bpann (empty) → 0.1

raw patch · 4 files changed

+334/−0 lines, 4 filesdep +basedep +haskell98dep +splitsetup-changed

Dependencies added: base, haskell98, split

Files

• LICENSE +30/−0
• Setup.hs +3/−0
• bpann.cabal +35/−0
• src/AI/BPANN.hs +266/−0

@@ -0,0 +1,30 @@+Copyright Robert Steuck 2011++All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions are met:++    * Redistributions of source code must retain the above copyright+      notice, this list of conditions and the following disclaimer.++    * Redistributions in binary form must reproduce the above+      copyright notice, this list of conditions and the following+      disclaimer in the documentation and/or other materials provided+      with the distribution.++    * Neither the name of Robert Steuck nor the names of other+      contributors may be used to endorse or promote products derived+      from this software without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR+A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT+OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT+LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,+DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY+THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.

@@ -0,0 +1,3 @@+#!/usr/bin/env runhaskell+import Distribution.Simple+main = defaultMain

@@ -0,0 +1,35 @@+Name:              bpann++Version:           0.1++Synopsis:          backpropagation neuronal network++Description:       - fully-connected multylayer perceptron+                   - uses bias neurons+                   - creation of randomly initialized networks of arbitrary size+                   - easy (de-)serialization++License:           BSD3++License-file:      LICENSE++Author:            Robert Steuck++Maintainer:        robert.steuck@gmail.com++Copyright:         (c) Robert Steuck 2011++Stability:         Experimental++Category:          AI++Build-type:        Simple+Cabal-version:     >=1.2+++Library+  Exposed-modules: AI.BPANN+  Build-depends:   base >= 4 && < 5, split -any, haskell98 -any+  +  hs-source-dirs: src+  

@@ -0,0 +1,266 @@+-----------------------------------------------------------------------------+-- |+-- Module      :  BPANN+-- Copyright   :  (c) Robert Steuck 2011+-- License     :  AllRightsReserved+--+-- Maintainer  :  robert.steuck@gmail.com+-- Stability   :  experimental+-- Portability :  portable+--+-- Basic backpropagation neuronal network+-- inspired by hnn++module AI.BPANN where++import Data.List+import Maybe+import Random+import Data.List.Split++-- ** Types for computation+type ALayer a = [(Neuron,a)] -- Das erste Neuron ist immer das BIAS Neuron++type ANetwork a = [ALayer a]++type Network = ANetwork ()++-- |information generated during a simple forward pass+-----------------------------------------------------------+data ForwardPassInfo = FPInfo {+-- |output+-----------------------------------------------------------+  o :: Double,+-- |sum of weighted inputs+-----------------------------------------------------------+  net :: Double, -- Summe der Gewichteten Eingaben+-- |inputs+-----------------------------------------------------------+  xs :: [Double] -- Ungewichtete Eingaben+} deriving Show++-- |the neuron+-----------------------------------------------------------+data Neuron = Neuron {+-- |input weights+-----------------------------------------------------------+  ws :: [Double],+-- |activation function+-----------------------------------------------------------+  fun :: (Double -> Double),+-- |first derivation of the activation function+-----------------------------------------------------------+  fun' :: (Double -> Double) -- 1. Ableitung der Aktivierungsfunktion+}++instance Show Neuron where+  show (Neuron ws _ _) = +    "Neuron: ws=" ++ (show ws)++-- ** Types for serialisation+type PackedNeuron = [Double]++-- ** Activation functions+-- |1/(1+e^(-x))+-----------------------------------------------------------+sigmoid :: Double -> Double+sigmoid x = 1.0 / (1 + exp (-x))++-- |first derivation+-----------------------------------------------------------+sigmoid' :: Double -> Double+sigmoid' x = sigmoid x * (1 - sigmoid x)++-- ** Network creation+type NeuronCreator = PackedNeuron -> Neuron++sigmoidNeuron :: PackedNeuron -> Neuron+sigmoidNeuron ws = Neuron ws sigmoid sigmoid'++-- |activation function is 'id'+-----------------------------------------------------------+outputNeuron :: PackedNeuron -> Neuron+outputNeuron ws = Neuron ws id (const 1)++biasNeuron :: Int -- ^ number of inputs+  -> Neuron+biasNeuron nInputs = Neuron (replicate nInputs 1) (const 1) (const 0)++createLayer :: [PackedNeuron] -> NeuronCreator -> ALayer ()+createLayer pns nc = map (\pn -> (nc pn,())) pns++sigmoidLayer :: [PackedNeuron] -> ALayer ()+sigmoidLayer pns = (biasNeuron nInputs, ()) : createLayer pns sigmoidNeuron+  where+    nInputs = length $ head pns+++outputLayer :: [PackedNeuron] -> ALayer ()+outputLayer pns = createLayer pns outputNeuron -- no need for bias neuron at output layer++createRandomNetwork ::+  Int -- ^ seed for random weigth generator+  -> [Int] -- ^ number of neurons per layer+  -> Network+createRandomNetwork seed layerNeuronCounts =+    unpackNetwork wss+  where+    restLayerNeuronCounts' = init layerNeuronCounts+    hiddenIcsNcs = zip (map (+1) restLayerNeuronCounts') (tail restLayerNeuronCounts') -- :: [(InputCount,NeuronCount)]+    (outputIc,outputNc) = ((snd $ last hiddenIcsNcs) + 1,last layerNeuronCounts)  -- :: (InputCount,NeuronCount)+    rs = randomRs (-1,1) $ mkStdGen seed+    (hiddenWss,rs') = foldl (\(wss',rs') (ic,nc) -> let+                                (sl,rs'') = icNcToPackedNeurons ic nc rs'+                                in+                               (wss'++[sl],rs'')) ([],rs) hiddenIcsNcs+    (outputWss,_) = icNcToPackedNeurons outputIc outputNc rs'+    wss = hiddenWss ++ [outputWss]++-- ** serialisation deserialization++icNcToPackedNeurons :: Int -> Int -> [Double] -> ([PackedNeuron],[Double])+icNcToPackedNeurons ic nc ws = (take nc $ splitEvery ic ws, drop (ic * nc) ws)++unpackNetwork :: [[PackedNeuron]] -> Network+unpackNetwork wss =+    hLayers ++ [oLayer]+  where+    hLayers = map sigmoidLayer $ init wss+    oLayer = outputLayer $ last wss++packNetwork :: Network -> [[PackedNeuron]]+packNetwork n = (map unpackHiddenLayer (init n)) ++ [unpackLayer (last n)]+  where+    unpackLayer ol = map (ws . fst) ol+    unpackHiddenLayer l = unpackLayer $ tail l -- drop bias neuron+++-- * backpropagation algorithm+-- ** forward pass+-- |generate forward pass info for a network+-----------------------------------------------------------+passForward :: Network -> [Double] -> ANetwork ForwardPassInfo+passForward nw xs = reverse $ fst $ foldl pf ([],(1 : xs)) nw -- Die 1 ist der virtuelle BiasInput+  where+    pf (nw',xs') l = (l' : nw', xs'')+      where+        l' = (passForward' l xs')+        xs'' = map (o . snd) l'++-- |generate forward pass info for a layer+-----------------------------------------------------------+passForward' :: ALayer a -> [Double] -> ALayer ForwardPassInfo+passForward' l xs = (map (\(n,_) -> (n, passForward'' n xs)) l)++-- |generate forward pass info for a neuron+-----------------------------------------------------------+passForward'' :: Neuron -> [Double] -> ForwardPassInfo+passForward'' n xs = FPInfo {+    o = (fun n) net',+    net = net',+    xs = xs+  }+  where+    net' = calcNet xs (ws n)++-- |calculate the weigtet input of the neuron+-----------------------------------------------------------+calcNet :: [Double] -> [Double] -> Double+calcNet xs ws = sum $ zipWith (*) xs ws++-- ** weight update+-- |updates the weigts for an entire network+-----------------------------------------------------------+weightUpdate ::+  Double -- ^ learning rate 'alpha'+  -> ANetwork ForwardPassInfo+  -> [Double] -- ^ desired output value+  -> Network+weightUpdate alpha fpnw ys = fst $ foldr (weightUpdate' alpha) ([],ds) fpnw+  where+    ds = zipWith (-) ys (map (o . snd) (last fpnw))++-- |updates the weigts for a layer+-----------------------------------------------------------+weightUpdate' :: Double -> ALayer ForwardPassInfo -> (Network,[Double]) -> (Network,[Double])+weightUpdate' alpha fpl (nw,ds) = (l':nw, ds')+  where+    (l,δs) = unzip $ zipWith (weightUpdate'' alpha) fpl ds+    ds' = map sum $ transpose $ map (\(n,δ) -> map (\w -> w * δ) (ws n)) (zip l δs)+    l' = (map (\n -> (n,())) l)++-- |updates the weigts for a neuron+-----------------------------------------------------------+weightUpdate'' :: Double -> (Neuron, ForwardPassInfo) -> Double -> (Neuron, Double)+weightUpdate'' alpha (n,fpi) d = (n{ws=ws'},δ)+  where+    δ = ((fun' n) (net fpi)) * d+    ws' = zipWith (\x w -> w + (alpha * δ * x)) (xs fpi) (ws n)++-- ** forward pass and weigtupdate put together+backprop ::+  Double -- ^ learning rate 'alpha'+  -> Network+  -> ([Double],[Double]) -- ^ inpit and desired output+  -> Network+backprop alpha nw (xs,ys) = weightUpdate alpha (passForward nw xs) ys++-- * Evaluation+-- |calculates the output of a network for a given input vector+-----------------------------------------------------------+calculate :: Network -> [Double] -> [Double]+calculate nw xs = foldl calculate' (1 : xs) nw -- Die 1 ist der virtuelle BiasInput++-- |calculates the output of a layer for a given input vector+-----------------------------------------------------------+calculate' :: [Double] -> ALayer a -> [Double]+calculate' xs l = map (\(n,_) -> (fun n) (calcNet xs (ws n))) l++-- * Training+-- |quadratic error for a single vector pair+-----------------------------------------------------------+quadErrorNet :: Network -> ([Double], [Double]) -> Double+quadErrorNet nw (xs,ys) = sum $ zipWith (\o y -> (y - o) ** 2) os ys+  where+  os = calculate nw xs++-- |quadratic error for for multiple pairs+-----------------------------------------------------------+globalQuadError :: Network -> [([Double], [Double])] -> Double+globalQuadError nw samples = sum $ map (quadErrorNet nw) samples++-- |produces an indefinite sequence of networks+-----------------------------------------------------------+trainAlot :: +  Double -- ^ learning rate 'alpha'+  -> Network+  -> [([Double],[Double])] -- ^ list of pairs of input and desired output+  -> [Network]+trainAlot alpha nw samples =+  iterate (\nw' -> foldl (backprop alpha) nw' samples) nw++-- |trains a network with a set of vector pairs until a the 'globalQuadError' is smaller than epsilon+-----------------------------------------------------------+train ::+  Double -- ^ learning rate 'alpha'+  -> Double -- ^ the maximum error 'epsilon'+  -> Network+  -> [([Double],[Double])] -- ^ list of pairs of input and desired output+  -> Network+train alpha epsilon nw samples = fromJust $ find+  (\nw' -> globalQuadError nw' samples < epsilon)+  (trainAlot alpha nw samples)++-- tests+testBoolAnd = train 0.5 0.001 (createRandomNetwork 1 [2,2,1])+  [([0,0],[0]),([0,1],[0]),([1,0],[0]),([1,1],[1])]++testBoolOr = train 0.5 0.001 (createRandomNetwork 1 [2,2,1])+  [([0,0],[0]),([0,1],[1]),([1,0],[1]),([1,1],[1])]++testBoolXor = train 0.5 0.001 (createRandomNetwork 1 [2,2,1])+  [([0,0],[0]),([0,1],[1]),([1,0],[1]),([1,1],[0])]++testBoolNot = train 0.5 0.001 (createRandomNetwork 1 [1,1,1])+  [([0],[1]),([1],[0])]+