{-# LANGUAGE FlexibleContexts,TypeSynonymInstances #-}
module Search where
import Control.Arrow (second,(***),(&&&))
import Control.Applicative ((<$>))
import Data.Map hiding (map)
import qualified Data.Map as M (map,lookup)
import Control.Monad.Reader
import Control.Monad.State
import System.Random
import Data.List (sort,groupBy)
import Data.Ord (compare,comparing)
import Data.Function (on)
---------------------- library for random picking -------------------------------------
-- | a state holding a standard random generator
class MonadState StdGen m => RandomState m
-- | pick an element randomly from a list
pick :: RandomState m => [a] -> m a
pick xs = do (i,g) <- gets random
put g >> return (xs !! (i `mod` length xs))
---------------------- library for range of ints -------------------------
-- | a simple guess on range and version semantics
type Range = (Int,Int)
-- | functions checking the position of a number against a range
inside,lower,higher :: Int -> Range -> Bool
x `inside` (l,r) = x >= l && x <= r
x `lower` (l,_) = x < l
x `higher` (_,r) = x > r
-- | three chances to move a number
data Direction = Lower | Indifferent | Higher deriving (Eq,Ord,Enum)
-- | tell which direction the number should be moved towards the range
comparation :: Int -> Range -> Direction
comparation x r | x `inside` r = Indifferent
| x `lower` r = Higher
| x `higher` r = Lower
-- | Inverting a direction
opposite :: Direction -> Direction
opposite Indifferent = Indifferent
opposite Higher = Lower
opposite Lower = Higher
--------------------------- really generic stuff for the algo ------------------------------------
-- | package root name
type Label = Int
-- | package version
type Version = Int
-- | A fully specified package , name and version
type Assign = (Label,Version)
-- | The dependencies specifications. one to each assign.
type Deps = Map Assign [(Label,Range)]
-- | Validity for each label, its version domain
-- [Version] is intended sorted from lowest
type Validity = Map Label (Range,[Version])
fromDeps :: Deps -> Validity
fromDeps = fromList. map ((fst . head) &&& (((head &&& last) &&& id) . sort . map snd)) .
groupBy (on (==) fst) . sort . keys
-- | Changing version respecting its possibles
move :: [Version] -> Direction -> Version -> Version
move _ Indifferent v = v
move xs t v = case dropWhile (test v) (right xs) of
[] -> v
y:_ -> y
where (test,right) = case t of Higher -> ((>=),id)
Lower -> ((<=),reverse)
-- | What is needed as knowledge to run the algo. The dependencies constraint to respect and the Version domains for each label
data Environment = Environment {deps :: Deps,validity :: Validity}
-- | the reader monad with the right environment inside
class (Functor m,MonadReader Environment m) => HackageEnvironment m
-- | what we use as state
type GenericState a = Map Label a
-- | a tagged version of Version
type Tagged b = (Version,b)
-- | state modification is always explicit
type Evolver b m = GenericState b -> m (GenericState b)
-- | wrap and unwrap a flat state with a specific tagging, binding an action inside
withTag :: Functor m
=> (Assign -> b) -- ^ mapping from an Assignment to a tag for it
-> Evolver (Tagged b) m -- ^ the action with the tagged state
-> Evolver Version m -- ^ the resulting action on the flat assignment state
withTag f a s = M.map fst <$> a (mapWithKey (\k v -> (v ,f (k,v))) s)
-- | modify by touching all labels
onEach :: Monad m
=> (Label -> Evolver b m) -- ^ the "per label" modification
-> Evolver b m -- ^ the all modification
onEach f = foldM (flip f) `ap` keys
--------------------------------------------- tension operators ---------------------------
-- | The state of the evolution specifications, a version for each package name together with the tension put on it by its neighbors
type WithTension m = Evolver (Tagged [Direction]) m
-- | Changing the tension of a package and its deps , the added tension always sum up to zero, the tension given to a dep always shows
-- with opposit sign on the dependent package.
-- Seen from the label pov a label contributes a hint on where to go next to its dependencies.
-- It's a contribution trying to contract distancies locally , to fulfill the hard constraint of deps.
contribute :: HackageEnvironment m
=> Label -- ^ identify the label on which to work
-> WithTension m -- ^ an evolver modifier for a state tagged with directions
contribute l state = do
h <- asks deps
let each (l,r) (s,ts') = let
(v,ts) = maybe (error "fuck") id $ M.lookup l s -- the state for the current dep, version and tension, buggy if Deps is not closed
t = comparation v r -- see how the dep relates with its parent will
in (insert l (v,t:ts) s, opposite t : ts') -- tension contributeion on the dep and accumulation of its opposit
(state',mem) = foldr each (state,[]) depa where -- looping on all deps
depa = maybe (error $ "missed dep" ++ show key) id $ M.lookup key h
key = (l,fst $ maybe (error "fuck") id $ M.lookup l state)
return $ adjust (second (mem ++ )) l state' -- contribute the tension on the package
-- | changing the version of one label releasing its tension (should really use the energy parameter!)
change :: (RandomState m,HackageEnvironment m) => Label -> WithTension m
change l s = do
let (v,ts) = s ! l -- the label state
t <- pick ts -- pick a random move from the accumulated tension
(r,vs) <- (! l) <$> asks validity -- valid range for a label
return $ insert l (move vs t v, []) s -- changing the assignment
-- | flashing the state with some random valid version
flash :: (RandomState m, HackageEnvironment m) => Evolver Version m
flash _ = do cs <- assocs <$> asks validity --
fromList <$> mapM (\(l,(_,vs)) -> ((,) l) <$> pick vs) cs
-- | a full assign correction round
turn :: (RandomState m, HackageEnvironment m) => Evolver Version m
turn = withTag (const []) ((onEach change =<<) .onEach contribute)
----------------------------------
type Hackage = [(Assign,[(Label,[Version])])]
hackage =fromList [ ((4,1),[(1,(2,3)),(2,(1,2))]),
((2,1),[(3,(2,3)),(1,(1,3))]),
((2,2),[(3,(3,4)),(1,(3,3))]),
((3,2),[(1,(1,2))]),
((3,3),[(1,(2,2))]),
((3,4),[(1,(2,3))]),
((1,1),[]),
((1,2),[]),
((1,3),[])
]:: Deps
------------------
type Simple = ReaderT Environment (State StdGen)
instance HackageEnvironment Simple
instance RandomState Simple
run
:: Deps
-> StdGen
-> Maybe (GenericState Version)
-> (GenericState Version -> Simple b)
-> b
run d g (Just s) a = evalState (runReaderT (a s) (Environment d (fromDeps d))) (g)
run d g Nothing a = evalState (runReaderT (flash undefined >>= a) (Environment d (fromDeps d))) g
play n = do
g <- newStdGen
return . map toList . run hackage g Nothing $ sequence <$> take n . iterate (turn =<<) . return