module Hopfield.Clusters where
import qualified Data.Vector as V
import Control.Monad.Random (MonadRandom)
import Control.Monad (liftM, replicateM)
import Hopfield.Common
import Hopfield.Hopfield
import Hopfield.Measurement
import Hopfield.Util
getPatternInCluster :: MonadRandom m => Method -> Pattern -> Double -> m Pattern
getPatternInCluster method originPat p
= liftM V.fromList $ mapM transformBit (V.toList originPat)
where transformBit x = do
flip_bit <- gibbsSampling p
let bit = if (odd flip_bit) then (flipBit method x) else x
return bit
getCluster :: MonadRandom m => Method -> Pattern -> Int -> Double -> m [Pattern]
getCluster method originPat size p
= replicateM size (getPatternInCluster method originPat p)
getGaussianCluster :: MonadRandom m => Method -> Pattern -> Int -> Double -> Double -> m [Pattern]
getGaussianCluster method originPat size mean stdDev
| mean > fromIntegral patSize = error "the mean cannot be greater than the size of the pattern in getGaussianCluster"
| otherwise = do
normal_values <- replicateM size (normal mean stdDev)
return $ map encoding $ map round normal_values
where encoding x = V.fromList [ valueAtIndex y x | y <- [0 .. patSize 1]]
patSize = V.length originPat
valueAtIndex y x = if (y <=x) then 1 else (smallerValue method)
smallerValue x = case x of
Hopfield -> 1
_ -> 0
basinsGivenProbabilityT1 :: MonadRandom m => LearningType -> Int -> Int -> Double -> m Double
basinsGivenProbabilityT1 learning networkSize clusterSize p
= do
originPat <- randomSignVector networkSize
cluster <- getCluster Hopfield originPat clusterSize p
avgBasinsGivenPats learning cluster
experimentUsingT1 :: MonadRandom m => LearningType -> Int -> Int -> m Double
experimentUsingT1 learning networkSize clusterSize
= do
basinAvgs <- mapM (basinsGivenProbabilityT1 learning networkSize clusterSize) probabilities
return $ average basinAvgs
where probabilities = [0.0, 0.1 .. 0.5]
experimentUsingT1NoAvg :: MonadRandom m => LearningType -> Int -> Int -> m [(Double, Double)]
experimentUsingT1NoAvg learning networkSize clusterSize
= do
results <- mapM (basinsGivenProbabilityT1 learning networkSize clusterSize) probabilities
return $ zip probabilities results
where probabilities = [0.0, 0.1 .. 0.5]
basinsGivenProbabilityT1With2Clusters :: MonadRandom m => LearningType -> Int -> Int -> Double -> Double -> m (Double, Double)
basinsGivenProbabilityT1With2Clusters learning networkSize clusterSize p1 p2 = do
originPat1 <- randomSignVector networkSize
originPat2 <- randomSignVector networkSize
cluster1 <- getCluster Hopfield originPat1 clusterSize p1
cluster2 <- getCluster Hopfield originPat2 clusterSize p2
avg1 <- avgBasinsGivenPats learning cluster1
avg2 <- avgBasinsGivenPats learning cluster2
return $ (avg1, avg2)
basinsGivenStdT2 :: MonadRandom m => LearningType -> Int -> Int -> Double -> Double -> m Double
basinsGivenStdT2 learning networkSize clusterSize mean std
= do
originPat <- randomSignVector networkSize
cluster <- getGaussianCluster Hopfield originPat clusterSize mean std
avgBasinsGivenPats learning cluster
experimentUsingT2 :: MonadRandom m => LearningType -> Int -> Int -> m Double
experimentUsingT2 learning networkSize clusterSize
= do
let mean = networkSize ./. (2 :: Int)
deviations = [0.0, 2.0 .. networkSize ./. (8 :: Int)]
basinAvgs <- mapM (basinsGivenStdT2 learning networkSize clusterSize mean) deviations
return $ average basinAvgs
experimentUsingT2NoAvg :: MonadRandom m => LearningType -> Int -> Int -> m [(Double, Double)]
experimentUsingT2NoAvg learning networkSize clusterSize
= do
let mean = networkSize ./. (2 :: Int)
deviations = [0.0, 2.0 .. networkSize ./. (8 :: Int)]
basinAvgs <- mapM (basinsGivenStdT2 learning networkSize clusterSize mean) deviations
return $ zip deviations basinAvgs
basinsGivenStdT2With2Clusters :: MonadRandom m => LearningType -> Int -> Int ->
Double -> Double -> Double -> Double -> m (Double, Double)
basinsGivenStdT2With2Clusters learning networkSize clusterSize mean1 mean2 std1 std2 = do
originPat1 <- randomSignVector networkSize
originPat2 <- randomSignVector networkSize
cluster1 <- getGaussianCluster Hopfield originPat1 clusterSize mean1 std1
cluster2 <- getGaussianCluster Hopfield originPat2 clusterSize mean2 std2
avg1 <- avgBasinsGivenPats learning cluster1
avg2 <- avgBasinsGivenPats learning cluster2
return $ (avg1, avg2)
avgBasinsGivenPats :: MonadRandom m => LearningType -> [Pattern] -> m Double
avgBasinsGivenPats learning pats = do
basinSizes <- mapM (measurePatternBasin hopfield) pats
return $ average basinSizes
where hopfield = buildHopfieldData learning pats
repeatExperiment :: MonadRandom m => (LearningType -> Int -> Int -> m Double) -> LearningType -> Int -> Int -> Int -> m Double
repeatExperiment experiment learning nrExperiments networkSize clusterSize
= liftM average $ replicateM nrExperiments (experiment learning networkSize clusterSize)