NeuralNetwork.hs


Here is the Haskell code that I wrote to make a neural network. Next I will train it to play Tic tac toe.

Here starts Neuron.hs

module NeuralNetwork.Neuron where

import Data.Binary
import qualified Data.Sequence as Seq

data Node = Neuron { bias :: Double, priors :: [Int], weights :: [Double], hidden :: Bool } |
            Input { value :: Double } deriving (Show, Eq)
instance Binary Node where
    put (Neuron{bias = bias, priors = priors, weights = weights, hidden = hidden}) =
        do put (0 :: Word8); put bias; put priors; put weights; put hidden
    put (Input{value = value}) = do put (1 :: Word8); put value
    get = do t <- get :: Get Word8
             case t of
                  0 -> do b <- get; p <- get; w <- get; h <- get;
                          return Neuron {bias = b, priors = p, weights = w, hidden = h}
                  1 -> do value <- get;
                          return Input {value = value}

adjustWeights :: [Double] -> Double -> Node -> Node
adjustWeights inputs error (Neuron b p w h) =
    let w' = zipWith (+) (fmap (*error) inputs) w
        b' = b + error
        in Neuron b' p w' h
adjustWeights _ _ n = n

result :: Seq.Seq Double -> Node -> Double
result _ (Input value) = value
result values node = transferFunction $ rawResult values node

rawResult :: Seq.Seq Double -> Node -> Double
rawResult values (Neuron b p w _) = b + sum (zipWith (*) (fmap (Seq.index values) p) w)
rawResult _ (Input value) = value

transferFunction :: (Floating a) => a -> a
transferFunction x = 1/(1+exp(-x))

Here starts NeuralNetwork


module NeuralNetwork.NeuralNetwork
    (NeuralNetwork,
     replaceInputNodes,
     newInputNodes,
     generateVariant,
     results,
     makeInputs,
     emptyNetwork,
     randomNetwork,
     makeNetwork) where

import qualified Data.Foldable as Foldable
import qualified Data.Sequence as Seq
import NeuralNetwork.Neuron
import Data.Binary
import System.Random

data NeuralNetwork = NeuralNetwork { nodes :: [Node] } deriving (Show, Eq)
instance Binary NeuralNetwork where
    put NeuralNetwork{nodes = nodes} = do put nodes
    get = do nodes <- get; return NeuralNetwork {nodes = nodes}

inputNodes :: NeuralNetwork -> [Node]
inputNodes NeuralNetwork {nodes = nodes} = [v | v@Input {} <- nodes]

outputNodes :: NeuralNetwork -> [Node]
outputNodes NeuralNetwork {nodes = nodes} =
    [x | x@(Neuron {}) <- nodes, not (hidden x)]

replaceInputNodes :: NeuralNetwork -> [Node] -> NeuralNetwork
replaceInputNodes NeuralNetwork {nodes = nodes} newI =
    NeuralNetwork $ newI ++ (drop (length newI) nodes)

newInputNodes :: NeuralNetwork -> [Double] -> NeuralNetwork
newInputNodes n values = replaceInputNodes n $ makeInputs (length values) values

generateVariant :: (RandomGen g) => (Int, Double, Double, g) -> NeuralNetwork -> NeuralNetwork
generateVariant (chance, min, max, g) NeuralNetwork {nodes = nodes} =
    let nLength = length nodes
        doIts = take nLength $ randomRs (1, chance) g
        rndds = drop nLength $ randomRs (min, max) g
        rnds = (doIts, rndds) in
        NeuralNetwork $ varyNodes rnds nodes

varyNodes :: ([Int], [Double]) -> [Node] -> [Node]
varyNodes _ [] = []
varyNodes (1 : ds, rs) (Neuron b p w h : xs) =
    let w' = zipWith (+) w rs
        rs' = drop (length w) rs in
        Neuron b p w' h : varyNodes (ds, rs') xs
varyNodes (_ : ds, rs) (x : xs) = x : varyNodes (ds, rs) xs

propigateErrors :: [Double] -> NeuralNetwork -> [Double]
propigateErrors expected network@(NeuralNetwork nodes) =
    let actual = results network
        outputDeltas = zipWith (-) expected actual
        missingDeltas = length nodes - length outputDeltas
        deltas = take missingDeltas (repeat 0) ++ outputDeltas
        nds = zip nodes deltas in
        foldErrors [] nds

foldErrors :: [Double] -> [(Node, Double)] -> [Double]
foldErrors es [] = es
foldErrors es ns =
    let (n, e) = last ns
        p = case n of Neuron _ p _ _ -> p
                      _ -> []
        w = case n of Neuron _ _ w _ -> w
                      _ -> []
        seq = Seq.fromList (init ns)
        pws = zip p w
        mrs = munge seq pws e
        ns' = Foldable.toList mrs
        in foldErrors (e : es) ns'

munge :: Seq.Seq (Node, Double) -> [(Int, Double)] -> Double -> Seq.Seq (Node, Double)
munge ns [] _ = ns
munge ns ((p, w) : pws) e =
    let n = Seq.index ns p
        n' = (fst n, snd n + e * w)
        ns' = Seq.update p n' ns in
        munge ns' pws e

errorCorrect :: [Double] -> Double -> NeuralNetwork -> NeuralNetwork
errorCorrect expected learnRate n =
    let errors = propigateErrors expected n
        outputs = allResults n in
        NeuralNetwork . reverse $ adjustAllWeights (nodes n) errors outputs learnRate

adjustAllWeights :: [Node] -> [Double] -> [Double] -> Double -> [Node]
adjustAllWeights [] _ _ _ = []
adjustAllWeights nodes es os learnRate =
    let error = last es
        output = last os
        n = last nodes
        p = case n of Neuron _ p _ _ -> p
                      _ -> []
        inputs = getItems (Seq.fromList os) p
        derivative = output * (1 - output)
        errorMash = error * derivative * learnRate
        n' = adjustWeights inputs errorMash n
        in (n' : adjustAllWeights (init nodes) (init es) (init os) learnRate)

getItems :: Seq.Seq a -> [Int] -> [a]
getItems s [] = []
getItems s (x:xs) = Seq.index s x : getItems s xs

allResults :: NeuralNetwork -> [Double]
allResults NeuralNetwork {nodes = n} =
    let (all, results) =
         foldl resultFold (Seq.fromList [], Seq.fromList []) n in
    Foldable.toList all

results :: NeuralNetwork -> [Double]
results NeuralNetwork {nodes = n} =
    let (all, results) =
         foldl resultFold (Seq.fromList [], Seq.fromList []) n in
    Foldable.toList results

resultFold :: (Seq.Seq Double, Seq.Seq Double) -> Node -> (Seq.Seq Double, Seq.Seq Double)
resultFold (all, outs) x@(Neuron b p w False) =
    let r = result all x in
    (all Seq.|> r, outs Seq.|> r)
resultFold (all, outs) x =
    let r = result all x in
    (all Seq.|> r, outs)

makeInputs :: Int -> [Double] -> [Node]
makeInputs n xs = foldr (\x acc -> Input x : acc) [] (take n xs)

makeHiddens :: [Double] -> [Int] -> Int -> Int -> ([Node], Int, Int, [Double])
makeHiddens r [] s l = ([], s, l, r)
makeHiddens rnd (x:xs) start length =
    let (list, lStart, lLength, rndOut) =
            (makeHiddens (drop (length * x) rnd) xs (start + length) x) in
        (makeNeurons x rnd start length True ++ list, lStart, lLength, rndOut)

makeNeurons :: Int -> [Double] -> Int -> Int -> Bool -> [Node]
makeNeurons 0 _ _ _ _ = []
makeNeurons n gen start length hidden =
    Neuron 1 [start..start+length-1] (take length gen) hidden :
     makeNeurons (n - 1) (drop length gen) start length hidden

emptyNetwork :: [Int] -> NeuralNetwork
emptyNetwork layerLengths = makeNetwork (repeat 1) layerLengths

randomNetwork :: (RandomGen g) => (Double, Double, g) -> [Int] -> NeuralNetwork
randomNetwork (min, max, g) layerLengths =
    makeNetwork (randomRs (min, max) g) layerLengths

makeNetwork :: [Double] -> [Int] -> NeuralNetwork
makeNetwork gen layerLengths =
    let inputs = head layerLengths
        (hiddens, start, length, genOut) =
                    makeHiddens gen (tail (init layerLengths)) 0 inputs in
            NeuralNetwork (makeInputs inputs (repeat 1) ++
                                      hiddens ++
                                      makeNeurons (last layerLengths) gen start length False)


The following code would allow you to make a Neural network

import System.Environmentimport Codec.Compression.GZip
import NeuralNetwork.NeuralNetwork
import qualified Data.ByteString.Lazy.Char8 as C
import Data.Binary
import System.Random
import System.Exit

main = do
    args <- getArgs  --[String]
    progName <- getProgName  --String
    handleInputs (length args) args progName

handleInputs :: Int -> [String] -> String -> IO ()
handleInputs count inputs prog
    | count < 5 = do
        putStrLn $ "Usage " ++ prog ++ " outFileName minWeight maxWeight inputCount [hiddenCount] outputCount"
        exitWith (ExitFailure 1)
    | otherwise = do
        gen <- getStdGen --Random
        let fileName = inputs !! 0
        let min = read $ inputs !! 1 :: Double
        let max = read $ inputs !! 2 :: Double
        let nodes = fmap (\x -> read x :: Int) (drop 3 inputs)
        let n = randomNetwork (min, max, gen) nodes
        let t = compress (encode n)
        C.writeFile fileName t

The following code would allow you to run a neural network

import System.Environmentimport Codec.Compression.GZip
import NeuralNetwork.NeuralNetwork
import qualified Data.ByteString.Lazy.Char8 as C
import Data.Binary
import System.IO
import System.Exit
import Control.Monad

main = do
    hSetBuffering stdin NoBuffering
    hSetBuffering stdout NoBuffering
    args <- getArgs  --[String]
    progName <- getProgName  --String
    handleInputs (length args) args progName

handleInputs :: Int -> [String] -> String -> IO ()
handleInputs count inputs prog
    | count < 1 = do
        putStrLn $ "Usage " ++ prog ++ " inFileName"
        exitWith (ExitFailure 1)
    | otherwise = do
        let fileName = inputs !! 0
        f <- C.readFile fileName
        let n = decode (decompress f) :: NeuralNetwork
        forever $ do
            i <- getLine
            let values = fmap (\x -> read x :: Double) $ words i
            let n' = newInputNodes n values
            putStrLn . unwords $ fmap (\x -> show x) (results n')


Popular posts from this blog

Goose Game

the Gunks

Vacation Week