machine-learning-in-haskell: try to implement network functions

machine-learning-in-haskell/MachineLearning.hs

@@ -17,6 +17,18 @@ randomList n gen = go n gen []
 
 -- definition of a neuron
 
+data NeuralNetwork = NeuralNetwork
+  { layers :: [[Neuron]],
+    finalLayer :: Neuron
+  }
+
+runNetwork :: NeuralNetwork -> Input -> Output
+runNetwork NeuralNetwork {layers, finalLayer} input =
+  run finalLayer $ runLayers layers input
+  where
+    runLayers [] input = input
+    runLayers (l : ls) input = runLayers ls $ map (`run` input) l
+
 data Neuron = Neuron
   { bias :: Float,
     activate :: Float -> Output,
@@ -43,12 +55,17 @@ modifyWeights dw neuron = neuron {weights = zipWith (+) dw (weights neuron)}
 modifyBias :: Weight -> Neuron -> Neuron
 modifyBias db neuron = neuron {bias = db + bias neuron}
 
-initializeNeuron :: Int -> Int -> Neuron
-initializeNeuron seed nWeights =
-  let gen = mkStdGen seed
-      (weights, gen') = randomList nWeights gen
+initializeNeuron :: StdGen -> Int -> (Neuron, StdGen)
+initializeNeuron gen nWeights =
+  let (weights, gen') = randomList nWeights gen
       (bias, gen'') = random gen'
-   in Neuron {bias = bias, activate = id, weights = weights}
+   in ( Neuron
+          { bias = bias,
+            activate = id,
+            weights = weights
+          },
+        gen''
+      )
 
 -- prerequisites for gradient descent
 
@@ -66,63 +83,104 @@ cost neuron trainingData =
       expected = map snd trainingData
    in meanSquaredError actual expected
 
+costNetwork :: NeuralNetwork -> TrainingData -> Float
+costNetwork network trainingData =
+  let actual = map (runNetwork network . fst) trainingData
+      expected = map snd trainingData
+   in meanSquaredError actual expected
+
 oneHotVectors :: Int -> [[Weight]]
 oneHotVectors n = [oneHot i | i <- [0 .. n - 1]]
   where
     oneHot index = [if j == index then epsilon else 0 | j <- [0 .. n - 1]]
 
-differential :: Neuron -> TrainingData -> Neuron
-differential neuron trainingData =
-  let c = cost neuron trainingData
+differential :: (Neuron -> TrainingData -> Float) -> Neuron -> TrainingData -> Neuron
+differential costFunc neuron trainingData =
+  let c = costFunc neuron trainingData
       weightUpdates = oneHotVectors $ length $ weights neuron
       dws =
         map
           ( \weightUpdate ->
-              (cost (modifyWeights weightUpdate neuron) trainingData - c) / epsilon
+              (costFunc (modifyWeights weightUpdate neuron) trainingData - c) / epsilon
           )
           weightUpdates
-      db = (cost (modifyBias epsilon neuron) trainingData - c) / epsilon
-   in trace (show neuron ++ ", cost = " ++ show c) $
-        neuron
-          { weights = dws,
-            bias = db
-          }
+      db = (costFunc (modifyBias epsilon neuron) trainingData - c) / epsilon
+   in neuron {weights = dws, bias = db}
+
+differentialNetwork :: NeuralNetwork -> TrainingData -> NeuralNetwork
+differentialNetwork network trainingData =
+  let costFunc = costNetwork
+      updatedLayers = map (map (\neuron -> differential costFunc neuron trainingData)) (layers network)
+      updatedFinalLayer = differential costFunc (finalLayer network) trainingData
+   in NeuralNetwork {layers = updatedLayers, finalLayer = updatedFinalLayer}
 
 learn :: Float -> Neuron -> (Neuron -> Neuron)
 learn learningRate differential =
   modifyBias (-learningRate * bias differential)
     . modifyWeights (map (\dw -> -learningRate * dw) (weights differential))
 
+learnNetwork :: Float -> NeuralNetwork -> (NeuralNetwork -> NeuralNetwork)
+learnNetwork learningRate differential network =
+  NeuralNetwork
+    { finalLayer = learn learningRate (finalLayer differential) (finalLayer network),
+      layers = zipWith (zipWith (learn learningRate)) (layers differential) (layers network)
+    }
+
 epoch :: TrainingData -> Neuron -> Neuron
 epoch trainingData neuron =
-  let neuron' = learn learningRate (differential neuron trainingData) neuron
+  let neuron' = learn learningRate (differential cost neuron trainingData) neuron
    in neuron'
   where
     learningRate = 1e-3
 
 -- concrete example
 
-trainingDataAdd, trainingDataDouble, trainingDataOr, trainingDataAnd :: TrainingData
+trainingDataAdd, trainingDataDouble, trainingDataOr, trainingDataAnd, trainingDataNand, trainingDataNot, trainingDataXor :: TrainingData
 trainingDataDouble = [([x], x * 2) | x <- [0 .. 4]]
 trainingDataAdd = [([x, y], x + y) | x <- [1 .. 10], y <- [1 .. 10]]
 trainingDataOr = [([0, 0], 0), ([1, 0], 1), ([0, 1], 1), ([1, 1], 1)]
 trainingDataAnd = [([0, 0], 0), ([1, 0], 0), ([0, 1], 0), ([1, 1], 1)]
+trainingDataNand = [([0, 0], 1), ([1, 0], 1), ([0, 1], 1), ([1, 1], 0)]
+trainingDataXor = [([0, 0], 0), ([1, 0], 1), ([0, 1], 1), ([1, 1], 0)]
+trainingDataNot = [([0], 1), ([1], 0)]
+
+gen = mkStdGen 69
 
 trainDouble n =
-  let neuron = initializeNeuron 69 1
+  let (neuron, _) = initializeNeuron gen 1
    in iterate (epoch trainingDataDouble) neuron !! n
 
 trainAdd n =
-  let neuron = initializeNeuron 69 2
+  let (neuron, _) = initializeNeuron gen 2
    in iterate (epoch trainingDataAdd) neuron !! n
 
 trainOr n =
-  let neuron = (initializeNeuron 69 2) {activate = sigmoid}
-   in iterate (epoch trainingDataOr) neuron !! n
+  let (neuron, _) = initializeNeuron gen 2
+      neuron' = neuron {activate = sigmoid}
+   in iterate (epoch trainingDataOr) neuron' !! n
 
 trainAnd n =
-  let neuron = (initializeNeuron 69 2) {activate = sigmoid}
-   in iterate (epoch trainingDataAnd) neuron !! n
+  let (neuron, _) = initializeNeuron gen 2
+      neuron' = neuron {activate = sigmoid}
+   in iterate (epoch trainingDataAnd) neuron' !! n
+
+trainXor n =
+  let (neuron, _) = initializeNeuron gen 2
+      neuron' = neuron {activate = sigmoid}
+   in iterate (epoch trainingDataXor) neuron' !! n
+
+trainNand n =
+  let (neuron, _) = initializeNeuron gen 2
+      neuron' = neuron {activate = sigmoid}
+   in iterate (epoch trainingDataNand) neuron' !! n
+
+trainNot n =
+  let (neuron, _) = initializeNeuron gen 2
+      neuron' = neuron {activate = sigmoid}
+   in iterate (epoch trainingDataNot) neuron' !! n
 
 evaluateNeuron :: Neuron -> TrainingData -> [(Input, Output)]
 evaluateNeuron neuron = map (\(x, _) -> (x, run neuron x))
+
+evaluateNetwork :: NeuralNetwork -> TrainingData -> [(Input, Output)]
+evaluateNetwork network = map (\(x, _) -> (x, runNetwork network x))