{-# 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