Experiment.hs

{-# LANGUAGE ParallelListComp #-}

module Hopfield.Experiments.Experiment where

import Control.Monad (replicateM)
import Test.QuickCheck

import Hopfield.Clusters
import Hopfield.Common
import Hopfield.Experiments.ExperimentUtil
import Hopfield.Hopfield
import Hopfield.Measurement
import Hopfield.SuperAttractors
import Hopfield.TestUtil (Type(H), patternGen)
import Hopfield.Util


errorHeader :: String
errorHeader = "Degree\tExpected error"


basinHeader :: String
basinHeader = "Degree\tBasin size"


main :: IO ()
main = do

    let n          = 100    -- number of neurons
        numRandoms = 8      -- number of random patterns to include
        maxDegree  = 32     -- maximum degree of super attractor


    -- The super attractor - primary care giver
    originPat <- generate $ patternGen H n

    -- Sample random patterns with Hamming distance between 25-75% from origin
    -- This is to ensure that this is a pure super attractor experiment
    -- and not a cluster one!
    let minHamming = round $ n .* (0.25 :: Double)
        maxHamming = round $ n .* (0.75 :: Double)
        dist       = hammingDistribution n (minHamming, maxHamming)

    randomPats <- replicateM numRandoms $ sampleHammingRange originPat dist


    let pats        = originPat:randomPats
        p           = length pats
        originIndex = 0                         -- index of main pattern
        degrees     = powersOfTwo maxDegree
        patCombiner = oneSuperAttr


    putStrLn $ unwords [show n, "neurons.", "Super attractor plus", show numRandoms, "random patterns.\n"]


    -- Compute probability of error
    doErrorProb n p degrees


    -- Compute hamming distance
    doHamming originPat randomPats "origin" "random"


    putStrLn "Building networks..."
    let nets = buildNetworks pats degrees Hebbian patCombiner


    --Check if pattern is fixed.
    doCheckFixed (zip degrees nets) originIndex "degrees"


    putStrLn "Measuring basins of attraction"
    let results = measureMultiBasins measurePatternBasin nets originPat

    putStrLn basinHeader
    printMList results [ \r -> attachLabel [pack d, pack r] | d <- degrees ]

    -- putStrLn "T1 experiment with 1 cluster"
    -- putStrLn $ show $ evalRand (repeatExperiment experimentUsingT1 Storkey 1 50 8) (mkStdGen 1)

    putStrLn "T1 experiment with 1 cluster with no average but lists"

    let avgs =  replicate 10 $ experimentUsingT1NoAvg Hebbian 100 10
    printMList avgs (replicate 10 show)