diff --git a/Control/CP/ComposableTransformers.hs b/Control/CP/ComposableTransformers.hs deleted file mode 100644 --- a/Control/CP/ComposableTransformers.hs +++ /dev/null @@ -1,312 +0,0 @@ -{- - - Monadic Constraint Programming - - http://www.cs.kuleuven.be/~toms/Haskell/ - - Tom Schrijvers - -} -{-# LANGUAGE GADTs #-} -{-# LANGUAGE Rank2Types #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE ImpredicativeTypes #-} -{-# LANGUAGE FlexibleContexts #-} - -module Control.CP.ComposableTransformers ( - solve, restart, - NewBound, - Bound(..), - Composition(..), - CTransformer, - CForSolver, - CForResult, - CTreeState, - RestartST(..) , - SealedCST(..), - CNodeBoundedST(..), - CDepthBoundedST(..), - CBranchBoundST(..), - CFirstSolutionST(..), - CSolutionBoundST(..), - CIdentityCST(..), - CRandomST(..), - CLimitedDiscrepancyST(..) -) where - -import Control.CP.Transformers -import Control.CP.SearchTree -import Control.CP.Solver -import Control.CP.Queue -import Control.CP.Debug - -import System.Random (mkStdGen, randoms) - --------------------------------------------------------------------------------- --- EVALUATION --------------------------------------------------------------------------------- - -solve :: (Queue q, Solver solver, CTransformer c, CForSolver c ~ solver, - Elem q ~ (Label solver,Tree solver (CForResult c),CTreeState c)) - => q -> c -> Tree solver (CForResult c) -> (Int,[CForResult c]) -solve q c model = run $ eval model q (TStack c) - - -restart :: (Queue q, Solver solver, CTransformer c, CForSolver c ~ solver, - Elem q ~ (Label solver,Tree solver (CForResult c),CTreeState c)) - => q -> [c] -> Tree solver (CForResult c) -> (Int,[CForResult c]) -restart q cs model = run $ eval model q (RestartST (map Seal cs) return) - - --------------------------------------------------------------------------------- --- COMPOSABLE TRANSFORMERS --------------------------------------------------------------------------------- - -data TStack es ts (solver :: * -> *) a where - TStack :: (CTransformer c, CForSolver c ~ solver, CForResult c ~ a) - => c -> TStack (CEvalState c) (CTreeState c) solver a - -instance Solver solver => Transformer (TStack es ts solver a) where - type EvalState (TStack es ts solver a) = es - type TreeState (TStack es ts solver a) = ts - type ForSolver (TStack es ts solver a) = solver - type ForResult (TStack es ts solver a) = a - initT (TStack c) _ = return $ initCT c - leftT (TStack c) _ = leftCT c - rightT (TStack c) _ = rightCT c - nextT = nextTStack - returnT i wl t@(TStack c) es = returnCT c es (\es' -> continue i wl t es') (\es' -> endT i wl t es') - -nextTStack :: - (Solver solver, Queue q, Elem q ~ (Label solver,Tree solver a,ts)) - => Int -> Tree solver a -> q -> (TStack es ts solver a) -> es -> ts -> solver (Int,[a]) -nextTStack i tree q t es ts = - case t of - TStack c -> - nextCT tree c es ts (\tree' es' ts' -> eval' i tree' q t es' ts') - (\es' -> continue i q t es') - (\es' -> endT i q t es') - --------------------------------------------------------------------------------- -type CSearchSig c a = - (Solver (CForSolver c), CTransformer c) - => Tree (CForSolver c) a -> c -> CEvalState c -> CTreeState c -> (EVAL c a) -> (CONTINUE c a) -> (EXIT c a) -> (CForSolver c) (Int,[a]) - -type CContinueSig c a = - (Solver (CForSolver c), CTransformer c) - => c -> CEvalState c -> (CONTINUE c a) -> (EXIT c a) -> (CForSolver c) (Int,[a]) - -type EVAL c a = (Tree (CForSolver c) a -> CEvalState c -> CTreeState c-> (CForSolver c) (Int,[a])) -type CONTINUE c a = (CEvalState c -> (CForSolver c) (Int,[a])) -type EXIT c a = (CEvalState c) -> (CForSolver c) (Int,[a]) - -class Solver (CForSolver c) => CTransformer c where - type CEvalState c :: * - type CTreeState c :: * - type CForSolver c :: (* -> *) - type CForResult c :: * - initCT :: c -> (CEvalState c, CTreeState c) - leftCT, rightCT :: c -> CTreeState c -> CTreeState c - leftCT _ = id - rightCT = leftCT - nextCT :: CSearchSig c (CForResult c) - nextCT = evalCT - returnCT :: CContinueSig c (CForResult c) - returnCT = continueCT - completeCT :: c -> CEvalState c -> Bool - completeCT _ _ = True - -evalCT :: CSearchSig c a -evalCT tree c es ts eval continue exit = - eval tree es ts - -continueCT :: CContinueSig c a -continueCT c es continue exit = - continue es - -exitCT :: CContinueSig c a -exitCT c es continue exit = - exit es - -newtype CNodeBoundedST (solver :: * -> *) a = CNBST Int - -instance Solver solver => CTransformer (CNodeBoundedST solver a) where - type CEvalState (CNodeBoundedST solver a) = Int - type CTreeState (CNodeBoundedST solver a) = () - type CForSolver (CNodeBoundedST solver a) = solver - type CForResult (CNodeBoundedST solver a) = a - initCT (CNBST n) = (n,()) - nextCT tree c es ts eval' continue exit - | es == 0 = exit es - | otherwise = eval' tree (es - 1) ts - -newtype CDepthBoundedST (solver :: * -> *) a = CDBST Int - -instance Solver solver => CTransformer (CDepthBoundedST solver a) where - type CEvalState (CDepthBoundedST solver a) = Bool - type CTreeState (CDepthBoundedST solver a) = Int - type CForSolver (CDepthBoundedST solver a) = solver - type CForResult (CDepthBoundedST solver a) = a - initCT (CDBST n) = (True,n) - leftCT _ ts = ts - 1 - nextCT tree c es ts eval' continue exit - | ts == 0 = continue False - | otherwise = eval' tree es ts - completeCT _ es = es - -newtype CLimitedDiscrepancyST (solver :: * -> *) a = CLDST Int - -instance Solver solver => CTransformer (CLimitedDiscrepancyST solver a) where - type CEvalState (CLimitedDiscrepancyST solver a) = () - type CTreeState (CLimitedDiscrepancyST solver a) = Int - type CForSolver (CLimitedDiscrepancyST solver a) = solver - type CForResult (CLimitedDiscrepancyST solver a) = a - initCT (CLDST n) = ((),n) - rightCT _ n = n - 1 - nextCT tree c es ts eval' continue exit - | ts == 0 = continue es - | otherwise = eval' tree es ts - -newtype CRandomST (solver :: * -> *) a = CRST Int - -instance Solver solver => CTransformer (CRandomST solver a) where - type CEvalState (CRandomST solver a) = [Bool] - type CTreeState (CRandomST solver a) = () - type CForSolver (CRandomST solver a) = solver - type CForResult (CRandomST solver a) = a - initCT (CRST n) = (randoms $ mkStdGen n,()) - nextCT tree@(Try l r) c (switch:es) - | switch = evalCT (Try r l) c es - | otherwise = evalCT tree c es - nextCT tree@(Add d (Try l r)) c (switch:es) - | switch = evalCT (Add d (Try r l)) c es - | otherwise = evalCT tree c es - nextCT tree c es = evalCT tree c es - -data CIdentityCST (solver :: * -> *) a = CIST - -instance Solver solver => CTransformer (CIdentityCST solver a) where - type CEvalState (CIdentityCST solver a) = () - type CTreeState (CIdentityCST solver a) = () - type CForSolver (CIdentityCST solver a) = solver - type CForResult (CIdentityCST solver a) = a - initCT _ = ((),()) - -data CFirstSolutionST (solver :: * -> *) a = CFSST - -instance Solver solver => CTransformer (CFirstSolutionST solver a) where - type CEvalState (CFirstSolutionST solver a) = Bool - type CTreeState (CFirstSolutionST solver a) = () - type CForSolver (CFirstSolutionST solver a) = solver - type CForResult (CFirstSolutionST solver a) = a - initCT _ = (True,()) - returnCT _ es continue exit = - exit False - completeCT _ es = es - -data CSolutionBoundST (solver :: * -> *) a = CSBST Int - -instance Solver solver => CTransformer (CSolutionBoundST solver a) where - type CEvalState (CSolutionBoundST solver a) = Int - type CTreeState (CSolutionBoundST solver a) = () - type CForSolver (CSolutionBoundST solver a) = solver - type CForResult (CSolutionBoundST solver a) = a - initCT (CSBST n) = (n,()) - returnCT _ 1 continue exit = exit 0 - returnCT _ n continue exit = continue (n-1) - completeCT _ es = es==0 - --------------------------------------------------------------------------------- -data Composition es ts solver a where - (:-) :: (CTransformer c1, CTransformer c2, - CForSolver c1 ~ solver, CForSolver c2 ~ solver, - CForResult c1 ~ a, CForResult c2 ~ a - ) - => c1 -> c2 -> Composition (CEvalState c1,CEvalState c2) (CTreeState c1,CTreeState c2) solver a - -instance Solver solver => CTransformer (Composition es ts solver a) where - type CEvalState (Composition es ts solver a) = es - type CTreeState (Composition es ts solver a) = ts - type CForSolver (Composition es ts solver a) = solver - type CForResult (Composition es ts solver a) = a - initCT (c1 :- c2) = let (es1,ts1) = initCT c1 - (es2,ts2) = initCT c2 - in ((es1,es2),(ts1,ts2)) - leftCT (c1 :- c2) (ts1,ts2) = (leftCT c1 ts1,leftCT c2 ts2) - rightCT (c1 :- c2) (ts1,ts2) = (rightCT c1 ts1,rightCT c2 ts2) - nextCT tree (c1 :- c2) (es1,es2) (ts1,ts2) eval' continue exit = - nextCT tree c1 es1 ts1 - (\tree' es1' ts1' -> nextCT tree' c2 es2 ts2 - (\tree'' es2' ts2' -> eval' tree'' (es1',es2') (ts1',ts2')) - (\es2' -> continue (es1',es2')) - (\es2' -> exit (es1',es2')) ) - (\es1' -> continue (es1',es2)) - (\es1' -> exit (es1',es2)) - returnCT (c1 :- c2) (es1,es2) continue exit = - returnCT c1 es1 (\es1' -> returnCT c2 es2 (\es2' -> continue (es1',es2')) (\es2' -> exit (es1',es2'))) - (\es1' -> exit (es1',es2)) - completeCT (c1 :- c2) (es1,es2) = completeCT c1 es1 && completeCT c2 es2 - --------------------------------------------------------------------------------- --- BRANCH & BOUND --------------------------------------------------------------------------------- - -newtype CBranchBoundST (solver :: * -> *) a = CBBST (NewBound solver) -data BBEvalState solver = BBP Int (Bound solver) - -newtype Bound solver = Bound (forall a. (Tree solver a -> Tree solver a)) -type NewBound solver = solver (Bound solver) - -instance (Solver solver) => CTransformer (CBranchBoundST solver a) where - type CEvalState (CBranchBoundST solver a) = BBEvalState solver - type CTreeState (CBranchBoundST solver a) = Int - type CForSolver (CBranchBoundST solver a) = solver - type CForResult (CBranchBoundST solver a) = a - initCT _ = (BBP 0 (Bound id),0) - nextCT tree c es@(BBP nv (Bound bound)) v eval continue exit - | nv > v = eval (bound tree) es nv - | otherwise = eval tree es v - returnCT (CBBST newBound) (BBP v bound) continue exit = - do bound' <- newBound - continue $ BBP (v + 1) bound' - --------------------------------------------------------------------------------- --- RESTARTING --------------------------------------------------------------------------------- - -data SealedCST es ts solver a where - Seal :: CTransformer c => c -> SealedCST (CEvalState c) (CTreeState c) (CForSolver c) (CForResult c) - -instance Solver solver => CTransformer (SealedCST es ts solver a) where - type CEvalState (SealedCST es ts solver a) = es - type CTreeState (SealedCST es ts solver a) = ts - type CForSolver (SealedCST es ts solver a) = solver - type CForResult (SealedCST es ts solver a) = a - leftCT (Seal c) = leftCT c - rightCT (Seal c) = rightCT c - initCT (Seal c) = initCT c - nextCT tree (Seal c) = nextCT tree c - returnCT (Seal c) = returnCT c - completeCT (Seal c) = completeCT c - -data RestartST es ts (solver :: * -> *) a = RestartST [SealedCST es ts solver a] (Tree solver a -> solver (Tree solver a)) - -instance Solver solver => Transformer (RestartST es ts solver a) where - type EvalState (RestartST es ts solver a) = (SealedCST es ts solver a,[SealedCST es ts solver a],es,Label solver,Tree solver a) - type TreeState (RestartST es ts solver a) = ts - type ForSolver (RestartST es ts solver a) = solver - type ForResult (RestartST es ts solver a) = a - initT (RestartST (c:cs) _) tree = - let (es,ts) = initCT c - in do l <- mark - return ((c,cs,es,l,tree),ts) - leftT _ (c,_,_,_,_) = leftCT c - rightT _ (c,_,_,_,_) = rightCT c - nextT i tree q t es@(c,cs,es_c,l,tree0) ts = - nextCT tree c es_c ts (\tree' es_c' ts' -> eval' i tree' q t (c,cs,es_c',l,tree0) ts') - (\es_c' -> continue i q t (c,cs,es_c',l,tree0)) - (\es_c' -> endT i q t (c,cs,es_c',l,tree0)) - returnT i wl t es@(c,cs,es_c,l,tree0) = returnCT c es_c (\es_c' -> continue i wl t (c,cs,es_c',l,tree0)) (\es_c' -> endT i wl t (c,cs,es_c',l,tree0)) - endT i wl t es@(_,[],_,_,_) = return (i,[]) - endT i wl t@(RestartST _ f) es@(c0,(c:cs),es_c0,l,tree0) - | completeCT c0 es_c0 = return (i,[]) - | otherwise = let (es,ts) = initCT c - in do tree' <- f tree0 - continue i (pushQ (l,tree',ts) $ emptyQ wl) t (c,cs,es,l,tree0) - diff --git a/Control/CP/Debug.hs b/Control/CP/Debug.hs deleted file mode 100644 --- a/Control/CP/Debug.hs +++ /dev/null @@ -1,22 +0,0 @@ -{-# LANGUAGE CPP #-} - -module Control.CP.Debug ( - debug, - imdebug -) where - -import Debug.Trace - -debug :: String -> a -> a -imdebug :: Show a => String -> a -> a - -{-# INLINE debug #-} -{-# INLINE imdebug #-} - -#ifdef DEBUG -debug = trace -imdebug s a = trace ("imdebug " ++ s ++ ": " ++ (show a)) a -#else -debug = flip const -imdebug = flip const -#endif diff --git a/Control/CP/EnumTerm.hs b/Control/CP/EnumTerm.hs deleted file mode 100644 --- a/Control/CP/EnumTerm.hs +++ /dev/null @@ -1,113 +0,0 @@ -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE TransformListComp #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE FlexibleContexts #-} - -module Control.CP.EnumTerm ( - EnumTerm(..), - assignment, assignments, - inOrder, firstFail, middleOut, endsOut, - labelling, levelList, enumerate -) where - -import GHC.Exts (sortWith) - -import Control.CP.Solver -import Control.CP.SearchTree - -class (Solver s, Term s t, Show (TermBaseType s t)) => EnumTerm s t where - type TermBaseType s t :: * - - getDomainSize :: t -> s (Int) - getDomain :: t -> s [TermBaseType s t] - setValue :: t -> TermBaseType s t -> s [Constraint s] - splitDomain :: t -> s ([[Constraint s]],Bool) - splitDomains :: [t] -> s ([[Constraint s]],[t]) - getValue :: t -> s (Maybe (TermBaseType s t)) - defaultOrder :: [t] -> s [t] - enumerator :: (MonadTree m, TreeSolver m ~ s) => Maybe ([t] -> m ()) - - getDomainSize x = do - r <- getDomain x - return $ length r - - getValue x = do - d <- getDomain x - return $ case d of - [v] -> Just v - _ -> Nothing - splitDomain x = do - d <- getDomain x - case d of - [] -> return ([],True) - [_] -> return ([[]],True) - _ -> do - rr <- mapM (setValue x) d - return (rr,True) - - splitDomains [] = return ([[]],[]) - splitDomains (a@(x:b)) = do - s <- getDomainSize x - if s==0 - then return ([],[]) - else if s==1 - then splitDomains b - else do - (r,v) <- splitDomain x - if v - then return (r,b) - else return (r,a) - - defaultOrder = firstFail - enumerator = Nothing - -enumerate :: (MonadTree m, TreeSolver m ~ s, EnumTerm s t) => [t] -> m () -enumerate = case enumerator of - Nothing -> labelling defaultOrder - Just x -> x - -assignment :: (EnumTerm s t, MonadTree m, TreeSolver m ~ s) => t -> m (TermBaseType s t) -assignment q = label $ getValue q >>= \y -> (case y of Just x -> return $ return x; _ -> return false) - -assignments :: (EnumTerm s t, MonadTree m, TreeSolver m ~ s) => [t] -> m [TermBaseType s t] -assignments = mapM assignment - -firstFail :: EnumTerm s t => [t] -> s [t] -firstFail qs = do ds <- mapM getDomainSize qs - return [ q | (d,q) <- zip ds qs - , then sortWith by d ] - -inOrder :: EnumTerm s t => [t] -> s [t] -inOrder = return - -middleOut :: EnumTerm s t => [t] -> s [t] -middleOut l = let n = (length l) `div` 2 in - return $ interleave (drop n l) (reverse $ take n l) - -endsOut :: EnumTerm s t => [t] -> s [t] -endsOut l = let n = (length l) `div` 2 in - return $ interleave (reverse $ drop n l) (take n l) - -interleave [] ys = ys -interleave (x:xs) ys = x:interleave ys xs - -levelList :: (Solver s, MonadTree m, TreeSolver m ~ s) => [m ()] -> m () -levelList [] = false -levelList [a] = a -levelList l = - let len = length l - (p1,p2) = splitAt (len `div` 2) l - in (levelList p1) \/ (levelList p2) ---levelList [] = false ---levelList [a] = a ---levelList (a:b) = a \/ levelList b - -labelling :: (MonadTree m, TreeSolver m ~ s, EnumTerm s t) => ([t] -> s [t]) -> [t] -> m () -labelling _ [] = true -labelling o l = label $ do - ll <- o l - (cl,c) <- splitDomains ll - let ml = map (\l -> foldr (/\) true $ map addC l) cl - return $ do - levelList ml - labelling return c diff --git a/Control/CP/FD/Decompose.hs b/Control/CP/FD/Decompose.hs deleted file mode 100644 --- a/Control/CP/FD/Decompose.hs +++ /dev/null @@ -1,698 +0,0 @@ -{- - - Monadic Constraint Programming - - http://www.cs.kuleuven.be/~toms/MCP/ - - Pieter Wuille - -} - -{-# LANGUAGE GeneralizedNewtypeDeriving #-} - -module Control.CP.FD.Decompose ( - DecompData, - baseDecompData, - decompose, - decomposeEx, - decompBoolLookup, - decompIntLookup, - decompColLookup, -) where - -import Data.Map (Map) -import qualified Data.Map as Map - -import Data.Set (Set) -import qualified Data.Set as Set - -import Control.Monad.State.Lazy hiding (state) - -import Control.CP.Debug -import Data.Expr.Data -import Data.Expr.Util -import Control.CP.FD.Graph -import Control.CP.FD.Model - -data DecompData = DecompData { - -- expressions currently accessible as variables - cseMapBool :: Map ModelBool EGVarId, - cseMapInt :: Map ModelInt EGVarId, - cseMapCol :: Map ModelCol EGVarId, - -- parent graph's data - cseParent :: Maybe DecompData, - -- expressions imported from parent graph - cseImports :: ([ModelBool],[ModelInt],[ModelCol]), - -- counter for unique id's - cseNIds :: Int, - -- locked nodes (already shown to the caller, and cannot be unified/replaced anymore) - cseLocked :: EGTypeData (Set EGVarId), - -- level of nesting - cseLevel :: Int -} - -decompBoolLookup :: DecompData -> ModelBool -> Maybe EGVarId -decompBoolLookup d v = Map.lookup v $ cseMapBool d - -decompIntLookup :: DecompData -> ModelInt -> Maybe EGVarId -decompIntLookup d v = Map.lookup v $ cseMapInt d - -decompColLookup :: DecompData -> ModelCol -> Maybe EGVarId -decompColLookup d v = Map.lookup v $ cseMapCol d - --- | base instance of DecompData -baseDecompData :: DecompData -baseDecompData = DecompData { - cseMapBool = Map.empty, - cseMapInt = Map.empty, - cseMapCol = Map.empty, - cseParent = Nothing, - cseImports = ([],[],[]), - cseNIds = 0, - cseLevel = 0, - cseLocked = baseTypeData (Set.empty) -} - --- | the state for the DCMonad -data DCState = DCState { - dcsData :: DecompData, - dcsModel :: EGModel -} - --- | base state for the DCMonad -baseDCState = DCState { - dcsData = baseDecompData, - dcsModel = baseGraph -} - --- | definition of a decomposer monad -newtype DCMonad a = DCMonad { state :: State DCState a } - deriving (Monad, MonadState DCState) - --- | transform an expression into a graph, taking and returning an updated state -decomposeEx :: DecompData -> Int -> Model -> ([ModelBool],[ModelInt],[ModelCol]) -> Maybe EGModel -> (DecompData,EGModel,Int) -decomposeEx dat vars model (lb,li,lc) prev = - let prog = do - s1 <- get - put $ s1 { dcsData = (dcsData s1) { cseNIds = max vars (cseNIds $ dcsData s1) } } - decomposeBoolEx (Just True) model - mapM_ decomposeBool lb - mapM_ decomposeInt li - mapM_ decomposeCol lc - s2 <- get - put $ s2 { dcsData = (dcsData s2) { cseLocked = egTypeDataMap (\f -> Set.fromList $ Map.keys $ f $ egmLinks $ dcsModel s2) } } - pmodel = case prev of - Nothing -> baseGraph - Just x -> x - res = execState (state prog) $ DCState { dcsData = dat, dcsModel = pmodel } - in (dcsData res,dcsModel res,cseNIds $ dcsData res) - --- | easier version of decomposeEx that does not require or return a state -decompose :: Model -> EGModel -decompose x = (\(_,x,_) -> x) $ decomposeEx baseDecompData 0 x ([],[],[]) Nothing - --- | decomposition states can be stacked, this function tests whether a property hold --- for a state or any of its parents -stateProperty :: (DecompData -> Bool) -> DecompData -> Bool -stateProperty f s = if f s then True else case (cseParent s) of - Just p -> stateProperty f p - _ -> False - -newVar :: EGVarType -> DCMonad EGVarId -newVar typ = do - s <- get - let (nv,nm) = addNode typ (dcsModel s) - put $ s { dcsModel = nm } - return nv - -importBool :: Maybe Bool -> ModelBool -> DCMonad EGVarId -importBool val expr = do - n <- newBoolVar val expr - s <- get - if cseLevel (dcsData s) == 0 - then error $ "Boolean expression (value="++(show val)++") escapes: " ++ (show expr) - else do - let ni = length $ (\(x,_,_)->x) $ cseImports $ dcsData s - put $ s { dcsData = (dcsData s) { cseImports = (\(a,b,c) -> (a++[expr],b,c)) (cseImports $ dcsData s) } } - addConstraint (EGBoolExtern ni) ([n],[],[]) - return n - -importInt :: ModelInt -> DCMonad EGVarId -importInt expr = do - n <- newIntVar expr - s <- get - if cseLevel (dcsData s) == 0 - then error $ "Integer expression escapes: " ++ (show expr) - else do - let ni = length $ (\(_,x,_)->x) $ cseImports $ dcsData s - put $ s { dcsData = (dcsData s) { cseImports = (\(a,b,c) -> (a,b++[expr],c)) (cseImports $ dcsData s) } } - addConstraint (EGIntExtern ni) ([],[n],[]) - return n - -importCol :: ModelCol -> DCMonad EGVarId -importCol expr = do - n <- newColVar expr - s <- get - if cseLevel (dcsData s) == 0 - then error $ "Collection expression escapes: " ++ (show expr) - else do - let ni = length $ (\(_,_,x)->x) $ cseImports $ dcsData s - put $ s { dcsData = (dcsData s) { cseImports = (\(a,b,c) -> (a,b,c++[expr])) (cseImports $ dcsData s) } } - addConstraint (EGColExtern ni) ([],[],[n]) - return n - -unifyVars :: EGVarType -> EGVarId -> EGVarId -> DCMonad Bool -unifyVars typ v1 v2 = do - s <- get - let rm = egTypeGet typ $ cseLocked $ dcsData s - i1 = Set.member v1 rm - i2 = Set.member v2 rm - if (i1 && i2) - then return False -- if both nodes are locked, unification is not possible - else if i1 - then unifyVars typ v2 v1 -- if only i1 is locked, unify v2 with v1 instead of v1 with v2 - else do -- otherwise, really unify - let nm = unifyNodes typ v1 v2 (dcsModel s) - case typ of - EGBoolType -> put $ s { dcsModel = nm, dcsData = (dcsData s) { cseMapBool = Map.map tran $ cseMapBool $ dcsData s } } - EGIntType -> put $ s { dcsModel = nm, dcsData = (dcsData s) { cseMapInt = Map.map tran $ cseMapInt $ dcsData s } } - EGColType -> put $ s { dcsModel = nm, dcsData = (dcsData s) { cseMapCol = Map.map tran $ cseMapCol $ dcsData s } } - return True - where tran = unifyIds v1 v2 - -addConstraint :: EGConstraintSpec -> ([EGVarId],[EGVarId],[EGVarId]) -> DCMonad () -addConstraint spec (lb,li,lc) = do - s <- get - let nm = addEdge spec (EGTypeData { boolData=lb, intData=li, colData=lc }) (dcsModel s) - put $ s { dcsModel = nm } - -newBoolVar :: Maybe Bool -> ModelBool -> DCMonad EGVarId -newBoolVar val expr = do - n <- case val of - Nothing -> newVar EGBoolType - Just x -> decomposeBool $ BoolConst x - s <- get - let nc = Map.insert expr n (cseMapBool $ dcsData s) - put $ s { dcsData = (dcsData s) { cseMapBool = nc } } - return n - -newIntVar :: ModelInt -> DCMonad EGVarId -newIntVar expr = do - n <- newVar EGIntType - s <- get - let nc = Map.insert expr n (cseMapInt $ dcsData s) - put $ s { dcsData = (dcsData s) { cseMapInt = nc } } - return n - -newColVar :: ModelCol -> DCMonad EGVarId -newColVar expr = do - n <- newVar EGColType - s <- get - let nc = Map.insert expr n (cseMapCol $ dcsData s) - put $ s { dcsData = (dcsData s) { cseMapCol = nc } } - return n - -decomposeSubmodel :: (Int,Int,Int) -> (([ModelBool],[ModelInt],[ModelCol]) -> DCMonad ()) -> DCMonad (EGModel,([EGVarId],[EGVarId],[EGVarId])) -decomposeSubmodel (nArgsBool,nArgsInt,nArgsCol) m = do - oArgsBool <- mapM (const $ nextId >>= (\x -> return $ BoolTerm $ ModelBoolVar $ x)) [1..nArgsBool] - oArgsInt <- mapM (const $ nextId >>= (\x -> return $ Term $ ModelIntVar $ x)) [1..nArgsInt] - oArgsCol <- mapM (const $ nextId >>= (\x -> return $ ColTerm $ ModelColVar $ x)) [1..nArgsCol] - s <- get - let sm = m (oArgsBool,oArgsInt,oArgsCol) - ns = execState (state sm) $ baseDCState { dcsData = (dcsData baseDCState) { cseLevel = 1 + (cseLevel $ dcsData s), cseNIds = 0+(cseNIds $ dcsData s), cseParent = Just $ dcsData s } } - put $ s { dcsData = (dcsData s) { cseNIds = 0+(cseNIds $ dcsData ns) } } - argsBool <- mapM decomposeBool $ (\(x,_,_) -> x) $ cseImports $ dcsData ns - argsInt <- mapM decomposeInt $ (\(_,x,_) -> x) $ cseImports $ dcsData ns - argsCol <- mapM decomposeCol $ (\(_,_,x) -> x) $ cseImports $ dcsData ns - return (dcsModel ns, (argsBool,argsInt,argsCol)) - -constIntTrans :: ModelIntTerm ModelFunctions -> EGParTerm -constIntTrans (ModelIntPar x) = EGPTParam x -constIntTrans x = error $ "non-constant int transform: "++(show x) -constColTrans :: ModelColTerm ModelFunctions -> EGParColTerm -constColTrans (ModelColPar x) = EGPTColParam x -constColTrans x = error $ "non-constant col transform: "++(show x) -constBoolTrans :: ModelBoolTerm ModelFunctions -> EGParBoolTerm -constBoolTrans (ModelBoolPar x) = EGPTBoolParam x -constBoolTrans x = error $ "non-constant bool transform: "++(show x) -constIntTransInv :: EGParTerm -> ModelIntTerm ModelFunctions -constIntTransInv (EGPTParam x) = ModelIntPar x -constColTransInv :: EGParColTerm -> ModelColTerm ModelFunctions -constColTransInv (EGPTColParam x) = ModelColPar x -constBoolTransInv :: EGParBoolTerm -> ModelBoolTerm ModelFunctions -constBoolTransInv (EGPTBoolParam x) = ModelBoolPar x - -constTrans = (constIntTrans,constColTrans,constBoolTrans,constIntTransInv,constColTransInv,constBoolTransInv) -invConstTrans = (constIntTransInv,constColTransInv,constBoolTransInv,constIntTrans,constColTrans,constBoolTrans) - -dependenceTester d = - ( - \x -> if Map.member x (cseMapInt d) && not (x `elem` ((\(_,x,_) -> x) $ cseImports d)) then Just True else Nothing, - \x -> if Map.member x (cseMapCol d) && not (x `elem` ((\(_,_,x) -> x) $ cseImports d)) then Just True else Nothing, - \x -> case x of - BoolTerm (ModelExtra _) -> Just True - _ -> if Map.member x (cseMapBool d) && not (x `elem` ((\(x,_,_) -> x) $ cseImports d)) then Just True else Nothing - ) - -dependentIntExpr :: DecompData -> ModelInt -> Bool -dependentIntExpr d = propertyEx $ dependenceTester d -dependentBoolExpr :: DecompData -> ModelBool -> Bool -dependentBoolExpr d = boolPropertyEx $ dependenceTester d -dependentColExpr :: DecompData -> ModelCol -> Bool -dependentColExpr d = colPropertyEx $ dependenceTester d - -nextId :: DCMonad Int -nextId = do - s <- get - let n = cseNIds $ dcsData s - put $ s { dcsData = (dcsData s) { cseNIds = n + 1 } } - return n - ------------------------------------------ --- | Decomposition of special values | -- ------------------------------------------ - -decomposeBool :: ModelBool -> DCMonad EGVarId -decomposeBool expr = do - (Just x) <- decomposeBoolEx Nothing expr - return x - -decomposeBoolEx :: Maybe Bool -> ModelBool -> DCMonad (Maybe EGVarId) -decomposeBoolEx val expr = do - s <- get - debug ("decomposeBoolEx [level "++(show $ cseLevel $ dcsData s)++"] val="++(show val)++" expr="++(show expr)) $ return () - let key = expr - case Map.lookup key (cseMapBool $ dcsData s) of -- local variable or already locally decomposed expression - Just i -> do - debug ("decomposeBoolEx [level "++(show $ cseLevel $ dcsData s)++"] val="++(show val)++" expr="++(show expr)++": already decomposed: "++(show i)) $ return () - return $ Just i - Nothing -> if (modelVariantBool expr) - then do - if (stateProperty (Map.member key . cseMapBool) $ dcsData s) && not (dependentBoolExpr (dcsData s) expr) && (cseLevel $ dcsData s) > 0 - then do -- Loop Invariant Code Motion - debug ("decomposeBoolEx: [level "++(show $ cseLevel $ dcsData s)++"] [variant indep] "++(show expr)) $ return () - n <- importBool val expr - return $ Just n - else do - debug ("decomposeBoolEx: [level "++(show $ cseLevel $ dcsData s)++"] [variant dep] "++(show expr)) $ return () - realDecomposeBoolEx val expr - else do - debug ("decomposeBoolEx: [level "++(show $ cseLevel $ dcsData s)++"] [invariant] "++(show expr)) $ return () - n <- newBoolVar val expr - let tr = boolTransform constTrans expr - addConstraint (EGBoolValue tr) ([n],[],[]) - return $ Just n - -decomposeInt :: ModelInt -> DCMonad EGVarId -decomposeInt expr = do - s <- get - debug ("decomposeInt [level "++(show $ cseLevel $ dcsData s)++"] expr="++(show expr)) $ return () - let key = expr - case Map.lookup key (cseMapInt $ dcsData s) of - Just i -> return i - Nothing -> if (modelVariantInt expr) - then if (stateProperty (Map.member key . cseMapInt) $ dcsData s) && not (dependentIntExpr (dcsData s) expr) && (cseLevel $ dcsData s) > 0 - then do - debug ("decomposeInt: [level "++(show $ cseLevel $ dcsData s)++"] [variant indep] "++(show expr)) $ return () - importInt expr - else do - debug ("decomposeInt: [level "++(show $ cseLevel $ dcsData s)++"] [variant dep] "++(show expr)) $ return () - realDecomposeInt expr - else do - debug ("decomposeInt: [level "++(show $ cseLevel $ dcsData s)++"] [invariant] "++(show expr)) $ return () - n <- newIntVar expr - let tr = transform constTrans expr - addConstraint (EGIntValue tr) ([],[n],[]) - return n - -decomposeCol :: ModelCol -> DCMonad EGVarId -decomposeCol expr = do - s <- get - debug ("decomposeCol [level "++(show $ cseLevel $ dcsData s)++"] expr="++(show expr)) $ return () - let key = expr - case Map.lookup key (cseMapCol $ dcsData s) of - Just i -> return i - Nothing -> if (modelVariantCol expr) - then if (stateProperty (Map.member key . cseMapCol) $ dcsData s) && not (dependentColExpr (dcsData s) expr) && (cseLevel $ dcsData s) > 0 - then do - debug ("decomposeCol: [level "++(show $ cseLevel $ dcsData s)++"] [variant indep] "++(show expr)) $ return () - importCol expr - else do - debug ("decomposeCol: [level "++(show $ cseLevel $ dcsData s)++"] [variant dep] "++(show expr)) $ return () - realDecomposeCol expr - else do - debug ("decomposeCol: [level "++(show $ cseLevel $ dcsData s)++"] [invariant] "++(show expr)) $ return () - n <- newColVar expr - let tr = colTransform constTrans expr - addConstraint (EGColValue tr) ([],[],[n]) - return n - - ------------------------------------------- --- | Real decomposers for expressions | -- ------------------------------------------- - -realDecomposeBoolEx :: Maybe Bool -> ModelBool -> DCMonad (Maybe EGVarId) -realDecomposeBoolEx val expr = case expr of - BoolTerm (ModelExtra (ForNewBool f)) -> do - n <- nextId - let v = BoolTerm $ ModelBoolVar n - newBoolVar Nothing v - decomposeBoolEx val $ f v - BoolTerm (ModelExtra (ForNewInt f)) -> do - n <- nextId - let v = Term $ ModelIntVar n - newIntVar v - decomposeBoolEx val $ f v - BoolTerm (ModelExtra (ForNewCol f)) -> do - n <- nextId - let v = ColTerm $ ModelColVar n - newColVar v - decomposeBoolEx val $ f v - BoolTerm (ModelBoolVar i) -> do - n <- newBoolVar val expr - return $ Just n - BoolCond c t f -> case val of - Just True -> do - dc <- decomposeBool c - di <- decomposeBool $ boolSimplify $ BoolNot c - ct <- decomposeBool (BoolConst True) - if (t /= BoolConst True) - then do - dt <- decomposeBool t - addConstraint EGCondEqual ([dc,dt,ct],[],[]) - else return () - if (f /= BoolConst True) - then do - df <- decomposeBool f - addConstraint EGCondEqual ([di,df,ct],[],[]) - else return () - return Nothing - _ -> error "No reified boolean conditional exists" - BoolAnd a b -> case val of - Just True -> do - decomposeBoolEx val a - decomposeBoolEx val b - return Nothing - _ -> do - n <- newBoolVar val expr - ad <- decomposeBool a - bd <- decomposeBool b - addConstraint EGAnd ([n,ad,bd],[],[]) - return $ Just n - BoolOr a b -> case val of - Just False -> do - decomposeBoolEx val a - decomposeBoolEx val b - return Nothing - _ -> do - n <- newBoolVar val expr - ad <- decomposeBool a - bd <- decomposeBool b - addConstraint EGOr ([n,ad,bd],[],[]) - return $ Just n - BoolNot a -> case val of - Just True -> do - decomposeBoolEx (Just False) a - return Nothing - Just False -> do - decomposeBoolEx (Just True) a - return Nothing - _ -> do - n <- newBoolVar val expr - ad <- decomposeBool a - addConstraint EGNot ([n,ad],[],[]) - return $ Just n - Rel a r b -> case (r,val) of - (EREqual,Just True) -> do - ad <- decomposeInt a - bd <- decomposeInt b - res <- unifyVars EGIntType ad bd - if res - then return Nothing - else do - n <- decomposeBool (BoolConst True) - addConstraint EGEqual ([n],[ad,bd],[]) - return Nothing - (ERDiff,Just False) -> do - ad <- decomposeInt a - bd <- decomposeInt b - res <- unifyVars EGIntType ad bd - if res - then return Nothing - else do - n <- decomposeBool (BoolConst True) - addConstraint EGEqual ([n],[ad,bd],[]) - return Nothing - _ -> do - n <- newBoolVar val expr - ad <- decomposeInt a - bd <- decomposeInt b - addConstraint (case r of - EREqual -> EGEqual - ERDiff -> EGDiff - ERLess -> EGLess True - ) ([n],[ad,bd],[]) - return $ Just n - ColEqual a b -> case val of - Just True -> do - ad <- decomposeCol a - bd <- decomposeCol b - res <- unifyVars EGColType ad bd - if not res - then error "unification of collections failed" - else return Nothing - _ -> error "No negated or reified version of ColEqual exists" - AllDiff b c -> case val of - Just True -> do - ac <- decomposeCol c - addConstraint (EGAllDiff b) ([],[],[ac]) - return Nothing - _ -> error "No negated or reified version of AllDiff exists" - Sorted b c -> case val of - Just True -> do - ac <- decomposeCol c - addConstraint (EGSorted b) ([],[],[ac]) - return Nothing - _ -> error "No negated or reified version of Sorted exists" - Dom i c -> case val of - Just True -> do - ac <- decomposeCol c - ai <- decomposeInt i - addConstraint EGDom ([],[ai],[ac]) - return Nothing - _ -> error "No negated or reified version of Dom exists" - BoolEqual a b -> case val of - Just True -> do - ad <- decomposeBool a - bd <- decomposeBool b - res <- unifyVars EGBoolType ad bd - if res - then return Nothing - else do - n <- decomposeBool (BoolConst True) - addConstraint EGEquiv ([n,ad,bd],[],[]) - return Nothing - _ -> do - n <- newBoolVar val expr - ad <- decomposeBool a - bd <- decomposeBool b - addConstraint EGEquiv ([n,ad,bd],[],[]) - return $ Just n --- BoolAll f (ColRange l h) -> do --- ld <- decomposeInt l --- hd <- decomposeInt h --- n <- newBoolVar val expr --- (smod,(argsBool,argsInt,argsCol)) <- decomposeSubmodel (0,1,0) $ \([],[oarg],[]) -> do --- let sexpr = f oarg --- arg <- newIntVar oarg --- debug ("BoolAllC: arg="++(show arg)++" oarg="++(show oarg)) $ return () --- addConstraint (EGIntExtern $ -1) ([],[arg],[]) --- case val of --- Just True -> do --- decomposeBoolEx (Just True) sexpr --- return () --- _ -> do --- res <- decomposeBool sexpr --- addConstraint (EGBoolExtern $ -1) ([res],[],[]) --- let force = case val of --- Just True -> True --- _ -> False --- addConstraint (EGAllC smod (length argsBool,length argsInt,length argsCol) force) ([n]++argsBool,[ld,hd]++argsInt,argsCol) --- return $ Just n --- BoolAny f (ColRange l h) -> do --- ld <- decomposeInt l --- hd <- decomposeInt h --- n <- newBoolVar val expr --- (smod,(argsBool,argsInt,argsCol)) <- decomposeSubmodel (0,1,0) $ \([],[oarg],[]) -> do --- let sexpr = f oarg --- arg <- newIntVar oarg --- addConstraint (EGIntExtern $ -1) ([],[arg],[]) --- case val of --- Just False -> do --- decomposeBoolEx (Just False) sexpr --- return () --- _ -> do --- res <- decomposeBool sexpr --- addConstraint (EGBoolExtern $ -1) ([res],[],[]) --- let force = case val of --- Just False -> True --- _ -> False --- addConstraint (EGAnyC smod (length argsBool,length argsInt,length argsCol) force) ([n]++argsBool,[ld,hd]++argsInt,argsCol) --- return $ Just n - BoolAll f c -> do - cd <- decomposeCol c - n <- newBoolVar val expr - (smod,(argsBool,argsInt,argsCol)) <- decomposeSubmodel (0,1,0) $ \([],[oarg],[]) -> do - let sexpr = f oarg - arg <- newIntVar oarg - addConstraint (EGIntExtern $ -1) ([],[arg],[]) - case val of - Just True -> do {- in case a BoolAll itself must hold, each submodel must hold too -} - decomposeBoolEx (Just True) sexpr - return () - _ -> do - res <- decomposeBool sexpr - addConstraint (EGBoolExtern $ -1) ([res],[],[]) - let force = - case val of - Just True -> True - _ -> False - addConstraint (EGAll smod (length argsBool,length argsInt,length argsCol) force) ([n] ++ argsBool,argsInt,[cd] ++ argsCol) - return $ Just n - BoolAny f c -> do - cd <- decomposeCol c - n <- newBoolVar val expr - (smod,(argsBool,argsInt,argsCol)) <- decomposeSubmodel (0,1,0) $ \([],[oarg],[]) -> do - let sexpr = f oarg - arg <- newIntVar oarg - addConstraint (EGIntExtern $ -1) ([],[arg],[]) - case val of - Just False -> do {- in case a BoolAny itself may not hold, each submodel may not hold either -} - decomposeBoolEx (Just False) sexpr - return () - _ -> do - res <- decomposeBool sexpr - addConstraint (EGBoolExtern $ -1) ([res],[],[]) - let force = - case val of - Just False -> True - _ -> False - addConstraint ((if force then EGAll else EGAny) smod (length argsBool,length argsInt,length argsCol) force) ([n] ++ argsBool,argsInt,[cd] ++ argsCol) - return $ Just n - _ -> error $ "Unable to decompose boolean expression: " ++ (show expr) ++ "(== " ++ (show val) ++ ")" - -realDecomposeInt :: ModelInt -> DCMonad EGVarId -realDecomposeInt expr = do - let pIntOp a x b = do - n <- newIntVar expr - ad <- decomposeInt a - bd <- decomposeInt b - addConstraint x ([],[n,ad,bd],[]) - return n - case expr of - Term (ModelIntVar i) -> newIntVar expr - Plus a b -> pIntOp a EGPlus b - Minus a b -> pIntOp a EGMinus b - Mult a b -> pIntOp a EGMult b - Div a b -> pIntOp a EGDiv b - Mod a b -> pIntOp a EGMod b - Abs a -> do - n <- newIntVar expr - ad <- decomposeInt a - addConstraint EGAbs ([],[n,ad],[]) - return n - At a b -> do - n <- newIntVar expr - ad <- decomposeCol a - bd <- decomposeInt b - addConstraint EGAt ([],[n,bd],[ad]) - return n - ColSize a -> do - n <- newIntVar expr - ad <- decomposeCol a - addConstraint EGSize ([],[n],[ad]) - return n - Channel a -> do - n <- newIntVar expr - ad <- decomposeBool a - addConstraint EGChannel ([ad],[n],[]) - return n - Cond c t f -> do - n <- newIntVar expr - cd <- decomposeBool c - td <- decomposeInt t - fd <- decomposeInt f - addConstraint EGCondInt ([cd],[n,td,fd],[]) - return n - Fold f i c -> do - cd <- decomposeCol c - id <- decomposeInt i - n <- newIntVar expr - (smod,(argsBool,argsInt,argsCol)) <- decomposeSubmodel (0,2,0) $ \([],[oacc,oarg],[]) -> do - let sexpr = f oacc oarg - acc <- newIntVar oacc - addConstraint (EGIntExtern $ -2) ([],[acc],[]) - arg <- newIntVar oarg - addConstraint (EGIntExtern $ -3) ([],[arg],[]) - res <- decomposeInt sexpr - addConstraint (EGIntExtern $ -1) ([],[res],[]) - addConstraint (EGFold smod (length argsBool,length argsInt,length argsCol)) (argsBool,[n,id]++argsInt,[cd]++argsCol) - return n - _ -> error $ "Unable to decompose expression: " ++ (show expr) - -listAll :: [a] -> (a -> Maybe b) -> Maybe [b] -listAll [] _ = Just [] -listAll (a:b) f = case f a of - Nothing -> Nothing - Just r -> case listAll b f of - Nothing -> Nothing - Just x -> Just (r:x) - -realDecomposeCol :: ModelCol -> DCMonad EGVarId -realDecomposeCol expr = case expr of - ColList l -> do - n <- newColVar expr - ld <- mapM decomposeInt l - addConstraint (EGList (length l)) ([],ld,[n]) - return n - ColTerm (ModelColVar i) -> newColVar expr - ColRange a b -> do - n <- newColVar expr - ad <- decomposeInt a - bd <- decomposeInt b - addConstraint EGRange ([],[ad,bd],[n]) - return n - ColCat a b -> do - n <- newColVar expr - ad <- decomposeCol a - bd <- decomposeCol b - addConstraint EGCat ([],[],[n,ad,bd]) - return n -{- ColSlice f n c -> do - nn <- newColVar expr - cd <- decomposeCol c - let fd x = debug ("ColSlice: f("++(show x)++")="++(show $ f $ transform invConstTrans x)) $ transform constTrans $ f $ transform invConstTrans x - let nd = transform constTrans n - addConstraint (EGSlice fd nd) ([],[],[nn,cd]) - return nn -} - ColSlice f nn c -> do - cd <- decomposeCol c - nd <- decomposeInt nn - n <- newColVar expr - (smod,(argsBool,argsInt,argsCol)) <- decomposeSubmodel (0,1,0) $ \([],[oarg],[]) -> do - let sexpr = f oarg - arg <- newIntVar oarg - addConstraint (EGIntExtern $ -2) ([],[arg],[]) - res <- decomposeInt sexpr - addConstraint (EGIntExtern $ -1) ([],[res],[]) - addConstraint (EGSlice smod (length argsBool,length argsInt,length argsCol)) (argsBool,[nd]++argsInt,[n,cd]++argsCol) - return n - ColMap f c -> do - cd <- decomposeCol c - n <- newColVar expr - (smod,(argsBool,argsInt,argsCol)) <- decomposeSubmodel (0,1,0) $ \([],[oarg],[]) -> do - let sexpr = f oarg - arg <- newIntVar oarg - addConstraint (EGIntExtern $ -2) ([],[arg],[]) - res <- decomposeInt sexpr - addConstraint (EGIntExtern $ -1) ([],[res],[]) - addConstraint (EGMap smod (length argsBool,length argsInt,length argsCol)) (argsBool,argsInt,[n,cd]++argsCol) - return n - _ -> error $ "Unable to decompose collection: " ++ (show expr) diff --git a/Control/CP/FD/Example.hs b/Control/CP/FD/Example.hs deleted file mode 100644 --- a/Control/CP/FD/Example.hs +++ /dev/null @@ -1,109 +0,0 @@ -{-# LANGUAGE RankNTypes #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE ScopedTypeVariables #-} - -module Control.CP.FD.Example ( - example_main, - example_sat_main, - example_sat_main_void, - example_sat_main_single, - example_sat_main_single_expr, - example_sat_main_coll_expr, - example_min_main, - example_min_main_void, - example_min_main_single, - example_min_main_single_expr, - example_min_main_coll_expr, - runSolve, - labeller, - postMinimize, - ExampleModel, ExampleMinModel, - module Control.CP.FD.Interface, -) where - - -import System.Environment (getArgs) -import Data.Maybe (fromJust,isJust) -import Data.Map (Map) -import qualified Data.Map as Map -import Data.List (init,last) - -import Control.CP.FD.OvertonFD.OvertonFD -import Control.CP.FD.OvertonFD.Sugar -import Control.CP.FD.FD -import Control.CP.FD.Model - -import Control.CP.Debug - -import Control.CP.FD.Interface -import Control.CP.SearchTree -import Control.CP.EnumTerm -import Control.CP.ComposableTransformers -import Control.CP.FD.Solvers - -import Control.Monad.Cont - -type ExampleModel t = (forall s m. (Show (FDIntTerm s), FDSolver s, MonadTree m, TreeSolver m ~ (FDInstance s)) => t -> m (ModelCol)) -type ExampleMinModel t = (forall s m. (Show (FDIntTerm s), FDSolver s, MonadTree m, TreeSolver m ~ (FDInstance s)) => t -> m (ModelInt,ModelCol)) - -postMinimize :: ExampleMinModel t -> ExampleModel t -postMinimize m = \x -> do - (min,res) <- m x - debug ("postMinimize: min="++(show min)) $ return () - label $ do - setMinimizeVar min - return $ return res - -runSolveSAT x = solve dfs fs x -runSolveMIN x = solve dfs (bb boundMinimize) x - -runSolve False x = runSolveSAT x -runSolve True x = runSolveMIN x - -labeller col = do - label $ do - min <- getMinimizeVar - case min of - Nothing -> return $ labelCol col - Just v -> return $ do - enumerate [v] - labelCol col - -example_main :: ExampleModel [String] -> ExampleModel ModelInt -> ExampleModel ModelCol -> Bool -> IO () -example_main f fx fcx typ = do - args <- getArgs - case args of - ("overton_run":r) -> print $ runSolve typ $ ((f r) :: Tree (FDInstance OvertonFD) ModelCol) >>= labeller - [] -> putStr "Solver type required: must be overton_run\n" - (a:r) -> putStr ("Unsupported solver: " ++ a ++ "\n") - -example_min_main :: ExampleMinModel [String] -> ExampleMinModel ModelInt -> ExampleMinModel ModelCol -> IO () -example_min_main f fx fcx = example_main (postMinimize f) (postMinimize fx) (postMinimize fcx) True - -example_sat_main :: ExampleModel [String] -> ExampleModel ModelInt -> ExampleModel ModelCol -> IO () -example_sat_main f fx fcx = example_main f fx fcx False - -example_sat_main_void :: ExampleModel () -> IO () -example_sat_main_void f = example_sat_main (const $ f ()) (const $ f ()) (const $ f ()) - -example_min_main_void :: ExampleMinModel () -> IO () -example_min_main_void f = example_min_main (const $ f ()) (const $ f ()) (const $ f ()) - -example_sat_main_single :: Read n => ExampleModel n -> IO () -example_sat_main_single f = example_sat_main (f . read . head) (error "Uncompilable model") (error "Uncompilable model") - -example_min_main_single :: Read n => ExampleMinModel n -> IO () -example_min_main_single f = example_min_main (f . read . head) (error "Uncompilable model") (error "Uncompilable model") - -example_sat_main_single_expr :: ExampleModel ModelInt -> IO () -example_sat_main_single_expr f = example_sat_main (f . fromInteger . read . head) f (\x -> f $ x!(cte 0)) - -example_min_main_single_expr :: ExampleMinModel ModelInt -> IO () -example_min_main_single_expr f = example_min_main (f . fromInteger . read . head) f (\x -> f $ x!(cte 0)) - -example_sat_main_coll_expr :: ExampleModel ModelCol -> IO () -example_sat_main_coll_expr f = example_sat_main (f . list . foldr (++) [] . map (map fromInteger . read . (\x -> "[" ++ x ++ "]"))) (f. list . (\x -> [x])) f - -example_min_main_coll_expr :: ExampleMinModel ModelCol -> IO () -example_min_main_coll_expr f = example_min_main (f . list . foldr (++) [] . map (map fromInteger . read . (\x -> "[" ++ x ++ "]"))) (f. list . (\x -> [x])) f diff --git a/Control/CP/FD/FD.hs b/Control/CP/FD/FD.hs deleted file mode 100644 --- a/Control/CP/FD/FD.hs +++ /dev/null @@ -1,1555 +0,0 @@ -{-# LANGUAGE GeneralizedNewtypeDeriving #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE TypeSynonymInstances #-} -{-# LANGUAGE UndecidableInstances #-} - -module Control.CP.FD.FD ( - module Data.Expr.Sugar, - FDInstance, - FDSolver(..), - FDSpecInfo, - FDSpecInfoBool(..), FDSpecInfoInt(..), FDSpecInfoCol(..), - liftFD, addFD, - SpecFn, SpecFnRes, SpecResult(..), - getBoolSpec_, getIntSpec_, getColSpec_, - getBoolSpec, getIntSpec, getColSpec, - getEdge, markEdge, - setFailed, - getLevel, - getIntVal, getBoolVal, getColVal, - getIntTerm, getBoolTerm, getColTerm, - getSingleIntTerm, - getDefBoolSpec, getDefIntSpec, getDefColSpec, - getFullBoolSpec, getFullIntSpec, getFullColSpec, - getColItems, - fdSpecInfo_spec, - specInfoBoolTerm, specInfoIntTerm, - Control.CP.FD.FD.newInt, Control.CP.FD.FD.newBool, Control.CP.FD.FD.newCol, - procSubModel, procSubModelEx, specSubModelEx, - runFD, - setMinimizeVar, boundMinimize, getMinimizeTerm, getMinimizeVar, - fdNewvar, -) where - -import Control.Monad.State.Lazy -import Control.Monad.Trans -import qualified Data.Map as Map -import Data.Map(Map) -import Data.Maybe -import Data.List -import qualified Data.Set as Set -import Data.Set(Set) - -import Control.CP.Debug -import Data.Expr.Sugar -import Data.Expr.Data --- import Control.CP.FD.Expr.Util -import Control.CP.FD.Model -import Control.CP.FD.Decompose -import Control.CP.FD.Graph -import Control.CP.SearchTree -import Control.CP.ComposableTransformers -import Control.CP.EnumTerm -import Control.CP.Solver -import Control.Mixin.Mixin - --- | state kept by FDInstance, in addition to the underlying solver's internal state -data FDSolver s => FDState s = FDState { - -- | expression representing unprocessed constraints - fdsExpr :: Model, - -- | model being processed now - fdsModel :: Maybe EGModel, - -- | private data for the decomposer (kept to optimize constraints which aren't added in one go) - fdsDecomp :: DecompData, - -- | when adding constraints, the EGEdgeId's occurring in the decomposed model - fdsNewEdges :: Set EGEdgeId, - fdsDoneEdges :: Set EGEdgeId, - -- | expressions that need to be decomposed - fdsForceBool :: [ModelBool], fdsForcedBool :: Map ModelBool (FDBoolTerm s), - fdsForceInt :: [ModelInt], fdsForcedInt :: Map ModelInt (FDIntTerm s), - fdsForceCol :: [ModelCol], - -- | variable counter - fdsVars :: Int, - - -- | already introduced integer variables/terms/constants/expressions - fdsIntVars :: Map EGVarId (FDSpecInfoInt s), - -- | needed sets of possible types - fdsIntVarTypes :: Map EGVarId (Set (FDIntSpecTypeSet s)), - -- | which variables are being decomposed right now - fdsIntVarBusy :: Set EGVarId, - -- | which nodes are unified with which others - fdsIntUnifies :: Map EGVarId (Set EGVarId), - - -- | already introduced boolean variables/terms/constants/expressions - fdsBoolVars :: Map EGVarId (FDSpecInfoBool s), - fdsBoolVarTypes :: Map EGVarId (Set (FDBoolSpecTypeSet s)), - fdsBoolVarBusy :: Set EGVarId, - fdsBoolUnifies :: Map EGVarId (Set EGVarId), - -- | already introduced collection variables/terms/constants/expressions - fdsColVars :: Map EGVarId (FDSpecInfoCol s), - fdsColVarTypes :: Map EGVarId (Set (FDColSpecTypeSet s)), - fdsColVarBusy :: Set EGVarId, - fdsColUnifies :: Map EGVarId (Set EGVarId), - - -- | db of specifiers - fdsDb :: SpecDb s, - - -- | solver is failed? - fdsFailed :: Bool, - - -- | level of nesting - fdsLevel :: Int, - - -- | levels of dummyness - fdsDummyLevel :: Int, - - fdsMinimizeVar :: Maybe ModelInt, - fdsMinimizeTerm :: Maybe (FDIntTerm s) -} - -myFromJust str m = case m of - Nothing -> error $ "myFromJust: " ++ str - Just x -> x - -unifyInts a b = do - s <- get - let sa = Map.findWithDefault (Set.singleton a) a (fdsIntUnifies s) - let sb = Map.findWithDefault (Set.singleton b) b (fdsIntUnifies s) - let sc = Set.union sa sb - put s { fdsIntUnifies = foldr (\a b -> Map.insert a sc b) (fdsIntUnifies s) $ Set.toList sc } - -unifyBools a b = do - s <- get - let sa = Map.findWithDefault (Set.singleton a) a (fdsBoolUnifies s) - let sb = Map.findWithDefault (Set.singleton b) b (fdsBoolUnifies s) - let sc = Set.union sa sb - put s { fdsBoolUnifies = foldr (\a b -> Map.insert a sc b) (fdsBoolUnifies s) $ Set.toList sc } - -unifyCols a b = do - s <- get - let sa = Map.findWithDefault (Set.singleton a) a (fdsColUnifies s) - let sb = Map.findWithDefault (Set.singleton b) b (fdsColUnifies s) - let sc = Set.union sa sb - put s { fdsColUnifies = foldr (\a b -> Map.insert a sc b) (fdsColUnifies s) $ Set.toList sc } - -mapVals :: Show b => (a -> Maybe b) -> [a] -> [String] -mapVals f l = nub $ sort $ map show $ catMaybes $ map f l - -dumpSpec :: FDSolver s => FDState s -> String -dumpSpec s = - foldl (++) "" (map (\(i,r) -> "i" ++ (show $ unVarId i) ++ "\n" ++ foldl (++) "" (map (\x -> " "++x++"\n") (mapVals (fdspIntSpec r) (Nothing : (map Just $ Set.toList $ fdspIntTypes r))))) $ Map.toList (fdsIntVars s)) ++ - foldl (++) "" (map (\(i,r) -> "b" ++ (show $ unVarId i) ++ "\n" ++ foldl (++) "" (map (\x -> " "++x++"\n") (mapVals (fdspBoolSpec r) (Nothing : (map Just $ Set.toList $ fdspBoolTypes r))))) $ Map.toList (fdsBoolVars s)) ++ - foldl (++) "" (map (\(i,r) -> "c" ++ (show $ unVarId i) ++ "\n" ++ foldl (++) "" (map (\x -> " "++x++"\n") (mapVals (fdspColSpec r) (Nothing : (map Just $ Set.toList $ fdspColTypes r))))) $ Map.toList (fdsColVars s)) - -setMinimizeVar :: (Show (FDIntTerm s), FDSolver s) => ModelInt -> FDInstance s () -setMinimizeVar v = do - s <- get - case Map.lookup v (fdsForcedInt s) of - Just t -> debug ("setMinimizeVar: (cached) var="++(show v)++" term="++(show t)) $ put s { fdsMinimizeVar = Just v, fdsMinimizeTerm = Just t } - Nothing -> do - var <- getSingleIntTerm v - s2 <- get - debug ("setMinimizeVar: (not cached) var="++(show v)++" term="++(show var)) $ put s2 { fdsMinimizeVar = Just v, fdsMinimizeTerm = Just var } - -getMinimizeVar :: (Show (FDIntTerm s), FDSolver s) => FDInstance s (Maybe ModelInt) -getMinimizeVar = do - s <- get - return $ fdsMinimizeVar s - -getMinimizeTerm :: (Show (FDIntTerm s), FDSolver s) => FDInstance s (Maybe (FDIntTerm s)) -getMinimizeTerm = do - s <- get - debug ("getMinimizeTerm: "++(show $ fdsMinimizeTerm s)) $ return () - return (fdsMinimizeTerm s) --- case (fdsMinimizeTerm s) of --- q@(Just _) -> return q --- Nothing -> case (fdsMinimizeVar s) of --- Nothing -> return Nothing --- Just v -> do --- q <- getSingleIntTerm v --- put s { fdsMinimizeTerm = Just q } --- return $ Just q - -boundMinimize :: (Show (FDIntTerm s), FDSolver s, EnumTerm s (FDIntTerm s), Integral (TermBaseType s (FDIntTerm s))) => NewBound (FDInstance s) -boundMinimize = do - bound <- getMinimizeTerm - case bound of - Nothing -> error "no bound variable defined" - Just bndvar -> do - x <- liftFD $ getValue bndvar - case x of - Just val -> do - con <- liftFD $ fdConstrainIntTerm bndvar (toInteger val) - let f = Bound (\x -> (Add (Right con) x)) - return f - _ -> error "bound variable is not assigned" - -runFD :: FDSolver s => FDInstance s a -> s a -runFD (FDInstance { unFDInstance = u }) = evalStateT u baseFDState - -linkExterns :: FDSolver s => (Int -> Maybe (FDSpecInfoBool s), Int -> Maybe (FDSpecInfoInt s), Int -> Maybe (FDSpecInfoCol s)) -> EGEdgeId -> FDInstance s () -linkExterns (sfb,sfi,sfc) id = do - s <- get - let Just jm = fdsModel s - let Just edge = Map.lookup id $ egmEdges jm - case (egeCons edge) of - EGBoolExtern p -> do - case sfb p of - Nothing -> return () - Just spec -> do - let [varid] = boolData $ egeLinks edge - if (Map.member varid $ fdsBoolVars s) then error "double bool import" else return () - put $ s { fdsBoolVars = Map.insert varid spec $ fdsBoolVars s, fdsBoolVarTypes = Map.delete varid $ fdsBoolVarTypes s } - markEdge id - EGIntExtern p -> do - case sfi p of - Nothing -> return () - Just spec -> do - let [varid] = intData $ egeLinks edge - if (Map.member varid $ fdsIntVars s) then error "double int import" else return () - put $ s { fdsIntVars = Map.insert varid spec $ fdsIntVars s, fdsIntVarTypes = Map.delete varid $ fdsIntVarTypes s } - markEdge id - EGColExtern p -> do - case sfc p of - Nothing -> return () - Just spec -> do - let [varid] = colData $ egeLinks edge - if (Map.member varid $ fdsColVars s) then error "double col import" else return () - put $ s { fdsColVars = Map.insert varid spec $ fdsColVars s, fdsColVarTypes = Map.delete varid $ fdsColVarTypes s } - markEdge id - _ -> return () - -procSubModel :: FDSolver s => EGModel -> (Int -> FDSpecInfoBool s, Int -> FDSpecInfoInt s, Int -> FDSpecInfoCol s) -> FDInstance s () -procSubModel sm (fb,fi,fc) = procSubModelEx sm (Just . fb,Just . fi,Just . fc) - -procSubModelEx :: FDSolver s => EGModel -> (Int -> Maybe (FDSpecInfoBool s), Int -> Maybe (FDSpecInfoInt s), Int -> Maybe (FDSpecInfoCol s)) -> FDInstance s () -procSubModelEx sm specfn = do - s <- get - let ss = baseFDState { - fdsModel = Just sm, - fdsVars = fdsVars s, - fdsFailed = fdsFailed s, - fdsLevel = 1 + fdsLevel s - } - put ss - initForModel - s2 <- get - mapM_ (linkExterns specfn) $ Set.toList $ fdsNewEdges s2 - process - s3 <- get - put $ s { fdsFailed = fdsFailed s || fdsFailed s3, fdsVars = fdsVars s3 } - -getLevel :: FDSolver s => FDInstance s Int -getLevel = do - s <- get - return $ fdsLevel s - --- specSubModelEx :: FDSolver s => EGModel -> (Int -> Maybe (FDSpecInfoBool s), Int -> Maybe (FDSpecInfoInt s), Int -> Maybe (FDSpecInfoCol s)) -> FDInstance s () -specSubModelEx sm specfn = do - s <- get - let ss = baseFDState { - fdsModel = Just sm, - fdsVars = fdsVars s, - fdsFailed = fdsFailed s, - fdsLevel = 1 + fdsLevel s - } - put ss - initForModel - s2 <- get - mapM_ (linkExterns specfn) $ Set.toList $ fdsNewEdges s2 - s3 <- get - put s3 { fdsDummyLevel = 1 } - processEx False - s4 <- get - put $ s { fdsFailed = fdsFailed s || fdsFailed s4, fdsVars = fdsVars s4 } - return (fdsBoolVars s4, fdsIntVars s4, fdsColVars s4) - -optimizeSetSet :: Ord a => Set (Set a) -> Set (Set a) -optimizeSetSet x = - let (min,xx) = Set.deleteFindMin x - inter = Set.fold Set.intersection min xx - in if Set.null inter then x else Set.singleton inter - -optimizeVarTypes :: FDSolver s => FDInstance s () -optimizeVarTypes = do - s <- get - put $ s { - fdsBoolVarTypes = Map.map optimizeSetSet $ fdsBoolVarTypes s, - fdsIntVarTypes = Map.map optimizeSetSet $ fdsIntVarTypes s, - fdsColVarTypes = Map.map optimizeSetSet $ fdsColVarTypes s - } - -checkNeedSpecType var typ db = any (Set.member typ) $ Set.toList $ Map.findWithDefault Set.empty var db - -decompSpec fn db un unfn ex vars typs = do - s <- get - let tri [] = do - debug ("decompSpec vars="++(show vars)++": no spec left, failing") $ return () - return Nothing - tri (((_,_,id),_):rest) | not (Set.member id vars) = tri rest - tri ((key@(_,_,id),(eid,s)):rest) = case ex s of - Nothing -> tri rest - Just spec -> do - res <- spec - case res of - SpecResNone -> tri rest - SpecResSpec (typ,spec) -> if Set.member typ typs - then do - rr <- liftFD spec - debug ("decompSpec: got spec: " ++ (show rr)) $ return () - fn (Set.findMin vars) typ rr - case eid of - Nothing -> return () - Just e -> do - debug ("decompSpec: marking edge "++(show e)) $ return () - markEdge e - return $ Just (typ,rr) - else tri rest - SpecResUnify v -> do - unfn id v - decompSpec fn db un unfn ex vars typs - tri $ Map.toDescList $ db - -decompBestHelp id spec fn unfn eid prio db = do - res <- spec - case res of - SpecResNone -> do - debug ("decompBestHelp: level "++(show prio)++" specifier for var "++(show id)++" by edge "++(show eid)++" has failed") $ return () - return () - SpecResSpec (typ,ss) -> if checkNeedSpecType id typ db - then do - rr <- liftFD ss - res <- fn id typ rr - case eid of - Nothing -> return () - Just e -> do - debug ("decompBestHelp: marking edge "++(show e)) $ return () - markEdge e - return () - return res - else do - debug ("decompBestHelp: typ "++(show typ)++" specifier for id "++(show id)++" seems not needed") $ return () - return () - SpecResUnify v -> do - unfn id v - return () - -decompBest :: FDSolver s => FDInstance s Bool -decompBest = do - s1 <- debug "in decompBest: get" $ get - debug "in decompBest" $ return () - if Map.null $ fdsDb s1 - then return False - else do - let (((prio,knd,id),(eid,spec)),nm) = Map.deleteFindMax $ fdsDb $ debug "s1?" s1 - s2 = debug ("got best spec: prio="++(show prio)++", knd="++(show knd)++", id="++(show id)++", eid="++(show eid)++", spec=?") $ s1 { fdsDb = nm } - put s2 - case knd of - FDTBool -> do - let s3 = s2 { fdsBoolVarBusy = Set.insert id $ fdsBoolVarBusy s2 } - put s3 - let Just j = fdsBoolSel spec - decompBestHelp id j addBoolVar unifyBools eid prio $ fdsBoolVarTypes s3 - s4 <- get - put $ s4 { fdsBoolVarBusy = Set.delete id $ fdsBoolVarBusy s4 } - FDTInt -> do - let s3 = s2 { fdsIntVarBusy = Set.insert id $ fdsIntVarBusy s2 } - put s3 - let Just j = fdsIntSel spec - decompBestHelp id j addIntVar unifyInts eid prio $ fdsIntVarTypes s3 - s4 <- get - put $ s4 { fdsIntVarBusy = Set.delete id $ fdsIntVarBusy s4 } - FDTCol -> do - let s3 = s2 { fdsColVarBusy = Set.insert id $ fdsColVarBusy s2 } - put s3 - let Just j = fdsColSel spec - decompBestHelp id j addColVar unifyCols eid prio $ fdsColVarTypes s3 - s4 <- get - put $ s4 { fdsColVarBusy = Set.delete id $ fdsColVarBusy s4 } - return True - -decompDefaultBool :: FDSolver s => FDInstance s Bool -decompDefaultBool = do - s1 <- get - if Map.null $ fdsBoolVarTypes s1 - then return False - else do - let ((varid,set),nm) = Map.deleteFindMin $ fdsBoolVarTypes s1 - s2 = s1 { fdsBoolVarTypes = nm } - put s2 - if Set.null set - then return True - else do - defaultBoolDecomp varid Nothing - return True - -decompDefaultInt :: FDSolver s => FDInstance s Bool -decompDefaultInt = do - s1 <- get - if Map.null $ fdsIntVarTypes s1 - then return False - else do - let ((varid,set),nm) = Map.deleteFindMin $ fdsIntVarTypes s1 - s2 = s1 { fdsIntVarTypes = nm } - put s2 - if Set.null set - then return True - else do - defaultIntDecomp varid Nothing - return True - -defaultBoolDecomp :: FDSolver s => EGVarId -> (Maybe (FDBoolSpecTypeSet s)) -> FDInstance s (Maybe (FDBoolSpecType s, FDBoolSpec s)) -defaultBoolDecomp var typs = do - s <- get - if fdsDummyLevel s > 0 - then return Nothing - else do - vt <- liftFD $ fdTypeVarBool - let Just jt = typs - if (isNothing typs || not (Set.null $ Set.intersection vt jt)) - then do - Just v <- fdNewvar - let (ty,sp) = fdBoolSpec_term v - rs <- liftFD sp - addBoolVar var ty (rs, Nothing) - return $ Just (ty,rs) - else return Nothing - -defaultIntDecomp :: FDSolver s => EGVarId -> (Maybe (FDIntSpecTypeSet s)) -> FDInstance s (Maybe (FDIntSpecType s, FDIntSpec s)) -defaultIntDecomp var typs = do - s <- get - if fdsDummyLevel s > 0 - then return Nothing - else do - vt <- liftFD $ fdTypeVarInt - let Just jt = typs - if (isNothing typs || not (Set.null $ Set.intersection vt jt)) - then do - Just v <- fdNewvar - let (ty,sp) = fdIntSpec_term v - rs <- liftFD sp - addIntVar var ty (rs, Nothing) - return $ Just (ty,rs) - else return Nothing - -getBoolSpec_ :: FDSolver s => EGVarId -> FDBoolSpecTypeSet s -> FDInstance s (Maybe (FDBoolSpecType s, FDBoolSpec s)) -getBoolSpec_ var typs = do - s <- get - let vars = Map.findWithDefault (Set.singleton var) var $ fdsBoolUnifies s - getBoolSpec__ vars typs - -getBoolSpec__ :: FDSolver s => Set EGVarId -> FDBoolSpecTypeSet s -> FDInstance s (Maybe (FDBoolSpecType s, FDBoolSpec s)) -getBoolSpec__ vars typs = do - s <- get - let mp = foldl (\b a -> case Map.lookup a (fdsBoolVars s) of { Nothing -> b; Just x -> case b of { Nothing -> Just x; Just r -> Just $ unionSpecBool r x }}) Nothing (Set.toList vars) - let sp = Set.intersection (maybe Set.empty fdspBoolTypes mp) typs - let db = fdsDb s - if Set.null sp - then if not (Set.null $ Set.intersection vars $ fdsBoolVarBusy s) - then return Nothing - else do - put $ s { fdsBoolVarBusy = Set.union vars $ fdsBoolVarBusy s } - res <- decompSpec addBoolVar db (\x -> Map.lookup x $ fdsBoolUnifies s) unifyBools fdsBoolSel vars typs - s2 <- get - put $ s2 { fdsBoolVarBusy = Set.difference (fdsBoolVarBusy s) vars } - case res of - Just (tp,(sp,_)) -> return $ Just (tp,sp) - _ -> defaultBoolDecomp (Set.findMin vars) $ Just typs - else do - let lp = Set.findMin sp - let Just jmp = mp - let Just j = fdspBoolSpec jmp $ Just lp - return $ Just (lp,j) - -getBoolSpec :: FDSolver s => EGVarId -> FDInstance s (Maybe (FDBoolSpec s)) -getBoolSpec var = do - s <- allBoolSpec - q <- getBoolSpec_ var s - return $ case q of - Just (_,x) -> Just x - Nothing -> Nothing - -getIntSpec_ :: FDSolver s => EGVarId -> FDIntSpecTypeSet s -> FDInstance s (Maybe (FDIntSpecType s, FDIntSpec s)) -getIntSpec_ var typs = do - s <- get - let vars = Map.findWithDefault (Set.singleton var) var $ fdsIntUnifies s - getIntSpec__ vars typs - -getIntSpec__ :: FDSolver s => Set EGVarId -> FDIntSpecTypeSet s -> FDInstance s (Maybe (FDIntSpecType s, FDIntSpec s)) -getIntSpec__ vars typs = do - s <- get - let mp = foldl (\b a -> case Map.lookup a (fdsIntVars s) of { Nothing -> b; Just x -> case b of { Nothing -> Just x; Just r -> Just $ unionSpecInt r x }}) Nothing $ Set.toList vars - let sp = Set.intersection (maybe Set.empty fdspIntTypes mp) typs - let db = fdsDb s - if Set.null sp - then if not (Set.null $ Set.intersection vars $ fdsIntVarBusy s) - then do - debug ("getIntSpec__ "++(show (vars,typs))++": busy, failing") $ return () - return Nothing - else do - put $ s { fdsIntVarBusy = Set.union vars $ fdsIntVarBusy s } - res <- decompSpec addIntVar db (\x -> Map.lookup x $ fdsIntUnifies s) unifyInts fdsIntSel vars typs - s2 <- get - put $ s2 { fdsIntVarBusy = Set.difference (fdsIntVarBusy s) vars } - case res of - Just (tp,(sp,_)) -> return $ Just (tp,sp) - _ -> defaultIntDecomp (Set.findMin vars) $ Just typs - else do - let lp = Set.findMin sp - let Just jmp = mp - let Just j = fdspIntSpec jmp $ Just lp - return $ Just (lp,j) - -getIntSpec :: FDSolver s => EGVarId -> FDInstance s (Maybe (FDIntSpec s)) -getIntSpec var = do - s <- allIntSpec - q <- getIntSpec_ var s - return $ case q of - Just (_,x) -> Just x - Nothing -> Nothing - -getColSpec_ :: FDSolver s => EGVarId -> FDColSpecTypeSet s -> FDInstance s (Maybe (FDColSpecType s, FDColSpec s)) -getColSpec_ var typs = do - s <- get - let vars = Map.findWithDefault (Set.singleton var) var $ fdsColUnifies s - getColSpec__ vars typs - -getColSpec__ :: FDSolver s => Set EGVarId -> FDColSpecTypeSet s -> FDInstance s (Maybe (FDColSpecType s, FDColSpec s)) -getColSpec__ vars typs = do - s <- get - let mp = foldl (\b a -> case Map.lookup a (fdsColVars s) of { Nothing -> b; Just x -> case b of { Nothing -> Just x; Just r -> Just $ unionSpecCol r x }}) Nothing (Set.toList vars) - let sp = Set.intersection (maybe Set.empty fdspColTypes mp) typs - let db = fdsDb s - if Set.null sp - then if not (Set.null $ Set.intersection vars $ fdsColVarBusy s) - then return Nothing - else do - put $ s { fdsColVarBusy = Set.union vars $ fdsColVarBusy s } - res <- decompSpec addColVar db (\x -> Map.lookup x $ fdsColUnifies s) unifyCols fdsColSel vars typs - s2 <- get - put $ s2 { fdsColVarBusy = Set.difference (fdsColVarBusy s) vars } - case res of - Just (tp,(sp,_)) -> return $ Just (tp,sp) - _ -> return Nothing - else do - let lp = Set.findMin sp - let Just jmp = mp - let Just j = fdspColSpec jmp $ Just lp - return $ Just (lp,j) - -getColSpec :: (Show (FDColSpec s), FDSolver s) => EGVarId -> FDInstance s (Maybe (FDColSpec s)) -getColSpec var = do - s <- allColSpec - q <- getColSpec_ var s - return $ case q of - Just (_,x) -> Just x - Nothing -> Nothing - --- | initial FDState state -baseFDState :: FDSolver s => FDState s -baseFDState = FDState { - fdsVars = 0, - fdsExpr = BoolConst True, - fdsForceBool = [], - fdsForcedBool = Map.empty, - fdsForceInt = [], - fdsForcedInt = Map.empty, - fdsForceCol = [], - fdsModel = Nothing, - fdsNewEdges = Set.empty, - fdsDoneEdges = Set.empty, - fdsDecomp = baseDecompData, - fdsIntVars = Map.empty, - fdsIntVarTypes = Map.empty, - fdsIntVarBusy = Set.empty, - fdsIntUnifies = Map.empty, - fdsBoolVars = Map.empty, - fdsBoolVarTypes = Map.empty, - fdsBoolVarBusy = Set.empty, - fdsBoolUnifies = Map.empty, - fdsColVars = Map.empty, - fdsColVarTypes = Map.empty, - fdsColVarBusy = Set.empty, - fdsColUnifies = Map.empty, - fdsDb = Map.empty, - fdsFailed = False, - fdsLevel = 0, - fdsDummyLevel = 0, - fdsMinimizeVar = Nothing, - fdsMinimizeTerm = Nothing -} - -edgesLeft :: FDSolver s => FDInstance s Bool -edgesLeft = get >>= return . Set.null . fdsNewEdges - --- | run the second argument as long as the first one produces true -whileM :: Monad m => m Bool -> m a -> m () -whileM cond act = do - x <- cond - if x - then do - act - whileM cond act - else return () - -whileM_ :: Monad m => m Bool -> m () -whileM_ cond = whileM cond $ return () - --- | a label for an FDInstance; must store the FDState plus the Solver's internal state -data FDSolver s => FDLabel s = FDLabel { - fdlState :: FDState s, - fdlLabel :: Label s -} - --- | definition of FDInstance, a Solver wrapper that adds power to post boolean expressions as constraints -newtype FDSolver s => FDInstance s a = FDInstance { unFDInstance :: StateT (FDState s) s a } - deriving (Monad, MonadState (FDState s)) - --- | helper function to combine two Maybe's -joinWith :: (a -> a -> a) -> Maybe a -> Maybe a -> Maybe a -joinWith f a b = case (a,b) of - (Nothing,_) -> b - (_,Nothing) -> a - (Just x,Just y) -> Just $ f x y - --- | lift a monad action for the underlying solver to a monad action for an FDInstance around it -liftFD :: FDSolver s => s a -> FDInstance s a -liftFD = FDInstance . lift - -liftFDTree :: (FDSolver s, MonadTree m, TreeSolver m ~ (FDInstance s)) => Tree s a -> m a -liftFDTree = mapTree liftFD - -data SpecResult t = - SpecResNone - | SpecResSpec t - | SpecResUnify EGVarId - -type SpecBool s = FDInstance s (SpecResult (FDBoolSpecType s, s (FDBoolSpec s, Maybe EGBoolPar))) -type SpecInt s = FDInstance s (SpecResult (FDIntSpecType s, s (FDIntSpec s, Maybe EGPar))) -type SpecCol s = FDInstance s (SpecResult (FDColSpecType s, s (FDColSpec s, Maybe EGColPar))) - -type SpecFnRes s = - ( - [(Int, EGVarId, Bool, SpecBool s)], - [(Int, EGVarId, Bool, SpecInt s)], - [(Int, EGVarId, Bool, SpecCol s)] - ) - -type SpecFn s = EGEdge -> SpecFnRes s - -data TermType = FDTBool | FDTInt | FDTCol - deriving (Eq,Ord,Bounded,Enum,Show) - -fdsBoolSel x = case x of - FDSBool a -> Just a - _ -> Nothing -fdsIntSel x = case x of - FDSInt a -> Just a - _ -> Nothing -fdsColSel x = case x of - FDSCol a -> Just a - _ -> Nothing - -data TermTypeSpec s = FDSBool (SpecBool s) | FDSInt (SpecInt s) | FDSCol (SpecCol s) - -instance Show (TermTypeSpec s) where - show (FDSBool _) = "FDSBool" - show (FDSInt _) = "FDSInt" - show (FDSCol _) = "FDSCol" - -type SpecDb s = Map (Int,TermType,EGVarId) (Maybe EGEdgeId,TermTypeSpec s) - -addBoolSpec :: FDSolver s => SpecDb s -> (Int,EGVarId,Maybe EGEdgeId,SpecBool s) -> SpecDb s -addBoolSpec db (prio,var,eid,spec) = Map.insert (prio,FDTBool,var) (eid,FDSBool spec) db - -addIntSpec :: FDSolver s => SpecDb s -> (Int,EGVarId,Maybe EGEdgeId,SpecInt s) -> SpecDb s -addIntSpec db (prio,var,eid,spec) = Map.insert (prio,FDTInt,var) (eid,FDSInt spec) db - -addColSpec :: FDSolver s => SpecDb s -> (Int,EGVarId,Maybe EGEdgeId,SpecCol s) -> SpecDb s -addColSpec db (prio,var,eid,spec) = Map.insert (prio,FDTCol,var) (eid,FDSCol spec) db - -emptyFDSpecInfoBool :: FDSolver s => EGVarId -> FDState s -> FDSpecInfoBool s -emptyFDSpecInfoBool v s = FDSpecInfoBool { fdspBoolSpec = const Nothing, fdspBoolVar = Just v, fdspBoolVal = getBoolVal_ v s, fdspBoolTypes = Set.empty } -emptyFDSpecInfoInt :: FDSolver s => EGVarId -> FDState s -> FDSpecInfoInt s -emptyFDSpecInfoInt v s = FDSpecInfoInt { fdspIntSpec = const Nothing, fdspIntVar = Just v, fdspIntVal = getIntVal_ v s, fdspIntTypes = Set.empty } -emptyFDSpecInfoCol :: FDSolver s => EGVarId -> FDState s -> FDSpecInfoCol s -emptyFDSpecInfoCol v s = FDSpecInfoCol { fdspColSpec = const Nothing, fdspColVar = Just v, fdspColVal = getColVal_ v s, fdspColTypes = Set.empty } - -data FDSpecInfoBool s = FDSpecInfoBool { fdspBoolSpec :: Maybe (FDBoolSpecType s) -> Maybe (FDBoolSpec s), fdspBoolVar :: Maybe EGVarId, fdspBoolVal :: Maybe EGBoolPar, fdspBoolTypes :: Set (FDBoolSpecType s) } -data FDSpecInfoInt s = FDSpecInfoInt { fdspIntSpec :: Maybe (FDIntSpecType s) -> Maybe (FDIntSpec s), fdspIntVar :: Maybe EGVarId, fdspIntVal :: Maybe EGPar, fdspIntTypes :: Set (FDIntSpecType s) } -data FDSpecInfoCol s = FDSpecInfoCol { fdspColSpec :: Maybe (FDColSpecType s) -> Maybe (FDColSpec s), fdspColVar :: Maybe EGVarId, fdspColVal :: Maybe EGColPar, fdspColTypes :: Set (FDColSpecType s) } - -unionSpecBool (FDSpecInfoBool { fdspBoolSpec = s1, fdspBoolVar = n1, fdspBoolVal = v1, fdspBoolTypes = t1 }) (FDSpecInfoBool { fdspBoolSpec = s2, fdspBoolVar = n2, fdspBoolVal = v2, fdspBoolTypes = t2 }) = - FDSpecInfoBool { fdspBoolSpec = \t -> (s1 t) `mplus` (s2 t), fdspBoolVal = v1 `mplus` v2, fdspBoolVar = n1 `mplus` n2, fdspBoolTypes = Set.union t1 t2 } -unionSpecInt (FDSpecInfoInt { fdspIntSpec = s1, fdspIntVar = n1, fdspIntVal = v1, fdspIntTypes = t1 }) (FDSpecInfoInt { fdspIntSpec = s2, fdspIntVar = n2, fdspIntVal = v2, fdspIntTypes = t2 }) = - FDSpecInfoInt { fdspIntSpec = \t -> (s1 t) `mplus` (s2 t), fdspIntVal = v1 `mplus` v2, fdspIntVar = n1 `mplus` n2, fdspIntTypes = Set.union t1 t2 } -unionSpecCol (FDSpecInfoCol { fdspColSpec = s1, fdspColVar = n1, fdspColVal = v1, fdspColTypes = t1 }) (FDSpecInfoCol { fdspColSpec = s2, fdspColVar = n2, fdspColVal = v2, fdspColTypes = t2 }) = - FDSpecInfoCol { fdspColSpec = \t -> (s1 t) `mplus` (s2 t), fdspColVal = v1 `mplus` v2, fdspColVar = n1 `mplus` n2, fdspColTypes = Set.union t1 t2 } - -instance (Ord (FDBoolSpec s), Ord (FDBoolSpecType s)) => Eq (FDSpecInfoBool s) where - a == b = (compare a b) == EQ -instance (Ord (FDBoolSpec s), Ord (FDBoolSpecType s)) => Ord (FDSpecInfoBool s) where - compare (FDSpecInfoBool { fdspBoolSpec = s1, fdspBoolVar = r1, fdspBoolVal = v1, fdspBoolTypes = t1 }) (FDSpecInfoBool { fdspBoolSpec = s2, fdspBoolVar = r2, fdspBoolVal = v2, fdspBoolTypes = t2 }) = - compare r1 r2 <<>> compare v1 v2 <<>> compare (s1 Nothing) (s2 Nothing) <<>> compare (Map.fromList $ map (\x -> (x,s1 $ Just x)) $ Set.toList t1) (Map.fromList $ map (\x -> (x,s2 $ Just x)) $ Set.toList t2) - -instance (Ord (FDIntSpec s), Ord (FDIntSpecType s)) => Eq (FDSpecInfoInt s) where - a == b = (compare a b) == EQ -instance (Ord (FDIntSpec s), Ord (FDIntSpecType s)) => Ord (FDSpecInfoInt s) where - compare (FDSpecInfoInt { fdspIntSpec = s1, fdspIntVar = r1, fdspIntVal = v1, fdspIntTypes = t1 }) (FDSpecInfoInt { fdspIntSpec = s2, fdspIntVar = r2, fdspIntVal = v2, fdspIntTypes = t2 }) = - compare r1 r2 <<>> compare v1 v2 <<>> compare (s1 Nothing) (s2 Nothing) <<>> compare (Map.fromList $ map (\x -> (x,s1 $ Just x)) $ Set.toList t1) (Map.fromList $ map (\x -> (x,s2 $ Just x)) $ Set.toList t2) - -instance (Ord (FDColSpec s), Ord (FDColSpecType s)) => Eq (FDSpecInfoCol s) where - a == b = (compare a b) == EQ -instance (Ord (FDColSpec s), Ord (FDColSpecType s)) => Ord (FDSpecInfoCol s) where - compare (FDSpecInfoCol { fdspColSpec = s1, fdspColVar = r1, fdspColVal = v1, fdspColTypes = t1 }) (FDSpecInfoCol { fdspColSpec = s2, fdspColVar = r2, fdspColVal = v2, fdspColTypes = t2 }) = - compare r1 r2 <<>> compare v1 v2 <<>> compare (s1 Nothing) (s2 Nothing) <<>> compare (Map.fromList $ map (\x -> (x,s1 $ Just x)) $ Set.toList t1) (Map.fromList $ map (\x -> (x,s2 $ Just x)) $ Set.toList t2) - -specInfoMapBool :: FDSolver s => FDSpecInfoBool s -> Map (FDBoolSpecType s) (FDBoolSpec s) -specInfoMapBool (FDSpecInfoBool { fdspBoolSpec = f, fdspBoolTypes = t }) = Map.fromList $ map (\t -> (t,myFromJust "specInfoMapBool" $ f $ Just t)) $ Set.toList t - -specInfoMapInt :: FDSolver s => FDSpecInfoInt s -> Map (FDIntSpecType s) (FDIntSpec s) -specInfoMapInt (FDSpecInfoInt { fdspIntSpec = f, fdspIntTypes = t }) = Map.fromList $ map (\t -> (t,myFromJust "specInfoMapInt" $ f $ Just t)) $ Set.toList t - -specInfoMapCol :: FDSolver s => FDSpecInfoCol s -> Map (FDColSpecType s) (FDColSpec s) -specInfoMapCol (FDSpecInfoCol { fdspColSpec = f, fdspColTypes = t }) = Map.fromList $ map (\t -> (t,myFromJust "specInfoMapCol" $ f $ Just t)) $ Set.toList t - -specInfoBoolTerm :: FDSolver s => FDBoolTerm s -> s (FDSpecInfoBool s) -specInfoBoolTerm t = do - let (tp,sp) = fdBoolSpec_term t - s <- sp - return $ FDSpecInfoBool { fdspBoolSpec = \t -> case t of { Nothing -> Just s; Just tt | tp==tt -> Just s; _ -> Nothing }, fdspBoolVar = Nothing, fdspBoolVal = Nothing, fdspBoolTypes = Set.singleton tp } - -specInfoIntTerm :: FDSolver s => FDIntTerm s -> s (FDSpecInfoInt s) -specInfoIntTerm t = do - let (tp,sp) = fdIntSpec_term t - s <- sp - return $ FDSpecInfoInt { fdspIntSpec = \t -> case t of { Nothing -> Just s; Just tt | tp==tt -> Just s; _ -> Nothing }, fdspIntVar = Nothing, fdspIntVal = Nothing, fdspIntTypes = Set.singleton tp } - -instance Show (FDBoolSpec s) => Show (FDSpecInfoBool s) where - show (FDSpecInfoBool { fdspBoolSpec = f, fdspBoolVar = e, fdspBoolVal = v }) = "FSSpecInfoBool { default:" ++ (show $ f Nothing) ++ ", var:" ++ (show e) ++ ", val:" ++ (show v) ++ "}" -instance Show (FDIntSpec s) => Show (FDSpecInfoInt s) where - show (FDSpecInfoInt { fdspIntSpec = f, fdspIntVar = e, fdspIntVal = v }) = "FSSpecInfoInt { default:" ++ (show $ f Nothing) ++ ", var:" ++ (show e) ++ ", val:" ++ (show v) ++ "}" -instance Show (FDColSpec s) => Show (FDSpecInfoCol s) where - show (FDSpecInfoCol { fdspColSpec = f, fdspColVar = e, fdspColVal = v }) = "FSSpecInfoCol { default:" ++ (show $ f Nothing) ++ ", var:" ++ (show e) ++ ", val:" ++ (show v) ++ "}" - -type FDSpecInfo s = ([FDSpecInfoBool s],[FDSpecInfoInt s],[FDSpecInfoCol s]) - -fdSpecInfo_edge :: FDSolver s => EGEdgeId -> FDInstance s (FDSpecInfo s) -fdSpecInfo_edge f = do - s <- get - let edge = getJustEdge f s - intS p = Map.findWithDefault (emptyFDSpecInfoInt p s) p $ fdsIntVars s - boolS p = Map.findWithDefault (emptyFDSpecInfoBool p s) p $ fdsBoolVars s - colS p = Map.findWithDefault (emptyFDSpecInfoCol p s) p $ fdsColVars s --- an m x = case x of --- Just i -> Map.lookup i m --- Nothing -> if Map.null m then Nothing else Just $ snd $ Map.findMin m --- boolX v = FDSpecInfoBool { fdspBoolSpec = an $ boolS v, fdspBoolVar = Just v, fdspBoolVal = getBoolVal_ v s, fdspBoolTypes = Set.fromList $ Map.keys $ boolS v } --- intX v = FDSpecInfoInt { fdspIntSpec = an $ intS v, fdspIntVar = Just v, fdspIntVal = getIntVal_ v s, fdspIntTypes = Set.fromList $ Map.keys $ intS v } --- colX v = FDSpecInfoCol { fdspColSpec = an $ colS v, fdspColVar = Just v, fdspColVal = getColVal_ v s, fdspColTypes = Set.fromList $ Map.keys $ colS v } - return (map boolS $ boolData $ egeLinks edge, map intS $ intData $ egeLinks edge, map colS $ colData $ egeLinks edge) - -fdSpecInfo_spec :: FDSolver s => ([Either (FDSpecInfoBool s) (FDBoolSpecType s,FDBoolSpec s)],[Either (FDSpecInfoInt s) (FDIntSpecType s,FDIntSpec s)],[Either (FDSpecInfoCol s) (FDColSpecType s,FDColSpec s)]) -> FDSpecInfo s -fdSpecInfo_spec (b,i,c) = (fdSpecInfo_spec_b b, fdSpecInfo_spec_i i, fdSpecInfo_spec_c c) - -fdSpecInfo_spec_b :: FDSolver s => [Either (FDSpecInfoBool s) (FDBoolSpecType s,FDBoolSpec s)] -> [FDSpecInfoBool s] -fdSpecInfo_spec_b b = - let fb (Right x) = FDSpecInfoBool { fdspBoolSpec = nt x, fdspBoolVar = Nothing, fdspBoolVal = Nothing, fdspBoolTypes = Set.singleton $ fst x } - fb (Left x) = x - nt (_,x) Nothing = Just x - nt (t1,x) (Just t2) | t1==t2 = Just x - nt _ _ = Nothing - in (map fb b) - -fdSpecInfo_spec_i :: FDSolver s => [Either (FDSpecInfoInt s) (FDIntSpecType s,FDIntSpec s)] -> [FDSpecInfoInt s] -fdSpecInfo_spec_i i = - let fi (Right x) = FDSpecInfoInt { fdspIntSpec = nt x, fdspIntVar = Nothing, fdspIntVal = Nothing, fdspIntTypes = Set.singleton $ fst x } - fi (Left x) = x - nt (_,x) Nothing = Just x - nt (t1,x) (Just t2) | t1==t2 = Just x - nt _ _ = Nothing - in (map fi i) - -fdSpecInfo_spec_c :: FDSolver s => [Either (FDSpecInfoCol s) (FDColSpecType s,FDColSpec s)] -> [FDSpecInfoCol s] -fdSpecInfo_spec_c c = - let fc (Right x) = FDSpecInfoCol { fdspColSpec = nt x, fdspColVar = Nothing, fdspColVal = Nothing, fdspColTypes = Set.singleton $ fst x } - fc (Left x) = x - nt (_,x) Nothing = Just x - nt (t1,x) (Just t2) | t1==t2 = Just x - nt _ _ = Nothing - in (map fc c) - --- | A solver needs to be an instance of this FDSolver class in order to --- create an FDInstance around it. -class - ( - Solver s, - Term s (FDIntTerm s), - Term s (FDBoolTerm s), - Eq (FDBoolSpecType s), Ord (FDBoolSpecType s), Enum (FDBoolSpecType s), Bounded (FDBoolSpecType s), Show (FDBoolSpecType s), - Eq (FDIntSpecType s), Ord (FDIntSpecType s), Enum (FDIntSpecType s), Bounded (FDIntSpecType s), Show (FDIntSpecType s), - Eq (FDColSpecType s), Ord (FDColSpecType s), Enum (FDColSpecType s), Bounded (FDColSpecType s), Show (FDColSpecType s), --- Integral (TermBaseType s (FDIntTerm s)), Num (TermBaseType s (FDBoolTerm s)), - Show (FDIntSpec s), Show (FDColSpec s), Show (FDBoolSpec s) - ) => FDSolver s where - -- term types - type FDIntTerm s :: * -- a Term of s, representing Integer variables - type FDBoolTerm s :: * -- a Term of s, representing Bool variables - -- spec types - type FDIntSpec s :: * -- a type specifying an Integer expression; should at least support constant Integer's and FDIntTerm's - type FDBoolSpec s :: * -- a type specifying a Bool expression; should at least support constant Bool's and FDBoolTerm's - type FDColSpec s :: * -- a type specifying a Integer array expression; should at least support lists of Int's and lists of IntTerm's - -- spec type type - type FDIntSpecType s :: * -- a type specifying the type of an FDIntSpec s, in case there is more than one - type FDBoolSpecType s :: * -- a type specifying the type of an FDIntSpec s, in case there is more than one - type FDColSpecType s :: * -- a type specifying the type of an FDIntSpec s, in case there is more than one - - - -- constructors for specifiers - fdIntSpec_const :: EGPar -> (FDIntSpecType s, s (FDIntSpec s)) - fdBoolSpec_const :: EGBoolPar -> (FDBoolSpecType s, s (FDBoolSpec s)) - fdColSpec_const :: EGColPar -> (FDColSpecType s, s (FDColSpec s)) - fdColSpec_list :: [FDIntSpec s] -> (FDColSpecType s, s (FDColSpec s)) - fdIntSpec_term :: FDIntTerm s -> (FDIntSpecType s, s (FDIntSpec s)) - fdBoolSpec_term :: FDBoolTerm s -> (FDBoolSpecType s, s (FDBoolSpec s)) - fdColSpec_size :: EGPar -> (FDColSpecType s, s (FDColSpec s)) - fdIntVarSpec :: FDIntSpec s -> s (Maybe (FDIntTerm s)) - fdBoolVarSpec :: FDBoolSpec s -> s (Maybe (FDBoolTerm s)) - - -- function to inform about allowed types for nodes - fdTypeReqBool :: s (EGEdge -> [(EGVarId,FDBoolSpecTypeSet s)]) - fdTypeReqInt :: s (EGEdge -> [(EGVarId,FDIntSpecTypeSet s)]) - fdTypeReqCol :: s (EGEdge -> [(EGVarId,FDColSpecTypeSet s)]) - fdTypeReqBool = return (\(EGEdge { egeLinks = EGTypeData { boolData = l } }) -> map (\x -> (x,Set.fromList [minBound..maxBound])) l) - fdTypeReqInt = return (\(EGEdge { egeLinks = EGTypeData { intData = l } }) -> map (\x -> (x,Set.fromList [minBound..maxBound])) l) - fdTypeReqCol = return (\(EGEdge { egeLinks = EGTypeData { colData = l } }) -> map (\x -> (x,Set.fromList [minBound..maxBound])) l) - - fdTypeVarInt :: s (Set (FDIntSpecType s)) - fdTypeVarBool :: s (Set (FDBoolSpecType s)) - fdTypeVarInt = return $ Set.singleton maxBound - fdTypeVarBool = return $ Set.singleton maxBound - - -- rating functions for specification of terms - fdSpecify :: Mixin (SpecFn s) - fdSpecify = mixinId - - -- inspect collections - fdColInspect :: FDColSpec s -> s [FDIntTerm s] - - -- function to request processing an edge in a graph - fdProcess :: Mixin (EGConstraintSpec -> FDSpecInfo s -> FDInstance s ()) - - -- add equality constraints - fdEqualBool :: FDBoolSpec s -> FDBoolSpec s -> FDInstance s () - fdEqualInt :: FDIntSpec s -> FDIntSpec s -> FDInstance s () - fdEqualCol :: FDColSpec s -> FDColSpec s -> FDInstance s () - - fdConstrainIntTerm :: FDIntTerm s -> Integer -> s (Constraint s) - fdSplitIntDomain :: FDIntTerm s -> s ([Constraint s],Bool) - fdSplitBoolDomain :: FDBoolTerm s -> s ([Constraint s],Bool) - -fdGetValBool :: (FDSolver s, EnumTerm s (FDBoolTerm s)) => FDBoolSpec s -> s (Maybe (TermBaseType s (FDBoolTerm s))) -fdGetValInt :: (FDSolver s, EnumTerm s (FDIntTerm s)) => FDIntSpec s -> s (Maybe (TermBaseType s (FDIntTerm s))) - -fdGetValBool s = fdBoolVarSpec s >>= \x -> case x of - Just t -> getValue t - _ -> return Nothing - -fdGetValInt s = fdIntVarSpec s >>= \x -> case x of - Just t -> getValue t - _ -> return Nothing - -type FDBoolSpecTypeSet s = Set (FDBoolSpecType s) -type FDIntSpecTypeSet s = Set (FDIntSpecType s) -type FDColSpecTypeSet s = Set (FDColSpecType s) - -fdCombineSpecify :: FDSolver s => SpecFn s -> SpecFn s -> SpecFn s -fdCombineSpecify a b edge = - let (a1,a2,a3) = a edge - (b1,b2,b3) = b edge - in (a1++b1,a2++b2,a3++b3) - -procEdge :: FDSolver s => FDInstance s Bool -procEdge = do - s <- get - if (Set.null $ fdsNewEdges s) - then return False - else do - let f = Set.findMin $ fdsNewEdges s - edge = getJustEdge f s - debug ("procEdge("++(show f)++")") $ return () - info <- fdSpecInfo_edge f - full_fdProcess (egeCons edge) info - debug ("procEdge: marking edge "++(show f)) $ return () - markEdge f - s2 <- get - return $ not $ Set.null $ fdsNewEdges s2 - -getEdge :: FDSolver s => EGEdgeId -> FDInstance s (Maybe EGEdge) -getEdge id = do - s <- get - return $ do - v <- fdsModel s - Map.lookup id $ egmEdges v - -markEdge :: FDSolver s => EGEdgeId -> FDInstance s () -markEdge id = do - s <- get - debug ("markEdge: "++(show $ id)) $ return () - put $ s { fdsNewEdges = Set.delete id $ fdsNewEdges s, fdsDoneEdges = Set.insert id $ fdsDoneEdges s } - -sureMaybe :: [Maybe a] -> Maybe [a] -sureMaybe [] = Just [] -sureMaybe (Nothing:_) = Nothing -sureMaybe ((Just a):b) = case sureMaybe b of - Nothing -> Nothing - Just l -> Just (a:l) - -allIntSpec :: FDSolver s => FDInstance s (Set (FDIntSpecType s)) -allIntSpec = return $ Set.fromList [minBound..maxBound] - -allBoolSpec :: FDSolver s => FDInstance s (Set (FDBoolSpecType s)) -allBoolSpec = return $ Set.fromList [minBound..maxBound] - -allColSpec :: FDSolver s => FDInstance s (Set (FDColSpecType s)) -allColSpec = return $ Set.fromList [minBound..maxBound] - -default_fdSpecify :: FDSolver s => SpecFn s -default_fdSpecify edge = case (debug ("default_fdSpecify("++(show edge)++")") edge) of - EGEdge { egeCons = EGIntValue c, egeLinks = EGTypeData { intData = [v] } } -> - ([],[(1000,v,True,do - let (tp, m) = fdIntSpec_const c - return $ SpecResSpec (tp,m >>= (\x -> return (x, Just c))) - )],[]) - EGEdge { egeCons = EGBoolValue c, egeLinks = EGTypeData { boolData = [v] } } -> - ([(1000,v,True,do - let (tp, m) = fdBoolSpec_const c - return $ SpecResSpec (tp, m >>= (\x -> return (x, Just c))) - )],[],[]) - EGEdge { egeCons = EGColValue c, egeLinks = EGTypeData { colData = [v] } } -> - ([],[],[(990,v,True,do - let (tp, m) = fdColSpec_const c - return $ SpecResSpec (tp, m >>= (\x -> return (x, Just c))) - )]) - EGEdge { egeCons = EGList s, egeLinks = EGTypeData { colData = [c], intData = l } } -> - ([],[],[(500,c,True,do - x <- mapM (\x -> getIntSpec x) l - case sureMaybe x of - Nothing -> return SpecResNone - Just ll -> do - let (tp, m) = fdColSpec_list ll - return $ SpecResSpec $ (tp, m >>= (\x -> return (x, Nothing))) - )]) - EGEdge { egeCons = EGSize, egeLinks = EGTypeData { colData = [c], intData=[s] } } -> - ([],[],[(250,c,True,do - ss <- get - let k = getIntVal_ s ss - case k of - Nothing -> return SpecResNone - Just ll -> do - let (tp, m) = fdColSpec_size ll - return $ SpecResSpec $ (tp, m >>= (\x -> return (x, Nothing))) - )]) - EGEdge { egeCons = EGRange, egeLinks = EGTypeData { colData = [c], intData=[l,h] } } -> - ([],[],[(250,c,False,do - ss <- get - let ll = getIntVal_ l ss - hh = getIntVal_ h ss - case (ll,hh) of - (Just (Const jl), Just (Const jh)) -> do - let (tp,m) = fdColSpec_size (Const $ jh-jl+1) - return $ SpecResSpec $ (tp, m >>= (\x -> return (x, Just $ ColList [Const x | x <- [jl..jh]]))) - (Just jl, Just jh) -> do - let (tp,m) = fdColSpec_size (jh-jl+1) - return $ SpecResSpec $ (tp, m >>= (\x -> return (x, Nothing))) - _ -> return SpecResNone - )]) - _ -> ([],[],[]) - -default_fdProcess :: FDSolver s => EGConstraintSpec -> FDSpecInfo s -> FDInstance s () -default_fdProcess cons _ = error $ "Cannot process "++(show cons) - --- | mark all new edges(=constraints) of a model given in graph-form as to-be-processed -initForModel :: FDSolver s => FDInstance s () -initForModel = do - s <- get - let Just model = fdsModel s - put $ s { - fdsNewEdges = Set.difference (Set.union (fdsNewEdges s) $ Set.fromList $ Map.keys $ egmEdges model) $ fdsDoneEdges s - } - -setAlter :: Ord a => a -> Maybe (Set (Set a)) -> Maybe (Set (Set a)) -setAlter _ Nothing = Nothing -setAlter typ (Just x) = let f = fl x in if Set.null f then Nothing else Just f - where fl = Set.filter $ not . Set.member typ - -addSpecInt :: FDSolver s => FDIntSpecType s -> (FDIntSpec s, Maybe EGPar) -> EGVarId -> FDState s -> Maybe (FDSpecInfoInt s) -> Maybe (FDSpecInfoInt s) -addSpecInt tp def id s Nothing = addSpecInt tp def id s (Just $ emptyFDSpecInfoInt id s) -addSpecInt tp (def,val) _ _ (Just (m@(FDSpecInfoInt { fdspIntSpec = f, fdspIntTypes = t }))) = - Just $ m { - fdspIntSpec = \x -> case x of - Just tt | tt==tp -> Just $ def - Nothing -> case f Nothing of - Nothing -> Just def - Just ttt -> Just ttt - k -> f k, - fdspIntTypes = Set.insert tp t, - fdspIntVal = case val of - Nothing -> fdspIntVal m - _ -> val - } - -addSpecBool :: FDSolver s => FDBoolSpecType s -> (FDBoolSpec s, Maybe EGBoolPar) -> EGVarId -> FDState s -> Maybe (FDSpecInfoBool s) -> Maybe (FDSpecInfoBool s) -addSpecBool tp def id s Nothing = addSpecBool tp def id s (Just $ emptyFDSpecInfoBool id s) -addSpecBool tp (def,val) _ _ (Just (m@(FDSpecInfoBool { fdspBoolSpec = f, fdspBoolTypes = t }))) = - Just $ m { - fdspBoolSpec = \x -> case x of - Just tt | tt==tp -> Just $ def - Nothing -> case f Nothing of - Nothing -> Just def - Just ttt -> Just ttt - k -> f k, - fdspBoolTypes = Set.insert tp t, - fdspBoolVal = case val of - Nothing -> fdspBoolVal m - _ -> val - } - -addSpecCol :: FDSolver s => FDColSpecType s -> (FDColSpec s, Maybe EGColPar) -> EGVarId -> FDState s -> Maybe (FDSpecInfoCol s) -> Maybe (FDSpecInfoCol s) -addSpecCol tp def id s Nothing = addSpecCol tp def id s (Just $ emptyFDSpecInfoCol id s) -addSpecCol tp (def,val) _ _ (Just (m@(FDSpecInfoCol { fdspColSpec = f, fdspColTypes = t }))) = - Just $ m { - fdspColSpec = \x -> case x of - Just tt | tt==tp -> Just $ def - Nothing -> case f Nothing of - Nothing -> Just def - Just ttt -> Just ttt - k -> f k, - fdspColTypes = Set.insert tp t, - fdspColVal = case val of - Nothing -> fdspColVal m - _ -> val - } - --- | add an int term -addIntVar :: FDSolver s => EGVarId -> FDIntSpecType s -> (FDIntSpec s, Maybe EGPar) -> FDInstance s () -addIntVar id typ (spec@(rs,_)) = do --- debug ("addIntVar id="++(show id)++" typ="++(show typ)++" spec="++(show spec)) $ return () - s <- get - case (Map.lookup id $ fdsIntVars s) of - Just t | not (Set.null $ fdspIntTypes t) -> case (fdspIntSpec t Nothing) of - Just x -> fdEqualInt rs x - Nothing -> case fdspIntSpec t $ Just $ Set.findMax $ fdspIntTypes t of - Just x -> fdEqualInt rs x - Nothing -> return () - _ -> return () - s2 <- get - put $ s2 - { - fdsIntVars = Map.alter (addSpecInt typ spec id s2) id $ fdsIntVars s2, - fdsIntVarBusy = Set.delete id $ fdsIntVarBusy s2, - fdsIntVarTypes = Map.alter (setAlter typ) id $ fdsIntVarTypes s2 - } - --- | add a bool term -addBoolVar :: FDSolver s => EGVarId -> FDBoolSpecType s -> (FDBoolSpec s, Maybe EGBoolPar) -> FDInstance s () -addBoolVar id typ (spec@(rs,_)) = do --- debug ("addBoolVar id="++(show id)++" typ="++(show typ)++" spec="++(show spec)) $ return () - s <- get - case (Map.lookup id $ fdsBoolVars s) of - Just t | not (Set.null $ fdspBoolTypes t) -> case (fdspBoolSpec t Nothing) of - Just x -> fdEqualBool rs x - Nothing -> case fdspBoolSpec t $ Just $ Set.findMax $ fdspBoolTypes t of - Just x -> fdEqualBool rs x - Nothing -> return () - _ -> return () - s2 <- get - put $ s2 - { - fdsBoolVars = Map.alter (addSpecBool typ spec id s2) id $ fdsBoolVars s2, - fdsBoolVarBusy = Set.delete id $ fdsBoolVarBusy s2, - fdsBoolVarTypes = Map.alter (setAlter typ) id $ fdsBoolVarTypes s2 - } - --- | add a col term -addColVar :: FDSolver s => EGVarId -> FDColSpecType s -> (FDColSpec s, Maybe EGColPar) -> FDInstance s () -addColVar id typ (spec@(rs,_)) = do --- debug ("addColVar id="++(show id)++" typ="++(show typ)++" spec="++(show spec)) $ return () - s <- get - case (Map.lookup id $ fdsColVars s) of - Just t | not (Set.null $ fdspColTypes t) -> case (fdspColSpec t Nothing) of - Just x -> fdEqualCol rs x - Nothing -> case fdspColSpec t $ Just $ Set.findMax $ fdspColTypes t of - Just x -> fdEqualCol rs x - Nothing -> return () - _ -> return () - s2 <- get - put $ s2 - { - fdsColVars = Map.alter (addSpecCol typ spec id s2) id $ fdsColVars s2, - fdsColVarBusy = Set.delete id $ fdsColVarBusy s2, - fdsColVarTypes = Map.alter (setAlter typ) id $ fdsColVarTypes s2 - } - -full_fdProcess :: FDSolver s => EGConstraintSpec -> FDSpecInfo s -> FDInstance s () -full_fdProcess = mixin (fdProcess <@> mixinLift default_fdProcess) - -full_fdSpecify :: FDSolver s => SpecFn s -full_fdSpecify = mixin (fdSpecify <@> mixinLift default_fdSpecify) - - -getJustEdge :: FDSolver s => EGEdgeId -> FDState s -> EGEdge -getJustEdge i s = - let Just m = fdsModel s - Just x = Map.lookup i (egmEdges m) - in x - -buildSpecDb :: FDSolver s => FDInstance s () -buildSpecDb = do - s <- get - let origDb = fdsDb s - ne = debug "bsdb: ne" $ map (\k -> (k,getJustEdge k s)) $ Set.toList $ debug "bsbd: fdsne" $ fdsNewEdges s - proc db (eid,edge) = do - let (lB,lI,lC) = debug ("bsbd: specify("++(show edge)++")") $ full_fdSpecify edge - dB = foldr (\(prio,var,full,spec) d -> debug "bsbd: addbool" $ addBoolSpec d (prio,var,if full then Just eid else Nothing,spec)) db $ debug ("lB["++(show $ length lB)++"]") lB - dI = foldr (\(prio,var,full,spec) d -> debug "bsbd: addint" $ addIntSpec d (prio,var,if full then Just eid else Nothing,spec)) dB $ debug ("lI["++(show $ length lI)++"]") lI - dC = foldr (\(prio,var,full,spec) d -> debug "bsbd: addcol" $ addColSpec d (prio,var,if full then Just eid else Nothing,spec)) dI $ debug ("lC["++(show $ length lC)++"]") lC - in dC - newDb = foldl proc origDb ne - put $ s { fdsDb = newDb } - -addBoolTypeReq :: FDSolver s => EGVarId -> FDBoolSpecTypeSet s -> FDInstance s () -addBoolTypeReq var set = do - s <- get - let chk tp = case Map.lookup var (fdsBoolVars s) of - Nothing -> False - Just x -> Set.member tp (fdspBoolTypes x) - sset = Map.findWithDefault Set.empty var (fdsBoolVarTypes s) - if Set.member set sset - then return () - else if any chk (Set.toList set) - then return () - else do - let nsset = Set.insert set sset - put $ s - { - fdsBoolVarTypes = Map.insert var nsset $ fdsBoolVarTypes s - } - -addIntTypeReq :: FDSolver s => EGVarId -> FDIntSpecTypeSet s -> FDInstance s () -addIntTypeReq var set = do - s <- get - let chk tp = case Map.lookup var (fdsIntVars s) of - Nothing -> False - Just x -> Set.member tp (fdspIntTypes x) - sset = Map.findWithDefault Set.empty var (fdsIntVarTypes s) - if Set.member set sset - then return () - else if any chk (Set.toList set) - then return () - else do - let nsset = Set.insert set sset - put $ s - { - fdsIntVarTypes = Map.insert var nsset $ fdsIntVarTypes s - } - -addColTypeReq :: FDSolver s => EGVarId -> FDColSpecTypeSet s -> FDInstance s () -addColTypeReq var set = do - s <- get - let chk tp = case Map.lookup var (fdsColVars s) of - Nothing -> False - Just x -> Set.member tp (fdspColTypes x) - sset = Map.findWithDefault Set.empty var (fdsColVarTypes s) - if Set.member set sset - then return () - else if any chk (Set.toList set) - then return () - else do - let nsset = Set.insert set sset - put $ s - { - fdsColVarTypes = Map.insert var nsset (fdsColVarTypes s) - } - -addTypeReqs :: FDSolver s => FDInstance s () -addTypeReqs = do - s <- get - fBool <- liftFD fdTypeReqBool - fInt <- liftFD fdTypeReqInt - fCol <- liftFD fdTypeReqCol - let ne = map (\k -> getJustEdge k s) $ Set.toList $ fdsNewEdges s - proc edge = do - mapM_ (uncurry addBoolTypeReq) $ fBool edge - mapM_ (uncurry addIntTypeReq) $ fInt edge - mapM_ (uncurry addColTypeReq) $ fCol edge - mapM_ proc ne - -processEx :: FDSolver s => Bool -> FDInstance s () -processEx x = do - ssm1 <- get - let ss0 = ssm1 { fdsModel = Just $ pruneNodes $ myFromJust "processEx" $ fdsModel ssm1 } - debug ("process ["++(show $ fdsLevel ss0)++"]") $ return () - -- search spec type requirements for all to-be-processed edges - debug ("addTypeReqs ["++(show $ fdsLevel ss0)++"]") $ addTypeReqs - -- optimize type requirements - debug ("optimizeVarTypes["++(show $ fdsLevel ss0)++"]") $ optimizeVarTypes - ss <- get - debug ("DUMP type reqs ["++(show $ fdsLevel ss0)++"]: "++(show $ fdsIntVarTypes ss)) $ return () - -- build specifier database for all to-be-processed edges - debug ("buildSpecDb ["++(show $ fdsLevel ss0)++"]") $ buildSpecDb - ss2 <- get - debug ("DUMP spec db ["++(show $ fdsLevel ss0)++"]: "++(show $ fdsDb ss2)) $ return () - -- create as much specifiers as possible (marking consumed edges as processed) - whileM_ $ debug ("decompBest ["++(show $ fdsLevel ss0)++"]") decompBest - -- try default specifier for remaining boolean nodes (=create new underlying term for each) - whileM_ $ debug ("decompDefBool ["++(show $ fdsLevel ss0)++"]") decompDefaultBool - -- try default specifier for remaining integer nodes (=create new underlying term for each) - whileM_ $ debug ("decompDefInt ["++(show $ fdsLevel ss0)++"]") decompDefaultInt - ss3 <- get - debug ("DUMP specs: "++(dumpSpec ss3)) $ return () - -- process remaining edges - if x - then whileM_ $ debug ("procEdge ["++(show $ fdsLevel ss0)++"]") procEdge - else return () - -process :: FDSolver s => FDInstance s () -process = processEx True - -commit :: FDSolver s => FDInstance s () -commit = do - s <- get - debug "begin commit" $ return () - case (fdsExpr s,fdsForceBool s,fdsForceInt s,fdsForceCol s) of - (BoolConst True,[],[],[]) -> return () - (expr,_,_,_) -> do - debug ("expr=["++(show expr)++"]") $ return () - let (dcd,graph,vars) = debug "decomposing" $ decomposeEx (fdsDecomp s) (fdsVars s) expr (fdsForceBool s,fdsForceInt s,fdsForceCol s) $ fdsModel s - put $ s { fdsExpr = BoolConst True, fdsDecomp = dcd, fdsModel = Just graph, fdsForceBool=[], fdsForceInt=[], fdsForceCol=[], fdsVars = max vars (fdsVars s) } - debug ("graph=["++(present graph)++"]"++"]") $ return () - -- mark all non-yet-processed edges as to-be-processed - debug "initForModel" $ initForModel - process - -instance FDSolver s => Solver (FDInstance s) where - type Constraint (FDInstance s) = Either Model (Constraint s) - type Label (FDInstance s) = FDLabel s - add (Left expr) = do - s <- get - if (fdsFailed s) - then return False - else do - put $ s { fdsExpr = (fdsExpr s) @&& expr } - return True - add (Right col) = do - s <- get - if (fdsFailed s) - then return False - else do - ret <- liftFD $ add col - if ret - then return True - else do - setFailed - return False - mark = do - commit - ss <- get - sl <- liftFD mark - return $ FDLabel { fdlState=ss, fdlLabel=sl } - markn n = do - commit - ss <- get - sl <- liftFD $ markn n - return $ FDLabel { fdlState=ss, fdlLabel=sl } - goto label = do - liftFD $ goto $ fdlLabel label - put $ fdlState label - run x = run $ runFD x - -instance FDSolver s => Term (FDInstance s) ModelInt where - newvar = do - s <- get - let i = fdsVars s - put $ s { fdsVars = 1+i } - return $ Term $ ModelIntVar i - type Help (FDInstance s) ModelInt = () - help _ _ = () - -instance FDSolver s => Term (FDInstance s) ModelBool where - newvar = do - s <- get - let i = fdsVars s - put $ s { fdsVars = 1+i } - return $ BoolTerm $ ModelBoolVar i - type Help (FDInstance s) ModelBool = () - help _ _ = () - -instance FDSolver s => Term (FDInstance s) ModelCol where - newvar = do - s <- get - let i = fdsVars s - put $ s { fdsVars = 1+i } - return $ ColTerm $ ModelColVar i - type Help (FDInstance s) ModelCol = () - help _ _ = () - -newCol :: FDSolver s => FDInstance s ModelCol -newCol = newvar - -newInt :: FDSolver s => FDInstance s ModelInt -newInt = newvar - -newBool :: FDSolver s => FDInstance s ModelBool -newBool = newvar - -combine :: [Maybe a] -> [a] -> [a] -combine [] _ = [] -combine (Nothing:r) (a:b) = a:(combine r b) -combine (Just x:r) b = x:(combine r b) - -realGetIntTerm :: FDSolver s => [ModelInt] -> FDInstance s [FDIntTerm s] -realGetIntTerm m = do - s <- debug ("realGetIntTerm: "++(show m)) $ get - put $ s { fdsForceInt = m++(fdsForceInt s) } - commit - s2 <- get - let ids = map (\x -> decompIntLookup (fdsDecomp s2) x) m - tp <- liftFD $ fdTypeVarInt - specs <- mapM (\(Just id) -> getIntSpec_ id tp) ids - vars <- mapM (\(Just (_,spec)) -> liftFD $ fdIntVarSpec spec) specs - let rvars = map (\(Just x) -> x) vars - s3 <- get - put $ s3 { fdsForcedInt = Map.union (fdsForcedInt s3) (Map.fromList $ zip m rvars) } - return rvars - -getSingleIntTerm :: FDSolver s => ModelInt -> FDInstance s (FDIntTerm s) -getSingleIntTerm m = do - s <- get - case Map.lookup m (fdsForcedInt s) of - Nothing -> realGetIntTerm [m] >>= return.head - Just d -> return d - -getIntTerm :: FDSolver s => [ModelInt] -> FDInstance s [FDIntTerm s] -getIntTerm m = do - s <- get - let lo = map (\x -> (x,Map.lookup x $ fdsForcedInt s)) m - let go = map fst $ filter (\(_,x) -> isNothing x) lo - vo <- case go of - [] -> return [] - _ -> realGetIntTerm go - return $ combine (map snd lo) vo - -realGetBoolTerm :: FDSolver s => [ModelBool] -> FDInstance s [FDBoolTerm s] -realGetBoolTerm m = do - s <- get - put $ s { fdsForceBool = m++(fdsForceBool s) } - commit - s2 <- get - let ids = map (\x -> decompBoolLookup (fdsDecomp s2) x) m - tp <- liftFD $ fdTypeVarBool - specs <- mapM (\(Just id) -> getBoolSpec_ id tp) ids - vars <- mapM (\(Just (_,spec)) -> liftFD $ fdBoolVarSpec spec) specs - let rvars = map (\(Just x) -> x) vars - s3 <- get - put $ s3 { fdsForcedBool = Map.union (fdsForcedBool s3) (Map.fromList $ zip m rvars) } - return rvars - -getBoolTerm :: FDSolver s => [ModelBool] -> FDInstance s [FDBoolTerm s] -getBoolTerm m = do - s <- get - let lo = map (\x -> (x,Map.lookup x $ fdsForcedBool s)) m - let go = map fst $ filter (\(_,x) -> isNothing x) lo - vo <- case go of - [] -> return [] - _ -> realGetBoolTerm go - return $ combine (map snd lo) vo - -getColTerm :: FDSolver s => [ModelCol] -> FDColSpecType s -> FDInstance s [FDColSpec s] -getColTerm m tp = do - s <- get - put $ s { fdsForceCol = m++(fdsForceCol s) } - commit - s2 <- get - let ids = map (\x -> decompColLookup (fdsDecomp s2) x) m - specs <- mapM (\(Just id) -> getColSpec_ id (Set.singleton tp)) ids - return $ map (snd . myFromJust ("getColTerm(tp="++(show tp)++")")) specs - -getColItems :: FDSolver s => ModelCol -> FDColSpecType s -> FDInstance s [FDIntTerm s] -getColItems c tp = do - [cc] <- getColTerm [c] tp - lst <- liftFD $ fdColInspect cc - return lst - -instance (FDSolver s, EnumTerm s (FDIntTerm s)) => EnumTerm (FDInstance s) ModelInt where - type TermBaseType (FDInstance s) ModelInt = TermBaseType s (FDIntTerm s) - getDomainSize v = do - f <- getFailed - if f - then return 0 - else do - var <- getSingleIntTerm v - liftFD $ getDomainSize var - getValue v = do - var <- getSingleIntTerm v - liftFD $ getValue var --- setValue var val = return [var @== cte val] - setValue _ = error "setting of boolean variable through FD interface is not implemented" - getDomain var = error "retrieval of full domain not implemented in FD" - splitDomain v = do - var <- getSingleIntTerm v - (doms,full) <- liftFD $ fdSplitIntDomain var - return (map (\x -> [Right x]) doms, full) - enumerator = case enumerator of - Nothing -> Nothing - Just e -> Just $ \l -> label $ do - f <- getFailed - if f - then return false - else do - ll <- getIntTerm l - return $ liftFDTree $ e ll - -instance (FDSolver s, EnumTerm s (FDBoolTerm s)) => EnumTerm (FDInstance s) ModelBool where - type TermBaseType (FDInstance s) ModelBool = TermBaseType s (FDBoolTerm s) - getDomainSize v = do - f <- getFailed - if f - then return 0 - else do - [var] <- getBoolTerm [v] - liftFD $ getDomainSize var - getValue v = do - [var] <- getBoolTerm [v] - liftFD $ getValue var --- setValue var val = return [var @= BoolConst (val /] - setValue _ = error "setting of boolean variable through FD interface is not implemented" - getDomain var = error "retrieval of full boolean domain not implemented in FD" - splitDomain v = do - [var] <- getBoolTerm [v] - (doms,full) <- liftFD $ fdSplitBoolDomain var - return (map (\x -> [Right x]) doms, full) - enumerator = case enumerator of - Nothing -> Nothing - Just e -> Just $ \l -> label $ do - f <- getFailed - if f - then return false - else do - ll <- getBoolTerm l - return $ liftFDTree $ e ll - -getIntVal_ :: FDSolver s => EGVarId -> FDState s -> Maybe EGPar -getIntVal_ id s = - let r1 = - case Map.lookup id (fdsIntVars s) of - Nothing -> Nothing - Just x -> fdspIntVal x - in case r1 of - Nothing -> - let Just j = fdsModel s - ei = findEdge j EGIntType id (==0) (\x -> case x of { EGIntValue _ -> True; _ -> False }) - in case ei of - Nothing -> Nothing - Just (_,ed) -> case egeCons ed of { EGIntValue c -> Just c } - Just x -> r1 - -getIntVal :: FDSolver s => EGVarId -> FDInstance s (Maybe EGPar) -getIntVal id = gets $ getIntVal_ id - -getBoolVal_ :: FDSolver s => EGVarId -> FDState s -> Maybe EGBoolPar -getBoolVal_ id s = - let r1 = - case Map.lookup id (fdsBoolVars s) of - Nothing -> Nothing - Just x -> fdspBoolVal x - in case r1 of - Nothing -> - let Just j = fdsModel s - l = getConnectedEdges j EGBoolType id - f (EGEdge { egeCons = EGBoolValue c },_) _ = Just c - f _ s = s - in foldr f Nothing l - Just x -> r1 - -getBoolVal :: FDSolver s => EGVarId -> FDInstance s (Maybe EGBoolPar) -getBoolVal id = gets $ getBoolVal_ id - -getColVal_ :: FDSolver s => EGVarId -> FDState s -> Maybe EGColPar -getColVal_ id s = - let r1 = - case Map.lookup id (fdsColVars s) of - Nothing -> Nothing - Just x -> fdspColVal x - in case r1 of - Nothing -> - let Just j = fdsModel s - l = getConnectedEdges j EGColType id - f (EGEdge { egeCons = EGColValue c },_) _ = Just c - f _ s = s - in foldr f Nothing l - Just x -> r1 - -getColVal :: FDSolver s => EGVarId -> FDInstance s (Maybe EGColPar) -getColVal id = gets $ getColVal_ id - -setFailed :: FDSolver s => FDInstance s () -setFailed = do - s <- get - debug "setFailed!" $ return () - put $ s { fdsFailed = True } - -getFailed :: FDSolver s => FDInstance s Bool -getFailed = do - s <- get - return $ fdsFailed s - -addFD :: (Show (Constraint s), FDSolver s) => Constraint s -> FDInstance s () -addFD c = do - s <- get - if (fdsFailed s) - then debug ("addFD("++(show c)++"): already failed") $ return () - else do - x <- liftFD $ add c - debug ("addFD("++(show c)++"): result="++(show x)) $ return () - if not x then setFailed else return () - -getDefIntSpec :: FDSolver s => FDSpecInfoInt s -> FDIntSpec s -getDefIntSpec (FDSpecInfoInt { fdspIntSpec = f }) = case f Nothing of - Just t -> t - Nothing -> error "getDefIntSpec: no spec" - -getDefBoolSpec :: FDSolver s => FDSpecInfoBool s -> FDBoolSpec s -getDefBoolSpec (FDSpecInfoBool { fdspBoolSpec = f }) = case f Nothing of - Just t -> t - Nothing -> error "getDefBoolSpec: no spec" - -getDefColSpec :: FDSolver s => FDSpecInfoCol s -> FDColSpec s -getDefColSpec (FDSpecInfoCol { fdspColSpec = f }) = case f Nothing of - Just t -> t - Nothing -> error "getDefColSpec: no spec" - --- getFullIntSpec :: FDSolver s => EGVarId -> s (FDSpecInfoInt s) -getFullIntSpec id = do - s <- get - return $ myFromJust "getFullIntSpec" $ Map.lookup id $ fdsIntVars s - --- getFullBoolSpec :: FDSolver s => EGVarId -> s (FDSpecInfoBool s) -getFullBoolSpec id = do - s <- get - return $ myFromJust "getFullBoolSpec" $ Map.lookup id $ fdsBoolVars s - --- getFullColSpec :: FDSolver s => EGVarId -> s (FDSpecInfoCol s) -getFullColSpec id = do - s <- get - return $ myFromJust "getFullColSpec" $ Map.lookup id $ fdsColVars s - -fdNewvar :: (FDSolver s, Term s t) => FDInstance s (Maybe t) -fdNewvar = do - s <- get - if fdsDummyLevel s > 0 - then return Nothing - else liftFD newvar >>= return . Just diff --git a/Control/CP/FD/Graph.hs b/Control/CP/FD/Graph.hs deleted file mode 100644 --- a/Control/CP/FD/Graph.hs +++ /dev/null @@ -1,411 +0,0 @@ -{- - - Monadic Constraint Programming - - http://www.cs.kuleuven.be/~toms/MCP/ - - Pieter Wuille - -} - -{-# LANGUAGE RankNTypes #-} -{-# LANGUAGE GeneralizedNewtypeDeriving #-} -{-# LANGUAGE StandaloneDeriving #-} -{-# LANGUAGE FlexibleInstances #-} - -module Control.CP.FD.Graph ( - EGConstraintSpec(..), - EGParTerm(..), - EGParBoolTerm(..), - EGParColTerm(..), - EGPar, EGBoolPar, EGColPar, - EGConsArgs, - EGEdgeId, - EGVarId(..), - EGVarType(..), - EGTypeData(..), - EGEdge(..), - EGModel(..), - addEdge, - addNode, - delNode, - findEdge, - unifyNodes, - unifyIds, - baseGraph, - baseTypeData, - egTypeDataMap, egTypeGet, egTypeMod, - present, - getConnectedEdges, - externMap, filterModel, emptyModel, pruneNodes, -) where - -import Control.Monad (foldM) - -import Data.Maybe (fromJust) -import Data.Map (Map) -import qualified Data.Map as Map - -import Data.Expr.Data --- import Control.CP.FD.Expr.Util - --- BoolEqual, Rel _ (EREqual) _, ColEqual are encoded in the graph itself, and --- not represented as constraints between them - -data EGVarType = - EGBoolType - | EGIntType - | EGColType - deriving (Eq,Show) - --- instance KeyableExpr EGConstraintSpec where --- keyCompare a b = compare a b - -data EGConstraintSpec = - EGIntValue EGPar -- i0 == p - | EGBoolValue EGBoolPar -- b0 == p - | EGColValue EGColPar -- c0 == p - | EGIntExtern Int -- super[p] == i0 - | EGBoolExtern Int -- super[p] == b0 - | EGColExtern Int -- super[p] == c0 - | EGPlus -- i0==i1+i2 - | EGMinus -- i0==i1-i2 - | EGMult -- i0==i1*i2 - | EGDiv -- i0==i1/i2 {- (i0==i1/i2) is NOT the same as (i1==i0*i2) -} - | EGMod -- i0==i1%i2 - | EGAbs -- i0==abs(i1) - | EGAt -- i0==c0[i1] - | EGFold EGModel (Int,Int,Int) -- i0==fold(p,i1,c0) {- inner intExtern(-1) is fold-function's return value, intExtern(-2) is the accumulator, intExtern(-3) is the argument -} - | EGSize -- i0==size(c0) - | EGChannel -- int(b0) == i0 - | EGList Int -- c0 == [i0,i1,i2,...] (len p) - | EGRange -- c0 == [i0..i1] - | EGMap EGModel (Int,Int,Int) -- c0 == map(p,c1) {- inner intExtern(-1) is map-function's return value, intExtern(-2) is its argument -} - | EGSlice EGModel (Int,Int,Int) -- c0 == c1[f(0)...f(i0-1)]; inner model defines f: intExtern(-1) is return value, intExtern(-2) is its argument --- | EGSlice (EGPar -> EGPar) EGPar -- c0 == c1[f(0)...f(n-1)] - | EGCat -- c0 == c1++c2 - | EGAnd -- b0 == b1 && b2 - | EGOr -- b0 == b1 || b2 - | EGEquiv -- b0 == (b1 == b2) - | EGNot -- b0 == !b1 - | EGEqual -- b0 <-> i0 == i1 - | EGDiff -- b0 <-> i0 /= i1 - | EGLess Bool -- false: b0 <-> i0 <= i1 ; true: b0 <-> i0 < i1 - | EGAll EGModel (Int,Int,Int) Bool -- b0 <-> foreach (i from c0): p(i) {- inner boolExtern(-1) is truth value of predicate, intExtern(-1) is its argument; bool is true if all inner predicates need to be true -} - | EGAny EGModel (Int,Int,Int) Bool -- b0 <-> forany (i from c0): p(i) {- inner boolExtern(-1) is truth value of predicate, intExtern(-1) is its argument; bool is true if all inner predicates need to be false -} --- | EGAllC EGModel (Int,Int,Int) Bool -- b0 <-> foreach (i from [i0,i1]: p(i) {- inner boolExtern(-1) is truth value of predicate, intExtern(-1) is its (constant) argument; bool is true if all inner predicates need to be true -} --- | EGAnyC EGModel (Int,Int,Int) Bool -- b0 <-> foreach (i from [i0,i1]: p(i) {- inner boolExtern(-1) is truth value of predicate, intExtern(-1) is its (constant) argument; bool is true if all inner predicates need to be true -} - | EGSorted Bool -- c0 is increasing (false), or strictly increasing (true) - | EGAllDiff Bool -- c0 is all different (b0 means: use in consistency) - | EGDom -- i0 is any of c0 - | EGCondEqual -- b0 ? (b1==b2) : true - | EGCondInt -- i0 = b0 ? i1 : i2 - deriving (Eq,Show) - -instance Ord (EGPar -> EGPar) where - compare a b = compare (a (Term (EGPTParam (-1)))) (b (Term (EGPTParam (-1)))) - -instance Eq (EGPar -> EGPar) where - a == b = (a (Term (EGPTParam (-1)))) == (b (Term (EGPTParam (-1)))) - -instance Show (EGPar -> EGPar) where - show f = show $ f (Term (EGPTParam (-1))) - -dummyConstraint :: EGConstraintSpec -> Bool -dummyConstraint c = case c of - EGIntExtern _ -> True - EGBoolExtern _ -> True - EGColExtern _ -> True - _ -> False - -data EGParTerm = - EGPTParam Int - deriving (Show,Eq,Ord) - -data EGParBoolTerm = - EGPTBoolParam Int - deriving (Show,Eq,Ord) - -data EGParColTerm = - EGPTColParam Int - deriving (Show,Eq,Ord) - -type EGPar = Expr EGParTerm EGParColTerm EGParBoolTerm -type EGBoolPar = BoolExpr EGParTerm EGParColTerm EGParBoolTerm -type EGColPar = ColExpr EGParTerm EGParColTerm EGParBoolTerm - --- Bools, Ints, Cols -type EGConsArgs = (Int,Int,Int) - -getConsArgs :: EGConstraintSpec -> EGTypeData Int -getConsArgs x = case - case x of - EGBoolValue _ -> (1,0,0) - EGIntValue _ -> (0,1,0) - EGColValue _ -> (0,0,1) - EGIntExtern _ -> (0,1,0) - EGBoolExtern _ -> (1,0,0) - EGColExtern _ -> (0,0,1) - EGPlus -> (0,3,0) - EGMinus -> (0,3,0) - EGMult -> (0,3,0) - EGDiv -> (0,3,0) - EGMod -> (0,3,0) - EGAbs -> (0,2,0) - EGAt -> (0,2,1) - EGFold _ (a,b,c) -> (a,2+b,1+c) - EGSize -> (0,1,1) - EGChannel -> (1,1,0) - EGList n -> (0,n,1) - EGRange -> (0,2,1) - EGMap _ (a,b,c) -> (a,b,2+c) - EGSlice _ (a,b,c) -> (a,1+b,2+c) - EGCat -> (0,0,3) - EGAnd -> (3,0,0) - EGOr -> (3,0,0) - EGEquiv -> (3,0,0) - EGNot -> (2,0,0) - EGEqual -> (1,2,0) - EGDiff -> (1,2,0) - EGLess _ -> (1,2,0) - EGAll _ (a,b,c) _ -> (1+a,b,1+c) - EGAny _ (a,b,c) _ -> (1+a,b,1+c) --- EGAllC _ (a,b,c) _ -> (1+a,2+b,c) --- EGAnyC _ (a,b,c) _ -> (1+a,2+b,c) - EGSorted _ -> (0,0,1) - EGAllDiff _ -> (0,0,1) - EGDom -> (0,1,1) - EGCondEqual -> (3,0,0) - EGCondInt -> (1,3,0) - of (a,b,c) -> EGTypeData { boolData = a, intData = b, colData =c } - -newtype EGEdgeId = EGEdgeId { unEGEdgeId :: Int } - deriving (Eq,Ord,Show) - -data EGVarId = EGVarId { unVarId :: Int } - deriving (Eq,Ord,Show) - -data EGTypeData x = EGTypeData { - boolData :: x, - intData :: x, - colData :: x -} - -deriving instance Show x => Show (EGTypeData x) -deriving instance Eq x => Eq (EGTypeData x) - -baseTypeData :: x -> EGTypeData x -baseTypeData x = EGTypeData { - boolData = x, - intData = x, - colData = x -} - -egTypeDataMap :: ((forall a. EGTypeData a -> a) -> b) -> EGTypeData b -egTypeDataMap f = EGTypeData { - boolData = f boolData, - intData = f intData, - colData = f colData -} - -egTypeGet :: EGVarType -> EGTypeData a -> a -egTypeGet EGBoolType = boolData -egTypeGet EGIntType = intData -egTypeGet EGColType = colData - -egTypeMod :: EGVarType -> EGTypeData a -> (a -> a) -> EGTypeData a -egTypeMod EGBoolType d f = d { boolData = f $ boolData d } -egTypeMod EGIntType d f = d { intData = f $ intData d } -egTypeMod EGColType d f = d { colData = f $ colData d } - -data EGEdge = EGEdge { - egeCons :: EGConstraintSpec, - egeLinks :: EGTypeData [EGVarId] -} deriving (Eq,Show) - -showBool :: EGVarId -> String -showBool (EGVarId i) = "b" ++ (show i) -showInt :: EGVarId -> String -showInt (EGVarId i) = "i" ++ (show i) -showCol :: EGVarId -> String -showCol (EGVarId i) = "c" ++ (show i) - -showLst :: (EGVarId -> String) -> [EGVarId] -> String -showLst _ [] = "[]" -showLst f x = "[" ++ (foldl1 (\x y -> x ++ "," ++ y) $ map f x) ++ "]" - -instance Display EGEdge where - displayer (EGEdge { egeCons = EGBoolValue i, egeLinks = EGTypeData { boolData = [l] } }) = displaySingle $ (showBool l) ++ " == " ++ "#["++(show i)++"]" - displayer (EGEdge { egeCons = EGIntValue i, egeLinks = EGTypeData { intData = [l] }}) = displaySingle $ (showInt l) ++ " == " ++ "#["++(show i)++"]" - displayer (EGEdge { egeCons = EGColValue i, egeLinks = EGTypeData { colData = [l] }}) = displaySingle $ (showCol l) ++ " == " ++ "#["++(show i)++"]" - displayer (EGEdge { egeCons = EGBoolExtern i, egeLinks = EGTypeData { boolData = [l] }}) = displaySingle $ (showBool l) ++ " == parentBool[" ++ (show i) ++ "]" - displayer (EGEdge { egeCons = EGIntExtern i, egeLinks = EGTypeData { intData = [l] }}) = displaySingle $ (showInt l) ++ " == parentInt[" ++ (show i) ++ "]" - displayer (EGEdge { egeCons = EGColExtern i, egeLinks = EGTypeData { colData = [l] }}) = displaySingle $ (showCol l) ++ " == parentCol[" ++ (show i) ++ "]" - displayer (EGEdge { egeCons = EGPlus, egeLinks = EGTypeData { intData=[a,b,c] }}) = displaySingle $ (showInt a) ++ " == " ++ (showInt b) ++ " + " ++ (showInt c) - displayer (EGEdge { egeCons = EGMinus, egeLinks = EGTypeData { intData=[a,b,c] }}) = displaySingle $ (showInt a) ++ " == " ++ (showInt b) ++ " - " ++ (showInt c) - displayer (EGEdge { egeCons = EGMult, egeLinks = EGTypeData { intData=[a,b,c] }}) = displaySingle $ (showInt a) ++ " == " ++ (showInt b) ++ " * " ++ (showInt c) - displayer (EGEdge { egeCons = EGDiv, egeLinks = EGTypeData { intData=[a,b,c] }}) = displaySingle $ (showInt a) ++ " == " ++ (showInt b) ++ " / " ++ (showInt c) - displayer (EGEdge { egeCons = EGMod, egeLinks = EGTypeData { intData=[a,b,c] }}) = displaySingle $ (showInt a) ++ " == " ++ (showInt b) ++ " % " ++ (showInt c) - displayer (EGEdge { egeCons = EGAbs, egeLinks = EGTypeData { intData=[a,b] }}) = displaySingle $ (showInt a) ++ " == abs(" ++ (showInt b) ++ ")" - displayer (EGEdge { egeCons = EGAt, egeLinks = EGTypeData { intData=[a,b], colData=[c] }}) = displaySingle $ (showInt a) ++ " == " ++ (showCol c) ++ "[" ++ (showInt b) ++ "]" - displayer (EGEdge { egeCons = EGSize, egeLinks = EGTypeData { intData=[a], colData=[c] }}) = displaySingle $ (showInt a) ++ " == size(" ++ (showCol c) ++ ")" - displayer (EGEdge { egeCons = EGDom, egeLinks = EGTypeData { intData=[a], colData=[c] }}) = displaySingle $ ("dom(" ++ (showInt a) ++ ") == " ++ (showCol c)) - displayer (EGEdge { egeCons = EGChannel, egeLinks = EGTypeData { boolData=[a], intData=[b] }}) = displaySingle $ (showBool a) ++ " == " ++ (showInt b) - displayer (EGEdge { egeCons = EGList 0, egeLinks = EGTypeData { colData=[c] }}) = displaySingle $ (showCol c) ++ " == []" - displayer (EGEdge { egeCons = EGList _, egeLinks = EGTypeData { intData=l, colData=[c] }}) = displaySingle $ (showCol c) ++ " == ["++(foldl1 (\a b -> a ++","++b) $ map showInt l)++"]" - displayer (EGEdge { egeCons = EGAllDiff _, egeLinks = EGTypeData { colData=[c] }}) = displaySingle $ "allDiff " ++ (showCol c) - displayer (EGEdge { egeCons = EGSorted b, egeLinks = EGTypeData { colData=[c] }}) = displaySingle $ "sorted " ++ (show b) ++ " " ++ (showCol c) - displayer (EGEdge { egeCons = EGRange, egeLinks = EGTypeData { intData=[l,h], colData=[c] }}) = displaySingle $ (showCol c) ++ " == ["++(showInt l)++".."++(showInt h)++"]" --- displayer (EGEdge { egeCons = EGSlice f n, egeLinks = EGTypeData { colData=[c,o] }}) = displaySingle $ (showCol c) ++ " == "++(showCol o)++"[f(0)..f("++(show n)++"-1)]" - displayer (EGEdge { egeCons = EGCat, egeLinks = EGTypeData { colData=[c,a,b] }}) = displaySingle $ (showCol c) ++ " == "++(showCol a)++"++"++(showCol b) - displayer (EGEdge { egeCons = EGAnd, egeLinks = EGTypeData { boolData=[c,a,b] }}) = displaySingle $ (showBool c) ++ " == "++(showBool a)++" && "++(showBool b) - displayer (EGEdge { egeCons = EGOr, egeLinks = EGTypeData { boolData=[c,a,b] }}) = displaySingle $ (showBool c) ++ " == "++(showBool a)++" || "++(showBool b) - displayer (EGEdge { egeCons = EGEquiv, egeLinks = EGTypeData { boolData=[c,a,b] }}) = displaySingle $ (showBool c) ++ " == ("++(showBool a)++" == "++(showBool b)++")" - displayer (EGEdge { egeCons = EGNot, egeLinks = EGTypeData { boolData=[c,a] }}) = displaySingle $ (showBool c) ++ " == !"++(showBool a) - displayer (EGEdge { egeCons = EGEqual, egeLinks = EGTypeData { boolData=[r], intData=[a,b] }}) = displaySingle $ (showBool r) ++ " == ("++(showInt a)++" == "++(showInt b)++")" - displayer (EGEdge { egeCons = EGDiff, egeLinks = EGTypeData { boolData=[r], intData=[a,b] }}) = displaySingle $ (showBool r) ++ " == ("++(showInt a)++" != "++(showInt b)++")" - displayer (EGEdge { egeCons = EGLess q, egeLinks = EGTypeData { boolData=[r], intData=[a,b] }}) = displaySingle $ (showBool r) ++ " == ("++(showInt a)++(if q then " < " else " <= ")++(showInt b)++")" - displayer (EGEdge { egeCons = EGAll s _ _, egeLinks = EGTypeData { boolData=r:ab, intData=ai, colData=c:ac }}) = DisplayData ((showBool r)++" == forall("++(showCol c)++") "++(showLst showBool ab)++" "++(showLst showInt ai)++" "++(showLst showCol ac),[displayer s]) - displayer (EGEdge { egeCons = EGAny s _ _, egeLinks = EGTypeData { boolData=r:ab, intData=ai, colData=c:ac }}) = DisplayData ((showBool r)++" == forany("++(showCol c)++") "++(showLst showBool ab)++" "++(showLst showInt ai)++" "++(showLst showCol ac),[displayer s]) --- displayer (EGEdge { egeCons = EGAllC s _ _, egeLinks = EGTypeData { boolData=r:ab, intData=l:h:ai, colData=ac }}) = DisplayData ((showBool r)++" == forall("++(showInt l)++".."++(showInt h)++") "++(showLst showBool ab)++" "++(showLst showInt ai)++" "++(showLst showCol ac),[displayer s]) --- displayer (EGEdge { egeCons = EGAnyC s _ _, egeLinks = EGTypeData { boolData=r:ab, intData=l:h:ai, colData=ac }}) = DisplayData ((showBool r)++" == forany("++(showInt l)++".."++(showInt h)++") "++(showLst showBool ab)++" "++(showLst showInt ai)++" "++(showLst showCol ac),[displayer s]) - displayer (EGEdge { egeCons = EGMap s _, egeLinks = EGTypeData { boolData=ab, intData=ai, colData=r:c:ac }}) = DisplayData ((showCol r)++" == map("++(showCol c)++") "++(showLst showBool ab)++" "++(showLst showInt ai)++" "++(showLst showCol ac),[displayer s]) - displayer (EGEdge { egeCons = EGSlice s _, egeLinks = EGTypeData { boolData=ab, intData=n:ai, colData=r:c:ac }}) = DisplayData ((showCol r)++" == slice("++(showCol c)++",0..("++(showInt n)++")-1) "++(showLst showBool ab)++" "++(showLst showInt ai)++" "++(showLst showCol ac),[displayer s]) - displayer (EGEdge { egeCons = EGFold s _, egeLinks = EGTypeData { boolData=ab, intData=r:i:ai, colData=c:ac }}) = DisplayData ((showInt r)++" == fold("++(showCol c)++","++(showInt i)++") "++(showLst showBool ab)++" "++(showLst showInt ai)++" "++(showLst showCol ac),[displayer s]) - displayer (EGEdge { egeCons = EGCondInt, egeLinks = EGTypeData { boolData=[c], intData=[r,t,f] }}) = displaySingle $ (showInt r) ++ " = (if " ++ (showBool c) ++" then (" ++ (showInt t) ++ ") else (" ++ (showInt f)++"))" - displayer (EGEdge { egeCons = EGCondEqual, egeLinks = EGTypeData { boolData=[c,a,b] }}) = displaySingle $ "if " ++ (showBool c) ++" then " ++ (showBool a) ++ "=="++(showBool b) - displayer (EGEdge { egeCons = c }) = DisplayData ("???("++(show c)++")",[]) - -externMap :: EGModel -> EGTypeData (Map Int EGVarId) -externMap md = foldr f (baseTypeData Map.empty) $ map snd $ Map.toList $ egmEdges md - where f :: EGEdge -> EGTypeData (Map Int EGVarId) -> EGTypeData (Map Int EGVarId) - f (EGEdge { egeCons = EGIntExtern i, egeLinks = EGTypeData { intData = [v] } }) st = egTypeMod EGIntType st $ \m -> Map.insert i v m - f (EGEdge { egeCons = EGBoolExtern i, egeLinks = EGTypeData { boolData = [v] } }) st = egTypeMod EGBoolType st $ \m -> Map.insert i v m - f (EGEdge { egeCons = EGColExtern i, egeLinks = EGTypeData { colData = [v] } }) st = egTypeMod EGColType st $ \m -> Map.insert i v m - f _ st = st - -emptyModel :: EGModel -> Bool -emptyModel mod = - let mm = externMap mod - ss = Map.size (intData mm) + Map.size (colData mm) + Map.size (boolData mm) - in ss == (Map.size $ egmEdges mod) - -data EGModel = EGModel { - egmParams :: EGTypeData Int, - egmVars :: EGTypeData Int, - egmNEdges :: Int, - egmEdges :: Map EGEdgeId EGEdge, - egmLinks :: EGTypeData (Map EGVarId [(EGEdgeId,Int)]) -} deriving (Eq,Show) - -filterModel :: EGModel -> (EGEdge -> Maybe a) -> (EGModel,[a]) -filterModel mod f = foldl ff (mod,[]) $ Map.toList $ egmEdges mod - where ff (mm,n) (id,ed) = - let res = f ed - in case res of - Nothing -> (mm,n) - Just a -> (delEdge id mm,a:n) - -prefix :: String -> DisplayData -> DisplayData -prefix s (DisplayData (s1,x)) = DisplayData (s++s1,x) - -instance Display EGModel where - displayer (EGModel { egmEdges = x }) = DisplayData ("EGModel",map (\(id,x) -> prefix ((show $ unEGEdgeId id)++": ") $ displayer x) $ Map.toList x) - -addEdge :: EGConstraintSpec -> EGTypeData [EGVarId] -> EGModel -> EGModel -addEdge cons links model = - if (expected == getConsArgs cons) - then - let newEdgeId = EGEdgeId $ egmNEdges model - in model { - egmNEdges = egmNEdges model + 1, - egmEdges = Map.insert newEdgeId (EGEdge { egeCons = cons, egeLinks = links }) $ egmEdges model, - egmLinks = egTypeDataMap $ \f -> - foldr (\i -> - Map.insertWith (++) ((f links) !! i) [(newEdgeId,i)] - ) (f $ egmLinks model) [0..(length (f links) - 1)] - } - else - error $ "incorrect number of arguments for constraint ("++(show cons)++")" - where expected = egTypeDataMap (\f -> length $ f links) - -unifyIds :: EGVarId -> EGVarId -> EGVarId -> EGVarId --- unifyIds fromId toId = (\x -> if x>fromId then x-1 else x) . (\x -> if x==fromId then toId else x) -unifyIds fromId toId = \x -> if x==fromId then toId else x - -delEdge :: EGEdgeId -> EGModel -> EGModel -delEdge id mod = do - let fnd = Map.lookup id $ egmEdges mod - case fnd of - Nothing -> error "deleting inexisting edge" - Just ff -> do - let nmp = Map.delete id $ egmEdges mod - mif [] = Nothing - mif x = Just x - afn = mif . filter ((/=id) . fst) - nln = egTypeDataMap $ \f -> foldr (\vid pre -> Map.alter (\(Just x) -> afn x) vid pre) (f $ egmLinks mod) $ f $ egeLinks ff - mod { egmEdges = nmp, egmLinks = nln } - -findEdge :: EGModel -> EGVarType -> EGVarId -> (Int -> Bool) -> (EGConstraintSpec -> Bool) -> Maybe (EGEdgeId,EGEdge) -findEdge model typ varid pos cons = - let mtc1 = Map.findWithDefault [] varid $ egTypeGet typ $ egmLinks model - mtc2 = filter (\(_,p) -> pos p) mtc1 - mtc3 = map (\(id,_) -> - (id,case Map.lookup id (egmEdges model) of - Nothing -> error $ "cannot find edge id="++(show id) - Just xx -> xx - )) mtc2 - mtc4 = filter (\(_,s) -> cons $ egeCons s) mtc3 - in case mtc4 of - [] -> Nothing - a:_ -> Just a - -pruneNodes :: EGModel -> EGModel -pruneNodes mod = - mod { egmLinks = egTypeDataMap $ \f -> Map.fromList $ filter (\(_,v) -> case v of [] -> True; _ -> False) $ Map.toList $ f $ egmLinks mod } - -unifyNodes :: EGVarType -> EGVarId -> EGVarId -> EGModel -> EGModel -unifyNodes vt fromId toId model = model { --- egmVars = egTypeMod vt (egmVars model) pred, - egmEdges = Map.map (\x -> x { - egeLinks = egTypeMod vt (egeLinks x) $ \z -> - map (unifyIds fromId toId) z - }) $ egmEdges model, - egmLinks = egTypeMod vt (egmLinks model) $ \x -> Map.insertWith (++) toId (Map.findWithDefault [] fromId x) x -} - -addNode :: EGVarType -> EGModel -> (EGVarId,EGModel) -addNode vt model = ( - EGVarId (egTypeGet vt $ egmVars model), - model { - egmVars = egTypeMod vt (egmVars model) succ - } - ) - -delNode :: EGVarType -> EGVarId -> EGModel -> EGModel -delNode vt id model = model { egmLinks = egTypeMod vt (egmLinks model) (Map.delete id) } - -baseGraph :: EGModel -baseGraph = EGModel { - egmParams = baseTypeData 0, - egmVars = baseTypeData 0, - egmNEdges = 0, - egmEdges = Map.empty, - egmLinks = baseTypeData Map.empty -} - -data DisplayData = DisplayData (String,[DisplayData]) - -class Display a where - display :: Int -> a -> String - displayer :: a -> DisplayData - display n x = display n $ displayer x - -present :: Display a => a -> String -present = display 0 - -instance Display DisplayData where - displayer = id - display n (DisplayData (dir,sub)) = foldl (++) ((replicate (n*2) ' ')++dir++"\n") $ map (display $ n+1) sub - -displaySingle :: String -> DisplayData -displaySingle x = DisplayData (x,[]) - -getConnectedEdges :: EGModel -> EGVarType -> EGVarId -> [(EGEdge,Int)] -getConnectedEdges model typ id = map (\(eid,pos) -> (fromJust $ Map.lookup eid $ egmEdges model, pos)) $ fromJust $ Map.lookup id $ egTypeGet typ $ egmLinks model diff --git a/Control/CP/FD/Interface.hs b/Control/CP/FD/Interface.hs deleted file mode 100644 --- a/Control/CP/FD/Interface.hs +++ /dev/null @@ -1,220 +0,0 @@ -{-# LANGUAGE GADTs #-} -{-# LANGUAGE RankNTypes #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE TypeSynonymInstances #-} -{-# LANGUAGE ScopedTypeVariables #-} - -module Control.CP.FD.Interface ( - FDSolver, - FDInstance, - (@+),(@-),(@*),(@/),(@%),(!),(@!!),(@..),(@++),size,xfold,xsum,xhead,xtail,list,slice,xmap,cte, - (Control.CP.FD.Interface.@||), - (Control.CP.FD.Interface.@&&), - Control.CP.FD.Interface.inv, - (Control.CP.FD.Interface.@=), - (Control.CP.FD.Interface.@/=), - (Control.CP.FD.Interface.@<), - (Control.CP.FD.Interface.@>), - (Control.CP.FD.Interface.@<=), - (Control.CP.FD.Interface.@>=), - (Control.CP.FD.Interface.@:), - (Control.CP.FD.Interface.@?), - (Control.CP.FD.Interface.@??), - Control.CP.FD.Interface.channel, - val, --- Control.CP.FD.Interface.newInt, Control.CP.FD.Interface.newBool, Control.CP.FD.Interface.newCol, - Control.CP.FD.Interface.sorted, - Control.CP.FD.Interface.sSorted, - Control.CP.FD.Interface.forall, - Control.CP.FD.Interface.forany, - Control.CP.FD.Interface.loopall, - Control.CP.FD.Interface.allDiff, - Control.CP.FD.Interface.allDiffD, - Control.CP.FD.Interface.loopany, - allin, - asExpr, asCol, Control.CP.FD.Interface.asBool, - colList, labelCol, - ModelInt, ModelCol, ModelBool, - exists, true, false, --- Modelable, -) where - -import Control.CP.FD.FD (FDSolver, FDInstance, FDIntTerm, getColItems) -import qualified Control.CP.FD.Model as Model -import Control.CP.FD.Model (Model, ModelBool, ModelCol, ModelInt, ToModelBool, asBool, asExpr, asCol, cte, newModelTerm, ModelIntArg, ModelBoolArg, ModelColArg) -import qualified Data.Expr.Sugar as Sugar -import Data.Expr.Util -import Data.Expr.Data -import Data.Expr.Sugar ((@+),(@-),(@*),(@/),(@%),(!),(@!!),(@..),(@++),size,xfold,xhead,xtail,slice,xmap,xsum,list) -import Control.CP.Solver -import Control.CP.SearchTree -import Control.CP.EnumTerm - -newtype DummySolver a = DummySolver () - -instance Monad DummySolver where - return _ = DummySolver () - _ >>= _ = DummySolver () - -data EQHelp b where - EQHelp :: Model.ModelTermType b => ((b -> Model) -> Model) -> EQHelp b - -instance Model.ModelTermType t => Term DummySolver t where - type Help DummySolver t = EQHelp t - help _ _ = EQHelp newModelTerm - newvar = DummySolver () - -instance Solver DummySolver where - type Constraint DummySolver = Either Model () - type Label DummySolver = () - add _ = DummySolver () - run _ = error "Attempt to run dummy solver" - mark = DummySolver () - goto _ = DummySolver () - -newtype Model.ModelTermType t => DummyTerm t = DummyTerm t - --- class (Solver s, Term s ModelBool, Term s ModelInt, Term s ModelCol) => Modelable s where - --- instance Modelable DummySolver where - --- instance FDSolver s => Modelable (FDInstance s) where - - -treeToModel :: Tree DummySolver () -> Model -treeToModel (Return _) = BoolConst True -treeToModel (Try a b) = (Sugar.@||) (treeToModel a) (treeToModel b) -treeToModel (Add (Left c) m) = (Sugar.@&&) c (treeToModel m) -treeToModel Fail = BoolConst False -treeToModel (Label _) = error "Cannot turn labelled trees into expressions" -treeToModel (NewVar (f :: t -> Tree DummySolver ())) = case (help ((error "treeToModel undefined 1") :: DummySolver ()) ((error "treeToModel undefined 2") :: t)) of EQHelp ff -> ff (\x -> treeToModel $ f (x :: t)) - -addM :: (Constraint s ~ Either Model q, MonadTree m, TreeSolver m ~ s) => Model -> m () -addM m = addC $ Left m - -infixr 2 @|| -(@||) :: (Constraint s ~ Either Model q, MonadTree m, TreeSolver m ~ s) => Tree DummySolver () -> Tree DummySolver () -> m () -(@||) a b = addM $ treeToModel $ a \/ b - -infixr 3 @&& -(@&&) :: (Constraint s ~ Either Model q, MonadTree m, TreeSolver m ~ s) => Tree DummySolver () -> Tree DummySolver () -> m () -(@&&) a b = addM $ treeToModel $ a /\ b - -channel :: Tree DummySolver () -> ModelInt -channel a = Sugar.channel $ treeToModel a - -inv :: (Constraint s ~ Either Model q, MonadTree m, TreeSolver m ~ s) => Tree DummySolver () -> m () -inv a = addM $ Sugar.inv $ treeToModel a - -infix 4 @=, @/=, @<, @>, @<=, @>= - -class ModelExprClass a where - (@=) :: (Constraint s ~ Either Model q, MonadTree m, TreeSolver m ~ s) => a -> a -> m () - (@/=) :: (Constraint s ~ Either Model q, MonadTree m, TreeSolver m ~ s) => a -> a -> m () - -instance ModelExprClass ModelInt where - a @= b = addM $ (Sugar.@=) a b - a @/= b = addM $ (Sugar.@/=) a b - -instance ModelExprClass ModelCol where - a @= b = addM $ (Sugar.@=) a b - a @/= b = addM $ (Sugar.@/=) a b - -instance ModelExprClass ModelBool where - a @= b = addM $ (Sugar.@=) a b - a @/= b = addM $ (Sugar.@/=) a b - -instance ModelExprClass (Tree DummySolver ()) where - a @= b = addM $ (Sugar.@=) (treeToModel a) (treeToModel b) - a @/= b = addM $ (Sugar.@/=) (treeToModel a) (treeToModel b) - -(@<) :: (Constraint s ~ Either Model q, MonadTree m, TreeSolver m ~ s) => ModelInt -> ModelInt -> m () -(@<) a b = addM $ (Sugar.@<) a b - -(@>) :: (Constraint s ~ Either Model q, MonadTree m, TreeSolver m ~ s) => ModelInt -> ModelInt -> m () -(@>) a b = addM $ (Sugar.@>) a b - -(@>=) :: (Constraint s ~ Either Model q, MonadTree m, TreeSolver m ~ s) => ModelInt -> ModelInt -> m () -(@>=) a b = addM $ (Sugar.@>=) a b - -(@<=) :: (Constraint s ~ Either Model q, MonadTree m, TreeSolver m ~ s) => ModelInt -> ModelInt -> m () -(@<=) a b = addM $ (Sugar.@<=) a b - -val :: Tree DummySolver () -> ModelInt -val = Sugar.toExpr . treeToModel - -{- newBool :: (Constraint s ~ Either Model q, MonadTree m, TreeSolver m ~ s) => (ModelBool -> Tree DummySolver a) -> m a -newBool = exists - -newInt :: (Constraint s ~ Either Model q, MonadTree m, TreeSolver m ~ s) => (ModelInt -> m a) -> m a -newInt = exists - -newCol :: (Constraint s ~ Either Model q, MonadTree m, TreeSolver m ~ s) => (ModelCol -> m a) -> m a -newCol = exists --} - -asBool :: (FDSolver s, MonadTree m, TreeSolver m ~ FDInstance s, ToModelBool t) => t -> m () -asBool = addM . Control.CP.FD.Model.asBool - -sorted :: (Constraint s ~ Either Model q, MonadTree m, TreeSolver m ~ s) => ModelCol -> m () -sorted = addM . Sugar.sorted - -sSorted :: (Constraint s ~ Either Model q, MonadTree m, TreeSolver m ~ s) => ModelCol -> m () -sSorted = addM . Sugar.sSorted - -allDiff :: (Constraint s ~ Either Model q, MonadTree m, TreeSolver m ~ s) => ModelCol -> m () -allDiff = addM . Sugar.allDiff - -allDiffD :: (Constraint s ~ Either Model q, MonadTree m, TreeSolver m ~ s) => ModelCol -> m () -allDiffD = addM . Sugar.allDiffD - -mm (nv@(Term tv)) m x = - let tf t = if (t==tv) then x else Term t - tb t = if (Term t==x) then nv else Term t - in boolTransformEx (tf,ColTerm,BoolTerm,tb,ColTerm,BoolTerm) m - -forall :: (Term s ModelInt, Term s ModelBool, Term s ModelCol, Constraint s ~ Either Model q, MonadTree m, TreeSolver m ~ s) => ModelCol -> (ModelInt -> Tree DummySolver ()) -> m () --- forall col f = exists $ \nv -> addM $ Sugar.forall col $ mm nv $ treeToModel $ f nv -forall col f = addM $ Sugar.forall col (treeToModel . f) - -forany :: (Term s ModelInt, Term s ModelBool, Term s ModelCol, Constraint s ~ Either Model q, MonadTree m, TreeSolver m ~ s) => ModelCol -> (ModelInt -> Tree DummySolver ()) -> m () --- forany col f = exists $ \nv -> addM $ Sugar.forany col $ mm nv $ treeToModel $ f nv -forany col f = addM $ Sugar.forany col (treeToModel . f) - -loopall :: (Term s ModelInt, Term s ModelBool, Term s ModelCol, Constraint s ~ Either Model q, MonadTree m, TreeSolver m ~ s) => (ModelInt,ModelInt) -> (ModelInt -> Tree DummySolver ()) -> m () --- loopall r f = exists $ \nv -> addM $ Sugar.loopall r $ mm nv $ treeToModel $ f nv -loopall r f = addM $ Sugar.loopall r (treeToModel . f) - -loopany :: (Term s ModelInt, Term s ModelBool, Term s ModelCol, Constraint s ~ Either Model q, MonadTree m, TreeSolver m ~ s) => (ModelInt,ModelInt) -> (ModelInt -> Tree DummySolver ()) -> m () --- loopany r f = exists $ \nv -> addM $ Sugar.loopany r $ mm nv $ treeToModel $ f nv -loopany r f = addM $ Sugar.loopany r (treeToModel . f) - -colList :: (Constraint s ~ Either Model q, MonadTree m, TreeSolver m ~ s) => ModelCol -> Int -> m [ModelInt] -colList col len = do - addM $ (Sugar.@=) (size col) (asExpr len) - return $ map (\i -> col!cte i) [0..len-1] - -labelCol :: (FDSolver s, MonadTree m, TreeSolver m ~ FDInstance s, EnumTerm s (FDIntTerm s)) => ModelCol -> m [TermBaseType s (FDIntTerm s)] -labelCol col = label $ do - lst <- getColItems col maxBound - return $ do - lsti <- colList col $ length lst - enumerate lsti - assignments lsti - -infix 5 @: - -(@:) :: (Constraint s ~ Either Model q, MonadTree m, TreeSolver m ~ s, Sugar.ExprRange ModelIntArg ModelColArg ModelBoolArg r, Term s ModelInt, Term s ModelBool, Term s ModelCol) => ModelInt -> r -> m () -a @: b = addM $ (Sugar.@:) a b - -infix 4 @? -infix 4 @?? - -a @? (t,f) = (Sugar.@?) (treeToModel a) (t,f) -a @?? (t,f) = addM $ (Sugar.@??) (treeToModel a) (treeToModel t, treeToModel f) - -allin :: (Constraint s ~ Either Model q, MonadTree m, TreeSolver m ~ s, Sugar.ExprRange ModelIntArg ModelColArg ModelBoolArg r, Term s ModelInt, Term s ModelBool, Term s ModelCol) => ModelCol -> r -> m () -allin c b = Control.CP.FD.Interface.forall c $ \x -> addM $ (Sugar.@:) x b diff --git a/Control/CP/FD/Model.hs b/Control/CP/FD/Model.hs deleted file mode 100644 --- a/Control/CP/FD/Model.hs +++ /dev/null @@ -1,192 +0,0 @@ -{- - - Monadic Constraint Programming - - http://www.cs.kuleuven.be/~toms/Haskell/ - - Tom Schrijvers & Pieter Wuille - -} - -{-# LANGUAGE StandaloneDeriving #-} -{-# LANGUAGE TypeSynonymInstances #-} -{-# LANGUAGE UndecidableInstances #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE FlexibleContexts #-} - -module Control.CP.FD.Model ( - Model, - ModelIntTerm(..), - ModelBoolTerm(..), - ModelColTerm(..), - ModelFunctions(..), - ModelInt, ToModelInt(..), ModelIntArg, - ModelCol, ToModelCol(..), ModelColArg, - ModelBool, ToModelBool(..), ModelBoolArg, - modelVariantInt, modelVariantBool, modelVariantCol, - ModelTermType(..), - showModel, - cte, -) where - -import Data.Expr.Data -import Data.Expr.Util -import Data.Expr.Sugar - -data ModelIntTerm t = - ModelIntVar Int - | ModelIntPar Int - deriving (Show) - -data ModelColTerm t = - ModelColVar Int - | ModelColPar Int - deriving (Show) - -data ModelBoolTerm t = - ModelBoolVar Int - | ModelBoolPar Int - | ModelExtra t - deriving (Show) - -data ModelFunctions = - ForNewBool (ModelBoolExpr ModelFunctions -> Model) - | ForNewInt (ModelIntExpr ModelFunctions -> Model) - | ForNewCol (ModelColExpr ModelFunctions -> Model) - -data ModelIntros = - NewBool Int FlatModel - | NewInt Int FlatModel - | NewCol Int FlatModel - deriving (Show,Eq) - -instance Ord ModelIntros where - compare (NewBool n1 m1) (NewBool n2 m2) = compare n1 n2 <<>> compare m1 m2 - compare (NewBool _ _) _ = LT - compare _ (NewBool _ _) = GT - compare (NewInt n1 m1) (NewInt n2 m2) = compare n1 n2 <<>> compare m1 m2 - compare (NewInt _ _) _ = LT - compare _ (NewInt _ _) = GT - compare (NewCol n1 m1) (NewCol n2 m2) = compare n1 n2 <<>> compare m1 m2 - -instance Show ModelFunctions where - show (ForNewBool f) = show $ explicate (-999999) $ f $ BoolTerm $ ModelBoolVar (-1000000) - show (ForNewInt f) = show $ explicate (-1999999) $ f $ Term $ ModelIntVar (-2000000) - show (ForNewCol f) = show $ explicate (-2999999) $ f $ ColTerm $ ModelColVar (-3000000) - -instance Eq ModelFunctions where - a==b = False - -instance Ord ModelFunctions where - compare _ _ = error "Unable to compare model functions" - --- instance Show Model where --- show x = show $ explicate 0 x - -deriving instance Eq t => Eq (ModelBoolTerm t) -deriving instance Ord t => Ord (ModelBoolTerm t) -deriving instance Eq t => Eq (ModelIntTerm t) -deriving instance Ord t => Ord (ModelIntTerm t) -deriving instance Eq t => Eq (ModelColTerm t) -deriving instance Ord t => Ord (ModelColTerm t) - -type ModelIntExpr t = Expr (ModelIntTerm t) (ModelColTerm t) (ModelBoolTerm t) -type ModelBoolExpr t = BoolExpr (ModelIntTerm t) (ModelColTerm t) (ModelBoolTerm t) -type ModelColExpr t = ColExpr (ModelIntTerm t) (ModelColTerm t) (ModelBoolTerm t) - -type ModelInt = ModelIntExpr ModelFunctions -type ModelBool = ModelBoolExpr ModelFunctions -type ModelCol = ModelColExpr ModelFunctions - -type ModelIntArg = ModelIntTerm ModelFunctions -type ModelBoolArg = ModelBoolTerm ModelFunctions -type ModelColArg = ModelColTerm ModelFunctions - -type FlatModelInt = ModelIntExpr ModelIntros -type FlatModelBool = ModelBoolExpr ModelIntros -type FlatModelCol = ModelColExpr ModelIntros - -type Model = ModelBool -type FlatModel = FlatModelBool - -explicate :: Int -> Model -> FlatModel -explicate num mod = boolTransformEx (it,ct,bt,iit,ict,ibt) mod - where it (ModelIntVar i) = Term $ ModelIntVar i - it (ModelIntPar i) = Term $ ModelIntPar i - ct (ModelColVar i) = ColTerm $ ModelColVar i - ct (ModelColPar i) = ColTerm $ ModelColPar i - iit (ModelIntVar i) = Term $ ModelIntVar i - iit (ModelIntPar i) = Term $ ModelIntPar i - ict (ModelColVar i) = ColTerm $ ModelColVar i - ict (ModelColPar i) = ColTerm $ ModelColPar i - ibt (ModelBoolVar i) = BoolTerm $ ModelBoolVar i - ibt (ModelBoolPar i) = BoolTerm $ ModelBoolPar i - bt (ModelBoolVar i) = BoolTerm $ ModelBoolVar i - bt (ModelBoolPar i) = BoolTerm $ ModelBoolPar i - bt (ModelExtra (ForNewBool f)) = BoolTerm $ ModelExtra $ NewBool num $ explicate (num+1) $ f $ BoolTerm $ ModelBoolVar num - bt (ModelExtra (ForNewInt f)) = BoolTerm $ ModelExtra $ NewInt num $ explicate (num+1) $ f $ Term $ ModelIntVar num - bt (ModelExtra (ForNewCol f)) = BoolTerm $ ModelExtra $ NewCol num $ explicate (num+1) $ f $ ColTerm $ ModelColVar num - -flatten :: Model -> FlatModel -flatten = explicate 0 - -showModel :: Model -> String -showModel = show . flatten - -variantIntTerm :: ModelIntTerm a -> Bool -variantIntTerm (ModelIntVar _) = True -variantIntTerm (ModelIntPar _) = False - -variantBoolTerm :: ModelBoolTerm a -> Bool -variantBoolTerm (ModelBoolVar _) = True -variantBoolTerm (ModelBoolPar _) = False -variantBoolTerm (ModelExtra _) = True - -variantColTerm :: ModelColTerm a -> Bool -variantColTerm (ModelColVar _) = True -variantColTerm (ModelColPar _) = False - -modelVariantInt :: ModelIntExpr x -> Bool -modelVariantInt = property variantIntTerm variantColTerm variantBoolTerm -modelVariantCol :: ModelColExpr x -> Bool -modelVariantCol = colProperty variantIntTerm variantColTerm variantBoolTerm -modelVariantBool :: ModelBoolExpr x -> Bool -modelVariantBool = boolProperty variantIntTerm variantColTerm variantBoolTerm - -newBool :: (ModelBool -> Model) -> Model -newBool = boolSimplify . BoolTerm . ModelExtra . ForNewBool - -newInt :: (ModelInt -> Model) -> Model -newInt = boolSimplify . BoolTerm . ModelExtra . ForNewInt - -newCol :: (ModelCol -> Model) -> Model -newCol = boolSimplify . BoolTerm . ModelExtra . ForNewCol - -class ModelTermType s where - newModelTerm :: (s -> Model) -> Model - -instance ModelTermType ModelBool where - newModelTerm = newBool - -instance ModelTermType ModelInt where - newModelTerm = newInt - -instance ModelTermType ModelCol where - newModelTerm = newCol - -cte :: Integral a => a -> ModelInt -cte = Const . toInteger - -class ToModelBool t where - asBool :: t -> ModelBool - -class ToModelInt t where - asExpr :: t -> ModelInt - -class ToModelCol t where - asCol :: t -> ModelCol - -instance ToExpr (ModelIntTerm ModelFunctions) (ModelColTerm ModelFunctions) (ModelBoolTerm ModelFunctions) t => ToModelInt t where - asExpr = toExpr - -instance ToBoolExpr (ModelIntTerm ModelFunctions) (ModelColTerm ModelFunctions) (ModelBoolTerm ModelFunctions) t => ToModelBool t where - asBool = toBoolExpr - -instance ToColExpr (ModelIntTerm ModelFunctions) (ModelColTerm ModelFunctions) (ModelBoolTerm ModelFunctions) t => ToModelCol t where - asCol = toColExpr diff --git a/Control/CP/FD/OvertonFD/Domain.hs b/Control/CP/FD/OvertonFD/Domain.hs deleted file mode 100644 --- a/Control/CP/FD/OvertonFD/Domain.hs +++ /dev/null @@ -1,187 +0,0 @@ -{- - - Origin: - - Constraint Programming in Haskell - - http://overtond.blogspot.com/2008/07/pre.html - - author: David Overton, Melbourne Australia - - - - Modifications: - - Monadic Constraint Programming - - http://www.cs.kuleuven.be/~toms/Haskell/ - - Tom Schrijvers - -} - -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE IncoherentInstances #-} -{-# LANGUAGE UndecidableInstances #-} - -module Control.CP.FD.OvertonFD.Domain ( - Domain, - ToDomain, - toDomain, - member, - isSubsetOf, - elems, - intersection, - difference, - union, - empty, - null, - singleton, - isSingleton, - filterLessThan, - filterGreaterThan, - findMax, - findMin, - size, - shiftDomain, - mapDomain, - absDomain -) where - -import qualified Data.IntSet as IntSet -import Data.IntSet (IntSet) -import Prelude hiding (null) -import Control.CP.Debug - -data Domain - = Set IntSet - | Range !Int !Int - deriving Show - -size :: Domain -> Int -size (Range l u) = u - l + 1 -size (Set set) = IntSet.size set - --- Domain constructors -class ToDomain a where - toDomain :: a -> Domain - -instance ToDomain Domain where - toDomain = id - -instance ToDomain IntSet where - toDomain = Set - -instance Integral a => ToDomain [a] where - toDomain = toDomain . IntSet.fromList . map fromIntegral - -instance (Integral a, Integral b) => ToDomain (a, b) where - toDomain (a, b) = Range (fromIntegral a) (fromIntegral b) - -instance ToDomain () where - toDomain () = Range (-1000000000) 1000000000 -- minBound maxBound (too sensitive to overflow, e.g. 2 * minBound == 0) - -instance Integral a => ToDomain a where - toDomain a = toDomain (a, a) - --- Operations on Domains -instance Eq Domain where - (Range xl xh) == (Range yl yh) = xl == yl && xh == yh - xs == ys = elems xs == elems ys - -member :: Int -> Domain -> Bool -member n x@(Set xs) = debugDom "[Domain.member]" x $ n `IntSet.member` xs -member n x@(Range xl xh) = debugDom "[Domain.member]" x $ n >= xl && n <= xh - -isSubsetOf :: Domain -> Domain -> Bool -isSubsetOf x@(Set xs) (Set ys) = debugDom "[Domain.isso]" x $ xs `IntSet.isSubsetOf` ys -isSubsetOf x@(Range xl xh) (Range yl yh) = debugDom "[Domain.isso]" x $ xl >= yl && xh <= yh -isSubsetOf x@(Set xs) yd@(Range yl yh) = debugDom "[Domain.isso]" x $ - isSubsetOf (Range xl xh) yd where - xl = IntSet.findMin xs - xh = IntSet.findMax xs -isSubsetOf (Range xl xh) x@(Set ys) = debugDom "[Domain.isso]" x $ - all (`IntSet.member` ys) [xl..xh] - -elems :: Domain -> [Int] -elems x@(Set xs) = debugDom "[Domain.elems]" x $ IntSet.elems xs -elems x@(Range xl xh) = debugDom "[Domain.elems]" x $ [xl..xh] - -intersection :: Domain -> Domain -> Domain -intersection x@(Set xs) (Set ys) = debugDom "[Domain.intersection]" x $ Set (xs `IntSet.intersection` ys) -intersection x@(Range xl xh) (Range yl yh) = debugDom "[Domain.intersection]" x $ Range (max xl yl) (min xh yh) -intersection x@(Set xs) (Range yl yh) = debugDom "[Domain.intersection]" x $ - Set $ IntSet.filter (\x -> x >= yl && x <= yh) xs -intersection x y = intersection y x - -union :: Domain -> Domain -> Domain -union x@(Set xs) (Set ys) = debugDom "[Domain.union]" x $ Set (xs `IntSet.union` ys) -union x@(Range xl xh) (Range yl yh) - | xh + 1 >= yl || yh+1 >= xl = debugDom "[Domain.union]" x $ Range (min xl yl) (max xh yh) - | otherwise = debugDom "[Domain.union]" x $ union (Set $ IntSet.fromList [xl..xh]) (Set $ IntSet.fromList [yl..yh]) -union x@(Set xs) y@(Range yl yh) = debugDom "[Domain.union]" x $ - if null x then y - else - let xmin = IntSet.findMin xs - xmax = IntSet.findMax xs - in - if (xmin + 1 >= yl && xmax - 1 <= yh) - then Range (min xmin yl) (max xmax yh) - else union (Set xs) (Set $ IntSet.fromList [yl..yh]) -union x y = union y x - -difference :: Domain -> Domain -> Domain -difference (x@(Set xs)) (y@(Set ys)) = debugDom "[Domain.difference]" x $ Set (xs `IntSet.difference` ys) -difference xd@(Range xl xh) (Range yl yh) - | yl > xh || yh < xl = debugDom "[Domain.difference]" xd $ xd - | otherwise = debugDom "[Domain.difference]" xd $ Set $ IntSet.fromList [x | x <- [xl..xh], x < yl || x > yh] -difference (x@(Set xs)) (Range yl yh) = - debugDom "[Domain.difference]" x $ Set $ IntSet.filter (\x -> x < yl || x > yh) xs -difference (x@(Range xl xh)) (Set ys) - | IntSet.findMin ys > xh || IntSet.findMax ys < xl = debugDom "[Domain.difference]" x $ Range xl xh - | otherwise = debugDom "[Domain.difference]" x $ Set $ - IntSet.fromList [x | x <- [xl..xh], not (x `IntSet.member` ys)] - -null :: Domain -> Bool -null (x@(Set xs)) = debug ("[Domain.null] " ++ printDom x) $ IntSet.null xs -null (x@(Range xl xh)) = debug ("[Domain.null] " ++ printDom x) $ xl > xh - -singleton :: Int -> Domain -singleton x = Range x x - -isSingleton :: Domain -> Bool -isSingleton (x@(Set xs)) = debugDom "[Domain.isSingleton]" x $ (IntSet.size xs)==1 -isSingleton (x@(Range xl xh)) = debug ("[Domain.isSingleton] " ++ printDom x) $ xl == xh - -filterLessThan :: Int -> Domain -> Domain -filterLessThan n (x@(Set xs)) = debug ("[Domain.filterLess] " ++ printDom x) $ Set $ IntSet.filter (< n) xs -filterLessThan n (x@(Range xl xh)) = debug ("[Domain.filterLess] " ++ printDom x) $ Range xl (min (n-1) xh) - -filterGreaterThan :: Int -> Domain -> Domain -filterGreaterThan n (x@(Set xs)) = debug ("[Domain.filterGreater] " ++ printDom x) $ Set $ IntSet.filter (> n) xs -filterGreaterThan n (x@(Range xl xh)) = debug ("[Domain.filterGreater] " ++ printDom x) $ Range (max (n+1) xl) xh - -findMax :: Domain -> Int -findMax (x@(Set xs)) = debug ("[Domain.findMax] " ++ printDom x) $ IntSet.findMax xs -findMax (x@(Range xl xh)) = debug ("[Domain.findMax] " ++ printDom x) $ xh - -findMin :: Domain -> Int -findMin (Set xs) = IntSet.findMin xs -findMin (Range xl xh) = xl - -empty :: Domain -empty = Range 1 0 - -shiftDomain :: Domain -> Int -> Domain -shiftDomain (x@(Range l u)) d = debug ("[Domain.shift] " ++ printDom x) $ Range (l + d) (u + d) -shiftDomain (x@(Set xs)) d = debug ("[Domain.shift] " ++ printDom x) $ Set $ IntSet.fromList $ map (+d) (IntSet.elems xs) - -mapDomain :: Domain -> (Int -> [Int]) -> Domain -mapDomain d f = debug ("[Domain.map] " ++ printDom d) $ Set $ IntSet.fromList $ concatMap f $ elems d - -absDomain :: Domain -> Domain -absDomain d@(Range l u) | l >= 0 = d - | u < 0 = Range (abs u) (abs l) - | otherwise = Range 0 (max (abs l) u) -absDomain d@(Set s) | IntSet.findMin s >= 0 = d - | otherwise = Set $ IntSet.map abs s - -mirrorDomain :: Domain -> Domain -mirrorDomain d@(Range l u) | l <= 0 && u >= 0 = Range (min l (-u)) (max (-l) u) - -printDom :: Domain -> String -printDom (Set cs) = "dom:Set(#" ++ (show $ IntSet.size cs) ++ ")" -printDom (Range l h) = "dom:Range(#" ++ (show $ h-l+1) ++ ":" ++ (show l) ++ "-" ++ (show h) ++ ")" - -debugDom :: String -> Domain -> a -> a -debugDom s d a = debug ("[Domain.findMax] " ++ printDom d) a diff --git a/Control/CP/FD/OvertonFD/OvertonFD.hs b/Control/CP/FD/OvertonFD/OvertonFD.hs deleted file mode 100644 --- a/Control/CP/FD/OvertonFD/OvertonFD.hs +++ /dev/null @@ -1,392 +0,0 @@ -{- - - Origin: - - Constraint Programming in Haskell - - http://overtond.blogspot.com/2008/07/pre.html - - author: David Overton, Melbourne Australia - - - - Modifications: - - Monadic Constraint Programming - - http://www.cs.kuleuven.be/~toms/Haskell/ - - Tom Schrijvers - -} - -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE GeneralizedNewtypeDeriving #-} - -module Control.CP.FD.OvertonFD.OvertonFD ( - OvertonFD, - fd_objective, - fd_domain, - FDVar, - OConstraint(..), - lookup, -) where - -import Prelude hiding (lookup) -import Data.Maybe (fromJust,isJust) -import Control.Monad.State.Lazy -import Control.Monad.Trans -import qualified Data.Map as Map -import Data.Map ((!), Map) -import Control.Monad (liftM,(<=<)) - -import Control.CP.FD.OvertonFD.Domain as Domain -import Control.CP.FD.FD hiding ((!)) -import Control.CP.Solver -import Control.CP.SearchTree -import Control.CP.EnumTerm - -import Control.CP.Debug - --------------------------------------------------------------------------------- --- Solver instance ------------------------------------------------------------- --------------------------------------------------------------------------------- - -data OConstraint = - OHasValue FDVar Int - | OSame FDVar FDVar - | ODiff FDVar FDVar - | OLess FDVar FDVar - | OLessEq FDVar FDVar - | OAdd FDVar FDVar FDVar - | OSub FDVar FDVar FDVar - | OMult FDVar FDVar FDVar - | OAbs FDVar FDVar - deriving (Show,Eq) - -instance Solver OvertonFD where - type Constraint OvertonFD = OConstraint - type Label OvertonFD = FDState - add c = debug ("addOverton("++(show c)++")") $ addOverton c - run p = debug ("runOverton") $ runOverton p - mark = get - goto = put - -instance Term OvertonFD FDVar where - newvar = newVar () - type Help OvertonFD FDVar = () - help _ _ = () - -instance EnumTerm OvertonFD FDVar where - type TermBaseType OvertonFD FDVar = Int - getDomain = fd_domain - setValue var val = return [var `OHasValue` val] - --------------------------------------------------------------------------------- --- Constraints ----------------------------------------------------------------- --------------------------------------------------------------------------------- - -addOverton (OHasValue v i) = v `hasValue` i -addOverton (OSame a b) = a `same` b -addOverton (ODiff a b) = a `different` b -addOverton (OLess a b) = a .<. b -addOverton (OLessEq a b) = a .<=. b -addOverton (OAdd a b c) = addSum a b c -addOverton (OSub a b c) = addSub a b c -addOverton (OMult a b c) = addMult a b c -addOverton (OAbs a b) = addAbs a b - -fd_domain :: FDVar -> OvertonFD [Int] -fd_domain v = do d <- lookup v - return $ elems d - -fd_objective :: OvertonFD FDVar -fd_objective = - do s <- get - return $ objective s - --------------------------------------------------------------------------------- - --- The FD monad -newtype OvertonFD a = OvertonFD { unFD :: State FDState a } - deriving (Monad, MonadState FDState) - --- FD variables -newtype FDVar = FDVar { unFDVar :: Int } deriving (Ord, Eq, Show) - -type VarSupply = FDVar - -data VarInfo = VarInfo - { delayedConstraints :: OvertonFD Bool, domain :: Domain } - -instance Show VarInfo where - show x = show $ domain x - -type VarMap = Map FDVar VarInfo - -data FDState = FDState - { varSupply :: VarSupply, varMap :: VarMap, objective :: FDVar } - deriving Show - -instance Eq FDState where - s1 == s2 = f s1 == f s2 - where f s = head $ elems $ domain $ varMap s ! (objective s) - -instance Ord FDState where - compare s1 s2 = compare (f s1) (f s2) - where f s = head $ elems $ domain $ varMap s ! (objective s) - - -- TOM: inconsistency is not observable within the OvertonFD monad -consistentFD :: OvertonFD Bool -consistentFD = return True - --- Run the FD monad and produce a lazy list of possible solutions. -runOverton :: OvertonFD a -> a -runOverton fd = - let j = evalState (unFD fd) initState - in j - -initState :: FDState -initState = FDState { varSupply = FDVar 0, varMap = Map.empty, objective = FDVar 0 } - --- Get a new FDVar -newVar :: ToDomain a => a -> OvertonFD FDVar -newVar d = do - s <- get - let v = varSupply s - put $ s { varSupply = FDVar (unFDVar v + 1) } - modify $ \s -> - let vm = varMap s - vi = VarInfo { - delayedConstraints = return True, - domain = toDomain d} - in - s { varMap = Map.insert v vi vm } - return v - -newVars :: ToDomain a => Int -> a -> OvertonFD [FDVar] -newVars n d = replicateM n (newVar d) - --- Lookup the current domain of a variable. -lookup :: FDVar -> OvertonFD Domain -lookup x = do - s <- get - return . domain $ varMap s ! x - --- Update the domain of a variable and fire all delayed constraints --- associated with that variable. -update :: FDVar -> Domain -> OvertonFD Bool -update x i = do - debug (show x ++ " <- " ++ show i) (return ()) - s <- get - let vm = varMap s - let vi = vm ! x - debug ("where old domain = " ++ show (domain vi)) (return ()) - put $ s { varMap = Map.insert x (vi { domain = i}) vm } - delayedConstraints vi - --- Add a new constraint for a variable to the constraint store. -addConstraint :: FDVar -> OvertonFD Bool -> OvertonFD () -addConstraint x constraint = do - s <- get - let vm = varMap s - let vi = vm ! x - let cs = delayedConstraints vi - put $ s { varMap = - Map.insert x (vi { delayedConstraints = do b <- cs - if b then constraint - else return False}) vm } - --- Useful helper function for adding binary constraints between FDVars. -type BinaryConstraint = FDVar -> FDVar -> OvertonFD Bool -addBinaryConstraint :: BinaryConstraint -> BinaryConstraint -addBinaryConstraint f x y = do - let constraint = f x y - b <- constraint - when b $ (do addConstraint x constraint - addConstraint y constraint) - return b - --- Constrain a variable to a particular value. -hasValue :: FDVar -> Int -> OvertonFD Bool -var `hasValue` val = do - vals <- lookup var - if val `member` vals - then do let i = singleton val - if (i /= vals) - then update var i - else return True - else return False - --- Constrain two variables to have the same value. -same :: FDVar -> FDVar -> OvertonFD Bool -same = addBinaryConstraint $ \x y -> do - debug "inside same" $ return () - xv <- lookup x - yv <- lookup y - debug (show xv ++ " same " ++ show yv) $ return () - let i = xv `intersection` yv - if not $ Domain.null i - then whenwhen (i /= xv) (i /= yv) (update x i) (update y i) - else return False - -whenwhen c1 c2 a1 a2 = - if c1 - then do b1 <- a1 - if b1 - then if c2 - then a2 - else return True - else return False - else if c2 - then a2 - else return True - --- Constrain two variables to have different values. -different :: FDVar -> FDVar -> OvertonFD Bool -different = addBinaryConstraint $ \x y -> do - xv <- lookup x - yv <- lookup y - if not (isSingleton xv) || not (isSingleton yv) || xv /= yv - then whenwhen (isSingleton xv && xv `isSubsetOf` yv) - (isSingleton yv && yv `isSubsetOf` xv) - (update y (yv `difference` xv)) - (update x (xv `difference` yv)) - else return False - --- Constrain one variable to have a value less than the value of another --- variable. -infix 4 .<. -(.<.) :: FDVar -> FDVar -> OvertonFD Bool -(.<.) = addBinaryConstraint $ \x y -> do - xv <- lookup x - yv <- lookup y - let xv' = filterLessThan (findMax yv) xv - let yv' = filterGreaterThan (findMin xv) yv - if not $ Domain.null xv' - then if not $ Domain.null yv' - then whenwhen (xv /= xv') (yv /= yv') (update x xv') (update y yv') - else return False - else return False - --- Constrain one variable to have a value less than or equal to the value of another --- variable. -infix 4 .<=. -(.<=.) :: FDVar -> FDVar -> OvertonFD Bool -(.<=.) = addBinaryConstraint $ \x y -> do - xv <- lookup x - yv <- lookup y - let xv' = filterLessThan (1 + findMax yv) xv - let yv' = filterGreaterThan ((findMin xv) - 1) yv - if not $ Domain.null xv' - then if not $ Domain.null yv' - then whenwhen (xv /= xv') (yv /= yv') (update x xv') (update y yv') - else return False - else return False - -{- --- Get all solutions for a constraint without actually updating the --- constraint store. -solutions :: OvertonFD s a -> OvertonFD s [a] -solutions constraint = do - s <- get - return $ evalStateT (unFD constraint) s - --- Label variables using a depth-first left-to-right search. -labelling :: [FDVar s] -> OvertonFD s [Int] -labelling = mapM label where - label var = do - vals <- lookup var - val <- OvertonFD . lift $ elems vals - var `hasValue` val - return val --} - -dump :: [FDVar] -> OvertonFD [Domain] -dump = mapM lookup - --- Add constraint (z = x `op` y) for var z -addArithmeticConstraint :: - (Domain -> Domain -> Domain) -> - (Domain -> Domain -> Domain) -> - (Domain -> Domain -> Domain) -> - FDVar -> FDVar -> FDVar -> OvertonFD Bool -addArithmeticConstraint getZDomain getXDomain getYDomain x y z = do - xv <- lookup x - yv <- lookup y - let constraint z x y getDomain = do - xv <- lookup x - yv <- lookup y - zv <- lookup z - let znew = debug "binaryArith:intersection" $ (debug "binaryArith:zv" $ zv) `intersection` (debug "binaryArith:getDomain" $ getDomain xv yv) - debug ("binaryArith:" ++ show z ++ " before: " ++ show zv ++ show "; after: " ++ show znew) (return ()) - if debug "binaryArith:null?" $ not $ Domain.null (debug "binaryArith:null?:znew" $ znew) - then if (znew /= zv) - then debug ("binaryArith:update") $ update z znew - else return True - else return False - let zConstraint = debug "binaryArith: zConstraint" $ constraint z x y getZDomain - xConstraint = debug "binaryArith: xConstraint" $ constraint x z y getXDomain - yConstraint = debug "binaryArith: yConstraint" $ constraint y z x getYDomain - debug ("addBinaryArith: z x") (return ()) - addConstraint z xConstraint - debug ("addBinaryArith: z y") (return ()) - addConstraint z yConstraint - debug ("addBinaryArith: x z") (return ()) - addConstraint x zConstraint - debug ("addBinaryArith: x y") (return ()) - addConstraint x yConstraint - debug ("addBinaryArith: y z") (return ()) - addConstraint y zConstraint - debug ("addBinaryArith: y x") (return ()) - addConstraint y xConstraint - debug ("addBinaryArith: done") (return ()) - return True - --- Add constraint (z = op x) for var z -addUnaryArithmeticConstraint :: (Domain -> Domain) -> (Domain -> Domain) -> FDVar -> FDVar -> OvertonFD Bool -addUnaryArithmeticConstraint getZDomain getXDomain x z = do - xv <- lookup x - let constraint z x getDomain = do - xv <- lookup x - zv <- lookup z - let znew = zv `intersection` (getDomain xv) - debug ("unaryArith:" ++ show z ++ " before: " ++ show zv ++ show "; after: " ++ show znew) (return ()) - if not $ Domain.null znew - then if (znew /= zv) - then update z znew - else return True - else return False - let zConstraint = constraint z x getZDomain - xConstraint = constraint x z getXDomain - addConstraint z xConstraint - addConstraint x zConstraint - return True - -addSum = addArithmeticConstraint getDomainPlus getDomainMinus getDomainMinus - -addSub = addArithmeticConstraint getDomainMinus getDomainPlus (flip getDomainMinus) - -addMult = addArithmeticConstraint getDomainMult getDomainDiv getDomainDiv - -addAbs = addUnaryArithmeticConstraint absDomain (\z -> mapDomain z (\i -> [i,-i])) - -getDomainPlus :: Domain -> Domain -> Domain -getDomainPlus xs ys = toDomain (zl, zh) where - zl = findMin xs + findMin ys - zh = findMax xs + findMax ys - -getDomainMinus :: Domain -> Domain -> Domain -getDomainMinus xs ys = toDomain (zl, zh) where - zl = findMin xs - findMax ys - zh = findMax xs - findMin ys - -getDomainMult :: Domain -> Domain -> Domain -getDomainMult xs ys = (\d -> debug ("multDomain" ++ show d ++ "=" ++ show xs ++ "*" ++ show ys ) d) $ toDomain (zl, zh) where - zl = minimum products - zh = maximum products - products = [x * y | - x <- [findMin xs, findMax xs], - y <- [findMin ys, findMax ys]] - -getDomainDiv :: Domain -> Domain -> Domain -getDomainDiv xs ys = toDomain (zl, zh) where - zl = minimum quotientsl - zh = maximum quotientsh - quotientsl = [if y /= 0 then x `div` y else minBound | - x <- [findMin xs, findMax xs], - y <- [findMin ys, findMax ys]] - quotientsh = [if y /= 0 then x `div` y else maxBound | - x <- [findMin xs, findMax xs], - y <- [findMin ys, findMax ys]] diff --git a/Control/CP/FD/OvertonFD/Sugar.hs b/Control/CP/FD/OvertonFD/Sugar.hs deleted file mode 100644 --- a/Control/CP/FD/OvertonFD/Sugar.hs +++ /dev/null @@ -1,112 +0,0 @@ -{-# LANGUAGE TypeFamilies #-} - -module Control.CP.FD.OvertonFD.Sugar ( -) where - -import Data.Set(Set) -import qualified Data.Set as Set - -import Control.CP.Debug -import Control.Mixin.Mixin -import Control.CP.Solver -import Control.CP.FD.FD -import Control.CP.FD.SimpleFD -import Data.Expr.Data -import Data.Expr.Sugar --- import Control.CP.FD.Expr.Util -import Control.CP.FD.Model -import Control.CP.FD.Graph -import Control.CP.FD.OvertonFD.OvertonFD - -newVars :: Term s t => Int -> s [t] -newVars 0 = return [] -newVars n = do - l <- newVars $ n-1 - n <- newvar - return $ n:l - -instance FDSolver OvertonFD where - type FDIntTerm OvertonFD = FDVar - type FDBoolTerm OvertonFD = FDVar - - type FDIntSpec OvertonFD = FDVar - type FDBoolSpec OvertonFD = FDVar - type FDColSpec OvertonFD = [FDVar] - - type FDIntSpecType OvertonFD = () - type FDBoolSpecType OvertonFD = () - type FDColSpecType OvertonFD = () - - fdIntSpec_const (Const i) = ((),do - v <- newvar - add $ OHasValue v $ fromInteger i - return v) - fdIntSpec_term i = ((),return i) - - fdBoolSpec_const (BoolConst i) = ((),do - v <- newvar - add $ OHasValue v $ if i then 1 else 0 - return v) - fdBoolSpec_term i = ((),return i) - - fdColSpec_list l = ((),return l) - fdColSpec_size (Const s) = ((),newVars $ fromInteger s) - fdColSpec_const l = ((),error "constant collections not yet supported by overton interface") - - fdColInspect = return - - fdSpecify = specify <@> simple_fdSpecify - fdProcess = process <@> simple_fdProcess - - fdEqualInt v1 v2 = addFD $ OSame v1 v2 - fdEqualBool v1 v2 = addFD $ OSame v1 v2 - fdEqualCol v1 v2 = do - if length v1 /= length v2 - then setFailed - else sequence_ $ zipWith (\a b -> addFD $ OSame a b) v1 v2 - - fdIntVarSpec = return . Just - fdBoolVarSpec = return . Just - fdSplitIntDomain b = do - d <- fd_domain b - return $ (map (b `OHasValue`) d, True) - fdSplitBoolDomain b = do - d <- fd_domain b - return $ (map (b `OHasValue`) $ filter (\x -> x==0 || x==1) d, True) - --- processBinary :: (EGVarId,EGVarId,EGVarId) -> (FDVar -> FDVar -> FDVar -> OConstraint) -> FDInstance OvertonFD () -processBinary (v1,v2,va) f = addFD $ f (getDefIntSpec v1) (getDefIntSpec v2) (getDefIntSpec va) - --- processUnary :: (EGVarId,EGVarId) -> (FDVar -> FDVar -> OConstraint) -> FDInstance OvertonFD () -processUnary (v1,va) f = addFD $ f (getDefIntSpec v1) (getDefIntSpec va) - -specify :: Mixin (SpecFn OvertonFD) -specify s t edge = case (debug ("overton-specify("++(show edge)++")") edge) of - EGEdge { egeCons = EGChannel, egeLinks = EGTypeData { intData=[i], boolData=[b] } } -> - ([(1000,b,True,do - s <- getIntSpec i - case s of - Just ss -> return $ SpecResSpec ((),return (ss,Nothing)) - _ -> return SpecResNone - )],[(1000,i,True,do - s <- getBoolSpec b - case s of - Just ss -> return $ SpecResSpec ((),return (ss,Nothing)) - _ -> return SpecResNone - )],[]) - _ -> s edge - --- process :: Mixin (EGEdge -> FDInstance OvertonFD ()) -process s t con info = case (con,info) of - (EGIntValue c, ([],[a],[])) -> case c of - Const v -> addFD $ OHasValue (getDefIntSpec a) (fromInteger v) - _ -> error "Overton solver does not support parametrized values" - (EGPlus, ([],[a,b,c],[])) -> processBinary (b,c,a) OAdd - (EGMinus, ([],[a,b,c],[])) -> processBinary (a,c,b) OAdd - (EGMult, ([],[a,b,c],[])) -> processBinary (b,c,a) OMult - (EGAbs, ([],[a,b],[])) -> processUnary (b,a) OAbs - (EGDiff, ([FDSpecInfoBool {fdspBoolVal = Just (BoolConst True)}],[a,b],[])) -> addFD $ ODiff (getDefIntSpec a) (getDefIntSpec b) - (EGLess True, ([FDSpecInfoBool {fdspBoolVal = Just (BoolConst True)}],[a,b],[])) -> addFD $ OLess (getDefIntSpec a) (getDefIntSpec b) - (EGLess False, ([FDSpecInfoBool {fdspBoolVal = Just (BoolConst True)}],[a,b],[])) -> addFD $ OLessEq (getDefIntSpec a) (getDefIntSpec b) - (EGEqual, ([FDSpecInfoBool {fdspBoolVal = Just (BoolConst True)}],[a,b],[])) -> addFD $ OSame (getDefIntSpec a) (getDefIntSpec b) - _ -> s con info diff --git a/Control/CP/FD/SearchSpec/Data.hs b/Control/CP/FD/SearchSpec/Data.hs deleted file mode 100644 --- a/Control/CP/FD/SearchSpec/Data.hs +++ /dev/null @@ -1,111 +0,0 @@ -{-# LANGUAGE StandaloneDeriving #-} - -module Control.CP.FD.SearchSpec.Data ( - OptimDirection(..), - VarExpr(..), - VarStat(..), - Labelling(..), - SearchSpec(..), - ConstraintExpr, - ConstraintRefs(..), - mmapSearch -) where - -import Control.CP.Solver -import Control.CP.FD.FD -import Data.Expr.Data -import Control.Search.Generator -import Control.Search.Language - --- Wouter Swierstra - Data Types a la Carte --- Jacques Carette, Oleg - Finally Tagless - -data VarStat = - DLowerBound - | DUpperBound - | DDomSize - | DLowerRegret - | DUpperRegret - | DDegree - | DWDregree - | DRandom - | DMedian - | DDummy Int - deriving (Eq,Ord,Show) - -data OptimDirection = - Maximize - | Minimize - deriving (Eq,Ord,Show) - -type VarExpr = Expr VarStat () () - -data ConstraintRefs = - VarRef - | ValRef - deriving (Eq,Ord,Show) - -type ConstraintExpr = Expr ConstraintRefs () () -type ConstraintBoolExpr = BoolExpr ConstraintRefs () () - -data Labelling v a b = - LabelInt v VarExpr (ConstraintExpr -> ConstraintExpr-> ConstraintBoolExpr) - | LabelCol a VarExpr OptimDirection VarExpr (ConstraintExpr -> ConstraintExpr -> ConstraintBoolExpr) - | LabelBool b VarExpr - -data SearchSpec v a b = - Labelling (Labelling v a b) - | CombineSeq (SearchSpec v a b) (SearchSpec v a b) - | CombinePar (SearchSpec v a b) (SearchSpec v a b) - | TryOnce (SearchSpec v a b) - | LimitSolCount Integer (SearchSpec v a b) - | LimitDepth Integer (SearchSpec v a b) - | LimitNodeCount Integer (SearchSpec v a b) - | LimitDiscrepancy Integer (SearchSpec v a b) - | BranchBound v OptimDirection (SearchSpec v a b) - | PrintSol [v] [a] [b] (SearchSpec v a b) - -deriving instance (Show v, Show a, Show b) => Show (SearchSpec v a b) - -instance (Show v, Show a, Show b) => Show (Labelling v a b) where - show (LabelInt v x f) = "LabelInt " ++ (show v) ++ " " ++ (show x) ++ " " ++ (show $ f (Term VarRef) (Term ValRef)) - show (LabelCol v x d s f) = "LabelCol " ++ (show v) ++ " " ++ (show x) ++ " " ++ show d ++ " " ++ show s ++ " " ++ (show $ f (Term VarRef) (Term ValRef)) - show (LabelBool v x) = "LabelBool " ++ (show v) ++ " " ++ (show x) - -mmapSearch :: (Monad m) => SearchSpec v1 a1 b1 -> (v1 -> m v2) -> (a1 -> m a2) -> (b1 -> m b2) -> m (SearchSpec v2 a2 b2) -mmapSearch (Labelling (LabelInt v x f)) vf af bf = vf v >>= \y -> return $ Labelling $ LabelInt y x f -mmapSearch (Labelling (LabelCol a x d s f)) vf af bf = af a >>= \y -> return $ Labelling $ LabelCol y x d s f -mmapSearch (Labelling (LabelBool v x)) vf af bf = bf v >>= \y -> return $ Labelling $ LabelBool y x -mmapSearch (CombineSeq a b) vf af bf = do - ad <- mmapSearch a vf af bf - bd <- mmapSearch b vf af bf - return (CombineSeq ad bd) -mmapSearch (CombinePar a b) vf af bf = do - ad <- mmapSearch a vf af bf - bd <- mmapSearch b vf af bf - return (CombinePar ad bd) -mmapSearch (TryOnce a) vf af bf = do - ad <- mmapSearch a vf af bf - return (TryOnce ad) -mmapSearch (LimitSolCount n a) vf af bf = do - ad <- mmapSearch a vf af bf - return (LimitSolCount n ad) -mmapSearch (LimitDepth n a) vf af bf = do - ad <- mmapSearch a vf af bf - return $ (LimitDepth n ad) -mmapSearch (LimitNodeCount n a) vf af bf = do - ad <- mmapSearch a vf af bf - return $ (LimitNodeCount n ad) -mmapSearch (LimitDiscrepancy n a) vf af bf = do - ad <- mmapSearch a vf af bf - return $ (LimitDiscrepancy n ad) -mmapSearch (BranchBound v d a) vf af bf = do - vd <- vf v - ad <- mmapSearch a vf af bf - return (BranchBound vd d ad) -mmapSearch (PrintSol i c b a) iF cF bF = do - vi <- mapM iF i - vc <- mapM cF c - vb <- mapM bF b - ad <- mmapSearch a iF cF bF - return (PrintSol vi vc vb ad) diff --git a/Control/CP/FD/SimpleFD.hs b/Control/CP/FD/SimpleFD.hs deleted file mode 100644 --- a/Control/CP/FD/SimpleFD.hs +++ /dev/null @@ -1,190 +0,0 @@ -{-# LANGUAGE TypeFamilies #-} - -module Control.CP.FD.SimpleFD ( - simple_fdSpecify, - simple_fdProcess, -) where - -import Data.List (tails) -import qualified Data.Set as Set - -import Control.CP.Debug -import Control.Mixin.Mixin -import Control.CP.FD.FD -import Control.CP.Solver -import Control.CP.FD.Graph -import Data.Expr.Data --- import Control.CP.FD.Expr.Util - -itake :: [a] -> Int -> Int -> [a] -itake _ _ 0 = [] -itake [] _ _ = [] -itake (a:ar) 0 l = a:(itake ar 0 (l-1)) -itake (a:ar) p l = itake ar (p-1) l - -simple_fdSpecify :: (FDSolver s, FDColSpec s ~ [FDIntTerm s], FDIntSpec s ~ FDIntTerm s, FDBoolSpec s ~ FDBoolTerm s) => Mixin (SpecFn s) -simple_fdSpecify s t edge = case (debug ("simple_fdSpecify("++(show edge)++")") edge) of - EGEdge { egeCons=EGAt, egeLinks = EGTypeData { colData=[c], intData=[r,p] } } -> - ([],[(500,r,True,do - k <- getIntVal p - case k of - Just (Const kk) -> do - Just cc <- getColSpec c - let trm = cc !! fromInteger kk - return $ SpecResSpec (minBound,return $ (trm, Nothing)) - _ -> return SpecResNone - )],[]) -{- EGEdge { egeCons=EGSlice f n, egeLinks = EGTypeData { colData=[r,s] } } -> - ([],[],[(500,r,True,do - (Just ss) <- getColSpec s - return $ SpecResSpec (minBound,return $ [ss !! (\(Const x) -> fromInteger x) (f i) | i <- [0..n-1]]) - )]) -} - EGEdge { egeCons=EGCat, egeLinks = EGTypeData { colData=[r,a,b] } } -> - ([],[],[(500,r,True,do - Just aa <- getColSpec a - Just bb <- getColSpec b - return $ SpecResSpec (minBound,return (aa++bb,Nothing)) - )]) -{- EGEdge { egeCons=EGRange, egeLinks = EGTypeData { intData=[l,h], colData=[c] } } -> - ([],[],[(550,c,False,do - ll <- getIntVal l - hh <- getIntVal h - case (ll,hh) of - (Just lll, Just hhh) -> return $ SpecResSpec (fdColSpec_size (hhh-lll+1) >>= \(t,v) -> return (t,(v,Nothing))) - _ -> return SpecResNone - )]) -} - _ -> s edge - -trueSpec = FDSpecInfoBool {fdspBoolSpec=const Nothing,fdspBoolVar=Nothing,fdspBoolVal=Just $ BoolConst True,fdspBoolTypes=Set.empty} - -simple_fdProcess :: (FDSolver s, FDColSpec s ~ [FDIntTerm s], FDIntSpec s ~ FDIntTerm s, FDBoolSpec s ~ FDBoolTerm s) => Mixin (EGConstraintSpec -> FDSpecInfo s -> FDInstance s ()) -simple_fdProcess s t cons info = case (cons,info) of - (EGAt,(_,[r,FDSpecInfoInt {fdspIntVal = Just (Const n)}],[c])) -> do - let cc = getDefColSpec c - sr = getDefIntSpec r - fdEqualInt (cc !! fromInteger n) sr - (EGAt,(_,[r,p],[c])) -> error ("Unsupported EGAt in simple_fdProcess r="++(show r)++" p="++(show p)++" c="++(show c)) - (EGList n,(_,l,[c])) -> do - let cc = getDefColSpec c - sequence_ $ zipWith (\id ce -> fdEqualInt ce $ getDefIntSpec id) l cc - (EGRange, ([],[FDSpecInfoInt {fdspIntVal = Just (Const ll)},FDSpecInfoInt {fdspIntVal=Just (Const hh)}],[c])) -> do - let cc = getDefColSpec c - sequence_ $ zipWith (\val var -> t (EGIntValue (Const val)) $ fdSpecInfo_spec ([],[Right (minBound,var)],[])) [ll..hh] cc - (EGRange, ([],[FDSpecInfoInt {fdspIntVar = Just ll},FDSpecInfoInt {fdspIntVar=Just hh}],[c])) -> do - let cc = getDefColSpec c - l <- getIntVal ll - h <- getIntVal hh - case (l,h) of - (Just (Const lll), Just (Const hhh)) -> sequence_ $ zipWith (\val var -> t (EGIntValue (Const val)) $ fdSpecInfo_spec ([],[Right (minBound,var)],[])) [lll..hhh] cc - _ -> s cons info - (EGRange, ([],[l,h],[c])) -> do - error ("Unsupported EGRange in simple_fdProcess: l=("++(show l)++") h=("++(show h)++") c=("++(show c)++")") - (EGSorted q, (_,_,[c])) -> do - let cc = getDefColSpec c - sequence_ $ zipWith (\a b -> t (EGLess q) $ fdSpecInfo_spec ([Left trueSpec],[Right (minBound,a), Right (minBound,b)],[])) cc (tail cc) - (EGAllDiff _, (_,_,[c])) -> do - let cc = getDefColSpec c - sequence_ [ t EGDiff $ fdSpecInfo_spec ([Left trueSpec],[Right (minBound,x), Right (minBound,e)],[]) | (x:xs) <- tails cc, e <- xs ] - (EGAll sm (nb,ni,nc) force,(r:vb,vi,c:vc)) -> do - let dr = getDefBoolSpec r - let dc = getDefColSpec c - let dcs = length dc - debug ("iter_process EGAll: dcs="++(show dcs)) $ return () - if force - then do - let mf i = do - let v = dc!!i - dv <- liftFD $ specInfoIntTerm v - let fb (-1) = error "SimpleFD EGAll undefined 1" - fb n = vb!!n - fi (-1) = dv - fi n = vi!!n - procSubModel sm (fb,fi,(vc!!)) - mapM_ mf [0..fromIntegral $ dcs-1] - else do - let mf i = do - let v = dc!!i - b <- liftFD $ newvar - db <- liftFD $ specInfoBoolTerm b - dv <- liftFD $ specInfoIntTerm v - let fb (-1) = db - fb n = vb!!n - fi (-1) = dv - fi n = vi!!n - procSubModel sm (fb,fi,(vc!!)) - return b - bools <- mapM mf [0..fromIntegral $ dcs-1] - treeAll t EGAnd True bools - return () - (EGAny sm (nb,ni,nc) _,(r:vb,vi,c:vc)) -> do - let dr = getDefBoolSpec r - let dc = getDefColSpec c - let dcs = length dc - let mf i = do - let v = dc!!i - b <- liftFD $ newvar - db <- liftFD $ specInfoBoolTerm b - dv <- liftFD $ specInfoIntTerm v - let fb (-1) = db - fb n = vb!!n - fi (-1) = dv - fi n = vi!!n - fc n = vc!!n - procSubModel sm (fb,fi,fc) - return b - bools <- mapM mf [0..fromIntegral $ dcs-1] - treeAll t EGOr False bools - return () - (EGMap sm (nb,ni,nc),(vb,vi,cr:c:vc)) -> do - let dc = getDefColSpec c - let dcr = getDefColSpec cr - let dcs = length dc - let mf i = do - let vin = dc!!i - let vout = dcr!!i - din <- liftFD $ specInfoIntTerm vin - dout <- liftFD $ specInfoIntTerm vout - let fi (-1) = dout - fi (-2) = din - fi n = vi!!n - fb n = vb!!n - fc n = vc!!n - procSubModel sm (fb,fi,fc) - mapM_ mf [0..fromIntegral $ dcs-1] - (EGFold sm (nb,ni,nc),(vb,r:ss:vi,c:vc)) -> do - let dc = getDefColSpec c - let dinit = getDefIntSpec ss - let dcs = length dc - let dres = getDefIntSpec r - tmp <- mapM (const $ liftFD newvar) [0..dcs-2] - let tmpv = tmp++[dres] - let mf i = do - let vin1 = if (i==0) then dinit else tmpv!!(i-1) - vout = tmpv!!i - let vin2 = dc!!i - din1 <- liftFD $ specInfoIntTerm vin1 - din2 <- liftFD $ specInfoIntTerm vin2 - dout <- liftFD $ specInfoIntTerm vout - let fi (-1) = dout - fi (-2) = din1 - fi (-3) = din2 - fi n = vi!!n - fb n = vb!!n - fc n = vc!!n - procSubModel sm (fb,fi,fc) - mapM_ mf [0..fromIntegral $ dcs-1] - _ -> s cons info - -treeAll :: (FDSolver s, FDBoolSpec s ~ FDBoolTerm s) => (EGConstraintSpec -> FDSpecInfo s -> FDInstance s ()) -> EGConstraintSpec -> Bool -> [FDBoolSpec s] -> FDInstance s (FDBoolSpec s) -treeAll p c d [] = return $ error "SimpleFD treeAll undefined" -treeAll p c d [a] = return a -treeAll p c d x = do - let (l,r) = splitAt ((length x) `div` 2) x - ld <- treeAll p c d l - rd <- treeAll p c d r - ldi <- liftFD $ specInfoBoolTerm ld - rdi <- liftFD $ specInfoBoolTerm rd - o <- liftFD $ newvar - oi <- liftFD $ specInfoBoolTerm o - p c ([oi,ldi,rdi],[],[]) - return o diff --git a/Control/CP/FD/Solvers.hs b/Control/CP/FD/Solvers.hs deleted file mode 100644 --- a/Control/CP/FD/Solvers.hs +++ /dev/null @@ -1,52 +0,0 @@ -module Control.CP.FD.Solvers where - -import qualified Control.CP.PriorityQueue as PriorityQueue -import qualified Data.Sequence - -import Control.CP.ComposableTransformers -import Control.CP.SearchTree -import Control.CP.FD.FD --- import Control.CP.FD.OvertonFD.Sugar --- import Control.CP.FD.OvertonFD.OvertonFD --- import Control.CP.FD.Gecode.CodegenSolver - --------------------------------------------------------------------------------- --- FORCE SOLVERS --------------------------------------------------------------------------------- - --- as_overtonfd :: Tree (FDWrapper OvertonFD) a -> Tree OvertonFD a --- as_overtonfd = unwrap --- --- as_gecode_codegen :: Tree (FDWrapper CodegenSolver) a -> Tree CodegenSolver a --- as_gecode_codegen = unwrap --- --- as_gen_gecode_codegen :: (FDExpr CodegenSolver -> Tree (FDWrapper CodegenSolver) a) -> (FDExpr CodegenSolver -> Tree CodegenSolver a) --- as_gen_gecode_codegen f = (\x -> unwrap $ f x) --- - ------------------------------------------------------------------------------- --- SEARCH STRATEGIES ------------------------------------------------------------------------------- - -dfs = [] -bfs = Data.Sequence.empty -pfs :: Ord a => PriorityQueue.PriorityQueue a (a,b,c) -pfs = PriorityQueue.empty - -nb :: Int -> CNodeBoundedST s a -nb = CNBST -db :: Int -> CDepthBoundedST s a -db = CDBST -bb :: NewBound s -> CBranchBoundST s a -bb = CBBST -sb :: Int -> CSolutionBoundST s a -sb = CSBST -fs :: CFirstSolutionST s a -fs = CFSST -it :: CIdentityCST s a -it = CIST -ra :: Int -> CRandomST s a -ra = CRST -ld :: Int -> CLimitedDiscrepancyST s a -ld = CLDST - diff --git a/Control/CP/PriorityQueue.hs b/Control/CP/PriorityQueue.hs deleted file mode 100644 --- a/Control/CP/PriorityQueue.hs +++ /dev/null @@ -1,110 +0,0 @@ -{- Copyright (c) 2008 the authors listed at the following URL, and/or -the authors of referenced articles or incorporated external code: -http://en.literateprograms.org/Priority_Queue_(Haskell)?action=history&offset=20080608152146 - -Permission is hereby granted, free of charge, to any person obtaining -a copy of this software and associated documentation files (the -"Software"), to deal in the Software without restriction, including -without limitation the rights to use, copy, modify, merge, publish, -distribute, sublicense, and/or sell copies of the Software, and to -permit persons to whom the Software is furnished to do so, subject to -the following conditions: - -The above copyright notice and this permission notice shall be -included in all copies or substantial portions of the Software. - -THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, -EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF -MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. -IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY -CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, -TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE -SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. - -Retrieved from: http://en.literateprograms.org/Priority_Queue_(Haskell)?oldid=13634 --} - -module Control.CP.PriorityQueue ( - PriorityQueue, - empty, - is_empty, - minKey, - minKeyValue, - insert, - deleteMin, - deleteMinAndInsert -) where - - -import Prelude - - --- Declare the data type constructors. - -data Ord k => PriorityQueue k a = Nil | Branch k a (PriorityQueue k a) (PriorityQueue k a) - - --- Declare the exported interface functions. - --- Return an empty priority queue. - -is_empty Nil = True -is_empty _ = False - -empty :: Ord k => PriorityQueue k a -empty = Nil - - --- Return the highest-priority key. - -minKey :: Ord k => PriorityQueue k a -> k -minKey = fst . minKeyValue - - --- Return the highest-priority key plus its associated value. - -minKeyValue :: Ord k => PriorityQueue k a -> (k, a) -minKeyValue Nil = error "empty queue" -minKeyValue (Branch k a _ _) = (k, a) - - --- Insert a key/value pair into a queue. - -insert :: Ord k => k -> a -> PriorityQueue k a -> PriorityQueue k a -insert k a q = union (singleton k a) q - -deleteMin :: Ord k => PriorityQueue k a -> ((k,a), PriorityQueue k a) -deleteMin(Branch k a l r) = ((k,a),union l r) - --- Delete the highest-priority key/value pair and insert a new key/value pair into the queue. - -deleteMinAndInsert :: Ord k => k -> a -> PriorityQueue k a -> PriorityQueue k a -deleteMinAndInsert k a Nil = singleton k a -deleteMinAndInsert k a (Branch _ _ l r) = union (insert k a l) r - - - --- Declare the private helper functions. - --- Join two queues in sorted order. - -union :: Ord k => PriorityQueue k a -> PriorityQueue k a -> PriorityQueue k a -union l Nil = l -union Nil r = r -union l@(Branch kl _ _ _) r@(Branch kr _ _ _) - | kl <= kr = link l r - | otherwise = link r l - - --- Join two queues without regard to order. - --- (This is a helper to the union helper.) - -link (Branch k a Nil m) r = Branch k a r m -link (Branch k a ll lr) r = Branch k a lr (union ll r) - - --- Return a queue with a single item from a key/value pair. - -singleton :: Ord k => k -> a -> PriorityQueue k a -singleton k a = Branch k a Nil Nil diff --git a/Control/CP/Queue.hs b/Control/CP/Queue.hs deleted file mode 100644 --- a/Control/CP/Queue.hs +++ /dev/null @@ -1,53 +0,0 @@ -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE ViewPatterns #-} -{-# LANGUAGE FlexibleInstances #-} -{- - - The Queue data type, a worklist data type for search. - - - - Monadic Constraint Programming - - http://www.cs.kuleuven.be/~toms/Haskell/ - - Tom Schrijvers - -} - -module Control.CP.Queue ( - Queue, - Elem, - emptyQ, - isEmptyQ, - popQ, - pushQ -) where - -import qualified Data.Sequence -import qualified Control.CP.PriorityQueue as PriorityQueue - -class Queue q where - type Elem q :: * - emptyQ :: q -> q - isEmptyQ :: q -> Bool - popQ :: q -> (Elem q,q) - pushQ :: Elem q -> q -> q - -instance Queue [a] where - type Elem [a] = a - emptyQ _ = [] - isEmptyQ = Prelude.null - popQ (x:xs) = (x,xs) - pushQ = (:) - -instance Queue (Data.Sequence.Seq a) where - type Elem (Data.Sequence.Seq a) = a - emptyQ _ = Data.Sequence.empty - isEmptyQ = Data.Sequence.null --- popQ (Data.Sequence.viewl -> x Data.Sequence.:< xs) = (x,xs) - popQ l = case Data.Sequence.viewl l of - x Data.Sequence.:< xs -> (x,xs) - pushQ = flip (Data.Sequence.|>) - -instance Ord a => Queue (PriorityQueue.PriorityQueue a (a,b,c)) where - type Elem (PriorityQueue.PriorityQueue a (a,b,c)) = (a,b,c) - emptyQ _ = PriorityQueue.empty - isEmptyQ = PriorityQueue.is_empty - pushQ x@(k,_,_) = PriorityQueue.insert k x - popQ q = let ((_,x),q') = PriorityQueue.deleteMin q - in (x,q') diff --git a/Control/CP/SearchTree.hs b/Control/CP/SearchTree.hs deleted file mode 100644 --- a/Control/CP/SearchTree.hs +++ /dev/null @@ -1,324 +0,0 @@ -{- - - The Tree data type, a generic modelling language for constraint solvers. - - - - Monadic Constraint Programming - - http://www.cs.kuleuven.be/~toms/Haskell/ - - Tom Schrijvers - -} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE GADTs #-} -{-# LANGUAGE RankNTypes #-} -{-# LANGUAGE FlexibleContexts #-} - -module Control.CP.SearchTree ( - Tree(..), - transformTree, - bindTree, - insertTree, - (/\), - true, - disj, - conj, - disj2, - prim, - addC, - addT, - exist, - forall, - indent, - showTree, - mapTree, - MonadTree(..), - untree -) where - -import Control.CP.Solver -import Control.Mixin.Mixin - -import Control.Monad -import Control.Monad.Cont -import Control.Monad.Reader -import Control.Monad.Writer -import Control.Monad.State - -import Data.Monoid - - -------------------------------------------------------------------------------- ------------------------------------ Tree -------------------------------------- -------------------------------------------------------------------------------- - -data Tree s a where - Fail :: Tree s a -- failure - Return :: a -> Tree s a -- finished - Try :: Tree s a -> Tree s a -> Tree s a -- disjunction - Add :: Constraint s -> Tree s a -> Tree s a -- sequentially adding a constraint to a tree - NewVar :: Term s t => (t -> Tree s a) -> Tree s a -- add a new variable to a tree - Label :: s (Tree s a) -> Tree s a -- label with a strategy - -flattenTree :: Solver s => Tree s a -> Maybe ([Constraint s],a) -flattenTree Fail = Nothing -flattenTree (Return a) = Just ([],a) -flattenTree (Try _ _) = Nothing -flattenTree (Add c t) = case flattenTree t of - Nothing -> Nothing - Just (l,a) -> Just (c:l,a) -flattenTree (NewVar _) = Nothing -flattenTree (Label _) = Nothing - -transformTree :: Solver s => Mixin (Tree s a -> Tree s a) -transformTree _ _ Fail = Fail -transformTree _ _ (Return x) = Return x -transformTree _ t (Try x y) = Try (t x) (t y) -transformTree _ t (Add c x) = Add c (t x) -transformTree _ t (NewVar f) = NewVar (\x -> t $ f x) -transformTree _ t (Label m) = Label $ m >>= return . t --- transformTree s _ x = s x - -mapTree :: (Solver s1, Solver s2, MonadTree m, TreeSolver m ~ s2) => (forall t. s1 t -> s2 t) -> Tree s1 a -> m a -mapTree _ Fail = false -mapTree _ (Return a) = return a -mapTree f (Try a b) = mapTree f a \/ mapTree f b --- mapTree f (Add c n) = label $ f $ (add c >>= \t -> if t then return (mapTree f n) else return false) --- mapTree (NewVar _) = undefined -mapTree f (Label l) = label $ (f l) >>= (\t -> return (mapTree f t)) - -instance Solver s => Functor (Tree s) where - fmap = liftM - -instance Solver s => Monad (Tree s) where - return = Return - (>>=) = bindTree - - -bindTree :: Solver s => Tree s a -> (a -> Tree s b) -> Tree s b -Fail `bindTree` k = Fail -(Return x) `bindTree` k = k x -(Try m n) `bindTree` k = Try (m `bindTree` k) (n `bindTree` k) -(Add c m) `bindTree` k = Add c (m `bindTree` k) -(NewVar f) `bindTree` k = NewVar (\x -> f x `bindTree` k) -(Label m) `bindTree` k = Label (m >>= \t -> return (t `bindTree` k)) - -insertTree :: Solver s => Tree s a -> Tree s () -> Tree s a -(NewVar f) `insertTree` t = NewVar (\x -> f x `insertTree` t) -(Add c o) `insertTree` t = Add c (o `insertTree` t) -other `insertTree` t = t /\ other - -{- Monad laws: - - - - 1. return x >>= f == f x - - - - return a >>= f - - == Return a >>= f (return def) - - == f x (bind def) - - - - 2. m >>= return = m - - - - By induction - - case m of - - 1) Return x -> - - Return x >>= return - - == return x (bind def) - - == Return x (return def) - - 2) Fail -> - - Fail >>= return - - == Fail (bind def) - - 3) Try l r >>= return - - == Try (l >>= return) (r >>= return) (bind def) - - == Try l r (induction) - - 4) Add c m >>= return - - == Add c (m >>= return) (bind def) - - == Add c m (induction) - - 5) NewVar i f >>= return - - == NewVar i (\v -> f v >>= return) (bind def) - - == NewVar i (\v -> f v) ((co)-induction?) - - == NewVar i f (eta reduction) - - 6) Label sm >>= return - - == Label (sm >>= \m -> return (m >>= return)) (bind def) - - == Label (sm >>= \m -> return m) (co-induction) - - == Label (sm >>= return) (eta reduction) - - == Label sm (2nd monad law for Monad s) - - - - 3. (m >>= f) >>= g = m >>= (\x -> f x >>= g) - - - - By induction - - case m of - - 1) (Return y >>= f) >>= g - - == f y >>= g (bind def) - - == (\x -> f x >>= g) y (beta expansion) - - == Return y >>= (\x -> f x >>= g) (bind def) - - 2) (Fail >>= f) >>= g - - == Fail >>= g (bind def) - - == Fail (bind def) - - == Fail >>= (\x -> f x >>= g) (bind def) - - 3) (Try l r >>= f) >>= g - - == Try (l >>= f) (r >>= f)) >>= g (bind def) - - == Try ((l >>= f) >>= g) ((r >>= f) >>= g) (bind def) - - == Try (l >>= (\x -> f x >>= g)) (r >>= (\x -> f x >>= g)) (induction) - - == Try l r >>= (\x -> f x >>= g) (bind def) - - 4) (NewVar i m >>= f) >>= g - - == NewVar i (\v -> m v >>= f) >>= g (bind def) - - == NewVar i (\w -> (\v -> m v >>= f) w >>= g) (bind def) - - == NewVar i (\w -> (m w >>= f) >>= g) (beta reduction) - - == NewVar i (\w -> m w >>= (\x -> f x >>= g)) (co-induction) - - == NewVar i m >>= (\x -> f x >>= g) (bind def) - - 5) (Label sm >>= f) >>= g - - == Label (sm >>= \m -> return (m >>= f)) >>= g (bind def) - - == Label ((sm >>= \m -> return (m >>= f)) >>= \m' -> return (m' >>= g)) - - == Label (sm >>= (\m -> return (m >>= f) >>= \m' -> return (m' >>= g))) - - == Label (sm >>= \m -> return ((m >>= f) >>= g)) - - == Label (sm >>= \m -> return (m >>= (\x -> f x >>= g))) - - == Label sm >>= (\x -> f x >>= g) - - - -} - -------------------------------------------------------------------------------- ------------------------------------ Monad Subclass ---------------------------- -------------------------------------------------------------------------------- - -infixl 2 \/ - --- | Generalization of the search tree data type, --- allowing monad transformer decoration. -class (Monad m, Solver (TreeSolver m)) => MonadTree m where - type TreeSolver m :: * -> * - addTo :: Constraint (TreeSolver m) -> m a -> m a - false :: m a - (\/) :: m a -> m a -> m a - exists :: Term (TreeSolver m) t => (t -> m a) -> m a - label :: (TreeSolver m) (m a) -> m a - -instance Solver solver => MonadTree (Tree solver) where - type TreeSolver (Tree solver) = solver - addTo = Add - false = Fail - (\/) = Try - exists = NewVar - label = Label - -instance (MonadTree m, Solver (TreeSolver m)) => MonadTree (ContT r m) where - type TreeSolver (ContT r m) = TreeSolver m - addTo constraint cm = ContT $ \k -> addTo constraint (runContT cm k) - false = lift false - l \/ r = ContT $ \k -> (runContT l k) \/ (runContT r k) - exists f = ContT $ \k -> exists (\t -> runContT (f t) k) - label scm = ContT $ \k -> label (scm >>= \cm -> return $ runContT cm k) - -------------------------------------------------------------------------------- ------------------------------------ Sugar ------------------------------------- -------------------------------------------------------------------------------- - -infixr 3 /\ -(/\) :: MonadTree tree => tree a -> tree b -> tree b -(/\) = (>>) - -true :: MonadTree tree => tree () -true = return () - -disj :: MonadTree tree => [tree a] -> tree a -disj [] = false -disj a = foldr1 (\/) a - -conj :: MonadTree tree => [tree ()] -> tree () -conj [] = true -conj a = foldr1 (/\) a - -disj2 :: MonadTree tree => [tree a] -> tree a -disj2 (x: []) = x -disj2 l = let (xs,ys) = split l - split [] = ([],[]) - split (a:as) = let (bs,cs) = split as - in (a:cs,bs) - in (disj2 xs) \/ (disj2 ys) - -prim :: MonadTree tree => TreeSolver tree a -> tree a -prim action = label (action >>= return . return) - -addC :: MonadTree tree => Constraint (TreeSolver tree) -> tree () -addC c = c `addTo` true - -addT :: MonadTree tree => Constraint (TreeSolver tree) -> tree Bool -addT c = c `addTo` (return True) - -exist :: (MonadTree tree, Term (TreeSolver tree) t) => Int -> ([t] -> tree a) -> tree a -exist n ftree = f n [] - where f 0 acc = ftree $ reverse acc - f n acc = exists $ \v -> f (n-1) (v:acc) - -forall :: (MonadTree tree, Term (TreeSolver tree) t) => [t] -> (t -> tree ()) -> tree () -forall list ftree = conj $ map ftree list - --- Shortcut the search procedure for a Tree that does not contain Try nodes. --- create a solver monad that returns the result of the Tree, or a specified --- value upon failure -untree :: Solver s => v -> Tree s v -> s v -untree _ (Return x) = return x -untree _ (Try _ _) = error "convertion of Try nodes to solver is not supported" -untree e (Fail) = return e -untree e (Label s) = s >>= untree e -untree e (Add c t) = (add c) >>= (\x -> if x then untree e t else return e) -untree e (NewVar f) = do - v <- newvar - untree e (f v) - --- | show - -indent :: Int -> String -indent l = replicate (2*l) ' ' - -showTree :: (Show (Constraint s), Show a, Solver s) => Int -> Tree s a -> s String -showTree l Fail = return $ indent l ++ "Fail\n" -showTree l (Return x) = return $ indent l ++ "Return [" ++ (show x) ++ "]\n" -showTree l (Try a b) = do - m <- mark - s1 <- showTree (l+1) a - goto m - s2 <- showTree (l+1) b - return $ indent l ++ "Try\n" ++ s1 ++ s2 -showTree l (Add c t) = do - s <- showTree (l+1) t - return $ indent l ++ "Add (" ++ (show c) ++ ")\n" ++ s -showTree l (NewVar f) = do - n <- newvar - s <- showTree (l+1) (f n) - return $ indent l ++ "NewVar\n" ++ s -showTree l (Label a) = do - r <- a - s <- showTree (l+1) r - return $ indent l ++ "Label\n" ++ s - -instance Show (Tree s a) where - show Fail = "Fail" - show (Return _) = "Return" - show (Try l r) = "Try (" ++ show l ++ ") (" ++ show r ++ ")" - show (Add _ t) = "Add (" ++ show t ++ ")" - show (NewVar _) = "NewVar " - show (Label _) = "Label " - ----------------------------------------------------------------------- --- Monad Transformer Instances ----------------------------------------------------------------------- - -instance MonadTree t => MonadTree (ReaderT env t) where - type TreeSolver (ReaderT env t) = TreeSolver t - addTo constraint tree = ReaderT $ \env -> addTo constraint (runReaderT tree env) - false = lift false - l \/ r = ReaderT $ \env -> runReaderT l env \/ runReaderT r env - exists f = ReaderT $ \env -> exists (\var -> runReaderT (f var) env) - label p = ReaderT $ \env -> label (p >>= \m -> return $ runReaderT m env) - -instance (Monoid w, MonadTree t) => MonadTree (WriterT w t) where - type TreeSolver (WriterT w t) = TreeSolver t - addTo constraint tree = WriterT $ addTo constraint (runWriterT tree) - false = lift false - l \/ r = WriterT $ runWriterT l \/ runWriterT r - exists f = WriterT $ exists (\var -> runWriterT (f var)) - label p = WriterT $ label (p >>= \m -> return $ runWriterT m) - -instance MonadTree t => MonadTree (StateT s t) where - type TreeSolver (StateT s t) = TreeSolver t - addTo constraint tree = StateT $ \s -> addTo constraint (runStateT tree s) - false = lift false - l \/ r = StateT $ \s -> runStateT l s \/ runStateT r s - exists f = StateT $ \s -> exists (\var -> runStateT (f var) s) - label p = StateT $ \s -> label (p >>= \m -> return $ runStateT m s) diff --git a/Control/CP/Solver.hs b/Control/CP/Solver.hs deleted file mode 100644 --- a/Control/CP/Solver.hs +++ /dev/null @@ -1,80 +0,0 @@ -{- - - The Solver class, a generic interface for constraint solvers. - - - - Monadic Constraint Programming - - http://www.cs.kuleuven.be/~toms/Haskell/ - - Tom Schrijvers - -} - -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE FlexibleInstances #-} - -module Control.CP.Solver ( - Solver, - Constraint, - Label, - add, - run, - mark, markn, - goto, - Term, - newvar, - Help, - help, -) where - -import Control.Monad.Writer -import Data.Monoid - -class Monad solver => Solver solver where - -- | the constraints - type Constraint solver :: * - -- | the labels - type Label solver :: * - -- | add a constraint to the current state, and - -- return whether the resulting state is consistent - add :: Constraint solver -> solver Bool - -- | run a computation - run :: solver a -> a - -- | mark the current state, and return its label - mark :: solver (Label solver) - -- | mark the current state as discontinued, yet return a label that is usable n times - markn :: Int -> solver (Label solver) - -- | go to the state with given label - goto :: Label solver -> solver () - - markn _ = mark - -class (Solver solver) => Term solver term where - -- | produce a fresh constraint variable - newvar :: solver term - - -- see note [Solver-Specific Term Operations] - type Help solver term - help :: solver () -> term -> Help solver term - --- [Solver-Specific Term Operations] --- --- Terms of solvers in general only support the 'newvar' operation. --- However, for specific solvers, all terms may support additional --- operations. --- --- The 'Help'/'help' infrastructure allows accessing this solver-specific --- term operations. - --- | WriterT decoration of a solver --- useful for producing statistics during solving -instance (Monoid w, Solver s) => Solver (WriterT w s) where - type Constraint (WriterT w s) = Constraint s - type Label (WriterT w s) = Label s - add = lift . add - run = fst . run . runWriterT - mark = lift mark - markn = lift . markn - goto = lift . goto - -instance (Monoid w, Term s t) => Term (WriterT w s) t where - newvar = lift newvar - type Help (WriterT w s) t = () - help _ _ = () diff --git a/Control/CP/Transformers.hs b/Control/CP/Transformers.hs deleted file mode 100644 --- a/Control/CP/Transformers.hs +++ /dev/null @@ -1,114 +0,0 @@ -{- - - Monadic Constraint Programming - - http://www.cs.kuleuven.be/~toms/Haskell/ - - Tom Schrijvers - -} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE Rank2Types #-} -{-# LANGUAGE BangPatterns #-} -module Control.CP.Transformers ( - eval, - eval', - continue, - NodeBoundedST, - DepthBoundedST, - Transformer(..), -) where - -import Control.CP.Solver -import Control.CP.SearchTree -import Control.CP.Queue -import Control.CP.Debug - --------------------------------------------------------------------------------- --- EVALUATION --------------------------------------------------------------------------------- - -eval :: (Solver solver, Queue q, Elem q ~ (Label solver,Tree solver (ForResult t),TreeState t), Transformer t, - ForSolver t ~ solver) - => Tree solver (ForResult t) -> q -> t -> solver (Int,[ForResult t]) -eval tree q t = debug "eval" $ - do (es,ts) <- initT t tree - eval' 0 tree q t es ts - -eval' :: SearchSig solver q t (ForResult t) -eval' !i (Return x) wl t es ts = do (j,xs) <- returnT (i+1) wl t es - return (j,(x:xs)) -eval' i (Add c k) wl t es ts = do b <- Control.CP.Solver.add c - if b then eval' (i+1) k wl t es ts - else continue (i+1) wl t es -eval' i (NewVar f) wl t es ts = do v <- newvar - eval' (i+1) (f v) wl t es ts -eval' i (Try l r) wl t es ts = - do now <- markn 2 - let wl' = pushQ (now,l,leftT t es ts) $ pushQ (now,r,rightT t es ts) wl - continue (i+1) wl' t es -eval' i Fail wl t es ts = continue (i+1) wl t es -eval' i (Label m) wl t es ts = do tree <- m - eval' (i+1) tree wl t es ts - -continue :: ContinueSig solver q t (ForResult t) -continue i wl t es - | isEmptyQ wl = endT i wl t es -- return (i,[]) - | otherwise = let ((past,tree,ts),wl') = popQ wl - in do goto past - nextT i tree wl' t es ts - --------------------------------------------------------------------------------- --- TRANSFORMER --------------------------------------------------------------------------------- - -type SearchSig solver q t a = - (Solver solver, Queue q, Transformer t, - Elem q ~ (Label solver,Tree solver a,TreeState t), - ForSolver t ~ solver) - => Int -> Tree solver a -> q -> t -> EvalState t -> TreeState t -> solver (Int,[a]) - -type ContinueSig solver q t a = - (Solver solver, Queue q, Transformer t, - Elem q ~ (Label solver,Tree solver a,TreeState t), - ForSolver t ~ solver) - => Int -> q -> t -> EvalState t -> solver (Int,[a]) - -class Transformer t where - type EvalState t :: * - type TreeState t :: * - type ForSolver t :: (* -> *) - type ForResult t :: * - leftT, rightT :: t -> EvalState t -> TreeState t -> TreeState t - leftT _ _ = id - rightT = leftT - nextT :: SearchSig (ForSolver t) q t (ForResult t) - nextT = eval' - initT :: t -> Tree (ForSolver t) (ForResult t) -> (ForSolver t) (EvalState t,TreeState t) - returnT :: ContinueSig solver q t (ForResult t) - returnT i wl t es = continue i wl t es - endT :: ContinueSig solver q t (ForResult t) - endT i wl t es = return (i,[]) - -newtype DepthBoundedST (solver :: * -> *) a = DBST Int - -instance Solver solver => Transformer (DepthBoundedST solver a) where - type EvalState (DepthBoundedST solver a) = () - type TreeState (DepthBoundedST solver a) = Int - type ForSolver (DepthBoundedST solver a) = solver - type ForResult (DepthBoundedST solver a) = a - initT (DBST n) _ = return ((),n) - leftT _ _ ts = ts - 1 - nextT i tree q t es ts - | ts == 0 = continue i q t es - | otherwise = eval' i tree q t es ts - -newtype NodeBoundedST (solver :: * -> *) a = NBST Int - -instance Solver solver => Transformer (NodeBoundedST solver a) where - type EvalState (NodeBoundedST solver a) = Int - type TreeState (NodeBoundedST solver a) = () - type ForSolver (NodeBoundedST solver a) = solver - type ForResult (NodeBoundedST solver a) = a - initT (NBST n) _ = return (n,()) - nextT i tree q t es ts - | es == 0 = return (i,[]) - | otherwise = eval' i tree q t (es - 1) ts - diff --git a/Control/Mixin/Mixin.hs b/Control/Mixin/Mixin.hs deleted file mode 100644 --- a/Control/Mixin/Mixin.hs +++ /dev/null @@ -1,60 +0,0 @@ --- | Module with basic infrastructure for function inheritance --- based on open rercusion. --- --- See the work of William Cook. --- --- We use the following terminology. --- --- * A /closed/ function is an ordinary function. --- --- * A /mixin/ function is an open function that can be --- inherited from, or that extends another open function. --- --- We obtain a closed function from a base mixin 'base' --- and a number of mixin extensions 'e1',...,'en' as follows: --- --- > mixin (en <@> ... <@> e1 <@> base) --- -module Control.Mixin.Mixin ( - Mixin, - (<@>), - mixin, - mixinId, - mixinLift -) where - -infixl 5 <@> - --- | Type of mixin functions. -type Mixin a = a -- the 'super' function - -> a -- the 'this' function - -> a -- the current function - --- | Mixin composition. -(<@>) :: Mixin a -> Mixin a -> Mixin a -(f1 <@> f2) super this = f1 (f2 super this) this - --- | Turn a mixin into a closed function. -mixin :: Mixin a -> a -mixin openF - = let closedF = openF errorF closedF - errorF = error $ "super called in base mixin" - in closedF - --- | Mixin identity function. --- --- Identity for mixin composition: --- --- --- > mixinId <@> f == f --- > f <@> mixinId == f --- -mixinId :: Mixin a -mixinId super this = super - --- | Mixin lift function --- --- > mixin . mixinLift = id - -mixinLift :: (a -> b) -> Mixin (a -> b) -mixinLift f _ _ = f diff --git a/Control/Monatron/AutoInstances.hs b/Control/Monatron/AutoInstances.hs deleted file mode 100644 --- a/Control/Monatron/AutoInstances.hs +++ /dev/null @@ -1,16 +0,0 @@ -{-# OPTIONS - -XFlexibleInstances - -XOverlappingInstances -#-} - -module Control.Monatron.AutoInstances where - -import Control.Monatron.MonadT - ------------------------------------------------------------------- -instance (Monad m, MonadT t) => Monad (t m) where - return = treturn - fail = lift . fail - (>>=) = tbind - -instance (Monad m, MonadT t) => Functor (t m) where fmap = liftM diff --git a/Control/Monatron/AutoLift.hs b/Control/Monatron/AutoLift.hs deleted file mode 100644 --- a/Control/Monatron/AutoLift.hs +++ /dev/null @@ -1,128 +0,0 @@ -{-# OPTIONS - -XFlexibleInstances - -XMultiParamTypeClasses - -XFunctionalDependencies - -XUndecidableInstances - -XOverlappingInstances -#-} - --- -XOverlappingInstances - -module Control.Monatron.AutoLift ( - StateM(..), get,put, - WriterM (..), tell, - ReaderM(..), ask,local, - ExcM(..), throw,handle, - ContM(..), callCC, - ListM(..), mZero,mPlus, - module Control.Monatron.Operations -) where - -import Control.Monatron.Operations -import Control.Exception (SomeException) - - ------------------------------------------------------------------- --- State -class Monad m => StateM z m | m -> z where - stateModel :: AlgModel (StateOp z) m - -instance Monad m => StateM z (StateT z m) where - stateModel = modelStateT - -instance (StateM z m, MonadT t) => StateM z (t m) where - stateModel = liftAlgModel stateModel - -get :: StateM z m => m z -get = getX stateModel - -put :: StateM z m => z -> m () -put = putX stateModel - ------------------------------------------------------------------- --- Traces -class (Monoid z, Monad m) => WriterM z m | m -> z where - writerModel :: AlgModel (WriterOp z) m - -instance (Monoid z, Monad m) => WriterM z (WriterT z m) where - writerModel = modelWriterT - -instance (Monoid z, WriterM z m, MonadT t) => WriterM z (t m) where - writerModel = liftAlgModel writerModel - -tell :: (Monoid z, WriterM z m) => z -> m () -tell z = traceX writerModel z - ------------------------------------------------------------------- --- Environments -class Monad m => ReaderM z m | m -> z where - readerModel :: Model (ReaderOp z) m - -instance Monad m => ReaderM z (ReaderT z m) where - readerModel = modelReaderT - -instance (ReaderM z m, Functor m, FMonadT t) => ReaderM z (t m) where - readerModel = liftModel readerModel - -ask :: ReaderM z m => m z -ask = askX readerModel - -local :: ReaderM z m => (z -> z) -> m a -> m a -local = localX readerModel - ------------------------------------------------------------------- --- Throw and Handle -class Monad m => ExcM z m | m -> z where - throwModel :: AlgModel (ThrowOp z) m - handleModel :: Model (HandleOp z) m - -instance Monad m => ExcM z (ExcT z m) where - throwModel = modelThrowExcT - handleModel = modelHandleExcT - -instance ExcM SomeException IO where - throwModel = modelThrowIO - handleModel = modelHandleIO - -instance (ExcM z m, Functor m, FMonadT t) => ExcM z (t m) where - throwModel = liftAlgModel throwModel - handleModel = liftModel handleModel - -throw :: ExcM z m => z -> m a -throw = throwX throwModel - -handle :: ExcM z m => m a -> (z -> m a) -> m a -handle = handleX handleModel - ------------------------------------------------------------------- --- callCC operation - -class Monad m => ContM r m | m -> r where - contModel :: AlgModel (ContOp r) m - -instance Monad m => ContM (m r) (ContT r m) where - contModel = modelContT - -instance (ContM r m, MonadT t) => ContM r (t m) where - contModel = liftAlgModel contModel - -callCC :: ContM r m => ((a -> r) -> a) -> m a -callCC = callCCX contModel - ------------------------------------------------------------------- --- MPlus operations - -class Monad m => ListM m where - listModel :: AlgModel ListOp m - -instance Monad m => ListM (ListT m) where - listModel = modelListT - -instance (ListM m, MonadT t) => ListM (t m) where - listModel = liftAlgModel listModel - -mZero :: (ListM m) => m a -mZero = zeroListX listModel - -mPlus :: ListM m => m a -> m a -> m a -mPlus = plusListX listModel diff --git a/Control/Monatron/Codensity.hs b/Control/Monatron/Codensity.hs deleted file mode 100644 --- a/Control/Monatron/Codensity.hs +++ /dev/null @@ -1,36 +0,0 @@ -{-# OPTIONS -XRank2Types #-} - -module Control.Monatron.Codensity ( - Codensity, - codensity, - runCodensity -) where - -import Control.Monatron.MonadT -import Control.Monad.Fix -import Control.Monatron.AutoInstances() - ----------------------------------------------------------- --- Codensity Monad ----------------------------------------------------------- - -newtype Codensity f a = Codensity { - unCodensity :: forall b. (a -> f b) -> f b -} - -codensity :: (forall b. (a -> f b) -> f b) -> Codensity f a -codensity = Codensity - -runCodensity :: Monad m => Codensity m a -> m a -runCodensity c = unCodensity c return - -instance MonadT Codensity where - lift m = Codensity (m >>=) - c `tbind` f = Codensity (\k -> unCodensity c (\a -> unCodensity (f a) k)) - --- still need to prove that MonadFix laws hold -instance MonadFix m => MonadFix (Codensity m) where - mfix f = Codensity $ \k -> mfix (runCodensity. f) >>= k - ------------------------- - diff --git a/Control/Monatron/IdT.hs b/Control/Monatron/IdT.hs deleted file mode 100644 --- a/Control/Monatron/IdT.hs +++ /dev/null @@ -1,13 +0,0 @@ -module Control.Monatron.IdT where - -import Control.Monatron.Monatron - -newtype IdT m a = IdT { runIdT :: m a } - -instance MonadT IdT where - lift = IdT - tbind m f = IdT $ runIdT m >>= runIdT . f - -instance FMonadT IdT where - tmap' d1 _d2 g f = IdT . f . fmapD d1 g . runIdT - diff --git a/Control/Monatron/Monad.hs b/Control/Monatron/Monad.hs deleted file mode 100644 --- a/Control/Monatron/Monad.hs +++ /dev/null @@ -1,67 +0,0 @@ - -module Control.Monatron.Monad ( - State, Writer, Reader, Exception, Cont, - state,writer,reader,exception,cont, - runState, runWriter, runReader, runException, runCont, - Id(..), Lift(..) -) where - - -import Control.Monatron.Transformer -import Control.Monad -import Control.Monad.Fix - -newtype Id a = Id {runId :: a} -data Lift a = L {runLift :: a} - -type State s = StateT s Id -type Writer w = WriterT w Id -type Reader r = ReaderT r Id -type Exception x = ExcT x Id -type Cont r = ContT r Id - -state :: (s -> (a, s)) -> State s a -state st = stateT $ \s -> Id $ st s - -runState :: s -> State s a -> (a,s) -runState s = runId. runStateT s - -writer :: Monoid w => (a,w) -> Writer w a -writer = writerT . Id - -runWriter :: Monoid w => Writer w a -> (a,w) -runWriter = runId. runWriterT - -reader :: (r -> a) -> Reader r a -reader e = readerT $ \r -> Id (e r) - -runReader :: r -> Reader r a -> a -runReader r = runId . runReaderT r - -exception :: Either x a -> Exception x a -exception = excT . Id - -runException :: Exception x a -> Either x a -runException = runId. runExcT - -cont :: ((a -> r) -> r) -> Cont r a -cont c = contT $ \k -> Id $ c (runId . k) - -runCont :: (a -> r) -> Cont r a -> r -runCont k = runId. runContT (Id. k) - -instance Monad Id where - return = Id - fail = error - m >>= f = f (runId m) - -instance Monad Lift where - return x = L x - fail x = error x - L x >>= k = k x - -instance Functor Id where fmap = liftM -instance Functor Lift where fmap = liftM - -instance MonadFix Id where mfix f = let m = f (runId m) in m -instance MonadFix Lift where mfix f = let m = f (runLift m) in m diff --git a/Control/Monatron/MonadInfo.hs b/Control/Monatron/MonadInfo.hs deleted file mode 100644 --- a/Control/Monatron/MonadInfo.hs +++ /dev/null @@ -1,74 +0,0 @@ -{-# LANGUAGE FlexibleInstances #-} --- {-# LANGUAGE OverlappingInstances #-} -{-# LANGUAGE TypeOperators #-} - -module Control.Monatron.MonadInfo ( - MInfo(..), MonadInfo(minfo), MonadInfoT(tminfo), - miInc -) where - -import Control.Monatron.Monad -import Control.Monatron.MonadT -import Control.Monatron.IdT -import Control.Monatron.Transformer -import Control.Monatron.Zipper -import Control.Monatron.Codensity - -import Data.Map (Map) -import qualified Data.Map as Map - -newtype MInfo = MInfo (Map String Int) - deriving (Show, Eq, Ord) - -miBase = MInfo Map.empty - -miInc s (MInfo m) = MInfo $ Map.alter (\x -> case x of { Nothing -> Just 1; Just n -> Just (n+1) }) s m - -undef :: a -undef = error "MonadInfo: undefined" - -class Monad m => MonadInfo m where - minfo :: m a -> MInfo - -class MonadT t => MonadInfoT t where - tminfo :: MonadInfo m => t m a -> MInfo - -instance MonadInfoT (StateT s) where - tminfo x = miInc "StateT" (minfo $ runStateT (undef :: s) x) - -instance Monoid w => MonadInfoT (WriterT w) where - tminfo x = miInc "WriterT" (minfo $ runWriterT x) - -instance MonadInfoT (ReaderT s) where - tminfo x = miInc "ReaderT" (minfo $ runReaderT (undef :: s) x) - -instance MonadInfoT (ExcT x) where - tminfo x = miInc "ExcT" (minfo $ runExcT x) - -instance MonadInfoT (ContT x) where - tminfo x = miInc "ContT" (minfo $ runContT (undef) x) - -instance MonadInfoT ListT where - tminfo x = miInc "ListT" (minfo $ runListT x) - -instance Functor f => MonadInfoT (StepT f) where - tminfo x = miInc "StepT" (minfo $ runStepT x) - -instance (MonadInfoT t1, MonadInfoT t2) => MonadInfoT (t1 :> t2) where - tminfo x = miInc ":>" (minfo $ runZipper x) - -instance MonadInfoT Codensity where - tminfo x = miInc "Codensity" (minfo $ runCodensity x) - -instance MonadInfo Id where - minfo _ = miInc "Id" miBase - -instance MonadInfo Lift where - minfo _ = miInc "Lift" miBase - -instance MonadInfoT IdT where - tminfo x = miInc "IdT" (minfo $ runIdT x) - -instance (MonadInfo m, MonadInfoT t) => MonadInfo (t m) where - minfo x = tminfo x - diff --git a/Control/Monatron/MonadT.hs b/Control/Monatron/MonadT.hs deleted file mode 100644 --- a/Control/Monatron/MonadT.hs +++ /dev/null @@ -1,47 +0,0 @@ -{-# OPTIONS -XRank2Types #-} - -module Control.Monatron.MonadT ( - MonadT(..), FMonadT(..), MMonadT(..), FComp(..), FunctorD(..), tmap, mtmap, - module Control.Monad -) where - -import Control.Monad - - ----------------------------------------------------------- --- Class of monad transformers with --- a lifting of first-order operations ----------------------------------------------------------- - -class MonadT t where - lift :: Monad m => m a -> t m a - treturn :: Monad m => a -> t m a - treturn = lift. return - tbind :: Monad m => t m a -> (a -> t m b) -> t m b - -newtype FunctorD f = FunctorD {fmapD :: forall a b . (a -> b) -> f a -> f b} - -functor :: Functor f => FunctorD f -functor = FunctorD fmap - -class MonadT t => FMonadT t where - tmap' :: FunctorD m -> FunctorD n -> (a -> b) -> (forall x. m x -> n x) -> t m a -> t n b - -tmap :: (FMonadT t, Functor m, Functor n) => (forall b. m b -> n b) -> t m a -> t n a -tmap = tmap' functor functor id - -mtmap :: FMonadT t => FunctorD f -> (a -> b) -> t f a -> t f b -mtmap fd f = tmap' fd fd f id - -class FMonadT t => MMonadT t where - flift :: Functor f => f a -> t f a --should coincide with lift! - monoidalT :: (Functor f, Functor g) => t f (t g a) -> t (FComp f g) a - ----------------------------------------- --- Functor Composition ----------------------------------------- - -newtype (FComp f g) a = Comp {deComp :: (f (g a)) } - -instance (Functor f, Functor g) => Functor (FComp f g) where - fmap f (Comp fga) = Comp (fmap (fmap f) fga) diff --git a/Control/Monatron/Monatron.hs b/Control/Monatron/Monatron.hs deleted file mode 100644 --- a/Control/Monatron/Monatron.hs +++ /dev/null @@ -1,12 +0,0 @@ - -module Control.Monatron.Monatron ( - module Control.Monatron.Monad, - module Control.Monatron.AutoLift, - version -)where - -import Control.Monatron.Monad -import Control.Monatron.AutoLift - -version :: (Int,Int,Int) -version = (0,0,1) diff --git a/Control/Monatron/Open.hs b/Control/Monatron/Open.hs deleted file mode 100644 --- a/Control/Monatron/Open.hs +++ /dev/null @@ -1,58 +0,0 @@ --- {-# OPTIONS -fglasgow-exts -XNoMonomorphismRestriction -XOverlappingInstances #-} - -{-# LANGUAGE NoMonomorphismRestriction #-} -{-# LANGUAGE OverlappingInstances #-} -{-# LANGUAGE TypeOperators #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE FlexibleInstances #-} - -module Control.Monatron.Open where - -import Control.Monatron.Monatron () -import Control.Monatron.AutoLift - -infixr 9 :+: -infixr 9 <@> - -data (:+:) f g a = Inl (f a) | Inr (g a) - -newtype Fix f = In {out :: f (Fix f)} - -type Open e f r = (e -> r) -> (f e -> r) - -(<@>) :: Open e f r -> Open e g r -> Open e (f :+: g) r -evalf <@> evalg = \eval e -> - case e of - Inl el -> evalf eval el - Inr er -> evalg eval er - -fix :: Open (Fix f) f r -> (Fix f -> r) -fix f = let this = f this . out - in this - --- Borrowed from Data types \`a la Carte - -class (f :<: g) where - inj :: f a -> g a - -instance Functor f => (:<:) f f where - inj = id - -instance (Functor g, Functor f) - => (:<:) f (f :+: g) where - inj = Inl - -instance (Functor g, Functor h, Functor f, f :<: g) - => (:<:) f (h :+: g) where - inj = Inr . inj - -inject :: (f :<: g) => f (Fix g) -> Fix g -inject = In . inj - -instance (Functor f, Functor g) => - Functor (f :+: g) where - fmap f (Inl x) = Inl (fmap f x) - fmap f (Inr y) = Inr (fmap f y) - -foldFix :: Functor f => (f a -> a) -> Fix f -> a -foldFix f = f . fmap (foldFix f) . out diff --git a/Control/Monatron/Operations.hs b/Control/Monatron/Operations.hs deleted file mode 100644 --- a/Control/Monatron/Operations.hs +++ /dev/null @@ -1,195 +0,0 @@ -{-# OPTIONS -XRank2Types #-} - -module Control.Monatron.Operations ( - ExtModel, Model, AlgModel, toAlg, liftModel, liftAlgModel, liftExtModel, - StateOp(..), modelStateT, getX, putX, - ReaderOp(..), modelReaderT, askX, inEnvX, localX, - WriterOp(..), modelWriterT, traceX, - ThrowOp(..),HandleOp(..), modelThrowExcT, modelHandleExcT, - modelThrowIO, modelHandleIO, throwX, handleX, - ContOp(..), modelContT, callccX, callCCX, abortX, - StepOp(..), stepX, modelStepT, - ListOp(..), modelListT, zeroListX, plusListX, - module Control.Monatron.Transformer -) where - -import Control.Monatron.Codensity -import Control.Monatron.Transformer -import qualified Control.Exception as IO (throwIO,catch,SomeException) - -------------------------------------------------- --- Models and Standard Liftings -------------------------------------------------- - -type ExtModel f g m = forall a. f (m (g a)) -> m a -type Model f m = forall a. f (m a) -> m a -type AlgModel f m = forall a. f a -> m a - -toAlg :: (Functor f, Monad m) => Model f m -> AlgModel f (Codensity m) -toAlg op t = codensity $ \k -> op (fmap k t) - -liftModel :: (Functor f, Monad m, Functor m, FMonadT t, Monad (t (Codensity m))) => - Model f m -> Model f (t m) -liftModel op = tmap runCodensity . join . lift . toAlg op . fmap (tmap lift) - -liftAlgModel :: (MonadT t, Monad m, Functor f) => AlgModel f m -> AlgModel f (t m) -liftAlgModel op = lift . op - -liftExtModel :: ( Functor f, Functor g, Monad m, Functor m, - MMonadT t, Functor (t f), Functor (t m)) => - ExtModel f g m -> ExtModel f g (t m) -liftExtModel op = tmap (op . fmap deComp . deComp) . - monoidalT . flift . fmap (monoidalT . fmap flift) - ----------------------- --- State Operations ----------------------- - -data StateOp s a = Get (s -> a) | Put s a - -instance Functor (StateOp s) where - fmap f (Get g) = Get (f . g) - fmap f (Put s a) = Put s (f a) - -modelStateT :: Monad m => AlgModel (StateOp s) (StateT s m) -modelStateT (Get g) = stateT (\s -> return (g s, s)) -modelStateT (Put s a) = stateT (\_ -> return (a, s)) - -getX :: Monad m => AlgModel (StateOp s) m -> m s -getX op = op $ Get id - -putX :: Monad m => AlgModel (StateOp s) m -> s -> m () -putX op s = op $ Put s () - ----------------------- --- Reader Operations ----------------------- - -data ReaderOp s a = Ask (s -> a) | InEnv s a - -instance Functor (ReaderOp s) where - fmap f (Ask g) = Ask (f . g) - fmap f (InEnv s a) = InEnv s (f a) - -modelReaderT :: Monad m => Model (ReaderOp s) (ReaderT s m) -modelReaderT (Ask g) = readerT (\s -> runReaderT s (g s)) -modelReaderT (InEnv s a) = readerT (\_ -> runReaderT s a) - -askX :: Monad m => Model (ReaderOp s) m -> m s -askX op = op $ Ask return - -inEnvX :: Monad m => Model (ReaderOp s) m -> s -> m a -> m a -inEnvX op s m = op $ InEnv s m - ---derived - -localX :: Monad m => Model (ReaderOp z) m -> (z -> z) -> m a -> m a -localX m f t = do z <- askX m - inEnvX m (f z) t - ------------------------- --- Exception Operations ------------------------- - -data ThrowOp x a = Throw x -data HandleOp x a = Handle a (x -> a) - -instance Functor (ThrowOp x) where - fmap _ (Throw x) = Throw x - -instance Functor (HandleOp x) where - fmap f (Handle a h) = Handle (f a) (f . h) - -modelThrowExcT :: Monad m => AlgModel (ThrowOp x) (ExcT x m) -modelThrowExcT (Throw x) = excT (return (Left x)) - -modelHandleExcT :: Monad m => Model (HandleOp x) (ExcT x m) -modelHandleExcT (Handle m h) = excT (runExcT m >>= \exa -> case exa of - Left x -> runExcT (h x) - Right a -> return (Right a)) - -modelThrowIO :: AlgModel (ThrowOp IO.SomeException) IO -modelThrowIO (Throw x) = IO.throwIO x - -modelHandleIO :: Model (HandleOp IO.SomeException) IO -modelHandleIO (Handle m h) = IO.catch m h - -throwX :: Monad m => AlgModel (ThrowOp x) m -> x -> m a -throwX op x = op $ Throw x - -handleX :: Monad m => Model(HandleOp x) m -> m a -> (x -> m a) -> m a -handleX op m h = op $ Handle m h - ------------------------- --- Writer Operations ------------------------- - -data WriterOp w a = Trace w a - -instance Functor (WriterOp w) where - fmap f (Trace w a) = Trace w (f a) - -modelWriterT :: (Monad m, Monoid w) => AlgModel (WriterOp w) (WriterT w m) -modelWriterT (Trace w a) = writerT (return (a,w)) - -traceX :: (Monad m) => AlgModel (WriterOp w) m -> w -> m () -traceX op w = op $ Trace w () - --------------------------- --- Continuation Operations --------------------------- - -data ContOp r a = Abort r | CallCC ((a -> r) -> a) - -instance Functor (ContOp r) where - fmap _ (Abort r) = Abort r - fmap f (CallCC k) = CallCC (\c -> f (k (c . f))) - -modelContT :: Monad m => AlgModel (ContOp (m r)) (ContT r m) -modelContT (Abort mr) = contT $ \_ -> mr -modelContT (CallCC k) = contT $ \c -> c (k c) - -abortX :: Monad m => AlgModel (ContOp r) m -> r -> m a -abortX op r = op (Abort r) - -callCCX :: Monad m => AlgModel (ContOp r) m -> ((a -> r) -> a) -> m a -callCCX op f = op (CallCC f) - -callccX :: Monad m => AlgModel (ContOp r) m -> ((a -> m b) -> m a) -> m a -callccX op f = join $ callCCX op (\k -> f (\x -> abortX op (k (return x)))) - --------------------------- --- Step Operations --------------------------- - -newtype StepOp f x = StepOp (f x) - -instance (Functor f) => Functor (StepOp f) where - fmap h (StepOp fa) = StepOp (fmap h fa) - -modelStepT :: (Functor f, Monad m) => Model (StepOp f) (StepT f m) -modelStepT (StepOp fa) = stepT (return (Right fa)) - -stepX :: (Monad m) => Model (StepOp f) m -> f (m x) -> m x -stepX op = op . StepOp - --------------------------- --- List Operations --------------------------- - -data ListOp a = ZeroList | PlusList a a - -instance Functor ListOp where - fmap _ ZeroList = ZeroList - fmap f (PlusList a b) = PlusList (f a) (f b) - -modelListT :: Monad m => AlgModel ListOp (ListT m) -modelListT ZeroList = emptyL -modelListT (PlusList t u) = appendL (return t) (return u) - -zeroListX :: Monad m => AlgModel ListOp m -> m a -zeroListX op = op ZeroList - -plusListX :: Monad m => AlgModel ListOp m -> m a -> m a -> m a -plusListX op t u = join $ op (PlusList t u) - diff --git a/Control/Monatron/Transformer.hs b/Control/Monatron/Transformer.hs deleted file mode 100644 --- a/Control/Monatron/Transformer.hs +++ /dev/null @@ -1,286 +0,0 @@ -{-# LANGUAGE ScopedTypeVariables #-} - -module Control.Monatron.Transformer ( - StateT, stateT, runStateT, - WriterT, writerT, runWriterT, - ReaderT, readerT, runReaderT, - ExcT, excT, runExcT, - ContT, contT, runContT, - StepT, stepT, runStepT, caseStepT, unfoldStepT, - ListT, listT, runListT, foldListT, collectListT, emptyL, appendL, --- module Monatron.Operations, - module Control.Monatron.MonadT, - module Data.Monoid -) where - ---import Monatron.Operations -import Control.Monad.Fix -import Control.Monatron.MonadT --- for Writer -import Data.Monoid hiding ((<>)) --- for Error (and Reader?) ---import Monatron.Codensity -import Control.Monatron.AutoInstances() - ---State Monad Transformer -newtype StateT s m a = S { unS :: s -> m (a,s) } - -stateT :: (s -> m (a, s)) -> StateT s m a -stateT = S - -runStateT :: s -> StateT s m a -> m (a,s) -runStateT s m = unS m s - -instance MonadT (StateT s) where - lift m = S $ \s -> m >>= \a -> return (a,s) - m `tbind` k = S $ \s -> unS m s >>= \ ~(a, s') -> unS (k a) s' - -instance (MonadFix m) => MonadFix (StateT s m) where - mfix f = S $ \s -> mfix (runStateT s . f . fst) - -instance FMonadT (StateT s) where - tmap' d1 _d2 g f (S m) = S (f . fmapD d1 (\(x,s) -> (g x,s)) . m) - -instance MMonadT (StateT s) where - flift t = S (\s -> fmap (\a -> (a,s)) t) - monoidalT (S t) = S (\s -> Comp $ fmap (\(S t',s') -> t' s') (t s)) - -{- --- StateT implementation of operations -withStateT :: Monad m => Fop (With s) (StateT s m) -withStateT (With f) = S $ \s -> runStateT s (f s) - -makeStateT :: Monad m => Fop (Make s) (StateT s m) -makeStateT (Make (m,s)) = S $ \_ -> runStateT s m --} - --------------------------------------------------------------- --- Writer Monad Transformer - -newtype WriterT w m a = W {unW :: m (a,w) } - -writerT :: (Monoid w, Monad m) => m (a,w) -> WriterT w m a -writerT = W - -runWriterT :: (Monoid w) => WriterT w m a -> m (a,w) -runWriterT = unW - -instance Monoid w => MonadT (WriterT w) where - tbind (W m) f = W (do (a,w) <- m - (a',w') <- unW (f a) - return (a',w `mappend` w')) - lift m = W (liftM (\a -> (a,mempty)) m) - -{- -instance (MonadFix m, Monoid w) => MonadFix (WriterT w m) where - mfix f = W $ mfix (unW. f) --} - -instance Monoid w => FMonadT (WriterT w) where - tmap' d1 _d2 g f = W . f . fmapD d1 (\(x,s) -> (g x,s)) . unW - -instance Monoid w => MMonadT (WriterT w) where - flift t = W (fmap (\a -> (a,mempty)) t) - monoidalT (W t) = W $ Comp $ fmap (\(W t',w) -> - fmap (\(a,w') -> (a,w `mappend` w')) t') $ t - -{- --- WriterT implementation of operations -withWriterT :: (Monoid w, Monad m) => Fop (With w) (WriterT w m) -withWriterT (With c) = W $ S $ \w -> runWriterT (c w) - - -makeWriterT :: (Monoid w, Monad m) => Fop (Make w) (WriterT w m) -makeWriterT (Make (m, w)) = writerT $ runWriterT m >>= \(a,w') -> - return (a,w' `mappend` w) --} --------------------------------------------------------------- --- Reader Monad Transformer -newtype ReaderT s m a = R { unR :: s -> m a } - -runReaderT :: s -> ReaderT s m a -> m a -runReaderT s m = unR m s - -instance MonadT (ReaderT s) where - tbind m k = R (\s -> unR m s >>= \a -> unR (k a) s) - lift m = R (\_ -> m) - -readerT :: Monad m => (e -> m a) -> ReaderT e m a -readerT = R - -{- -instance (MonadFix m) => MonadFix (ReaderT w m) where - mfix f = R $ mfix (unR. f) --} - -instance FMonadT (ReaderT s) where - tmap' d1 _d2 g f (R m) = R (f . fmapD d1 g . m) - -instance MMonadT (ReaderT s) where - flift t = R (\_ -> t) - monoidalT (R t) = R (\s -> Comp $ fmap (($ s) . unR) (t s)) - -{- --- ReaderT implementation of operations -makeReaderT :: Monad m => Fop (Make e) (ReaderT e m) -makeReaderT = R . makeStateT . fmap unR - -withReaderT :: Monad m => Fop (With e) (ReaderT e m) -withReaderT = R . withStateT . fmap unR --} --------------------------------------------------------------- --- Exceptions Monad Transformer -newtype ExcT x m a = X {unX :: m (Either x a)} - -excT :: Monad m => m (Either x a) -> ExcT x m a -excT = X - -runExcT :: Monad m => ExcT x m a -> m (Either x a) -runExcT = unX --- -instance (MonadFix m) => MonadFix (ExcT x m) where - mfix f = X $ mfix (unX . f . fromRight) - where fromRight (Right a) = a - fromRight _ = error "ExceptionT: mfix looped." - - --- -instance MonadT (ExcT x) where - lift m = X (liftM Right m) - (X m) `tbind` f = X (do a <- m - case a of - Left x -> return (Left x) - Right b -> unX (f b)) - - -instance FMonadT (ExcT x) where - tmap' d1 _d2 g f = X . f . fmapD d1 func . unX where - func (Left x) = Left x - func (Right y) = Right (g y) - -{- --- internal operations -throwExcT :: Monad m => Fop (Throw x) (ExcT x m) -throwExcT (Throw x) = X $ return (Left x) --- -handleExcT :: Monad m => Fop (Handle x) (ExcT x m) -handleExcT (Handle (m, h)) = X (unX m >>= \exa -> - case exa of - Left x -> unX (h x) - Right a -> return (Right a)) - --- Instances of the operations for IO exceptions -throwIO :: Fop (Throw IO.SomeException) IO -throwIO (Throw x) = IO.throwIO x --- -handleIO :: Fop (Handle IO.SomeException) IO -handleIO (Handle (m, h)) = IO.catch m h --} - --------------------------------------------------------------- --- Continuations Monad Transformer - -newtype ContT r m a = C {unC :: (a -> m r) -> m r} - -runContT :: (a -> m r) -> ContT r m a -> m r -runContT = flip unC - -contT :: ((a -> m r) -> m r) -> ContT r m a -contT = C - -instance MonadT (ContT r) where - lift m = C (m >>=) - m `tbind` k = C $ \c -> unC m (\a -> unC (k a) c) - -{- -callCCContT :: Monad m => Fop (CallCC (m r)) (ContT r m) -callCCContT (CallCC f) = C $ \k -> unC (f (\a -> unC a k)) k - -abortContT :: Monad m => Fop (Abort (m r)) (ContT r m) -abortContT (Abort mr) = C $ \_ -> mr --} --------------------------------------------------------------- --- List monad transformer - -data LSig f a b = NilT b - | ConsT a (f a) - -newtype ListT m a = L {unL :: m (LSig (ListT m) a ())} - -runListT :: ListT m a -> m (LSig (ListT m) a ()) -runListT = unL - -listT :: m (LSig (ListT m) a ()) -> ListT m a -listT = L - -emptyL :: Monad m => ListT m a -emptyL = L $ return $ NilT () - -appendL :: Monad m=> ListT m a -> ListT m a -> ListT m a -appendL (L m1) (L m2) = L $ do - l <- m1 - case l of - NilT () -> m2 - ConsT a l1 -> return (ConsT a (appendL l1 (L m2))) - -foldListT :: Monad m => (a -> m b -> m b) -> m b -> ListT m a -> m b -foldListT c n (L m) = do l <- m - case l of - NilT () -> n - ConsT a l1 -> c a (foldListT c n l1) - -collectListT :: Monad m => ListT m a -> m [a] -collectListT lt = foldListT (\a m -> m >>= return. (a:)) (return []) lt - -instance MonadT ListT where - lift m = L $ liftM (`ConsT` emptyL) m - m `tbind` f = L $ foldListT (\a l -> unL $ f a `appendL` L l) - (return $ NilT ()) - m - -instance FMonadT ListT where - tmap' d1 d2 g t (L m) = L $ t $ fmapD d1 (\lsig -> case lsig of - NilT () -> NilT () - ConsT a l -> ConsT (g a) (tmap' d1 d2 g t l)) m - -{- -mZeroListT :: Monad m => Fop MZero (ListT m) -mZeroListT (MZero _) = emptyL - -mPlusListT :: (Monad m) => Fop MPlus (ListT m) -mPlusListT (MPlus (a, b)) = appendL a b --} ------------------------------------------------- --- Step Monad Transformer ------------------------------------------------- - -newtype StepT f m x = T {runT :: m (Either x (f (StepT f m x)))} - -stepT :: m (Either x (f (StepT f m x))) -> StepT f m x -stepT = T - -runStepT :: StepT f m x -> m (Either x (f (StepT f m x))) -runStepT = runT - -{- -instance (Functor f, Monad m) => Monad (StepT f m) where - return = treturn - (>>=) = tbind --} - ---instance (Functor f, Monad m) => Functor (StepT f m) where fmap = liftM - -caseStepT :: (Functor f, Monad m) => - (a -> StepT f m x) -> (f (StepT f m a) -> StepT f m x) - -> StepT f m a -> StepT f m x -caseStepT v c (T m) = T (m >>= either (runT . v) (runT . c)) - -unfoldStepT :: (Functor f, Monad m) => (y -> m (Either x (f y))) -> y -> StepT f m x -unfoldStepT k y = T (liftM (fmap (fmap (unfoldStepT k))) (k y)) - -instance (Functor f) => MonadT (StepT f) where - tbind t f = caseStepT f (T . return . Right . fmap (`tbind` f)) t - lift = T . liftM Left - -instance (Functor f) => FMonadT (StepT f) where - tmap' d1 d2 g t (T m) = T (t (fmapD d1 (either (Left . g) (Right . fmap (tmap' d1 d2 g t))) m)) diff --git a/Control/Monatron/Zipper.hs b/Control/Monatron/Zipper.hs deleted file mode 100644 --- a/Control/Monatron/Zipper.hs +++ /dev/null @@ -1,123 +0,0 @@ --- {-# OPTIONS -fglasgow-exts -XNoMonomorphismRestriction #-} -{-# LANGUAGE NoMonomorphismRestriction #-} -{-# LANGUAGE KindSignatures #-} -{-# LANGUAGE TypeOperators #-} -{-# LANGUAGE MultiParamTypeClasses #-} - -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE OverlappingInstances #-} -{-# LANGUAGE UndecidableInstances #-} -{-# LANGUAGE RankNTypes #-} - -module Control.Monatron.Zipper where - -import Control.Monatron.MonadT () -import Control.Monatron.IdT () -import Control.Monatron.AutoLift -import Control.Monatron.Operations -import Control.Monatron.Monad () --- import Monatron.AutoInstances() - -newtype (t1 :> (t2 :: (* -> *) -> * -> *)) m a = L { runL :: t1 (t2 m) a } - -runZipper :: (t1 :> t2) m a -> t1 (t2 m) a -runZipper = runL - -zipper :: t1 (t2 m) a -> (t1 :> t2) m a -zipper = L - --- * Relative Navigation - --- | shift focus to left -leftL :: (t1 :> t2) m a -> t1 (t2 m) a -leftL = runL - --- | shift focus to right -rightL :: t1 (t2 m) a -> (t1 :> t2) m a -rightL = L - --- The zipper is an FMonadT and a MonadT - -instance (FMonadT t1, FMonadT t2) => FMonadT (t1 :> t2) where - tmap' d1 d2 g f = - L . tmap' (FunctorD (mtmap d1)) (FunctorD (mtmap d2)) g (tmap' d1 d2 id f) . runL - -instance (MonadT t1, MonadT t2) => MonadT (t1 :> t2) where - lift = L . lift . lift - tbind m f = L $ runL m >>= runL . f - --- Instances of the zipper for the various effects - -instance (Monad m, MonadT t1, MonadT t2, StateM z (t2 m)) => StateM z ((t1 :> t2) m) where - stateModel = L . liftAlgModel stateModel - -instance (WriterM z (t2 m), MonadT t1, Monad m, MonadT t2) => WriterM z ((t1 :> t2) m) where - writerModel = L . liftAlgModel writerModel - -instance (ReaderM z (t2 m), FMonadT t1, FMonadT t2, Functor (t2 m), Monad m) => - ReaderM z ((t1 :> t2) m) where - readerModel = L . liftModel readerModel . fmap runL - -instance (ExcM z (t2 m), FMonadT t1, FMonadT t2, Functor (t2 m), Monad m) => - ExcM z ((t1 :> t2) m) where - throwModel = L . liftAlgModel throwModel - handleModel = L . liftModel handleModel . fmap runL - -instance (ContM r (t2 m), FMonadT t1, FMonadT t2, Functor (t2 m), Monad m) => - ContM r ((t1 :> t2) m) where - contModel = L . liftAlgModel contModel - -instance (ListM (t2 m), FMonadT t1, FMonadT t2, Functor (t2 m), Monad m) => - ListM ((t1 :> t2) m) where - listModel = L . liftAlgModel listModel - --- runtest :: (((),Int),Int) --- runtest = runState 0 $ runStateT 0 $ runZipper (put 3) - --- Views and masks; could be in a different file - -data (:><:) m n = View { - to :: forall a . m a -> n a, - from :: forall a . n a -> m a -} - -i :: m :><: m -i = View id id - -o :: (Monad m, MonadT t1, MonadT t2) => t1 (t2 m) :><: (t1 :> t2) m -o = View rightL leftL - -vlift :: (FMonadT t, Functor m, Functor n) - => (m :><: n) -> (t m :><: t n) -vlift v = View (tmap (to v)) (tmap (from v)) - - -hcomp :: (n :><: o) -> (m :><: n) -> (m :><: o) -v2 `hcomp` v1 = View (to v2 . to v1) (from v1 . from v2) - -vcomp :: (Functor m1, Functor m2, FMonadT t) - => (t m2 :><: m3) -> (m1 :><: m2) -> (t m1 :><: m3) -v2 `vcomp` v1 = v2 `hcomp` (vlift v1) - --- program :: StateM Int m => m Int --- program = put 3 >> return 4 - --- t = runState 1 $ runStateT 0 $ runIdT $ runIdT $ view i program - -r :: Monad m => StateT s m :><: ReaderT s m -r = View { - to = \s -> readerT (\e -> liftM fst $ runStateT e s), - from = \e -> stateT (\s -> liftM (\x -> (x,s)) $ runReaderT s e) -} - -stateIso :: Monad m => (s1 -> s2) -> (s2 -> s1) -> StateT s1 m :><: StateT s2 m -stateIso f fm1 = View {to = iso f fm1, from = iso fm1 f } where - iso g h m = stateT $ \s2 -> do (a, s1) <- runStateT (h s2) m - return (a, g s1) - -getv :: StateM s n => (m :><: n) -> m s -getv var = from var get - -putv :: StateM s n => (m :><: n) -> s -> m () -putv var = from var . put diff --git a/Control/Monatron/ZipperExamples.hs b/Control/Monatron/ZipperExamples.hs deleted file mode 100644 --- a/Control/Monatron/ZipperExamples.hs +++ /dev/null @@ -1,83 +0,0 @@ -{-# OPTIONS -XTypeOperators -XFlexibleContexts #-} - -module Control.Monatron.ZipperExamples where - -import Control.Monatron.Monatron -import Control.Monatron.Zipper -import Control.Monatron.Open - --- Don't we need a bidirectional view to implement this combinator? - -fmask :: (m :><: n) -> Open e f (n a) -> Open e f (m a) -fmask v evalf eval = from v . evalf (to v . eval) - -type Env = [(String,Int)] - -type Count = Int - -data Mem e = Store e | Retrieve - -type Reg = Int - -evalMem2 :: (StateM Reg (t m), StateM Count m, MonadT t) - => Open e Mem (t m Int) -evalMem2 eval (Store e) = - do count <- lift $ get - lift $ put (count + 1) - n <- eval e - put n - return n -evalMem2 eval Retrieve = lift $ get - -type M4 = StateT Reg (StateT Env (ExcT String (StateT Count Id))) - -data Lit a = Lit Int -data Var a = Var String -data Add e = Add e e - -instance Functor Lit where - fmap _ (Lit l) = Lit l - -instance Functor Var where - fmap _ (Var v) = Var v - -instance Functor Add where - fmap f (Add e1 e2) = Add (f e1) (f e2) - -instance Functor Mem where - fmap f (Store x) = Store (f x) - fmap f Retrieve = Retrieve - -lit :: (Lit :<: g) => Int -> Fix g -lit l = inject (Lit l) - -var :: (Var :<: g) => String -> Fix g -var v = inject (Var v) - -add :: (Add :<: g) => Fix g -> Fix g -> Fix g -add e1 e2 = inject (Add e1 e2) - -store :: (Mem :<: g) => Fix g -> Fix g -store e = inject (Store e) - -retrieve :: (Mem :<: g) => Fix g -retrieve = inject Retrieve - -type Expr3 = Fix (Mem :+: Var :+: Lit) - -evalLit _ (Lit n) = return n - -evalVar _ (Var v) = do env <- get - case lookup v env of - Just n -> return n - Nothing -> throw "undefined variable" - -eval4 :: Expr3 -> M4 Int -eval4 = fix ( fmask (i `vcomp` o `vcomp` o) evalMem2 - <@> fmask o evalVar - <@> evalLit) - -test = runId $ runStateT 0 $ handleExc $ runStateT [] $ runStateT 0 $ eval4 (store (lit 3)) - -handleExc :: Monad m => ExcT a m b -> m b -handleExc = liftM (either (error "Error!") id) . runExcT diff --git a/Control/Search/Combinator/And.hs b/Control/Search/Combinator/And.hs deleted file mode 100644 --- a/Control/Search/Combinator/And.hs +++ /dev/null @@ -1,143 +0,0 @@ -{-# LANGUAGE FlexibleContexts #-} - -module Control.Search.Combinator.And (andN,(<&>)) where - -import Data.Maybe (fromMaybe, catMaybes, fromJust) - -import Control.Search.Language -import Control.Search.GeneratorInfo -import Control.Search.Memo -import Control.Search.MemoReader -import Control.Search.Generator - -import Control.Search.Combinator.Success - -import Control.Monatron.Monatron hiding (Abort, L, state, cont) -import Control.Monatron.Zipper hiding (i,r) -import Control.Monatron.IdT - -seqNLoop :: (ReaderM Int m, Evalable m) => Int -> [Eval m] -> Eval m -seqNLoop uid lst = commentEval $ - Eval { structs = (foldr1 (@++@) $ map (structs) lst) @++@ mystructs - , toString = "seqN" ++ show uid ++ "(" ++ (foldr1 (\x y -> x ++ "," ++ y) $ map (toString) lst) ++ ")" - , treeState_ = [entry ("seqn_pos",Int,assign 0) -- is the first or the second search active? - , ("seqn_union",Union [(SType (s3 i),"seq" ++ show i) | i <- [0..nbranches-1]], -- union of both tree states - \i -> -- init nested state of first search - let j = xpath i 0 - in initSubEvalState j (s1 0) (fs1 0) - )] - , initH = \i -> (local (const 0) $ inits (xsuper 0) (xpath i 0)) - , evalState_ = [("complete",Bool,const $ return true)] -- some global data - , pushLeftH = push pushLeft - , pushRightH = push pushRight - , nextSameH = \i -> let j = i `withBase` "popped_estate" - in do nd <- inSeq nextDiff i - ns <- inSeq nextSame i - return $ IfThenElse ((seq_pos i) @== (seq_pos j)) ns nd - , nextDiffH = inSeq $ nextDiff - , bodyH = \i -> - let seqBody super j pos = - do - dr <- dec_ref "bodyE-stmt" j i pos - bodyE super (j `onAbort` (comment "seqLoopN.bodyE" >>> dr)) - in do cb <- mapM (\x -> canBranch x >>= \b -> return (if b then 1 else 0)) {- (const $ return 1) -} lst - let cu n | n==nbranches = 0 - cu n = (cb!!n) + cu (n+1) - ss <- mapM (\pos -> local (const $ fromIntegral pos) $ inSeq_ seqBody i) [0..nbranches-1] - let cc n | n==nbranches = Skip - cc n | cu n <= 1 = if ((cb !! n) == 1) then (ss !! n) else cc (n+1) - cc n | otherwise = IfThenElse (seq_pos i @== fromIntegral n) (ss !! n) (cc (n+1)) - return $ cc 0 - , addH = inSeq $ addE - , failH = \i -> inSeq_ (\super j pos -> failE super j @>>>@ (dec_ref "failE" j i pos)) i - , returnH = \i -> numSwitch (\n -> if (n>> dr2 - >>> (seq_pos i <== fromIntegral (n+1)) - >>> init >>> stmt1 >>> stmt2) - returnE (xsuper n) $ j1 `withCommit` const action - else do let j2o = xpath i n - dr3 <- dec_ref "returnE-j2B" j2o i n - let j2 = j2o `onCommit` dr3 - returnE (xsuper n) j2 - ) --- , continue = \_ -> return true - , tryH = \i -> inSeq_ (\super j pos -> do { dr <- dec_ref "tryE" j i pos; return (comment "seqLoop.tryE(a)") @>>>@ tryE super (j `onAbort` (comment "seqLoop.tryE(b)" >>> dr))}) i - , startTryH = \i -> local (const 0) $ inSeq_ (\super j pos -> do { dr <- dec_ref "startTryE" j i pos; return (comment "seqLoop.startTryE(a)") @>>>@ startTryE super (j `onAbort` (comment "seqLoop.startTryE(b)" >>> dr))}) i - , tryLH = \i -> inSeq_ (\super j pos -> tryE_ super j @>>>@ (dec_ref "tryE_" j i pos)) i - , intArraysE = foldr1 (++) $ map (intArraysE) lst - , boolArraysE = foldr1 (++) $ map (boolArraysE) lst - , intVarsE = foldr1 (++) $ map (intVarsE) lst - , deleteH = deleteMe - , canBranch = do res <- mapM (canBranch) lst - return $ or res - , complete = \i -> return $ estate i @=> "complete" --- , complete = const $ return false - } - where nbranches = length lst - xsuper i = lst !! i - mystructs = (catMaybes (map s1 [0..nbranches-1]),map s3 [0..nbranches-1]) - evalStruct side super = Just $ -- if (length (evalState_ super) == 0) then Nothing else Just $ - Struct (side ++ "EvalState" ++ show uid) $ --- (Bool, "cont") : -- continue or not with this search - (Int, "ref_count") : -- how many active nodes of this search - [(ty, field) | (field,ty,_) <- evalState_ super] -- fields of this search --- needSide = \pos stm -> if (length (evalState_ (xsuper pos)) == 0) then Skip else stm - needSide pos stm = stm - s1 i = evalStruct ("Seq" ++ show i) (xsuper i) - et i = maybe (THook "void") (Pointer . SType) $ s1 i - s3 i = Struct ("Seq" ++ show i ++ "TreeState" ++ show uid) $ (case s1 i of { Nothing -> id; Just s -> ((Pointer $ SType s, "evalState"):) }) [(ty, field) | (field,ty,_) <- treeState_ (xsuper i)] - st i = Pointer . SType $ s3 i - xpath i n = flip withClone (\i -> inc (ref_count i)) $ withPath i (inN n) (et n) (st n) - fs1 n = \i -> [(field,init) | (field,_ty,init) <- evalState_ (xsuper n) ] - fs3 n = \i -> [(field,init) | (field,_ty,init) <- treeState_ (xsuper n) ] - withSeq f = numSwitch (\n -> f (xsuper n) (inN n)) - inSeq f = \i -> numSwitch (\n -> f (xsuper n) (xpath i n)) - inSeq_ f = \i -> numSwitch (\n -> f (xsuper n) (xpath i n) n) - push dir = \i -> inSeq_ ( \super j pos -> dir super (j `onCommit` (mkCopy i "seqn_pos" - >>> needSide pos (mkCopy j "evalState") - >>> needSide pos (inc (ref_count j)) - ) - ) - ) i - initSubEvalState = \j s fs -> (case s of { Nothing -> return Skip; Just ss -> return ( (estate j <== New ss) - >>> (ref_count j <== 1) --- >>> (cont j <== true) - )}) - @>>>@ inite (fs j) j - deleteMe = \i -> inSeq_ (\super j pos -> do delrest <- deleteE super j - dr <- dec_ref "deleteMe" j i pos - return (delrest >>> dr)) i --- dec_ref :: String -> Info -> Info -> Int -> Statement - dec_ref s j i pos = complete (xsuper pos) j >>= \compl -> decrefx j pos (estate_type i,estate i) (estate_type j,estate j) (ref_count_type, ref_count j) (THook "bool", compl) - decrefx j pos = memo "dec_ref_and" j (\(_,esti) (_,estj) (_,rcj) (_,xcl) -> return $ ((assign ((esti @=> "complete") &&& (xcl))) (esti @=> "complete") >>> - needSide pos (dec (rcj) >>> ifthen (rcj @== 0) (Delete (estj)))) {- >>> DebugValue ("completeness and" ++ show uid) (esti @=> "complete") -}) - inN n = \state -> state @-> "seqn_union" @-> ("seq" ++ show n) - seq_pos = \i -> tstate i @-> "seqn_pos" - - -andN [] = dummy -andN [s] = s -andN s = - let sc = buildCombiner s - in case sc of - SearchCombiner { runner = runner, elems = elems } -> - Search { mkeval = \super -> do { ss <- extractCombiners elems $ mapE (L . mmap runL . runL) super - ; uid <- get - ; put $ uid+1 - ; return $ mapE (L . mmap L . runL) $ memoLoop $ seqNLoop uid ss - } - , runsearch = runner . rReaderT 0 . runL - } - -a <&> b = andN [a,b] - diff --git a/Control/Search/Combinator/Base.hs b/Control/Search/Combinator/Base.hs deleted file mode 100644 --- a/Control/Search/Combinator/Base.hs +++ /dev/null @@ -1,320 +0,0 @@ -module Control.Search.Combinator.Base ( - label - , vlabel - , glabel, gblabel - , int_assign - , ilabel - , maxV, minV, lbV, ubV, domsizeV, lbRegretV, ubRegretV, degreeV, domSizeDegreeV, wDegreeV, domSizeWDegreeV, randomV, minD, maxD, meanD, medianD, randomD - , foldVarSel, ifoldVarSel, bfoldVarSel, bifoldVarSel - ) where - -import Control.Search.Language -import Control.Search.GeneratorInfo -import Control.Search.Generator - -import Control.Monatron.IdT - -data Label m = Label - { treeStateL :: [(String,Type, Value -> Statement)] - , leftChild_L :: [Info -> Statement] - , rightChild_L :: [Info -> Statement] - , addL :: Info -> m Statement - , tryL :: Info -> m Statement - , intArraysL :: [String] - , boolArraysL :: [String] - , intVarsL :: [String] - } - -v1Label var1 selVal rel e = - Label { treeStateL = [("val", Int, assign 0) - ,("eq", Bool, assign true)] - , leftChild_L = - [ \i -> mkUpdate i "eq" (const true) - , \i -> mkCopy i "val" ] - , rightChild_L = - [ \i -> mkUpdate i "eq" (const false) - , \i -> mkCopy i "val" ] - , addL = \i -> return $ - IfThenElse (eq i) - (Post (space i) (var i `rel` val i)) - (Post (space i) (neg (var i `rel` val i))) - , tryL = \i -> returnE e (resetInfo i) >>= \ret -> -- XXX - tryE_ e (resetInfo i) >>= \try -> -- XXX - return $ (IfThenElse (Assigned (var i)) - ret - (val i <== (selVal $ var i) >>> try)) - , intArraysL = [] - , boolArraysL = [] - , intVarsL = [var1] - } - where val i = tstate i @-> "val" - eq i = tstate i @-> "eq" - var i = IVar var1 (space i) - - -vLabel vars selVar selVal rel e = - Label { treeStateL = [("pos", Int, assign 0) - ,("val", Int, assign 0) - ,("eq", Bool, assign true)] - , leftChild_L = - [ \i -> mkUpdate i "eq" (const true) - , \i -> mkCopy i "val" - , \i -> mkCopy i "pos"] - , rightChild_L = - [ \i -> mkUpdate i "eq" (const false) - , \i -> mkCopy i "val" - , \i -> mkCopy i "pos"] - , addL = \i -> return $ - IfThenElse (eq i) - (Post (space i) (var i `rel` val i)) - (Post (space i) (neg (var i `rel` val i))) - , tryL = \i -> returnE e (resetInfo i) >>= \ret -> -- XXX - tryE_ e (resetInfo i) >>= \try -> -- XXX - return $ (selVar i vars - ret - (val i <== (selVal $ var i) >>> try)) - , intArraysL = [vars] - , boolArraysL = [] - , intVarsL = [] - } - where val i = tstate i @-> "val" - pos i = tstate i @-> "pos" - eq i = tstate i @-> "eq" - var i = AVarElem vars (space i) (pos i) - -vbLabel vars selVar selVal rel e = - Label { treeStateL = [("pos", Int, assign 0) - ,("val", Int, assign 0) - ,("eq", Bool, assign true)] - , leftChild_L = - [ \i -> mkUpdate i "eq" (const true) - , \i -> mkCopy i "val" - , \i -> mkCopy i "pos"] - , rightChild_L = - [ \i -> mkUpdate i "eq" (const false) - , \i -> mkCopy i "val" - , \i -> mkCopy i "pos"] - , addL = \i -> return $ - IfThenElse (eq i) - (Post (space i) (var i `rel` val i)) - (Post (space i) (neg (var i `rel` val i))) - , tryL = \i -> returnE e (resetInfo i) >>= \ret -> -- XXX - tryE_ e (resetInfo i) >>= \try -> -- XXX - return $ (selVar i vars - ret - (val i <== (selVal $ var i) >>> try)) - , intArraysL = [] - , boolArraysL = [vars] - , intVarsL = [] - } - where val i = tstate i @-> "val" - pos i = tstate i @-> "pos" - eq i = tstate i @-> "eq" - var i = BAVarElem vars (space i) (pos i) - -type ValSel = Value -> Value - -type VarSel = Info -> String -> Statement -> Statement -> Statement - -foldVarSel metric (better, zero) i vars notfound found = - Fold vars (tstate i) (space i) zero metric better - >>> IfThenElse (pos i @< 0) notfound found - where pos i = tstate i @-> "pos" - -ifoldVarSel metric (better, zero) i vars notfound found = - IFold vars (tstate i) (space i) zero metric better - >>> IfThenElse (pos i @< 0) notfound found - where pos i = tstate i @-> "pos" - -bfoldVarSel metric (better, zero) i vars notfound found = - BFold vars (tstate i) (space i) zero metric better - >>> IfThenElse (pos i @< 0) notfound found - where pos i = tstate i @-> "pos" - -bifoldVarSel metric (better, zero) i vars notfound found = - BIFold vars (tstate i) (space i) zero metric better - >>> IfThenElse (pos i @< 0) notfound found - where pos i = tstate i @-> "pos" - - --------------------------------------------------------------------------------- --- SEARCH TRANSFORMERS --------------------------------------------------------------------------------- - -pushLeftTop e = \i -> pushLeft e (i `onCommit` mkCopy i "space" ) -pushRightTop e = \i -> pushRight e (i `onCommit` mkUpdate i "space" Clone) - - -baseLoop label this = return $ commentEval $ current - where current = - Eval { structs = ([],[]) - , treeState_ = map entry $ treeStateL label - , initH = const $ return Skip - , evalState_ = [] - , pushLeftH = \i -> cachedCommit i @>>>@ return (seqs [f i | f <- leftChild_L label]) - , pushRightH = \i -> cachedCommit i @>>>@ return (seqs [f i | f <- rightChild_L label]) - , nextSameH = \i -> return Skip - , nextDiffH = \i -> return Skip - , bodyH = addE this . resetInfo -- XXX - , addH = \i -> tryE this (resetInfo i) >>= \try -> -- XXX - addL label i >>= \a -> - return (a >>> try) - , failH = const $ return Skip - , returnH = \i -> cachedCommit i --- , continue = \_ -> return true - , tryH = tr label - , startTryH = tr label - , tryLH = \i -> pushRightTop this (newinfo i "R") >>= \p2 -> - pushLeftTop this (newinfo i "L") >>= \p4 -> - return $ ( - SHook "st->queue->push_back(TreeState());" >>> - SHook "TreeState& nstateR = st->queue->back();" >>> - p2 >>> - SHook "st->queue->push_back(TreeState());" >>> - SHook "TreeState& nstateL = st->queue->back();" >>> - p4 - ) - , intArraysE = intArraysL label - , boolArraysE = boolArraysL label - , intVarsE = intVarsL label - , deleteH = \i -> return Skip - , toString = "base" - , canBranch = return True - , complete = const $ return true - } - where new_tstate = Var "nstate" - tr lab i = failE this (resetInfo i) >>= \fail -> - tryL lab i >>= \tryl -> - return $ (SHook "Gecode::SpaceStatus status;" >>> - (Var "status" <== VHook (rp 0 (space i) ++ "->status()")) >>> - IfThenElse (Var "status" @== VHook "SS_FAILED") (fail >>> Delete (space i)) tryl - ) - -label :: String -> (Value -> Value) -> (Value -> Value -> Value, Value) -> (Value -> Value) -> (Value -> Value -> Constraint) -> Search -label get varMeasure varComp valSel rel = - Search { mkeval = \this -> baseLoop (vLabel get (foldVarSel varMeasure varComp) valSel rel this) this - , runsearch = runIdT - } - -vlabel :: String -> (Value -> Value) -> (Value -> Value -> Constraint) -> Search -vlabel get valSel rel = - Search { mkeval = \this -> baseLoop (v1Label get valSel rel this) this - , runsearch = runIdT - } - -ilabel :: String -> (Value -> Value) -> (Value -> Value -> Value, Value) -> (Value -> Value) -> (Value -> Value -> Constraint) -> Search -ilabel get varMeasure varComp valSel rel = - Search { mkeval = \this -> baseLoop (vLabel get (ifoldVarSel varMeasure varComp) valSel rel this) this - , runsearch = runIdT - } - -int_assign :: String -> VarSel -> (Value -> Value) -> (Value -> Value -> Constraint) -> Search -int_assign get varSel valSel rel = - Search { mkeval = \this -> assignLoop (vLabel get varSel valSel rel this) this - , runsearch = runIdT - } - -glabel :: String -> VarSel -> (Value -> Value) -> (Value -> Value -> Constraint) -> Search -glabel get varSel valSel rel = - Search { mkeval = \this -> baseLoop (vLabel get varSel valSel rel this) this - , runsearch = runIdT - } - -gblabel :: String -> VarSel -> (Value -> Value) -> (Value -> Value -> Constraint) -> Search -gblabel get varSel valSel rel = - Search { mkeval = \this -> baseLoop (vbLabel get varSel valSel rel this) this - , runsearch = runIdT - } - -maxV = (Gt,IVal minBound) -minV = (Lt,IVal maxBound) - -lbV = MinDom -ubV = MaxDom -domsizeV = \v -> MaxDom v - MinDom v -lbRegretV = LbRegret -ubRegretV = UbRegret -degreeV = Degree -domSizeDegreeV = \v -> domsizeV v `Div` degreeV v -wDegreeV = WDegree -domSizeWDegreeV= \v -> domsizeV v `Div` wDegreeV v -randomV = const Random - -minD = MinDom -maxD = MaxDom -meanD = \v -> (maxD v + minD v) `Div` 2 -medianD = \v -> Median v -randomD = \v -> (Random `Mod` (domsizeV v)) + minD v - -{- -assignLoop label this = return $ commentEval $ current - where current = - Eval { structs = ([],[]) - , treeState_ = map entry $ treeStateL label - , initH = const $ return Skip - , evalState_ = [] - , pushLeftH = error "assignLoop.tyE_" - , pushRightH = error "assignLoop.tyE_" - , nextSameH = \i -> return Skip - , nextDiffH = \i -> return Skip - , bodyH = addE this . resetInfo -- XXX - , addH = \i -> tryE this (resetInfo i) >>= \try -> -- XXX - addL label i >>= \a -> - return (a >>> try) - , failH = const $ return Skip - , returnH = \i -> cachedCommit i - , tryH = returnE this . resetInfo - , startTryH = \i -> (return $ comment "") @>>>@ (returnE this . resetInfo) i @>>>@ (return $ comment "") - , tryLH = error "assignLoop.tryE_" - , intArraysE = intArraysL label - , boolArraysE = boolArraysL label - , intVarsE = intVarsL label - , deleteH = \i -> return Skip - , toString = "assign" - , canBranch = return False - , complete = const $ return true - } --} -assignLoop label this = return $ commentEval $ current - where current = - Eval { structs = ([],[]) - , treeState_ = map entry $ treeStateL label - , initH = const $ return Skip - , evalState_ = [] - , pushLeftH = \i -> cachedCommit i @>>>@ return (seqs [f i | f <- leftChild_L label]) - , pushRightH = \i -> cachedCommit i @>>>@ return (seqs [f i | f <- rightChild_L label]) - , nextSameH = \i -> return Skip - , nextDiffH = \i -> return Skip - , bodyH = addE this . resetInfo -- XXX - , addH = \i -> tryE this (resetInfo i) >>= \try -> -- XXX - addL label i >>= \a -> - return (a >>> try) - , failH = const $ return Skip - , returnH = \i -> cachedCommit i - , tryH = tr label - , startTryH = tr label - , tryLH = \i -> -- pushRightTop this (newinfo i "R") >>= \p2 -> - pushLeftTop this (newinfo i "L") >>= \p4 -> - return $ ( - -- SHook "queue->push_back(TreeState());" >>> - -- SHook "TreeState& nstateR = queue->back();" >>> - -- p2 >>> - SHook "st->queue->push_back(TreeState());" >>> - SHook "TreeState& nstateL = st->queue->back();" >>> - p4 - ) - , intArraysE = intArraysL label - , boolArraysE = boolArraysL label - , intVarsE = intVarsL label - , deleteH = \i -> return Skip - , toString = "base" - , canBranch = return True - , complete = const $ return true - } - where new_tstate = Var "nstate" - tr lab i = failE this (resetInfo i) >>= \fail -> - tryL lab i >>= \tryl -> - return $ ( - (Var "status" <== VHook (rp 0 (space i) ++ "->status()")) >>> - IfThenElse (Var "status" @== VHook "SS_FAILED") (fail >>> Delete (space i)) tryl - ) diff --git a/Control/Search/Combinator/Failure.hs b/Control/Search/Combinator/Failure.hs deleted file mode 100644 --- a/Control/Search/Combinator/Failure.hs +++ /dev/null @@ -1,40 +0,0 @@ -module Control.Search.Combinator.Failure (failure) where - -import Control.Search.Language -import Control.Search.GeneratorInfo -import Control.Search.Generator - -import Control.Monatron.Monatron hiding (Abort, L, state, cont) -import Control.Monatron.IdT - -failLoop uid _super = - commentEval $ Eval { structs = ([],[]) - , treeState_ = [] - , evalState_ = [] - , pushLeftH = \_ -> return Skip - , pushRightH = \_ -> return Skip - , nextSameH = \_ -> return Skip - , nextDiffH = \_ -> return Skip - , bodyH = \i -> cachedAbort i - , addH = \_ -> return Skip - , failH = \i -> cachedAbort i - , returnH = \i -> cachedAbort i --- , continue = \_ -> return true - , tryH = \i -> cachedAbort i - , startTryH = \i -> cachedAbort i - , tryLH = \_ -> return Skip - , intArraysE = [] - , intVarsE = [] - , boolArraysE = [] - , deleteH = \i -> cachedAbort i - , initH = \_ -> return $ {- DebugOutput $ "fail" ++ show uid >>> -} Skip - , toString = "fail" ++ show uid - , canBranch = return False - , complete = const $ return false - } - -failure :: Search -failure = - Search { mkeval = \super -> get >>= \uid -> return (failLoop uid super) - , runsearch = runIdT - } diff --git a/Control/Search/Combinator/For.hs b/Control/Search/Combinator/For.hs deleted file mode 100644 --- a/Control/Search/Combinator/For.hs +++ /dev/null @@ -1,115 +0,0 @@ -{-# LANGUAGE FlexibleContexts #-} - -module Control.Search.Combinator.For (for, foreach) where - -import Control.Search.Language -import Control.Search.GeneratorInfo -import Control.Search.Generator -import Control.Search.Memo -import Control.Search.MemoReader - -import Data.Int - -import Control.Monatron.Zipper hiding (i,r) -import Control.Monatron.Monatron hiding (Abort, L, state, cont) - -forLoop :: (ReaderM Bool m, Evalable m) => Int32 -> Int -> (Eval m) -> Eval m -forLoop n uid (super) = commentEval $ - Eval - { - structs = structs super @++@ mystructs - , toString = "for" ++ show uid ++ "(" ++ show n ++ "," ++ toString super ++ ")" - , treeState_ = treeState_ super - , initH = \i -> initE super i @>>>@ return (parent i <== baseTstate i) @>>>@ cachedClone i (cloneBase i) - , evalState_ = ("counter",Int,const $ return 0) : {- ("cont",Bool,const $ return true) : -} ("ref_count",Int,const $ return 1) : ("parent",THook "TreeState",const $ return Null) : evalState_ super - , pushLeftH = push pushLeft - , pushRightH = push pushRight - , nextSameH = nextSame super - , nextDiffH = nextDiff super - , bodyH = \i -> dec_ref i >>= \deref -> bodyE super (i `onAbort` deref) - , addH = addE super - , failH = \i -> failE super i @>>>@ dec_ref i - , returnH = \i -> let j deref = i `onCommit` deref - in dec_ref i >>= returnE super . j - , tryH = \i -> do deref <- dec_ref i - tryE super ((i `withField` ("counter", counter)) `onAbort` deref) - , startTryH = \i -> do deref <- dec_ref i - startTryE super ((i `withField` ("counter", counter)) `onAbort` deref) - , tryLH = \i -> tryE_ super i @>>>@ dec_ref i - , intArraysE = intArraysE super - , boolArraysE = boolArraysE super - , intVarsE = intVarsE super - , deleteH = error "forLoop.deleteE NOT YET IMPLEMENTED" - , canBranch = return True - , complete = complete super - } - where mystructs = ([],[]) - fs1 = [(field,init) | (field,ty,init) <- evalState_ super] - parent = \i -> estate i @=> "parent" - counter = \i -> estate i @=> "counter" - dec_ref = \i -> let i' = resetCommit $ i `withBase` ("for_tstate" ++ show uid) - in do flag <- ask - if flag - then local (const False) $ do - stmt1 <- inits super i' - stmt2 <- startTryE super (i' `withField` ("counter", counter)) - ini <- inite fs1 i' - cc <- cachedClone (cloneBase i) i' - compl <- complete super i - return (dec (ref_count i) - >>> ifthen (ref_count i @== 0) - ( inc (counter i) - >>> comment ("forLoop: bla 1 (baseTstate i' == \"" ++ rp 0 (baseTstate i') ++ "\", ref_count i' == \"" ++ rp 0 (ref_count i') ++ "\")") - >>> ifthen (counter i @< IVal n &&& Not compl) - ( SHook ("TreeState for_tstate" ++ show uid ++ ";") - >>> comment "forLoop: bla 2" - >>> (baseTstate i' <== parent i) - >>> comment "forLoop: bla 3" - >>> cc - >>> comment "forLoop: bla 4" - >>> (ref_count i' <== 1) - >>> comment "forLoop: bla 5" --- >>> (cont i' <== true) - >>> comment "forLoop: bla 6" - >>> ini - >>> comment "forLoop: bla 7" - >>> stmt1 - >>> comment "forLoop: bla 8" - >>> stmt2) - )) - else return $ dec (ref_count i) >>> ifthen (ref_count i @== 0) (comment "Delete-forLoop-dec_ref" >>> Delete (space $ cloneBase i)) - push dir = \i -> dir super (i `onCommit` inc (ref_count i)) -for - :: Int32 - -> Search - -> Search -for n s = - case s of - Search { mkeval = evals, runsearch = runs } -> - Search { mkeval = - \super -> - do { uid <- get - ; put (uid + 1) - ; s' <- evals $ mapE (L . L . mmap runL . runL) super - ; return $ mapE (L . mmap L . runL) $ forLoop n uid (mapE runL s') - } - , runsearch = runs . rReaderT True . runL - } - -foreach - :: Int32 - -> ((Info -> Value) -> Search) - -> Search -foreach n mksearch = - case mksearch (\i -> field i "counter") of - Search { mkeval = eval, runsearch = run } -> - Search { mkeval = - \super -> - do { uid <- get - ; put (uid + 1) - ; s' <- eval $ mapE (L . L . mmap runL . runL) super - ; return $ mapE (L . mmap L . runL) $ forLoop n uid (mapE runL s') - } - , runsearch = run . rReaderT True . runL - } - diff --git a/Control/Search/Combinator/If.hs b/Control/Search/Combinator/If.hs deleted file mode 100644 --- a/Control/Search/Combinator/If.hs +++ /dev/null @@ -1,151 +0,0 @@ -{-# LANGUAGE FlexibleContexts #-} - -module Control.Search.Combinator.If (if') where - -import Control.Search.Language -import Control.Search.GeneratorInfo -import Control.Search.MemoReader -import Control.Search.Generator -import Control.Search.Stat - -import Control.Monatron.Monatron hiding (Abort, L, state, cont) -import Control.Monatron.Zipper hiding (i,r) - -xs1 uid lsuper rsuper = Struct ("LeftEvalState" ++ show uid) $ {- (Bool, "cont") : -} (Int, "ref_count") : [(ty, field) | (field,ty,_) <- evalState_ lsuper] -xfs1 uid lsuper rsuper = [(field,init) | (field,ty,init) <- evalState_ rsuper ] -xs2 uid lsuper rsuper = Struct ("RightEvalState" ++ show uid) $ {- (Bool, "cont") : -} (Int, "ref_count") : [(ty, field) | (field,ty,_) <- evalState_ rsuper] -xfs2 uid lsuper rsuper = [(field,init) | (field,ty,init) <- evalState_ rsuper ] -xs3 uid lsuper rsuper = Struct ("LeftTreeState" ++ show uid) $ (Pointer $ SType $ xs1 uid lsuper rsuper, "evalState") : [(ty, field) | (field,ty,_) <- treeState_ lsuper] -xfs3 uid lsuper rsuper = [(field,init) | (field,ty,init) <- treeState_ lsuper] -xs4 uid lsuper rsuper = Struct ("RightTreeState" ++ show uid) $ (Pointer $ SType $ xs2 uid lsuper rsuper, "evalState") : [(ty, field) | (field,ty,_) <- treeState_ rsuper] -xfs4 uid lsuper rsuper = [(field,init) | (field,ty,init) <- treeState_ rsuper] - -in1 = \state -> state @-> "if_union" @-> "if_then" -in2 = \state -> state @-> "if_union" @-> "if_else" - -xpath uid lsuper rsuper i FirstS = withPath i in1 (SType $ xs1 uid lsuper rsuper) (SType $ xs3 uid lsuper rsuper) -xpath uid lsuper rsuper i SecondS = withPath i in2 (SType $ xs2 uid lsuper rsuper) (SType $ xs4 uid lsuper rsuper) - -ifLoop :: (Evalable m, ReaderM SeqPos m) => Stat -> Int -> Eval m -> Eval m -> Eval m -ifLoop cond uid lsuper rsuper = commentEval $ - Eval { structs = structs lsuper @++@ structs rsuper @++@ mystructs - , toString = "if" ++ show uid ++ "(" ++ show cond ++ "," ++ toString lsuper ++ "," ++ toString rsuper ++ ")" - , treeState_ = [("if_true", Bool,const $ return Skip), - ("if_union",Union [(SType s3,"if_true"),(SType s4,"if_false")],const $ return Skip) - ] - , initH = \i -> (readStat cond >>= \r -> return (assign (r i) (tstate i @-> "if_true"))) @>>>@ initstate i - , evalState_ = [] - , pushLeftH = push pushLeft - , pushRightH = push pushRight - , nextSameH = \i -> let j = i `withBase` "popped_estate" - in do nS1 <- local (const FirstS) $ inSeq nextSame i - nS2 <- local (const SecondS) $ inSeq nextSame i - nD1 <- local (const FirstS) $ inSeq nextDiff i - nD2 <- local (const SecondS) $ inSeq nextDiff i - return $ IfThenElse (is_fst i) - (IfThenElse (is_fst j) nS1 nD1) - (IfThenElse (is_fst j) nD2 nS2) - , nextDiffH = \i -> inSeq nextDiff i - , bodyH = \i -> - let f y z p = - let j = mpath i p -{- in do cond <- continue z (estate j) - deref <- dec_ref i - stmt <- bodyE z (j `onAbort` deref) - return $ IfThenElse (cont j) - (IfThenElse cond - stmt - ( (cont j <== false) - >>> deref - >>> abort j)) - (deref >>> abort j) --} - in dec_ref i >>= \deref -> bodyE z (j `onAbort` deref) - in IfThenElse (is_fst i) @$ local (const FirstS) (f in1 lsuper FirstS) - @. local (const SecondS) (f in2 rsuper SecondS) - , addH = inSeq $ addE - , failH = \i -> inSeq failE i @>>>@ dec_ref i - , returnH = \i -> - let j1 deref = mpath i FirstS `onCommit` deref - j2 deref = mpath i SecondS `onCommit` deref - in IfThenElse (is_fst i) @$ (dec_refx (j1 Skip) >>= returnE lsuper . j1) @. (dec_refx (j2 Skip) >>= returnE rsuper . j2) --- , continue = \_ -> return true - , tryH = \i -> IfThenElse (is_fst i) @$ tryE lsuper (mpath i FirstS) @. tryE rsuper (mpath i SecondS) - , startTryH = \i -> IfThenElse (is_fst i) @$ startTryE lsuper (mpath i FirstS) @. startTryE rsuper (mpath i SecondS) - , tryLH = \i -> IfThenElse (is_fst i) @$ tryE_ lsuper (mpath i FirstS) @. tryE_ rsuper (mpath i SecondS) - , boolArraysE = boolArraysE lsuper ++ boolArraysE rsuper - , intArraysE = intArraysE lsuper ++ intArraysE rsuper - , intVarsE = intVarsE lsuper ++ intVarsE rsuper - , deleteH = deleteMe - , canBranch = canBranch lsuper >>= \l -> canBranch rsuper >>= \r -> return (l || r) - , complete = \i -> do sid1 <- complete lsuper (mpath i FirstS) - sid2 <- complete rsuper (mpath i SecondS) - return $ Cond (tstate i @-> "is_fst") sid1 sid2 - } - where mystructs = ([s1,s2],[s3,s4]) - s1 = xs1 uid lsuper rsuper - s2 = xs2 uid lsuper rsuper - s3 = xs3 uid lsuper rsuper - s4 = xs4 uid lsuper rsuper - fs1 = xfs1 uid lsuper rsuper - fs2 = xfs2 uid lsuper rsuper - fs3 = xfs3 uid lsuper rsuper - fs4 = xfs4 uid lsuper rsuper - mpath = xpath uid lsuper rsuper - withSeq f = seqSwitch (f lsuper in1) (f rsuper in2) - withSeq_ f = seqSwitch (f lsuper in1 FirstS) (f rsuper in2 SecondS) - inSeq f = \i -> withSeq_ $ \super ins pos -> f super (mpath i pos) - dec_ref = \i -> seqSwitch (dec_refx $ mpath i FirstS) (dec_refx $ mpath i SecondS) - dec_refx = \j -> return $ dec (ref_count j) >>> ifthen (ref_count j @== 0) (comment "ifLoop-dec_refx" >>> Delete (estate j)) - push dir = \i -> seqSwitch (push1 dir i) (push2 dir i) - push1 dir = \i -> - let j = mpath i FirstS - in dir lsuper (j `onCommit` ( mkCopy i "if_true" - >>> mkCopy j "evalState" - >>> inc (ref_count j) - )) - push2 dir = \i -> - let j = mpath i SecondS - in dir rsuper (j `onCommit` ( mkCopy i "if_true" - >>> mkCopy j "evalState" - >>> inc (ref_count j) - )) - initstate = \i -> - let f d = - let j = mpath i (if d then FirstS else SecondS) - in return ( (estate j <== New (if d then s1 else s2)) - >>> (ref_count j <== 1) - ) - @>>>@ inite (if d then fs1 else fs2) j - @>>>@ inits (if d then lsuper else rsuper) j - in do thenP <- f True - elseP <- f False - return $ IfThenElse (tstate i @-> "if_true") thenP elseP - in1 = \state -> state @-> "if_union" @-> "if_then" - in2 = \state -> state @-> "if_union" @-> "if_else" - is_fst = \i -> tstate i @-> "if_true" - deleteMe = \i -> seqSwitch (deleteE lsuper (mpath i FirstS)) (deleteE rsuper (mpath i SecondS)) @>>>@ dec_ref i - -if' - :: Stat - -> Search - -> Search - -> Search -if' cond s1 s2 = - case s1 of - Search { mkeval = evals1, runsearch = runs1 } -> - case s2 of - Search { mkeval = evals2, runsearch = runs2 } -> - Search { mkeval = - \super -> do { s2' <- evals2 $ mapE (L . L . L . mmap (mmap runL . runL) . runL) super - ; s1' <- evals1 $ mapE (L . L . mmap (mmap runL . runL) . runL) super - ; uid <- get - ; put (uid + 1) - ; return $ mapE (L . mmap L . runL) $ - ifLoop cond uid (mapE (L . mmap (mmap L) . runL . runL) s1') - (mapE (L . mmap (mmap L) . runL . runL . runL) s2') - } - , runsearch = runs2 . runs1 . runL . rReaderT FirstS . runL - } - where in1 = \state -> state @-> "if_union" @-> "if_then" - in2 = \state -> state @-> "if_union" @-> "if_else" diff --git a/Control/Search/Combinator/Let.hs b/Control/Search/Combinator/Let.hs deleted file mode 100644 --- a/Control/Search/Combinator/Let.hs +++ /dev/null @@ -1,41 +0,0 @@ -module Control.Search.Combinator.Let (let', set') where - -import Control.Search.Language -import Control.Search.GeneratorInfo -import Control.Search.Generator -import Control.Search.Stat - -stmPrefixLoop stm super = super { tryH = \i -> (stm i) @>>>@ (tryE super) i, startTryH = \i -> (stm i) @>>>@ (startTryH super) i, toString = "prefix(" ++ toString super ++ ")" } - -letLoop :: Evalable m => VarId -> Stat -> Eval m -> Eval m -letLoop v@(VarId i) val super'' = - let super' = evalStat val super'' - super = super' { evalState_ = ("var" ++ (show i), Int, \i -> setVarInfo v i >> readStat val >>= \x -> return (x i)) : evalState_ super', - toString = "let(" ++ show v ++ "," ++ show val ++ "," ++ toString super'' ++ ")" } - in commentEval super - -let' - :: VarId - -> Stat - -> Search - -> Search - -let' var val s = - case s of - Search { mkeval = evals, runsearch = runs } -> - Search { mkeval = \super -> do { ss <- evals super - ; return $ letLoop var val ss - } - , runsearch = runs - } - -set' :: VarId -> Stat -> Search -> Search -set' var val s = case s of - Search { mkeval = evals, runsearch = runs } -> - Search { mkeval = \super -> do { ss <- evals super - ; let ss1 = evalStat (varStat var) ss - ; let ss2 = evalStat val ss1 - ; return $ stmPrefixLoop (\i -> readStat (varStat var) >>= \rvar -> readStat val >>= \rval -> return $ Assign (rvar i) (rval i)) ss2 - } - , runsearch = runs - } diff --git a/Control/Search/Combinator/Misc.hs b/Control/Search/Combinator/Misc.hs deleted file mode 100644 --- a/Control/Search/Combinator/Misc.hs +++ /dev/null @@ -1,85 +0,0 @@ -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE RankNTypes #-} - -module Control.Search.Combinator.Misc (dbs, lds, bbmin) where - -import Control.Search.Language -import Control.Search.GeneratorInfo -import Control.Search.Generator -import Control.Search.Stat - -import Data.Int - -import Control.Monatron.IdT - -ldsLoop :: Monad m => Stat -> MkEval m -ldsLoop limit super' = return $ commentEval $ super - { treeState_ = entry ("lds",Int,assign 0) : treeState_ super - , initH = \i -> readStat limit >>= \f -> initH super i @>>>@ return (assign (f i) (tstate i @-> "lds")) - , evalState_ = ("lds_complete", Bool, const $ return true) : evalState_ super - , pushLeftH = \i -> pushLeft super (i `onCommit` mkCopy i "lds") - , pushRightH = \i -> pushRight super (i `onCommit` mkUpdate i "lds" (\x -> x - 1)) >>= \stmt -> - return $ IfThenElse - (tstate (old i) @-> "lds" @>= 0) - stmt - (abort i >>> (estate i @=> "lds_complete" <== false)) - , toString = "lds(" ++ show limit ++ "," ++ toString super ++ ")" - , complete = \i -> return $ estate i @=> "lds_complete" - } - where super = evalStat limit super' - --------------------------------------------------------------------------------- -dbsLoop :: Monad m => Int32 -> MkEval m -dbsLoop limit super = return $ commentEval $ super - { treeState_ = entry ("depth_limit",Int,assign $ IVal limit) : treeState_ super - , evalState_ = ("dbs_complete", Bool, const $ return true) : evalState_ super - , pushLeftH = push pushLeft - , pushRightH = push pushRight - , toString = "dbs(" ++ show limit ++ "," ++ toString super ++ ")" - , complete = \i -> return $ estate i @=> "dbs_complete" - } - where push dir = - \i -> dir super (i `onCommit` mkUpdate i "depth_limit" (\x -> x - 1)) >>= \stmt -> - return $ IfThenElse (tstate (old i) @-> "depth_limit" @>= 0) - stmt - ((estate i @=> "dbs_complete" <== false) >>> abort i) - --------------------------------------------------------------------------------- -bbLoop :: Monad m => String -> MkEval m -bbLoop var super = return $ commentEval $ super - { treeState_ = entry ("tree_bound_version",Int,assign 0) : treeState_ super - , evalState_ = ("bound_version",Int,const $ return 0) : ("bound",Int,const $ return $ IVal maxBound) : evalState_ super - , returnH = \i -> returnE super (i `onCommit` - let get = VHook (rp 0 (space i) ++ "->iv[VAR_" ++ var ++ "].min()") - in (Assign (estate i @=> "bound") get >>> inc (estate i @=> "bound_version"))) - , bodyH = \i -> let set = Post (space i) (VHook (rp 0 (space i) ++ "->iv[VAR_" ++ var ++ "]") $< (estate i @=> "bound")) - in do r <- bodyE super i - return $ (ifthen (tstate i @-> "tree_bound_version" @< (estate i @=>"bound_version")) - (set >>> (Assign (tstate i @-> "tree_bound_version") ((tstate i @-> "tree_bound_version") + 1))) - >>> r) - , pushLeftH = push pushLeft - , pushRightH = push pushRight - , intVarsE = var : intVarsE super - , complete = const $ return true - , toString = "bb(" ++ show var ++ "," ++ toString super ++ ")" - } - where push dir = \i -> dir super (i `onCommit` mkCopy i "tree_bound_version") - -bbmin :: String -> Search -bbmin var = - Search { mkeval = bbLoop var - , runsearch = runIdT - } - -lds :: Stat -> Search -lds n = - Search { mkeval = ldsLoop n - , runsearch = runIdT - } - -dbs :: Int32 -> Search -dbs n = - Search { mkeval = dbsLoop n - , runsearch = runIdT - } - diff --git a/Control/Search/Combinator/Once.hs b/Control/Search/Combinator/Once.hs deleted file mode 100644 --- a/Control/Search/Combinator/Once.hs +++ /dev/null @@ -1,30 +0,0 @@ -module Control.Search.Combinator.Once (once, onceOld) where - -import Control.Search.Language -import Control.Search.GeneratorInfo -import Control.Search.Generator -import Control.Search.Memo -import Control.Search.Stat -import Control.Search.Combinator.Until - -import Control.Monatron.IdT - -onceLoop :: MkEval m -onceLoop super = return $ commentEval $ super - { evalState_ = ("onceMore", Bool, const $ return true) : evalState_ super - , bodyH = \i -> do goOn <- bodyE super i - ca <- cachedAbort i - return $ IfThenElse (estate i @=> "onceMore") - goOn - ca - , returnH = \i -> returnE super $ i `onCommit` assign false (estate i @=> "onceMore") - , toString = "once(" ++ toString super ++ ")" - } - -once :: Search -once = - Search { mkeval = onceLoop - , runsearch = runIdT - } - -onceOld = limit 1 solutionsStat diff --git a/Control/Search/Combinator/Or.hs b/Control/Search/Combinator/Or.hs deleted file mode 100644 --- a/Control/Search/Combinator/Or.hs +++ /dev/null @@ -1,174 +0,0 @@ -{-# LANGUAGE FlexibleContexts #-} - -module Control.Search.Combinator.Or ((<|>)) where - -import Control.Search.Language -import Control.Search.GeneratorInfo -import Control.Search.Generator -import Control.Search.MemoReader -import Control.Search.Memo - -import Control.Monatron.Monatron hiding (Abort, L, state, cont) -import Control.Monatron.Zipper hiding (i,r) - -xs1 uid lsuper rsuper = Struct ("LeftEvalState" ++ show uid) $ (THook "TreeState", "parent") : {- (Bool, "cont") : -} (Int, "ref_count") : [(ty, field) | (field,ty,_) <- evalState_ lsuper] -xfs1 uid lsuper rsuper = [(field,init) | (field,ty,init) <- evalState_ lsuper ] -xs2 uid lsuper rsuper = Struct ("RightEvalState" ++ show uid) $ xneedSide uid lsuper rsuper SecondS $ {- (Bool, "cont") : -} (Int, "ref_count") : [(ty, field) | (field,ty,_) <- evalState_ rsuper] -xfs2 uid lsuper rsuper = [(field,init) | (field,ty,init) <- evalState_ rsuper ] -xet uid lsuper rsuper FirstS = SType $ xs1 uid lsuper rsuper -xet uid lsuper rsuper SecondS = SType $ xs2 uid lsuper rsuper -xs3 uid lsuper rsuper = Struct ("LeftTreeState" ++ show uid) $ (Pointer $ SType $ xs1 uid lsuper rsuper, "evalState") : [(ty, field) | (field,ty,_) <- treeState_ lsuper] -xfs3 uid lsuper rsuper = [(field,init) | (field,ty,init) <- treeState_ lsuper] -xs4 uid lsuper rsuper = Struct ("RightTreeState" ++ show uid) $ xneedSide uid lsuper rsuper SecondS [(Pointer $ SType $ xs2 uid lsuper rsuper, "evalState")] ++ [(ty, field) | (field,ty,_) <- treeState_ rsuper] -xst uid lsuper rsuper FirstS = SType $ xs3 uid lsuper rsuper -xst uid lsuper rsuper SecondS = SType $ xs4 uid lsuper rsuper -xneedSide :: Monoid m => Int -> Eval n -> Eval n -> SeqPos -> m -> m -xneedSide uid lsuper rsuper = \pos stm -> case pos of { FirstS -> stm; - SecondS -> if (length (evalState_ rsuper) == 0) then mempty else stm; - } - -orLoop :: (ReaderM SeqPos m, Evalable m) => Int -> (Eval m) -> (Eval m) -> Eval m -orLoop uid (lsuper) (rsuper) = commentEval $ - Eval { structs = structs lsuper @++@ structs rsuper @++@ mystructs - , toString = "or" ++ show uid ++ "(" ++ toString lsuper ++ "," ++ toString rsuper ++ ")" - , treeState_ = [entry ("is_fst",Bool,assign true) - , ("or_union",Union [(SType s3,"fst"),(SType s4,"snd")], - \i -> - let j = withPath i in1 (et FirstS) (st FirstS) - in do cc <- cachedClone i (cloneBase j) - return ( (estate j <== New s1) - >>> (ref_count j <== 1) --- >>> (cont j <== true) - >>> (parent j <== baseTstate j) - >>> cc - ) - @>>>@ mseqs [init (j `withClone` (\k -> inc $ ref_count k)) | (f,init) <- fs3] - @>>>@ inite fs1 j - )] - , initH = \i -> initE lsuper (withPath i in1 (et FirstS) (st FirstS)) - , evalState_ = [] - , pushLeftH = push pushLeft - , pushRightH = push pushRight - , nextSameH = \i -> let j = i `withBase` "popped_estate" - in do nS1 <- local (const FirstS) $ inSeq nextSame i - nS2 <- local (const SecondS) $ inSeq nextSame i - nD1 <- local (const FirstS) $ inSeq nextDiff i - nD2 <- local (const SecondS) $ inSeq nextDiff i - return $ IfThenElse (is_fst i) - (IfThenElse (is_fst j) nS1 nD1) - (IfThenElse (is_fst j) nD2 nS2) - , nextDiffH = \i -> inSeq nextDiff i - , bodyH = \i -> - let f y z p = - let j = withPath i y (et p) (st p) - in dec_ref i >>= \deref -> bodyE z (j `onAbort` deref) - in IfThenElse (is_fst i) @$ local (const FirstS) (f in1 lsuper FirstS) - @. local (const SecondS) (f in2 rsuper SecondS) - , addH = inSeq $ addE - , failH = \i -> inSeq failE i @>>>@ dec_ref i - , returnH = \i -> - let j1 deref = (withPath i in1 (et FirstS) (st FirstS)) `onCommit` (comment "returnE-deref-j1" >>> deref >>> comment "end returnE-deref-j1") - j2 deref = (withPath i in2 (et SecondS) (st SecondS)) `onCommit` (comment "returnE-deref-j2" >>> deref >>> comment "end returnE-deref-j2") - in seqSwitch (dec_ref1 i >>= returnE lsuper . j1) - (dec_ref2 (j2 Skip) >>= returnE rsuper . j2) - , tryH = \i -> - do dr <- dec_ref i - inSeq (\super j -> tryE super (j `onAbort` (comment "Combinator/Or tryH onAbort" >>> dr ))) i - , startTryH = \i -> local (const FirstS) $ inSeq startTryE i - , tryLH = \i -> inSeq tryE_ i @>>>@ dec_ref i - , boolArraysE = boolArraysE lsuper ++ boolArraysE rsuper - , intArraysE = intArraysE lsuper ++ intArraysE rsuper - , intVarsE = intVarsE lsuper ++ intVarsE rsuper - , deleteH = deleteMe - , canBranch = return True - , complete = \i -> do sid1 <- complete lsuper (withPath i in1 (et FirstS) (st FirstS)) - sid2 <- complete rsuper (withPath i in2 (et SecondS) (st SecondS)) - return $ (Cond (tstate i @-> "is_fst") sid1 sid2) - --- , complete = const $ return false - } - where mystructs = ([s1,s2],[s3,s4]) - s1 = xs1 uid lsuper rsuper - s2 = xs2 uid lsuper rsuper - s3 = xs3 uid lsuper rsuper - s4 = xs4 uid lsuper rsuper - fs1 = xfs1 uid lsuper rsuper - fs2 = xfs2 uid lsuper rsuper - fs3 = xfs3 uid lsuper rsuper - et = xet uid lsuper rsuper - st = xst uid lsuper rsuper - needSide = xneedSide uid lsuper rsuper - parent = \i -> estate i @=> "parent" - withSeq f = seqSwitch (f lsuper in1 FirstS) (f rsuper in2 SecondS) - withSeq_ f = seqSwitch (f lsuper in1 FirstS) (f rsuper in2 SecondS) - inSeq f = \i -> withSeq_ $ \super ins pos -> f super (withPath i ins (et pos) (st pos)) - dec_ref = \i -> seqSwitch (dec_ref1 i) (dec_ref2 $ withPath i in2 (et SecondS) (st SecondS)) - dec_ref1 = \i -> let j1 = withPath i in1 (et FirstS) (st FirstS) - i' = resetClone $ resetAbort $ resetCommit $ i `withBase` ("or_tstate" ++ show uid) - j2 = withPath i' in2 (et SecondS) (st SecondS) - in (local (const SecondS) $ - do stmt1 <- inits rsuper j2 - stmt2 <- startTryE rsuper j2 - ini <- inite fs2 j2 - compl <- complete lsuper j1 - return ( dec (ref_count j1) - >>> (ifthen (ref_count j1 @== 0) $ - ( - {- DebugValue ("or" ++ show uid ++ ": left finished with complete") (compl) - >>> -} (ifthen (Not compl) $ - ( SHook ("TreeState or_tstate" ++ show uid ++ ";") - >>> (baseTstate j2 <== parent j1) - >>> (is_fst i' <== false) - >>> comment "orLoop-dec_ref1-Delete" >>> Delete (estate j1) - >>> needSide SecondS (estate j2 <== New s2) - >>> needSide SecondS (ref_count j2 <== 1) --- >>> (cont j2 <== true) - >>> ini - >>> stmt1 >>> stmt2 - ) - ) - ) - ) - ) - ) - dec_ref2 = \j -> {- return (DebugValue ("or" ++ show uid ++ ": right dec_ref from") (ref_count j)) @>>>@ -} (complete rsuper (withPath (resetClone $ resetAbort $ resetCommit $ j `withBase` ("or_tstate" ++ show uid)) in2 (et SecondS) (st SecondS)) >>= \compl -> (return $ needSide SecondS $ dec (ref_count j) >>> ifthen (ref_count j @== 0) ({- DebugValue ("or" ++ show uid ++ ": right finished with complete") compl >>> -} comment "orLoop-dec_ref2-Delete" >>> Delete (estate j)))) - push dir = \i -> seqSwitch (push1 dir i) (push2 dir i) - push1 dir = \i -> - let j = withPath i in1 (et FirstS) (st FirstS) - in dir lsuper (j `onCommit` ( mkCopy i "is_fst" - >>> mkCopy j "evalState" - >>> inc (ref_count j) - )) - push2 dir = \i -> - let j = withPath i in2 (et SecondS) (st SecondS) - in dir rsuper (j `onCommit` ( mkCopy i "is_fst" - >>> needSide SecondS (mkCopy j "evalState") - >>> needSide SecondS (inc (ref_count j)) - )) - in1 = \state -> state @-> "or_union" @-> "fst" - in2 = \state -> state @-> "or_union" @-> "snd" - is_fst = \i -> tstate i @-> "is_fst" - deleteMe = \i -> seqSwitch (deleteE lsuper (withPath i in1 (et FirstS) (st FirstS))) (deleteE rsuper (withPath i in2 (et SecondS) (st SecondS))) @>>>@ dec_ref i - -(<|>) - :: Search - -> Search - -> Search -s1 <|> s2 = - case s1 of - Search { mkeval = evals1, runsearch = runs1 } -> - case s2 of - Search { mkeval = evals2, runsearch = runs2 } -> - Search {mkeval = - \super -> do { s2' <- evals2 $ mapE (L . L . L . mmap (mmap runL . runL) . runL) super - ; s1' <- evals1 $ mapE (L . L . mmap (mmap runL . runL) . runL) super - ; uid <- get - ; put (uid + 1) - ; return $ mapE (L . mmap L . runL) $ - orLoop uid (mapE (L . mmap (mmap L) . runL . runL) s1') - (mapE (L . mmap (mmap L) . runL . runL . runL) s2') - } - , runsearch = runs2 . runs1 . runL . rReaderT FirstS . runL - } - where in1 = \state -> state @-> "or_union" @-> "fst" - in2 = \state -> state @-> "or_union" @-> "snd" diff --git a/Control/Search/Combinator/OrRepeat.hs b/Control/Search/Combinator/OrRepeat.hs deleted file mode 100644 --- a/Control/Search/Combinator/OrRepeat.hs +++ /dev/null @@ -1,95 +0,0 @@ -{-# LANGUAGE FlexibleContexts #-} - -module Control.Search.Combinator.OrRepeat (orRepeat) where - -import Control.Search.Language -import Control.Search.GeneratorInfo -import Control.Search.Generator -import Control.Search.MemoReader -import Control.Search.Memo -import Control.Search.Stat - -import Control.Monatron.Monatron hiding (Abort, L, state, cont) -import Control.Monatron.Zipper hiding (i,r) - -orRepeatLoop :: (Evalable m, ReaderM Bool m) => Stat -> Int -> Eval m -> Eval m -orRepeatLoop cond uid super' = commentEval $ - Eval - { - structs = structs super @++@ mystructs - , treeState_ = treeState_ super - , toString = "orRepeat" ++ show uid ++ "(" ++ toString super' ++ ")" - , initH = \i -> initE super i @>>>@ return (parent i <== baseTstate i) @>>>@ cachedClone i (cloneBase i) - , evalState_ = {- ("cont",Bool,const $ return true) : -} ("ref_count_orr" ++ show uid,Int,const $ return 1) : ("parent",THook "TreeState",const $ return Null) : evalState_ super - , pushLeftH = push pushLeft - , pushRightH = push pushRight - , nextSameH = nextSame super - , nextDiffH = nextDiff super - , bodyH = \i -> dec_ref i >>= \deref -> bodyE super (i `onAbort` deref) - , addH = addE super - , failH = \i -> failE super i @>>>@ dec_ref i - , returnH = \i -> let j deref = i `onCommit` deref - in dec_ref i >>= returnE super . j - , tryH = \i -> do deref <- dec_ref i - tryE super (i `onAbort` deref) - , startTryH = \i -> do deref <- dec_ref i - startTryE super (i `onAbort` deref) - , tryLH = \i -> tryE_ super i @>>>@ dec_ref i - , intArraysE = intArraysE super - , boolArraysE = boolArraysE super - , intVarsE = intVarsE super - , deleteH = error "orRepeatLoop.deleteE NOT YET IMPLEMENTED" - , canBranch = return True - , complete = complete super --- , complete = const $ return false - } - where mystructs = ([],[]) - super = evalStat cond super' - fs1 = [(field,init) | (field,ty,init) <- evalState_ super] - parent = \i -> estate i @=> "parent" - dec_ref = \i -> let i' = resetAbort $ resetCommit $ i `withBase` ("orr_tstate" ++ show uid) - ii = resetAbort $ resetCommit $ i - in do flag <- ask - if flag - then local (const False) $ do - stmt1 <- inits super i' - stmt2 <- startTryE super i' - r <- readStat cond - ini <- inite fs1 i' - -- let cc = clone ii i' - -- cc <- cachedClone (cloneBase ii) i' - cc1 <- cachedClone (i { baseTstate = parent ii} ) i' - -- cc2 <- cachedClone (i' ) i' - compl <- complete super ii - return (dec (ref_countx ii $ "orr" ++ show uid) - >>> ifthen (ref_countx ii ("orr" ++ show uid) @== 0) - (ifthen (r i' &&& Not compl) - ( SHook ("TreeState orr_tstate" ++ show uid ++ ";") - >>> (baseTstate i' <== parent ii) - -- >>> ((baseTstate i' @-> "space") <== (parent ii @-> "space")) - -- >>> cc - >>> cc1 - -- >>> cc2 - >>> (ref_countx i' ("orr" ++ show uid) <== 1) --- >>> (cont i' <== true) - >>> ini >>> stmt1 >>> stmt2) - )) - else return $ dec (ref_countx ii ("orr" ++ show uid)) >>> ifthen (ref_countx ii ("orr" ++ show uid) @== 0) (comment "orRepeatLoop-dec_ref-Delete" >>> Delete (space $ cloneBase ii)) - push dir = \i -> dir super (i `onCommit'` inc (ref_countx i $ "orr" ++ show uid)) - -orRepeat - :: Stat - -> Search - -> Search -orRepeat cond s = - case s of - Search { mkeval = evals, runsearch = runs } -> - Search { mkeval = - \super -> - do { uid <- get - ; put (uid + 1) - ; s' <- evals $ mapE (L . L . mmap runL . runL) super - ; return $ mapE (L . mmap L . runL) $ orRepeatLoop cond uid (mapE runL s') - } - , runsearch = runs . rReaderT True . runL - } diff --git a/Control/Search/Combinator/Post.hs b/Control/Search/Combinator/Post.hs deleted file mode 100644 --- a/Control/Search/Combinator/Post.hs +++ /dev/null @@ -1,34 +0,0 @@ -{-# LANGUAGE Rank2Types #-} -{-# LANGUAGE FlexibleContexts #-} - -module Control.Search.Combinator.Post (post) where - -import Control.Search.Language -import Control.Search.GeneratorInfo -import Control.Search.Generator -import Control.Search.Constraints - -postLoop :: VarInfoM m => ConstraintGen -> MkEval m -> MkEval m -postLoop (ConstraintGen c l) par this = do - super <- par this - return $ commentEval $ super - { tryH = try tryE super - , startTryH = try startTryE super - , toString = "post(," ++ toString super ++ ")" - , intVarsE = l ++ intVarsE super - } - where try f super = \i -> -- failE super i >>= \fail -> -- XXX - f super i >>= \body -> - c i >>= \cc -> - return $ Post (space i) cc >>> body --- (Var "status" <== VHook (rp 0 (space i) ++ "->status()")) >>> --- IfThenElse (Var "status" @== VHook "SS_FAILED") (fail >>> comment "Delete-postLoop-try" >>> Delete (space i)) body - - -post :: ConstraintGen -> Search -> Search -post c s = - case s of - Search { mkeval = m, runsearch = r } -> - Search { mkeval = postLoop c m - , runsearch = r - } diff --git a/Control/Search/Combinator/Print.hs b/Control/Search/Combinator/Print.hs deleted file mode 100644 --- a/Control/Search/Combinator/Print.hs +++ /dev/null @@ -1,34 +0,0 @@ -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE RankNTypes #-} - -module Control.Search.Combinator.Print (prt,dbg) where - -import Control.Search.Language -import Control.Search.GeneratorInfo -import Control.Search.Generator - -import Control.Monatron.IdT - -printLoop :: [String] -> MkEval m -printLoop lst super = return $ commentEval $ super - { returnH = \i -> returnE super $ i `onCommit` Print (space i) lst - , toString = "print(" ++ toString super ++ ")" - } - -debugLoop :: Evalable m => String -> MkEval m -debugLoop str super = return $ commentEval $ super - { initH = \i -> return (DebugOutput str) @>>>@ initH super i - , toString = "debug(" ++ show str ++ "," ++ toString super ++ ")" - } - -prt :: [String] -> Search -prt l = - Search { mkeval = printLoop l - , runsearch = runIdT - } - -dbg :: String -> Search -dbg str = - Search { mkeval = debugLoop str - , runsearch = runIdT - } diff --git a/Control/Search/Combinator/Repeat.hs b/Control/Search/Combinator/Repeat.hs deleted file mode 100644 --- a/Control/Search/Combinator/Repeat.hs +++ /dev/null @@ -1,84 +0,0 @@ -{-# LANGUAGE FlexibleContexts #-} - -module Control.Search.Combinator.Repeat (repeat) where - -import Prelude hiding (lex, until, init, repeat) - -import Control.Search.Language -import Control.Search.GeneratorInfo -import Control.Search.Generator -import Control.Search.MemoReader -import Control.Search.Memo - -import Control.Monatron.Monatron hiding (Abort, L, state, cont) -import Control.Monatron.Zipper hiding (i,r) - -repeatLoop :: (ReaderM Bool m, Evalable m) => Int -> Eval m -> Eval m -repeatLoop uid super = commentEval $ - Eval - { - structs = structs super @++@ mystructs - , toString = "repeat" ++ show uid ++ "(" ++ toString super ++ ")" - , treeState_ = ("dummy", Int, - \i -> do cc <- cachedClone i (cloneBase i) - return ((parent i <== baseTstate i) - >>> cc - ) - ) : treeState_ super -- `withClone` (\k -> inc $ ref_count k) - , initH = \i -> initE super i - , evalState_ = {- ("cont",Bool,const $ return true) : -} ("ref_count",Int,const $ return 1) : ("parent",THook "TreeState",const $ return Null) : evalState_ super - , pushLeftH = push pushLeft - , pushRightH = push pushRight - , nextSameH = nextSame super - , nextDiffH = nextDiff super - , bodyH = \i -> dec_ref i >>= \deref -> bodyE super (i `onAbort` deref) - , addH = addE super - , failH = \i -> failE super i @>>>@ dec_ref i - , returnH = \i -> let j deref = i `onCommit` deref - in dec_ref i >>= returnE super . j - , tryH = tryE super - , startTryH = startTryE super - , tryLH = \i -> tryE_ super i @>>>@ dec_ref i - , boolArraysE = boolArraysE super - , intArraysE = intArraysE super - , intVarsE = intVarsE super - , deleteH = error "repeatLoop.deleteE NOT YET IMPLEMENTED" - , canBranch = canBranch super - , complete = const $ return true - } - where mystructs = ([],[]) - fs1 = [(field,init) | (field,ty,init) <- evalState_ super] - parent = \i -> estate i @=> "parent" - dec_ref = \i -> let i' = resetCommit $ i `withBase` ("repeat_tstate" ++ show uid) - in do flag <- ask - if flag - then local (const False) $ do - stmt1 <- inits super i' - stmt2 <- startTryE super i' - ini <- inite fs1 i' - return (dec (ref_count i) - >>> ifthen (ref_count i @== 0) - ( SHook ("TreeState repeat_tstate" ++ show uid ++ ";") - >>> (baseTstate i' <== parent i) - >>> clone (cloneBase i) i' - >>> (ref_count i' <== 1) --- >>> (cont i' <== true) - >>> ini >>> stmt1 >>> stmt2)) - else return $dec (ref_count i) >>> ifthen (ref_count i @== 0) (comment "Delete-repeatLoop-dec_ref" >>> Delete (space $ cloneBase i)) - push dir = \i -> dir super (i `onCommit` inc (ref_count i)) - -repeat - :: Search - -> Search -repeat s = - case s of - Search { mkeval = evals, runsearch = runs } -> - Search { mkeval = - \super -> - do { uid <- get - ; put (uid + 1) - ; s' <- evals $ mapE (L . L . mmap runL . runL) super - ; return $ mapE (L . mmap L . runL) $ repeatLoop uid $ mapE runL s' - } - , runsearch = runs . rReaderT True . runL - } diff --git a/Control/Search/Combinator/Success.hs b/Control/Search/Combinator/Success.hs deleted file mode 100644 --- a/Control/Search/Combinator/Success.hs +++ /dev/null @@ -1,38 +0,0 @@ -module Control.Search.Combinator.Success (dummy) where - -import Control.Search.Language -import Control.Search.GeneratorInfo -import Control.Search.Generator -import Control.Search.Memo - -import Control.Monatron.IdT - -successLoop :: Evalable m => Eval m -> Eval m -successLoop this = commentEval $ - Eval { structs = ([],[]) - , treeState_ = [] - , initH = const $ return Skip - , evalState_ = [] - , pushLeftH = error "succesloop.tyE_" - , pushRightH = error "succesloop.tyE_" - , nextSameH = \i -> return Skip - , nextDiffH = \i -> return Skip - , bodyH = addE this . resetInfo -- XXX - , addH = \i -> tryE this (resetInfo i) - , failH = const $ return Skip - , returnH = \i -> cachedCommit i - -- const $ return Skip --- , continue = \_ -> return true - , tryH = returnE this . resetInfo - , startTryH = \i -> (return $ comment "") @>>>@ (returnE this . resetInfo) i @>>>@ (return $ comment "") - , tryLH = error "succesloop.tryE_" - , intArraysE = [] - , boolArraysE = [] - , intVarsE = [] - , deleteH = \i -> return Skip - , toString = "succeed" - , canBranch = return False - , complete = const $ return true - } - -dummy = Search { mkeval = return . successLoop, runsearch = runIdT } diff --git a/Control/Search/Combinator/Until.hs b/Control/Search/Combinator/Until.hs deleted file mode 100644 --- a/Control/Search/Combinator/Until.hs +++ /dev/null @@ -1,188 +0,0 @@ -{-# LANGUAGE FlexibleContexts #-} - -module Control.Search.Combinator.Until (until,limit,glimit) where - -import Prelude hiding (until) -import Data.Int - -import Control.Search.Language -import Control.Search.GeneratorInfo -import Control.Search.MemoReader -import Control.Search.Generator -import Control.Search.Combinator.Failure -import Control.Search.Stat - -import Control.Monatron.Monatron hiding (Abort, L, state, cont) -import Control.Monatron.Zipper hiding (i,r) - -untilLoop :: (Evalable m, ReaderM SeqPos m) => Stat -> Int -> (Eval m) -> (Eval m) -> Eval m -untilLoop cond uid lsuper' rsuper = commentEval c - where c = Eval { structs = structs lsuper @++@ structs rsuper @++@ mystructs - , toString = "until" ++ show uid ++ "(" ++ show cond ++ "," ++ toString lsuper' ++ "," ++ toString rsuper ++ ")" - , treeState_ = [entry ("is_fst",Bool,assign true) - ,("until_union", Union [(SType s3,"fst"),(SType s4,"snd")], - \i -> - let j = xpath i FirstS - in initSubEvalState j s1 fs1 FirstS) - ] - , initH = \i -> inits lsuper (i `xpath` FirstS) - , evalState_ = [("until_complete",Bool,const $ return true)] - , pushLeftH = push pushLeft - , pushRightH = push pushRight - , nextSameH = \i -> let j = i `withBase` "popped_estate" - in do let nS1 = local (const FirstS) $ inSeq nextSame i - let nS2 = local (const SecondS) $ inSeq nextSame i - let nD1 = local (const FirstS) $ inSeq nextDiff i - let nD2 = local (const SecondS) $ inSeq nextDiff i - swfst i (swfst j nS1 nD1) (swfst j nD2 nS2) - , nextDiffH = inSeq nextDiff - , -- MAIN ENTRY POINT FOR NEW NODE - -- if (fst) { - -- if (seq_union.fst.evalState->cont) { - -- } else { - -- } - -- } else { - -- if (seq_union.snd.evalState->cont) { - -- } else { - -- } - -- } - bodyH = \i -> - let f y z iscomplete pos = - do compl <- iscomplete (i `xpath` pos) - let j = i `xpath` pos `onAbort` (comment "untilLoop.bodyE" >>> dec_ref i j compl pos) - bodyE z j - in do let s1 = local (const FirstS) $ f in1 lsuper liscomplete FirstS - s2 = local (const SecondS) $ f in2 rsuper riscomplete SecondS - swfst i s1 s2 - , addH = inSeq $ addE - , failH = \i -> inSeq' (\super j iscomplete pos -> iscomplete j >>= \compl -> (failE super j @>>>@ return (dec_ref i j compl pos))) i - , returnH = \i -> inSeq' (\super j iscomplete pos -> iscomplete j >>= \compl -> (returnE super (j `onCommit` dec_ref i j compl pos))) i --- , continue = \_ -> return true - -- IF THE CURRENT STATUS IS NOT FAILED - -- EITHER (is_fst) - -- if () { // SWITCH TO NEW SEARCH - -- } else { - -- - -- } - -- OR (!is_fst) - , tryH = tryX tryE - , startTryH = tryX startTryE - , tryLH = \i -> inSeq' (\super j iscomplete pos -> iscomplete j >>= \compl -> (tryE_ super j @>>>@ return (dec_ref i j compl pos))) i - , boolArraysE = boolArraysE lsuper ++ boolArraysE rsuper - , intArraysE = intArraysE lsuper ++ intArraysE rsuper - , intVarsE = intVarsE lsuper ++ intVarsE rsuper - , deleteH = error "untilLoop.deleteE NOT YET IMPLEMENTED" - , canBranch = canBranch lsuper >>= \l -> canBranch rsuper >>= \r -> return (l || r) - , complete = \i -> return $ estate i @=> "until_complete" --- , complete = const $ return false - } - needSide_ = \pos stmY stmN -> case pos of { FirstS -> if (length (evalState_ lsuper) == 0) then stmN else stmY; - SecondS -> if (length (evalState_ rsuper) == 0) then stmN else stmY; - } - needSide :: Monoid m => SeqPos -> m -> m - needSide = \pos stm -> needSide_ pos stm mempty - mystructs = ([s1,s2],[s3,s4]) - s1 = Struct ("LeftEvalState" ++ show uid) $ needSide FirstS $ {- (Bool, "cont") : -} (Int, "ref_count_until" ++ show uid) : [(ty, field) | (field,ty,_) <- evalState_ lsuper] - fs1 = [(field,init) | (field,ty,init) <- evalState_ lsuper ] - s2 = Struct ("RightEvalState" ++ show uid) $ needSide SecondS $ {- (Bool, "cont") : -} (Int, "ref_count_until" ++ show uid) : [(ty, field) | (field,ty,_) <- evalState_ rsuper] - fs2 = [(field,init) | (field,ty,init) <- evalState_ rsuper ] - s3 = Struct ("LeftTreeState" ++ show uid) $ needSide FirstS [(Pointer $ SType s1, "evalState")] ++ [(ty, field) | (field,ty,_) <- treeState_ lsuper] - fs3 = [(field,init) | (field,ty,init) <- treeState_ lsuper] - s4 = Struct ("RightTreeState" ++ show uid) $ needSide SecondS [(Pointer $ SType s2, "evalState")] ++ [(ty, field) | (field,ty,_) <- treeState_ rsuper] - xpath i FirstS = withPath i in1 (Pointer $ SType s1) (Pointer $ SType s3) - xpath i SecondS = withPath i in2 (Pointer $ SType s2) (Pointer $ SType s4) - in1 = \state -> state @-> "until_union" @-> "fst" - in2 = \state -> state @-> "until_union" @-> "snd" - is_fst = \i -> tstate i @-> "is_fst" - withSeq f = seqSwitch (f lsuper in1) (f rsuper in2) - withSeq_ f = seqSwitch (f lsuper in1 FirstS) (f rsuper in2 SecondS) - inSeq f = \i -> withSeq_ $ \super ins pos -> f super (i `xpath` pos) - inSeq' f = \i -> seqSwitch (f lsuper (i `xpath` FirstS) liscomplete FirstS) - (f rsuper (i `xpath` SecondS) riscomplete SecondS) - dec_ref = \i j iscomplete pos -> needSide_ pos (dec (ref_countx j $ "until" ++ show uid) >>> - ifthen (ref_countx j ("until" ++ show uid) @== 0) ( - {- DebugValue ("until" ++ show uid ++ ": left branch finished with complete") iscomplete - >>> DebugValue ("until" ++ show uid ++ ": until's previous completeness was") (complet i) - >>> -} (complet i <== (complet i &&& iscomplete)) >>> Delete (estate j) - ) - ) (complet i <== (complet i &&& iscomplete)) - push dir = \i -> seqSwitch (push1 dir i) (push2 dir i) - push1 dir = \i -> - let j = i `xpath` FirstS - in dir lsuper (j `onCommit` ( mkCopy i "is_fst" - >>> mkCopy j "evalState" - >>> inc (ref_countx j $ "until" ++ show uid) - )) - push2 dir = \i -> - let j = i `xpath` SecondS - in dir rsuper (j `onCommit` ( mkCopy i "is_fst" - >>> mkCopy j "evalState" - >>> inc (ref_countx j $ "until" ++ show uid) - )) - lsuper = evalStat cond lsuper' - complet = \i -> estate i @=> "until_complete" - liscomplete = complete lsuper' - riscomplete = complete rsuper - initSubEvalState = \j s fs pos -> return (needSide pos ( (estate j <== New s) - >>> (ref_countx j ("until" ++ show uid) <== 1) --- >>> (cont j <== true) - ) - ) - @>>>@ inite fs j - tryX = \x i -> do lc <- liscomplete (i `xpath` FirstS) - rc <- riscomplete (i `xpath` SecondS) - let j1 = i `xpath` FirstS `onAbort` (comment "untilLoop.tryE j1" >>> dec_ref i j1 lc FirstS) - j2 = i `xpath` SecondS `onAbort` (comment "untilLoop.tryE j2" >>> dec_ref i j2 rc SecondS) - j2b = i `xpath` SecondS `onAbort` (comment "untilLoop.tryE j2b" >>> dec_ref i j2b rc SecondS) - seqSwitch (x lsuper j1 >>= \try1 -> - deleteE lsuper j1 >>= \delete1 -> - (local (const SecondS) $ - do stmt1 <- inits rsuper j2b - stmt2 <- startTryE rsuper j2b - ini <- initSubEvalState j2b s2 fs2 SecondS - return ( delete1 - >>> dec_ref i j1 lc FirstS - >>> (is_fst i <== false) - >>> ini - >>> comment "initTreeState_ j2b rsuper" - >>> stmt1 - >>> comment "tryE rsuper j2b" - >>> comment ("length: " ++ show (length (abort_ j2b))) - >>> stmt2) - ) >>= \start2 -> readStat cond >>= \r -> return $ IfThenElse (r j1) ({- (DebugOutput $ "until" ++ show uid ++ " switches") >>> -} start2) try1 - ) - (x rsuper j2) - swfst i t e = do b1 <- canBranch lsuper - b2 <- canBranch rsuper - if (b1 && b2) then do { tt <- t; ee <- e; return $ IfThenElse (is_fst i) tt ee } - else if b1 then t - else e - - -limit :: Int32 -> Stat -> Search -> Search -limit n stat s = until (stat #>= constStat (const (IVal n))) s failure - -glimit :: Stat -> Search -> Search -glimit cond s = until (cond) s failure - -until - :: Stat - -> Search - -> Search - -> Search -until cond s1 s2 = - case s1 of - Search { mkeval = evals1, runsearch = runs1 } -> - case s2 of - Search { mkeval = evals2, runsearch = runs2 } -> - Search { mkeval = - \super -> do { s2' <- evals2 $ mapE (L . L . L . mmap (mmap runL . runL) . runL) super - ; s1' <- evals1 $ mapE (L . L . mmap (mmap runL . runL) . runL) super - ; uid <- get - ; put (uid + 1) - ; return $ mapE (L . mmap L . runL) $ memoLoop $ - untilLoop cond uid (mapE ({- L . mmap (mmap L) . runL . runL-} mmap L . runL) s1') - (mapE ({- L . mmap (mmap L) . runL . runL . runL-} mmap L . runL . runL) s2') - } - , runsearch = runs2 . runs1 . runL . rReaderT FirstS . runL - } diff --git a/Control/Search/Constraints.hs b/Control/Search/Constraints.hs deleted file mode 100644 --- a/Control/Search/Constraints.hs +++ /dev/null @@ -1,71 +0,0 @@ -{-# LANGUAGE Rank2Types #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE TypeOperators #-} -{-# LANGUAGE ExistentialQuantification #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE PatternGuards #-} -{-# LANGUAGE GeneralizedNewtypeDeriving #-} -{-# LANGUAGE OverlappingInstances #-} - -module Control.Search.Constraints - ( clvar, cvar, cvars, cbvars, cval, cop, ctrue, cfalse, cexprStatVal, cexprStatMed, cexprStatMin, cexprStatMax - , ConstraintExpr(..), ConstraintGen(..) - ) where - -import Text.PrettyPrint hiding (space) -import Data.List (sort, nub, sortBy) -import Unsafe.Coerce - -import Control.Search.Language -import Control.Search.GeneratorInfo -import Control.Search.Memo -import Control.Search.Stat -import Control.Search.Generator - -import Control.Monatron.Monatron hiding (Abort, L, state, cont) -import Control.Monatron.Zipper hiding (i,r) -import Control.Monatron.IdT - -import Data.Maybe (fromJust) -import Data.Map (Map) -import qualified Data.Map as Map - -import Control.Search.SStateT - -data ConstraintExpr = ConstraintExpr (forall m. VarInfoM m => m IValue) Bool [String] - -data ConstraintGen = ConstraintGen (forall m. VarInfoM m => Info -> m Constraint) [String] - -cvars :: String -> Integer -> ConstraintExpr -cvars v n = ConstraintExpr (return $ \i -> (AVarElem v (space i) (fromInteger n))) True [v] - -cbvars :: String -> Integer -> ConstraintExpr -cbvars v n = ConstraintExpr (return $ \i -> (BAVarElem v (space i) (fromInteger n))) True [v] - -cvar :: String -> ConstraintExpr -cvar v = ConstraintExpr (return $ \i -> (IVar v (space i))) True [v] - -cval :: Integer -> ConstraintExpr -cval i = ConstraintExpr (return $ const $ fromInteger i) False [] - -clvar :: VarId -> ConstraintExpr -clvar v@(VarId n) = ConstraintExpr (do inf <- lookupVarInfo v - return $ const $ estate inf @=> ("var" ++ show n) - ) False [] - -cop :: ConstraintExpr -> (Value -> Value -> Constraint) -> ConstraintExpr -> ConstraintGen -cop (ConstraintExpr v1 _ l1) op (ConstraintExpr v2 _ l2) = ConstraintGen (\info -> (v1 >>= \x -> v2 >>= \y -> return (x info `op` y info))) (l1 ++ l2) - -ctrue :: ConstraintGen -ctrue = ConstraintGen (const $ return TrueC) [] - -cfalse :: ConstraintGen -cfalse = ConstraintGen (const $ return FalseC) [] - -cexprStat f (ConstraintExpr m c l) = Stat (\e -> e { intVarsE = l ++ intVarsE e }) (m >>= \iv -> return (\info -> (if c then iv info @-> (f ++ "()") else iv info))) -cexprStatVal = cexprStat "val" -cexprStatMin = cexprStat "min" -cexprStatMax = cexprStat "max" -cexprStatMed = cexprStat "med" - - diff --git a/Control/Search/Generator.hs b/Control/Search/Generator.hs deleted file mode 100644 --- a/Control/Search/Generator.hs +++ /dev/null @@ -1,855 +0,0 @@ -{-# LANGUAGE CPP #-} -{-# LANGUAGE Rank2Types #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE TypeOperators #-} -{-# LANGUAGE ExistentialQuantification #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE PatternGuards #-} -{-# LANGUAGE GeneralizedNewtypeDeriving #-} -{-# LANGUAGE OverlappingInstances #-} -{-# LANGUAGE IncoherentInstances #-} -{-# LANGUAGE UndecidableInstances #-} - -module Control.Search.Generator - ( (<@>) - , mmap - , search - , ($==) - , ($/=) - , ($<) - , ($<=) - , ($>) - , ($>=) - , (@>) - , VarId(..) - - , mapE, Eval(..), inite, seqSwitch, VarInfoM(..), MkEval, Evalable - , SeqPos(..), Search(..), (@.), (@$), (@>>>@) - , ref_count, ref_countx, ref_count_type, commentEval, (@++@) - , entry, numSwitch, SearchCombiner(..) - , buildCombiner, extractCombiners - , memo - , memoLoop {- ,MemoWrapper, runMemoWrapper-} - , rReaderT -#ifndef NOMEMO - , cacheStatement -#endif - , cloneBase - , mkCopy, mkUpdate, rp, inits, mseqs - , cachedCommit, cachedAbort, cachedClone - , nextSame, nextDiff, pushLeft, pushRight, bodyE, addE, returnE, initE, failE, tryE, startTryE, tryE_, deleteE - ) where - -import Debug.Trace - -import Text.PrettyPrint hiding (space) -import Data.List (sort, nub, sortBy) -import Data.List (intercalate) -import Data.Unique -import Unsafe.Coerce - -import Control.Search.Language -import Control.Search.GeneratorInfo -#ifndef NOMEMO -import Control.Search.Memo -import Control.Search.MemoReader -#endif - -import Control.Monatron.Monatron hiding (Abort, L, state, cont) -import Control.Monatron.Zipper hiding (i,r) -import Control.Monatron.MonadInfo -import Control.Monatron.IdT - -import Data.Maybe (fromJust) -import Data.Map (Map) -import qualified Data.Map as Map - -import Control.Search.SStateT - -modify :: StateM s f => (s -> s) -> f () -modify f = get >>= put . f - -newtype GenModeT m a = GenModeT { unGenModeT :: ReaderT GenMode m a } - deriving (MonadT, ReaderM GenMode, FMonadT) - -class Monad m => GenModeM m where - getFlags :: m PrettyFlags - getMode :: m GenMode - getFlags = getMode >>= return . PrettyFlags - -instance MonadInfoT GenModeT where - tminfo x = miInc "GenModeT" $ minfo (runReaderT undefined (unGenModeT x)) - -instance Monad m => GenModeM (GenModeT m) where - getMode = GenModeT ask - -instance (GenModeM m, FMonadT t) => GenModeM (t m) where - getMode = lift getMode - -runGenModeT :: GenMode -> GenModeT m a -> m a -runGenModeT m (GenModeT r) = runReaderT m r - -type TreeState = Value - -newtype VarId = VarId Int - deriving (Ord, Eq, Show) - -type VarInfo = Map VarId Info - -newtype VarInfoT m a = VarInfoT { unVarInfoT :: SStateT VarInfo m a } - deriving (MonadT,StateM VarInfo, FMonadT) - -instance MonadInfoT VarInfoT where - tminfo x = miInc "VarInfoT" $ minfo (runSStateT undefined (unVarInfoT x)) - -class Monad m => VarInfoM m where - lookupVarInfo :: VarId -> m Info - setVarInfo :: VarId -> Info -> m () - -instance Monad m => VarInfoM (VarInfoT m) where - lookupVarInfo var = VarInfoT $ get >>= return . fromJust . Map.lookup var - setVarInfo var val = VarInfoT $ get >>= \tbl -> (put $ Map.insert var val tbl) - -instance (VarInfoM m, FMonadT t) => VarInfoM (t m) where - lookupVarInfo = lift . lookupVarInfo - setVarInfo var val = lift (setVarInfo var val) - -#ifdef NOMEMO -class (VarInfoM m, HookStatsM m, MonadInfo m, GenModeM m, Functor m) => Evalable m -instance (VarInfoM m, HookStatsM m, MonadInfo m, GenModeM m, Functor m) => Evalable m -#else -class (VarInfoM m, HookStatsM m, MonadInfo m, MemoM m, GenModeM m, Functor m) => Evalable m -instance (VarInfoM m, HookStatsM m, MonadInfo m, MemoM m, GenModeM m, Functor m) => Evalable m -#endif - -data Eval m = Eval - { structs :: ([Struct],[Struct]) -- auxiliary type declarations - , treeState_ :: [(String,Type, Info -> m Statement)] -- tree state fields (name, type, init) - , evalState_ :: [(String,Type, Info -> m Value)] - , nextSameH :: Info -> m Statement - , nextDiffH :: Info -> m Statement - , pushLeftH :: Info -> m Statement - , pushRightH :: Info -> m Statement - , bodyH :: Info -> m Statement - , initH :: Info -> m Statement - , addH :: Info -> m Statement - , returnH :: Info -> m Statement - , failH :: Info -> m Statement - , tryH :: Info -> m Statement - , tryLH :: Info -> m Statement - , startTryH :: Info -> m Statement - , intArraysE :: [String] - , boolArraysE :: [String] - , intVarsE :: [String] - , -- Free heap allocated memory for search heuristic associated to this node - -- because it is being abandoned. - -- - -- BE CAREFUL: deallocate memory only once in case of multiple references. - -- - -- Example use case: untilLoop - deleteH :: Info -> m Statement - , toString :: String - , canBranch :: m Bool - , complete :: Info -> m Value - } - -commentStatement :: (HookStatsM m) => String -> Eval m -> (Info -> m Statement) -> (Info -> m Statement) -#ifdef OUTPUTCOMMENTS -commentStatement c e f = \x -> (f x >>= \s -> return (DebugOutput ("begin: " ++ c ++ " @ " ++ toString e) >>> s >>> DebugOutput ("end: " ++ c ++ " @ " ++ toString e))) -#else -commentStatement c e f = \x -> (f x >>= \s -> return (comment ("begin: " ++ c ++ " @ " ++ toString e) >>> s >>> comment ("end: " ++ c ++ " @ " ++ toString e))) -#endif - -commentEval :: Evalable m => Eval m -> Eval m -#ifdef COMMENTS -commentEval e = - e { treeState_ = map (\(a,b,c) -> (a,b,commentStatement "treeState" e c)) (treeState_ e) - , nextSameH = commentStatement "nextSame" e (nextSame e) - , nextDiffH = commentStatement "nextDiff" e (nextDiff e) - , pushLeftH = commentStatement "pushLeft" e (pushLeft e) - , pushRightH = commentStatement "pushRight" e (pushRight e) - , bodyH = commentStatement "bodyE" e (bodyE e) - , initH = commentStatement "initE" e (initE e) - , addH = commentStatement "addE" e (addE e) - , returnH = commentStatement "returnE" e (returnE e) - , failH = commentStatement "failE" e (failE e) - , tryH = commentStatement "tryE" e (tryE e) - , tryLH = commentStatement "tryE_" e (tryE_ e) - , deleteH = commentStatement "deleteE" e (deleteE e) - , startTryH = commentStatement "startTryE" e (startTryE e) - } -#else -commentEval = id -#endif - -entry :: Monad m => (String,Type,Value -> Statement) -> (String,Type,Info -> m Statement) -entry (name,ty,up) = (name, ty, \i -> return (up $ (@->name) $ tstate i)) - -rootEntry :: Monad m => [(String,Type,Info -> m Statement)] -rootEntry = [ entry ("space",Pointer SpaceType,assign RootSpace) - ] - -inits :: Evalable m => Eval m -> Info -> m Statement -inits e i = initTreeState_ i e @>>>@ initH e i - -inite :: Monad m => [(String,Info -> m Value)] -> Info -> m Statement -inite fs i = mseqs [init i >>= \ini -> return (estate i @=> f <== ini) | (f,init) <- fs] - -mkCopy i f = (tstate i @-> f) <== (tstate (old i) @-> f) -mkUpdate i f g = (tstate i @-> f) <== g (tstate (old i) @-> f) - -mseqs lst = sequence lst >>= \s -> return (seqs s) - -mapE :: (HookStatsM m, HookStatsM n) => (forall x. m x -> n x) -> Eval m -> Eval n -mapE x = mapE_ (const x) - -data HookStat = HookStat { nCalls :: Integer } - -newtype HookStatsT m a = HookStatsT { unHookStatsT :: StateT HookStat m a } - deriving (Monad, StateM HookStat, FMonadT, MonadT) - -runHookStatsT :: Monad m => HookStatsT m a -> m (a, Integer) -runHookStatsT m = do - (a, s) <- runStateT (HookStat { nCalls = 0 }) $ unHookStatsT m - return (a, nCalls s) - -instance MonadInfoT HookStatsT where - tminfo = miInc "HookStatsT" . minfo . runHookStatsT - -class Monad m => HookStatsM m where - hookCalled :: m () - -instance Monad m => HookStatsM (HookStatsT m) where - hookCalled = modify (\st -> st { nCalls = 1 + nCalls st }) - -instance (MonadT t, HookStatsM m) => HookStatsM (t m) where - hookCalled = lift hookCalled - -callHook :: HookStatsM m => String -> Eval m -> Info -> m () -callHook s e i = hookCalled - -nextSame, nextDiff, pushLeft, pushRight, bodyE, addE, returnE, initE, failE, tryE, startTryE, tryE_, deleteE :: HookStatsM m => Eval m -> Info -> m Statement -nextSame e i = callHook "nextSame" e i >> nextSameH e i -nextDiff e i = callHook "nextDiff" e i >> nextDiffH e i -pushLeft e i = callHook "pushLeft" e i >> pushLeftH e i -pushRight e i = callHook "pushRight" e i >> pushRightH e i -bodyE e i = callHook "body" e i >> bodyH e i -addE e i = callHook "add" e i >> addH e i -returnE e i = callHook "return" e i >> returnH e i -initE e i = callHook "init" e i >> initH e i -failE e i = callHook "fail" e i >> failH e i -tryE e i = callHook "try" e i >> tryH e i -startTryE e i = callHook "startTry" e i >> startTryH e i -tryE_ e i = callHook "tryL" e i >> tryLH e i -deleteE e i = callHook "deleteH" e i >> deleteH e i - -mapE_ :: (HookStatsM m, HookStatsM n) => (forall x. Maybe Info -> m x -> n x) -> Eval m -> Eval n -mapE_ f e = - Eval { structs = structs e - , treeState_ = map (\(s,t,m) -> (s,t,\i -> f (Just i) (m i))) (treeState_ e) - , evalState_ = map (\(s,t,m) -> (s,t,\i -> f (Just i) (m i))) (evalState_ e) - , nextSameH = \i -> f (Just i) (nextSame e i) - , nextDiffH = \i -> f (Just i) (nextDiff e i) - , pushLeftH = \i -> f (Just i) (pushLeft e i) - , pushRightH = \i -> f (Just i) (pushRight e i) - , bodyH = \i -> f (Just i) (bodyE e i) - , addH = \i -> f (Just i) (addE e i) - , returnH = \i -> f (Just i) (returnE e i) - , initH = \i -> f (Just i) (initE e i) - , failH = \i -> f (Just i) (failE e i) - , tryH = \i -> f (Just i) (tryE e i) - , startTryH = \i -> f (Just i) (startTryE e i) - , tryLH = \i -> f (Just i) (tryE_ e i) - , boolArraysE = boolArraysE e - , intArraysE = intArraysE e - , intVarsE = intVarsE e - , deleteH = \i -> f (Just i) (deleteE e i) - , toString = toString e - , canBranch = f Nothing $ canBranch e - , complete = \i -> f (Just i) (complete e i) - } - --------------------------------------------------------------------------------- --- SEARCH TRANSFORMERS --------------------------------------------------------------------------------- - -#ifndef NOMEMO -buildMemoKey :: MemoM m => String -> Maybe (Eval m) -> Maybe Statement -> Info -> m MemoKey -buildMemoKey fn (Just e) _ i = do - t <- getMemo - return $ MemoKey { memoFn = fn, memoInfo = Just i , memoStack = Just (toString e), memoExtra = Just (memoRead t), memoStatement = Nothing, memoParams = map fst (stackField i) } -buildMemoKey fn Nothing (Just s) i = do - return $ MemoKey { memoFn = fn, memoInfo = Nothing, memoStack = Nothing , memoExtra = Nothing , memoStatement = Just s , memoParams = map fst (stackField i) } - -lookupMemo :: Evalable m => String -> Maybe (Eval m) -> Maybe Statement -> Info -> m (Maybe MemoValue) -lookupMemo fn e s i = - do t <- getMemo - key <- buildMemoKey fn e s i - let r = Map.lookup key $ memoMap t - case r of - Nothing -> return () - Just k -> setMemo $ t { memoMap = Map.adjust (\x -> x { memoUsed = memoUsed x + 1 }) key (memoMap t) } - return r - -insertMemo :: Evalable m => String -> Maybe (Eval m) -> Statement -> (Int -> ([(String,Type,Value)], m Statement)) -> Info -> m MemoValue -insertMemo fn e s sm i = - do t <- getMemo - fl <- getFlags - let n = memoCount t - let (lst,ss) = sm n - let ni = i { stackField = stackField i ++ (map (\(n,t,v) -> (rpx 0 fl t, n)) lst) } - key <- buildMemoKey fn e (Just s) ni - s2 <- ss - let val = MemoValue { memoId = n - , memoCode = s2 - , memoUsed = 1 - , memoFields = stackField ni - } - setMemo $ t { memoMap = Map.insert key val $ memoMap t - , memoCount = n+1 - } - return val - -invokeMemo :: Evalable m => String -> Eval m -> (Eval m -> (Info -> m Statement)) -> (Info -> m Statement) -invokeMemo fn e x i = - do let def = x e - r <- lookupMemo fn (Just e) Nothing i - val <- case r of - Nothing -> do val <- def i - case val of - Skip -> return Nothing - _ -> do num <- insertMemo fn (Just e) val (const ([],return val)) i - return $ Just num - Just val -> return $ Just val - case val of - Nothing -> return Skip - Just x -> cacheCall (fn ++ show (memoId x)) (stackField i) [] - --- cacheCall :: String -> Info -> Statement -cacheCall :: Evalable m => String -> [(String,String)] -> [Value] -> m Statement -cacheCall fn i lst = do - fl@(PrettyFlags pf) <- getFlags - return $ SHook (fn ++ "(" ++ intercalate "," (map snd (fixArgs pf) ++ (map snd i) ++ (map (rpx 0 fl) lst)) ++ ");") - -cacheStatement_ :: Evalable m => String -> (Int -> ([(String,Type,Value)], m Statement)) -> Info -> m Statement -cacheStatement_ fn sm i = - do let (olst,ss) = sm 0 - fl <- getFlags - let ni = i { stackField = stackField i ++ (map (\(n,t,v) -> (rpx 0 fl t, n)) olst) } - s <- ss - x <- lookupMemo fn Nothing (Just s) ni - val <- case x of - Nothing -> do case s of - Skip -> return Nothing - _ -> do num <- insertMemo fn Nothing s sm i - return $ Just num - Just r -> return $ Just r - case val of - Nothing -> return Skip - Just x -> do let (lst,_) = sm (memoId x) - cacheCall (fn ++ show (memoId x)) (stackField i) (map (\(n,t,v) -> v) lst) - -cacheStatement :: Evalable m => String -> Statement -> Info -> m Statement -cacheStatement fn s i = cacheStatement_ fn (const ([],return s)) i - -{- -newtype MemoWrapper m a = MemoWrapper { runMemoWrapper :: m a } - -instance MonadT MemoWrapper where - lift = MemoWrapper - treturn = MemoWrapper . return - tbind (MemoWrapper a) f = MemoWrapper (a >>= (\x -> runMemoWrapper (f x))) - -instance FMonadT MemoWrapper where - tmap' d1 _d2 g f = MemoWrapper . f . fmapD d1 g . runMemoWrapper --} - -class Memoable m where - memox :: String -> Info -> (Int -> ([(String,Type,Value)],m)) -> m - -instance Memoable m => Memoable ((Type,Value) -> m) where - memox name info f = \(typ,val) -> - case typ of - THook "void" -> memox name info (\n -> let (lst,m) = f n in (lst,m (typ,Var "WTF??"))) - _ -> memox name info (\n -> let (lst,m) = f n in (((nam n lst,typ,val):lst),m (typ,Var $ nam n lst))) - where nam n lst = "arg_" ++ name ++ "_" ++ show n ++ "_" ++ show (length lst) - -{- -instance Memoable m => Memoable (Value -> m) where - memox name info f = \val -> memox name info (\n -> let (lst,m) = f n in (((nam n lst,Pointer (THook "void"),val):lst),m (Var $ nam n lst))) - where nam n lst = "arg_" ++ name ++ "_" ++ show n ++ "_" ++ show (length lst) --} - -instance Evalable m => Memoable (m Statement) where - memox name info f = cacheStatement_ ("cached_" ++ name) f info - -memo :: Memoable m => String -> Info -> m -> m -memo name info m = memox name info (const ([],m)) --- memo name info m = m - - - -memoLoop super = - super { startTryH = invokeMemo "startTry" super startTryE - , bodyH = invokeMemo "body" super bodyE - , failH = invokeMemo "fail" super failE - , tryH = invokeMemo "try" super tryE - , addH = invokeMemo "add" super addE - , returnH = invokeMemo "ret" super returnE - , tryLH = invokeMemo "try_" super tryE_ - , initH = invokeMemo "init" super initE - , pushLeftH = invokeMemo "pushL" super pushLeft - , pushRightH = invokeMemo "pushR" super pushRight - , deleteH = invokeMemo "delete" super deleteE - , nextSameH = invokeMemo "nextSame" super nextSame - , nextDiffH = invokeMemo "nextDiff" super nextDiff - } - -cachedCommit :: Evalable m => Info -> m Statement -cachedCommit i = return (comment "begin commit") @>>>@ cacheStatement "commit" (commit i) i @>>>@ return (comment "end commit") - -cachedAbort :: Evalable m => Info -> m Statement -cachedAbort i = return (comment "begin abort") @>>>@ cacheStatement "abort" (abort i) i @>>>@ return (comment "end abort") - --- cachedClone :: MemoM m => Info -> Info -> m Statement -cachedClone i j = return (comment "begin clone") @>>>@ cacheStatement "clone" (cloneIt i j) i @>>>@ return (comment "end clone") --- cachedClone i j = return $ clone i j - -rReaderT x m = runMemoReaderT x m -#else - -cachedCommit x = return $ (comment "begin commit" >>> commit x >>> comment "end commit") -cachedAbort x = return $ (comment "begin abort" >>> abort x >>> comment "end abort") -cachedClone i j = return $ (comment "begin clone" >>> cloneIt i j >>> comment "end clone") -memo :: String -> Info -> m -> m -memo name info m = m -memoLoop = id -rReaderT = runReaderT -#endif --------------------------------------------------------------------------------- - --------------------------------------------------------------------------------- -data SeqPos = OutS | FirstS | SecondS - deriving (Show) - -seqSwitch :: ReaderM SeqPos m => m a -> m a -> m a -seqSwitch l r = - do flag <- ask - case flag of - FirstS -> l - SecondS -> r - -numSwitch n = - do flag <- ask - n flag - -(l1,l2) @++@ (l3,l4) = (l1 ++ l3, l2 ++ l4) - - -ref_count = \i -> estate i @=> "ref_count" -ref_countx = \i s -> estate i @=> ("ref_count_" ++ s) -ref_count_type = THook "int" --------------------------------------------------------------------------------- - --- cloneBase i = resetClone $ info { baseTstate = estate i @=> "parent" } -cloneBase i = i { baseTstate = estate i @=> "parent" } - - -(@>>>@) :: Evalable m => m Statement -> m Statement -> m Statement -(@>>>@) x y = do s1 <- x - s2 <- y - return (s1 >>> s2) - -f @$ x = x >>= return . f -mf @. x = mf >>= \f -> f @$ x - --------------------------------------------------------------------------------- --- PRINTING --------------------------------------------------------------------------------- - --- printTreeStateType :: Monad m => Eval m -> String -printTreeStateType e = - {- render $ pretty $-} Struct "TreeState" [ (ty,name) | (name,ty,_) <- treeState_ e ] - --- printEvalStateType :: Monad m => Eval m -> String -printEvalStateType e = - {-render $ pretty $-} Struct "EvalState" [ (ty,name) | (name,ty,_) <- evalState_ e ] - --- initEvalState :: Monad m => Info -> Eval m -> Doc -initEvalState i e = mconcat $ --- {-vcat-} [SHook ((rp 0 ty) ++ " " ++ name ++ ";") | (name,ty,_) <- evalState_ e] - [SHook "struct EvalState evalState;"] - -initTreeState_ :: Monad m => Info -> Eval m -> m Statement -initTreeState_ i e = mseqs [ init i | (_,_,init) <- treeState_ e] - - --- initIntArrays :: Eval m -> Doc -initIntArrays eval = - mconcat [ doc arr | arr <- nub $ sort $ intArraysE eval] - where doc arr - | [(_,"")] <- reads arr :: [(Int,String)] - = SHook ("vm->getSearchintVarArray(\"" ++ arr ++ "\", VAR_" ++ arr ++ ");") - | otherwise - = SHook ("vm->getintVarArray(\"" ++ arr ++ "\", VAR_" ++ arr ++ ");") - --- initBoolArrays :: Eval m -> Doc -initBoolArrays eval = - mconcat [ doc arr | arr <- nub $ sort $ boolArraysE eval] - where doc arr - | [(_,"")] <- reads arr :: [(Int,String)] - = SHook ("vm->getSearchboolVarArray(\"" ++ arr ++ "\", VAR_" ++ arr ++ ");") - | otherwise - = SHook ("vm->getboolVarArray(\"" ++ arr ++ "\", VAR_" ++ arr ++ ");") - --- declIntArrays :: Eval m -> Doc -declIntArrays eval = - mconcat [ doc arr | arr <- nub $ sort $ intArraysE eval] - where doc arr - | [(_,"")] <- reads arr :: [(Int,String)] - = SHook ("vector VAR_" ++ arr ++ ";") - | otherwise - = SHook ("vector VAR_" ++ arr ++ ";") - -declBoolArrays eval = - mconcat [ doc arr | arr <- nub $ sort $ boolArraysE eval] - where doc arr - | [(_,"")] <- reads arr :: [(Int,String)] - = SHook ("vector VAR_" ++ arr ++ ";") - | otherwise - = SHook ("vector VAR_" ++ arr ++ ";") - --- initIntVars :: Eval m -> Doc -initIntVars eval = - mconcat [ doc var | var <- nub $ sort $ intVarsE eval] - where doc var = SHook ("vm->getintVarIndex(\"" ++ var ++ "\", VAR_" ++ var ++ ");") - --- declIntVars :: Eval m -> Doc -declIntVars eval = - mconcat [ doc var | var <- nub $ sort $ intVarsE eval] - where doc var = SHook ("int VAR_" ++ var ++ ";") - -corefn :: (Evalable m, WriterM ProgramString m) => Eval m -> m Statement -corefn eval = - do fl <- getFlags - sInitE <- inite (map (\(a,_,b) -> (a,b)) (evalState_ eval)) info - sInitS <- inits eval info - sTry <- startTryE eval info - sNext <- nextSame eval info - sBody <- bodyE eval info - return $ seqs [ -- SHook $ "\n status = " ++ rpx 0 fl RootSpace ++ "->status();" - SHook "\n" - , SHook " st->queue = new std::vector();" - , sInitE - , sInitS - , sTry - , Block (SHook " while (!st->queue->empty())") $ seqs - [ SHook " /* pop first element */" - , SHook " TreeState popped_estate = st->queue->back();" - , SHook " st->queue->pop_back();" - , sNext - , SHook " st->estate = popped_estate;" - , sBody - ] - ] - -mainfn :: (Evalable m, WriterM ProgramString m) => Eval m -> m Statement -mainfn eval = - do core <- corefn eval - return $ seqs [ SHook ("\n\nvoid eval(" ++ spacetype ModeFZ ++ "* root, VarMap* vm, Printer* p) {") - , SHook "RootState rootState;" - , SHook "RootState *st = &rootState;" - , initIntVars eval - , initBoolArrays eval - , initIntArrays eval - , core - , SHook "}" - ] - -cppfn :: (Evalable m, WriterM ProgramString m) => Eval m -> m Statement -cppfn eval = - do core <- corefn eval - return $ seqs [ SHook ("\n\nvoid eval(" ++ spacetype ModeGecode ++ "* root, Printer *p) {") - , SHook "RootState rootState;" - , SHook "RootState *st = &rootState;" - , SHook (" mgr.root(*root);") - , core - , SHook "}" - ] - -mcpfn :: (Evalable m, WriterM ProgramString m) => Eval m -> m Statement -mcpfn eval = - do core <- corefn eval - return $ seqs [ SHook ("\n\nvoid eval(" ++ spacetype ModeMCP ++ "* root) {") - , SHook "RootState rootState;" - , SHook "RootState *st = &rootState;" - , core - , SHook "}" - ] - -typedecls :: Evalable m => Eval m -> m Statement -typedecls eval = - do fl <- getFlags - return $ seqs [ SHook ("struct EvalState;") - , SHook (render $ vcat $ [text "struct" <+> text name <> semi | Struct name _ <- fst $ structs eval]) - , SHook (render $ vcat $ map (prettyX fl) $ snd $ structs eval) - , SHook (rpx 1 fl $ printTreeStateType eval) - , SHook (rpx 1 fl $ printEvalStateType eval) - , SHook (render $ vcat $ map (prettyX fl) $ fst $ structs eval) - ] - -declRootState :: Eval m -> Statement -declRootState eval = seqs [ SHook "typedef struct {" - , SHook " TreeState estate;" - , SHook " std::vector *queue;" - , initEvalState info eval - , SHook "} RootState;" - ] - - -generate :: (Evalable m, WriterM ProgramString m) => Eval m -> m () -generate eval_ = - do fl <- getFlags - types <- typedecls eval - let header = seqs [ types - , declIntVars eval - , declBoolArrays eval - , declIntArrays eval - , declRootState eval - ] - main <- mainfn eval - tell $ mempty { main = Just main, header = header } - where eval = commentEval $ eval_ { treeState_ = rootEntry ++ treeState_ eval_ } - -generatemcp :: (Evalable m, WriterM ProgramString m) => Eval m -> m () -generatemcp eval_ = - do fl <- getFlags - types <- typedecls eval - let header = seqs [ types - , declRootState eval - ] - main <- mcpfn eval - tell $ mempty { main = Just main, header = header } - where eval = commentEval $ eval_ { treeState_ = rootEntry ++ treeState_ eval_ } - - -generatecpp :: (Evalable m, WriterM ProgramString m) => Eval m -> m () -generatecpp eval_ = - do fl <- getFlags - types <- typedecls eval - let header = seqs [ SHook "#include \"statemgr/varaccessor.hh\"" - , types - , declRootState eval - , SHook "StateMgr mgr;" - ] - main <- cppfn eval - tell $ mempty { main = Just main, header = header } - where eval = commentEval $ eval_ { treeState_ = rootEntry ++ treeState_ eval_ } - -rp n = render . nest n . pretty -rpx n s = render . nest n . prettyX s - --------------------------------------------------------------------------------- --- COMPOSITION COMBINATORS --------------------------------------------------------------------------------- - --- def vars = label vars lbV minV minD ($==) - -type MkEval m = Evalable m => Eval m -> State Int (Eval m) - -fixall :: Evalable m => MkEval m -> Eval m -fixall f = let this = fst $ runState 0 $ f this - in this - -data Search = forall t2. (FMonadT t2, MonadInfoT t2) => - Search { mkeval :: forall m t1. (HookStatsM m, MonadInfoT t1, FMonadT t1, Evalable m) => MkEval ((t1 :> t2) m) - , runsearch :: forall m x. (Evalable m) => t2 m x -> m x - } - -#ifndef NOMEMO -memoize :: Search -memoize = - Search { mkeval = return . memoLoop - , runsearch = runIdT - } -#endif - -{-# RULES - "L" L = unsafeCoerce - #-} -{-# RULES - "runL" runL = unsafeCoerce - #-} -{-# RULES - "unsafeCoerce/unsafeCoerce" unsafeCoerce . unsafeCoerce = unsafeCoerce - #-} -{-# RULES - "mmap/unsafeCoerce" mmap unsafeCoerce = unsafeCoerce - #-} -{-# RULES - "mapE/unsafeCoerce" mapE unsafeCoerce = unsafeCoerce - #-} - -(<@>) - :: Search -> Search -> Search -s1 <@> s2 = - case s1 of - Search { mkeval = evals1, runsearch = runs1 } -> - case s2 of - Search { mkeval = evals2, runsearch = runs2 } -> - Search {mkeval = - \super -> do { s2' <- evals2 $ mapE (L . L . mmap runL . runL) super - ; s1' <- evals1 (mapE runL s2') - ; return $ mapE (L . mmap L . runL) s1' - } - , runsearch = runs2 . runs1 . runL - } - - -data SearchCombiner = forall t1 t2. (FMonadT t1, FMonadT t2, MonadInfoT t1, MonadInfoT t2) => - SearchCombiner { runner :: forall m x. Evalable m => ((t1 :> t2) m) x -> m x - , elems :: [SearchCombinerElem t1 t2] - } - - -data SearchCombinerElem t1 t2 = - SearchCombinerElem { mapper :: forall t' m. (FMonadT t', MonadInfoT t', Evalable m) => Eval (t' ((t1 :> t2) m)) -> State Int (Eval (t' ((t1 :> t2) m))) - } - - -extractCombiners :: (Evalable m, FMonadT t', MonadInfoT t', FMonadT t1, MonadInfoT t1, FMonadT t2, MonadInfoT t2) => [SearchCombinerElem t1 t2] -> Eval (t' ((t1 :> t2) m)) -> State Int [(Eval (t' ((t1 :> t2) m)))] -extractCombiners [] _ = return [] -extractCombiners (SearchCombinerElem { mapper=m }:b) super = - do prev <- extractCombiners b super - next <- m super - return $ (next) : prev - - -buildCombiner [s] = - case s of - Search { mkeval = evals, runsearch = runs } -> - SearchCombiner { runner = runIdT . runs . runL - , elems = [SearchCombinerElem { mapper = liftM (mapE (mmap L . runL)) . evals . mapE (L . mmap runL) - }] - } -buildCombiner (s:ss) = - case s of - Search { mkeval = evals, runsearch = runs } -> - case buildCombiner ss of - SearchCombiner { runner = runner, elems = elems } -> - SearchCombiner { runner = runner . runs . runL - , elems = SearchCombinerElem { mapper = liftM (mapE (mmap L . runL)) . evals . mapE (L . mmap runL) - } : liftSearchCombinerElems elems - } - - - -liftSearchCombinerElems :: (FMonadT t1, FMonadT t0, FMonadT t2, MonadInfoT t1, MonadInfoT t0, MonadInfoT t2) => [SearchCombinerElem t1 t2] -> [SearchCombinerElem t0 (t1 :> t2)] -liftSearchCombinerElems [] = [] -liftSearchCombinerElems (s:ss) = - case s of - SearchCombinerElem { mapper = m } -> - SearchCombinerElem { mapper = liftM (mapE (mmap L . runL)) . m . mapE (L . mmap runL) - } : liftSearchCombinerElems ss - -mmap :: (FMonadT t, MonadInfoT t, Monad m, Monad n, MonadInfo m) => (forall x. m x -> n x) -> t m a -> t n a -mmap f x = tmap' mfunctor mfunctor id f x - -mfunctor :: Monad m => FunctorD m -mfunctor = FunctorD { fmapD = \f m -> m >>= return . f } - -evalSStateT m s = runSStateT m s >>= \t -> case t of { Tup2 a _ -> return a } - -data FunctionDef = FunctionDef { funName :: String, funArgs :: [(Type,String)], funBody :: Statement } - -genfun :: PrettyFlags -> FunctionDef -> String -genfun fl f = rpx 0 fl $ - Block - (SHook ("void " ++ funName f ++ "(" ++ intercalate "," [ rpx 0 fl t ++ " " ++ an | (t,an) <- funArgs f ] ++ ")")) - (funBody f) - -data ProgramString = ProgramString { header :: Statement - , functions :: [FunctionDef] - , main :: Maybe Statement - , pcomment :: [String] - } - -transformProgram fn p = p { header = inliner fn (header p), functions = map (\f -> f { funBody = inliner fn (funBody f) }) (functions p), main = maybe Nothing (Just . inliner fn) (main p) } - -instance Monoid ProgramString where - mempty = ProgramString { header = Skip, functions = [], main = Nothing, pcomment = [] } - mappend p1 p2 = ProgramString { header = header p1 >>> header p2, functions = functions p1 ++ functions p2, main = maybe (main p2) Just (main p1), pcomment = pcomment p1 ++ pcomment p2 } - -genprog :: PrettyFlags -> ProgramString -> String -genprog fl p = concatMap (\x -> "// " ++ x ++ "\n\n") (pcomment p) ++ rpx 0 fl (header p) ++ concatMap (\x -> "\n" ++ genfun fl x ++ "\n") (functions p) ++ maybe "" (rpx 0 fl) (main p) - -monadInfo :: MInfo -> (Int,Int,Int) -monadInfo (MInfo x) = - let total = sum $ map snd $ Map.toList x - identities = Map.findWithDefault 0 "Id" x + Map.findWithDefault 0 "IdT" x - zippers = Map.findWithDefault 0 ":>" x - in (total - (identities+zippers),zippers,identities) - -getgen :: (Evalable m, WriterM ProgramString m) => Eval m -> m () -getgen x = do - fl <- getFlags - case genMode fl of - ModeFZ -> generate x - ModeMCP -> generatemcp x - ModeGecode -> generatecpp x - ModeUnk -> error "Unknown generator?" - -search' :: GenMode -> Search -> ProgramString -#ifdef NOMEMO -search' fl s = - case s of - Search { mkeval = evals, runsearch = runs } -> do - let fevals = fixall $ evals - in case runId $ runGenModeT fl $ runHookStatsT $ evalSStateT Map.empty $ unVarInfoT $ runs $ runWriterT $ getgen $ mapE runL $ fevals - of (((_,eval)),n) -> let cmt = show $ monadInfo $ minfo $ canBranch $ fevals - in eval { pcomment = ["Combinator stats: " ++ cmt, "Hook calls: " ++ show n]} -#else -refType t n = - case t of - x | last x == '*' -> n - "int" -> n - "bool" -> n - _ -> '&' : n - -search' fl s = - case memoize <@> s of - Search { mkeval = evals, runsearch = runs } -> do - let fevals = fixall $ evals - in case runId $ runGenModeT fl $ runHookStatsT $ runMemoT $ evalSStateT Map.empty $ unVarInfoT $ runs $ runWriterT $ getgen $ mapE runL $ fevals - of (((_,eval),t),n) -> let {- m = inlineMap t -} - p = {- transformProgram m -} (mempty { functions = map toFun (filter (not . needInline) t) } `mappend` eval) - cmt = show $ monadInfo $ minfo $ canBranch $ fevals - in p { pcomment = ["Combinator stats: " ++ cmt, "Hook calls: " ++ show n]} - where toFun (key,val) = FunctionDef { funName = memoFn key ++ show (memoId val), funArgs = mm (map (\x -> (THook (fst x), refType (fst x) $ snd x)) (memoFields val)), funBody = simplify (memoCode val) } - mm = ((fixArgs fl) ++) - -fixArgs ModeMCP = [ -- (Pointer (THook "Gecode::SpaceStatus"), "status") - (Pointer (THook "RootState"), "st") - ] -fixArgs _ = [ -- (Pointer (THook "Gecode::SpaceStatus"), "status") - (Pointer (THook "RootState"), "st"), - (Pointer (THook "Printer"),"p") - ] - -needInline (key,val) = False {- (memoUsed val <= 1) -} -{-needInline (key,val) = - let code = simplify $ memoCode val - res = (memoUsed val <= 1) || (case code of { Seq _ _ -> False; Block _ _ -> False; Skip -> True; _ -> True }) - in trace ("needInline? " ++ show code ++ " -> " ++ show res ++ "\n") res --} --- needInline _ = False - -inlineMap fl fns = do - lst <- mapM (\(key,val) -> cacheCall (memoFn key ++ show (memoId val)) (memoFields val) [] >>= \c -> return (c, memoCode val)) [ x | x <- fns, needInline x ] - return $ Map.fromList lst - -#endif - - -search :: Search -> String -search s = genprog (PrettyFlags ModeMCP) (search' ModeMCP s) diff --git a/Control/Search/GeneratorInfo.hs b/Control/Search/GeneratorInfo.hs deleted file mode 100644 --- a/Control/Search/GeneratorInfo.hs +++ /dev/null @@ -1,120 +0,0 @@ -module Control.Search.GeneratorInfo where - -import Control.Search.Language - -type TreeState = Value -type EvalState = Value -space i = baseTstate i @-> "space" - -data Info = Info { baseTstate :: TreeState - , path :: TreeState -> TreeState - , abort_ :: [Statement -> Statement] - , commit_ :: [Statement -> Statement] - , old :: Info - , clone :: Info -> Statement - , field :: String -> Value - , stackField :: [(String,String)] - , treeStateType :: Type - , evalStateType :: Type - } - -(@@) :: Ordering -> Ordering -> Ordering -EQ @@ x = x -x @@ _ = x - -instance Ord Info where - compare a b = compare (baseTstate a) (baseTstate b) - @@ compare (path a $ baseTstate a) (path b $ baseTstate b) - @@ compare (map ($ Skip) $ abort_ a) (map ($ Skip) $ abort_ b) - @@ compare (map ($ Skip) $ commit_ a) (map ($ Skip) $ commit_ b) - @@ compare (clone a (resetClone a)) (clone b (resetClone b)) - -instance Eq Info where - a == b = case compare a b of { EQ -> True; _ -> False } - -type Field = String - -tstate i = path i (baseTstate i) -tstate_type i = treeStateType i - --- VHook ("/* " ++ show (estate_type i) ++ " */ null") -estate i = case estate_type i of - Pointer (SType (Struct "EvalState" _)) -> Ref (Var $ "st->evalState") - Pointer (THook "EvalState") -> Ref (Var "st->evalState") - _ -> (tstate i) @-> "evalState" - -estate_type i = evalStateType i - -withCommit i f = i { commit_ = f : commit_ i } -onAbort i stmt = i { abort_ = (stmt >>>) : abort_ i } -onCommit i stmt = i `withCommit` (stmt >>>) -onCommit' i stmt = i `withCommit` (>>> stmt) -withPath i p e t = i { path = p . path i - , old = withPath (old i) p e t - , evalStateType = e - , treeStateType = t - } -withBase i str = i { baseTstate = Var str, stackField = ("TreeState",str):(stackField i) } - -withClone i stmt = i { clone = \j -> clone i j >>> stmt (i { baseTstate = baseTstate j }) } -withField i (f,g) = i { field = \f' -> if f' == f then g i else field i f' } - -resetPath i = i { path = id - , old = resetPath $ old i - , treeStateType = Pointer (THook "TreeState") - , evalStateType = Pointer (THook "EvalState") - } -resetCommit i = i { commit_ = [const $ comment "Delete-resetCommit" >>> (Delete $ space i)] } -shiftCommit i = i { commit_ = tail $ commit_ i } -resetAbort i = i { abort_ = [const $ comment "Delete-resetAbort" >>> (Delete $ space i)] } -shiftAbort i = i { abort_ = tail $ abort_ i } -resetClone i = i { clone = const Skip } - -resetInfo i = i { path = id - , old = resetInfo $ old i - , commit_ = [ const $ comment "Delete-resetInfo-commit_" >>> (Delete $ space i) ] - , abort_ = [ const $ comment "Delete-resetInfo-abort_" >>> (Delete $ space i), const (comment "reset")] - , clone = const Skip - , treeStateType = Pointer (THook "TreeState") - , evalStateType = Pointer (THook "EvalState") - } - -mkInfo name = - let i = Info { baseTstate = Var name - , path = id - , abort_ = [const $ comment "Delete-mkInfo-abort_" >>> (Delete $ space i)] - , commit_ = [const $ comment "Delete-mkInfo-commit_" >>> (Delete $ space i)] - , old = i - , clone = const Skip - , field = \f -> error ("unknown field `" ++ f ++ "'") - , stackField = [] - , treeStateType = Pointer (THook "TreeState") - , evalStateType = Pointer (THook "EvalState") - } - in i - -info = mkInfo "st->estate" - -newinfo i n = - Info { baseTstate = Var $ "nstate" ++ n - , path = id - , abort_ = [const Skip] - , commit_ = [const Skip] - , old = resetPath i - , clone = const Skip - , field = \f -> error ("unknown field `" ++ f ++ "'") - , stackField = [("TreeState","nstate" ++ n)] - , treeStateType = Pointer (THook "TreeState") - , evalStateType = Pointer (THook "EvalState") - } - -commit i = go $ commit_ i - where go [] = Skip - go (f:fs) = f (go fs) -abort i = go $ abort_ i - where go [] = Skip - go (f:fs) = f (go fs) - -primClone i = \j -> space j <== Clone (space i) - -cloneIt i j = primClone i j >>> clone i j diff --git a/Control/Search/Language.hs b/Control/Search/Language.hs deleted file mode 100644 --- a/Control/Search/Language.hs +++ /dev/null @@ -1,531 +0,0 @@ -{-# LANGUAGE FlexibleInstances #-} - -module Control.Search.Language where - -import Text.PrettyPrint -import Data.Monoid hiding ((<>)) -import Data.Int -import qualified Data.Map as Map -import Data.Map (Map) - - -spacetype ModeFZ = "FlatZincSpace" -spacetype ModeGecode = "State" -spacetype ModeMCP = "MCPProgram" - -xsspace fl@(PrettyFlags ModeFZ) x str = prettyX fl (PField x str) -xsspace fl@(PrettyFlags ModeMCP) x str = prettyX fl (PField x str) -xsspace fl@(PrettyFlags ModeGecode) x str = text "((VarAccessorSpace*)msg.space(" <> prettyX fl x <> text "))->" <> text str - -instance Monoid Statement where - mempty = Skip - mappend = (>>>) - -data GenMode = ModeUnk | ModeGecode | ModeFZ | ModeMCP - deriving Eq - -data PrettyFlags = PrettyFlags { genMode :: GenMode } - deriving Eq - -renderVar :: PrettyFlags -> Value -> Doc -renderVar f@(PrettyFlags { genMode = ModeFZ }) x = case x of - (AVarElem vs s i) -> xsspace f s "iv" <> brackets (text "VAR_" <> text vs <> brackets (pr_ i)) - (AVarSize vs s) -> text "VAR_" <> text vs <> text ".size()" - (BAVarElem vs s i) -> xsspace f s "bv" <> brackets (text "VAR_" <> text vs <> brackets (pr_ i)) - (BAVarSize vs s) -> text "VAR_" <> text vs <> text ".size()" - (IVar vs s) -> xsspace f s "iv" <> brackets (text "VAR_" <> text vs) - where pr_ :: Value -> Doc - pr_ = prettyX f -renderVar f@(PrettyFlags { genMode = ModeGecode }) x = case x of - (AVarElem vs s i) -> xsspace f s "va.iv" <> parens (text "idx" <> parens (xsspace f s "va.map()" <> text ",\"" <> text vs <> text "\"") <> text "+" <> pr_ i) - (AVarSize vs s) -> text "size" <> parens (xsspace f s "va.map()" <> text ",\"" <> text vs <> text "\"") - (BAVarElem vs s i) -> xsspace f s "va.bv" <> parens (text "idx" <> parens (xsspace f s "va.map()" <> text ",\"" <> text vs <> text "\"") <> text "+" <> pr_ i) - (BAVarSize vs s) -> text "size" <> parens (xsspace f s "va.map()" <> text ",\"" <> text vs <> text "\"") - (IVar vs s) -> xsspace f s "va.iv" <> parens (text "idx" <> parens (xsspace f s "va.map()" <> text ",\"" <> text vs <> text "\"")) - where pr_ :: Value -> Doc - pr_ = prettyX f -renderVar f@(PrettyFlags { genMode = ModeMCP }) x = case x of - (AVarElem vs s i) -> xsspace f s vs <> brackets (pretty i) - (AVarSize vs s) -> xsspace f s vs <> text ".size()" - (BAVarElem vs s i) -> xsspace f s vs <> brackets (pretty i) - (BAVarSize vs s) -> xsspace f s vs <> text ".size()" - (IVar vs s) -> xsspace f s vs - -renderVar f@(PrettyFlags { genMode = ModeUnk }) _ = error "Cannot generate variable without render mode!" - - -class Pretty x where - prettyX :: PrettyFlags -> x -> Doc - pretty :: x -> Doc - prettyX _ = pretty - pretty = prettyX (PrettyFlags { genMode = ModeUnk }) - -data Struct = Struct String [(Type,String)] deriving (Show, Eq, Ord) - -instance Pretty Struct where - prettyX x (Struct name fields) = - text "struct" <+> text name <+> text "{" - $+$ nest 2 (vcat [prettyX x ty <+> text f <> text ";" | (ty,f) <- fields]) - $+$ text "};" - - -data Type = Pointer Type - | SpaceType - | Int - | Bool - | Union [(Type,String)] - | SType Struct - | THook String - deriving (Show, Eq, Ord) - -data Value = IVal Int32 - | BVal Bool - | RootSpace - | Minus Value Value - | Plus Value Value - | Mult Value Value - | Div Value Value - | Mod Value Value - | Abs Value - | Var String - | Ref Value - | Deref Value - | Clone Value - | Field String String - | Field' Value String - | PField Value String - | Lt Value Value - | Gq Value Value - | Gt Value Value - | Eq Value Value - | BaseContinue - | And Value Value - | Or Value Value - | Not Value - | VHook String - | Max Value Value - | AVarElem String Value Value - | AVarSize String Value - | BAVarElem String Value Value - | BAVarSize String Value - | IVar String Value - | MinDom Value - | MaxDom Value - | Degree Value - | WDegree Value - | UbRegret Value - | LbRegret Value - | Median Value - | Random - | Null - | New Struct - | Base - | Cond Value Value Value - | Assigned Value - | Dummy Int - | MaxVal - | MinVal - deriving (Show, Eq, Ord) - -instance Num Value where - (-) = Minus - fromInteger = IVal . fromInteger - (+) = Plus - (*) = Mult - abs = Abs - signum = error "signum is not defined for Value" - -divValue (IVal x) (IVal y) = IVal (x `div` y) -divValue x y = Div x y - -true = BVal True -false = BVal False -(&&&) = And -(|||) = Or -(@>) = Gt -(@>=) = Gq -x @<= y = y `Gq` x -(@==) = Eq -(@->) = Field' -(@=>) = PField -(@<) = Lt -lex cmps l1 l2 = foldr (\(x,y,cmp) r -> (x `cmp` y) ||| ((x @== y) &&& r)) false (zip3 l1 l2 cmps) - -simplValue :: Value -> Value -simplValue (Cond c t e) = - let c' = simplValue c - t' = simplValue t - e' = simplValue e - in case (c',t',e') of - (BVal True, _, _) -> t' - (BVal False, _, _) -> e' - _ | t' == e' -> t' - _ -> Cond c' t' e' -simplValue (Minus (IVal x) (IVal y)) = IVal (x - y) -simplValue (Lt x y) = Lt (simplValue x) (simplValue y) -simplValue (Gq x y) = Gq (simplValue x) (simplValue y) -simplValue (And x y) = - let x' = simplValue x - y' = simplValue y - in case (x',y') of - (x, (BVal True)) -> x - (x, (BVal False)) -> BVal False - _ -> And x' y' -simplValue (Not x) = - let x' = simplValue x - in case x' of - (BVal True) -> BVal False - (BVal False) -> BVal True - _ -> Not x' -simplValue (PField (Ref x) f) = Field' (simplValue x) f -simplValue v = v - -instance Pretty Type where - prettyX x (Pointer t) = prettyX x t <> text "*" - prettyX x SpaceType = text $ spacetype (genMode x) - prettyX x Int = text "int" - prettyX x Bool = text "bool" - prettyX x (Union fields) = - text "union" <+> text "{" - $+$ nest 2 (vcat [prettyX x ty <+> text f <> text ";" | (ty,f) <- fields]) - $+$ text "}" - prettyX x (SType (Struct name fields)) = - text name - prettyX x (THook str) = - text str - -instance Pretty Value where - prettyX x = prettyX_ x . simplValue - where - prettyX_ :: PrettyFlags -> Value -> Doc - prettyX_ _ (Cond c t e) = pr_ c <+> text "?" <+> pr_ t <+> text ":" <+> pr_ e - prettyX_ _ Base = text "" - prettyX_ _ Null = text "NULL" - prettyX_ _ (IVal i) = int $ fromInteger $ toInteger i - prettyX_ _ (BVal True) = text "true" - prettyX_ _ (BVal False) = text "false" - prettyX_ _ (Abs x) = text "abs" <> parens (pr_ x) - prettyX_ fl RootSpace = case (genMode fl) of - ModeFZ -> text "root" - ModeGecode -> text "mgr.root()" - ModeMCP -> text "root" - prettyX_ _ (Minus v1 v2) = pr_ v1 <+> text "-" <+> pr_ v2 - prettyX_ _ (Plus v1 v2) = pr_ v1 <+> text "+" <+> pr_ v2 - prettyX_ _ (Mult v1 v2) = pr_ v1 <+> text "*" <+> pr_ v2 - prettyX_ _ (Div v1 v2) = parens (pr_ v1) <+> text "/" <+> parens (pr_ v2) - prettyX_ _ (Mod v1 v2) = parens (pr_ v1) <+> text "%" <+> parens (pr_ v2) - prettyX_ _ (Ref x) = parens $ text "&" <> parens (pr_ x) - prettyX_ _ (Deref x) = parens $ text "*" <> parens (pr_ x) - prettyX_ _ (Var x) = text x - prettyX_ f (Clone x) = text ("static_cast<" ++ spacetype (genMode f) ++ "*>(") <> pr_ x <> text "->clone(true))" - -- prettyX_ (Clone x) = text ("static_cast<" ++ spacetype ++ "*>(") <> pretty_ x <> text "->clone(false))" - prettyX_ _ (Field r f) = text r <> text "." <> text f - prettyX_ _ (Field' r f) = pr_ r <> text "." <> text f --- prettyX_ (PField (Field' (Var "estate") "evalState") f) = text f --- prettyX_ (PField (Field' (Var "nstate") "evalState") f) = text f --- prettyX_ (PField (Field' (Var _) "evalState") f) = text f - prettyX_ _ (PField r f) = pr_ r <> text "->" <> text f - prettyX_ _ (Lt x y) = parens (pr_ x) <+> text "<" <+> parens (pr_ y) - prettyX_ _ (Gq x y) = parens (pr_ x) <+> text ">=" <+> parens (pr_ y) - prettyX_ _ (Gt x y) = parens (pr_ x) <+> text ">" <+> parens (pr_ y) - prettyX_ _ (Eq x y) = parens (pr_ x) <+> text "==" <+> parens (pr_ y) - prettyX_ _ BaseContinue = text "!st->queue->empty()" - prettyX_ _ (And x y) = parens (pr_ x) <+> text "&&" <+> parens (pr_ y) - prettyX_ _ (Or x y) = parens (pr_ x) <+> text "||" <+> parens (pr_ y) - prettyX_ _ (Not x) = text "!" <> parens (pr_ x) - prettyX_ _ (VHook s) = text s - prettyX_ _ (Max x y) = text "max" <> parens (pr_ x <> text "," <> pr_ y) - prettyX_ e v@(AVarElem _ _ _) = renderVar e v - prettyX_ e v@(AVarSize _ _) = renderVar e v - prettyX_ e v@(BAVarElem _ _ _) = renderVar e v - prettyX_ e v@(BAVarSize _ _) = renderVar e v - prettyX_ e v@(IVar _ _) = renderVar e v - prettyX_ _ (MinDom v) = pr_ v <> text ".min()" - prettyX_ _ (MaxDom v) = pr_ v <> text ".max()" - prettyX_ _ (Degree v) = pr_ v <> text ".degree()" - prettyX_ _ (WDegree v) = pr_ v <> text ".afc()" -- aka accumulated failure count - prettyX_ _ (UbRegret v) = pr_ v <> text ".regret_max()" - prettyX_ _ (LbRegret v) = pr_ v <> text ".regret_min()" - prettyX_ _ (Median v) = pr_ v <> text ".med()" - prettyX_ _ MaxVal = text "Gecode::Int::Limits::max" - prettyX_ _ MinVal = text "Gecode::Int::Limits::min" - prettyX_ _ Random = text "rand()" - prettyX_ _ (New (Struct name _)) = text "new" <+> text name - prettyX_ _ (Assigned var) = pr_ var <> text ".assigned()" - pr :: Value -> Doc - pr = prettyX x - pr_ :: Value -> Doc - pr_ = prettyX_ x - -data Constraint = EqC Value Value - | NqC Value Value - | LtC Value Value - | LqC Value Value - | GtC Value Value - | GqC Value Value - | TrueC - | FalseC - deriving (Eq, Ord, Show) - -($==) = EqC -($/=) = NqC -($<) = LtC -($<=) = LqC -($>) = GtC -($>=) = GqC - -neg (EqC x y) = NqC x y -neg (NqC x y) = EqC x y -neg (LtC x y) = GqC x y -neg (LqC x y) = GtC x y -neg (GtC x y) = LqC x y -neg (GqC x y) = LtC x y - -instance Pretty Constraint where - prettyX f (EqC x y) = - prettyX f x <> text "," <> text "IRT_EQ" <> text "," <> prettyX f y - prettyX f (NqC x y) = - prettyX f x <> text "," <> text "IRT_NQ" <> text "," <> prettyX f y - prettyX f (LtC x y) = - prettyX f x <> text "," <> text "IRT_LE" <> text "," <> prettyX f y - prettyX f (LqC x y) = - prettyX f x <> text "," <> text "IRT_LQ" <> text "," <> prettyX f y - prettyX f (GtC x y) = - prettyX f x <> text "," <> text "IRT_GR" <> text "," <> prettyX f y - prettyX f (GqC x y) = - prettyX f x <> text "," <> text "IRT_GQ" <> text "," <> prettyX f y - prettyX f TrueC = error "true constraint can't be posted directly" - prettyX f FalseC = error "false constraint can't be posted directly" - - -data Statement = IfThenElse Value Statement Statement - | Push Value - | Skip - | Seq Statement Statement - | Assign Value Value - | Abort - | Print Value [String] - | SHook String - | Post Value Constraint - | Fold String Value Value Value (Value -> Value) (Value -> Value -> Value) - | IFold String Value Value Value (Value -> Value) (Value -> Value -> Value) - | BFold String Value Value Value (Value -> Value) (Value -> Value -> Value) - | BIFold String Value Value Value (Value -> Value) (Value -> Value -> Value) --- | MFold String [(Value, Value->Value)] ([Value] -> [Value] -> Value) - | Delete Value - | Block Statement Statement - | DebugOutput String - | DebugValue String Value - deriving (Eq,Ord,Show) - -inliner :: (Statement -> Maybe Statement) -> Statement -> Statement -inliner f s = - case f s of - Just x -> inliner f x - Nothing -> case s of - IfThenElse v s1 s2 -> IfThenElse v (inliner f s1) (inliner f s2) - Seq s1 s2 -> Seq (inliner f s1) (inliner f s2) - Block s1 s2 -> Block s1 (inliner f s2) - _ -> s - -instance Ord (Value -> Value) where - compare a b = compare (a (Dummy 0)) (b (Dummy 0)) - -instance Eq (Value -> Value) where - a == b = (a (Dummy 1)) == (b (Dummy 1)) - -instance Show (Value -> Value) where - show a = show (a (Dummy 1)) - -instance Ord (Value -> Value -> Value) where - compare a b = compare (a (Dummy 2) (Dummy 3)) (b (Dummy 2) (Dummy 3)) - -instance Eq (Value -> Value -> Value) where - a == b = (a (Dummy 4) (Dummy 5)) == (b (Dummy 4) (Dummy 5)) - -instance Show (Value -> Value -> Value) where - show a = show (a (Dummy 1) (Dummy 2)) - -comment str = SHook ("// " ++ str) - -dec var = Assign var (var - 1) -inc var = Assign var (var + 1) -(>>>) = Seq -(<==) = Assign -assign = flip Assign -ifthen c t = IfThenElse c t Skip -seqs = foldr (>>>) Skip - -simplStmt :: Statement -> Statement -simplStmt (IfThenElse c t e) - = let c' = simplValue c - t' = simplStmt t - e' = simplStmt e - in go c' t' e' - where go (BVal True) t e = t - go (BVal False) t e = e - go c t e | t == e = t - go c Skip e = simplStmt $ IfThenElse (Not c) e t - go c1 (IfThenElse c2 t2 e2) e1 - | e1 == e2 = simplStmt $ IfThenElse (c1 &&& c2) t2 e1 - go c t e = IfThenElse c t e -simplStmt (Assign x y) | x==y = Skip -simplStmt (Seq Skip a) = simplStmt a -simplStmt (Seq a Skip) = simplStmt a -simplStmt s = s - -instance Pretty Statement where - prettyX x = prettyX_ . simplStmt - where - prettyX_ (Push tstate) = - text "st->queue->push_back" <> parens (pr tstate) <> text ";" - prettyX_ (IfThenElse c t Skip) = text "if" <+> parens (pr c) <+> text "{" $+$ nest 2 (pr t) $+$ text "}" - prettyX_ (IfThenElse c t e) = text "if" <+> parens (pr c) <+> text "{" $+$ nest 2 (pr t) $+$ text "} else {" $+$ nest 2 (pr_ e) $+$ text "}" - prettyX_ Skip = - empty - prettyX_ (Assign var (Minus val 1)) - | var == val - = pr var <> text "--;" - prettyX_ (Assign var (Plus val 1)) - | var == val - = pr var <> text "++;" - prettyX_ (Block s1 s2) = pr s1 <+> text "{" $+$ nest 2 (pr s2) $+$ text "}" - prettyX_ (Seq s1 s2) = - pr s1 $+$ pr s2 - prettyX_ (Assign x Null) = pr x <> text ";" - prettyX_ (Assign x y) = let y' = simplValue y - in if x == y' - then pr Skip - else pr x <+> text "=" <+> pr y' <> text ";" - prettyX_ Abort = - text "break;" - prettyX_ (Print space vs) = - (vcat $ map (\s -> text "std::cout << \"[\"; for (int i=0; i<" <> pr (AVarSize s space) <> text "; i++) { std::cout << " <> pr (AVarElem s space (Var "i")) <> text " << \" \"; }; std::cout << \"] \";") vs) <> text "std::cout << std::endl;" - prettyX_ (DebugOutput str) = - text "cout << " <> text (show str) <> text " << endl;" - prettyX_ (DebugValue str val) = - text "cout << " <> text (show $ str ++ ": ") <> text " << " <> pr val <> text " << endl;" - prettyX_ (SHook s) = - text s - prettyX_ (Post space FalseC) = pr space <> text "->fail();" - prettyX_ (Post space TrueC) = empty - prettyX_ (Post space c) = - text "rel(*" <> parens (pr space) <> text "," <> pr c <> text ");" - prettyX_ (Fold vars state space m0 metric better) = - let - pos = Field' state "pos" - size = AVarSize vars space - in - text "int best_pos = -1;" - $+$ pr (Assign pos 0) - $+$ text "for (int metric = " <> pr m0 <> text "; " <> pr (pos @< size ) <> text "; " <> pr pos <> text "++) {" - $+$ nest 2 (text "if" <+> parens (text "!" <> pr (AVarElem vars space pos) <> text ".assigned()") <+> text "{" - $+$ nest 2 ( text "int current_metric = " <> pr (metric (AVarElem vars space pos)) <> text ";" - $+$ pr (IfThenElse (Var "current_metric" `better` Var "metric") - (Assign (Var "metric") (Var "current_metric") >>> (Assign (Var "best_pos") pos)) - Skip - ) - ) - $+$ text "}" - ) - $+$ text "}" - $+$ pr (Assign pos (Var "best_pos")) - prettyX_ (IFold vars state space m0 metric better) = - let - pos = Field' state "pos" - size = AVarSize vars state - in - text "int best_pos = -1;" - $+$ pr (Assign pos 0) - $+$ text "for (int metric = " <> pr m0 <> text "; " <> pr (pos @< size ) <> text "; " <> pr pos <> text "++) {" - $+$ nest 2 (text "if" <+> parens (text "!" <> pr (AVarElem vars space pos) <> text ".assigned()") <+> text "{" - $+$ nest 2 ( text "int current_metric = " <> pr (metric pos) <> text ";" - $+$ pr (IfThenElse (Var "current_metric" `better` Var "metric") - (Assign (Var "metric") (Var "current_metric") >>> (Assign (Var "best_pos") pos)) - Skip - ) - ) - $+$ text "}" - ) - $+$ text "}" - $+$ pr (Assign pos (Var "best_pos")) - prettyX_ (BFold vars state space m0 metric better) = - let - pos = Field' state "pos" - size = BAVarSize vars space - in - text "int best_pos = -1;" - $+$ pr (Assign pos 0) - $+$ text "for (int metric = " <> pr m0 <> text "; " <> pr (pos @< size ) <> text "; " <> pr pos <> text "++) {" - $+$ nest 2 (text "if" <+> parens (text "!" <> pr (BAVarElem vars space pos) <> text ".assigned()") <+> text "{" - $+$ nest 2 ( text "int current_metric = " <> pr (metric (BAVarElem vars space pos)) <> text ";" - $+$ pr (IfThenElse (Var "current_metric" `better` Var "metric") - (Assign (Var "metric") (Var "current_metric") >>> (Assign (Var "best_pos") pos)) - Skip - ) - ) - $+$ text "}" - ) - $+$ text "}" - $+$ pr (Assign pos (Var "best_pos")) - prettyX_ (BIFold vars state space m0 metric better) = - let - pos = Field' state "pos" - size = BAVarSize vars space - in - text "int best_pos = -1;" - $+$ pr (Assign pos 0) - $+$ text "for (int metric = " <> pr m0 <> text "; " <> pr (pos @< size ) <> text "; " <> pr pos <> text "++) {" - $+$ nest 2 (text "if" <+> parens (text "!" <> pr (BAVarElem vars space pos) <> text ".assigned()") <+> text "{" - $+$ nest 2 ( text "int current_metric = " <> pr (metric pos) <> text ";" - $+$ pr (IfThenElse (Var "current_metric" `better` Var "metric") - (Assign (Var "metric") (Var "current_metric") >>> (Assign (Var "best_pos") pos)) - Skip - ) - ) - $+$ text "}" - ) - $+$ text "}" - $+$ pr (Assign pos (Var "best_pos")) -{- prettyX_ (MFold state metrics better) = - let - space = Field "estate" "space" - pos = Field state "pos" - cvar = CVar "get" space pos - size = VHook $ render $ pr space <> text "->" <> text "get" <> text "().size()" - acc_vars = [Var $ "metric" ++ show i | i <- [1..length metrics]] - cur_vars = [Var $ "current_metric" ++ show i | i <- [1..length metrics]] - init_list = hcat $ punctuate comma [pr v <+> text "=" <+> pretty z | (v,(z,_)) <- zip acc_vars metrics] - computations = vcat $ [text "int" <+> pr (Update var (f cvar))| (var,(_,f)) <- zip cur_vars metrics] - updates = foldl (>>>) Skip [Update v1 v2 | (v1,v2) <- zip acc_vars cur_vars] - in - text "int best_pos = -1;" - $+$ pr (Update pos 0) - $+$ text "for (int " <> init_list <> text "; " <> pr (pos @< size ) <> text "; " <> pr pos <> text "++) {" - $+$ nest 2 (text "if" <+> parens (text "!" <> pr cvar <> text ".assigned()") <+> text "{" - $+$ nest 2 ( computations - $+$ pr (IfThenElse (cur_vars `better` acc_vars) - (updates >>> (Update (Var "best_pos") pos)) - Skip - ) - ) - $+$ text "}" - ) - $+$ text "}" - $+$ pr (Update pos (Var "best_pos")) -} - prettyX_ (Delete value) = - text "delete" <+> pr value <> text ";" - pr :: Pretty x => x -> Doc - pr = prettyX x - pr_ :: Statement -> Doc - pr_ = prettyX_ - - -class Simplifiable a where - simplify :: a -> a - -instance Simplifiable Statement where - simplify = simplStmt - -instance Simplifiable Value where - simplify = simplValue diff --git a/Control/Search/Memo.hs b/Control/Search/Memo.hs deleted file mode 100644 --- a/Control/Search/Memo.hs +++ /dev/null @@ -1,67 +0,0 @@ -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE GeneralizedNewtypeDeriving #-} -{-# LANGUAGE OverlappingInstances #-} - - -module Control.Search.Memo where - -import Control.Monatron.Monatron hiding (Abort, L, state, cont) -import Control.Monatron.Zipper hiding (i,r) -import Control.Monatron.IdT -import Control.Monatron.MonadInfo - -import Data.List (sort, nub, sortBy) -import Data.Maybe (fromJust) -import Data.Map (Map) -import qualified Data.Map as Map - -import Control.Search.Language -import Control.Search.GeneratorInfo -import Control.Search.SStateT - -data MemoKey = MemoKey { memoFn :: String, memoInfo :: Maybe Info, memoStack :: Maybe String, memoExtra :: Maybe (Map Int String), memoStatement :: Maybe Statement, memoParams :: [String] } - deriving (Eq, Ord) - -data MemoValue = MemoValue { memoId :: Int, memoCode :: Statement, memoUsed :: Int, memoFields :: [(String,String)] } - -data MemoInfo = MemoInfo { memoMap :: Map MemoKey MemoValue - , memoCount :: Int - , memoRead :: Map Int String - } - -initMemoInfo = MemoInfo { memoMap = Map.empty - , memoCount = 0 - , memoRead = Map.empty - } - -newtype MemoT m a = MemoT { unMemoT :: SStateT MemoInfo m a } - deriving (MonadT,StateM MemoInfo,FMonadT) - -instance MonadInfoT MemoT where - tminfo x = miInc "MemoT" (minfo $ runMemoT x) - --- runMemoT :: Monad m => MemoT m a -> m (a,[(String,Statement,[(String,String)])]) -runMemoT m = do (Tup2 a s) <- runSStateT initMemoInfo (unMemoT m) - return (a, {- map (\(key,val) -> ( memoFn key ++ show (memoId val) - , comment (" fn=" ++ memoFn key ++ " stack='" ++ show (memoStack key) ++ "' extra='" ++ show (memoExtra key) ++ "' used: " ++ show (memoUsed val)) >>> memoCode val - , memoFields key - ) - ) $ -} sortBy (\(ka,va) (kb,vb) -> compare (memoId va) (memoId vb)) $ Map.toList (memoMap s) - ) - --- runReaderMemoT :: (ReaderM r m, ReaderMemoM r (MemoT m)) => MemoT m a -> m (a,[(String,Statement,Info)]) --- runReaderMemoT m = do val <- ask --- runMemoT (memoLocal (const val) m) - -class Monad m => MemoM m where - getMemo :: m MemoInfo - setMemo :: MemoInfo -> m () - -instance Monad m => MemoM (MemoT m) where - getMemo = MemoT $ get - setMemo = MemoT . put - -instance (MemoM m, FMonadT t) => MemoM (t m) where - getMemo = lift $ getMemo - setMemo = lift . setMemo - diff --git a/Control/Search/MemoReader.hs b/Control/Search/MemoReader.hs deleted file mode 100644 --- a/Control/Search/MemoReader.hs +++ /dev/null @@ -1,61 +0,0 @@ -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE GADTs #-} -{-# LANGUAGE GeneralizedNewtypeDeriving #-} - -module Control.Search.MemoReader where - -import Control.Search.Memo - -import Data.Map (Map) -import qualified Data.Map as Map - -import Control.Monatron.Monatron hiding (Abort, L, state, cont) -import Control.Monatron.Zipper hiding (i,r) -import Control.Monatron.MonadInfo -import Control.Monatron.IdT - -newtype MemoReaderT r m a = MemoReaderT { unMemoReaderT :: Int -> ReaderT r m a } - -instance MonadT (MemoReaderT r) where - lift m = MemoReaderT $ const $ lift m - tbind (MemoReaderT i) f = MemoReaderT (\n -> i n `tbind` (\r -> unMemoReaderT (f r) n)) - -instance MonadInfoT (MemoReaderT r) where - tminfo x = miInc "MemoReaderT" (minfo $ runReaderT undefined (unMemoReaderT x 0)) - -instance FMonadT (MemoReaderT s) where - tmap' d1 d2 g f (MemoReaderT m) = MemoReaderT (tmap' d1 d2 g f . m) - -memoReaderT :: MemoM m => (e -> Int -> m a) -> MemoReaderT e m a -memoReaderT f = MemoReaderT (\n -> readerT (\e -> f e n)) - -deMemoReaderT :: MemoM m => e -> Int -> MemoReaderT e m a -> m a -deMemoReaderT e i (MemoReaderT f) = runReaderT e (f i) - -runMemoReaderT :: (MemoM m, Show s) => s -> MemoReaderT s m a -> m a -runMemoReaderT s r = - do x1 <- getMemo - let l = Map.size (memoRead x1) - setMemo x1 { memoRead = Map.insert l (show s) $ memoRead x1 } - r <- deMemoReaderT s l r - x2 <- getMemo - setMemo x2 { memoRead = Map.delete l $ memoRead x2 } - return r - -modelMemoReaderT :: (Show s, MemoM m) => Model (ReaderOp s) (MemoReaderT s m) -modelMemoReaderT (Ask g) = memoReaderT (\s n -> deMemoReaderT s n (g s)) -modelMemoReaderT (InEnv s a) = memoReaderT (\_ n -> deMemoReaderT s n (do { m1 <- getMemo - ; let oldVal = memoRead m1 Map.! n - ; setMemo m1 { memoRead = Map.insert n (show s) (memoRead m1) } - ; x <- a - ; m2 <- getMemo - ; setMemo m2 { memoRead = Map.insert n oldVal (memoRead m2) } - ; return x - } - ) - ) - -instance (MemoM m, Show s) => ReaderM s (MemoReaderT s m) where - readerModel = modelMemoReaderT - diff --git a/Control/Search/SStateT.hs b/Control/Search/SStateT.hs deleted file mode 100644 --- a/Control/Search/SStateT.hs +++ /dev/null @@ -1,47 +0,0 @@ -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE MultiParamTypeClasses #-} - -module Control.Search.SStateT ( - SStateT, sstateT, runSStateT, - Tup2(..), snd2, fst2 -) where - -import Control.Monad.Fix -import Control.Monatron.MonadT -import Control.Monatron.AutoInstances () -import Control.Monatron.Operations -import Control.Monatron.AutoLift - -data Tup2 a b = Tup2 a !b - -fst2 (Tup2 a _) = a -snd2 (Tup2 _ b) = b - -newtype SStateT s m a = SS { unSS :: s -> m (Tup2 a s) } - -sstateT :: (s -> m (Tup2 a s)) -> SStateT s m a -sstateT = SS - -runSStateT :: s -> SStateT s m a -> m (Tup2 a s) -runSStateT s m = unSS m s - -instance MonadT (SStateT s) where - lift m = SS $ \s -> m >>= \a -> return (Tup2 a s) - m `tbind` k = SS $ \s -> unSS m s >>= \ ~(Tup2 a s') -> unSS (k a) s' - -instance (MonadFix m) => MonadFix (SStateT s m) where - mfix f = SS $ \s -> mfix (runSStateT s . f . fst2) - -instance FMonadT (SStateT s) where - tmap' d1 _d2 g f (SS m) = SS (f . fmapD d1 (\(Tup2 x s) -> (Tup2 (g x) s)) . m) - -instance MMonadT (SStateT s) where - flift t = SS (\s -> fmap (\a -> (Tup2 a s)) t) - monoidalT (SS t) = SS (\s -> Comp $ fmap (\(Tup2 (SS t') s') -> t' s') (t s)) - -instance Monad m => StateM z (SStateT z m) where - stateModel = modelSStateT - -modelSStateT :: Monad m => AlgModel (StateOp s) (SStateT s m) -modelSStateT (Get g) = sstateT (\s -> return (Tup2 (g s) s)) -modelSStateT (Put s a) = sstateT (\_ -> return (Tup2 a s)) diff --git a/Control/Search/Stat.hs b/Control/Search/Stat.hs deleted file mode 100644 --- a/Control/Search/Stat.hs +++ /dev/null @@ -1,185 +0,0 @@ -{-# LANGUAGE Rank2Types #-} -{-# LANGUAGE FlexibleInstances #-} - -module Control.Search.Stat - ( appStat - , constStat - , depthStat - , nodesStat - , discrepancyStat - , solutionsStat - , failsStat - , timeStat - , notStat - , Stat(..), IValue, varStat - , (#>), (#<), (#>=), (#<=), (#=), (#/) - , readStat, evalStat - ) where - -import Text.PrettyPrint hiding (space) - -import Control.Search.Language -import Control.Search.GeneratorInfo -import Control.Search.Memo -import Control.Search.Generator - --- ========================================================================== -- --- IVALUE --- ========================================================================== -- - -type IValue = Info -> Value - -instance Show (Info -> Value) where - show x = "" -instance Eq (Info -> Value) where - x == y = False - -instance Num (Info -> Value) where - x - y = \i -> x i - y i - fromInteger x = \i -> IVal (fromInteger x) - x + y = \i -> x i + y i - x * y = \i -> x i * y i - abs x = \i -> abs (x i) - signum x = \i -> signum (x i) - --- ========================================================================== -- --- STATS --- ========================================================================== -- - -data Stat = Stat (forall m. Evalable m => Eval m -> Eval m) (forall m. Evalable m => m IValue) - -instance Show Stat where - show _ = "" - -instance Eq Stat where - _ == _ = False - -readStat :: Evalable m => Stat -> m IValue -readStat (Stat _ r) = r - -evalStat :: Evalable m => Stat -> Eval m -> Eval m -evalStat (Stat e _) = e - --- -------------------------------------------------------------------------- -- - -instance Num Stat where - x - y = liftStat (-) x y - fromInteger = constStat . fromInteger - x + y = liftStat (+) x y - x * y = liftStat (*) x y - abs = appStat abs - signum = appStat signum - -instance Bounded Stat where - maxBound = constStat $ const MaxVal - minBound = constStat $ const MinVal - -appStat :: (Value -> Value) -> Stat -> Stat -appStat f (Stat e r) = Stat e (r >>= \x -> return (\i -> f (x i))) - -liftStat :: (Value -> Value -> Value) -> Stat -> Stat -> Stat -liftStat op (Stat e1 x) (Stat e2 y) = Stat (e1 . e2) (x >>= \xv -> y >>= \yv -> return (\i -> xv i `op` yv i)) - -constStat :: IValue -> Stat -constStat x = Stat id (return x) - -(#>) :: Stat -> Stat -> Stat -(#>) = liftStat (@>) - -(#=) :: Stat -> Stat -> Stat -(#=) = liftStat (@==) - -(#<) :: Stat -> Stat -> Stat -(#<) = liftStat (@<) - -(#>=) :: Stat -> Stat -> Stat -(#>=) = liftStat (@>=) - -(#<=) :: Stat -> Stat -> Stat -(#<=) = liftStat (@<=) - -(#/) :: Stat -> Stat -> Stat -(#/) = liftStat (divValue) - -notStat :: Stat -> Stat -notStat = appStat Not --- -------------------------------------------------------------------------- -- - -depthStat :: Stat -depthStat = - Stat (\super -> - let push dir = \i -> dir super (i `onCommit` mkUpdate i "depth" (\x -> x + 1)) - in commentEval $ super - { treeState_ = entry ("depth",Int,assign $ 0) : treeState_ super - , pushLeftH = push pushLeft - , pushRightH = push pushRight - , toString = "stat_depth:" ++ toString super - }) - (return (\info -> tstate info @-> "depth")) - -discrepancyStat :: Stat -discrepancyStat = - Stat - (\super -> commentEval $ - super - { treeState_ = entry ("discrepancy",Int,assign 0) : treeState_ super - , pushLeftH = \i -> pushLeft super (i `onCommit` mkCopy i "discrepancy") - , pushRightH = \i -> pushRight super (i `onCommit` mkUpdate i "discrepancy" (\x -> x + 1)) - , toString = "stat_discr:" ++ toString super - }) - (return (\info -> tstate info @-> "discrepancy")) - -nodesStat :: Stat -nodesStat = - eStat ("nodes", Int, const 0) $ - \super -> super { bodyH = \i -> return (inc (estate i @=> "nodes")) @>>>@ bodyE super i } - -solutionsStat :: Stat -solutionsStat = - eStat ("solutions", Int, const 0) $ - \super -> super {returnH = \i -> returnE super (i `onCommit` inc (solutions i))} - where solutions i = estate i @=> "solutions" - -varStat :: VarId -> Stat -varStat v@(VarId i) = Stat id (do inf <- lookupVarInfo v - return (const $ estate inf @=> ("var" ++ show i)) - ) - -failsStat :: Stat -failsStat = - eStat ("fails", Int, const 0) $ - \super -> super { failH = \i -> returnH super i @>>>@ return (inc (fails i)) } - where fails i = estate i @=> "fails" - -eStat :: (String, Type, Info -> Value) -> (forall m. Evalable m => Eval m -> Eval m) -> Stat -eStat (name,typ,val) f = - Stat (\super -> commentEval $ f $ super { evalState_ = (name,typ,\i -> return (val i)) : evalState_ super, toString = "stat_" ++ name ++ ":" ++ toString super }) - (return (\i -> estate i @=> name)) - --- TIMER STATISTIC --- --- Based on Gecode::Support::Timer. --- --- --- -timeStat :: Stat -timeStat = - Stat (\super -> commentEval $ - super { evalState_ = ("total",Int, const $ return 0) : - ("timer",THook "Gecode::Support::Timer",const $ return Null) : - ("running",Bool,const $ return false) : - evalState_ super - , nextDiffH = \i -> - return (ifthen (running i) - ((running i <== false) >>> - (total i <== (total i + (VHook (render $ text "static_cast" <> parens (pretty (timer i) <> text ".stop()"))))))) - , bodyH = \i -> - return (ifthen (Not $ running i) - ((running i <== true) >>> SHook ((render $ pretty $ timer i) ++ ".start();"))) - @>>>@ bodyE super i - , toString = "stat_time:" ++ toString super - }) - (return (\i -> total i + Cond (running i) (VHook (render $ text "static_cast" <> parens (pretty (timer i) <> text ".stop()"))) 0)) - where running i = estate i @=> "running" - timer i = estate i @=> "timer" - total i = estate i @=> "total" diff --git a/Data/Expr/Data.hs b/Data/Expr/Data.hs deleted file mode 100644 --- a/Data/Expr/Data.hs +++ /dev/null @@ -1,297 +0,0 @@ -{- - - Monadic Constraint Programming - - http://www.cs.kuleuven.be/~toms/MCP/ - - Pieter Wuille - -} - -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE StandaloneDeriving #-} - -module Data.Expr.Data ( - Expr(..), - ColExpr(..), - BoolExpr(..), - ExprRel(..), - (<<>>) -) where - --------------------- --- | Data types | -- --------------------- - --- some simple kinds of expressions -data Expr t c b = - Term t - | ExprHole Int - | Const Integer - | Plus (Expr t c b) (Expr t c b) - | Minus (Expr t c b) (Expr t c b) - | Mult (Expr t c b) (Expr t c b) - | Div (Expr t c b) (Expr t c b) - | Mod (Expr t c b) (Expr t c b) - | Abs (Expr t c b) - | At (ColExpr t c b) (Expr t c b) - | Fold (Expr t c b -> Expr t c b -> Expr t c b) (Expr t c b) (ColExpr t c b) - | Cond (BoolExpr t c b) (Expr t c b) (Expr t c b) - | ColSize (ColExpr t c b) - | Channel (BoolExpr t c b) - -data ColExpr t c b = - ColTerm c - | ColList [Expr t c b] - | ColRange (Expr t c b) (Expr t c b) - | ColMap (Expr t c b -> Expr t c b) (ColExpr t c b) - | ColSlice (Expr t c b -> Expr t c b) (Expr t c b) (ColExpr t c b) -- ColSlice f n c -> c[f(0)..f(n-1)] - | ColCat (ColExpr t c b) (ColExpr t c b) - -data ExprRel = - EREqual - | ERDiff - | ERLess - deriving (Show,Eq,Ord) - -data BoolExpr t c b = - BoolTerm b - | BoolConst Bool - | BoolAnd (BoolExpr t c b) (BoolExpr t c b) - | BoolOr (BoolExpr t c b) (BoolExpr t c b) - | BoolNot (BoolExpr t c b) - | BoolCond (BoolExpr t c b) (BoolExpr t c b) (BoolExpr t c b) - | Rel (Expr t c b) ExprRel (Expr t c b) - | BoolAll (Expr t c b -> BoolExpr t c b) (ColExpr t c b) - | BoolAny (Expr t c b -> BoolExpr t c b) (ColExpr t c b) - | ColEqual (ColExpr t c b) (ColExpr t c b) - | BoolEqual (BoolExpr t c b) (BoolExpr t c b) - | AllDiff Bool (ColExpr t c b) - | Sorted Bool (ColExpr t c b) - | Dom (Expr t c b) (ColExpr t c b) - ------------------------ --- | Show instance | -- ------------------------ - -class ShowFn t where - showFn :: Int -> t -> String -instance (Show t, Show c, Show b) => ShowFn (Expr t c b) where - showFn _ (Term a) = "Term ("++(show a)++")" - showFn _ (ExprHole a) = "par"++(show a) - showFn _ (Const a) = "Const "++(show a) - showFn l (Plus a b) = "Plus ("++(showFn l a)++") ("++(showFn l b)++")" - showFn l (Minus a b) = "Minus ("++(showFn l a)++") ("++(showFn l b)++")" - showFn l (Mult a b) = "Mult ("++(showFn l a)++") ("++(showFn l b)++")" - showFn l (Div a b) = "Div ("++(showFn l a)++") ("++(showFn l b)++")" - showFn l (Mod a b) = "Mod ("++(showFn l a)++") ("++(showFn l b)++")" - showFn l (Abs a) = "Abs ("++(showFn l a)++")" - showFn l (At a b) = "At ("++(showFn l a)++") ("++(showFn l b)++")" - showFn l (Fold a b c) = "Fold ("++(showFn l a)++") ("++(showFn l b)++") ("++(showFn l c)++")" - showFn l (ColSize a) = "ColSize ("++(showFn l a)++")" - showFn l (Channel b) = "Channel ("++(showFn l b)++")" - showFn l (Cond c t f) = "Cond ("++(showFn l c)++") ("++(showFn l t)++") ("++(showFn l f)++")" -instance (ShowFn l) => ShowFn [l] where - showFn d l = "[" ++ (foldr1 (\a b -> a++","++b) $ map (showFn d) l) ++ "]" -instance (Show t, Show c, Show b) => ShowFn (ColExpr t c b) where - showFn d (ColTerm a) = "ColTerm ("++(show a)++")" - showFn d (ColList l) = "ColList ("++(showFn d l)++")" - showFn d (ColMap f l) = "ColMap ("++(showFn d f)++") ("++(showFn d l)++")" - showFn d (ColSlice f l c) = "ColSlice ("++(showFn d f)++") ("++(showFn d l)++") ("++(showFn d c)++")" - showFn d (ColCat a b) = "ColCat ("++(showFn d a)++") ("++(showFn d b)++")" - showFn d (ColRange a b) = "ColRange ("++(showFn d a)++") ("++(showFn d b)++")" -instance (Show t, Show c, Show b) => ShowFn (BoolExpr t c b) where - showFn d (BoolTerm b) = "BoolTerm ("++(show b)++")" - showFn d (BoolConst b) = "BoolConst "++(show b) - showFn d (BoolAnd a b) = "BoolAnd ("++(showFn d a)++") ("++(showFn d b)++")" - showFn d (BoolOr a b) = "BoolOr ("++(showFn d a)++") ("++(showFn d b)++")" - showFn d (BoolNot a) = "BoolNot ("++(showFn d a)++")" - showFn d (BoolEqual a b) = "BoolEqual ("++(showFn d a)++") ("++(showFn d b)++")" - showFn d (Rel a r b) = "Rel ("++(showFn d a)++") "++(show r)++" ("++(showFn d b)++")" - showFn d (BoolAll f c) = "BoolAll ("++(showFn d f)++") ("++(showFn d c)++")" - showFn d (BoolAny f c) = "BoolAny ("++(showFn d f)++") ("++(showFn d c)++")" - showFn d (ColEqual a b) = "ColEqual ("++(showFn d a)++") ("++(showFn d b)++")" - showFn d (AllDiff _ c) = "AllDiff ("++(showFn d c)++")" - showFn d (Sorted b c) = "Sorted "++(show b)++"("++(showFn d c)++")" - showFn l (BoolCond c t f) = "BoolCond ("++(showFn l c)++") ("++(showFn l t)++") ("++(showFn l f)++")" - showFn d (Dom i c) = "Dom ("++(showFn d i)++") ("++(showFn d c)++")" -instance (Show t, Show c, Show b, ShowFn e) => ShowFn (Expr t c b -> e) where - showFn l f = "\\par"++(show l)++" -> "++(showFn (l+1) (f (ExprHole l))) -instance (Show t, Show c, Show b) => Show (Expr t c b) where - show = showFn 0 -instance (Show t, Show c, Show b) => Show (ColExpr t c b) where - show = showFn 0 -instance (Show t, Show c, Show b) => Show (BoolExpr t c b) where - show = showFn 0 - ---------------------- --- | Eq instance | -- ---------------------- - -equalExpr :: (Eq t, Eq c, Eq b) => Int -> Expr t c b -> Expr t c b -> Bool -equalExpr _ (Term a) (Term b) = a==b -equalExpr _ (ExprHole a) (ExprHole b) = a==b -equalExpr _ (Const a) (Const b) = a==b -equalExpr l (Plus a c) (Plus b d) = equalExpr l a b && equalExpr l d c -equalExpr l (Minus a c) (Minus b d) = equalExpr l a b && equalExpr l d c -equalExpr l (Mult a c) (Mult b d) = equalExpr l a b && equalExpr l d c -equalExpr l (Div a c) (Plus b d) = equalExpr l a b && equalExpr l d c -equalExpr l (Mod a c) (Plus b d) = equalExpr l a b && equalExpr l d c -equalExpr l (Abs a) (Abs b) = equalExpr l a b -equalExpr l (At a c) (At b d) = equalExpr l c d && equalColExpr l a b -equalExpr l (ColSize a) (ColSize b) = equalColExpr l a b -equalExpr l (Fold f a c) (Fold g b d) = equalExpr l a b && equalColExpr l c d && equalExpr (l+2) (f (ExprHole l) (ExprHole $ l+1)) (g (ExprHole l) (ExprHole $ l+1)) -equalExpr l (Channel a) (Channel b) = equalBoolExpr l a b -equalExpr l (Cond c t f) (Cond d u g) = equalBoolExpr l c d && equalExpr l t u && equalExpr l f g -equalExpr _ _ _ = False - -equalColExpr :: (Eq t, Eq c, Eq b) => Int -> ColExpr t c b -> ColExpr t c b -> Bool -equalColExpr _ (ColTerm a) (ColTerm b) = a==b -equalColExpr _ (ColList []) (ColList []) = True -equalColExpr l (ColList (a:ar)) (ColList (b:br)) = equalExpr l a b && equalColExpr l (ColList ar) (ColList br) -equalColExpr l (ColMap f a) (ColMap g b) = equalColExpr l a b && equalExpr (l+1) (f (ExprHole l)) (g (ExprHole l)) -equalColExpr l (ColSlice a c e) (ColSlice b d f) = equalExpr (l+1) (a (ExprHole l)) (b (ExprHole l)) && equalExpr l c d && equalColExpr l e f -equalColExpr l (ColCat a c) (ColCat b d) = equalColExpr l a b && equalColExpr l c d -equalColExpr l (ColRange a c) (ColRange b d) = equalExpr l a b && equalExpr l c d -equalColExpr _ _ _ = False - -equalBoolExpr :: (Eq t, Eq c, Eq b) => Int -> BoolExpr t c b -> BoolExpr t c b -> Bool -equalBoolExpr _ (BoolTerm a) (BoolTerm b) = a==b -equalBoolExpr _ (BoolConst a) (BoolConst b) = a==b -equalBoolExpr l (BoolAnd a c) (BoolAnd b d) = equalBoolExpr l a b && equalBoolExpr l c d -equalBoolExpr l (BoolOr a c) (BoolOr b d) = equalBoolExpr l a b && equalBoolExpr l c d -equalBoolExpr l (BoolEqual a c) (BoolEqual b d) = equalBoolExpr l a b && equalBoolExpr l c d -equalBoolExpr l (BoolNot a) (BoolNot b) = equalBoolExpr l a b -equalBoolExpr l (Rel a r c) (Rel b s d) = r==s && equalExpr l a b && equalExpr l c d -equalBoolExpr l (BoolAll f c) (BoolAll g d) = equalColExpr l c d && equalBoolExpr (l+1) (f $ ExprHole l) (g $ ExprHole l) -equalBoolExpr l (BoolAny f c) (BoolAny g d) = equalColExpr l c d && equalBoolExpr (l+1) (f $ ExprHole l) (g $ ExprHole l) -equalBoolExpr l (ColEqual a c) (ColEqual b d) = equalColExpr l a b && equalColExpr l c d -equalBoolExpr l (AllDiff _ c) (AllDiff _ d) = equalColExpr l c d -equalBoolExpr l (Sorted a c) (Sorted b d) = a==b && equalColExpr l c d -equalBoolExpr l (BoolCond c t f) (BoolCond d u g) = equalBoolExpr l c d && equalBoolExpr l t u && equalBoolExpr l f g -equalBoolExpr l (Dom a c) (Dom b d) = equalExpr l a b && equalColExpr l c d -equalBoolExpr _ _ _ = False - -instance (Eq t, Eq c, Eq b) => Eq (Expr t c b) where - a == b = equalExpr 0 a b -instance (Eq t, Eq c, Eq b) => Eq (ColExpr t c b) where - a == b = equalColExpr 0 a b -instance (Eq t, Eq c, Eq b) => Eq (BoolExpr t c b) where - a == b = equalBoolExpr 0 a b - ------------------------------------------------------ --- | ExprKey: Provides ordering over expressions | -- ------------------------------------------------------ - -infixr 4 <<>> -a <<>> b = case a of - EQ -> b - _ -> a - -compareColExpr :: (Ord s, Ord c, Ord b) => Int -> ColExpr s c b -> ColExpr s c b -> Ordering -compareColExpr _ (ColList []) (ColList []) = EQ -compareColExpr l (ColList (a:ar)) (ColList (b:br)) = compareExpr l a b <<>> compareColExpr l (ColList ar) (ColList br) -compareColExpr _ (ColList _) _ = LT -compareColExpr _ _ (ColList _) = GT -compareColExpr l (ColMap f1 c1) (ColMap f2 c2) = compareColExpr l c1 c2 <<>> compareExpr (l+1) (f1 $ ExprHole l) (f2 $ ExprHole l) -compareColExpr _ (ColMap _ _) _ = LT -compareColExpr _ _ (ColMap _ _) = GT -compareColExpr l (ColSlice p1 l1 c1) (ColSlice p2 l2 c2) = compareExpr (l+1) (p1 $ ExprHole l) (p2 $ ExprHole l) <<>> compareExpr l l1 l2 <<>> compareColExpr l c1 c2 -compareColExpr _ (ColSlice _ _ _) _ = LT -compareColExpr _ _ (ColSlice _ _ _) = GT -compareColExpr l (ColCat a1 b1) (ColCat a2 b2) = compareColExpr l a1 a2 <<>> compareColExpr l b1 b2 -compareColExpr _ (ColCat _ _) _ = LT -compareColExpr _ _ (ColCat _ _) = GT -compareColExpr l (ColRange l1 h1) (ColRange l2 h2) = compareExpr l l1 l2 <<>> compareExpr l l2 h2 -compareColExpr _ (ColRange _ _) _ = LT -compareColExpr _ _ (ColRange _ _) = GT -compareColExpr _ (ColTerm t1) (ColTerm t2) = compare t1 t2 - -compareBoolExpr :: (Ord s, Ord c, Ord b) => Int -> BoolExpr s c b -> BoolExpr s c b -> Ordering -compareBoolExpr _ (BoolConst a) (BoolConst b) = compare a b -compareBoolExpr _ (BoolConst _) _ = LT -compareBoolExpr _ _ (BoolConst _) = GT -compareBoolExpr l (BoolAnd a1 b1) (BoolAnd a2 b2) = compareBoolExpr l a1 a2 <<>> compareBoolExpr l b1 b2 -compareBoolExpr _ (BoolAnd _ _) _ = LT -compareBoolExpr _ _ (BoolAnd _ _) = GT -compareBoolExpr l (BoolOr a1 b1) (BoolOr a2 b2) = compareBoolExpr l a1 a2 <<>> compareBoolExpr l b1 b2 -compareBoolExpr _ (BoolOr _ _) _ = LT -compareBoolExpr _ _ (BoolOr _ _) = GT -compareBoolExpr l (BoolEqual a1 b1) (BoolEqual a2 b2) = compareBoolExpr l a1 a2 <<>> compareBoolExpr l b1 b2 -compareBoolExpr _ (BoolEqual _ _) _ = LT -compareBoolExpr _ _ (BoolEqual _ _) = GT -compareBoolExpr l (BoolNot a1) (BoolNot a2) = compareBoolExpr l a1 a2 -compareBoolExpr _ (BoolNot _) _ = LT -compareBoolExpr _ _ (BoolNot _) = GT -compareBoolExpr l (Rel a1 r1 b1) (Rel a2 r2 b2) = compare r1 r2 <<>> compareExpr l a1 a2 <<>> compareExpr l b1 b2 -compareBoolExpr _ (Rel _ _ _) _ = LT -compareBoolExpr _ _ (Rel _ _ _) = GT -compareBoolExpr l (BoolAll f1 c1) (BoolAll f2 c2) = compareColExpr l c1 c2 <<>> compareBoolExpr (l+1) (f1 $ ExprHole l) (f2 $ ExprHole l) -compareBoolExpr _ (BoolAll _ _) _ = LT -compareBoolExpr _ _ (BoolAll _ _) = GT -compareBoolExpr l (BoolAny f1 c1) (BoolAny f2 c2) = compareColExpr l c1 c2 <<>> compareBoolExpr (l+1) (f1 $ ExprHole l) (f2 $ ExprHole l) -compareBoolExpr _ (BoolAny _ _) _ = LT -compareBoolExpr _ _ (BoolAny _ _) = GT -compareBoolExpr l (ColEqual a1 b1) (ColEqual a2 b2) = compareColExpr l a1 a2 <<>> compareColExpr l b1 b2 -compareBoolExpr _ (ColEqual _ _) _ = LT -compareBoolExpr _ _ (ColEqual _ _) = GT -compareBoolExpr l (Sorted a1 b1) (Sorted a2 b2) = compare a1 a2 <<>> compareColExpr l b1 b2 -compareBoolExpr _ (Sorted _ _) _ = LT -compareBoolExpr _ _ (Sorted _ _) = GT -compareBoolExpr l (AllDiff _ b1) (AllDiff _ b2) = compareColExpr l b1 b2 -compareBoolExpr _ (AllDiff _ _) _ = LT -compareBoolExpr _ _ (AllDiff _ _) = GT -compareBoolExpr l (BoolCond c1 t1 f1) (BoolCond c2 t2 f2) = compareBoolExpr l c1 c2 <<>> compareBoolExpr l t1 t2 <<>> compareBoolExpr l f1 f2 -compareBoolExpr _ (BoolCond _ _ _) _ = LT -compareBoolExpr _ _ (BoolCond _ _ _) = GT -compareBoolExpr l (Dom i1 c1) (Dom i2 c2) = compareExpr l i1 i2 <<>> compareColExpr l c1 c2 -compareBoolExpr _ (Dom _ _) _ = LT -compareBoolExpr _ _ (Dom _ _) = GT -compareBoolExpr _ (BoolTerm a) (BoolTerm b) = compare a b - -compareExpr :: (Ord s, Ord c, Ord b) => Int -> Expr s c b -> Expr s c b -> Ordering -compareExpr _ (Const i1) (Const i2) = compare i1 i2 -compareExpr _ (Const _) _ = LT -compareExpr _ _ (Const _) = GT -compareExpr _ (ExprHole i1) (ExprHole i2) = compare i1 i2 -compareExpr _ (ExprHole _) _ = LT -compareExpr _ _ (ExprHole _) = GT -compareExpr l (Plus a1 b1) (Plus a2 b2) = compareExpr l a1 a2 <<>> compareExpr l b1 b2 -compareExpr _ (Plus _ _) _ = LT -compareExpr _ _ (Plus _ _) = GT -compareExpr l (Minus a1 b1) (Minus a2 b2) = compareExpr l a1 a2 <<>> compareExpr l b1 b2 -compareExpr _ (Minus _ _) _ = LT -compareExpr _ _ (Minus _ _) = GT -compareExpr l (Mult a1 b1) (Mult a2 b2) = compareExpr l a1 a2 <<>> compareExpr l b1 b2 -compareExpr _ (Mult _ _) _ = LT -compareExpr _ _ (Mult _ _) = GT -compareExpr l (Div a1 b1) (Div a2 b2) = compareExpr l a1 a2 <<>> compareExpr l b1 b2 -compareExpr _ (Div _ _) _ = LT -compareExpr _ _ (Div _ _) = GT -compareExpr l (Mod a1 b1) (Mod a2 b2) = compareExpr l a1 a2 <<>> compareExpr l b1 b2 -compareExpr _ (Mod _ _) _ = LT -compareExpr _ _ (Mod _ _) = GT -compareExpr l (Abs a1) (Abs a2) = compareExpr l a1 a2 -compareExpr _ (Abs _) _ = LT -compareExpr _ _ (Abs _) = GT -compareExpr l (At c1 a1) (At c2 a2) = compareExpr l a1 a2 <<>> compareColExpr l c1 c2 -compareExpr _ (At _ _) _ = LT -compareExpr _ _ (At _ _) = GT -compareExpr l (ColSize c1) (ColSize c2) = compareColExpr l c1 c2 -compareExpr _ (ColSize _) _ = LT -compareExpr _ _ (ColSize _) = GT -compareExpr l (Fold f1 i1 c1) (Fold f2 i2 c2) = compareExpr l i1 i2 <<>> compareColExpr l c1 c2 <<>> compareExpr (l+2) (f1 (ExprHole l) (ExprHole $ l+1)) (f2 (ExprHole l) (ExprHole $ l+1)) -compareExpr _ (Fold _ _ _) _ = LT -compareExpr _ _ (Fold _ _ _) = GT -compareExpr l (Channel b1) (Channel b2) = compareBoolExpr l b1 b2 -compareExpr _ (Channel _) _ = LT -compareExpr _ _ (Channel _) = GT -compareExpr l (Cond c1 t1 f1) (Cond c2 t2 f2) = compareBoolExpr l c1 c2 <<>> compareExpr l t1 t2 <<>> compareExpr l f1 f2 -compareExpr _ (Cond _ _ _) _ = LT -compareExpr _ _ (Cond _ _ _) = GT -compareExpr _ (Term t1) (Term t2) = compare t1 t2 - -instance (Ord s, Ord c, Ord b) => Ord (Expr s c b) where - compare = compareExpr 0 - -instance (Ord s, Ord c, Ord b) => Ord (ColExpr s c b) where - compare = compareColExpr 0 - -instance (Ord s, Ord c, Ord b) => Ord (BoolExpr s c b) where - compare = compareBoolExpr 0 diff --git a/Data/Expr/Sugar.hs b/Data/Expr/Sugar.hs deleted file mode 100644 --- a/Data/Expr/Sugar.hs +++ /dev/null @@ -1,285 +0,0 @@ -{- - - Monadic Constraint Programming - - http://www.cs.kuleuven.be/~toms/MCP/ - - Pieter Wuille - -} - -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE FlexibleContexts #-} - -module Data.Expr.Sugar ( - (@+), (@-), (@*), (@/), (@%), (@?), (@??), (@:), - (!), (@!!), (@++), (@..), size, slice, xhead, xtail, xmap, xfold, list, channel, xsum, - (@||), (@&&), inv, - (@/=), (@>), (@<), (@>=), (@<=), (@=), - loopall, loopany, forall, forany, - Expr(), ColExpr(), BoolExpr(), - ToExpr(..), ToColExpr(..), ToBoolExpr(..), - sorted, sSorted, allDiff, allDiffD, - ExprClass, ExprRange, -) where - -import Data.Expr.Data -import Data.Expr.Util - ----------------------------------- --- | Built-in class instances | -- ----------------------------------- - -instance (Eq s, Eq c, Eq b, Show s, Show c, Show b) => Num (Expr s c b) where - a + b = simplify $ a `Plus` b - a - b = simplify $ a `Minus` b - a * b = simplify $ a `Mult` b - abs a = simplify $ Abs a - negate a = simplify $ (Const 0) `Minus` a - fromInteger c = Const $ fromInteger c - signum (Const a) = Const $ signum a - signum a = error "signum not possible for generic Expr" - -instance (Ord s, Ord c, Ord b, Eq s, Eq c, Eq b, Show s, Show c, Show b) => Real (Expr s c b) where - toRational (Const x) = toRational x - toRational _ = error "toRational not possible for generic Expr" - -instance (Eq s, Eq c, Eq b) => Enum (Expr s c b) where - succ a = simplify $ a `Plus` (Const 1) - pred a = simplify $ a `Minus` (Const 1) - toEnum = Const . toEnum - fromEnum (Const a) = fromEnum a - fromEnum _ = error "fromEnum not possible for generic Expr" - -instance (Ord s, Ord c, Ord b, Eq s, Eq c, Eq b, Show s, Show c, Show b) => Integral (Expr s c b) where - toInteger (Const a) = toInteger a - toInteger _ = error "toInteger not possible for generic Expr" - divMod a b = (simplify $ a `Div` b, simplify $ a `Mod` b) - quotRem (Const a) (Const b) = case quotRem a b of (c,d) -> (Const c,Const d) - quotRem (Const 0) b = (Const 0,Const 0) - quotRem a (Const 1) = (a,Const 0) - quotRem a (Const (-1)) = (negate a,Const 0) - quotRem _ _ = error "quotRem not possible for generic Expr" - ---------------------------------------------- --- | convertion from/to expression types | -- ---------------------------------------------- - --- convertible to expressions: -class ToExpr tt cc bb t where - toExpr :: t -> Expr tt cc bb - --- convertible to collection-expressions: -class ToColExpr tt cc bb c where - toColExpr :: c -> ColExpr tt cc bb - --- convertible to boolean expressions: -class ToBoolExpr tt cc bb b where - toBoolExpr :: b -> BoolExpr tt cc bb - --- infix 4 @=, @/= - -class (Eq tt, Eq cc, Eq bb) => ExprClass tt cc bb a where - (@=) :: a -> a -> BoolExpr tt cc bb - (@/=) :: a -> a -> BoolExpr tt cc bb - a @/= b = boolSimplify $ BoolNot $ a @= b - -class (Eq tt, Eq cc, Eq bb) => ExprRange tt cc bb r where - (@:) :: Expr tt cc bb -> r -> BoolExpr tt cc bb - --- integers can be used as constant expressions -instance ToExpr tt cc bb Integer where - toExpr = Const - --- expressions themselves are trivially convertible to expressions -instance ToExpr t a b (Expr t a b) where - toExpr = id - --- ints can be used as constant expressions -instance ToExpr tt cc bb Int where - toExpr = Const . toInteger - --- boolean expressions can be used as integer expressions (being 0 or 1) -instance (Eq t, Eq a, Eq b) => ToExpr t a b (BoolExpr t a b) where - toExpr = simplify . Channel - --- collection expressions themselves are trivially convertible to collection expressions -instance ToColExpr t a b (ColExpr t a b) where - toColExpr = id - --- an expression can be used as a collection of one expressions -instance (Eq t, Eq a, Eq b) => ToColExpr t a b (Expr t a b) where - toColExpr a = colSimplify $ ColList [a] - --- a list of expressions van be used as a collection -instance (Eq b, Eq a, Eq t) => ToColExpr t a b [Expr t a b] where - toColExpr = colSimplify . ColList - --- a boolean constant can be used as a constant boolean expression -instance ToBoolExpr tt cc bb Bool where - toBoolExpr = BoolConst - --- boolean expressions are trivially convertible to boolean expressions -instance ToBoolExpr t a b (BoolExpr t a b) where - toBoolExpr = id - --- the integer terms used by an expression can be used as interger expressions -instance ToExpr t a b t where - toExpr = Term - --- the collections terms used by an expression can be used as collection expressions -instance ToColExpr t a b a where - toColExpr = ColTerm - --- the boolean terms used by an expression can be used as boolean expressions -instance ToBoolExpr t a b b where - toBoolExpr = BoolTerm - -------------------------------------- --- | integer operators/functions | -- -------------------------------------- - --- @+ @- @* @/ @% are identical to + - * / % for integer expressions, except --- that they also accept types convertible to expressions, instead of only --- expressions themselves - -infixl 6 @+, @- -infixl 7 @* -infixl 7 @/ -infixl 7 @% - -(@+) :: (Eq t, Eq c, Eq b, ToExpr t c b p, ToExpr t c b q) => p -> q -> Expr t c b -(@-) :: (Eq t, Eq c, Eq b, ToExpr t c b p, ToExpr t c b q) => p -> q -> Expr t c b -(@*) :: (Eq t, Eq c, Eq b, ToExpr t c b p, ToExpr t c b q) => p -> q -> Expr t c b -(@/) :: (Eq t, Eq c, Eq b, ToExpr t c b p, ToExpr t c b q) => p -> q -> Expr t c b -(@%) :: (Eq t, Eq c, Eq b, ToExpr t c b p, ToExpr t c b q) => p -> q -> Expr t c b - -a @+ b = simplify $ (toExpr a) `Plus` (toExpr b) -a @- b = simplify $ (toExpr a) `Minus` (toExpr b) -a @* b = simplify $ (toExpr a) `Mult` (toExpr b) -a @/ b = simplify $ (toExpr a) `Div` (toExpr b) -a @% b = simplify $ (toExpr a) `Mod` (toExpr b) - ----------------------------------- --- | list operators/functions | -- ----------------------------------- - -infix 9 ! -infix 9 @!! -infix 9 @.. -infixr 5 @++ -infix 4 @? -infix 4 @?? -infix 5 @: - -(!) :: (Eq t, Eq c, Eq b) => ColExpr t c b -> Expr t c b -> Expr t c b -(@!!) :: (Eq t, Eq c, Eq b) => ColExpr t c b -> Integer -> Expr t c b -(@..) :: (Eq t, Eq c, Eq b) => Expr t c b -> Expr t c b -> ColExpr t c b -(@++) :: (Eq t, Eq c, Eq b) => ColExpr t c b -> ColExpr t c b -> ColExpr t c b - -(@?) :: (Eq t, Eq c, Eq b) => BoolExpr t c b -> (Expr t c b, Expr t c b) -> Expr t c b -c @? (t,f) = simplify $ Cond c t f - -(@??) :: (Eq t, Eq c, Eq b) => BoolExpr t c b -> (BoolExpr t c b, BoolExpr t c b) -> BoolExpr t c b -c @?? (t,f) = boolSimplify $ BoolCond c t f - -c!p = simplify $ At c p -c @!! p = simplify $ At c (Const p) -a @.. b = colSimplify $ ColRange (toExpr a) (toExpr b) -a @++ b = colSimplify $ ColCat (toColExpr a) (toColExpr b) - -size :: (Eq t, Eq c, Eq b) => ColExpr t c b -> Expr t c b -size a = simplify $ ColSize a - -xfold :: (Eq t, Eq c, Eq b) => (Expr t c b -> Expr t c b -> Expr t c b) -> Expr t c b -> ColExpr t c b -> Expr t c b -xfold f i c = simplify $ Fold (\a b -> f a b) i c - -xsum :: (Num (Expr t c b), Eq t, Eq c, Eq b) => ColExpr t c b -> Expr t c b -xsum c = xfold (+) (Const 0) c - -list :: (Eq t, Eq c, Eq b) => [Expr t c b] -> ColExpr t c b -list x = colSimplify $ ColList x - -xhead :: (Eq t, Eq c, Eq b, ToColExpr t c b p) => p -> Expr t c b -xhead c = simplify $ At (toColExpr c) (Const 0) - -xtail :: (Eq t, Eq c, Eq b, ToColExpr t c b p) => p -> ColExpr t c b -xtail c = let cc = toColExpr c in colSimplify $ ColSlice (\x -> simplify (x `Plus` (Const 1))) (simplify $ (size cc) `Minus` (Const 1)) cc - -slice :: (Eq t, Eq c, Eq b) => ColExpr t c b -> ColExpr t c b -> ColExpr t c b -slice c p = case (c,p) of - (_,ColRange l h) -> colSimplify $ ColSlice (\x -> simplify (l `Plus` x)) (simplify $ Const 1 `Plus` (simplify $ h `Minus` l)) c - (_,ColMap f (ColRange l h)) -> colSimplify $ ColSlice (\i -> simplify $ f $ simplify (l `Plus` i)) (simplify $ Const 1 `Plus` (simplify $ h `Minus` l)) c - (_,ColSlice f n c2) -> colSimplify $ ColSlice (\i -> simplify $ c2 `At` (f i)) n c - _ -> xmap (\i -> simplify $ c `At` i) p - -xmap :: (Eq t, Eq c, Eq b) => (Expr t c b -> Expr t c b) -> ColExpr t c b -> ColExpr t c b -xmap f c = colSimplify $ ColMap f c - -loopall :: (Eq t, Eq c, Eq b) => (Expr t c b,Expr t c b) -> (Expr t c b -> BoolExpr t c b) -> BoolExpr t c b -loopall (l,h) f = boolSimplify $ BoolAll f $ colSimplify $ ColRange l h - -loopany :: (Eq t, Eq c, Eq b) => (Expr t c b,Expr t c b) -> (Expr t c b -> BoolExpr t c b) -> BoolExpr t c b -loopany (l,h) f = boolSimplify $ BoolAny f $ colSimplify $ ColRange l h - -forall :: (Eq t, Eq c, Eq b) => (ColExpr t c b) -> (Expr t c b -> BoolExpr t c b) -> BoolExpr t c b -forall c f = boolSimplify $ BoolAll f c - -forany :: (Eq t, Eq c, Eq b) => (ColExpr t c b) -> (Expr t c b -> BoolExpr t c b) -> BoolExpr t c b -forany c f = boolSimplify $ BoolAny f c - -channel :: (Eq t, Eq c, Eq b) => BoolExpr t c b -> Expr t c b -channel = simplify . Channel - -------------------------------------- --- | boolean operators/functions | -- -------------------------------------- - --- infixr 1 /\ --- infixr 1 \/ -infixr 2 @|| -infixr 3 @&& - --- (\/) :: (Eq t, Eq c, Eq b, ToBoolExpr t c b p, ToBoolExpr t c b q) => p -> q -> BoolExpr t c b --- (/\) :: (Eq t, Eq c, Eq b, ToBoolExpr t c b p, ToBoolExpr t c b q) => p -> q -> BoolExpr t c b -inv :: (Eq t, Eq c, Eq b, ToBoolExpr t c b p) => p -> BoolExpr t c b - -a @|| b = boolSimplify $ BoolOr (toBoolExpr a) (toBoolExpr b) -a @&& b = boolSimplify $ BoolAnd (toBoolExpr a) (toBoolExpr b) -inv a = boolSimplify $ BoolNot (toBoolExpr a) --- a \/ b = a @|| b --- a /\ b = a @&& b - ----------------------------------------- --- | relational operators/functions | -- ----------------------------------------- - -instance (Eq t, Eq c, Eq b) => ExprClass t c b (Expr t c b) where - a @= b = boolSimplify $ Rel a EREqual b - -instance (Eq t, Eq c, Eq b) => ExprClass t c b (BoolExpr t c b) where - a @= b = boolSimplify $ BoolEqual a b - -instance (Eq t, Eq c, Eq b) => ExprClass t c b (ColExpr t c b) where - a @= b = boolSimplify $ ColEqual a b - - -infixr 4 @<,@<=,@>,@>= -(@<) :: (Eq t, Eq c, Eq b) => Expr t c b -> Expr t c b -> BoolExpr t c b -(@>) :: (Eq t, Eq c, Eq b) => Expr t c b -> Expr t c b -> BoolExpr t c b -(@<=) :: (Eq t, Eq c, Eq b) => Expr t c b -> Expr t c b -> BoolExpr t c b -(@>=) :: (Eq t, Eq c, Eq b) => Expr t c b -> Expr t c b -> BoolExpr t c b - -a @< b = boolSimplify $ Rel a ERLess b -a @> b = boolSimplify $ Rel b ERLess a -a @<= b = boolSimplify $ Rel a ERLess (simplify $ b `Plus` (Const 1)) -a @>= b = boolSimplify $ Rel b ERLess (simplify $ a `Plus` (Const 1)) - -sorted c = boolSimplify $ Sorted False c -sSorted c = boolSimplify $ Sorted True c -allDiff c = boolSimplify $ AllDiff False c -allDiffD c = boolSimplify $ AllDiff True c - -instance (Eq t, Eq c, Eq b) => ExprRange t c b (Expr t c b,Expr t c b) where - a @: (l,h) = (a @>= l) @&& (a @<= h) - -instance (Eq t, Eq c, Eq b) => ExprRange t c b (ColExpr t c b) where - a @: c = boolSimplify $ Dom a c - diff --git a/Data/Expr/Util.hs b/Data/Expr/Util.hs deleted file mode 100644 --- a/Data/Expr/Util.hs +++ /dev/null @@ -1,481 +0,0 @@ -{- - - Monadic Constraint Programming - - http://www.cs.kuleuven.be/~toms/MCP/ - - Pieter Wuille - -} - -{-# LANGUAGE StandaloneDeriving #-} - -module Data.Expr.Util ( - Expr(), BoolExpr(), ColExpr(), - transform, colTransform, boolTransform, - transformEx, colTransformEx, boolTransformEx, - property, colProperty, boolProperty, - propertyEx, colPropertyEx, boolPropertyEx, - collapse, colCollapse, boolCollapse, - simplify, colSimplify, boolSimplify, - WalkPhase(..), WalkResult(..), walk, colWalk, boolWalk, -) where - -import Data.Expr.Data - -------------------------- --- | Helper functions |-- -------------------------- - -relCheck :: Integer -> ExprRel -> Integer -> Bool -relCheck a EREqual b = a==b -relCheck a ERDiff b = a/=b -relCheck a ERLess b = a (a->b,c->d,e->f,b->a,d->c,f->e) -> Expr a c e -> Expr b d f -transform (f,fc,fb,fi,fic,fib) = transformEx (Term . f, ColTerm . fc, BoolTerm . fb, Term . fi, ColTerm . fic, BoolTerm . fib) - -transformEx :: (Eq a, Eq b, Eq c, Eq d, Eq e, Eq f) => ((a -> Expr b d f),(c -> ColExpr b d f),(e -> BoolExpr b d f),(b -> Expr a c e),(d -> ColExpr a c e),(f -> BoolExpr a c e)) -> Expr a c e -> Expr b d f -transformEx (f,_,_,_,_,_) (Term v) = f v -transformEx f (Const i) = Const i -transformEx f (ExprHole i) = ExprHole i -transformEx f (Plus a b) = simplify $ Plus (transformEx f a) (transformEx f b) -transformEx f (Minus a b) = simplify $ Minus (transformEx f a) (transformEx f b) -transformEx f (Mult a b) = simplify $ Mult (transformEx f a) (transformEx f b) -transformEx f (Div a b) = simplify $ Div (transformEx f a) (transformEx f b) -transformEx f (Mod a b) = simplify $ Mod (transformEx f a) (transformEx f b) -transformEx f (Abs a) = simplify $ Abs (transformEx f a) -transformEx f (At c a) = simplify $ At (colTransformEx f c) (transformEx f a) -transformEx f (ColSize c) = simplify $ ColSize $ colTransformEx f c -transformEx f (Channel a) = simplify $ Channel $ boolTransformEx f a -transformEx f (Cond c t e) = simplify $ Cond (boolTransformEx f c) (transformEx f t) (transformEx f e) -transformEx t@(f,fc,fb,fi,fic,fib) (Fold m i c) = simplify $ Fold (\a b -> transformEx t (m (transformEx (fi,fic,fib,f,fc,fb) a) (transformEx (fi,fic,fib,f,fc,fb) b))) (transformEx t i) (colTransformEx t c) - -colTransform :: (Eq a, Eq b, Eq c, Eq d, Eq e, Eq f) => (a->b,c->d,e->f,b->a,d->c,f->e) -> ColExpr a c e -> ColExpr b d f -colTransform (f,fc,fb,fi,fic,fib) = colTransformEx (Term . f, ColTerm . fc, BoolTerm . fb, Term . fi, ColTerm . fic, BoolTerm . fib) - -colTransformEx :: (Eq a, Eq b, Eq c, Eq d, Eq e, Eq f) => ((a -> Expr b d f),(c -> ColExpr b d f),(e -> BoolExpr b d f),(b -> Expr a c e),(d -> ColExpr a c e),f -> BoolExpr a c e) -> ColExpr a c e -> ColExpr b d f -colTransformEx (_,f,_,_,_,_) (ColTerm c) = f c -colTransformEx f (ColList l) = colSimplify $ ColList $ map (transformEx f) l -colTransformEx t@(f,fc,fb,fi,fic,fib) (ColMap m c) = colSimplify $ ColMap (\a -> transformEx t (m (transformEx (fi,fic,fib,f,fc,fb) a))) (colTransformEx t c) -colTransformEx t@(f,fc,fb,fi,fic,fib) (ColSlice p l c) = colSimplify $ ColSlice (\a -> transformEx t (p (transformEx (fi,fic,fib,f,fc,fb) a))) (transformEx t l) (colTransformEx t c) -colTransformEx f (ColCat a b) = colSimplify $ ColCat (colTransformEx f a) (colTransformEx f b) -colTransformEx f (ColRange a b) = colSimplify $ ColRange (transformEx f a) (transformEx f b) - -boolTransform :: (Eq a, Eq b, Eq c, Eq d, Eq e, Eq f) => (a->b,c->d,e->f,b->a,d->c,f->e) -> BoolExpr a c e -> BoolExpr b d f -boolTransform (f,fc,fb,fi,fic,fib) = boolTransformEx (Term . f, ColTerm . fc, BoolTerm . fb, Term . fi, ColTerm . fic, BoolTerm . fib) - -boolTransformEx :: (Eq a, Eq b, Eq c, Eq d, Eq e, Eq f) => ((a -> Expr b d f),(c -> ColExpr b d f),(e -> BoolExpr b d f),(b -> Expr a c e),(d -> ColExpr a c e),f -> BoolExpr a c e) -> BoolExpr a c e -> BoolExpr b d f -boolTransformEx (_,_,f,_,_,_) (BoolTerm v) = f v -boolTransformEx f (BoolConst c) = BoolConst c -boolTransformEx f (BoolAnd a b) = boolSimplify $ BoolAnd (boolTransformEx f a) (boolTransformEx f b) -boolTransformEx f (BoolOr a b) = boolSimplify $ BoolOr (boolTransformEx f a) (boolTransformEx f b) -boolTransformEx f (BoolEqual a b) = boolSimplify $ BoolEqual (boolTransformEx f a) (boolTransformEx f b) -boolTransformEx f (BoolNot a) = boolSimplify $ BoolNot (boolTransformEx f a) -boolTransformEx f (Rel a r b) = boolSimplify $ Rel (transformEx f a) r (transformEx f b) -boolTransformEx t@(f,fc,fb,fi,fic,fib) (BoolAll m c) = boolSimplify $ BoolAll (\a -> boolTransformEx t (m (transformEx (fi,fic,fib,f,fc,fb) a))) (colTransformEx t c) -boolTransformEx t@(f,fc,fb,fi,fic,fib) (BoolAny m c) = boolSimplify $ BoolAny (\a -> boolTransformEx t (m (transformEx (fi,fic,fib,f,fc,fb) a))) (colTransformEx t c) -boolTransformEx f (ColEqual a b) = boolSimplify $ ColEqual (colTransformEx f a) (colTransformEx f b) -boolTransformEx f (Sorted b c) = boolSimplify $ Sorted b (colTransformEx f c) -boolTransformEx f (AllDiff b c) = boolSimplify $ AllDiff b (colTransformEx f c) -boolTransformEx f (BoolCond c t e) = boolSimplify $ BoolCond (boolTransformEx f c) (boolTransformEx f t) (boolTransformEx f e) -boolTransformEx f (Dom i c) = boolSimplify $ Dom (transformEx f i) (colTransformEx f c) - ------------------------------------------------------------------------------------------- --- | Check whether an expression is possibly referring to terms with a given property | -- ------------------------------------------------------------------------------------------- - -propertyEx :: (Expr a b c -> Maybe Bool, ColExpr a b c -> Maybe Bool, BoolExpr a b c -> Maybe Bool) -> Expr a b c -> Bool -propertyEx f@(fi,fc,fb) t = case fi t of - Just a -> a - Nothing -> case t of - Plus a b -> propertyEx f a || propertyEx f b - Minus a b -> propertyEx f a || propertyEx f b - Mult a b -> propertyEx f a || propertyEx f b - Div a b -> propertyEx f a || propertyEx f b - Mod a b -> propertyEx f a || propertyEx f b - Abs a -> propertyEx f a - At a b -> propertyEx f b || colPropertyEx f a - ColSize a -> colPropertyEx f a - Fold _ _ _ -> True - Channel b -> boolPropertyEx f b - Cond c t e -> boolPropertyEx f c || propertyEx f t || propertyEx f e - _ -> False - -colPropertyEx :: (Expr a b c -> Maybe Bool, ColExpr a b c -> Maybe Bool, BoolExpr a b c -> Maybe Bool) -> ColExpr a b c -> Bool -colPropertyEx f@(fi,fc,fb) t = case fc t of - Just a -> a - Nothing -> case t of - ColList l -> any (propertyEx f) l - ColMap _ _ -> True - ColSlice p l c -> propertyEx f (p (ExprHole (-1))) || propertyEx f l || colPropertyEx f c - ColRange l h -> propertyEx f l || propertyEx f h - ColCat a b -> colPropertyEx f a || colPropertyEx f b - _ -> False - -boolPropertyEx :: (Expr a b c -> Maybe Bool, ColExpr a b c -> Maybe Bool, BoolExpr a b c -> Maybe Bool) -> BoolExpr a b c -> Bool -boolPropertyEx f@(fi,fc,fb) t = case fb t of - Just a -> a - Nothing -> case t of - BoolAnd a b -> boolPropertyEx f a || boolPropertyEx f b - BoolOr a b -> boolPropertyEx f a || boolPropertyEx f b - BoolNot a -> boolPropertyEx f a - BoolEqual a b -> boolPropertyEx f a || boolPropertyEx f b - Rel a _ b -> propertyEx f a || propertyEx f b - BoolAll _ _ -> True - BoolAny _ _ -> True - ColEqual a b -> colPropertyEx f a || colPropertyEx f b - AllDiff _ c -> colPropertyEx f c - Sorted _ c -> colPropertyEx f c - BoolCond c t e -> boolPropertyEx f c || boolPropertyEx f t || boolPropertyEx f e - Dom i c -> propertyEx f i || colPropertyEx f c - _ -> False - - -property :: (a -> Bool) -> (b -> Bool) -> (c -> Bool) -> Expr a b c -> Bool -property fit fct fbt = propertyEx (propInt fit, propCol fct, propBool fbt) -colProperty :: (a -> Bool) -> (b -> Bool) -> (c -> Bool) -> ColExpr a b c -> Bool -colProperty fit fct fbt = colPropertyEx (propInt fit, propCol fct, propBool fbt) -boolProperty :: (a -> Bool) -> (b -> Bool) -> (c -> Bool) -> BoolExpr a b c -> Bool -boolProperty fit fct fbt = boolPropertyEx (propInt fit, propCol fct, propBool fbt) - -propInt :: (a -> Bool) -> Expr a b c -> Maybe Bool -propInt ft t = case t of - Term x -> Just $ ft x - _ -> Nothing - -propCol :: (b -> Bool) -> ColExpr a b c -> Maybe Bool -propCol ft t = case t of - ColTerm x -> Just $ ft x - _ -> Nothing - -propBool :: (c -> Bool) -> BoolExpr a b c -> Maybe Bool -propBool ft t = case t of - BoolTerm x -> Just $ ft x - _ -> Nothing - - -------------------------------------------------------------------- --- | Count how many references to terms an expression contains | -- -------------------------------------------------------------------- - -varrefs :: Expr a b c -> Int -varrefs (Term _) = 1 -varrefs (Const _) = 0 -varrefs (ExprHole _) = 0 -varrefs (Plus a b) = varrefs a + varrefs b -varrefs (Minus a b) = varrefs a + varrefs b -varrefs (Mult a b) = varrefs a + varrefs b -varrefs (Div a b) = varrefs a + varrefs b -varrefs (Mod a b) = varrefs a + varrefs b -varrefs (Abs a) = varrefs a -varrefs (At c i) = varrefs i + colVarrefs c -varrefs (ColSize c) = colVarrefs c -varrefs (Fold f i c) = varrefs i + colVarrefs c + varrefs (f (ExprHole 0) (ExprHole 1)) -varrefs (Channel b) = boolVarrefs b -varrefs (Cond c t e) = boolVarrefs c + varrefs t + varrefs e - -colVarrefs :: ColExpr a b c -> Int -colVarrefs (ColTerm _) = 1 -colVarrefs (ColList lst) = sum $ map varrefs lst -colVarrefs (ColMap m c) = colVarrefs c + varrefs (m (ExprHole 0)) -colVarrefs (ColSlice p l c) = varrefs (p (ExprHole 0)) + varrefs l + colVarrefs c -colVarrefs (ColCat a b) = colVarrefs a + colVarrefs b -colVarrefs (ColRange a b) = varrefs a + varrefs b - -boolVarrefs :: BoolExpr a b c -> Int -boolVarrefs (BoolTerm _) = 1 -boolVarrefs (BoolConst _) = 0 -boolVarrefs (BoolAnd a b) = boolVarrefs a + boolVarrefs b -boolVarrefs (BoolOr a b) = boolVarrefs a + boolVarrefs b -boolVarrefs (BoolEqual a b) = boolVarrefs a + boolVarrefs b -boolVarrefs (BoolNot a) = boolVarrefs a -boolVarrefs (BoolAll f c) = boolVarrefs (f $ ExprHole 0) + colVarrefs c -boolVarrefs (BoolAny f c) = boolVarrefs (f $ ExprHole 0) + colVarrefs c -boolVarrefs (Rel a _ b) = varrefs a + varrefs b -boolVarrefs (ColEqual a b) = colVarrefs a + colVarrefs b -boolVarrefs (Sorted _ c) = colVarrefs c -boolVarrefs (AllDiff _ c) = colVarrefs c -boolVarrefs (BoolCond c t e) = boolVarrefs c + boolVarrefs t + boolVarrefs e -boolVarrefs (Dom i c) = varrefs i + colVarrefs c - ------------------------------- --- | Simplify expressions | -- ------------------------------- - -simplify :: (Eq s, Eq c, Eq b) => Expr s c b -> Expr s c b --- dropout rules (things that won't ever be changed) -simplify a@(Const _) = a -simplify a@(Term _) = a -simplify a@(ExprHole _) = a --- simplification rules (either decrease # of variable references, or leave that equal and decrease # of tree nodes) ---- level 0 (result in a final expression) -simplify (Mult a@(Const 0) _) = a -simplify (Div a@(Const 0) _) = a -simplify (Mod a@(Const 0) _) = a -simplify (Mod _ (Const 1)) = Const 0 -simplify (Mod _ (Const (-1))) = Const 0 -simplify (Mod (Mult (Const a) b) (Const c)) | (a `mod` c)==0 = Const 0 -simplify (Minus a b) | a==b = Const 0 -simplify (Plus (Const a) (Const b)) = Const (a+b) -simplify (Minus (Const a) (Const b)) = Const (a-b) -simplify (Mult (Const a) (Const b)) = Const (a*b) -simplify (Div (Const a) (Const b)) = Const $ (a `div` b) -simplify (Abs (Const a)) = Const (abs a) -simplify (Mod (Const a) (Const b)) = Const $ (a `mod` b) -simplify (Plus (Const 0) a) = a -simplify (Mult (Const 1) a) = a -simplify (Div a (Const 1)) = a -simplify (At (ColList l) (Const c)) = l!!(fromInteger c) -simplify (ColSize (ColList l)) = Const $ toInteger $ length l -simplify (ColSize (ColSlice _ l _)) = l -simplify (Channel (BoolConst False)) = Const 0 -simplify (Channel (BoolConst True)) = Const 1 -simplify (Cond (BoolConst True) t _) = t -simplify (Cond (BoolConst False) _ f) = f ---- level 1 (result in one recursive call to simplify) -simplify (Plus a b) | a==b = simplify $ Mult (Const 2) a -simplify (Div a (Const (-1))) = simplify $ Minus (Const 0) a -simplify (Plus (Const c) (Plus (Const a) b)) = simplify $ Plus (Const $ c+a) b -simplify (Plus (Const c) (Minus (Const a) b)) = simplify $ Minus (Const $ c+a) b -simplify (Minus (Const c) (Plus (Const a) b)) = simplify $ Minus (Const $ c-a) b -simplify (Minus (Const c) (Minus (Const a) b)) = simplify $ Plus (Const $ c-a) b -simplify (Mult (Const c) (Mult (Const a) b)) = simplify $ Mult (Const $ a*c) b -simplify (Div (Mult (Const a) b) (Const c)) | (a `mod` c)==0 = simplify $ Mult (Const (a `div` c)) b -simplify (ColSize (ColMap _ c)) = simplify $ ColSize c -simplify (Fold f1 i (ColMap f2 c)) = simplify $ Fold (\a b -> f1 a (f2 b)) i c -simplify (At (ColRange l h) p) = simplify $ Plus l p -simplify (Cond (BoolNot c) t f) = simplify $ Cond c f t ---- level 2 (result in two recursive calls to simplify) -simplify (Plus a (Mult b c)) | a==b && ((varrefs a)>0) = simplify $ Mult (simplify $ Plus c (Const 1)) a -simplify (Plus a (Mult b c)) | a==c && ((varrefs a)>0) = simplify $ Mult (simplify $ Plus b (Const 1)) a -simplify (Plus (Mult b c) a) | a==b && ((varrefs a)>0) = simplify $ Mult (simplify $ Plus c (Const 1)) a -simplify (Plus (Mult b c) a) | a==c && ((varrefs a)>0) = simplify $ Mult (simplify $ Plus b (Const 1)) a -simplify (Plus (Mult a b) (Mult c d)) | a==c = simplify $ Mult (simplify $ Plus b d) a -simplify (Plus (Mult a b) (Mult c d)) | a==d = simplify $ Mult (simplify $ Plus b c) a -simplify (Plus (Mult a b) (Mult c d)) | b==c = simplify $ Mult (simplify $ Plus a d) b -simplify (Plus (Mult a b) (Mult c d)) | b==d = simplify $ Mult (simplify $ Plus a c) b -simplify (Minus a (Mult b c)) | a==b && ((varrefs a)>0) = simplify $ Mult (simplify $ Minus (Const 1) c) a -simplify (Minus a (Mult b c)) | a==c && ((varrefs a)>0) = simplify $ Mult (simplify $ Minus (Const 1) b) a -simplify (Minus (Mult b c) a) | a==b && ((varrefs a)>0) = simplify $ Mult (simplify $ Minus c (Const 1)) a -simplify (Minus (Mult b c) a) | a==c && ((varrefs a)>0) = simplify $ Mult (simplify $ Minus b (Const 1)) a -simplify (Minus (Mult a b) (Mult c d)) | a==c = simplify $ Mult (simplify $ Minus b d) a -simplify (Minus (Mult a b) (Mult c d)) | a==d = simplify $ Mult (simplify $ Minus b c) a -simplify (Minus (Mult a b) (Mult c d)) | b==c = simplify $ Mult (simplify $ Minus a d) b -simplify (Minus (Mult a b) (Mult c d)) | b==d = simplify $ Mult (simplify $ Minus a c) b -simplify (Mult (Abs a) (Abs b)) = simplify $ Abs (simplify $ Mult a b) -simplify (Div (Abs a) (Abs b)) = simplify $ Abs (simplify $ Div a b) -simplify (ColSize (ColRange l h)) = simplify $ Plus (Const 1) $ simplify $ Minus h l -simplify (At (ColSlice f _ c) i) = simplify $ At c (f i) -simplify (At (ColMap m c) i) = simplify $ m $ simplify $ At c i -simplify t@(At (ColCat c1 c2) c@(Const p)) = case simplify (ColSize c1) of - Const l | p simplify $ At c1 c - Const l | p>=l -> simplify $ At c2 (Const $ p-l) - _ -> t {- no further (At _ _) rules may follow after this -} ---- level 3 (results in three recursive calls to simplify) -simplify (ColSize (ColCat a b)) = simplify $ Plus (simplify $ ColSize a) (simplify $ ColSize b) --- reordering rules (do not decrease # of variables or # of tree nodes, but normalize an expression in such a way that the same normalization cannot be applied anymore - possibly because that can only occur in a case already matched by a simplification rule above) ---- level 1 -simplify (Plus a (Const c)) = simplify $ Plus (Const c) a -simplify (Minus a (Const c)) = simplify $ Plus (Const (-c)) a -simplify (Mult a (Const c)) = simplify $ Mult (Const c) a -simplify (Mult (Const (-1)) a) = simplify $ Minus (Const 0) a ---- level 2 -simplify (Mult t@(Const c) (Plus (Const a) b)) = simplify $ Plus (Const (a*c)) (simplify $ Mult t b) -simplify (Mult t@(Const c) (Minus (Const a) b)) = simplify $ Minus (Const (a*c)) (simplify $ Mult t b) -simplify (Plus a (Plus t@(Const b) c)) = simplify $ Plus t (simplify $ Plus a c) -simplify (Plus a (Minus t@(Const b) c)) = simplify $ Plus t (simplify $ Minus a c) -simplify (Minus a (Plus (Const b) c)) = simplify $ Plus (Const (-b)) (simplify $ Minus a c) -simplify (Minus a (Minus (Const b) c)) = simplify $ Plus (Const (-b)) (simplify $ Plus a c) -simplify (Mult a (Mult t@(Const b) c)) = simplify $ Mult t (simplify $ Mult a c) -simplify (Plus (Plus t@(Const a) b) c) = simplify $ Plus t (simplify $ Plus b c) -simplify (Plus (Minus t@(Const a) b) c) = simplify $ Plus t (simplify $ Minus c b) -simplify (Minus (Plus t@(Const a) b) c) = simplify $ Plus t (simplify $ Minus b c) -simplify (Minus (Minus t@(Const a) b) c) = simplify $ Minus t (simplify $ Plus b c) -simplify (Mult (Mult t@(Const a) b) c) = simplify $ Mult t (simplify $ Mult b c) -simplify (Mult a (Minus t@(Const 0) b)) = simplify $ Minus t (simplify $ Mult a b) -simplify (Mult (Minus t@(Const 0) b) a) = simplify $ Minus t (simplify $ Mult a b) -simplify (Div (Minus t@(Const 0) a) b) = simplify $ Minus t (simplify $ Div a b) -simplify (Div a (Minus t@(Const 0) b)) = simplify $ Minus t (simplify $ Div a b) --- fallback rule -simplify a = a - -colSimplify :: (Eq s, Eq c, Eq b) => ColExpr s c b -> ColExpr s c b --- dropout rules -colSimplify t@(ColTerm _) = t --- simplify rules ---- level 1 -colSimplify (ColMap f1 (ColMap f2 c)) = colSimplify $ ColMap (f1.f2) c -colSimplify (ColMap f (ColList l)) = colSimplify $ ColList (map f l) ---- level 2 -colSimplify (ColSlice p1 l1 (ColSlice p2 l2 c)) = colSimplify $ ColSlice (p1 . p2) l1 c --- reordering rules ---- level 2 -colSimplify (ColCat (ColCat c1 c2) c3) = colSimplify $ ColCat c1 (colSimplify $ ColCat c2 c3) -colSimplify (ColSlice p l (ColMap f c)) = colSimplify $ ColMap f $ colSimplify $ ColSlice p l c --- fallback rule -colSimplify x = x - -boolSimplify :: (Eq s, Eq c, Eq b) => BoolExpr s c b -> BoolExpr s c b --- dropout rules -boolSimplify t@(BoolTerm _) = t -boolSimplify t@(BoolConst _) = t --- simplify rules ---- level 0 -boolSimplify (BoolAnd (BoolConst False) _) = BoolConst False -boolSimplify (BoolAnd (BoolConst True) a) = a -boolSimplify (BoolAnd _ (BoolConst False)) = BoolConst False -boolSimplify (BoolAnd a (BoolConst True)) = a -boolSimplify (BoolOr (BoolConst True) _) = BoolConst True -boolSimplify (BoolOr (BoolConst False) a) = a -boolSimplify (BoolOr _ (BoolConst True)) = BoolConst True -boolSimplify (BoolOr a (BoolConst False)) = a -boolSimplify (BoolNot (BoolConst a)) = BoolConst (not a) -boolSimplify (BoolEqual (BoolConst True) a) = a -boolSimplify (BoolEqual a (BoolConst True)) = a -boolSimplify (BoolNot (BoolNot a)) = a -boolSimplify (BoolOr a b) | a==b = a -boolSimplify (BoolAnd a b) | a==b = a -boolSimplify (BoolEqual a b) | a==b = BoolConst False -boolSimplify (Rel (Const a) r (Const b)) = BoolConst $ relCheck a r b -boolSimplify (BoolAll f (ColList [])) = BoolConst True -boolSimplify (BoolAny f (ColList [])) = BoolConst False -boolSimplify (BoolAll f (ColList [a])) = f a -boolSimplify (BoolAny f (ColList [a])) = f a -boolSimplify (ColEqual (ColList []) (ColList [])) = BoolConst True -boolSimplify (ColEqual (ColList []) (ColList _)) = BoolConst False -boolSimplify (ColEqual (ColList _) (ColList [])) = BoolConst False -boolSimplify (BoolCond (BoolConst True) t _) = t -boolSimplify (BoolCond (BoolConst False) _ f) = f ---- level 1 -boolSimplify (BoolEqual (BoolNot a) (BoolNot b)) = boolSimplify $ BoolEqual a b -boolSimplify (BoolEqual (BoolConst False) a) = boolSimplify $ BoolNot a -boolSimplify (BoolEqual a (BoolConst False)) = boolSimplify $ BoolNot a -boolSimplify (BoolNot (Rel a EREqual b)) = boolSimplify $ Rel a ERDiff b -boolSimplify (BoolNot (Rel a ERDiff b)) = boolSimplify $ Rel a EREqual b -boolSimplify (BoolAll f (ColList [a,b])) = boolSimplify $ f a `BoolAnd` f b -boolSimplify (BoolAny f (ColList [a,b])) = boolSimplify $ f a `BoolOr` f b -boolSimplify (ColEqual (ColList [a]) (ColList [b])) = boolSimplify $ Rel a EREqual b -boolSimplify (Rel (Channel a) EREqual (Channel b)) = boolSimplify $ BoolEqual a b -boolSimplify (BoolCond (BoolNot c) t f) = boolSimplify $ BoolCond c f t ---- level 2 -boolSimplify (BoolAnd (BoolNot a) (BoolNot b)) = boolSimplify $ BoolNot $ boolSimplify $ BoolOr a b -boolSimplify (BoolOr (BoolNot a) (BoolNot b)) = boolSimplify $ BoolNot $ boolSimplify $ BoolAnd a b -boolSimplify (Rel (Channel a) ERDiff (Channel b)) = boolSimplify $ BoolNot $ boolSimplify $ BoolEqual a b -boolSimplify (Rel (Channel a) ERLess (Channel b)) = boolSimplify $ BoolAnd b $ boolSimplify $ BoolNot a -- int(b1) < int(b2) <=> !b1 && b2 --- fallback -boolSimplify a = a - -------------------------------------------------------------------- --- | Turn expressions over expressions into simply expressions | -- -------------------------------------------------------------------- - -collapse :: (Eq t, Eq c, Eq b) => Expr (Expr t c b) (ColExpr t c b) (BoolExpr t c b) -> Expr t c b -collapse (Term t) = t -collapse (Const i) = Const i -collapse (Plus a b) = simplify $ Plus (collapse a) (collapse b) -collapse (Minus a b) = simplify $ Minus (collapse a) (collapse b) -collapse (Mult a b) = simplify $ Mult (collapse a) (collapse b) -collapse (Div a b) = simplify $ Div (collapse a) (collapse b) -collapse (Mod a b) = simplify $ Mod (collapse a) (collapse b) -collapse (Abs a) = simplify $ Abs (collapse a) -collapse (At c a) = simplify $ At (colCollapse c) (collapse a) -collapse (ColSize c) = simplify $ ColSize (colCollapse c) -collapse (Fold f i c) = simplify $ Fold (\a b -> collapse $ f (Term a) (Term b)) (collapse i) (colCollapse c) -collapse (Channel b) = simplify $ Channel (boolCollapse b) -collapse (Cond c t e) = simplify $ Cond (boolCollapse c) (collapse t) (collapse e) - -colCollapse :: (Eq t, Eq c, Eq b) => ColExpr (Expr t c b) (ColExpr t c b) (BoolExpr t c b) -> ColExpr t c b -colCollapse (ColTerm t) = t -colCollapse (ColList l) = colSimplify $ ColList $ map collapse l -colCollapse (ColMap f c) = colSimplify $ ColMap (\a -> collapse $ f (Term a)) (colCollapse c) -colCollapse (ColSlice p l c) = colSimplify $ ColSlice (\x -> collapse $ p (Term x)) (collapse l) (colCollapse c) -colCollapse (ColCat a b) = colSimplify $ ColCat (colCollapse a) (colCollapse b) -colCollapse (ColRange a b) = colSimplify $ ColRange (collapse a) (collapse b) - -boolCollapse :: (Eq t, Eq c, Eq b) => BoolExpr (Expr t c b) (ColExpr t c b) (BoolExpr t c b) -> BoolExpr t c b -boolCollapse (BoolTerm t) = t -boolCollapse (BoolConst c) = BoolConst c -boolCollapse (BoolAnd a b) = boolSimplify $ BoolAnd (boolCollapse a) (boolCollapse b) -boolCollapse (BoolOr a b) = boolSimplify $ BoolOr (boolCollapse a) (boolCollapse b) -boolCollapse (BoolEqual a b) = boolSimplify $ BoolEqual (boolCollapse a) (boolCollapse b) -boolCollapse (BoolNot a) = boolSimplify $ BoolNot (boolCollapse a) -boolCollapse (Rel a r b) = boolSimplify $ Rel (collapse a) r (collapse b) -boolCollapse (BoolAll f c) = boolSimplify $ BoolAll (\a -> boolCollapse $ f (Term a)) (colCollapse c) -boolCollapse (BoolAny f c) = boolSimplify $ BoolAny (\a -> boolCollapse $ f (Term a)) (colCollapse c) -boolCollapse (ColEqual a b) = boolSimplify $ ColEqual (colCollapse a) (colCollapse b) -boolCollapse (Sorted b c) = boolSimplify $ Sorted b (colCollapse c) -boolCollapse (AllDiff b c) = boolSimplify $ AllDiff b (colCollapse c) -boolCollapse (BoolCond c t e) = boolSimplify $ BoolCond (boolCollapse c) (boolCollapse t) (boolCollapse e) -boolCollapse (Dom i c) = boolSimplify $ Dom (collapse i) (colCollapse c) - ------------------------------------------ --- | walk through expressions ------------------------------------------ - -data WalkPhase = WalkPre | WalkSingle | WalkPost - deriving (Ord,Eq,Enum,Show) - -data WalkResult = WalkSkip | WalkDescend - deriving (Ord,Eq,Enum,Show) - -xwalker :: (Eq t, Eq c, Eq b, Monad m) => (WalkPhase -> m WalkResult) -> (Expr t c b -> WalkPhase -> m WalkResult, ColExpr t c b -> WalkPhase -> m WalkResult, BoolExpr t c b -> WalkPhase -> m WalkResult) -> ([Expr t c b],[ColExpr t c b],[BoolExpr t c b]) -> m () -xwalker q f ([],[],[]) = do - q WalkSingle - return () -xwalker q f (li,lc,lb) = do - r <- q WalkPre - case r of - WalkSkip -> return () - WalkDescend -> do - mapM_ (\p -> walk p f) li - mapM_ (\p -> colWalk p f) lc - mapM_ (\p -> boolWalk p f) lb - q WalkPost - return () - -walker :: (Eq t, Eq c, Eq b, Monad m) => Expr t c b -> (Expr t c b -> WalkPhase -> m WalkResult, ColExpr t c b -> WalkPhase -> m WalkResult, BoolExpr t c b -> WalkPhase -> m WalkResult) -> ([Expr t c b],[ColExpr t c b],[BoolExpr t c b]) -> m () -walker x f@(i,c,b) l = xwalker (i x) f l -colWalker :: (Eq t, Eq c, Eq b, Monad m) => ColExpr t c b -> (Expr t c b -> WalkPhase -> m WalkResult, ColExpr t c b -> WalkPhase -> m WalkResult, BoolExpr t c b -> WalkPhase -> m WalkResult) -> ([Expr t c b],[ColExpr t c b],[BoolExpr t c b]) -> m () -colWalker x f@(i,c,b) l = xwalker (c x) f l -boolWalker :: (Eq t, Eq c, Eq b, Monad m) => BoolExpr t c b -> (Expr t c b -> WalkPhase -> m WalkResult, ColExpr t c b -> WalkPhase -> m WalkResult, BoolExpr t c b -> WalkPhase -> m WalkResult) -> ([Expr t c b],[ColExpr t c b],[BoolExpr t c b]) -> m () -boolWalker x f@(i,c,b) l = xwalker (b x) f l - -walk :: (Eq t, Eq c, Eq b, Monad m) => Expr t c b -> (Expr t c b -> WalkPhase -> m WalkResult, ColExpr t c b -> WalkPhase -> m WalkResult, BoolExpr t c b -> WalkPhase -> m WalkResult) -> m () -walk x@(Term _) f = walker x f ([],[],[]) -walk x@(Const _) f = walker x f ([],[],[]) -walk x@(Plus a b) f = walker x f ([a,b],[],[]) -walk x@(Minus a b) f = walker x f ([a,b],[],[]) -walk x@(Mult a b) f = walker x f ([a,b],[],[]) -walk x@(Div a b) f = walker x f ([a,b],[],[]) -walk x@(Mod a b) f = walker x f ([a,b],[],[]) -walk x@(Abs a) f = walker x f ([a],[],[]) -walk x@(At c a) f = walker x f ([a],[c],[]) -walk x@(ColSize c) f = walker x f ([],[c],[]) -walk x@(Fold _ i c) f = walker x f ([i],[c],[]) -walk x@(Channel b) f = walker x f ([],[],[b]) -walk x@(Cond c t e) f = walker x f ([t,e],[],[c]) -walk x@(ExprHole _) f = return () - -colWalk x@(ColTerm _) f = colWalker x f ([],[],[]) -colWalk x@(ColList l) f = colWalker x f (l,[],[]) -colWalk x@(ColMap _ c) f = colWalker x f ([],[c],[]) -colWalk x@(ColSlice _ l c) f = colWalker x f ([l],[c],[]) -colWalk x@(ColCat a b) f = colWalker x f ([],[a,b],[]) -colWalk x@(ColRange a b) f = colWalker x f ([a,b],[],[]) - -boolWalk x@(BoolTerm _) f = boolWalker x f ([],[],[]) -boolWalk x@(BoolConst _) f = boolWalker x f ([],[],[]) -boolWalk x@(BoolAnd a b) f = boolWalker x f ([],[],[a,b]) -boolWalk x@(BoolOr a b) f = boolWalker x f ([],[],[a,b]) -boolWalk x@(BoolEqual a b) f = boolWalker x f ([],[],[a,b]) -boolWalk x@(BoolNot a) f = boolWalker x f ([],[],[a]) -boolWalk x@(Rel a _ b) f = boolWalker x f ([a,b],[],[]) -boolWalk x@(BoolAll _ c) f = boolWalker x f ([],[c],[]) -boolWalk x@(BoolAny _ c) f = boolWalker x f ([],[c],[]) -boolWalk x@(ColEqual a b) f = boolWalker x f ([],[a,b],[]) -boolWalk x@(Sorted _ c) f = boolWalker x f ([],[c],[]) -boolWalk x@(AllDiff _ c) f = boolWalker x f ([],[c],[]) -boolWalk x@(BoolCond c t e) f = boolWalker x f ([],[],[c,t,e]) -boolWalk x@(Dom i c) f = boolWalker x f ([i],[c],[]) - diff --git a/Data/Linear.hs b/Data/Linear.hs deleted file mode 100644 --- a/Data/Linear.hs +++ /dev/null @@ -1,82 +0,0 @@ -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE StandaloneDeriving #-} -{-# LANGUAGE ScopedTypeVariables #-} - -module Data.Linear ( - Linear, - integerToLinear, - constToLinear, - termToLinear, --- linearOpLinear, --- linearOpLinears, - linearToConst, - linearToTerm, - linearMultiply, - linearMult, - linearToList, linearToListEx, - getCoef, -) where - -import qualified Data.Map as Map -import Data.Map(Map) - -data (Ord t, Num v) => Linear t v = Linear v (Map t v) - -deriving instance (Num v, Eq v, Ord t, Eq t) => Eq (Linear t v) -deriving instance (Num v, Ord v, Ord t, Eq t) => Ord (Linear t v) -deriving instance (Num v, Show v, Ord t, Show t) => Show (Linear t v) - -termToLinear :: (Num v, Ord t) => t -> Linear t v -termToLinear x = Linear 0 $ Map.singleton x 1 - -integerToLinear :: (Num v, Ord t) => Integer -> Linear t v -integerToLinear = constToLinear . fromInteger - -constToLinear :: (Num v, Ord t) => v -> Linear t v -constToLinear x = Linear x Map.empty - --- linearOpLinear :: (Num v, Ord t) => v -> Linear t v -> v -> Linear t v -> Linear t v --- linearOpLinear a (Linear ac am) b (Linear bc bm) = Linear (a*ac+b*bc) $ Map.filter (/=0) $ Map.unionWith (\ax bx -> ax*a+bx*b) am bm - --- linearOpLinears :: (Num v, Ord t) => [(v,Linear t v)] -> Linear t v --- linearOpLinears l = foldr (\(c,t) a -> linearOpLinear 1 a c t) (integerToLinear 0) l - -linearToList :: (Ord t, Num v) => Linear t v -> [(Maybe t,v)] -linearToList (Linear c m) = [(Nothing,c)] ++ (map (\(a,b) -> (Just a,b)) $ Map.toList m) - -linearToListEx :: (Ord t, Num v) => Linear t v -> (v,[(t,v)]) -linearToListEx (Linear c m) = (c,Map.toList m) - -getCoef :: (Num v, Ord t) => Maybe t -> Linear t v -> v -getCoef Nothing (Linear c _) = c -getCoef (Just t) (Linear _ m) = Map.findWithDefault 0 t m - -linearMult :: (Num v, Eq v, Ord t) => v -> Linear t v -> Linear t v -linearMult m (Linear ac am) = Linear (m*ac) $ if (m==0) then Map.empty else Map.filter (/=0) $ Map.map (m*) am - -linearMultiply :: (Num v, Eq v, Ord t) => Linear t v -> Linear t v -> Maybe (Linear t v) -linearMultiply (Linear ac am) bl | (Map.null am) = Just $ linearMult ac bl -linearMultiply bl (Linear ac am) | (Map.null am) = Just $ linearMult ac bl -linearMultiply _ _ = Nothing - -linearToConst :: (Num v, Ord t) => Linear t v -> Maybe v -linearToConst (Linear c m) | Map.null m = Just c -linearToConst _ = Nothing - -linearToTerm :: (Num v, Eq v, Ord t) => Linear t v -> Maybe t -linearToTerm (Linear c m) | (c==0 && (Map.size m)==1) = - let (t,v) = Map.findMin m - in if (v==1) then Just t else Nothing -linearToTerm _ = Nothing - -instance (Num v, Eq v, Ord t, Eq t, Show t) => Num (Linear t v) where - (Linear ac am) + (Linear bc bm) = Linear (ac+bc) $ Map.filter (/=0) $ Map.unionWith (+) am bm - (Linear ac am) - (Linear bc bm) = Linear (ac-bc) $ Map.filter (/=0) $ Map.unionWith (+) am $ Map.map negate bm - a * b = case linearMultiply a b of Just x -> x; Nothing -> error "Cannot multiply generic linear expressions" - negate (Linear ac am) = Linear (-ac) $ Map.map negate am - abs (Linear ac am) | (Map.null am) = Linear (abs ac) Map.empty - abs _ = error "Cannot take abs of generic linear expressions" - signum (Linear ac am) | (Map.null am) = Linear (signum ac) Map.empty - signum _ = error "Cannot take signum of generic linear expressions" - fromInteger x = integerToLinear x diff --git a/LICENSE b/LICENSE --- a/LICENSE +++ b/LICENSE @@ -1,26 +1,26 @@ -Redistribution and use in source and binary forms, with or without -modification, are permitted provided that the following conditions -are met: - -Redistributions of source code must retain the above copyright -notice, this list of conditions and the following disclaimer. - -Redistributions in binary form must reproduce the above copyright -notice, this list of conditions and the following disclaimer in the -documentation and/or other materials provided with the distribution. - -The names of its contributors may not be used to endorse or promote products -derived from this software without specific prior written permission. - -THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS -"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT -LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR -A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR -CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, -EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, -PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR -PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF -LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING -NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS -SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. - +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions +are met: + +Redistributions of source code must retain the above copyright +notice, this list of conditions and the following disclaimer. + +Redistributions in binary form must reproduce the above copyright +notice, this list of conditions and the following disclaimer in the +documentation and/or other materials provided with the distribution. + +The names of its contributors may not be used to endorse or promote products +derived from this software without specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT +LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR +A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR +CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, +EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, +PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR +PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF +LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING +NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS +SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. + diff --git a/Language/CPP/Pretty.hs b/Language/CPP/Pretty.hs deleted file mode 100644 --- a/Language/CPP/Pretty.hs +++ /dev/null @@ -1,241 +0,0 @@ -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE TypeSynonymInstances #-} - -module Language.CPP.Pretty ( - codegen -) where - -import Text.PrettyPrint.HughesPJ -import Language.CPP.Syntax.AST - -class Pretty t where - pretty :: t -> Doc - prettyPrec :: Int -> t -> Doc - pretty = prettyPrec 0 - prettyPrec _ = pretty - -class ToString t where - toString :: t -> String - -instance ToString CPPAssignOp where - toString x = case x of - CPPAssOp -> "=" - CPPAssOpMul -> "*=" - CPPAssOpDiv -> "/=" - CPPAssOpRmd -> "%=" - CPPAssOpAdd -> "+=" - CPPAssOpSub -> "-=" - CPPAssOpShl -> "<<=" - CPPAssOpShr -> ">>=" - CPPAssOpAnd -> "&=" - CPPAssOpOr -> "|=" - CPPAssOpXor -> "^=" - -{- - Priorities in C (http://www.difranco.net/cop2220/op-prec.htm) - - 2: comma - 4: assignments - 6: conditional - 8: logical or - 10: logical and - 12: bitwise or - 14: bitwise xor - 16: bitwise and - 18: equality/inequality test - 20: relational tests - 22: bitshift - 24: addition/subtraction - 26: multiplication/division/modulus - 28: preincrement/predecrement/negation/complement/cast/dereference/address/sizeof - 30: brackets/index/member/postincrement/postdecrement/ --} - - -instance Pretty CPPConst where - pretty (CPPConstInt x) = text $ show x - pretty (CPPConstChar x) = text $ "'" ++ x ++ "'" -- TODO: character escaping - pretty (CPPConstString x) = text $ "\"" ++ x ++ "\"" - pretty (CPPConstFloat x) = text x - -prio :: Int -> Int -> Doc -> Doc -prio myL outerL doc = if myL (text $ toString op) <+> (prettyPrec 4 o2) - prettyPrec l (CPPVar v) = text v - prettyPrec l (CPPComma lst) = lparen <> (foldl (<>) empty $ punctuate comma $ map (prettyPrec 2) lst) <> rparen - prettyPrec l (CPPBinary o1 CPPOpMul o2) = prio 26 l $ (prettyPrec 26 o1) <> text "*" <> (prettyPrec 27 o2) - prettyPrec l (CPPBinary o1 CPPOpDiv o2) = prio 26 l $ (prettyPrec 26 o1) <> text "/" <> (prettyPrec 27 o2) - prettyPrec l (CPPBinary o1 CPPOpRmd o2) = prio 26 l $ (prettyPrec 26 o1) <> text "%" <> (prettyPrec 27 o2) - prettyPrec l (CPPBinary o1 CPPOpAdd o2) = prio 24 l $ (prettyPrec 24 o1) <> text "+" <> (prettyPrec 24 o2) - prettyPrec l (CPPBinary o1 CPPOpSub o2) = prio 24 l $ (prettyPrec 24 o1) <> text "-" <> (prettyPrec 25 o2) - prettyPrec l (CPPBinary o1 CPPOpShl o2) = prio 22 l $ (prettyPrec 22 o1) <> text "<<" <> (prettyPrec 23 o2) - prettyPrec l (CPPBinary o1 CPPOpShr o2) = prio 22 l $ (prettyPrec 22 o1) <> text ">>" <> (prettyPrec 23 o2) - prettyPrec l (CPPBinary o1 CPPOpLe o2) = prio 20 l $ (prettyPrec 20 o1) <> text "<" <> (prettyPrec 21 o2) - prettyPrec l (CPPBinary o1 CPPOpGr o2) = prio 20 l $ (prettyPrec 20 o1) <> text ">" <> (prettyPrec 21 o2) - prettyPrec l (CPPBinary o1 CPPOpGeq o2) = prio 20 l $ (prettyPrec 20 o1) <> text ">=" <> (prettyPrec 21 o2) - prettyPrec l (CPPBinary o1 CPPOpLeq o2) = prio 20 l $ (prettyPrec 20 o1) <> text "<=" <> (prettyPrec 21 o2) - prettyPrec l (CPPBinary o1 CPPOpEq o2) = prio 18 l $ (prettyPrec 18 o1) <> text "==" <> (prettyPrec 19 o2) - prettyPrec l (CPPBinary o1 CPPOpNeq o2) = prio 18 l $ (prettyPrec 18 o1) <> text "!=" <> (prettyPrec 19 o2) - prettyPrec l (CPPBinary o1 CPPOpAnd o2) = prio 16 l $ (prettyPrec 16 o1) <> text "&" <> (prettyPrec 16 o2) - prettyPrec l (CPPBinary o1 CPPOpXor o2) = prio 14 l $ (prettyPrec 14 o1) <> text "^" <> (prettyPrec 14 o2) - prettyPrec l (CPPBinary o1 CPPOpOr o2) = prio 12 l $ (prettyPrec 12 o1) <> text "|" <> (prettyPrec 12 o2) - prettyPrec l (CPPBinary o1 CPPOpLAnd o2) = prio 10 l $ (prettyPrec 10 o1) <> text "&&" <> (prettyPrec 10 o2) - prettyPrec l (CPPBinary o1 CPPOpLOr o2) = prio 8 l $ (prettyPrec 8 o1) <> text "||" <> (prettyPrec 8 o2) - prettyPrec l (CPPUnary CPPOpPreInc o) = prio 28 l $ text "++" <> (prettyPrec 28 o ) - prettyPrec l (CPPUnary CPPOpPreDec o) = prio 28 l $ text "--" <> (prettyPrec 28 o ) - prettyPrec l (CPPUnary CPPOpPostInc o) = prio 28 l $ (prettyPrec 28 o ) <> text "++" - prettyPrec l (CPPUnary CPPOpPostDec o) = prio 28 l $ (prettyPrec 28 o ) <> text "--" - prettyPrec l (CPPUnary CPPOpAdr o) = prio 28 l $ text "&" <> (prettyPrec 28 o ) - prettyPrec l (CPPUnary CPPOpInd o) = prio 28 l $ text "*" <> (prettyPrec 28 o ) - prettyPrec l (CPPUnary CPPOpPlus o) = prio 28 l $ text "+" <> (prettyPrec 28 o ) - prettyPrec l (CPPUnary CPPOpMinus o) = prio 28 l $ text "-" <> (prettyPrec 28 o ) - prettyPrec l (CPPUnary CPPOpComp o) = prio 28 l $ text "~" <> (prettyPrec 28 o ) - prettyPrec l (CPPUnary CPPOpNeg o) = prio 28 l $ text "!" <> (prettyPrec 28 o ) - prettyPrec l (CPPCond c (Just t) f) = prio 6 l $ (prettyPrec 7 c ) <+> text "?" <+> (prettyPrec 7 t ) <+> text ":" <+> (prettyPrec 6 f) - prettyPrec l (CPPCond c Nothing t) = prio 6 l $ (prettyPrec 7 c ) <> text "?:" <> (prettyPrec 6 t ) - prettyPrec l (CPPCast t e) = prio 28 l $ lparen <> (pretty t) <> rparen <> (prettyPrec 28 e ) - prettyPrec l (CPPSizeOfExpr e) = prio 28 l $ text "sizeof" <> lparen <> (pretty e) <> rparen - prettyPrec l (CPPSizeOfType t) = prio 28 l $ text "sizeof" <> lparen <> (pretty t) <> rparen - prettyPrec l (CPPIndex a b) = prio 28 l $ (prettyPrec 28 a) <> lbrack <> (pretty b) <> rbrack - prettyPrec l (CPPCall a b) = prio 28 l $ (prettyPrec 28 a) <> lparen <> (hcat $ punctuate comma $ map pretty b) <> rparen - prettyPrec l (CPPMember a m False) = prio 28 l $ (prettyPrec 28 a) <> text "." <> text m - prettyPrec l (CPPMember a m True) = prio 28 l $ (prettyPrec 28 a) <> text "->" <> text m - prettyPrec l (CPPNew a b) = prio 28 l $ text "new" <+> (pretty a) <> lparen <> (hcat $ punctuate comma $ map pretty b) <> rparen - -instance Pretty s => Pretty (Maybe s) where - prettyPrec _ Nothing = empty - prettyPrec l (Just x) = prettyPrec l x - -instance (Pretty a, Pretty b) => Pretty (Either a b) where - prettyPrec l (Left x) = prettyPrec l x - prettyPrec l (Right x) = prettyPrec l x - -instance Pretty CPPStat where - pretty (CPPLabel s b) = (nest (-1000) $ (text s) <> char ':') $$ pretty b - pretty (CPPCase x b) = (text "case" <+> pretty x <> char ':') $+$ (nest 2 (pretty b)) - pretty (CPPDefault b) = (text "default:") $+$ (nest 2 $ pretty b) - pretty (CPPSimple x) = (pretty x) <> char ';' - pretty (CPPCompound []) = empty - pretty (CPPCompound [CPPStatement (c@(CPPCompound _))]) = pretty c - pretty (CPPCompound [CPPStatement (c@(CPPVerbStat _))]) = pretty c - pretty (CPPCompound [CPPStatement a]) = pretty a - pretty (CPPCompound l) = lbrace $+$ (nest 2 $ vcat $ map pretty l) $+$ rbrace - pretty (CPPIf c t (Just f)) = text "if" <+> parens (pretty c) <+> braces (pretty t) <+> text "else" <+> braces (pretty f) - pretty (CPPIf c t Nothing) = text "if" <+> parens (pretty c) <+> braces (pretty t) - pretty (CPPSwitch x b) = text "switch (" <> pretty x <> text ") {" <+> pretty b <+> text "}" - pretty (CPPWhile x False b) = text "while" <> (parens $ pretty x) <+> (braces $ pretty b) - pretty (CPPWhile x True b) = text "do" <+> (braces $ pretty b) <+> text "while" <> (parens $ pretty x) <> semi - pretty (CPPFor f1 f2 f3 b) = text "for (" <> pretty f1 <> text ";" <+> pretty f2 <> text ";" <+> pretty f3 <> text ") {" $+$ nest 2 (pretty b) $+$ text "}" - pretty (CPPGoto l) = text ("goto " ++ l ++ ";") - pretty (CPPCont) = text "continue;" - pretty (CPPBreak) = text "break;" - pretty (CPPReturn x) = (text "return" <+> pretty x) <> text ";" - pretty (CPPDelete x) = (text "delete" <+> pretty x) <> text ";" - pretty (CPPVerbStat l) = lbrace $+$ (nest 2 $ vcat $ map text l) $+$ rbrace - -instance Pretty CPPQual where - pretty (CPPQualConst) = text "const" - pretty (CPPQualVolatile) = text "volatile" - -instance Pretty CPPStorSpec where - pretty (CPPAuto) = text "auto" - pretty (CPPRegister) = text "register" - pretty (CPPStatic) = text "static" - pretty (CPPExtern) = text "extern" - pretty (CPPTypedef) = text "typedef" - pretty (CPPInline) = text "inline" - pretty (CPPVirtual) = text "virtual" - -instance Pretty a => Pretty [a] where - pretty [] = empty - pretty [a] = pretty a - pretty (a:b) = pretty a <+> pretty b - -instance Pretty CPPVisibility where - pretty CPPPublic = text "public" - pretty CPPPrivate = text "private" - pretty CPPProtected = text "protected" - -instance Pretty (CPPType,Doc,Int,[CPPQual]) where - pretty (CPPPtr qual typ,s,l,q) = pretty (typ,char '*' <> (pretty q <+> (prio 4 l s)),4::Int,qual) - pretty (CPPRef qual typ,s,l,q) = pretty (typ,char '&' <> (pretty q <+> (prio 4 l s)),4::Int,qual) - pretty (CPPArray qual typ len,s,l,_) = pretty (typ,((prio 2 l s) <> lbrack <> pretty len <> rbrack),2::Int,qual) - pretty (CPPTypePrim prim,s,l,q) = pretty q <+> (text prim <+> s) - pretty (CPPTempl prim lst,s,l,q) = pretty q <+> (text prim <> char '<' <> (hcat $ punctuate comma $ map pretty lst) <> char '>') <+> s - -instance Pretty (CPPType,Doc) where - pretty (typ,doc) = pretty (typ,doc,0 :: Int,[]::[CPPQual]) - -instance Pretty CPPType where - pretty x = pretty (x,empty) - -prettyString Nothing = empty -prettyString (Just x) = text x - -instance Pretty CPPDecl where - pretty (CPPDecl { cppDeclName=name, cppType = typ, cppTypeQual = qual, cppTypeStor = stor, cppDeclInit=Nothing }) = pretty stor <+> pretty (typ,prettyString name,0 :: Int,qual) - pretty (CPPDecl { cppDeclName=name, cppType = typ, cppTypeQual = qual, cppTypeStor = stor, cppDeclInit=Just (CPPInitValue code) }) = pretty stor <+> pretty (typ,prettyString name,0 :: Int,qual) <> char '=' <> pretty code - pretty (CPPDecl { cppDeclName=name, cppType = typ, cppTypeQual = qual, cppTypeStor = stor, cppDeclInit=Just (CPPInitCall args) }) = pretty stor <+> pretty (typ,prettyString name,0 :: Int,qual) <> lparen <> (hcat $ punctuate comma $ map pretty args) <> rparen - pretty (CPPDecl { cppDeclName=name, cppType = typ, cppTypeQual = qual, cppTypeStor = stor, cppDeclInit=Just (CPPInitArray args) }) = pretty stor <+> pretty (typ,prettyString name,0 :: Int,qual) <> char '=' <> lbrace <> (hcat $ punctuate comma $ map pretty args) <> rbrace - -instance Pretty CPPDef where - pretty (CPPDef { cppDefName=name, cppDefRetType=typ, cppDefStor=stor, cppDefArgs=args, cppDefBody = body, cppDefQual=qual }) = - let pre = (pretty stor <+> pretty (typ, text name)) <> parens (hcat $ punctuate comma $ map pretty args) <+> (hsep $ map pretty qual) - in case body of - Nothing -> pre <> text ";" - Just b -> pre <+> text "{" $+$ (nest 2 $ pretty b) $+$ text "}" - -instance Pretty (CPPConstr,String) where - pretty (CPPConstr { cppConstrStor=stor, cppConstrArgs=args, cppConstrBody=body, cppConstrInit=ini },name) = - let pre = (pretty stor <+> text name) <> parens (hcat $ punctuate comma $ map pretty args) - init [] = empty - init lst = colon <+> (hcat $ punctuate (text ", ") $ map (\(tp,args) -> pretty tp <> (parens $ hcat $ punctuate comma $ map pretty args)) lst) - in case body of - Nothing -> (pre <+> init ini) <> text ";" - Just b -> (pre <+> init ini) <+> text "{" $+$ (nest 2 $ pretty b) $+$ text "}" - -instance Pretty CPPBlockItem where - pretty (CPPStatement stat) = pretty stat - pretty (CPPBlockDecl decl) = pretty decl <> text ";" - pretty (CPPComment str) = text "//" <+> text str - -instance Pretty CPPMacroStm where - pretty (CPPMacroIncludeUser str) = text "#include" <+> (text $ "\"" ++ str ++"\"") - pretty (CPPMacroIncludeSys str) = text "#include" <+> (text $ "<" ++ str ++ ">") - pretty (CPPMacroDefine { cppMacroDefName = name, cppMacroDefArgs = Nothing, cppMacroDefExpr = expr }) = text "#define" <+> text name <+> text expr - pretty (CPPMacroDefine { cppMacroDefName = name, cppMacroDefArgs = Just lst, cppMacroDefExpr = expr }) = text $ "#define " ++ name ++ "(" ++ (foldr1 (\a b -> a++","++b) lst) ++ ")" ++ " " ++ expr - -instance Pretty CPPElement where - pretty (CPPElemNamespace (name,ns)) = (text "namespace" <+> text name <+> lbrace) $+$ nest 2 (pretty ns) $+$ rbrace - pretty (CPPElemDecl decl) = pretty decl <> semi - pretty (CPPElemDef def) = pretty def - pretty (CPPElemClass cls) = pretty cls - -instance Pretty CPPNamespace where - pretty (CPPNamespace list) = vcat $ map (\x -> pretty x $+$ char ' ') list - -instance Pretty CPPClass where - pretty (CPPClass { cppClassName = name, cppClassInherit = inh, cppClassDecls = decls, cppClassDefs = defs, cppClassConstrs = constrs }) = - let sel vis lst = map snd $ filter (\x -> fst x == vis) lst - inhh [] = empty - inhh lst = colon <+> (hcat $ punctuate (text ", ") $ map (\(vis,tp) -> pretty vis <+> pretty tp) lst) - decl vis = case sel vis decls of - [] -> empty - lst -> (nest (-2) (pretty vis) <> char ':') $+$ vcat (map (\x -> pretty x <> semi) lst) $+$ text " " - def vis = case sel vis defs of - [] -> empty - lst -> (nest (-2) (pretty vis) <> char ':') $+$ vcat (map pretty lst) $+$ text " " - constr vis = case sel vis constrs of - [] -> empty - lst -> (nest (-2) (pretty vis) <> char ':') $+$ vcat (map (\x -> pretty (x,name)) lst) $+$ text " " - comb vis = constr vis $+$ def vis - in (text "class" <+> text name <+> inhh inh <+> char '{') $+$ nest 2 (decl CPPPrivate $+$ decl CPPProtected $+$ decl CPPPublic $+$ comb CPPPrivate $+$ comb CPPProtected $+$ comb CPPPublic) $+$ char '}' <> semi - -instance Pretty CPPFile where - pretty (CPPFile { cppMacroStm = macro, cppUsing = using, cppTranslUnit = unit }) = vcat (map pretty macro) $+$ text " " $+$ vcat (map (\x -> text "using" <+> text "namespace" <+> text x <> semi) using) $+$ text " " $+$ pretty unit - -codegen :: Pretty x => x -> String -codegen = render . pretty diff --git a/Language/CPP/Syntax/AST.hs b/Language/CPP/Syntax/AST.hs deleted file mode 100644 --- a/Language/CPP/Syntax/AST.hs +++ /dev/null @@ -1,174 +0,0 @@ --- AST for C++ code - -{- based on: - language-c-0.3.1.1: Analysis and generation of C code - Language.C.Syntax.AST - - Abstract syntax of C++ source and header files. --} - -module Language.CPP.Syntax.AST where - -data CPPFile = CPPFile { cppMacroStm :: [CPPMacroStm], cppUsing :: [String], cppTranslUnit :: CPPNamespace } - deriving (Eq,Ord,Show) - -data CPPMacroStm = - CPPMacroIncludeUser String - | CPPMacroIncludeSys String - | CPPMacroDefine { cppMacroDefName:: String, cppMacroDefArgs :: Maybe [String], cppMacroDefExpr :: String } - deriving (Eq,Ord,Show) - -data CPPElement = - CPPElemNamespace (String,CPPNamespace) - | CPPElemDecl CPPDecl - | CPPElemDef CPPDef - | CPPElemClass CPPClass - deriving (Eq,Ord,Show) - -data CPPNamespace = CPPNamespace [CPPElement] - deriving (Eq,Ord,Show) - -data CPPClass = CPPClass { cppClassName :: String, cppClassInherit :: [(CPPVisibility,CPPType)], cppClassDecls :: [(CPPVisibility,CPPDecl)], cppClassDefs :: [(CPPVisibility,CPPDef)], cppClassConstrs :: [(CPPVisibility,CPPConstr)] } - deriving (Eq,Ord,Show) - -data CPPVisibility = - CPPPublic - | CPPProtected - | CPPPrivate - deriving (Eq,Ord,Show) - --- TODO: function pointers --- TODO: struct/union/enum -data CPPType = - CPPTypePrim String - | CPPArray [CPPQual] CPPType (Maybe CPPExpr) - | CPPPtr [CPPQual] CPPType - | CPPRef [CPPQual] CPPType - | CPPTempl String [CPPType] - deriving (Eq,Ord,Show) - -data CPPStorSpec = - CPPAuto - | CPPRegister - | CPPStatic - | CPPExtern - | CPPTypedef - | CPPInline - | CPPVirtual - deriving (Eq,Ord,Show) - -data CPPQual = - CPPQualConst - | CPPQualVolatile - deriving (Eq,Ord,Show) - -data CPPInit = - CPPInitValue CPPExpr - | CPPInitCall [CPPExpr] - | CPPInitArray [CPPExpr] - deriving (Eq,Ord,Show) - -data CPPDecl = CPPDecl { cppDeclName :: Maybe String, cppType :: CPPType, cppTypeQual :: [CPPQual], cppTypeStor :: [CPPStorSpec], cppDeclInit :: Maybe CPPInit } - deriving (Eq,Ord,Show) - -data CPPDef = CPPDef { cppDefName :: String, cppDefRetType :: CPPType, cppDefStor :: [CPPStorSpec], cppDefQual :: [CPPQual], cppDefArgs :: [CPPDecl], cppDefBody :: Maybe CPPStat } - deriving (Eq,Ord,Show) - -data CPPConstr = CPPConstr { cppConstrStor :: [CPPStorSpec], cppConstrArgs :: [CPPDecl], cppConstrBody :: Maybe CPPStat, cppConstrInit :: [(Either CPPExpr CPPType,[CPPExpr])] } - deriving (Eq,Ord,Show) - -data CPPStat = - CPPLabel String CPPStat - | CPPCase CPPExpr CPPStat - | CPPDefault CPPStat - | CPPSimple CPPExpr - | CPPCompound [CPPBlockItem] - | CPPVerbStat [String] - | CPPIf CPPExpr CPPStat (Maybe CPPStat) - | CPPSwitch CPPExpr CPPStat - | CPPWhile CPPExpr Bool CPPStat - | CPPFor (Either (Maybe CPPExpr) CPPDecl) (Maybe CPPExpr) (Maybe CPPExpr) CPPStat - | CPPGoto String - | CPPCont - | CPPBreak - | CPPReturn (Maybe CPPExpr) - | CPPDelete CPPExpr - deriving (Eq,Ord,Show) - -data CPPBlockItem = - CPPStatement CPPStat - | CPPBlockDecl CPPDecl - | CPPComment String - deriving (Eq,Ord,Show) - -data CPPExpr = - CPPComma [CPPExpr] - | CPPAssign CPPExpr CPPAssignOp CPPExpr - | CPPBinary CPPExpr CPPBinaryOp CPPExpr - | CPPUnary CPPUnaryOp CPPExpr - | CPPCond CPPExpr (Maybe CPPExpr) CPPExpr - | CPPCast CPPType CPPExpr - | CPPSizeOfExpr CPPExpr - | CPPSizeOfType CPPType - | CPPIndex CPPExpr CPPExpr - | CPPCall CPPExpr [CPPExpr] - | CPPMember CPPExpr String Bool - | CPPVar String - | CPPConst CPPConst - | CPPNew CPPType [CPPExpr] - deriving (Eq,Ord,Show) - -data CPPConst = - CPPConstInt Integer - | CPPConstChar String - | CPPConstFloat String - | CPPConstString String - deriving (Eq,Ord,Show) - -data CPPAssignOp = - CPPAssOp - | CPPAssOpMul - | CPPAssOpDiv - | CPPAssOpRmd - | CPPAssOpAdd - | CPPAssOpSub - | CPPAssOpShl - | CPPAssOpShr - | CPPAssOpAnd - | CPPAssOpOr - | CPPAssOpXor - deriving (Eq,Ord,Show) - -data CPPUnaryOp = - CPPOpPreInc - | CPPOpPostInc - | CPPOpPreDec - | CPPOpPostDec - | CPPOpAdr - | CPPOpInd - | CPPOpPlus - | CPPOpMinus - | CPPOpComp - | CPPOpNeg - deriving (Eq,Ord,Show) - -data CPPBinaryOp = - CPPOpMul - | CPPOpDiv - | CPPOpRmd - | CPPOpAdd - | CPPOpSub - | CPPOpShl - | CPPOpShr - | CPPOpLe - | CPPOpGr - | CPPOpLeq - | CPPOpGeq - | CPPOpEq - | CPPOpNeq - | CPPOpAnd - | CPPOpOr - | CPPOpXor - | CPPOpLAnd - | CPPOpLOr - deriving (Eq,Ord,Show) diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -1,11 +1,11 @@ -monadiccp [![Build Status](https://secure.travis-ci.org/neothemachine/monadiccp.png?branch=master)](http://travis-ci.org/neothemachine/monadiccp) -========= - - -Acknowledgments ---------------- - -- Thanks to Chris Mears for a patch to get - the package to compile against GHC 7.4.1. -- Thanks to Nicholas Tung for a patch to get - the package to compile against GHC 7.2.2. +monadiccp [![Build Status](https://travis-ci.org/letmaik/monadiccp.svg?branch=master)](https://travis-ci.org/letmaik/monadiccp) +========= + + +Acknowledgments +--------------- + +- Thanks to Chris Mears for a patch to get + the package to compile against GHC 7.4.1. +- Thanks to Nicholas Tung for a patch to get + the package to compile against GHC 7.2.2. diff --git a/Setup.hs b/Setup.hs --- a/Setup.hs +++ b/Setup.hs @@ -1,4 +1,4 @@ -#! /usr/bin/env runhaskell - -import Distribution.Simple -main = defaultMain +#! /usr/bin/env runhaskell + +import Distribution.Simple +main = defaultMain diff --git a/examples/AllInterval.hs b/examples/AllInterval.hs --- a/examples/AllInterval.hs +++ b/examples/AllInterval.hs @@ -1,28 +1,28 @@ -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE FlexibleContexts #-} - -import Control.CP.FD.Example - --- diffList: the differences between successive elements of a list -diffList l = exists $ \d -> do -- request a (collection) variable d - let n = size l -- introduce n as alias for size l - size d @= n-1 -- size of d must be one less than l - loopall (0,n-2) $ \i -> do -- for each i in [0..n-2] - d!i @= abs (l!i - l!(i+1)) -- d[i] = abs(l[i]-l[i+1]) - return d -- and return d to the caller - -model :: ExampleModel ModelInt -- type signature -model n = -- function 'model' takes argument n - exists $ \x -> do -- request a (collection) variable x - size x @= n -- whose size must be n - d <- diffList x -- d becomes the diffList of x - x `allin` (cte 0,n-1) -- all x elements are in [0..n-1] - d `allin` (cte 1,n-1) -- all d elements are in [1..n-1] - allDiff x -- all x elements are different - allDiff d -- all d elements are different - x @!! 0 @< x @!! 1 -- some symmetry breaking - d @!! 0 @> d ! (n-2) -- some symmetry breaking - return x -- return the list itself - -main = example_sat_main_single_expr model - +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE FlexibleContexts #-} + +import Control.CP.FD.Example + +-- diffList: the differences between successive elements of a list +diffList l = exists $ \d -> do -- request a (collection) variable d + let n = size l -- introduce n as alias for size l + size d @= n-1 -- size of d must be one less than l + loopall (0,n-2) $ \i -> do -- for each i in [0..n-2] + d!i @= abs (l!i - l!(i+1)) -- d[i] = abs(l[i]-l[i+1]) + return d -- and return d to the caller + +model :: ExampleModel ModelInt -- type signature +model n = -- function 'model' takes argument n + exists $ \x -> do -- request a (collection) variable x + size x @= n -- whose size must be n + d <- diffList x -- d becomes the diffList of x + x `allin` (cte 0,n-1) -- all x elements are in [0..n-1] + d `allin` (cte 1,n-1) -- all d elements are in [1..n-1] + allDiff x -- all x elements are different + allDiff d -- all d elements are different + x @!! 0 @< x @!! 1 -- some symmetry breaking + d @!! 0 @> d ! (n-2) -- some symmetry breaking + return x -- return the list itself + +main = example_sat_main_single_expr model + diff --git a/examples/Alpha.hs b/examples/Alpha.hs --- a/examples/Alpha.hs +++ b/examples/Alpha.hs @@ -1,53 +1,53 @@ -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE FlexibleContexts #-} - --- A kid goes into a grocery store and buys four items. The cashier charges $7.11. --- The kid pays and is about to leave when the cashier calls the kid back, and says --- "Hold on, I multiplied the four items instead of adding them; I'll try again... --- Gosh, with adding them the price still comes to $7.11"! What were the prices of --- the four items? - -import Data.Char (ord) - -import Control.CP.FD.Example -import Control.CP.FD.Interface -import Control.CP.FD.Model -import Control.CP.SearchTree -import Control.CP.Solver - - -(@==) :: (MonadTree m, TreeSolver m ~ s, Constraint s ~ Either Model q) => ModelInt -> ModelInt -> m () -(@==) = (@=) - - -word :: ModelCol -> String -> ModelInt -word lst = foldr (\x -> (lst!(cte $ ord x - ord 'a')+)) (cte 0) - -model :: ExampleModel () -model _ = exists $ \col -> do - size col @= cte 26 - allDiff col - col `allin` (cte 1,cte 26) - word col "ballet" @== 45 - word col "cello" @== 43 - word col "concert" @== 74 - word col "flute" @== 30 - word col "fugue" @== 50 - word col "glee" @== 66 - word col "jazz" @== 58 - word col "lyre" @== 47 - word col "oboe" @== 53 - word col "opera" @== 65 - word col "polka" @== 59 - word col "quartet" @== 50 - word col "saxophone" @== 134 - word col "scale" @== 51 - word col "solo" @== 37 - word col "song" @== 61 - word col "soprano" @== 82 - word col "theme" @== 72 - word col "violin" @== 100 - word col "waltz" @== 34 - return col - -main = example_sat_main_void model +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE FlexibleContexts #-} + +-- A kid goes into a grocery store and buys four items. The cashier charges $7.11. +-- The kid pays and is about to leave when the cashier calls the kid back, and says +-- "Hold on, I multiplied the four items instead of adding them; I'll try again... +-- Gosh, with adding them the price still comes to $7.11"! What were the prices of +-- the four items? + +import Data.Char (ord) + +import Control.CP.FD.Example +import Control.CP.FD.Interface +import Control.CP.FD.Model +import Control.CP.SearchTree +import Control.CP.Solver + + +(@==) :: (MonadTree m, TreeSolver m ~ s, Constraint s ~ Either Model q) => ModelInt -> ModelInt -> m () +(@==) = (@=) + + +word :: ModelCol -> String -> ModelInt +word lst = foldr (\x -> (lst!(cte $ ord x - ord 'a')+)) (cte 0) + +model :: ExampleModel () +model _ = exists $ \col -> do + size col @= cte 26 + allDiff col + col `allin` (cte 1,cte 26) + word col "ballet" @== 45 + word col "cello" @== 43 + word col "concert" @== 74 + word col "flute" @== 30 + word col "fugue" @== 50 + word col "glee" @== 66 + word col "jazz" @== 58 + word col "lyre" @== 47 + word col "oboe" @== 53 + word col "opera" @== 65 + word col "polka" @== 59 + word col "quartet" @== 50 + word col "saxophone" @== 134 + word col "scale" @== 51 + word col "solo" @== 37 + word col "song" @== 61 + word col "soprano" @== 82 + word col "theme" @== 72 + word col "violin" @== 100 + word col "waltz" @== 34 + return col + +main = example_sat_main_void model diff --git a/examples/BIBD.hs b/examples/BIBD.hs --- a/examples/BIBD.hs +++ b/examples/BIBD.hs @@ -1,29 +1,29 @@ -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE FlexibleContexts #-} - -import Control.CP.FD.Example - --- path :: ModelInt -> ModelCol -> (ModelInt -> ModelInt) -> (ModelInt -> ModelInt) -> ModelCol --- row :: ModelInt -> ModelCol -> ModelInt -> ModelCol --- col :: ModelInt -> ModelCol -> ModelInt -> ModelCol -path nc ne l r c = slice l $ xmap (\k -> nc*(r k)+(c k)) (0 @.. (ne-1)) -row nc ne l i = path nc ne l (const i) id -col nc ne l i = path nc ne l id (const i) - -model :: ExampleModel (ModelInt,ModelInt,ModelInt) -model (v,k,lambda) = exists $ \mm -> do - let b = (v*(v-1)*lambda) `div` (k*(k-1)) - let r = (lambda*(v-1)) `div` (k-1) - size mm @= b*v - let p r c = mm!(r*b+c) - mm `allin` (cte 0,cte 1) - loopall (0,v-1) $ \rr -> xsum (row b b mm rr) @= r - loopall (0,b-1) $ \cc -> xsum (col b v mm cc) @= k - loopall (0,v-1) $ \r1 -> do - loopall (r1+1,v-1) $ \r2 -> do - xsum (xmap (\i -> (p r1 i) * (p r2 i)) (0 @.. (b-1))) @= lambda - return mm - -main = example_sat_main_void (\_ -> model (6,3,2)) - - +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE FlexibleContexts #-} + +import Control.CP.FD.Example + +-- path :: ModelInt -> ModelCol -> (ModelInt -> ModelInt) -> (ModelInt -> ModelInt) -> ModelCol +-- row :: ModelInt -> ModelCol -> ModelInt -> ModelCol +-- col :: ModelInt -> ModelCol -> ModelInt -> ModelCol +path nc ne l r c = slice l $ xmap (\k -> nc*(r k)+(c k)) (0 @.. (ne-1)) +row nc ne l i = path nc ne l (const i) id +col nc ne l i = path nc ne l id (const i) + +model :: ExampleModel (ModelInt,ModelInt,ModelInt) +model (v,k,lambda) = exists $ \mm -> do + let b = (v*(v-1)*lambda) `div` (k*(k-1)) + let r = (lambda*(v-1)) `div` (k-1) + size mm @= b*v + let p r c = mm!(r*b+c) + mm `allin` (cte 0,cte 1) + loopall (0,v-1) $ \rr -> xsum (row b b mm rr) @= r + loopall (0,b-1) $ \cc -> xsum (col b v mm cc) @= k + loopall (0,v-1) $ \r1 -> do + loopall (r1+1,v-1) $ \r2 -> do + xsum (xmap (\i -> (p r1 i) * (p r2 i)) (0 @.. (b-1))) @= lambda + return mm + +main = example_sat_main_void (\_ -> model (6,3,2)) + + diff --git a/examples/Domino.hs b/examples/Domino.hs --- a/examples/Domino.hs +++ b/examples/Domino.hs @@ -1,96 +1,96 @@ -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE ScopedTypeVariables #-} - -import Control.CP.FD.Example - -model :: ExampleModel ModelInt -model num = do - let spc = spec num - width = (spc! cte 0) - height = (spc! cte 1) - board0 = (slice spc (cte 2 @.. (width*height+1))) @++ (list [cte $ -1]) - brd = slice board0 $ xmap (\i -> ((i @% (width+1)) @= width) @? (width*height,width*(i @/ (width+1))+(i @% (width+1)))) (cte 0 @.. ((width+1)*height-1)) - exists $ \board -> do - board @= brd - exists $ \ps -> do - size ps @= 56 - let p1 i = ps!(2*i) - p2 i = ps!(2*i+1) - posdiffs = list [1,width+1] - exists $ \x -> do - size x @= (width+1)*height - loopall (0,height-1) $ \i -> x!(i*(width+1)+width) @= cte 28 - loopall (0,6) $ \i -> - loopall (i,6) $ \j -> do - let dc = j-i+((1+17*i-(i+1)*(i+1)) `div` 2) - diff = abs $ (p1 dc) - (p2 dc) - diff @: posdiffs - (j @= i) @?? (p1 dc @< p2 dc,true) - board!(p1 dc) @= i - board!(p2 dc) @= j - x!(p1 dc) @= dc - x!(p2 dc) @= dc - return ps - -main = example_sat_main_single_expr model - -specs :: ModelCol -specs = list - [ - 8,7, - 2,1,0,3,0,4,5,5, - 6,2,0,6,3,1,4,0, - 3,2,3,6,2,5,4,3, - 5,4,5,1,1,2,1,2, - 0,0,1,5,0,5,4,4, - 4,6,2,1,3,6,6,1, - 4,2,0,6,5,3,3,6, - - 8,7, - 5,1,2,4,6,2,0,5, - 6,6,4,3,5,0,1,5, - 2,0,4,0,4,0,5,0, - 6,1,3,6,3,5,4,3, - 3,1,0,1,2,2,1,4, - 3,6,6,2,4,0,5,4, - 1,3,6,1,2,3,5,2, - - 8,7, - 4,4,5,4,0,3,6,5, - 1,6,0,1,5,3,4,1, - 2,6,2,2,5,3,6,0, - 1,3,0,6,4,4,2,3, - 3,5,5,2,4,2,2,1, - 2,1,3,3,5,6,6,1, - 5,1,6,0,0,0,4,0, - - 8,7, - 3,0,2,3,3,4,4,3, - 6,5,3,4,2,0,2,1, - 6,5,1,2,3,0,2,0, - 4,5,4,1,6,6,2,5, - 4,3,6,1,0,4,5,5, - 1,3,2,5,6,0,0,1, - 0,5,4,6,2,1,6,1, - - 8,7, - 4,1,5,2,4,4,6,2, - 2,5,6,1,4,6,0,2, - 6,5,1,1,0,1,4,3, - 6,2,1,1,3,2,0,6, - 3,6,3,3,5,5,0,5, - 3,0,1,0,0,5,4,3, - 3,2,4,5,4,2,6,0, - - 8,7, - 4,1,2,1,0,2,4,4, - 5,5,6,6,0,4,6,3, - 6,0,5,1,1,0,5,3, - 3,4,2,2,0,3,1,2, - 3,6,5,6,1,2,3,2, - 2,5,0,6,6,3,3,5, - 4,1,0,0,4,1,4,5 - ] - -spec n = slice specs ((58*n) @.. (58*(n+1))) +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE ScopedTypeVariables #-} + +import Control.CP.FD.Example + +model :: ExampleModel ModelInt +model num = do + let spc = spec num + width = (spc! cte 0) + height = (spc! cte 1) + board0 = (slice spc (cte 2 @.. (width*height+1))) @++ (list [cte $ -1]) + brd = slice board0 $ xmap (\i -> ((i @% (width+1)) @= width) @? (width*height,width*(i @/ (width+1))+(i @% (width+1)))) (cte 0 @.. ((width+1)*height-1)) + exists $ \board -> do + board @= brd + exists $ \ps -> do + size ps @= 56 + let p1 i = ps!(2*i) + p2 i = ps!(2*i+1) + posdiffs = list [1,width+1] + exists $ \x -> do + size x @= (width+1)*height + loopall (0,height-1) $ \i -> x!(i*(width+1)+width) @= cte 28 + loopall (0,6) $ \i -> + loopall (i,6) $ \j -> do + let dc = j-i+((1+17*i-(i+1)*(i+1)) `div` 2) + diff = abs $ (p1 dc) - (p2 dc) + diff @: posdiffs + (j @= i) @?? (p1 dc @< p2 dc,true) + board!(p1 dc) @= i + board!(p2 dc) @= j + x!(p1 dc) @= dc + x!(p2 dc) @= dc + return ps + +main = example_sat_main_single_expr model + +specs :: ModelCol +specs = list + [ + 8,7, + 2,1,0,3,0,4,5,5, + 6,2,0,6,3,1,4,0, + 3,2,3,6,2,5,4,3, + 5,4,5,1,1,2,1,2, + 0,0,1,5,0,5,4,4, + 4,6,2,1,3,6,6,1, + 4,2,0,6,5,3,3,6, + + 8,7, + 5,1,2,4,6,2,0,5, + 6,6,4,3,5,0,1,5, + 2,0,4,0,4,0,5,0, + 6,1,3,6,3,5,4,3, + 3,1,0,1,2,2,1,4, + 3,6,6,2,4,0,5,4, + 1,3,6,1,2,3,5,2, + + 8,7, + 4,4,5,4,0,3,6,5, + 1,6,0,1,5,3,4,1, + 2,6,2,2,5,3,6,0, + 1,3,0,6,4,4,2,3, + 3,5,5,2,4,2,2,1, + 2,1,3,3,5,6,6,1, + 5,1,6,0,0,0,4,0, + + 8,7, + 3,0,2,3,3,4,4,3, + 6,5,3,4,2,0,2,1, + 6,5,1,2,3,0,2,0, + 4,5,4,1,6,6,2,5, + 4,3,6,1,0,4,5,5, + 1,3,2,5,6,0,0,1, + 0,5,4,6,2,1,6,1, + + 8,7, + 4,1,5,2,4,4,6,2, + 2,5,6,1,4,6,0,2, + 6,5,1,1,0,1,4,3, + 6,2,1,1,3,2,0,6, + 3,6,3,3,5,5,0,5, + 3,0,1,0,0,5,4,3, + 3,2,4,5,4,2,6,0, + + 8,7, + 4,1,2,1,0,2,4,4, + 5,5,6,6,0,4,6,3, + 6,0,5,1,1,0,5,3, + 3,4,2,2,0,3,1,2, + 3,6,5,6,1,2,3,2, + 2,5,0,6,6,3,3,5, + 4,1,0,0,4,1,4,5 + ] + +spec n = slice specs ((58*n) @.. (58*(n+1))) diff --git a/examples/EFPA.hs b/examples/EFPA.hs --- a/examples/EFPA.hs +++ b/examples/EFPA.hs @@ -1,22 +1,22 @@ -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE FlexibleContexts #-} - -import Control.CP.FD.Example - -model :: ExampleModel (ModelInt,ModelInt,ModelInt,ModelInt) -model (v,q,l,d) = do - let n = q*l - let nseqpair = (v*(v-1)) `div` 2 - exists $ \c -> do - size c @= n*v - c `allin` (cte 1,q) - let el ro co = c ! (ro*n+co) - loopall (cte 0,v-1) $ \row -> do - loopall (1,q) $ \val -> do - xsum (xmap (\col -> channel (el row col @= val)) (0 @.. (n-1))) @= l - loopall (cte 0,v-1) $ \a -> do - loopall (a+1,v-1) $ \b -> do - xsum (xmap (\col -> channel (el a col @/= el b col)) (0 @.. (n-1))) @= d - return c - -main = example_sat_main_void (\_ -> model (5,3,2,4)) +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE FlexibleContexts #-} + +import Control.CP.FD.Example + +model :: ExampleModel (ModelInt,ModelInt,ModelInt,ModelInt) +model (v,q,l,d) = do + let n = q*l + let nseqpair = (v*(v-1)) `div` 2 + exists $ \c -> do + size c @= n*v + c `allin` (cte 1,q) + let el ro co = c ! (ro*n+co) + loopall (cte 0,v-1) $ \row -> do + loopall (1,q) $ \val -> do + xsum (xmap (\col -> channel (el row col @= val)) (0 @.. (n-1))) @= l + loopall (cte 0,v-1) $ \a -> do + loopall (a+1,v-1) $ \b -> do + xsum (xmap (\col -> channel (el a col @/= el b col)) (0 @.. (n-1))) @= d + return c + +main = example_sat_main_void (\_ -> model (5,3,2,4)) diff --git a/examples/GolombRuler.hs b/examples/GolombRuler.hs --- a/examples/GolombRuler.hs +++ b/examples/GolombRuler.hs @@ -1,30 +1,30 @@ -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE FlexibleContexts #-} - -import Control.CP.FD.Example - -model :: ExampleMinModel ModelInt -model n = - exists $ \m -> do - size m @= n - m `allin` (cte 0,n*n) - let dn = (n*n-n) `div` 2 - exists $ \d -> do - size d @= dn - d `allin` (cte 0,n*n) - let diag i j = d ! (((i*(2*n-i-1)) `div` 2) + j - i - 1) - m!(cte 0) @= cte 0 - loopall (cte 1,n-1) $ \j -> do - diag 0 j @= m!j - loopall (cte 1,n-2) $ \i -> - loopall (i+1,n-1) $ \j -> do - diag i j @= (m!j) - (m!i) - loopall (cte 0,n-1) $ \i -> - loopall (i+1,n-1) $ \j -> do - diag i j @>= (j-i)*(j-i+1) `div` 2 - diag 0 1 @<= diag (n-2) (n-1) - allDiff d - sSorted m - return (m!(n-1),m) - -main = example_min_main_single_expr model +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE FlexibleContexts #-} + +import Control.CP.FD.Example + +model :: ExampleMinModel ModelInt +model n = + exists $ \m -> do + size m @= n + m `allin` (cte 0,n*n) + let dn = (n*n-n) `div` 2 + exists $ \d -> do + size d @= dn + d `allin` (cte 0,n*n) + let diag i j = d ! (((i*(2*n-i-1)) `div` 2) + j - i - 1) + m!(cte 0) @= cte 0 + loopall (cte 1,n-1) $ \j -> do + diag 0 j @= m!j + loopall (cte 1,n-2) $ \i -> + loopall (i+1,n-1) $ \j -> do + diag i j @= (m!j) - (m!i) + loopall (cte 0,n-1) $ \i -> + loopall (i+1,n-1) $ \j -> do + diag i j @>= (j-i)*(j-i+1) `div` 2 + diag 0 1 @<= diag (n-2) (n-1) + allDiff d + sSorted m + return (m!(n-1),m) + +main = example_min_main_single_expr model diff --git a/examples/GraphColor.hs b/examples/GraphColor.hs --- a/examples/GraphColor.hs +++ b/examples/GraphColor.hs @@ -1,415 +1,415 @@ -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE FlexibleContexts #-} - -import Control.CP.FD.Example - -model :: ExampleMinModel () -model () = do - let c = board - let numNodes = c!0 - numEdges = c!1 - edgePos = slice c ((cte 2) @.. (1+numEdges)) - edge i = slice c ((2+numEdges+((i@=0) @? (cte 0,edgePos!(i-1)))) @.. (1+numEdges+(edgePos!i))) - exists $ \numColors -> do - exists $ \colors -> do - numColors @: (cte 0,numNodes) - size colors @= numNodes - colors `allin` (cte 0,numColors) - loopall (0,(size (edge 0)-1)) $ \i -> colors!((edge 0)!i) @= (size (edge 0)-1-i) - loopall (1,numEdges-1) $ allDiffD . slice colors . edge - return (numColors,colors) - -main = example_min_main_void model - -{- - - [numNodes,numEdges,[cumul. clique sizes],[clique elems]] - - 0--1 - | | - 2--3 - - 4,4,2,4,6,8,0,1,1,3,3,2,2,0 - - 0-1 - / \ - 4-----2 - \ / - \3/ - - 5,6,2,4,6,8,10,12,0,1,1,2,2,3,3,4,4,0,2,4 --} - -board :: ModelCol -board = list $ - [ - 200,367, - 30,60,85,110,135,160,185,210,235,260,285,305,325,345,365,385,405,425,445,465,485,505,525,545,565,585,600,615,630,645,660,675,690,705,720,735,750,765,780,795,810,825,840,855,870,885,900,910,920,930,940,950,955,960,965,970,975,980,985,990,995,1000,1005,1010,1015,1020,1025,1027,1029,1031,1033,1035,1037,1039,1041,1043,1045,1047,1049,1051,1053,1055,1057,1059,1061,1063,1065,1067,1069,1071,1073,1075,1077,1079,1081,1083,1085,1087,1089,1091,1093,1095,1097,1099,1101,1103,1105,1107,1109,1111,1113,1115,1117,1119,1121,1123,1125,1127,1129,1131,1133,1135,1137,1139,1141,1143,1145,1147,1149,1151,1153,1155,1157,1159,1161,1163,1165,1167,1169,1171,1173,1175,1177,1179,1181,1183,1185,1187,1189,1191,1193,1195,1197,1199,1201,1203,1205,1207,1209,1211,1213,1215,1217,1219,1221,1223,1225,1227,1229,1231,1233,1235,1237,1239,1241,1243,1245,1247,1249,1251,1253,1255,1257,1259,1261,1263,1265,1267,1269,1271,1273,1275,1277,1279,1281,1283,1285,1287,1289,1291,1293,1295,1297,1299,1301,1303,1305,1307,1309,1311,1313,1315,1317,1319,1321,1323,1325,1327,1329,1331,1333,1335,1337,1339,1341,1343,1345,1347,1349,1351,1353,1355,1357,1359,1361,1363,1365,1367,1369,1371,1373,1375,1377,1379,1381,1383,1385,1387,1389,1391,1393,1395,1397,1399,1401,1403,1405,1407,1409,1411,1413,1415,1417,1419,1421,1423,1425,1427,1429,1431,1433,1435,1437,1439,1441,1443,1445,1447,1449,1451,1453,1455,1457,1459,1461,1463,1465,1467,1469,1471,1473,1475,1477,1479,1481,1483,1485,1487,1489,1491,1493,1495,1497,1499,1501,1503,1505,1507,1509,1511,1513,1515,1517,1519,1521,1523,1525,1527,1529,1531,1533,1535,1537,1539,1541,1543,1545,1547,1549,1551,1553,1555,1557,1559,1561,1563,1565,1567,1569,1571,1573,1575,1577,1579,1581,1583,1585,1587,1589,1591,1593,1595,1597,1599,1601,1603,1605,1607,1609,1611,1613,1615,1617,1619,1621,1623,1625, - 6,11,14,25,40,42,48,53,61,76,80,87,89,92,108,115,120,131,132,137,145,159,162,163,164,168,172,173,176,182, - 3,15,16,31,34,35,37,38,49,58,67,78,86,91,100,110,114,123,129,132,133,140,143,154,167,168,174,175,193,197, - 3,10,33,38,43,45,48,51,65,66,82,88,90,93,94,103,107,128,131,141,152,155,168,185,199, - 0,4,7,26,28,33,36,58,61,72,79,81,90,99,105,114,115,124,135,152,159,161,173,181,192, - 12,15,28,39,43,44,45,66,83,84,85,99,102,108,112,115,120,126,131,152,157,163,171,182,183, - 13,14,15,38,55,66,76,78,87,91,95,99,109,110,125,130,134,137,148,153,159,169,181,185,195, - 3,4,31,35,41,42,57,60,65,66,72,74,84,86,90,91,94,96,110,139,140,141,165,179,199, - 0,4,5,9,28,31,42,49,54,63,65,72,74,75,76,82,91,99,107,109,140,147,154,169,182, - 4,5,10,17,41,43,48,58,65,85,92,97,107,112,114,129,131,146,150,153,158,169,176,184,191, - 4,8,15,16,20,21,37,55,68,84,87,104,109,112,117,119,122,123,126,133,142,164,167,180,195, - 5,6,10,11,28,30,43,46,53,60,66,79,82,105,114,116,119,124,127,147,157,171,184,195,196, - 15,16,30,35,36,56,66,78,81,84,99,126,128,129,138,151,152,153,166,190, - 5,21,23,29,39,40,49,69,88,114,122,127,128,142,148,155,161,171,188,190, - 0,3,15,23,31,41,57,60,69,76,89,107,109,128,153,155,161,169,174,183, - 9,33,43,61,64,69,85,98,100,101,114,120,138,144,172,182,184,187,188,198, - 4,6,8,10,23,27,45,57,66,68,71,93,110,122,139,146,150,155,156,188, - 4,14,18,22,63,77,78,83,94,98,104,114,150,166,172,177,183,186,196,199, - 22,35,46,47,63,64,70,78,87,99,102,112,116,119,125,131,152,165,174,186, - 1,3,13,15,19,26,46,51,65,73,76,110,114,149,152,163,166,170,178,186, - 9,29,33,40,50,54,102,105,111,112,119,120,124,128,136,138,144,175,190,199, - 39,75,79,102,106,112,123,125,138,145,154,155,159,162,165,168,175,181,189,196, - 0,11,12,23,42,63,68,71,79,83,89,98,113,117,121,141,156,176,177,193, - 10,17,31,56,77,89,102,115,116,117,118,120,136,157,163,168,172,182,193,196, - 9,34,35,43,44,57,60,64,79,87,88,94,103,133,156,157,166,171,174,189, - 13,21,22,31,41,45,66,67,79,86,112,116,119,146,160,171,175,181,192,195, - 11,24,26,45,57,91,99,102,122,123,135,141,144,146,154,156,167,191,194,199, - 17,44,53,61,82,90,95,103,107,122,124,145,169,186,190, - 2,14,26,37,58,61,75,95,103,109,115,116,141,154,199, - 5,13,21,28,61,64,65,73,105,115,119,132,148,154,185, - 10,20,38,45,61,75,109,111,115,143,150,157,163,179,186, - 9,45,48,49,51,52,57,64,70,128,158,163,182,183,192, - 47,55,57,64,79,80,105,131,152,163,172,180,186,190,197, - 16,36,69,84,99,113,118,121,126,137,160,162,165,177,196, - 16,44,50,53,54,65,69,80,96,112,125,139,150,153,193, - 6,54,72,76,86,95,96,144,145,148,151,164,168,180,183, - 10,18,19,37,65,85,90,104,112,128,147,158,164,192,198, - 20,21,36,50,53,74,90,96,99,124,129,140,163,171,183, - 13,20,27,53,65,77,86,98,110,125,133,139,147,188,196, - 23,41,43,49,58,74,77,86,111,126,150,168,173,185,189, - 11,35,62,89,125,132,134,141,149,163,166,167,171,194,196, - 14,28,30,52,114,115,122,125,132,135,172,177,179,181,195, - 0,8,9,20,23,53,77,93,121,136,141,147,150,191,199, - 3,21,47,49,91,102,106,113,124,136,140,143,177,178,194, - 44,46,52,53,68,82,89,90,120,128,144,147,175,178,192, - 8,16,19,21,67,72,79,82,86,90,115,116,149,152,199, - 12,30,78,80,97,120,122,123,143,146,151,165,173,177,178, - 9,19,39,46,91,109,128,130,131,146,148,150,178,185,198, - 29,44,69,74,96,115,122,126,189,199, - 22,42,52,53,97,113,146,151,160,195, - 19,20,32,77,81,133,134,138,147,177, - 0,4,56,59,107,109,144,149,158,167, - 6,69,99,104,110,114,118,134,152,172, - 25,76,126,140,143, - 4,54,67,116,142, - 47,52,124,151,192, - 32,55,61,64,73, - 11,65,128,134,190, - 45,48,63,131,139, - 34,55,82,108,151, - 24,34,54,112,156, - 12,47,72,148,163, - 74,126,145,162,170, - 73,78,104,175,192, - 19,83,127,130,166, - 20,90,98,137,165, - 22,24,29,49,132, - 82,92,116,134,184, - 160,184, - 192,199, - 0,129, - 20,80, - 8,29, - 93,171, - 101,165, - 124,193, - 2,100, - 66,173, - 151,191, - 164,187, - 3,130, - 118,176, - 121,184, - 25,106, - 159,193, - 121,123, - 5,62, - 97,101, - 6,143, - 123,163, - 19,125, - 17,108, - 122,168, - 181,184, - 25,41, - 62,70, - 29,103, - 48,67, - 46,160, - 79,170, - 143,152, - 38,184, - 2,40, - 191,195, - 7,196, - 62,199, - 76,141, - 82,166, - 36,80, - 51,189, - 13,97, - 3,192, - 90,180, - 47,176, - 13,172, - 92,121, - 50,64, - 65,113, - 108,123, - 26,106, - 34,153, - 90,123, - 34,39, - 116,178, - 22,179, - 50,61, - 84,105, - 84,93, - 19,108, - 29,59, - 63,185, - 119,129, - 50,177, - 80,194, - 13,36, - 46,56, - 38,144, - 82,193, - 72,93, - 49,95, - 42,155, - 117,140, - 109,189, - 19,35, - 31,125, - 118,191, - 163,169, - 40,167, - 91,127, - 3,121, - 124,149, - 40,174, - 30,175, - 19,132, - 18,165, - 34,93, - 37,63, - 10,55, - 88,95, - 76,122, - 7,91, - 25,141, - 29,173, - 139,173, - 8,130, - 110,158, - 81,174, - 113,114, - 95,182, - 136,149, - 5,199, - 56,106, - 36,120, - 133,187, - 111,172, - 19,34, - 96,197, - 32,108, - 27,63, - 50,188, - 20,116, - 50,118, - 10,50, - 24,172, - 86,138, - 35,50, - 141,153, - 98,132, - 70,143, - 1,97, - 8,160, - 37,170, - 4,73, - 1,94, - 88,146, - 59,61, - 104,156, - 62,172, - 117,139, - 66,189, - 33,134, - 122,169, - 95,163, - 95,152, - 83,140, - 110,189, - 147,159, - 22,147, - 59,173, - 30,41, - 33,183, - 181,187, - 88,105, - 93,151, - 6,130, - 24,30, - 84,130, - 72,120, - 118,159, - 147,189, - 122,149, - 24,175, - 39,169, - 164,186, - 93,187, - 13,156, - 119,176, - 73,91, - 174,178, - 71,198, - 10,134, - 30,101, - 79,93, - 180,187, - 1,50, - 51,59, - 18,169, - 73,153, - 1,198, - 137,154, - 61,106, - 80,113, - 48,142, - 100,111, - 97,133, - 82,97, - 136,170, - 53,134, - 65,177, - 7,80, - 73,137, - 6,70, - 115,166, - 72,196, - 40,109, - 91,101, - 2,177, - 120,185, - 55,65, - 72,166, - 104,165, - 173,187, - 54,71, - 3,61, - 52,56, - 120,149, - 64,72, - 42,43, - 75,185, - 62,68, - 108,147, - 30,111, - 25,58, - 39,93, - 75,117, - 61,194, - 140,153, - 80,121, - 93,102, - 9,177, - 7,163, - 17,70, - 5,168, - 63,178, - 74,160, - 148,158, - 9,84, - 30,76, - 63,80, - 68,99, - 20,152, - 7,182, - 7,22, - 71,134, - 32,100, - 107,164, - 23,62, - 5,98, - 130,192, - 65,144, - 139,161, - 24,124, - 31,47, - 29,140, - 61,153, - 53,109, - 20,26, - 143,160, - 47,195, - 171,172, - 185,193, - 128,173, - 38,96, - 14,171, - 176,199, - 111,139, - 21,54, - 80,171, - 116,185, - 184,199, - 37,88, - 62,133, - 3,150, - 48,109, - 46,176, - 24,178, - 59,172, - 180,198, - 64,109, - 110,111, - 101,146, - 66,164, - 5,117, - 144,179, - 71,126, - 166,169, - 107,151, - 46,85, - 106,139, - 27,153, - 97,148, - 68,185, - 17,179, - 10,142, - 168,169, - 4,46, - 113,152, - 52,176, - 6,38, - 22,48, - 20,120, - 2,84, - 71,85, - 91,116, - 0,189, - 116,197, - 142,147, - 33,165, - 86,198, - 146,149, - 152,187, - 44,62, - 48,175, - 56,150, - 63,161, - 71,164, - 17,171, - 19,66 - ] +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE FlexibleContexts #-} + +import Control.CP.FD.Example + +model :: ExampleMinModel () +model () = do + let c = board + let numNodes = c!0 + numEdges = c!1 + edgePos = slice c ((cte 2) @.. (1+numEdges)) + edge i = slice c ((2+numEdges+((i@=0) @? (cte 0,edgePos!(i-1)))) @.. (1+numEdges+(edgePos!i))) + exists $ \numColors -> do + exists $ \colors -> do + numColors @: (cte 0,numNodes) + size colors @= numNodes + colors `allin` (cte 0,numColors) + loopall (0,(size (edge 0)-1)) $ \i -> colors!((edge 0)!i) @= (size (edge 0)-1-i) + loopall (1,numEdges-1) $ allDiffD . slice colors . edge + return (numColors,colors) + +main = example_min_main_void model + +{- + + [numNodes,numEdges,[cumul. clique sizes],[clique elems]] + + 0--1 + | | + 2--3 + + 4,4,2,4,6,8,0,1,1,3,3,2,2,0 + + 0-1 + / \ + 4-----2 + \ / + \3/ + + 5,6,2,4,6,8,10,12,0,1,1,2,2,3,3,4,4,0,2,4 +-} + +board :: ModelCol +board = list $ + [ + 200,367, + 30,60,85,110,135,160,185,210,235,260,285,305,325,345,365,385,405,425,445,465,485,505,525,545,565,585,600,615,630,645,660,675,690,705,720,735,750,765,780,795,810,825,840,855,870,885,900,910,920,930,940,950,955,960,965,970,975,980,985,990,995,1000,1005,1010,1015,1020,1025,1027,1029,1031,1033,1035,1037,1039,1041,1043,1045,1047,1049,1051,1053,1055,1057,1059,1061,1063,1065,1067,1069,1071,1073,1075,1077,1079,1081,1083,1085,1087,1089,1091,1093,1095,1097,1099,1101,1103,1105,1107,1109,1111,1113,1115,1117,1119,1121,1123,1125,1127,1129,1131,1133,1135,1137,1139,1141,1143,1145,1147,1149,1151,1153,1155,1157,1159,1161,1163,1165,1167,1169,1171,1173,1175,1177,1179,1181,1183,1185,1187,1189,1191,1193,1195,1197,1199,1201,1203,1205,1207,1209,1211,1213,1215,1217,1219,1221,1223,1225,1227,1229,1231,1233,1235,1237,1239,1241,1243,1245,1247,1249,1251,1253,1255,1257,1259,1261,1263,1265,1267,1269,1271,1273,1275,1277,1279,1281,1283,1285,1287,1289,1291,1293,1295,1297,1299,1301,1303,1305,1307,1309,1311,1313,1315,1317,1319,1321,1323,1325,1327,1329,1331,1333,1335,1337,1339,1341,1343,1345,1347,1349,1351,1353,1355,1357,1359,1361,1363,1365,1367,1369,1371,1373,1375,1377,1379,1381,1383,1385,1387,1389,1391,1393,1395,1397,1399,1401,1403,1405,1407,1409,1411,1413,1415,1417,1419,1421,1423,1425,1427,1429,1431,1433,1435,1437,1439,1441,1443,1445,1447,1449,1451,1453,1455,1457,1459,1461,1463,1465,1467,1469,1471,1473,1475,1477,1479,1481,1483,1485,1487,1489,1491,1493,1495,1497,1499,1501,1503,1505,1507,1509,1511,1513,1515,1517,1519,1521,1523,1525,1527,1529,1531,1533,1535,1537,1539,1541,1543,1545,1547,1549,1551,1553,1555,1557,1559,1561,1563,1565,1567,1569,1571,1573,1575,1577,1579,1581,1583,1585,1587,1589,1591,1593,1595,1597,1599,1601,1603,1605,1607,1609,1611,1613,1615,1617,1619,1621,1623,1625, + 6,11,14,25,40,42,48,53,61,76,80,87,89,92,108,115,120,131,132,137,145,159,162,163,164,168,172,173,176,182, + 3,15,16,31,34,35,37,38,49,58,67,78,86,91,100,110,114,123,129,132,133,140,143,154,167,168,174,175,193,197, + 3,10,33,38,43,45,48,51,65,66,82,88,90,93,94,103,107,128,131,141,152,155,168,185,199, + 0,4,7,26,28,33,36,58,61,72,79,81,90,99,105,114,115,124,135,152,159,161,173,181,192, + 12,15,28,39,43,44,45,66,83,84,85,99,102,108,112,115,120,126,131,152,157,163,171,182,183, + 13,14,15,38,55,66,76,78,87,91,95,99,109,110,125,130,134,137,148,153,159,169,181,185,195, + 3,4,31,35,41,42,57,60,65,66,72,74,84,86,90,91,94,96,110,139,140,141,165,179,199, + 0,4,5,9,28,31,42,49,54,63,65,72,74,75,76,82,91,99,107,109,140,147,154,169,182, + 4,5,10,17,41,43,48,58,65,85,92,97,107,112,114,129,131,146,150,153,158,169,176,184,191, + 4,8,15,16,20,21,37,55,68,84,87,104,109,112,117,119,122,123,126,133,142,164,167,180,195, + 5,6,10,11,28,30,43,46,53,60,66,79,82,105,114,116,119,124,127,147,157,171,184,195,196, + 15,16,30,35,36,56,66,78,81,84,99,126,128,129,138,151,152,153,166,190, + 5,21,23,29,39,40,49,69,88,114,122,127,128,142,148,155,161,171,188,190, + 0,3,15,23,31,41,57,60,69,76,89,107,109,128,153,155,161,169,174,183, + 9,33,43,61,64,69,85,98,100,101,114,120,138,144,172,182,184,187,188,198, + 4,6,8,10,23,27,45,57,66,68,71,93,110,122,139,146,150,155,156,188, + 4,14,18,22,63,77,78,83,94,98,104,114,150,166,172,177,183,186,196,199, + 22,35,46,47,63,64,70,78,87,99,102,112,116,119,125,131,152,165,174,186, + 1,3,13,15,19,26,46,51,65,73,76,110,114,149,152,163,166,170,178,186, + 9,29,33,40,50,54,102,105,111,112,119,120,124,128,136,138,144,175,190,199, + 39,75,79,102,106,112,123,125,138,145,154,155,159,162,165,168,175,181,189,196, + 0,11,12,23,42,63,68,71,79,83,89,98,113,117,121,141,156,176,177,193, + 10,17,31,56,77,89,102,115,116,117,118,120,136,157,163,168,172,182,193,196, + 9,34,35,43,44,57,60,64,79,87,88,94,103,133,156,157,166,171,174,189, + 13,21,22,31,41,45,66,67,79,86,112,116,119,146,160,171,175,181,192,195, + 11,24,26,45,57,91,99,102,122,123,135,141,144,146,154,156,167,191,194,199, + 17,44,53,61,82,90,95,103,107,122,124,145,169,186,190, + 2,14,26,37,58,61,75,95,103,109,115,116,141,154,199, + 5,13,21,28,61,64,65,73,105,115,119,132,148,154,185, + 10,20,38,45,61,75,109,111,115,143,150,157,163,179,186, + 9,45,48,49,51,52,57,64,70,128,158,163,182,183,192, + 47,55,57,64,79,80,105,131,152,163,172,180,186,190,197, + 16,36,69,84,99,113,118,121,126,137,160,162,165,177,196, + 16,44,50,53,54,65,69,80,96,112,125,139,150,153,193, + 6,54,72,76,86,95,96,144,145,148,151,164,168,180,183, + 10,18,19,37,65,85,90,104,112,128,147,158,164,192,198, + 20,21,36,50,53,74,90,96,99,124,129,140,163,171,183, + 13,20,27,53,65,77,86,98,110,125,133,139,147,188,196, + 23,41,43,49,58,74,77,86,111,126,150,168,173,185,189, + 11,35,62,89,125,132,134,141,149,163,166,167,171,194,196, + 14,28,30,52,114,115,122,125,132,135,172,177,179,181,195, + 0,8,9,20,23,53,77,93,121,136,141,147,150,191,199, + 3,21,47,49,91,102,106,113,124,136,140,143,177,178,194, + 44,46,52,53,68,82,89,90,120,128,144,147,175,178,192, + 8,16,19,21,67,72,79,82,86,90,115,116,149,152,199, + 12,30,78,80,97,120,122,123,143,146,151,165,173,177,178, + 9,19,39,46,91,109,128,130,131,146,148,150,178,185,198, + 29,44,69,74,96,115,122,126,189,199, + 22,42,52,53,97,113,146,151,160,195, + 19,20,32,77,81,133,134,138,147,177, + 0,4,56,59,107,109,144,149,158,167, + 6,69,99,104,110,114,118,134,152,172, + 25,76,126,140,143, + 4,54,67,116,142, + 47,52,124,151,192, + 32,55,61,64,73, + 11,65,128,134,190, + 45,48,63,131,139, + 34,55,82,108,151, + 24,34,54,112,156, + 12,47,72,148,163, + 74,126,145,162,170, + 73,78,104,175,192, + 19,83,127,130,166, + 20,90,98,137,165, + 22,24,29,49,132, + 82,92,116,134,184, + 160,184, + 192,199, + 0,129, + 20,80, + 8,29, + 93,171, + 101,165, + 124,193, + 2,100, + 66,173, + 151,191, + 164,187, + 3,130, + 118,176, + 121,184, + 25,106, + 159,193, + 121,123, + 5,62, + 97,101, + 6,143, + 123,163, + 19,125, + 17,108, + 122,168, + 181,184, + 25,41, + 62,70, + 29,103, + 48,67, + 46,160, + 79,170, + 143,152, + 38,184, + 2,40, + 191,195, + 7,196, + 62,199, + 76,141, + 82,166, + 36,80, + 51,189, + 13,97, + 3,192, + 90,180, + 47,176, + 13,172, + 92,121, + 50,64, + 65,113, + 108,123, + 26,106, + 34,153, + 90,123, + 34,39, + 116,178, + 22,179, + 50,61, + 84,105, + 84,93, + 19,108, + 29,59, + 63,185, + 119,129, + 50,177, + 80,194, + 13,36, + 46,56, + 38,144, + 82,193, + 72,93, + 49,95, + 42,155, + 117,140, + 109,189, + 19,35, + 31,125, + 118,191, + 163,169, + 40,167, + 91,127, + 3,121, + 124,149, + 40,174, + 30,175, + 19,132, + 18,165, + 34,93, + 37,63, + 10,55, + 88,95, + 76,122, + 7,91, + 25,141, + 29,173, + 139,173, + 8,130, + 110,158, + 81,174, + 113,114, + 95,182, + 136,149, + 5,199, + 56,106, + 36,120, + 133,187, + 111,172, + 19,34, + 96,197, + 32,108, + 27,63, + 50,188, + 20,116, + 50,118, + 10,50, + 24,172, + 86,138, + 35,50, + 141,153, + 98,132, + 70,143, + 1,97, + 8,160, + 37,170, + 4,73, + 1,94, + 88,146, + 59,61, + 104,156, + 62,172, + 117,139, + 66,189, + 33,134, + 122,169, + 95,163, + 95,152, + 83,140, + 110,189, + 147,159, + 22,147, + 59,173, + 30,41, + 33,183, + 181,187, + 88,105, + 93,151, + 6,130, + 24,30, + 84,130, + 72,120, + 118,159, + 147,189, + 122,149, + 24,175, + 39,169, + 164,186, + 93,187, + 13,156, + 119,176, + 73,91, + 174,178, + 71,198, + 10,134, + 30,101, + 79,93, + 180,187, + 1,50, + 51,59, + 18,169, + 73,153, + 1,198, + 137,154, + 61,106, + 80,113, + 48,142, + 100,111, + 97,133, + 82,97, + 136,170, + 53,134, + 65,177, + 7,80, + 73,137, + 6,70, + 115,166, + 72,196, + 40,109, + 91,101, + 2,177, + 120,185, + 55,65, + 72,166, + 104,165, + 173,187, + 54,71, + 3,61, + 52,56, + 120,149, + 64,72, + 42,43, + 75,185, + 62,68, + 108,147, + 30,111, + 25,58, + 39,93, + 75,117, + 61,194, + 140,153, + 80,121, + 93,102, + 9,177, + 7,163, + 17,70, + 5,168, + 63,178, + 74,160, + 148,158, + 9,84, + 30,76, + 63,80, + 68,99, + 20,152, + 7,182, + 7,22, + 71,134, + 32,100, + 107,164, + 23,62, + 5,98, + 130,192, + 65,144, + 139,161, + 24,124, + 31,47, + 29,140, + 61,153, + 53,109, + 20,26, + 143,160, + 47,195, + 171,172, + 185,193, + 128,173, + 38,96, + 14,171, + 176,199, + 111,139, + 21,54, + 80,171, + 116,185, + 184,199, + 37,88, + 62,133, + 3,150, + 48,109, + 46,176, + 24,178, + 59,172, + 180,198, + 64,109, + 110,111, + 101,146, + 66,164, + 5,117, + 144,179, + 71,126, + 166,169, + 107,151, + 46,85, + 106,139, + 27,153, + 97,148, + 68,185, + 17,179, + 10,142, + 168,169, + 4,46, + 113,152, + 52,176, + 6,38, + 22,48, + 20,120, + 2,84, + 71,85, + 91,116, + 0,189, + 116,197, + 142,147, + 33,165, + 86,198, + 146,149, + 152,187, + 44,62, + 48,175, + 56,150, + 63,161, + 71,164, + 17,171, + 19,66 + ] diff --git a/examples/Grocery.hs b/examples/Grocery.hs --- a/examples/Grocery.hs +++ b/examples/Grocery.hs @@ -1,21 +1,21 @@ -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE FlexibleContexts #-} - --- A kid goes into a grocery store and buys four items. The cashier charges $7.11. --- The kid pays and is about to leave when the cashier calls the kid back, and says --- "Hold on, I multiplied the four items instead of adding them; I'll try again... --- Gosh, with adding them the price still comes to $7.11"! What were the prices of --- the four items? - -import Control.CP.FD.Example - -model :: ExampleModel () -model _ = exists $ \col -> do - [a,b,c,d] <- colList col 4 - sorted col - allin col (cte 0,cte 711) - a+b+c+d @= 711 - (a*b)*(c*d) @= 711000000 - return col - -main = example_sat_main_void model +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE FlexibleContexts #-} + +-- A kid goes into a grocery store and buys four items. The cashier charges $7.11. +-- The kid pays and is about to leave when the cashier calls the kid back, and says +-- "Hold on, I multiplied the four items instead of adding them; I'll try again... +-- Gosh, with adding them the price still comes to $7.11"! What were the prices of +-- the four items? + +import Control.CP.FD.Example + +model :: ExampleModel () +model _ = exists $ \col -> do + [a,b,c,d] <- colList col 4 + sorted col + allin col (cte 0,cte 711) + a+b+c+d @= 711 + (a*b)*(c*d) @= 711000000 + return col + +main = example_sat_main_void model diff --git a/examples/LangfordNumber.hs b/examples/LangfordNumber.hs --- a/examples/LangfordNumber.hs +++ b/examples/LangfordNumber.hs @@ -1,30 +1,30 @@ -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE FlexibleContexts #-} - -import Control.CP.FD.Example - -model :: ExampleModel ModelCol -model c = do - let c = col - n = c!0 - k = c!1 - exists $ \y -> do - size y @= k*n - y `allin` (cte 1,n) - exists $ \p -> do - size p @= k*n - p `allin` (cte 0,k*n-1) - loopall (cte 0,n-1) $ \i -> - loopall (cte 0,k-2) $ \j -> - p!(i*k+j) + i+2 @= p!(i*k+j+1) - allDiffD p - loopall (cte 0,n-1) $ \i -> - loopall (cte 0,k-1) $ \j -> - y!(p!(i*k+j)) @= i+1 - y!0 @< y!(n*k-1) - return y - -main = example_sat_main_coll_expr model - -col :: ModelCol -col = list $ [4,2] +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE FlexibleContexts #-} + +import Control.CP.FD.Example + +model :: ExampleModel ModelCol +model c = do + let c = col + n = c!0 + k = c!1 + exists $ \y -> do + size y @= k*n + y `allin` (cte 1,n) + exists $ \p -> do + size p @= k*n + p `allin` (cte 0,k*n-1) + loopall (cte 0,n-1) $ \i -> + loopall (cte 0,k-2) $ \j -> + p!(i*k+j) + i+2 @= p!(i*k+j+1) + allDiffD p + loopall (cte 0,n-1) $ \i -> + loopall (cte 0,k-1) $ \j -> + y!(p!(i*k+j)) @= i+1 + y!0 @< y!(n*k-1) + return y + +main = example_sat_main_coll_expr model + +col :: ModelCol +col = list $ [4,2] diff --git a/examples/MagicSeries.hs b/examples/MagicSeries.hs --- a/examples/MagicSeries.hs +++ b/examples/MagicSeries.hs @@ -1,20 +1,20 @@ -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE FlexibleContexts #-} - -import Control.CP.FD.Example - -count col val = -- count c v = #{foreach i: c[i]==v} - xsum $ xmap (\v -> channel (v @= val)) col - -model :: ExampleModel ModelInt -model n = exists $ \col -> do -- request a (collection) variable col - size col @= n -- col has length n - col `allin` (cte 0,n-1) -- all col elements are in [0..n-1] - loopall (0,n-1) $ \i -> do -- foreach i in [0..n-1]: - count col i @= (col!i) -- col[i] == count col i - xsum col @= n -- sum(col) = n - -- sum(i*col[i]) = n - (xsum (xmap (\i -> (i-1)*(col!i)) ((cte 0) @.. (n-1)))) @= cte 0 - return col -- return col - -main = example_sat_main_single_expr model +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE FlexibleContexts #-} + +import Control.CP.FD.Example + +count col val = -- count c v = #{foreach i: c[i]==v} + xsum $ xmap (\v -> channel (v @= val)) col + +model :: ExampleModel ModelInt +model n = exists $ \col -> do -- request a (collection) variable col + size col @= n -- col has length n + col `allin` (cte 0,n-1) -- all col elements are in [0..n-1] + loopall (0,n-1) $ \i -> do -- foreach i in [0..n-1]: + count col i @= (col!i) -- col[i] == count col i + xsum col @= n -- sum(col) = n + -- sum(i*col[i]) = n + (xsum (xmap (\i -> (i-1)*(col!i)) ((cte 0) @.. (n-1)))) @= cte 0 + return col -- return col + +main = example_sat_main_single_expr model diff --git a/examples/MagicSquare.hs b/examples/MagicSquare.hs --- a/examples/MagicSquare.hs +++ b/examples/MagicSquare.hs @@ -1,34 +1,34 @@ -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE FlexibleContexts #-} - -import Control.CP.FD.Example - -path :: ModelInt -> ModelCol -> (ModelInt -> ModelInt) -> (ModelInt -> ModelInt) -> ModelCol -path n l r c = slice l $ xmap (\k -> n*(r k)+(c k)) (0 @.. (n-1)) - -row :: ModelInt -> ModelCol -> ModelInt -> ModelCol -row n l i = path n l (const i) id - -col :: ModelInt -> ModelCol -> ModelInt -> ModelCol -col n l i = path n l id (const i) - -diag1 n l = path n l id id -diag2 n l = path n l id (\x -> n-x-1) - -model :: ExampleModel ModelInt -model n = exists $ \mat -> do - let nn = n*n - let s = n*(nn+1) `div` 2 - size mat @= n*n - loopall (0,n-1) $ \i -> do - xfold (+) (cte 0) (col n mat i) @= s - xfold (+) (cte 0) (row n mat i) @= s - xfold (+) (cte 0) (diag1 n mat) @= s - xfold (+) (cte 0) (diag2 n mat) @= s - mat `allin` (cte 1,nn) - allDiff mat - (mat @!! 0) @> (mat!(n-1)) - (mat @!! 0) @> (mat!(n*n-n)) - return mat - -main = example_sat_main_single_expr model +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE FlexibleContexts #-} + +import Control.CP.FD.Example + +path :: ModelInt -> ModelCol -> (ModelInt -> ModelInt) -> (ModelInt -> ModelInt) -> ModelCol +path n l r c = slice l $ xmap (\k -> n*(r k)+(c k)) (0 @.. (n-1)) + +row :: ModelInt -> ModelCol -> ModelInt -> ModelCol +row n l i = path n l (const i) id + +col :: ModelInt -> ModelCol -> ModelInt -> ModelCol +col n l i = path n l id (const i) + +diag1 n l = path n l id id +diag2 n l = path n l id (\x -> n-x-1) + +model :: ExampleModel ModelInt +model n = exists $ \mat -> do + let nn = n*n + let s = n*(nn+1) `div` 2 + size mat @= n*n + loopall (0,n-1) $ \i -> do + xfold (+) (cte 0) (col n mat i) @= s + xfold (+) (cte 0) (row n mat i) @= s + xfold (+) (cte 0) (diag1 n mat) @= s + xfold (+) (cte 0) (diag2 n mat) @= s + mat `allin` (cte 1,nn) + allDiff mat + (mat @!! 0) @> (mat!(n-1)) + (mat @!! 0) @> (mat!(n*n-n)) + return mat + +main = example_sat_main_single_expr model diff --git a/examples/MineSweeper.hs b/examples/MineSweeper.hs --- a/examples/MineSweeper.hs +++ b/examples/MineSweeper.hs @@ -1,50 +1,50 @@ -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE FlexibleContexts #-} - -import Control.CP.FD.Example - -aroundY :: ModelCol -aroundY = list [-1,-1,0,1,1,1,0,-1] - -aroundX :: ModelCol -aroundX = list [0,1,1,1,0,-1,-1,-1] - -model :: ExampleModel () -model () = do - let c = board - let s = c!0 - spec x y = c!(1+y*s+x) - exists $ \m -> do - m `allin` (cte 0,cte 1) - size m @= s*s+1 - m!(s*s) @= cte 0 - let v x y = (x@>=s @|| x@<0 @|| y@>=s @|| y@<0) @? (s*s,y*s+x) - let around x y = slice m $ xmap (\p -> v (x+(aroundX!p)) (y+(aroundY!p))) (cte 0 @.. cte 7) - loopall (cte 0,s-1) $ \x -> - loopall (cte 0,s-1) $ \y -> do - ((spec x y) @< (cte 0)) @?? (true,do - m!(y*s+x) @= 0 - xsum (around x y) @= (spec x y) - ) - return m - -main = example_sat_main_void model - -u = (-1) - -board :: ModelCol -board = list $ - [ - 10, - - 1,u,u,2,u,2,u,2,u,u, - u,3,2,u,u,u,4,u,u,1, - u,u,u,1,3,u,u,u,4,u, - 3,u,1,u,u,u,3,u,u,u, - u,2,1,u,1,u,u,3,u,2, - u,3,u,2,u,u,2,u,1,u, - 2,u,u,3,2,u,u,2,u,u, - u,3,u,u,u,3,2,u,u,3, - u,u,3,u,3,3,u,u,u,u, - u,2,u,2,u,u,u,2,2,u - ] +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE FlexibleContexts #-} + +import Control.CP.FD.Example + +aroundY :: ModelCol +aroundY = list [-1,-1,0,1,1,1,0,-1] + +aroundX :: ModelCol +aroundX = list [0,1,1,1,0,-1,-1,-1] + +model :: ExampleModel () +model () = do + let c = board + let s = c!0 + spec x y = c!(1+y*s+x) + exists $ \m -> do + m `allin` (cte 0,cte 1) + size m @= s*s+1 + m!(s*s) @= cte 0 + let v x y = (x@>=s @|| x@<0 @|| y@>=s @|| y@<0) @? (s*s,y*s+x) + let around x y = slice m $ xmap (\p -> v (x+(aroundX!p)) (y+(aroundY!p))) (cte 0 @.. cte 7) + loopall (cte 0,s-1) $ \x -> + loopall (cte 0,s-1) $ \y -> do + ((spec x y) @< (cte 0)) @?? (true,do + m!(y*s+x) @= 0 + xsum (around x y) @= (spec x y) + ) + return m + +main = example_sat_main_void model + +u = (-1) + +board :: ModelCol +board = list $ + [ + 10, + + 1,u,u,2,u,2,u,2,u,u, + u,3,2,u,u,u,4,u,u,1, + u,u,u,1,3,u,u,u,4,u, + 3,u,1,u,u,u,3,u,u,u, + u,2,1,u,1,u,u,3,u,2, + u,3,u,2,u,u,2,u,1,u, + 2,u,u,3,2,u,u,2,u,u, + u,3,u,u,u,3,2,u,u,3, + u,u,3,u,3,3,u,u,u,u, + u,2,u,2,u,u,u,2,2,u + ] diff --git a/examples/Olympic.hs b/examples/Olympic.hs --- a/examples/Olympic.hs +++ b/examples/Olympic.hs @@ -1,51 +1,52 @@ -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE FlexibleContexts #-} - -{- -% File : olympic.pl -% Author : Neng-Fa ZHOU -% Date : 1993 -% Purpose: solve a puzzle taken from Olympic Arithmetic Contest -/*********************************************************************** - Given ten variables with the following configuration: - - X7 X8 X9 X10 - - X4 X5 X6 - - X2 X3 - - X1 - - We already know that X1 is equal to 3 and want to assign each variable - with a different integer from {1,2,...,10} such that for any three - variables - Xi Xj - - Xk - the following constraint is satisfied: - - |Xi-Xj| = Xk -***********************************************************************/ --} - - -import Control.CP.FD.Example - -main = example_sat_main_void model - -model :: ExampleModel () -model _ = exists $ \col -> do - [x1,x2,x3,x4,x5,x6,x7,x8,x9,x10] <- colList col 10 - col `allin` (cte 1, cte 10) - allDiff col - x1 @= 3 - minus x2 x3 x1 - minus x4 x5 x2 - minus x5 x6 x3 - minus x7 x8 x4 - minus x8 x9 x5 - minus x9 x10 x6 - return col - -minus x1 x2 x3 = (abs (x1-x2)) @= x3 +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE FlexibleContexts #-} + +{- +% File : olympic.pl +% Author : Neng-Fa ZHOU +% Date : 1993 +% Purpose: solve a puzzle taken from Olympic Arithmetic Contest +/*********************************************************************** + Given ten variables with the following configuration: + + X7 X8 X9 X10 + + X4 X5 X6 + + X2 X3 + + X1 + + We already know that X1 is equal to 3 and want to assign each variable + with a different integer from {1,2,...,10} such that for any three + variables + Xi Xj + + Xk + the following constraint is satisfied: + + |Xi-Xj| = Xk +***********************************************************************/ +-} + + +import Control.CP.FD.Example +import System.Environment + +main = withArgs ["overton_run"] $ example_sat_main_void model + +model :: ExampleModel () +model _ = exists $ \col -> do + [x1,x2,x3,x4,x5,x6,x7,x8,x9,x10] <- colList col 10 + col `allin` (cte (1 :: Integer), cte (10 :: Integer)) + allDiff col + x1 @= 3 + minus x2 x3 x1 + minus x4 x5 x2 + minus x5 x6 x3 + minus x7 x8 x4 + minus x8 x9 x5 + minus x9 x10 x6 + return col + +minus x1 x2 x3 = (abs (x1-x2)) @= x3 diff --git a/examples/Partition.hs b/examples/Partition.hs --- a/examples/Partition.hs +++ b/examples/Partition.hs @@ -1,32 +1,32 @@ -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE FlexibleContexts #-} - -import Control.CP.FD.Example - -model :: ExampleModel ModelInt -model n = - exists $ \x -> do - exists $ \y -> do - let xy = x @++ y - size x @= n - size y @= n - x `allin` (cte 1,2*n) - y `allin` (cte 1,2*n) - sSorted x - sSorted y - (x!cte 0) @< (y!cte 0) - allDiff xy - let sx = xmap (\v -> v*v) x - let sy = xmap (\v -> v*v) y - xsum x @= xsum y - xsum sx @= xsum sy - let t1 = 2*n*(2*n+1) `div` 4 - let t2 = 2*n*(2*n+1)*(4*n+1) `div` 12 - xsum x @= t1 - xsum y @= t1 - xsum sx @= t2 - xsum sy @= t2 - return xy - -main = example_sat_main_single_expr model - +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE FlexibleContexts #-} + +import Control.CP.FD.Example + +model :: ExampleModel ModelInt +model n = + exists $ \x -> do + exists $ \y -> do + let xy = x @++ y + size x @= n + size y @= n + x `allin` (cte 1,2*n) + y `allin` (cte 1,2*n) + sSorted x + sSorted y + (x!cte 0) @< (y!cte 0) + allDiff xy + let sx = xmap (\v -> v*v) x + let sy = xmap (\v -> v*v) y + xsum x @= xsum y + xsum sx @= xsum sy + let t1 = 2*n*(2*n+1) `div` 4 + let t2 = 2*n*(2*n+1)*(4*n+1) `div` 12 + xsum x @= t1 + xsum y @= t1 + xsum sx @= t2 + xsum sy @= t2 + return xy + +main = example_sat_main_single_expr model + diff --git a/examples/PerfectSquare.hs b/examples/PerfectSquare.hs --- a/examples/PerfectSquare.hs +++ b/examples/PerfectSquare.hs @@ -1,26 +1,26 @@ -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE FlexibleContexts #-} - -import Control.CP.FD.Example - -model :: ExampleModel ModelCol -model c = do - let numSquares = c!0 - totalSize = c!1 - s = slice c ((cte 2) @.. (1+numSquares)) - exists $ \pos -> do - size pos @= 2*numSquares - let x i = pos!i - y i = pos!(i+numSquares) - pos `allin` (cte 0,totalSize-1) - loopall (0,numSquares-1) $ \i -> do - x i @<= totalSize - (s!i) - y i @<= totalSize - (s!i) - loopall (0,numSquares-1) $ \i -> - loopall (i+1,numSquares-1) $ \j -> ((x i)+(s!i) @<= (x j)) @|| ((x j)+(s!j) @<= (x i)) @|| ((y i)+(s!i) @<= (y j)) @|| ((y j)+(s!j) @<= (y i)) --- loopall (0,totalSize-1) $ \c -> do --- totalSize @= xsum (xmap (\i -> (s!i)*channel((x i) @: (c-(s!i)+1,c))) ((cte 0) @.. (numSquares-1))) --- totalSize @= xsum (xmap (\i -> (s!i)*channel((y i) @: (c-(s!i)+1,c))) ((cte 0) @.. (numSquares-1))) - return pos - -main = example_sat_main_coll_expr model +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE FlexibleContexts #-} + +import Control.CP.FD.Example + +model :: ExampleModel ModelCol +model c = do + let numSquares = c!0 + totalSize = c!1 + s = slice c ((cte 2) @.. (1+numSquares)) + exists $ \pos -> do + size pos @= 2*numSquares + let x i = pos!i + y i = pos!(i+numSquares) + pos `allin` (cte 0,totalSize-1) + loopall (0,numSquares-1) $ \i -> do + x i @<= totalSize - (s!i) + y i @<= totalSize - (s!i) + loopall (0,numSquares-1) $ \i -> + loopall (i+1,numSquares-1) $ \j -> ((x i)+(s!i) @<= (x j)) @|| ((x j)+(s!j) @<= (x i)) @|| ((y i)+(s!i) @<= (y j)) @|| ((y j)+(s!j) @<= (y i)) +-- loopall (0,totalSize-1) $ \c -> do +-- totalSize @= xsum (xmap (\i -> (s!i)*channel((x i) @: (c-(s!i)+1,c))) ((cte 0) @.. (numSquares-1))) +-- totalSize @= xsum (xmap (\i -> (s!i)*channel((y i) @: (c-(s!i)+1,c))) ((cte 0) @.. (numSquares-1))) + return pos + +main = example_sat_main_coll_expr model diff --git a/examples/Queens.hs b/examples/Queens.hs --- a/examples/Queens.hs +++ b/examples/Queens.hs @@ -1,22 +1,22 @@ -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE FlexibleContexts #-} - -import Control.CP.FD.Example - -noattack i j qi qj = do - qi @/= qj - qi + i @/= qj + j - qi - i @/= qj - j - -model :: ExampleModel ModelInt -model n = exists $ \p -> do - size p @= n - p `allin` (cte 0,n-1) - allDiff p - loopall (cte 0,n-2) $ \i -> - loopall (i+1,n-1) $ \j -> - noattack i j (p!i) (p!j) - return p - -main = example_sat_main_single_expr model - +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE FlexibleContexts #-} + +import Control.CP.FD.Example + +noattack i j qi qj = do + qi @/= qj + qi + i @/= qj + j + qi - i @/= qj - j + +model :: ExampleModel ModelInt +model n = exists $ \p -> do + size p @= n + p `allin` (cte 0,n-1) + allDiff p + loopall (cte 0,n-2) $ \i -> + loopall (i+1,n-1) $ \j -> + noattack i j (p!i) (p!j) + return p + +main = example_sat_main_single_expr model + diff --git a/examples/Ring.hs b/examples/Ring.hs --- a/examples/Ring.hs +++ b/examples/Ring.hs @@ -1,19 +1,19 @@ -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE FlexibleContexts #-} - -import Control.CP.FD.Example - -main = example_sat_main_single_expr model - -model :: ExampleModel ModelInt -model n = exists $ \col -> do - size col @= n - loopall (0,(n-1)) $ \i -> do - let v0 = col ! i - v1 = col ! ((i+1) `mod` n) - v2 = col ! ((i+2) `mod` n) - 2 * v1 @= 2 * v2 - v0 - v0 @: (cte (-10), cte 10) - return col - - +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE FlexibleContexts #-} + +import Control.CP.FD.Example + +main = example_sat_main_single_expr model + +model :: ExampleModel ModelInt +model n = exists $ \col -> do + size col @= n + loopall (0,(n-1)) $ \i -> do + let v0 = col ! i + v1 = col ! ((i+1) `mod` n) + v2 = col ! ((i+2) `mod` n) + 2 * v1 @= 2 * v2 - v0 + v0 @: (cte (-10), cte 10) + return col + + diff --git a/examples/StressDomain.hs b/examples/StressDomain.hs --- a/examples/StressDomain.hs +++ b/examples/StressDomain.hs @@ -1,22 +1,22 @@ -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE FlexibleContexts #-} - -import Control.CP.FD.Example - -main = example_sat_main_single_expr model - -model :: ExampleModel ModelInt -model n = exists $ \col -> do - l <- colList col 5 - col `allin` (cte 0, cte 5*n) - let revCol = list (reverse l) - colP = list [0,2,4] - forall revCol $ \v -> - forall colP $ \p -> - loopall (0,5*n) $ \j -> - v @/= 5*j+p - loopall (0,5*(n `div` 2)) $ \j -> - forall revCol $ \v -> do - v @>= 5*j - v @<= 5*(j+5*(n `div` 2)) - return col +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE FlexibleContexts #-} + +import Control.CP.FD.Example + +main = example_sat_main_single_expr model + +model :: ExampleModel ModelInt +model n = exists $ \col -> do + l <- colList col 5 + col `allin` (cte 0, cte 5*n) + let revCol = list (reverse l) + colP = list [0,2,4] + forall revCol $ \v -> + forall colP $ \p -> + loopall (0,5*n) $ \j -> + v @/= 5*j+p + loopall (0,5*(n `div` 2)) $ \j -> + forall revCol $ \v -> do + v @>= 5*j + v @<= 5*(j+5*(n `div` 2)) + return col diff --git a/examples/Sudoku.hs b/examples/Sudoku.hs --- a/examples/Sudoku.hs +++ b/examples/Sudoku.hs @@ -1,46 +1,46 @@ -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE FlexibleContexts #-} - -import Control.CP.FD.Example - -model :: ExampleModel () -model () = exists $ \mat -> do - size mat @= 81 - allin mat (cte 1,cte 9) - let row i = slice mat $ xmap (\p -> i*9+p) (cte 0 @.. cte 8) - let col i = slice mat $ xmap (\p -> i+9*p) (cte 0 @.. cte 8) - let block r c = slice mat $ xmap (\p -> 3*c+27*r+p) $ list [0,1,2,9,10,11,18,19,20] - let pos r c = mat!(r*9+c) - loopall (cte 0,cte 2) $ \i -> - loopall (cte 0,cte 2) $ \j -> do - allDiffD $ row $ i*3+j - allDiffD $ col $ i*3+j - allDiffD $ block i j - pos 0 8 @= cte 2 - pos 1 0 @= cte 4 - pos 1 4 @= cte 3 - pos 1 8 @= cte 1 - pos 2 4 @= cte 1 - pos 2 6 @= cte 9 - pos 2 7 @= cte 5 - pos 3 0 @= cte 5 - pos 3 2 @= cte 2 - pos 3 3 @= cte 8 - pos 3 6 @= cte 1 - pos 4 3 @= cte 7 - pos 4 5 @= cte 2 - pos 5 2 @= cte 7 - pos 5 5 @= cte 9 - pos 5 6 @= cte 2 - pos 5 8 @= cte 4 - pos 6 1 @= cte 4 - pos 6 4 @= cte 2 - pos 7 0 @= cte 1 - pos 7 2 @= cte 9 - pos 7 4 @= cte 7 - pos 7 8 @= cte 6 - pos 8 0 @= cte 3 - pos 8 3 @= cte 5 - return mat - -main = example_sat_main_void model +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE FlexibleContexts #-} + +import Control.CP.FD.Example + +model :: ExampleModel () +model () = exists $ \mat -> do + size mat @= 81 + allin mat (cte 1,cte 9) + let row i = slice mat $ xmap (\p -> i*9+p) (cte 0 @.. cte 8) + let col i = slice mat $ xmap (\p -> i+9*p) (cte 0 @.. cte 8) + let block r c = slice mat $ xmap (\p -> 3*c+27*r+p) $ list [0,1,2,9,10,11,18,19,20] + let pos r c = mat!(r*9+c) + loopall (cte 0,cte 2) $ \i -> + loopall (cte 0,cte 2) $ \j -> do + allDiffD $ row $ i*3+j + allDiffD $ col $ i*3+j + allDiffD $ block i j + pos 0 8 @= cte 2 + pos 1 0 @= cte 4 + pos 1 4 @= cte 3 + pos 1 8 @= cte 1 + pos 2 4 @= cte 1 + pos 2 6 @= cte 9 + pos 2 7 @= cte 5 + pos 3 0 @= cte 5 + pos 3 2 @= cte 2 + pos 3 3 @= cte 8 + pos 3 6 @= cte 1 + pos 4 3 @= cte 7 + pos 4 5 @= cte 2 + pos 5 2 @= cte 7 + pos 5 5 @= cte 9 + pos 5 6 @= cte 2 + pos 5 8 @= cte 4 + pos 6 1 @= cte 4 + pos 6 4 @= cte 2 + pos 7 0 @= cte 1 + pos 7 2 @= cte 9 + pos 7 4 @= cte 7 + pos 7 8 @= cte 6 + pos 8 0 @= cte 3 + pos 8 3 @= cte 5 + return mat + +main = example_sat_main_void model diff --git a/examples/Test.hs b/examples/Test.hs --- a/examples/Test.hs +++ b/examples/Test.hs @@ -1,15 +1,15 @@ -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE FlexibleContexts #-} - -import Control.CP.FD.Example - -model :: ExampleModel () -model _ = exists $ \arr -> do - arr `allin` (cte 0,cte 10) - size arr @= 4 - xsum arr @= 10 - xsum (xmap (\x -> x*x) arr) @= 30 - sorted arr - return arr - -main = example_sat_main_void model +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE FlexibleContexts #-} + +import Control.CP.FD.Example + +model :: ExampleModel () +model _ = exists $ \arr -> do + arr `allin` (cte 0,cte 10) + size arr @= 4 + xsum arr @= 10 + xsum (xmap (\x -> x*x) arr) @= 30 + sorted arr + return arr + +main = example_sat_main_void model diff --git a/examples/TestPretty.hs b/examples/TestPretty.hs --- a/examples/TestPretty.hs +++ b/examples/TestPretty.hs @@ -1,20 +1,20 @@ -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE ScopedTypeVariables #-} - -import Control.CP.FD.Example - -model :: ExampleModel ModelInt -model i = exists $ \col -> do - [a,b,c,d] <- colList col 4 - forall col (@>0) - forall col (@<=10) --- loopall (1,4) $ \(x :: ModelInt) -> (xfold (+) (cte 0) (xlist [col!x,col!(4-x)]) @== 5) - loopall (1,4) $ \i -> i*(col!(i-1)) @<= 100 - allDiff col - sorted col - xfold (+) (cte 0) col @= i - return col - -main = example_sat_main_single_expr model - +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE ScopedTypeVariables #-} + +import Control.CP.FD.Example + +model :: ExampleModel ModelInt +model i = exists $ \col -> do + [a,b,c,d] <- colList col 4 + forall col (@>0) + forall col (@<=10) +-- loopall (1,4) $ \(x :: ModelInt) -> (xfold (+) (cte 0) (xlist [col!x,col!(4-x)]) @== 5) + loopall (1,4) $ \i -> i*(col!(i-1)) @<= 100 + allDiff col + sorted col + xfold (+) (cte 0) col @= i + return col + +main = example_sat_main_single_expr model + diff --git a/examples/TryDemo.hs b/examples/TryDemo.hs --- a/examples/TryDemo.hs +++ b/examples/TryDemo.hs @@ -1,21 +1,21 @@ -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE FlexibleContexts #-} - -{- - - Monadic Constraint Programming - - http://www.cs.kuleuven.be/~toms/Haskell/ - - Tom Schrijvers & Pieter Wuille - -} - -import Control.CP.FD.Example - -main = example_sat_main_void model - -model :: ExampleModel () -model _ = exists $ \col -> do - [a,b] <- colList col 2 - a @: (cte 1, cte 5) - b @: (cte 0, cte 4) - a - b @= 1 - (a @= 2) @|| (a @= 3) @|| (a @= 4) - return col +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE FlexibleContexts #-} + +{- + - Monadic Constraint Programming + - http://www.cs.kuleuven.be/~toms/Haskell/ + - Tom Schrijvers & Pieter Wuille + -} + +import Control.CP.FD.Example + +main = example_sat_main_void model + +model :: ExampleModel () +model _ = exists $ \col -> do + [a,b] <- colList col 2 + a @: (cte 1, cte 5) + b @: (cte 0, cte 4) + a - b @= 1 + (a @= 2) @|| (a @= 3) @|| (a @= 4) + return col diff --git a/examples/Zebra.hs b/examples/Zebra.hs --- a/examples/Zebra.hs +++ b/examples/Zebra.hs @@ -1,43 +1,43 @@ -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE FlexibleContexts #-} - -import Control.CP.FD.Example - -main = example_sat_main_void model - -model :: ExampleModel () -model _ = exists $ \vars -> do - [n1,n2,n3,n4,n5, - c1,c2,c3,c4,c5, - p1,p2,p3,p4,p5, - a1,a2,a3,a4,a5, - d1,d2,d3,d4,d5] <- colList vars 25 - let ns = slice vars (cte 0 @.. cte 4) - cs = slice vars (cte 5 @.. cte 9) - ps = slice vars (cte 10 @.. cte 14) - as = slice vars (cte 15 @.. cte 19) - ds = slice vars (cte 20 @.. cte 24) - vars `allin` (cte 1, cte 5) - allDiff ns - allDiff cs - allDiff ps - allDiff as - allDiff ds - n1 @= c2 - n2 @= a1 - n3 @= p1 - n4 @= d3 - n5 @= 1 - d5 @= 3 - p3 @= d1 - c1 @= d4 - p5 @= a4 - p2 @= c3 - c1 @= c5+1 - plusorminus a3 p4 1 - plusorminus a5 p2 1 - plusorminus n5 c4 1 - return vars - -plusorminus x y c = - x @= y+c @|| x @= y-c +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE FlexibleContexts #-} + +import Control.CP.FD.Example + +main = example_sat_main_void model + +model :: ExampleModel () +model _ = exists $ \vars -> do + [n1,n2,n3,n4,n5, + c1,c2,c3,c4,c5, + p1,p2,p3,p4,p5, + a1,a2,a3,a4,a5, + d1,d2,d3,d4,d5] <- colList vars 25 + let ns = slice vars (cte 0 @.. cte 4) + cs = slice vars (cte 5 @.. cte 9) + ps = slice vars (cte 10 @.. cte 14) + as = slice vars (cte 15 @.. cte 19) + ds = slice vars (cte 20 @.. cte 24) + vars `allin` (cte 1, cte 5) + allDiff ns + allDiff cs + allDiff ps + allDiff as + allDiff ds + n1 @= c2 + n2 @= a1 + n3 @= p1 + n4 @= d3 + n5 @= 1 + d5 @= 3 + p3 @= d1 + c1 @= d4 + p5 @= a4 + p2 @= c3 + c1 @= c5+1 + plusorminus a3 p4 1 + plusorminus a5 p2 1 + plusorminus n5 c4 1 + return vars + +plusorminus x y c = + x @= y+c @|| x @= y-c diff --git a/monadiccp.cabal b/monadiccp.cabal --- a/monadiccp.cabal +++ b/monadiccp.cabal @@ -1,98 +1,106 @@ -Name: monadiccp -Version: 0.7.6 -Description: Monadic Constraint Programming framework -License: BSD3 -License-file: LICENSE -Author: Tom Schrijvers, Pieter Wuille -Maintainer: maik.riechert@arcor.de -Build-Type: Simple -Category: control -Synopsis: Constraint Programming -Homepage: http://users.ugent.be/~tschrijv/MCP/ -Bug-reports: https://github.com/neothemachine/monadiccp/issues -Cabal-Version: >=1.6 -Extra-Source-Files: examples/*.hs -Data-Files: README.md - -tested-with: - GHC==7.6.3 - -source-repository head - type: git - location: https://github.com/neothemachine/monadiccp.git - -Flag Debug - Description: Generate debug output - Default: False - -library - Build-Depends: base >= 2, base < 5, containers, mtl, random, pretty, parsec >= 3.0 - Exposed-Modules: Data.Expr.Sugar - Data.Expr.Data - Data.Expr.Util - Data.Linear - Control.CP.SearchTree - Control.CP.Transformers - Control.CP.ComposableTransformers - Control.CP.Solver - Control.CP.PriorityQueue - Control.CP.Queue - Control.CP.FD.Interface - Control.CP.FD.OvertonFD.OvertonFD - Control.CP.FD.OvertonFD.Sugar - Control.CP.EnumTerm - Control.CP.FD.Solvers - Control.CP.FD.Model - Control.CP.FD.Example - Control.CP.FD.FD - Control.CP.Debug - Control.CP.FD.SearchSpec.Data - Control.CP.FD.OvertonFD.Domain - Control.CP.FD.SimpleFD - Control.CP.FD.Graph - Control.CP.FD.Decompose - Control.Search.Language - Control.Search.Stat - Control.Search.Generator - Control.Search.Combinator.For - Control.Search.Combinator.Until - Control.Search.Combinator.If - Control.Search.Combinator.OrRepeat - Control.Search.Combinator.Let - Control.Search.Combinator.Success - Control.Search.Combinator.Base - Control.Search.Combinator.Failure - Control.Search.Combinator.Once - Control.Search.Combinator.And - Control.Search.Combinator.Repeat - Control.Search.Combinator.Or - Control.Search.Combinator.Post - Control.Search.Combinator.Misc - Control.Search.Combinator.Print - Control.Search.Memo - Control.Search.GeneratorInfo - Control.Search.Constraints - Control.Search.MemoReader - Control.Search.SStateT - Control.Mixin.Mixin - Language.CPP.Syntax.AST - Language.CPP.Pretty - Other-Modules: Control.Monatron.Monatron - Control.Monatron.MonadInfo - Control.Monatron.AutoLift - Control.Monatron.Operations - Control.Monatron.Zipper - Control.Monatron.IdT - Control.Monatron.Codensity - Control.Monatron.Transformer - Control.Monatron.Open - Control.Monatron.AutoInstances - Control.Monatron.MonadT - Control.Monatron.Monad - Control.Monatron.ZipperExamples - GHC-Prof-Options: -auto-all -caf-all - if flag(Debug) - CPP-Options: -DDEBUG - CC-Options: "-ggdb3" "-Wall" - else - CC-Options: "-g0" "-DNDEBUG" "-Wall" +Name: monadiccp +Version: 0.7.7 +Description: Monadic Constraint Programming framework +License: BSD3 +License-file: LICENSE +Author: Tom Schrijvers, Pieter Wuille +Maintainer: maik.riechert@arcor.de +Build-Type: Simple +Category: control +Synopsis: Constraint Programming +Homepage: https://people.cs.kuleuven.be/~tom.schrijvers/MCP/ +Bug-reports: https://github.com/letmaik/monadiccp/issues +Cabal-Version: >=1.8 +Extra-Source-Files: examples/*.hs +Data-Files: README.md + +tested-with: + GHC==7.6.3 + +source-repository head + type: git + location: https://github.com/letmaik/monadiccp.git + +Flag Debug + Description: Generate debug output + Default: False + +library + hs-source-dirs: src + Build-Depends: base >= 2, base < 5, containers, mtl, random, pretty, parsec >= 3.0, + semigroups + Exposed-Modules: Data.Expr.Sugar + Data.Expr.Data + Data.Expr.Util + Data.Linear + Control.CP.SearchTree + Control.CP.Transformers + Control.CP.ComposableTransformers + Control.CP.Solver + Control.CP.PriorityQueue + Control.CP.Queue + Control.CP.FD.Interface + Control.CP.FD.OvertonFD.OvertonFD + Control.CP.FD.OvertonFD.Sugar + Control.CP.EnumTerm + Control.CP.FD.Solvers + Control.CP.FD.Model + Control.CP.FD.Example + Control.CP.FD.FD + Control.CP.Debug + Control.CP.FD.SearchSpec.Data + Control.CP.FD.OvertonFD.Domain + Control.CP.FD.SimpleFD + Control.CP.FD.Graph + Control.CP.FD.Decompose + Control.Search.Language + Control.Search.Stat + Control.Search.Generator + Control.Search.Combinator.For + Control.Search.Combinator.Until + Control.Search.Combinator.If + Control.Search.Combinator.OrRepeat + Control.Search.Combinator.Let + Control.Search.Combinator.Success + Control.Search.Combinator.Base + Control.Search.Combinator.Failure + Control.Search.Combinator.Once + Control.Search.Combinator.And + Control.Search.Combinator.Repeat + Control.Search.Combinator.Or + Control.Search.Combinator.Post + Control.Search.Combinator.Misc + Control.Search.Combinator.Print + Control.Search.Memo + Control.Search.GeneratorInfo + Control.Search.Constraints + Control.Search.MemoReader + Control.Search.SStateT + Control.Mixin.Mixin + Language.CPP.Syntax.AST + Language.CPP.Pretty + Other-Modules: Control.Monatron.Monatron + Control.Monatron.MonadInfo + Control.Monatron.AutoLift + Control.Monatron.Operations + Control.Monatron.Zipper + Control.Monatron.IdT + Control.Monatron.Codensity + Control.Monatron.Transformer + Control.Monatron.Open + Control.Monatron.AutoInstances + Control.Monatron.MonadT + Control.Monatron.Monad + Control.Monatron.ZipperExamples + GHC-Prof-Options: -auto-all -caf-all + if flag(Debug) + CPP-Options: -DDEBUG + CC-Options: "-ggdb3" "-Wall" + else + CC-Options: "-g0" "-DNDEBUG" "-Wall" + +test-suite olympic + hs-source-dirs: examples + type: exitcode-stdio-1.0 + main-is: Olympic.hs + build-depends: base, monadiccp diff --git a/src/Control/CP/ComposableTransformers.hs b/src/Control/CP/ComposableTransformers.hs new file mode 100644 --- /dev/null +++ b/src/Control/CP/ComposableTransformers.hs @@ -0,0 +1,313 @@ +{- + - Monadic Constraint Programming + - http://www.cs.kuleuven.be/~toms/Haskell/ + - Tom Schrijvers + -} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE Rank2Types #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE ImpredicativeTypes #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE ConstrainedClassMethods #-} + +module Control.CP.ComposableTransformers ( + solve, restart, + NewBound, + Bound(..), + Composition(..), + CTransformer, + CForSolver, + CForResult, + CTreeState, + RestartST(..) , + SealedCST(..), + CNodeBoundedST(..), + CDepthBoundedST(..), + CBranchBoundST(..), + CFirstSolutionST(..), + CSolutionBoundST(..), + CIdentityCST(..), + CRandomST(..), + CLimitedDiscrepancyST(..) +) where + +import Control.CP.Transformers +import Control.CP.SearchTree +import Control.CP.Solver +import Control.CP.Queue +import Control.CP.Debug + +import System.Random (mkStdGen, randoms) + +-------------------------------------------------------------------------------- +-- EVALUATION +-------------------------------------------------------------------------------- + +solve :: (Queue q, Solver solver, CTransformer c, CForSolver c ~ solver, + Elem q ~ (Label solver,Tree solver (CForResult c),CTreeState c)) + => q -> c -> Tree solver (CForResult c) -> (Int,[CForResult c]) +solve q c model = run $ eval model q (TStack c) + + +restart :: (Queue q, Solver solver, CTransformer c, CForSolver c ~ solver, + Elem q ~ (Label solver,Tree solver (CForResult c),CTreeState c)) + => q -> [c] -> Tree solver (CForResult c) -> (Int,[CForResult c]) +restart q cs model = run $ eval model q (RestartST (map Seal cs) return) + + +-------------------------------------------------------------------------------- +-- COMPOSABLE TRANSFORMERS +-------------------------------------------------------------------------------- + +data TStack es ts (solver :: * -> *) a where + TStack :: (CTransformer c, CForSolver c ~ solver, CForResult c ~ a) + => c -> TStack (CEvalState c) (CTreeState c) solver a + +instance Solver solver => Transformer (TStack es ts solver a) where + type EvalState (TStack es ts solver a) = es + type TreeState (TStack es ts solver a) = ts + type ForSolver (TStack es ts solver a) = solver + type ForResult (TStack es ts solver a) = a + initT (TStack c) _ = return $ initCT c + leftT (TStack c) _ = leftCT c + rightT (TStack c) _ = rightCT c + nextT = nextTStack + returnT i wl t@(TStack c) es = returnCT c es (\es' -> continue i wl t es') (\es' -> endT i wl t es') + +nextTStack :: + (Solver solver, Queue q, Elem q ~ (Label solver,Tree solver a,ts)) + => Int -> Tree solver a -> q -> (TStack es ts solver a) -> es -> ts -> solver (Int,[a]) +nextTStack i tree q t es ts = + case t of + TStack c -> + nextCT tree c es ts (\tree' es' ts' -> eval' i tree' q t es' ts') + (\es' -> continue i q t es') + (\es' -> endT i q t es') + +-------------------------------------------------------------------------------- +type CSearchSig c a = + (Solver (CForSolver c), CTransformer c) + => Tree (CForSolver c) a -> c -> CEvalState c -> CTreeState c -> (EVAL c a) -> (CONTINUE c a) -> (EXIT c a) -> (CForSolver c) (Int,[a]) + +type CContinueSig c a = + (Solver (CForSolver c), CTransformer c) + => c -> CEvalState c -> (CONTINUE c a) -> (EXIT c a) -> (CForSolver c) (Int,[a]) + +type EVAL c a = (Tree (CForSolver c) a -> CEvalState c -> CTreeState c-> (CForSolver c) (Int,[a])) +type CONTINUE c a = (CEvalState c -> (CForSolver c) (Int,[a])) +type EXIT c a = (CEvalState c) -> (CForSolver c) (Int,[a]) + +class Solver (CForSolver c) => CTransformer c where + type CEvalState c :: * + type CTreeState c :: * + type CForSolver c :: (* -> *) + type CForResult c :: * + initCT :: c -> (CEvalState c, CTreeState c) + leftCT, rightCT :: c -> CTreeState c -> CTreeState c + leftCT _ = id + rightCT = leftCT + nextCT :: CSearchSig c (CForResult c) + nextCT = evalCT + returnCT :: CContinueSig c (CForResult c) + returnCT = continueCT + completeCT :: c -> CEvalState c -> Bool + completeCT _ _ = True + +evalCT :: CSearchSig c a +evalCT tree c es ts eval continue exit = + eval tree es ts + +continueCT :: CContinueSig c a +continueCT c es continue exit = + continue es + +exitCT :: CContinueSig c a +exitCT c es continue exit = + exit es + +newtype CNodeBoundedST (solver :: * -> *) a = CNBST Int + +instance Solver solver => CTransformer (CNodeBoundedST solver a) where + type CEvalState (CNodeBoundedST solver a) = Int + type CTreeState (CNodeBoundedST solver a) = () + type CForSolver (CNodeBoundedST solver a) = solver + type CForResult (CNodeBoundedST solver a) = a + initCT (CNBST n) = (n,()) + nextCT tree c es ts eval' continue exit + | es == 0 = exit es + | otherwise = eval' tree (es - 1) ts + +newtype CDepthBoundedST (solver :: * -> *) a = CDBST Int + +instance Solver solver => CTransformer (CDepthBoundedST solver a) where + type CEvalState (CDepthBoundedST solver a) = Bool + type CTreeState (CDepthBoundedST solver a) = Int + type CForSolver (CDepthBoundedST solver a) = solver + type CForResult (CDepthBoundedST solver a) = a + initCT (CDBST n) = (True,n) + leftCT _ ts = ts - 1 + nextCT tree c es ts eval' continue exit + | ts == 0 = continue False + | otherwise = eval' tree es ts + completeCT _ es = es + +newtype CLimitedDiscrepancyST (solver :: * -> *) a = CLDST Int + +instance Solver solver => CTransformer (CLimitedDiscrepancyST solver a) where + type CEvalState (CLimitedDiscrepancyST solver a) = () + type CTreeState (CLimitedDiscrepancyST solver a) = Int + type CForSolver (CLimitedDiscrepancyST solver a) = solver + type CForResult (CLimitedDiscrepancyST solver a) = a + initCT (CLDST n) = ((),n) + rightCT _ n = n - 1 + nextCT tree c es ts eval' continue exit + | ts == 0 = continue es + | otherwise = eval' tree es ts + +newtype CRandomST (solver :: * -> *) a = CRST Int + +instance Solver solver => CTransformer (CRandomST solver a) where + type CEvalState (CRandomST solver a) = [Bool] + type CTreeState (CRandomST solver a) = () + type CForSolver (CRandomST solver a) = solver + type CForResult (CRandomST solver a) = a + initCT (CRST n) = (randoms $ mkStdGen n,()) + nextCT tree@(Try l r) c (switch:es) + | switch = evalCT (Try r l) c es + | otherwise = evalCT tree c es + nextCT tree@(Add d (Try l r)) c (switch:es) + | switch = evalCT (Add d (Try r l)) c es + | otherwise = evalCT tree c es + nextCT tree c es = evalCT tree c es + +data CIdentityCST (solver :: * -> *) a = CIST + +instance Solver solver => CTransformer (CIdentityCST solver a) where + type CEvalState (CIdentityCST solver a) = () + type CTreeState (CIdentityCST solver a) = () + type CForSolver (CIdentityCST solver a) = solver + type CForResult (CIdentityCST solver a) = a + initCT _ = ((),()) + +data CFirstSolutionST (solver :: * -> *) a = CFSST + +instance Solver solver => CTransformer (CFirstSolutionST solver a) where + type CEvalState (CFirstSolutionST solver a) = Bool + type CTreeState (CFirstSolutionST solver a) = () + type CForSolver (CFirstSolutionST solver a) = solver + type CForResult (CFirstSolutionST solver a) = a + initCT _ = (True,()) + returnCT _ es continue exit = + exit False + completeCT _ es = es + +data CSolutionBoundST (solver :: * -> *) a = CSBST Int + +instance Solver solver => CTransformer (CSolutionBoundST solver a) where + type CEvalState (CSolutionBoundST solver a) = Int + type CTreeState (CSolutionBoundST solver a) = () + type CForSolver (CSolutionBoundST solver a) = solver + type CForResult (CSolutionBoundST solver a) = a + initCT (CSBST n) = (n,()) + returnCT _ 1 continue exit = exit 0 + returnCT _ n continue exit = continue (n-1) + completeCT _ es = es==0 + +-------------------------------------------------------------------------------- +data Composition es ts solver a where + (:-) :: (CTransformer c1, CTransformer c2, + CForSolver c1 ~ solver, CForSolver c2 ~ solver, + CForResult c1 ~ a, CForResult c2 ~ a + ) + => c1 -> c2 -> Composition (CEvalState c1,CEvalState c2) (CTreeState c1,CTreeState c2) solver a + +instance Solver solver => CTransformer (Composition es ts solver a) where + type CEvalState (Composition es ts solver a) = es + type CTreeState (Composition es ts solver a) = ts + type CForSolver (Composition es ts solver a) = solver + type CForResult (Composition es ts solver a) = a + initCT (c1 :- c2) = let (es1,ts1) = initCT c1 + (es2,ts2) = initCT c2 + in ((es1,es2),(ts1,ts2)) + leftCT (c1 :- c2) (ts1,ts2) = (leftCT c1 ts1,leftCT c2 ts2) + rightCT (c1 :- c2) (ts1,ts2) = (rightCT c1 ts1,rightCT c2 ts2) + nextCT tree (c1 :- c2) (es1,es2) (ts1,ts2) eval' continue exit = + nextCT tree c1 es1 ts1 + (\tree' es1' ts1' -> nextCT tree' c2 es2 ts2 + (\tree'' es2' ts2' -> eval' tree'' (es1',es2') (ts1',ts2')) + (\es2' -> continue (es1',es2')) + (\es2' -> exit (es1',es2')) ) + (\es1' -> continue (es1',es2)) + (\es1' -> exit (es1',es2)) + returnCT (c1 :- c2) (es1,es2) continue exit = + returnCT c1 es1 (\es1' -> returnCT c2 es2 (\es2' -> continue (es1',es2')) (\es2' -> exit (es1',es2'))) + (\es1' -> exit (es1',es2)) + completeCT (c1 :- c2) (es1,es2) = completeCT c1 es1 && completeCT c2 es2 + +-------------------------------------------------------------------------------- +-- BRANCH & BOUND +-------------------------------------------------------------------------------- + +newtype CBranchBoundST (solver :: * -> *) a = CBBST (NewBound solver) +data BBEvalState solver = BBP Int (Bound solver) + +newtype Bound solver = Bound (forall a. (Tree solver a -> Tree solver a)) +type NewBound solver = solver (Bound solver) + +instance (Solver solver) => CTransformer (CBranchBoundST solver a) where + type CEvalState (CBranchBoundST solver a) = BBEvalState solver + type CTreeState (CBranchBoundST solver a) = Int + type CForSolver (CBranchBoundST solver a) = solver + type CForResult (CBranchBoundST solver a) = a + initCT _ = (BBP 0 (Bound id),0) + nextCT tree c es@(BBP nv (Bound bound)) v eval continue exit + | nv > v = eval (bound tree) es nv + | otherwise = eval tree es v + returnCT (CBBST newBound) (BBP v bound) continue exit = + do bound' <- newBound + continue $ BBP (v + 1) bound' + +-------------------------------------------------------------------------------- +-- RESTARTING +-------------------------------------------------------------------------------- + +data SealedCST es ts solver a where + Seal :: CTransformer c => c -> SealedCST (CEvalState c) (CTreeState c) (CForSolver c) (CForResult c) + +instance Solver solver => CTransformer (SealedCST es ts solver a) where + type CEvalState (SealedCST es ts solver a) = es + type CTreeState (SealedCST es ts solver a) = ts + type CForSolver (SealedCST es ts solver a) = solver + type CForResult (SealedCST es ts solver a) = a + leftCT (Seal c) = leftCT c + rightCT (Seal c) = rightCT c + initCT (Seal c) = initCT c + nextCT tree (Seal c) = nextCT tree c + returnCT (Seal c) = returnCT c + completeCT (Seal c) = completeCT c + +data RestartST es ts (solver :: * -> *) a = RestartST [SealedCST es ts solver a] (Tree solver a -> solver (Tree solver a)) + +instance Solver solver => Transformer (RestartST es ts solver a) where + type EvalState (RestartST es ts solver a) = (SealedCST es ts solver a,[SealedCST es ts solver a],es,Label solver,Tree solver a) + type TreeState (RestartST es ts solver a) = ts + type ForSolver (RestartST es ts solver a) = solver + type ForResult (RestartST es ts solver a) = a + initT (RestartST (c:cs) _) tree = + let (es,ts) = initCT c + in do l <- mark + return ((c,cs,es,l,tree),ts) + leftT _ (c,_,_,_,_) = leftCT c + rightT _ (c,_,_,_,_) = rightCT c + nextT i tree q t es@(c,cs,es_c,l,tree0) ts = + nextCT tree c es_c ts (\tree' es_c' ts' -> eval' i tree' q t (c,cs,es_c',l,tree0) ts') + (\es_c' -> continue i q t (c,cs,es_c',l,tree0)) + (\es_c' -> endT i q t (c,cs,es_c',l,tree0)) + returnT i wl t es@(c,cs,es_c,l,tree0) = returnCT c es_c (\es_c' -> continue i wl t (c,cs,es_c',l,tree0)) (\es_c' -> endT i wl t (c,cs,es_c',l,tree0)) + endT i wl t es@(_,[],_,_,_) = return (i,[]) + endT i wl t@(RestartST _ f) es@(c0,(c:cs),es_c0,l,tree0) + | completeCT c0 es_c0 = return (i,[]) + | otherwise = let (es,ts) = initCT c + in do tree' <- f tree0 + continue i (pushQ (l,tree',ts) $ emptyQ wl) t (c,cs,es,l,tree0) + diff --git a/src/Control/CP/Debug.hs b/src/Control/CP/Debug.hs new file mode 100644 --- /dev/null +++ b/src/Control/CP/Debug.hs @@ -0,0 +1,22 @@ +{-# LANGUAGE CPP #-} + +module Control.CP.Debug ( + debug, + imdebug +) where + +import Debug.Trace + +debug :: String -> a -> a +imdebug :: Show a => String -> a -> a + +{-# INLINE debug #-} +{-# INLINE imdebug #-} + +#ifdef DEBUG +debug = trace +imdebug s a = trace ("imdebug " ++ s ++ ": " ++ (show a)) a +#else +debug = flip const +imdebug = flip const +#endif diff --git a/src/Control/CP/EnumTerm.hs b/src/Control/CP/EnumTerm.hs new file mode 100644 --- /dev/null +++ b/src/Control/CP/EnumTerm.hs @@ -0,0 +1,113 @@ +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TransformListComp #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE FlexibleContexts #-} + +module Control.CP.EnumTerm ( + EnumTerm(..), + assignment, assignments, + inOrder, firstFail, middleOut, endsOut, + labelling, levelList, enumerate +) where + +import GHC.Exts (sortWith) + +import Control.CP.Solver +import Control.CP.SearchTree + +class (Solver s, Term s t, Show (TermBaseType s t)) => EnumTerm s t where + type TermBaseType s t :: * + + getDomainSize :: t -> s (Int) + getDomain :: t -> s [TermBaseType s t] + setValue :: t -> TermBaseType s t -> s [Constraint s] + splitDomain :: t -> s ([[Constraint s]],Bool) + splitDomains :: [t] -> s ([[Constraint s]],[t]) + getValue :: t -> s (Maybe (TermBaseType s t)) + defaultOrder :: [t] -> s [t] + enumerator :: (MonadTree m, TreeSolver m ~ s) => Maybe ([t] -> m ()) + + getDomainSize x = do + r <- getDomain x + return $ length r + + getValue x = do + d <- getDomain x + return $ case d of + [v] -> Just v + _ -> Nothing + splitDomain x = do + d <- getDomain x + case d of + [] -> return ([],True) + [_] -> return ([[]],True) + _ -> do + rr <- mapM (setValue x) d + return (rr,True) + + splitDomains [] = return ([[]],[]) + splitDomains (a@(x:b)) = do + s <- getDomainSize x + if s==0 + then return ([],[]) + else if s==1 + then splitDomains b + else do + (r,v) <- splitDomain x + if v + then return (r,b) + else return (r,a) + + defaultOrder = firstFail + enumerator = Nothing + +enumerate :: (MonadTree m, TreeSolver m ~ s, EnumTerm s t) => [t] -> m () +enumerate = case enumerator of + Nothing -> labelling defaultOrder + Just x -> x + +assignment :: (EnumTerm s t, MonadTree m, TreeSolver m ~ s) => t -> m (TermBaseType s t) +assignment q = label $ getValue q >>= \y -> (case y of Just x -> return $ return x; _ -> return false) + +assignments :: (EnumTerm s t, MonadTree m, TreeSolver m ~ s) => [t] -> m [TermBaseType s t] +assignments = mapM assignment + +firstFail :: EnumTerm s t => [t] -> s [t] +firstFail qs = do ds <- mapM getDomainSize qs + return [ q | (d,q) <- zip ds qs + , then sortWith by d ] + +inOrder :: EnumTerm s t => [t] -> s [t] +inOrder = return + +middleOut :: EnumTerm s t => [t] -> s [t] +middleOut l = let n = (length l) `div` 2 in + return $ interleave (drop n l) (reverse $ take n l) + +endsOut :: EnumTerm s t => [t] -> s [t] +endsOut l = let n = (length l) `div` 2 in + return $ interleave (reverse $ drop n l) (take n l) + +interleave [] ys = ys +interleave (x:xs) ys = x:interleave ys xs + +levelList :: (Solver s, MonadTree m, TreeSolver m ~ s) => [m ()] -> m () +levelList [] = false +levelList [a] = a +levelList l = + let len = length l + (p1,p2) = splitAt (len `div` 2) l + in (levelList p1) \/ (levelList p2) +--levelList [] = false +--levelList [a] = a +--levelList (a:b) = a \/ levelList b + +labelling :: (MonadTree m, TreeSolver m ~ s, EnumTerm s t) => ([t] -> s [t]) -> [t] -> m () +labelling _ [] = true +labelling o l = label $ do + ll <- o l + (cl,c) <- splitDomains ll + let ml = map (\l -> foldr (/\) true $ map addC l) cl + return $ do + levelList ml + labelling return c diff --git a/src/Control/CP/FD/Decompose.hs b/src/Control/CP/FD/Decompose.hs new file mode 100644 --- /dev/null +++ b/src/Control/CP/FD/Decompose.hs @@ -0,0 +1,699 @@ +{- + - Monadic Constraint Programming + - http://www.cs.kuleuven.be/~toms/MCP/ + - Pieter Wuille + -} + +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE DatatypeContexts #-} + +module Control.CP.FD.Decompose ( + DecompData, + baseDecompData, + decompose, + decomposeEx, + decompBoolLookup, + decompIntLookup, + decompColLookup, +) where + +import Data.Map (Map) +import qualified Data.Map as Map + +import Data.Set (Set) +import qualified Data.Set as Set + +import Control.Monad.State.Lazy hiding (state) + +import Control.CP.Debug +import Data.Expr.Data +import Data.Expr.Util +import Control.CP.FD.Graph +import Control.CP.FD.Model + +data DecompData = DecompData { + -- expressions currently accessible as variables + cseMapBool :: Map ModelBool EGVarId, + cseMapInt :: Map ModelInt EGVarId, + cseMapCol :: Map ModelCol EGVarId, + -- parent graph's data + cseParent :: Maybe DecompData, + -- expressions imported from parent graph + cseImports :: ([ModelBool],[ModelInt],[ModelCol]), + -- counter for unique id's + cseNIds :: Int, + -- locked nodes (already shown to the caller, and cannot be unified/replaced anymore) + cseLocked :: EGTypeData (Set EGVarId), + -- level of nesting + cseLevel :: Int +} + +decompBoolLookup :: DecompData -> ModelBool -> Maybe EGVarId +decompBoolLookup d v = Map.lookup v $ cseMapBool d + +decompIntLookup :: DecompData -> ModelInt -> Maybe EGVarId +decompIntLookup d v = Map.lookup v $ cseMapInt d + +decompColLookup :: DecompData -> ModelCol -> Maybe EGVarId +decompColLookup d v = Map.lookup v $ cseMapCol d + +-- | base instance of DecompData +baseDecompData :: DecompData +baseDecompData = DecompData { + cseMapBool = Map.empty, + cseMapInt = Map.empty, + cseMapCol = Map.empty, + cseParent = Nothing, + cseImports = ([],[],[]), + cseNIds = 0, + cseLevel = 0, + cseLocked = baseTypeData (Set.empty) +} + +-- | the state for the DCMonad +data DCState = DCState { + dcsData :: DecompData, + dcsModel :: EGModel +} + +-- | base state for the DCMonad +baseDCState = DCState { + dcsData = baseDecompData, + dcsModel = baseGraph +} + +-- | definition of a decomposer monad +newtype DCMonad a = DCMonad { state :: State DCState a } + deriving (Monad, Applicative, Functor, MonadState DCState) + +-- | transform an expression into a graph, taking and returning an updated state +decomposeEx :: DecompData -> Int -> Model -> ([ModelBool],[ModelInt],[ModelCol]) -> Maybe EGModel -> (DecompData,EGModel,Int) +decomposeEx dat vars model (lb,li,lc) prev = + let prog = do + s1 <- get + put $ s1 { dcsData = (dcsData s1) { cseNIds = max vars (cseNIds $ dcsData s1) } } + decomposeBoolEx (Just True) model + mapM_ decomposeBool lb + mapM_ decomposeInt li + mapM_ decomposeCol lc + s2 <- get + put $ s2 { dcsData = (dcsData s2) { cseLocked = egTypeDataMap (\f -> Set.fromList $ Map.keys $ f $ egmLinks $ dcsModel s2) } } + pmodel = case prev of + Nothing -> baseGraph + Just x -> x + res = execState (state prog) $ DCState { dcsData = dat, dcsModel = pmodel } + in (dcsData res,dcsModel res,cseNIds $ dcsData res) + +-- | easier version of decomposeEx that does not require or return a state +decompose :: Model -> EGModel +decompose x = (\(_,x,_) -> x) $ decomposeEx baseDecompData 0 x ([],[],[]) Nothing + +-- | decomposition states can be stacked, this function tests whether a property hold +-- for a state or any of its parents +stateProperty :: (DecompData -> Bool) -> DecompData -> Bool +stateProperty f s = if f s then True else case (cseParent s) of + Just p -> stateProperty f p + _ -> False + +newVar :: EGVarType -> DCMonad EGVarId +newVar typ = do + s <- get + let (nv,nm) = addNode typ (dcsModel s) + put $ s { dcsModel = nm } + return nv + +importBool :: Maybe Bool -> ModelBool -> DCMonad EGVarId +importBool val expr = do + n <- newBoolVar val expr + s <- get + if cseLevel (dcsData s) == 0 + then error $ "Boolean expression (value="++(show val)++") escapes: " ++ (show expr) + else do + let ni = length $ (\(x,_,_)->x) $ cseImports $ dcsData s + put $ s { dcsData = (dcsData s) { cseImports = (\(a,b,c) -> (a++[expr],b,c)) (cseImports $ dcsData s) } } + addConstraint (EGBoolExtern ni) ([n],[],[]) + return n + +importInt :: ModelInt -> DCMonad EGVarId +importInt expr = do + n <- newIntVar expr + s <- get + if cseLevel (dcsData s) == 0 + then error $ "Integer expression escapes: " ++ (show expr) + else do + let ni = length $ (\(_,x,_)->x) $ cseImports $ dcsData s + put $ s { dcsData = (dcsData s) { cseImports = (\(a,b,c) -> (a,b++[expr],c)) (cseImports $ dcsData s) } } + addConstraint (EGIntExtern ni) ([],[n],[]) + return n + +importCol :: ModelCol -> DCMonad EGVarId +importCol expr = do + n <- newColVar expr + s <- get + if cseLevel (dcsData s) == 0 + then error $ "Collection expression escapes: " ++ (show expr) + else do + let ni = length $ (\(_,_,x)->x) $ cseImports $ dcsData s + put $ s { dcsData = (dcsData s) { cseImports = (\(a,b,c) -> (a,b,c++[expr])) (cseImports $ dcsData s) } } + addConstraint (EGColExtern ni) ([],[],[n]) + return n + +unifyVars :: EGVarType -> EGVarId -> EGVarId -> DCMonad Bool +unifyVars typ v1 v2 = do + s <- get + let rm = egTypeGet typ $ cseLocked $ dcsData s + i1 = Set.member v1 rm + i2 = Set.member v2 rm + if (i1 && i2) + then return False -- if both nodes are locked, unification is not possible + else if i1 + then unifyVars typ v2 v1 -- if only i1 is locked, unify v2 with v1 instead of v1 with v2 + else do -- otherwise, really unify + let nm = unifyNodes typ v1 v2 (dcsModel s) + case typ of + EGBoolType -> put $ s { dcsModel = nm, dcsData = (dcsData s) { cseMapBool = Map.map tran $ cseMapBool $ dcsData s } } + EGIntType -> put $ s { dcsModel = nm, dcsData = (dcsData s) { cseMapInt = Map.map tran $ cseMapInt $ dcsData s } } + EGColType -> put $ s { dcsModel = nm, dcsData = (dcsData s) { cseMapCol = Map.map tran $ cseMapCol $ dcsData s } } + return True + where tran = unifyIds v1 v2 + +addConstraint :: EGConstraintSpec -> ([EGVarId],[EGVarId],[EGVarId]) -> DCMonad () +addConstraint spec (lb,li,lc) = do + s <- get + let nm = addEdge spec (EGTypeData { boolData=lb, intData=li, colData=lc }) (dcsModel s) + put $ s { dcsModel = nm } + +newBoolVar :: Maybe Bool -> ModelBool -> DCMonad EGVarId +newBoolVar val expr = do + n <- case val of + Nothing -> newVar EGBoolType + Just x -> decomposeBool $ BoolConst x + s <- get + let nc = Map.insert expr n (cseMapBool $ dcsData s) + put $ s { dcsData = (dcsData s) { cseMapBool = nc } } + return n + +newIntVar :: ModelInt -> DCMonad EGVarId +newIntVar expr = do + n <- newVar EGIntType + s <- get + let nc = Map.insert expr n (cseMapInt $ dcsData s) + put $ s { dcsData = (dcsData s) { cseMapInt = nc } } + return n + +newColVar :: ModelCol -> DCMonad EGVarId +newColVar expr = do + n <- newVar EGColType + s <- get + let nc = Map.insert expr n (cseMapCol $ dcsData s) + put $ s { dcsData = (dcsData s) { cseMapCol = nc } } + return n + +decomposeSubmodel :: (Int,Int,Int) -> (([ModelBool],[ModelInt],[ModelCol]) -> DCMonad ()) -> DCMonad (EGModel,([EGVarId],[EGVarId],[EGVarId])) +decomposeSubmodel (nArgsBool,nArgsInt,nArgsCol) m = do + oArgsBool <- mapM (const $ nextId >>= (\x -> return $ BoolTerm $ ModelBoolVar $ x)) [1..nArgsBool] + oArgsInt <- mapM (const $ nextId >>= (\x -> return $ Term $ ModelIntVar $ x)) [1..nArgsInt] + oArgsCol <- mapM (const $ nextId >>= (\x -> return $ ColTerm $ ModelColVar $ x)) [1..nArgsCol] + s <- get + let sm = m (oArgsBool,oArgsInt,oArgsCol) + ns = execState (state sm) $ baseDCState { dcsData = (dcsData baseDCState) { cseLevel = 1 + (cseLevel $ dcsData s), cseNIds = 0+(cseNIds $ dcsData s), cseParent = Just $ dcsData s } } + put $ s { dcsData = (dcsData s) { cseNIds = 0+(cseNIds $ dcsData ns) } } + argsBool <- mapM decomposeBool $ (\(x,_,_) -> x) $ cseImports $ dcsData ns + argsInt <- mapM decomposeInt $ (\(_,x,_) -> x) $ cseImports $ dcsData ns + argsCol <- mapM decomposeCol $ (\(_,_,x) -> x) $ cseImports $ dcsData ns + return (dcsModel ns, (argsBool,argsInt,argsCol)) + +constIntTrans :: ModelIntTerm ModelFunctions -> EGParTerm +constIntTrans (ModelIntPar x) = EGPTParam x +constIntTrans x = error $ "non-constant int transform: "++(show x) +constColTrans :: ModelColTerm ModelFunctions -> EGParColTerm +constColTrans (ModelColPar x) = EGPTColParam x +constColTrans x = error $ "non-constant col transform: "++(show x) +constBoolTrans :: ModelBoolTerm ModelFunctions -> EGParBoolTerm +constBoolTrans (ModelBoolPar x) = EGPTBoolParam x +constBoolTrans x = error $ "non-constant bool transform: "++(show x) +constIntTransInv :: EGParTerm -> ModelIntTerm ModelFunctions +constIntTransInv (EGPTParam x) = ModelIntPar x +constColTransInv :: EGParColTerm -> ModelColTerm ModelFunctions +constColTransInv (EGPTColParam x) = ModelColPar x +constBoolTransInv :: EGParBoolTerm -> ModelBoolTerm ModelFunctions +constBoolTransInv (EGPTBoolParam x) = ModelBoolPar x + +constTrans = (constIntTrans,constColTrans,constBoolTrans,constIntTransInv,constColTransInv,constBoolTransInv) +invConstTrans = (constIntTransInv,constColTransInv,constBoolTransInv,constIntTrans,constColTrans,constBoolTrans) + +dependenceTester d = + ( + \x -> if Map.member x (cseMapInt d) && not (x `elem` ((\(_,x,_) -> x) $ cseImports d)) then Just True else Nothing, + \x -> if Map.member x (cseMapCol d) && not (x `elem` ((\(_,_,x) -> x) $ cseImports d)) then Just True else Nothing, + \x -> case x of + BoolTerm (ModelExtra _) -> Just True + _ -> if Map.member x (cseMapBool d) && not (x `elem` ((\(x,_,_) -> x) $ cseImports d)) then Just True else Nothing + ) + +dependentIntExpr :: DecompData -> ModelInt -> Bool +dependentIntExpr d = propertyEx $ dependenceTester d +dependentBoolExpr :: DecompData -> ModelBool -> Bool +dependentBoolExpr d = boolPropertyEx $ dependenceTester d +dependentColExpr :: DecompData -> ModelCol -> Bool +dependentColExpr d = colPropertyEx $ dependenceTester d + +nextId :: DCMonad Int +nextId = do + s <- get + let n = cseNIds $ dcsData s + put $ s { dcsData = (dcsData s) { cseNIds = n + 1 } } + return n + +----------------------------------------- +-- | Decomposition of special values | -- +----------------------------------------- + +decomposeBool :: ModelBool -> DCMonad EGVarId +decomposeBool expr = do + (Just x) <- decomposeBoolEx Nothing expr + return x + +decomposeBoolEx :: Maybe Bool -> ModelBool -> DCMonad (Maybe EGVarId) +decomposeBoolEx val expr = do + s <- get + debug ("decomposeBoolEx [level "++(show $ cseLevel $ dcsData s)++"] val="++(show val)++" expr="++(show expr)) $ return () + let key = expr + case Map.lookup key (cseMapBool $ dcsData s) of -- local variable or already locally decomposed expression + Just i -> do + debug ("decomposeBoolEx [level "++(show $ cseLevel $ dcsData s)++"] val="++(show val)++" expr="++(show expr)++": already decomposed: "++(show i)) $ return () + return $ Just i + Nothing -> if (modelVariantBool expr) + then do + if (stateProperty (Map.member key . cseMapBool) $ dcsData s) && not (dependentBoolExpr (dcsData s) expr) && (cseLevel $ dcsData s) > 0 + then do -- Loop Invariant Code Motion + debug ("decomposeBoolEx: [level "++(show $ cseLevel $ dcsData s)++"] [variant indep] "++(show expr)) $ return () + n <- importBool val expr + return $ Just n + else do + debug ("decomposeBoolEx: [level "++(show $ cseLevel $ dcsData s)++"] [variant dep] "++(show expr)) $ return () + realDecomposeBoolEx val expr + else do + debug ("decomposeBoolEx: [level "++(show $ cseLevel $ dcsData s)++"] [invariant] "++(show expr)) $ return () + n <- newBoolVar val expr + let tr = boolTransform constTrans expr + addConstraint (EGBoolValue tr) ([n],[],[]) + return $ Just n + +decomposeInt :: ModelInt -> DCMonad EGVarId +decomposeInt expr = do + s <- get + debug ("decomposeInt [level "++(show $ cseLevel $ dcsData s)++"] expr="++(show expr)) $ return () + let key = expr + case Map.lookup key (cseMapInt $ dcsData s) of + Just i -> return i + Nothing -> if (modelVariantInt expr) + then if (stateProperty (Map.member key . cseMapInt) $ dcsData s) && not (dependentIntExpr (dcsData s) expr) && (cseLevel $ dcsData s) > 0 + then do + debug ("decomposeInt: [level "++(show $ cseLevel $ dcsData s)++"] [variant indep] "++(show expr)) $ return () + importInt expr + else do + debug ("decomposeInt: [level "++(show $ cseLevel $ dcsData s)++"] [variant dep] "++(show expr)) $ return () + realDecomposeInt expr + else do + debug ("decomposeInt: [level "++(show $ cseLevel $ dcsData s)++"] [invariant] "++(show expr)) $ return () + n <- newIntVar expr + let tr = transform constTrans expr + addConstraint (EGIntValue tr) ([],[n],[]) + return n + +decomposeCol :: ModelCol -> DCMonad EGVarId +decomposeCol expr = do + s <- get + debug ("decomposeCol [level "++(show $ cseLevel $ dcsData s)++"] expr="++(show expr)) $ return () + let key = expr + case Map.lookup key (cseMapCol $ dcsData s) of + Just i -> return i + Nothing -> if (modelVariantCol expr) + then if (stateProperty (Map.member key . cseMapCol) $ dcsData s) && not (dependentColExpr (dcsData s) expr) && (cseLevel $ dcsData s) > 0 + then do + debug ("decomposeCol: [level "++(show $ cseLevel $ dcsData s)++"] [variant indep] "++(show expr)) $ return () + importCol expr + else do + debug ("decomposeCol: [level "++(show $ cseLevel $ dcsData s)++"] [variant dep] "++(show expr)) $ return () + realDecomposeCol expr + else do + debug ("decomposeCol: [level "++(show $ cseLevel $ dcsData s)++"] [invariant] "++(show expr)) $ return () + n <- newColVar expr + let tr = colTransform constTrans expr + addConstraint (EGColValue tr) ([],[],[n]) + return n + + +------------------------------------------ +-- | Real decomposers for expressions | -- +------------------------------------------ + +realDecomposeBoolEx :: Maybe Bool -> ModelBool -> DCMonad (Maybe EGVarId) +realDecomposeBoolEx val expr = case expr of + BoolTerm (ModelExtra (ForNewBool f)) -> do + n <- nextId + let v = BoolTerm $ ModelBoolVar n + newBoolVar Nothing v + decomposeBoolEx val $ f v + BoolTerm (ModelExtra (ForNewInt f)) -> do + n <- nextId + let v = Term $ ModelIntVar n + newIntVar v + decomposeBoolEx val $ f v + BoolTerm (ModelExtra (ForNewCol f)) -> do + n <- nextId + let v = ColTerm $ ModelColVar n + newColVar v + decomposeBoolEx val $ f v + BoolTerm (ModelBoolVar i) -> do + n <- newBoolVar val expr + return $ Just n + BoolCond c t f -> case val of + Just True -> do + dc <- decomposeBool c + di <- decomposeBool $ boolSimplify $ BoolNot c + ct <- decomposeBool (BoolConst True) + if (t /= BoolConst True) + then do + dt <- decomposeBool t + addConstraint EGCondEqual ([dc,dt,ct],[],[]) + else return () + if (f /= BoolConst True) + then do + df <- decomposeBool f + addConstraint EGCondEqual ([di,df,ct],[],[]) + else return () + return Nothing + _ -> error "No reified boolean conditional exists" + BoolAnd a b -> case val of + Just True -> do + decomposeBoolEx val a + decomposeBoolEx val b + return Nothing + _ -> do + n <- newBoolVar val expr + ad <- decomposeBool a + bd <- decomposeBool b + addConstraint EGAnd ([n,ad,bd],[],[]) + return $ Just n + BoolOr a b -> case val of + Just False -> do + decomposeBoolEx val a + decomposeBoolEx val b + return Nothing + _ -> do + n <- newBoolVar val expr + ad <- decomposeBool a + bd <- decomposeBool b + addConstraint EGOr ([n,ad,bd],[],[]) + return $ Just n + BoolNot a -> case val of + Just True -> do + decomposeBoolEx (Just False) a + return Nothing + Just False -> do + decomposeBoolEx (Just True) a + return Nothing + _ -> do + n <- newBoolVar val expr + ad <- decomposeBool a + addConstraint EGNot ([n,ad],[],[]) + return $ Just n + Rel a r b -> case (r,val) of + (EREqual,Just True) -> do + ad <- decomposeInt a + bd <- decomposeInt b + res <- unifyVars EGIntType ad bd + if res + then return Nothing + else do + n <- decomposeBool (BoolConst True) + addConstraint EGEqual ([n],[ad,bd],[]) + return Nothing + (ERDiff,Just False) -> do + ad <- decomposeInt a + bd <- decomposeInt b + res <- unifyVars EGIntType ad bd + if res + then return Nothing + else do + n <- decomposeBool (BoolConst True) + addConstraint EGEqual ([n],[ad,bd],[]) + return Nothing + _ -> do + n <- newBoolVar val expr + ad <- decomposeInt a + bd <- decomposeInt b + addConstraint (case r of + EREqual -> EGEqual + ERDiff -> EGDiff + ERLess -> EGLess True + ) ([n],[ad,bd],[]) + return $ Just n + ColEqual a b -> case val of + Just True -> do + ad <- decomposeCol a + bd <- decomposeCol b + res <- unifyVars EGColType ad bd + if not res + then error "unification of collections failed" + else return Nothing + _ -> error "No negated or reified version of ColEqual exists" + AllDiff b c -> case val of + Just True -> do + ac <- decomposeCol c + addConstraint (EGAllDiff b) ([],[],[ac]) + return Nothing + _ -> error "No negated or reified version of AllDiff exists" + Sorted b c -> case val of + Just True -> do + ac <- decomposeCol c + addConstraint (EGSorted b) ([],[],[ac]) + return Nothing + _ -> error "No negated or reified version of Sorted exists" + Dom i c -> case val of + Just True -> do + ac <- decomposeCol c + ai <- decomposeInt i + addConstraint EGDom ([],[ai],[ac]) + return Nothing + _ -> error "No negated or reified version of Dom exists" + BoolEqual a b -> case val of + Just True -> do + ad <- decomposeBool a + bd <- decomposeBool b + res <- unifyVars EGBoolType ad bd + if res + then return Nothing + else do + n <- decomposeBool (BoolConst True) + addConstraint EGEquiv ([n,ad,bd],[],[]) + return Nothing + _ -> do + n <- newBoolVar val expr + ad <- decomposeBool a + bd <- decomposeBool b + addConstraint EGEquiv ([n,ad,bd],[],[]) + return $ Just n +-- BoolAll f (ColRange l h) -> do +-- ld <- decomposeInt l +-- hd <- decomposeInt h +-- n <- newBoolVar val expr +-- (smod,(argsBool,argsInt,argsCol)) <- decomposeSubmodel (0,1,0) $ \([],[oarg],[]) -> do +-- let sexpr = f oarg +-- arg <- newIntVar oarg +-- debug ("BoolAllC: arg="++(show arg)++" oarg="++(show oarg)) $ return () +-- addConstraint (EGIntExtern $ -1) ([],[arg],[]) +-- case val of +-- Just True -> do +-- decomposeBoolEx (Just True) sexpr +-- return () +-- _ -> do +-- res <- decomposeBool sexpr +-- addConstraint (EGBoolExtern $ -1) ([res],[],[]) +-- let force = case val of +-- Just True -> True +-- _ -> False +-- addConstraint (EGAllC smod (length argsBool,length argsInt,length argsCol) force) ([n]++argsBool,[ld,hd]++argsInt,argsCol) +-- return $ Just n +-- BoolAny f (ColRange l h) -> do +-- ld <- decomposeInt l +-- hd <- decomposeInt h +-- n <- newBoolVar val expr +-- (smod,(argsBool,argsInt,argsCol)) <- decomposeSubmodel (0,1,0) $ \([],[oarg],[]) -> do +-- let sexpr = f oarg +-- arg <- newIntVar oarg +-- addConstraint (EGIntExtern $ -1) ([],[arg],[]) +-- case val of +-- Just False -> do +-- decomposeBoolEx (Just False) sexpr +-- return () +-- _ -> do +-- res <- decomposeBool sexpr +-- addConstraint (EGBoolExtern $ -1) ([res],[],[]) +-- let force = case val of +-- Just False -> True +-- _ -> False +-- addConstraint (EGAnyC smod (length argsBool,length argsInt,length argsCol) force) ([n]++argsBool,[ld,hd]++argsInt,argsCol) +-- return $ Just n + BoolAll f c -> do + cd <- decomposeCol c + n <- newBoolVar val expr + (smod,(argsBool,argsInt,argsCol)) <- decomposeSubmodel (0,1,0) $ \([],[oarg],[]) -> do + let sexpr = f oarg + arg <- newIntVar oarg + addConstraint (EGIntExtern $ -1) ([],[arg],[]) + case val of + Just True -> do {- in case a BoolAll itself must hold, each submodel must hold too -} + decomposeBoolEx (Just True) sexpr + return () + _ -> do + res <- decomposeBool sexpr + addConstraint (EGBoolExtern $ -1) ([res],[],[]) + let force = + case val of + Just True -> True + _ -> False + addConstraint (EGAll smod (length argsBool,length argsInt,length argsCol) force) ([n] ++ argsBool,argsInt,[cd] ++ argsCol) + return $ Just n + BoolAny f c -> do + cd <- decomposeCol c + n <- newBoolVar val expr + (smod,(argsBool,argsInt,argsCol)) <- decomposeSubmodel (0,1,0) $ \([],[oarg],[]) -> do + let sexpr = f oarg + arg <- newIntVar oarg + addConstraint (EGIntExtern $ -1) ([],[arg],[]) + case val of + Just False -> do {- in case a BoolAny itself may not hold, each submodel may not hold either -} + decomposeBoolEx (Just False) sexpr + return () + _ -> do + res <- decomposeBool sexpr + addConstraint (EGBoolExtern $ -1) ([res],[],[]) + let force = + case val of + Just False -> True + _ -> False + addConstraint ((if force then EGAll else EGAny) smod (length argsBool,length argsInt,length argsCol) force) ([n] ++ argsBool,argsInt,[cd] ++ argsCol) + return $ Just n + _ -> error $ "Unable to decompose boolean expression: " ++ (show expr) ++ "(== " ++ (show val) ++ ")" + +realDecomposeInt :: ModelInt -> DCMonad EGVarId +realDecomposeInt expr = do + let pIntOp a x b = do + n <- newIntVar expr + ad <- decomposeInt a + bd <- decomposeInt b + addConstraint x ([],[n,ad,bd],[]) + return n + case expr of + Term (ModelIntVar i) -> newIntVar expr + Plus a b -> pIntOp a EGPlus b + Minus a b -> pIntOp a EGMinus b + Mult a b -> pIntOp a EGMult b + Div a b -> pIntOp a EGDiv b + Mod a b -> pIntOp a EGMod b + Abs a -> do + n <- newIntVar expr + ad <- decomposeInt a + addConstraint EGAbs ([],[n,ad],[]) + return n + At a b -> do + n <- newIntVar expr + ad <- decomposeCol a + bd <- decomposeInt b + addConstraint EGAt ([],[n,bd],[ad]) + return n + ColSize a -> do + n <- newIntVar expr + ad <- decomposeCol a + addConstraint EGSize ([],[n],[ad]) + return n + Channel a -> do + n <- newIntVar expr + ad <- decomposeBool a + addConstraint EGChannel ([ad],[n],[]) + return n + Cond c t f -> do + n <- newIntVar expr + cd <- decomposeBool c + td <- decomposeInt t + fd <- decomposeInt f + addConstraint EGCondInt ([cd],[n,td,fd],[]) + return n + Fold f i c -> do + cd <- decomposeCol c + id <- decomposeInt i + n <- newIntVar expr + (smod,(argsBool,argsInt,argsCol)) <- decomposeSubmodel (0,2,0) $ \([],[oacc,oarg],[]) -> do + let sexpr = f oacc oarg + acc <- newIntVar oacc + addConstraint (EGIntExtern $ -2) ([],[acc],[]) + arg <- newIntVar oarg + addConstraint (EGIntExtern $ -3) ([],[arg],[]) + res <- decomposeInt sexpr + addConstraint (EGIntExtern $ -1) ([],[res],[]) + addConstraint (EGFold smod (length argsBool,length argsInt,length argsCol)) (argsBool,[n,id]++argsInt,[cd]++argsCol) + return n + _ -> error $ "Unable to decompose expression: " ++ (show expr) + +listAll :: [a] -> (a -> Maybe b) -> Maybe [b] +listAll [] _ = Just [] +listAll (a:b) f = case f a of + Nothing -> Nothing + Just r -> case listAll b f of + Nothing -> Nothing + Just x -> Just (r:x) + +realDecomposeCol :: ModelCol -> DCMonad EGVarId +realDecomposeCol expr = case expr of + ColList l -> do + n <- newColVar expr + ld <- mapM decomposeInt l + addConstraint (EGList (length l)) ([],ld,[n]) + return n + ColTerm (ModelColVar i) -> newColVar expr + ColRange a b -> do + n <- newColVar expr + ad <- decomposeInt a + bd <- decomposeInt b + addConstraint EGRange ([],[ad,bd],[n]) + return n + ColCat a b -> do + n <- newColVar expr + ad <- decomposeCol a + bd <- decomposeCol b + addConstraint EGCat ([],[],[n,ad,bd]) + return n +{- ColSlice f n c -> do + nn <- newColVar expr + cd <- decomposeCol c + let fd x = debug ("ColSlice: f("++(show x)++")="++(show $ f $ transform invConstTrans x)) $ transform constTrans $ f $ transform invConstTrans x + let nd = transform constTrans n + addConstraint (EGSlice fd nd) ([],[],[nn,cd]) + return nn -} + ColSlice f nn c -> do + cd <- decomposeCol c + nd <- decomposeInt nn + n <- newColVar expr + (smod,(argsBool,argsInt,argsCol)) <- decomposeSubmodel (0,1,0) $ \([],[oarg],[]) -> do + let sexpr = f oarg + arg <- newIntVar oarg + addConstraint (EGIntExtern $ -2) ([],[arg],[]) + res <- decomposeInt sexpr + addConstraint (EGIntExtern $ -1) ([],[res],[]) + addConstraint (EGSlice smod (length argsBool,length argsInt,length argsCol)) (argsBool,[nd]++argsInt,[n,cd]++argsCol) + return n + ColMap f c -> do + cd <- decomposeCol c + n <- newColVar expr + (smod,(argsBool,argsInt,argsCol)) <- decomposeSubmodel (0,1,0) $ \([],[oarg],[]) -> do + let sexpr = f oarg + arg <- newIntVar oarg + addConstraint (EGIntExtern $ -2) ([],[arg],[]) + res <- decomposeInt sexpr + addConstraint (EGIntExtern $ -1) ([],[res],[]) + addConstraint (EGMap smod (length argsBool,length argsInt,length argsCol)) (argsBool,argsInt,[n,cd]++argsCol) + return n + _ -> error $ "Unable to decompose collection: " ++ (show expr) diff --git a/src/Control/CP/FD/Example.hs b/src/Control/CP/FD/Example.hs new file mode 100644 --- /dev/null +++ b/src/Control/CP/FD/Example.hs @@ -0,0 +1,110 @@ +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE AllowAmbiguousTypes #-} + +module Control.CP.FD.Example ( + example_main, + example_sat_main, + example_sat_main_void, + example_sat_main_single, + example_sat_main_single_expr, + example_sat_main_coll_expr, + example_min_main, + example_min_main_void, + example_min_main_single, + example_min_main_single_expr, + example_min_main_coll_expr, + runSolve, + labeller, + postMinimize, + ExampleModel, ExampleMinModel, + module Control.CP.FD.Interface, +) where + + +import System.Environment (getArgs) +import Data.Maybe (fromJust,isJust) +import Data.Map (Map) +import qualified Data.Map as Map +import Data.List (init,last) + +import Control.CP.FD.OvertonFD.OvertonFD +import Control.CP.FD.OvertonFD.Sugar +import Control.CP.FD.FD +import Control.CP.FD.Model + +import Control.CP.Debug + +import Control.CP.FD.Interface +import Control.CP.SearchTree +import Control.CP.EnumTerm +import Control.CP.ComposableTransformers +import Control.CP.FD.Solvers + +import Control.Monad.Cont + +type ExampleModel t = (forall s m. (Show (FDIntTerm s), FDSolver s, MonadTree m, TreeSolver m ~ (FDInstance s)) => t -> m (ModelCol)) +type ExampleMinModel t = (forall s m. (Show (FDIntTerm s), FDSolver s, MonadTree m, TreeSolver m ~ (FDInstance s)) => t -> m (ModelInt,ModelCol)) + +postMinimize :: ExampleMinModel t -> ExampleModel t +postMinimize m = \x -> do + (min,res) <- m x + debug ("postMinimize: min="++(show min)) $ return () + label $ do + setMinimizeVar min + return $ return res + +runSolveSAT x = solve dfs fs x +runSolveMIN x = solve dfs (bb boundMinimize) x + +runSolve False x = runSolveSAT x +runSolve True x = runSolveMIN x + +labeller col = do + label $ do + min <- getMinimizeVar + case min of + Nothing -> return $ labelCol col + Just v -> return $ do + enumerate [v] + labelCol col + +example_main :: ExampleModel [String] -> ExampleModel ModelInt -> ExampleModel ModelCol -> Bool -> IO () +example_main f fx fcx typ = do + args <- getArgs + case args of + ("overton_run":r) -> print $ runSolve typ $ ((f r) :: Tree (FDInstance OvertonFD) ModelCol) >>= labeller + [] -> putStr "Solver type required: must be overton_run\n" + (a:r) -> putStr ("Unsupported solver: " ++ a ++ "\n") + +example_min_main :: ExampleMinModel [String] -> ExampleMinModel ModelInt -> ExampleMinModel ModelCol -> IO () +example_min_main f fx fcx = example_main (postMinimize f) (postMinimize fx) (postMinimize fcx) True + +example_sat_main :: ExampleModel [String] -> ExampleModel ModelInt -> ExampleModel ModelCol -> IO () +example_sat_main f fx fcx = example_main f fx fcx False + +example_sat_main_void :: ExampleModel () -> IO () +example_sat_main_void f = example_sat_main (const $ f ()) (const $ f ()) (const $ f ()) + +example_min_main_void :: ExampleMinModel () -> IO () +example_min_main_void f = example_min_main (const $ f ()) (const $ f ()) (const $ f ()) + +example_sat_main_single :: Read n => ExampleModel n -> IO () +example_sat_main_single f = example_sat_main (f . read . head) (error "Uncompilable model") (error "Uncompilable model") + +example_min_main_single :: Read n => ExampleMinModel n -> IO () +example_min_main_single f = example_min_main (f . read . head) (error "Uncompilable model") (error "Uncompilable model") + +example_sat_main_single_expr :: ExampleModel ModelInt -> IO () +example_sat_main_single_expr f = example_sat_main (f . fromInteger . read . head) f (\x -> f $ x!(cte (0::Integer))) + +example_min_main_single_expr :: ExampleMinModel ModelInt -> IO () +example_min_main_single_expr f = example_min_main (f . fromInteger . read . head) f (\x -> f $ x!(cte (0::Integer))) + +example_sat_main_coll_expr :: ExampleModel ModelCol -> IO () +example_sat_main_coll_expr f = example_sat_main (f . list . foldr (++) [] . map (map fromInteger . read . (\x -> "[" ++ x ++ "]"))) (f. list . (\x -> [x])) f + +example_min_main_coll_expr :: ExampleMinModel ModelCol -> IO () +example_min_main_coll_expr f = example_min_main (f . list . foldr (++) [] . map (map fromInteger . read . (\x -> "[" ++ x ++ "]"))) (f. list . (\x -> [x])) f diff --git a/src/Control/CP/FD/FD.hs b/src/Control/CP/FD/FD.hs new file mode 100644 --- /dev/null +++ b/src/Control/CP/FD/FD.hs @@ -0,0 +1,1556 @@ +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE TypeSynonymInstances #-} +{-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE DatatypeContexts #-} + +module Control.CP.FD.FD ( + module Data.Expr.Sugar, + FDInstance, + FDSolver(..), + FDSpecInfo, + FDSpecInfoBool(..), FDSpecInfoInt(..), FDSpecInfoCol(..), + liftFD, addFD, + SpecFn, SpecFnRes, SpecResult(..), + getBoolSpec_, getIntSpec_, getColSpec_, + getBoolSpec, getIntSpec, getColSpec, + getEdge, markEdge, + setFailed, + getLevel, + getIntVal, getBoolVal, getColVal, + getIntTerm, getBoolTerm, getColTerm, + getSingleIntTerm, + getDefBoolSpec, getDefIntSpec, getDefColSpec, + getFullBoolSpec, getFullIntSpec, getFullColSpec, + getColItems, + fdSpecInfo_spec, + specInfoBoolTerm, specInfoIntTerm, + Control.CP.FD.FD.newInt, Control.CP.FD.FD.newBool, Control.CP.FD.FD.newCol, + procSubModel, procSubModelEx, specSubModelEx, + runFD, + setMinimizeVar, boundMinimize, getMinimizeTerm, getMinimizeVar, + fdNewvar, +) where + +import Control.Monad.State.Lazy +import Control.Monad.Trans +import qualified Data.Map as Map +import Data.Map(Map) +import Data.Maybe +import Data.List +import qualified Data.Set as Set +import Data.Set(Set) + +import Control.CP.Debug +import Data.Expr.Sugar +import Data.Expr.Data +-- import Control.CP.FD.Expr.Util +import Control.CP.FD.Model +import Control.CP.FD.Decompose +import Control.CP.FD.Graph +import Control.CP.SearchTree +import Control.CP.ComposableTransformers +import Control.CP.EnumTerm +import Control.CP.Solver +import Control.Mixin.Mixin + +-- | state kept by FDInstance, in addition to the underlying solver's internal state +data FDSolver s => FDState s = FDState { + -- | expression representing unprocessed constraints + fdsExpr :: Model, + -- | model being processed now + fdsModel :: Maybe EGModel, + -- | private data for the decomposer (kept to optimize constraints which aren't added in one go) + fdsDecomp :: DecompData, + -- | when adding constraints, the EGEdgeId's occurring in the decomposed model + fdsNewEdges :: Set EGEdgeId, + fdsDoneEdges :: Set EGEdgeId, + -- | expressions that need to be decomposed + fdsForceBool :: [ModelBool], fdsForcedBool :: Map ModelBool (FDBoolTerm s), + fdsForceInt :: [ModelInt], fdsForcedInt :: Map ModelInt (FDIntTerm s), + fdsForceCol :: [ModelCol], + -- | variable counter + fdsVars :: Int, + + -- | already introduced integer variables/terms/constants/expressions + fdsIntVars :: Map EGVarId (FDSpecInfoInt s), + -- | needed sets of possible types + fdsIntVarTypes :: Map EGVarId (Set (FDIntSpecTypeSet s)), + -- | which variables are being decomposed right now + fdsIntVarBusy :: Set EGVarId, + -- | which nodes are unified with which others + fdsIntUnifies :: Map EGVarId (Set EGVarId), + + -- | already introduced boolean variables/terms/constants/expressions + fdsBoolVars :: Map EGVarId (FDSpecInfoBool s), + fdsBoolVarTypes :: Map EGVarId (Set (FDBoolSpecTypeSet s)), + fdsBoolVarBusy :: Set EGVarId, + fdsBoolUnifies :: Map EGVarId (Set EGVarId), + -- | already introduced collection variables/terms/constants/expressions + fdsColVars :: Map EGVarId (FDSpecInfoCol s), + fdsColVarTypes :: Map EGVarId (Set (FDColSpecTypeSet s)), + fdsColVarBusy :: Set EGVarId, + fdsColUnifies :: Map EGVarId (Set EGVarId), + + -- | db of specifiers + fdsDb :: SpecDb s, + + -- | solver is failed? + fdsFailed :: Bool, + + -- | level of nesting + fdsLevel :: Int, + + -- | levels of dummyness + fdsDummyLevel :: Int, + + fdsMinimizeVar :: Maybe ModelInt, + fdsMinimizeTerm :: Maybe (FDIntTerm s) +} + +myFromJust str m = case m of + Nothing -> error $ "myFromJust: " ++ str + Just x -> x + +unifyInts a b = do + s <- get + let sa = Map.findWithDefault (Set.singleton a) a (fdsIntUnifies s) + let sb = Map.findWithDefault (Set.singleton b) b (fdsIntUnifies s) + let sc = Set.union sa sb + put s { fdsIntUnifies = foldr (\a b -> Map.insert a sc b) (fdsIntUnifies s) $ Set.toList sc } + +unifyBools a b = do + s <- get + let sa = Map.findWithDefault (Set.singleton a) a (fdsBoolUnifies s) + let sb = Map.findWithDefault (Set.singleton b) b (fdsBoolUnifies s) + let sc = Set.union sa sb + put s { fdsBoolUnifies = foldr (\a b -> Map.insert a sc b) (fdsBoolUnifies s) $ Set.toList sc } + +unifyCols a b = do + s <- get + let sa = Map.findWithDefault (Set.singleton a) a (fdsColUnifies s) + let sb = Map.findWithDefault (Set.singleton b) b (fdsColUnifies s) + let sc = Set.union sa sb + put s { fdsColUnifies = foldr (\a b -> Map.insert a sc b) (fdsColUnifies s) $ Set.toList sc } + +mapVals :: Show b => (a -> Maybe b) -> [a] -> [String] +mapVals f l = nub $ sort $ map show $ catMaybes $ map f l + +dumpSpec :: FDSolver s => FDState s -> String +dumpSpec s = + foldl (++) "" (map (\(i,r) -> "i" ++ (show $ unVarId i) ++ "\n" ++ foldl (++) "" (map (\x -> " "++x++"\n") (mapVals (fdspIntSpec r) (Nothing : (map Just $ Set.toList $ fdspIntTypes r))))) $ Map.toList (fdsIntVars s)) ++ + foldl (++) "" (map (\(i,r) -> "b" ++ (show $ unVarId i) ++ "\n" ++ foldl (++) "" (map (\x -> " "++x++"\n") (mapVals (fdspBoolSpec r) (Nothing : (map Just $ Set.toList $ fdspBoolTypes r))))) $ Map.toList (fdsBoolVars s)) ++ + foldl (++) "" (map (\(i,r) -> "c" ++ (show $ unVarId i) ++ "\n" ++ foldl (++) "" (map (\x -> " "++x++"\n") (mapVals (fdspColSpec r) (Nothing : (map Just $ Set.toList $ fdspColTypes r))))) $ Map.toList (fdsColVars s)) + +setMinimizeVar :: (Show (FDIntTerm s), FDSolver s) => ModelInt -> FDInstance s () +setMinimizeVar v = do + s <- get + case Map.lookup v (fdsForcedInt s) of + Just t -> debug ("setMinimizeVar: (cached) var="++(show v)++" term="++(show t)) $ put s { fdsMinimizeVar = Just v, fdsMinimizeTerm = Just t } + Nothing -> do + var <- getSingleIntTerm v + s2 <- get + debug ("setMinimizeVar: (not cached) var="++(show v)++" term="++(show var)) $ put s2 { fdsMinimizeVar = Just v, fdsMinimizeTerm = Just var } + +getMinimizeVar :: (Show (FDIntTerm s), FDSolver s) => FDInstance s (Maybe ModelInt) +getMinimizeVar = do + s <- get + return $ fdsMinimizeVar s + +getMinimizeTerm :: (Show (FDIntTerm s), FDSolver s) => FDInstance s (Maybe (FDIntTerm s)) +getMinimizeTerm = do + s <- get + debug ("getMinimizeTerm: "++(show $ fdsMinimizeTerm s)) $ return () + return (fdsMinimizeTerm s) +-- case (fdsMinimizeTerm s) of +-- q@(Just _) -> return q +-- Nothing -> case (fdsMinimizeVar s) of +-- Nothing -> return Nothing +-- Just v -> do +-- q <- getSingleIntTerm v +-- put s { fdsMinimizeTerm = Just q } +-- return $ Just q + +boundMinimize :: (Show (FDIntTerm s), FDSolver s, EnumTerm s (FDIntTerm s), Integral (TermBaseType s (FDIntTerm s))) => NewBound (FDInstance s) +boundMinimize = do + bound <- getMinimizeTerm + case bound of + Nothing -> error "no bound variable defined" + Just bndvar -> do + x <- liftFD $ getValue bndvar + case x of + Just val -> do + con <- liftFD $ fdConstrainIntTerm bndvar (toInteger val) + let f = Bound (\x -> (Add (Right con) x)) + return f + _ -> error "bound variable is not assigned" + +runFD :: FDSolver s => FDInstance s a -> s a +runFD (FDInstance { unFDInstance = u }) = evalStateT u baseFDState + +linkExterns :: FDSolver s => (Int -> Maybe (FDSpecInfoBool s), Int -> Maybe (FDSpecInfoInt s), Int -> Maybe (FDSpecInfoCol s)) -> EGEdgeId -> FDInstance s () +linkExterns (sfb,sfi,sfc) id = do + s <- get + let Just jm = fdsModel s + let Just edge = Map.lookup id $ egmEdges jm + case (egeCons edge) of + EGBoolExtern p -> do + case sfb p of + Nothing -> return () + Just spec -> do + let [varid] = boolData $ egeLinks edge + if (Map.member varid $ fdsBoolVars s) then error "double bool import" else return () + put $ s { fdsBoolVars = Map.insert varid spec $ fdsBoolVars s, fdsBoolVarTypes = Map.delete varid $ fdsBoolVarTypes s } + markEdge id + EGIntExtern p -> do + case sfi p of + Nothing -> return () + Just spec -> do + let [varid] = intData $ egeLinks edge + if (Map.member varid $ fdsIntVars s) then error "double int import" else return () + put $ s { fdsIntVars = Map.insert varid spec $ fdsIntVars s, fdsIntVarTypes = Map.delete varid $ fdsIntVarTypes s } + markEdge id + EGColExtern p -> do + case sfc p of + Nothing -> return () + Just spec -> do + let [varid] = colData $ egeLinks edge + if (Map.member varid $ fdsColVars s) then error "double col import" else return () + put $ s { fdsColVars = Map.insert varid spec $ fdsColVars s, fdsColVarTypes = Map.delete varid $ fdsColVarTypes s } + markEdge id + _ -> return () + +procSubModel :: FDSolver s => EGModel -> (Int -> FDSpecInfoBool s, Int -> FDSpecInfoInt s, Int -> FDSpecInfoCol s) -> FDInstance s () +procSubModel sm (fb,fi,fc) = procSubModelEx sm (Just . fb,Just . fi,Just . fc) + +procSubModelEx :: FDSolver s => EGModel -> (Int -> Maybe (FDSpecInfoBool s), Int -> Maybe (FDSpecInfoInt s), Int -> Maybe (FDSpecInfoCol s)) -> FDInstance s () +procSubModelEx sm specfn = do + s <- get + let ss = baseFDState { + fdsModel = Just sm, + fdsVars = fdsVars s, + fdsFailed = fdsFailed s, + fdsLevel = 1 + fdsLevel s + } + put ss + initForModel + s2 <- get + mapM_ (linkExterns specfn) $ Set.toList $ fdsNewEdges s2 + process + s3 <- get + put $ s { fdsFailed = fdsFailed s || fdsFailed s3, fdsVars = fdsVars s3 } + +getLevel :: FDSolver s => FDInstance s Int +getLevel = do + s <- get + return $ fdsLevel s + +-- specSubModelEx :: FDSolver s => EGModel -> (Int -> Maybe (FDSpecInfoBool s), Int -> Maybe (FDSpecInfoInt s), Int -> Maybe (FDSpecInfoCol s)) -> FDInstance s () +specSubModelEx sm specfn = do + s <- get + let ss = baseFDState { + fdsModel = Just sm, + fdsVars = fdsVars s, + fdsFailed = fdsFailed s, + fdsLevel = 1 + fdsLevel s + } + put ss + initForModel + s2 <- get + mapM_ (linkExterns specfn) $ Set.toList $ fdsNewEdges s2 + s3 <- get + put s3 { fdsDummyLevel = 1 } + processEx False + s4 <- get + put $ s { fdsFailed = fdsFailed s || fdsFailed s4, fdsVars = fdsVars s4 } + return (fdsBoolVars s4, fdsIntVars s4, fdsColVars s4) + +optimizeSetSet :: Ord a => Set (Set a) -> Set (Set a) +optimizeSetSet x = + let (min,xx) = Set.deleteFindMin x + inter = Set.fold Set.intersection min xx + in if Set.null inter then x else Set.singleton inter + +optimizeVarTypes :: FDSolver s => FDInstance s () +optimizeVarTypes = do + s <- get + put $ s { + fdsBoolVarTypes = Map.map optimizeSetSet $ fdsBoolVarTypes s, + fdsIntVarTypes = Map.map optimizeSetSet $ fdsIntVarTypes s, + fdsColVarTypes = Map.map optimizeSetSet $ fdsColVarTypes s + } + +checkNeedSpecType var typ db = any (Set.member typ) $ Set.toList $ Map.findWithDefault Set.empty var db + +decompSpec fn db un unfn ex vars typs = do + s <- get + let tri [] = do + debug ("decompSpec vars="++(show vars)++": no spec left, failing") $ return () + return Nothing + tri (((_,_,id),_):rest) | not (Set.member id vars) = tri rest + tri ((key@(_,_,id),(eid,s)):rest) = case ex s of + Nothing -> tri rest + Just spec -> do + res <- spec + case res of + SpecResNone -> tri rest + SpecResSpec (typ,spec) -> if Set.member typ typs + then do + rr <- liftFD spec + debug ("decompSpec: got spec: " ++ (show rr)) $ return () + fn (Set.findMin vars) typ rr + case eid of + Nothing -> return () + Just e -> do + debug ("decompSpec: marking edge "++(show e)) $ return () + markEdge e + return $ Just (typ,rr) + else tri rest + SpecResUnify v -> do + unfn id v + decompSpec fn db un unfn ex vars typs + tri $ Map.toDescList $ db + +decompBestHelp id spec fn unfn eid prio db = do + res <- spec + case res of + SpecResNone -> do + debug ("decompBestHelp: level "++(show prio)++" specifier for var "++(show id)++" by edge "++(show eid)++" has failed") $ return () + return () + SpecResSpec (typ,ss) -> if checkNeedSpecType id typ db + then do + rr <- liftFD ss + res <- fn id typ rr + case eid of + Nothing -> return () + Just e -> do + debug ("decompBestHelp: marking edge "++(show e)) $ return () + markEdge e + return () + return res + else do + debug ("decompBestHelp: typ "++(show typ)++" specifier for id "++(show id)++" seems not needed") $ return () + return () + SpecResUnify v -> do + unfn id v + return () + +decompBest :: FDSolver s => FDInstance s Bool +decompBest = do + s1 <- debug "in decompBest: get" $ get + debug "in decompBest" $ return () + if Map.null $ fdsDb s1 + then return False + else do + let (((prio,knd,id),(eid,spec)),nm) = Map.deleteFindMax $ fdsDb $ debug "s1?" s1 + s2 = debug ("got best spec: prio="++(show prio)++", knd="++(show knd)++", id="++(show id)++", eid="++(show eid)++", spec=?") $ s1 { fdsDb = nm } + put s2 + case knd of + FDTBool -> do + let s3 = s2 { fdsBoolVarBusy = Set.insert id $ fdsBoolVarBusy s2 } + put s3 + let Just j = fdsBoolSel spec + decompBestHelp id j addBoolVar unifyBools eid prio $ fdsBoolVarTypes s3 + s4 <- get + put $ s4 { fdsBoolVarBusy = Set.delete id $ fdsBoolVarBusy s4 } + FDTInt -> do + let s3 = s2 { fdsIntVarBusy = Set.insert id $ fdsIntVarBusy s2 } + put s3 + let Just j = fdsIntSel spec + decompBestHelp id j addIntVar unifyInts eid prio $ fdsIntVarTypes s3 + s4 <- get + put $ s4 { fdsIntVarBusy = Set.delete id $ fdsIntVarBusy s4 } + FDTCol -> do + let s3 = s2 { fdsColVarBusy = Set.insert id $ fdsColVarBusy s2 } + put s3 + let Just j = fdsColSel spec + decompBestHelp id j addColVar unifyCols eid prio $ fdsColVarTypes s3 + s4 <- get + put $ s4 { fdsColVarBusy = Set.delete id $ fdsColVarBusy s4 } + return True + +decompDefaultBool :: FDSolver s => FDInstance s Bool +decompDefaultBool = do + s1 <- get + if Map.null $ fdsBoolVarTypes s1 + then return False + else do + let ((varid,set),nm) = Map.deleteFindMin $ fdsBoolVarTypes s1 + s2 = s1 { fdsBoolVarTypes = nm } + put s2 + if Set.null set + then return True + else do + defaultBoolDecomp varid Nothing + return True + +decompDefaultInt :: FDSolver s => FDInstance s Bool +decompDefaultInt = do + s1 <- get + if Map.null $ fdsIntVarTypes s1 + then return False + else do + let ((varid,set),nm) = Map.deleteFindMin $ fdsIntVarTypes s1 + s2 = s1 { fdsIntVarTypes = nm } + put s2 + if Set.null set + then return True + else do + defaultIntDecomp varid Nothing + return True + +defaultBoolDecomp :: FDSolver s => EGVarId -> (Maybe (FDBoolSpecTypeSet s)) -> FDInstance s (Maybe (FDBoolSpecType s, FDBoolSpec s)) +defaultBoolDecomp var typs = do + s <- get + if fdsDummyLevel s > 0 + then return Nothing + else do + vt <- liftFD $ fdTypeVarBool + let Just jt = typs + if (isNothing typs || not (Set.null $ Set.intersection vt jt)) + then do + Just v <- fdNewvar + let (ty,sp) = fdBoolSpec_term v + rs <- liftFD sp + addBoolVar var ty (rs, Nothing) + return $ Just (ty,rs) + else return Nothing + +defaultIntDecomp :: FDSolver s => EGVarId -> (Maybe (FDIntSpecTypeSet s)) -> FDInstance s (Maybe (FDIntSpecType s, FDIntSpec s)) +defaultIntDecomp var typs = do + s <- get + if fdsDummyLevel s > 0 + then return Nothing + else do + vt <- liftFD $ fdTypeVarInt + let Just jt = typs + if (isNothing typs || not (Set.null $ Set.intersection vt jt)) + then do + Just v <- fdNewvar + let (ty,sp) = fdIntSpec_term v + rs <- liftFD sp + addIntVar var ty (rs, Nothing) + return $ Just (ty,rs) + else return Nothing + +getBoolSpec_ :: FDSolver s => EGVarId -> FDBoolSpecTypeSet s -> FDInstance s (Maybe (FDBoolSpecType s, FDBoolSpec s)) +getBoolSpec_ var typs = do + s <- get + let vars = Map.findWithDefault (Set.singleton var) var $ fdsBoolUnifies s + getBoolSpec__ vars typs + +getBoolSpec__ :: FDSolver s => Set EGVarId -> FDBoolSpecTypeSet s -> FDInstance s (Maybe (FDBoolSpecType s, FDBoolSpec s)) +getBoolSpec__ vars typs = do + s <- get + let mp = foldl (\b a -> case Map.lookup a (fdsBoolVars s) of { Nothing -> b; Just x -> case b of { Nothing -> Just x; Just r -> Just $ unionSpecBool r x }}) Nothing (Set.toList vars) + let sp = Set.intersection (maybe Set.empty fdspBoolTypes mp) typs + let db = fdsDb s + if Set.null sp + then if not (Set.null $ Set.intersection vars $ fdsBoolVarBusy s) + then return Nothing + else do + put $ s { fdsBoolVarBusy = Set.union vars $ fdsBoolVarBusy s } + res <- decompSpec addBoolVar db (\x -> Map.lookup x $ fdsBoolUnifies s) unifyBools fdsBoolSel vars typs + s2 <- get + put $ s2 { fdsBoolVarBusy = Set.difference (fdsBoolVarBusy s) vars } + case res of + Just (tp,(sp,_)) -> return $ Just (tp,sp) + _ -> defaultBoolDecomp (Set.findMin vars) $ Just typs + else do + let lp = Set.findMin sp + let Just jmp = mp + let Just j = fdspBoolSpec jmp $ Just lp + return $ Just (lp,j) + +getBoolSpec :: FDSolver s => EGVarId -> FDInstance s (Maybe (FDBoolSpec s)) +getBoolSpec var = do + s <- allBoolSpec + q <- getBoolSpec_ var s + return $ case q of + Just (_,x) -> Just x + Nothing -> Nothing + +getIntSpec_ :: FDSolver s => EGVarId -> FDIntSpecTypeSet s -> FDInstance s (Maybe (FDIntSpecType s, FDIntSpec s)) +getIntSpec_ var typs = do + s <- get + let vars = Map.findWithDefault (Set.singleton var) var $ fdsIntUnifies s + getIntSpec__ vars typs + +getIntSpec__ :: FDSolver s => Set EGVarId -> FDIntSpecTypeSet s -> FDInstance s (Maybe (FDIntSpecType s, FDIntSpec s)) +getIntSpec__ vars typs = do + s <- get + let mp = foldl (\b a -> case Map.lookup a (fdsIntVars s) of { Nothing -> b; Just x -> case b of { Nothing -> Just x; Just r -> Just $ unionSpecInt r x }}) Nothing $ Set.toList vars + let sp = Set.intersection (maybe Set.empty fdspIntTypes mp) typs + let db = fdsDb s + if Set.null sp + then if not (Set.null $ Set.intersection vars $ fdsIntVarBusy s) + then do + debug ("getIntSpec__ "++(show (vars,typs))++": busy, failing") $ return () + return Nothing + else do + put $ s { fdsIntVarBusy = Set.union vars $ fdsIntVarBusy s } + res <- decompSpec addIntVar db (\x -> Map.lookup x $ fdsIntUnifies s) unifyInts fdsIntSel vars typs + s2 <- get + put $ s2 { fdsIntVarBusy = Set.difference (fdsIntVarBusy s) vars } + case res of + Just (tp,(sp,_)) -> return $ Just (tp,sp) + _ -> defaultIntDecomp (Set.findMin vars) $ Just typs + else do + let lp = Set.findMin sp + let Just jmp = mp + let Just j = fdspIntSpec jmp $ Just lp + return $ Just (lp,j) + +getIntSpec :: FDSolver s => EGVarId -> FDInstance s (Maybe (FDIntSpec s)) +getIntSpec var = do + s <- allIntSpec + q <- getIntSpec_ var s + return $ case q of + Just (_,x) -> Just x + Nothing -> Nothing + +getColSpec_ :: FDSolver s => EGVarId -> FDColSpecTypeSet s -> FDInstance s (Maybe (FDColSpecType s, FDColSpec s)) +getColSpec_ var typs = do + s <- get + let vars = Map.findWithDefault (Set.singleton var) var $ fdsColUnifies s + getColSpec__ vars typs + +getColSpec__ :: FDSolver s => Set EGVarId -> FDColSpecTypeSet s -> FDInstance s (Maybe (FDColSpecType s, FDColSpec s)) +getColSpec__ vars typs = do + s <- get + let mp = foldl (\b a -> case Map.lookup a (fdsColVars s) of { Nothing -> b; Just x -> case b of { Nothing -> Just x; Just r -> Just $ unionSpecCol r x }}) Nothing (Set.toList vars) + let sp = Set.intersection (maybe Set.empty fdspColTypes mp) typs + let db = fdsDb s + if Set.null sp + then if not (Set.null $ Set.intersection vars $ fdsColVarBusy s) + then return Nothing + else do + put $ s { fdsColVarBusy = Set.union vars $ fdsColVarBusy s } + res <- decompSpec addColVar db (\x -> Map.lookup x $ fdsColUnifies s) unifyCols fdsColSel vars typs + s2 <- get + put $ s2 { fdsColVarBusy = Set.difference (fdsColVarBusy s) vars } + case res of + Just (tp,(sp,_)) -> return $ Just (tp,sp) + _ -> return Nothing + else do + let lp = Set.findMin sp + let Just jmp = mp + let Just j = fdspColSpec jmp $ Just lp + return $ Just (lp,j) + +getColSpec :: (Show (FDColSpec s), FDSolver s) => EGVarId -> FDInstance s (Maybe (FDColSpec s)) +getColSpec var = do + s <- allColSpec + q <- getColSpec_ var s + return $ case q of + Just (_,x) -> Just x + Nothing -> Nothing + +-- | initial FDState state +baseFDState :: FDSolver s => FDState s +baseFDState = FDState { + fdsVars = 0, + fdsExpr = BoolConst True, + fdsForceBool = [], + fdsForcedBool = Map.empty, + fdsForceInt = [], + fdsForcedInt = Map.empty, + fdsForceCol = [], + fdsModel = Nothing, + fdsNewEdges = Set.empty, + fdsDoneEdges = Set.empty, + fdsDecomp = baseDecompData, + fdsIntVars = Map.empty, + fdsIntVarTypes = Map.empty, + fdsIntVarBusy = Set.empty, + fdsIntUnifies = Map.empty, + fdsBoolVars = Map.empty, + fdsBoolVarTypes = Map.empty, + fdsBoolVarBusy = Set.empty, + fdsBoolUnifies = Map.empty, + fdsColVars = Map.empty, + fdsColVarTypes = Map.empty, + fdsColVarBusy = Set.empty, + fdsColUnifies = Map.empty, + fdsDb = Map.empty, + fdsFailed = False, + fdsLevel = 0, + fdsDummyLevel = 0, + fdsMinimizeVar = Nothing, + fdsMinimizeTerm = Nothing +} + +edgesLeft :: FDSolver s => FDInstance s Bool +edgesLeft = get >>= return . Set.null . fdsNewEdges + +-- | run the second argument as long as the first one produces true +whileM :: Monad m => m Bool -> m a -> m () +whileM cond act = do + x <- cond + if x + then do + act + whileM cond act + else return () + +whileM_ :: Monad m => m Bool -> m () +whileM_ cond = whileM cond $ return () + +-- | a label for an FDInstance; must store the FDState plus the Solver's internal state +data FDSolver s => FDLabel s = FDLabel { + fdlState :: FDState s, + fdlLabel :: Label s +} + +-- | definition of FDInstance, a Solver wrapper that adds power to post boolean expressions as constraints +newtype FDSolver s => FDInstance s a = FDInstance { unFDInstance :: StateT (FDState s) s a } + deriving (Monad, Applicative, Functor, MonadState (FDState s)) + +-- | helper function to combine two Maybe's +joinWith :: (a -> a -> a) -> Maybe a -> Maybe a -> Maybe a +joinWith f a b = case (a,b) of + (Nothing,_) -> b + (_,Nothing) -> a + (Just x,Just y) -> Just $ f x y + +-- | lift a monad action for the underlying solver to a monad action for an FDInstance around it +liftFD :: FDSolver s => s a -> FDInstance s a +liftFD = FDInstance . lift + +liftFDTree :: (FDSolver s, MonadTree m, TreeSolver m ~ (FDInstance s)) => Tree s a -> m a +liftFDTree = mapTree liftFD + +data SpecResult t = + SpecResNone + | SpecResSpec t + | SpecResUnify EGVarId + +type SpecBool s = FDInstance s (SpecResult (FDBoolSpecType s, s (FDBoolSpec s, Maybe EGBoolPar))) +type SpecInt s = FDInstance s (SpecResult (FDIntSpecType s, s (FDIntSpec s, Maybe EGPar))) +type SpecCol s = FDInstance s (SpecResult (FDColSpecType s, s (FDColSpec s, Maybe EGColPar))) + +type SpecFnRes s = + ( + [(Int, EGVarId, Bool, SpecBool s)], + [(Int, EGVarId, Bool, SpecInt s)], + [(Int, EGVarId, Bool, SpecCol s)] + ) + +type SpecFn s = EGEdge -> SpecFnRes s + +data TermType = FDTBool | FDTInt | FDTCol + deriving (Eq,Ord,Bounded,Enum,Show) + +fdsBoolSel x = case x of + FDSBool a -> Just a + _ -> Nothing +fdsIntSel x = case x of + FDSInt a -> Just a + _ -> Nothing +fdsColSel x = case x of + FDSCol a -> Just a + _ -> Nothing + +data TermTypeSpec s = FDSBool (SpecBool s) | FDSInt (SpecInt s) | FDSCol (SpecCol s) + +instance Show (TermTypeSpec s) where + show (FDSBool _) = "FDSBool" + show (FDSInt _) = "FDSInt" + show (FDSCol _) = "FDSCol" + +type SpecDb s = Map (Int,TermType,EGVarId) (Maybe EGEdgeId,TermTypeSpec s) + +addBoolSpec :: FDSolver s => SpecDb s -> (Int,EGVarId,Maybe EGEdgeId,SpecBool s) -> SpecDb s +addBoolSpec db (prio,var,eid,spec) = Map.insert (prio,FDTBool,var) (eid,FDSBool spec) db + +addIntSpec :: FDSolver s => SpecDb s -> (Int,EGVarId,Maybe EGEdgeId,SpecInt s) -> SpecDb s +addIntSpec db (prio,var,eid,spec) = Map.insert (prio,FDTInt,var) (eid,FDSInt spec) db + +addColSpec :: FDSolver s => SpecDb s -> (Int,EGVarId,Maybe EGEdgeId,SpecCol s) -> SpecDb s +addColSpec db (prio,var,eid,spec) = Map.insert (prio,FDTCol,var) (eid,FDSCol spec) db + +emptyFDSpecInfoBool :: FDSolver s => EGVarId -> FDState s -> FDSpecInfoBool s +emptyFDSpecInfoBool v s = FDSpecInfoBool { fdspBoolSpec = const Nothing, fdspBoolVar = Just v, fdspBoolVal = getBoolVal_ v s, fdspBoolTypes = Set.empty } +emptyFDSpecInfoInt :: FDSolver s => EGVarId -> FDState s -> FDSpecInfoInt s +emptyFDSpecInfoInt v s = FDSpecInfoInt { fdspIntSpec = const Nothing, fdspIntVar = Just v, fdspIntVal = getIntVal_ v s, fdspIntTypes = Set.empty } +emptyFDSpecInfoCol :: FDSolver s => EGVarId -> FDState s -> FDSpecInfoCol s +emptyFDSpecInfoCol v s = FDSpecInfoCol { fdspColSpec = const Nothing, fdspColVar = Just v, fdspColVal = getColVal_ v s, fdspColTypes = Set.empty } + +data FDSpecInfoBool s = FDSpecInfoBool { fdspBoolSpec :: Maybe (FDBoolSpecType s) -> Maybe (FDBoolSpec s), fdspBoolVar :: Maybe EGVarId, fdspBoolVal :: Maybe EGBoolPar, fdspBoolTypes :: Set (FDBoolSpecType s) } +data FDSpecInfoInt s = FDSpecInfoInt { fdspIntSpec :: Maybe (FDIntSpecType s) -> Maybe (FDIntSpec s), fdspIntVar :: Maybe EGVarId, fdspIntVal :: Maybe EGPar, fdspIntTypes :: Set (FDIntSpecType s) } +data FDSpecInfoCol s = FDSpecInfoCol { fdspColSpec :: Maybe (FDColSpecType s) -> Maybe (FDColSpec s), fdspColVar :: Maybe EGVarId, fdspColVal :: Maybe EGColPar, fdspColTypes :: Set (FDColSpecType s) } + +unionSpecBool (FDSpecInfoBool { fdspBoolSpec = s1, fdspBoolVar = n1, fdspBoolVal = v1, fdspBoolTypes = t1 }) (FDSpecInfoBool { fdspBoolSpec = s2, fdspBoolVar = n2, fdspBoolVal = v2, fdspBoolTypes = t2 }) = + FDSpecInfoBool { fdspBoolSpec = \t -> (s1 t) `mplus` (s2 t), fdspBoolVal = v1 `mplus` v2, fdspBoolVar = n1 `mplus` n2, fdspBoolTypes = Set.union t1 t2 } +unionSpecInt (FDSpecInfoInt { fdspIntSpec = s1, fdspIntVar = n1, fdspIntVal = v1, fdspIntTypes = t1 }) (FDSpecInfoInt { fdspIntSpec = s2, fdspIntVar = n2, fdspIntVal = v2, fdspIntTypes = t2 }) = + FDSpecInfoInt { fdspIntSpec = \t -> (s1 t) `mplus` (s2 t), fdspIntVal = v1 `mplus` v2, fdspIntVar = n1 `mplus` n2, fdspIntTypes = Set.union t1 t2 } +unionSpecCol (FDSpecInfoCol { fdspColSpec = s1, fdspColVar = n1, fdspColVal = v1, fdspColTypes = t1 }) (FDSpecInfoCol { fdspColSpec = s2, fdspColVar = n2, fdspColVal = v2, fdspColTypes = t2 }) = + FDSpecInfoCol { fdspColSpec = \t -> (s1 t) `mplus` (s2 t), fdspColVal = v1 `mplus` v2, fdspColVar = n1 `mplus` n2, fdspColTypes = Set.union t1 t2 } + +instance (Ord (FDBoolSpec s), Ord (FDBoolSpecType s)) => Eq (FDSpecInfoBool s) where + a == b = (compare a b) == EQ +instance (Ord (FDBoolSpec s), Ord (FDBoolSpecType s)) => Ord (FDSpecInfoBool s) where + compare (FDSpecInfoBool { fdspBoolSpec = s1, fdspBoolVar = r1, fdspBoolVal = v1, fdspBoolTypes = t1 }) (FDSpecInfoBool { fdspBoolSpec = s2, fdspBoolVar = r2, fdspBoolVal = v2, fdspBoolTypes = t2 }) = + compare r1 r2 <<>> compare v1 v2 <<>> compare (s1 Nothing) (s2 Nothing) <<>> compare (Map.fromList $ map (\x -> (x,s1 $ Just x)) $ Set.toList t1) (Map.fromList $ map (\x -> (x,s2 $ Just x)) $ Set.toList t2) + +instance (Ord (FDIntSpec s), Ord (FDIntSpecType s)) => Eq (FDSpecInfoInt s) where + a == b = (compare a b) == EQ +instance (Ord (FDIntSpec s), Ord (FDIntSpecType s)) => Ord (FDSpecInfoInt s) where + compare (FDSpecInfoInt { fdspIntSpec = s1, fdspIntVar = r1, fdspIntVal = v1, fdspIntTypes = t1 }) (FDSpecInfoInt { fdspIntSpec = s2, fdspIntVar = r2, fdspIntVal = v2, fdspIntTypes = t2 }) = + compare r1 r2 <<>> compare v1 v2 <<>> compare (s1 Nothing) (s2 Nothing) <<>> compare (Map.fromList $ map (\x -> (x,s1 $ Just x)) $ Set.toList t1) (Map.fromList $ map (\x -> (x,s2 $ Just x)) $ Set.toList t2) + +instance (Ord (FDColSpec s), Ord (FDColSpecType s)) => Eq (FDSpecInfoCol s) where + a == b = (compare a b) == EQ +instance (Ord (FDColSpec s), Ord (FDColSpecType s)) => Ord (FDSpecInfoCol s) where + compare (FDSpecInfoCol { fdspColSpec = s1, fdspColVar = r1, fdspColVal = v1, fdspColTypes = t1 }) (FDSpecInfoCol { fdspColSpec = s2, fdspColVar = r2, fdspColVal = v2, fdspColTypes = t2 }) = + compare r1 r2 <<>> compare v1 v2 <<>> compare (s1 Nothing) (s2 Nothing) <<>> compare (Map.fromList $ map (\x -> (x,s1 $ Just x)) $ Set.toList t1) (Map.fromList $ map (\x -> (x,s2 $ Just x)) $ Set.toList t2) + +specInfoMapBool :: FDSolver s => FDSpecInfoBool s -> Map (FDBoolSpecType s) (FDBoolSpec s) +specInfoMapBool (FDSpecInfoBool { fdspBoolSpec = f, fdspBoolTypes = t }) = Map.fromList $ map (\t -> (t,myFromJust "specInfoMapBool" $ f $ Just t)) $ Set.toList t + +specInfoMapInt :: FDSolver s => FDSpecInfoInt s -> Map (FDIntSpecType s) (FDIntSpec s) +specInfoMapInt (FDSpecInfoInt { fdspIntSpec = f, fdspIntTypes = t }) = Map.fromList $ map (\t -> (t,myFromJust "specInfoMapInt" $ f $ Just t)) $ Set.toList t + +specInfoMapCol :: FDSolver s => FDSpecInfoCol s -> Map (FDColSpecType s) (FDColSpec s) +specInfoMapCol (FDSpecInfoCol { fdspColSpec = f, fdspColTypes = t }) = Map.fromList $ map (\t -> (t,myFromJust "specInfoMapCol" $ f $ Just t)) $ Set.toList t + +specInfoBoolTerm :: FDSolver s => FDBoolTerm s -> s (FDSpecInfoBool s) +specInfoBoolTerm t = do + let (tp,sp) = fdBoolSpec_term t + s <- sp + return $ FDSpecInfoBool { fdspBoolSpec = \t -> case t of { Nothing -> Just s; Just tt | tp==tt -> Just s; _ -> Nothing }, fdspBoolVar = Nothing, fdspBoolVal = Nothing, fdspBoolTypes = Set.singleton tp } + +specInfoIntTerm :: FDSolver s => FDIntTerm s -> s (FDSpecInfoInt s) +specInfoIntTerm t = do + let (tp,sp) = fdIntSpec_term t + s <- sp + return $ FDSpecInfoInt { fdspIntSpec = \t -> case t of { Nothing -> Just s; Just tt | tp==tt -> Just s; _ -> Nothing }, fdspIntVar = Nothing, fdspIntVal = Nothing, fdspIntTypes = Set.singleton tp } + +instance Show (FDBoolSpec s) => Show (FDSpecInfoBool s) where + show (FDSpecInfoBool { fdspBoolSpec = f, fdspBoolVar = e, fdspBoolVal = v }) = "FSSpecInfoBool { default:" ++ (show $ f Nothing) ++ ", var:" ++ (show e) ++ ", val:" ++ (show v) ++ "}" +instance Show (FDIntSpec s) => Show (FDSpecInfoInt s) where + show (FDSpecInfoInt { fdspIntSpec = f, fdspIntVar = e, fdspIntVal = v }) = "FSSpecInfoInt { default:" ++ (show $ f Nothing) ++ ", var:" ++ (show e) ++ ", val:" ++ (show v) ++ "}" +instance Show (FDColSpec s) => Show (FDSpecInfoCol s) where + show (FDSpecInfoCol { fdspColSpec = f, fdspColVar = e, fdspColVal = v }) = "FSSpecInfoCol { default:" ++ (show $ f Nothing) ++ ", var:" ++ (show e) ++ ", val:" ++ (show v) ++ "}" + +type FDSpecInfo s = ([FDSpecInfoBool s],[FDSpecInfoInt s],[FDSpecInfoCol s]) + +fdSpecInfo_edge :: FDSolver s => EGEdgeId -> FDInstance s (FDSpecInfo s) +fdSpecInfo_edge f = do + s <- get + let edge = getJustEdge f s + intS p = Map.findWithDefault (emptyFDSpecInfoInt p s) p $ fdsIntVars s + boolS p = Map.findWithDefault (emptyFDSpecInfoBool p s) p $ fdsBoolVars s + colS p = Map.findWithDefault (emptyFDSpecInfoCol p s) p $ fdsColVars s +-- an m x = case x of +-- Just i -> Map.lookup i m +-- Nothing -> if Map.null m then Nothing else Just $ snd $ Map.findMin m +-- boolX v = FDSpecInfoBool { fdspBoolSpec = an $ boolS v, fdspBoolVar = Just v, fdspBoolVal = getBoolVal_ v s, fdspBoolTypes = Set.fromList $ Map.keys $ boolS v } +-- intX v = FDSpecInfoInt { fdspIntSpec = an $ intS v, fdspIntVar = Just v, fdspIntVal = getIntVal_ v s, fdspIntTypes = Set.fromList $ Map.keys $ intS v } +-- colX v = FDSpecInfoCol { fdspColSpec = an $ colS v, fdspColVar = Just v, fdspColVal = getColVal_ v s, fdspColTypes = Set.fromList $ Map.keys $ colS v } + return (map boolS $ boolData $ egeLinks edge, map intS $ intData $ egeLinks edge, map colS $ colData $ egeLinks edge) + +fdSpecInfo_spec :: FDSolver s => ([Either (FDSpecInfoBool s) (FDBoolSpecType s,FDBoolSpec s)],[Either (FDSpecInfoInt s) (FDIntSpecType s,FDIntSpec s)],[Either (FDSpecInfoCol s) (FDColSpecType s,FDColSpec s)]) -> FDSpecInfo s +fdSpecInfo_spec (b,i,c) = (fdSpecInfo_spec_b b, fdSpecInfo_spec_i i, fdSpecInfo_spec_c c) + +fdSpecInfo_spec_b :: FDSolver s => [Either (FDSpecInfoBool s) (FDBoolSpecType s,FDBoolSpec s)] -> [FDSpecInfoBool s] +fdSpecInfo_spec_b b = + let fb (Right x) = FDSpecInfoBool { fdspBoolSpec = nt x, fdspBoolVar = Nothing, fdspBoolVal = Nothing, fdspBoolTypes = Set.singleton $ fst x } + fb (Left x) = x + nt (_,x) Nothing = Just x + nt (t1,x) (Just t2) | t1==t2 = Just x + nt _ _ = Nothing + in (map fb b) + +fdSpecInfo_spec_i :: FDSolver s => [Either (FDSpecInfoInt s) (FDIntSpecType s,FDIntSpec s)] -> [FDSpecInfoInt s] +fdSpecInfo_spec_i i = + let fi (Right x) = FDSpecInfoInt { fdspIntSpec = nt x, fdspIntVar = Nothing, fdspIntVal = Nothing, fdspIntTypes = Set.singleton $ fst x } + fi (Left x) = x + nt (_,x) Nothing = Just x + nt (t1,x) (Just t2) | t1==t2 = Just x + nt _ _ = Nothing + in (map fi i) + +fdSpecInfo_spec_c :: FDSolver s => [Either (FDSpecInfoCol s) (FDColSpecType s,FDColSpec s)] -> [FDSpecInfoCol s] +fdSpecInfo_spec_c c = + let fc (Right x) = FDSpecInfoCol { fdspColSpec = nt x, fdspColVar = Nothing, fdspColVal = Nothing, fdspColTypes = Set.singleton $ fst x } + fc (Left x) = x + nt (_,x) Nothing = Just x + nt (t1,x) (Just t2) | t1==t2 = Just x + nt _ _ = Nothing + in (map fc c) + +-- | A solver needs to be an instance of this FDSolver class in order to +-- create an FDInstance around it. +class + ( + Solver s, + Term s (FDIntTerm s), + Term s (FDBoolTerm s), + Eq (FDBoolSpecType s), Ord (FDBoolSpecType s), Enum (FDBoolSpecType s), Bounded (FDBoolSpecType s), Show (FDBoolSpecType s), + Eq (FDIntSpecType s), Ord (FDIntSpecType s), Enum (FDIntSpecType s), Bounded (FDIntSpecType s), Show (FDIntSpecType s), + Eq (FDColSpecType s), Ord (FDColSpecType s), Enum (FDColSpecType s), Bounded (FDColSpecType s), Show (FDColSpecType s), +-- Integral (TermBaseType s (FDIntTerm s)), Num (TermBaseType s (FDBoolTerm s)), + Show (FDIntSpec s), Show (FDColSpec s), Show (FDBoolSpec s) + ) => FDSolver s where + -- term types + type FDIntTerm s :: * -- a Term of s, representing Integer variables + type FDBoolTerm s :: * -- a Term of s, representing Bool variables + -- spec types + type FDIntSpec s :: * -- a type specifying an Integer expression; should at least support constant Integer's and FDIntTerm's + type FDBoolSpec s :: * -- a type specifying a Bool expression; should at least support constant Bool's and FDBoolTerm's + type FDColSpec s :: * -- a type specifying a Integer array expression; should at least support lists of Int's and lists of IntTerm's + -- spec type type + type FDIntSpecType s :: * -- a type specifying the type of an FDIntSpec s, in case there is more than one + type FDBoolSpecType s :: * -- a type specifying the type of an FDIntSpec s, in case there is more than one + type FDColSpecType s :: * -- a type specifying the type of an FDIntSpec s, in case there is more than one + + + -- constructors for specifiers + fdIntSpec_const :: EGPar -> (FDIntSpecType s, s (FDIntSpec s)) + fdBoolSpec_const :: EGBoolPar -> (FDBoolSpecType s, s (FDBoolSpec s)) + fdColSpec_const :: EGColPar -> (FDColSpecType s, s (FDColSpec s)) + fdColSpec_list :: [FDIntSpec s] -> (FDColSpecType s, s (FDColSpec s)) + fdIntSpec_term :: FDIntTerm s -> (FDIntSpecType s, s (FDIntSpec s)) + fdBoolSpec_term :: FDBoolTerm s -> (FDBoolSpecType s, s (FDBoolSpec s)) + fdColSpec_size :: EGPar -> (FDColSpecType s, s (FDColSpec s)) + fdIntVarSpec :: FDIntSpec s -> s (Maybe (FDIntTerm s)) + fdBoolVarSpec :: FDBoolSpec s -> s (Maybe (FDBoolTerm s)) + + -- function to inform about allowed types for nodes + fdTypeReqBool :: s (EGEdge -> [(EGVarId,FDBoolSpecTypeSet s)]) + fdTypeReqInt :: s (EGEdge -> [(EGVarId,FDIntSpecTypeSet s)]) + fdTypeReqCol :: s (EGEdge -> [(EGVarId,FDColSpecTypeSet s)]) + fdTypeReqBool = return (\(EGEdge { egeLinks = EGTypeData { boolData = l } }) -> map (\x -> (x,Set.fromList [minBound..maxBound])) l) + fdTypeReqInt = return (\(EGEdge { egeLinks = EGTypeData { intData = l } }) -> map (\x -> (x,Set.fromList [minBound..maxBound])) l) + fdTypeReqCol = return (\(EGEdge { egeLinks = EGTypeData { colData = l } }) -> map (\x -> (x,Set.fromList [minBound..maxBound])) l) + + fdTypeVarInt :: s (Set (FDIntSpecType s)) + fdTypeVarBool :: s (Set (FDBoolSpecType s)) + fdTypeVarInt = return $ Set.singleton maxBound + fdTypeVarBool = return $ Set.singleton maxBound + + -- rating functions for specification of terms + fdSpecify :: Mixin (SpecFn s) + fdSpecify = mixinId + + -- inspect collections + fdColInspect :: FDColSpec s -> s [FDIntTerm s] + + -- function to request processing an edge in a graph + fdProcess :: Mixin (EGConstraintSpec -> FDSpecInfo s -> FDInstance s ()) + + -- add equality constraints + fdEqualBool :: FDBoolSpec s -> FDBoolSpec s -> FDInstance s () + fdEqualInt :: FDIntSpec s -> FDIntSpec s -> FDInstance s () + fdEqualCol :: FDColSpec s -> FDColSpec s -> FDInstance s () + + fdConstrainIntTerm :: FDIntTerm s -> Integer -> s (Constraint s) + fdSplitIntDomain :: FDIntTerm s -> s ([Constraint s],Bool) + fdSplitBoolDomain :: FDBoolTerm s -> s ([Constraint s],Bool) + +fdGetValBool :: (FDSolver s, EnumTerm s (FDBoolTerm s)) => FDBoolSpec s -> s (Maybe (TermBaseType s (FDBoolTerm s))) +fdGetValInt :: (FDSolver s, EnumTerm s (FDIntTerm s)) => FDIntSpec s -> s (Maybe (TermBaseType s (FDIntTerm s))) + +fdGetValBool s = fdBoolVarSpec s >>= \x -> case x of + Just t -> getValue t + _ -> return Nothing + +fdGetValInt s = fdIntVarSpec s >>= \x -> case x of + Just t -> getValue t + _ -> return Nothing + +type FDBoolSpecTypeSet s = Set (FDBoolSpecType s) +type FDIntSpecTypeSet s = Set (FDIntSpecType s) +type FDColSpecTypeSet s = Set (FDColSpecType s) + +fdCombineSpecify :: FDSolver s => SpecFn s -> SpecFn s -> SpecFn s +fdCombineSpecify a b edge = + let (a1,a2,a3) = a edge + (b1,b2,b3) = b edge + in (a1++b1,a2++b2,a3++b3) + +procEdge :: FDSolver s => FDInstance s Bool +procEdge = do + s <- get + if (Set.null $ fdsNewEdges s) + then return False + else do + let f = Set.findMin $ fdsNewEdges s + edge = getJustEdge f s + debug ("procEdge("++(show f)++")") $ return () + info <- fdSpecInfo_edge f + full_fdProcess (egeCons edge) info + debug ("procEdge: marking edge "++(show f)) $ return () + markEdge f + s2 <- get + return $ not $ Set.null $ fdsNewEdges s2 + +getEdge :: FDSolver s => EGEdgeId -> FDInstance s (Maybe EGEdge) +getEdge id = do + s <- get + return $ do + v <- fdsModel s + Map.lookup id $ egmEdges v + +markEdge :: FDSolver s => EGEdgeId -> FDInstance s () +markEdge id = do + s <- get + debug ("markEdge: "++(show $ id)) $ return () + put $ s { fdsNewEdges = Set.delete id $ fdsNewEdges s, fdsDoneEdges = Set.insert id $ fdsDoneEdges s } + +sureMaybe :: [Maybe a] -> Maybe [a] +sureMaybe [] = Just [] +sureMaybe (Nothing:_) = Nothing +sureMaybe ((Just a):b) = case sureMaybe b of + Nothing -> Nothing + Just l -> Just (a:l) + +allIntSpec :: FDSolver s => FDInstance s (Set (FDIntSpecType s)) +allIntSpec = return $ Set.fromList [minBound..maxBound] + +allBoolSpec :: FDSolver s => FDInstance s (Set (FDBoolSpecType s)) +allBoolSpec = return $ Set.fromList [minBound..maxBound] + +allColSpec :: FDSolver s => FDInstance s (Set (FDColSpecType s)) +allColSpec = return $ Set.fromList [minBound..maxBound] + +default_fdSpecify :: FDSolver s => SpecFn s +default_fdSpecify edge = case (debug ("default_fdSpecify("++(show edge)++")") edge) of + EGEdge { egeCons = EGIntValue c, egeLinks = EGTypeData { intData = [v] } } -> + ([],[(1000,v,True,do + let (tp, m) = fdIntSpec_const c + return $ SpecResSpec (tp,m >>= (\x -> return (x, Just c))) + )],[]) + EGEdge { egeCons = EGBoolValue c, egeLinks = EGTypeData { boolData = [v] } } -> + ([(1000,v,True,do + let (tp, m) = fdBoolSpec_const c + return $ SpecResSpec (tp, m >>= (\x -> return (x, Just c))) + )],[],[]) + EGEdge { egeCons = EGColValue c, egeLinks = EGTypeData { colData = [v] } } -> + ([],[],[(990,v,True,do + let (tp, m) = fdColSpec_const c + return $ SpecResSpec (tp, m >>= (\x -> return (x, Just c))) + )]) + EGEdge { egeCons = EGList s, egeLinks = EGTypeData { colData = [c], intData = l } } -> + ([],[],[(500,c,True,do + x <- mapM (\x -> getIntSpec x) l + case sureMaybe x of + Nothing -> return SpecResNone + Just ll -> do + let (tp, m) = fdColSpec_list ll + return $ SpecResSpec $ (tp, m >>= (\x -> return (x, Nothing))) + )]) + EGEdge { egeCons = EGSize, egeLinks = EGTypeData { colData = [c], intData=[s] } } -> + ([],[],[(250,c,True,do + ss <- get + let k = getIntVal_ s ss + case k of + Nothing -> return SpecResNone + Just ll -> do + let (tp, m) = fdColSpec_size ll + return $ SpecResSpec $ (tp, m >>= (\x -> return (x, Nothing))) + )]) + EGEdge { egeCons = EGRange, egeLinks = EGTypeData { colData = [c], intData=[l,h] } } -> + ([],[],[(250,c,False,do + ss <- get + let ll = getIntVal_ l ss + hh = getIntVal_ h ss + case (ll,hh) of + (Just (Const jl), Just (Const jh)) -> do + let (tp,m) = fdColSpec_size (Const $ jh-jl+1) + return $ SpecResSpec $ (tp, m >>= (\x -> return (x, Just $ ColList [Const x | x <- [jl..jh]]))) + (Just jl, Just jh) -> do + let (tp,m) = fdColSpec_size (jh-jl+1) + return $ SpecResSpec $ (tp, m >>= (\x -> return (x, Nothing))) + _ -> return SpecResNone + )]) + _ -> ([],[],[]) + +default_fdProcess :: FDSolver s => EGConstraintSpec -> FDSpecInfo s -> FDInstance s () +default_fdProcess cons _ = error $ "Cannot process "++(show cons) + +-- | mark all new edges(=constraints) of a model given in graph-form as to-be-processed +initForModel :: FDSolver s => FDInstance s () +initForModel = do + s <- get + let Just model = fdsModel s + put $ s { + fdsNewEdges = Set.difference (Set.union (fdsNewEdges s) $ Set.fromList $ Map.keys $ egmEdges model) $ fdsDoneEdges s + } + +setAlter :: Ord a => a -> Maybe (Set (Set a)) -> Maybe (Set (Set a)) +setAlter _ Nothing = Nothing +setAlter typ (Just x) = let f = fl x in if Set.null f then Nothing else Just f + where fl = Set.filter $ not . Set.member typ + +addSpecInt :: FDSolver s => FDIntSpecType s -> (FDIntSpec s, Maybe EGPar) -> EGVarId -> FDState s -> Maybe (FDSpecInfoInt s) -> Maybe (FDSpecInfoInt s) +addSpecInt tp def id s Nothing = addSpecInt tp def id s (Just $ emptyFDSpecInfoInt id s) +addSpecInt tp (def,val) _ _ (Just (m@(FDSpecInfoInt { fdspIntSpec = f, fdspIntTypes = t }))) = + Just $ m { + fdspIntSpec = \x -> case x of + Just tt | tt==tp -> Just $ def + Nothing -> case f Nothing of + Nothing -> Just def + Just ttt -> Just ttt + k -> f k, + fdspIntTypes = Set.insert tp t, + fdspIntVal = case val of + Nothing -> fdspIntVal m + _ -> val + } + +addSpecBool :: FDSolver s => FDBoolSpecType s -> (FDBoolSpec s, Maybe EGBoolPar) -> EGVarId -> FDState s -> Maybe (FDSpecInfoBool s) -> Maybe (FDSpecInfoBool s) +addSpecBool tp def id s Nothing = addSpecBool tp def id s (Just $ emptyFDSpecInfoBool id s) +addSpecBool tp (def,val) _ _ (Just (m@(FDSpecInfoBool { fdspBoolSpec = f, fdspBoolTypes = t }))) = + Just $ m { + fdspBoolSpec = \x -> case x of + Just tt | tt==tp -> Just $ def + Nothing -> case f Nothing of + Nothing -> Just def + Just ttt -> Just ttt + k -> f k, + fdspBoolTypes = Set.insert tp t, + fdspBoolVal = case val of + Nothing -> fdspBoolVal m + _ -> val + } + +addSpecCol :: FDSolver s => FDColSpecType s -> (FDColSpec s, Maybe EGColPar) -> EGVarId -> FDState s -> Maybe (FDSpecInfoCol s) -> Maybe (FDSpecInfoCol s) +addSpecCol tp def id s Nothing = addSpecCol tp def id s (Just $ emptyFDSpecInfoCol id s) +addSpecCol tp (def,val) _ _ (Just (m@(FDSpecInfoCol { fdspColSpec = f, fdspColTypes = t }))) = + Just $ m { + fdspColSpec = \x -> case x of + Just tt | tt==tp -> Just $ def + Nothing -> case f Nothing of + Nothing -> Just def + Just ttt -> Just ttt + k -> f k, + fdspColTypes = Set.insert tp t, + fdspColVal = case val of + Nothing -> fdspColVal m + _ -> val + } + +-- | add an int term +addIntVar :: FDSolver s => EGVarId -> FDIntSpecType s -> (FDIntSpec s, Maybe EGPar) -> FDInstance s () +addIntVar id typ (spec@(rs,_)) = do +-- debug ("addIntVar id="++(show id)++" typ="++(show typ)++" spec="++(show spec)) $ return () + s <- get + case (Map.lookup id $ fdsIntVars s) of + Just t | not (Set.null $ fdspIntTypes t) -> case (fdspIntSpec t Nothing) of + Just x -> fdEqualInt rs x + Nothing -> case fdspIntSpec t $ Just $ Set.findMax $ fdspIntTypes t of + Just x -> fdEqualInt rs x + Nothing -> return () + _ -> return () + s2 <- get + put $ s2 + { + fdsIntVars = Map.alter (addSpecInt typ spec id s2) id $ fdsIntVars s2, + fdsIntVarBusy = Set.delete id $ fdsIntVarBusy s2, + fdsIntVarTypes = Map.alter (setAlter typ) id $ fdsIntVarTypes s2 + } + +-- | add a bool term +addBoolVar :: FDSolver s => EGVarId -> FDBoolSpecType s -> (FDBoolSpec s, Maybe EGBoolPar) -> FDInstance s () +addBoolVar id typ (spec@(rs,_)) = do +-- debug ("addBoolVar id="++(show id)++" typ="++(show typ)++" spec="++(show spec)) $ return () + s <- get + case (Map.lookup id $ fdsBoolVars s) of + Just t | not (Set.null $ fdspBoolTypes t) -> case (fdspBoolSpec t Nothing) of + Just x -> fdEqualBool rs x + Nothing -> case fdspBoolSpec t $ Just $ Set.findMax $ fdspBoolTypes t of + Just x -> fdEqualBool rs x + Nothing -> return () + _ -> return () + s2 <- get + put $ s2 + { + fdsBoolVars = Map.alter (addSpecBool typ spec id s2) id $ fdsBoolVars s2, + fdsBoolVarBusy = Set.delete id $ fdsBoolVarBusy s2, + fdsBoolVarTypes = Map.alter (setAlter typ) id $ fdsBoolVarTypes s2 + } + +-- | add a col term +addColVar :: FDSolver s => EGVarId -> FDColSpecType s -> (FDColSpec s, Maybe EGColPar) -> FDInstance s () +addColVar id typ (spec@(rs,_)) = do +-- debug ("addColVar id="++(show id)++" typ="++(show typ)++" spec="++(show spec)) $ return () + s <- get + case (Map.lookup id $ fdsColVars s) of + Just t | not (Set.null $ fdspColTypes t) -> case (fdspColSpec t Nothing) of + Just x -> fdEqualCol rs x + Nothing -> case fdspColSpec t $ Just $ Set.findMax $ fdspColTypes t of + Just x -> fdEqualCol rs x + Nothing -> return () + _ -> return () + s2 <- get + put $ s2 + { + fdsColVars = Map.alter (addSpecCol typ spec id s2) id $ fdsColVars s2, + fdsColVarBusy = Set.delete id $ fdsColVarBusy s2, + fdsColVarTypes = Map.alter (setAlter typ) id $ fdsColVarTypes s2 + } + +full_fdProcess :: FDSolver s => EGConstraintSpec -> FDSpecInfo s -> FDInstance s () +full_fdProcess = mixin (fdProcess <@> mixinLift default_fdProcess) + +full_fdSpecify :: FDSolver s => SpecFn s +full_fdSpecify = mixin (fdSpecify <@> mixinLift default_fdSpecify) + + +getJustEdge :: FDSolver s => EGEdgeId -> FDState s -> EGEdge +getJustEdge i s = + let Just m = fdsModel s + Just x = Map.lookup i (egmEdges m) + in x + +buildSpecDb :: FDSolver s => FDInstance s () +buildSpecDb = do + s <- get + let origDb = fdsDb s + ne = debug "bsdb: ne" $ map (\k -> (k,getJustEdge k s)) $ Set.toList $ debug "bsbd: fdsne" $ fdsNewEdges s + proc db (eid,edge) = do + let (lB,lI,lC) = debug ("bsbd: specify("++(show edge)++")") $ full_fdSpecify edge + dB = foldr (\(prio,var,full,spec) d -> debug "bsbd: addbool" $ addBoolSpec d (prio,var,if full then Just eid else Nothing,spec)) db $ debug ("lB["++(show $ length lB)++"]") lB + dI = foldr (\(prio,var,full,spec) d -> debug "bsbd: addint" $ addIntSpec d (prio,var,if full then Just eid else Nothing,spec)) dB $ debug ("lI["++(show $ length lI)++"]") lI + dC = foldr (\(prio,var,full,spec) d -> debug "bsbd: addcol" $ addColSpec d (prio,var,if full then Just eid else Nothing,spec)) dI $ debug ("lC["++(show $ length lC)++"]") lC + in dC + newDb = foldl proc origDb ne + put $ s { fdsDb = newDb } + +addBoolTypeReq :: FDSolver s => EGVarId -> FDBoolSpecTypeSet s -> FDInstance s () +addBoolTypeReq var set = do + s <- get + let chk tp = case Map.lookup var (fdsBoolVars s) of + Nothing -> False + Just x -> Set.member tp (fdspBoolTypes x) + sset = Map.findWithDefault Set.empty var (fdsBoolVarTypes s) + if Set.member set sset + then return () + else if any chk (Set.toList set) + then return () + else do + let nsset = Set.insert set sset + put $ s + { + fdsBoolVarTypes = Map.insert var nsset $ fdsBoolVarTypes s + } + +addIntTypeReq :: FDSolver s => EGVarId -> FDIntSpecTypeSet s -> FDInstance s () +addIntTypeReq var set = do + s <- get + let chk tp = case Map.lookup var (fdsIntVars s) of + Nothing -> False + Just x -> Set.member tp (fdspIntTypes x) + sset = Map.findWithDefault Set.empty var (fdsIntVarTypes s) + if Set.member set sset + then return () + else if any chk (Set.toList set) + then return () + else do + let nsset = Set.insert set sset + put $ s + { + fdsIntVarTypes = Map.insert var nsset $ fdsIntVarTypes s + } + +addColTypeReq :: FDSolver s => EGVarId -> FDColSpecTypeSet s -> FDInstance s () +addColTypeReq var set = do + s <- get + let chk tp = case Map.lookup var (fdsColVars s) of + Nothing -> False + Just x -> Set.member tp (fdspColTypes x) + sset = Map.findWithDefault Set.empty var (fdsColVarTypes s) + if Set.member set sset + then return () + else if any chk (Set.toList set) + then return () + else do + let nsset = Set.insert set sset + put $ s + { + fdsColVarTypes = Map.insert var nsset (fdsColVarTypes s) + } + +addTypeReqs :: FDSolver s => FDInstance s () +addTypeReqs = do + s <- get + fBool <- liftFD fdTypeReqBool + fInt <- liftFD fdTypeReqInt + fCol <- liftFD fdTypeReqCol + let ne = map (\k -> getJustEdge k s) $ Set.toList $ fdsNewEdges s + proc edge = do + mapM_ (uncurry addBoolTypeReq) $ fBool edge + mapM_ (uncurry addIntTypeReq) $ fInt edge + mapM_ (uncurry addColTypeReq) $ fCol edge + mapM_ proc ne + +processEx :: FDSolver s => Bool -> FDInstance s () +processEx x = do + ssm1 <- get + let ss0 = ssm1 { fdsModel = Just $ pruneNodes $ myFromJust "processEx" $ fdsModel ssm1 } + debug ("process ["++(show $ fdsLevel ss0)++"]") $ return () + -- search spec type requirements for all to-be-processed edges + debug ("addTypeReqs ["++(show $ fdsLevel ss0)++"]") $ addTypeReqs + -- optimize type requirements + debug ("optimizeVarTypes["++(show $ fdsLevel ss0)++"]") $ optimizeVarTypes + ss <- get + debug ("DUMP type reqs ["++(show $ fdsLevel ss0)++"]: "++(show $ fdsIntVarTypes ss)) $ return () + -- build specifier database for all to-be-processed edges + debug ("buildSpecDb ["++(show $ fdsLevel ss0)++"]") $ buildSpecDb + ss2 <- get + debug ("DUMP spec db ["++(show $ fdsLevel ss0)++"]: "++(show $ fdsDb ss2)) $ return () + -- create as much specifiers as possible (marking consumed edges as processed) + whileM_ $ debug ("decompBest ["++(show $ fdsLevel ss0)++"]") decompBest + -- try default specifier for remaining boolean nodes (=create new underlying term for each) + whileM_ $ debug ("decompDefBool ["++(show $ fdsLevel ss0)++"]") decompDefaultBool + -- try default specifier for remaining integer nodes (=create new underlying term for each) + whileM_ $ debug ("decompDefInt ["++(show $ fdsLevel ss0)++"]") decompDefaultInt + ss3 <- get + debug ("DUMP specs: "++(dumpSpec ss3)) $ return () + -- process remaining edges + if x + then whileM_ $ debug ("procEdge ["++(show $ fdsLevel ss0)++"]") procEdge + else return () + +process :: FDSolver s => FDInstance s () +process = processEx True + +commit :: FDSolver s => FDInstance s () +commit = do + s <- get + debug "begin commit" $ return () + case (fdsExpr s,fdsForceBool s,fdsForceInt s,fdsForceCol s) of + (BoolConst True,[],[],[]) -> return () + (expr,_,_,_) -> do + debug ("expr=["++(show expr)++"]") $ return () + let (dcd,graph,vars) = debug "decomposing" $ decomposeEx (fdsDecomp s) (fdsVars s) expr (fdsForceBool s,fdsForceInt s,fdsForceCol s) $ fdsModel s + put $ s { fdsExpr = BoolConst True, fdsDecomp = dcd, fdsModel = Just graph, fdsForceBool=[], fdsForceInt=[], fdsForceCol=[], fdsVars = max vars (fdsVars s) } + debug ("graph=["++(present graph)++"]"++"]") $ return () + -- mark all non-yet-processed edges as to-be-processed + debug "initForModel" $ initForModel + process + +instance FDSolver s => Solver (FDInstance s) where + type Constraint (FDInstance s) = Either Model (Constraint s) + type Label (FDInstance s) = FDLabel s + add (Left expr) = do + s <- get + if (fdsFailed s) + then return False + else do + put $ s { fdsExpr = (fdsExpr s) @&& expr } + return True + add (Right col) = do + s <- get + if (fdsFailed s) + then return False + else do + ret <- liftFD $ add col + if ret + then return True + else do + setFailed + return False + mark = do + commit + ss <- get + sl <- liftFD mark + return $ FDLabel { fdlState=ss, fdlLabel=sl } + markn n = do + commit + ss <- get + sl <- liftFD $ markn n + return $ FDLabel { fdlState=ss, fdlLabel=sl } + goto label = do + liftFD $ goto $ fdlLabel label + put $ fdlState label + run x = run $ runFD x + +instance FDSolver s => Term (FDInstance s) ModelInt where + newvar = do + s <- get + let i = fdsVars s + put $ s { fdsVars = 1+i } + return $ Term $ ModelIntVar i + type Help (FDInstance s) ModelInt = () + help _ _ = () + +instance FDSolver s => Term (FDInstance s) ModelBool where + newvar = do + s <- get + let i = fdsVars s + put $ s { fdsVars = 1+i } + return $ BoolTerm $ ModelBoolVar i + type Help (FDInstance s) ModelBool = () + help _ _ = () + +instance FDSolver s => Term (FDInstance s) ModelCol where + newvar = do + s <- get + let i = fdsVars s + put $ s { fdsVars = 1+i } + return $ ColTerm $ ModelColVar i + type Help (FDInstance s) ModelCol = () + help _ _ = () + +newCol :: FDSolver s => FDInstance s ModelCol +newCol = newvar + +newInt :: FDSolver s => FDInstance s ModelInt +newInt = newvar + +newBool :: FDSolver s => FDInstance s ModelBool +newBool = newvar + +combine :: [Maybe a] -> [a] -> [a] +combine [] _ = [] +combine (Nothing:r) (a:b) = a:(combine r b) +combine (Just x:r) b = x:(combine r b) + +realGetIntTerm :: FDSolver s => [ModelInt] -> FDInstance s [FDIntTerm s] +realGetIntTerm m = do + s <- debug ("realGetIntTerm: "++(show m)) $ get + put $ s { fdsForceInt = m++(fdsForceInt s) } + commit + s2 <- get + let ids = map (\x -> decompIntLookup (fdsDecomp s2) x) m + tp <- liftFD $ fdTypeVarInt + specs <- mapM (\(Just id) -> getIntSpec_ id tp) ids + vars <- mapM (\(Just (_,spec)) -> liftFD $ fdIntVarSpec spec) specs + let rvars = map (\(Just x) -> x) vars + s3 <- get + put $ s3 { fdsForcedInt = Map.union (fdsForcedInt s3) (Map.fromList $ zip m rvars) } + return rvars + +getSingleIntTerm :: FDSolver s => ModelInt -> FDInstance s (FDIntTerm s) +getSingleIntTerm m = do + s <- get + case Map.lookup m (fdsForcedInt s) of + Nothing -> realGetIntTerm [m] >>= return.head + Just d -> return d + +getIntTerm :: FDSolver s => [ModelInt] -> FDInstance s [FDIntTerm s] +getIntTerm m = do + s <- get + let lo = map (\x -> (x,Map.lookup x $ fdsForcedInt s)) m + let go = map fst $ filter (\(_,x) -> isNothing x) lo + vo <- case go of + [] -> return [] + _ -> realGetIntTerm go + return $ combine (map snd lo) vo + +realGetBoolTerm :: FDSolver s => [ModelBool] -> FDInstance s [FDBoolTerm s] +realGetBoolTerm m = do + s <- get + put $ s { fdsForceBool = m++(fdsForceBool s) } + commit + s2 <- get + let ids = map (\x -> decompBoolLookup (fdsDecomp s2) x) m + tp <- liftFD $ fdTypeVarBool + specs <- mapM (\(Just id) -> getBoolSpec_ id tp) ids + vars <- mapM (\(Just (_,spec)) -> liftFD $ fdBoolVarSpec spec) specs + let rvars = map (\(Just x) -> x) vars + s3 <- get + put $ s3 { fdsForcedBool = Map.union (fdsForcedBool s3) (Map.fromList $ zip m rvars) } + return rvars + +getBoolTerm :: FDSolver s => [ModelBool] -> FDInstance s [FDBoolTerm s] +getBoolTerm m = do + s <- get + let lo = map (\x -> (x,Map.lookup x $ fdsForcedBool s)) m + let go = map fst $ filter (\(_,x) -> isNothing x) lo + vo <- case go of + [] -> return [] + _ -> realGetBoolTerm go + return $ combine (map snd lo) vo + +getColTerm :: FDSolver s => [ModelCol] -> FDColSpecType s -> FDInstance s [FDColSpec s] +getColTerm m tp = do + s <- get + put $ s { fdsForceCol = m++(fdsForceCol s) } + commit + s2 <- get + let ids = map (\x -> decompColLookup (fdsDecomp s2) x) m + specs <- mapM (\(Just id) -> getColSpec_ id (Set.singleton tp)) ids + return $ map (snd . myFromJust ("getColTerm(tp="++(show tp)++")")) specs + +getColItems :: FDSolver s => ModelCol -> FDColSpecType s -> FDInstance s [FDIntTerm s] +getColItems c tp = do + [cc] <- getColTerm [c] tp + lst <- liftFD $ fdColInspect cc + return lst + +instance (FDSolver s, EnumTerm s (FDIntTerm s)) => EnumTerm (FDInstance s) ModelInt where + type TermBaseType (FDInstance s) ModelInt = TermBaseType s (FDIntTerm s) + getDomainSize v = do + f <- getFailed + if f + then return 0 + else do + var <- getSingleIntTerm v + liftFD $ getDomainSize var + getValue v = do + var <- getSingleIntTerm v + liftFD $ getValue var +-- setValue var val = return [var @== cte val] + setValue _ = error "setting of boolean variable through FD interface is not implemented" + getDomain var = error "retrieval of full domain not implemented in FD" + splitDomain v = do + var <- getSingleIntTerm v + (doms,full) <- liftFD $ fdSplitIntDomain var + return (map (\x -> [Right x]) doms, full) + enumerator = case enumerator of + Nothing -> Nothing + Just e -> Just $ \l -> label $ do + f <- getFailed + if f + then return false + else do + ll <- getIntTerm l + return $ liftFDTree $ e ll + +instance (FDSolver s, EnumTerm s (FDBoolTerm s)) => EnumTerm (FDInstance s) ModelBool where + type TermBaseType (FDInstance s) ModelBool = TermBaseType s (FDBoolTerm s) + getDomainSize v = do + f <- getFailed + if f + then return 0 + else do + [var] <- getBoolTerm [v] + liftFD $ getDomainSize var + getValue v = do + [var] <- getBoolTerm [v] + liftFD $ getValue var +-- setValue var val = return [var @= BoolConst (val /] + setValue _ = error "setting of boolean variable through FD interface is not implemented" + getDomain var = error "retrieval of full boolean domain not implemented in FD" + splitDomain v = do + [var] <- getBoolTerm [v] + (doms,full) <- liftFD $ fdSplitBoolDomain var + return (map (\x -> [Right x]) doms, full) + enumerator = case enumerator of + Nothing -> Nothing + Just e -> Just $ \l -> label $ do + f <- getFailed + if f + then return false + else do + ll <- getBoolTerm l + return $ liftFDTree $ e ll + +getIntVal_ :: FDSolver s => EGVarId -> FDState s -> Maybe EGPar +getIntVal_ id s = + let r1 = + case Map.lookup id (fdsIntVars s) of + Nothing -> Nothing + Just x -> fdspIntVal x + in case r1 of + Nothing -> + let Just j = fdsModel s + ei = findEdge j EGIntType id (==0) (\x -> case x of { EGIntValue _ -> True; _ -> False }) + in case ei of + Nothing -> Nothing + Just (_,ed) -> case egeCons ed of { EGIntValue c -> Just c } + Just x -> r1 + +getIntVal :: FDSolver s => EGVarId -> FDInstance s (Maybe EGPar) +getIntVal id = gets $ getIntVal_ id + +getBoolVal_ :: FDSolver s => EGVarId -> FDState s -> Maybe EGBoolPar +getBoolVal_ id s = + let r1 = + case Map.lookup id (fdsBoolVars s) of + Nothing -> Nothing + Just x -> fdspBoolVal x + in case r1 of + Nothing -> + let Just j = fdsModel s + l = getConnectedEdges j EGBoolType id + f (EGEdge { egeCons = EGBoolValue c },_) _ = Just c + f _ s = s + in foldr f Nothing l + Just x -> r1 + +getBoolVal :: FDSolver s => EGVarId -> FDInstance s (Maybe EGBoolPar) +getBoolVal id = gets $ getBoolVal_ id + +getColVal_ :: FDSolver s => EGVarId -> FDState s -> Maybe EGColPar +getColVal_ id s = + let r1 = + case Map.lookup id (fdsColVars s) of + Nothing -> Nothing + Just x -> fdspColVal x + in case r1 of + Nothing -> + let Just j = fdsModel s + l = getConnectedEdges j EGColType id + f (EGEdge { egeCons = EGColValue c },_) _ = Just c + f _ s = s + in foldr f Nothing l + Just x -> r1 + +getColVal :: FDSolver s => EGVarId -> FDInstance s (Maybe EGColPar) +getColVal id = gets $ getColVal_ id + +setFailed :: FDSolver s => FDInstance s () +setFailed = do + s <- get + debug "setFailed!" $ return () + put $ s { fdsFailed = True } + +getFailed :: FDSolver s => FDInstance s Bool +getFailed = do + s <- get + return $ fdsFailed s + +addFD :: (Show (Constraint s), FDSolver s) => Constraint s -> FDInstance s () +addFD c = do + s <- get + if (fdsFailed s) + then debug ("addFD("++(show c)++"): already failed") $ return () + else do + x <- liftFD $ add c + debug ("addFD("++(show c)++"): result="++(show x)) $ return () + if not x then setFailed else return () + +getDefIntSpec :: FDSolver s => FDSpecInfoInt s -> FDIntSpec s +getDefIntSpec (FDSpecInfoInt { fdspIntSpec = f }) = case f Nothing of + Just t -> t + Nothing -> error "getDefIntSpec: no spec" + +getDefBoolSpec :: FDSolver s => FDSpecInfoBool s -> FDBoolSpec s +getDefBoolSpec (FDSpecInfoBool { fdspBoolSpec = f }) = case f Nothing of + Just t -> t + Nothing -> error "getDefBoolSpec: no spec" + +getDefColSpec :: FDSolver s => FDSpecInfoCol s -> FDColSpec s +getDefColSpec (FDSpecInfoCol { fdspColSpec = f }) = case f Nothing of + Just t -> t + Nothing -> error "getDefColSpec: no spec" + +-- getFullIntSpec :: FDSolver s => EGVarId -> s (FDSpecInfoInt s) +getFullIntSpec id = do + s <- get + return $ myFromJust "getFullIntSpec" $ Map.lookup id $ fdsIntVars s + +-- getFullBoolSpec :: FDSolver s => EGVarId -> s (FDSpecInfoBool s) +getFullBoolSpec id = do + s <- get + return $ myFromJust "getFullBoolSpec" $ Map.lookup id $ fdsBoolVars s + +-- getFullColSpec :: FDSolver s => EGVarId -> s (FDSpecInfoCol s) +getFullColSpec id = do + s <- get + return $ myFromJust "getFullColSpec" $ Map.lookup id $ fdsColVars s + +fdNewvar :: (FDSolver s, Term s t) => FDInstance s (Maybe t) +fdNewvar = do + s <- get + if fdsDummyLevel s > 0 + then return Nothing + else liftFD newvar >>= return . Just diff --git a/src/Control/CP/FD/Graph.hs b/src/Control/CP/FD/Graph.hs new file mode 100644 --- /dev/null +++ b/src/Control/CP/FD/Graph.hs @@ -0,0 +1,411 @@ +{- + - Monadic Constraint Programming + - http://www.cs.kuleuven.be/~toms/MCP/ + - Pieter Wuille + -} + +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE FlexibleInstances #-} + +module Control.CP.FD.Graph ( + EGConstraintSpec(..), + EGParTerm(..), + EGParBoolTerm(..), + EGParColTerm(..), + EGPar, EGBoolPar, EGColPar, + EGConsArgs, + EGEdgeId, + EGVarId(..), + EGVarType(..), + EGTypeData(..), + EGEdge(..), + EGModel(..), + addEdge, + addNode, + delNode, + findEdge, + unifyNodes, + unifyIds, + baseGraph, + baseTypeData, + egTypeDataMap, egTypeGet, egTypeMod, + present, + getConnectedEdges, + externMap, filterModel, emptyModel, pruneNodes, +) where + +import Control.Monad (foldM) + +import Data.Maybe (fromJust) +import Data.Map (Map) +import qualified Data.Map as Map + +import Data.Expr.Data +-- import Control.CP.FD.Expr.Util + +-- BoolEqual, Rel _ (EREqual) _, ColEqual are encoded in the graph itself, and +-- not represented as constraints between them + +data EGVarType = + EGBoolType + | EGIntType + | EGColType + deriving (Eq,Show) + +-- instance KeyableExpr EGConstraintSpec where +-- keyCompare a b = compare a b + +data EGConstraintSpec = + EGIntValue EGPar -- i0 == p + | EGBoolValue EGBoolPar -- b0 == p + | EGColValue EGColPar -- c0 == p + | EGIntExtern Int -- super[p] == i0 + | EGBoolExtern Int -- super[p] == b0 + | EGColExtern Int -- super[p] == c0 + | EGPlus -- i0==i1+i2 + | EGMinus -- i0==i1-i2 + | EGMult -- i0==i1*i2 + | EGDiv -- i0==i1/i2 {- (i0==i1/i2) is NOT the same as (i1==i0*i2) -} + | EGMod -- i0==i1%i2 + | EGAbs -- i0==abs(i1) + | EGAt -- i0==c0[i1] + | EGFold EGModel (Int,Int,Int) -- i0==fold(p,i1,c0) {- inner intExtern(-1) is fold-function's return value, intExtern(-2) is the accumulator, intExtern(-3) is the argument -} + | EGSize -- i0==size(c0) + | EGChannel -- int(b0) == i0 + | EGList Int -- c0 == [i0,i1,i2,...] (len p) + | EGRange -- c0 == [i0..i1] + | EGMap EGModel (Int,Int,Int) -- c0 == map(p,c1) {- inner intExtern(-1) is map-function's return value, intExtern(-2) is its argument -} + | EGSlice EGModel (Int,Int,Int) -- c0 == c1[f(0)...f(i0-1)]; inner model defines f: intExtern(-1) is return value, intExtern(-2) is its argument +-- | EGSlice (EGPar -> EGPar) EGPar -- c0 == c1[f(0)...f(n-1)] + | EGCat -- c0 == c1++c2 + | EGAnd -- b0 == b1 && b2 + | EGOr -- b0 == b1 || b2 + | EGEquiv -- b0 == (b1 == b2) + | EGNot -- b0 == !b1 + | EGEqual -- b0 <-> i0 == i1 + | EGDiff -- b0 <-> i0 /= i1 + | EGLess Bool -- false: b0 <-> i0 <= i1 ; true: b0 <-> i0 < i1 + | EGAll EGModel (Int,Int,Int) Bool -- b0 <-> foreach (i from c0): p(i) {- inner boolExtern(-1) is truth value of predicate, intExtern(-1) is its argument; bool is true if all inner predicates need to be true -} + | EGAny EGModel (Int,Int,Int) Bool -- b0 <-> forany (i from c0): p(i) {- inner boolExtern(-1) is truth value of predicate, intExtern(-1) is its argument; bool is true if all inner predicates need to be false -} +-- | EGAllC EGModel (Int,Int,Int) Bool -- b0 <-> foreach (i from [i0,i1]: p(i) {- inner boolExtern(-1) is truth value of predicate, intExtern(-1) is its (constant) argument; bool is true if all inner predicates need to be true -} +-- | EGAnyC EGModel (Int,Int,Int) Bool -- b0 <-> foreach (i from [i0,i1]: p(i) {- inner boolExtern(-1) is truth value of predicate, intExtern(-1) is its (constant) argument; bool is true if all inner predicates need to be true -} + | EGSorted Bool -- c0 is increasing (false), or strictly increasing (true) + | EGAllDiff Bool -- c0 is all different (b0 means: use in consistency) + | EGDom -- i0 is any of c0 + | EGCondEqual -- b0 ? (b1==b2) : true + | EGCondInt -- i0 = b0 ? i1 : i2 + deriving (Eq,Show) + +instance Ord (EGPar -> EGPar) where + compare a b = compare (a (Term (EGPTParam (-1)))) (b (Term (EGPTParam (-1)))) + +instance Eq (EGPar -> EGPar) where + a == b = (a (Term (EGPTParam (-1)))) == (b (Term (EGPTParam (-1)))) + +instance Show (EGPar -> EGPar) where + show f = show $ f (Term (EGPTParam (-1))) + +dummyConstraint :: EGConstraintSpec -> Bool +dummyConstraint c = case c of + EGIntExtern _ -> True + EGBoolExtern _ -> True + EGColExtern _ -> True + _ -> False + +data EGParTerm = + EGPTParam Int + deriving (Show,Eq,Ord) + +data EGParBoolTerm = + EGPTBoolParam Int + deriving (Show,Eq,Ord) + +data EGParColTerm = + EGPTColParam Int + deriving (Show,Eq,Ord) + +type EGPar = Expr EGParTerm EGParColTerm EGParBoolTerm +type EGBoolPar = BoolExpr EGParTerm EGParColTerm EGParBoolTerm +type EGColPar = ColExpr EGParTerm EGParColTerm EGParBoolTerm + +-- Bools, Ints, Cols +type EGConsArgs = (Int,Int,Int) + +getConsArgs :: EGConstraintSpec -> EGTypeData Int +getConsArgs x = case + case x of + EGBoolValue _ -> (1,0,0) + EGIntValue _ -> (0,1,0) + EGColValue _ -> (0,0,1) + EGIntExtern _ -> (0,1,0) + EGBoolExtern _ -> (1,0,0) + EGColExtern _ -> (0,0,1) + EGPlus -> (0,3,0) + EGMinus -> (0,3,0) + EGMult -> (0,3,0) + EGDiv -> (0,3,0) + EGMod -> (0,3,0) + EGAbs -> (0,2,0) + EGAt -> (0,2,1) + EGFold _ (a,b,c) -> (a,2+b,1+c) + EGSize -> (0,1,1) + EGChannel -> (1,1,0) + EGList n -> (0,n,1) + EGRange -> (0,2,1) + EGMap _ (a,b,c) -> (a,b,2+c) + EGSlice _ (a,b,c) -> (a,1+b,2+c) + EGCat -> (0,0,3) + EGAnd -> (3,0,0) + EGOr -> (3,0,0) + EGEquiv -> (3,0,0) + EGNot -> (2,0,0) + EGEqual -> (1,2,0) + EGDiff -> (1,2,0) + EGLess _ -> (1,2,0) + EGAll _ (a,b,c) _ -> (1+a,b,1+c) + EGAny _ (a,b,c) _ -> (1+a,b,1+c) +-- EGAllC _ (a,b,c) _ -> (1+a,2+b,c) +-- EGAnyC _ (a,b,c) _ -> (1+a,2+b,c) + EGSorted _ -> (0,0,1) + EGAllDiff _ -> (0,0,1) + EGDom -> (0,1,1) + EGCondEqual -> (3,0,0) + EGCondInt -> (1,3,0) + of (a,b,c) -> EGTypeData { boolData = a, intData = b, colData =c } + +newtype EGEdgeId = EGEdgeId { unEGEdgeId :: Int } + deriving (Eq,Ord,Show) + +data EGVarId = EGVarId { unVarId :: Int } + deriving (Eq,Ord,Show) + +data EGTypeData x = EGTypeData { + boolData :: x, + intData :: x, + colData :: x +} + +deriving instance Show x => Show (EGTypeData x) +deriving instance Eq x => Eq (EGTypeData x) + +baseTypeData :: x -> EGTypeData x +baseTypeData x = EGTypeData { + boolData = x, + intData = x, + colData = x +} + +egTypeDataMap :: ((forall a. EGTypeData a -> a) -> b) -> EGTypeData b +egTypeDataMap f = EGTypeData { + boolData = f boolData, + intData = f intData, + colData = f colData +} + +egTypeGet :: EGVarType -> EGTypeData a -> a +egTypeGet EGBoolType = boolData +egTypeGet EGIntType = intData +egTypeGet EGColType = colData + +egTypeMod :: EGVarType -> EGTypeData a -> (a -> a) -> EGTypeData a +egTypeMod EGBoolType d f = d { boolData = f $ boolData d } +egTypeMod EGIntType d f = d { intData = f $ intData d } +egTypeMod EGColType d f = d { colData = f $ colData d } + +data EGEdge = EGEdge { + egeCons :: EGConstraintSpec, + egeLinks :: EGTypeData [EGVarId] +} deriving (Eq,Show) + +showBool :: EGVarId -> String +showBool (EGVarId i) = "b" ++ (show i) +showInt :: EGVarId -> String +showInt (EGVarId i) = "i" ++ (show i) +showCol :: EGVarId -> String +showCol (EGVarId i) = "c" ++ (show i) + +showLst :: (EGVarId -> String) -> [EGVarId] -> String +showLst _ [] = "[]" +showLst f x = "[" ++ (foldl1 (\x y -> x ++ "," ++ y) $ map f x) ++ "]" + +instance Display EGEdge where + displayer (EGEdge { egeCons = EGBoolValue i, egeLinks = EGTypeData { boolData = [l] } }) = displaySingle $ (showBool l) ++ " == " ++ "#["++(show i)++"]" + displayer (EGEdge { egeCons = EGIntValue i, egeLinks = EGTypeData { intData = [l] }}) = displaySingle $ (showInt l) ++ " == " ++ "#["++(show i)++"]" + displayer (EGEdge { egeCons = EGColValue i, egeLinks = EGTypeData { colData = [l] }}) = displaySingle $ (showCol l) ++ " == " ++ "#["++(show i)++"]" + displayer (EGEdge { egeCons = EGBoolExtern i, egeLinks = EGTypeData { boolData = [l] }}) = displaySingle $ (showBool l) ++ " == parentBool[" ++ (show i) ++ "]" + displayer (EGEdge { egeCons = EGIntExtern i, egeLinks = EGTypeData { intData = [l] }}) = displaySingle $ (showInt l) ++ " == parentInt[" ++ (show i) ++ "]" + displayer (EGEdge { egeCons = EGColExtern i, egeLinks = EGTypeData { colData = [l] }}) = displaySingle $ (showCol l) ++ " == parentCol[" ++ (show i) ++ "]" + displayer (EGEdge { egeCons = EGPlus, egeLinks = EGTypeData { intData=[a,b,c] }}) = displaySingle $ (showInt a) ++ " == " ++ (showInt b) ++ " + " ++ (showInt c) + displayer (EGEdge { egeCons = EGMinus, egeLinks = EGTypeData { intData=[a,b,c] }}) = displaySingle $ (showInt a) ++ " == " ++ (showInt b) ++ " - " ++ (showInt c) + displayer (EGEdge { egeCons = EGMult, egeLinks = EGTypeData { intData=[a,b,c] }}) = displaySingle $ (showInt a) ++ " == " ++ (showInt b) ++ " * " ++ (showInt c) + displayer (EGEdge { egeCons = EGDiv, egeLinks = EGTypeData { intData=[a,b,c] }}) = displaySingle $ (showInt a) ++ " == " ++ (showInt b) ++ " / " ++ (showInt c) + displayer (EGEdge { egeCons = EGMod, egeLinks = EGTypeData { intData=[a,b,c] }}) = displaySingle $ (showInt a) ++ " == " ++ (showInt b) ++ " % " ++ (showInt c) + displayer (EGEdge { egeCons = EGAbs, egeLinks = EGTypeData { intData=[a,b] }}) = displaySingle $ (showInt a) ++ " == abs(" ++ (showInt b) ++ ")" + displayer (EGEdge { egeCons = EGAt, egeLinks = EGTypeData { intData=[a,b], colData=[c] }}) = displaySingle $ (showInt a) ++ " == " ++ (showCol c) ++ "[" ++ (showInt b) ++ "]" + displayer (EGEdge { egeCons = EGSize, egeLinks = EGTypeData { intData=[a], colData=[c] }}) = displaySingle $ (showInt a) ++ " == size(" ++ (showCol c) ++ ")" + displayer (EGEdge { egeCons = EGDom, egeLinks = EGTypeData { intData=[a], colData=[c] }}) = displaySingle $ ("dom(" ++ (showInt a) ++ ") == " ++ (showCol c)) + displayer (EGEdge { egeCons = EGChannel, egeLinks = EGTypeData { boolData=[a], intData=[b] }}) = displaySingle $ (showBool a) ++ " == " ++ (showInt b) + displayer (EGEdge { egeCons = EGList 0, egeLinks = EGTypeData { colData=[c] }}) = displaySingle $ (showCol c) ++ " == []" + displayer (EGEdge { egeCons = EGList _, egeLinks = EGTypeData { intData=l, colData=[c] }}) = displaySingle $ (showCol c) ++ " == ["++(foldl1 (\a b -> a ++","++b) $ map showInt l)++"]" + displayer (EGEdge { egeCons = EGAllDiff _, egeLinks = EGTypeData { colData=[c] }}) = displaySingle $ "allDiff " ++ (showCol c) + displayer (EGEdge { egeCons = EGSorted b, egeLinks = EGTypeData { colData=[c] }}) = displaySingle $ "sorted " ++ (show b) ++ " " ++ (showCol c) + displayer (EGEdge { egeCons = EGRange, egeLinks = EGTypeData { intData=[l,h], colData=[c] }}) = displaySingle $ (showCol c) ++ " == ["++(showInt l)++".."++(showInt h)++"]" +-- displayer (EGEdge { egeCons = EGSlice f n, egeLinks = EGTypeData { colData=[c,o] }}) = displaySingle $ (showCol c) ++ " == "++(showCol o)++"[f(0)..f("++(show n)++"-1)]" + displayer (EGEdge { egeCons = EGCat, egeLinks = EGTypeData { colData=[c,a,b] }}) = displaySingle $ (showCol c) ++ " == "++(showCol a)++"++"++(showCol b) + displayer (EGEdge { egeCons = EGAnd, egeLinks = EGTypeData { boolData=[c,a,b] }}) = displaySingle $ (showBool c) ++ " == "++(showBool a)++" && "++(showBool b) + displayer (EGEdge { egeCons = EGOr, egeLinks = EGTypeData { boolData=[c,a,b] }}) = displaySingle $ (showBool c) ++ " == "++(showBool a)++" || "++(showBool b) + displayer (EGEdge { egeCons = EGEquiv, egeLinks = EGTypeData { boolData=[c,a,b] }}) = displaySingle $ (showBool c) ++ " == ("++(showBool a)++" == "++(showBool b)++")" + displayer (EGEdge { egeCons = EGNot, egeLinks = EGTypeData { boolData=[c,a] }}) = displaySingle $ (showBool c) ++ " == !"++(showBool a) + displayer (EGEdge { egeCons = EGEqual, egeLinks = EGTypeData { boolData=[r], intData=[a,b] }}) = displaySingle $ (showBool r) ++ " == ("++(showInt a)++" == "++(showInt b)++")" + displayer (EGEdge { egeCons = EGDiff, egeLinks = EGTypeData { boolData=[r], intData=[a,b] }}) = displaySingle $ (showBool r) ++ " == ("++(showInt a)++" != "++(showInt b)++")" + displayer (EGEdge { egeCons = EGLess q, egeLinks = EGTypeData { boolData=[r], intData=[a,b] }}) = displaySingle $ (showBool r) ++ " == ("++(showInt a)++(if q then " < " else " <= ")++(showInt b)++")" + displayer (EGEdge { egeCons = EGAll s _ _, egeLinks = EGTypeData { boolData=r:ab, intData=ai, colData=c:ac }}) = DisplayData ((showBool r)++" == forall("++(showCol c)++") "++(showLst showBool ab)++" "++(showLst showInt ai)++" "++(showLst showCol ac),[displayer s]) + displayer (EGEdge { egeCons = EGAny s _ _, egeLinks = EGTypeData { boolData=r:ab, intData=ai, colData=c:ac }}) = DisplayData ((showBool r)++" == forany("++(showCol c)++") "++(showLst showBool ab)++" "++(showLst showInt ai)++" "++(showLst showCol ac),[displayer s]) +-- displayer (EGEdge { egeCons = EGAllC s _ _, egeLinks = EGTypeData { boolData=r:ab, intData=l:h:ai, colData=ac }}) = DisplayData ((showBool r)++" == forall("++(showInt l)++".."++(showInt h)++") "++(showLst showBool ab)++" "++(showLst showInt ai)++" "++(showLst showCol ac),[displayer s]) +-- displayer (EGEdge { egeCons = EGAnyC s _ _, egeLinks = EGTypeData { boolData=r:ab, intData=l:h:ai, colData=ac }}) = DisplayData ((showBool r)++" == forany("++(showInt l)++".."++(showInt h)++") "++(showLst showBool ab)++" "++(showLst showInt ai)++" "++(showLst showCol ac),[displayer s]) + displayer (EGEdge { egeCons = EGMap s _, egeLinks = EGTypeData { boolData=ab, intData=ai, colData=r:c:ac }}) = DisplayData ((showCol r)++" == map("++(showCol c)++") "++(showLst showBool ab)++" "++(showLst showInt ai)++" "++(showLst showCol ac),[displayer s]) + displayer (EGEdge { egeCons = EGSlice s _, egeLinks = EGTypeData { boolData=ab, intData=n:ai, colData=r:c:ac }}) = DisplayData ((showCol r)++" == slice("++(showCol c)++",0..("++(showInt n)++")-1) "++(showLst showBool ab)++" "++(showLst showInt ai)++" "++(showLst showCol ac),[displayer s]) + displayer (EGEdge { egeCons = EGFold s _, egeLinks = EGTypeData { boolData=ab, intData=r:i:ai, colData=c:ac }}) = DisplayData ((showInt r)++" == fold("++(showCol c)++","++(showInt i)++") "++(showLst showBool ab)++" "++(showLst showInt ai)++" "++(showLst showCol ac),[displayer s]) + displayer (EGEdge { egeCons = EGCondInt, egeLinks = EGTypeData { boolData=[c], intData=[r,t,f] }}) = displaySingle $ (showInt r) ++ " = (if " ++ (showBool c) ++" then (" ++ (showInt t) ++ ") else (" ++ (showInt f)++"))" + displayer (EGEdge { egeCons = EGCondEqual, egeLinks = EGTypeData { boolData=[c,a,b] }}) = displaySingle $ "if " ++ (showBool c) ++" then " ++ (showBool a) ++ "=="++(showBool b) + displayer (EGEdge { egeCons = c }) = DisplayData ("???("++(show c)++")",[]) + +externMap :: EGModel -> EGTypeData (Map Int EGVarId) +externMap md = foldr f (baseTypeData Map.empty) $ map snd $ Map.toList $ egmEdges md + where f :: EGEdge -> EGTypeData (Map Int EGVarId) -> EGTypeData (Map Int EGVarId) + f (EGEdge { egeCons = EGIntExtern i, egeLinks = EGTypeData { intData = [v] } }) st = egTypeMod EGIntType st $ \m -> Map.insert i v m + f (EGEdge { egeCons = EGBoolExtern i, egeLinks = EGTypeData { boolData = [v] } }) st = egTypeMod EGBoolType st $ \m -> Map.insert i v m + f (EGEdge { egeCons = EGColExtern i, egeLinks = EGTypeData { colData = [v] } }) st = egTypeMod EGColType st $ \m -> Map.insert i v m + f _ st = st + +emptyModel :: EGModel -> Bool +emptyModel mod = + let mm = externMap mod + ss = Map.size (intData mm) + Map.size (colData mm) + Map.size (boolData mm) + in ss == (Map.size $ egmEdges mod) + +data EGModel = EGModel { + egmParams :: EGTypeData Int, + egmVars :: EGTypeData Int, + egmNEdges :: Int, + egmEdges :: Map EGEdgeId EGEdge, + egmLinks :: EGTypeData (Map EGVarId [(EGEdgeId,Int)]) +} deriving (Eq,Show) + +filterModel :: EGModel -> (EGEdge -> Maybe a) -> (EGModel,[a]) +filterModel mod f = foldl ff (mod,[]) $ Map.toList $ egmEdges mod + where ff (mm,n) (id,ed) = + let res = f ed + in case res of + Nothing -> (mm,n) + Just a -> (delEdge id mm,a:n) + +prefix :: String -> DisplayData -> DisplayData +prefix s (DisplayData (s1,x)) = DisplayData (s++s1,x) + +instance Display EGModel where + displayer (EGModel { egmEdges = x }) = DisplayData ("EGModel",map (\(id,x) -> prefix ((show $ unEGEdgeId id)++": ") $ displayer x) $ Map.toList x) + +addEdge :: EGConstraintSpec -> EGTypeData [EGVarId] -> EGModel -> EGModel +addEdge cons links model = + if (expected == getConsArgs cons) + then + let newEdgeId = EGEdgeId $ egmNEdges model + in model { + egmNEdges = egmNEdges model + 1, + egmEdges = Map.insert newEdgeId (EGEdge { egeCons = cons, egeLinks = links }) $ egmEdges model, + egmLinks = egTypeDataMap $ \f -> + foldr (\i -> + Map.insertWith (++) ((f links) !! i) [(newEdgeId,i)] + ) (f $ egmLinks model) [0..(length (f links) - 1)] + } + else + error $ "incorrect number of arguments for constraint ("++(show cons)++")" + where expected = egTypeDataMap (\f -> length $ f links) + +unifyIds :: EGVarId -> EGVarId -> EGVarId -> EGVarId +-- unifyIds fromId toId = (\x -> if x>fromId then x-1 else x) . (\x -> if x==fromId then toId else x) +unifyIds fromId toId = \x -> if x==fromId then toId else x + +delEdge :: EGEdgeId -> EGModel -> EGModel +delEdge id mod = do + let fnd = Map.lookup id $ egmEdges mod + case fnd of + Nothing -> error "deleting inexisting edge" + Just ff -> do + let nmp = Map.delete id $ egmEdges mod + mif [] = Nothing + mif x = Just x + afn = mif . filter ((/=id) . fst) + nln = egTypeDataMap $ \f -> foldr (\vid pre -> Map.alter (\(Just x) -> afn x) vid pre) (f $ egmLinks mod) $ f $ egeLinks ff + mod { egmEdges = nmp, egmLinks = nln } + +findEdge :: EGModel -> EGVarType -> EGVarId -> (Int -> Bool) -> (EGConstraintSpec -> Bool) -> Maybe (EGEdgeId,EGEdge) +findEdge model typ varid pos cons = + let mtc1 = Map.findWithDefault [] varid $ egTypeGet typ $ egmLinks model + mtc2 = filter (\(_,p) -> pos p) mtc1 + mtc3 = map (\(id,_) -> + (id,case Map.lookup id (egmEdges model) of + Nothing -> error $ "cannot find edge id="++(show id) + Just xx -> xx + )) mtc2 + mtc4 = filter (\(_,s) -> cons $ egeCons s) mtc3 + in case mtc4 of + [] -> Nothing + a:_ -> Just a + +pruneNodes :: EGModel -> EGModel +pruneNodes mod = + mod { egmLinks = egTypeDataMap $ \f -> Map.fromList $ filter (\(_,v) -> case v of [] -> True; _ -> False) $ Map.toList $ f $ egmLinks mod } + +unifyNodes :: EGVarType -> EGVarId -> EGVarId -> EGModel -> EGModel +unifyNodes vt fromId toId model = model { +-- egmVars = egTypeMod vt (egmVars model) pred, + egmEdges = Map.map (\x -> x { + egeLinks = egTypeMod vt (egeLinks x) $ \z -> + map (unifyIds fromId toId) z + }) $ egmEdges model, + egmLinks = egTypeMod vt (egmLinks model) $ \x -> Map.insertWith (++) toId (Map.findWithDefault [] fromId x) x +} + +addNode :: EGVarType -> EGModel -> (EGVarId,EGModel) +addNode vt model = ( + EGVarId (egTypeGet vt $ egmVars model), + model { + egmVars = egTypeMod vt (egmVars model) succ + } + ) + +delNode :: EGVarType -> EGVarId -> EGModel -> EGModel +delNode vt id model = model { egmLinks = egTypeMod vt (egmLinks model) (Map.delete id) } + +baseGraph :: EGModel +baseGraph = EGModel { + egmParams = baseTypeData 0, + egmVars = baseTypeData 0, + egmNEdges = 0, + egmEdges = Map.empty, + egmLinks = baseTypeData Map.empty +} + +data DisplayData = DisplayData (String,[DisplayData]) + +class Display a where + display :: Int -> a -> String + displayer :: a -> DisplayData + display n x = display n $ displayer x + +present :: Display a => a -> String +present = display 0 + +instance Display DisplayData where + displayer = id + display n (DisplayData (dir,sub)) = foldl (++) ((replicate (n*2) ' ')++dir++"\n") $ map (display $ n+1) sub + +displaySingle :: String -> DisplayData +displaySingle x = DisplayData (x,[]) + +getConnectedEdges :: EGModel -> EGVarType -> EGVarId -> [(EGEdge,Int)] +getConnectedEdges model typ id = map (\(eid,pos) -> (fromJust $ Map.lookup eid $ egmEdges model, pos)) $ fromJust $ Map.lookup id $ egTypeGet typ $ egmLinks model diff --git a/src/Control/CP/FD/Interface.hs b/src/Control/CP/FD/Interface.hs new file mode 100644 --- /dev/null +++ b/src/Control/CP/FD/Interface.hs @@ -0,0 +1,229 @@ +{-# LANGUAGE GADTs #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE TypeSynonymInstances #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE DatatypeContexts #-} + +module Control.CP.FD.Interface ( + FDSolver, + FDInstance, + (@+),(@-),(@*),(@/),(@%),(!),(@!!),(@..),(@++),size,xfold,xsum,xhead,xtail,list,slice,xmap,cte, + (Control.CP.FD.Interface.@||), + (Control.CP.FD.Interface.@&&), + Control.CP.FD.Interface.inv, + (Control.CP.FD.Interface.@=), + (Control.CP.FD.Interface.@/=), + (Control.CP.FD.Interface.@<), + (Control.CP.FD.Interface.@>), + (Control.CP.FD.Interface.@<=), + (Control.CP.FD.Interface.@>=), + (Control.CP.FD.Interface.@:), + (Control.CP.FD.Interface.@?), + (Control.CP.FD.Interface.@??), + Control.CP.FD.Interface.channel, + val, +-- Control.CP.FD.Interface.newInt, Control.CP.FD.Interface.newBool, Control.CP.FD.Interface.newCol, + Control.CP.FD.Interface.sorted, + Control.CP.FD.Interface.sSorted, + Control.CP.FD.Interface.forall, + Control.CP.FD.Interface.forany, + Control.CP.FD.Interface.loopall, + Control.CP.FD.Interface.allDiff, + Control.CP.FD.Interface.allDiffD, + Control.CP.FD.Interface.loopany, + allin, + asExpr, asCol, Control.CP.FD.Interface.asBool, + colList, labelCol, + ModelInt, ModelCol, ModelBool, + exists, true, false, +-- Modelable, +) where + +import Control.CP.FD.FD (FDSolver, FDInstance, FDIntTerm, getColItems) +import qualified Control.CP.FD.Model as Model +import Control.CP.FD.Model (Model, ModelBool, ModelCol, ModelInt, ToModelBool, asBool, asExpr, asCol, cte, newModelTerm, ModelIntArg, ModelBoolArg, ModelColArg) +import qualified Data.Expr.Sugar as Sugar +import Data.Expr.Util +import Data.Expr.Data +import Data.Expr.Sugar ((@+),(@-),(@*),(@/),(@%),(!),(@!!),(@..),(@++),size,xfold,xhead,xtail,slice,xmap,xsum,list) +import Control.CP.Solver +import Control.CP.SearchTree +import Control.CP.EnumTerm +import Control.Monad (ap, liftM) + +newtype DummySolver a = DummySolver () + +instance Monad DummySolver where + return = pure + _ >>= _ = DummySolver () + +instance Applicative DummySolver where + pure _ = DummySolver () + (<*>) = ap + +instance Functor DummySolver where + fmap = liftM + +data EQHelp b where + EQHelp :: Model.ModelTermType b => ((b -> Model) -> Model) -> EQHelp b + +instance Model.ModelTermType t => Term DummySolver t where + type Help DummySolver t = EQHelp t + help _ _ = EQHelp newModelTerm + newvar = DummySolver () + +instance Solver DummySolver where + type Constraint DummySolver = Either Model () + type Label DummySolver = () + add _ = DummySolver () + run _ = error "Attempt to run dummy solver" + mark = DummySolver () + goto _ = DummySolver () + +newtype Model.ModelTermType t => DummyTerm t = DummyTerm t + +-- class (Solver s, Term s ModelBool, Term s ModelInt, Term s ModelCol) => Modelable s where + +-- instance Modelable DummySolver where + +-- instance FDSolver s => Modelable (FDInstance s) where + + +treeToModel :: Tree DummySolver () -> Model +treeToModel (Return _) = BoolConst True +treeToModel (Try a b) = (Sugar.@||) (treeToModel a) (treeToModel b) +treeToModel (Add (Left c) m) = (Sugar.@&&) c (treeToModel m) +treeToModel Fail = BoolConst False +treeToModel (Label _) = error "Cannot turn labelled trees into expressions" +treeToModel (NewVar (f :: t -> Tree DummySolver ())) = case (help ((error "treeToModel undefined 1") :: DummySolver ()) ((error "treeToModel undefined 2") :: t)) of EQHelp ff -> ff (\x -> treeToModel $ f (x :: t)) + +addM :: (Constraint s ~ Either Model q, MonadTree m, TreeSolver m ~ s) => Model -> m () +addM m = addC $ Left m + +infixr 2 @|| +(@||) :: (Constraint s ~ Either Model q, MonadTree m, TreeSolver m ~ s) => Tree DummySolver () -> Tree DummySolver () -> m () +(@||) a b = addM $ treeToModel $ a \/ b + +infixr 3 @&& +(@&&) :: (Constraint s ~ Either Model q, MonadTree m, TreeSolver m ~ s) => Tree DummySolver () -> Tree DummySolver () -> m () +(@&&) a b = addM $ treeToModel $ a /\ b + +channel :: Tree DummySolver () -> ModelInt +channel a = Sugar.channel $ treeToModel a + +inv :: (Constraint s ~ Either Model q, MonadTree m, TreeSolver m ~ s) => Tree DummySolver () -> m () +inv a = addM $ Sugar.inv $ treeToModel a + +infix 4 @=, @/=, @<, @>, @<=, @>= + +class ModelExprClass a where + (@=) :: (Constraint s ~ Either Model q, MonadTree m, TreeSolver m ~ s) => a -> a -> m () + (@/=) :: (Constraint s ~ Either Model q, MonadTree m, TreeSolver m ~ s) => a -> a -> m () + +instance ModelExprClass ModelInt where + a @= b = addM $ (Sugar.@=) a b + a @/= b = addM $ (Sugar.@/=) a b + +instance ModelExprClass ModelCol where + a @= b = addM $ (Sugar.@=) a b + a @/= b = addM $ (Sugar.@/=) a b + +instance ModelExprClass ModelBool where + a @= b = addM $ (Sugar.@=) a b + a @/= b = addM $ (Sugar.@/=) a b + +instance ModelExprClass (Tree DummySolver ()) where + a @= b = addM $ (Sugar.@=) (treeToModel a) (treeToModel b) + a @/= b = addM $ (Sugar.@/=) (treeToModel a) (treeToModel b) + +(@<) :: (Constraint s ~ Either Model q, MonadTree m, TreeSolver m ~ s) => ModelInt -> ModelInt -> m () +(@<) a b = addM $ (Sugar.@<) a b + +(@>) :: (Constraint s ~ Either Model q, MonadTree m, TreeSolver m ~ s) => ModelInt -> ModelInt -> m () +(@>) a b = addM $ (Sugar.@>) a b + +(@>=) :: (Constraint s ~ Either Model q, MonadTree m, TreeSolver m ~ s) => ModelInt -> ModelInt -> m () +(@>=) a b = addM $ (Sugar.@>=) a b + +(@<=) :: (Constraint s ~ Either Model q, MonadTree m, TreeSolver m ~ s) => ModelInt -> ModelInt -> m () +(@<=) a b = addM $ (Sugar.@<=) a b + +val :: Tree DummySolver () -> ModelInt +val = Sugar.toExpr . treeToModel + +{- newBool :: (Constraint s ~ Either Model q, MonadTree m, TreeSolver m ~ s) => (ModelBool -> Tree DummySolver a) -> m a +newBool = exists + +newInt :: (Constraint s ~ Either Model q, MonadTree m, TreeSolver m ~ s) => (ModelInt -> m a) -> m a +newInt = exists + +newCol :: (Constraint s ~ Either Model q, MonadTree m, TreeSolver m ~ s) => (ModelCol -> m a) -> m a +newCol = exists +-} + +asBool :: (FDSolver s, MonadTree m, TreeSolver m ~ FDInstance s, ToModelBool t) => t -> m () +asBool = addM . Control.CP.FD.Model.asBool + +sorted :: (Constraint s ~ Either Model q, MonadTree m, TreeSolver m ~ s) => ModelCol -> m () +sorted = addM . Sugar.sorted + +sSorted :: (Constraint s ~ Either Model q, MonadTree m, TreeSolver m ~ s) => ModelCol -> m () +sSorted = addM . Sugar.sSorted + +allDiff :: (Constraint s ~ Either Model q, MonadTree m, TreeSolver m ~ s) => ModelCol -> m () +allDiff = addM . Sugar.allDiff + +allDiffD :: (Constraint s ~ Either Model q, MonadTree m, TreeSolver m ~ s) => ModelCol -> m () +allDiffD = addM . Sugar.allDiffD + +mm (nv@(Term tv)) m x = + let tf t = if (t==tv) then x else Term t + tb t = if (Term t==x) then nv else Term t + in boolTransformEx (tf,ColTerm,BoolTerm,tb,ColTerm,BoolTerm) m + +forall :: (Term s ModelInt, Term s ModelBool, Term s ModelCol, Constraint s ~ Either Model q, MonadTree m, TreeSolver m ~ s) => ModelCol -> (ModelInt -> Tree DummySolver ()) -> m () +-- forall col f = exists $ \nv -> addM $ Sugar.forall col $ mm nv $ treeToModel $ f nv +forall col f = addM $ Sugar.forall col (treeToModel . f) + +forany :: (Term s ModelInt, Term s ModelBool, Term s ModelCol, Constraint s ~ Either Model q, MonadTree m, TreeSolver m ~ s) => ModelCol -> (ModelInt -> Tree DummySolver ()) -> m () +-- forany col f = exists $ \nv -> addM $ Sugar.forany col $ mm nv $ treeToModel $ f nv +forany col f = addM $ Sugar.forany col (treeToModel . f) + +loopall :: (Term s ModelInt, Term s ModelBool, Term s ModelCol, Constraint s ~ Either Model q, MonadTree m, TreeSolver m ~ s) => (ModelInt,ModelInt) -> (ModelInt -> Tree DummySolver ()) -> m () +-- loopall r f = exists $ \nv -> addM $ Sugar.loopall r $ mm nv $ treeToModel $ f nv +loopall r f = addM $ Sugar.loopall r (treeToModel . f) + +loopany :: (Term s ModelInt, Term s ModelBool, Term s ModelCol, Constraint s ~ Either Model q, MonadTree m, TreeSolver m ~ s) => (ModelInt,ModelInt) -> (ModelInt -> Tree DummySolver ()) -> m () +-- loopany r f = exists $ \nv -> addM $ Sugar.loopany r $ mm nv $ treeToModel $ f nv +loopany r f = addM $ Sugar.loopany r (treeToModel . f) + +colList :: (Constraint s ~ Either Model q, MonadTree m, TreeSolver m ~ s) => ModelCol -> Int -> m [ModelInt] +colList col len = do + addM $ (Sugar.@=) (size col) (asExpr len) + return $ map (\i -> col!cte i) [0..len-1] + +labelCol :: (FDSolver s, MonadTree m, TreeSolver m ~ FDInstance s, EnumTerm s (FDIntTerm s)) => ModelCol -> m [TermBaseType s (FDIntTerm s)] +labelCol col = label $ do + lst <- getColItems col maxBound + return $ do + lsti <- colList col $ length lst + enumerate lsti + assignments lsti + +infix 5 @: + +(@:) :: (Constraint s ~ Either Model q, MonadTree m, TreeSolver m ~ s, Sugar.ExprRange ModelIntArg ModelColArg ModelBoolArg r, Term s ModelInt, Term s ModelBool, Term s ModelCol) => ModelInt -> r -> m () +a @: b = addM $ (Sugar.@:) a b + +infix 4 @? +infix 4 @?? + +a @? (t,f) = (Sugar.@?) (treeToModel a) (t,f) +a @?? (t,f) = addM $ (Sugar.@??) (treeToModel a) (treeToModel t, treeToModel f) + +allin :: (Constraint s ~ Either Model q, MonadTree m, TreeSolver m ~ s, Sugar.ExprRange ModelIntArg ModelColArg ModelBoolArg r, Term s ModelInt, Term s ModelBool, Term s ModelCol) => ModelCol -> r -> m () +allin c b = Control.CP.FD.Interface.forall c $ \x -> addM $ (Sugar.@:) x b diff --git a/src/Control/CP/FD/Model.hs b/src/Control/CP/FD/Model.hs new file mode 100644 --- /dev/null +++ b/src/Control/CP/FD/Model.hs @@ -0,0 +1,192 @@ +{- + - Monadic Constraint Programming + - http://www.cs.kuleuven.be/~toms/Haskell/ + - Tom Schrijvers & Pieter Wuille + -} + +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE TypeSynonymInstances #-} +{-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE FlexibleContexts #-} + +module Control.CP.FD.Model ( + Model, + ModelIntTerm(..), + ModelBoolTerm(..), + ModelColTerm(..), + ModelFunctions(..), + ModelInt, ToModelInt(..), ModelIntArg, + ModelCol, ToModelCol(..), ModelColArg, + ModelBool, ToModelBool(..), ModelBoolArg, + modelVariantInt, modelVariantBool, modelVariantCol, + ModelTermType(..), + showModel, + cte, +) where + +import Data.Expr.Data +import Data.Expr.Util +import Data.Expr.Sugar + +data ModelIntTerm t = + ModelIntVar Int + | ModelIntPar Int + deriving (Show) + +data ModelColTerm t = + ModelColVar Int + | ModelColPar Int + deriving (Show) + +data ModelBoolTerm t = + ModelBoolVar Int + | ModelBoolPar Int + | ModelExtra t + deriving (Show) + +data ModelFunctions = + ForNewBool (ModelBoolExpr ModelFunctions -> Model) + | ForNewInt (ModelIntExpr ModelFunctions -> Model) + | ForNewCol (ModelColExpr ModelFunctions -> Model) + +data ModelIntros = + NewBool Int FlatModel + | NewInt Int FlatModel + | NewCol Int FlatModel + deriving (Show,Eq) + +instance Ord ModelIntros where + compare (NewBool n1 m1) (NewBool n2 m2) = compare n1 n2 <<>> compare m1 m2 + compare (NewBool _ _) _ = LT + compare _ (NewBool _ _) = GT + compare (NewInt n1 m1) (NewInt n2 m2) = compare n1 n2 <<>> compare m1 m2 + compare (NewInt _ _) _ = LT + compare _ (NewInt _ _) = GT + compare (NewCol n1 m1) (NewCol n2 m2) = compare n1 n2 <<>> compare m1 m2 + +instance Show ModelFunctions where + show (ForNewBool f) = show $ explicate (-999999) $ f $ BoolTerm $ ModelBoolVar (-1000000) + show (ForNewInt f) = show $ explicate (-1999999) $ f $ Term $ ModelIntVar (-2000000) + show (ForNewCol f) = show $ explicate (-2999999) $ f $ ColTerm $ ModelColVar (-3000000) + +instance Eq ModelFunctions where + a==b = False + +instance Ord ModelFunctions where + compare _ _ = error "Unable to compare model functions" + +-- instance Show Model where +-- show x = show $ explicate 0 x + +deriving instance Eq t => Eq (ModelBoolTerm t) +deriving instance Ord t => Ord (ModelBoolTerm t) +deriving instance Eq t => Eq (ModelIntTerm t) +deriving instance Ord t => Ord (ModelIntTerm t) +deriving instance Eq t => Eq (ModelColTerm t) +deriving instance Ord t => Ord (ModelColTerm t) + +type ModelIntExpr t = Expr (ModelIntTerm t) (ModelColTerm t) (ModelBoolTerm t) +type ModelBoolExpr t = BoolExpr (ModelIntTerm t) (ModelColTerm t) (ModelBoolTerm t) +type ModelColExpr t = ColExpr (ModelIntTerm t) (ModelColTerm t) (ModelBoolTerm t) + +type ModelInt = ModelIntExpr ModelFunctions +type ModelBool = ModelBoolExpr ModelFunctions +type ModelCol = ModelColExpr ModelFunctions + +type ModelIntArg = ModelIntTerm ModelFunctions +type ModelBoolArg = ModelBoolTerm ModelFunctions +type ModelColArg = ModelColTerm ModelFunctions + +type FlatModelInt = ModelIntExpr ModelIntros +type FlatModelBool = ModelBoolExpr ModelIntros +type FlatModelCol = ModelColExpr ModelIntros + +type Model = ModelBool +type FlatModel = FlatModelBool + +explicate :: Int -> Model -> FlatModel +explicate num mod = boolTransformEx (it,ct,bt,iit,ict,ibt) mod + where it (ModelIntVar i) = Term $ ModelIntVar i + it (ModelIntPar i) = Term $ ModelIntPar i + ct (ModelColVar i) = ColTerm $ ModelColVar i + ct (ModelColPar i) = ColTerm $ ModelColPar i + iit (ModelIntVar i) = Term $ ModelIntVar i + iit (ModelIntPar i) = Term $ ModelIntPar i + ict (ModelColVar i) = ColTerm $ ModelColVar i + ict (ModelColPar i) = ColTerm $ ModelColPar i + ibt (ModelBoolVar i) = BoolTerm $ ModelBoolVar i + ibt (ModelBoolPar i) = BoolTerm $ ModelBoolPar i + bt (ModelBoolVar i) = BoolTerm $ ModelBoolVar i + bt (ModelBoolPar i) = BoolTerm $ ModelBoolPar i + bt (ModelExtra (ForNewBool f)) = BoolTerm $ ModelExtra $ NewBool num $ explicate (num+1) $ f $ BoolTerm $ ModelBoolVar num + bt (ModelExtra (ForNewInt f)) = BoolTerm $ ModelExtra $ NewInt num $ explicate (num+1) $ f $ Term $ ModelIntVar num + bt (ModelExtra (ForNewCol f)) = BoolTerm $ ModelExtra $ NewCol num $ explicate (num+1) $ f $ ColTerm $ ModelColVar num + +flatten :: Model -> FlatModel +flatten = explicate 0 + +showModel :: Model -> String +showModel = show . flatten + +variantIntTerm :: ModelIntTerm a -> Bool +variantIntTerm (ModelIntVar _) = True +variantIntTerm (ModelIntPar _) = False + +variantBoolTerm :: ModelBoolTerm a -> Bool +variantBoolTerm (ModelBoolVar _) = True +variantBoolTerm (ModelBoolPar _) = False +variantBoolTerm (ModelExtra _) = True + +variantColTerm :: ModelColTerm a -> Bool +variantColTerm (ModelColVar _) = True +variantColTerm (ModelColPar _) = False + +modelVariantInt :: ModelIntExpr x -> Bool +modelVariantInt = property variantIntTerm variantColTerm variantBoolTerm +modelVariantCol :: ModelColExpr x -> Bool +modelVariantCol = colProperty variantIntTerm variantColTerm variantBoolTerm +modelVariantBool :: ModelBoolExpr x -> Bool +modelVariantBool = boolProperty variantIntTerm variantColTerm variantBoolTerm + +newBool :: (ModelBool -> Model) -> Model +newBool = boolSimplify . BoolTerm . ModelExtra . ForNewBool + +newInt :: (ModelInt -> Model) -> Model +newInt = boolSimplify . BoolTerm . ModelExtra . ForNewInt + +newCol :: (ModelCol -> Model) -> Model +newCol = boolSimplify . BoolTerm . ModelExtra . ForNewCol + +class ModelTermType s where + newModelTerm :: (s -> Model) -> Model + +instance ModelTermType ModelBool where + newModelTerm = newBool + +instance ModelTermType ModelInt where + newModelTerm = newInt + +instance ModelTermType ModelCol where + newModelTerm = newCol + +cte :: Integral a => a -> ModelInt +cte = Const . toInteger + +class ToModelBool t where + asBool :: t -> ModelBool + +class ToModelInt t where + asExpr :: t -> ModelInt + +class ToModelCol t where + asCol :: t -> ModelCol + +instance ToExpr (ModelIntTerm ModelFunctions) (ModelColTerm ModelFunctions) (ModelBoolTerm ModelFunctions) t => ToModelInt t where + asExpr = toExpr + +instance ToBoolExpr (ModelIntTerm ModelFunctions) (ModelColTerm ModelFunctions) (ModelBoolTerm ModelFunctions) t => ToModelBool t where + asBool = toBoolExpr + +instance ToColExpr (ModelIntTerm ModelFunctions) (ModelColTerm ModelFunctions) (ModelBoolTerm ModelFunctions) t => ToModelCol t where + asCol = toColExpr diff --git a/src/Control/CP/FD/OvertonFD/Domain.hs b/src/Control/CP/FD/OvertonFD/Domain.hs new file mode 100644 --- /dev/null +++ b/src/Control/CP/FD/OvertonFD/Domain.hs @@ -0,0 +1,187 @@ +{- + - Origin: + - Constraint Programming in Haskell + - http://overtond.blogspot.com/2008/07/pre.html + - author: David Overton, Melbourne Australia + - + - Modifications: + - Monadic Constraint Programming + - http://www.cs.kuleuven.be/~toms/Haskell/ + - Tom Schrijvers + -} + +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE IncoherentInstances #-} +{-# LANGUAGE UndecidableInstances #-} + +module Control.CP.FD.OvertonFD.Domain ( + Domain, + ToDomain, + toDomain, + member, + isSubsetOf, + elems, + intersection, + difference, + union, + empty, + null, + singleton, + isSingleton, + filterLessThan, + filterGreaterThan, + findMax, + findMin, + size, + shiftDomain, + mapDomain, + absDomain +) where + +import qualified Data.IntSet as IntSet +import Data.IntSet (IntSet) +import Prelude hiding (null) +import Control.CP.Debug + +data Domain + = Set IntSet + | Range !Int !Int + deriving Show + +size :: Domain -> Int +size (Range l u) = u - l + 1 +size (Set set) = IntSet.size set + +-- Domain constructors +class ToDomain a where + toDomain :: a -> Domain + +instance ToDomain Domain where + toDomain = id + +instance ToDomain IntSet where + toDomain = Set + +instance Integral a => ToDomain [a] where + toDomain = toDomain . IntSet.fromList . map fromIntegral + +instance (Integral a, Integral b) => ToDomain (a, b) where + toDomain (a, b) = Range (fromIntegral a) (fromIntegral b) + +instance ToDomain () where + toDomain () = Range (-1000000000) 1000000000 -- minBound maxBound (too sensitive to overflow, e.g. 2 * minBound == 0) + +instance Integral a => ToDomain a where + toDomain a = toDomain (a, a) + +-- Operations on Domains +instance Eq Domain where + (Range xl xh) == (Range yl yh) = xl == yl && xh == yh + xs == ys = elems xs == elems ys + +member :: Int -> Domain -> Bool +member n x@(Set xs) = debugDom "[Domain.member]" x $ n `IntSet.member` xs +member n x@(Range xl xh) = debugDom "[Domain.member]" x $ n >= xl && n <= xh + +isSubsetOf :: Domain -> Domain -> Bool +isSubsetOf x@(Set xs) (Set ys) = debugDom "[Domain.isso]" x $ xs `IntSet.isSubsetOf` ys +isSubsetOf x@(Range xl xh) (Range yl yh) = debugDom "[Domain.isso]" x $ xl >= yl && xh <= yh +isSubsetOf x@(Set xs) yd@(Range yl yh) = debugDom "[Domain.isso]" x $ + isSubsetOf (Range xl xh) yd where + xl = IntSet.findMin xs + xh = IntSet.findMax xs +isSubsetOf (Range xl xh) x@(Set ys) = debugDom "[Domain.isso]" x $ + all (`IntSet.member` ys) [xl..xh] + +elems :: Domain -> [Int] +elems x@(Set xs) = debugDom "[Domain.elems]" x $ IntSet.elems xs +elems x@(Range xl xh) = debugDom "[Domain.elems]" x $ [xl..xh] + +intersection :: Domain -> Domain -> Domain +intersection x@(Set xs) (Set ys) = debugDom "[Domain.intersection]" x $ Set (xs `IntSet.intersection` ys) +intersection x@(Range xl xh) (Range yl yh) = debugDom "[Domain.intersection]" x $ Range (max xl yl) (min xh yh) +intersection x@(Set xs) (Range yl yh) = debugDom "[Domain.intersection]" x $ + Set $ IntSet.filter (\x -> x >= yl && x <= yh) xs +intersection x y = intersection y x + +union :: Domain -> Domain -> Domain +union x@(Set xs) (Set ys) = debugDom "[Domain.union]" x $ Set (xs `IntSet.union` ys) +union x@(Range xl xh) (Range yl yh) + | xh + 1 >= yl || yh+1 >= xl = debugDom "[Domain.union]" x $ Range (min xl yl) (max xh yh) + | otherwise = debugDom "[Domain.union]" x $ union (Set $ IntSet.fromList [xl..xh]) (Set $ IntSet.fromList [yl..yh]) +union x@(Set xs) y@(Range yl yh) = debugDom "[Domain.union]" x $ + if null x then y + else + let xmin = IntSet.findMin xs + xmax = IntSet.findMax xs + in + if (xmin + 1 >= yl && xmax - 1 <= yh) + then Range (min xmin yl) (max xmax yh) + else union (Set xs) (Set $ IntSet.fromList [yl..yh]) +union x y = union y x + +difference :: Domain -> Domain -> Domain +difference (x@(Set xs)) (y@(Set ys)) = debugDom "[Domain.difference]" x $ Set (xs `IntSet.difference` ys) +difference xd@(Range xl xh) (Range yl yh) + | yl > xh || yh < xl = debugDom "[Domain.difference]" xd $ xd + | otherwise = debugDom "[Domain.difference]" xd $ Set $ IntSet.fromList [x | x <- [xl..xh], x < yl || x > yh] +difference (x@(Set xs)) (Range yl yh) = + debugDom "[Domain.difference]" x $ Set $ IntSet.filter (\x -> x < yl || x > yh) xs +difference (x@(Range xl xh)) (Set ys) + | IntSet.findMin ys > xh || IntSet.findMax ys < xl = debugDom "[Domain.difference]" x $ Range xl xh + | otherwise = debugDom "[Domain.difference]" x $ Set $ + IntSet.fromList [x | x <- [xl..xh], not (x `IntSet.member` ys)] + +null :: Domain -> Bool +null (x@(Set xs)) = debug ("[Domain.null] " ++ printDom x) $ IntSet.null xs +null (x@(Range xl xh)) = debug ("[Domain.null] " ++ printDom x) $ xl > xh + +singleton :: Int -> Domain +singleton x = Range x x + +isSingleton :: Domain -> Bool +isSingleton (x@(Set xs)) = debugDom "[Domain.isSingleton]" x $ (IntSet.size xs)==1 +isSingleton (x@(Range xl xh)) = debug ("[Domain.isSingleton] " ++ printDom x) $ xl == xh + +filterLessThan :: Int -> Domain -> Domain +filterLessThan n (x@(Set xs)) = debug ("[Domain.filterLess] " ++ printDom x) $ Set $ IntSet.filter (< n) xs +filterLessThan n (x@(Range xl xh)) = debug ("[Domain.filterLess] " ++ printDom x) $ Range xl (min (n-1) xh) + +filterGreaterThan :: Int -> Domain -> Domain +filterGreaterThan n (x@(Set xs)) = debug ("[Domain.filterGreater] " ++ printDom x) $ Set $ IntSet.filter (> n) xs +filterGreaterThan n (x@(Range xl xh)) = debug ("[Domain.filterGreater] " ++ printDom x) $ Range (max (n+1) xl) xh + +findMax :: Domain -> Int +findMax (x@(Set xs)) = debug ("[Domain.findMax] " ++ printDom x) $ IntSet.findMax xs +findMax (x@(Range xl xh)) = debug ("[Domain.findMax] " ++ printDom x) $ xh + +findMin :: Domain -> Int +findMin (Set xs) = IntSet.findMin xs +findMin (Range xl xh) = xl + +empty :: Domain +empty = Range 1 0 + +shiftDomain :: Domain -> Int -> Domain +shiftDomain (x@(Range l u)) d = debug ("[Domain.shift] " ++ printDom x) $ Range (l + d) (u + d) +shiftDomain (x@(Set xs)) d = debug ("[Domain.shift] " ++ printDom x) $ Set $ IntSet.fromList $ map (+d) (IntSet.elems xs) + +mapDomain :: Domain -> (Int -> [Int]) -> Domain +mapDomain d f = debug ("[Domain.map] " ++ printDom d) $ Set $ IntSet.fromList $ concatMap f $ elems d + +absDomain :: Domain -> Domain +absDomain d@(Range l u) | l >= 0 = d + | u < 0 = Range (abs u) (abs l) + | otherwise = Range 0 (max (abs l) u) +absDomain d@(Set s) | IntSet.findMin s >= 0 = d + | otherwise = Set $ IntSet.map abs s + +mirrorDomain :: Domain -> Domain +mirrorDomain d@(Range l u) | l <= 0 && u >= 0 = Range (min l (-u)) (max (-l) u) + +printDom :: Domain -> String +printDom (Set cs) = "dom:Set(#" ++ (show $ IntSet.size cs) ++ ")" +printDom (Range l h) = "dom:Range(#" ++ (show $ h-l+1) ++ ":" ++ (show l) ++ "-" ++ (show h) ++ ")" + +debugDom :: String -> Domain -> a -> a +debugDom s d a = debug ("[Domain.findMax] " ++ printDom d) a diff --git a/src/Control/CP/FD/OvertonFD/OvertonFD.hs b/src/Control/CP/FD/OvertonFD/OvertonFD.hs new file mode 100644 --- /dev/null +++ b/src/Control/CP/FD/OvertonFD/OvertonFD.hs @@ -0,0 +1,392 @@ +{- + - Origin: + - Constraint Programming in Haskell + - http://overtond.blogspot.com/2008/07/pre.html + - author: David Overton, Melbourne Australia + - + - Modifications: + - Monadic Constraint Programming + - http://www.cs.kuleuven.be/~toms/Haskell/ + - Tom Schrijvers + -} + +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} + +module Control.CP.FD.OvertonFD.OvertonFD ( + OvertonFD, + fd_objective, + fd_domain, + FDVar, + OConstraint(..), + lookup, +) where + +import Prelude hiding (lookup) +import Data.Maybe (fromJust,isJust) +import Control.Monad.State.Lazy +import Control.Monad.Trans +import qualified Data.Map as Map +import Data.Map ((!), Map) +import Control.Monad (liftM,(<=<)) + +import Control.CP.FD.OvertonFD.Domain as Domain +import Control.CP.FD.FD hiding ((!)) +import Control.CP.Solver +import Control.CP.SearchTree +import Control.CP.EnumTerm + +import Control.CP.Debug + +-------------------------------------------------------------------------------- +-- Solver instance ------------------------------------------------------------- +-------------------------------------------------------------------------------- + +data OConstraint = + OHasValue FDVar Int + | OSame FDVar FDVar + | ODiff FDVar FDVar + | OLess FDVar FDVar + | OLessEq FDVar FDVar + | OAdd FDVar FDVar FDVar + | OSub FDVar FDVar FDVar + | OMult FDVar FDVar FDVar + | OAbs FDVar FDVar + deriving (Show,Eq) + +instance Solver OvertonFD where + type Constraint OvertonFD = OConstraint + type Label OvertonFD = FDState + add c = debug ("addOverton("++(show c)++")") $ addOverton c + run p = debug ("runOverton") $ runOverton p + mark = get + goto = put + +instance Term OvertonFD FDVar where + newvar = newVar () + type Help OvertonFD FDVar = () + help _ _ = () + +instance EnumTerm OvertonFD FDVar where + type TermBaseType OvertonFD FDVar = Int + getDomain = fd_domain + setValue var val = return [var `OHasValue` val] + +-------------------------------------------------------------------------------- +-- Constraints ----------------------------------------------------------------- +-------------------------------------------------------------------------------- + +addOverton (OHasValue v i) = v `hasValue` i +addOverton (OSame a b) = a `same` b +addOverton (ODiff a b) = a `different` b +addOverton (OLess a b) = a .<. b +addOverton (OLessEq a b) = a .<=. b +addOverton (OAdd a b c) = addSum a b c +addOverton (OSub a b c) = addSub a b c +addOverton (OMult a b c) = addMult a b c +addOverton (OAbs a b) = addAbs a b + +fd_domain :: FDVar -> OvertonFD [Int] +fd_domain v = do d <- lookup v + return $ elems d + +fd_objective :: OvertonFD FDVar +fd_objective = + do s <- get + return $ objective s + +-------------------------------------------------------------------------------- + +-- The FD monad +newtype OvertonFD a = OvertonFD { unFD :: State FDState a } + deriving (Monad, Applicative, Functor, MonadState FDState) + +-- FD variables +newtype FDVar = FDVar { unFDVar :: Int } deriving (Ord, Eq, Show) + +type VarSupply = FDVar + +data VarInfo = VarInfo + { delayedConstraints :: OvertonFD Bool, domain :: Domain } + +instance Show VarInfo where + show x = show $ domain x + +type VarMap = Map FDVar VarInfo + +data FDState = FDState + { varSupply :: VarSupply, varMap :: VarMap, objective :: FDVar } + deriving Show + +instance Eq FDState where + s1 == s2 = f s1 == f s2 + where f s = head $ elems $ domain $ varMap s ! (objective s) + +instance Ord FDState where + compare s1 s2 = compare (f s1) (f s2) + where f s = head $ elems $ domain $ varMap s ! (objective s) + + -- TOM: inconsistency is not observable within the OvertonFD monad +consistentFD :: OvertonFD Bool +consistentFD = return True + +-- Run the FD monad and produce a lazy list of possible solutions. +runOverton :: OvertonFD a -> a +runOverton fd = + let j = evalState (unFD fd) initState + in j + +initState :: FDState +initState = FDState { varSupply = FDVar 0, varMap = Map.empty, objective = FDVar 0 } + +-- Get a new FDVar +newVar :: ToDomain a => a -> OvertonFD FDVar +newVar d = do + s <- get + let v = varSupply s + put $ s { varSupply = FDVar (unFDVar v + 1) } + modify $ \s -> + let vm = varMap s + vi = VarInfo { + delayedConstraints = return True, + domain = toDomain d} + in + s { varMap = Map.insert v vi vm } + return v + +newVars :: ToDomain a => Int -> a -> OvertonFD [FDVar] +newVars n d = replicateM n (newVar d) + +-- Lookup the current domain of a variable. +lookup :: FDVar -> OvertonFD Domain +lookup x = do + s <- get + return . domain $ varMap s ! x + +-- Update the domain of a variable and fire all delayed constraints +-- associated with that variable. +update :: FDVar -> Domain -> OvertonFD Bool +update x i = do + debug (show x ++ " <- " ++ show i) (return ()) + s <- get + let vm = varMap s + let vi = vm ! x + debug ("where old domain = " ++ show (domain vi)) (return ()) + put $ s { varMap = Map.insert x (vi { domain = i}) vm } + delayedConstraints vi + +-- Add a new constraint for a variable to the constraint store. +addConstraint :: FDVar -> OvertonFD Bool -> OvertonFD () +addConstraint x constraint = do + s <- get + let vm = varMap s + let vi = vm ! x + let cs = delayedConstraints vi + put $ s { varMap = + Map.insert x (vi { delayedConstraints = do b <- cs + if b then constraint + else return False}) vm } + +-- Useful helper function for adding binary constraints between FDVars. +type BinaryConstraint = FDVar -> FDVar -> OvertonFD Bool +addBinaryConstraint :: BinaryConstraint -> BinaryConstraint +addBinaryConstraint f x y = do + let constraint = f x y + b <- constraint + when b $ (do addConstraint x constraint + addConstraint y constraint) + return b + +-- Constrain a variable to a particular value. +hasValue :: FDVar -> Int -> OvertonFD Bool +var `hasValue` val = do + vals <- lookup var + if val `member` vals + then do let i = singleton val + if (i /= vals) + then update var i + else return True + else return False + +-- Constrain two variables to have the same value. +same :: FDVar -> FDVar -> OvertonFD Bool +same = addBinaryConstraint $ \x y -> do + debug "inside same" $ return () + xv <- lookup x + yv <- lookup y + debug (show xv ++ " same " ++ show yv) $ return () + let i = xv `intersection` yv + if not $ Domain.null i + then whenwhen (i /= xv) (i /= yv) (update x i) (update y i) + else return False + +whenwhen c1 c2 a1 a2 = + if c1 + then do b1 <- a1 + if b1 + then if c2 + then a2 + else return True + else return False + else if c2 + then a2 + else return True + +-- Constrain two variables to have different values. +different :: FDVar -> FDVar -> OvertonFD Bool +different = addBinaryConstraint $ \x y -> do + xv <- lookup x + yv <- lookup y + if not (isSingleton xv) || not (isSingleton yv) || xv /= yv + then whenwhen (isSingleton xv && xv `isSubsetOf` yv) + (isSingleton yv && yv `isSubsetOf` xv) + (update y (yv `difference` xv)) + (update x (xv `difference` yv)) + else return False + +-- Constrain one variable to have a value less than the value of another +-- variable. +infix 4 .<. +(.<.) :: FDVar -> FDVar -> OvertonFD Bool +(.<.) = addBinaryConstraint $ \x y -> do + xv <- lookup x + yv <- lookup y + let xv' = filterLessThan (findMax yv) xv + let yv' = filterGreaterThan (findMin xv) yv + if not $ Domain.null xv' + then if not $ Domain.null yv' + then whenwhen (xv /= xv') (yv /= yv') (update x xv') (update y yv') + else return False + else return False + +-- Constrain one variable to have a value less than or equal to the value of another +-- variable. +infix 4 .<=. +(.<=.) :: FDVar -> FDVar -> OvertonFD Bool +(.<=.) = addBinaryConstraint $ \x y -> do + xv <- lookup x + yv <- lookup y + let xv' = filterLessThan (1 + findMax yv) xv + let yv' = filterGreaterThan ((findMin xv) - 1) yv + if not $ Domain.null xv' + then if not $ Domain.null yv' + then whenwhen (xv /= xv') (yv /= yv') (update x xv') (update y yv') + else return False + else return False + +{- +-- Get all solutions for a constraint without actually updating the +-- constraint store. +solutions :: OvertonFD s a -> OvertonFD s [a] +solutions constraint = do + s <- get + return $ evalStateT (unFD constraint) s + +-- Label variables using a depth-first left-to-right search. +labelling :: [FDVar s] -> OvertonFD s [Int] +labelling = mapM label where + label var = do + vals <- lookup var + val <- OvertonFD . lift $ elems vals + var `hasValue` val + return val +-} + +dump :: [FDVar] -> OvertonFD [Domain] +dump = mapM lookup + +-- Add constraint (z = x `op` y) for var z +addArithmeticConstraint :: + (Domain -> Domain -> Domain) -> + (Domain -> Domain -> Domain) -> + (Domain -> Domain -> Domain) -> + FDVar -> FDVar -> FDVar -> OvertonFD Bool +addArithmeticConstraint getZDomain getXDomain getYDomain x y z = do + xv <- lookup x + yv <- lookup y + let constraint z x y getDomain = do + xv <- lookup x + yv <- lookup y + zv <- lookup z + let znew = debug "binaryArith:intersection" $ (debug "binaryArith:zv" $ zv) `intersection` (debug "binaryArith:getDomain" $ getDomain xv yv) + debug ("binaryArith:" ++ show z ++ " before: " ++ show zv ++ show "; after: " ++ show znew) (return ()) + if debug "binaryArith:null?" $ not $ Domain.null (debug "binaryArith:null?:znew" $ znew) + then if (znew /= zv) + then debug ("binaryArith:update") $ update z znew + else return True + else return False + let zConstraint = debug "binaryArith: zConstraint" $ constraint z x y getZDomain + xConstraint = debug "binaryArith: xConstraint" $ constraint x z y getXDomain + yConstraint = debug "binaryArith: yConstraint" $ constraint y z x getYDomain + debug ("addBinaryArith: z x") (return ()) + addConstraint z xConstraint + debug ("addBinaryArith: z y") (return ()) + addConstraint z yConstraint + debug ("addBinaryArith: x z") (return ()) + addConstraint x zConstraint + debug ("addBinaryArith: x y") (return ()) + addConstraint x yConstraint + debug ("addBinaryArith: y z") (return ()) + addConstraint y zConstraint + debug ("addBinaryArith: y x") (return ()) + addConstraint y xConstraint + debug ("addBinaryArith: done") (return ()) + return True + +-- Add constraint (z = op x) for var z +addUnaryArithmeticConstraint :: (Domain -> Domain) -> (Domain -> Domain) -> FDVar -> FDVar -> OvertonFD Bool +addUnaryArithmeticConstraint getZDomain getXDomain x z = do + xv <- lookup x + let constraint z x getDomain = do + xv <- lookup x + zv <- lookup z + let znew = zv `intersection` (getDomain xv) + debug ("unaryArith:" ++ show z ++ " before: " ++ show zv ++ show "; after: " ++ show znew) (return ()) + if not $ Domain.null znew + then if (znew /= zv) + then update z znew + else return True + else return False + let zConstraint = constraint z x getZDomain + xConstraint = constraint x z getXDomain + addConstraint z xConstraint + addConstraint x zConstraint + return True + +addSum = addArithmeticConstraint getDomainPlus getDomainMinus getDomainMinus + +addSub = addArithmeticConstraint getDomainMinus getDomainPlus (flip getDomainMinus) + +addMult = addArithmeticConstraint getDomainMult getDomainDiv getDomainDiv + +addAbs = addUnaryArithmeticConstraint absDomain (\z -> mapDomain z (\i -> [i,-i])) + +getDomainPlus :: Domain -> Domain -> Domain +getDomainPlus xs ys = toDomain (zl, zh) where + zl = findMin xs + findMin ys + zh = findMax xs + findMax ys + +getDomainMinus :: Domain -> Domain -> Domain +getDomainMinus xs ys = toDomain (zl, zh) where + zl = findMin xs - findMax ys + zh = findMax xs - findMin ys + +getDomainMult :: Domain -> Domain -> Domain +getDomainMult xs ys = (\d -> debug ("multDomain" ++ show d ++ "=" ++ show xs ++ "*" ++ show ys ) d) $ toDomain (zl, zh) where + zl = minimum products + zh = maximum products + products = [x * y | + x <- [findMin xs, findMax xs], + y <- [findMin ys, findMax ys]] + +getDomainDiv :: Domain -> Domain -> Domain +getDomainDiv xs ys = toDomain (zl, zh) where + zl = minimum quotientsl + zh = maximum quotientsh + quotientsl = [if y /= 0 then x `div` y else minBound | + x <- [findMin xs, findMax xs], + y <- [findMin ys, findMax ys]] + quotientsh = [if y /= 0 then x `div` y else maxBound | + x <- [findMin xs, findMax xs], + y <- [findMin ys, findMax ys]] diff --git a/src/Control/CP/FD/OvertonFD/Sugar.hs b/src/Control/CP/FD/OvertonFD/Sugar.hs new file mode 100644 --- /dev/null +++ b/src/Control/CP/FD/OvertonFD/Sugar.hs @@ -0,0 +1,113 @@ +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE FlexibleContexts #-} + +module Control.CP.FD.OvertonFD.Sugar ( +) where + +import Data.Set(Set) +import qualified Data.Set as Set + +import Control.CP.Debug +import Control.Mixin.Mixin +import Control.CP.Solver +import Control.CP.FD.FD +import Control.CP.FD.SimpleFD +import Data.Expr.Data +import Data.Expr.Sugar +-- import Control.CP.FD.Expr.Util +import Control.CP.FD.Model +import Control.CP.FD.Graph +import Control.CP.FD.OvertonFD.OvertonFD + +newVars :: Term s t => Int -> s [t] +newVars 0 = return [] +newVars n = do + l <- newVars $ n-1 + n <- newvar + return $ n:l + +instance FDSolver OvertonFD where + type FDIntTerm OvertonFD = FDVar + type FDBoolTerm OvertonFD = FDVar + + type FDIntSpec OvertonFD = FDVar + type FDBoolSpec OvertonFD = FDVar + type FDColSpec OvertonFD = [FDVar] + + type FDIntSpecType OvertonFD = () + type FDBoolSpecType OvertonFD = () + type FDColSpecType OvertonFD = () + + fdIntSpec_const (Const i) = ((),do + v <- newvar + add $ OHasValue v $ fromInteger i + return v) + fdIntSpec_term i = ((),return i) + + fdBoolSpec_const (BoolConst i) = ((),do + v <- newvar + add $ OHasValue v $ if i then 1 else 0 + return v) + fdBoolSpec_term i = ((),return i) + + fdColSpec_list l = ((),return l) + fdColSpec_size (Const s) = ((),newVars $ fromInteger s) + fdColSpec_const l = ((),error "constant collections not yet supported by overton interface") + + fdColInspect = return + + fdSpecify = specify <@> simple_fdSpecify + fdProcess = process <@> simple_fdProcess + + fdEqualInt v1 v2 = addFD $ OSame v1 v2 + fdEqualBool v1 v2 = addFD $ OSame v1 v2 + fdEqualCol v1 v2 = do + if length v1 /= length v2 + then setFailed + else sequence_ $ zipWith (\a b -> addFD $ OSame a b) v1 v2 + + fdIntVarSpec = return . Just + fdBoolVarSpec = return . Just + fdSplitIntDomain b = do + d <- fd_domain b + return $ (map (b `OHasValue`) d, True) + fdSplitBoolDomain b = do + d <- fd_domain b + return $ (map (b `OHasValue`) $ filter (\x -> x==0 || x==1) d, True) + +-- processBinary :: (EGVarId,EGVarId,EGVarId) -> (FDVar -> FDVar -> FDVar -> OConstraint) -> FDInstance OvertonFD () +processBinary (v1,v2,va) f = addFD $ f (getDefIntSpec v1) (getDefIntSpec v2) (getDefIntSpec va) + +-- processUnary :: (EGVarId,EGVarId) -> (FDVar -> FDVar -> OConstraint) -> FDInstance OvertonFD () +processUnary (v1,va) f = addFD $ f (getDefIntSpec v1) (getDefIntSpec va) + +specify :: Mixin (SpecFn OvertonFD) +specify s t edge = case (debug ("overton-specify("++(show edge)++")") edge) of + EGEdge { egeCons = EGChannel, egeLinks = EGTypeData { intData=[i], boolData=[b] } } -> + ([(1000,b,True,do + s <- getIntSpec i + case s of + Just ss -> return $ SpecResSpec ((),return (ss,Nothing)) + _ -> return SpecResNone + )],[(1000,i,True,do + s <- getBoolSpec b + case s of + Just ss -> return $ SpecResSpec ((),return (ss,Nothing)) + _ -> return SpecResNone + )],[]) + _ -> s edge + +-- process :: Mixin (EGEdge -> FDInstance OvertonFD ()) +process s t con info = case (con,info) of + (EGIntValue c, ([],[a],[])) -> case c of + Const v -> addFD $ OHasValue (getDefIntSpec a) (fromInteger v) + _ -> error "Overton solver does not support parametrized values" + (EGPlus, ([],[a,b,c],[])) -> processBinary (b,c,a) OAdd + (EGMinus, ([],[a,b,c],[])) -> processBinary (a,c,b) OAdd + (EGMult, ([],[a,b,c],[])) -> processBinary (b,c,a) OMult + (EGAbs, ([],[a,b],[])) -> processUnary (b,a) OAbs + (EGDiff, ([FDSpecInfoBool {fdspBoolVal = Just (BoolConst True)}],[a,b],[])) -> addFD $ ODiff (getDefIntSpec a) (getDefIntSpec b) + (EGLess True, ([FDSpecInfoBool {fdspBoolVal = Just (BoolConst True)}],[a,b],[])) -> addFD $ OLess (getDefIntSpec a) (getDefIntSpec b) + (EGLess False, ([FDSpecInfoBool {fdspBoolVal = Just (BoolConst True)}],[a,b],[])) -> addFD $ OLessEq (getDefIntSpec a) (getDefIntSpec b) + (EGEqual, ([FDSpecInfoBool {fdspBoolVal = Just (BoolConst True)}],[a,b],[])) -> addFD $ OSame (getDefIntSpec a) (getDefIntSpec b) + _ -> s con info diff --git a/src/Control/CP/FD/SearchSpec/Data.hs b/src/Control/CP/FD/SearchSpec/Data.hs new file mode 100644 --- /dev/null +++ b/src/Control/CP/FD/SearchSpec/Data.hs @@ -0,0 +1,111 @@ +{-# LANGUAGE StandaloneDeriving #-} + +module Control.CP.FD.SearchSpec.Data ( + OptimDirection(..), + VarExpr(..), + VarStat(..), + Labelling(..), + SearchSpec(..), + ConstraintExpr, + ConstraintRefs(..), + mmapSearch +) where + +import Control.CP.Solver +import Control.CP.FD.FD +import Data.Expr.Data +import Control.Search.Generator +import Control.Search.Language + +-- Wouter Swierstra - Data Types a la Carte +-- Jacques Carette, Oleg - Finally Tagless + +data VarStat = + DLowerBound + | DUpperBound + | DDomSize + | DLowerRegret + | DUpperRegret + | DDegree + | DWDregree + | DRandom + | DMedian + | DDummy Int + deriving (Eq,Ord,Show) + +data OptimDirection = + Maximize + | Minimize + deriving (Eq,Ord,Show) + +type VarExpr = Expr VarStat () () + +data ConstraintRefs = + VarRef + | ValRef + deriving (Eq,Ord,Show) + +type ConstraintExpr = Expr ConstraintRefs () () +type ConstraintBoolExpr = BoolExpr ConstraintRefs () () + +data Labelling v a b = + LabelInt v VarExpr (ConstraintExpr -> ConstraintExpr-> ConstraintBoolExpr) + | LabelCol a VarExpr OptimDirection VarExpr (ConstraintExpr -> ConstraintExpr -> ConstraintBoolExpr) + | LabelBool b VarExpr + +data SearchSpec v a b = + Labelling (Labelling v a b) + | CombineSeq (SearchSpec v a b) (SearchSpec v a b) + | CombinePar (SearchSpec v a b) (SearchSpec v a b) + | TryOnce (SearchSpec v a b) + | LimitSolCount Integer (SearchSpec v a b) + | LimitDepth Integer (SearchSpec v a b) + | LimitNodeCount Integer (SearchSpec v a b) + | LimitDiscrepancy Integer (SearchSpec v a b) + | BranchBound v OptimDirection (SearchSpec v a b) + | PrintSol [v] [a] [b] (SearchSpec v a b) + +deriving instance (Show v, Show a, Show b) => Show (SearchSpec v a b) + +instance (Show v, Show a, Show b) => Show (Labelling v a b) where + show (LabelInt v x f) = "LabelInt " ++ (show v) ++ " " ++ (show x) ++ " " ++ (show $ f (Term VarRef) (Term ValRef)) + show (LabelCol v x d s f) = "LabelCol " ++ (show v) ++ " " ++ (show x) ++ " " ++ show d ++ " " ++ show s ++ " " ++ (show $ f (Term VarRef) (Term ValRef)) + show (LabelBool v x) = "LabelBool " ++ (show v) ++ " " ++ (show x) + +mmapSearch :: (Monad m) => SearchSpec v1 a1 b1 -> (v1 -> m v2) -> (a1 -> m a2) -> (b1 -> m b2) -> m (SearchSpec v2 a2 b2) +mmapSearch (Labelling (LabelInt v x f)) vf af bf = vf v >>= \y -> return $ Labelling $ LabelInt y x f +mmapSearch (Labelling (LabelCol a x d s f)) vf af bf = af a >>= \y -> return $ Labelling $ LabelCol y x d s f +mmapSearch (Labelling (LabelBool v x)) vf af bf = bf v >>= \y -> return $ Labelling $ LabelBool y x +mmapSearch (CombineSeq a b) vf af bf = do + ad <- mmapSearch a vf af bf + bd <- mmapSearch b vf af bf + return (CombineSeq ad bd) +mmapSearch (CombinePar a b) vf af bf = do + ad <- mmapSearch a vf af bf + bd <- mmapSearch b vf af bf + return (CombinePar ad bd) +mmapSearch (TryOnce a) vf af bf = do + ad <- mmapSearch a vf af bf + return (TryOnce ad) +mmapSearch (LimitSolCount n a) vf af bf = do + ad <- mmapSearch a vf af bf + return (LimitSolCount n ad) +mmapSearch (LimitDepth n a) vf af bf = do + ad <- mmapSearch a vf af bf + return $ (LimitDepth n ad) +mmapSearch (LimitNodeCount n a) vf af bf = do + ad <- mmapSearch a vf af bf + return $ (LimitNodeCount n ad) +mmapSearch (LimitDiscrepancy n a) vf af bf = do + ad <- mmapSearch a vf af bf + return $ (LimitDiscrepancy n ad) +mmapSearch (BranchBound v d a) vf af bf = do + vd <- vf v + ad <- mmapSearch a vf af bf + return (BranchBound vd d ad) +mmapSearch (PrintSol i c b a) iF cF bF = do + vi <- mapM iF i + vc <- mapM cF c + vb <- mapM bF b + ad <- mmapSearch a iF cF bF + return (PrintSol vi vc vb ad) diff --git a/src/Control/CP/FD/SimpleFD.hs b/src/Control/CP/FD/SimpleFD.hs new file mode 100644 --- /dev/null +++ b/src/Control/CP/FD/SimpleFD.hs @@ -0,0 +1,190 @@ +{-# LANGUAGE TypeFamilies #-} + +module Control.CP.FD.SimpleFD ( + simple_fdSpecify, + simple_fdProcess, +) where + +import Data.List (tails) +import qualified Data.Set as Set + +import Control.CP.Debug +import Control.Mixin.Mixin +import Control.CP.FD.FD +import Control.CP.Solver +import Control.CP.FD.Graph +import Data.Expr.Data +-- import Control.CP.FD.Expr.Util + +itake :: [a] -> Int -> Int -> [a] +itake _ _ 0 = [] +itake [] _ _ = [] +itake (a:ar) 0 l = a:(itake ar 0 (l-1)) +itake (a:ar) p l = itake ar (p-1) l + +simple_fdSpecify :: (FDSolver s, FDColSpec s ~ [FDIntTerm s], FDIntSpec s ~ FDIntTerm s, FDBoolSpec s ~ FDBoolTerm s) => Mixin (SpecFn s) +simple_fdSpecify s t edge = case (debug ("simple_fdSpecify("++(show edge)++")") edge) of + EGEdge { egeCons=EGAt, egeLinks = EGTypeData { colData=[c], intData=[r,p] } } -> + ([],[(500,r,True,do + k <- getIntVal p + case k of + Just (Const kk) -> do + Just cc <- getColSpec c + let trm = cc !! fromInteger kk + return $ SpecResSpec (minBound,return $ (trm, Nothing)) + _ -> return SpecResNone + )],[]) +{- EGEdge { egeCons=EGSlice f n, egeLinks = EGTypeData { colData=[r,s] } } -> + ([],[],[(500,r,True,do + (Just ss) <- getColSpec s + return $ SpecResSpec (minBound,return $ [ss !! (\(Const x) -> fromInteger x) (f i) | i <- [0..n-1]]) + )]) -} + EGEdge { egeCons=EGCat, egeLinks = EGTypeData { colData=[r,a,b] } } -> + ([],[],[(500,r,True,do + Just aa <- getColSpec a + Just bb <- getColSpec b + return $ SpecResSpec (minBound,return (aa++bb,Nothing)) + )]) +{- EGEdge { egeCons=EGRange, egeLinks = EGTypeData { intData=[l,h], colData=[c] } } -> + ([],[],[(550,c,False,do + ll <- getIntVal l + hh <- getIntVal h + case (ll,hh) of + (Just lll, Just hhh) -> return $ SpecResSpec (fdColSpec_size (hhh-lll+1) >>= \(t,v) -> return (t,(v,Nothing))) + _ -> return SpecResNone + )]) -} + _ -> s edge + +trueSpec = FDSpecInfoBool {fdspBoolSpec=const Nothing,fdspBoolVar=Nothing,fdspBoolVal=Just $ BoolConst True,fdspBoolTypes=Set.empty} + +simple_fdProcess :: (FDSolver s, FDColSpec s ~ [FDIntTerm s], FDIntSpec s ~ FDIntTerm s, FDBoolSpec s ~ FDBoolTerm s) => Mixin (EGConstraintSpec -> FDSpecInfo s -> FDInstance s ()) +simple_fdProcess s t cons info = case (cons,info) of + (EGAt,(_,[r,FDSpecInfoInt {fdspIntVal = Just (Const n)}],[c])) -> do + let cc = getDefColSpec c + sr = getDefIntSpec r + fdEqualInt (cc !! fromInteger n) sr + (EGAt,(_,[r,p],[c])) -> error ("Unsupported EGAt in simple_fdProcess r="++(show r)++" p="++(show p)++" c="++(show c)) + (EGList n,(_,l,[c])) -> do + let cc = getDefColSpec c + sequence_ $ zipWith (\id ce -> fdEqualInt ce $ getDefIntSpec id) l cc + (EGRange, ([],[FDSpecInfoInt {fdspIntVal = Just (Const ll)},FDSpecInfoInt {fdspIntVal=Just (Const hh)}],[c])) -> do + let cc = getDefColSpec c + sequence_ $ zipWith (\val var -> t (EGIntValue (Const val)) $ fdSpecInfo_spec ([],[Right (minBound,var)],[])) [ll..hh] cc + (EGRange, ([],[FDSpecInfoInt {fdspIntVar = Just ll},FDSpecInfoInt {fdspIntVar=Just hh}],[c])) -> do + let cc = getDefColSpec c + l <- getIntVal ll + h <- getIntVal hh + case (l,h) of + (Just (Const lll), Just (Const hhh)) -> sequence_ $ zipWith (\val var -> t (EGIntValue (Const val)) $ fdSpecInfo_spec ([],[Right (minBound,var)],[])) [lll..hhh] cc + _ -> s cons info + (EGRange, ([],[l,h],[c])) -> do + error ("Unsupported EGRange in simple_fdProcess: l=("++(show l)++") h=("++(show h)++") c=("++(show c)++")") + (EGSorted q, (_,_,[c])) -> do + let cc = getDefColSpec c + sequence_ $ zipWith (\a b -> t (EGLess q) $ fdSpecInfo_spec ([Left trueSpec],[Right (minBound,a), Right (minBound,b)],[])) cc (tail cc) + (EGAllDiff _, (_,_,[c])) -> do + let cc = getDefColSpec c + sequence_ [ t EGDiff $ fdSpecInfo_spec ([Left trueSpec],[Right (minBound,x), Right (minBound,e)],[]) | (x:xs) <- tails cc, e <- xs ] + (EGAll sm (nb,ni,nc) force,(r:vb,vi,c:vc)) -> do + let dr = getDefBoolSpec r + let dc = getDefColSpec c + let dcs = length dc + debug ("iter_process EGAll: dcs="++(show dcs)) $ return () + if force + then do + let mf i = do + let v = dc!!i + dv <- liftFD $ specInfoIntTerm v + let fb (-1) = error "SimpleFD EGAll undefined 1" + fb n = vb!!n + fi (-1) = dv + fi n = vi!!n + procSubModel sm (fb,fi,(vc!!)) + mapM_ mf [0..fromIntegral $ dcs-1] + else do + let mf i = do + let v = dc!!i + b <- liftFD $ newvar + db <- liftFD $ specInfoBoolTerm b + dv <- liftFD $ specInfoIntTerm v + let fb (-1) = db + fb n = vb!!n + fi (-1) = dv + fi n = vi!!n + procSubModel sm (fb,fi,(vc!!)) + return b + bools <- mapM mf [0..fromIntegral $ dcs-1] + treeAll t EGAnd True bools + return () + (EGAny sm (nb,ni,nc) _,(r:vb,vi,c:vc)) -> do + let dr = getDefBoolSpec r + let dc = getDefColSpec c + let dcs = length dc + let mf i = do + let v = dc!!i + b <- liftFD $ newvar + db <- liftFD $ specInfoBoolTerm b + dv <- liftFD $ specInfoIntTerm v + let fb (-1) = db + fb n = vb!!n + fi (-1) = dv + fi n = vi!!n + fc n = vc!!n + procSubModel sm (fb,fi,fc) + return b + bools <- mapM mf [0..fromIntegral $ dcs-1] + treeAll t EGOr False bools + return () + (EGMap sm (nb,ni,nc),(vb,vi,cr:c:vc)) -> do + let dc = getDefColSpec c + let dcr = getDefColSpec cr + let dcs = length dc + let mf i = do + let vin = dc!!i + let vout = dcr!!i + din <- liftFD $ specInfoIntTerm vin + dout <- liftFD $ specInfoIntTerm vout + let fi (-1) = dout + fi (-2) = din + fi n = vi!!n + fb n = vb!!n + fc n = vc!!n + procSubModel sm (fb,fi,fc) + mapM_ mf [0..fromIntegral $ dcs-1] + (EGFold sm (nb,ni,nc),(vb,r:ss:vi,c:vc)) -> do + let dc = getDefColSpec c + let dinit = getDefIntSpec ss + let dcs = length dc + let dres = getDefIntSpec r + tmp <- mapM (const $ liftFD newvar) [0..dcs-2] + let tmpv = tmp++[dres] + let mf i = do + let vin1 = if (i==0) then dinit else tmpv!!(i-1) + vout = tmpv!!i + let vin2 = dc!!i + din1 <- liftFD $ specInfoIntTerm vin1 + din2 <- liftFD $ specInfoIntTerm vin2 + dout <- liftFD $ specInfoIntTerm vout + let fi (-1) = dout + fi (-2) = din1 + fi (-3) = din2 + fi n = vi!!n + fb n = vb!!n + fc n = vc!!n + procSubModel sm (fb,fi,fc) + mapM_ mf [0..fromIntegral $ dcs-1] + _ -> s cons info + +treeAll :: (FDSolver s, FDBoolSpec s ~ FDBoolTerm s) => (EGConstraintSpec -> FDSpecInfo s -> FDInstance s ()) -> EGConstraintSpec -> Bool -> [FDBoolSpec s] -> FDInstance s (FDBoolSpec s) +treeAll p c d [] = return $ error "SimpleFD treeAll undefined" +treeAll p c d [a] = return a +treeAll p c d x = do + let (l,r) = splitAt ((length x) `div` 2) x + ld <- treeAll p c d l + rd <- treeAll p c d r + ldi <- liftFD $ specInfoBoolTerm ld + rdi <- liftFD $ specInfoBoolTerm rd + o <- liftFD $ newvar + oi <- liftFD $ specInfoBoolTerm o + p c ([oi,ldi,rdi],[],[]) + return o diff --git a/src/Control/CP/FD/Solvers.hs b/src/Control/CP/FD/Solvers.hs new file mode 100644 --- /dev/null +++ b/src/Control/CP/FD/Solvers.hs @@ -0,0 +1,52 @@ +module Control.CP.FD.Solvers where + +import qualified Control.CP.PriorityQueue as PriorityQueue +import qualified Data.Sequence + +import Control.CP.ComposableTransformers +import Control.CP.SearchTree +import Control.CP.FD.FD +-- import Control.CP.FD.OvertonFD.Sugar +-- import Control.CP.FD.OvertonFD.OvertonFD +-- import Control.CP.FD.Gecode.CodegenSolver + +-------------------------------------------------------------------------------- +-- FORCE SOLVERS +-------------------------------------------------------------------------------- + +-- as_overtonfd :: Tree (FDWrapper OvertonFD) a -> Tree OvertonFD a +-- as_overtonfd = unwrap +-- +-- as_gecode_codegen :: Tree (FDWrapper CodegenSolver) a -> Tree CodegenSolver a +-- as_gecode_codegen = unwrap +-- +-- as_gen_gecode_codegen :: (FDExpr CodegenSolver -> Tree (FDWrapper CodegenSolver) a) -> (FDExpr CodegenSolver -> Tree CodegenSolver a) +-- as_gen_gecode_codegen f = (\x -> unwrap $ f x) +-- + +------------------------------------------------------------------------------ +-- SEARCH STRATEGIES +------------------------------------------------------------------------------ + +dfs = [] +bfs = Data.Sequence.empty +pfs :: Ord a => PriorityQueue.PriorityQueue a (a,b,c) +pfs = PriorityQueue.empty + +nb :: Int -> CNodeBoundedST s a +nb = CNBST +db :: Int -> CDepthBoundedST s a +db = CDBST +bb :: NewBound s -> CBranchBoundST s a +bb = CBBST +sb :: Int -> CSolutionBoundST s a +sb = CSBST +fs :: CFirstSolutionST s a +fs = CFSST +it :: CIdentityCST s a +it = CIST +ra :: Int -> CRandomST s a +ra = CRST +ld :: Int -> CLimitedDiscrepancyST s a +ld = CLDST + diff --git a/src/Control/CP/PriorityQueue.hs b/src/Control/CP/PriorityQueue.hs new file mode 100644 --- /dev/null +++ b/src/Control/CP/PriorityQueue.hs @@ -0,0 +1,112 @@ +{- Copyright (c) 2008 the authors listed at the following URL, and/or +the authors of referenced articles or incorporated external code: +http://en.literateprograms.org/Priority_Queue_(Haskell)?action=history&offset=20080608152146 + +Permission is hereby granted, free of charge, to any person obtaining +a copy of this software and associated documentation files (the +"Software"), to deal in the Software without restriction, including +without limitation the rights to use, copy, modify, merge, publish, +distribute, sublicense, and/or sell copies of the Software, and to +permit persons to whom the Software is furnished to do so, subject to +the following conditions: + +The above copyright notice and this permission notice shall be +included in all copies or substantial portions of the Software. + +THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, +EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF +MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. +IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY +CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, +TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE +SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. + +Retrieved from: http://en.literateprograms.org/Priority_Queue_(Haskell)?oldid=13634 +-} + +{-# LANGUAGE DatatypeContexts #-} + +module Control.CP.PriorityQueue ( + PriorityQueue, + empty, + is_empty, + minKey, + minKeyValue, + insert, + deleteMin, + deleteMinAndInsert +) where + + +import Prelude + + +-- Declare the data type constructors. + +data Ord k => PriorityQueue k a = Nil | Branch k a (PriorityQueue k a) (PriorityQueue k a) + + +-- Declare the exported interface functions. + +-- Return an empty priority queue. + +is_empty Nil = True +is_empty _ = False + +empty :: Ord k => PriorityQueue k a +empty = Nil + + +-- Return the highest-priority key. + +minKey :: Ord k => PriorityQueue k a -> k +minKey = fst . minKeyValue + + +-- Return the highest-priority key plus its associated value. + +minKeyValue :: Ord k => PriorityQueue k a -> (k, a) +minKeyValue Nil = error "empty queue" +minKeyValue (Branch k a _ _) = (k, a) + + +-- Insert a key/value pair into a queue. + +insert :: Ord k => k -> a -> PriorityQueue k a -> PriorityQueue k a +insert k a q = union (singleton k a) q + +deleteMin :: Ord k => PriorityQueue k a -> ((k,a), PriorityQueue k a) +deleteMin(Branch k a l r) = ((k,a),union l r) + +-- Delete the highest-priority key/value pair and insert a new key/value pair into the queue. + +deleteMinAndInsert :: Ord k => k -> a -> PriorityQueue k a -> PriorityQueue k a +deleteMinAndInsert k a Nil = singleton k a +deleteMinAndInsert k a (Branch _ _ l r) = union (insert k a l) r + + + +-- Declare the private helper functions. + +-- Join two queues in sorted order. + +union :: Ord k => PriorityQueue k a -> PriorityQueue k a -> PriorityQueue k a +union l Nil = l +union Nil r = r +union l@(Branch kl _ _ _) r@(Branch kr _ _ _) + | kl <= kr = link l r + | otherwise = link r l + + +-- Join two queues without regard to order. + +-- (This is a helper to the union helper.) + +link (Branch k a Nil m) r = Branch k a r m +link (Branch k a ll lr) r = Branch k a lr (union ll r) + + +-- Return a queue with a single item from a key/value pair. + +singleton :: Ord k => k -> a -> PriorityQueue k a +singleton k a = Branch k a Nil Nil diff --git a/src/Control/CP/Queue.hs b/src/Control/CP/Queue.hs new file mode 100644 --- /dev/null +++ b/src/Control/CP/Queue.hs @@ -0,0 +1,53 @@ +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE ViewPatterns #-} +{-# LANGUAGE FlexibleInstances #-} +{- + - The Queue data type, a worklist data type for search. + - + - Monadic Constraint Programming + - http://www.cs.kuleuven.be/~toms/Haskell/ + - Tom Schrijvers + -} + +module Control.CP.Queue ( + Queue, + Elem, + emptyQ, + isEmptyQ, + popQ, + pushQ +) where + +import qualified Data.Sequence +import qualified Control.CP.PriorityQueue as PriorityQueue + +class Queue q where + type Elem q :: * + emptyQ :: q -> q + isEmptyQ :: q -> Bool + popQ :: q -> (Elem q,q) + pushQ :: Elem q -> q -> q + +instance Queue [a] where + type Elem [a] = a + emptyQ _ = [] + isEmptyQ = Prelude.null + popQ (x:xs) = (x,xs) + pushQ = (:) + +instance Queue (Data.Sequence.Seq a) where + type Elem (Data.Sequence.Seq a) = a + emptyQ _ = Data.Sequence.empty + isEmptyQ = Data.Sequence.null +-- popQ (Data.Sequence.viewl -> x Data.Sequence.:< xs) = (x,xs) + popQ l = case Data.Sequence.viewl l of + x Data.Sequence.:< xs -> (x,xs) + pushQ = flip (Data.Sequence.|>) + +instance Ord a => Queue (PriorityQueue.PriorityQueue a (a,b,c)) where + type Elem (PriorityQueue.PriorityQueue a (a,b,c)) = (a,b,c) + emptyQ _ = PriorityQueue.empty + isEmptyQ = PriorityQueue.is_empty + pushQ x@(k,_,_) = PriorityQueue.insert k x + popQ q = let ((_,x),q') = PriorityQueue.deleteMin q + in (x,q') diff --git a/src/Control/CP/SearchTree.hs b/src/Control/CP/SearchTree.hs new file mode 100644 --- /dev/null +++ b/src/Control/CP/SearchTree.hs @@ -0,0 +1,328 @@ +{- + - The Tree data type, a generic modelling language for constraint solvers. + - + - Monadic Constraint Programming + - http://www.cs.kuleuven.be/~toms/Haskell/ + - Tom Schrijvers + -} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE FlexibleContexts #-} + +module Control.CP.SearchTree ( + Tree(..), + transformTree, + bindTree, + insertTree, + (/\), + true, + disj, + conj, + disj2, + prim, + addC, + addT, + exist, + forall, + indent, + showTree, + mapTree, + MonadTree(..), + untree +) where + +import Control.CP.Solver +import Control.Mixin.Mixin + +import Control.Monad +import Control.Monad.Cont +import Control.Monad.Reader +import Control.Monad.Writer +import Control.Monad.State + +import Data.Monoid + + +------------------------------------------------------------------------------- +----------------------------------- Tree -------------------------------------- +------------------------------------------------------------------------------- + +data Tree s a where + Fail :: Tree s a -- failure + Return :: a -> Tree s a -- finished + Try :: Tree s a -> Tree s a -> Tree s a -- disjunction + Add :: Constraint s -> Tree s a -> Tree s a -- sequentially adding a constraint to a tree + NewVar :: Term s t => (t -> Tree s a) -> Tree s a -- add a new variable to a tree + Label :: s (Tree s a) -> Tree s a -- label with a strategy + +flattenTree :: Solver s => Tree s a -> Maybe ([Constraint s],a) +flattenTree Fail = Nothing +flattenTree (Return a) = Just ([],a) +flattenTree (Try _ _) = Nothing +flattenTree (Add c t) = case flattenTree t of + Nothing -> Nothing + Just (l,a) -> Just (c:l,a) +flattenTree (NewVar _) = Nothing +flattenTree (Label _) = Nothing + +transformTree :: Solver s => Mixin (Tree s a -> Tree s a) +transformTree _ _ Fail = Fail +transformTree _ _ (Return x) = Return x +transformTree _ t (Try x y) = Try (t x) (t y) +transformTree _ t (Add c x) = Add c (t x) +transformTree _ t (NewVar f) = NewVar (\x -> t $ f x) +transformTree _ t (Label m) = Label $ m >>= return . t +-- transformTree s _ x = s x + +mapTree :: (Solver s1, Solver s2, MonadTree m, TreeSolver m ~ s2) => (forall t. s1 t -> s2 t) -> Tree s1 a -> m a +mapTree _ Fail = false +mapTree _ (Return a) = return a +mapTree f (Try a b) = mapTree f a \/ mapTree f b +-- mapTree f (Add c n) = label $ f $ (add c >>= \t -> if t then return (mapTree f n) else return false) +-- mapTree (NewVar _) = undefined +mapTree f (Label l) = label $ (f l) >>= (\t -> return (mapTree f t)) + +instance Solver s => Functor (Tree s) where + fmap = liftM + +instance Solver s => Applicative (Tree s) where + pure = Return + (<*>) = ap + +instance Solver s => Monad (Tree s) where + return = pure + (>>=) = bindTree + + +bindTree :: Solver s => Tree s a -> (a -> Tree s b) -> Tree s b +Fail `bindTree` k = Fail +(Return x) `bindTree` k = k x +(Try m n) `bindTree` k = Try (m `bindTree` k) (n `bindTree` k) +(Add c m) `bindTree` k = Add c (m `bindTree` k) +(NewVar f) `bindTree` k = NewVar (\x -> f x `bindTree` k) +(Label m) `bindTree` k = Label (m >>= \t -> return (t `bindTree` k)) + +insertTree :: Solver s => Tree s a -> Tree s () -> Tree s a +(NewVar f) `insertTree` t = NewVar (\x -> f x `insertTree` t) +(Add c o) `insertTree` t = Add c (o `insertTree` t) +other `insertTree` t = t /\ other + +{- Monad laws: + - + - 1. return x >>= f == f x + - + - return a >>= f + - == Return a >>= f (return def) + - == f x (bind def) + - + - 2. m >>= return = m + - + - By induction + - case m of + - 1) Return x -> + - Return x >>= return + - == return x (bind def) + - == Return x (return def) + - 2) Fail -> + - Fail >>= return + - == Fail (bind def) + - 3) Try l r >>= return + - == Try (l >>= return) (r >>= return) (bind def) + - == Try l r (induction) + - 4) Add c m >>= return + - == Add c (m >>= return) (bind def) + - == Add c m (induction) + - 5) NewVar i f >>= return + - == NewVar i (\v -> f v >>= return) (bind def) + - == NewVar i (\v -> f v) ((co)-induction?) + - == NewVar i f (eta reduction) + - 6) Label sm >>= return + - == Label (sm >>= \m -> return (m >>= return)) (bind def) + - == Label (sm >>= \m -> return m) (co-induction) + - == Label (sm >>= return) (eta reduction) + - == Label sm (2nd monad law for Monad s) + - + - 3. (m >>= f) >>= g = m >>= (\x -> f x >>= g) + - + - By induction + - case m of + - 1) (Return y >>= f) >>= g + - == f y >>= g (bind def) + - == (\x -> f x >>= g) y (beta expansion) + - == Return y >>= (\x -> f x >>= g) (bind def) + - 2) (Fail >>= f) >>= g + - == Fail >>= g (bind def) + - == Fail (bind def) + - == Fail >>= (\x -> f x >>= g) (bind def) + - 3) (Try l r >>= f) >>= g + - == Try (l >>= f) (r >>= f)) >>= g (bind def) + - == Try ((l >>= f) >>= g) ((r >>= f) >>= g) (bind def) + - == Try (l >>= (\x -> f x >>= g)) (r >>= (\x -> f x >>= g)) (induction) + - == Try l r >>= (\x -> f x >>= g) (bind def) + - 4) (NewVar i m >>= f) >>= g + - == NewVar i (\v -> m v >>= f) >>= g (bind def) + - == NewVar i (\w -> (\v -> m v >>= f) w >>= g) (bind def) + - == NewVar i (\w -> (m w >>= f) >>= g) (beta reduction) + - == NewVar i (\w -> m w >>= (\x -> f x >>= g)) (co-induction) + - == NewVar i m >>= (\x -> f x >>= g) (bind def) + - 5) (Label sm >>= f) >>= g + - == Label (sm >>= \m -> return (m >>= f)) >>= g (bind def) + - == Label ((sm >>= \m -> return (m >>= f)) >>= \m' -> return (m' >>= g)) + - == Label (sm >>= (\m -> return (m >>= f) >>= \m' -> return (m' >>= g))) + - == Label (sm >>= \m -> return ((m >>= f) >>= g)) + - == Label (sm >>= \m -> return (m >>= (\x -> f x >>= g))) + - == Label sm >>= (\x -> f x >>= g) + - + -} + +------------------------------------------------------------------------------- +----------------------------------- Monad Subclass ---------------------------- +------------------------------------------------------------------------------- + +infixl 2 \/ + +-- | Generalization of the search tree data type, +-- allowing monad transformer decoration. +class (Monad m, Solver (TreeSolver m)) => MonadTree m where + type TreeSolver m :: * -> * + addTo :: Constraint (TreeSolver m) -> m a -> m a + false :: m a + (\/) :: m a -> m a -> m a + exists :: Term (TreeSolver m) t => (t -> m a) -> m a + label :: (TreeSolver m) (m a) -> m a + +instance Solver solver => MonadTree (Tree solver) where + type TreeSolver (Tree solver) = solver + addTo = Add + false = Fail + (\/) = Try + exists = NewVar + label = Label + +instance (MonadTree m, Solver (TreeSolver m)) => MonadTree (ContT r m) where + type TreeSolver (ContT r m) = TreeSolver m + addTo constraint cm = ContT $ \k -> addTo constraint (runContT cm k) + false = lift false + l \/ r = ContT $ \k -> (runContT l k) \/ (runContT r k) + exists f = ContT $ \k -> exists (\t -> runContT (f t) k) + label scm = ContT $ \k -> label (scm >>= \cm -> return $ runContT cm k) + +------------------------------------------------------------------------------- +----------------------------------- Sugar ------------------------------------- +------------------------------------------------------------------------------- + +infixr 3 /\ +(/\) :: MonadTree tree => tree a -> tree b -> tree b +(/\) = (>>) + +true :: MonadTree tree => tree () +true = return () + +disj :: MonadTree tree => [tree a] -> tree a +disj [] = false +disj a = foldr1 (\/) a + +conj :: MonadTree tree => [tree ()] -> tree () +conj [] = true +conj a = foldr1 (/\) a + +disj2 :: MonadTree tree => [tree a] -> tree a +disj2 (x: []) = x +disj2 l = let (xs,ys) = split l + split [] = ([],[]) + split (a:as) = let (bs,cs) = split as + in (a:cs,bs) + in (disj2 xs) \/ (disj2 ys) + +prim :: MonadTree tree => TreeSolver tree a -> tree a +prim action = label (action >>= return . return) + +addC :: MonadTree tree => Constraint (TreeSolver tree) -> tree () +addC c = c `addTo` true + +addT :: MonadTree tree => Constraint (TreeSolver tree) -> tree Bool +addT c = c `addTo` (return True) + +exist :: (MonadTree tree, Term (TreeSolver tree) t) => Int -> ([t] -> tree a) -> tree a +exist n ftree = f n [] + where f 0 acc = ftree $ reverse acc + f n acc = exists $ \v -> f (n-1) (v:acc) + +forall :: (MonadTree tree, Term (TreeSolver tree) t) => [t] -> (t -> tree ()) -> tree () +forall list ftree = conj $ map ftree list + +-- Shortcut the search procedure for a Tree that does not contain Try nodes. +-- create a solver monad that returns the result of the Tree, or a specified +-- value upon failure +untree :: Solver s => v -> Tree s v -> s v +untree _ (Return x) = return x +untree _ (Try _ _) = error "convertion of Try nodes to solver is not supported" +untree e (Fail) = return e +untree e (Label s) = s >>= untree e +untree e (Add c t) = (add c) >>= (\x -> if x then untree e t else return e) +untree e (NewVar f) = do + v <- newvar + untree e (f v) + +-- | show + +indent :: Int -> String +indent l = replicate (2*l) ' ' + +showTree :: (Show (Constraint s), Show a, Solver s) => Int -> Tree s a -> s String +showTree l Fail = return $ indent l ++ "Fail\n" +showTree l (Return x) = return $ indent l ++ "Return [" ++ (show x) ++ "]\n" +showTree l (Try a b) = do + m <- mark + s1 <- showTree (l+1) a + goto m + s2 <- showTree (l+1) b + return $ indent l ++ "Try\n" ++ s1 ++ s2 +showTree l (Add c t) = do + s <- showTree (l+1) t + return $ indent l ++ "Add (" ++ (show c) ++ ")\n" ++ s +showTree l (NewVar f) = do + n <- newvar + s <- showTree (l+1) (f n) + return $ indent l ++ "NewVar\n" ++ s +showTree l (Label a) = do + r <- a + s <- showTree (l+1) r + return $ indent l ++ "Label\n" ++ s + +instance Show (Tree s a) where + show Fail = "Fail" + show (Return _) = "Return" + show (Try l r) = "Try (" ++ show l ++ ") (" ++ show r ++ ")" + show (Add _ t) = "Add (" ++ show t ++ ")" + show (NewVar _) = "NewVar " + show (Label _) = "Label " + +---------------------------------------------------------------------- +-- Monad Transformer Instances +---------------------------------------------------------------------- + +instance MonadTree t => MonadTree (ReaderT env t) where + type TreeSolver (ReaderT env t) = TreeSolver t + addTo constraint tree = ReaderT $ \env -> addTo constraint (runReaderT tree env) + false = lift false + l \/ r = ReaderT $ \env -> runReaderT l env \/ runReaderT r env + exists f = ReaderT $ \env -> exists (\var -> runReaderT (f var) env) + label p = ReaderT $ \env -> label (p >>= \m -> return $ runReaderT m env) + +instance (Monoid w, MonadTree t) => MonadTree (WriterT w t) where + type TreeSolver (WriterT w t) = TreeSolver t + addTo constraint tree = WriterT $ addTo constraint (runWriterT tree) + false = lift false + l \/ r = WriterT $ runWriterT l \/ runWriterT r + exists f = WriterT $ exists (\var -> runWriterT (f var)) + label p = WriterT $ label (p >>= \m -> return $ runWriterT m) + +instance MonadTree t => MonadTree (StateT s t) where + type TreeSolver (StateT s t) = TreeSolver t + addTo constraint tree = StateT $ \s -> addTo constraint (runStateT tree s) + false = lift false + l \/ r = StateT $ \s -> runStateT l s \/ runStateT r s + exists f = StateT $ \s -> exists (\var -> runStateT (f var) s) + label p = StateT $ \s -> label (p >>= \m -> return $ runStateT m s) diff --git a/src/Control/CP/Solver.hs b/src/Control/CP/Solver.hs new file mode 100644 --- /dev/null +++ b/src/Control/CP/Solver.hs @@ -0,0 +1,80 @@ +{- + - The Solver class, a generic interface for constraint solvers. + - + - Monadic Constraint Programming + - http://www.cs.kuleuven.be/~toms/Haskell/ + - Tom Schrijvers + -} + +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE FlexibleInstances #-} + +module Control.CP.Solver ( + Solver, + Constraint, + Label, + add, + run, + mark, markn, + goto, + Term, + newvar, + Help, + help, +) where + +import Control.Monad.Writer +import Data.Monoid + +class Monad solver => Solver solver where + -- | the constraints + type Constraint solver :: * + -- | the labels + type Label solver :: * + -- | add a constraint to the current state, and + -- return whether the resulting state is consistent + add :: Constraint solver -> solver Bool + -- | run a computation + run :: solver a -> a + -- | mark the current state, and return its label + mark :: solver (Label solver) + -- | mark the current state as discontinued, yet return a label that is usable n times + markn :: Int -> solver (Label solver) + -- | go to the state with given label + goto :: Label solver -> solver () + + markn _ = mark + +class (Solver solver) => Term solver term where + -- | produce a fresh constraint variable + newvar :: solver term + + -- see note [Solver-Specific Term Operations] + type Help solver term + help :: solver () -> term -> Help solver term + +-- [Solver-Specific Term Operations] +-- +-- Terms of solvers in general only support the 'newvar' operation. +-- However, for specific solvers, all terms may support additional +-- operations. +-- +-- The 'Help'/'help' infrastructure allows accessing this solver-specific +-- term operations. + +-- | WriterT decoration of a solver +-- useful for producing statistics during solving +instance (Monoid w, Solver s) => Solver (WriterT w s) where + type Constraint (WriterT w s) = Constraint s + type Label (WriterT w s) = Label s + add = lift . add + run = fst . run . runWriterT + mark = lift mark + markn = lift . markn + goto = lift . goto + +instance (Monoid w, Term s t) => Term (WriterT w s) t where + newvar = lift newvar + type Help (WriterT w s) t = () + help _ _ = () diff --git a/src/Control/CP/Transformers.hs b/src/Control/CP/Transformers.hs new file mode 100644 --- /dev/null +++ b/src/Control/CP/Transformers.hs @@ -0,0 +1,115 @@ +{- + - Monadic Constraint Programming + - http://www.cs.kuleuven.be/~toms/Haskell/ + - Tom Schrijvers + -} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE Rank2Types #-} +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE ConstrainedClassMethods #-} +module Control.CP.Transformers ( + eval, + eval', + continue, + NodeBoundedST, + DepthBoundedST, + Transformer(..), +) where + +import Control.CP.Solver +import Control.CP.SearchTree +import Control.CP.Queue +import Control.CP.Debug + +-------------------------------------------------------------------------------- +-- EVALUATION +-------------------------------------------------------------------------------- + +eval :: (Solver solver, Queue q, Elem q ~ (Label solver,Tree solver (ForResult t),TreeState t), Transformer t, + ForSolver t ~ solver) + => Tree solver (ForResult t) -> q -> t -> solver (Int,[ForResult t]) +eval tree q t = debug "eval" $ + do (es,ts) <- initT t tree + eval' 0 tree q t es ts + +eval' :: SearchSig solver q t (ForResult t) +eval' !i (Return x) wl t es ts = do (j,xs) <- returnT (i+1) wl t es + return (j,(x:xs)) +eval' i (Add c k) wl t es ts = do b <- Control.CP.Solver.add c + if b then eval' (i+1) k wl t es ts + else continue (i+1) wl t es +eval' i (NewVar f) wl t es ts = do v <- newvar + eval' (i+1) (f v) wl t es ts +eval' i (Try l r) wl t es ts = + do now <- markn 2 + let wl' = pushQ (now,l,leftT t es ts) $ pushQ (now,r,rightT t es ts) wl + continue (i+1) wl' t es +eval' i Fail wl t es ts = continue (i+1) wl t es +eval' i (Label m) wl t es ts = do tree <- m + eval' (i+1) tree wl t es ts + +continue :: ContinueSig solver q t (ForResult t) +continue i wl t es + | isEmptyQ wl = endT i wl t es -- return (i,[]) + | otherwise = let ((past,tree,ts),wl') = popQ wl + in do goto past + nextT i tree wl' t es ts + +-------------------------------------------------------------------------------- +-- TRANSFORMER +-------------------------------------------------------------------------------- + +type SearchSig solver q t a = + (Solver solver, Queue q, Transformer t, + Elem q ~ (Label solver,Tree solver a,TreeState t), + ForSolver t ~ solver) + => Int -> Tree solver a -> q -> t -> EvalState t -> TreeState t -> solver (Int,[a]) + +type ContinueSig solver q t a = + (Solver solver, Queue q, Transformer t, + Elem q ~ (Label solver,Tree solver a,TreeState t), + ForSolver t ~ solver) + => Int -> q -> t -> EvalState t -> solver (Int,[a]) + +class Transformer t where + type EvalState t :: * + type TreeState t :: * + type ForSolver t :: (* -> *) + type ForResult t :: * + leftT, rightT :: t -> EvalState t -> TreeState t -> TreeState t + leftT _ _ = id + rightT = leftT + nextT :: SearchSig (ForSolver t) q t (ForResult t) + nextT = eval' + initT :: t -> Tree (ForSolver t) (ForResult t) -> (ForSolver t) (EvalState t,TreeState t) + returnT :: ContinueSig solver q t (ForResult t) + returnT i wl t es = continue i wl t es + endT :: ContinueSig solver q t (ForResult t) + endT i wl t es = return (i,[]) + +newtype DepthBoundedST (solver :: * -> *) a = DBST Int + +instance Solver solver => Transformer (DepthBoundedST solver a) where + type EvalState (DepthBoundedST solver a) = () + type TreeState (DepthBoundedST solver a) = Int + type ForSolver (DepthBoundedST solver a) = solver + type ForResult (DepthBoundedST solver a) = a + initT (DBST n) _ = return ((),n) + leftT _ _ ts = ts - 1 + nextT i tree q t es ts + | ts == 0 = continue i q t es + | otherwise = eval' i tree q t es ts + +newtype NodeBoundedST (solver :: * -> *) a = NBST Int + +instance Solver solver => Transformer (NodeBoundedST solver a) where + type EvalState (NodeBoundedST solver a) = Int + type TreeState (NodeBoundedST solver a) = () + type ForSolver (NodeBoundedST solver a) = solver + type ForResult (NodeBoundedST solver a) = a + initT (NBST n) _ = return (n,()) + nextT i tree q t es ts + | es == 0 = return (i,[]) + | otherwise = eval' i tree q t (es - 1) ts + diff --git a/src/Control/Mixin/Mixin.hs b/src/Control/Mixin/Mixin.hs new file mode 100644 --- /dev/null +++ b/src/Control/Mixin/Mixin.hs @@ -0,0 +1,60 @@ +-- | Module with basic infrastructure for function inheritance +-- based on open rercusion. +-- +-- See the work of William Cook. +-- +-- We use the following terminology. +-- +-- * A /closed/ function is an ordinary function. +-- +-- * A /mixin/ function is an open function that can be +-- inherited from, or that extends another open function. +-- +-- We obtain a closed function from a base mixin 'base' +-- and a number of mixin extensions 'e1',...,'en' as follows: +-- +-- > mixin (en <@> ... <@> e1 <@> base) +-- +module Control.Mixin.Mixin ( + Mixin, + (<@>), + mixin, + mixinId, + mixinLift +) where + +infixl 5 <@> + +-- | Type of mixin functions. +type Mixin a = a -- the 'super' function + -> a -- the 'this' function + -> a -- the current function + +-- | Mixin composition. +(<@>) :: Mixin a -> Mixin a -> Mixin a +(f1 <@> f2) super this = f1 (f2 super this) this + +-- | Turn a mixin into a closed function. +mixin :: Mixin a -> a +mixin openF + = let closedF = openF errorF closedF + errorF = error $ "super called in base mixin" + in closedF + +-- | Mixin identity function. +-- +-- Identity for mixin composition: +-- +-- +-- > mixinId <@> f == f +-- > f <@> mixinId == f +-- +mixinId :: Mixin a +mixinId super this = super + +-- | Mixin lift function +-- +-- > mixin . mixinLift = id + +mixinLift :: (a -> b) -> Mixin (a -> b) +mixinLift f _ _ = f diff --git a/src/Control/Monatron/AutoInstances.hs b/src/Control/Monatron/AutoInstances.hs new file mode 100644 --- /dev/null +++ b/src/Control/Monatron/AutoInstances.hs @@ -0,0 +1,19 @@ +{-# Language FlexibleInstances #-} +{-# language OverlappingInstances #-} +{-# language IncoherentInstances #-} + +module Control.Monatron.AutoInstances where + +import Control.Monatron.MonadT + +------------------------------------------------------------------ +instance (Monad m, MonadT t) => Monad (t m) where + return = pure + fail = lift . fail + (>>=) = tbind + +instance (Monad m, MonadT t) => Functor (t m) where fmap = liftM + +instance (Monad m, MonadT t) => Applicative (t m) where + pure = treturn + (<*>) = ap diff --git a/src/Control/Monatron/AutoLift.hs b/src/Control/Monatron/AutoLift.hs new file mode 100644 --- /dev/null +++ b/src/Control/Monatron/AutoLift.hs @@ -0,0 +1,128 @@ +{-# OPTIONS + -XFlexibleInstances + -XMultiParamTypeClasses + -XFunctionalDependencies + -XUndecidableInstances + -XOverlappingInstances +#-} + +-- -XOverlappingInstances + +module Control.Monatron.AutoLift ( + StateM(..), get,put, + WriterM (..), tell, + ReaderM(..), ask,local, + ExcM(..), throw,handle, + ContM(..), callCC, + ListM(..), mZero,mPlus, + module Control.Monatron.Operations +) where + +import Control.Monatron.Operations +import Control.Exception (SomeException) + + +------------------------------------------------------------------ +-- State +class Monad m => StateM z m | m -> z where + stateModel :: AlgModel (StateOp z) m + +instance Monad m => StateM z (StateT z m) where + stateModel = modelStateT + +instance (StateM z m, MonadT t) => StateM z (t m) where + stateModel = liftAlgModel stateModel + +get :: StateM z m => m z +get = getX stateModel + +put :: StateM z m => z -> m () +put = putX stateModel + +------------------------------------------------------------------ +-- Traces +class (Monoid z, Monad m) => WriterM z m | m -> z where + writerModel :: AlgModel (WriterOp z) m + +instance (Monoid z, Monad m) => WriterM z (WriterT z m) where + writerModel = modelWriterT + +instance (Monoid z, WriterM z m, MonadT t) => WriterM z (t m) where + writerModel = liftAlgModel writerModel + +tell :: (Monoid z, WriterM z m) => z -> m () +tell z = traceX writerModel z + +------------------------------------------------------------------ +-- Environments +class Monad m => ReaderM z m | m -> z where + readerModel :: Model (ReaderOp z) m + +instance Monad m => ReaderM z (ReaderT z m) where + readerModel = modelReaderT + +instance (ReaderM z m, Functor m, FMonadT t) => ReaderM z (t m) where + readerModel = liftModel readerModel + +ask :: ReaderM z m => m z +ask = askX readerModel + +local :: ReaderM z m => (z -> z) -> m a -> m a +local = localX readerModel + +------------------------------------------------------------------ +-- Throw and Handle +class Monad m => ExcM z m | m -> z where + throwModel :: AlgModel (ThrowOp z) m + handleModel :: Model (HandleOp z) m + +instance Monad m => ExcM z (ExcT z m) where + throwModel = modelThrowExcT + handleModel = modelHandleExcT + +instance ExcM SomeException IO where + throwModel = modelThrowIO + handleModel = modelHandleIO + +instance (ExcM z m, Functor m, FMonadT t) => ExcM z (t m) where + throwModel = liftAlgModel throwModel + handleModel = liftModel handleModel + +throw :: ExcM z m => z -> m a +throw = throwX throwModel + +handle :: ExcM z m => m a -> (z -> m a) -> m a +handle = handleX handleModel + +------------------------------------------------------------------ +-- callCC operation + +class Monad m => ContM r m | m -> r where + contModel :: AlgModel (ContOp r) m + +instance Monad m => ContM (m r) (ContT r m) where + contModel = modelContT + +instance (ContM r m, MonadT t) => ContM r (t m) where + contModel = liftAlgModel contModel + +callCC :: ContM r m => ((a -> r) -> a) -> m a +callCC = callCCX contModel + +------------------------------------------------------------------ +-- MPlus operations + +class Monad m => ListM m where + listModel :: AlgModel ListOp m + +instance Monad m => ListM (ListT m) where + listModel = modelListT + +instance (ListM m, MonadT t) => ListM (t m) where + listModel = liftAlgModel listModel + +mZero :: (ListM m) => m a +mZero = zeroListX listModel + +mPlus :: ListM m => m a -> m a -> m a +mPlus = plusListX listModel diff --git a/src/Control/Monatron/Codensity.hs b/src/Control/Monatron/Codensity.hs new file mode 100644 --- /dev/null +++ b/src/Control/Monatron/Codensity.hs @@ -0,0 +1,36 @@ +{-# OPTIONS -XRank2Types #-} + +module Control.Monatron.Codensity ( + Codensity, + codensity, + runCodensity +) where + +import Control.Monatron.MonadT +import Control.Monad.Fix +import Control.Monatron.AutoInstances() + +---------------------------------------------------------- +-- Codensity Monad +---------------------------------------------------------- + +newtype Codensity f a = Codensity { + unCodensity :: forall b. (a -> f b) -> f b +} + +codensity :: (forall b. (a -> f b) -> f b) -> Codensity f a +codensity = Codensity + +runCodensity :: Monad m => Codensity m a -> m a +runCodensity c = unCodensity c return + +instance MonadT Codensity where + lift m = Codensity (m >>=) + c `tbind` f = Codensity (\k -> unCodensity c (\a -> unCodensity (f a) k)) + +-- still need to prove that MonadFix laws hold +instance MonadFix m => MonadFix (Codensity m) where + mfix f = Codensity $ \k -> mfix (runCodensity. f) >>= k + +------------------------ + diff --git a/src/Control/Monatron/IdT.hs b/src/Control/Monatron/IdT.hs new file mode 100644 --- /dev/null +++ b/src/Control/Monatron/IdT.hs @@ -0,0 +1,13 @@ +module Control.Monatron.IdT where + +import Control.Monatron.Monatron + +newtype IdT m a = IdT { runIdT :: m a } + +instance MonadT IdT where + lift = IdT + tbind m f = IdT $ runIdT m >>= runIdT . f + +instance FMonadT IdT where + tmap' d1 _d2 g f = IdT . f . fmapD d1 g . runIdT + diff --git a/src/Control/Monatron/Monad.hs b/src/Control/Monatron/Monad.hs new file mode 100644 --- /dev/null +++ b/src/Control/Monatron/Monad.hs @@ -0,0 +1,70 @@ + +module Control.Monatron.Monad ( + State, Writer, Reader, Exception, Cont, + state,writer,reader,exception,cont, + runState, runWriter, runReader, runException, runCont, + Id(..), Lift(..) +) where + + +import Control.Monatron.Transformer +import Control.Monad +import Control.Monad.Fix + +newtype Id a = Id {runId :: a} +data Lift a = L {runLift :: a} + +type State s = StateT s Id +type Writer w = WriterT w Id +type Reader r = ReaderT r Id +type Exception x = ExcT x Id +type Cont r = ContT r Id + +state :: (s -> (a, s)) -> State s a +state st = stateT $ \s -> Id $ st s + +runState :: s -> State s a -> (a,s) +runState s = runId. runStateT s + +writer :: Monoid w => (a,w) -> Writer w a +writer = writerT . Id + +runWriter :: Monoid w => Writer w a -> (a,w) +runWriter = runId. runWriterT + +reader :: (r -> a) -> Reader r a +reader e = readerT $ \r -> Id (e r) + +runReader :: r -> Reader r a -> a +runReader r = runId . runReaderT r + +exception :: Either x a -> Exception x a +exception = excT . Id + +runException :: Exception x a -> Either x a +runException = runId. runExcT + +cont :: ((a -> r) -> r) -> Cont r a +cont c = contT $ \k -> Id $ c (runId . k) + +runCont :: (a -> r) -> Cont r a -> r +runCont k = runId. runContT (Id. k) + +instance Monad Id where + return = pure + fail = error + m >>= f = f (runId m) + +instance Monad Lift where + return x = L x + fail x = error x + L x >>= k = k x + +instance Functor Id where fmap = liftM +instance Functor Lift where fmap = liftM + +instance Applicative Id where pure = Id ; (<*>) = ap +instance Applicative Lift where pure = L ; (<*>) = ap + +instance MonadFix Id where mfix f = let m = f (runId m) in m +instance MonadFix Lift where mfix f = let m = f (runLift m) in m diff --git a/src/Control/Monatron/MonadInfo.hs b/src/Control/Monatron/MonadInfo.hs new file mode 100644 --- /dev/null +++ b/src/Control/Monatron/MonadInfo.hs @@ -0,0 +1,74 @@ +{-# LANGUAGE FlexibleInstances #-} +-- {-# LANGUAGE OverlappingInstances #-} +{-# LANGUAGE TypeOperators #-} + +module Control.Monatron.MonadInfo ( + MInfo(..), MonadInfo(minfo), MonadInfoT(tminfo), + miInc +) where + +import Control.Monatron.Monad +import Control.Monatron.MonadT +import Control.Monatron.IdT +import Control.Monatron.Transformer +import Control.Monatron.Zipper +import Control.Monatron.Codensity + +import Data.Map (Map) +import qualified Data.Map as Map + +newtype MInfo = MInfo (Map String Int) + deriving (Show, Eq, Ord) + +miBase = MInfo Map.empty + +miInc s (MInfo m) = MInfo $ Map.alter (\x -> case x of { Nothing -> Just 1; Just n -> Just (n+1) }) s m + +undef :: a +undef = error "MonadInfo: undefined" + +class Monad m => MonadInfo m where + minfo :: m a -> MInfo + +class MonadT t => MonadInfoT t where + tminfo :: MonadInfo m => t m a -> MInfo + +instance MonadInfoT (StateT s) where + tminfo x = miInc "StateT" (minfo $ runStateT (undef :: s) x) + +instance Monoid w => MonadInfoT (WriterT w) where + tminfo x = miInc "WriterT" (minfo $ runWriterT x) + +instance MonadInfoT (ReaderT s) where + tminfo x = miInc "ReaderT" (minfo $ runReaderT (undef :: s) x) + +instance MonadInfoT (ExcT x) where + tminfo x = miInc "ExcT" (minfo $ runExcT x) + +instance MonadInfoT (ContT x) where + tminfo x = miInc "ContT" (minfo $ runContT (undef) x) + +instance MonadInfoT ListT where + tminfo x = miInc "ListT" (minfo $ runListT x) + +instance Functor f => MonadInfoT (StepT f) where + tminfo x = miInc "StepT" (minfo $ runStepT x) + +instance (MonadInfoT t1, MonadInfoT t2) => MonadInfoT (t1 :> t2) where + tminfo x = miInc ":>" (minfo $ runZipper x) + +instance MonadInfoT Codensity where + tminfo x = miInc "Codensity" (minfo $ runCodensity x) + +instance MonadInfo Id where + minfo _ = miInc "Id" miBase + +instance MonadInfo Lift where + minfo _ = miInc "Lift" miBase + +instance MonadInfoT IdT where + tminfo x = miInc "IdT" (minfo $ runIdT x) + +instance (MonadInfo m, MonadInfoT t) => MonadInfo (t m) where + minfo x = tminfo x + diff --git a/src/Control/Monatron/MonadT.hs b/src/Control/Monatron/MonadT.hs new file mode 100644 --- /dev/null +++ b/src/Control/Monatron/MonadT.hs @@ -0,0 +1,47 @@ +{-# OPTIONS -XRank2Types #-} + +module Control.Monatron.MonadT ( + MonadT(..), FMonadT(..), MMonadT(..), FComp(..), FunctorD(..), tmap, mtmap, + module Control.Monad +) where + +import Control.Monad + + +---------------------------------------------------------- +-- Class of monad transformers with +-- a lifting of first-order operations +---------------------------------------------------------- + +class MonadT t where + lift :: Monad m => m a -> t m a + treturn :: Monad m => a -> t m a + treturn = lift. return + tbind :: Monad m => t m a -> (a -> t m b) -> t m b + +newtype FunctorD f = FunctorD {fmapD :: forall a b . (a -> b) -> f a -> f b} + +functor :: Functor f => FunctorD f +functor = FunctorD fmap + +class MonadT t => FMonadT t where + tmap' :: FunctorD m -> FunctorD n -> (a -> b) -> (forall x. m x -> n x) -> t m a -> t n b + +tmap :: (FMonadT t, Functor m, Functor n) => (forall b. m b -> n b) -> t m a -> t n a +tmap = tmap' functor functor id + +mtmap :: FMonadT t => FunctorD f -> (a -> b) -> t f a -> t f b +mtmap fd f = tmap' fd fd f id + +class FMonadT t => MMonadT t where + flift :: Functor f => f a -> t f a --should coincide with lift! + monoidalT :: (Functor f, Functor g) => t f (t g a) -> t (FComp f g) a + +---------------------------------------- +-- Functor Composition +---------------------------------------- + +newtype (FComp f g) a = Comp {deComp :: (f (g a)) } + +instance (Functor f, Functor g) => Functor (FComp f g) where + fmap f (Comp fga) = Comp (fmap (fmap f) fga) diff --git a/src/Control/Monatron/Monatron.hs b/src/Control/Monatron/Monatron.hs new file mode 100644 --- /dev/null +++ b/src/Control/Monatron/Monatron.hs @@ -0,0 +1,12 @@ + +module Control.Monatron.Monatron ( + module Control.Monatron.Monad, + module Control.Monatron.AutoLift, + version +)where + +import Control.Monatron.Monad +import Control.Monatron.AutoLift + +version :: (Int,Int,Int) +version = (0,0,1) diff --git a/src/Control/Monatron/Open.hs b/src/Control/Monatron/Open.hs new file mode 100644 --- /dev/null +++ b/src/Control/Monatron/Open.hs @@ -0,0 +1,58 @@ +-- {-# OPTIONS -fglasgow-exts -XNoMonomorphismRestriction -XOverlappingInstances #-} + +{-# LANGUAGE NoMonomorphismRestriction #-} +{-# LANGUAGE OverlappingInstances #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE FlexibleInstances #-} + +module Control.Monatron.Open where + +import Control.Monatron.Monatron () +import Control.Monatron.AutoLift + +infixr 9 :+: +infixr 9 <@> + +data (:+:) f g a = Inl (f a) | Inr (g a) + +newtype Fix f = In {out :: f (Fix f)} + +type Open e f r = (e -> r) -> (f e -> r) + +(<@>) :: Open e f r -> Open e g r -> Open e (f :+: g) r +evalf <@> evalg = \eval e -> + case e of + Inl el -> evalf eval el + Inr er -> evalg eval er + +fix :: Open (Fix f) f r -> (Fix f -> r) +fix f = let this = f this . out + in this + +-- Borrowed from Data types \`a la Carte + +class (f :<: g) where + inj :: f a -> g a + +instance Functor f => (:<:) f f where + inj = id + +instance (Functor g, Functor f) + => (:<:) f (f :+: g) where + inj = Inl + +instance (Functor g, Functor h, Functor f, f :<: g) + => (:<:) f (h :+: g) where + inj = Inr . inj + +inject :: (f :<: g) => f (Fix g) -> Fix g +inject = In . inj + +instance (Functor f, Functor g) => + Functor (f :+: g) where + fmap f (Inl x) = Inl (fmap f x) + fmap f (Inr y) = Inr (fmap f y) + +foldFix :: Functor f => (f a -> a) -> Fix f -> a +foldFix f = f . fmap (foldFix f) . out diff --git a/src/Control/Monatron/Operations.hs b/src/Control/Monatron/Operations.hs new file mode 100644 --- /dev/null +++ b/src/Control/Monatron/Operations.hs @@ -0,0 +1,195 @@ +{-# OPTIONS -XRank2Types #-} + +module Control.Monatron.Operations ( + ExtModel, Model, AlgModel, toAlg, liftModel, liftAlgModel, liftExtModel, + StateOp(..), modelStateT, getX, putX, + ReaderOp(..), modelReaderT, askX, inEnvX, localX, + WriterOp(..), modelWriterT, traceX, + ThrowOp(..),HandleOp(..), modelThrowExcT, modelHandleExcT, + modelThrowIO, modelHandleIO, throwX, handleX, + ContOp(..), modelContT, callccX, callCCX, abortX, + StepOp(..), stepX, modelStepT, + ListOp(..), modelListT, zeroListX, plusListX, + module Control.Monatron.Transformer +) where + +import Control.Monatron.Codensity +import Control.Monatron.Transformer +import qualified Control.Exception as IO (throwIO,catch,SomeException) + +------------------------------------------------- +-- Models and Standard Liftings +------------------------------------------------- + +type ExtModel f g m = forall a. f (m (g a)) -> m a +type Model f m = forall a. f (m a) -> m a +type AlgModel f m = forall a. f a -> m a + +toAlg :: (Functor f, Monad m) => Model f m -> AlgModel f (Codensity m) +toAlg op t = codensity $ \k -> op (fmap k t) + +liftModel :: (Functor f, Monad m, Functor m, FMonadT t, Monad (t (Codensity m))) => + Model f m -> Model f (t m) +liftModel op = tmap runCodensity . join . lift . toAlg op . fmap (tmap lift) + +liftAlgModel :: (MonadT t, Monad m, Functor f) => AlgModel f m -> AlgModel f (t m) +liftAlgModel op = lift . op + +liftExtModel :: ( Functor f, Functor g, Monad m, Functor m, + MMonadT t, Functor (t f), Functor (t m)) => + ExtModel f g m -> ExtModel f g (t m) +liftExtModel op = tmap (op . fmap deComp . deComp) . + monoidalT . flift . fmap (monoidalT . fmap flift) + +---------------------- +-- State Operations +---------------------- + +data StateOp s a = Get (s -> a) | Put s a + +instance Functor (StateOp s) where + fmap f (Get g) = Get (f . g) + fmap f (Put s a) = Put s (f a) + +modelStateT :: Monad m => AlgModel (StateOp s) (StateT s m) +modelStateT (Get g) = stateT (\s -> return (g s, s)) +modelStateT (Put s a) = stateT (\_ -> return (a, s)) + +getX :: Monad m => AlgModel (StateOp s) m -> m s +getX op = op $ Get id + +putX :: Monad m => AlgModel (StateOp s) m -> s -> m () +putX op s = op $ Put s () + +---------------------- +-- Reader Operations +---------------------- + +data ReaderOp s a = Ask (s -> a) | InEnv s a + +instance Functor (ReaderOp s) where + fmap f (Ask g) = Ask (f . g) + fmap f (InEnv s a) = InEnv s (f a) + +modelReaderT :: Monad m => Model (ReaderOp s) (ReaderT s m) +modelReaderT (Ask g) = readerT (\s -> runReaderT s (g s)) +modelReaderT (InEnv s a) = readerT (\_ -> runReaderT s a) + +askX :: Monad m => Model (ReaderOp s) m -> m s +askX op = op $ Ask return + +inEnvX :: Monad m => Model (ReaderOp s) m -> s -> m a -> m a +inEnvX op s m = op $ InEnv s m + +--derived + +localX :: Monad m => Model (ReaderOp z) m -> (z -> z) -> m a -> m a +localX m f t = do z <- askX m + inEnvX m (f z) t + +------------------------ +-- Exception Operations +------------------------ + +data ThrowOp x a = Throw x +data HandleOp x a = Handle a (x -> a) + +instance Functor (ThrowOp x) where + fmap _ (Throw x) = Throw x + +instance Functor (HandleOp x) where + fmap f (Handle a h) = Handle (f a) (f . h) + +modelThrowExcT :: Monad m => AlgModel (ThrowOp x) (ExcT x m) +modelThrowExcT (Throw x) = excT (return (Left x)) + +modelHandleExcT :: Monad m => Model (HandleOp x) (ExcT x m) +modelHandleExcT (Handle m h) = excT (runExcT m >>= \exa -> case exa of + Left x -> runExcT (h x) + Right a -> return (Right a)) + +modelThrowIO :: AlgModel (ThrowOp IO.SomeException) IO +modelThrowIO (Throw x) = IO.throwIO x + +modelHandleIO :: Model (HandleOp IO.SomeException) IO +modelHandleIO (Handle m h) = IO.catch m h + +throwX :: Monad m => AlgModel (ThrowOp x) m -> x -> m a +throwX op x = op $ Throw x + +handleX :: Monad m => Model(HandleOp x) m -> m a -> (x -> m a) -> m a +handleX op m h = op $ Handle m h + +------------------------ +-- Writer Operations +------------------------ + +data WriterOp w a = Trace w a + +instance Functor (WriterOp w) where + fmap f (Trace w a) = Trace w (f a) + +modelWriterT :: (Monad m, Monoid w) => AlgModel (WriterOp w) (WriterT w m) +modelWriterT (Trace w a) = writerT (return (a,w)) + +traceX :: (Monad m) => AlgModel (WriterOp w) m -> w -> m () +traceX op w = op $ Trace w () + +-------------------------- +-- Continuation Operations +-------------------------- + +data ContOp r a = Abort r | CallCC ((a -> r) -> a) + +instance Functor (ContOp r) where + fmap _ (Abort r) = Abort r + fmap f (CallCC k) = CallCC (\c -> f (k (c . f))) + +modelContT :: Monad m => AlgModel (ContOp (m r)) (ContT r m) +modelContT (Abort mr) = contT $ \_ -> mr +modelContT (CallCC k) = contT $ \c -> c (k c) + +abortX :: Monad m => AlgModel (ContOp r) m -> r -> m a +abortX op r = op (Abort r) + +callCCX :: Monad m => AlgModel (ContOp r) m -> ((a -> r) -> a) -> m a +callCCX op f = op (CallCC f) + +callccX :: Monad m => AlgModel (ContOp r) m -> ((a -> m b) -> m a) -> m a +callccX op f = join $ callCCX op (\k -> f (\x -> abortX op (k (return x)))) + +-------------------------- +-- Step Operations +-------------------------- + +newtype StepOp f x = StepOp (f x) + +instance (Functor f) => Functor (StepOp f) where + fmap h (StepOp fa) = StepOp (fmap h fa) + +modelStepT :: (Functor f, Monad m) => Model (StepOp f) (StepT f m) +modelStepT (StepOp fa) = stepT (return (Right fa)) + +stepX :: (Monad m) => Model (StepOp f) m -> f (m x) -> m x +stepX op = op . StepOp + +-------------------------- +-- List Operations +-------------------------- + +data ListOp a = ZeroList | PlusList a a + +instance Functor ListOp where + fmap _ ZeroList = ZeroList + fmap f (PlusList a b) = PlusList (f a) (f b) + +modelListT :: Monad m => AlgModel ListOp (ListT m) +modelListT ZeroList = emptyL +modelListT (PlusList t u) = appendL (return t) (return u) + +zeroListX :: Monad m => AlgModel ListOp m -> m a +zeroListX op = op ZeroList + +plusListX :: Monad m => AlgModel ListOp m -> m a -> m a -> m a +plusListX op t u = join $ op (PlusList t u) + diff --git a/src/Control/Monatron/Transformer.hs b/src/Control/Monatron/Transformer.hs new file mode 100644 --- /dev/null +++ b/src/Control/Monatron/Transformer.hs @@ -0,0 +1,286 @@ +{-# LANGUAGE ScopedTypeVariables #-} + +module Control.Monatron.Transformer ( + StateT, stateT, runStateT, + WriterT, writerT, runWriterT, + ReaderT, readerT, runReaderT, + ExcT, excT, runExcT, + ContT, contT, runContT, + StepT, stepT, runStepT, caseStepT, unfoldStepT, + ListT, listT, runListT, foldListT, collectListT, emptyL, appendL, +-- module Monatron.Operations, + module Control.Monatron.MonadT, + module Data.Monoid +) where + +--import Monatron.Operations +import Control.Monad.Fix +import Control.Monatron.MonadT +-- for Writer +import Data.Monoid hiding ((<>)) +-- for Error (and Reader?) +--import Monatron.Codensity +import Control.Monatron.AutoInstances() + +--State Monad Transformer +newtype StateT s m a = S { unS :: s -> m (a,s) } + +stateT :: (s -> m (a, s)) -> StateT s m a +stateT = S + +runStateT :: s -> StateT s m a -> m (a,s) +runStateT s m = unS m s + +instance MonadT (StateT s) where + lift m = S $ \s -> m >>= \a -> return (a,s) + m `tbind` k = S $ \s -> unS m s >>= \ ~(a, s') -> unS (k a) s' + +instance (MonadFix m) => MonadFix (StateT s m) where + mfix f = S $ \s -> mfix (runStateT s . f . fst) + +instance FMonadT (StateT s) where + tmap' d1 _d2 g f (S m) = S (f . fmapD d1 (\(x,s) -> (g x,s)) . m) + +instance MMonadT (StateT s) where + flift t = S (\s -> fmap (\a -> (a,s)) t) + monoidalT (S t) = S (\s -> Comp $ fmap (\(S t',s') -> t' s') (t s)) + +{- +-- StateT implementation of operations +withStateT :: Monad m => Fop (With s) (StateT s m) +withStateT (With f) = S $ \s -> runStateT s (f s) + +makeStateT :: Monad m => Fop (Make s) (StateT s m) +makeStateT (Make (m,s)) = S $ \_ -> runStateT s m +-} + +-------------------------------------------------------------- +-- Writer Monad Transformer + +newtype WriterT w m a = W {unW :: m (a,w) } + +writerT :: (Monoid w, Monad m) => m (a,w) -> WriterT w m a +writerT = W + +runWriterT :: (Monoid w) => WriterT w m a -> m (a,w) +runWriterT = unW + +instance Monoid w => MonadT (WriterT w) where + tbind (W m) f = W (do (a,w) <- m + (a',w') <- unW (f a) + return (a',w `mappend` w')) + lift m = W (liftM (\a -> (a,mempty)) m) + +{- +instance (MonadFix m, Monoid w) => MonadFix (WriterT w m) where + mfix f = W $ mfix (unW. f) +-} + +instance Monoid w => FMonadT (WriterT w) where + tmap' d1 _d2 g f = W . f . fmapD d1 (\(x,s) -> (g x,s)) . unW + +instance Monoid w => MMonadT (WriterT w) where + flift t = W (fmap (\a -> (a,mempty)) t) + monoidalT (W t) = W $ Comp $ fmap (\(W t',w) -> + fmap (\(a,w') -> (a,w `mappend` w')) t') $ t + +{- +-- WriterT implementation of operations +withWriterT :: (Monoid w, Monad m) => Fop (With w) (WriterT w m) +withWriterT (With c) = W $ S $ \w -> runWriterT (c w) + + +makeWriterT :: (Monoid w, Monad m) => Fop (Make w) (WriterT w m) +makeWriterT (Make (m, w)) = writerT $ runWriterT m >>= \(a,w') -> + return (a,w' `mappend` w) +-} +-------------------------------------------------------------- +-- Reader Monad Transformer +newtype ReaderT s m a = R { unR :: s -> m a } + +runReaderT :: s -> ReaderT s m a -> m a +runReaderT s m = unR m s + +instance MonadT (ReaderT s) where + tbind m k = R (\s -> unR m s >>= \a -> unR (k a) s) + lift m = R (\_ -> m) + +readerT :: Monad m => (e -> m a) -> ReaderT e m a +readerT = R + +{- +instance (MonadFix m) => MonadFix (ReaderT w m) where + mfix f = R $ mfix (unR. f) +-} + +instance FMonadT (ReaderT s) where + tmap' d1 _d2 g f (R m) = R (f . fmapD d1 g . m) + +instance MMonadT (ReaderT s) where + flift t = R (\_ -> t) + monoidalT (R t) = R (\s -> Comp $ fmap (($ s) . unR) (t s)) + +{- +-- ReaderT implementation of operations +makeReaderT :: Monad m => Fop (Make e) (ReaderT e m) +makeReaderT = R . makeStateT . fmap unR + +withReaderT :: Monad m => Fop (With e) (ReaderT e m) +withReaderT = R . withStateT . fmap unR +-} +-------------------------------------------------------------- +-- Exceptions Monad Transformer +newtype ExcT x m a = X {unX :: m (Either x a)} + +excT :: Monad m => m (Either x a) -> ExcT x m a +excT = X + +runExcT :: Monad m => ExcT x m a -> m (Either x a) +runExcT = unX +-- +instance (MonadFix m) => MonadFix (ExcT x m) where + mfix f = X $ mfix (unX . f . fromRight) + where fromRight (Right a) = a + fromRight _ = error "ExceptionT: mfix looped." + + +-- +instance MonadT (ExcT x) where + lift m = X (liftM Right m) + (X m) `tbind` f = X (do a <- m + case a of + Left x -> return (Left x) + Right b -> unX (f b)) + + +instance FMonadT (ExcT x) where + tmap' d1 _d2 g f = X . f . fmapD d1 func . unX where + func (Left x) = Left x + func (Right y) = Right (g y) + +{- +-- internal operations +throwExcT :: Monad m => Fop (Throw x) (ExcT x m) +throwExcT (Throw x) = X $ return (Left x) +-- +handleExcT :: Monad m => Fop (Handle x) (ExcT x m) +handleExcT (Handle (m, h)) = X (unX m >>= \exa -> + case exa of + Left x -> unX (h x) + Right a -> return (Right a)) + +-- Instances of the operations for IO exceptions +throwIO :: Fop (Throw IO.SomeException) IO +throwIO (Throw x) = IO.throwIO x +-- +handleIO :: Fop (Handle IO.SomeException) IO +handleIO (Handle (m, h)) = IO.catch m h +-} + +-------------------------------------------------------------- +-- Continuations Monad Transformer + +newtype ContT r m a = C {unC :: (a -> m r) -> m r} + +runContT :: (a -> m r) -> ContT r m a -> m r +runContT = flip unC + +contT :: ((a -> m r) -> m r) -> ContT r m a +contT = C + +instance MonadT (ContT r) where + lift m = C (m >>=) + m `tbind` k = C $ \c -> unC m (\a -> unC (k a) c) + +{- +callCCContT :: Monad m => Fop (CallCC (m r)) (ContT r m) +callCCContT (CallCC f) = C $ \k -> unC (f (\a -> unC a k)) k + +abortContT :: Monad m => Fop (Abort (m r)) (ContT r m) +abortContT (Abort mr) = C $ \_ -> mr +-} +-------------------------------------------------------------- +-- List monad transformer + +data LSig f a b = NilT b + | ConsT a (f a) + +newtype ListT m a = L {unL :: m (LSig (ListT m) a ())} + +runListT :: ListT m a -> m (LSig (ListT m) a ()) +runListT = unL + +listT :: m (LSig (ListT m) a ()) -> ListT m a +listT = L + +emptyL :: Monad m => ListT m a +emptyL = L $ return $ NilT () + +appendL :: Monad m=> ListT m a -> ListT m a -> ListT m a +appendL (L m1) (L m2) = L $ do + l <- m1 + case l of + NilT () -> m2 + ConsT a l1 -> return (ConsT a (appendL l1 (L m2))) + +foldListT :: Monad m => (a -> m b -> m b) -> m b -> ListT m a -> m b +foldListT c n (L m) = do l <- m + case l of + NilT () -> n + ConsT a l1 -> c a (foldListT c n l1) + +collectListT :: Monad m => ListT m a -> m [a] +collectListT lt = foldListT (\a m -> m >>= return. (a:)) (return []) lt + +instance MonadT ListT where + lift m = L $ liftM (`ConsT` emptyL) m + m `tbind` f = L $ foldListT (\a l -> unL $ f a `appendL` L l) + (return $ NilT ()) + m + +instance FMonadT ListT where + tmap' d1 d2 g t (L m) = L $ t $ fmapD d1 (\lsig -> case lsig of + NilT () -> NilT () + ConsT a l -> ConsT (g a) (tmap' d1 d2 g t l)) m + +{- +mZeroListT :: Monad m => Fop MZero (ListT m) +mZeroListT (MZero _) = emptyL + +mPlusListT :: (Monad m) => Fop MPlus (ListT m) +mPlusListT (MPlus (a, b)) = appendL a b +-} +------------------------------------------------ +-- Step Monad Transformer +------------------------------------------------ + +newtype StepT f m x = T {runT :: m (Either x (f (StepT f m x)))} + +stepT :: m (Either x (f (StepT f m x))) -> StepT f m x +stepT = T + +runStepT :: StepT f m x -> m (Either x (f (StepT f m x))) +runStepT = runT + +{- +instance (Functor f, Monad m) => Monad (StepT f m) where + return = treturn + (>>=) = tbind +-} + +--instance (Functor f, Monad m) => Functor (StepT f m) where fmap = liftM + +caseStepT :: (Functor f, Monad m) => + (a -> StepT f m x) -> (f (StepT f m a) -> StepT f m x) + -> StepT f m a -> StepT f m x +caseStepT v c (T m) = T (m >>= either (runT . v) (runT . c)) + +unfoldStepT :: (Functor f, Monad m) => (y -> m (Either x (f y))) -> y -> StepT f m x +unfoldStepT k y = T (liftM (fmap (fmap (unfoldStepT k))) (k y)) + +instance (Functor f) => MonadT (StepT f) where + tbind t f = caseStepT f (T . return . Right . fmap (`tbind` f)) t + lift = T . liftM Left + +instance (Functor f) => FMonadT (StepT f) where + tmap' d1 d2 g t (T m) = T (t (fmapD d1 (either (Left . g) (Right . fmap (tmap' d1 d2 g t))) m)) diff --git a/src/Control/Monatron/Zipper.hs b/src/Control/Monatron/Zipper.hs new file mode 100644 --- /dev/null +++ b/src/Control/Monatron/Zipper.hs @@ -0,0 +1,123 @@ +-- {-# OPTIONS -fglasgow-exts -XNoMonomorphismRestriction #-} +{-# LANGUAGE NoMonomorphismRestriction #-} +{-# LANGUAGE KindSignatures #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE MultiParamTypeClasses #-} + +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE OverlappingInstances #-} +{-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE RankNTypes #-} + +module Control.Monatron.Zipper where + +import Control.Monatron.MonadT () +import Control.Monatron.IdT () +import Control.Monatron.AutoLift +import Control.Monatron.Operations +import Control.Monatron.Monad () +-- import Monatron.AutoInstances() + +newtype (t1 :> (t2 :: (* -> *) -> * -> *)) m a = L { runL :: t1 (t2 m) a } + +runZipper :: (t1 :> t2) m a -> t1 (t2 m) a +runZipper = runL + +zipper :: t1 (t2 m) a -> (t1 :> t2) m a +zipper = L + +-- * Relative Navigation + +-- | shift focus to left +leftL :: (t1 :> t2) m a -> t1 (t2 m) a +leftL = runL + +-- | shift focus to right +rightL :: t1 (t2 m) a -> (t1 :> t2) m a +rightL = L + +-- The zipper is an FMonadT and a MonadT + +instance (FMonadT t1, FMonadT t2) => FMonadT (t1 :> t2) where + tmap' d1 d2 g f = + L . tmap' (FunctorD (mtmap d1)) (FunctorD (mtmap d2)) g (tmap' d1 d2 id f) . runL + +instance (MonadT t1, MonadT t2) => MonadT (t1 :> t2) where + lift = L . lift . lift + tbind m f = L $ runL m >>= runL . f + +-- Instances of the zipper for the various effects + +instance (Monad m, MonadT t1, MonadT t2, StateM z (t2 m)) => StateM z ((t1 :> t2) m) where + stateModel = L . liftAlgModel stateModel + +instance (WriterM z (t2 m), MonadT t1, Monad m, MonadT t2) => WriterM z ((t1 :> t2) m) where + writerModel = L . liftAlgModel writerModel + +instance (ReaderM z (t2 m), FMonadT t1, FMonadT t2, Functor (t2 m), Monad m) => + ReaderM z ((t1 :> t2) m) where + readerModel = L . liftModel readerModel . fmap runL + +instance (ExcM z (t2 m), FMonadT t1, FMonadT t2, Functor (t2 m), Monad m) => + ExcM z ((t1 :> t2) m) where + throwModel = L . liftAlgModel throwModel + handleModel = L . liftModel handleModel . fmap runL + +instance (ContM r (t2 m), FMonadT t1, FMonadT t2, Functor (t2 m), Monad m) => + ContM r ((t1 :> t2) m) where + contModel = L . liftAlgModel contModel + +instance (ListM (t2 m), FMonadT t1, FMonadT t2, Functor (t2 m), Monad m) => + ListM ((t1 :> t2) m) where + listModel = L . liftAlgModel listModel + +-- runtest :: (((),Int),Int) +-- runtest = runState 0 $ runStateT 0 $ runZipper (put 3) + +-- Views and masks; could be in a different file + +data (:><:) m n = View { + to :: forall a . m a -> n a, + from :: forall a . n a -> m a +} + +i :: m :><: m +i = View id id + +o :: (Monad m, MonadT t1, MonadT t2) => t1 (t2 m) :><: (t1 :> t2) m +o = View rightL leftL + +vlift :: (FMonadT t, Functor m, Functor n) + => (m :><: n) -> (t m :><: t n) +vlift v = View (tmap (to v)) (tmap (from v)) + + +hcomp :: (n :><: o) -> (m :><: n) -> (m :><: o) +v2 `hcomp` v1 = View (to v2 . to v1) (from v1 . from v2) + +vcomp :: (Functor m1, Functor m2, FMonadT t) + => (t m2 :><: m3) -> (m1 :><: m2) -> (t m1 :><: m3) +v2 `vcomp` v1 = v2 `hcomp` (vlift v1) + +-- program :: StateM Int m => m Int +-- program = put 3 >> return 4 + +-- t = runState 1 $ runStateT 0 $ runIdT $ runIdT $ view i program + +r :: Monad m => StateT s m :><: ReaderT s m +r = View { + to = \s -> readerT (\e -> liftM fst $ runStateT e s), + from = \e -> stateT (\s -> liftM (\x -> (x,s)) $ runReaderT s e) +} + +stateIso :: Monad m => (s1 -> s2) -> (s2 -> s1) -> StateT s1 m :><: StateT s2 m +stateIso f fm1 = View {to = iso f fm1, from = iso fm1 f } where + iso g h m = stateT $ \s2 -> do (a, s1) <- runStateT (h s2) m + return (a, g s1) + +getv :: StateM s n => (m :><: n) -> m s +getv var = from var get + +putv :: StateM s n => (m :><: n) -> s -> m () +putv var = from var . put diff --git a/src/Control/Monatron/ZipperExamples.hs b/src/Control/Monatron/ZipperExamples.hs new file mode 100644 --- /dev/null +++ b/src/Control/Monatron/ZipperExamples.hs @@ -0,0 +1,83 @@ +{-# OPTIONS -XTypeOperators -XFlexibleContexts #-} + +module Control.Monatron.ZipperExamples where + +import Control.Monatron.Monatron +import Control.Monatron.Zipper +import Control.Monatron.Open + +-- Don't we need a bidirectional view to implement this combinator? + +fmask :: (m :><: n) -> Open e f (n a) -> Open e f (m a) +fmask v evalf eval = from v . evalf (to v . eval) + +type Env = [(String,Int)] + +type Count = Int + +data Mem e = Store e | Retrieve + +type Reg = Int + +evalMem2 :: (StateM Reg (t m), StateM Count m, MonadT t) + => Open e Mem (t m Int) +evalMem2 eval (Store e) = + do count <- lift $ get + lift $ put (count + 1) + n <- eval e + put n + return n +evalMem2 eval Retrieve = lift $ get + +type M4 = StateT Reg (StateT Env (ExcT String (StateT Count Id))) + +data Lit a = Lit Int +data Var a = Var String +data Add e = Add e e + +instance Functor Lit where + fmap _ (Lit l) = Lit l + +instance Functor Var where + fmap _ (Var v) = Var v + +instance Functor Add where + fmap f (Add e1 e2) = Add (f e1) (f e2) + +instance Functor Mem where + fmap f (Store x) = Store (f x) + fmap f Retrieve = Retrieve + +lit :: (Lit :<: g) => Int -> Fix g +lit l = inject (Lit l) + +var :: (Var :<: g) => String -> Fix g +var v = inject (Var v) + +add :: (Add :<: g) => Fix g -> Fix g -> Fix g +add e1 e2 = inject (Add e1 e2) + +store :: (Mem :<: g) => Fix g -> Fix g +store e = inject (Store e) + +retrieve :: (Mem :<: g) => Fix g +retrieve = inject Retrieve + +type Expr3 = Fix (Mem :+: Var :+: Lit) + +evalLit _ (Lit n) = return n + +evalVar _ (Var v) = do env <- get + case lookup v env of + Just n -> return n + Nothing -> throw "undefined variable" + +eval4 :: Expr3 -> M4 Int +eval4 = fix ( fmask (i `vcomp` o `vcomp` o) evalMem2 + <@> fmask o evalVar + <@> evalLit) + +test = runId $ runStateT 0 $ handleExc $ runStateT [] $ runStateT 0 $ eval4 (store (lit 3)) + +handleExc :: Monad m => ExcT a m b -> m b +handleExc = liftM (either (error "Error!") id) . runExcT diff --git a/src/Control/Search/Combinator/And.hs b/src/Control/Search/Combinator/And.hs new file mode 100644 --- /dev/null +++ b/src/Control/Search/Combinator/And.hs @@ -0,0 +1,143 @@ +{-# LANGUAGE FlexibleContexts #-} + +module Control.Search.Combinator.And (andN,(<&>)) where + +import Data.Maybe (fromMaybe, catMaybes, fromJust) + +import Control.Search.Language +import Control.Search.GeneratorInfo +import Control.Search.Memo +import Control.Search.MemoReader +import Control.Search.Generator + +import Control.Search.Combinator.Success + +import Control.Monatron.Monatron hiding (Abort, L, state, cont) +import Control.Monatron.Zipper hiding (i,r) +import Control.Monatron.IdT + +seqNLoop :: (ReaderM Int m, Evalable m) => Int -> [Eval m] -> Eval m +seqNLoop uid lst = commentEval $ + Eval { structs = (foldr1 (@++@) $ map (structs) lst) @++@ mystructs + , toString = "seqN" ++ show uid ++ "(" ++ (foldr1 (\x y -> x ++ "," ++ y) $ map (toString) lst) ++ ")" + , treeState_ = [entry ("seqn_pos",Int,assign 0) -- is the first or the second search active? + , ("seqn_union",Union [(SType (s3 i),"seq" ++ show i) | i <- [0..nbranches-1]], -- union of both tree states + \i -> -- init nested state of first search + let j = xpath i 0 + in initSubEvalState j (s1 0) (fs1 0) + )] + , initH = \i -> (local (const 0) $ inits (xsuper 0) (xpath i 0)) + , evalState_ = [("complete",Bool,const $ return true)] -- some global data + , pushLeftH = push pushLeft + , pushRightH = push pushRight + , nextSameH = \i -> let j = i `withBase` "popped_estate" + in do nd <- inSeq nextDiff i + ns <- inSeq nextSame i + return $ IfThenElse ((seq_pos i) @== (seq_pos j)) ns nd + , nextDiffH = inSeq $ nextDiff + , bodyH = \i -> + let seqBody super j pos = + do + dr <- dec_ref "bodyE-stmt" j i pos + bodyE super (j `onAbort` (comment "seqLoopN.bodyE" >>> dr)) + in do cb <- mapM (\x -> canBranch x >>= \b -> return (if b then 1 else 0)) {- (const $ return 1) -} lst + let cu n | n==nbranches = 0 + cu n = (cb!!n) + cu (n+1) + ss <- mapM (\pos -> local (const $ fromIntegral pos) $ inSeq_ seqBody i) [0..nbranches-1] + let cc n | n==nbranches = Skip + cc n | cu n <= 1 = if ((cb !! n) == 1) then (ss !! n) else cc (n+1) + cc n | otherwise = IfThenElse (seq_pos i @== fromIntegral n) (ss !! n) (cc (n+1)) + return $ cc 0 + , addH = inSeq $ addE + , failH = \i -> inSeq_ (\super j pos -> failE super j @>>>@ (dec_ref "failE" j i pos)) i + , returnH = \i -> numSwitch (\n -> if (n>> dr2 + >>> (seq_pos i <== fromIntegral (n+1)) + >>> init >>> stmt1 >>> stmt2) + returnE (xsuper n) $ j1 `withCommit` const action + else do let j2o = xpath i n + dr3 <- dec_ref "returnE-j2B" j2o i n + let j2 = j2o `onCommit` dr3 + returnE (xsuper n) j2 + ) +-- , continue = \_ -> return true + , tryH = \i -> inSeq_ (\super j pos -> do { dr <- dec_ref "tryE" j i pos; return (comment "seqLoop.tryE(a)") @>>>@ tryE super (j `onAbort` (comment "seqLoop.tryE(b)" >>> dr))}) i + , startTryH = \i -> local (const 0) $ inSeq_ (\super j pos -> do { dr <- dec_ref "startTryE" j i pos; return (comment "seqLoop.startTryE(a)") @>>>@ startTryE super (j `onAbort` (comment "seqLoop.startTryE(b)" >>> dr))}) i + , tryLH = \i -> inSeq_ (\super j pos -> tryE_ super j @>>>@ (dec_ref "tryE_" j i pos)) i + , intArraysE = foldr1 (++) $ map (intArraysE) lst + , boolArraysE = foldr1 (++) $ map (boolArraysE) lst + , intVarsE = foldr1 (++) $ map (intVarsE) lst + , deleteH = deleteMe + , canBranch = do res <- mapM (canBranch) lst + return $ or res + , complete = \i -> return $ estate i @=> "complete" +-- , complete = const $ return false + } + where nbranches = length lst + xsuper i = lst !! i + mystructs = (catMaybes (map s1 [0..nbranches-1]),map s3 [0..nbranches-1]) + evalStruct side super = Just $ -- if (length (evalState_ super) == 0) then Nothing else Just $ + Struct (side ++ "EvalState" ++ show uid) $ +-- (Bool, "cont") : -- continue or not with this search + (Int, "ref_count") : -- how many active nodes of this search + [(ty, field) | (field,ty,_) <- evalState_ super] -- fields of this search +-- needSide = \pos stm -> if (length (evalState_ (xsuper pos)) == 0) then Skip else stm + needSide pos stm = stm + s1 i = evalStruct ("Seq" ++ show i) (xsuper i) + et i = maybe (THook "void") (Pointer . SType) $ s1 i + s3 i = Struct ("Seq" ++ show i ++ "TreeState" ++ show uid) $ (case s1 i of { Nothing -> id; Just s -> ((Pointer $ SType s, "evalState"):) }) [(ty, field) | (field,ty,_) <- treeState_ (xsuper i)] + st i = Pointer . SType $ s3 i + xpath i n = flip withClone (\i -> inc (ref_count i)) $ withPath i (inN n) (et n) (st n) + fs1 n = \i -> [(field,init) | (field,_ty,init) <- evalState_ (xsuper n) ] + fs3 n = \i -> [(field,init) | (field,_ty,init) <- treeState_ (xsuper n) ] + withSeq f = numSwitch (\n -> f (xsuper n) (inN n)) + inSeq f = \i -> numSwitch (\n -> f (xsuper n) (xpath i n)) + inSeq_ f = \i -> numSwitch (\n -> f (xsuper n) (xpath i n) n) + push dir = \i -> inSeq_ ( \super j pos -> dir super (j `onCommit` (mkCopy i "seqn_pos" + >>> needSide pos (mkCopy j "evalState") + >>> needSide pos (inc (ref_count j)) + ) + ) + ) i + initSubEvalState = \j s fs -> (case s of { Nothing -> return Skip; Just ss -> return ( (estate j <== New ss) + >>> (ref_count j <== 1) +-- >>> (cont j <== true) + )}) + @>>>@ inite (fs j) j + deleteMe = \i -> inSeq_ (\super j pos -> do delrest <- deleteE super j + dr <- dec_ref "deleteMe" j i pos + return (delrest >>> dr)) i +-- dec_ref :: String -> Info -> Info -> Int -> Statement + dec_ref s j i pos = complete (xsuper pos) j >>= \compl -> decrefx j pos (estate_type i,estate i) (estate_type j,estate j) (ref_count_type, ref_count j) (THook "bool", compl) + decrefx j pos = memo "dec_ref_and" j (\(_,esti) (_,estj) (_,rcj) (_,xcl) -> return $ ((assign ((esti @=> "complete") &&& (xcl))) (esti @=> "complete") >>> + needSide pos (dec (rcj) >>> ifthen (rcj @== 0) (Delete (estj)))) {- >>> DebugValue ("completeness and" ++ show uid) (esti @=> "complete") -}) + inN n = \state -> state @-> "seqn_union" @-> ("seq" ++ show n) + seq_pos = \i -> tstate i @-> "seqn_pos" + + +andN [] = dummy +andN [s] = s +andN s = + let sc = buildCombiner s + in case sc of + SearchCombiner { runner = runner, elems = elems } -> + Search { mkeval = \super -> do { ss <- extractCombiners elems $ mapE (L . mmap runL . runL) super + ; uid <- get + ; put $ uid+1 + ; return $ mapE (L . mmap L . runL) $ memoLoop $ seqNLoop uid ss + } + , runsearch = runner . rReaderT 0 . runL + } + +a <&> b = andN [a,b] + diff --git a/src/Control/Search/Combinator/Base.hs b/src/Control/Search/Combinator/Base.hs new file mode 100644 --- /dev/null +++ b/src/Control/Search/Combinator/Base.hs @@ -0,0 +1,320 @@ +module Control.Search.Combinator.Base ( + label + , vlabel + , glabel, gblabel + , int_assign + , ilabel + , maxV, minV, lbV, ubV, domsizeV, lbRegretV, ubRegretV, degreeV, domSizeDegreeV, wDegreeV, domSizeWDegreeV, randomV, minD, maxD, meanD, medianD, randomD + , foldVarSel, ifoldVarSel, bfoldVarSel, bifoldVarSel + ) where + +import Control.Search.Language +import Control.Search.GeneratorInfo +import Control.Search.Generator + +import Control.Monatron.IdT + +data Label m = Label + { treeStateL :: [(String,Type, Value -> Statement)] + , leftChild_L :: [Info -> Statement] + , rightChild_L :: [Info -> Statement] + , addL :: Info -> m Statement + , tryL :: Info -> m Statement + , intArraysL :: [String] + , boolArraysL :: [String] + , intVarsL :: [String] + } + +v1Label var1 selVal rel e = + Label { treeStateL = [("val", Int, assign 0) + ,("eq", Bool, assign true)] + , leftChild_L = + [ \i -> mkUpdate i "eq" (const true) + , \i -> mkCopy i "val" ] + , rightChild_L = + [ \i -> mkUpdate i "eq" (const false) + , \i -> mkCopy i "val" ] + , addL = \i -> return $ + IfThenElse (eq i) + (Post (space i) (var i `rel` val i)) + (Post (space i) (neg (var i `rel` val i))) + , tryL = \i -> returnE e (resetInfo i) >>= \ret -> -- XXX + tryE_ e (resetInfo i) >>= \try -> -- XXX + return $ (IfThenElse (Assigned (var i)) + ret + (val i <== (selVal $ var i) >>> try)) + , intArraysL = [] + , boolArraysL = [] + , intVarsL = [var1] + } + where val i = tstate i @-> "val" + eq i = tstate i @-> "eq" + var i = IVar var1 (space i) + + +vLabel vars selVar selVal rel e = + Label { treeStateL = [("pos", Int, assign 0) + ,("val", Int, assign 0) + ,("eq", Bool, assign true)] + , leftChild_L = + [ \i -> mkUpdate i "eq" (const true) + , \i -> mkCopy i "val" + , \i -> mkCopy i "pos"] + , rightChild_L = + [ \i -> mkUpdate i "eq" (const false) + , \i -> mkCopy i "val" + , \i -> mkCopy i "pos"] + , addL = \i -> return $ + IfThenElse (eq i) + (Post (space i) (var i `rel` val i)) + (Post (space i) (neg (var i `rel` val i))) + , tryL = \i -> returnE e (resetInfo i) >>= \ret -> -- XXX + tryE_ e (resetInfo i) >>= \try -> -- XXX + return $ (selVar i vars + ret + (val i <== (selVal $ var i) >>> try)) + , intArraysL = [vars] + , boolArraysL = [] + , intVarsL = [] + } + where val i = tstate i @-> "val" + pos i = tstate i @-> "pos" + eq i = tstate i @-> "eq" + var i = AVarElem vars (space i) (pos i) + +vbLabel vars selVar selVal rel e = + Label { treeStateL = [("pos", Int, assign 0) + ,("val", Int, assign 0) + ,("eq", Bool, assign true)] + , leftChild_L = + [ \i -> mkUpdate i "eq" (const true) + , \i -> mkCopy i "val" + , \i -> mkCopy i "pos"] + , rightChild_L = + [ \i -> mkUpdate i "eq" (const false) + , \i -> mkCopy i "val" + , \i -> mkCopy i "pos"] + , addL = \i -> return $ + IfThenElse (eq i) + (Post (space i) (var i `rel` val i)) + (Post (space i) (neg (var i `rel` val i))) + , tryL = \i -> returnE e (resetInfo i) >>= \ret -> -- XXX + tryE_ e (resetInfo i) >>= \try -> -- XXX + return $ (selVar i vars + ret + (val i <== (selVal $ var i) >>> try)) + , intArraysL = [] + , boolArraysL = [vars] + , intVarsL = [] + } + where val i = tstate i @-> "val" + pos i = tstate i @-> "pos" + eq i = tstate i @-> "eq" + var i = BAVarElem vars (space i) (pos i) + +type ValSel = Value -> Value + +type VarSel = Info -> String -> Statement -> Statement -> Statement + +foldVarSel metric (better, zero) i vars notfound found = + Fold vars (tstate i) (space i) zero metric better + >>> IfThenElse (pos i @< 0) notfound found + where pos i = tstate i @-> "pos" + +ifoldVarSel metric (better, zero) i vars notfound found = + IFold vars (tstate i) (space i) zero metric better + >>> IfThenElse (pos i @< 0) notfound found + where pos i = tstate i @-> "pos" + +bfoldVarSel metric (better, zero) i vars notfound found = + BFold vars (tstate i) (space i) zero metric better + >>> IfThenElse (pos i @< 0) notfound found + where pos i = tstate i @-> "pos" + +bifoldVarSel metric (better, zero) i vars notfound found = + BIFold vars (tstate i) (space i) zero metric better + >>> IfThenElse (pos i @< 0) notfound found + where pos i = tstate i @-> "pos" + + +-------------------------------------------------------------------------------- +-- SEARCH TRANSFORMERS +-------------------------------------------------------------------------------- + +pushLeftTop e = \i -> pushLeft e (i `onCommit` mkCopy i "space" ) +pushRightTop e = \i -> pushRight e (i `onCommit` mkUpdate i "space" Clone) + + +baseLoop label this = return $ commentEval $ current + where current = + Eval { structs = ([],[]) + , treeState_ = map entry $ treeStateL label + , initH = const $ return Skip + , evalState_ = [] + , pushLeftH = \i -> cachedCommit i @>>>@ return (seqs [f i | f <- leftChild_L label]) + , pushRightH = \i -> cachedCommit i @>>>@ return (seqs [f i | f <- rightChild_L label]) + , nextSameH = \i -> return Skip + , nextDiffH = \i -> return Skip + , bodyH = addE this . resetInfo -- XXX + , addH = \i -> tryE this (resetInfo i) >>= \try -> -- XXX + addL label i >>= \a -> + return (a >>> try) + , failH = const $ return Skip + , returnH = \i -> cachedCommit i +-- , continue = \_ -> return true + , tryH = tr label + , startTryH = tr label + , tryLH = \i -> pushRightTop this (newinfo i "R") >>= \p2 -> + pushLeftTop this (newinfo i "L") >>= \p4 -> + return $ ( + SHook "st->queue->push_back(TreeState());" >>> + SHook "TreeState& nstateR = st->queue->back();" >>> + p2 >>> + SHook "st->queue->push_back(TreeState());" >>> + SHook "TreeState& nstateL = st->queue->back();" >>> + p4 + ) + , intArraysE = intArraysL label + , boolArraysE = boolArraysL label + , intVarsE = intVarsL label + , deleteH = \i -> return Skip + , toString = "base" + , canBranch = return True + , complete = const $ return true + } + where new_tstate = Var "nstate" + tr lab i = failE this (resetInfo i) >>= \fail -> + tryL lab i >>= \tryl -> + return $ (SHook "Gecode::SpaceStatus status;" >>> + (Var "status" <== VHook (rp 0 (space i) ++ "->status()")) >>> + IfThenElse (Var "status" @== VHook "SS_FAILED") (fail >>> Delete (space i)) tryl + ) + +label :: String -> (Value -> Value) -> (Value -> Value -> Value, Value) -> (Value -> Value) -> (Value -> Value -> Constraint) -> Search +label get varMeasure varComp valSel rel = + Search { mkeval = \this -> baseLoop (vLabel get (foldVarSel varMeasure varComp) valSel rel this) this + , runsearch = runIdT + } + +vlabel :: String -> (Value -> Value) -> (Value -> Value -> Constraint) -> Search +vlabel get valSel rel = + Search { mkeval = \this -> baseLoop (v1Label get valSel rel this) this + , runsearch = runIdT + } + +ilabel :: String -> (Value -> Value) -> (Value -> Value -> Value, Value) -> (Value -> Value) -> (Value -> Value -> Constraint) -> Search +ilabel get varMeasure varComp valSel rel = + Search { mkeval = \this -> baseLoop (vLabel get (ifoldVarSel varMeasure varComp) valSel rel this) this + , runsearch = runIdT + } + +int_assign :: String -> VarSel -> (Value -> Value) -> (Value -> Value -> Constraint) -> Search +int_assign get varSel valSel rel = + Search { mkeval = \this -> assignLoop (vLabel get varSel valSel rel this) this + , runsearch = runIdT + } + +glabel :: String -> VarSel -> (Value -> Value) -> (Value -> Value -> Constraint) -> Search +glabel get varSel valSel rel = + Search { mkeval = \this -> baseLoop (vLabel get varSel valSel rel this) this + , runsearch = runIdT + } + +gblabel :: String -> VarSel -> (Value -> Value) -> (Value -> Value -> Constraint) -> Search +gblabel get varSel valSel rel = + Search { mkeval = \this -> baseLoop (vbLabel get varSel valSel rel this) this + , runsearch = runIdT + } + +maxV = (Gt,IVal minBound) +minV = (Lt,IVal maxBound) + +lbV = MinDom +ubV = MaxDom +domsizeV = \v -> MaxDom v - MinDom v +lbRegretV = LbRegret +ubRegretV = UbRegret +degreeV = Degree +domSizeDegreeV = \v -> domsizeV v `Div` degreeV v +wDegreeV = WDegree +domSizeWDegreeV= \v -> domsizeV v `Div` wDegreeV v +randomV = const Random + +minD = MinDom +maxD = MaxDom +meanD = \v -> (maxD v + minD v) `Div` 2 +medianD = \v -> Median v +randomD = \v -> (Random `Mod` (domsizeV v)) + minD v + +{- +assignLoop label this = return $ commentEval $ current + where current = + Eval { structs = ([],[]) + , treeState_ = map entry $ treeStateL label + , initH = const $ return Skip + , evalState_ = [] + , pushLeftH = error "assignLoop.tyE_" + , pushRightH = error "assignLoop.tyE_" + , nextSameH = \i -> return Skip + , nextDiffH = \i -> return Skip + , bodyH = addE this . resetInfo -- XXX + , addH = \i -> tryE this (resetInfo i) >>= \try -> -- XXX + addL label i >>= \a -> + return (a >>> try) + , failH = const $ return Skip + , returnH = \i -> cachedCommit i + , tryH = returnE this . resetInfo + , startTryH = \i -> (return $ comment "") @>>>@ (returnE this . resetInfo) i @>>>@ (return $ comment "") + , tryLH = error "assignLoop.tryE_" + , intArraysE = intArraysL label + , boolArraysE = boolArraysL label + , intVarsE = intVarsL label + , deleteH = \i -> return Skip + , toString = "assign" + , canBranch = return False + , complete = const $ return true + } +-} +assignLoop label this = return $ commentEval $ current + where current = + Eval { structs = ([],[]) + , treeState_ = map entry $ treeStateL label + , initH = const $ return Skip + , evalState_ = [] + , pushLeftH = \i -> cachedCommit i @>>>@ return (seqs [f i | f <- leftChild_L label]) + , pushRightH = \i -> cachedCommit i @>>>@ return (seqs [f i | f <- rightChild_L label]) + , nextSameH = \i -> return Skip + , nextDiffH = \i -> return Skip + , bodyH = addE this . resetInfo -- XXX + , addH = \i -> tryE this (resetInfo i) >>= \try -> -- XXX + addL label i >>= \a -> + return (a >>> try) + , failH = const $ return Skip + , returnH = \i -> cachedCommit i + , tryH = tr label + , startTryH = tr label + , tryLH = \i -> -- pushRightTop this (newinfo i "R") >>= \p2 -> + pushLeftTop this (newinfo i "L") >>= \p4 -> + return $ ( + -- SHook "queue->push_back(TreeState());" >>> + -- SHook "TreeState& nstateR = queue->back();" >>> + -- p2 >>> + SHook "st->queue->push_back(TreeState());" >>> + SHook "TreeState& nstateL = st->queue->back();" >>> + p4 + ) + , intArraysE = intArraysL label + , boolArraysE = boolArraysL label + , intVarsE = intVarsL label + , deleteH = \i -> return Skip + , toString = "base" + , canBranch = return True + , complete = const $ return true + } + where new_tstate = Var "nstate" + tr lab i = failE this (resetInfo i) >>= \fail -> + tryL lab i >>= \tryl -> + return $ ( + (Var "status" <== VHook (rp 0 (space i) ++ "->status()")) >>> + IfThenElse (Var "status" @== VHook "SS_FAILED") (fail >>> Delete (space i)) tryl + ) diff --git a/src/Control/Search/Combinator/Failure.hs b/src/Control/Search/Combinator/Failure.hs new file mode 100644 --- /dev/null +++ b/src/Control/Search/Combinator/Failure.hs @@ -0,0 +1,40 @@ +module Control.Search.Combinator.Failure (failure) where + +import Control.Search.Language +import Control.Search.GeneratorInfo +import Control.Search.Generator + +import Control.Monatron.Monatron hiding (Abort, L, state, cont) +import Control.Monatron.IdT + +failLoop uid _super = + commentEval $ Eval { structs = ([],[]) + , treeState_ = [] + , evalState_ = [] + , pushLeftH = \_ -> return Skip + , pushRightH = \_ -> return Skip + , nextSameH = \_ -> return Skip + , nextDiffH = \_ -> return Skip + , bodyH = \i -> cachedAbort i + , addH = \_ -> return Skip + , failH = \i -> cachedAbort i + , returnH = \i -> cachedAbort i +-- , continue = \_ -> return true + , tryH = \i -> cachedAbort i + , startTryH = \i -> cachedAbort i + , tryLH = \_ -> return Skip + , intArraysE = [] + , intVarsE = [] + , boolArraysE = [] + , deleteH = \i -> cachedAbort i + , initH = \_ -> return $ {- DebugOutput $ "fail" ++ show uid >>> -} Skip + , toString = "fail" ++ show uid + , canBranch = return False + , complete = const $ return false + } + +failure :: Search +failure = + Search { mkeval = \super -> get >>= \uid -> return (failLoop uid super) + , runsearch = runIdT + } diff --git a/src/Control/Search/Combinator/For.hs b/src/Control/Search/Combinator/For.hs new file mode 100644 --- /dev/null +++ b/src/Control/Search/Combinator/For.hs @@ -0,0 +1,115 @@ +{-# LANGUAGE FlexibleContexts #-} + +module Control.Search.Combinator.For (for, foreach) where + +import Control.Search.Language +import Control.Search.GeneratorInfo +import Control.Search.Generator +import Control.Search.Memo +import Control.Search.MemoReader + +import Data.Int + +import Control.Monatron.Zipper hiding (i,r) +import Control.Monatron.Monatron hiding (Abort, L, state, cont) + +forLoop :: (ReaderM Bool m, Evalable m) => Int32 -> Int -> (Eval m) -> Eval m +forLoop n uid (super) = commentEval $ + Eval + { + structs = structs super @++@ mystructs + , toString = "for" ++ show uid ++ "(" ++ show n ++ "," ++ toString super ++ ")" + , treeState_ = treeState_ super + , initH = \i -> initE super i @>>>@ return (parent i <== baseTstate i) @>>>@ cachedClone i (cloneBase i) + , evalState_ = ("counter",Int,const $ return 0) : {- ("cont",Bool,const $ return true) : -} ("ref_count",Int,const $ return 1) : ("parent",THook "TreeState",const $ return Null) : evalState_ super + , pushLeftH = push pushLeft + , pushRightH = push pushRight + , nextSameH = nextSame super + , nextDiffH = nextDiff super + , bodyH = \i -> dec_ref i >>= \deref -> bodyE super (i `onAbort` deref) + , addH = addE super + , failH = \i -> failE super i @>>>@ dec_ref i + , returnH = \i -> let j deref = i `onCommit` deref + in dec_ref i >>= returnE super . j + , tryH = \i -> do deref <- dec_ref i + tryE super ((i `withField` ("counter", counter)) `onAbort` deref) + , startTryH = \i -> do deref <- dec_ref i + startTryE super ((i `withField` ("counter", counter)) `onAbort` deref) + , tryLH = \i -> tryE_ super i @>>>@ dec_ref i + , intArraysE = intArraysE super + , boolArraysE = boolArraysE super + , intVarsE = intVarsE super + , deleteH = error "forLoop.deleteE NOT YET IMPLEMENTED" + , canBranch = return True + , complete = complete super + } + where mystructs = ([],[]) + fs1 = [(field,init) | (field,ty,init) <- evalState_ super] + parent = \i -> estate i @=> "parent" + counter = \i -> estate i @=> "counter" + dec_ref = \i -> let i' = resetCommit $ i `withBase` ("for_tstate" ++ show uid) + in do flag <- ask + if flag + then local (const False) $ do + stmt1 <- inits super i' + stmt2 <- startTryE super (i' `withField` ("counter", counter)) + ini <- inite fs1 i' + cc <- cachedClone (cloneBase i) i' + compl <- complete super i + return (dec (ref_count i) + >>> ifthen (ref_count i @== 0) + ( inc (counter i) + >>> comment ("forLoop: bla 1 (baseTstate i' == \"" ++ rp 0 (baseTstate i') ++ "\", ref_count i' == \"" ++ rp 0 (ref_count i') ++ "\")") + >>> ifthen (counter i @< IVal n &&& Not compl) + ( SHook ("TreeState for_tstate" ++ show uid ++ ";") + >>> comment "forLoop: bla 2" + >>> (baseTstate i' <== parent i) + >>> comment "forLoop: bla 3" + >>> cc + >>> comment "forLoop: bla 4" + >>> (ref_count i' <== 1) + >>> comment "forLoop: bla 5" +-- >>> (cont i' <== true) + >>> comment "forLoop: bla 6" + >>> ini + >>> comment "forLoop: bla 7" + >>> stmt1 + >>> comment "forLoop: bla 8" + >>> stmt2) + )) + else return $ dec (ref_count i) >>> ifthen (ref_count i @== 0) (comment "Delete-forLoop-dec_ref" >>> Delete (space $ cloneBase i)) + push dir = \i -> dir super (i `onCommit` inc (ref_count i)) +for + :: Int32 + -> Search + -> Search +for n s = + case s of + Search { mkeval = evals, runsearch = runs } -> + Search { mkeval = + \super -> + do { uid <- get + ; put (uid + 1) + ; s' <- evals $ mapE (L . L . mmap runL . runL) super + ; return $ mapE (L . mmap L . runL) $ forLoop n uid (mapE runL s') + } + , runsearch = runs . rReaderT True . runL + } + +foreach + :: Int32 + -> ((Info -> Value) -> Search) + -> Search +foreach n mksearch = + case mksearch (\i -> field i "counter") of + Search { mkeval = eval, runsearch = run } -> + Search { mkeval = + \super -> + do { uid <- get + ; put (uid + 1) + ; s' <- eval $ mapE (L . L . mmap runL . runL) super + ; return $ mapE (L . mmap L . runL) $ forLoop n uid (mapE runL s') + } + , runsearch = run . rReaderT True . runL + } + diff --git a/src/Control/Search/Combinator/If.hs b/src/Control/Search/Combinator/If.hs new file mode 100644 --- /dev/null +++ b/src/Control/Search/Combinator/If.hs @@ -0,0 +1,151 @@ +{-# LANGUAGE FlexibleContexts #-} + +module Control.Search.Combinator.If (if') where + +import Control.Search.Language +import Control.Search.GeneratorInfo +import Control.Search.MemoReader +import Control.Search.Generator +import Control.Search.Stat + +import Control.Monatron.Monatron hiding (Abort, L, state, cont) +import Control.Monatron.Zipper hiding (i,r) + +xs1 uid lsuper rsuper = Struct ("LeftEvalState" ++ show uid) $ {- (Bool, "cont") : -} (Int, "ref_count") : [(ty, field) | (field,ty,_) <- evalState_ lsuper] +xfs1 uid lsuper rsuper = [(field,init) | (field,ty,init) <- evalState_ rsuper ] +xs2 uid lsuper rsuper = Struct ("RightEvalState" ++ show uid) $ {- (Bool, "cont") : -} (Int, "ref_count") : [(ty, field) | (field,ty,_) <- evalState_ rsuper] +xfs2 uid lsuper rsuper = [(field,init) | (field,ty,init) <- evalState_ rsuper ] +xs3 uid lsuper rsuper = Struct ("LeftTreeState" ++ show uid) $ (Pointer $ SType $ xs1 uid lsuper rsuper, "evalState") : [(ty, field) | (field,ty,_) <- treeState_ lsuper] +xfs3 uid lsuper rsuper = [(field,init) | (field,ty,init) <- treeState_ lsuper] +xs4 uid lsuper rsuper = Struct ("RightTreeState" ++ show uid) $ (Pointer $ SType $ xs2 uid lsuper rsuper, "evalState") : [(ty, field) | (field,ty,_) <- treeState_ rsuper] +xfs4 uid lsuper rsuper = [(field,init) | (field,ty,init) <- treeState_ rsuper] + +in1 = \state -> state @-> "if_union" @-> "if_then" +in2 = \state -> state @-> "if_union" @-> "if_else" + +xpath uid lsuper rsuper i FirstS = withPath i in1 (SType $ xs1 uid lsuper rsuper) (SType $ xs3 uid lsuper rsuper) +xpath uid lsuper rsuper i SecondS = withPath i in2 (SType $ xs2 uid lsuper rsuper) (SType $ xs4 uid lsuper rsuper) + +ifLoop :: (Evalable m, ReaderM SeqPos m) => Stat -> Int -> Eval m -> Eval m -> Eval m +ifLoop cond uid lsuper rsuper = commentEval $ + Eval { structs = structs lsuper @++@ structs rsuper @++@ mystructs + , toString = "if" ++ show uid ++ "(" ++ show cond ++ "," ++ toString lsuper ++ "," ++ toString rsuper ++ ")" + , treeState_ = [("if_true", Bool,const $ return Skip), + ("if_union",Union [(SType s3,"if_true"),(SType s4,"if_false")],const $ return Skip) + ] + , initH = \i -> (readStat cond >>= \r -> return (assign (r i) (tstate i @-> "if_true"))) @>>>@ initstate i + , evalState_ = [] + , pushLeftH = push pushLeft + , pushRightH = push pushRight + , nextSameH = \i -> let j = i `withBase` "popped_estate" + in do nS1 <- local (const FirstS) $ inSeq nextSame i + nS2 <- local (const SecondS) $ inSeq nextSame i + nD1 <- local (const FirstS) $ inSeq nextDiff i + nD2 <- local (const SecondS) $ inSeq nextDiff i + return $ IfThenElse (is_fst i) + (IfThenElse (is_fst j) nS1 nD1) + (IfThenElse (is_fst j) nD2 nS2) + , nextDiffH = \i -> inSeq nextDiff i + , bodyH = \i -> + let f y z p = + let j = mpath i p +{- in do cond <- continue z (estate j) + deref <- dec_ref i + stmt <- bodyE z (j `onAbort` deref) + return $ IfThenElse (cont j) + (IfThenElse cond + stmt + ( (cont j <== false) + >>> deref + >>> abort j)) + (deref >>> abort j) +-} + in dec_ref i >>= \deref -> bodyE z (j `onAbort` deref) + in IfThenElse (is_fst i) @$ local (const FirstS) (f in1 lsuper FirstS) + @. local (const SecondS) (f in2 rsuper SecondS) + , addH = inSeq $ addE + , failH = \i -> inSeq failE i @>>>@ dec_ref i + , returnH = \i -> + let j1 deref = mpath i FirstS `onCommit` deref + j2 deref = mpath i SecondS `onCommit` deref + in IfThenElse (is_fst i) @$ (dec_refx (j1 Skip) >>= returnE lsuper . j1) @. (dec_refx (j2 Skip) >>= returnE rsuper . j2) +-- , continue = \_ -> return true + , tryH = \i -> IfThenElse (is_fst i) @$ tryE lsuper (mpath i FirstS) @. tryE rsuper (mpath i SecondS) + , startTryH = \i -> IfThenElse (is_fst i) @$ startTryE lsuper (mpath i FirstS) @. startTryE rsuper (mpath i SecondS) + , tryLH = \i -> IfThenElse (is_fst i) @$ tryE_ lsuper (mpath i FirstS) @. tryE_ rsuper (mpath i SecondS) + , boolArraysE = boolArraysE lsuper ++ boolArraysE rsuper + , intArraysE = intArraysE lsuper ++ intArraysE rsuper + , intVarsE = intVarsE lsuper ++ intVarsE rsuper + , deleteH = deleteMe + , canBranch = canBranch lsuper >>= \l -> canBranch rsuper >>= \r -> return (l || r) + , complete = \i -> do sid1 <- complete lsuper (mpath i FirstS) + sid2 <- complete rsuper (mpath i SecondS) + return $ Cond (tstate i @-> "is_fst") sid1 sid2 + } + where mystructs = ([s1,s2],[s3,s4]) + s1 = xs1 uid lsuper rsuper + s2 = xs2 uid lsuper rsuper + s3 = xs3 uid lsuper rsuper + s4 = xs4 uid lsuper rsuper + fs1 = xfs1 uid lsuper rsuper + fs2 = xfs2 uid lsuper rsuper + fs3 = xfs3 uid lsuper rsuper + fs4 = xfs4 uid lsuper rsuper + mpath = xpath uid lsuper rsuper + withSeq f = seqSwitch (f lsuper in1) (f rsuper in2) + withSeq_ f = seqSwitch (f lsuper in1 FirstS) (f rsuper in2 SecondS) + inSeq f = \i -> withSeq_ $ \super ins pos -> f super (mpath i pos) + dec_ref = \i -> seqSwitch (dec_refx $ mpath i FirstS) (dec_refx $ mpath i SecondS) + dec_refx = \j -> return $ dec (ref_count j) >>> ifthen (ref_count j @== 0) (comment "ifLoop-dec_refx" >>> Delete (estate j)) + push dir = \i -> seqSwitch (push1 dir i) (push2 dir i) + push1 dir = \i -> + let j = mpath i FirstS + in dir lsuper (j `onCommit` ( mkCopy i "if_true" + >>> mkCopy j "evalState" + >>> inc (ref_count j) + )) + push2 dir = \i -> + let j = mpath i SecondS + in dir rsuper (j `onCommit` ( mkCopy i "if_true" + >>> mkCopy j "evalState" + >>> inc (ref_count j) + )) + initstate = \i -> + let f d = + let j = mpath i (if d then FirstS else SecondS) + in return ( (estate j <== New (if d then s1 else s2)) + >>> (ref_count j <== 1) + ) + @>>>@ inite (if d then fs1 else fs2) j + @>>>@ inits (if d then lsuper else rsuper) j + in do thenP <- f True + elseP <- f False + return $ IfThenElse (tstate i @-> "if_true") thenP elseP + in1 = \state -> state @-> "if_union" @-> "if_then" + in2 = \state -> state @-> "if_union" @-> "if_else" + is_fst = \i -> tstate i @-> "if_true" + deleteMe = \i -> seqSwitch (deleteE lsuper (mpath i FirstS)) (deleteE rsuper (mpath i SecondS)) @>>>@ dec_ref i + +if' + :: Stat + -> Search + -> Search + -> Search +if' cond s1 s2 = + case s1 of + Search { mkeval = evals1, runsearch = runs1 } -> + case s2 of + Search { mkeval = evals2, runsearch = runs2 } -> + Search { mkeval = + \super -> do { s2' <- evals2 $ mapE (L . L . L . mmap (mmap runL . runL) . runL) super + ; s1' <- evals1 $ mapE (L . L . mmap (mmap runL . runL) . runL) super + ; uid <- get + ; put (uid + 1) + ; return $ mapE (L . mmap L . runL) $ + ifLoop cond uid (mapE (L . mmap (mmap L) . runL . runL) s1') + (mapE (L . mmap (mmap L) . runL . runL . runL) s2') + } + , runsearch = runs2 . runs1 . runL . rReaderT FirstS . runL + } + where in1 = \state -> state @-> "if_union" @-> "if_then" + in2 = \state -> state @-> "if_union" @-> "if_else" diff --git a/src/Control/Search/Combinator/Let.hs b/src/Control/Search/Combinator/Let.hs new file mode 100644 --- /dev/null +++ b/src/Control/Search/Combinator/Let.hs @@ -0,0 +1,41 @@ +module Control.Search.Combinator.Let (let', set') where + +import Control.Search.Language +import Control.Search.GeneratorInfo +import Control.Search.Generator +import Control.Search.Stat + +stmPrefixLoop stm super = super { tryH = \i -> (stm i) @>>>@ (tryE super) i, startTryH = \i -> (stm i) @>>>@ (startTryH super) i, toString = "prefix(" ++ toString super ++ ")" } + +letLoop :: Evalable m => VarId -> Stat -> Eval m -> Eval m +letLoop v@(VarId i) val super'' = + let super' = evalStat val super'' + super = super' { evalState_ = ("var" ++ (show i), Int, \i -> setVarInfo v i >> readStat val >>= \x -> return (x i)) : evalState_ super', + toString = "let(" ++ show v ++ "," ++ show val ++ "," ++ toString super'' ++ ")" } + in commentEval super + +let' + :: VarId + -> Stat + -> Search + -> Search + +let' var val s = + case s of + Search { mkeval = evals, runsearch = runs } -> + Search { mkeval = \super -> do { ss <- evals super + ; return $ letLoop var val ss + } + , runsearch = runs + } + +set' :: VarId -> Stat -> Search -> Search +set' var val s = case s of + Search { mkeval = evals, runsearch = runs } -> + Search { mkeval = \super -> do { ss <- evals super + ; let ss1 = evalStat (varStat var) ss + ; let ss2 = evalStat val ss1 + ; return $ stmPrefixLoop (\i -> readStat (varStat var) >>= \rvar -> readStat val >>= \rval -> return $ Assign (rvar i) (rval i)) ss2 + } + , runsearch = runs + } diff --git a/src/Control/Search/Combinator/Misc.hs b/src/Control/Search/Combinator/Misc.hs new file mode 100644 --- /dev/null +++ b/src/Control/Search/Combinator/Misc.hs @@ -0,0 +1,85 @@ +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE RankNTypes #-} + +module Control.Search.Combinator.Misc (dbs, lds, bbmin) where + +import Control.Search.Language +import Control.Search.GeneratorInfo +import Control.Search.Generator +import Control.Search.Stat + +import Data.Int + +import Control.Monatron.IdT + +ldsLoop :: Monad m => Stat -> MkEval m +ldsLoop limit super' = return $ commentEval $ super + { treeState_ = entry ("lds",Int,assign 0) : treeState_ super + , initH = \i -> readStat limit >>= \f -> initH super i @>>>@ return (assign (f i) (tstate i @-> "lds")) + , evalState_ = ("lds_complete", Bool, const $ return true) : evalState_ super + , pushLeftH = \i -> pushLeft super (i `onCommit` mkCopy i "lds") + , pushRightH = \i -> pushRight super (i `onCommit` mkUpdate i "lds" (\x -> x - 1)) >>= \stmt -> + return $ IfThenElse + (tstate (old i) @-> "lds" @>= 0) + stmt + (abort i >>> (estate i @=> "lds_complete" <== false)) + , toString = "lds(" ++ show limit ++ "," ++ toString super ++ ")" + , complete = \i -> return $ estate i @=> "lds_complete" + } + where super = evalStat limit super' + +-------------------------------------------------------------------------------- +dbsLoop :: Monad m => Int32 -> MkEval m +dbsLoop limit super = return $ commentEval $ super + { treeState_ = entry ("depth_limit",Int,assign $ IVal limit) : treeState_ super + , evalState_ = ("dbs_complete", Bool, const $ return true) : evalState_ super + , pushLeftH = push pushLeft + , pushRightH = push pushRight + , toString = "dbs(" ++ show limit ++ "," ++ toString super ++ ")" + , complete = \i -> return $ estate i @=> "dbs_complete" + } + where push dir = + \i -> dir super (i `onCommit` mkUpdate i "depth_limit" (\x -> x - 1)) >>= \stmt -> + return $ IfThenElse (tstate (old i) @-> "depth_limit" @>= 0) + stmt + ((estate i @=> "dbs_complete" <== false) >>> abort i) + +-------------------------------------------------------------------------------- +bbLoop :: Monad m => String -> MkEval m +bbLoop var super = return $ commentEval $ super + { treeState_ = entry ("tree_bound_version",Int,assign 0) : treeState_ super + , evalState_ = ("bound_version",Int,const $ return 0) : ("bound",Int,const $ return $ IVal maxBound) : evalState_ super + , returnH = \i -> returnE super (i `onCommit` + let get = VHook (rp 0 (space i) ++ "->iv[VAR_" ++ var ++ "].min()") + in (Assign (estate i @=> "bound") get >>> inc (estate i @=> "bound_version"))) + , bodyH = \i -> let set = Post (space i) (VHook (rp 0 (space i) ++ "->iv[VAR_" ++ var ++ "]") $< (estate i @=> "bound")) + in do r <- bodyE super i + return $ (ifthen (tstate i @-> "tree_bound_version" @< (estate i @=>"bound_version")) + (set >>> (Assign (tstate i @-> "tree_bound_version") ((tstate i @-> "tree_bound_version") + 1))) + >>> r) + , pushLeftH = push pushLeft + , pushRightH = push pushRight + , intVarsE = var : intVarsE super + , complete = const $ return true + , toString = "bb(" ++ show var ++ "," ++ toString super ++ ")" + } + where push dir = \i -> dir super (i `onCommit` mkCopy i "tree_bound_version") + +bbmin :: String -> Search +bbmin var = + Search { mkeval = bbLoop var + , runsearch = runIdT + } + +lds :: Stat -> Search +lds n = + Search { mkeval = ldsLoop n + , runsearch = runIdT + } + +dbs :: Int32 -> Search +dbs n = + Search { mkeval = dbsLoop n + , runsearch = runIdT + } + diff --git a/src/Control/Search/Combinator/Once.hs b/src/Control/Search/Combinator/Once.hs new file mode 100644 --- /dev/null +++ b/src/Control/Search/Combinator/Once.hs @@ -0,0 +1,30 @@ +module Control.Search.Combinator.Once (once, onceOld) where + +import Control.Search.Language +import Control.Search.GeneratorInfo +import Control.Search.Generator +import Control.Search.Memo +import Control.Search.Stat +import Control.Search.Combinator.Until + +import Control.Monatron.IdT + +onceLoop :: MkEval m +onceLoop super = return $ commentEval $ super + { evalState_ = ("onceMore", Bool, const $ return true) : evalState_ super + , bodyH = \i -> do goOn <- bodyE super i + ca <- cachedAbort i + return $ IfThenElse (estate i @=> "onceMore") + goOn + ca + , returnH = \i -> returnE super $ i `onCommit` assign false (estate i @=> "onceMore") + , toString = "once(" ++ toString super ++ ")" + } + +once :: Search +once = + Search { mkeval = onceLoop + , runsearch = runIdT + } + +onceOld = limit 1 solutionsStat diff --git a/src/Control/Search/Combinator/Or.hs b/src/Control/Search/Combinator/Or.hs new file mode 100644 --- /dev/null +++ b/src/Control/Search/Combinator/Or.hs @@ -0,0 +1,174 @@ +{-# LANGUAGE FlexibleContexts #-} + +module Control.Search.Combinator.Or ((<|>)) where + +import Control.Search.Language +import Control.Search.GeneratorInfo +import Control.Search.Generator +import Control.Search.MemoReader +import Control.Search.Memo + +import Control.Monatron.Monatron hiding (Abort, L, state, cont) +import Control.Monatron.Zipper hiding (i,r) + +xs1 uid lsuper rsuper = Struct ("LeftEvalState" ++ show uid) $ (THook "TreeState", "parent") : {- (Bool, "cont") : -} (Int, "ref_count") : [(ty, field) | (field,ty,_) <- evalState_ lsuper] +xfs1 uid lsuper rsuper = [(field,init) | (field,ty,init) <- evalState_ lsuper ] +xs2 uid lsuper rsuper = Struct ("RightEvalState" ++ show uid) $ xneedSide uid lsuper rsuper SecondS $ {- (Bool, "cont") : -} (Int, "ref_count") : [(ty, field) | (field,ty,_) <- evalState_ rsuper] +xfs2 uid lsuper rsuper = [(field,init) | (field,ty,init) <- evalState_ rsuper ] +xet uid lsuper rsuper FirstS = SType $ xs1 uid lsuper rsuper +xet uid lsuper rsuper SecondS = SType $ xs2 uid lsuper rsuper +xs3 uid lsuper rsuper = Struct ("LeftTreeState" ++ show uid) $ (Pointer $ SType $ xs1 uid lsuper rsuper, "evalState") : [(ty, field) | (field,ty,_) <- treeState_ lsuper] +xfs3 uid lsuper rsuper = [(field,init) | (field,ty,init) <- treeState_ lsuper] +xs4 uid lsuper rsuper = Struct ("RightTreeState" ++ show uid) $ xneedSide uid lsuper rsuper SecondS [(Pointer $ SType $ xs2 uid lsuper rsuper, "evalState")] ++ [(ty, field) | (field,ty,_) <- treeState_ rsuper] +xst uid lsuper rsuper FirstS = SType $ xs3 uid lsuper rsuper +xst uid lsuper rsuper SecondS = SType $ xs4 uid lsuper rsuper +xneedSide :: Monoid m => Int -> Eval n -> Eval n -> SeqPos -> m -> m +xneedSide uid lsuper rsuper = \pos stm -> case pos of { FirstS -> stm; + SecondS -> if (length (evalState_ rsuper) == 0) then mempty else stm; + } + +orLoop :: (ReaderM SeqPos m, Evalable m) => Int -> (Eval m) -> (Eval m) -> Eval m +orLoop uid (lsuper) (rsuper) = commentEval $ + Eval { structs = structs lsuper @++@ structs rsuper @++@ mystructs + , toString = "or" ++ show uid ++ "(" ++ toString lsuper ++ "," ++ toString rsuper ++ ")" + , treeState_ = [entry ("is_fst",Bool,assign true) + , ("or_union",Union [(SType s3,"fst"),(SType s4,"snd")], + \i -> + let j = withPath i in1 (et FirstS) (st FirstS) + in do cc <- cachedClone i (cloneBase j) + return ( (estate j <== New s1) + >>> (ref_count j <== 1) +-- >>> (cont j <== true) + >>> (parent j <== baseTstate j) + >>> cc + ) + @>>>@ mseqs [init (j `withClone` (\k -> inc $ ref_count k)) | (f,init) <- fs3] + @>>>@ inite fs1 j + )] + , initH = \i -> initE lsuper (withPath i in1 (et FirstS) (st FirstS)) + , evalState_ = [] + , pushLeftH = push pushLeft + , pushRightH = push pushRight + , nextSameH = \i -> let j = i `withBase` "popped_estate" + in do nS1 <- local (const FirstS) $ inSeq nextSame i + nS2 <- local (const SecondS) $ inSeq nextSame i + nD1 <- local (const FirstS) $ inSeq nextDiff i + nD2 <- local (const SecondS) $ inSeq nextDiff i + return $ IfThenElse (is_fst i) + (IfThenElse (is_fst j) nS1 nD1) + (IfThenElse (is_fst j) nD2 nS2) + , nextDiffH = \i -> inSeq nextDiff i + , bodyH = \i -> + let f y z p = + let j = withPath i y (et p) (st p) + in dec_ref i >>= \deref -> bodyE z (j `onAbort` deref) + in IfThenElse (is_fst i) @$ local (const FirstS) (f in1 lsuper FirstS) + @. local (const SecondS) (f in2 rsuper SecondS) + , addH = inSeq $ addE + , failH = \i -> inSeq failE i @>>>@ dec_ref i + , returnH = \i -> + let j1 deref = (withPath i in1 (et FirstS) (st FirstS)) `onCommit` (comment "returnE-deref-j1" >>> deref >>> comment "end returnE-deref-j1") + j2 deref = (withPath i in2 (et SecondS) (st SecondS)) `onCommit` (comment "returnE-deref-j2" >>> deref >>> comment "end returnE-deref-j2") + in seqSwitch (dec_ref1 i >>= returnE lsuper . j1) + (dec_ref2 (j2 Skip) >>= returnE rsuper . j2) + , tryH = \i -> + do dr <- dec_ref i + inSeq (\super j -> tryE super (j `onAbort` (comment "Combinator/Or tryH onAbort" >>> dr ))) i + , startTryH = \i -> local (const FirstS) $ inSeq startTryE i + , tryLH = \i -> inSeq tryE_ i @>>>@ dec_ref i + , boolArraysE = boolArraysE lsuper ++ boolArraysE rsuper + , intArraysE = intArraysE lsuper ++ intArraysE rsuper + , intVarsE = intVarsE lsuper ++ intVarsE rsuper + , deleteH = deleteMe + , canBranch = return True + , complete = \i -> do sid1 <- complete lsuper (withPath i in1 (et FirstS) (st FirstS)) + sid2 <- complete rsuper (withPath i in2 (et SecondS) (st SecondS)) + return $ (Cond (tstate i @-> "is_fst") sid1 sid2) + +-- , complete = const $ return false + } + where mystructs = ([s1,s2],[s3,s4]) + s1 = xs1 uid lsuper rsuper + s2 = xs2 uid lsuper rsuper + s3 = xs3 uid lsuper rsuper + s4 = xs4 uid lsuper rsuper + fs1 = xfs1 uid lsuper rsuper + fs2 = xfs2 uid lsuper rsuper + fs3 = xfs3 uid lsuper rsuper + et = xet uid lsuper rsuper + st = xst uid lsuper rsuper + needSide = xneedSide uid lsuper rsuper + parent = \i -> estate i @=> "parent" + withSeq f = seqSwitch (f lsuper in1 FirstS) (f rsuper in2 SecondS) + withSeq_ f = seqSwitch (f lsuper in1 FirstS) (f rsuper in2 SecondS) + inSeq f = \i -> withSeq_ $ \super ins pos -> f super (withPath i ins (et pos) (st pos)) + dec_ref = \i -> seqSwitch (dec_ref1 i) (dec_ref2 $ withPath i in2 (et SecondS) (st SecondS)) + dec_ref1 = \i -> let j1 = withPath i in1 (et FirstS) (st FirstS) + i' = resetClone $ resetAbort $ resetCommit $ i `withBase` ("or_tstate" ++ show uid) + j2 = withPath i' in2 (et SecondS) (st SecondS) + in (local (const SecondS) $ + do stmt1 <- inits rsuper j2 + stmt2 <- startTryE rsuper j2 + ini <- inite fs2 j2 + compl <- complete lsuper j1 + return ( dec (ref_count j1) + >>> (ifthen (ref_count j1 @== 0) $ + ( + {- DebugValue ("or" ++ show uid ++ ": left finished with complete") (compl) + >>> -} (ifthen (Not compl) $ + ( SHook ("TreeState or_tstate" ++ show uid ++ ";") + >>> (baseTstate j2 <== parent j1) + >>> (is_fst i' <== false) + >>> comment "orLoop-dec_ref1-Delete" >>> Delete (estate j1) + >>> needSide SecondS (estate j2 <== New s2) + >>> needSide SecondS (ref_count j2 <== 1) +-- >>> (cont j2 <== true) + >>> ini + >>> stmt1 >>> stmt2 + ) + ) + ) + ) + ) + ) + dec_ref2 = \j -> {- return (DebugValue ("or" ++ show uid ++ ": right dec_ref from") (ref_count j)) @>>>@ -} (complete rsuper (withPath (resetClone $ resetAbort $ resetCommit $ j `withBase` ("or_tstate" ++ show uid)) in2 (et SecondS) (st SecondS)) >>= \compl -> (return $ needSide SecondS $ dec (ref_count j) >>> ifthen (ref_count j @== 0) ({- DebugValue ("or" ++ show uid ++ ": right finished with complete") compl >>> -} comment "orLoop-dec_ref2-Delete" >>> Delete (estate j)))) + push dir = \i -> seqSwitch (push1 dir i) (push2 dir i) + push1 dir = \i -> + let j = withPath i in1 (et FirstS) (st FirstS) + in dir lsuper (j `onCommit` ( mkCopy i "is_fst" + >>> mkCopy j "evalState" + >>> inc (ref_count j) + )) + push2 dir = \i -> + let j = withPath i in2 (et SecondS) (st SecondS) + in dir rsuper (j `onCommit` ( mkCopy i "is_fst" + >>> needSide SecondS (mkCopy j "evalState") + >>> needSide SecondS (inc (ref_count j)) + )) + in1 = \state -> state @-> "or_union" @-> "fst" + in2 = \state -> state @-> "or_union" @-> "snd" + is_fst = \i -> tstate i @-> "is_fst" + deleteMe = \i -> seqSwitch (deleteE lsuper (withPath i in1 (et FirstS) (st FirstS))) (deleteE rsuper (withPath i in2 (et SecondS) (st SecondS))) @>>>@ dec_ref i + +(<|>) + :: Search + -> Search + -> Search +s1 <|> s2 = + case s1 of + Search { mkeval = evals1, runsearch = runs1 } -> + case s2 of + Search { mkeval = evals2, runsearch = runs2 } -> + Search {mkeval = + \super -> do { s2' <- evals2 $ mapE (L . L . L . mmap (mmap runL . runL) . runL) super + ; s1' <- evals1 $ mapE (L . L . mmap (mmap runL . runL) . runL) super + ; uid <- get + ; put (uid + 1) + ; return $ mapE (L . mmap L . runL) $ + orLoop uid (mapE (L . mmap (mmap L) . runL . runL) s1') + (mapE (L . mmap (mmap L) . runL . runL . runL) s2') + } + , runsearch = runs2 . runs1 . runL . rReaderT FirstS . runL + } + where in1 = \state -> state @-> "or_union" @-> "fst" + in2 = \state -> state @-> "or_union" @-> "snd" diff --git a/src/Control/Search/Combinator/OrRepeat.hs b/src/Control/Search/Combinator/OrRepeat.hs new file mode 100644 --- /dev/null +++ b/src/Control/Search/Combinator/OrRepeat.hs @@ -0,0 +1,95 @@ +{-# LANGUAGE FlexibleContexts #-} + +module Control.Search.Combinator.OrRepeat (orRepeat) where + +import Control.Search.Language +import Control.Search.GeneratorInfo +import Control.Search.Generator +import Control.Search.MemoReader +import Control.Search.Memo +import Control.Search.Stat + +import Control.Monatron.Monatron hiding (Abort, L, state, cont) +import Control.Monatron.Zipper hiding (i,r) + +orRepeatLoop :: (Evalable m, ReaderM Bool m) => Stat -> Int -> Eval m -> Eval m +orRepeatLoop cond uid super' = commentEval $ + Eval + { + structs = structs super @++@ mystructs + , treeState_ = treeState_ super + , toString = "orRepeat" ++ show uid ++ "(" ++ toString super' ++ ")" + , initH = \i -> initE super i @>>>@ return (parent i <== baseTstate i) @>>>@ cachedClone i (cloneBase i) + , evalState_ = {- ("cont",Bool,const $ return true) : -} ("ref_count_orr" ++ show uid,Int,const $ return 1) : ("parent",THook "TreeState",const $ return Null) : evalState_ super + , pushLeftH = push pushLeft + , pushRightH = push pushRight + , nextSameH = nextSame super + , nextDiffH = nextDiff super + , bodyH = \i -> dec_ref i >>= \deref -> bodyE super (i `onAbort` deref) + , addH = addE super + , failH = \i -> failE super i @>>>@ dec_ref i + , returnH = \i -> let j deref = i `onCommit` deref + in dec_ref i >>= returnE super . j + , tryH = \i -> do deref <- dec_ref i + tryE super (i `onAbort` deref) + , startTryH = \i -> do deref <- dec_ref i + startTryE super (i `onAbort` deref) + , tryLH = \i -> tryE_ super i @>>>@ dec_ref i + , intArraysE = intArraysE super + , boolArraysE = boolArraysE super + , intVarsE = intVarsE super + , deleteH = error "orRepeatLoop.deleteE NOT YET IMPLEMENTED" + , canBranch = return True + , complete = complete super +-- , complete = const $ return false + } + where mystructs = ([],[]) + super = evalStat cond super' + fs1 = [(field,init) | (field,ty,init) <- evalState_ super] + parent = \i -> estate i @=> "parent" + dec_ref = \i -> let i' = resetAbort $ resetCommit $ i `withBase` ("orr_tstate" ++ show uid) + ii = resetAbort $ resetCommit $ i + in do flag <- ask + if flag + then local (const False) $ do + stmt1 <- inits super i' + stmt2 <- startTryE super i' + r <- readStat cond + ini <- inite fs1 i' + -- let cc = clone ii i' + -- cc <- cachedClone (cloneBase ii) i' + cc1 <- cachedClone (i { baseTstate = parent ii} ) i' + -- cc2 <- cachedClone (i' ) i' + compl <- complete super ii + return (dec (ref_countx ii $ "orr" ++ show uid) + >>> ifthen (ref_countx ii ("orr" ++ show uid) @== 0) + (ifthen (r i' &&& Not compl) + ( SHook ("TreeState orr_tstate" ++ show uid ++ ";") + >>> (baseTstate i' <== parent ii) + -- >>> ((baseTstate i' @-> "space") <== (parent ii @-> "space")) + -- >>> cc + >>> cc1 + -- >>> cc2 + >>> (ref_countx i' ("orr" ++ show uid) <== 1) +-- >>> (cont i' <== true) + >>> ini >>> stmt1 >>> stmt2) + )) + else return $ dec (ref_countx ii ("orr" ++ show uid)) >>> ifthen (ref_countx ii ("orr" ++ show uid) @== 0) (comment "orRepeatLoop-dec_ref-Delete" >>> Delete (space $ cloneBase ii)) + push dir = \i -> dir super (i `onCommit'` inc (ref_countx i $ "orr" ++ show uid)) + +orRepeat + :: Stat + -> Search + -> Search +orRepeat cond s = + case s of + Search { mkeval = evals, runsearch = runs } -> + Search { mkeval = + \super -> + do { uid <- get + ; put (uid + 1) + ; s' <- evals $ mapE (L . L . mmap runL . runL) super + ; return $ mapE (L . mmap L . runL) $ orRepeatLoop cond uid (mapE runL s') + } + , runsearch = runs . rReaderT True . runL + } diff --git a/src/Control/Search/Combinator/Post.hs b/src/Control/Search/Combinator/Post.hs new file mode 100644 --- /dev/null +++ b/src/Control/Search/Combinator/Post.hs @@ -0,0 +1,34 @@ +{-# LANGUAGE Rank2Types #-} +{-# LANGUAGE FlexibleContexts #-} + +module Control.Search.Combinator.Post (post) where + +import Control.Search.Language +import Control.Search.GeneratorInfo +import Control.Search.Generator +import Control.Search.Constraints + +postLoop :: VarInfoM m => ConstraintGen -> MkEval m -> MkEval m +postLoop (ConstraintGen c l) par this = do + super <- par this + return $ commentEval $ super + { tryH = try tryE super + , startTryH = try startTryE super + , toString = "post(," ++ toString super ++ ")" + , intVarsE = l ++ intVarsE super + } + where try f super = \i -> -- failE super i >>= \fail -> -- XXX + f super i >>= \body -> + c i >>= \cc -> + return $ Post (space i) cc >>> body +-- (Var "status" <== VHook (rp 0 (space i) ++ "->status()")) >>> +-- IfThenElse (Var "status" @== VHook "SS_FAILED") (fail >>> comment "Delete-postLoop-try" >>> Delete (space i)) body + + +post :: ConstraintGen -> Search -> Search +post c s = + case s of + Search { mkeval = m, runsearch = r } -> + Search { mkeval = postLoop c m + , runsearch = r + } diff --git a/src/Control/Search/Combinator/Print.hs b/src/Control/Search/Combinator/Print.hs new file mode 100644 --- /dev/null +++ b/src/Control/Search/Combinator/Print.hs @@ -0,0 +1,34 @@ +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE RankNTypes #-} + +module Control.Search.Combinator.Print (prt,dbg) where + +import Control.Search.Language +import Control.Search.GeneratorInfo +import Control.Search.Generator + +import Control.Monatron.IdT + +printLoop :: [String] -> MkEval m +printLoop lst super = return $ commentEval $ super + { returnH = \i -> returnE super $ i `onCommit` Print (space i) lst + , toString = "print(" ++ toString super ++ ")" + } + +debugLoop :: Evalable m => String -> MkEval m +debugLoop str super = return $ commentEval $ super + { initH = \i -> return (DebugOutput str) @>>>@ initH super i + , toString = "debug(" ++ show str ++ "," ++ toString super ++ ")" + } + +prt :: [String] -> Search +prt l = + Search { mkeval = printLoop l + , runsearch = runIdT + } + +dbg :: String -> Search +dbg str = + Search { mkeval = debugLoop str + , runsearch = runIdT + } diff --git a/src/Control/Search/Combinator/Repeat.hs b/src/Control/Search/Combinator/Repeat.hs new file mode 100644 --- /dev/null +++ b/src/Control/Search/Combinator/Repeat.hs @@ -0,0 +1,84 @@ +{-# LANGUAGE FlexibleContexts #-} + +module Control.Search.Combinator.Repeat (repeat) where + +import Prelude hiding (lex, until, init, repeat) + +import Control.Search.Language +import Control.Search.GeneratorInfo +import Control.Search.Generator +import Control.Search.MemoReader +import Control.Search.Memo + +import Control.Monatron.Monatron hiding (Abort, L, state, cont) +import Control.Monatron.Zipper hiding (i,r) + +repeatLoop :: (ReaderM Bool m, Evalable m) => Int -> Eval m -> Eval m +repeatLoop uid super = commentEval $ + Eval + { + structs = structs super @++@ mystructs + , toString = "repeat" ++ show uid ++ "(" ++ toString super ++ ")" + , treeState_ = ("dummy", Int, + \i -> do cc <- cachedClone i (cloneBase i) + return ((parent i <== baseTstate i) + >>> cc + ) + ) : treeState_ super -- `withClone` (\k -> inc $ ref_count k) + , initH = \i -> initE super i + , evalState_ = {- ("cont",Bool,const $ return true) : -} ("ref_count",Int,const $ return 1) : ("parent",THook "TreeState",const $ return Null) : evalState_ super + , pushLeftH = push pushLeft + , pushRightH = push pushRight + , nextSameH = nextSame super + , nextDiffH = nextDiff super + , bodyH = \i -> dec_ref i >>= \deref -> bodyE super (i `onAbort` deref) + , addH = addE super + , failH = \i -> failE super i @>>>@ dec_ref i + , returnH = \i -> let j deref = i `onCommit` deref + in dec_ref i >>= returnE super . j + , tryH = tryE super + , startTryH = startTryE super + , tryLH = \i -> tryE_ super i @>>>@ dec_ref i + , boolArraysE = boolArraysE super + , intArraysE = intArraysE super + , intVarsE = intVarsE super + , deleteH = error "repeatLoop.deleteE NOT YET IMPLEMENTED" + , canBranch = canBranch super + , complete = const $ return true + } + where mystructs = ([],[]) + fs1 = [(field,init) | (field,ty,init) <- evalState_ super] + parent = \i -> estate i @=> "parent" + dec_ref = \i -> let i' = resetCommit $ i `withBase` ("repeat_tstate" ++ show uid) + in do flag <- ask + if flag + then local (const False) $ do + stmt1 <- inits super i' + stmt2 <- startTryE super i' + ini <- inite fs1 i' + return (dec (ref_count i) + >>> ifthen (ref_count i @== 0) + ( SHook ("TreeState repeat_tstate" ++ show uid ++ ";") + >>> (baseTstate i' <== parent i) + >>> clone (cloneBase i) i' + >>> (ref_count i' <== 1) +-- >>> (cont i' <== true) + >>> ini >>> stmt1 >>> stmt2)) + else return $dec (ref_count i) >>> ifthen (ref_count i @== 0) (comment "Delete-repeatLoop-dec_ref" >>> Delete (space $ cloneBase i)) + push dir = \i -> dir super (i `onCommit` inc (ref_count i)) + +repeat + :: Search + -> Search +repeat s = + case s of + Search { mkeval = evals, runsearch = runs } -> + Search { mkeval = + \super -> + do { uid <- get + ; put (uid + 1) + ; s' <- evals $ mapE (L . L . mmap runL . runL) super + ; return $ mapE (L . mmap L . runL) $ repeatLoop uid $ mapE runL s' + } + , runsearch = runs . rReaderT True . runL + } diff --git a/src/Control/Search/Combinator/Success.hs b/src/Control/Search/Combinator/Success.hs new file mode 100644 --- /dev/null +++ b/src/Control/Search/Combinator/Success.hs @@ -0,0 +1,38 @@ +module Control.Search.Combinator.Success (dummy) where + +import Control.Search.Language +import Control.Search.GeneratorInfo +import Control.Search.Generator +import Control.Search.Memo + +import Control.Monatron.IdT + +successLoop :: Evalable m => Eval m -> Eval m +successLoop this = commentEval $ + Eval { structs = ([],[]) + , treeState_ = [] + , initH = const $ return Skip + , evalState_ = [] + , pushLeftH = error "succesloop.tyE_" + , pushRightH = error "succesloop.tyE_" + , nextSameH = \i -> return Skip + , nextDiffH = \i -> return Skip + , bodyH = addE this . resetInfo -- XXX + , addH = \i -> tryE this (resetInfo i) + , failH = const $ return Skip + , returnH = \i -> cachedCommit i + -- const $ return Skip +-- , continue = \_ -> return true + , tryH = returnE this . resetInfo + , startTryH = \i -> (return $ comment "") @>>>@ (returnE this . resetInfo) i @>>>@ (return $ comment "") + , tryLH = error "succesloop.tryE_" + , intArraysE = [] + , boolArraysE = [] + , intVarsE = [] + , deleteH = \i -> return Skip + , toString = "succeed" + , canBranch = return False + , complete = const $ return true + } + +dummy = Search { mkeval = return . successLoop, runsearch = runIdT } diff --git a/src/Control/Search/Combinator/Until.hs b/src/Control/Search/Combinator/Until.hs new file mode 100644 --- /dev/null +++ b/src/Control/Search/Combinator/Until.hs @@ -0,0 +1,188 @@ +{-# LANGUAGE FlexibleContexts #-} + +module Control.Search.Combinator.Until (until,limit,glimit) where + +import Prelude hiding (until) +import Data.Int + +import Control.Search.Language +import Control.Search.GeneratorInfo +import Control.Search.MemoReader +import Control.Search.Generator +import Control.Search.Combinator.Failure +import Control.Search.Stat + +import Control.Monatron.Monatron hiding (Abort, L, state, cont) +import Control.Monatron.Zipper hiding (i,r) + +untilLoop :: (Evalable m, ReaderM SeqPos m) => Stat -> Int -> (Eval m) -> (Eval m) -> Eval m +untilLoop cond uid lsuper' rsuper = commentEval c + where c = Eval { structs = structs lsuper @++@ structs rsuper @++@ mystructs + , toString = "until" ++ show uid ++ "(" ++ show cond ++ "," ++ toString lsuper' ++ "," ++ toString rsuper ++ ")" + , treeState_ = [entry ("is_fst",Bool,assign true) + ,("until_union", Union [(SType s3,"fst"),(SType s4,"snd")], + \i -> + let j = xpath i FirstS + in initSubEvalState j s1 fs1 FirstS) + ] + , initH = \i -> inits lsuper (i `xpath` FirstS) + , evalState_ = [("until_complete",Bool,const $ return true)] + , pushLeftH = push pushLeft + , pushRightH = push pushRight + , nextSameH = \i -> let j = i `withBase` "popped_estate" + in do let nS1 = local (const FirstS) $ inSeq nextSame i + let nS2 = local (const SecondS) $ inSeq nextSame i + let nD1 = local (const FirstS) $ inSeq nextDiff i + let nD2 = local (const SecondS) $ inSeq nextDiff i + swfst i (swfst j nS1 nD1) (swfst j nD2 nS2) + , nextDiffH = inSeq nextDiff + , -- MAIN ENTRY POINT FOR NEW NODE + -- if (fst) { + -- if (seq_union.fst.evalState->cont) { + -- } else { + -- } + -- } else { + -- if (seq_union.snd.evalState->cont) { + -- } else { + -- } + -- } + bodyH = \i -> + let f y z iscomplete pos = + do compl <- iscomplete (i `xpath` pos) + let j = i `xpath` pos `onAbort` (comment "untilLoop.bodyE" >>> dec_ref i j compl pos) + bodyE z j + in do let s1 = local (const FirstS) $ f in1 lsuper liscomplete FirstS + s2 = local (const SecondS) $ f in2 rsuper riscomplete SecondS + swfst i s1 s2 + , addH = inSeq $ addE + , failH = \i -> inSeq' (\super j iscomplete pos -> iscomplete j >>= \compl -> (failE super j @>>>@ return (dec_ref i j compl pos))) i + , returnH = \i -> inSeq' (\super j iscomplete pos -> iscomplete j >>= \compl -> (returnE super (j `onCommit` dec_ref i j compl pos))) i +-- , continue = \_ -> return true + -- IF THE CURRENT STATUS IS NOT FAILED + -- EITHER (is_fst) + -- if () { // SWITCH TO NEW SEARCH + -- } else { + -- + -- } + -- OR (!is_fst) + , tryH = tryX tryE + , startTryH = tryX startTryE + , tryLH = \i -> inSeq' (\super j iscomplete pos -> iscomplete j >>= \compl -> (tryE_ super j @>>>@ return (dec_ref i j compl pos))) i + , boolArraysE = boolArraysE lsuper ++ boolArraysE rsuper + , intArraysE = intArraysE lsuper ++ intArraysE rsuper + , intVarsE = intVarsE lsuper ++ intVarsE rsuper + , deleteH = error "untilLoop.deleteE NOT YET IMPLEMENTED" + , canBranch = canBranch lsuper >>= \l -> canBranch rsuper >>= \r -> return (l || r) + , complete = \i -> return $ estate i @=> "until_complete" +-- , complete = const $ return false + } + needSide_ = \pos stmY stmN -> case pos of { FirstS -> if (length (evalState_ lsuper) == 0) then stmN else stmY; + SecondS -> if (length (evalState_ rsuper) == 0) then stmN else stmY; + } + needSide :: Monoid m => SeqPos -> m -> m + needSide = \pos stm -> needSide_ pos stm mempty + mystructs = ([s1,s2],[s3,s4]) + s1 = Struct ("LeftEvalState" ++ show uid) $ needSide FirstS $ {- (Bool, "cont") : -} (Int, "ref_count_until" ++ show uid) : [(ty, field) | (field,ty,_) <- evalState_ lsuper] + fs1 = [(field,init) | (field,ty,init) <- evalState_ lsuper ] + s2 = Struct ("RightEvalState" ++ show uid) $ needSide SecondS $ {- (Bool, "cont") : -} (Int, "ref_count_until" ++ show uid) : [(ty, field) | (field,ty,_) <- evalState_ rsuper] + fs2 = [(field,init) | (field,ty,init) <- evalState_ rsuper ] + s3 = Struct ("LeftTreeState" ++ show uid) $ needSide FirstS [(Pointer $ SType s1, "evalState")] ++ [(ty, field) | (field,ty,_) <- treeState_ lsuper] + fs3 = [(field,init) | (field,ty,init) <- treeState_ lsuper] + s4 = Struct ("RightTreeState" ++ show uid) $ needSide SecondS [(Pointer $ SType s2, "evalState")] ++ [(ty, field) | (field,ty,_) <- treeState_ rsuper] + xpath i FirstS = withPath i in1 (Pointer $ SType s1) (Pointer $ SType s3) + xpath i SecondS = withPath i in2 (Pointer $ SType s2) (Pointer $ SType s4) + in1 = \state -> state @-> "until_union" @-> "fst" + in2 = \state -> state @-> "until_union" @-> "snd" + is_fst = \i -> tstate i @-> "is_fst" + withSeq f = seqSwitch (f lsuper in1) (f rsuper in2) + withSeq_ f = seqSwitch (f lsuper in1 FirstS) (f rsuper in2 SecondS) + inSeq f = \i -> withSeq_ $ \super ins pos -> f super (i `xpath` pos) + inSeq' f = \i -> seqSwitch (f lsuper (i `xpath` FirstS) liscomplete FirstS) + (f rsuper (i `xpath` SecondS) riscomplete SecondS) + dec_ref = \i j iscomplete pos -> needSide_ pos (dec (ref_countx j $ "until" ++ show uid) >>> + ifthen (ref_countx j ("until" ++ show uid) @== 0) ( + {- DebugValue ("until" ++ show uid ++ ": left branch finished with complete") iscomplete + >>> DebugValue ("until" ++ show uid ++ ": until's previous completeness was") (complet i) + >>> -} (complet i <== (complet i &&& iscomplete)) >>> Delete (estate j) + ) + ) (complet i <== (complet i &&& iscomplete)) + push dir = \i -> seqSwitch (push1 dir i) (push2 dir i) + push1 dir = \i -> + let j = i `xpath` FirstS + in dir lsuper (j `onCommit` ( mkCopy i "is_fst" + >>> mkCopy j "evalState" + >>> inc (ref_countx j $ "until" ++ show uid) + )) + push2 dir = \i -> + let j = i `xpath` SecondS + in dir rsuper (j `onCommit` ( mkCopy i "is_fst" + >>> mkCopy j "evalState" + >>> inc (ref_countx j $ "until" ++ show uid) + )) + lsuper = evalStat cond lsuper' + complet = \i -> estate i @=> "until_complete" + liscomplete = complete lsuper' + riscomplete = complete rsuper + initSubEvalState = \j s fs pos -> return (needSide pos ( (estate j <== New s) + >>> (ref_countx j ("until" ++ show uid) <== 1) +-- >>> (cont j <== true) + ) + ) + @>>>@ inite fs j + tryX = \x i -> do lc <- liscomplete (i `xpath` FirstS) + rc <- riscomplete (i `xpath` SecondS) + let j1 = i `xpath` FirstS `onAbort` (comment "untilLoop.tryE j1" >>> dec_ref i j1 lc FirstS) + j2 = i `xpath` SecondS `onAbort` (comment "untilLoop.tryE j2" >>> dec_ref i j2 rc SecondS) + j2b = i `xpath` SecondS `onAbort` (comment "untilLoop.tryE j2b" >>> dec_ref i j2b rc SecondS) + seqSwitch (x lsuper j1 >>= \try1 -> + deleteE lsuper j1 >>= \delete1 -> + (local (const SecondS) $ + do stmt1 <- inits rsuper j2b + stmt2 <- startTryE rsuper j2b + ini <- initSubEvalState j2b s2 fs2 SecondS + return ( delete1 + >>> dec_ref i j1 lc FirstS + >>> (is_fst i <== false) + >>> ini + >>> comment "initTreeState_ j2b rsuper" + >>> stmt1 + >>> comment "tryE rsuper j2b" + >>> comment ("length: " ++ show (length (abort_ j2b))) + >>> stmt2) + ) >>= \start2 -> readStat cond >>= \r -> return $ IfThenElse (r j1) ({- (DebugOutput $ "until" ++ show uid ++ " switches") >>> -} start2) try1 + ) + (x rsuper j2) + swfst i t e = do b1 <- canBranch lsuper + b2 <- canBranch rsuper + if (b1 && b2) then do { tt <- t; ee <- e; return $ IfThenElse (is_fst i) tt ee } + else if b1 then t + else e + + +limit :: Int32 -> Stat -> Search -> Search +limit n stat s = until (stat #>= constStat (const (IVal n))) s failure + +glimit :: Stat -> Search -> Search +glimit cond s = until (cond) s failure + +until + :: Stat + -> Search + -> Search + -> Search +until cond s1 s2 = + case s1 of + Search { mkeval = evals1, runsearch = runs1 } -> + case s2 of + Search { mkeval = evals2, runsearch = runs2 } -> + Search { mkeval = + \super -> do { s2' <- evals2 $ mapE (L . L . L . mmap (mmap runL . runL) . runL) super + ; s1' <- evals1 $ mapE (L . L . mmap (mmap runL . runL) . runL) super + ; uid <- get + ; put (uid + 1) + ; return $ mapE (L . mmap L . runL) $ memoLoop $ + untilLoop cond uid (mapE ({- L . mmap (mmap L) . runL . runL-} mmap L . runL) s1') + (mapE ({- L . mmap (mmap L) . runL . runL . runL-} mmap L . runL . runL) s2') + } + , runsearch = runs2 . runs1 . runL . rReaderT FirstS . runL + } diff --git a/src/Control/Search/Constraints.hs b/src/Control/Search/Constraints.hs new file mode 100644 --- /dev/null +++ b/src/Control/Search/Constraints.hs @@ -0,0 +1,71 @@ +{-# LANGUAGE Rank2Types #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE ExistentialQuantification #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE PatternGuards #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE OverlappingInstances #-} + +module Control.Search.Constraints + ( clvar, cvar, cvars, cbvars, cval, cop, ctrue, cfalse, cexprStatVal, cexprStatMed, cexprStatMin, cexprStatMax + , ConstraintExpr(..), ConstraintGen(..) + ) where + +import Text.PrettyPrint hiding (space) +import Data.List (sort, nub, sortBy) +import Unsafe.Coerce + +import Control.Search.Language +import Control.Search.GeneratorInfo +import Control.Search.Memo +import Control.Search.Stat +import Control.Search.Generator + +import Control.Monatron.Monatron hiding (Abort, L, state, cont) +import Control.Monatron.Zipper hiding (i,r) +import Control.Monatron.IdT + +import Data.Maybe (fromJust) +import Data.Map (Map) +import qualified Data.Map as Map + +import Control.Search.SStateT + +data ConstraintExpr = ConstraintExpr (forall m. VarInfoM m => m IValue) Bool [String] + +data ConstraintGen = ConstraintGen (forall m. VarInfoM m => Info -> m Constraint) [String] + +cvars :: String -> Integer -> ConstraintExpr +cvars v n = ConstraintExpr (return $ \i -> (AVarElem v (space i) (fromInteger n))) True [v] + +cbvars :: String -> Integer -> ConstraintExpr +cbvars v n = ConstraintExpr (return $ \i -> (BAVarElem v (space i) (fromInteger n))) True [v] + +cvar :: String -> ConstraintExpr +cvar v = ConstraintExpr (return $ \i -> (IVar v (space i))) True [v] + +cval :: Integer -> ConstraintExpr +cval i = ConstraintExpr (return $ const $ fromInteger i) False [] + +clvar :: VarId -> ConstraintExpr +clvar v@(VarId n) = ConstraintExpr (do inf <- lookupVarInfo v + return $ const $ estate inf @=> ("var" ++ show n) + ) False [] + +cop :: ConstraintExpr -> (Value -> Value -> Constraint) -> ConstraintExpr -> ConstraintGen +cop (ConstraintExpr v1 _ l1) op (ConstraintExpr v2 _ l2) = ConstraintGen (\info -> (v1 >>= \x -> v2 >>= \y -> return (x info `op` y info))) (l1 ++ l2) + +ctrue :: ConstraintGen +ctrue = ConstraintGen (const $ return TrueC) [] + +cfalse :: ConstraintGen +cfalse = ConstraintGen (const $ return FalseC) [] + +cexprStat f (ConstraintExpr m c l) = Stat (\e -> e { intVarsE = l ++ intVarsE e }) (m >>= \iv -> return (\info -> (if c then iv info @-> (f ++ "()") else iv info))) +cexprStatVal = cexprStat "val" +cexprStatMin = cexprStat "min" +cexprStatMax = cexprStat "max" +cexprStatMed = cexprStat "med" + + diff --git a/src/Control/Search/Generator.hs b/src/Control/Search/Generator.hs new file mode 100644 --- /dev/null +++ b/src/Control/Search/Generator.hs @@ -0,0 +1,860 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE Rank2Types #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE ExistentialQuantification #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE PatternGuards #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE OverlappingInstances #-} +{-# LANGUAGE IncoherentInstances #-} +{-# LANGUAGE UndecidableInstances #-} + +module Control.Search.Generator + ( (<@>) + , mmap + , search + , ($==) + , ($/=) + , ($<) + , ($<=) + , ($>) + , ($>=) + , (@>) + , VarId(..) + + , mapE, Eval(..), inite, seqSwitch, VarInfoM(..), MkEval, Evalable + , SeqPos(..), Search(..), (@.), (@$), (@>>>@) + , ref_count, ref_countx, ref_count_type, commentEval, (@++@) + , entry, numSwitch, SearchCombiner(..) + , buildCombiner, extractCombiners + , memo + , memoLoop {- ,MemoWrapper, runMemoWrapper-} + , rReaderT +#ifndef NOMEMO + , cacheStatement +#endif + , cloneBase + , mkCopy, mkUpdate, rp, inits, mseqs + , cachedCommit, cachedAbort, cachedClone + , nextSame, nextDiff, pushLeft, pushRight, bodyE, addE, returnE, initE, failE, tryE, startTryE, tryE_, deleteE + ) where + +import Debug.Trace + +import Text.PrettyPrint hiding (space) +import Prelude hiding ((<>)) +import Data.List (sort, nub, sortBy) +import Data.List (intercalate) +import Data.Unique +import Unsafe.Coerce + +import Control.Search.Language +import Control.Search.GeneratorInfo +#ifndef NOMEMO +import Control.Search.Memo +import Control.Search.MemoReader +#endif + +import Control.Monatron.Monatron hiding (Abort, L, state, cont) +import Control.Monatron.Zipper hiding (i,r) +import Control.Monatron.MonadInfo +import Control.Monatron.IdT + +import Data.Maybe (fromJust) +import Data.Map (Map) +import qualified Data.Map as Map +import qualified Data.Semigroup as DS + +import Control.Search.SStateT + +modify :: StateM s f => (s -> s) -> f () +modify f = get >>= put . f + +newtype GenModeT m a = GenModeT { unGenModeT :: ReaderT GenMode m a } + deriving (MonadT, ReaderM GenMode, FMonadT) + +class Monad m => GenModeM m where + getFlags :: m PrettyFlags + getMode :: m GenMode + getFlags = getMode >>= return . PrettyFlags + +instance MonadInfoT GenModeT where + tminfo x = miInc "GenModeT" $ minfo (runReaderT undefined (unGenModeT x)) + +instance Monad m => GenModeM (GenModeT m) where + getMode = GenModeT ask + +instance (GenModeM m, FMonadT t) => GenModeM (t m) where + getMode = lift getMode + +runGenModeT :: GenMode -> GenModeT m a -> m a +runGenModeT m (GenModeT r) = runReaderT m r + +type TreeState = Value + +newtype VarId = VarId Int + deriving (Ord, Eq, Show) + +type VarInfo = Map VarId Info + +newtype VarInfoT m a = VarInfoT { unVarInfoT :: SStateT VarInfo m a } + deriving (MonadT,StateM VarInfo, FMonadT) + +instance MonadInfoT VarInfoT where + tminfo x = miInc "VarInfoT" $ minfo (runSStateT undefined (unVarInfoT x)) + +class Monad m => VarInfoM m where + lookupVarInfo :: VarId -> m Info + setVarInfo :: VarId -> Info -> m () + +instance Monad m => VarInfoM (VarInfoT m) where + lookupVarInfo var = VarInfoT $ get >>= return . fromJust . Map.lookup var + setVarInfo var val = VarInfoT $ get >>= \tbl -> (put $ Map.insert var val tbl) + +instance (VarInfoM m, FMonadT t) => VarInfoM (t m) where + lookupVarInfo = lift . lookupVarInfo + setVarInfo var val = lift (setVarInfo var val) + +#ifdef NOMEMO +class (VarInfoM m, HookStatsM m, MonadInfo m, GenModeM m, Functor m) => Evalable m +instance (VarInfoM m, HookStatsM m, MonadInfo m, GenModeM m, Functor m) => Evalable m +#else +class (VarInfoM m, HookStatsM m, MonadInfo m, MemoM m, GenModeM m, Functor m) => Evalable m +instance (VarInfoM m, HookStatsM m, MonadInfo m, MemoM m, GenModeM m, Functor m) => Evalable m +#endif + +data Eval m = Eval + { structs :: ([Struct],[Struct]) -- auxiliary type declarations + , treeState_ :: [(String,Type, Info -> m Statement)] -- tree state fields (name, type, init) + , evalState_ :: [(String,Type, Info -> m Value)] + , nextSameH :: Info -> m Statement + , nextDiffH :: Info -> m Statement + , pushLeftH :: Info -> m Statement + , pushRightH :: Info -> m Statement + , bodyH :: Info -> m Statement + , initH :: Info -> m Statement + , addH :: Info -> m Statement + , returnH :: Info -> m Statement + , failH :: Info -> m Statement + , tryH :: Info -> m Statement + , tryLH :: Info -> m Statement + , startTryH :: Info -> m Statement + , intArraysE :: [String] + , boolArraysE :: [String] + , intVarsE :: [String] + , -- Free heap allocated memory for search heuristic associated to this node + -- because it is being abandoned. + -- + -- BE CAREFUL: deallocate memory only once in case of multiple references. + -- + -- Example use case: untilLoop + deleteH :: Info -> m Statement + , toString :: String + , canBranch :: m Bool + , complete :: Info -> m Value + } + +commentStatement :: (HookStatsM m) => String -> Eval m -> (Info -> m Statement) -> (Info -> m Statement) +#ifdef OUTPUTCOMMENTS +commentStatement c e f = \x -> (f x >>= \s -> return (DebugOutput ("begin: " ++ c ++ " @ " ++ toString e) >>> s >>> DebugOutput ("end: " ++ c ++ " @ " ++ toString e))) +#else +commentStatement c e f = \x -> (f x >>= \s -> return (comment ("begin: " ++ c ++ " @ " ++ toString e) >>> s >>> comment ("end: " ++ c ++ " @ " ++ toString e))) +#endif + +commentEval :: Evalable m => Eval m -> Eval m +#ifdef COMMENTS +commentEval e = + e { treeState_ = map (\(a,b,c) -> (a,b,commentStatement "treeState" e c)) (treeState_ e) + , nextSameH = commentStatement "nextSame" e (nextSame e) + , nextDiffH = commentStatement "nextDiff" e (nextDiff e) + , pushLeftH = commentStatement "pushLeft" e (pushLeft e) + , pushRightH = commentStatement "pushRight" e (pushRight e) + , bodyH = commentStatement "bodyE" e (bodyE e) + , initH = commentStatement "initE" e (initE e) + , addH = commentStatement "addE" e (addE e) + , returnH = commentStatement "returnE" e (returnE e) + , failH = commentStatement "failE" e (failE e) + , tryH = commentStatement "tryE" e (tryE e) + , tryLH = commentStatement "tryE_" e (tryE_ e) + , deleteH = commentStatement "deleteE" e (deleteE e) + , startTryH = commentStatement "startTryE" e (startTryE e) + } +#else +commentEval = id +#endif + +entry :: Monad m => (String,Type,Value -> Statement) -> (String,Type,Info -> m Statement) +entry (name,ty,up) = (name, ty, \i -> return (up $ (@->name) $ tstate i)) + +rootEntry :: Monad m => [(String,Type,Info -> m Statement)] +rootEntry = [ entry ("space",Pointer SpaceType,assign RootSpace) + ] + +inits :: Evalable m => Eval m -> Info -> m Statement +inits e i = initTreeState_ i e @>>>@ initH e i + +inite :: Monad m => [(String,Info -> m Value)] -> Info -> m Statement +inite fs i = mseqs [init i >>= \ini -> return (estate i @=> f <== ini) | (f,init) <- fs] + +mkCopy i f = (tstate i @-> f) <== (tstate (old i) @-> f) +mkUpdate i f g = (tstate i @-> f) <== g (tstate (old i) @-> f) + +mseqs lst = sequence lst >>= \s -> return (seqs s) + +mapE :: (HookStatsM m, HookStatsM n) => (forall x. m x -> n x) -> Eval m -> Eval n +mapE x = mapE_ (const x) + +data HookStat = HookStat { nCalls :: Integer } + +newtype HookStatsT m a = HookStatsT { unHookStatsT :: StateT HookStat m a } + deriving (Monad, StateM HookStat, FMonadT, MonadT) + +runHookStatsT :: Monad m => HookStatsT m a -> m (a, Integer) +runHookStatsT m = do + (a, s) <- runStateT (HookStat { nCalls = 0 }) $ unHookStatsT m + return (a, nCalls s) + +instance MonadInfoT HookStatsT where + tminfo = miInc "HookStatsT" . minfo . runHookStatsT + +class Monad m => HookStatsM m where + hookCalled :: m () + +instance Monad m => HookStatsM (HookStatsT m) where + hookCalled = modify (\st -> st { nCalls = 1 + nCalls st }) + +instance (MonadT t, HookStatsM m) => HookStatsM (t m) where + hookCalled = lift hookCalled + +callHook :: HookStatsM m => String -> Eval m -> Info -> m () +callHook s e i = hookCalled + +nextSame, nextDiff, pushLeft, pushRight, bodyE, addE, returnE, initE, failE, tryE, startTryE, tryE_, deleteE :: HookStatsM m => Eval m -> Info -> m Statement +nextSame e i = callHook "nextSame" e i >> nextSameH e i +nextDiff e i = callHook "nextDiff" e i >> nextDiffH e i +pushLeft e i = callHook "pushLeft" e i >> pushLeftH e i +pushRight e i = callHook "pushRight" e i >> pushRightH e i +bodyE e i = callHook "body" e i >> bodyH e i +addE e i = callHook "add" e i >> addH e i +returnE e i = callHook "return" e i >> returnH e i +initE e i = callHook "init" e i >> initH e i +failE e i = callHook "fail" e i >> failH e i +tryE e i = callHook "try" e i >> tryH e i +startTryE e i = callHook "startTry" e i >> startTryH e i +tryE_ e i = callHook "tryL" e i >> tryLH e i +deleteE e i = callHook "deleteH" e i >> deleteH e i + +mapE_ :: (HookStatsM m, HookStatsM n) => (forall x. Maybe Info -> m x -> n x) -> Eval m -> Eval n +mapE_ f e = + Eval { structs = structs e + , treeState_ = map (\(s,t,m) -> (s,t,\i -> f (Just i) (m i))) (treeState_ e) + , evalState_ = map (\(s,t,m) -> (s,t,\i -> f (Just i) (m i))) (evalState_ e) + , nextSameH = \i -> f (Just i) (nextSame e i) + , nextDiffH = \i -> f (Just i) (nextDiff e i) + , pushLeftH = \i -> f (Just i) (pushLeft e i) + , pushRightH = \i -> f (Just i) (pushRight e i) + , bodyH = \i -> f (Just i) (bodyE e i) + , addH = \i -> f (Just i) (addE e i) + , returnH = \i -> f (Just i) (returnE e i) + , initH = \i -> f (Just i) (initE e i) + , failH = \i -> f (Just i) (failE e i) + , tryH = \i -> f (Just i) (tryE e i) + , startTryH = \i -> f (Just i) (startTryE e i) + , tryLH = \i -> f (Just i) (tryE_ e i) + , boolArraysE = boolArraysE e + , intArraysE = intArraysE e + , intVarsE = intVarsE e + , deleteH = \i -> f (Just i) (deleteE e i) + , toString = toString e + , canBranch = f Nothing $ canBranch e + , complete = \i -> f (Just i) (complete e i) + } + +-------------------------------------------------------------------------------- +-- SEARCH TRANSFORMERS +-------------------------------------------------------------------------------- + +#ifndef NOMEMO +buildMemoKey :: MemoM m => String -> Maybe (Eval m) -> Maybe Statement -> Info -> m MemoKey +buildMemoKey fn (Just e) _ i = do + t <- getMemo + return $ MemoKey { memoFn = fn, memoInfo = Just i , memoStack = Just (toString e), memoExtra = Just (memoRead t), memoStatement = Nothing, memoParams = map fst (stackField i) } +buildMemoKey fn Nothing (Just s) i = do + return $ MemoKey { memoFn = fn, memoInfo = Nothing, memoStack = Nothing , memoExtra = Nothing , memoStatement = Just s , memoParams = map fst (stackField i) } + +lookupMemo :: Evalable m => String -> Maybe (Eval m) -> Maybe Statement -> Info -> m (Maybe MemoValue) +lookupMemo fn e s i = + do t <- getMemo + key <- buildMemoKey fn e s i + let r = Map.lookup key $ memoMap t + case r of + Nothing -> return () + Just k -> setMemo $ t { memoMap = Map.adjust (\x -> x { memoUsed = memoUsed x + 1 }) key (memoMap t) } + return r + +insertMemo :: Evalable m => String -> Maybe (Eval m) -> Statement -> (Int -> ([(String,Type,Value)], m Statement)) -> Info -> m MemoValue +insertMemo fn e s sm i = + do t <- getMemo + fl <- getFlags + let n = memoCount t + let (lst,ss) = sm n + let ni = i { stackField = stackField i ++ (map (\(n,t,v) -> (rpx 0 fl t, n)) lst) } + key <- buildMemoKey fn e (Just s) ni + s2 <- ss + let val = MemoValue { memoId = n + , memoCode = s2 + , memoUsed = 1 + , memoFields = stackField ni + } + setMemo $ t { memoMap = Map.insert key val $ memoMap t + , memoCount = n+1 + } + return val + +invokeMemo :: Evalable m => String -> Eval m -> (Eval m -> (Info -> m Statement)) -> (Info -> m Statement) +invokeMemo fn e x i = + do let def = x e + r <- lookupMemo fn (Just e) Nothing i + val <- case r of + Nothing -> do val <- def i + case val of + Skip -> return Nothing + _ -> do num <- insertMemo fn (Just e) val (const ([],return val)) i + return $ Just num + Just val -> return $ Just val + case val of + Nothing -> return Skip + Just x -> cacheCall (fn ++ show (memoId x)) (stackField i) [] + +-- cacheCall :: String -> Info -> Statement +cacheCall :: Evalable m => String -> [(String,String)] -> [Value] -> m Statement +cacheCall fn i lst = do + fl@(PrettyFlags pf) <- getFlags + return $ SHook (fn ++ "(" ++ intercalate "," (map snd (fixArgs pf) ++ (map snd i) ++ (map (rpx 0 fl) lst)) ++ ");") + +cacheStatement_ :: Evalable m => String -> (Int -> ([(String,Type,Value)], m Statement)) -> Info -> m Statement +cacheStatement_ fn sm i = + do let (olst,ss) = sm 0 + fl <- getFlags + let ni = i { stackField = stackField i ++ (map (\(n,t,v) -> (rpx 0 fl t, n)) olst) } + s <- ss + x <- lookupMemo fn Nothing (Just s) ni + val <- case x of + Nothing -> do case s of + Skip -> return Nothing + _ -> do num <- insertMemo fn Nothing s sm i + return $ Just num + Just r -> return $ Just r + case val of + Nothing -> return Skip + Just x -> do let (lst,_) = sm (memoId x) + cacheCall (fn ++ show (memoId x)) (stackField i) (map (\(n,t,v) -> v) lst) + +cacheStatement :: Evalable m => String -> Statement -> Info -> m Statement +cacheStatement fn s i = cacheStatement_ fn (const ([],return s)) i + +{- +newtype MemoWrapper m a = MemoWrapper { runMemoWrapper :: m a } + +instance MonadT MemoWrapper where + lift = MemoWrapper + treturn = MemoWrapper . return + tbind (MemoWrapper a) f = MemoWrapper (a >>= (\x -> runMemoWrapper (f x))) + +instance FMonadT MemoWrapper where + tmap' d1 _d2 g f = MemoWrapper . f . fmapD d1 g . runMemoWrapper +-} + +class Memoable m where + memox :: String -> Info -> (Int -> ([(String,Type,Value)],m)) -> m + +instance Memoable m => Memoable ((Type,Value) -> m) where + memox name info f = \(typ,val) -> + case typ of + THook "void" -> memox name info (\n -> let (lst,m) = f n in (lst,m (typ,Var "WTF??"))) + _ -> memox name info (\n -> let (lst,m) = f n in (((nam n lst,typ,val):lst),m (typ,Var $ nam n lst))) + where nam n lst = "arg_" ++ name ++ "_" ++ show n ++ "_" ++ show (length lst) + +{- +instance Memoable m => Memoable (Value -> m) where + memox name info f = \val -> memox name info (\n -> let (lst,m) = f n in (((nam n lst,Pointer (THook "void"),val):lst),m (Var $ nam n lst))) + where nam n lst = "arg_" ++ name ++ "_" ++ show n ++ "_" ++ show (length lst) +-} + +instance Evalable m => Memoable (m Statement) where + memox name info f = cacheStatement_ ("cached_" ++ name) f info + +memo :: Memoable m => String -> Info -> m -> m +memo name info m = memox name info (const ([],m)) +-- memo name info m = m + + + +memoLoop super = + super { startTryH = invokeMemo "startTry" super startTryE + , bodyH = invokeMemo "body" super bodyE + , failH = invokeMemo "fail" super failE + , tryH = invokeMemo "try" super tryE + , addH = invokeMemo "add" super addE + , returnH = invokeMemo "ret" super returnE + , tryLH = invokeMemo "try_" super tryE_ + , initH = invokeMemo "init" super initE + , pushLeftH = invokeMemo "pushL" super pushLeft + , pushRightH = invokeMemo "pushR" super pushRight + , deleteH = invokeMemo "delete" super deleteE + , nextSameH = invokeMemo "nextSame" super nextSame + , nextDiffH = invokeMemo "nextDiff" super nextDiff + } + +cachedCommit :: Evalable m => Info -> m Statement +cachedCommit i = return (comment "begin commit") @>>>@ cacheStatement "commit" (commit i) i @>>>@ return (comment "end commit") + +cachedAbort :: Evalable m => Info -> m Statement +cachedAbort i = return (comment "begin abort") @>>>@ cacheStatement "abort" (abort i) i @>>>@ return (comment "end abort") + +-- cachedClone :: MemoM m => Info -> Info -> m Statement +cachedClone i j = return (comment "begin clone") @>>>@ cacheStatement "clone" (cloneIt i j) i @>>>@ return (comment "end clone") +-- cachedClone i j = return $ clone i j + +rReaderT x m = runMemoReaderT x m +#else + +cachedCommit x = return $ (comment "begin commit" >>> commit x >>> comment "end commit") +cachedAbort x = return $ (comment "begin abort" >>> abort x >>> comment "end abort") +cachedClone i j = return $ (comment "begin clone" >>> cloneIt i j >>> comment "end clone") +memo :: String -> Info -> m -> m +memo name info m = m +memoLoop = id +rReaderT = runReaderT +#endif +-------------------------------------------------------------------------------- + +-------------------------------------------------------------------------------- +data SeqPos = OutS | FirstS | SecondS + deriving (Show) + +seqSwitch :: ReaderM SeqPos m => m a -> m a -> m a +seqSwitch l r = + do flag <- ask + case flag of + FirstS -> l + SecondS -> r + +numSwitch n = + do flag <- ask + n flag + +(l1,l2) @++@ (l3,l4) = (l1 ++ l3, l2 ++ l4) + + +ref_count = \i -> estate i @=> "ref_count" +ref_countx = \i s -> estate i @=> ("ref_count_" ++ s) +ref_count_type = THook "int" +-------------------------------------------------------------------------------- + +-- cloneBase i = resetClone $ info { baseTstate = estate i @=> "parent" } +cloneBase i = i { baseTstate = estate i @=> "parent" } + + +(@>>>@) :: Evalable m => m Statement -> m Statement -> m Statement +(@>>>@) x y = do s1 <- x + s2 <- y + return (s1 >>> s2) + +f @$ x = x >>= return . f +mf @. x = mf >>= \f -> f @$ x + +-------------------------------------------------------------------------------- +-- PRINTING +-------------------------------------------------------------------------------- + +-- printTreeStateType :: Monad m => Eval m -> String +printTreeStateType e = + {- render $ pretty $-} Struct "TreeState" [ (ty,name) | (name,ty,_) <- treeState_ e ] + +-- printEvalStateType :: Monad m => Eval m -> String +printEvalStateType e = + {-render $ pretty $-} Struct "EvalState" [ (ty,name) | (name,ty,_) <- evalState_ e ] + +-- initEvalState :: Monad m => Info -> Eval m -> Doc +initEvalState i e = mconcat $ +-- {-vcat-} [SHook ((rp 0 ty) ++ " " ++ name ++ ";") | (name,ty,_) <- evalState_ e] + [SHook "struct EvalState evalState;"] + +initTreeState_ :: Monad m => Info -> Eval m -> m Statement +initTreeState_ i e = mseqs [ init i | (_,_,init) <- treeState_ e] + + +-- initIntArrays :: Eval m -> Doc +initIntArrays eval = + mconcat [ doc arr | arr <- nub $ sort $ intArraysE eval] + where doc arr + | [(_,"")] <- reads arr :: [(Int,String)] + = SHook ("vm->getSearchintVarArray(\"" ++ arr ++ "\", VAR_" ++ arr ++ ");") + | otherwise + = SHook ("vm->getintVarArray(\"" ++ arr ++ "\", VAR_" ++ arr ++ ");") + +-- initBoolArrays :: Eval m -> Doc +initBoolArrays eval = + mconcat [ doc arr | arr <- nub $ sort $ boolArraysE eval] + where doc arr + | [(_,"")] <- reads arr :: [(Int,String)] + = SHook ("vm->getSearchboolVarArray(\"" ++ arr ++ "\", VAR_" ++ arr ++ ");") + | otherwise + = SHook ("vm->getboolVarArray(\"" ++ arr ++ "\", VAR_" ++ arr ++ ");") + +-- declIntArrays :: Eval m -> Doc +declIntArrays eval = + mconcat [ doc arr | arr <- nub $ sort $ intArraysE eval] + where doc arr + | [(_,"")] <- reads arr :: [(Int,String)] + = SHook ("vector VAR_" ++ arr ++ ";") + | otherwise + = SHook ("vector VAR_" ++ arr ++ ";") + +declBoolArrays eval = + mconcat [ doc arr | arr <- nub $ sort $ boolArraysE eval] + where doc arr + | [(_,"")] <- reads arr :: [(Int,String)] + = SHook ("vector VAR_" ++ arr ++ ";") + | otherwise + = SHook ("vector VAR_" ++ arr ++ ";") + +-- initIntVars :: Eval m -> Doc +initIntVars eval = + mconcat [ doc var | var <- nub $ sort $ intVarsE eval] + where doc var = SHook ("vm->getintVarIndex(\"" ++ var ++ "\", VAR_" ++ var ++ ");") + +-- declIntVars :: Eval m -> Doc +declIntVars eval = + mconcat [ doc var | var <- nub $ sort $ intVarsE eval] + where doc var = SHook ("int VAR_" ++ var ++ ";") + +corefn :: (Evalable m, WriterM ProgramString m) => Eval m -> m Statement +corefn eval = + do fl <- getFlags + sInitE <- inite (map (\(a,_,b) -> (a,b)) (evalState_ eval)) info + sInitS <- inits eval info + sTry <- startTryE eval info + sNext <- nextSame eval info + sBody <- bodyE eval info + return $ seqs [ -- SHook $ "\n status = " ++ rpx 0 fl RootSpace ++ "->status();" + SHook "\n" + , SHook " st->queue = new std::vector();" + , sInitE + , sInitS + , sTry + , Block (SHook " while (!st->queue->empty())") $ seqs + [ SHook " /* pop first element */" + , SHook " TreeState popped_estate = st->queue->back();" + , SHook " st->queue->pop_back();" + , sNext + , SHook " st->estate = popped_estate;" + , sBody + ] + ] + +mainfn :: (Evalable m, WriterM ProgramString m) => Eval m -> m Statement +mainfn eval = + do core <- corefn eval + return $ seqs [ SHook ("\n\nvoid eval(" ++ spacetype ModeFZ ++ "* root, VarMap* vm, Printer* p) {") + , SHook "RootState rootState;" + , SHook "RootState *st = &rootState;" + , initIntVars eval + , initBoolArrays eval + , initIntArrays eval + , core + , SHook "}" + ] + +cppfn :: (Evalable m, WriterM ProgramString m) => Eval m -> m Statement +cppfn eval = + do core <- corefn eval + return $ seqs [ SHook ("\n\nvoid eval(" ++ spacetype ModeGecode ++ "* root, Printer *p) {") + , SHook "RootState rootState;" + , SHook "RootState *st = &rootState;" + , SHook (" mgr.root(*root);") + , core + , SHook "}" + ] + +mcpfn :: (Evalable m, WriterM ProgramString m) => Eval m -> m Statement +mcpfn eval = + do core <- corefn eval + return $ seqs [ SHook ("\n\nvoid eval(" ++ spacetype ModeMCP ++ "* root) {") + , SHook "RootState rootState;" + , SHook "RootState *st = &rootState;" + , core + , SHook "}" + ] + +typedecls :: Evalable m => Eval m -> m Statement +typedecls eval = + do fl <- getFlags + return $ seqs [ SHook ("struct EvalState;") + , SHook (render $ vcat $ [text "struct" <+> text name <> semi | Struct name _ <- fst $ structs eval]) + , SHook (render $ vcat $ map (prettyX fl) $ snd $ structs eval) + , SHook (rpx 1 fl $ printTreeStateType eval) + , SHook (rpx 1 fl $ printEvalStateType eval) + , SHook (render $ vcat $ map (prettyX fl) $ fst $ structs eval) + ] + +declRootState :: Eval m -> Statement +declRootState eval = seqs [ SHook "typedef struct {" + , SHook " TreeState estate;" + , SHook " std::vector *queue;" + , initEvalState info eval + , SHook "} RootState;" + ] + + +generate :: (Evalable m, WriterM ProgramString m) => Eval m -> m () +generate eval_ = + do fl <- getFlags + types <- typedecls eval + let header = seqs [ types + , declIntVars eval + , declBoolArrays eval + , declIntArrays eval + , declRootState eval + ] + main <- mainfn eval + tell $ mempty { main = Just main, header = header } + where eval = commentEval $ eval_ { treeState_ = rootEntry ++ treeState_ eval_ } + +generatemcp :: (Evalable m, WriterM ProgramString m) => Eval m -> m () +generatemcp eval_ = + do fl <- getFlags + types <- typedecls eval + let header = seqs [ types + , declRootState eval + ] + main <- mcpfn eval + tell $ mempty { main = Just main, header = header } + where eval = commentEval $ eval_ { treeState_ = rootEntry ++ treeState_ eval_ } + + +generatecpp :: (Evalable m, WriterM ProgramString m) => Eval m -> m () +generatecpp eval_ = + do fl <- getFlags + types <- typedecls eval + let header = seqs [ SHook "#include \"statemgr/varaccessor.hh\"" + , types + , declRootState eval + , SHook "StateMgr mgr;" + ] + main <- cppfn eval + tell $ mempty { main = Just main, header = header } + where eval = commentEval $ eval_ { treeState_ = rootEntry ++ treeState_ eval_ } + +rp n = render . nest n . pretty +rpx n s = render . nest n . prettyX s + +-------------------------------------------------------------------------------- +-- COMPOSITION COMBINATORS +-------------------------------------------------------------------------------- + +-- def vars = label vars lbV minV minD ($==) + +type MkEval m = Evalable m => Eval m -> State Int (Eval m) + +fixall :: Evalable m => MkEval m -> Eval m +fixall f = let this = fst $ runState 0 $ f this + in this + +data Search = forall t2. (FMonadT t2, MonadInfoT t2) => + Search { mkeval :: forall m t1. (HookStatsM m, MonadInfoT t1, FMonadT t1, Evalable m) => MkEval ((t1 :> t2) m) + , runsearch :: forall m x. (Evalable m) => t2 m x -> m x + } + +#ifndef NOMEMO +memoize :: Search +memoize = + Search { mkeval = return . memoLoop + , runsearch = runIdT + } +#endif + +{-# RULES + "L" L = unsafeCoerce + #-} +{- # RULES + "runL" runL = unsafeCoerce + #-} +{-# RULES + "unsafeCoerce/unsafeCoerce" unsafeCoerce . unsafeCoerce = unsafeCoerce + #-} +{-# RULES + "mmap/unsafeCoerce" mmap unsafeCoerce = unsafeCoerce + #-} +{-# RULES + "mapE/unsafeCoerce" mapE unsafeCoerce = unsafeCoerce + #-} + +(<@>) + :: Search -> Search -> Search +s1 <@> s2 = + case s1 of + Search { mkeval = evals1, runsearch = runs1 } -> + case s2 of + Search { mkeval = evals2, runsearch = runs2 } -> + Search {mkeval = + \super -> do { s2' <- evals2 $ mapE (L . L . mmap runL . runL) super + ; s1' <- evals1 (mapE runL s2') + ; return $ mapE (L . mmap L . runL) s1' + } + , runsearch = runs2 . runs1 . runL + } + + +data SearchCombiner = forall t1 t2. (FMonadT t1, FMonadT t2, MonadInfoT t1, MonadInfoT t2) => + SearchCombiner { runner :: forall m x. Evalable m => ((t1 :> t2) m) x -> m x + , elems :: [SearchCombinerElem t1 t2] + } + + +data SearchCombinerElem t1 t2 = + SearchCombinerElem { mapper :: forall t' m. (FMonadT t', MonadInfoT t', Evalable m) => Eval (t' ((t1 :> t2) m)) -> State Int (Eval (t' ((t1 :> t2) m))) + } + + +extractCombiners :: (Evalable m, FMonadT t', MonadInfoT t', FMonadT t1, MonadInfoT t1, FMonadT t2, MonadInfoT t2) => [SearchCombinerElem t1 t2] -> Eval (t' ((t1 :> t2) m)) -> State Int [(Eval (t' ((t1 :> t2) m)))] +extractCombiners [] _ = return [] +extractCombiners (SearchCombinerElem { mapper=m }:b) super = + do prev <- extractCombiners b super + next <- m super + return $ (next) : prev + + +buildCombiner [s] = + case s of + Search { mkeval = evals, runsearch = runs } -> + SearchCombiner { runner = runIdT . runs . runL + , elems = [SearchCombinerElem { mapper = liftM (mapE (mmap L . runL)) . evals . mapE (L . mmap runL) + }] + } +buildCombiner (s:ss) = + case s of + Search { mkeval = evals, runsearch = runs } -> + case buildCombiner ss of + SearchCombiner { runner = runner, elems = elems } -> + SearchCombiner { runner = runner . runs . runL + , elems = SearchCombinerElem { mapper = liftM (mapE (mmap L . runL)) . evals . mapE (L . mmap runL) + } : liftSearchCombinerElems elems + } + + + +liftSearchCombinerElems :: (FMonadT t1, FMonadT t0, FMonadT t2, MonadInfoT t1, MonadInfoT t0, MonadInfoT t2) => [SearchCombinerElem t1 t2] -> [SearchCombinerElem t0 (t1 :> t2)] +liftSearchCombinerElems [] = [] +liftSearchCombinerElems (s:ss) = + case s of + SearchCombinerElem { mapper = m } -> + SearchCombinerElem { mapper = liftM (mapE (mmap L . runL)) . m . mapE (L . mmap runL) + } : liftSearchCombinerElems ss + +mmap :: (FMonadT t, MonadInfoT t, Monad m, Monad n, MonadInfo m) => (forall x. m x -> n x) -> t m a -> t n a +mmap f x = tmap' mfunctor mfunctor id f x + +mfunctor :: Monad m => FunctorD m +mfunctor = FunctorD { fmapD = \f m -> m >>= return . f } + +evalSStateT m s = runSStateT m s >>= \t -> case t of { Tup2 a _ -> return a } + +data FunctionDef = FunctionDef { funName :: String, funArgs :: [(Type,String)], funBody :: Statement } + +genfun :: PrettyFlags -> FunctionDef -> String +genfun fl f = rpx 0 fl $ + Block + (SHook ("void " ++ funName f ++ "(" ++ intercalate "," [ rpx 0 fl t ++ " " ++ an | (t,an) <- funArgs f ] ++ ")")) + (funBody f) + +data ProgramString = ProgramString { header :: Statement + , functions :: [FunctionDef] + , main :: Maybe Statement + , pcomment :: [String] + } + +transformProgram fn p = p { header = inliner fn (header p), functions = map (\f -> f { funBody = inliner fn (funBody f) }) (functions p), main = maybe Nothing (Just . inliner fn) (main p) } + +instance Monoid ProgramString where + mempty = ProgramString { header = Skip, functions = [], main = Nothing, pcomment = [] } + mappend p1 p2 = ProgramString { header = header p1 >>> header p2, functions = functions p1 ++ functions p2, main = maybe (main p2) Just (main p1), pcomment = pcomment p1 ++ pcomment p2 } + +instance DS.Semigroup ProgramString where + (<>) = mappend + +genprog :: PrettyFlags -> ProgramString -> String +genprog fl p = concatMap (\x -> "// " ++ x ++ "\n\n") (pcomment p) ++ rpx 0 fl (header p) ++ concatMap (\x -> "\n" ++ genfun fl x ++ "\n") (functions p) ++ maybe "" (rpx 0 fl) (main p) + +monadInfo :: MInfo -> (Int,Int,Int) +monadInfo (MInfo x) = + let total = sum $ map snd $ Map.toList x + identities = Map.findWithDefault 0 "Id" x + Map.findWithDefault 0 "IdT" x + zippers = Map.findWithDefault 0 ":>" x + in (total - (identities+zippers),zippers,identities) + +getgen :: (Evalable m, WriterM ProgramString m) => Eval m -> m () +getgen x = do + fl <- getFlags + case genMode fl of + ModeFZ -> generate x + ModeMCP -> generatemcp x + ModeGecode -> generatecpp x + ModeUnk -> error "Unknown generator?" + +search' :: GenMode -> Search -> ProgramString +#ifdef NOMEMO +search' fl s = + case s of + Search { mkeval = evals, runsearch = runs } -> do + let fevals = fixall $ evals + in case runId $ runGenModeT fl $ runHookStatsT $ evalSStateT Map.empty $ unVarInfoT $ runs $ runWriterT $ getgen $ mapE runL $ fevals + of (((_,eval)),n) -> let cmt = show $ monadInfo $ minfo $ canBranch $ fevals + in eval { pcomment = ["Combinator stats: " ++ cmt, "Hook calls: " ++ show n]} +#else +refType t n = + case t of + x | last x == '*' -> n + "int" -> n + "bool" -> n + _ -> '&' : n + +search' fl s = + case memoize <@> s of + Search { mkeval = evals, runsearch = runs } -> do + let fevals = fixall $ evals + in case runId $ runGenModeT fl $ runHookStatsT $ runMemoT $ evalSStateT Map.empty $ unVarInfoT $ runs $ runWriterT $ getgen $ mapE runL $ fevals + of (((_,eval),t),n) -> let {- m = inlineMap t -} + p = {- transformProgram m -} (mempty { functions = map toFun (filter (not . needInline) t) } `mappend` eval) + cmt = show $ monadInfo $ minfo $ canBranch $ fevals + in p { pcomment = ["Combinator stats: " ++ cmt, "Hook calls: " ++ show n]} + where toFun (key,val) = FunctionDef { funName = memoFn key ++ show (memoId val), funArgs = mm (map (\x -> (THook (fst x), refType (fst x) $ snd x)) (memoFields val)), funBody = simplify (memoCode val) } + mm = ((fixArgs fl) ++) + +fixArgs ModeMCP = [ -- (Pointer (THook "Gecode::SpaceStatus"), "status") + (Pointer (THook "RootState"), "st") + ] +fixArgs _ = [ -- (Pointer (THook "Gecode::SpaceStatus"), "status") + (Pointer (THook "RootState"), "st"), + (Pointer (THook "Printer"),"p") + ] + +needInline (key,val) = False {- (memoUsed val <= 1) -} +{-needInline (key,val) = + let code = simplify $ memoCode val + res = (memoUsed val <= 1) || (case code of { Seq _ _ -> False; Block _ _ -> False; Skip -> True; _ -> True }) + in trace ("needInline? " ++ show code ++ " -> " ++ show res ++ "\n") res +-} +-- needInline _ = False + +inlineMap fl fns = do + lst <- mapM (\(key,val) -> cacheCall (memoFn key ++ show (memoId val)) (memoFields val) [] >>= \c -> return (c, memoCode val)) [ x | x <- fns, needInline x ] + return $ Map.fromList lst + +#endif + + +search :: Search -> String +search s = genprog (PrettyFlags ModeMCP) (search' ModeMCP s) diff --git a/src/Control/Search/GeneratorInfo.hs b/src/Control/Search/GeneratorInfo.hs new file mode 100644 --- /dev/null +++ b/src/Control/Search/GeneratorInfo.hs @@ -0,0 +1,120 @@ +module Control.Search.GeneratorInfo where + +import Control.Search.Language + +type TreeState = Value +type EvalState = Value +space i = baseTstate i @-> "space" + +data Info = Info { baseTstate :: TreeState + , path :: TreeState -> TreeState + , abort_ :: [Statement -> Statement] + , commit_ :: [Statement -> Statement] + , old :: Info + , clone :: Info -> Statement + , field :: String -> Value + , stackField :: [(String,String)] + , treeStateType :: Type + , evalStateType :: Type + } + +(@@) :: Ordering -> Ordering -> Ordering +EQ @@ x = x +x @@ _ = x + +instance Ord Info where + compare a b = compare (baseTstate a) (baseTstate b) + @@ compare (path a $ baseTstate a) (path b $ baseTstate b) + @@ compare (map ($ Skip) $ abort_ a) (map ($ Skip) $ abort_ b) + @@ compare (map ($ Skip) $ commit_ a) (map ($ Skip) $ commit_ b) + @@ compare (clone a (resetClone a)) (clone b (resetClone b)) + +instance Eq Info where + a == b = case compare a b of { EQ -> True; _ -> False } + +type Field = String + +tstate i = path i (baseTstate i) +tstate_type i = treeStateType i + +-- VHook ("/* " ++ show (estate_type i) ++ " */ null") +estate i = case estate_type i of + Pointer (SType (Struct "EvalState" _)) -> Ref (Var $ "st->evalState") + Pointer (THook "EvalState") -> Ref (Var "st->evalState") + _ -> (tstate i) @-> "evalState" + +estate_type i = evalStateType i + +withCommit i f = i { commit_ = f : commit_ i } +onAbort i stmt = i { abort_ = (stmt >>>) : abort_ i } +onCommit i stmt = i `withCommit` (stmt >>>) +onCommit' i stmt = i `withCommit` (>>> stmt) +withPath i p e t = i { path = p . path i + , old = withPath (old i) p e t + , evalStateType = e + , treeStateType = t + } +withBase i str = i { baseTstate = Var str, stackField = ("TreeState",str):(stackField i) } + +withClone i stmt = i { clone = \j -> clone i j >>> stmt (i { baseTstate = baseTstate j }) } +withField i (f,g) = i { field = \f' -> if f' == f then g i else field i f' } + +resetPath i = i { path = id + , old = resetPath $ old i + , treeStateType = Pointer (THook "TreeState") + , evalStateType = Pointer (THook "EvalState") + } +resetCommit i = i { commit_ = [const $ comment "Delete-resetCommit" >>> (Delete $ space i)] } +shiftCommit i = i { commit_ = tail $ commit_ i } +resetAbort i = i { abort_ = [const $ comment "Delete-resetAbort" >>> (Delete $ space i)] } +shiftAbort i = i { abort_ = tail $ abort_ i } +resetClone i = i { clone = const Skip } + +resetInfo i = i { path = id + , old = resetInfo $ old i + , commit_ = [ const $ comment "Delete-resetInfo-commit_" >>> (Delete $ space i) ] + , abort_ = [ const $ comment "Delete-resetInfo-abort_" >>> (Delete $ space i), const (comment "reset")] + , clone = const Skip + , treeStateType = Pointer (THook "TreeState") + , evalStateType = Pointer (THook "EvalState") + } + +mkInfo name = + let i = Info { baseTstate = Var name + , path = id + , abort_ = [const $ comment "Delete-mkInfo-abort_" >>> (Delete $ space i)] + , commit_ = [const $ comment "Delete-mkInfo-commit_" >>> (Delete $ space i)] + , old = i + , clone = const Skip + , field = \f -> error ("unknown field `" ++ f ++ "'") + , stackField = [] + , treeStateType = Pointer (THook "TreeState") + , evalStateType = Pointer (THook "EvalState") + } + in i + +info = mkInfo "st->estate" + +newinfo i n = + Info { baseTstate = Var $ "nstate" ++ n + , path = id + , abort_ = [const Skip] + , commit_ = [const Skip] + , old = resetPath i + , clone = const Skip + , field = \f -> error ("unknown field `" ++ f ++ "'") + , stackField = [("TreeState","nstate" ++ n)] + , treeStateType = Pointer (THook "TreeState") + , evalStateType = Pointer (THook "EvalState") + } + +commit i = go $ commit_ i + where go [] = Skip + go (f:fs) = f (go fs) +abort i = go $ abort_ i + where go [] = Skip + go (f:fs) = f (go fs) + +primClone i = \j -> space j <== Clone (space i) + +cloneIt i j = primClone i j >>> clone i j diff --git a/src/Control/Search/Language.hs b/src/Control/Search/Language.hs new file mode 100644 --- /dev/null +++ b/src/Control/Search/Language.hs @@ -0,0 +1,538 @@ +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE NoMonomorphismRestriction #-} +{-# LANGUAGE CPP #-} + +module Control.Search.Language where + +import Text.PrettyPrint +import Data.Monoid hiding ((<>)) +import Prelude hiding ((<>)) +import qualified Data.Semigroup as DS +import Data.Int +import qualified Data.Map as Map +import Data.Map (Map) + + +spacetype ModeFZ = "FlatZincSpace" +spacetype ModeGecode = "State" +spacetype ModeMCP = "MCPProgram" + +xsspace fl@(PrettyFlags ModeFZ) x str = prettyX fl (PField x str) +xsspace fl@(PrettyFlags ModeMCP) x str = prettyX fl (PField x str) +xsspace fl@(PrettyFlags ModeGecode) x str = text "((VarAccessorSpace*)msg.space(" <> prettyX fl x <> text "))->" <> text str + +instance Monoid Statement where + mempty = Skip + mappend = (>>>) + +instance DS.Semigroup Statement where + (<>) = (>>>) + +data GenMode = ModeUnk | ModeGecode | ModeFZ | ModeMCP + deriving Eq + +data PrettyFlags = PrettyFlags { genMode :: GenMode } + deriving Eq + +renderVar :: PrettyFlags -> Value -> Doc +renderVar f@(PrettyFlags { genMode = ModeFZ }) x = case x of + (AVarElem vs s i) -> xsspace f s "iv" <> brackets (text "VAR_" <> text vs <> brackets (pr_ i)) + (AVarSize vs s) -> text "VAR_" <> text vs <> text ".size()" + (BAVarElem vs s i) -> xsspace f s "bv" <> brackets (text "VAR_" <> text vs <> brackets (pr_ i)) + (BAVarSize vs s) -> text "VAR_" <> text vs <> text ".size()" + (IVar vs s) -> xsspace f s "iv" <> brackets (text "VAR_" <> text vs) + where pr_ :: Value -> Doc + pr_ = prettyX f +renderVar f@(PrettyFlags { genMode = ModeGecode }) x = case x of + (AVarElem vs s i) -> xsspace f s "va.iv" <> parens (text "idx" <> parens (xsspace f s "va.map()" <> text ",\"" <> text vs <> text "\"") <> text "+" <> pr_ i) + (AVarSize vs s) -> text "size" <> parens (xsspace f s "va.map()" <> text ",\"" <> text vs <> text "\"") + (BAVarElem vs s i) -> xsspace f s "va.bv" <> parens (text "idx" <> parens (xsspace f s "va.map()" <> text ",\"" <> text vs <> text "\"") <> text "+" <> pr_ i) + (BAVarSize vs s) -> text "size" <> parens (xsspace f s "va.map()" <> text ",\"" <> text vs <> text "\"") + (IVar vs s) -> xsspace f s "va.iv" <> parens (text "idx" <> parens (xsspace f s "va.map()" <> text ",\"" <> text vs <> text "\"")) + where pr_ :: Value -> Doc + pr_ = prettyX f +renderVar f@(PrettyFlags { genMode = ModeMCP }) x = case x of + (AVarElem vs s i) -> xsspace f s vs <> brackets (pretty i) + (AVarSize vs s) -> xsspace f s vs <> text ".size()" + (BAVarElem vs s i) -> xsspace f s vs <> brackets (pretty i) + (BAVarSize vs s) -> xsspace f s vs <> text ".size()" + (IVar vs s) -> xsspace f s vs + +renderVar f@(PrettyFlags { genMode = ModeUnk }) _ = error "Cannot generate variable without render mode!" + + +class Pretty x where + prettyX :: PrettyFlags -> x -> Doc + pretty :: x -> Doc + prettyX _ = pretty + pretty = prettyX (PrettyFlags { genMode = ModeUnk }) + +data Struct = Struct String [(Type,String)] deriving (Show, Eq, Ord) + +instance Pretty Struct where + prettyX x (Struct name fields) = + text "struct" <+> text name <+> text "{" + $+$ nest 2 (vcat [prettyX x ty <+> text f <> text ";" | (ty,f) <- fields]) + $+$ text "};" + + +data Type = Pointer Type + | SpaceType + | Int + | Bool + | Union [(Type,String)] + | SType Struct + | THook String + deriving (Show, Eq, Ord) + +data Value = IVal Int32 + | BVal Bool + | RootSpace + | Minus Value Value + | Plus Value Value + | Mult Value Value + | Div Value Value + | Mod Value Value + | Abs Value + | Var String + | Ref Value + | Deref Value + | Clone Value + | Field String String + | Field' Value String + | PField Value String + | Lt Value Value + | Gq Value Value + | Gt Value Value + | Eq Value Value + | BaseContinue + | And Value Value + | Or Value Value + | Not Value + | VHook String + | Max Value Value + | AVarElem String Value Value + | AVarSize String Value + | BAVarElem String Value Value + | BAVarSize String Value + | IVar String Value + | MinDom Value + | MaxDom Value + | Degree Value + | WDegree Value + | UbRegret Value + | LbRegret Value + | Median Value + | Random + | Null + | New Struct + | Base + | Cond Value Value Value + | Assigned Value + | Dummy Int + | MaxVal + | MinVal + deriving (Show, Eq, Ord) + +instance Num Value where + (-) = Minus + fromInteger = IVal . fromInteger + (+) = Plus + (*) = Mult + abs = Abs + signum = error "signum is not defined for Value" + +divValue (IVal x) (IVal y) = IVal (x `div` y) +divValue x y = Div x y + +true = BVal True +false = BVal False +(&&&) = And +(|||) = Or +(@>) = Gt +(@>=) = Gq +x @<= y = y `Gq` x +(@==) = Eq +(@->) = Field' +(@=>) = PField +(@<) = Lt +lex cmps l1 l2 = foldr (\(x,y,cmp) r -> (x `cmp` y) ||| ((x @== y) &&& r)) false (zip3 l1 l2 cmps) + +simplValue :: Value -> Value +simplValue (Cond c t e) = + let c' = simplValue c + t' = simplValue t + e' = simplValue e + in case (c',t',e') of + (BVal True, _, _) -> t' + (BVal False, _, _) -> e' + _ | t' == e' -> t' + _ -> Cond c' t' e' +simplValue (Minus (IVal x) (IVal y)) = IVal (x - y) +simplValue (Lt x y) = Lt (simplValue x) (simplValue y) +simplValue (Gq x y) = Gq (simplValue x) (simplValue y) +simplValue (And x y) = + let x' = simplValue x + y' = simplValue y + in case (x',y') of + (x, (BVal True)) -> x + (x, (BVal False)) -> BVal False + _ -> And x' y' +simplValue (Not x) = + let x' = simplValue x + in case x' of + (BVal True) -> BVal False + (BVal False) -> BVal True + _ -> Not x' +simplValue (PField (Ref x) f) = Field' (simplValue x) f +simplValue v = v + +instance Pretty Type where + prettyX x (Pointer t) = prettyX x t <> text "*" + prettyX x SpaceType = text $ spacetype (genMode x) + prettyX x Int = text "int" + prettyX x Bool = text "bool" + prettyX x (Union fields) = + text "union" <+> text "{" + $+$ nest 2 (vcat [prettyX x ty <+> text f <> text ";" | (ty,f) <- fields]) + $+$ text "}" + prettyX x (SType (Struct name fields)) = + text name + prettyX x (THook str) = + text str + +instance Pretty Value where + prettyX x = prettyX_ x . simplValue + where + prettyX_ :: PrettyFlags -> Value -> Doc + prettyX_ _ (Cond c t e) = pr_ c <+> text "?" <+> pr_ t <+> text ":" <+> pr_ e + prettyX_ _ Base = text "" + prettyX_ _ Null = text "NULL" + prettyX_ _ (IVal i) = int $ fromInteger $ toInteger i + prettyX_ _ (BVal True) = text "true" + prettyX_ _ (BVal False) = text "false" + prettyX_ _ (Abs x) = text "abs" <> parens (pr_ x) + prettyX_ fl RootSpace = case (genMode fl) of + ModeFZ -> text "root" + ModeGecode -> text "mgr.root()" + ModeMCP -> text "root" + prettyX_ _ (Minus v1 v2) = pr_ v1 <+> text "-" <+> pr_ v2 + prettyX_ _ (Plus v1 v2) = pr_ v1 <+> text "+" <+> pr_ v2 + prettyX_ _ (Mult v1 v2) = pr_ v1 <+> text "*" <+> pr_ v2 + prettyX_ _ (Div v1 v2) = parens (pr_ v1) <+> text "/" <+> parens (pr_ v2) + prettyX_ _ (Mod v1 v2) = parens (pr_ v1) <+> text "%" <+> parens (pr_ v2) + prettyX_ _ (Ref x) = parens $ text "&" <> parens (pr_ x) + prettyX_ _ (Deref x) = parens $ text "*" <> parens (pr_ x) + prettyX_ _ (Var x) = text x + prettyX_ f (Clone x) = text ("static_cast<" ++ spacetype (genMode f) ++ "*>(") <> pr_ x <> text "->clone(true))" + -- prettyX_ (Clone x) = text ("static_cast<" ++ spacetype ++ "*>(") <> pretty_ x <> text "->clone(false))" + prettyX_ _ (Field r f) = text r <> text "." <> text f + prettyX_ _ (Field' r f) = pr_ r <> text "." <> text f +-- prettyX_ (PField (Field' (Var "estate") "evalState") f) = text f +-- prettyX_ (PField (Field' (Var "nstate") "evalState") f) = text f +-- prettyX_ (PField (Field' (Var _) "evalState") f) = text f + prettyX_ _ (PField r f) = pr_ r <> text "->" <> text f + prettyX_ _ (Lt x y) = parens (pr_ x) <+> text "<" <+> parens (pr_ y) + prettyX_ _ (Gq x y) = parens (pr_ x) <+> text ">=" <+> parens (pr_ y) + prettyX_ _ (Gt x y) = parens (pr_ x) <+> text ">" <+> parens (pr_ y) + prettyX_ _ (Eq x y) = parens (pr_ x) <+> text "==" <+> parens (pr_ y) + prettyX_ _ BaseContinue = text "!st->queue->empty()" + prettyX_ _ (And x y) = parens (pr_ x) <+> text "&&" <+> parens (pr_ y) + prettyX_ _ (Or x y) = parens (pr_ x) <+> text "||" <+> parens (pr_ y) + prettyX_ _ (Not x) = text "!" <> parens (pr_ x) + prettyX_ _ (VHook s) = text s + prettyX_ _ (Max x y) = text "max" <> parens (pr_ x <> text "," <> pr_ y) + prettyX_ e v@(AVarElem _ _ _) = renderVar e v + prettyX_ e v@(AVarSize _ _) = renderVar e v + prettyX_ e v@(BAVarElem _ _ _) = renderVar e v + prettyX_ e v@(BAVarSize _ _) = renderVar e v + prettyX_ e v@(IVar _ _) = renderVar e v + prettyX_ _ (MinDom v) = pr_ v <> text ".min()" + prettyX_ _ (MaxDom v) = pr_ v <> text ".max()" + prettyX_ _ (Degree v) = pr_ v <> text ".degree()" + prettyX_ _ (WDegree v) = pr_ v <> text ".afc()" -- aka accumulated failure count + prettyX_ _ (UbRegret v) = pr_ v <> text ".regret_max()" + prettyX_ _ (LbRegret v) = pr_ v <> text ".regret_min()" + prettyX_ _ (Median v) = pr_ v <> text ".med()" + prettyX_ _ MaxVal = text "Gecode::Int::Limits::max" + prettyX_ _ MinVal = text "Gecode::Int::Limits::min" + prettyX_ _ Random = text "rand()" + prettyX_ _ (New (Struct name _)) = text "new" <+> text name + prettyX_ _ (Assigned var) = pr_ var <> text ".assigned()" + pr :: Value -> Doc + pr = prettyX x + pr_ :: Value -> Doc + pr_ = prettyX_ x + +data Constraint = EqC Value Value + | NqC Value Value + | LtC Value Value + | LqC Value Value + | GtC Value Value + | GqC Value Value + | TrueC + | FalseC + deriving (Eq, Ord, Show) + +($==) = EqC +($/=) = NqC +($<) = LtC +($<=) = LqC +($>) = GtC +($>=) = GqC + +neg (EqC x y) = NqC x y +neg (NqC x y) = EqC x y +neg (LtC x y) = GqC x y +neg (LqC x y) = GtC x y +neg (GtC x y) = LqC x y +neg (GqC x y) = LtC x y + +instance Pretty Constraint where + prettyX f (EqC x y) = + prettyX f x <> text "," <> text "IRT_EQ" <> text "," <> prettyX f y + prettyX f (NqC x y) = + prettyX f x <> text "," <> text "IRT_NQ" <> text "," <> prettyX f y + prettyX f (LtC x y) = + prettyX f x <> text "," <> text "IRT_LE" <> text "," <> prettyX f y + prettyX f (LqC x y) = + prettyX f x <> text "," <> text "IRT_LQ" <> text "," <> prettyX f y + prettyX f (GtC x y) = + prettyX f x <> text "," <> text "IRT_GR" <> text "," <> prettyX f y + prettyX f (GqC x y) = + prettyX f x <> text "," <> text "IRT_GQ" <> text "," <> prettyX f y + prettyX f TrueC = error "true constraint can't be posted directly" + prettyX f FalseC = error "false constraint can't be posted directly" + + +data Statement = IfThenElse Value Statement Statement + | Push Value + | Skip + | Seq Statement Statement + | Assign Value Value + | Abort + | Print Value [String] + | SHook String + | Post Value Constraint + | Fold String Value Value Value (Value -> Value) (Value -> Value -> Value) + | IFold String Value Value Value (Value -> Value) (Value -> Value -> Value) + | BFold String Value Value Value (Value -> Value) (Value -> Value -> Value) + | BIFold String Value Value Value (Value -> Value) (Value -> Value -> Value) +-- | MFold String [(Value, Value->Value)] ([Value] -> [Value] -> Value) + | Delete Value + | Block Statement Statement + | DebugOutput String + | DebugValue String Value + deriving (Eq,Ord,Show) + +inliner :: (Statement -> Maybe Statement) -> Statement -> Statement +inliner f s = + case f s of + Just x -> inliner f x + Nothing -> case s of + IfThenElse v s1 s2 -> IfThenElse v (inliner f s1) (inliner f s2) + Seq s1 s2 -> Seq (inliner f s1) (inliner f s2) + Block s1 s2 -> Block s1 (inliner f s2) + _ -> s + +instance Ord (Value -> Value) where + compare a b = compare (a (Dummy 0)) (b (Dummy 0)) + +instance Eq (Value -> Value) where + a == b = (a (Dummy 1)) == (b (Dummy 1)) + +instance Show (Value -> Value) where + show a = show (a (Dummy 1)) + +instance Ord (Value -> Value -> Value) where + compare a b = compare (a (Dummy 2) (Dummy 3)) (b (Dummy 2) (Dummy 3)) + +instance Eq (Value -> Value -> Value) where + a == b = (a (Dummy 4) (Dummy 5)) == (b (Dummy 4) (Dummy 5)) + +instance Show (Value -> Value -> Value) where + show a = show (a (Dummy 1) (Dummy 2)) + +comment str = SHook ("// " ++ str) + +dec var = Assign var (var - 1) +inc var = Assign var (var + 1) +(>>>) = Seq +(<==) = Assign +assign = flip Assign +ifthen c t = IfThenElse c t Skip +seqs = foldr (>>>) Skip + +simplStmt :: Statement -> Statement +simplStmt (IfThenElse c t e) + = let c' = simplValue c + t' = simplStmt t + e' = simplStmt e + in go c' t' e' + where go (BVal True) t e = t + go (BVal False) t e = e + go c t e | t == e = t + go c Skip e = simplStmt $ IfThenElse (Not c) e t + go c1 (IfThenElse c2 t2 e2) e1 + | e1 == e2 = simplStmt $ IfThenElse (c1 &&& c2) t2 e1 + go c t e = IfThenElse c t e +simplStmt (Assign x y) | x==y = Skip +simplStmt (Seq Skip a) = simplStmt a +simplStmt (Seq a Skip) = simplStmt a +simplStmt s = s + +instance Pretty Statement where + prettyX x = prettyX_ . simplStmt + where + prettyX_ (Push tstate) = + text "st->queue->push_back" <> parens (pr tstate) <> text ";" + prettyX_ (IfThenElse c t Skip) = text "if" <+> parens (pr c) <+> text "{" $+$ nest 2 (pr t) $+$ text "}" + prettyX_ (IfThenElse c t e) = text "if" <+> parens (pr c) <+> text "{" $+$ nest 2 (pr t) $+$ text "} else {" $+$ nest 2 (pr_ e) $+$ text "}" + prettyX_ Skip = + empty + prettyX_ (Assign var (Minus val 1)) + | var == val + = pr var <> text "--;" + prettyX_ (Assign var (Plus val 1)) + | var == val + = pr var <> text "++;" + prettyX_ (Block s1 s2) = pr s1 <+> text "{" $+$ nest 2 (pr s2) $+$ text "}" + prettyX_ (Seq s1 s2) = + pr s1 $+$ pr s2 + prettyX_ (Assign x Null) = pr x <> text ";" + prettyX_ (Assign x y) = let y' = simplValue y + in if x == y' + then pr Skip + else pr x <+> text "=" <+> pr y' <> text ";" + prettyX_ Abort = + text "break;" + prettyX_ (Print space vs) = + (vcat $ map (\s -> text "std::cout << \"[\"; for (int i=0; i<" <> pr (AVarSize s space) <> text "; i++) { std::cout << " <> pr (AVarElem s space (Var "i")) <> text " << \" \"; }; std::cout << \"] \";") vs) <> text "std::cout << std::endl;" + prettyX_ (DebugOutput str) = + text "cout << " <> text (show str) <> text " << endl;" + prettyX_ (DebugValue str val) = + text "cout << " <> text (show $ str ++ ": ") <> text " << " <> pr val <> text " << endl;" + prettyX_ (SHook s) = + text s + prettyX_ (Post space FalseC) = pr space <> text "->fail();" + prettyX_ (Post space TrueC) = empty + prettyX_ (Post space c) = + text "rel(*" <> parens (pr space) <> text "," <> pr c <> text ");" + prettyX_ (Fold vars state space m0 metric better) = + let + pos = Field' state "pos" + size = AVarSize vars space + in + text "int best_pos = -1;" + $+$ pr (Assign pos 0) + $+$ text "for (int metric = " <> pr m0 <> text "; " <> pr (pos @< size ) <> text "; " <> pr pos <> text "++) {" + $+$ nest 2 (text "if" <+> parens (text "!" <> pr (AVarElem vars space pos) <> text ".assigned()") <+> text "{" + $+$ nest 2 ( text "int current_metric = " <> pr (metric (AVarElem vars space pos)) <> text ";" + $+$ pr (IfThenElse (Var "current_metric" `better` Var "metric") + (Assign (Var "metric") (Var "current_metric") >>> (Assign (Var "best_pos") pos)) + Skip + ) + ) + $+$ text "}" + ) + $+$ text "}" + $+$ pr (Assign pos (Var "best_pos")) + prettyX_ (IFold vars state space m0 metric better) = + let + pos = Field' state "pos" + size = AVarSize vars state + in + text "int best_pos = -1;" + $+$ pr (Assign pos 0) + $+$ text "for (int metric = " <> pr m0 <> text "; " <> pr (pos @< size ) <> text "; " <> pr pos <> text "++) {" + $+$ nest 2 (text "if" <+> parens (text "!" <> pr (AVarElem vars space pos) <> text ".assigned()") <+> text "{" + $+$ nest 2 ( text "int current_metric = " <> pr (metric pos) <> text ";" + $+$ pr (IfThenElse (Var "current_metric" `better` Var "metric") + (Assign (Var "metric") (Var "current_metric") >>> (Assign (Var "best_pos") pos)) + Skip + ) + ) + $+$ text "}" + ) + $+$ text "}" + $+$ pr (Assign pos (Var "best_pos")) + prettyX_ (BFold vars state space m0 metric better) = + let + pos = Field' state "pos" + size = BAVarSize vars space + in + text "int best_pos = -1;" + $+$ pr (Assign pos 0) + $+$ text "for (int metric = " <> pr m0 <> text "; " <> pr (pos @< size ) <> text "; " <> pr pos <> text "++) {" + $+$ nest 2 (text "if" <+> parens (text "!" <> pr (BAVarElem vars space pos) <> text ".assigned()") <+> text "{" + $+$ nest 2 ( text "int current_metric = " <> pr (metric (BAVarElem vars space pos)) <> text ";" + $+$ pr (IfThenElse (Var "current_metric" `better` Var "metric") + (Assign (Var "metric") (Var "current_metric") >>> (Assign (Var "best_pos") pos)) + Skip + ) + ) + $+$ text "}" + ) + $+$ text "}" + $+$ pr (Assign pos (Var "best_pos")) + prettyX_ (BIFold vars state space m0 metric better) = + let + pos = Field' state "pos" + size = BAVarSize vars space + in + text "int best_pos = -1;" + $+$ pr (Assign pos 0) + $+$ text "for (int metric = " <> pr m0 <> text "; " <> pr (pos @< size ) <> text "; " <> pr pos <> text "++) {" + $+$ nest 2 (text "if" <+> parens (text "!" <> pr (BAVarElem vars space pos) <> text ".assigned()") <+> text "{" + $+$ nest 2 ( text "int current_metric = " <> pr (metric pos) <> text ";" + $+$ pr (IfThenElse (Var "current_metric" `better` Var "metric") + (Assign (Var "metric") (Var "current_metric") >>> (Assign (Var "best_pos") pos)) + Skip + ) + ) + $+$ text "}" + ) + $+$ text "}" + $+$ pr (Assign pos (Var "best_pos")) +{- prettyX_ (MFold state metrics better) = + let + space = Field "estate" "space" + pos = Field state "pos" + cvar = CVar "get" space pos + size = VHook $ render $ pr space <> text "->" <> text "get" <> text "().size()" + acc_vars = [Var $ "metric" ++ show i | i <- [1..length metrics]] + cur_vars = [Var $ "current_metric" ++ show i | i <- [1..length metrics]] + init_list = hcat $ punctuate comma [pr v <+> text "=" <+> pretty z | (v,(z,_)) <- zip acc_vars metrics] + computations = vcat $ [text "int" <+> pr (Update var (f cvar))| (var,(_,f)) <- zip cur_vars metrics] + updates = foldl (>>>) Skip [Update v1 v2 | (v1,v2) <- zip acc_vars cur_vars] + in + text "int best_pos = -1;" + $+$ pr (Update pos 0) + $+$ text "for (int " <> init_list <> text "; " <> pr (pos @< size ) <> text "; " <> pr pos <> text "++) {" + $+$ nest 2 (text "if" <+> parens (text "!" <> pr cvar <> text ".assigned()") <+> text "{" + $+$ nest 2 ( computations + $+$ pr (IfThenElse (cur_vars `better` acc_vars) + (updates >>> (Update (Var "best_pos") pos)) + Skip + ) + ) + $+$ text "}" + ) + $+$ text "}" + $+$ pr (Update pos (Var "best_pos")) -} + prettyX_ (Delete value) = + text "delete" <+> pr value <> text ";" + pr :: Pretty x => x -> Doc + pr = prettyX x + pr_ :: Statement -> Doc + pr_ = prettyX_ + + +class Simplifiable a where + simplify :: a -> a + +instance Simplifiable Statement where + simplify = simplStmt + +instance Simplifiable Value where + simplify = simplValue diff --git a/src/Control/Search/Memo.hs b/src/Control/Search/Memo.hs new file mode 100644 --- /dev/null +++ b/src/Control/Search/Memo.hs @@ -0,0 +1,67 @@ +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE OverlappingInstances #-} + + +module Control.Search.Memo where + +import Control.Monatron.Monatron hiding (Abort, L, state, cont) +import Control.Monatron.Zipper hiding (i,r) +import Control.Monatron.IdT +import Control.Monatron.MonadInfo + +import Data.List (sort, nub, sortBy) +import Data.Maybe (fromJust) +import Data.Map (Map) +import qualified Data.Map as Map + +import Control.Search.Language +import Control.Search.GeneratorInfo +import Control.Search.SStateT + +data MemoKey = MemoKey { memoFn :: String, memoInfo :: Maybe Info, memoStack :: Maybe String, memoExtra :: Maybe (Map Int String), memoStatement :: Maybe Statement, memoParams :: [String] } + deriving (Eq, Ord) + +data MemoValue = MemoValue { memoId :: Int, memoCode :: Statement, memoUsed :: Int, memoFields :: [(String,String)] } + +data MemoInfo = MemoInfo { memoMap :: Map MemoKey MemoValue + , memoCount :: Int + , memoRead :: Map Int String + } + +initMemoInfo = MemoInfo { memoMap = Map.empty + , memoCount = 0 + , memoRead = Map.empty + } + +newtype MemoT m a = MemoT { unMemoT :: SStateT MemoInfo m a } + deriving (MonadT,StateM MemoInfo,FMonadT) + +instance MonadInfoT MemoT where + tminfo x = miInc "MemoT" (minfo $ runMemoT x) + +-- runMemoT :: Monad m => MemoT m a -> m (a,[(String,Statement,[(String,String)])]) +runMemoT m = do (Tup2 a s) <- runSStateT initMemoInfo (unMemoT m) + return (a, {- map (\(key,val) -> ( memoFn key ++ show (memoId val) + , comment (" fn=" ++ memoFn key ++ " stack='" ++ show (memoStack key) ++ "' extra='" ++ show (memoExtra key) ++ "' used: " ++ show (memoUsed val)) >>> memoCode val + , memoFields key + ) + ) $ -} sortBy (\(ka,va) (kb,vb) -> compare (memoId va) (memoId vb)) $ Map.toList (memoMap s) + ) + +-- runReaderMemoT :: (ReaderM r m, ReaderMemoM r (MemoT m)) => MemoT m a -> m (a,[(String,Statement,Info)]) +-- runReaderMemoT m = do val <- ask +-- runMemoT (memoLocal (const val) m) + +class Monad m => MemoM m where + getMemo :: m MemoInfo + setMemo :: MemoInfo -> m () + +instance Monad m => MemoM (MemoT m) where + getMemo = MemoT $ get + setMemo = MemoT . put + +instance (MemoM m, FMonadT t) => MemoM (t m) where + getMemo = lift $ getMemo + setMemo = lift . setMemo + diff --git a/src/Control/Search/MemoReader.hs b/src/Control/Search/MemoReader.hs new file mode 100644 --- /dev/null +++ b/src/Control/Search/MemoReader.hs @@ -0,0 +1,61 @@ +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} + +module Control.Search.MemoReader where + +import Control.Search.Memo + +import Data.Map (Map) +import qualified Data.Map as Map + +import Control.Monatron.Monatron hiding (Abort, L, state, cont) +import Control.Monatron.Zipper hiding (i,r) +import Control.Monatron.MonadInfo +import Control.Monatron.IdT + +newtype MemoReaderT r m a = MemoReaderT { unMemoReaderT :: Int -> ReaderT r m a } + +instance MonadT (MemoReaderT r) where + lift m = MemoReaderT $ const $ lift m + tbind (MemoReaderT i) f = MemoReaderT (\n -> i n `tbind` (\r -> unMemoReaderT (f r) n)) + +instance MonadInfoT (MemoReaderT r) where + tminfo x = miInc "MemoReaderT" (minfo $ runReaderT undefined (unMemoReaderT x 0)) + +instance FMonadT (MemoReaderT s) where + tmap' d1 d2 g f (MemoReaderT m) = MemoReaderT (tmap' d1 d2 g f . m) + +memoReaderT :: MemoM m => (e -> Int -> m a) -> MemoReaderT e m a +memoReaderT f = MemoReaderT (\n -> readerT (\e -> f e n)) + +deMemoReaderT :: MemoM m => e -> Int -> MemoReaderT e m a -> m a +deMemoReaderT e i (MemoReaderT f) = runReaderT e (f i) + +runMemoReaderT :: (MemoM m, Show s) => s -> MemoReaderT s m a -> m a +runMemoReaderT s r = + do x1 <- getMemo + let l = Map.size (memoRead x1) + setMemo x1 { memoRead = Map.insert l (show s) $ memoRead x1 } + r <- deMemoReaderT s l r + x2 <- getMemo + setMemo x2 { memoRead = Map.delete l $ memoRead x2 } + return r + +modelMemoReaderT :: (Show s, MemoM m) => Model (ReaderOp s) (MemoReaderT s m) +modelMemoReaderT (Ask g) = memoReaderT (\s n -> deMemoReaderT s n (g s)) +modelMemoReaderT (InEnv s a) = memoReaderT (\_ n -> deMemoReaderT s n (do { m1 <- getMemo + ; let oldVal = memoRead m1 Map.! n + ; setMemo m1 { memoRead = Map.insert n (show s) (memoRead m1) } + ; x <- a + ; m2 <- getMemo + ; setMemo m2 { memoRead = Map.insert n oldVal (memoRead m2) } + ; return x + } + ) + ) + +instance (MemoM m, Show s) => ReaderM s (MemoReaderT s m) where + readerModel = modelMemoReaderT + diff --git a/src/Control/Search/SStateT.hs b/src/Control/Search/SStateT.hs new file mode 100644 --- /dev/null +++ b/src/Control/Search/SStateT.hs @@ -0,0 +1,47 @@ +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} + +module Control.Search.SStateT ( + SStateT, sstateT, runSStateT, + Tup2(..), snd2, fst2 +) where + +import Control.Monad.Fix +import Control.Monatron.MonadT +import Control.Monatron.AutoInstances () +import Control.Monatron.Operations +import Control.Monatron.AutoLift + +data Tup2 a b = Tup2 a !b + +fst2 (Tup2 a _) = a +snd2 (Tup2 _ b) = b + +newtype SStateT s m a = SS { unSS :: s -> m (Tup2 a s) } + +sstateT :: (s -> m (Tup2 a s)) -> SStateT s m a +sstateT = SS + +runSStateT :: s -> SStateT s m a -> m (Tup2 a s) +runSStateT s m = unSS m s + +instance MonadT (SStateT s) where + lift m = SS $ \s -> m >>= \a -> return (Tup2 a s) + m `tbind` k = SS $ \s -> unSS m s >>= \ ~(Tup2 a s') -> unSS (k a) s' + +instance (MonadFix m) => MonadFix (SStateT s m) where + mfix f = SS $ \s -> mfix (runSStateT s . f . fst2) + +instance FMonadT (SStateT s) where + tmap' d1 _d2 g f (SS m) = SS (f . fmapD d1 (\(Tup2 x s) -> (Tup2 (g x) s)) . m) + +instance MMonadT (SStateT s) where + flift t = SS (\s -> fmap (\a -> (Tup2 a s)) t) + monoidalT (SS t) = SS (\s -> Comp $ fmap (\(Tup2 (SS t') s') -> t' s') (t s)) + +instance Monad m => StateM z (SStateT z m) where + stateModel = modelSStateT + +modelSStateT :: Monad m => AlgModel (StateOp s) (SStateT s m) +modelSStateT (Get g) = sstateT (\s -> return (Tup2 (g s) s)) +modelSStateT (Put s a) = sstateT (\_ -> return (Tup2 a s)) diff --git a/src/Control/Search/Stat.hs b/src/Control/Search/Stat.hs new file mode 100644 --- /dev/null +++ b/src/Control/Search/Stat.hs @@ -0,0 +1,186 @@ +{-# LANGUAGE Rank2Types #-} +{-# LANGUAGE FlexibleInstances #-} + +module Control.Search.Stat + ( appStat + , constStat + , depthStat + , nodesStat + , discrepancyStat + , solutionsStat + , failsStat + , timeStat + , notStat + , Stat(..), IValue, varStat + , (#>), (#<), (#>=), (#<=), (#=), (#/) + , readStat, evalStat + ) where + +import Text.PrettyPrint hiding (space) +import Prelude hiding ((<>)) + +import Control.Search.Language +import Control.Search.GeneratorInfo +import Control.Search.Memo +import Control.Search.Generator + +-- ========================================================================== -- +-- IVALUE +-- ========================================================================== -- + +type IValue = Info -> Value + +instance Show (Info -> Value) where + show x = "" +instance Eq (Info -> Value) where + x == y = False + +instance Num (Info -> Value) where + x - y = \i -> x i - y i + fromInteger x = \i -> IVal (fromInteger x) + x + y = \i -> x i + y i + x * y = \i -> x i * y i + abs x = \i -> abs (x i) + signum x = \i -> signum (x i) + +-- ========================================================================== -- +-- STATS +-- ========================================================================== -- + +data Stat = Stat (forall m. Evalable m => Eval m -> Eval m) (forall m. Evalable m => m IValue) + +instance Show Stat where + show _ = "" + +instance Eq Stat where + _ == _ = False + +readStat :: Evalable m => Stat -> m IValue +readStat (Stat _ r) = r + +evalStat :: Evalable m => Stat -> Eval m -> Eval m +evalStat (Stat e _) = e + +-- -------------------------------------------------------------------------- -- + +instance Num Stat where + x - y = liftStat (-) x y + fromInteger = constStat . fromInteger + x + y = liftStat (+) x y + x * y = liftStat (*) x y + abs = appStat abs + signum = appStat signum + +instance Bounded Stat where + maxBound = constStat $ const MaxVal + minBound = constStat $ const MinVal + +appStat :: (Value -> Value) -> Stat -> Stat +appStat f (Stat e r) = Stat e (r >>= \x -> return (\i -> f (x i))) + +liftStat :: (Value -> Value -> Value) -> Stat -> Stat -> Stat +liftStat op (Stat e1 x) (Stat e2 y) = Stat (e1 . e2) (x >>= \xv -> y >>= \yv -> return (\i -> xv i `op` yv i)) + +constStat :: IValue -> Stat +constStat x = Stat id (return x) + +(#>) :: Stat -> Stat -> Stat +(#>) = liftStat (@>) + +(#=) :: Stat -> Stat -> Stat +(#=) = liftStat (@==) + +(#<) :: Stat -> Stat -> Stat +(#<) = liftStat (@<) + +(#>=) :: Stat -> Stat -> Stat +(#>=) = liftStat (@>=) + +(#<=) :: Stat -> Stat -> Stat +(#<=) = liftStat (@<=) + +(#/) :: Stat -> Stat -> Stat +(#/) = liftStat (divValue) + +notStat :: Stat -> Stat +notStat = appStat Not +-- -------------------------------------------------------------------------- -- + +depthStat :: Stat +depthStat = + Stat (\super -> + let push dir = \i -> dir super (i `onCommit` mkUpdate i "depth" (\x -> x + 1)) + in commentEval $ super + { treeState_ = entry ("depth",Int,assign $ 0) : treeState_ super + , pushLeftH = push pushLeft + , pushRightH = push pushRight + , toString = "stat_depth:" ++ toString super + }) + (return (\info -> tstate info @-> "depth")) + +discrepancyStat :: Stat +discrepancyStat = + Stat + (\super -> commentEval $ + super + { treeState_ = entry ("discrepancy",Int,assign 0) : treeState_ super + , pushLeftH = \i -> pushLeft super (i `onCommit` mkCopy i "discrepancy") + , pushRightH = \i -> pushRight super (i `onCommit` mkUpdate i "discrepancy" (\x -> x + 1)) + , toString = "stat_discr:" ++ toString super + }) + (return (\info -> tstate info @-> "discrepancy")) + +nodesStat :: Stat +nodesStat = + eStat ("nodes", Int, const 0) $ + \super -> super { bodyH = \i -> return (inc (estate i @=> "nodes")) @>>>@ bodyE super i } + +solutionsStat :: Stat +solutionsStat = + eStat ("solutions", Int, const 0) $ + \super -> super {returnH = \i -> returnE super (i `onCommit` inc (solutions i))} + where solutions i = estate i @=> "solutions" + +varStat :: VarId -> Stat +varStat v@(VarId i) = Stat id (do inf <- lookupVarInfo v + return (const $ estate inf @=> ("var" ++ show i)) + ) + +failsStat :: Stat +failsStat = + eStat ("fails", Int, const 0) $ + \super -> super { failH = \i -> returnH super i @>>>@ return (inc (fails i)) } + where fails i = estate i @=> "fails" + +eStat :: (String, Type, Info -> Value) -> (forall m. Evalable m => Eval m -> Eval m) -> Stat +eStat (name,typ,val) f = + Stat (\super -> commentEval $ f $ super { evalState_ = (name,typ,\i -> return (val i)) : evalState_ super, toString = "stat_" ++ name ++ ":" ++ toString super }) + (return (\i -> estate i @=> name)) + +-- TIMER STATISTIC +-- +-- Based on Gecode::Support::Timer. +-- +-- +-- +timeStat :: Stat +timeStat = + Stat (\super -> commentEval $ + super { evalState_ = ("total",Int, const $ return 0) : + ("timer",THook "Gecode::Support::Timer",const $ return Null) : + ("running",Bool,const $ return false) : + evalState_ super + , nextDiffH = \i -> + return (ifthen (running i) + ((running i <== false) >>> + (total i <== (total i + (VHook (render $ text "static_cast" <> parens (pretty (timer i) <> text ".stop()"))))))) + , bodyH = \i -> + return (ifthen (Not $ running i) + ((running i <== true) >>> SHook ((render $ pretty $ timer i) ++ ".start();"))) + @>>>@ bodyE super i + , toString = "stat_time:" ++ toString super + }) + (return (\i -> total i + Cond (running i) (VHook (render $ text "static_cast" <> parens (pretty (timer i) <> text ".stop()"))) 0)) + where running i = estate i @=> "running" + timer i = estate i @=> "timer" + total i = estate i @=> "total" diff --git a/src/Data/Expr/Data.hs b/src/Data/Expr/Data.hs new file mode 100644 --- /dev/null +++ b/src/Data/Expr/Data.hs @@ -0,0 +1,297 @@ +{- + - Monadic Constraint Programming + - http://www.cs.kuleuven.be/~toms/MCP/ + - Pieter Wuille + -} + +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE StandaloneDeriving #-} + +module Data.Expr.Data ( + Expr(..), + ColExpr(..), + BoolExpr(..), + ExprRel(..), + (<<>>) +) where + +-------------------- +-- | Data types | -- +-------------------- + +-- some simple kinds of expressions +data Expr t c b = + Term t + | ExprHole Int + | Const Integer + | Plus (Expr t c b) (Expr t c b) + | Minus (Expr t c b) (Expr t c b) + | Mult (Expr t c b) (Expr t c b) + | Div (Expr t c b) (Expr t c b) + | Mod (Expr t c b) (Expr t c b) + | Abs (Expr t c b) + | At (ColExpr t c b) (Expr t c b) + | Fold (Expr t c b -> Expr t c b -> Expr t c b) (Expr t c b) (ColExpr t c b) + | Cond (BoolExpr t c b) (Expr t c b) (Expr t c b) + | ColSize (ColExpr t c b) + | Channel (BoolExpr t c b) + +data ColExpr t c b = + ColTerm c + | ColList [Expr t c b] + | ColRange (Expr t c b) (Expr t c b) + | ColMap (Expr t c b -> Expr t c b) (ColExpr t c b) + | ColSlice (Expr t c b -> Expr t c b) (Expr t c b) (ColExpr t c b) -- ColSlice f n c -> c[f(0)..f(n-1)] + | ColCat (ColExpr t c b) (ColExpr t c b) + +data ExprRel = + EREqual + | ERDiff + | ERLess + deriving (Show,Eq,Ord) + +data BoolExpr t c b = + BoolTerm b + | BoolConst Bool + | BoolAnd (BoolExpr t c b) (BoolExpr t c b) + | BoolOr (BoolExpr t c b) (BoolExpr t c b) + | BoolNot (BoolExpr t c b) + | BoolCond (BoolExpr t c b) (BoolExpr t c b) (BoolExpr t c b) + | Rel (Expr t c b) ExprRel (Expr t c b) + | BoolAll (Expr t c b -> BoolExpr t c b) (ColExpr t c b) + | BoolAny (Expr t c b -> BoolExpr t c b) (ColExpr t c b) + | ColEqual (ColExpr t c b) (ColExpr t c b) + | BoolEqual (BoolExpr t c b) (BoolExpr t c b) + | AllDiff Bool (ColExpr t c b) + | Sorted Bool (ColExpr t c b) + | Dom (Expr t c b) (ColExpr t c b) + +----------------------- +-- | Show instance | -- +----------------------- + +class ShowFn t where + showFn :: Int -> t -> String +instance (Show t, Show c, Show b) => ShowFn (Expr t c b) where + showFn _ (Term a) = "Term ("++(show a)++")" + showFn _ (ExprHole a) = "par"++(show a) + showFn _ (Const a) = "Const "++(show a) + showFn l (Plus a b) = "Plus ("++(showFn l a)++") ("++(showFn l b)++")" + showFn l (Minus a b) = "Minus ("++(showFn l a)++") ("++(showFn l b)++")" + showFn l (Mult a b) = "Mult ("++(showFn l a)++") ("++(showFn l b)++")" + showFn l (Div a b) = "Div ("++(showFn l a)++") ("++(showFn l b)++")" + showFn l (Mod a b) = "Mod ("++(showFn l a)++") ("++(showFn l b)++")" + showFn l (Abs a) = "Abs ("++(showFn l a)++")" + showFn l (At a b) = "At ("++(showFn l a)++") ("++(showFn l b)++")" + showFn l (Fold a b c) = "Fold ("++(showFn l a)++") ("++(showFn l b)++") ("++(showFn l c)++")" + showFn l (ColSize a) = "ColSize ("++(showFn l a)++")" + showFn l (Channel b) = "Channel ("++(showFn l b)++")" + showFn l (Cond c t f) = "Cond ("++(showFn l c)++") ("++(showFn l t)++") ("++(showFn l f)++")" +instance (ShowFn l) => ShowFn [l] where + showFn d l = "[" ++ (foldr1 (\a b -> a++","++b) $ map (showFn d) l) ++ "]" +instance (Show t, Show c, Show b) => ShowFn (ColExpr t c b) where + showFn d (ColTerm a) = "ColTerm ("++(show a)++")" + showFn d (ColList l) = "ColList ("++(showFn d l)++")" + showFn d (ColMap f l) = "ColMap ("++(showFn d f)++") ("++(showFn d l)++")" + showFn d (ColSlice f l c) = "ColSlice ("++(showFn d f)++") ("++(showFn d l)++") ("++(showFn d c)++")" + showFn d (ColCat a b) = "ColCat ("++(showFn d a)++") ("++(showFn d b)++")" + showFn d (ColRange a b) = "ColRange ("++(showFn d a)++") ("++(showFn d b)++")" +instance (Show t, Show c, Show b) => ShowFn (BoolExpr t c b) where + showFn d (BoolTerm b) = "BoolTerm ("++(show b)++")" + showFn d (BoolConst b) = "BoolConst "++(show b) + showFn d (BoolAnd a b) = "BoolAnd ("++(showFn d a)++") ("++(showFn d b)++")" + showFn d (BoolOr a b) = "BoolOr ("++(showFn d a)++") ("++(showFn d b)++")" + showFn d (BoolNot a) = "BoolNot ("++(showFn d a)++")" + showFn d (BoolEqual a b) = "BoolEqual ("++(showFn d a)++") ("++(showFn d b)++")" + showFn d (Rel a r b) = "Rel ("++(showFn d a)++") "++(show r)++" ("++(showFn d b)++")" + showFn d (BoolAll f c) = "BoolAll ("++(showFn d f)++") ("++(showFn d c)++")" + showFn d (BoolAny f c) = "BoolAny ("++(showFn d f)++") ("++(showFn d c)++")" + showFn d (ColEqual a b) = "ColEqual ("++(showFn d a)++") ("++(showFn d b)++")" + showFn d (AllDiff _ c) = "AllDiff ("++(showFn d c)++")" + showFn d (Sorted b c) = "Sorted "++(show b)++"("++(showFn d c)++")" + showFn l (BoolCond c t f) = "BoolCond ("++(showFn l c)++") ("++(showFn l t)++") ("++(showFn l f)++")" + showFn d (Dom i c) = "Dom ("++(showFn d i)++") ("++(showFn d c)++")" +instance (Show t, Show c, Show b, ShowFn e) => ShowFn (Expr t c b -> e) where + showFn l f = "\\par"++(show l)++" -> "++(showFn (l+1) (f (ExprHole l))) +instance (Show t, Show c, Show b) => Show (Expr t c b) where + show = showFn 0 +instance (Show t, Show c, Show b) => Show (ColExpr t c b) where + show = showFn 0 +instance (Show t, Show c, Show b) => Show (BoolExpr t c b) where + show = showFn 0 + +--------------------- +-- | Eq instance | -- +--------------------- + +equalExpr :: (Eq t, Eq c, Eq b) => Int -> Expr t c b -> Expr t c b -> Bool +equalExpr _ (Term a) (Term b) = a==b +equalExpr _ (ExprHole a) (ExprHole b) = a==b +equalExpr _ (Const a) (Const b) = a==b +equalExpr l (Plus a c) (Plus b d) = equalExpr l a b && equalExpr l d c +equalExpr l (Minus a c) (Minus b d) = equalExpr l a b && equalExpr l d c +equalExpr l (Mult a c) (Mult b d) = equalExpr l a b && equalExpr l d c +equalExpr l (Div a c) (Plus b d) = equalExpr l a b && equalExpr l d c +equalExpr l (Mod a c) (Plus b d) = equalExpr l a b && equalExpr l d c +equalExpr l (Abs a) (Abs b) = equalExpr l a b +equalExpr l (At a c) (At b d) = equalExpr l c d && equalColExpr l a b +equalExpr l (ColSize a) (ColSize b) = equalColExpr l a b +equalExpr l (Fold f a c) (Fold g b d) = equalExpr l a b && equalColExpr l c d && equalExpr (l+2) (f (ExprHole l) (ExprHole $ l+1)) (g (ExprHole l) (ExprHole $ l+1)) +equalExpr l (Channel a) (Channel b) = equalBoolExpr l a b +equalExpr l (Cond c t f) (Cond d u g) = equalBoolExpr l c d && equalExpr l t u && equalExpr l f g +equalExpr _ _ _ = False + +equalColExpr :: (Eq t, Eq c, Eq b) => Int -> ColExpr t c b -> ColExpr t c b -> Bool +equalColExpr _ (ColTerm a) (ColTerm b) = a==b +equalColExpr _ (ColList []) (ColList []) = True +equalColExpr l (ColList (a:ar)) (ColList (b:br)) = equalExpr l a b && equalColExpr l (ColList ar) (ColList br) +equalColExpr l (ColMap f a) (ColMap g b) = equalColExpr l a b && equalExpr (l+1) (f (ExprHole l)) (g (ExprHole l)) +equalColExpr l (ColSlice a c e) (ColSlice b d f) = equalExpr (l+1) (a (ExprHole l)) (b (ExprHole l)) && equalExpr l c d && equalColExpr l e f +equalColExpr l (ColCat a c) (ColCat b d) = equalColExpr l a b && equalColExpr l c d +equalColExpr l (ColRange a c) (ColRange b d) = equalExpr l a b && equalExpr l c d +equalColExpr _ _ _ = False + +equalBoolExpr :: (Eq t, Eq c, Eq b) => Int -> BoolExpr t c b -> BoolExpr t c b -> Bool +equalBoolExpr _ (BoolTerm a) (BoolTerm b) = a==b +equalBoolExpr _ (BoolConst a) (BoolConst b) = a==b +equalBoolExpr l (BoolAnd a c) (BoolAnd b d) = equalBoolExpr l a b && equalBoolExpr l c d +equalBoolExpr l (BoolOr a c) (BoolOr b d) = equalBoolExpr l a b && equalBoolExpr l c d +equalBoolExpr l (BoolEqual a c) (BoolEqual b d) = equalBoolExpr l a b && equalBoolExpr l c d +equalBoolExpr l (BoolNot a) (BoolNot b) = equalBoolExpr l a b +equalBoolExpr l (Rel a r c) (Rel b s d) = r==s && equalExpr l a b && equalExpr l c d +equalBoolExpr l (BoolAll f c) (BoolAll g d) = equalColExpr l c d && equalBoolExpr (l+1) (f $ ExprHole l) (g $ ExprHole l) +equalBoolExpr l (BoolAny f c) (BoolAny g d) = equalColExpr l c d && equalBoolExpr (l+1) (f $ ExprHole l) (g $ ExprHole l) +equalBoolExpr l (ColEqual a c) (ColEqual b d) = equalColExpr l a b && equalColExpr l c d +equalBoolExpr l (AllDiff _ c) (AllDiff _ d) = equalColExpr l c d +equalBoolExpr l (Sorted a c) (Sorted b d) = a==b && equalColExpr l c d +equalBoolExpr l (BoolCond c t f) (BoolCond d u g) = equalBoolExpr l c d && equalBoolExpr l t u && equalBoolExpr l f g +equalBoolExpr l (Dom a c) (Dom b d) = equalExpr l a b && equalColExpr l c d +equalBoolExpr _ _ _ = False + +instance (Eq t, Eq c, Eq b) => Eq (Expr t c b) where + a == b = equalExpr 0 a b +instance (Eq t, Eq c, Eq b) => Eq (ColExpr t c b) where + a == b = equalColExpr 0 a b +instance (Eq t, Eq c, Eq b) => Eq (BoolExpr t c b) where + a == b = equalBoolExpr 0 a b + +----------------------------------------------------- +-- | ExprKey: Provides ordering over expressions | -- +----------------------------------------------------- + +infixr 4 <<>> +a <<>> b = case a of + EQ -> b + _ -> a + +compareColExpr :: (Ord s, Ord c, Ord b) => Int -> ColExpr s c b -> ColExpr s c b -> Ordering +compareColExpr _ (ColList []) (ColList []) = EQ +compareColExpr l (ColList (a:ar)) (ColList (b:br)) = compareExpr l a b <<>> compareColExpr l (ColList ar) (ColList br) +compareColExpr _ (ColList _) _ = LT +compareColExpr _ _ (ColList _) = GT +compareColExpr l (ColMap f1 c1) (ColMap f2 c2) = compareColExpr l c1 c2 <<>> compareExpr (l+1) (f1 $ ExprHole l) (f2 $ ExprHole l) +compareColExpr _ (ColMap _ _) _ = LT +compareColExpr _ _ (ColMap _ _) = GT +compareColExpr l (ColSlice p1 l1 c1) (ColSlice p2 l2 c2) = compareExpr (l+1) (p1 $ ExprHole l) (p2 $ ExprHole l) <<>> compareExpr l l1 l2 <<>> compareColExpr l c1 c2 +compareColExpr _ (ColSlice _ _ _) _ = LT +compareColExpr _ _ (ColSlice _ _ _) = GT +compareColExpr l (ColCat a1 b1) (ColCat a2 b2) = compareColExpr l a1 a2 <<>> compareColExpr l b1 b2 +compareColExpr _ (ColCat _ _) _ = LT +compareColExpr _ _ (ColCat _ _) = GT +compareColExpr l (ColRange l1 h1) (ColRange l2 h2) = compareExpr l l1 l2 <<>> compareExpr l l2 h2 +compareColExpr _ (ColRange _ _) _ = LT +compareColExpr _ _ (ColRange _ _) = GT +compareColExpr _ (ColTerm t1) (ColTerm t2) = compare t1 t2 + +compareBoolExpr :: (Ord s, Ord c, Ord b) => Int -> BoolExpr s c b -> BoolExpr s c b -> Ordering +compareBoolExpr _ (BoolConst a) (BoolConst b) = compare a b +compareBoolExpr _ (BoolConst _) _ = LT +compareBoolExpr _ _ (BoolConst _) = GT +compareBoolExpr l (BoolAnd a1 b1) (BoolAnd a2 b2) = compareBoolExpr l a1 a2 <<>> compareBoolExpr l b1 b2 +compareBoolExpr _ (BoolAnd _ _) _ = LT +compareBoolExpr _ _ (BoolAnd _ _) = GT +compareBoolExpr l (BoolOr a1 b1) (BoolOr a2 b2) = compareBoolExpr l a1 a2 <<>> compareBoolExpr l b1 b2 +compareBoolExpr _ (BoolOr _ _) _ = LT +compareBoolExpr _ _ (BoolOr _ _) = GT +compareBoolExpr l (BoolEqual a1 b1) (BoolEqual a2 b2) = compareBoolExpr l a1 a2 <<>> compareBoolExpr l b1 b2 +compareBoolExpr _ (BoolEqual _ _) _ = LT +compareBoolExpr _ _ (BoolEqual _ _) = GT +compareBoolExpr l (BoolNot a1) (BoolNot a2) = compareBoolExpr l a1 a2 +compareBoolExpr _ (BoolNot _) _ = LT +compareBoolExpr _ _ (BoolNot _) = GT +compareBoolExpr l (Rel a1 r1 b1) (Rel a2 r2 b2) = compare r1 r2 <<>> compareExpr l a1 a2 <<>> compareExpr l b1 b2 +compareBoolExpr _ (Rel _ _ _) _ = LT +compareBoolExpr _ _ (Rel _ _ _) = GT +compareBoolExpr l (BoolAll f1 c1) (BoolAll f2 c2) = compareColExpr l c1 c2 <<>> compareBoolExpr (l+1) (f1 $ ExprHole l) (f2 $ ExprHole l) +compareBoolExpr _ (BoolAll _ _) _ = LT +compareBoolExpr _ _ (BoolAll _ _) = GT +compareBoolExpr l (BoolAny f1 c1) (BoolAny f2 c2) = compareColExpr l c1 c2 <<>> compareBoolExpr (l+1) (f1 $ ExprHole l) (f2 $ ExprHole l) +compareBoolExpr _ (BoolAny _ _) _ = LT +compareBoolExpr _ _ (BoolAny _ _) = GT +compareBoolExpr l (ColEqual a1 b1) (ColEqual a2 b2) = compareColExpr l a1 a2 <<>> compareColExpr l b1 b2 +compareBoolExpr _ (ColEqual _ _) _ = LT +compareBoolExpr _ _ (ColEqual _ _) = GT +compareBoolExpr l (Sorted a1 b1) (Sorted a2 b2) = compare a1 a2 <<>> compareColExpr l b1 b2 +compareBoolExpr _ (Sorted _ _) _ = LT +compareBoolExpr _ _ (Sorted _ _) = GT +compareBoolExpr l (AllDiff _ b1) (AllDiff _ b2) = compareColExpr l b1 b2 +compareBoolExpr _ (AllDiff _ _) _ = LT +compareBoolExpr _ _ (AllDiff _ _) = GT +compareBoolExpr l (BoolCond c1 t1 f1) (BoolCond c2 t2 f2) = compareBoolExpr l c1 c2 <<>> compareBoolExpr l t1 t2 <<>> compareBoolExpr l f1 f2 +compareBoolExpr _ (BoolCond _ _ _) _ = LT +compareBoolExpr _ _ (BoolCond _ _ _) = GT +compareBoolExpr l (Dom i1 c1) (Dom i2 c2) = compareExpr l i1 i2 <<>> compareColExpr l c1 c2 +compareBoolExpr _ (Dom _ _) _ = LT +compareBoolExpr _ _ (Dom _ _) = GT +compareBoolExpr _ (BoolTerm a) (BoolTerm b) = compare a b + +compareExpr :: (Ord s, Ord c, Ord b) => Int -> Expr s c b -> Expr s c b -> Ordering +compareExpr _ (Const i1) (Const i2) = compare i1 i2 +compareExpr _ (Const _) _ = LT +compareExpr _ _ (Const _) = GT +compareExpr _ (ExprHole i1) (ExprHole i2) = compare i1 i2 +compareExpr _ (ExprHole _) _ = LT +compareExpr _ _ (ExprHole _) = GT +compareExpr l (Plus a1 b1) (Plus a2 b2) = compareExpr l a1 a2 <<>> compareExpr l b1 b2 +compareExpr _ (Plus _ _) _ = LT +compareExpr _ _ (Plus _ _) = GT +compareExpr l (Minus a1 b1) (Minus a2 b2) = compareExpr l a1 a2 <<>> compareExpr l b1 b2 +compareExpr _ (Minus _ _) _ = LT +compareExpr _ _ (Minus _ _) = GT +compareExpr l (Mult a1 b1) (Mult a2 b2) = compareExpr l a1 a2 <<>> compareExpr l b1 b2 +compareExpr _ (Mult _ _) _ = LT +compareExpr _ _ (Mult _ _) = GT +compareExpr l (Div a1 b1) (Div a2 b2) = compareExpr l a1 a2 <<>> compareExpr l b1 b2 +compareExpr _ (Div _ _) _ = LT +compareExpr _ _ (Div _ _) = GT +compareExpr l (Mod a1 b1) (Mod a2 b2) = compareExpr l a1 a2 <<>> compareExpr l b1 b2 +compareExpr _ (Mod _ _) _ = LT +compareExpr _ _ (Mod _ _) = GT +compareExpr l (Abs a1) (Abs a2) = compareExpr l a1 a2 +compareExpr _ (Abs _) _ = LT +compareExpr _ _ (Abs _) = GT +compareExpr l (At c1 a1) (At c2 a2) = compareExpr l a1 a2 <<>> compareColExpr l c1 c2 +compareExpr _ (At _ _) _ = LT +compareExpr _ _ (At _ _) = GT +compareExpr l (ColSize c1) (ColSize c2) = compareColExpr l c1 c2 +compareExpr _ (ColSize _) _ = LT +compareExpr _ _ (ColSize _) = GT +compareExpr l (Fold f1 i1 c1) (Fold f2 i2 c2) = compareExpr l i1 i2 <<>> compareColExpr l c1 c2 <<>> compareExpr (l+2) (f1 (ExprHole l) (ExprHole $ l+1)) (f2 (ExprHole l) (ExprHole $ l+1)) +compareExpr _ (Fold _ _ _) _ = LT +compareExpr _ _ (Fold _ _ _) = GT +compareExpr l (Channel b1) (Channel b2) = compareBoolExpr l b1 b2 +compareExpr _ (Channel _) _ = LT +compareExpr _ _ (Channel _) = GT +compareExpr l (Cond c1 t1 f1) (Cond c2 t2 f2) = compareBoolExpr l c1 c2 <<>> compareExpr l t1 t2 <<>> compareExpr l f1 f2 +compareExpr _ (Cond _ _ _) _ = LT +compareExpr _ _ (Cond _ _ _) = GT +compareExpr _ (Term t1) (Term t2) = compare t1 t2 + +instance (Ord s, Ord c, Ord b) => Ord (Expr s c b) where + compare = compareExpr 0 + +instance (Ord s, Ord c, Ord b) => Ord (ColExpr s c b) where + compare = compareColExpr 0 + +instance (Ord s, Ord c, Ord b) => Ord (BoolExpr s c b) where + compare = compareBoolExpr 0 diff --git a/src/Data/Expr/Sugar.hs b/src/Data/Expr/Sugar.hs new file mode 100644 --- /dev/null +++ b/src/Data/Expr/Sugar.hs @@ -0,0 +1,285 @@ +{- + - Monadic Constraint Programming + - http://www.cs.kuleuven.be/~toms/MCP/ + - Pieter Wuille + -} + +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE FlexibleContexts #-} + +module Data.Expr.Sugar ( + (@+), (@-), (@*), (@/), (@%), (@?), (@??), (@:), + (!), (@!!), (@++), (@..), size, slice, xhead, xtail, xmap, xfold, list, channel, xsum, + (@||), (@&&), inv, + (@/=), (@>), (@<), (@>=), (@<=), (@=), + loopall, loopany, forall, forany, + Expr(), ColExpr(), BoolExpr(), + ToExpr(..), ToColExpr(..), ToBoolExpr(..), + sorted, sSorted, allDiff, allDiffD, + ExprClass, ExprRange, +) where + +import Data.Expr.Data +import Data.Expr.Util + +---------------------------------- +-- | Built-in class instances | -- +---------------------------------- + +instance (Eq s, Eq c, Eq b, Show s, Show c, Show b) => Num (Expr s c b) where + a + b = simplify $ a `Plus` b + a - b = simplify $ a `Minus` b + a * b = simplify $ a `Mult` b + abs a = simplify $ Abs a + negate a = simplify $ (Const 0) `Minus` a + fromInteger c = Const $ fromInteger c + signum (Const a) = Const $ signum a + signum a = error "signum not possible for generic Expr" + +instance (Ord s, Ord c, Ord b, Eq s, Eq c, Eq b, Show s, Show c, Show b) => Real (Expr s c b) where + toRational (Const x) = toRational x + toRational _ = error "toRational not possible for generic Expr" + +instance (Eq s, Eq c, Eq b) => Enum (Expr s c b) where + succ a = simplify $ a `Plus` (Const 1) + pred a = simplify $ a `Minus` (Const 1) + toEnum = Const . toEnum + fromEnum (Const a) = fromEnum a + fromEnum _ = error "fromEnum not possible for generic Expr" + +instance (Ord s, Ord c, Ord b, Eq s, Eq c, Eq b, Show s, Show c, Show b) => Integral (Expr s c b) where + toInteger (Const a) = toInteger a + toInteger _ = error "toInteger not possible for generic Expr" + divMod a b = (simplify $ a `Div` b, simplify $ a `Mod` b) + quotRem (Const a) (Const b) = case quotRem a b of (c,d) -> (Const c,Const d) + quotRem (Const 0) b = (Const 0,Const 0) + quotRem a (Const 1) = (a,Const 0) + quotRem a (Const (-1)) = (negate a,Const 0) + quotRem _ _ = error "quotRem not possible for generic Expr" + +--------------------------------------------- +-- | convertion from/to expression types | -- +--------------------------------------------- + +-- convertible to expressions: +class ToExpr tt cc bb t where + toExpr :: t -> Expr tt cc bb + +-- convertible to collection-expressions: +class ToColExpr tt cc bb c where + toColExpr :: c -> ColExpr tt cc bb + +-- convertible to boolean expressions: +class ToBoolExpr tt cc bb b where + toBoolExpr :: b -> BoolExpr tt cc bb + +-- infix 4 @=, @/= + +class (Eq tt, Eq cc, Eq bb) => ExprClass tt cc bb a where + (@=) :: a -> a -> BoolExpr tt cc bb + (@/=) :: a -> a -> BoolExpr tt cc bb + a @/= b = boolSimplify $ BoolNot $ a @= b + +class (Eq tt, Eq cc, Eq bb) => ExprRange tt cc bb r where + (@:) :: Expr tt cc bb -> r -> BoolExpr tt cc bb + +-- integers can be used as constant expressions +instance ToExpr tt cc bb Integer where + toExpr = Const + +-- expressions themselves are trivially convertible to expressions +instance ToExpr t a b (Expr t a b) where + toExpr = id + +-- ints can be used as constant expressions +instance ToExpr tt cc bb Int where + toExpr = Const . toInteger + +-- boolean expressions can be used as integer expressions (being 0 or 1) +instance (Eq t, Eq a, Eq b) => ToExpr t a b (BoolExpr t a b) where + toExpr = simplify . Channel + +-- collection expressions themselves are trivially convertible to collection expressions +instance ToColExpr t a b (ColExpr t a b) where + toColExpr = id + +-- an expression can be used as a collection of one expressions +instance (Eq t, Eq a, Eq b) => ToColExpr t a b (Expr t a b) where + toColExpr a = colSimplify $ ColList [a] + +-- a list of expressions van be used as a collection +instance (Eq b, Eq a, Eq t) => ToColExpr t a b [Expr t a b] where + toColExpr = colSimplify . ColList + +-- a boolean constant can be used as a constant boolean expression +instance ToBoolExpr tt cc bb Bool where + toBoolExpr = BoolConst + +-- boolean expressions are trivially convertible to boolean expressions +instance ToBoolExpr t a b (BoolExpr t a b) where + toBoolExpr = id + +-- the integer terms used by an expression can be used as interger expressions +instance ToExpr t a b t where + toExpr = Term + +-- the collections terms used by an expression can be used as collection expressions +instance ToColExpr t a b a where + toColExpr = ColTerm + +-- the boolean terms used by an expression can be used as boolean expressions +instance ToBoolExpr t a b b where + toBoolExpr = BoolTerm + +------------------------------------- +-- | integer operators/functions | -- +------------------------------------- + +-- @+ @- @* @/ @% are identical to + - * / % for integer expressions, except +-- that they also accept types convertible to expressions, instead of only +-- expressions themselves + +infixl 6 @+, @- +infixl 7 @* +infixl 7 @/ +infixl 7 @% + +(@+) :: (Eq t, Eq c, Eq b, ToExpr t c b p, ToExpr t c b q) => p -> q -> Expr t c b +(@-) :: (Eq t, Eq c, Eq b, ToExpr t c b p, ToExpr t c b q) => p -> q -> Expr t c b +(@*) :: (Eq t, Eq c, Eq b, ToExpr t c b p, ToExpr t c b q) => p -> q -> Expr t c b +(@/) :: (Eq t, Eq c, Eq b, ToExpr t c b p, ToExpr t c b q) => p -> q -> Expr t c b +(@%) :: (Eq t, Eq c, Eq b, ToExpr t c b p, ToExpr t c b q) => p -> q -> Expr t c b + +a @+ b = simplify $ (toExpr a) `Plus` (toExpr b) +a @- b = simplify $ (toExpr a) `Minus` (toExpr b) +a @* b = simplify $ (toExpr a) `Mult` (toExpr b) +a @/ b = simplify $ (toExpr a) `Div` (toExpr b) +a @% b = simplify $ (toExpr a) `Mod` (toExpr b) + +---------------------------------- +-- | list operators/functions | -- +---------------------------------- + +infix 9 ! +infix 9 @!! +infix 9 @.. +infixr 5 @++ +infix 4 @? +infix 4 @?? +infix 5 @: + +(!) :: (Eq t, Eq c, Eq b) => ColExpr t c b -> Expr t c b -> Expr t c b +(@!!) :: (Eq t, Eq c, Eq b) => ColExpr t c b -> Integer -> Expr t c b +(@..) :: (Eq t, Eq c, Eq b) => Expr t c b -> Expr t c b -> ColExpr t c b +(@++) :: (Eq t, Eq c, Eq b) => ColExpr t c b -> ColExpr t c b -> ColExpr t c b + +(@?) :: (Eq t, Eq c, Eq b) => BoolExpr t c b -> (Expr t c b, Expr t c b) -> Expr t c b +c @? (t,f) = simplify $ Cond c t f + +(@??) :: (Eq t, Eq c, Eq b) => BoolExpr t c b -> (BoolExpr t c b, BoolExpr t c b) -> BoolExpr t c b +c @?? (t,f) = boolSimplify $ BoolCond c t f + +c!p = simplify $ At c p +c @!! p = simplify $ At c (Const p) +a @.. b = colSimplify $ ColRange (toExpr a) (toExpr b) +a @++ b = colSimplify $ ColCat (toColExpr a) (toColExpr b) + +size :: (Eq t, Eq c, Eq b) => ColExpr t c b -> Expr t c b +size a = simplify $ ColSize a + +xfold :: (Eq t, Eq c, Eq b) => (Expr t c b -> Expr t c b -> Expr t c b) -> Expr t c b -> ColExpr t c b -> Expr t c b +xfold f i c = simplify $ Fold (\a b -> f a b) i c + +xsum :: (Num (Expr t c b), Eq t, Eq c, Eq b) => ColExpr t c b -> Expr t c b +xsum c = xfold (+) (Const 0) c + +list :: (Eq t, Eq c, Eq b) => [Expr t c b] -> ColExpr t c b +list x = colSimplify $ ColList x + +xhead :: (Eq t, Eq c, Eq b, ToColExpr t c b p) => p -> Expr t c b +xhead c = simplify $ At (toColExpr c) (Const 0) + +xtail :: (Eq t, Eq c, Eq b, ToColExpr t c b p) => p -> ColExpr t c b +xtail c = let cc = toColExpr c in colSimplify $ ColSlice (\x -> simplify (x `Plus` (Const 1))) (simplify $ (size cc) `Minus` (Const 1)) cc + +slice :: (Eq t, Eq c, Eq b) => ColExpr t c b -> ColExpr t c b -> ColExpr t c b +slice c p = case (c,p) of + (_,ColRange l h) -> colSimplify $ ColSlice (\x -> simplify (l `Plus` x)) (simplify $ Const 1 `Plus` (simplify $ h `Minus` l)) c + (_,ColMap f (ColRange l h)) -> colSimplify $ ColSlice (\i -> simplify $ f $ simplify (l `Plus` i)) (simplify $ Const 1 `Plus` (simplify $ h `Minus` l)) c + (_,ColSlice f n c2) -> colSimplify $ ColSlice (\i -> simplify $ c2 `At` (f i)) n c + _ -> xmap (\i -> simplify $ c `At` i) p + +xmap :: (Eq t, Eq c, Eq b) => (Expr t c b -> Expr t c b) -> ColExpr t c b -> ColExpr t c b +xmap f c = colSimplify $ ColMap f c + +loopall :: (Eq t, Eq c, Eq b) => (Expr t c b,Expr t c b) -> (Expr t c b -> BoolExpr t c b) -> BoolExpr t c b +loopall (l,h) f = boolSimplify $ BoolAll f $ colSimplify $ ColRange l h + +loopany :: (Eq t, Eq c, Eq b) => (Expr t c b,Expr t c b) -> (Expr t c b -> BoolExpr t c b) -> BoolExpr t c b +loopany (l,h) f = boolSimplify $ BoolAny f $ colSimplify $ ColRange l h + +forall :: (Eq t, Eq c, Eq b) => (ColExpr t c b) -> (Expr t c b -> BoolExpr t c b) -> BoolExpr t c b +forall c f = boolSimplify $ BoolAll f c + +forany :: (Eq t, Eq c, Eq b) => (ColExpr t c b) -> (Expr t c b -> BoolExpr t c b) -> BoolExpr t c b +forany c f = boolSimplify $ BoolAny f c + +channel :: (Eq t, Eq c, Eq b) => BoolExpr t c b -> Expr t c b +channel = simplify . Channel + +------------------------------------- +-- | boolean operators/functions | -- +------------------------------------- + +-- infixr 1 /\ +-- infixr 1 \/ +infixr 2 @|| +infixr 3 @&& + +-- (\/) :: (Eq t, Eq c, Eq b, ToBoolExpr t c b p, ToBoolExpr t c b q) => p -> q -> BoolExpr t c b +-- (/\) :: (Eq t, Eq c, Eq b, ToBoolExpr t c b p, ToBoolExpr t c b q) => p -> q -> BoolExpr t c b +inv :: (Eq t, Eq c, Eq b, ToBoolExpr t c b p) => p -> BoolExpr t c b + +a @|| b = boolSimplify $ BoolOr (toBoolExpr a) (toBoolExpr b) +a @&& b = boolSimplify $ BoolAnd (toBoolExpr a) (toBoolExpr b) +inv a = boolSimplify $ BoolNot (toBoolExpr a) +-- a \/ b = a @|| b +-- a /\ b = a @&& b + +---------------------------------------- +-- | relational operators/functions | -- +---------------------------------------- + +instance (Eq t, Eq c, Eq b) => ExprClass t c b (Expr t c b) where + a @= b = boolSimplify $ Rel a EREqual b + +instance (Eq t, Eq c, Eq b) => ExprClass t c b (BoolExpr t c b) where + a @= b = boolSimplify $ BoolEqual a b + +instance (Eq t, Eq c, Eq b) => ExprClass t c b (ColExpr t c b) where + a @= b = boolSimplify $ ColEqual a b + + +infixr 4 @<,@<=,@>,@>= +(@<) :: (Eq t, Eq c, Eq b) => Expr t c b -> Expr t c b -> BoolExpr t c b +(@>) :: (Eq t, Eq c, Eq b) => Expr t c b -> Expr t c b -> BoolExpr t c b +(@<=) :: (Eq t, Eq c, Eq b) => Expr t c b -> Expr t c b -> BoolExpr t c b +(@>=) :: (Eq t, Eq c, Eq b) => Expr t c b -> Expr t c b -> BoolExpr t c b + +a @< b = boolSimplify $ Rel a ERLess b +a @> b = boolSimplify $ Rel b ERLess a +a @<= b = boolSimplify $ Rel a ERLess (simplify $ b `Plus` (Const 1)) +a @>= b = boolSimplify $ Rel b ERLess (simplify $ a `Plus` (Const 1)) + +sorted c = boolSimplify $ Sorted False c +sSorted c = boolSimplify $ Sorted True c +allDiff c = boolSimplify $ AllDiff False c +allDiffD c = boolSimplify $ AllDiff True c + +instance (Eq t, Eq c, Eq b) => ExprRange t c b (Expr t c b,Expr t c b) where + a @: (l,h) = (a @>= l) @&& (a @<= h) + +instance (Eq t, Eq c, Eq b) => ExprRange t c b (ColExpr t c b) where + a @: c = boolSimplify $ Dom a c + diff --git a/src/Data/Expr/Util.hs b/src/Data/Expr/Util.hs new file mode 100644 --- /dev/null +++ b/src/Data/Expr/Util.hs @@ -0,0 +1,481 @@ +{- + - Monadic Constraint Programming + - http://www.cs.kuleuven.be/~toms/MCP/ + - Pieter Wuille + -} + +{-# LANGUAGE StandaloneDeriving #-} + +module Data.Expr.Util ( + Expr(), BoolExpr(), ColExpr(), + transform, colTransform, boolTransform, + transformEx, colTransformEx, boolTransformEx, + property, colProperty, boolProperty, + propertyEx, colPropertyEx, boolPropertyEx, + collapse, colCollapse, boolCollapse, + simplify, colSimplify, boolSimplify, + WalkPhase(..), WalkResult(..), walk, colWalk, boolWalk, +) where + +import Data.Expr.Data + +------------------------- +-- | Helper functions |-- +------------------------- + +relCheck :: Integer -> ExprRel -> Integer -> Bool +relCheck a EREqual b = a==b +relCheck a ERDiff b = a/=b +relCheck a ERLess b = a (a->b,c->d,e->f,b->a,d->c,f->e) -> Expr a c e -> Expr b d f +transform (f,fc,fb,fi,fic,fib) = transformEx (Term . f, ColTerm . fc, BoolTerm . fb, Term . fi, ColTerm . fic, BoolTerm . fib) + +transformEx :: (Eq a, Eq b, Eq c, Eq d, Eq e, Eq f) => ((a -> Expr b d f),(c -> ColExpr b d f),(e -> BoolExpr b d f),(b -> Expr a c e),(d -> ColExpr a c e),(f -> BoolExpr a c e)) -> Expr a c e -> Expr b d f +transformEx (f,_,_,_,_,_) (Term v) = f v +transformEx f (Const i) = Const i +transformEx f (ExprHole i) = ExprHole i +transformEx f (Plus a b) = simplify $ Plus (transformEx f a) (transformEx f b) +transformEx f (Minus a b) = simplify $ Minus (transformEx f a) (transformEx f b) +transformEx f (Mult a b) = simplify $ Mult (transformEx f a) (transformEx f b) +transformEx f (Div a b) = simplify $ Div (transformEx f a) (transformEx f b) +transformEx f (Mod a b) = simplify $ Mod (transformEx f a) (transformEx f b) +transformEx f (Abs a) = simplify $ Abs (transformEx f a) +transformEx f (At c a) = simplify $ At (colTransformEx f c) (transformEx f a) +transformEx f (ColSize c) = simplify $ ColSize $ colTransformEx f c +transformEx f (Channel a) = simplify $ Channel $ boolTransformEx f a +transformEx f (Cond c t e) = simplify $ Cond (boolTransformEx f c) (transformEx f t) (transformEx f e) +transformEx t@(f,fc,fb,fi,fic,fib) (Fold m i c) = simplify $ Fold (\a b -> transformEx t (m (transformEx (fi,fic,fib,f,fc,fb) a) (transformEx (fi,fic,fib,f,fc,fb) b))) (transformEx t i) (colTransformEx t c) + +colTransform :: (Eq a, Eq b, Eq c, Eq d, Eq e, Eq f) => (a->b,c->d,e->f,b->a,d->c,f->e) -> ColExpr a c e -> ColExpr b d f +colTransform (f,fc,fb,fi,fic,fib) = colTransformEx (Term . f, ColTerm . fc, BoolTerm . fb, Term . fi, ColTerm . fic, BoolTerm . fib) + +colTransformEx :: (Eq a, Eq b, Eq c, Eq d, Eq e, Eq f) => ((a -> Expr b d f),(c -> ColExpr b d f),(e -> BoolExpr b d f),(b -> Expr a c e),(d -> ColExpr a c e),f -> BoolExpr a c e) -> ColExpr a c e -> ColExpr b d f +colTransformEx (_,f,_,_,_,_) (ColTerm c) = f c +colTransformEx f (ColList l) = colSimplify $ ColList $ map (transformEx f) l +colTransformEx t@(f,fc,fb,fi,fic,fib) (ColMap m c) = colSimplify $ ColMap (\a -> transformEx t (m (transformEx (fi,fic,fib,f,fc,fb) a))) (colTransformEx t c) +colTransformEx t@(f,fc,fb,fi,fic,fib) (ColSlice p l c) = colSimplify $ ColSlice (\a -> transformEx t (p (transformEx (fi,fic,fib,f,fc,fb) a))) (transformEx t l) (colTransformEx t c) +colTransformEx f (ColCat a b) = colSimplify $ ColCat (colTransformEx f a) (colTransformEx f b) +colTransformEx f (ColRange a b) = colSimplify $ ColRange (transformEx f a) (transformEx f b) + +boolTransform :: (Eq a, Eq b, Eq c, Eq d, Eq e, Eq f) => (a->b,c->d,e->f,b->a,d->c,f->e) -> BoolExpr a c e -> BoolExpr b d f +boolTransform (f,fc,fb,fi,fic,fib) = boolTransformEx (Term . f, ColTerm . fc, BoolTerm . fb, Term . fi, ColTerm . fic, BoolTerm . fib) + +boolTransformEx :: (Eq a, Eq b, Eq c, Eq d, Eq e, Eq f) => ((a -> Expr b d f),(c -> ColExpr b d f),(e -> BoolExpr b d f),(b -> Expr a c e),(d -> ColExpr a c e),f -> BoolExpr a c e) -> BoolExpr a c e -> BoolExpr b d f +boolTransformEx (_,_,f,_,_,_) (BoolTerm v) = f v +boolTransformEx f (BoolConst c) = BoolConst c +boolTransformEx f (BoolAnd a b) = boolSimplify $ BoolAnd (boolTransformEx f a) (boolTransformEx f b) +boolTransformEx f (BoolOr a b) = boolSimplify $ BoolOr (boolTransformEx f a) (boolTransformEx f b) +boolTransformEx f (BoolEqual a b) = boolSimplify $ BoolEqual (boolTransformEx f a) (boolTransformEx f b) +boolTransformEx f (BoolNot a) = boolSimplify $ BoolNot (boolTransformEx f a) +boolTransformEx f (Rel a r b) = boolSimplify $ Rel (transformEx f a) r (transformEx f b) +boolTransformEx t@(f,fc,fb,fi,fic,fib) (BoolAll m c) = boolSimplify $ BoolAll (\a -> boolTransformEx t (m (transformEx (fi,fic,fib,f,fc,fb) a))) (colTransformEx t c) +boolTransformEx t@(f,fc,fb,fi,fic,fib) (BoolAny m c) = boolSimplify $ BoolAny (\a -> boolTransformEx t (m (transformEx (fi,fic,fib,f,fc,fb) a))) (colTransformEx t c) +boolTransformEx f (ColEqual a b) = boolSimplify $ ColEqual (colTransformEx f a) (colTransformEx f b) +boolTransformEx f (Sorted b c) = boolSimplify $ Sorted b (colTransformEx f c) +boolTransformEx f (AllDiff b c) = boolSimplify $ AllDiff b (colTransformEx f c) +boolTransformEx f (BoolCond c t e) = boolSimplify $ BoolCond (boolTransformEx f c) (boolTransformEx f t) (boolTransformEx f e) +boolTransformEx f (Dom i c) = boolSimplify $ Dom (transformEx f i) (colTransformEx f c) + +------------------------------------------------------------------------------------------ +-- | Check whether an expression is possibly referring to terms with a given property | -- +------------------------------------------------------------------------------------------ + +propertyEx :: (Expr a b c -> Maybe Bool, ColExpr a b c -> Maybe Bool, BoolExpr a b c -> Maybe Bool) -> Expr a b c -> Bool +propertyEx f@(fi,fc,fb) t = case fi t of + Just a -> a + Nothing -> case t of + Plus a b -> propertyEx f a || propertyEx f b + Minus a b -> propertyEx f a || propertyEx f b + Mult a b -> propertyEx f a || propertyEx f b + Div a b -> propertyEx f a || propertyEx f b + Mod a b -> propertyEx f a || propertyEx f b + Abs a -> propertyEx f a + At a b -> propertyEx f b || colPropertyEx f a + ColSize a -> colPropertyEx f a + Fold _ _ _ -> True + Channel b -> boolPropertyEx f b + Cond c t e -> boolPropertyEx f c || propertyEx f t || propertyEx f e + _ -> False + +colPropertyEx :: (Expr a b c -> Maybe Bool, ColExpr a b c -> Maybe Bool, BoolExpr a b c -> Maybe Bool) -> ColExpr a b c -> Bool +colPropertyEx f@(fi,fc,fb) t = case fc t of + Just a -> a + Nothing -> case t of + ColList l -> any (propertyEx f) l + ColMap _ _ -> True + ColSlice p l c -> propertyEx f (p (ExprHole (-1))) || propertyEx f l || colPropertyEx f c + ColRange l h -> propertyEx f l || propertyEx f h + ColCat a b -> colPropertyEx f a || colPropertyEx f b + _ -> False + +boolPropertyEx :: (Expr a b c -> Maybe Bool, ColExpr a b c -> Maybe Bool, BoolExpr a b c -> Maybe Bool) -> BoolExpr a b c -> Bool +boolPropertyEx f@(fi,fc,fb) t = case fb t of + Just a -> a + Nothing -> case t of + BoolAnd a b -> boolPropertyEx f a || boolPropertyEx f b + BoolOr a b -> boolPropertyEx f a || boolPropertyEx f b + BoolNot a -> boolPropertyEx f a + BoolEqual a b -> boolPropertyEx f a || boolPropertyEx f b + Rel a _ b -> propertyEx f a || propertyEx f b + BoolAll _ _ -> True + BoolAny _ _ -> True + ColEqual a b -> colPropertyEx f a || colPropertyEx f b + AllDiff _ c -> colPropertyEx f c + Sorted _ c -> colPropertyEx f c + BoolCond c t e -> boolPropertyEx f c || boolPropertyEx f t || boolPropertyEx f e + Dom i c -> propertyEx f i || colPropertyEx f c + _ -> False + + +property :: (a -> Bool) -> (b -> Bool) -> (c -> Bool) -> Expr a b c -> Bool +property fit fct fbt = propertyEx (propInt fit, propCol fct, propBool fbt) +colProperty :: (a -> Bool) -> (b -> Bool) -> (c -> Bool) -> ColExpr a b c -> Bool +colProperty fit fct fbt = colPropertyEx (propInt fit, propCol fct, propBool fbt) +boolProperty :: (a -> Bool) -> (b -> Bool) -> (c -> Bool) -> BoolExpr a b c -> Bool +boolProperty fit fct fbt = boolPropertyEx (propInt fit, propCol fct, propBool fbt) + +propInt :: (a -> Bool) -> Expr a b c -> Maybe Bool +propInt ft t = case t of + Term x -> Just $ ft x + _ -> Nothing + +propCol :: (b -> Bool) -> ColExpr a b c -> Maybe Bool +propCol ft t = case t of + ColTerm x -> Just $ ft x + _ -> Nothing + +propBool :: (c -> Bool) -> BoolExpr a b c -> Maybe Bool +propBool ft t = case t of + BoolTerm x -> Just $ ft x + _ -> Nothing + + +------------------------------------------------------------------- +-- | Count how many references to terms an expression contains | -- +------------------------------------------------------------------- + +varrefs :: Expr a b c -> Int +varrefs (Term _) = 1 +varrefs (Const _) = 0 +varrefs (ExprHole _) = 0 +varrefs (Plus a b) = varrefs a + varrefs b +varrefs (Minus a b) = varrefs a + varrefs b +varrefs (Mult a b) = varrefs a + varrefs b +varrefs (Div a b) = varrefs a + varrefs b +varrefs (Mod a b) = varrefs a + varrefs b +varrefs (Abs a) = varrefs a +varrefs (At c i) = varrefs i + colVarrefs c +varrefs (ColSize c) = colVarrefs c +varrefs (Fold f i c) = varrefs i + colVarrefs c + varrefs (f (ExprHole 0) (ExprHole 1)) +varrefs (Channel b) = boolVarrefs b +varrefs (Cond c t e) = boolVarrefs c + varrefs t + varrefs e + +colVarrefs :: ColExpr a b c -> Int +colVarrefs (ColTerm _) = 1 +colVarrefs (ColList lst) = sum $ map varrefs lst +colVarrefs (ColMap m c) = colVarrefs c + varrefs (m (ExprHole 0)) +colVarrefs (ColSlice p l c) = varrefs (p (ExprHole 0)) + varrefs l + colVarrefs c +colVarrefs (ColCat a b) = colVarrefs a + colVarrefs b +colVarrefs (ColRange a b) = varrefs a + varrefs b + +boolVarrefs :: BoolExpr a b c -> Int +boolVarrefs (BoolTerm _) = 1 +boolVarrefs (BoolConst _) = 0 +boolVarrefs (BoolAnd a b) = boolVarrefs a + boolVarrefs b +boolVarrefs (BoolOr a b) = boolVarrefs a + boolVarrefs b +boolVarrefs (BoolEqual a b) = boolVarrefs a + boolVarrefs b +boolVarrefs (BoolNot a) = boolVarrefs a +boolVarrefs (BoolAll f c) = boolVarrefs (f $ ExprHole 0) + colVarrefs c +boolVarrefs (BoolAny f c) = boolVarrefs (f $ ExprHole 0) + colVarrefs c +boolVarrefs (Rel a _ b) = varrefs a + varrefs b +boolVarrefs (ColEqual a b) = colVarrefs a + colVarrefs b +boolVarrefs (Sorted _ c) = colVarrefs c +boolVarrefs (AllDiff _ c) = colVarrefs c +boolVarrefs (BoolCond c t e) = boolVarrefs c + boolVarrefs t + boolVarrefs e +boolVarrefs (Dom i c) = varrefs i + colVarrefs c + +------------------------------ +-- | Simplify expressions | -- +------------------------------ + +simplify :: (Eq s, Eq c, Eq b) => Expr s c b -> Expr s c b +-- dropout rules (things that won't ever be changed) +simplify a@(Const _) = a +simplify a@(Term _) = a +simplify a@(ExprHole _) = a +-- simplification rules (either decrease # of variable references, or leave that equal and decrease # of tree nodes) +--- level 0 (result in a final expression) +simplify (Mult a@(Const 0) _) = a +simplify (Div a@(Const 0) _) = a +simplify (Mod a@(Const 0) _) = a +simplify (Mod _ (Const 1)) = Const 0 +simplify (Mod _ (Const (-1))) = Const 0 +simplify (Mod (Mult (Const a) b) (Const c)) | (a `mod` c)==0 = Const 0 +simplify (Minus a b) | a==b = Const 0 +simplify (Plus (Const a) (Const b)) = Const (a+b) +simplify (Minus (Const a) (Const b)) = Const (a-b) +simplify (Mult (Const a) (Const b)) = Const (a*b) +simplify (Div (Const a) (Const b)) = Const $ (a `div` b) +simplify (Abs (Const a)) = Const (abs a) +simplify (Mod (Const a) (Const b)) = Const $ (a `mod` b) +simplify (Plus (Const 0) a) = a +simplify (Mult (Const 1) a) = a +simplify (Div a (Const 1)) = a +simplify (At (ColList l) (Const c)) = l!!(fromInteger c) +simplify (ColSize (ColList l)) = Const $ toInteger $ length l +simplify (ColSize (ColSlice _ l _)) = l +simplify (Channel (BoolConst False)) = Const 0 +simplify (Channel (BoolConst True)) = Const 1 +simplify (Cond (BoolConst True) t _) = t +simplify (Cond (BoolConst False) _ f) = f +--- level 1 (result in one recursive call to simplify) +simplify (Plus a b) | a==b = simplify $ Mult (Const 2) a +simplify (Div a (Const (-1))) = simplify $ Minus (Const 0) a +simplify (Plus (Const c) (Plus (Const a) b)) = simplify $ Plus (Const $ c+a) b +simplify (Plus (Const c) (Minus (Const a) b)) = simplify $ Minus (Const $ c+a) b +simplify (Minus (Const c) (Plus (Const a) b)) = simplify $ Minus (Const $ c-a) b +simplify (Minus (Const c) (Minus (Const a) b)) = simplify $ Plus (Const $ c-a) b +simplify (Mult (Const c) (Mult (Const a) b)) = simplify $ Mult (Const $ a*c) b +simplify (Div (Mult (Const a) b) (Const c)) | (a `mod` c)==0 = simplify $ Mult (Const (a `div` c)) b +simplify (ColSize (ColMap _ c)) = simplify $ ColSize c +simplify (Fold f1 i (ColMap f2 c)) = simplify $ Fold (\a b -> f1 a (f2 b)) i c +simplify (At (ColRange l h) p) = simplify $ Plus l p +simplify (Cond (BoolNot c) t f) = simplify $ Cond c f t +--- level 2 (result in two recursive calls to simplify) +simplify (Plus a (Mult b c)) | a==b && ((varrefs a)>0) = simplify $ Mult (simplify $ Plus c (Const 1)) a +simplify (Plus a (Mult b c)) | a==c && ((varrefs a)>0) = simplify $ Mult (simplify $ Plus b (Const 1)) a +simplify (Plus (Mult b c) a) | a==b && ((varrefs a)>0) = simplify $ Mult (simplify $ Plus c (Const 1)) a +simplify (Plus (Mult b c) a) | a==c && ((varrefs a)>0) = simplify $ Mult (simplify $ Plus b (Const 1)) a +simplify (Plus (Mult a b) (Mult c d)) | a==c = simplify $ Mult (simplify $ Plus b d) a +simplify (Plus (Mult a b) (Mult c d)) | a==d = simplify $ Mult (simplify $ Plus b c) a +simplify (Plus (Mult a b) (Mult c d)) | b==c = simplify $ Mult (simplify $ Plus a d) b +simplify (Plus (Mult a b) (Mult c d)) | b==d = simplify $ Mult (simplify $ Plus a c) b +simplify (Minus a (Mult b c)) | a==b && ((varrefs a)>0) = simplify $ Mult (simplify $ Minus (Const 1) c) a +simplify (Minus a (Mult b c)) | a==c && ((varrefs a)>0) = simplify $ Mult (simplify $ Minus (Const 1) b) a +simplify (Minus (Mult b c) a) | a==b && ((varrefs a)>0) = simplify $ Mult (simplify $ Minus c (Const 1)) a +simplify (Minus (Mult b c) a) | a==c && ((varrefs a)>0) = simplify $ Mult (simplify $ Minus b (Const 1)) a +simplify (Minus (Mult a b) (Mult c d)) | a==c = simplify $ Mult (simplify $ Minus b d) a +simplify (Minus (Mult a b) (Mult c d)) | a==d = simplify $ Mult (simplify $ Minus b c) a +simplify (Minus (Mult a b) (Mult c d)) | b==c = simplify $ Mult (simplify $ Minus a d) b +simplify (Minus (Mult a b) (Mult c d)) | b==d = simplify $ Mult (simplify $ Minus a c) b +simplify (Mult (Abs a) (Abs b)) = simplify $ Abs (simplify $ Mult a b) +simplify (Div (Abs a) (Abs b)) = simplify $ Abs (simplify $ Div a b) +simplify (ColSize (ColRange l h)) = simplify $ Plus (Const 1) $ simplify $ Minus h l +simplify (At (ColSlice f _ c) i) = simplify $ At c (f i) +simplify (At (ColMap m c) i) = simplify $ m $ simplify $ At c i +simplify t@(At (ColCat c1 c2) c@(Const p)) = case simplify (ColSize c1) of + Const l | p simplify $ At c1 c + Const l | p>=l -> simplify $ At c2 (Const $ p-l) + _ -> t {- no further (At _ _) rules may follow after this -} +--- level 3 (results in three recursive calls to simplify) +simplify (ColSize (ColCat a b)) = simplify $ Plus (simplify $ ColSize a) (simplify $ ColSize b) +-- reordering rules (do not decrease # of variables or # of tree nodes, but normalize an expression in such a way that the same normalization cannot be applied anymore - possibly because that can only occur in a case already matched by a simplification rule above) +--- level 1 +simplify (Plus a (Const c)) = simplify $ Plus (Const c) a +simplify (Minus a (Const c)) = simplify $ Plus (Const (-c)) a +simplify (Mult a (Const c)) = simplify $ Mult (Const c) a +simplify (Mult (Const (-1)) a) = simplify $ Minus (Const 0) a +--- level 2 +simplify (Mult t@(Const c) (Plus (Const a) b)) = simplify $ Plus (Const (a*c)) (simplify $ Mult t b) +simplify (Mult t@(Const c) (Minus (Const a) b)) = simplify $ Minus (Const (a*c)) (simplify $ Mult t b) +simplify (Plus a (Plus t@(Const b) c)) = simplify $ Plus t (simplify $ Plus a c) +simplify (Plus a (Minus t@(Const b) c)) = simplify $ Plus t (simplify $ Minus a c) +simplify (Minus a (Plus (Const b) c)) = simplify $ Plus (Const (-b)) (simplify $ Minus a c) +simplify (Minus a (Minus (Const b) c)) = simplify $ Plus (Const (-b)) (simplify $ Plus a c) +simplify (Mult a (Mult t@(Const b) c)) = simplify $ Mult t (simplify $ Mult a c) +simplify (Plus (Plus t@(Const a) b) c) = simplify $ Plus t (simplify $ Plus b c) +simplify (Plus (Minus t@(Const a) b) c) = simplify $ Plus t (simplify $ Minus c b) +simplify (Minus (Plus t@(Const a) b) c) = simplify $ Plus t (simplify $ Minus b c) +simplify (Minus (Minus t@(Const a) b) c) = simplify $ Minus t (simplify $ Plus b c) +simplify (Mult (Mult t@(Const a) b) c) = simplify $ Mult t (simplify $ Mult b c) +simplify (Mult a (Minus t@(Const 0) b)) = simplify $ Minus t (simplify $ Mult a b) +simplify (Mult (Minus t@(Const 0) b) a) = simplify $ Minus t (simplify $ Mult a b) +simplify (Div (Minus t@(Const 0) a) b) = simplify $ Minus t (simplify $ Div a b) +simplify (Div a (Minus t@(Const 0) b)) = simplify $ Minus t (simplify $ Div a b) +-- fallback rule +simplify a = a + +colSimplify :: (Eq s, Eq c, Eq b) => ColExpr s c b -> ColExpr s c b +-- dropout rules +colSimplify t@(ColTerm _) = t +-- simplify rules +--- level 1 +colSimplify (ColMap f1 (ColMap f2 c)) = colSimplify $ ColMap (f1.f2) c +colSimplify (ColMap f (ColList l)) = colSimplify $ ColList (map f l) +--- level 2 +colSimplify (ColSlice p1 l1 (ColSlice p2 l2 c)) = colSimplify $ ColSlice (p1 . p2) l1 c +-- reordering rules +--- level 2 +colSimplify (ColCat (ColCat c1 c2) c3) = colSimplify $ ColCat c1 (colSimplify $ ColCat c2 c3) +colSimplify (ColSlice p l (ColMap f c)) = colSimplify $ ColMap f $ colSimplify $ ColSlice p l c +-- fallback rule +colSimplify x = x + +boolSimplify :: (Eq s, Eq c, Eq b) => BoolExpr s c b -> BoolExpr s c b +-- dropout rules +boolSimplify t@(BoolTerm _) = t +boolSimplify t@(BoolConst _) = t +-- simplify rules +--- level 0 +boolSimplify (BoolAnd (BoolConst False) _) = BoolConst False +boolSimplify (BoolAnd (BoolConst True) a) = a +boolSimplify (BoolAnd _ (BoolConst False)) = BoolConst False +boolSimplify (BoolAnd a (BoolConst True)) = a +boolSimplify (BoolOr (BoolConst True) _) = BoolConst True +boolSimplify (BoolOr (BoolConst False) a) = a +boolSimplify (BoolOr _ (BoolConst True)) = BoolConst True +boolSimplify (BoolOr a (BoolConst False)) = a +boolSimplify (BoolNot (BoolConst a)) = BoolConst (not a) +boolSimplify (BoolEqual (BoolConst True) a) = a +boolSimplify (BoolEqual a (BoolConst True)) = a +boolSimplify (BoolNot (BoolNot a)) = a +boolSimplify (BoolOr a b) | a==b = a +boolSimplify (BoolAnd a b) | a==b = a +boolSimplify (BoolEqual a b) | a==b = BoolConst False +boolSimplify (Rel (Const a) r (Const b)) = BoolConst $ relCheck a r b +boolSimplify (BoolAll f (ColList [])) = BoolConst True +boolSimplify (BoolAny f (ColList [])) = BoolConst False +boolSimplify (BoolAll f (ColList [a])) = f a +boolSimplify (BoolAny f (ColList [a])) = f a +boolSimplify (ColEqual (ColList []) (ColList [])) = BoolConst True +boolSimplify (ColEqual (ColList []) (ColList _)) = BoolConst False +boolSimplify (ColEqual (ColList _) (ColList [])) = BoolConst False +boolSimplify (BoolCond (BoolConst True) t _) = t +boolSimplify (BoolCond (BoolConst False) _ f) = f +--- level 1 +boolSimplify (BoolEqual (BoolNot a) (BoolNot b)) = boolSimplify $ BoolEqual a b +boolSimplify (BoolEqual (BoolConst False) a) = boolSimplify $ BoolNot a +boolSimplify (BoolEqual a (BoolConst False)) = boolSimplify $ BoolNot a +boolSimplify (BoolNot (Rel a EREqual b)) = boolSimplify $ Rel a ERDiff b +boolSimplify (BoolNot (Rel a ERDiff b)) = boolSimplify $ Rel a EREqual b +boolSimplify (BoolAll f (ColList [a,b])) = boolSimplify $ f a `BoolAnd` f b +boolSimplify (BoolAny f (ColList [a,b])) = boolSimplify $ f a `BoolOr` f b +boolSimplify (ColEqual (ColList [a]) (ColList [b])) = boolSimplify $ Rel a EREqual b +boolSimplify (Rel (Channel a) EREqual (Channel b)) = boolSimplify $ BoolEqual a b +boolSimplify (BoolCond (BoolNot c) t f) = boolSimplify $ BoolCond c f t +--- level 2 +boolSimplify (BoolAnd (BoolNot a) (BoolNot b)) = boolSimplify $ BoolNot $ boolSimplify $ BoolOr a b +boolSimplify (BoolOr (BoolNot a) (BoolNot b)) = boolSimplify $ BoolNot $ boolSimplify $ BoolAnd a b +boolSimplify (Rel (Channel a) ERDiff (Channel b)) = boolSimplify $ BoolNot $ boolSimplify $ BoolEqual a b +boolSimplify (Rel (Channel a) ERLess (Channel b)) = boolSimplify $ BoolAnd b $ boolSimplify $ BoolNot a -- int(b1) < int(b2) <=> !b1 && b2 +-- fallback +boolSimplify a = a + +------------------------------------------------------------------- +-- | Turn expressions over expressions into simply expressions | -- +------------------------------------------------------------------- + +collapse :: (Eq t, Eq c, Eq b) => Expr (Expr t c b) (ColExpr t c b) (BoolExpr t c b) -> Expr t c b +collapse (Term t) = t +collapse (Const i) = Const i +collapse (Plus a b) = simplify $ Plus (collapse a) (collapse b) +collapse (Minus a b) = simplify $ Minus (collapse a) (collapse b) +collapse (Mult a b) = simplify $ Mult (collapse a) (collapse b) +collapse (Div a b) = simplify $ Div (collapse a) (collapse b) +collapse (Mod a b) = simplify $ Mod (collapse a) (collapse b) +collapse (Abs a) = simplify $ Abs (collapse a) +collapse (At c a) = simplify $ At (colCollapse c) (collapse a) +collapse (ColSize c) = simplify $ ColSize (colCollapse c) +collapse (Fold f i c) = simplify $ Fold (\a b -> collapse $ f (Term a) (Term b)) (collapse i) (colCollapse c) +collapse (Channel b) = simplify $ Channel (boolCollapse b) +collapse (Cond c t e) = simplify $ Cond (boolCollapse c) (collapse t) (collapse e) + +colCollapse :: (Eq t, Eq c, Eq b) => ColExpr (Expr t c b) (ColExpr t c b) (BoolExpr t c b) -> ColExpr t c b +colCollapse (ColTerm t) = t +colCollapse (ColList l) = colSimplify $ ColList $ map collapse l +colCollapse (ColMap f c) = colSimplify $ ColMap (\a -> collapse $ f (Term a)) (colCollapse c) +colCollapse (ColSlice p l c) = colSimplify $ ColSlice (\x -> collapse $ p (Term x)) (collapse l) (colCollapse c) +colCollapse (ColCat a b) = colSimplify $ ColCat (colCollapse a) (colCollapse b) +colCollapse (ColRange a b) = colSimplify $ ColRange (collapse a) (collapse b) + +boolCollapse :: (Eq t, Eq c, Eq b) => BoolExpr (Expr t c b) (ColExpr t c b) (BoolExpr t c b) -> BoolExpr t c b +boolCollapse (BoolTerm t) = t +boolCollapse (BoolConst c) = BoolConst c +boolCollapse (BoolAnd a b) = boolSimplify $ BoolAnd (boolCollapse a) (boolCollapse b) +boolCollapse (BoolOr a b) = boolSimplify $ BoolOr (boolCollapse a) (boolCollapse b) +boolCollapse (BoolEqual a b) = boolSimplify $ BoolEqual (boolCollapse a) (boolCollapse b) +boolCollapse (BoolNot a) = boolSimplify $ BoolNot (boolCollapse a) +boolCollapse (Rel a r b) = boolSimplify $ Rel (collapse a) r (collapse b) +boolCollapse (BoolAll f c) = boolSimplify $ BoolAll (\a -> boolCollapse $ f (Term a)) (colCollapse c) +boolCollapse (BoolAny f c) = boolSimplify $ BoolAny (\a -> boolCollapse $ f (Term a)) (colCollapse c) +boolCollapse (ColEqual a b) = boolSimplify $ ColEqual (colCollapse a) (colCollapse b) +boolCollapse (Sorted b c) = boolSimplify $ Sorted b (colCollapse c) +boolCollapse (AllDiff b c) = boolSimplify $ AllDiff b (colCollapse c) +boolCollapse (BoolCond c t e) = boolSimplify $ BoolCond (boolCollapse c) (boolCollapse t) (boolCollapse e) +boolCollapse (Dom i c) = boolSimplify $ Dom (collapse i) (colCollapse c) + +----------------------------------------- +-- | walk through expressions +----------------------------------------- + +data WalkPhase = WalkPre | WalkSingle | WalkPost + deriving (Ord,Eq,Enum,Show) + +data WalkResult = WalkSkip | WalkDescend + deriving (Ord,Eq,Enum,Show) + +xwalker :: (Eq t, Eq c, Eq b, Monad m) => (WalkPhase -> m WalkResult) -> (Expr t c b -> WalkPhase -> m WalkResult, ColExpr t c b -> WalkPhase -> m WalkResult, BoolExpr t c b -> WalkPhase -> m WalkResult) -> ([Expr t c b],[ColExpr t c b],[BoolExpr t c b]) -> m () +xwalker q f ([],[],[]) = do + q WalkSingle + return () +xwalker q f (li,lc,lb) = do + r <- q WalkPre + case r of + WalkSkip -> return () + WalkDescend -> do + mapM_ (\p -> walk p f) li + mapM_ (\p -> colWalk p f) lc + mapM_ (\p -> boolWalk p f) lb + q WalkPost + return () + +walker :: (Eq t, Eq c, Eq b, Monad m) => Expr t c b -> (Expr t c b -> WalkPhase -> m WalkResult, ColExpr t c b -> WalkPhase -> m WalkResult, BoolExpr t c b -> WalkPhase -> m WalkResult) -> ([Expr t c b],[ColExpr t c b],[BoolExpr t c b]) -> m () +walker x f@(i,c,b) l = xwalker (i x) f l +colWalker :: (Eq t, Eq c, Eq b, Monad m) => ColExpr t c b -> (Expr t c b -> WalkPhase -> m WalkResult, ColExpr t c b -> WalkPhase -> m WalkResult, BoolExpr t c b -> WalkPhase -> m WalkResult) -> ([Expr t c b],[ColExpr t c b],[BoolExpr t c b]) -> m () +colWalker x f@(i,c,b) l = xwalker (c x) f l +boolWalker :: (Eq t, Eq c, Eq b, Monad m) => BoolExpr t c b -> (Expr t c b -> WalkPhase -> m WalkResult, ColExpr t c b -> WalkPhase -> m WalkResult, BoolExpr t c b -> WalkPhase -> m WalkResult) -> ([Expr t c b],[ColExpr t c b],[BoolExpr t c b]) -> m () +boolWalker x f@(i,c,b) l = xwalker (b x) f l + +walk :: (Eq t, Eq c, Eq b, Monad m) => Expr t c b -> (Expr t c b -> WalkPhase -> m WalkResult, ColExpr t c b -> WalkPhase -> m WalkResult, BoolExpr t c b -> WalkPhase -> m WalkResult) -> m () +walk x@(Term _) f = walker x f ([],[],[]) +walk x@(Const _) f = walker x f ([],[],[]) +walk x@(Plus a b) f = walker x f ([a,b],[],[]) +walk x@(Minus a b) f = walker x f ([a,b],[],[]) +walk x@(Mult a b) f = walker x f ([a,b],[],[]) +walk x@(Div a b) f = walker x f ([a,b],[],[]) +walk x@(Mod a b) f = walker x f ([a,b],[],[]) +walk x@(Abs a) f = walker x f ([a],[],[]) +walk x@(At c a) f = walker x f ([a],[c],[]) +walk x@(ColSize c) f = walker x f ([],[c],[]) +walk x@(Fold _ i c) f = walker x f ([i],[c],[]) +walk x@(Channel b) f = walker x f ([],[],[b]) +walk x@(Cond c t e) f = walker x f ([t,e],[],[c]) +walk x@(ExprHole _) f = return () + +colWalk x@(ColTerm _) f = colWalker x f ([],[],[]) +colWalk x@(ColList l) f = colWalker x f (l,[],[]) +colWalk x@(ColMap _ c) f = colWalker x f ([],[c],[]) +colWalk x@(ColSlice _ l c) f = colWalker x f ([l],[c],[]) +colWalk x@(ColCat a b) f = colWalker x f ([],[a,b],[]) +colWalk x@(ColRange a b) f = colWalker x f ([a,b],[],[]) + +boolWalk x@(BoolTerm _) f = boolWalker x f ([],[],[]) +boolWalk x@(BoolConst _) f = boolWalker x f ([],[],[]) +boolWalk x@(BoolAnd a b) f = boolWalker x f ([],[],[a,b]) +boolWalk x@(BoolOr a b) f = boolWalker x f ([],[],[a,b]) +boolWalk x@(BoolEqual a b) f = boolWalker x f ([],[],[a,b]) +boolWalk x@(BoolNot a) f = boolWalker x f ([],[],[a]) +boolWalk x@(Rel a _ b) f = boolWalker x f ([a,b],[],[]) +boolWalk x@(BoolAll _ c) f = boolWalker x f ([],[c],[]) +boolWalk x@(BoolAny _ c) f = boolWalker x f ([],[c],[]) +boolWalk x@(ColEqual a b) f = boolWalker x f ([],[a,b],[]) +boolWalk x@(Sorted _ c) f = boolWalker x f ([],[c],[]) +boolWalk x@(AllDiff _ c) f = boolWalker x f ([],[c],[]) +boolWalk x@(BoolCond c t e) f = boolWalker x f ([],[],[c,t,e]) +boolWalk x@(Dom i c) f = boolWalker x f ([i],[c],[]) + diff --git a/src/Data/Linear.hs b/src/Data/Linear.hs new file mode 100644 --- /dev/null +++ b/src/Data/Linear.hs @@ -0,0 +1,82 @@ +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE ScopedTypeVariables #-} + +module Data.Linear ( + Linear, + integerToLinear, + constToLinear, + termToLinear, +-- linearOpLinear, +-- linearOpLinears, + linearToConst, + linearToTerm, + linearMultiply, + linearMult, + linearToList, linearToListEx, + getCoef, +) where + +import qualified Data.Map as Map +import Data.Map(Map) + +data (Ord t, Num v) => Linear t v = Linear v (Map t v) + +deriving instance (Num v, Eq v, Ord t, Eq t) => Eq (Linear t v) +deriving instance (Num v, Ord v, Ord t, Eq t) => Ord (Linear t v) +deriving instance (Num v, Show v, Ord t, Show t) => Show (Linear t v) + +termToLinear :: (Num v, Ord t) => t -> Linear t v +termToLinear x = Linear 0 $ Map.singleton x 1 + +integerToLinear :: (Num v, Ord t) => Integer -> Linear t v +integerToLinear = constToLinear . fromInteger + +constToLinear :: (Num v, Ord t) => v -> Linear t v +constToLinear x = Linear x Map.empty + +-- linearOpLinear :: (Num v, Ord t) => v -> Linear t v -> v -> Linear t v -> Linear t v +-- linearOpLinear a (Linear ac am) b (Linear bc bm) = Linear (a*ac+b*bc) $ Map.filter (/=0) $ Map.unionWith (\ax bx -> ax*a+bx*b) am bm + +-- linearOpLinears :: (Num v, Ord t) => [(v,Linear t v)] -> Linear t v +-- linearOpLinears l = foldr (\(c,t) a -> linearOpLinear 1 a c t) (integerToLinear 0) l + +linearToList :: (Ord t, Num v) => Linear t v -> [(Maybe t,v)] +linearToList (Linear c m) = [(Nothing,c)] ++ (map (\(a,b) -> (Just a,b)) $ Map.toList m) + +linearToListEx :: (Ord t, Num v) => Linear t v -> (v,[(t,v)]) +linearToListEx (Linear c m) = (c,Map.toList m) + +getCoef :: (Num v, Ord t) => Maybe t -> Linear t v -> v +getCoef Nothing (Linear c _) = c +getCoef (Just t) (Linear _ m) = Map.findWithDefault 0 t m + +linearMult :: (Num v, Eq v, Ord t) => v -> Linear t v -> Linear t v +linearMult m (Linear ac am) = Linear (m*ac) $ if (m==0) then Map.empty else Map.filter (/=0) $ Map.map (m*) am + +linearMultiply :: (Num v, Eq v, Ord t) => Linear t v -> Linear t v -> Maybe (Linear t v) +linearMultiply (Linear ac am) bl | (Map.null am) = Just $ linearMult ac bl +linearMultiply bl (Linear ac am) | (Map.null am) = Just $ linearMult ac bl +linearMultiply _ _ = Nothing + +linearToConst :: (Num v, Ord t) => Linear t v -> Maybe v +linearToConst (Linear c m) | Map.null m = Just c +linearToConst _ = Nothing + +linearToTerm :: (Num v, Eq v, Ord t) => Linear t v -> Maybe t +linearToTerm (Linear c m) | (c==0 && (Map.size m)==1) = + let (t,v) = Map.findMin m + in if (v==1) then Just t else Nothing +linearToTerm _ = Nothing + +instance (Num v, Eq v, Ord t, Eq t, Show t) => Num (Linear t v) where + (Linear ac am) + (Linear bc bm) = Linear (ac+bc) $ Map.filter (/=0) $ Map.unionWith (+) am bm + (Linear ac am) - (Linear bc bm) = Linear (ac-bc) $ Map.filter (/=0) $ Map.unionWith (+) am $ Map.map negate bm + a * b = case linearMultiply a b of Just x -> x; Nothing -> error "Cannot multiply generic linear expressions" + negate (Linear ac am) = Linear (-ac) $ Map.map negate am + abs (Linear ac am) | (Map.null am) = Linear (abs ac) Map.empty + abs _ = error "Cannot take abs of generic linear expressions" + signum (Linear ac am) | (Map.null am) = Linear (signum ac) Map.empty + signum _ = error "Cannot take signum of generic linear expressions" + fromInteger x = integerToLinear x diff --git a/src/Language/CPP/Pretty.hs b/src/Language/CPP/Pretty.hs new file mode 100644 --- /dev/null +++ b/src/Language/CPP/Pretty.hs @@ -0,0 +1,242 @@ +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE TypeSynonymInstances #-} + +module Language.CPP.Pretty ( + codegen +) where + +import Text.PrettyPrint.HughesPJ +import Prelude hiding ((<>)) +import Language.CPP.Syntax.AST + +class Pretty t where + pretty :: t -> Doc + prettyPrec :: Int -> t -> Doc + pretty = prettyPrec 0 + prettyPrec _ = pretty + +class ToString t where + toString :: t -> String + +instance ToString CPPAssignOp where + toString x = case x of + CPPAssOp -> "=" + CPPAssOpMul -> "*=" + CPPAssOpDiv -> "/=" + CPPAssOpRmd -> "%=" + CPPAssOpAdd -> "+=" + CPPAssOpSub -> "-=" + CPPAssOpShl -> "<<=" + CPPAssOpShr -> ">>=" + CPPAssOpAnd -> "&=" + CPPAssOpOr -> "|=" + CPPAssOpXor -> "^=" + +{- + Priorities in C (http://www.difranco.net/cop2220/op-prec.htm) + + 2: comma + 4: assignments + 6: conditional + 8: logical or + 10: logical and + 12: bitwise or + 14: bitwise xor + 16: bitwise and + 18: equality/inequality test + 20: relational tests + 22: bitshift + 24: addition/subtraction + 26: multiplication/division/modulus + 28: preincrement/predecrement/negation/complement/cast/dereference/address/sizeof + 30: brackets/index/member/postincrement/postdecrement/ +-} + + +instance Pretty CPPConst where + pretty (CPPConstInt x) = text $ show x + pretty (CPPConstChar x) = text $ "'" ++ x ++ "'" -- TODO: character escaping + pretty (CPPConstString x) = text $ "\"" ++ x ++ "\"" + pretty (CPPConstFloat x) = text x + +prio :: Int -> Int -> Doc -> Doc +prio myL outerL doc = if myL (text $ toString op) <+> (prettyPrec 4 o2) + prettyPrec l (CPPVar v) = text v + prettyPrec l (CPPComma lst) = lparen <> (foldl (<>) empty $ punctuate comma $ map (prettyPrec 2) lst) <> rparen + prettyPrec l (CPPBinary o1 CPPOpMul o2) = prio 26 l $ (prettyPrec 26 o1) <> text "*" <> (prettyPrec 27 o2) + prettyPrec l (CPPBinary o1 CPPOpDiv o2) = prio 26 l $ (prettyPrec 26 o1) <> text "/" <> (prettyPrec 27 o2) + prettyPrec l (CPPBinary o1 CPPOpRmd o2) = prio 26 l $ (prettyPrec 26 o1) <> text "%" <> (prettyPrec 27 o2) + prettyPrec l (CPPBinary o1 CPPOpAdd o2) = prio 24 l $ (prettyPrec 24 o1) <> text "+" <> (prettyPrec 24 o2) + prettyPrec l (CPPBinary o1 CPPOpSub o2) = prio 24 l $ (prettyPrec 24 o1) <> text "-" <> (prettyPrec 25 o2) + prettyPrec l (CPPBinary o1 CPPOpShl o2) = prio 22 l $ (prettyPrec 22 o1) <> text "<<" <> (prettyPrec 23 o2) + prettyPrec l (CPPBinary o1 CPPOpShr o2) = prio 22 l $ (prettyPrec 22 o1) <> text ">>" <> (prettyPrec 23 o2) + prettyPrec l (CPPBinary o1 CPPOpLe o2) = prio 20 l $ (prettyPrec 20 o1) <> text "<" <> (prettyPrec 21 o2) + prettyPrec l (CPPBinary o1 CPPOpGr o2) = prio 20 l $ (prettyPrec 20 o1) <> text ">" <> (prettyPrec 21 o2) + prettyPrec l (CPPBinary o1 CPPOpGeq o2) = prio 20 l $ (prettyPrec 20 o1) <> text ">=" <> (prettyPrec 21 o2) + prettyPrec l (CPPBinary o1 CPPOpLeq o2) = prio 20 l $ (prettyPrec 20 o1) <> text "<=" <> (prettyPrec 21 o2) + prettyPrec l (CPPBinary o1 CPPOpEq o2) = prio 18 l $ (prettyPrec 18 o1) <> text "==" <> (prettyPrec 19 o2) + prettyPrec l (CPPBinary o1 CPPOpNeq o2) = prio 18 l $ (prettyPrec 18 o1) <> text "!=" <> (prettyPrec 19 o2) + prettyPrec l (CPPBinary o1 CPPOpAnd o2) = prio 16 l $ (prettyPrec 16 o1) <> text "&" <> (prettyPrec 16 o2) + prettyPrec l (CPPBinary o1 CPPOpXor o2) = prio 14 l $ (prettyPrec 14 o1) <> text "^" <> (prettyPrec 14 o2) + prettyPrec l (CPPBinary o1 CPPOpOr o2) = prio 12 l $ (prettyPrec 12 o1) <> text "|" <> (prettyPrec 12 o2) + prettyPrec l (CPPBinary o1 CPPOpLAnd o2) = prio 10 l $ (prettyPrec 10 o1) <> text "&&" <> (prettyPrec 10 o2) + prettyPrec l (CPPBinary o1 CPPOpLOr o2) = prio 8 l $ (prettyPrec 8 o1) <> text "||" <> (prettyPrec 8 o2) + prettyPrec l (CPPUnary CPPOpPreInc o) = prio 28 l $ text "++" <> (prettyPrec 28 o ) + prettyPrec l (CPPUnary CPPOpPreDec o) = prio 28 l $ text "--" <> (prettyPrec 28 o ) + prettyPrec l (CPPUnary CPPOpPostInc o) = prio 28 l $ (prettyPrec 28 o ) <> text "++" + prettyPrec l (CPPUnary CPPOpPostDec o) = prio 28 l $ (prettyPrec 28 o ) <> text "--" + prettyPrec l (CPPUnary CPPOpAdr o) = prio 28 l $ text "&" <> (prettyPrec 28 o ) + prettyPrec l (CPPUnary CPPOpInd o) = prio 28 l $ text "*" <> (prettyPrec 28 o ) + prettyPrec l (CPPUnary CPPOpPlus o) = prio 28 l $ text "+" <> (prettyPrec 28 o ) + prettyPrec l (CPPUnary CPPOpMinus o) = prio 28 l $ text "-" <> (prettyPrec 28 o ) + prettyPrec l (CPPUnary CPPOpComp o) = prio 28 l $ text "~" <> (prettyPrec 28 o ) + prettyPrec l (CPPUnary CPPOpNeg o) = prio 28 l $ text "!" <> (prettyPrec 28 o ) + prettyPrec l (CPPCond c (Just t) f) = prio 6 l $ (prettyPrec 7 c ) <+> text "?" <+> (prettyPrec 7 t ) <+> text ":" <+> (prettyPrec 6 f) + prettyPrec l (CPPCond c Nothing t) = prio 6 l $ (prettyPrec 7 c ) <> text "?:" <> (prettyPrec 6 t ) + prettyPrec l (CPPCast t e) = prio 28 l $ lparen <> (pretty t) <> rparen <> (prettyPrec 28 e ) + prettyPrec l (CPPSizeOfExpr e) = prio 28 l $ text "sizeof" <> lparen <> (pretty e) <> rparen + prettyPrec l (CPPSizeOfType t) = prio 28 l $ text "sizeof" <> lparen <> (pretty t) <> rparen + prettyPrec l (CPPIndex a b) = prio 28 l $ (prettyPrec 28 a) <> lbrack <> (pretty b) <> rbrack + prettyPrec l (CPPCall a b) = prio 28 l $ (prettyPrec 28 a) <> lparen <> (hcat $ punctuate comma $ map pretty b) <> rparen + prettyPrec l (CPPMember a m False) = prio 28 l $ (prettyPrec 28 a) <> text "." <> text m + prettyPrec l (CPPMember a m True) = prio 28 l $ (prettyPrec 28 a) <> text "->" <> text m + prettyPrec l (CPPNew a b) = prio 28 l $ text "new" <+> (pretty a) <> lparen <> (hcat $ punctuate comma $ map pretty b) <> rparen + +instance Pretty s => Pretty (Maybe s) where + prettyPrec _ Nothing = empty + prettyPrec l (Just x) = prettyPrec l x + +instance (Pretty a, Pretty b) => Pretty (Either a b) where + prettyPrec l (Left x) = prettyPrec l x + prettyPrec l (Right x) = prettyPrec l x + +instance Pretty CPPStat where + pretty (CPPLabel s b) = (nest (-1000) $ (text s) <> char ':') $$ pretty b + pretty (CPPCase x b) = (text "case" <+> pretty x <> char ':') $+$ (nest 2 (pretty b)) + pretty (CPPDefault b) = (text "default:") $+$ (nest 2 $ pretty b) + pretty (CPPSimple x) = (pretty x) <> char ';' + pretty (CPPCompound []) = empty + pretty (CPPCompound [CPPStatement (c@(CPPCompound _))]) = pretty c + pretty (CPPCompound [CPPStatement (c@(CPPVerbStat _))]) = pretty c + pretty (CPPCompound [CPPStatement a]) = pretty a + pretty (CPPCompound l) = lbrace $+$ (nest 2 $ vcat $ map pretty l) $+$ rbrace + pretty (CPPIf c t (Just f)) = text "if" <+> parens (pretty c) <+> braces (pretty t) <+> text "else" <+> braces (pretty f) + pretty (CPPIf c t Nothing) = text "if" <+> parens (pretty c) <+> braces (pretty t) + pretty (CPPSwitch x b) = text "switch (" <> pretty x <> text ") {" <+> pretty b <+> text "}" + pretty (CPPWhile x False b) = text "while" <> (parens $ pretty x) <+> (braces $ pretty b) + pretty (CPPWhile x True b) = text "do" <+> (braces $ pretty b) <+> text "while" <> (parens $ pretty x) <> semi + pretty (CPPFor f1 f2 f3 b) = text "for (" <> pretty f1 <> text ";" <+> pretty f2 <> text ";" <+> pretty f3 <> text ") {" $+$ nest 2 (pretty b) $+$ text "}" + pretty (CPPGoto l) = text ("goto " ++ l ++ ";") + pretty (CPPCont) = text "continue;" + pretty (CPPBreak) = text "break;" + pretty (CPPReturn x) = (text "return" <+> pretty x) <> text ";" + pretty (CPPDelete x) = (text "delete" <+> pretty x) <> text ";" + pretty (CPPVerbStat l) = lbrace $+$ (nest 2 $ vcat $ map text l) $+$ rbrace + +instance Pretty CPPQual where + pretty (CPPQualConst) = text "const" + pretty (CPPQualVolatile) = text "volatile" + +instance Pretty CPPStorSpec where + pretty (CPPAuto) = text "auto" + pretty (CPPRegister) = text "register" + pretty (CPPStatic) = text "static" + pretty (CPPExtern) = text "extern" + pretty (CPPTypedef) = text "typedef" + pretty (CPPInline) = text "inline" + pretty (CPPVirtual) = text "virtual" + +instance Pretty a => Pretty [a] where + pretty [] = empty + pretty [a] = pretty a + pretty (a:b) = pretty a <+> pretty b + +instance Pretty CPPVisibility where + pretty CPPPublic = text "public" + pretty CPPPrivate = text "private" + pretty CPPProtected = text "protected" + +instance Pretty (CPPType,Doc,Int,[CPPQual]) where + pretty (CPPPtr qual typ,s,l,q) = pretty (typ,char '*' <> (pretty q <+> (prio 4 l s)),4::Int,qual) + pretty (CPPRef qual typ,s,l,q) = pretty (typ,char '&' <> (pretty q <+> (prio 4 l s)),4::Int,qual) + pretty (CPPArray qual typ len,s,l,_) = pretty (typ,((prio 2 l s) <> lbrack <> pretty len <> rbrack),2::Int,qual) + pretty (CPPTypePrim prim,s,l,q) = pretty q <+> (text prim <+> s) + pretty (CPPTempl prim lst,s,l,q) = pretty q <+> (text prim <> char '<' <> (hcat $ punctuate comma $ map pretty lst) <> char '>') <+> s + +instance Pretty (CPPType,Doc) where + pretty (typ,doc) = pretty (typ,doc,0 :: Int,[]::[CPPQual]) + +instance Pretty CPPType where + pretty x = pretty (x,empty) + +prettyString Nothing = empty +prettyString (Just x) = text x + +instance Pretty CPPDecl where + pretty (CPPDecl { cppDeclName=name, cppType = typ, cppTypeQual = qual, cppTypeStor = stor, cppDeclInit=Nothing }) = pretty stor <+> pretty (typ,prettyString name,0 :: Int,qual) + pretty (CPPDecl { cppDeclName=name, cppType = typ, cppTypeQual = qual, cppTypeStor = stor, cppDeclInit=Just (CPPInitValue code) }) = pretty stor <+> pretty (typ,prettyString name,0 :: Int,qual) <> char '=' <> pretty code + pretty (CPPDecl { cppDeclName=name, cppType = typ, cppTypeQual = qual, cppTypeStor = stor, cppDeclInit=Just (CPPInitCall args) }) = pretty stor <+> pretty (typ,prettyString name,0 :: Int,qual) <> lparen <> (hcat $ punctuate comma $ map pretty args) <> rparen + pretty (CPPDecl { cppDeclName=name, cppType = typ, cppTypeQual = qual, cppTypeStor = stor, cppDeclInit=Just (CPPInitArray args) }) = pretty stor <+> pretty (typ,prettyString name,0 :: Int,qual) <> char '=' <> lbrace <> (hcat $ punctuate comma $ map pretty args) <> rbrace + +instance Pretty CPPDef where + pretty (CPPDef { cppDefName=name, cppDefRetType=typ, cppDefStor=stor, cppDefArgs=args, cppDefBody = body, cppDefQual=qual }) = + let pre = (pretty stor <+> pretty (typ, text name)) <> parens (hcat $ punctuate comma $ map pretty args) <+> (hsep $ map pretty qual) + in case body of + Nothing -> pre <> text ";" + Just b -> pre <+> text "{" $+$ (nest 2 $ pretty b) $+$ text "}" + +instance Pretty (CPPConstr,String) where + pretty (CPPConstr { cppConstrStor=stor, cppConstrArgs=args, cppConstrBody=body, cppConstrInit=ini },name) = + let pre = (pretty stor <+> text name) <> parens (hcat $ punctuate comma $ map pretty args) + init [] = empty + init lst = colon <+> (hcat $ punctuate (text ", ") $ map (\(tp,args) -> pretty tp <> (parens $ hcat $ punctuate comma $ map pretty args)) lst) + in case body of + Nothing -> (pre <+> init ini) <> text ";" + Just b -> (pre <+> init ini) <+> text "{" $+$ (nest 2 $ pretty b) $+$ text "}" + +instance Pretty CPPBlockItem where + pretty (CPPStatement stat) = pretty stat + pretty (CPPBlockDecl decl) = pretty decl <> text ";" + pretty (CPPComment str) = text "//" <+> text str + +instance Pretty CPPMacroStm where + pretty (CPPMacroIncludeUser str) = text "#include" <+> (text $ "\"" ++ str ++"\"") + pretty (CPPMacroIncludeSys str) = text "#include" <+> (text $ "<" ++ str ++ ">") + pretty (CPPMacroDefine { cppMacroDefName = name, cppMacroDefArgs = Nothing, cppMacroDefExpr = expr }) = text "#define" <+> text name <+> text expr + pretty (CPPMacroDefine { cppMacroDefName = name, cppMacroDefArgs = Just lst, cppMacroDefExpr = expr }) = text $ "#define " ++ name ++ "(" ++ (foldr1 (\a b -> a++","++b) lst) ++ ")" ++ " " ++ expr + +instance Pretty CPPElement where + pretty (CPPElemNamespace (name,ns)) = (text "namespace" <+> text name <+> lbrace) $+$ nest 2 (pretty ns) $+$ rbrace + pretty (CPPElemDecl decl) = pretty decl <> semi + pretty (CPPElemDef def) = pretty def + pretty (CPPElemClass cls) = pretty cls + +instance Pretty CPPNamespace where + pretty (CPPNamespace list) = vcat $ map (\x -> pretty x $+$ char ' ') list + +instance Pretty CPPClass where + pretty (CPPClass { cppClassName = name, cppClassInherit = inh, cppClassDecls = decls, cppClassDefs = defs, cppClassConstrs = constrs }) = + let sel vis lst = map snd $ filter (\x -> fst x == vis) lst + inhh [] = empty + inhh lst = colon <+> (hcat $ punctuate (text ", ") $ map (\(vis,tp) -> pretty vis <+> pretty tp) lst) + decl vis = case sel vis decls of + [] -> empty + lst -> (nest (-2) (pretty vis) <> char ':') $+$ vcat (map (\x -> pretty x <> semi) lst) $+$ text " " + def vis = case sel vis defs of + [] -> empty + lst -> (nest (-2) (pretty vis) <> char ':') $+$ vcat (map pretty lst) $+$ text " " + constr vis = case sel vis constrs of + [] -> empty + lst -> (nest (-2) (pretty vis) <> char ':') $+$ vcat (map (\x -> pretty (x,name)) lst) $+$ text " " + comb vis = constr vis $+$ def vis + in (text "class" <+> text name <+> inhh inh <+> char '{') $+$ nest 2 (decl CPPPrivate $+$ decl CPPProtected $+$ decl CPPPublic $+$ comb CPPPrivate $+$ comb CPPProtected $+$ comb CPPPublic) $+$ char '}' <> semi + +instance Pretty CPPFile where + pretty (CPPFile { cppMacroStm = macro, cppUsing = using, cppTranslUnit = unit }) = vcat (map pretty macro) $+$ text " " $+$ vcat (map (\x -> text "using" <+> text "namespace" <+> text x <> semi) using) $+$ text " " $+$ pretty unit + +codegen :: Pretty x => x -> String +codegen = render . pretty diff --git a/src/Language/CPP/Syntax/AST.hs b/src/Language/CPP/Syntax/AST.hs new file mode 100644 --- /dev/null +++ b/src/Language/CPP/Syntax/AST.hs @@ -0,0 +1,174 @@ +-- AST for C++ code + +{- based on: + language-c-0.3.1.1: Analysis and generation of C code + Language.C.Syntax.AST + + Abstract syntax of C++ source and header files. +-} + +module Language.CPP.Syntax.AST where + +data CPPFile = CPPFile { cppMacroStm :: [CPPMacroStm], cppUsing :: [String], cppTranslUnit :: CPPNamespace } + deriving (Eq,Ord,Show) + +data CPPMacroStm = + CPPMacroIncludeUser String + | CPPMacroIncludeSys String + | CPPMacroDefine { cppMacroDefName:: String, cppMacroDefArgs :: Maybe [String], cppMacroDefExpr :: String } + deriving (Eq,Ord,Show) + +data CPPElement = + CPPElemNamespace (String,CPPNamespace) + | CPPElemDecl CPPDecl + | CPPElemDef CPPDef + | CPPElemClass CPPClass + deriving (Eq,Ord,Show) + +data CPPNamespace = CPPNamespace [CPPElement] + deriving (Eq,Ord,Show) + +data CPPClass = CPPClass { cppClassName :: String, cppClassInherit :: [(CPPVisibility,CPPType)], cppClassDecls :: [(CPPVisibility,CPPDecl)], cppClassDefs :: [(CPPVisibility,CPPDef)], cppClassConstrs :: [(CPPVisibility,CPPConstr)] } + deriving (Eq,Ord,Show) + +data CPPVisibility = + CPPPublic + | CPPProtected + | CPPPrivate + deriving (Eq,Ord,Show) + +-- TODO: function pointers +-- TODO: struct/union/enum +data CPPType = + CPPTypePrim String + | CPPArray [CPPQual] CPPType (Maybe CPPExpr) + | CPPPtr [CPPQual] CPPType + | CPPRef [CPPQual] CPPType + | CPPTempl String [CPPType] + deriving (Eq,Ord,Show) + +data CPPStorSpec = + CPPAuto + | CPPRegister + | CPPStatic + | CPPExtern + | CPPTypedef + | CPPInline + | CPPVirtual + deriving (Eq,Ord,Show) + +data CPPQual = + CPPQualConst + | CPPQualVolatile + deriving (Eq,Ord,Show) + +data CPPInit = + CPPInitValue CPPExpr + | CPPInitCall [CPPExpr] + | CPPInitArray [CPPExpr] + deriving (Eq,Ord,Show) + +data CPPDecl = CPPDecl { cppDeclName :: Maybe String, cppType :: CPPType, cppTypeQual :: [CPPQual], cppTypeStor :: [CPPStorSpec], cppDeclInit :: Maybe CPPInit } + deriving (Eq,Ord,Show) + +data CPPDef = CPPDef { cppDefName :: String, cppDefRetType :: CPPType, cppDefStor :: [CPPStorSpec], cppDefQual :: [CPPQual], cppDefArgs :: [CPPDecl], cppDefBody :: Maybe CPPStat } + deriving (Eq,Ord,Show) + +data CPPConstr = CPPConstr { cppConstrStor :: [CPPStorSpec], cppConstrArgs :: [CPPDecl], cppConstrBody :: Maybe CPPStat, cppConstrInit :: [(Either CPPExpr CPPType,[CPPExpr])] } + deriving (Eq,Ord,Show) + +data CPPStat = + CPPLabel String CPPStat + | CPPCase CPPExpr CPPStat + | CPPDefault CPPStat + | CPPSimple CPPExpr + | CPPCompound [CPPBlockItem] + | CPPVerbStat [String] + | CPPIf CPPExpr CPPStat (Maybe CPPStat) + | CPPSwitch CPPExpr CPPStat + | CPPWhile CPPExpr Bool CPPStat + | CPPFor (Either (Maybe CPPExpr) CPPDecl) (Maybe CPPExpr) (Maybe CPPExpr) CPPStat + | CPPGoto String + | CPPCont + | CPPBreak + | CPPReturn (Maybe CPPExpr) + | CPPDelete CPPExpr + deriving (Eq,Ord,Show) + +data CPPBlockItem = + CPPStatement CPPStat + | CPPBlockDecl CPPDecl + | CPPComment String + deriving (Eq,Ord,Show) + +data CPPExpr = + CPPComma [CPPExpr] + | CPPAssign CPPExpr CPPAssignOp CPPExpr + | CPPBinary CPPExpr CPPBinaryOp CPPExpr + | CPPUnary CPPUnaryOp CPPExpr + | CPPCond CPPExpr (Maybe CPPExpr) CPPExpr + | CPPCast CPPType CPPExpr + | CPPSizeOfExpr CPPExpr + | CPPSizeOfType CPPType + | CPPIndex CPPExpr CPPExpr + | CPPCall CPPExpr [CPPExpr] + | CPPMember CPPExpr String Bool + | CPPVar String + | CPPConst CPPConst + | CPPNew CPPType [CPPExpr] + deriving (Eq,Ord,Show) + +data CPPConst = + CPPConstInt Integer + | CPPConstChar String + | CPPConstFloat String + | CPPConstString String + deriving (Eq,Ord,Show) + +data CPPAssignOp = + CPPAssOp + | CPPAssOpMul + | CPPAssOpDiv + | CPPAssOpRmd + | CPPAssOpAdd + | CPPAssOpSub + | CPPAssOpShl + | CPPAssOpShr + | CPPAssOpAnd + | CPPAssOpOr + | CPPAssOpXor + deriving (Eq,Ord,Show) + +data CPPUnaryOp = + CPPOpPreInc + | CPPOpPostInc + | CPPOpPreDec + | CPPOpPostDec + | CPPOpAdr + | CPPOpInd + | CPPOpPlus + | CPPOpMinus + | CPPOpComp + | CPPOpNeg + deriving (Eq,Ord,Show) + +data CPPBinaryOp = + CPPOpMul + | CPPOpDiv + | CPPOpRmd + | CPPOpAdd + | CPPOpSub + | CPPOpShl + | CPPOpShr + | CPPOpLe + | CPPOpGr + | CPPOpLeq + | CPPOpGeq + | CPPOpEq + | CPPOpNeq + | CPPOpAnd + | CPPOpOr + | CPPOpXor + | CPPOpLAnd + | CPPOpLOr + deriving (Eq,Ord,Show)