add connectNeurons

2 files changed, 79 insertions, 0 deletions

diff --git a/src/Mind.hs b/src/Mind.hs
index 45b90da..1ce8ab3 100644
--- a/src/Mind.hs
+++ b/src/Mind.hs
@@ -6,8 +6,11 @@ module Mind
   
   , Network (..)
   , createEmptyNetwork
+  , connectNeurons
   ) where
 
+import Data.Ix
+
 -- index different neuron types
 data NeuronIndex = Input Int | Internal Int | Output Int deriving (Show, Eq)
 
@@ -26,5 +29,45 @@ data Network = Network
   , outputNeurons :: [[Edge]]
   } deriving (Show, Eq)
 
+-- create a completely empty network
 createEmptyNetwork :: Int -> Int -> Int -> Network
 createEmptyNetwork i h o = Network i (replicate h []) (replicate o [])
+
+
+-- connect two neurons together with a new edge
+connectNeurons :: Network -> NeuronIndex -> NeuronIndex -> Float -> Maybe Network
+-- internal sink
+connectNeurons (Network i h o) source (Internal sink) weight = 
+  if (validSource (Network i h o) source) then do
+    newH <- insertEdge h sink $ Edge (source, weight)
+    return $ Network i newH o
+  else Nothing
+-- output sink
+connectNeurons (Network i h o) source (Output sink) weight = 
+  if (validSource (Network i h o) source) then do
+    newO <- insertEdge o sink $ Edge (source, weight)
+    return $ Network i h newO
+  else Nothing
+-- 
+connectNeurons _ _ (Input _) _ = Nothing
+
+
+
+-- helpers for connectNeurons
+
+-- check if a given NeuronIndex can be used as a valid source
+validSource :: Network -> NeuronIndex -> Bool
+validSource _ (Output _) = False
+validSource (Network i _ _) (Input x) = 
+  if (inRange (0, i) x) 
+  then True else False
+validSource (Network _ h _) (Internal x) = 
+  if (inRange (0, length h) x)
+  then True else False
+
+-- insert a new edge into a neuron list, possibly failing
+insertEdge :: [[Edge]] -> Int -> Edge -> Maybe [[Edge]]
+insertEdge ns i e 
+  | (inRange (0, length ns) i) = let (front, es:back) = splitAt i ns
+    in Just $ front ++ [e:es] ++ back
+  | otherwise = Nothing
diff --git a/test/MindTest.hs b/test/MindTest.hs
index 5eb1734..65d5a84 100644
--- a/test/MindTest.hs
+++ b/test/MindTest.hs
@@ -21,4 +21,40 @@ networkTests :: TestTree
 networkTests = testGroup "network tests" $
   [ testCase "create empty network" $
     (createEmptyNetwork 3 2 1) @?= Network 3 [[], []] [[]]
+  , testCase "output network connection" $
+    let network = Network 3 [[], []] [[]]
+    in (connectNeurons network (Input 0) (Output 0) (negate 1.0))
+    @?= (Just $ Network 3 [[], []] [[Edge (Input 0, (negate 1.0))]])
+  , testCase "internal network connection" $
+    let network = Network 3 [[], []] [[]]
+    in (connectNeurons network (Internal 0) (Internal 1) (negate 1.0))
+    @?= (Just $ Network 3 [[], [Edge (Internal 0, negate 1.0)]] [[]])
+  , testCase "internal self-connection" $
+    let network = Network 3 [[], []] [[]]
+    in (connectNeurons network (Internal 0) (Internal 0) (negate 1.0))
+    @?= (Just $ Network 3 [[Edge (Internal 0, negate 1.0)], []] [[]])
+  , testCase "internal source out of range" $
+    let network = Network 3 [[], []] [[]]
+    in (connectNeurons network (Internal 5) (Internal 0) (negate 1.0))
+    @?= Nothing
+  , testCase "internal sink out of range" $
+    let network = Network 3 [[], []] [[]]
+    in (connectNeurons network (Internal 1) (Internal (negate 1)) (negate 1.0))
+    @?= Nothing
+  , testCase "input source out of range" $
+    let network = Network 3 [[], []] [[]]
+    in (connectNeurons network (Input (negate 1)) (Internal 0) (negate 1.0))
+    @?= Nothing
+  , testCase "input sink" $
+    let network = Network 3 [[], []] [[]]
+    in (connectNeurons network (Input 0) (Input 0) (negate 1.0))
+    @?= Nothing
+  , testCase "output source" $
+    let network = Network 3 [[], []] [[]]
+    in (connectNeurons network (Output 0) (Output 0) (negate 1.0))
+    @?= Nothing
+  , testCase "output sink out of range" $
+    let network = Network 3 [[], []] [[]]
+    in (connectNeurons network (Input 0) (Output 4) (negate 1.0))
+    @?= Nothing
   ]