module Hopfield.SuperAttractors where
import Control.Monad.Random (MonadRandom)
import qualified Data.Vector as V
import Hopfield.Hopfield
import Hopfield.Measurement
type Degree = Int
type PatternCombiner a = a -> Degree -> [Pattern]
powersOfTwo :: Degree -> [Degree]
powersOfTwo ceil = takeWhile (<= ceil) $ iterate (*2) 1
buildNetworks :: a -> [Degree] -> LearningType-> PatternCombiner a -> [HopfieldData]
buildNetworks ps ds learnType combine
= [ buildHopfieldData learnType $ combine ps d | d <- ds ]
oneSuperAttr :: PatternCombiner [Pattern]
oneSuperAttr [] _ = []
oneSuperAttr (p: ps) k = replicate k p ++ ps
twoSuperAttrOneFixed :: Degree -> PatternCombiner [Pattern]
twoSuperAttrOneFixed j (pa:pb: ps) k = replicate j pa ++ replicate k pb ++ ps
twoSuperAttrOneFixed _ _ _ = []
allSuperAttr :: PatternCombiner [Pattern]
allSuperAttr ps k = concatMap (replicate k) ps
aggregateCombiners :: [PatternCombiner [Pattern]] -> PatternCombiner [[Pattern]]
aggregateCombiners combiners patList degree
| length combiners /= length patList
= error "Number of [Pattern] in list must match number of functions"
| otherwise
= concat $ zipWith ($) funcs patList
where
funcs = map (($ degree) . flip) combiners
p1, p2 :: Pattern
p1 = V.fromList [1,1,1,1,1,1,1,1,1,1]
p2 = V.fromList [1,1,1,1,1,1,1,1,1,1]
q1 :: Pattern
q1 = V.fromList [1,1,1,1,1,1,1,1,1,1]
oneSuperNets :: LearningType -> [HopfieldData]
oneSuperNets learnType = buildNetworks ps degrees learnType oneSuperAttr
where
ps = [p1,p2]
degrees = powersOfTwo $ V.length $ head ps
allSuperNets :: LearningType -> [HopfieldData]
allSuperNets learnType = buildNetworks ps degrees learnType allSuperAttr
where
ps = [p1,p2]
degrees = powersOfTwo $ V.length $ head ps
buildMultiPhaseNetwork :: LearningType -> [PatternCombiner [Pattern]] -> [HopfieldData]
buildMultiPhaseNetwork learnType combFuncs = buildNetworks patList degrees learnType aggComb
where
patList = [ [p1,p2], [q1] ]
degrees = powersOfTwo $ (V.length . head . head) patList
aggComb = aggregateCombiners combFuncs
retrainNormalWithOneSuper :: LearningType -> [HopfieldData]
retrainOneSuperWithNormal :: LearningType -> [HopfieldData]
retrainOneSuperWithOneSuper :: LearningType -> [HopfieldData]
retrainAllSuperWithNormal :: LearningType -> [HopfieldData]
retrainAllSuperWithOneSuper :: LearningType -> [HopfieldData]
retrainNormalWithOneSuper l = buildMultiPhaseNetwork l [const, oneSuperAttr]
retrainOneSuperWithNormal l = buildMultiPhaseNetwork l [oneSuperAttr, const]
retrainOneSuperWithOneSuper l = buildMultiPhaseNetwork l [oneSuperAttr, oneSuperAttr]
retrainAllSuperWithNormal l = buildMultiPhaseNetwork l [allSuperAttr, const]
retrainAllSuperWithOneSuper l = buildMultiPhaseNetwork l [allSuperAttr, oneSuperAttr]
measureMultiBasins :: MonadRandom m => BasinMeasure m a -> [HopfieldData] -> Pattern -> [m a]
measureMultiBasins measureBasin hs p = map (\h -> measureBasin h p) hs