module AI.NeuralNetworks.Simple (
ActivationFunction(..),
NeuralNetwork,
WeightDeltas,
emptyNeuralNetwork,
getWeights,
setWeights,
runNeuralNetwork,
backpropagationOneStep,
backpropagationStochastic,
backpropagationBatchParallel,
applyWeightDeltas,
unionWeightDeltas,
randomNeuralNetwork,
crossoverCommon,
crossoverMerge,
mutationCommon
) where
import System.Random
import Data.List (unfoldr, foldl')
import qualified Data.Map.Strict as M
import qualified Data.IntMap.Strict as IM
import Control.Applicative
import Control.Arrow
import Control.DeepSeq
import Control.Parallel.Strategies
import GHC.Conc (numCapabilities)
import Data.List.Split (chunksOf)
import Data.Maybe (fromJust)
import Data.Word
import Data.Bits
data ActivationFunction = Tanh
| Logistic
deriving (Show, Read, Eq)
logistic x = 1 / (1 + exp (x))
applyAF Tanh = tanh
applyAF Logistic = logistic
applyAFDerivative Tanh x = let t = tanh x in (1 + t) * (1 t)
applyAFDerivative Logistic x = let t = logistic x in t * (1 t)
data NeuralNetwork a = NeuralNetwork [Word16] [ ActivationFunction ] (M.Map Word64 a)
deriving (Show, Read, Eq)
instance NFData a => NFData (NeuralNetwork a) where
rnf (NeuralNetwork _ _ m) = rnf m `seq` ()
newtype WeightDeltas a = WeightDeltas (M.Map Word64 a)
deriving (Show, Read, Eq)
instance NFData a => NFData (WeightDeltas a) where
rnf (WeightDeltas m) = rnf m `seq` ()
emptyNeuralNetwork :: [Word16]
-> [ ActivationFunction ]
-> NeuralNetwork a
emptyNeuralNetwork ss as =
NeuralNetwork ss as M.empty
getWeights :: NeuralNetwork a
-> [((Word16, Word16, Word16), a)]
getWeights (NeuralNetwork _ _ ws) =
map (first decodeKey) $ M.toList ws
setWeights :: [((Word16, Word16, Word16), a)]
-> NeuralNetwork a
-> NeuralNetwork a
setWeights lst (NeuralNetwork ss as _) =
let ws = M.fromList $ map (\((k1, k2, k3), v) -> (makeKey k1 k2 k3, v)) lst
in NeuralNetwork ss as ws
runNeuralNetwork :: (Num a, Floating a)
=> NeuralNetwork a
-> [a]
-> [a]
runNeuralNetwork (NeuralNetwork ss as m) input =
let (result, _, _) = runNeuralNetwork' (head ss) (tail ss) as 0 m [] [] input
in result
runNeuralNetwork' _ [] _ _ _ ilfacc outacc xs = (xs, ilfacc, outacc)
runNeuralNetwork' _ _ [] _ _ _ _ _ =
error "runNeuralNetwork' - invalid number of activation functions"
runNeuralNetwork' prevs (so:ss) (af:as) layer ws ilfacc outacc xs =
let ilfs = [ ( (layer, n), inducedLocalField n layer ws xs) | n <- [1..so] ]
ilfacc' = ilfs ++ ilfacc
outs = [ ( (layer, n), x ) | (x, n) <- zip xs [1..prevs] ]
outacc' = outs ++ outacc
in runNeuralNetwork' so ss as (layer+1) ws ilfacc' outacc' (map (\(_, v) -> applyAF af v) ilfs)
inducedLocalField neuron layer ws xs =
let weight k = getWeight (makeKey layer neuron k) ws
in weight 0 + sum [ weight i * x | (x, i) <- zip xs [1..] ]
backpropagationOneStep :: (Num a, Floating a)
=> NeuralNetwork a
-> a
-> [a]
-> [a]
-> WeightDeltas a
backpropagationOneStep (NeuralNetwork ss as ws) learningRate input expout =
let (result, inducedLocalFields, outputs) = runNeuralNetwork' (head ss) (tail ss) as 0 ws [] [] input
errors = [ d o | (d, o) <- zip expout result ]
inducedLocalFieldsMap = M.fromList inducedLocalFields
outputsMap = M.fromList outputs
deltasMap = calculateDeltas ss as ws errors inducedLocalFieldsMap
wds = M.mapWithKey
(\k _ ->
let (ln, n, i) = decodeKey k
out = if i == 0 then 1
else fromJust $ M.lookup (ln, i) outputsMap
in learningRate * out * fromJust (M.lookup (ln, n) deltasMap)
) ws
in WeightDeltas wds
backpropagationStochastic :: (Num a, Floating a)
=> NeuralNetwork a
-> [([a],[a])]
-> a
-> (NeuralNetwork a -> Int -> IO Bool)
-> IO (NeuralNetwork a)
backpropagationStochastic net0 set0 learningRate stopf = do
g0 <- newStdGen
run g0 net0 set0 0
where
len = length set0
run rg net set gnum = do
let (rg', set') = shuffleList rg len set
net' = foldl' (\n (i, o) -> let wds = backpropagationOneStep n learningRate i o
in applyWeightDeltas wds n) net set'
stop <- stopf net' gnum
if stop then return net'
else run rg' net' set' (gnum+1)
backpropagationBatchParallel :: (Num a, Floating a, NFData a)
=> NeuralNetwork a
-> [([a],[a])]
-> a
-> (NeuralNetwork a -> Int -> IO Bool)
-> IO (NeuralNetwork a)
backpropagationBatchParallel net0 set learningRate stopf =
run net0 0
where
chunks = chunksOf ( ceiling $ fromIntegral (length set) / (fromIntegral numCapabilities :: Double) ) set
run net gnum = do
let wds = map (unionWeightDeltas . map (uncurry $ backpropagationOneStep net learningRate)) chunks
`using` parList rdeepseq
totalWds = unionWeightDeltas wds
net' = applyWeightDeltas totalWds net
stop <- stopf net' gnum
if stop then return net'
else run net' (gnum+1)
applyWeightDeltas :: (Num a, Floating a)
=> WeightDeltas a
-> NeuralNetwork a
-> NeuralNetwork a
applyWeightDeltas (WeightDeltas dws) (NeuralNetwork ss as ws) =
let ws' = M.mapWithKey (\k w -> w + fromJust (M.lookup k dws)) ws
in NeuralNetwork ss as ws'
unionWeightDeltas :: (Num a, Floating a)
=> [WeightDeltas a]
-> WeightDeltas a
unionWeightDeltas [] = error "Empty list"
unionWeightDeltas [x] = x
unionWeightDeltas (WeightDeltas hd : tl) =
let tm = foldl' (\acc (WeightDeltas m) -> M.mapWithKey (\k w -> w + fromJust (M.lookup k m)) acc) hd tl
in WeightDeltas tm
calculateDeltas ss as ws errors ilfm =
let (s:ss') = reverse ss
(a:as') = reverse as
cl = fromIntegral $ length ss 2
acc = M.fromList [ ((cl, n), err * applyAFDerivative a (fromJust $ M.lookup (cl, n) ilfm )) | (err, n) <- zip errors [1..s] ]
in calculateDeltas' (cl 1) s ss' as' ws ilfm acc
calculateDeltas' _ _ _ [] _ _ acc = acc
calculateDeltas' cl sprev ss as ws ilfm acc =
let (s:ss') = ss
(a:as') = as
err n = sum [ fromJust $ (*) <$> M.lookup (cl+1, k) acc <*> M.lookup (makeKey (cl+1) k n) ws | k <- [1..sprev] ]
newDeltas = [ ((cl, n), err n * applyAFDerivative a (fromJust $ M.lookup (cl, n) ilfm)) | n <- [1..s] ]
acc' = foldl' (\m (k, v) -> M.insert k v m) acc newDeltas
in calculateDeltas' (cl 1) s ss' as' ws ilfm acc'
randomNeuralNetwork :: (RandomGen g, Random a, Num a, Ord a)
=> g
-> [Word16]
-> [ ActivationFunction ]
-> a
-> (NeuralNetwork a, g)
randomNeuralNetwork gen ss as maxw
| length ss /= length as + 1 = error "Number of layers and activation functions mismatch"
| maxw < 0 = randomNeuralNetwork gen ss as (maxw)
| otherwise =
let keys = generateKeys ss
(weights, gen') = generateWeights gen maxw
ws = M.fromList $ zip keys weights
in (NeuralNetwork ss as ws, gen')
makeKey :: Word16 -> Word16 -> Word16 -> Word64
makeKey layer n i =
let t1 = fromIntegral layer
t2 = fromIntegral n
t3 = fromIntegral i
in shiftL t1 32 .|. shiftL t2 16 .|. t3
decodeKey :: Word64 -> (Word16, Word16, Word16)
decodeKey k =
let t1 = fromIntegral $ shiftR k 32
t2 = fromIntegral $ shiftR k 16 .&. 0xFFFF
t3 = fromIntegral $ k .&. 0xFFFF
in (t1, t2, t3)
generateKeys ss =
[ makeKey layer n i | (layer, inputs, neurons) <- zip3 [0..] (init ss) (tail ss), n <- [1 .. neurons], i <- [0 .. inputs ] ]
generateWeights gen maxw =
let (gen1, gen2) = split gen
in (unfoldr (Just . randomR (maxw, maxw) ) gen1, gen2)
crossoverCommon :: (Num a, RandomGen g)
=> g
-> NeuralNetwork a
-> NeuralNetwork a
-> ([NeuralNetwork a],g)
crossoverCommon g0 (NeuralNetwork ss1 as1 ws1) (NeuralNetwork _ _ ws2) =
let keys = generateKeys ss1
(ids, g1) = randomR (1, length keys 1) g0
(keys1, keys2) = splitAt ids keys
tmpMap ws lst = M.fromList [ (k, getWeight k ws) | k <- lst ]
ws1' = tmpMap ws1 keys1 `M.union` tmpMap ws2 keys2
ws2' = tmpMap ws1 keys2 `M.union` tmpMap ws2 keys1
in ( [ NeuralNetwork ss1 as1 ws1', NeuralNetwork ss1 as1 ws2' ], g1)
crossoverMerge :: (Num a, RandomGen g)
=> (a -> a -> a)
-> g
-> NeuralNetwork a
-> NeuralNetwork a
-> ([NeuralNetwork a],g)
crossoverMerge avgf gen (NeuralNetwork ss1 as1 ws1) (NeuralNetwork _ _ ws2) =
let ws' = M.fromList [ (k, getWeight k ws1 `avgf` getWeight k ws2) | k <- generateKeys ss1]
in ( [ NeuralNetwork ss1 as1 ws' ], gen )
mutationCommon :: (Random a, Num a, RandomGen g)
=> Double
-> a
-> g
-> NeuralNetwork a
-> (NeuralNetwork a, g)
mutationCommon percent maxw gen (NeuralNetwork ss as ws) =
let layers = length ss 1
mutnum = truncate $ percent * fromIntegral (M.size ws) :: Int
(ws', gen') = mutationCommon' mutnum (abs maxw) gen ws (init ss) (tail ss) layers
in (NeuralNetwork ss as ws', gen')
mutationCommon' mutnum maxw g0 ws inputs outputs layers
| mutnum <= 0 = (ws, g0)
| otherwise =
let (layer, g1) = randomR (0, layers 1) g0
(neuron, g2) = randomR (1, outputs !! layer) g1
(weightIdx, g3) = randomR (0, inputs !! layer) g2
(newWeight, g4) = randomR ( maxw, maxw) g3
ws' = M.insert (makeKey (fromIntegral layer) neuron weightIdx) newWeight ws
in mutationCommon' (mutnum 1) maxw g4 ws' inputs outputs layers
getWeight :: (Num a, Ord k) => k -> M.Map k a -> a
getWeight = M.findWithDefault 0
shuffleList :: (RandomGen g) => g -> Int -> [a] -> (g, [a])
shuffleList g lstlen lst =
shuffleList' g (lstlen1) (lstlen1) (IM.fromList $ zip [0..] lst)
shuffleList' g maxpos step m0
| step < 0 = (g, map snd $ IM.toList m0)
| otherwise =
let (pos, g') = randomR (0, maxpos) g
v1 = fromJust $ IM.lookup step m0
v2 = fromJust $ IM.lookup pos m0
m1 = IM.insert step v2 m0
m2 = IM.insert pos v1 m1
in shuffleList' g' maxpos (step1) m2