Conversion of a simple Python Neural Network to a Haskell implementation

Question

I started with this code and modified and expanded it in Python. As an exercise/challenge to myself I decided to covert the original to Haskell. I either write imperatively or functionally. This is the first time I have tried converting from one logic to another. I ran into a lot of little issue along the way. I aimed to just get it to work and I want to make it work better now.

import Data.List
import System.Random
import Data.Matrix hiding (transpose, trace)
import Debug.Trace

flipSign::Num a => a -> a
flipSign x = (-1) * x 

nonlin:: Bool -> Double ->   Double
nonlin True x = x*(1.0-x)
nonlin False x =  1.0 / (1.0 + (exp $ flipSign x))

randomList :: (Random a) => Int -> [a]
randomList seed = randoms (mkStdGen seed)

sample:: [[Double]]
sample = map (map fromIntegral)[ [0,0,1], [0,1,1], [1,0,1], [1,1,1] ]
answers:: [[Double]]
answers = transpose $ map (map fromIntegral) [[0,0,1,1]]

syn0:: [[Double]]
syn0 = [[x] | x<- take 3 (randomList 42 :: [Double])]

dotp:: [[Double]] -> [[Double]] -> [[Double]]
dotp x y = toLists newMatrix
    where
        mx = fromLists x
        my = fromLists y
        newMatrix = multStd mx my

nextGeneration::[[Double]] -> [[Double]] -> ([[Double]], [[Double]]) -> ([[Double]],[[Double]])
nextGeneration x labels syn0_l1 = (new_syn0, l1)
    where
        l0 = x
        syn0 = fst syn0_l1
        l1 = map (map $ nonlin False) $ dotp l0 syn0 
        l1_error = zipWith (zipWith (-)) labels l1
        l1_delta = zipWith (zipWith (*)) l1_error $ map (map (nonlin True)) l1 
        new_syn0 = zipWith (zipWith (+)) syn0 $ dotp (transpose l0) l1_delta 

generations::([[Double]] -> [[Double]]) -> [[Double]] -> Int -> [[Double]]
generations _ end 0 = end
generations fun weights count = generations fun (fun weights) (count - 1)

main = print $ snd $ iterate (nextGeneration sample answers ) (syn0, [[]] ) !!10000

Answer 1

You often switch between matrices and lists in the dotp function. Since that is an essential part of your code called every iteration and your data is a matrix, you should be using matrices everywhere.

In the documentation is noted, that there is a functor instance. That means you can use the function fmap on the matrix, which (in this case) maps a function over every cell. This means you can swap map (map fromIntegral) with fmap fromIntegral. The equivalent to zipWith (zipWith ..) is called elementwise.

The generations function doesn't seem to be called: you can avoid having dead code by compiling with warnings enabled, -Wall. The flipSign function is predefined and called negate.

I have changed nonlin to make the variable explicit, otherwise it wouldn't be clear what this Bool actually does. Furthermore, I have added some comments.

Finally, I have changed nextGeneration as there is no need to carry the l1 variable if it isn't needed by the next step. I've extracted that into a function (and so have to take the 9999th iteration in main).

Here is my version of the code:

import System.Random (randoms, mkStdGen)
import Data.Matrix

-- | input dataset
sample :: Matrix Double
sample = fmap fromIntegral $ fromLists
    [ [0,0,1]
    , [0,1,1]
    , [1,0,1]
    , [1,1,1]
    ]

-- | output dataset
answers :: Matrix Double
answers = transpose (fmap fromIntegral output)
    where
        output = fromLists [[0,0,1,1]]

-- | sigmoid function
nonlin :: Bool -> Double -> Double
nonlin derivative x = if derivative then x * (1.0 - x)
                                    else 1.0 / (1.0 + (exp (negate x)))

layer1 :: Matrix Double -> Matrix Double -> Matrix Double
layer1 l0 syn0 = fmap (nonlin False) (multStd l0 syn0)

nextGeneration :: Matrix Double -> Matrix Double
nextGeneration syn0 = new_syn0
    where
        -- forward propagation
        l1 = layer1 sample syn0

        -- how much did we miss?
        l1_error = elementwise (-) answers l1

        -- multiply how much we missed by the
        -- slope of the sigmoid at the values in l1
        l1_delta = elementwise (*) l1_error (fmap (nonlin True) l1)

        -- update weights
        new_syn0 = elementwise (+) syn0 (multStd (transpose sample) l1_delta)

main = do
    putStrLn "Output After Training:"
    print (layer1 sample result)
        where
            start = fromList 3 1 (randoms (mkStdGen 42))
            generations = iterate nextGeneration start
            result = generations !! 9999

Answer 2

Have some refactoring!

import Data.List
import System.Random
import Data.Matrix
import Control.Monad.Trans.State

nextGeneration:: Matrix Double -> Matrix Double -> Matrix Double -> (Matrix Double, Matrix Double)
nextGeneration l0 labels syn0 = (new_syn0, l1) where
  l1 = (\x -> 1 / (1 + exp (-x))) <$> multStd l0 syn0 
  l1_error = elementwise (-) labels l1
  l1_delta = elementwise (*) l1_error $ (\x -> x * (1 - x)) <$> l1 
  new_syn0 = elementwise (+) syn0 $ multStd (transpose l0) l1_delta 

main = do
  syn0 <- transpose . fromLists . (:[]) <$> replicateM 3 randomIO :: IO (Matrix Double)
  let sample = fromLists [[0,0,1], [0,1,1], [1,0,1], [1,1,1]]     ::     Matrix Double
      answers = transpose $ fromLists [[0,0,1,1]]                 ::     Matrix Double
  print $ last $ evalState (replicateM 10000 $ state $ nextGeneration sample answers) syn0