module Hopfield.Experiments.Experiment2SuperAttractors where
import Control.Monad (replicateM)
import Control.Monad.Random
import Test.QuickCheck
import Test.QuickCheck.Gen (unGen)
import Hopfield.Common
import Hopfield.Experiments.ExperimentUtil
import Hopfield.Hopfield (LearningType (..))
import Hopfield.Measurement
import Hopfield.SuperAttractors
import Hopfield.TestUtil (Type(H), patternGen)
import Hopfield.Util
genIO :: Gen a -> IO a
genIO g = do
rndInt <- randomIO
stdGen <- getStdGen
return $ unGen g stdGen rndInt
basinHeader :: String
basinHeader = "Degree\tOrigin basin\tNew basin"
main :: IO ()
main = do
let n = 100
numRandoms = 8
maxDegree = 32
fstDegree = 8
originPat <- genIO $ patternGen H n
let minHamming = round $ n .* (0.25 :: Double)
maxHamming = round $ n .* (0.75 :: Double)
dist = hammingDistribution n (minHamming, maxHamming)
randomPats <- replicateM numRandoms $ sampleHammingRange originPat dist
newPat <- sampleHammingRange originPat dist
let pats = originPat:newPat:randomPats
originIndex = 0
newIndex = fstDegree + 1
degrees = powersOfTwo maxDegree
patCombiner = twoSuperAttrOneFixed fstDegree
putStrLn $ unwords [show n, "neurons.", "Two Super attractors plus", show numRandoms, "random patterns.\n"]
doHamming originPat randomPats "origin" "random"
doHamming newPat randomPats "new" "random"
putStrLn "Building networks...\n"
let nets = buildNetworks pats degrees Hebbian patCombiner
putStrLn "Checking original pattern"
doCheckFixed (zip degrees nets) originIndex "degrees"
putStrLn "Checking new pattern"
doCheckFixed (zip degrees nets) newIndex "degrees"
putStrLn "Measuring basins of attraction of origin"
let resultsOrigin = measureMultiBasins measurePatternBasin nets originPat
let resultsNew = measureMultiBasins measurePatternBasin nets newPat
let results = zipWith (\a b -> sequence [a, b]) resultsOrigin resultsNew
printResults d rs = attachLabel $ [pack d] ++ map pack rs
putStrLn basinHeader
printMList results [ printResults d | d <- degrees ]