packages feed

hopfield-networks (empty) → 0.1.0.0

raw patch · 7 files changed

+297/−0 lines, 7 filesdep +MonadRandomdep +QuickCheckdep +basesetup-changed

Dependencies added: MonadRandom, QuickCheck, base, hopfield-networks, matrix, split, test-framework, test-framework-quickcheck2, vector

Files

+ LICENSE view
+ MachineLearning/Hopfield.hs view
@@ -0,0 +1,72 @@+-- | Implementation of Hopfield Network training and asssociating+module MachineLearning.Hopfield+    (HopfieldNet(..),+     initializeWith,+     activity,+     train,+     associate,+     energy) where++import           Control.Monad        (foldM)+import qualified Control.Monad.Random as R+import qualified Data.Matrix          as M+import qualified Data.Vector          as V+import           MachineLearning.Util+++-- | HopfieldNet maintains the state and weights of the Hopfield+-- Network, and is the major datastructure used in this code.+data HopfieldNet = HopfieldNet { _state   :: V.Vector Float+                               , _weights :: M.Matrix Float+                               } deriving (Show)++-- | Maps the activation of a neuron to the output.+activity :: Float -> Float+activity activation = if activation <= 0 then -1.0 else 1.0++initialize :: Int -> HopfieldNet+initialize n = HopfieldNet (V.replicate n 0) (M.zero n n)++-- | Initializes the HopfieldNet with the given training patterns.+initializeWith :: M.Matrix Float -> HopfieldNet+initializeWith patterns = train state patterns+  where+    state = initialize (M.ncols patterns)++update' :: HopfieldNet -> Int -> HopfieldNet+update' (HopfieldNet state weights) neuron = HopfieldNet newState weights+  where+    newState = state V.// [(neuron, activity activation)]+    -- Vector is indexed from 0, Matrix is indexed from 1.+    activation = dotProduct (M.getCol (neuron + 1) weights) state++update :: R.MonadRandom m => HopfieldNet -> m HopfieldNet+update current =  do+  i <-  R.getRandomR (0, (V.length . _state) current - 1)+  return $ update' current i++-- | Updates the weights of the Hopfield network with the given+-- training patterns.+train :: HopfieldNet -> M.Matrix Float -> HopfieldNet+train (HopfieldNet state weights) patterns =+    HopfieldNet state (weights + updates)+  where+    updates = M.matrix n n weight+    n = V.length state+    weight (i, j) = 1.0 / (fromIntegral . M.nrows) patterns *+                    dotProduct (M.getCol i patterns) (M.getCol j patterns)++settle :: R.MonadRandom m => HopfieldNet -> Int -> m HopfieldNet+settle net iterations = foldM (\state _ -> update state) net [1..iterations]++-- | Repeatedly adjusts the Hopfield network's state to minimize the+-- energy of the current configuration.+associate :: R.MonadRandom m => HopfieldNet -> Int -> V.Vector Float -> m (V.Vector Float)+associate net iterations pattern =+    do+      settled <-  settle (net { _state = pattern }) iterations+      return $ _state settled++-- | The energy of the current configuration of the Hopfield network.+energy :: HopfieldNet -> Float+energy (HopfieldNet state weights) = -0.5 * innerProduct weights state
+ MachineLearning/HopfieldDemonstration.hs view
@@ -0,0 +1,98 @@+module Main where++import qualified Data.Matrix              as M+import qualified Data.Vector              as V++import qualified Control.Monad.Random     as R+import           Data.List.Split          (chunksOf)+import           MachineLearning.Hopfield+import           MachineLearning.Util++-- Height and widght of the patterns we are training on+width, height :: Int+width = 6+height = 7++patterns :: M.Matrix Float+patterns = (M.rowVector x) M.<-> (M.rowVector o)+  where+    x = V.fromList+        [1, -1, -1, -1, -1, 1,+         -1, 1, -1, -1, 1, -1,+         -1, -1, 1, 1, -1, -1,+         -1, -1, 1, 1,  -1, -1,+         -1, -1, 1, 1, -1, -1,+         -1, 1, -1, -1, 1, -1,+         1, -1, -1, -1, -1, 1]+    o = V.fromList+        [1 , 1, 1, 1, 1, 1,+         1 , -1, -1, -1, -1, 1,+         1 , -1, -1, -1, -1, 1,+         1 , -1, -1, -1, -1, 1,+         1 , -1, -1, -1, -1, 1,+         1 , -1, -1, -1, -1, 1,+         1 , 1, 1, 1, 1, 1]++randomCorruption :: R.MonadRandom m => Float -> V.Vector Float -> m (V.Vector Float)+randomCorruption proportion pattern =+    do+      indices <- R.getRandomRs (0, V.length pattern - 1)+      values <-  R.getRandomRs (-1.0 :: Float, 1.0 :: Float)+      let mutatedValue = map activity values+      let mutations = take (numMutations pattern) (zip indices mutatedValue)+      return $ pattern V.// mutations+    where+      numMutations = floor . (proportion *) . fromIntegral . V.length++validate :: HopfieldNet -> Int -> Float -> V.Vector Float -> IO ()+validate trained iterations corruptionLevel pattern =+    do+      corrupted <- R.evalRandIO $ randomCorruption corruptionLevel pattern+      reproduction <- R.evalRandIO $ reproduce corrupted+      print $ ("Corruption error", difference corrupted pattern)+      print $ ("Reproduction error", difference pattern reproduction)++      print "Original"+      displayPattern pattern+      print "Corrupted"+      displayPattern corrupted+      print "Reproduction"+      displayPattern reproduction+    where+      reproduce = associate trained iterations++displayPattern :: V.Vector Float -> IO ()+displayPattern pattern =+    do+      putStrLn divider+      mapM_ printLine patternLines+      putStrLn divider+    where+      divider = replicate (width + 2) '-'+      patternLines = chunksOf width $ V.toList pattern+      printLine line = do+        putStr "|"+        mapM_ (putStr . repr) line+        putStrLn "|"+      repr el = if activity el <= 0 then " " else "X"+++-- TODO(tulloch) - Pass these on the command line.+numIterations :: Int+numIterations = 1000++corruptionRate :: Float+corruptionRate = 0.5++main :: IO ()+main = do+  putStrLn "Training patterns"+  eachPattern displayPattern++  putStrLn "Validation"+  eachPattern validatePattern+  return ()+  where+    eachPattern f = mapM_ (\x -> f $ M.getRow x patterns) [1..M.nrows patterns]+    validatePattern = validate trained numIterations corruptionRate+    trained = initializeWith patterns
+ MachineLearning/HopfieldTest.hs view
@@ -0,0 +1,45 @@+module Main where++import qualified Data.Vector                          as V+import           MachineLearning.Hopfield+import           MachineLearning.Util+import           Test.Framework                       (Test, defaultMain,+                                                       testGroup)+import           Test.Framework.Providers.QuickCheck2 (testProperty)+import           Test.QuickCheck++-- Unfortunately, we need an orphan instance here.+instance (Arbitrary a) =>  Arbitrary (V.Vector a) where+    arbitrary = fmap V.fromList arbitrary++-- -- QuickCheck properties+prop_normPositive :: V.Vector Float -> Bool+prop_normPositive x = norm x >= 0++symmetric :: Eq a => (t -> t -> a) -> t -> t -> Bool+symmetric f x y = f y x == f x y++type VectorPredicate = (V.Vector Float -> V.Vector Float -> Bool)++prop_symmetricDotProduct :: VectorPredicate+prop_symmetricDotProduct = symmetric dotProduct++prop_symmetricDifference :: VectorPredicate+prop_symmetricDifference = symmetric difference++prop_activitySignFunction :: Float -> Bool+prop_activitySignFunction x = x == 0 || activity x == signum x++tests :: [Test]+tests = [+ testGroup "QuickCheck Util" [+                testProperty "norm positive" prop_normPositive,+                testProperty "dotProduct symmetric" prop_symmetricDotProduct,+                testProperty "symmetric difference" prop_symmetricDifference+               ],+ testGroup "QuickCheck Hopfield" [+                testProperty "activity sign function" prop_activitySignFunction+               ]]++main :: IO ()+main = defaultMain tests
+ MachineLearning/Util.hs view
@@ -0,0 +1,29 @@+-- | Utility code used for matrix/vector manipulation+module MachineLearning.Util+    (norm,+     difference,+     dotProduct,+     innerProduct) where++import qualified Data.Matrix as M+import qualified Data.Vector as V++-- | The L^2 norm of a vector in R^n.+norm :: Floating a => V.Vector a -> a+norm x = sqrt $ dotProduct x x++-- | Distance between vectors in the Hilbert space induced by the L^2+-- norm on R^n.+difference :: Floating a => V.Vector a -> V.Vector a -> a+difference x y = norm (V.zipWith (-) x y)++-- | The inner product in R^n.+dotProduct :: Num b => V.Vector b -> V.Vector b -> b+dotProduct x y = V.foldl (+) 0 (V.zipWith (*) x y)++-- | The inner product on R^n induced by a PSD matrix M. Computes the+-- mapping x |-> x^T M x with x \in R^n, M \in R^{n x n}.+innerProduct :: (Num a) => M.Matrix a -> V.Vector a -> a+innerProduct m v = (M.transpose cv * m * cv) M.! (1, 1)+  where+    cv = M.colVector v
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ hopfield-networks.cabal view
@@ -0,0 +1,51 @@+name:                hopfield-networks+version:             0.1.0.0+synopsis:            Hopfield Networks for unsupervised learning in Haskell+homepage:            https://github.com/ajtulloch/hopfield-networks+license:             MIT+license-file:        LICENSE+author:              Andrew Tulloch+maintainer:          andrew+cabal@tullo.ch+category:            Math+build-type:          Simple+cabal-version:       >=1.10++library+    exposed-modules: MachineLearning.Hopfield, MachineLearning.Util+    default-language:    Haskell2010+    build-depends:+        base >= 4 && < 5,+        vector,+        matrix,+        MonadRandom,+        split++Test-Suite hopfield_test+    type: exitcode-stdio-1.0+    x-uses-tf: true+    main-is: MachineLearning/HopfieldTest.hs+    default-language: Haskell2010+    GHC-Options:    -Wall+    build-depends:+        hopfield-networks,+        base >= 4 && < 5,+        QuickCheck,+        vector,+        matrix,+        MonadRandom,+        test-framework-quickcheck2,+        test-framework+++executable hopfield_demonstration+    main-is: MachineLearning/HopfieldDemonstration.hs+    default-language: Haskell2010+    GHC-Options:    -Wall+    build-depends:+        hopfield-networks,+        base >= 4 && < 5,+        QuickCheck,+        vector,+        matrix,+        MonadRandom,+        split