monadiccp 0.6.1 → 0.7.0
raw patch · 66 files changed
+12016/−2981 lines, 66 filesdep +Monatrondep +prettydep ~basenew-uploader
Dependencies added: Monatron, pretty
Dependency ranges changed: base
Files
- Control/CP/ComposableTransformers.hs +4/−4
- Control/CP/Debug.hs +10/−1
- Control/CP/EnumTerm.hs +88/−77
- Control/CP/FD/Decompose.hs +698/−0
- Control/CP/FD/Example.hs +136/−0
- Control/CP/FD/Example/Example.hs +0/−44
- Control/CP/FD/Expr.hs +0/−236
- Control/CP/FD/FD.hs +1537/−244
- Control/CP/FD/Gecode/CodegenSolver.hs +1046/−473
- Control/CP/FD/Gecode/Common.hs +1677/−277
- Control/CP/FD/Gecode/Interface.hsc +257/−71
- Control/CP/FD/Gecode/Runtime.hs +158/−0
- Control/CP/FD/Gecode/RuntimeSearch.hs +226/−0
- Control/CP/FD/Gecode/RuntimeSolver.hs +0/−291
- Control/CP/FD/Gecode/Translate.hs +0/−203
- Control/CP/FD/Graph.hs +411/−0
- Control/CP/FD/Interface.hs +222/−0
- Control/CP/FD/Model.hs +192/−0
- Control/CP/FD/OvertonFD/Domain.hs +15/−4
- Control/CP/FD/OvertonFD/OvertonFD.hs +41/−32
- Control/CP/FD/OvertonFD/Sugar.hs +94/−98
- Control/CP/FD/SimpleFD.hs +190/−0
- Control/CP/FD/Solvers.hs +20/−17
- Control/CP/Herbrand/Herbrand.hs +0/−209
- Control/CP/Herbrand/HerbrandT.hs +0/−57
- Control/CP/Herbrand/Prolog.hs +0/−88
- Control/CP/Herbrand/PrologTerm.hs +0/−37
- Control/CP/Mixin.hs +0/−24
- Control/CP/SearchSpec/Generator.hs +1364/−0
- Control/CP/SearchSpec/Language.hs +345/−0
- Control/CP/SearchTree.hs +36/−12
- Control/CP/Solver.hs +17/−3
- Control/CP/Transformers.hs +4/−3
- Control/Mixin/Mixin.hs +60/−0
- Data/Expr/Data.hs +297/−0
- Data/Expr/Sugar.hs +286/−0
- Data/Expr/Util.hs +481/−0
- Data/Linear.hs +82/−0
- Language/CPP/Pretty.hs +241/−0
- Language/CPP/Syntax/AST.hs +174/−0
- examples/AllInterval.hs +25/−15
- examples/Alpha.hs +49/−57
- examples/BIBD.hs +29/−0
- examples/Domino.hs +95/−0
- examples/EFPA.hs +22/−0
- examples/GolombRuler.hs +30/−0
- examples/GraphColor.hs +414/−0
- examples/Grocery.hs +13/−13
- examples/LangfordNumber.hs +27/−0
- examples/MagicSeries.hs +20/−0
- examples/MagicSquare.hs +29/−26
- examples/MineSweeper.hs +46/−0
- examples/Olympic.hs +0/−51
- examples/Partition.hs +27/−68
- examples/PerfectSquare.hs +26/−0
- examples/Queens.hs +15/−17
- examples/Ring.hs +0/−30
- examples/StressDomain.hs +0/−23
- examples/Sudoku.hs +46/−0
- examples/Test.hs +15/−0
- examples/TestPretty.hs +20/−0
- examples/TryDemo.hs +0/−19
- examples/Zebra.hs +0/−39
- lib/gecodeglue.cpp +612/−107
- lib/gecodeglue.h +6/−1
- monadiccp.cabal +41/−10
Control/CP/ComposableTransformers.hs view
@@ -226,13 +226,13 @@ -- BRANCH & BOUND -------------------------------------------------------------------------------- -newtype CBranchBoundST (solver :: * -> *) a = CBBST (NewBound solver) +newtype CBranchBoundST (solver :: * -> *) a = CBBST (NewBound solver) data BBEvalState solver = BBP Int (Bound solver) -type Bound solver = forall a. Tree solver a -> Tree solver a+type Bound solver = forall a. (Tree solver a -> Tree solver a) type NewBound solver = solver (Bound solver) -instance Solver solver => CTransformer (CBranchBoundST solver a) where+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@@ -240,7 +240,7 @@ initCT _ = (BBP 0 id,0) nextCT tree c es@(BBP nv bound) v eval continue exit | nv > v = eval (bound tree) es nv- | otherwise = eval tree es v+ | otherwise = eval tree es v returnCT (CBBST newBound) (BBP v bound) continue exit = do bound' <- newBound continue $ BBP (v + 1) bound'
Control/CP/Debug.hs view
@@ -1,13 +1,22 @@ {-# LANGUAGE CPP #-} module Control.CP.Debug (- 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
Control/CP/EnumTerm.hs view
@@ -1,102 +1,113 @@-{-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TransformListComp #-}+{-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE FlexibleContexts #-} module Control.CP.EnumTerm (- EnumTerm,- TermDomain,- get_domain_size,- get_value,- split_domain_partial,- split_domain,- split_domains,- in_order,- firstfail,- middleout,- endsout,- interleave,- assignment,- assignments,- enumerate,- label+ EnumTerm(..),+ assignment, assignments,+ inOrder, firstFail, middleOut, endsOut,+ labelling, levelList, enumerate ) where import GHC.Exts (sortWith) -import Data.List (splitAt)-import Control.CP.SearchTree hiding (label) import Control.CP.Solver+import Control.CP.SearchTree ------------------------------------------------------------------------------------ ENUMERATION---------------------------------------------------------------------------------+class (Solver s, Term s t, Show (TermBaseType s t)) => EnumTerm s t where+ type TermBaseType s t :: * -class (Term s t, Enum (TermDomain s t)) => EnumTerm s t where- type TermDomain s t :: *- get_domain_size :: t -> s Int- get_value :: t -> s (Maybe (TermDomain s t))- split_domain_partial :: t -> s [Tree s ()]- - split_domain :: t -> s (Tree s ())- split_domain v = do- let rec tree = do- tree- Label $ do- x <- get_value v- case x of- Nothing -> split_domain v- Just _ -> return $ return ()- lst <- split_domain_partial v- return $ levelList $ map rec lst- - split_domains :: [t] -> s (Tree s ())- split_domains [] = return $ return ()- split_domains [a] = split_domain a- split_domains (a:b) = do- ta <- split_domain a- tb <- split_domains b- return $ ta /\ tb- - label :: ([t] -> s [t]) -> [t] -> Tree s ()- label o l = Label $ do- x <- o l- split_domains x- - enumerate :: [t] -> Tree s ()- enumerate l = label firstfail l+ 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 ()) -levelList :: Solver s => [Tree s ()] -> Tree s ()-levelList [] = Fail-levelList [a] = a-levelList l = - let len = length l- (p1,p2) = splitAt (len `div` 2) l- in Try (levelList p1) (levelList p2)+ 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) -in_order :: Monad m => a -> m a-in_order = return + 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) -firstfail qs = do ds <- mapM get_domain_size qs + 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 ] -middleout l = let n = (length l) `div` 2 in- interleave (drop n l) (reverse $ take n l)+inOrder :: EnumTerm s t => [t] -> s [t]+inOrder = return -endsout l = let n = (length l) `div` 2 in- interleave (reverse $ drop n l) (take n l)+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 ------------------------------------------------------------------------------------ RESULT-----------------------------------------------------------------------------------assignment :: EnumTerm s t => t -> Tree s (TermDomain s t)-assignment q = Label $ get_value q >>= \(Just x) -> return $ Return x+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 -assignments :: EnumTerm s t => [t] -> Tree s [TermDomain s t]-assignments = mapM assignment+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
+ Control/CP/FD/Decompose.hs view
@@ -0,0 +1,698 @@+{- + - 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++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)
+ Control/CP/FD/Example.hs view
@@ -0,0 +1,136 @@+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE CPP #-}+{-# 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,+ ExampleModel, ExampleMinModel, + module Control.CP.FD.Interface,+) where+++import System (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.Gecode.CodegenSolver+import Control.CP.FD.Gecode.Common+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++#ifdef RGECODE+import Control.CP.FD.Gecode.Runtime+import Control.CP.FD.Gecode.RuntimeSearch++setSearchMinimize :: Tree (FDInstance (GecodeWrappedSolver SearchGecodeSolver)) ()+setSearchMinimize = do+ term <- label $ + do+ x <- getMinimizeTerm+ return $ return x+ label $ do+ liftFD $ liftGC $ Control.CP.FD.Gecode.RuntimeSearch.setOptions (\o -> o { minimizeVar = term })+ return $ return ()+#endif++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++codegenOptionset :: (CodegenGecodeOptions -> CodegenGecodeOptions) -> Tree (FDInstance (GecodeWrappedSolver CodegenGecodeSolver)) ()+codegenOptionset f = label ((liftFD $ liftGC $ Control.CP.FD.Gecode.CodegenSolver.setOptions f) >> return true)++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+ ("gecode_compile":r) -> putStr $ generateGecode ((f r) :: Tree (FDInstance (GecodeWrappedSolver CodegenGecodeSolver)) ModelCol)+ ("gen_gecode_compile":r) -> putStr $ generateGecode ((\x -> codegenOptionset (\c -> c { noGenSearch=True }) >> fx x) :: ModelInt -> Tree (FDInstance (GecodeWrappedSolver CodegenGecodeSolver)) ModelCol)+ ("gen_gecode_compile_notrail":r) -> putStr $ generateGecode ((\x -> codegenOptionset (\c -> c { noTrailing=True, noGenSearch=True }) >> fx x) :: ModelInt -> Tree (FDInstance (GecodeWrappedSolver CodegenGecodeSolver)) ModelCol)+ ("gen_gecode_compile_gensrch":r) -> putStr $ generateGecode ((\x -> codegenOptionset (\c -> c { noGenSearch=False }) >> fx x) :: ModelInt -> Tree (FDInstance (GecodeWrappedSolver CodegenGecodeSolver)) ModelCol)+#ifdef RGECODE+ ("gecode_run":r) -> print $ runSolve typ $ ((f r) :: Tree (FDInstance (GecodeWrappedSolver RuntimeGecodeSolver)) ModelCol) >>= labeller+ ("gecode_run_cont":r) -> print $ runSolve typ $ ((runContT (f r >>= labeller) Return) :: Tree (FDInstance (GecodeWrappedSolver RuntimeGecodeSolver)) [Integer])+ ("gecode_search":r) -> print $ runSolve typ $ ((f r >>= (\x -> setSearchMinimize >> return x)) :: Tree (FDInstance (GecodeWrappedSolver SearchGecodeSolver)) ModelCol) >>= labelCol+#endif+ ("overton_run":r) -> print $ runSolve typ $ ((f r) :: Tree (FDInstance OvertonFD) ModelCol) >>= labeller+ [] -> putStr "Solver type required: one of gecode_compile, gen_gecode_compile, gecode_run, gecode_run_cont, 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
− Control/CP/FD/Example/Example.hs
@@ -1,44 +0,0 @@-{-# LANGUAGE Rank2Types #-}-{-# LANGUAGE CPP #-}--module Control.CP.FD.Example.Example (- example_main,- example_main_void,- example_main_single,- FDModel-) where---import System (getArgs)--import Control.CP.ComposableTransformers-import Control.CP.FD.Gecode.Translate-import Control.CP.FD.Solvers-import Control.CP.FD.FD-import Control.CP.EnumTerm-import Control.CP.SearchTree hiding (label)--#ifdef RGECODE-import Control.CP.FD.Gecode.RuntimeSolver-#endif--example_main :: (forall s. FDSolver s => [String] -> FDTree s [FDExpr s]) -> IO ()-example_main f = do- args <- getArgs- case args of- ("gecode_compile":r) -> putStr $ generate_gecode $ as_gecode_codegen $ f r-#ifdef RGECODE- ("gecode_run":r) -> print $ solve dfs fs $ as_gecode_runtime $ f r >>= \l -> enumerate l /\ assignments l- ("gecode_search":r) -> print $ solve dfs fs $ as_gecode_search $ f r >>= \l -> enumerate l /\ assignments l-#endif- ("overton_run":r) -> print $ solve dfs fs $ as_overtonfd $ f r >>= \l -> enumerate l /\ assignments l- [] -> putStr "Solver type required\n"- (a:r) -> putStr ("Unsupported solver: " ++ a ++ "\n")--example_main_void :: (forall s. FDSolver s => FDTree s [FDExpr s]) -> IO ()-example_main_void f = example_main (const f)--example_main_single :: Read n => (forall s. FDSolver s => n -> FDTree s [FDExpr s]) -> IO ()-example_main_single f = example_main (f . read . head)--type FDModel = FDSolver s => Tree (FDWrapper s) [FDExpr s]
− Control/CP/FD/Expr.hs
@@ -1,236 +0,0 @@-{- - - Monadic Constraint Programming- - http://www.cs.kuleuven.be/~toms/Haskell/- - Tom Schrijvers & Pieter Wuille- -}-{-# LANGUAGE MultiParamTypeClasses #-}-{-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE ScopedTypeVariables #-}--module Control.CP.FD.Expr (- Expr(..),- ToExpr(..),- ExprKey(..),- unExprKey-) where --import GHC.Exts (sortWith)-import qualified Control.CP.PriorityQueue as PriorityQueue-import qualified Data.Sequence--import Control.CP.SearchTree hiding (label)-import Control.CP.Transformers-import Control.CP.ComposableTransformers-import Control.CP.Queue-import Control.CP.Solver-import Control.CP.EnumTerm-import Control.CP.Debug-import Control.CP.Mixin---- some simple kinds of expressions-data Expr t =- Term t- | Const Integer- | Plus (Expr t) (Expr t)- | Minus (Expr t) (Expr t)- | Mult (Expr t) (Expr t)- | Div (Expr t) (Expr t)- | Mod (Expr t) (Expr t)- | Abs (Expr t)- deriving (Show,Eq)--varrefs :: forall s. Expr s -> Int-varrefs (Term _) = 1-varrefs (Const _) = 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--simplify :: (Eq s, Show s) => Expr s -> Expr s--- 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 (Const 0) _) = Const 0-simplify (Div (Const 0) _) = Const 0-simplify (Mod (Const 0) _) = Const 0-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 `div` b)-simplify (Plus (Const 0) a) = a-simplify (Mult (Const 1) a) = a-simplify (Div a (Const 1)) = a---- level 1 (result in one recursive call to simplify)-simplify (Plus a b) | a==b = 2 * a-simplify (Div a (Const (-1))) = negate a-simplify (Plus (Const c) (Plus (Const a) b)) = (Const $ c+a) + b-simplify (Plus (Const c) (Minus (Const a) b)) = (Const $ c+a) - b-simplify (Minus (Const c) (Plus (Const a) b)) = (Const $ c-a) - b-simplify (Minus (Const c) (Minus (Const a) b)) = (Const $ c-a) + b-simplify (Mult (Const c) (Mult (Const a) b)) = (Const $ a*c) * b-simplify (Div (Mult (Const a) b) (Const c)) | (a `mod` c)==0 = (Const (a `div` c)) * b---- level 2 (result in two recursive calls to simplify)-simplify (Plus a (Mult b c)) | a==b && ((varrefs a)>0) = (c+1) * a-simplify (Plus a (Mult b c)) | a==c && ((varrefs a)>0) = (b+1) * a-simplify (Plus (Mult b c) a) | a==b && ((varrefs a)>0) = (c+1) * a-simplify (Plus (Mult b c) a) | a==c && ((varrefs a)>0) = (b+1) * a-simplify (Plus (Mult a b) (Mult c d)) | a==c = (b+d) * a-simplify (Plus (Mult a b) (Mult c d)) | a==d = (b+c) * a-simplify (Plus (Mult a b) (Mult c d)) | b==c = (a+d) * b-simplify (Plus (Mult a b) (Mult c d)) | b==d = (a+c) * b-simplify (Minus a (Mult b c)) | a==b && ((varrefs a)>0) = (1-c) * a-simplify (Minus a (Mult b c)) | a==c && ((varrefs a)>0) = (1-b) * a-simplify (Minus (Mult b c) a) | a==b && ((varrefs a)>0) = (c-1) * a-simplify (Minus (Mult b c) a) | a==c && ((varrefs a)>0) = (b-1) * a-simplify (Minus (Mult a b) (Mult c d)) | a==c = (b-d) * a-simplify (Minus (Mult a b) (Mult c d)) | a==d = (b-c) * a-simplify (Minus (Mult a b) (Mult c d)) | b==c = (a-d) * b-simplify (Minus (Mult a b) (Mult c d)) | b==d = (a-c) * b-simplify (Mult (Abs a) (Abs b)) = abs (a*b)-simplify (Div (Abs a) (Abs b)) = abs (a `div` 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)) = (Const c) + a-simplify (Minus a (Const c)) = (Const (-c)) + a-simplify (Mult a (Const c)) = (Const c) * a-simplify (Mult (Const (-1)) a) = negate a---- level 2-simplify (Mult (Const c) (Plus (Const a) b)) = (Const (a*c)) + ((Const c)*b)-simplify (Mult (Const c) (Minus (Const a) b)) = (Const (a*c)) - ((Const c)*b)-simplify (Plus a (Plus (Const b) c)) = (Const b) + (a+c)-simplify (Plus a (Minus (Const b) c)) = (Const b) + (a-c)-simplify (Minus a (Plus (Const b) c)) = (Const (-b)) + (a-c)-simplify (Minus a (Minus (Const b) c)) = (Const (-b)) + (a+c)-simplify (Mult a (Mult (Const b) c)) = (Const b) * (a*c)-simplify (Plus (Plus (Const a) b) c) = (Const a) + (b+c)-simplify (Plus (Minus (Const a) b) c) = (Const a) + (c-b)-simplify (Minus (Plus (Const a) b) c) = (Const a) + (b-c)-simplify (Minus (Minus (Const a) b) c) = (Const a) - (b+c)-simplify (Mult (Mult (Const a) b) c) = (Const a) * (b*c)-simplify (Mult a (Minus (Const 0) b)) = negate (a*b)-simplify (Mult (Minus (Const 0) b) a) = negate (a*b)-simplify (Div (Minus (Const 0) a) b) = negate $ a `div` b-simplify (Div a (Minus (Const 0) b)) = negate $ a `div` b--- fallback rule-simplify a = a--instance (Eq s, Show s) => Num (Expr s) where- a + b = simplify $ Plus a b- a - b = simplify $ Minus a b- a * b = simplify $ Mult a b- abs a = simplify $ Abs a- negate a = 0 - a- fromInteger c = Const $ fromInteger c- signum (Const a) = Const (signum a)- signum a = error "signum not possible for generic Expr"--instance (Eq s, Show s) => Ord (Expr s) where- compare (Const x) (Const y) = compare x y- compare _ _ = error "compare not possible for generic Expr"--instance (Eq s, Show s) => Real (Expr s) where- toRational (Const x) = toRational x- toRational _ = error "toRational not possible for generic Expr"--instance (Eq s, Show s) => Enum (Expr s) where- succ a = a + 1- pred a = a - 1- toEnum = Const . toEnum- fromEnum (Const a) = fromEnum a- fromEnum _ = error "fromEnum not possible for generic Expr"--instance (Eq s, Show s) => Integral (Expr s) where- toInteger (Const a) = toInteger a- toInteger _ = error "toInteger not possible for generic Expr"- divMod a b = (simplify $ Div a b, simplify $ Mod a 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"---- a class of types convertible to expressions-class ToExpr tt t where- toExpr :: t -> Expr tt---- integers can be used as constant expressions-instance ToExpr tt Integer where- toExpr = Const---- ints can be used as constant expressions-instance ToExpr tt Int where- toExpr = Const . toInteger---- expressions themselves are trivially convertible to expressions-instance ToExpr t (Expr t) where- toExpr = id---- the terms used by the solver can be used as expressions referring--- to a variable-instance ToExpr t t where- toExpr = Term------------------------------------------------------------------------------------- ExprKey-----------------------------------------------------------------------------------newtype ExprKey s = ExprKey (Expr s)- deriving (Eq, Show)--unExprKey :: ExprKey s -> Expr s-unExprKey (ExprKey x) = x--instance Ord s => Ord (ExprKey s) where- -- consts- compare (ExprKey (Const i1)) (ExprKey (Const i2)) = compare i1 i2- compare (ExprKey (Const _)) _ = LT- compare _ (ExprKey (Const _)) = GT- -- abs- compare (ExprKey (Abs i1)) (ExprKey (Abs i2)) = compare (ExprKey i1) (ExprKey i2)- compare (ExprKey (Abs _)) _ = LT- compare _ (ExprKey (Abs _)) = GT- -- plus- compare (ExprKey (Plus a1 a2)) (ExprKey (Plus b1 b2)) = case (compare (ExprKey a1) (ExprKey b1)) of- LT -> LT- GT -> GT- EQ -> compare (ExprKey a2) (ExprKey b2)- compare (ExprKey (Plus _ _)) _ = LT- compare _ (ExprKey (Plus _ _)) = GT- -- minus- compare (ExprKey (Minus a1 a2)) (ExprKey (Minus b1 b2)) = case (compare (ExprKey a1) (ExprKey b1)) of- LT -> LT- GT -> GT- EQ -> compare (ExprKey a2) (ExprKey b2)- compare (ExprKey (Minus _ _)) _ = LT- compare _ (ExprKey (Minus _ _)) = GT- -- mult- compare (ExprKey (Mult a1 a2)) (ExprKey (Mult b1 b2)) = case (compare (ExprKey a1) (ExprKey b1)) of- LT -> LT- GT -> GT- EQ -> compare (ExprKey a2) (ExprKey b2)- compare (ExprKey (Mult _ _)) _ = LT- compare _ (ExprKey (Mult _ _)) = GT- -- div- compare (ExprKey (Div a1 a2)) (ExprKey (Div b1 b2)) = case (compare (ExprKey a1) (ExprKey b1)) of- LT -> LT- GT -> GT- EQ -> compare (ExprKey a2) (ExprKey b2)- compare (ExprKey (Div _ _)) _ = LT- compare _ (ExprKey (Div _ _)) = GT- -- mod- compare (ExprKey (Mod a1 a2)) (ExprKey (Mod b1 b2)) = case (compare (ExprKey a1) (ExprKey b1)) of- LT -> LT- GT -> GT- EQ -> compare (ExprKey a2) (ExprKey b2)- compare (ExprKey (Mod _ _)) _ = LT- compare _ (ExprKey (Mod _ _)) = GT- -- variables- compare (ExprKey (Term v1)) (ExprKey (Term v2)) = compare v1 v2
Control/CP/FD/FD.hs view
@@ -1,244 +1,1537 @@-{- - - Monadic Constraint Programming- - http://www.cs.kuleuven.be/~toms/Haskell/- - Tom Schrijvers & Pieter Wuille- -}-{-# LANGUAGE MultiParamTypeClasses #-}-{-# LANGUAGE TypeFamilies #-}-{-# LANGUAGE GADTs #-}-{-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE StandaloneDeriving #-}-{-# LANGUAGE UndecidableInstances #-}-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE ScopedTypeVariables #-}--module Control.CP.FD.FD (- FDSolver(..),- fresh_var,- decompose,- compile_constraint,- FDExpr,- FDConstraint(..),- FDWrapper(..),- FDTree,- FDLabel(..),- wrap,- unwrap,- (@:), (@<), (@>), (@<=), (@>=), (@=), (@/=),- (@+), (@-), (@*), (@/), (@%), - cte,- allDiff,- sorted,- sSorted,- allin-)where --import GHC.Exts (sortWith)--import Control.CP.SearchTree hiding (label)-import Control.CP.Transformers-import Control.CP.ComposableTransformers-import Control.CP.Queue-import Control.CP.Solver-import Control.CP.EnumTerm-import Control.CP.Debug-import Control.CP.Mixin-import Control.CP.FD.Expr------------------------------------------------------------------------------------- SYNTACTIC SUGAR------------------------------------------------------------------------------------- define class FDSolver, instances of which must define a compile_constraint--- function, to convert a constraint specified in syntactic sugar to a --- corresponding search Tree. Instances must furthermore specify a--- FDTerm x type, referring to the type of terms used-class (Show (FDTerm s), Eq (FDTerm s), Term s (FDTerm s)) => FDSolver s where- -- types- type FDTerm s :: *- -- functions- specific_compile_constraint :: Mixin (FDConstraint s -> Tree s Bool)- specific_decompose :: Mixin (Expr (FDTerm s) -> Tree s (FDTerm s))- specific_fresh_var :: Mixin (Tree s (FDTerm s))- -- default implementations- specific_decompose = mixinId- specific_fresh_var = mixinId---- compile constraint + defaults-compile_constraint :: FDSolver s => FDConstraint s -> Tree s Bool-compile_constraint = mixin (specific_compile_constraint <@> default_compile_constraint)-default_compile_constraint :: FDSolver so => Mixin (FDConstraint so -> Tree so Bool)-default_compile_constraint = default_compile_alldiff - <@> default_compile_sorted - <@> default_compile_dom---- decompose + default-decompose :: FDSolver s => Expr (FDTerm s) -> Tree s (FDTerm s)-decompose = mixin (front_decompose <@> specific_decompose <@> default_decompose)-default_decompose :: FDSolver s => Mixin (Expr (FDTerm s) -> Tree s (FDTerm s))-default_decompose _ _ x = debug "default_decompose" $ do- v <- fresh_var- compile_constraint (Same x (Term v))- return v-front_decompose :: FDSolver s => Mixin (Expr (FDTerm s) -> Tree s (FDTerm s))-front_decompose s t (Term x) = debug "front_decompose Term" $ return x-front_decompose s t x = debug "front_decompose _" $ s x---- fresh_var + default-fresh_var :: FDSolver s => Tree s (FDTerm s)-fresh_var = mixin (specific_fresh_var <@> default_fresh_var)-default_fresh_var :: FDSolver s => Mixin (Tree s (FDTerm s))-default_fresh_var _ _ = debug "default_fresh_var" $ NewVar $ \v -> return v--type FDExpr s = Expr (FDTerm s)---- currently 4 simple constraints + more complex (see default compiler at the bottom)-data Show (FDTerm s) => FDConstraint s =- Less (Expr (FDTerm s)) (Expr (FDTerm s))- | Diff (Expr (FDTerm s)) (Expr (FDTerm s))- | Same (Expr (FDTerm s)) (Expr (FDTerm s))- | Dom (Expr (FDTerm s)) Integer Integer- | AllDiff [Expr (FDTerm s)]- | Sorted [Expr (FDTerm s)] Bool -- True = less-or-equal, False = less--deriving instance Show (FDTerm s) => Show (FDConstraint s)-------------------------- FDWrapper--newtype FDWrapper s a = FDWrapper { subFD :: s a }--type FDTree s a = Tree (FDWrapper s) a--newtype FDLabel s = FDLabel (Label s)--instance FDSolver s => Monad (FDWrapper s) where- FDWrapper { subFD = a } >>= f = FDWrapper { subFD = a >>= (\x -> subFD $ f x) }- return x = FDWrapper { subFD = return x }--instance FDSolver s => Solver (FDWrapper s) where- type Constraint (FDWrapper s) = FDConstraint s- type Label (FDWrapper s) = FDLabel s- add c = FDWrapper { subFD = untree False $ compile_constraint c }- run (FDWrapper { subFD = x}) = run x- mark = FDWrapper { subFD = mark >>= \x -> return (FDLabel x) }- goto (FDLabel l) = FDWrapper { subFD = goto l }--data EQHelp a b where- EQHelp :: EQHelp a a--instance (FDSolver s, t ~ Expr (FDTerm s)) => Term (FDWrapper s) t where- type Help (FDWrapper s) t = EQHelp t (Expr (FDTerm s))- help _ _ = EQHelp- newvar = FDWrapper { subFD = newvar >>= (\x -> return (Term x)) }--instance (FDSolver s, FDTerm s ~ t, Eq t, EnumTerm s t, Integral (TermDomain s t)) => EnumTerm (FDWrapper s) (Expr t) where- type TermDomain (FDWrapper s) (Expr t) = TermDomain s t- get_domain_size (Const c) = return 1- get_domain_size (Term v) = FDWrapper (get_domain_size v)- get_value (Const c) = return $ Just $ fromInteger c- get_value (Term v) = FDWrapper $ get_value v- split_domain_partial (Const c) = return [return ()]- split_domain_partial (Term v) = FDWrapper $ split_domain_partial v >>= return . map wrap- split_domain (Const c) = return $ return ()- split_domain (Term v) = FDWrapper $ split_domain v >>= return . wrap- split_domains l = FDWrapper $ split_domains (map (\x -> case x of Term t -> t) l) >>= return . wrap--unwrap :: forall s a .FDSolver s => Tree (FDWrapper s) a -> Tree s a-unwrap Fail = Fail-unwrap (Return a) = Return a-unwrap (Try l r) = Try (unwrap l) (unwrap r)-unwrap (NewVar (f :: t -> Tree (FDWrapper s) a)) = NewVar ((\v -> - case help (undefined :: FDWrapper s ()) (undefined :: t) of- EQHelp -> unwrap (f (Term v :: Expr (FDTerm s)))) - :: FDTerm s -> Tree s a)-unwrap (Add c t) = compile_constraint c >>= (\b -> if b then (unwrap t) else Fail)-unwrap (Label (FDWrapper { subFD = m })) = Label (m >>= \x -> return (unwrap x))--wrap :: forall s a .FDSolver s => Tree s a -> Tree (FDWrapper s) a-wrap Fail = Fail-wrap (Return a) = Return a-wrap (Try l r) = Try (wrap l) (wrap r)-wrap (Label m) = Label $ FDWrapper $ m >>= return . wrap-wrap (Add c t) = Label $ FDWrapper $ add c >>= \res -> if res then return $ wrap t else return $ false-wrap (NewVar f) = Label $ FDWrapper $ newvar >>= return . wrap . f----- TODO: wrap afmaken--- TODO: Tree opsplitsen in Tree (Try nodes) en Conjunction (de rest)-------------------------- Operators---- syntactic sugar for expressions-infixl 6 @+-infixl 6 @--infixl 7 @*-infixl 7 @/-infixl 7 @%-a @+ b = (toExpr a) + (toExpr b)-a @- b = (toExpr a) - (toExpr b)-a @* b = (toExpr a) * (toExpr b)-a @/ b = (toExpr a) `div` (toExpr b)-a @% b = (toExpr a) `mod` (toExpr b)-cte x = fromInteger $ toInteger x---- syntactic sugar for relations--infix 4 @:-a @: (b,c) = addC $ Dom a (toInteger b) (toInteger c)--infix 4 @<-a @< b = addC $ Less a b--infix 4 @<=-a @<= b = addC $ Less a (b + 1)--infix 4 @>-a @> b = addC $ Less b a--infix 4 @>=-a @>= b = addC $ Less b (a + 1)--infix 4 @=-a @= b = addC $ Same a b--infix 4 @/=-a @/= b = addC $ Diff a b--allDiff l = addC $ AllDiff l-sorted l = addC $ Sorted l True-sSorted l = addC $ Sorted l False--allin list range = foldr1 (/\) $ map (@: range) list-------------------------------------------------------------------------------------- Default compilations------------------------------------------------------------------------------------default_compile_alldiff :: FDSolver so => Mixin (FDConstraint so -> Tree so Bool)-default_compile_alldiff s t c = case c of- (AllDiff []) -> return True- (AllDiff (x:xs)) -> do- conj [ (t $ Diff x e) /\ return () | e <- xs ]- t $ AllDiff xs- return True- _ -> s c--default_compile_sorted :: FDSolver so => Mixin (FDConstraint so -> Tree so Bool)-default_compile_sorted s t c = case c of- (Sorted [] _) -> return True- (Sorted (x:xs) eq) -> do- conj [ (t $ Less x (if eq then e+1 else e)) /\ return () | e <- xs ]- t $ Sorted xs eq- return True- _ -> s c--default_compile_dom :: FDSolver so => Mixin (FDConstraint so -> Tree so Bool)-default_compile_dom s t c = case c of- (Dom _ l u) | l>u -> Fail- (Dom x l u) -> do- t $ Less x (Const $ u+1)- t $ Less (Const $ l-1) x- return True- _ -> s c+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE FlexibleContexts #-}+{-# 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 = \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) =+ let fb (Right x) = FDSpecInfoBool { fdspBoolSpec = nt x, fdspBoolVar = Nothing, fdspBoolVal = Nothing, fdspBoolTypes = Set.singleton $ fst x }+ fb (Left x) = x+ fi (Right x) = FDSpecInfoInt { fdspIntSpec = nt x, fdspIntVar = Nothing, fdspIntVal = Nothing, fdspIntTypes = Set.singleton $ fst x }+ fi (Left x) = x+ 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 fb b, map fi i, 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
Control/CP/FD/Gecode/CodegenSolver.hs view
@@ -1,476 +1,1049 @@ {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-}--module Control.CP.FD.Gecode.CodegenSolver (- CodegenSolver(..),- compile,- Store(..),- StoreNode(..),- StoreNodeType(..),- getVarType,- isVarImplicit,- VarBound(..),- getAllBounds-) where--import Maybe (fromMaybe,catMaybes,isJust,fromJust)-import List (findIndex,find)-import Data.Map hiding (map,filter)--import Control.Monad.State.Lazy-import Control.Monad.Trans-import Control.Monad.Cont---import Control.CP.SearchTree hiding (label)-import Control.CP.Solver-import Control.CP.FD.FD-import Control.CP.FD.Expr-import Control.CP.Debug-import Control.CP.Mixin--import Control.CP.FD.Gecode.Common------------------------------------------------------------------------------------- | Helper functions-----------------------------------------------------------------------------------repl l i v = case l of- [] -> [v]- a:ar -> if i==0- then v:ar- else repl ar (i-1) v--revrepl l i v = repl l ((length l)-i-1) v--revget l i = l !! ((length l)-i-1)--dump n l = case l of- [] -> []- (a:b) -> if (n==0) then b else a:(dump (n-1) b)------------------------------------------------------------------------------------- | Gecode Solver instance declaration----------------------------------------------------------------------------------instance Solver CodegenSolver where- type Constraint CodegenSolver = GConstraint- type Label CodegenSolver = Store- add = addGecode- run = runGecode - mark = get- goto = put------------------------------------------------------------------------------------- | CodegenSolver terms-----------------------------------------------------------------------------------instance Term CodegenSolver IntTerm where- newvar = newVar False TypeInt >>= return . IntVar- type Help CodegenSolver IntTerm = ()- help _ _ = ()--instance Term CodegenSolver BoolTerm where- newvar = newVar False TypeBool >>= return . BoolVar- type Help CodegenSolver BoolTerm = ()- help _ _ = ()------------------------------------------------------------------------------------- | CodegenSolver monad definition -----------------------------------------------------------------------------------newtype CodegenSolver a = CodegenSolver { state :: State Store a }- deriving (Monad, MonadState Store)---- instance Show (CodegenSolver a) where--- show c = show $ execState (state c) initState---type VarId = Int-type LowerBound = Maybe Integer-type UpperBound = Maybe Integer--data VarBound = VarBound { varid :: VarId, lbound :: LowerBound, ubound :: UpperBound }- deriving (Show, Eq)--type VarBoundMap = Map VarId VarBound-type VarBoundPropagator = VarBoundMap -> [ VarBound ]-----------------------------------------------------------------------------------{- |- StoreNode represents a node in the search tree.- * Each node adds new constraints and variables.- * A node is a leaf node or an internal node- -}-data StoreNode = - StoreNode { cons :: [ GConstraint ]- -- ^ new constraints added in this node- , nbounds :: [ VarBoundPropagator ]- -- ^ new bound-generator functions in this node- , nvars :: [ Int ]- -- ^ id's of variables added in this node- , dis :: StoreNodeType- -- ^ either no children, or one left and one right child- }--data StoreNodeType = SNLeaf | SNIntl StoreNode StoreNode- deriving Show--instance Show StoreNode- where show sn = "StoreNode { cons=" ++ (show $ cons sn) ++ - ", nbounds=" ++ (show $ length $ nbounds sn) ++ - ", nvars=" ++ (show $ nvars sn) ++ - ", dus=" ++ (show $ dis sn) ++- "}"-----------------------------------------------------------------------------------data VarData = VarData { vtype :: GType, vimpl :: Bool }- deriving Show--data Store = Store { vars :: Int, vardata :: [ VarData ], ctree :: StoreNode, cpath :: [ Bool ], cexpr :: Map (ExprKey (FDTerm CodegenSolver)) Int }- deriving Show---setVarImplicitHelper :: Store -> Int -> Bool -> Store-setVarImplicitHelper s p v = s { vardata = revrepl (vardata s) p ( (revget (vardata s) p) { vimpl = v } ) }--initNode = StoreNode { cons = [], dis = SNLeaf, nvars = [], nbounds=[] }-initState = Store { vars=0, vardata=[], ctree=initNode, cpath=[], cexpr=empty }--addStateTree node path con vars bounds = case (dis node,path) of- (_,[]) -> node { cons = con++(cons node), nvars = vars++(nvars node), nbounds = bounds++(nbounds node) }- (SNLeaf,s:sr) -> node { dis = if s then SNIntl initNode (addStateTree initNode sr con vars bounds) - else SNIntl (addStateTree initNode sr con vars bounds) initNode }- (SNIntl l r,s:sr) -> node { dis = if s then SNIntl l (addStateTree r sr con vars bounds) - else SNIntl (addStateTree l sr con vars bounds) r }--addState store con vars bounds = store { ctree = addStateTree (ctree store) (cpath store) con vars bounds }--getConstraintsTree tree path = (cons tree) ++ case (dis tree,path) of- (SNLeaf,_) -> []- (SNIntl l _, False:s) -> getConstraintsTree l s- (SNIntl l _, []) -> getConstraintsTree l []- (SNIntl _ r, True:s) -> getConstraintsTree r s---getConstraints state = getConstraintsTree (ctree state) (cpath state)------------------------------------------------------------------------------------- | CodegenSolver compilation-----------------------------------------------------------------------------------compile :: Tree CodegenSolver a -> Store-compile x = execGecode (buildState x)--execGecode :: CodegenSolver a -> Store-execGecode x = execState (state x) initState--buildState :: Tree CodegenSolver a -> CodegenSolver ()-buildState (Add c v) = do add c- buildState v-buildState (NewVar f) = do v <- newvar- buildState $ f v-buildState (Try l r) = do v1 <- get- let opath = cpath v1- let ocexpr = cexpr v1- put $ v1 { cpath = opath ++ [ False ], cexpr = ocexpr }- buildState l- v2 <- get- put $ v2 { cpath = opath ++ [ True ], cexpr = ocexpr }- buildState r- v3 <- get- put $ v3 { cpath = opath, cexpr = ocexpr }-buildState (Label m) = m >>= buildState-buildState _ = return ()------------------------------------------------------------------------------------- | Bounds-----------------------------------------------------------------------------------data XInt = XInfMin | XInfPlus | XInt Integer--toXInt isUpper Nothing = if isUpper then XInfPlus else XInfMin-toXInt _ (Just i) = XInt i--bndMult (XInt a) (XInt b) _ _ = [XInt (a*b)]-bndMult XInfMin XInfMin _ _ = [XInfPlus]-bndMult XInfPlus XInfMin _ _ = [XInfMin]-bndMult XInfPlus XInfPlus _ _ = [XInfPlus]-bndMult (XInt a) XInfPlus la _- | a < 0 = [XInfMin]- | a > 0 = [XInfPlus]- | a == 0 && la = [XInfPlus]- | a == 0 && not la = [XInfMin]-bndMult (XInt a) XInfMin la _- | a < 0 = [XInfPlus]- | a > 0 = [XInfMin]- | a == 0 && la = [XInfMin]- | a == 0 && not la = [XInfPlus]-bndMult a b c d = bndMult b a d c--bndDiv _ _ _ _ = [XInfMin,XInfPlus]--boundFn f v1 v2 l1 l2 = f (toXInt l1 v1) (toXInt l2 v2) l1 l2--lowestBound :: [XInt] -> XInt-lowestBound = foldl1 m - where m XInfMin _ = XInfMin- m _ XInfMin = XInfMin- m (XInt a) (XInt b) = XInt $ min a b- m (XInt a) _ = XInt a- m _ (XInt a) = XInt a- m XInfPlus XInfPlus = XInfPlus--highestBound :: [XInt] -> XInt-highestBound = foldl1 m - where m XInfPlus _ = XInfPlus- m _ XInfPlus = XInfPlus- m (XInt a) (XInt b) = XInt $ max a b- m (XInt a) _ = XInt a- m _ (XInt a) = XInt a- m XInfMin XInfMin = XInfMin--boundRelation f (i1,i2,o) b = - let (i1l,i1u) = getBounds b i1- (i2l,i2u) = getBounds b i2- bns = foldl1 (++) $ map (\(a,b,c,d) -> boundFn f a b c d) - [(i1l,i2l,False,False)- ,(i1l,i2u,False,True)- ,(i1u,i2l,True,False)- ,(i1u,i2u,True,True)- ]- xl = lowestBound bns- xu = highestBound bns- fromXInt XInfPlus = Nothing- fromXInt XInfMin = Nothing- fromXInt (XInt a) = Just a- in case (xl,xu) of- (XInfPlus,_) -> []- (_,XInfMin) -> []- (_,_) -> [VarBound { varid = o, lbound = fromXInt xl, ubound = fromXInt xu }]--catPropagators p = foldl1 (\a b -> \x -> (a x) ++ (b x)) p--linearPropagator l p c = \b -> - let (IntVar i,cc) = l !! p- (low,high) = foldl - (\x y -> case (x,y) of- ((Just l1,Just h1),(Just l2,Just h2)) -> (Just (l1-h2),Just (h1-l2))- ((Nothing,Just h1),(Just l2,_)) -> (Nothing,Just (h1-l2))- ((_,Just h1),(Just l2,Nothing)) -> (Nothing,Just (h1-l2))- ((Just l1,Nothing),(_,Just h2)) -> (Just (l1-h2),Nothing)- ( (Just l1,_),(Nothing,Just h2)) -> (Just (l1-h2),Nothing)- _ -> (Nothing,Nothing)- ) (Just c,Just c) cbounds- cbounds = map - (\x -> case x of - (c,(Just l,Just h)) -> if c<0 then (Just (c*h),Just (c*l)) else (Just (c*l),Just (c*h))- (c,(Nothing,Just h)) -> if c<0 then (Just (c*h),Nothing) else (Nothing,Just (c*h))- (c,(Just l,Nothing)) -> if c<0 then (Nothing,Just (c*l)) else (Just (c*l),Nothing)- _ -> (Nothing,Nothing)- ) dbounds- dbounds = dump p bounds- bounds = map (\(IntVar v,c) -> {- debug ("var "++(show v)++" is in "++(show $ getBounds b v)) $ -} (c,getBounds b v)) l- in (i,cc,low,high)--linearEqPropagator ll p c = \b -> case linearPropagator ll p c b of- (_,0,_,_) -> []- (i,cc,Just l,Just h) -> {- debug ("["++(if l>h then "AAAARGH! " else "")++(show ll)++"="++(show c)++"/"++(show cc)++"->["++(show p)++"]: var "++(show i)++" in ["++(show l)++".."++(show h)++"]]\n") $ -} if (cc<0) - then let x=[ VarBound i (Just ((-h) `div` (-cc))) (Just (l `div` cc)) ] in {- debug (show x) -} x- else let x=[ VarBound i (Just ((-l) `div` (-cc))) (Just (h `div` cc)) ] in {- debug (show x) -} x- (i,cc,Nothing,Just h) -> {- debug ("["++(show ll)++"="++(show c)++"/"++(show cc)++"->["++(show p)++"]: var "++(show i)++" in [.."++(show h)++"]]\n") $ -} if (cc<0) - then let x=[ VarBound i (Just ((-h) `div` (-cc))) Nothing ] in {- debug (show x) -} x- else let x=[ VarBound i Nothing (Just (h `div` cc)) ] in {- debug (show x) -} x- (i,cc,Just l,Nothing) -> {- debug ("["++(show ll)++"="++(show c)++"/"++(show cc)++"->["++(show p)++"]: var "++(show i)++" in ["++(show l)++"..]]\n") $ -} if (cc<0) - then let x=[ VarBound i Nothing (Just (l `div` cc)) ] in {- debug (show x) -} x- else let x=[ VarBound i (Just ((-l) `div` (-cc))) Nothing ] in {- debug (show x) -} x- (i,cc,_,_) -> {- debug ("["++(show ll)++"="++(show c)++"/"++(show cc)++"->["++(show p)++"]: var "++(show i)++" in [..]]\n") $ -} []--linearLessPropagator l p c = \b -> case (linearPropagator l p c b) of- (_,0,_,_) -> []- (i,cc,_,Just h) -> if (cc<0) - then [ VarBound i (Just ((1-h) `div` (-cc))) Nothing ]- else [ VarBound i Nothing (Just ((h-1) `div` cc)) ]- _ -> []--debugBoundsPropagator :: GConstraint -> VarBoundPropagator-debugBoundsPropagator c = let cc = boundsPropagator c in- \b -> let ccc = cc b in {- debug ("debugBounds: "++(show c)++" -> "++(show ccc)) -} ccc--boundsPropagator :: GConstraint -> VarBoundPropagator-boundsPropagator c = case c of- CValue (IntVar i) v -> (\_ -> [ VarBound i (Just v) (Just v) ])- CDom (IntVar i) l u -> (\_ -> [ VarBound i (Just l) (Just u) ])- CRel (IntVar i) OLess (IntVar j) -> \b ->- let (jbl,jbu) = getBounds b j- (ibl,ibu) = getBounds b i- in catMaybes [ if isJust jbu then Just $ VarBound i Nothing (Just $ (fromJust jbu)-1) else Nothing,- if isJust ibl then Just $ VarBound j (Just $ (fromJust ibl)+1) Nothing else Nothing- ]- CRel (IntVar i) OEqual (IntVar j) -> \b ->- let (jbl,jbu) = getBounds b j- (ibl,ibu) = getBounds b i- in [ VarBound i jbl jbu, VarBound j ibl ibu ]- CRel (IntVar i) OEqual (IntConst c) -> boundsPropagator $ CValue (IntVar i) c- CRel (IntConst c) OEqual (IntVar i) -> boundsPropagator $ CValue (IntVar i) c- CRel (IntVar i) OLess (IntConst c) -> (\_ -> [ VarBound i Nothing (Just (c-1)) ])- CRel (IntConst c) OLess (IntVar i) -> (\_ -> [ VarBound i (Just (c+1)) Nothing ])- CLinear [(IntVar i,f)] OEqual c | (c `mod` f)==0 -> boundsPropagator $ CValue (IntVar i) (c `div` f)- CLinear l OEqual c -> catPropagators $ map (\p -> linearEqPropagator l p c) [0..((length l)-1)]- CLinear l OLess c -> catPropagators $ map (\p -> linearLessPropagator l p c) [0..((length l)-1)]- CMult (IntVar f1) (IntVar f2) (IntVar m) -> catPropagators- [ boundRelation bndMult (f1,f2,m)- , boundRelation bndDiv (m,f1,f2)- , boundRelation bndDiv (m,f2,f1)- ]- CAbs (IntVar v1) (IntVar v2) -> \b ->- let (v1l,v1h) = getBounds b v1- (v2l,v2h) = getBounds b v2- in [ case v2h of- Nothing -> VarBound v1 Nothing Nothing- Just h -> VarBound v1 (Just (-h)) (Just h)- , case (v1l,v1h) of- (Nothing,Nothing) -> VarBound v2 (Just 0) (Nothing)- (Just l,Nothing) | l<0 -> VarBound v2 (Just 0) Nothing- (Nothing,Just h) | h>0 -> VarBound v2 (Just 0) Nothing- (Just l,Nothing) | l>=0 -> VarBound v2 (Just l) Nothing- (Nothing,Just h) | h<=0 -> VarBound v2 (Just (-h)) Nothing- (Just l,Just h) | l<=0 && h>=0 -> VarBound v2 (Just 0) (Just ((-l) `max` h))- (Just l,Just h) | h<0 -> VarBound v2 (Just (-h)) (Just (-l))- (Just l,Just h) | l>0 -> VarBound v2 (Just l) (Just h)- ]- _ -> (\_ -> [])---- Combination-propagateVarBounds :: [ VarBoundPropagator ] -> VarBoundMap -> VarBoundMap-propagateVarBounds propagators vbmap = fixP propagators vbmap- where- fixP :: [VarBoundPropagator] -> VarBoundMap -> VarBoundMap - fixP [] src = src- fixP (p:ps) src = case propagate p src of- Nothing -> fixP ps src- Just src' -> fixP propagators src'- propagate p src = - either (const Nothing) Just $ foldl combine (Left src) (p src)- where combine prev vb = prev `fromMaybe` (intersectBound vb src >>= return . Right) - where src = either id id prev---- add a new bound to a bounds map - returns Nothing if map remains unchanged, Just <newmap> otherwise-intersectBound :: VarBound -> VarBoundMap -> Maybe VarBoundMap-intersectBound nw k - | oldValue == newValue = Nothing- | otherwise = Just result- where - (oldValue,result) = insertLookupWithKey (\k n o -> n) (varid nw) (fromJust newValue) k- newValue = - (do ov <- oldValue- return $ adj ov- ) `orElse` (Just nw)- adj fnd@(VarBound {lbound = olb, ubound = oub}) = nb- where- nlb = newmax 1 olb $ lbound nw- nub = newmax (-1) oub $ ubound nw- nb = fnd { lbound = nlb, ubound = nub }- newmax f b1 b2 = - (do x <- b1- y <- b2- return $ ((f*x) `max` (f*y)) `div` f- ) `orElse` b1 `orElse` b2--unionBounds :: VarBoundMap -> VarBoundMap -> VarBoundMap-unionBounds = unionWith unioner- where unioner (VarBound i1 l1 u1) (VarBound i2 l2 u2) = VarBound i1 (newmax (-1) l1 l2) (newmax 1 u1 u2)- newmax f b1 b2 = - do x <- b1- y <- b2- return $ ((f*x) `max` (f*y)) `div` f--getBounds :: VarBoundMap -> VarId -> (LowerBound, UpperBound)-getBounds b v = - let bnd = case Data.Map.lookup v b of- Nothing -> (Nothing,Nothing)- Just k -> (lbound k,ubound k)- in {- debug ("v"++(show v)++": "++(show bnd)) -} bnd--getNodeBounds :: StoreNode -> [ Bool ] -> [ VarBoundPropagator ] -> [ VarId ] -> [VarBoundMap]-getNodeBounds node path bnds vars = - let nvrs = nvars node ++ vars- nbnds = nbounds node ++ bnds- in case dis node of- SNLeaf -> [ propagateVarBounds nbnds $ fromList $ map (\x -> (x,VarBound x Nothing Nothing)) nvrs ]- SNIntl l r -> case path of- [] -> (getNodeBounds l [] nbnds nvrs) ++ (getNodeBounds r [] nbnds nvrs)- x:rp -> getNodeBounds (if x then r else l) rp nbnds nvrs---getPathBounds :: Store -> [Bool] -> VarBoundMap-getPathBounds s p = foldl (flip unionBounds) empty (getNodeBounds (ctree s) p [] [])--getAllBounds s = getPathBounds s []-getCurBounds s = getPathBounds s (cpath s)------------------------------------------------------------------------------------- | CodegenSolver solver implementation-----------------------------------------------------------------------------------addGecode c = do- s <- get- put $ addState s [c] [] [boundsPropagator c]- return True--newVar :: Bool -> GType -> CodegenSolver Int-newVar impl tp = do- s <- get- let vn = vars s- put $ addState (s { vars = vn + 1, vardata = (VarData { vtype=tp, vimpl=impl }) : (vardata s) }) [] [vn] []- return $ vn--runGecode :: CodegenSolver p -> p-runGecode x = evalState (state x) initState------------------------------------------------------------------------------------- | CodegenSolver FDSolver instance-----------------------------------------------------------------------------------instance GecodeSolver CodegenSolver where- caching_decompose super this x = Label $ do- s <- get- let wx = ExprKey x- case Data.Map.lookup wx (cexpr s) of- Nothing -> return $ do- n@(IntVar i) <- super x- Label $ do- s <- get- put $ s { cexpr = insert wx i $ cexpr s }- return $ return n- Just i -> return $ return $ IntVar i- setVarImplicit (IntVar i) b = do- s <- get- put $ setVarImplicitHelper s i b--instance FDSolver CodegenSolver where- type FDTerm CodegenSolver = IntTerm- specific_compile_constraint = linearCompile <@> basicCompile- specific_decompose = caching_decompose- specific_fresh_var super this = do- v@(IntVar i) <- super- Label $ do- setVarImplicit (IntVar i) True- return $ Return v---- | utility--getNumVars :: Store -> Int-getNumVars s = vars s--getVarData :: Store -> Int -> VarData-getVarData s i = (vardata s) !! ((length $ vardata s)-1-i)--modVarData :: Store -> Int -> VarData -> Store-modVarData s i d = s { vardata = revrepl (vardata s) i d }--getVarType :: Store -> Int -> GType-getVarType s i = vtype $ getVarData s i--isVarImplicit :: Store -> Int -> Bool-isVarImplicit s i = vimpl $ getVarData s i+{-# LANGUAGE FlexibleInstances #-}++module Control.CP.FD.Gecode.CodegenSolver (+ generateGecode,+ CodegenGecodeSolver,+ CodegenGecodeOptions(..), setOptions,+) where++import Data.Char (ord,chr)+import Data.Maybe (fromJust,isJust)+import Data.Map (Map)+import Data.Maybe (isNothing)+import qualified Data.Map as Map++import Control.Monad.State.Lazy+import Control.Monad.Trans++import Language.CPP.Syntax.AST+import Language.CPP.Pretty++import Control.CP.Debug+import Control.CP.Solver+import Control.CP.SearchTree+import Control.CP.EnumTerm+import Control.CP.FD.FD+import Data.Expr.Data+import Data.Expr.Sugar+-- import Control.CP.FD.Expr.Util+import Control.CP.FD.Model+import Control.CP.FD.Gecode.Common+import Data.Linear++import Control.CP.SearchSpec.Generator as Generator++idx s c i = + if i<0 + then error ("GC:CG idx("++s++"): i="++(show i)++"<0")+ else if i>=length c+ then error ("GC:CG idx("++s++"): i="++(show i)++">=(length c)="++(show $ c))+ else c!!i++data ColDef =+ ColDefSize GecodeIntConst+ | ColDefList [IntVar]+ | ColDefCat ColVar ColVar+-- | ColDefTake ColVar GecodeIntConst GecodeIntConst+ | ColDefConstMap GecodeListConst (GecodeCIFn CodegenGecodeSolver)+ deriving (Show)++data IntParDef =+ IntParDefExt Int+ | IntParDefCPP CPPExpr+ deriving (Show)++data ColParDef =+ ColParDefExt Int+ | ColParDefCPP CPPExpr+ deriving (Show)++data CodegenGecodeState = CodegenGecodeState {+ nIntVars :: Int,+ nBoolVars :: Int,+ nIntPars :: Int,+ intPars :: [IntParDef],+ nColPars :: Int,+ colPars :: [ColParDef],+ colVars :: [ColDef],+ colList :: [GecodeColConst],+ colListEnt :: Map GecodeColConst Int,+ cons :: [GecodeConstraint CodegenGecodeSolver],+ ret :: Maybe ColVar,+ level :: Int,+ parent :: Maybe CodegenGecodeState,+ options :: CodegenGecodeOptions,+ minVar :: Maybe IntVar+} deriving (Show)+++data CodegenGecodeOptions = CodegenGecodeOptions {+ noTrailing :: Bool,+ noGenSearch :: Bool+} deriving (Show)++initOptions :: CodegenGecodeOptions+initOptions = CodegenGecodeOptions {+ noTrailing = False,+ noGenSearch = False+}++initState :: CodegenGecodeState+initState = CodegenGecodeState { + nIntVars = 0,+ nBoolVars = 0,+ nIntPars = 0,+ intPars = [],+ nColPars = 0,+ colPars = [],+ colVars = [],+ colList = [],+ colListEnt = Map.empty,+ cons = [],+ ret = Nothing,+ level = 0,+ parent = Nothing,+ options = initOptions,+ minVar = Nothing+}++newIntParam :: CodegenGecodeSolver Int+newIntParam = do+ s <- get+ let n = nIntPars s+ let r = length $ intPars s+ put $ s { nIntPars = n+1, intPars = (intPars s)++[IntParDefExt n] }+ return r++newColParam :: CodegenGecodeSolver Int+newColParam = do+ s <- get+ let n = nColPars s+ let r = length $ colPars s+ put $ s { nColPars = n+1, colPars = (colPars s)++[ColParDefExt n] }+ return r++newtype CodegenGecodeSolver a = CodegenGecodeSolver { cgsState :: State CodegenGecodeState a }+ deriving (Monad, MonadState CodegenGecodeState)++instance Solver CodegenGecodeSolver where+ type Constraint CodegenGecodeSolver = GecodeConstraint CodegenGecodeSolver+ type Label CodegenGecodeSolver = ()+ run p = evalState (cgsState p) initState+ mark = return ()+ goto s = error "returning to a previous state is not supported yet"+ add c = do+ s <- get+ put $ s { cons = c:cons s }+ return True++setOptions :: (CodegenGecodeOptions -> CodegenGecodeOptions) -> CodegenGecodeSolver ()+setOptions f = do+ s <- get+ put $ s { options = f $ options s }++data IntVar = + IntVar Int Int -- IntVar level id+ | IntVarIdx ColVar GecodeIntConst + | IntVarCPP (CPPExpr -> CPPExpr)+ | IntVarCond GecodeBoolConst IntVar IntVar+ deriving (Eq,Ord,Show)+data BoolVar = + BoolVar Int Int -- BoolVar level id+ | BoolVarCPP (CPPExpr -> CPPExpr)+ deriving (Eq,Ord,Show)+data ColVar = ColVar Int Int -- ColVar level id+ deriving (Eq,Ord,Show)++instance Eq (CPPExpr -> CPPExpr) where+ a==b = a astThis == b astThis+instance Ord (CPPExpr -> CPPExpr) where+ compare a b = compare (a astThis) (b astThis)+instance Show (CPPExpr -> CPPExpr) where+ show a = show (a astThis)++genVar :: String -> CodegenGecodeState -> String+genVar s st = + case level st of+ 0 -> s+ l -> (s ++ show l)++instance Term CodegenGecodeSolver IntVar where+ newvar = do+ s <- get+ let ni = nIntVars s+ put $ s { nIntVars = ni+1 }+ return $ IntVar (level s) ni+ type Help CodegenGecodeSolver IntVar = ()+ help _ _ = ()++instance Term CodegenGecodeSolver BoolVar where+ newvar = do+ s <- get+ let ni = nBoolVars s+ put $ s { nBoolVars = ni+1 }+ return $ BoolVar (level s) ni+ type Help CodegenGecodeSolver BoolVar = ()+ help _ _ = ()++defineCol :: ColDef -> CodegenGecodeSolver ColVar+defineCol def = do+ s <- get+ let ni = length $ colVars s+ put $ s { colVars = colVars s ++ [def] }+ return $ ColVar (level s) ni++colSize :: ColVar -> CodegenGecodeState -> GecodeIntConst+colSize (cc@(ColVar l c)) s = + if (level s == l)+ then debug ("colSize (ColVar l="++(show l)++" c="++(show c)++")") $ case idx "colSize" (colVars s) c of+ ColDefSize s -> s+ ColDefList l -> Const $ toInteger $ length l+ ColDefCat c1 c2 -> colSize c1 s + colSize c2 s+-- ColDefTake _ _ s -> s+ else colSize cc (fromJust $ parent s)++lstindex :: Eq a => [a] -> [a] -> Maybe Int+lstindex [] _ = Just 0+lstindex _ [] = Nothing+lstindex r@(a:b) (c:d) | a==c = case lstindex b d of+ Nothing -> lstindex r d+ Just p -> Just $ p+1+lstindex a (_:b) = lstindex a b++registerList :: GecodeColConst -> (CodegenGecodeState -> CodegenGecodeState)+registerList l state = case lookupList state l of+ Nothing -> state { colListEnt = Map.insert l (length $ colList state) (colListEnt state), colList = (colList state) ++ [l] }+ Just _ -> state++lookupList :: CodegenGecodeState -> GecodeColConst -> Maybe (Int,Int)+lookupList s col = case Map.lookup col (colListEnt s) of+ Nothing -> case parent s of+ Nothing -> Nothing+ Just p -> lookupList p col+ Just r -> Just (level s,r)++instance GecodeSolver CodegenGecodeSolver where+ type GecodeIntVar CodegenGecodeSolver = IntVar+ type GecodeBoolVar CodegenGecodeSolver = BoolVar+ type GecodeColVar CodegenGecodeSolver = ColVar+ newInt_at c p = return $ IntVarIdx c p+ newInt_cond c t f = return $ IntVarCond c t f+ newCol_size s = defineCol $ ColDefSize s+ newCol_list l = defineCol $ ColDefList l+ newCol_cat c1 c2 = defineCol $ ColDefCat c1 c2+-- newCol_take c p l = defineCol $ ColDefTake c p l+ col_getSize c = do+ state <- get+ return $ colSize c state+ col_regList (ColTerm _) = return ()+ col_regList l = do+ state <- get+ put $ registerList l state+ splitBoolDomain _ = error "cannot split run-time boolean domains"+ splitIntDomain _ = error "cannot split run-time integer domains"++class CompilableModel t where+ specific_compile :: t -> CodegenGecodeSolver ()++instance CompilableModel (CodegenGecodeSolver a) where+ specific_compile x = x >> return ()++instance CompilableModel ((FDInstance (GecodeWrappedSolver CodegenGecodeSolver)) ModelCol) where+ specific_compile x = unliftGC $ runFD $ do+ res <- x+ [GCTVar col] <- getColTerm [res] GCSVar+ liftFD $ liftGC $ do+ s <- get+ put s { ret = Just col }+ min <- getMinimizeTerm+ liftFD $ liftGC $ do+ s <- get+ put s { minVar = min }++instance CompilableModel m => CompilableModel (ModelInt -> m) where+ specific_compile x = do+ n <- newIntParam+ specific_compile $ x $ Term $ ModelIntPar n++instance CompilableModel m => CompilableModel (ModelCol -> m) where+ specific_compile x = do+ n <- newColParam+ specific_compile $ x $ ColTerm $ ModelColPar n++buildState :: Solver s => Tree s a -> s a+buildState (Add c v) = debug "cgs::buildState.Add" $ + do+ add c+ buildState v+buildState (NewVar f) = debug "cgs::buildState.NewVar" $ + do+ v <- newvar+ buildState $ f v+buildState (Try l r) = debug "cgs::buildState.Try" $ buildState l+buildState (Label m) = debug "cgs::buildState.Label" $ m >>= buildState+buildState (Fail) = return $ error "Code generation for failed model"+buildState (Return x) = return x++instance CompilableModel (Tree (FDInstance (GecodeWrappedSolver CodegenGecodeSolver)) ModelCol) where+ specific_compile = specific_compile . buildState++getTopState :: (CodegenGecodeState -> a) -> (CodegenGecodeState -> a)+getTopState f o = case parent o of+ Just p -> getTopState f p+ Nothing -> f o++modTopState :: (CodegenGecodeState -> CodegenGecodeState) -> (CodegenGecodeState -> CodegenGecodeState)+modTopState f o = case parent o of+ Just p -> o { parent = Just $ modTopState f p }+ Nothing -> f o++compile :: CompilableModel m => Bool -> m -> (CodegenGecodeSolver a) -> CodegenGecodeSolver a+compile par x m = do+ s <- get+ case par of+ False -> put $ initState { parent = Nothing, level = 0 }+ True -> put $ initState { parent = Just s, level = 1 + level s, intPars = intPars s, colPars = colPars s }+ specific_compile x+ r <- m+ ss <- get+ case parent ss of+ Nothing -> return ()+ Just p -> put p+ return r++retState :: MonadState s m => m a -> m (a,s)+retState m = do+ r <- m+ s <- get+ return (r,s)++astCompile m = compile True m (astPost >>= return . CPPCompound)++astIncludes = [ "gecode/kernel.hh", "gecode/support.hh", "gecode/int.hh", "gecode/search.hh", "vector", "list" ]++astGenerate :: CodegenGecodeSolver [CPPFile]+astGenerate = do+ s <- get+ tru <- astTranslUnit+ mnu <- case noGenSearch $ options s of+ False -> astMainUnitGen+ True -> astMainUnitDef+ return [+ CPPFile {+ cppMacroStm = [ CPPMacroIncludeUser x | x <- astIncludes ],+ cppUsing = [ "Gecode", "std" ],+ cppTranslUnit = tru+ },+ CPPFile {+ cppMacroStm = [],+ cppUsing = [],+ cppTranslUnit = mnu+ }+ ]++astTInt = CPPTypePrim "int"+astTIV = CPPTypePrim "IntVar"+astTIA = CPPTypePrim "IntArgs"+astTIVA = CPPTypePrim "IntVarArgs"+astTBV = CPPTypePrim "BoolVar"+astTBVA = CPPTypePrim "BoolVarArgs"++astInt :: Integer -> CPPExpr+astInt a = CPPConst $ CPPConstInt a++astThis :: CPPExpr+astThis = CPPUnary CPPOpInd $ CPPVar "this"++astLowerBound = astInt (-1000000000)+astUpperBound = astInt (1000000000)++astColSize :: ColVar -> CodegenGecodeState -> CPPExpr -> CPPExpr+astColSize c state ctx = astIntExpr state ctx $ colSize c state++astIntParam :: CodegenGecodeState -> CPPExpr -> GecodeIntParam -> CPPExpr+astIntParam state ctx (GIParam n) | n<(-1000) = CPPVar $ "___parVar"++(show $ -(n+1000))++"___"+astIntParam state ctx (GIParam i) = case (idx "astIntParam" (intPars state) i) of+ IntParDefExt n -> CPPIndex (call ctx "iP") (astInt $ fromIntegral n)+ IntParDefCPP c -> c++astBoolParam :: CodegenGecodeState -> CPPExpr -> GecodeBoolParam -> CPPExpr+astBoolParam state ctx (GBParam i) = CPPIndex (call ctx "bP") (astInt $ fromIntegral i)++astColParam :: CodegenGecodeState -> CPPExpr -> GecodeColParam -> CPPExpr+astColParam state ctx (GCParam i) = case (idx "astColParam" (colPars state) i) of+ ColParDefExt n -> CPPIndex (call ctx "cP") (astInt $ fromIntegral n)+ ColParDefCPP c -> c ++astBoolExpr :: CodegenGecodeState -> CPPExpr -> GecodeBoolConst -> CPPExpr+astBoolExpr state ctx (BoolTerm par) = astBoolParam state ctx par+astBoolExpr state ctx (BoolConst b) = astInt (if b then 1 else 0)+astBoolExpr state ctx (BoolAnd a b) = CPPBinary (astBoolExpr state ctx a) CPPOpLAnd (astBoolExpr state ctx b)+astBoolExpr state ctx (BoolOr a b) = CPPBinary (astBoolExpr state ctx a) CPPOpLOr (astBoolExpr state ctx b)+astBoolExpr state ctx (BoolNot a) = CPPUnary CPPOpNeg (astBoolExpr state ctx a)+astBoolExpr state ctx (Rel a EREqual b) = CPPBinary (astIntExpr state ctx a) CPPOpEq (astIntExpr state ctx b)+astBoolExpr state ctx (Rel a ERDiff b) = CPPBinary (astIntExpr state ctx a) CPPOpNeq (astIntExpr state ctx b)+astBoolExpr state ctx (Rel a ERLess b) = CPPBinary (astIntExpr state ctx a) CPPOpLe (astIntExpr state ctx b)+astBoolExpr state ctx (BoolEqual a b) = CPPBinary (astBoolExpr state ctx a) CPPOpEq (astBoolExpr state ctx b)+astBoolExpr state ctx (BoolCond c t f) = CPPCond (astBoolExpr state ctx c) (Just $ astBoolExpr state ctx t) (astBoolExpr state ctx f)+astBoolExpr state ctx x = error $ "astBoolExpr(" ++ (show x) ++ ")"++astColExpr :: CodegenGecodeState -> CPPExpr -> GecodeColConst -> GecodeIntConst -> CPPExpr+astColExpr state ctx (ColTerm par) pos = CPPIndex (astColParam state ctx par) (astIntExpr state ctx pos)+astColExpr state ctx (ColList lst) (Const pos) = astIntExpr state ctx (lst!!(fromInteger pos))+astColExpr state ctx c p = case lookupList state c of+ Nothing -> error $ "Unregistered constant list used: " ++ (show c)+ Just (l,n) -> CPPIndex (CPPVar ("cte" ++ show l ++ "_" ++ show n)) (astIntExpr state ctx p)+astIntExpr :: CodegenGecodeState -> CPPExpr -> GecodeIntConst -> CPPExpr+astIntExpr state ctx (Term par) = astIntParam state ctx par+astIntExpr state _ (Const i) = astInt i+astIntExpr state ctx (Plus a b) = CPPBinary (astIntExpr state ctx a) CPPOpAdd (astIntExpr state ctx b)+astIntExpr state ctx (Minus a b) = CPPBinary (astIntExpr state ctx a) CPPOpSub (astIntExpr state ctx b)+astIntExpr state ctx (Mult a b) = CPPBinary (astIntExpr state ctx a) CPPOpMul (astIntExpr state ctx b)+astIntExpr state ctx (Div a b) = CPPBinary (astIntExpr state ctx a) CPPOpDiv (astIntExpr state ctx b)+astIntExpr state ctx (Mod a b) = CPPBinary (astIntExpr state ctx a) CPPOpRmd (astIntExpr state ctx b)+astIntExpr state ctx (Abs a) = CPPCall (CPPVar "abs") [astIntExpr state ctx a]+astIntExpr state ctx (At c a) = astColExpr state ctx c a+astIntExpr state ctx (ColSize (ColTerm (GCParam i))) = CPPIndex (call ctx "cPs") (astInt $ toInteger i)+astIntExpr state ctx (Channel b) = astBoolExpr state ctx b+astIntExpr state ctx (Cond c a b) = CPPCond (astBoolExpr state ctx c) (Just $ astIntExpr state ctx a) (astIntExpr state ctx b)++astDecl :: String -> CPPType -> CPPDecl+astDecl name typ = CPPDecl { cppDeclName=Just name, cppType=typ, cppTypeQual=[], cppTypeStor=[], cppDeclInit=Nothing }+astDeclEq :: String -> CPPType -> CPPExpr -> CPPDecl+astDeclEq name typ val = CPPDecl { cppDeclName=Just name, cppType=typ, cppTypeQual=[], cppTypeStor=[], cppDeclInit=Just $ CPPInitValue val }+astDeclEqA :: String -> CPPType -> [CPPExpr] -> CPPDecl+astDeclEqA name typ val = CPPDecl { cppDeclName=Just name, cppType=typ, cppTypeQual=[], cppTypeStor=[], cppDeclInit=Just $ CPPInitArray val }+astDeclFn :: String -> CPPType -> [CPPExpr] -> CPPDecl+astDeclFn name typ val = CPPDecl { cppDeclName=Just name, cppType=typ, cppTypeQual=[], cppTypeStor=[], cppDeclInit=Just $ CPPInitCall val }++call :: CPPExpr -> String -> CPPExpr+call (CPPUnary CPPOpInd (CPPVar "this")) f = CPPVar f+call (CPPUnary CPPOpInd x) f = CPPMember x f True+call x f = CPPMember x f False++instance Num CPPExpr where+ a + b = CPPBinary a CPPOpAdd b+ a * b = CPPBinary a CPPOpMul b+ a - b = CPPBinary a CPPOpSub b+ negate a = CPPUnary CPPOpMinus a+ abs a = CPPCall (CPPVar "abs") [a]+ signum a = CPPCall (CPPVar "signum") [a]+ fromInteger a = astInt a++astLinOperator GOEqual _ = CPPVar "IRT_EQ"+astLinOperator GODiff _ = CPPVar "IRT_NQ"+astLinOperator GOLess False = CPPVar "IRT_LE"+astLinOperator GOLess True = CPPVar "IRT_GR"+astLinOperator GOLessEqual False = CPPVar "IRT_LQ"+astLinOperator GOLessEqual True = CPPVar "IRT_GQ"++astReifList _ _ Nothing = []+astReifList state ctx (Just b) = [astBoolVar state ctx b]++varName s l n = s ++ (if l==0 then "" else show l) ++ "_" ++ (show n)+boolVarName (BoolVar l n) = varName "bV" l n+colVarName (ColVar l n) = varName "cV" l n+intVarName (IntVar l n) = varName "iV" l n++astBoolVar state ctx (BoolVarCPP f) = f ctx+astBoolVar state ctx (v@(BoolVar l _)) | (l < level state) = astBoolVar (fromJust $ parent state) ctx v+astBoolVar state ctx b = CPPVar $ boolVarName b+astIntVar state ctx (IntVarCond c t f) = CPPCond (astBoolExpr state ctx c) (Just $ astIntVar state ctx t) (astIntVar state ctx f)+astIntVar state ctx (IntVarCPP f) = f ctx+astIntVar state ctx (IntVarIdx c p) = CPPIndex (astColVar state ctx c) (astIntExpr state ctx p)+astIntVar state ctx (v@(IntVar l _)) | (l < level state) = astIntVar (fromJust $ parent state) ctx v+astIntVar state ctx i = CPPVar $ intVarName i+astColVar state ctx (ColVar 0 r) | (ret state == Just (ColVar 0 r)) = call ctx "ret"+astColVar state ctx (v@(ColVar l _)) | (l < level state) = astColVar (fromJust $ parent state) ctx v+astColVar state ctx c = CPPVar $ (colVarName c)++astLinearConstraint state ctx l o reif = + let (c,ll) = linearToListEx l+ in case (c,ll,o) of+ ((Const 0),[],_) -> CPPSimple $ CPPVar ("/* empty linear */")+ ((Const 0),[(i1,a),(i2,b)],_) | a==(-b) && a>0 -> CPPSimple $ CPPCall (CPPVar "rel") $ [ctx,astIntVar state ctx i1,astLinOperator o False,astIntVar state ctx i2] ++ astReifList state ctx reif+ ((Const 0),[(i2,a),(i1,b)],_) | a==(-b) && b>0 -> CPPSimple $ CPPCall (CPPVar "rel") $ [ctx,astIntVar state ctx i1,astLinOperator o False,astIntVar state ctx i2] ++ astReifList state ctx reif+ ((Const cc),[(i,(Const ff))],GOEqual) | (cc `mod` ff)==0 -> CPPSimple $ CPPCall (CPPVar "rel") $ [ctx,astIntVar state ctx i,CPPVar "IRT_EQ",astInt $ -cc `div` ff] ++ astReifList state ctx reif+ (c,[(i,Const 1)],rel) -> CPPSimple $ CPPCall (CPPVar "rel") $ [ctx,astIntVar state ctx i,astLinOperator o False,astIntExpr state ctx $ -c] ++ astReifList state ctx reif+ (c,[(i,Const (-1))],rel) -> CPPSimple $ CPPCall (CPPVar "rel") $ [ctx,astIntVar state ctx i,astLinOperator o True,astIntExpr state ctx $ c] ++ astReifList state ctx reif+ _ -> astTempList state (Just $ map snd ll) (Just $ map fst ll) Nothing ctx $ \ia iva _ -> [CPPSimple $ CPPCall (CPPVar "linear") $ [ctx,ia,iva,astLinOperator o False,astIntExpr state ctx $ -c] ++ astReifList state ctx reif]++astTempList :: CodegenGecodeState -> Maybe [GecodeIntConst] -> Maybe [IntVar] -> Maybe [BoolVar] -> CPPExpr -> (CPPExpr -> CPPExpr -> CPPExpr -> [CPPStat]) -> CPPStat+astTempList state i iv bv ctx f = CPPCompound $ + (+ (case i of Just ii -> [ CPPBlockDecl $ astDeclFn "ia" astTIA $ (astInt $ toInteger $ length ii) : [astIntExpr state ctx x | x <- ii] ]; _ -> []) ++ + (case iv of Just iiv -> [ CPPBlockDecl $ astDeclFn "iva" astTIVA $ [astInt $ toInteger $ length iiv] ] ++ [ CPPStatement $ CPPSimple $ CPPAssign (CPPIndex (CPPVar "iva") (astInt i)) CPPAssOp (astIntVar state ctx x) | (i,x) <- zip [0..] iiv ]; _ -> []) +++ (case bv of Just ibv -> [ CPPBlockDecl $ astDeclFn "bva" astTBVA $ [astInt $ toInteger $ length ibv] ] ++ [ CPPStatement $ CPPSimple $ CPPAssign (CPPIndex (CPPVar "bva") (astInt i)) CPPAssOp (astBoolVar state ctx x) | (i,x) <- zip [0..] ibv ]; _ -> []) +++ (map (CPPStatement) $ f (CPPVar "ia") (CPPVar "iva") (CPPVar "bva"))+ )++astTempSet state (num,fun) ctx f = CPPCompound $+ (+ [+ CPPBlockDecl $ astDeclFn "ia" astTIA [astIntExpr state ctx num],+ CPPStatement $ CPPFor (Right $ astDeclEq "asi" astTInt $ astInt 0) (Just $ CPPBinary (CPPVar "asi") CPPOpLe $ astIntExpr state ctx num) (Just $ CPPUnary CPPOpPostInc $ CPPVar "asi") $+ CPPSimple $ CPPAssign (CPPIndex (CPPVar "ia") (CPPVar "asi")) CPPAssOp (withPar (IntParDefCPP $ CPPVar "asi") state $ \state par -> astIntExpr state ctx $ fun (Term par)),+ CPPBlockDecl $ astDeclFn "is" (CPPTypePrim "IntSet") [CPPVar "ia"]+ ]+ ) ++ (map CPPStatement $ f $ CPPVar "is")++astTempSetConst state lst ctx f = CPPCompound $+ (+ [ CPPBlockDecl $ astDeclEqA "ia" (CPPArray [] astTInt $ Just $ astInt $ toInteger $ length lst) [astInt x | x <- lst],+ CPPBlockDecl $ astDeclFn "is" (CPPTypePrim "IntSet") [CPPVar "ia"]+ ]+ ) ++ (map CPPStatement $ f $ CPPVar "is")++astParTempList :: CodegenGecodeState -> GecodeListConst -> CPPExpr -> (CPPExpr -> [CPPStat]) -> CPPStat+astParTempList state (num,fun) ctx f = CPPCompound $+ (+ [+ CPPBlockDecl $ astDeclFn "ia" astTIA [astIntExpr state ctx num],+ CPPStatement $ CPPFor (Right $ astDeclEq "asi" astTInt $ astInt 0) (Just $ CPPBinary (CPPVar "asi") CPPOpLe $ astIntExpr state ctx num) (Just $ CPPUnary CPPOpPostInc $ CPPVar "asi") $+ CPPSimple $ CPPAssign (CPPIndex (CPPVar "ia") (CPPVar "asi")) CPPAssOp (withPar (IntParDefCPP $ CPPVar "asi") state $ \state par -> astIntExpr state ctx $ fun (Term par))+ ]+ ) ++ (map CPPStatement $ f $ CPPVar "ia")++astSection :: CodegenGecodeState -> GecodeColVarOrSection CodegenGecodeSolver -> CPPExpr -> (CPPExpr -> CPPExpr -> [CPPBlockItem]) -> CPPStat+astSection state (Left var) ctx f = CPPCompound $ f (astColVar state ctx var) (astColSize var state ctx)+astSection state (Right (var,(nn,ff))) ctx f = CPPCompound $+ [ CPPBlockDecl $ astDeclFn "as" astTIVA [astIntExpr state ctx nn],+ CPPStatement $ CPPFor (Right $ astDeclEq "asi" astTInt $ astInt 0) (Just $ CPPBinary (CPPVar "asi") CPPOpLe $ astIntExpr state ctx nn) (Just $ CPPUnary CPPOpPostInc $ CPPVar "asi") $+ CPPSimple $ CPPAssign (CPPIndex (CPPVar "as") (CPPVar "asi")) CPPAssOp (CPPIndex (astColVar state ctx var) (withPar (IntParDefCPP $ CPPVar "asi") state $ \state par -> astIntExpr state ctx $ ff (Term par)))+ ] ++ f (CPPVar "as") (astIntExpr state ctx nn)++astSectionM :: GecodeColVarOrSection CodegenGecodeSolver -> CPPExpr -> (CPPExpr -> CPPExpr -> CodegenGecodeSolver [CPPBlockItem]) -> CodegenGecodeSolver CPPStat+astSectionM (Left var) ctx m = do+ s <- get+ r <- m (astColVar s ctx var) (astColSize var s ctx)+ return $ CPPCompound r+astSectionM (Right (var,(nn,ff))) ctx f = do+ s <- get+ r <- f (CPPVar "as") (astIntExpr s ctx nn)+ return $ CPPCompound $+ [ CPPBlockDecl $ astDeclFn "as" astTIVA [astIntExpr s ctx nn],+ CPPStatement $ CPPFor (Right $ astDeclEq "asi" astTInt $ astInt 0) (Just $ CPPBinary (CPPVar "asi") CPPOpLe $ astIntExpr s ctx nn) (Just $ CPPUnary CPPOpPostInc $ CPPVar "asi") $+ CPPSimple $ CPPAssign (CPPIndex (CPPVar "as") (CPPVar "asi")) CPPAssOp (CPPIndex (astColVar s ctx var) (withPar (IntParDefCPP $ CPPVar "asi") s $ \state par -> astIntExpr state ctx $ ff (Term par)))+ ] ++ r++astMCPTypeName state = "MCPProgram"+astMCPType = CPPTypePrim . astMCPTypeName++withPar pardef state f =+ let l = length $ intPars state+ ss = state { intPars = (intPars state)++[pardef] }+ in f ss (GIParam l)++withParM pardef f = do+ s <- get+ let l = length $ intPars s+ put s { intPars = (intPars s)++[pardef] }+ r <- f (GIParam l)+ ss <- get+ put ss { intPars = intPars s }+ return r++astConstraint :: CPPExpr -> GecodeConstraint CodegenGecodeSolver -> CodegenGecodeSolver CPPStat+astConstraint ctx con = do+ procConstraint con+ state <- get+ let abv = astBoolVar state ctx+ aiv = astIntVar state ctx+ acv = astColVar state ctx+ tnm = "t" ++ (show $ level state)+ tnx i = "t" ++ (show $ level state) ++ [chr $ ord 'a' + i]+ ret <- case con of+ GCCond c b -> do+ inner <- astConstraint ctx c+ return $ CPPIf (astBoolExpr state ctx b) inner Nothing+ GCAll (GecodeIBFn f) (Left c) Nothing -> do+ inner <- astCompile $ f (IntVarCPP $ \ctx -> CPPIndex (astColVar state ctx c) (CPPVar tnm)) (BoolVarCPP $ \ctx -> CPPVar "/* GCAll undefined */")+ return $ CPPFor (Right $ astDeclEq tnm astTInt $ astInt 0 ) (Just $ CPPBinary (CPPVar tnm) CPPOpLe $ astColSize c state ctx) (Just $ CPPUnary CPPOpPostInc (CPPVar tnm)) inner+ GCAllC (GecodeCBFn f) (n,m) Nothing -> do+ inner <- withParM (IntParDefCPP $ CPPVar tnm) $ \par -> astCompile $ f (m $ Term par) (BoolVarCPP $ \ctx -> CPPVar "/* GCAllC undefined */")+ return $ CPPFor (Right $ astDeclEq tnm astTInt $ astInt 0) (Just $ CPPBinary (CPPVar tnm) CPPOpLe $ astIntExpr state ctx n) (Just $ CPPUnary CPPOpPostInc (CPPVar tnm)) inner+ GCAll (GecodeIBFn f) (Left c) (Just b) -> do+ inner <- astCompile $ f (IntVarCPP $ \ctx -> CPPIndex (astColVar state ctx c) (CPPVar (tnx 1))) (BoolVarCPP $ \ctx -> CPPIndex (CPPVar (tnx 0)) (CPPVar (tnx 1)))+ return $ CPPCompound $+ [+ CPPBlockDecl $ astDeclFn (tnx 0) (CPPTypePrim "BoolVarArray") [ctx,astColSize c state ctx,astInt 0,astInt 1],+ CPPStatement $ CPPFor (Right $ astDeclEq (tnx 1) astTInt $ astInt 0) (Just $ CPPBinary (CPPVar (tnx 1)) CPPOpLe $ astColSize c state ctx) (Just $ CPPUnary CPPOpPostInc (CPPVar (tnx 1))) inner,+ CPPStatement $ CPPSimple $ CPPCall (CPPVar "rel") [ctx,CPPVar "BOT_AND",CPPVar (tnx 0),abv b]+ ]+ GCAny (GecodeIBFn f) (Left c) (Just b) -> do+ inner <- astCompile $ f (IntVarCPP $ \ctx -> CPPIndex (astColVar state ctx c) (CPPVar $ tnx 1)) (BoolVarCPP $ \ctx -> CPPIndex (CPPVar $ tnx 0) (CPPVar $ tnx 1))+ return $ CPPCompound $+ [+ CPPBlockDecl $ astDeclFn (tnx 0) (CPPTypePrim "BoolVarArray") [ctx,astColSize c state ctx,astInt 0,astInt 1],+ CPPStatement $ CPPFor (Right $ astDeclEq (tnx 1) astTInt $ astInt 0) (Just $ CPPBinary (CPPVar $ tnx 1) CPPOpLe $ astColSize c state ctx) (Just $ CPPUnary CPPOpPostInc (CPPVar $ tnx 1)) inner,+ CPPStatement $ CPPSimple $ CPPCall (CPPVar "rel") [ctx,CPPVar "BOT_OR",CPPVar $ tnx 0,abv b]+ ]+ GCMap (GecodeIIFn f) (Left c) cr -> do+ inner <- astCompile $ f (IntVarCPP $ \ctx -> CPPIndex (astColVar state ctx c) (CPPVar tnm)) (IntVarCPP $ \ctx -> CPPIndex (astColVar state ctx cr) (CPPVar tnm))+ return $ CPPFor (Right $ astDeclEq tnm astTInt $ astInt 0) (Just $ CPPBinary (CPPVar tnm) CPPOpLe $ astColSize c state ctx) (Just $ CPPUnary CPPOpPostInc (CPPVar tnm)) inner+ GCFold (GecodeIIIFn f) c i res -> astSectionM c ctx $ \col siz -> do+ inner <- astCompile $ f (IntVarCPP $ \_ -> CPPVar (tnx 0)) (IntVarCPP $ \ctx -> CPPIndex col (CPPVar tnm)) (IntVarCPP $ \_ -> CPPVar (tnx 1))+ final <- astCompile $ f (IntVarCPP $ \_ -> CPPVar (tnx 0)) (IntVarCPP $ \ctx -> CPPIndex col (CPPBinary siz CPPOpSub 1)) res+ return $ [+ CPPBlockDecl $ astDeclEq (tnx 0) astTIV $ aiv i,+ CPPStatement $ CPPFor (Right $ astDeclEq tnm astTInt 0) (Just $ CPPBinary (CPPVar tnm) CPPOpLe $ CPPBinary siz CPPOpSub 1) (Just $ CPPUnary CPPOpPostInc (CPPVar tnm)) $ CPPCompound+ [+ CPPBlockDecl $ astDeclFn (tnx 1) astTIV [ctx,astLowerBound,astUpperBound],+ CPPStatement $ inner,+ CPPStatement $ CPPSimple $ CPPAssign (CPPVar (tnx 0)) CPPAssOp (CPPVar (tnx 1))+ ],+ CPPStatement $ final+ ]+ GCFoldC (GecodeICIFn f) (nnn) i res -> do+ inner <- withParM (IntParDefCPP $ CPPVar tnm) $ \par -> astCompile $ f (IntVarCPP $ \_ -> CPPVar (tnx 0)) (Term par) (IntVarCPP $ \_ -> CPPVar (tnx 1))+ final <- withParM (IntParDefCPP $ CPPBinary (astIntExpr state ctx nnn) CPPOpSub 1) $ \par -> astCompile $ f (IntVarCPP $ \_ -> CPPVar (tnx 0)) (Term par) res+ return $ CPPCompound+ [+ CPPBlockDecl $ astDeclEq (tnx 0) astTIV $ aiv i,+ CPPStatement $ CPPFor (Right $ astDeclEq tnm astTInt 0) (Just $ CPPBinary (CPPVar tnm) CPPOpLe $ CPPBinary (astIntExpr state ctx nnn) CPPOpSub 1) (Just $ CPPUnary CPPOpPostInc (CPPVar tnm)) $ CPPCompound+ [+ CPPBlockDecl $ astDeclFn (tnx 1) astTIV [ctx,astLowerBound,astUpperBound],+ CPPStatement $ inner,+ CPPStatement $ CPPSimple $ CPPAssign (CPPVar (tnx 0)) CPPAssOp (CPPVar (tnx 1))+ ],+ CPPStatement $ final+ ]+ _ -> return $ astSimpleConstraint ctx con state+-- return $ CPPCompound [ CPPStatement (CPPSimple $ CPPVar ("1 /* " ++(show con) ++ " */")), CPPStatement ret ]+ return ret++astSimpleConstraint ctx con state = case con of+ GCBoolVal bv val -> CPPSimple $ CPPCall (CPPVar "rel") [ctx,abv bv,CPPVar "IRT_EQ",astBoolExpr state ctx val]+ GCBoolEqual b1 b2 -> CPPSimple $ CPPCall (CPPVar "rel") [ctx,abv b1,CPPVar "IRT_EQ",abv b2]+ GCIntVal iv val -> CPPSimple $ CPPCall (CPPVar "rel") [ctx,aiv iv,CPPVar "IRT_EQ",astIntExpr state ctx val]+ GCMult r a b -> CPPSimple $ CPPCall (CPPVar "mult") [ctx,aiv a,aiv b,aiv r]+ GCDiv r a b -> CPPSimple $ CPPCall (CPPVar "div") [ctx,aiv a,aiv b,aiv r]+ GCMod r a b -> CPPSimple $ CPPCall (CPPVar "mod") [ctx,aiv a,aiv b,aiv r]+ GCAbs r a -> CPPSimple $ CPPCall (CPPVar "abs") [ctx,aiv a,aiv r]+ GCAt (Left r) (Left c) (Left p) -> CPPSimple $ CPPCall (CPPVar "element") [ctx,acv c,aiv p,aiv r]+ GCAt (Left r) (Right (Left c)) (Left p) -> astTempList state (Just $ map Const c) Nothing Nothing ctx $ \i _ _ -> [CPPSimple $ CPPCall (CPPVar "element") [ctx,i,aiv p,aiv r]]+ GCAt (Left r) (Right (Right c)) (Left p) -> astParTempList state c ctx $ \i -> [CPPSimple $ CPPCall (CPPVar "element") [ctx,i,aiv p,aiv r]]+ GCAt (Right r) (Left c) (Left p) -> CPPSimple $ CPPCall (CPPVar "element") [ctx,acv c,aiv p,astIntExpr state ctx r]+ GCAt (Right r) (Right (Left c)) (Left p) -> astTempList state (Just $ map Const c) Nothing Nothing ctx $ \i _ _ -> [CPPSimple $ CPPCall (CPPVar "element") [ctx,i,aiv p,astIntExpr state ctx r]]+ GCAt (Right r) (Right (Right c)) (Left p) -> astParTempList state c ctx $ \i -> [CPPSimple $ CPPCall (CPPVar "element") [ctx,i,aiv p,astIntExpr state ctx r]]+ GCAt (Left r) (Left c) (Right p) -> CPPSimple $ CPPCall (CPPVar "rel") [ctx,CPPIndex (acv c) (astIntExpr state ctx p),CPPVar "IRT_EQ",aiv r]+ GCAt (Left r) (Right (Left c)) (Right p) -> astTempList state (Just $ map Const c) Nothing Nothing ctx $ \i _ _ -> [CPPSimple $ CPPCall (CPPVar "element") [ctx,i,astIntExpr state ctx p,aiv r]]+ GCAt (Left r) (Right (Right (n,f))) (Right p) -> CPPSimple $ CPPCall (CPPVar "rel") [ctx,astIntExpr state ctx $ f p,CPPVar "IRT_EQ",aiv r]+ GCAt (Right r) (Left c) (Right p) -> CPPSimple $ CPPCall (CPPVar "rel") [ctx,CPPIndex (acv c) (astIntExpr state ctx p),CPPVar "IRT_EQ",astIntExpr state ctx r]+ GCAt (Right r) (Right (Left c)) (Right p) -> astTempList state (Just $ map Const c) Nothing Nothing ctx $ \i _ _ -> [CPPSimple $ CPPCall (CPPVar "element") [ctx,i,astIntExpr state ctx p,astIntExpr state ctx r]]+ GCAt (Right r) (Right (Right (n,f))) (Right p) -> CPPSimple $ CPPCall (CPPVar "rel") [ctx,astIntExpr state ctx $ f p,CPPVar "IRT_EQ",astIntExpr state ctx r]+ GCDom v (Left c) Nothing -> CPPSimple $ CPPCall (CPPVar "count") [ctx,acv c,aiv v,CPPVar "IRT_GR",astInt 0]+ GCDom v (Right (Left c)) Nothing -> astTempSetConst state c ctx $ \i -> [CPPSimple $ CPPCall (CPPVar "dom") [ctx,aiv v,i]]+ GCDom v (Right (Left c)) (Just b) -> astTempSetConst state c ctx $ \i -> [CPPSimple $ CPPCall (CPPVar "dom") [ctx,aiv v,i,abv b]]+ GCDom v (Right (Right c)) Nothing -> astTempSet state c ctx $ \i -> [CPPSimple $ CPPCall (CPPVar "dom") [ctx,aiv v,i]]+ GCDom v (Right (Right c)) (Just b) -> astTempSet state c ctx $ \i -> [CPPSimple $ CPPCall (CPPVar "dom") [ctx,aiv v,i,abv b]]+ GCChannel a b -> CPPSimple $ CPPCall (CPPVar "channel") [ctx,aiv a,abv b]+ GCLinear l op -> astLinearConstraint state ctx l op Nothing+ GCLinearReif l op b -> astLinearConstraint state ctx l op $ Just b+ -- TODO: Cat+ -- TODO: Take+ GCAnd lst r -> astTempList state Nothing Nothing (Just lst) ctx $ \_ _ b -> [CPPSimple $ CPPCall (CPPVar "rel") [ctx,CPPVar "BOT_AND",b,abv r]]+ GCOr lst r -> astTempList state Nothing Nothing (Just lst) ctx $ \_ _ b -> [CPPSimple $ CPPCall (CPPVar "rel") [ctx,CPPVar "BOT_OR",b,abv r]]+ GCNot r a -> CPPSimple $ CPPCall (CPPVar "rel") [ctx,abv r,CPPVar "IRT_NQ",abv a]+ GCEquiv r a b -> CPPSimple $ CPPCall (CPPVar "rel") [ctx,abv r,CPPVar "BOT_EQV",abv a,abv b]+ GCAllDiff b c -> astSection state c ctx $ \col siz -> [CPPStatement $ CPPSimple $ CPPCall (CPPVar "distinct") (if b then [ctx,col,CPPVar "ICL_DOM"] else [ctx,col])]+ GCSorted (Left c) op -> CPPSimple $ CPPCall (CPPVar "rel") [ctx,acv c,astLinOperator op False]+ GCSum c (Left i) -> astSection state c ctx $ \col siz -> [CPPStatement $ CPPSimple $ CPPCall (CPPVar "linear") [ctx,col,CPPVar "IRT_EQ",aiv i]]+ GCSum c (Right i) -> astSection state c ctx $ \col siz -> [CPPStatement $ CPPSimple $ CPPCall (CPPVar "linear") [ctx,col,CPPVar "IRT_EQ",astIntExpr state ctx i]]+ GCCount c (Left valvar) op (Left countvar) -> CPPSimple $ CPPCall (CPPVar "count") [ctx,astColVar state ctx c,astIntVar state ctx valvar,astLinOperator op False,astIntVar state ctx countvar]+ GCCount c (Right val) op (Left countvar) -> CPPSimple $ CPPCall (CPPVar "count") [ctx,astColVar state ctx c,astIntExpr state ctx val,astLinOperator op False,astIntVar state ctx countvar]+ GCCount c (Left valvar) op (Right count) -> CPPSimple $ CPPCall (CPPVar "count") [ctx,astColVar state ctx c,astIntVar state ctx valvar,astLinOperator op False,astIntExpr state ctx count]+ GCCount c (Right val) op (Right count) -> CPPSimple $ CPPCall (CPPVar "count") [ctx,astColVar state ctx c,astIntExpr state ctx val,astLinOperator op False,astIntExpr state ctx count]+ _ -> CPPSimple $ CPPVar $ "1 /*" ++ (show con) ++ "*/"+ where abv = astBoolVar state ctx+ aiv = astIntVar state ctx+ acv = astColVar state ctx+ tnm = "t" ++ (show $ level state)+ tnx i = "t" ++ (show $ level state) ++ [chr $ ord 'a' + i]++ifList :: Bool -> [a] -> [a]+ifList True x = x+ifList False _ = []++fnLoadColPar = + [+ "int nv=1;",+ "for (char *ptr=str; *ptr!=0; ptr++) {",+ " nv += (*ptr == ',');",+ "}",+ "int *ret=new int[nv];",+ "for (int n=0; n<nv; n++) {",+ " ret[n]=strtol(str,&str,10);",+ " while (*str!=0 && *str!=',') str++;",+ " str++;",+ "}",+ "*siz=nv;",+ "return ret;"+ ]++astTranslUnit = do+ pst <- astPost+ state <- get+ return $ CPPNamespace + [+ CPPElemDef $ CPPDef {+ cppDefName="loadCol",+ cppDefRetType=CPPPtr [] astTInt,+ cppDefStor=[],+ cppDefQual=[],+ cppDefArgs=[astDecl "str" $ CPPPtr [] (CPPTypePrim "char"),astDecl "siz" $ CPPPtr [] astTInt],+ cppDefBody=Just $ CPPVerbStat fnLoadColPar+ },+ CPPElemClass $ CPPClass {+ cppClassName = astMCPTypeName state,+ cppClassInherit = [(CPPPublic,CPPTypePrim "Space")],+ cppClassDecls = + (if nIntPars state > 0+ then [(CPPProtected,astDecl "iP" (CPPPtr [] astTInt))]+ else []+ ) +++ (if nColPars state > 0+ then [(CPPProtected,astDecl "cP" (CPPPtr [] $ CPPPtr [] astTInt)),+ (CPPProtected,astDecl "cPs" (CPPPtr [] astTInt))+ ]+ else []+ ) +++ (case ret state of+ Nothing -> []+ Just c -> [(CPPProtected,astDecl "ret" (CPPTypePrim "IntVarArray"))]+ ) +++ (case minVar state of+ Nothing -> []+ Just v -> [(CPPProtected,astDecl "cost" (CPPTypePrim "IntVar"))]+ ),+ cppClassDefs = [+ (CPPPublic,CPPDef { + cppDefName="copy",+ cppDefRetType=CPPPtr [] (CPPTypePrim "Space"), + cppDefStor=[CPPVirtual], + cppDefQual=[],+ cppDefArgs=[astDecl "share" $ CPPTypePrim "bool"], + cppDefBody = Just $ CPPReturn $ Just $ CPPNew (astMCPType state) [CPPVar "share",astThis]+ }),+ (CPPPublic,CPPDef {+ cppDefName="print",+ cppDefRetType=CPPTypePrim "void",+ cppDefStor=[CPPVirtual],+ cppDefArgs=[astDecl "os" $ CPPRef [] $ CPPTypePrim "ostream"],+ cppDefQual=[CPPQualConst],+ cppDefBody = Just $ CPPSimple $ case ret state of+ Just r -> CPPBinary (CPPBinary (CPPVar "os") CPPOpShl (call astThis "ret")) CPPOpShl (CPPVar "endl")+ _ -> CPPBinary (CPPBinary (CPPVar "os") CPPOpShl (CPPConst $ CPPConstString "Ok")) CPPOpShl (CPPVar "endl")+ }),+ (CPPPublic,CPPDef {+ cppDefName="getVar",+ cppDefRetType=CPPTypePrim "IntVar",+ cppDefStor=[CPPVirtual],+ cppDefArgs=[astDecl "v" $ CPPTypePrim "int"],+ cppDefQual=[],+ cppDefBody = Just $ case (ret state, minVar state) of+ (Just r, Just _) -> CPPReturn $ Just $ CPPCond (CPPBinary (CPPVar "v") CPPOpEq (CPPConst $ CPPConstInt $ -1)) (Just $ CPPVar "cost") $ CPPIndex (astColVar state astThis r) $ CPPVar "v"+ (Just r, Nothing) -> CPPReturn $ Just $ CPPIndex (astColVar state astThis r) $ CPPVar "v"+ }),+ (CPPPublic,CPPDef {+ cppDefName="getBranchVarIds",+ cppDefRetType=CPPTypePrim "vector<int>",+ cppDefStor=[CPPVirtual],+ cppDefArgs=[],+ cppDefQual=[],+ cppDefBody = case ret state of+ Just r -> Just $ CPPCompound [+ CPPBlockDecl $ astDeclFn "r" (CPPTypePrim "vector<int>") [astColSize r state astThis],+ CPPStatement $ CPPFor (Right $ astDeclEq "i" astTInt $ astInt 0) (Just $ CPPBinary (CPPVar "i") CPPOpLe $ astColSize r state astThis) (Just $ CPPUnary CPPOpPostInc $ CPPVar "i") $+ CPPSimple $ CPPAssign (CPPIndex (CPPVar "r") (CPPVar "i")) CPPAssOp $ CPPVar "i",+ CPPStatement $ CPPReturn $ Just $ CPPVar "r"+ ]+ })]++(+ case (minVar state) of+ Nothing -> []+ Just mv -> + [(CPPPublic,CPPDef {+ cppDefName="constrain",+ cppDefRetType=CPPTypePrim "void",+ cppDefStor=[],+ cppDefArgs=[astDecl "best_" $ CPPRef [CPPQualConst] (CPPTypePrim "Space")],+ cppDefQual=[],+ cppDefBody = Just $ CPPCompound $ + [+ CPPBlockDecl $ astDeclEq "best" (CPPPtr [] (CPPTypePrim "MCPProgram")) (CPPCast (CPPPtr [] (CPPTypePrim "MCPProgram")) (CPPUnary CPPOpAdr $ CPPVar "best_")),+ CPPStatement $ CPPSimple $ CPPCall (CPPVar "rel") [astThis,CPPVar "cost",CPPVar "IRT_LE",CPPCall (CPPMember (CPPMember (CPPVar "best") "cost" True) "val" False) []]+ ]+ })]+ )+ ,+ cppClassConstrs = [+ (CPPPublic, CPPConstr { cppConstrStor=[], cppConstrArgs=+ (+ (if (nIntPars state)+(nColPars state) > 0+ then [astDecl "args" (CPPPtr [] $ CPPPtr [] $ CPPTypePrim "char")]+ else []+ )+ ), cppConstrBody = Just $ CPPCompound $ (+ (if (nIntPars state)+(nColPars state) > 0+ then [CPPStatement $ CPPSimple $ CPPUnary CPPOpPostInc (CPPVar "args")]+ else []+ ) +++ (ifList (nIntPars state > 0) [CPPComment "init of iP", CPPStatement $ CPPVerbStat+ [+ "iP=new int["++(show (nIntPars state))++"];",+ "for (int i=0; i<"++(show (nIntPars state))++"; i++) {",+ " iP[i]=strtol(*(args++),NULL,10);",+ "}"+ ]+ ])+++ (ifList (nColPars state > 0) [CPPComment "init of cP", CPPStatement $ CPPVerbStat+ [+ "cP=new int*["++(show (nColPars state))++"];",+ "cPs=new int["++(show (nColPars state))++"];",+ "for (int i=0; i<"++(show (nColPars state))++"; i++) {",+ " cP[i]=loadCol(*(args++),cPs+i);",+ "}"+ ]+ ])+++ (case ret state of+ Nothing -> []+ Just r -> + [+ CPPComment "init of ret",+ CPPStatement $ CPPSimple $ CPPAssign (CPPVar "ret") CPPAssOp (CPPCall (CPPVar "IntVarArray") [astThis,astColSize r state astThis])+ ]+ ) +++ [CPPComment "begin of main post"]+ )++pst, cppConstrInit=[]+ }),+ (CPPPublic,CPPConstr { cppConstrStor=[], cppConstrArgs=[astDecl "share" $ CPPTypePrim "bool",astDecl "s" $ CPPRef [] $ astMCPType state], cppConstrInit=+ (+ [(Right (CPPTypePrim "Space"),[CPPVar "share",CPPVar "s"])] +++ (if nIntPars state > 0+ then [(Left (CPPVar "iP"),[call (CPPVar "s") "iP"])]+ else []+ ) +++ (if nColPars state > 0+ then [(Left (CPPVar "cP" ),[call (CPPVar "s") "cP" ]),+ (Left (CPPVar "cPs"),[call (CPPVar "s") "cPs"])+ ]+ else []+ )+ ), cppConstrBody = Just $ CPPCompound $ + (case (ret state) of+ Nothing -> []+ Just r -> [CPPStatement $ CPPSimple $ CPPCall (call (call astThis "ret") "update") [astThis,CPPVar "share",call (CPPVar "s") "ret"]]+-- (if (nBoolVars state > 0) then [CPPStatement $ CPPSimple $ CPPCall (call (CPPVar $ boolVarName $ BoolVar (level state) ii) "update") [astThis,CPPVar "share",CPPVar $ boolVarName $ BoolVar astBoolVar state (CPPVar "s") ii] | ii <- [0..(nBoolVars state)-1] ] else []) +++-- (if (nIntVars state > 0) then [CPPStatement $ CPPSimple $ CPPCall (call (CPPVar $ intVarName $ IntVar (level state) ii) "update") [astThis,CPPVar "share",CPPVar $ astIntVar state (CPPVar "s") ii] | ii <- [0..(nIntVars state)-1] ] else []) +++-- (if (length (colVars state) > 0) then [CPPStatement $ CPPSimple $ CPPCall (call (CPPVar $ colVarName $ ColVar (level state) ii) "update") [astThis,CPPVar "share",CPPVar $ astColVar state (CPPVar "s") ii] | ii <- [0..(length $ colVars state)-1] ] else [])+ ) ++ (case (minVar state) of+ Nothing -> []+ Just _ -> [CPPStatement $ CPPSimple $ CPPCall (call (call astThis "cost") "update") [astThis,CPPVar "share",call (CPPVar "s") "cost"]]+ )+ })+ ]+ }+ ]++astMainUnitGen = do+ state <- get+ return $ CPPNamespace + [ + CPPElemDef $ CPPDef {+ cppDefName="main",+ cppDefRetType=astTInt,+ cppDefStor=[],+ cppDefQual=[],+ cppDefArgs=[astDecl "argc" astTInt, astDecl "argv" $ CPPPtr [] $ CPPPtr [] $ CPPTypePrim "char"],+ cppDefBody=Just $ CPPCompound $+ ([+ CPPBlockDecl $ astDeclEq "prog" (CPPPtr [] $ astMCPType state) $ CPPNew (astMCPType state)+ (if ((nIntPars state)+(nColPars state) > 0)+ then [CPPVar "argv"]+ else []+ ),+ CPPStatement $ CPPSimple $ CPPCall (CPPVar "eval") [CPPVar "prog"],+ CPPStatement $ CPPReturn $ Just $ astInt 0+ ])+ }+ ]++astMainUnitDef = do+ state <- get+ return $ CPPNamespace+ [+ CPPElemDef $ CPPDef {+ cppDefName="main",+ cppDefRetType=astTInt,+ cppDefStor=[],+ cppDefQual=[],+ cppDefArgs=[astDecl "argc" astTInt, astDecl "argv" $ CPPPtr [] $ CPPPtr [] $ CPPTypePrim "char"],+ cppDefBody=Just $ CPPCompound $+ ([+ CPPBlockDecl $ astDeclEq "prog" (CPPPtr [] $ astMCPType state) $ CPPNew (astMCPType state)+ (if ((nIntPars state)+(nColPars state) > 0)+ then [CPPVar "argv"]+ else []+ ),+ CPPBlockDecl $ astDecl "so" (CPPTypePrim "Search::Options")+ ] ++ (if noTrailing $ options state then [+ CPPStatement $ CPPSimple $ CPPAssign (CPPMember (CPPVar "so") "c_d" False) CPPAssOp 1+ ] else []) ++ [+ CPPBlockDecl $ astDeclFn "srch" (CPPTempl (case minVar state of { Nothing -> "DFS"; _ -> "BAB" }) [astMCPType state]) [CPPVar "prog",CPPVar "so"],+ CPPStatement $ CPPDelete $ CPPVar "prog",+ CPPStatement $ CPPWhile (astInt (case minVar state of { Nothing -> 0; _ -> 1 })) True $ CPPCompound [+ CPPBlockDecl $ astDeclEq "sol" (CPPPtr [] $ astMCPType state) $ CPPCall (call (CPPVar "srch") "next") [],+ CPPStatement $ CPPIf (CPPUnary CPPOpNeg $ CPPVar "sol") CPPBreak Nothing,+ CPPStatement $ CPPSimple $ CPPCall (call (CPPUnary CPPOpInd $ CPPVar "sol") "print") [CPPVar "std::cout"]+ ],+ CPPStatement $ CPPReturn $ Just $ astInt 0+ ])+ }+ ]++astPost = do+ state <- get+ conss <- mapM (astConstraint astThis) (reverse $ cons state)+ state <- get+ return $+ [CPPComment "/* init col consts */"]+++ (concat [ case (colList state)!!pos of+ ColList lst -> [ CPPBlockDecl $ CPPDecl {+ cppDeclName=Just ("cte" ++ (show $ level state) ++ "_" ++ (show pos)),+ cppType=CPPArray [CPPQualConst] (CPPTypePrim "int") Nothing,+ cppTypeQual=[CPPQualConst],+ cppTypeStor=[],+ cppDeclInit=Just $ CPPInitArray [ astIntExpr state astThis x | x <- lst ]+ }]+ ColSlice f n p -> [ CPPBlockDecl $ CPPDecl {+ cppDeclName=Just ("cte" ++ (show $ level state) ++ "_" ++ (show pos)),+ cppType=CPPArray [] (CPPTypePrim "int") (Just $ astIntExpr state astThis n),+ cppTypeQual=[],+ cppTypeStor=[],+ cppDeclInit=Nothing+ },+ CPPStatement $ + CPPFor + (Right $ astDeclEq "i" astTInt $ astInt 0)+ (Just $ CPPBinary (CPPVar "i") CPPOpLe $ astIntExpr state astThis n) + (Just $ CPPUnary CPPOpPostInc $ CPPVar "i") $ + CPPSimple $ CPPAssign + (CPPIndex (CPPVar ("cte" ++ (show $ level state) ++ "_" ++ (show pos))) $ CPPVar "i") + CPPAssOp $ + withPar (IntParDefCPP $ CPPVar "i") state $ \state par -> astColExpr state astThis p $ f $ Term par+ ]+ ColCat a b -> [ CPPBlockDecl $ CPPDecl {+ cppDeclName=Just ("cte" ++ (show $ level state) ++ "_" ++ (show pos)),+ cppType=CPPArray [] (CPPTypePrim "int") (Just $ astIntExpr state astThis $ size a + size b),+ cppTypeQual=[],+ cppTypeStor=[],+ cppDeclInit=Nothing+ },+ CPPStatement $+ CPPFor+ (Right $ astDeclEq "i" astTInt $ astInt 0)+ (Just $ CPPBinary (CPPVar "i") CPPOpLe $ astIntExpr state astThis $ size a)+ (Just $ CPPUnary CPPOpPostInc $ CPPVar "i") $+ CPPSimple $ CPPAssign+ (CPPIndex (CPPVar ("cte" ++ (show $ level state) ++ "_" ++ (show pos))) $ CPPVar "i")+ CPPAssOp $+ withPar (IntParDefCPP $ CPPVar "i") state $ \state par -> astColExpr state astThis a $ Term par,+ CPPStatement $+ CPPFor+ (Right $ astDeclEq "i" astTInt $ astIntExpr state astThis $ size a)+ (Just $ CPPBinary (CPPVar "i") CPPOpLe $ astIntExpr state astThis $ size a + size b)+ (Just $ CPPUnary CPPOpPostInc $ CPPVar "i") $+ CPPSimple $ CPPAssign+ (CPPIndex (CPPVar ("cte" ++ (show $ level state) ++ "_" ++ (show pos))) $ CPPVar "i")+ CPPAssOp $+ withPar (IntParDefCPP $ CPPVar "i") state $ \state par -> astColExpr state astThis b $ (Term par) - (size a)+ ]+ x -> error $ "Unsupported operation on constant lists: " ++ (show x)+ | pos <- [0..(length (colList state))-1] + ]) +++ (if (nBoolVars state > 0) + then + [CPPComment "decl boolvars"]++[+ CPPBlockDecl $ astDeclFn (boolVarName $ BoolVar (level state) j) astTBV [astThis,astInt 0,astInt 1] | j <- [0..nBoolVars state - 1] + ] else []) +++ (if (nIntVars state > 0)+ then+ [CPPComment "decl intvars"]++[+ CPPBlockDecl $ astDeclFn (intVarName $ IntVar (level state) j) astTIV [astThis,astLowerBound,astUpperBound] | j <- [0..nIntVars state - 1]+ ] else []+ ) +++ (if (length (colVars state) > 0) + then + [CPPComment "decl colvars"]++[+ CPPBlockDecl $ astDeclFn (colVarName $ ColVar (level state) j) astTIVA [astColSize (ColVar (level state) j) state astThis] | j <- [0..(length $ colVars state)-1], not (level state == 0 && isJust (ret state) && ret state == Just (ColVar 0 j)) + ] else []+ ) +++ [CPPComment $ "init col vars"]+++ [ CPPStatement $ case x of+ ColDefSize s -> CPPCompound [CPPComment "ColDefSize",CPPStatement $ CPPFor (Right $ astDeclEq "i" astTInt $ astInt 0) (Just $ CPPBinary (CPPVar "i") CPPOpLe $ astIntExpr state astThis s) (Just $ CPPUnary CPPOpPostInc (CPPVar "i")) $+ CPPSimple $ CPPCall (call (CPPIndex (astColVar state astThis i) (CPPVar "i")) "init") [astThis,astLowerBound,astUpperBound]+ ]+ ColDefList l -> CPPCompound $ + (CPPComment "ColDefList") :+ (CPPBlockDecl $ astDeclFn "b" astTIVA [astInt $ toInteger $ length l]) :+ ([ CPPStatement $ CPPSimple $ CPPAssign (CPPIndex (CPPVar "b") (astInt $ toInteger i2)) CPPAssOp $ (astIntVar state astThis f2) | (i2,f2) <- zip [0..(length l)-1] l ] +++ [ CPPStatement $ CPPSimple $ CPPAssign (astColVar state astThis i) CPPAssOp (CPPVar "b") ])+ ColDefCat a b -> if (astColVar state astThis i) == (call astThis "ret")+ then+ CPPCompound $ [+ CPPComment "ColDefCat-ret",+ CPPStatement $ CPPFor (Right $ astDeclEq "i" astTInt $ astInt 0) (Just $ CPPBinary (CPPVar "i") CPPOpLe $ astColSize a state astThis) (Just $ CPPUnary CPPOpPostInc (CPPVar "i")) $ CPPSimple $ CPPAssign (CPPIndex (astColVar state astThis i) (CPPVar "i")) CPPAssOp (CPPIndex (astColVar state astThis a) (CPPVar "i")),+ CPPStatement $ CPPFor (Right $ astDeclEq "i" astTInt $ astInt 0) (Just $ CPPBinary (CPPVar "i") CPPOpLe $ astColSize b state astThis) (Just $ CPPUnary CPPOpPostInc (CPPVar "i")) $ CPPSimple $ CPPAssign (CPPIndex (astColVar state astThis i) (CPPVar "i" + astColSize a state astThis)) CPPAssOp (CPPIndex (astColVar state astThis b) (CPPVar "i"))+ ]+ else+ CPPCompound $ [+ CPPComment "ColDefCat",+ CPPBlockDecl $ astDeclFn "b" astTIVA [astColSize a state astThis + astColSize b state astThis],+ CPPStatement $ CPPFor (Right $ astDeclEq "i" astTInt $ astInt 0) (Just $ CPPBinary (CPPVar "i") CPPOpLe $ astColSize a state astThis) (Just $ CPPUnary CPPOpPostInc (CPPVar "i")) $ CPPSimple $ CPPAssign (CPPIndex (CPPVar "b") (CPPVar "i")) CPPAssOp (CPPIndex (astColVar state astThis a) (CPPVar "i")),+ CPPStatement $ CPPFor (Right $ astDeclEq "i" astTInt $ astInt 0) (Just $ CPPBinary (CPPVar "i") CPPOpLe $ astColSize b state astThis) (Just $ CPPUnary CPPOpPostInc (CPPVar "i")) $ CPPSimple $ CPPAssign (CPPIndex (CPPVar "b") (CPPVar "i" + astColSize a state astThis)) CPPAssOp (CPPIndex (astColVar state astThis b) (CPPVar "i")),+ CPPStatement $ CPPSimple $ CPPAssign (astColVar state astThis i) CPPAssOp (CPPVar "b")+ ]+ {- ColDefTake a p l -> CPPCompound $ [+ CPPBlockDecl $ astDeclFn "b" astTIVA [astThis,astIntExpr state astThis l],+ CPPStatement $ CPPFor (Right $ astDeclEq "i" astTInt $ astInt 0) (Just $ CPPBinary (CPPVar "i") CPPOpLe $ astColSize a state astThis) (Just $ CPPUnary CPPOpPostInc (CPPVar "i")) $ CPPSimple $ CPPAssign (CPPIndex (CPPVar "b") (CPPVar "i")) CPPAssOp (CPPIndex (astColVar state astThis a) (CPPVar "i" + (astIntExpr state astThis p))),+ CPPStatement $ CPPSimple $ CPPAssign (astColVar state astThis i) CPPAssOp (CPPVar "b")+ ]-}+ | (i,x) <- zip (map (ColVar (level state)) [0..(length $ colVars state)-1]) $ colVars state ] +++ (case (ret state) of+ Nothing -> []+ Just (ColVar 0 _) | level state == 0 -> []+ Just r -> + [+ CPPComment "init ret",+ CPPStatement $ CPPFor (Right $ astDeclEq "i" astTInt $ astInt 0) (Just $ CPPBinary (CPPVar "i") CPPOpLe $ astColSize r state astThis) (Just $ CPPUnary CPPOpPostInc (CPPVar "i")) $ CPPSimple $ CPPAssign (CPPIndex (call astThis "ret") (CPPVar "i")) CPPAssOp (CPPIndex (astColVar state astThis r) (CPPVar "i"))+ ]+ ) +++ [CPPComment "constraints"]++[ CPPStatement x | x <- conss ] +++ (if level state == 0+ then + [CPPComment "branchers" ]+++ (case minVar state of+ Nothing -> []+ Just m -> + [+ CPPStatement $ CPPSimple $ CPPAssign (CPPVar "cost") CPPAssOp (astIntVar state astThis m),+ CPPStatement $ CPPSimple $ CPPCall (CPPVar "branch") [astThis,call astThis "cost",CPPVar "INT_VAL_MIN"]+ ]+ )+++ ([CPPStatement $ CPPSimple $ CPPCall (CPPVar "branch") [astThis,call astThis "ret",CPPVar "INT_VAR_SIZE_MIN",CPPVar "INT_VAL_SPLIT_MIN"]])+ else []+ )++generateGecode :: CompilableModel t => t -> String+generateGecode x = + let ([tru,mnu],state) = run $ compile False x $ retState astGenerate+ sru = case (noGenSearch $ options state) of+ True -> ""+ False -> case (minVar state) of+ Nothing -> search $ prt ["branch"] <@> fs <@> Generator.label "branch" domsizeV minV medianD ($<=)+ Just _ -> search $ prt ["branch"] <@> (bbmin "cost" <@> (Generator.label "bound" lbV minV medianD ($==) <&> Generator.label "branch" domsizeV minV medianD ($<=) {- <&> Generator.label "bound" lbV minV meanD ($==) -} ))+ ret = codegen tru ++ sru ++ codegen mnu+ in ret
Control/CP/FD/Gecode/Common.hs view
@@ -1,277 +1,1677 @@-{-# LANGUAGE ExistentialQuantification #-}-{-# LANGUAGE GADTs #-}-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE TypeFamilies #-}--module Control.CP.FD.Gecode.Common (- GTerm(..),- GType(..),- IntTerm(..),- BoolTerm(..),- GConstraint(..),- GOperator(..),- GecodeSolver(..),- orElse,- linearCompile,- basicCompile-) where--import Maybe (fromMaybe,catMaybes,isJust,fromJust)-import List (findIndex,find)-import Data.Map hiding (map,filter)--import Control.Monad.State.Lazy-import Control.Monad.Trans-import Control.Monad.Cont---import Control.CP.SearchTree hiding (label)-import Control.CP.Solver-import Control.CP.FD.FD-import Control.CP.FD.Expr-import Control.CP.Debug-import Control.CP.Mixin--- import Control.CP.Gecode.Gecode------------------------------------------------------------------------------------- | Gecode terms-----------------------------------------------------------------------------------class GTerm t where- getVarId :: t -> Maybe Int- getIntValue :: t -> Maybe Integer- getDefBounds :: t -> (Integer,Integer)--data GType = TypeInt | TypeBool- deriving (Show, Eq)---- | integer terms-data IntTerm- = IntVar Int- | IntConst Integer- deriving Eq--instance Ord IntTerm where- compare (IntVar i1) (IntVar i2) = compare i1 i2- compare (IntVar _) _ = LT- compare _ (IntVar _) = GT- compare (IntConst c1) (IntConst c2) = compare c1 c2--instance Show IntTerm where- show (IntVar i) = "i" ++ (show i)- show (IntConst i) = (show i)--instance GTerm IntTerm where- getVarId (IntVar i) = Just i- getVarId (IntConst _) = Nothing- getIntValue (IntVar _) = Nothing- getIntValue (IntConst c) = Just c- getDefBounds _ = (-1000000000,1000000000)---- | boolean terms-data BoolTerm where- BoolVar :: Int -> BoolTerm- BoolConst :: Bool -> BoolTerm- deriving Eq--instance Show BoolTerm where- show (BoolVar i) = "b" ++ (show i)- show (BoolConst b) = show b--instance GTerm BoolTerm where- getVarId (BoolVar i) = Just i- getVarId (BoolConst _) = Nothing- getIntValue (BoolVar _) = Nothing- getIntValue (BoolConst c) = Just $ if c then 1 else 0- getDefBounds _ = (0,1)---- instance Term Gecode BoolTerm where--- type TermInfo Gecode BoolTerm = Bool--- newvar = newVar False TypeBool >>= return . BoolVar--- --- instance Term Gecode IntTerm where--- type TermInfo Gecode IntTerm = Bool--- newvar = newVar False TypeInt >>= return . IntVar-------------------------------------------------------------------------------------- | Gecode constraints -----------------------------------------------------------------------------------data GConstraint - = forall t . GTerm t => CDiff t t- | forall t . GTerm t => CSame t t- | CRel IntTerm GOperator IntTerm- | CMult IntTerm IntTerm IntTerm- | CAbs IntTerm IntTerm- | CDiv IntTerm IntTerm IntTerm- | CMod IntTerm IntTerm IntTerm- | CValue IntTerm Integer- | CDom IntTerm Integer Integer- | CLinear [(IntTerm,Integer)] GOperator Integer- | CAllDiff [IntTerm]- | CSorted [IntTerm] Bool--instance Show GConstraint where- show (CRel x o y) = "(Rel: " ++ (show x) ++ (show o) ++ (show y) ++ ")"- show (CMult x y z) = "(Mult: " ++ (show x) ++ " * " ++ (show y) ++ " = " ++ (show z) ++ ")"- show (CDiv x y z) = "(Div: " ++ (show x) ++ " / " ++ (show y) ++ " = " ++ (show z) ++ ")"- show (CMod x y z) = "(Mod: " ++ (show x) ++ " % " ++ (show y) ++ " = " ++ (show z) ++ ")"- show (CAbs x y) = "(Abs: abs " ++ (show x) ++ " = " ++ (show y) ++ ")"- show (CDom x y z) = "(Dom: " ++ (show x) ++ " in [" ++ (show y) ++ "," ++ (show z) ++ "])"- show (CValue x y) = "(Value: " ++ (show x) ++ " is " ++ (show y) ++ ")"- show (CLinear l o c) = "(Linear: " ++ (show l) ++ (show o) ++ (show c) ++ ")"- show (CAllDiff l) = "(AllDiff: " ++ (show l) ++ ")"--data GOperator- = OEqual- | ODiff- | OLess--instance Show GOperator where- show OEqual = "=="- show ODiff = "/="- show OLess = "<"------------------------------------------------------------------------------------- | Gecode FDSolver instance-----------------------------------------------------------------------------------class (Solver s, Term s IntTerm) => GecodeSolver s where- setVarImplicit :: IntTerm -> Bool -> s ()- setVarImplicit _ _ = return ()- caching_decompose :: GecodeSolver s => Mixin (Expr (FDTerm s) -> Tree s IntTerm)- caching_decompose s _ x = s x---- | basic compilation--basicCompile :: (FDSolver s, Constraint s ~ GConstraint, FDTerm s ~ IntTerm) => Mixin (FDConstraint s -> Tree s Bool)-basicCompile s t (Same a (Plus b c)) = do- va <- getAsVar a- vb <- getAsVar b- vc <- getAsVar c- addT (CLinear [(va,1),(vb,-1),(vc,-1)] OEqual 0)-basicCompile s t (Same a (Minus b c)) = do- va <- getAsVar a- vb <- getAsVar b- vc <- getAsVar c- addT (CLinear [(va,1),(vb,1),(vc,1)] OEqual 0)-basicCompile s t (Same a (Mult b c)) = do- va <- getAsVar a- vb <- getAsVar b- vc <- getAsVar c- addT (CMult vb vc va)-basicCompile s t (Same a (Div b c)) = do- va <- getAsVar a- vb <- getAsVar b- vc <- getAsVar c- addT (CDiv vb vc va)-basicCompile s t (Same a (Mod b c)) = do- va <- getAsVar a- vb <- getAsVar b- vc <- getAsVar c- addT (CMod vb vc va)-basicCompile s t (Same a (Abs b)) = do- va <- getAsVar a- vb <- getAsVar b- addT (CAbs vb va)-basicCompile s t (Same a@(Plus _ _) b) = basicCompile s t $ Same b a-basicCompile s t (Same a@(Minus _ _) b) = basicCompile s t $ Same b a-basicCompile s t (Same a@(Mult _ _) b) = basicCompile s t $ Same b a-basicCompile s t (Same a@(Div _ _) b) = basicCompile s t $ Same b a-basicCompile s t (Same a@(Mod _ _) b) = basicCompile s t $ Same b a-basicCompile s t (Same a@(Abs _) b) = basicCompile s t $ Same b a-basicCompile s t (Same a@(Const _) b) = basicCompile s t $ Same b a-basicCompile s t (Same a (Const i)) = do- va <- getAsVar a- addT (CValue va i)-basicCompile s t (x@(Same a b)) = do- va <- getAsVar a- vb <- getAsTerm b- addT (CRel va OEqual vb)-basicCompile s t (Diff a b) = do- va <- getAsVar a- vb <- getAsTerm b- addT (CRel va ODiff vb)-basicCompile s t (Less a b) = do- va <- getAsVar a- vb <- getAsTerm b- addT (CRel va OLess vb)-basicCompile s t (Dom a l h) = do- va <- getAsVar a- addT (CDom va l h)-basicCompile s t (AllDiff l) = do- vl <- mapM getAsVar l- addT (CAllDiff vl)-basicCompile s t (Sorted l e) = do- vl <- mapM getAsVar l- addT (CSorted vl e)--- basicCompile s _ x = s x--getAsVar :: (FDSolver s, Constraint s ~ GConstraint, FDTerm s ~ IntTerm) => Expr IntTerm -> Tree s IntTerm-getAsVar = decompose-getAsTerm :: (FDSolver s, Constraint s ~ GConstraint, FDTerm s ~ IntTerm) => Expr IntTerm -> Tree s IntTerm-getAsTerm (Const c) = return $ IntConst c-getAsTerm x = decompose x---- | linear constraint compilation--linearCompile :: (FDSolver s, Constraint s ~ GConstraint, FDTerm s ~ IntTerm) => Mixin (FDConstraint s -> Tree s Bool)-linearCompile s t (Same a@(Plus _ _) b) = linearCompileX a b OEqual-linearCompile s t (Same a@(Minus _ _) b) = linearCompileX a b OEqual-linearCompile s t (Same b a@(Plus _ _)) = linearCompileX a b OEqual-linearCompile s t (Same b a@(Minus _ _)) = linearCompileX a b OEqual-linearCompile s t (Diff a@(Plus _ _) b) = linearCompileX a b ODiff-linearCompile s t (Diff a@(Minus _ _) b) = linearCompileX a b ODiff-linearCompile s t (Diff a b@(Plus _ _)) = linearCompileX a b ODiff-linearCompile s t (Diff a b@(Minus _ _)) = linearCompileX a b ODiff-linearCompile s t (Less a@(Plus _ _) b) = linearCompileX a b OLess-linearCompile s t (Less a@(Minus _ _) b) = linearCompileX a b OLess-linearCompile s t (Less a b@(Plus _ _)) = linearCompileX a b OLess-linearCompile s t (Less a b@(Minus _ _)) = linearCompileX a b OLess-linearCompile s t x = s x--linearCompileX a b o = - do t1 <- linearExprCompile a- t2 <- linearExprCompile b- let (x,a,c) = linearAdd t1 t2 1 (-1)- addT (CLinear (filter (\(_,a) -> a /= 0) $ map (\(xe,ae) -> (IntVar xe,ae)) $ zip x a) o c)--linearExprCompile :: (FDSolver s, Constraint s ~ GConstraint, FDTerm s ~ IntTerm) => Expr (FDTerm s) -> Tree s ([Int],[Integer],Integer)-linearExprCompile (Term (IntVar i)) = - return ([i],[1],0)-linearExprCompile (Term (IntConst c)) = - return ([],[],-c)-linearExprCompile (Const c) = - return ([],[],-c)-linearExprCompile (Plus a b) = - do t1 <- linearExprCompile a- t2 <- linearExprCompile b- return $ linearAdd t1 t2 1 1-linearExprCompile (Minus a b) = - do t1 <- linearExprCompile a- t2 <- linearExprCompile b- return $ linearAdd t1 t2 1 (-1)-linearExprCompile (Mult (Const c) a) = - do t <- linearExprCompile a- return $ linearAdd t ([],[],0) c 1-linearExprCompile (Mult a (Const c)) = - linearExprCompile (Mult (Const c) a)-linearExprCompile x =- do (IntVar i) <- getAsVar x- return ([i],[1],0)--linearAdd (x1,a1,c1) (x2,a2,c2) m1 m2 = case (x1,a1) of- ([],[]) -> (x2,map (*m2) a2,m1*c1+m2*c2)- (x1e:x1s,a1e:a1s) -> linearAdd (x1s,a1s,c1) (linearAddTerm (x2,a2,c2) x1e a1e m2 m1 [] []) m1 1--linearAddTerm (x1,a1,c1) x2e a2e m1 m2 xc ac = case (x1,a1) of- ([],[]) -> (x2e:xc,(a2e*m2):ac,c1*m1)- (x1e:x1s,a1e:a1s) -> if x1e == x2e- then ((x2e:x1s) ++ xc,((a1e*m1+a2e*m2):(map (*m1) a1s)) ++ ac,c1*m1)- else linearAddTerm (x1s,a1s,c1) x2e a2e m1 m2 (x1e:xc) ((a1e*m1):ac)---- | utility--orElse :: Maybe a -> Maybe a -> Maybe a-orElse = mplus+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE TypeSynonymInstances #-}+{-# LANGUAGE UndecidableInstances #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE StandaloneDeriving #-}+{-# LANGUAGE ScopedTypeVariables #-}++module Control.CP.FD.Gecode.Common (+ GecodeSolver(..),+ GecodeConstraint(..),+ GecodeOperator(..),+ GecodeBoolSpecType(..), GecodeIntSpecType(..), GecodeColSpecType(..),+ GecodeIntSpec(..), GecodeBoolSpec(..), GecodeColSpec(..),+ GecodeIBFn(..), GecodeIIFn(..), GecodeIIIFn(..), GecodeICIFn(..), GecodeCBFn(..), GecodeCIFn(..),+ GecodeIntConst, GecodeBoolConst, GecodeColConst, GecodeListConst,+ GecodeIntParam(..), GecodeBoolParam(..), GecodeColParam(..),+ GecodeLinear,+ GecodeColVarOrSection,+ GecodeWrappedSolver, liftGC, unliftGC,+ toConst, fromConst, toBoolConst, fromBoolConst,+ addMeta, procConstraint+) where++import qualified Data.Map as Map+import Data.Map (Map)+import Data.Maybe (fromJust,isJust)+import qualified Data.Set as Set+import Data.Set(Set)++import Control.Mixin.Mixin++import Control.CP.Debug+import Control.CP.FD.FD+import Data.Expr.Data+import Data.Expr.Util+import Control.CP.FD.Graph+import Control.CP.FD.Model+import Control.CP.Solver+import Control.CP.EnumTerm+import Control.CP.SearchTree+import Data.Linear++newtype GecodeIntParam = GIParam Int+ deriving (Show,Eq,Ord)++newtype GecodeBoolParam = GBParam Int+ deriving (Show,Eq,Ord)++newtype GecodeColParam = GCParam Int+ deriving (Show,Eq,Ord)++type GecodeIntConst = Expr GecodeIntParam GecodeColParam GecodeBoolParam+type GecodeBoolConst = BoolExpr GecodeIntParam GecodeColParam GecodeBoolParam+type GecodeColConst = ColExpr GecodeIntParam GecodeColParam GecodeBoolParam+type GecodeListConst = (GecodeIntConst,GecodeIntConst -> GecodeIntConst)++-- buildList :: GecodeListConst -> Maybe [Integer]+buildList (Const n,f) = fromAll [q $ f $ Const x | x <- [0..n-1]]+ where q (Const x) = Just x+ q _ = Nothing+buildList _ = Nothing++myFromJust _ (Just x) = x+myFromJust str _ = error $ "myFromJust: "++str++type GecodeIntVarOrConst s = Either (GecodeIntVar s) GecodeIntConst+type GecodeColVarOrConst s = Either (GecodeColVar s) (Either [Integer] GecodeListConst)+type GecodeColSection s = (GecodeColVar s, GecodeListConst)++buildSection :: GecodeSolver s => GecodeColSection s -> s (GecodeColVar s)+buildSection (col,list) = case buildList list of+ Nothing -> error "Cannot instantiate section"+ Just l -> do+ ll <- mapM (\p -> newInt_at col $ Const p) l+ newCol_list ll++type GecodeColVarOrSection s = Either (GecodeColVar s) (GecodeColSection s)++-- getIntVarOrConst :: (FDSolver s, FDIntSpecType s ~ GecodeIntSpecType, FDIntSpec s ~ GecodeIntSpec s) => FDSpecInfoInt s -> GecodeIntVarOrConst s+getIntVarOrConst s = case (fdspIntSpec s) (Just GISConst) of+ Just (GITConst v) -> Right v+ _ -> case (fdspIntSpec s) (Just GISVar) of+ Just (GITVar c) -> Left c+ _ -> error "Cannot convert to Var-or-Const Int"++-- getColVarOrConst :: (FDSolver s, FDColSpecType s ~ GecodeColSpecType, FDColSpec s ~ GecodeColSpec s) => FDSpecInfoCol s -> GecodeColVarOrConst s+getColVarOrConst s = case (fdspColSpec s) (Just GCSConst) of+ Just (GCTConst t@(ColList l)) -> Right $ case fromAll [ case x of { Const y -> Just y; _ -> Nothing } | x <- l] of+ Just x -> Left x+ _ -> Right (size t, \i -> t!i)+ Just (GCTConst t) -> Right $ Right (size t, \i -> t!i)+ _ -> case (fdspColSpec s) (Just GCSVar) of+ Just (GCTVar v) -> Left v+ _ -> error "Cannot convert to Var-or-Const Col"++getAnyColSpec s = fdspColSpec s Nothing++transIntPar (EGPTParam i) = GIParam i+transBoolPar (EGPTBoolParam i) = GBParam i+transColPar (EGPTColParam i) = GCParam i+transRevIntPar (GIParam i) = EGPTParam i+transRevBoolPar (GBParam i) = EGPTBoolParam i+transRevColPar (GCParam i) = EGPTColParam i++transFns = (transIntPar,transColPar,transBoolPar,transRevIntPar,transRevColPar,transRevBoolPar)+transIFns = (transRevIntPar,transRevColPar,transRevBoolPar,transIntPar,transColPar,transBoolPar)+transPar = transform transFns+transIPar = transform transIFns+transParBool = boolTransform transFns+transIParBool = boolTransform transIFns+transParCol = colTransform transFns+transIParCol = colTransform transIFns++type GecodeLinear s = Linear (GecodeIntVar s) GecodeIntConst++data GecodeIntSpec s =+ GITConst GecodeIntConst+ | GITLinear (GecodeLinear s)+ | GITVar (GecodeIntVar s)++deriving instance (Eq (GecodeIntVar s), Show (GecodeIntVar s), Ord (GecodeIntVar s))=> Show (GecodeIntSpec s)++data GecodeIntSpecType =+ GISConst+ | GISLinear+ | GISVar+ deriving (Enum,Bounded,Eq,Ord,Show)++data GecodeBoolSpec s =+ GBTConst GecodeBoolConst+ | GBTCondConst GecodeBoolConst GecodeBoolConst -- x := GBTCondConst a b <=> if a then x==b+ | GBTVar (GecodeBoolVar s)++deriving instance (Eq (GecodeBoolVar s), Show (GecodeBoolVar s), Ord (GecodeBoolVar s))=> Show (GecodeBoolSpec s)++data GecodeBoolSpecType =+ GBSConst+ | GBSCondConst+ | GBSVar+ deriving (Enum,Bounded,Eq,Ord,Show)++data GecodeColSpec s =+ GCTConst (GecodeColConst)+ | GCTSection (GecodeColSection s)+ | GCTVar (GecodeColVar s)++deriving instance (Eq (GecodeColVar s), Show (GecodeColVar s), Ord (GecodeColVar s)) => Show (GecodeColSpec s)++data GecodeColSpecType =+ GCSConst+ | GCSSection+ | GCSVar+ deriving (Enum,Bounded,Eq,Ord,Show)++data GecodeOperator =+ GOEqual+ | GODiff+ | GOLess+ | GOLessEqual+ deriving (Eq,Ord,Show)++invOperator :: Bool -> a -> GecodeOperator -> a -> (a,GecodeOperator,a)+invOperator False a b c = (a,b,c)+invOperator True a GOEqual b = (a,GODiff,b)+invOperator True a GODiff b = (a,GOEqual,b)+invOperator True a GOLess b = (b,GOLessEqual,a)+invOperator True a GOLessEqual b = (b,GOLess,a)++data GecodeSolver s => GecodeConstraint s =+ GCBoolVal (GecodeBoolVar s) GecodeBoolConst+ | GCBoolEqual (GecodeBoolVar s) (GecodeBoolVar s)+ | GCIntVal (GecodeIntVar s) GecodeIntConst+ | GCLinear (GecodeLinear s) GecodeOperator+ | GCLinearReif (GecodeLinear s) GecodeOperator (GecodeBoolVar s)+ | GCColEqual (GecodeColVar s) (GecodeColVar s)+ | GCMult (GecodeIntVar s) (GecodeIntVar s) (GecodeIntVar s)+ | GCDiv (GecodeIntVar s) (GecodeIntVar s) (GecodeIntVar s)+ | GCMod (GecodeIntVar s) (GecodeIntVar s) (GecodeIntVar s)+ | GCAbs (GecodeIntVar s) (GecodeIntVar s)+ | GCAt (GecodeIntVarOrConst s) (GecodeColVarOrConst s) (GecodeIntVarOrConst s)+ | GCChannel (GecodeIntVar s) (GecodeBoolVar s)+ | GCSize (GecodeColVar s) (GecodeIntVarOrConst s)+ | GCCat (GecodeColVar s) (GecodeColVar s) (GecodeColVar s)+-- | GCTake (GecodeColVar s) (GecodeColVar s) GecodeIntConst GecodeIntConst+ | GCSlice (GecodeColVar s) (GecodeColSection s)+ | GCAnd [GecodeBoolVar s] (GecodeBoolVar s)+ | GCOr [GecodeBoolVar s] (GecodeBoolVar s)+ | GCNot (GecodeBoolVar s) (GecodeBoolVar s)+ | GCEquiv (GecodeBoolVar s) (GecodeBoolVar s) (GecodeBoolVar s)+ | GCAllDiff Bool (GecodeColVarOrSection s) -- bool is true when domain consistency is to be used+ | GCSorted (GecodeColVarOrSection s) GecodeOperator+ | GCAll (GecodeIBFn s) (GecodeColVarOrSection s) (Maybe (GecodeBoolVar s))+ | GCAny (GecodeIBFn s) (GecodeColVarOrSection s) (Maybe (GecodeBoolVar s))+ | GCAllC (GecodeCBFn s) (GecodeListConst) (Maybe (GecodeBoolVar s))+ | GCAnyC (GecodeCBFn s) (GecodeListConst) (Maybe (GecodeBoolVar s))+ | GCMap (GecodeIIFn s) (GecodeColVarOrSection s) (GecodeColVar s)+ | GCFold (GecodeIIIFn s) (GecodeColVarOrSection s) (GecodeIntVar s) (GecodeIntVar s) -- (prev -> arg -> ret -> ()) col init ret+ | GCFoldC (GecodeICIFn s) (GecodeIntConst) (GecodeIntVar s) (GecodeIntVar s) -- (prev -> arg -> ret -> ()) num init ret+ | GCSum (GecodeColVarOrSection s) (GecodeIntVarOrConst s)+ | GCCount (GecodeColVar s) (GecodeIntVarOrConst s) GecodeOperator (GecodeIntVarOrConst s)+ | GCDom (GecodeIntVar s) (GecodeColVarOrConst s) (Maybe (GecodeBoolVar s))+ | GCCond (GecodeConstraint s) GecodeBoolConst++procHelperInt :: GecodeSolver s => GecodeIntConst -> WalkPhase -> s WalkResult+procHelperInt _ _ = return WalkDescend+procHelperCol :: GecodeSolver s => GecodeColConst -> WalkPhase -> s WalkResult+procHelperCol c (WalkPre) = do+ return WalkDescend+procHelperCol c (WalkSingle) = do+ col_regList c+ return WalkDescend+procHelperCol c (WalkPost) = do+ col_regList c+ return WalkDescend+procHelperBool :: GecodeSolver s => GecodeBoolConst -> WalkPhase -> s WalkResult+procHelperBool _ _ = return WalkDescend+procHelper :: GecodeSolver s => (GecodeIntConst -> WalkPhase -> s WalkResult,GecodeColConst -> WalkPhase -> s WalkResult,GecodeBoolConst -> WalkPhase -> s WalkResult)+procHelper = (procHelperInt, procHelperCol, procHelperBool)++class Procable x where+ gwalk :: GecodeSolver s => x -> s ()++instance Procable GecodeIntConst where+ gwalk x = walk x procHelper++instance Procable GecodeBoolConst where+ gwalk x = boolWalk x procHelper++instance Procable GecodeColConst where+ gwalk x = colWalk x procHelper++instance Procable a => Procable (Either b a) where+ gwalk (Left _) = return ()+ gwalk (Right c) = gwalk c++instance (Ord b, Num a, Procable a) => Procable (Linear b a) where+ gwalk l = mapM_ (\(_,v) -> gwalk v) $ linearToList l++instance Procable GecodeListConst where+ gwalk (n,f) = gwalk n >> gwalk (f $ ExprHole (-1))++instance Procable (a,GecodeListConst) where+ gwalk (_,c) = gwalk c++instance Procable a => Procable [a] where+ gwalk l = mapM_ gwalk l++procConstraint (GCBoolVal _ x) = gwalk x+procConstraint (GCIntVal _ x) = gwalk x+procConstraint (GCLinear l _) = gwalk l+procConstraint (GCLinearReif l _ _) = gwalk l+procConstraint (GCAt a b c) = gwalk [a,c] >> gwalk b+procConstraint (GCSize _ a) = gwalk a+procConstraint (GCAll _ s _) = gwalk s+procConstraint (GCAny _ s _) = gwalk s+procConstraint (GCAllC _ l _) = gwalk l+procConstraint (GCAnyC _ l _) = gwalk l+procConstraint (GCFoldC _ l _ _)= gwalk l+procConstraint (GCSum s l) = gwalk l >> gwalk s+procConstraint (GCCount _ a _ b) = gwalk [a,b]+procConstraint (GCDom _ a _) = gwalk a+procConstraint (GCCond c a) = gwalk a >> procConstraint c+procConstraint _ = return ()++++unwrapConstraint :: (GecodeSolver s, GecodeConstraint s ~ Constraint s) => GecodeConstraint (GecodeWrappedSolver s) -> GecodeConstraint s+unwrapConstraint (GCBoolVal a b) = GCBoolVal a b+unwrapConstraint (GCBoolEqual a b) = GCBoolEqual a b+unwrapConstraint (GCIntVal a b) = GCIntVal a b+unwrapConstraint (GCLinear a b) = GCLinear a b+unwrapConstraint (GCLinearReif a b c) = GCLinearReif a b c+unwrapConstraint (GCColEqual a b) = GCColEqual a b+unwrapConstraint (GCMult a b c) = GCMult a b c+unwrapConstraint (GCDiv a b c) = GCDiv a b c+unwrapConstraint (GCMod a b c) = GCMod a b c+unwrapConstraint (GCAbs a b) = GCAbs a b+unwrapConstraint (GCAt a b c) = GCAt a b c+unwrapConstraint (GCChannel a b) = GCChannel a b+unwrapConstraint (GCSize a b) = GCSize a b+unwrapConstraint (GCCat a b c) = GCCat a b c+unwrapConstraint (GCSlice a b) = GCSlice a b+unwrapConstraint (GCAnd a b) = GCAnd a b+unwrapConstraint (GCOr a b) = GCOr a b+unwrapConstraint (GCNot a b) = GCNot a b+unwrapConstraint (GCEquiv a b c) = GCEquiv a b c+unwrapConstraint (GCAllDiff b c) = GCAllDiff b c+unwrapConstraint (GCSorted a b) = GCSorted a b+unwrapConstraint (GCAll f a b) = GCAll (uIBFn f) a b+unwrapConstraint (GCAny f a b) = GCAny (uIBFn f) a b+unwrapConstraint (GCAllC f a b) = GCAllC (uCBFn f) a b+unwrapConstraint (GCAnyC f a b) = GCAnyC (uCBFn f) a b+unwrapConstraint (GCMap f a b) = GCMap (uIIFn f) a b+unwrapConstraint (GCFold f a b c) = GCFold (uIIIFn f) a b c+unwrapConstraint (GCFoldC f a b c) = GCFoldC (uICIFn f) a b c+unwrapConstraint (GCCount a b c d) = GCCount a b c d+unwrapConstraint (GCSum a b) = GCSum a b+unwrapConstraint (GCDom a b c) = GCDom a b c+unwrapConstraint (GCCond a b) = GCCond (unwrapConstraint a) b++wrapConstraint :: (GecodeSolver s, GecodeConstraint s ~ Constraint s) => GecodeConstraint s -> GecodeConstraint (GecodeWrappedSolver s)+wrapConstraint (GCBoolVal a b) = GCBoolVal a b+wrapConstraint (GCBoolEqual a b) = GCBoolEqual a b+wrapConstraint (GCIntVal a b) = GCIntVal a b+wrapConstraint (GCLinear a b) = GCLinear a b+wrapConstraint (GCLinearReif a b c) = GCLinearReif a b c+wrapConstraint (GCColEqual a b) = GCColEqual a b+wrapConstraint (GCMult a b c) = GCMult a b c+wrapConstraint (GCDiv a b c) = GCDiv a b c+wrapConstraint (GCMod a b c) = GCMod a b c+wrapConstraint (GCAbs a b) = GCAbs a b+wrapConstraint (GCAt a b c) = GCAt a b c+wrapConstraint (GCChannel a b) = GCChannel a b+wrapConstraint (GCSize a b) = GCSize a b+wrapConstraint (GCCat a b c) = GCCat a b c+wrapConstraint (GCSlice a b) = GCSlice a b+wrapConstraint (GCAnd a b) = GCAnd a b+wrapConstraint (GCOr a b) = GCOr a b+wrapConstraint (GCNot a b) = GCNot a b+wrapConstraint (GCEquiv a b c) = GCEquiv a b c+wrapConstraint (GCAllDiff b c) = GCAllDiff b c+wrapConstraint (GCSorted a b) = GCSorted a b+wrapConstraint (GCAll f a b) = GCAll (wIBFn f) a b+wrapConstraint (GCAny f a b) = GCAny (wIBFn f) a b+wrapConstraint (GCAllC f a b) = GCAllC (wCBFn f) a b+wrapConstraint (GCAnyC f a b) = GCAnyC (wCBFn f) a b+wrapConstraint (GCMap f a b) = GCMap (wIIFn f) a b+wrapConstraint (GCFold f a b c) = GCFold (wIIIFn f) a b c+wrapConstraint (GCFoldC f a b c) = GCFoldC (wICIFn f) a b c+wrapConstraint (GCCount a b c d) = GCCount a b c d+wrapConstraint (GCSum a b) = GCSum a b+wrapConstraint (GCDom a b c) = GCDom a b c+wrapConstraint (GCCond a b) = GCCond (wrapConstraint a) b+++idx c i = + if i<0 + then error "idx: i<0"+ else if i>=length c+ then error "GC idx: i>=length c"+ else c!!i++newtype GecodeFn s = GecodeFn (s ())+newtype GecodeIBFn s = GecodeIBFn (GecodeIntVar s -> GecodeBoolVar s -> s ())+newtype GecodeCBFn s = GecodeCBFn (GecodeIntConst -> GecodeBoolVar s -> s ())+newtype GecodeCIFn s = GecodeCIFn (GecodeIntConst -> GecodeIntVar s -> s ())+newtype GecodeIIFn s = GecodeIIFn (GecodeIntVar s -> GecodeIntVar s -> s ())+newtype GecodeIIIFn s = GecodeIIIFn (GecodeIntVar s -> GecodeIntVar s -> GecodeIntVar s -> s ())+newtype GecodeICIFn s = GecodeICIFn (GecodeIntVar s -> GecodeIntConst -> GecodeIntVar s -> s ())++uFn (GecodeFn f) = GecodeFn (case f of (GecodeWrappedSolver m) -> m)+uIBFn (GecodeIBFn f) = GecodeIBFn (\a b -> case f a b of (GecodeWrappedSolver m) -> m)+uCBFn (GecodeCBFn f) = GecodeCBFn (\a b -> case f a b of (GecodeWrappedSolver m) -> m)+uCIFn (GecodeCIFn f) = GecodeCIFn (\a b -> case f a b of (GecodeWrappedSolver m) -> m)+uIIFn (GecodeIIFn f) = GecodeIIFn (\a b -> case f a b of (GecodeWrappedSolver m) -> m)+uIIIFn (GecodeIIIFn f) = GecodeIIIFn (\a b c -> case f a b c of (GecodeWrappedSolver m) -> m)+uICIFn (GecodeICIFn f) = GecodeICIFn (\a b c -> case f a b c of (GecodeWrappedSolver m) -> m)+wFn (GecodeFn f) = GecodeFn (GecodeWrappedSolver f)+wIBFn (GecodeIBFn f) = GecodeIBFn (\a b -> GecodeWrappedSolver $ f a b)+wCBFn (GecodeCBFn f) = GecodeCBFn (\a b -> GecodeWrappedSolver $ f a b)+wCIFn (GecodeCIFn f) = GecodeCIFn (\a b -> GecodeWrappedSolver $ f a b)+wIIFn (GecodeIIFn f) = GecodeIIFn (\a b -> GecodeWrappedSolver $ f a b)+wIIIFn (GecodeIIIFn f) = GecodeIIIFn (\a b c -> GecodeWrappedSolver $ f a b c)+wICIFn (GecodeICIFn f) = GecodeICIFn (\a b c -> GecodeWrappedSolver $ f a b c)++instance Show (GecodeIntConst -> GecodeIntConst) where+ show _ = "GecodeIntConst -> GecodeIntConst"+instance Show (GecodeIBFn s) where+ show _ = "GecodeIBFn"+instance Show (GecodeCBFn s) where+ show _ = "GecodeCBFn"+instance Show (GecodeCIFn s) where+ show _ = "GecodeCIFn"+instance Show (GecodeIIFn s) where+ show _ = "GecodeIIFn"+instance Show (GecodeIIIFn s) where+ show _ = "GecodeIIIFn"+instance Show (GecodeICIFn s) where+ show _ = "GecodeICIFn"+instance GecodeSolver s => Show (GecodeFn s) where+ show _ = "GecodeFn"++extractFull :: (a -> Maybe b) -> [a] -> Maybe [b]+extractFull _ [] = Just []+extractFull f (a:b) = case f a of+ Nothing -> Nothing+ Just r -> case extractFull f b of+ Nothing -> Nothing+ Just rr -> Just (r:rr)++-- deriving instance (Eq (GecodeIntVar s), Eq (GecodeBoolVar s), Eq (GecodeColVar s), Ord (GecodeIntVar s), Ord (GecodeBoolVar s), Ord (GecodeColVar s)) => Eq (GecodeConstraint s)+-- deriving instance (Eq (GecodeIntVar s), Eq (GecodeBoolVar s), Eq (GecodeColVar s), Ord (GecodeIntVar s), Ord (GecodeBoolVar s), Ord (GecodeColVar s)) => Ord (GecodeConstraint s)+deriving instance (GecodeSolver s, Eq (GecodeIntVar s), Eq (GecodeBoolVar s), Eq (GecodeColVar s), Ord (GecodeIntVar s), Ord (GecodeBoolVar s), Ord (GecodeColVar s), Show (GecodeIntVar s), Show (GecodeBoolVar s), Show (GecodeColVar s)) => Show (GecodeConstraint s)++intSpecToLinear (GITConst c) = constToLinear c+intSpecToLinear (GITVar v) = termToLinear v+intSpecToLinear (GITLinear l) = l++retLinear l = case linearToConst l of+ Just x -> return $ Just (900,return $ GITConst x)+ Nothing -> case linearToTerm l of+ Just x -> return $ Just (800,return $ GITVar x)+ Nothing -> return $ Just (700,return $ GITLinear l)++class (Solver s, Term s (GecodeIntVar s), Term s (GecodeBoolVar s),+ Eq (GecodeIntVar s), Eq (GecodeBoolVar s), Eq (GecodeColVar s),+ Ord (GecodeIntVar s), Ord (GecodeBoolVar s), Ord (GecodeColVar s),+ Show (GecodeIntVar s), Show (GecodeBoolVar s), Show (GecodeColVar s)+ ) => GecodeSolver s where+ type GecodeIntVar s :: *+ type GecodeBoolVar s :: *+ type GecodeColVar s :: *+ newInt_at :: GecodeColVar s -> GecodeIntConst -> s (GecodeIntVar s)+ newInt_cond :: GecodeBoolConst -> GecodeIntVar s -> GecodeIntVar s -> s (GecodeIntVar s)+ newCol_list :: [GecodeIntVar s] -> s (GecodeColVar s)+ newCol_size :: GecodeIntConst -> s (GecodeColVar s)+-- newCol_take :: GecodeColVar s -> GecodeIntConst -> GecodeIntConst -> s (GecodeColVar s)+ newCol_cat :: GecodeColVar s -> GecodeColVar s -> s (GecodeColVar s)+ -- newCol_cmap :: GecodeListConst -> GecodeCIFn s -> s (GecodeColVar s)+ splitIntDomain :: GecodeIntVar s -> s ([GecodeConstraint s],Bool)+ splitBoolDomain :: GecodeBoolVar s -> s ([GecodeConstraint s],Bool)+ col_getSize :: GecodeColVar s -> s GecodeIntConst+ col_regList :: GecodeColConst -> s ()+ col_regList _ = return ()++instance (GecodeSolver s, Constraint s ~ GecodeConstraint s) => GecodeSolver (GecodeWrappedSolver s) where+ type GecodeIntVar (GecodeWrappedSolver s) = GecodeIntVar s+ type GecodeBoolVar (GecodeWrappedSolver s) = GecodeBoolVar s+ type GecodeColVar (GecodeWrappedSolver s) = GecodeColVar s+ newInt_at c i = liftGC $ newInt_at c i+ newInt_cond c t f = liftGC $ newInt_cond c t f+ newCol_list = liftGC . newCol_list+ newCol_size = liftGC . newCol_size+-- newCol_take c p l = liftGC $ newCol_take c p l+ newCol_cat a b = liftGC $ newCol_cat a b+ -- newCol_cmap l f = liftGC $ newCol_cmap l f+ splitIntDomain a = liftGC $ (splitIntDomain a) >>= (\(l,b) -> return (map wrapConstraint l,b))+ splitBoolDomain a = liftGC $ (splitBoolDomain a) >>= (\(l,b) -> return (map wrapConstraint l,b))+ col_getSize = liftGC . col_getSize+ col_regList = liftGC . col_regList++instance (GecodeSolver s, Constraint s ~ GecodeConstraint s, EnumTerm s t) => EnumTerm (GecodeWrappedSolver s) t where+ type TermBaseType (GecodeWrappedSolver s) t = TermBaseType s t+ getDomainSize = liftGC . getDomainSize+ splitDomain a = liftGC $ splitDomain a >>= (\(x,t) -> return (map (map wrapConstraint) x,t))+ splitDomains a = liftGC $ splitDomains a >>= (\(x,t) -> return (map (map wrapConstraint) x, t))+ getValue = liftGC . getValue+ getDomain = liftGC . getDomain+ setValue a b = liftGC $ setValue a b >>= return . map wrapConstraint+ defaultOrder = liftGC . defaultOrder+ enumerator = case enumerator of+ Just x -> Just (mapTree liftGC . x)+ Nothing -> Nothing++forceDecompInt :: (GecodeSolver s, Constraint s ~ GecodeConstraint s) => FDSpecInfoInt (GecodeWrappedSolver s) -> FDInstance (GecodeWrappedSolver s) (GecodeIntVar s)+forceDecompInt info = + case fdspIntSpec info $ Just GISVar of+ Just (GITVar var) -> return var+ Nothing -> case fdspIntVal info of+ Just val -> do+ x <- liftFD $ newvar+ addFD $ GCIntVal x $ transPar val+ return x+ _ -> case fdspIntSpec info Nothing of+ Just (GITVar var) -> return var+ Just (GITConst v) -> do+ x <- liftFD $ newvar+ addFD $ GCIntVal x v+ return x+ Just (GITLinear l) -> do+ x <- liftFD $ newvar+ addFD $ GCLinear (l-(termToLinear x)) GOEqual+ return x+ _ -> error "unable to decompose int?"++getReifSpec info =+ case fdspBoolVal info of+ Just val -> GBTConst $ transParBool val+ _ -> case fdspBoolSpec info (Just GBSConst) of+ Just val -> val+ _ -> case fdspBoolSpec info (Just GBSCondConst) of+ Just val -> val+ _ -> case fdspBoolSpec info (Just GBSVar) of+ Just val -> val+ _ -> error "invalid reified specification"++forceLinearInt :: (GecodeSolver s, Constraint s ~ GecodeConstraint s) => FDSpecInfoInt (GecodeWrappedSolver s) -> FDInstance (GecodeWrappedSolver s) (GecodeLinear s)+forceLinearInt info =+ case fdspIntSpec info Nothing of+ Just x -> return $ intSpecToLinear x+ Nothing -> case fdspIntVal info of+ Just val -> return $ constToLinear $ transPar val+ _ -> error "unable to decompose to linear?"++forceConstInt :: (GecodeSolver s, Constraint s ~ GecodeConstraint s) => FDSpecInfoInt (GecodeWrappedSolver s) -> FDInstance (GecodeWrappedSolver s) (Maybe GecodeIntConst)+forceConstInt info = return $+ case fdspIntVal info of+ Just par -> Just $ transPar par+ Nothing -> case fdspIntSpec info $ Just GISConst of+ Just (GITConst v) -> Just v+ Nothing -> case fdspIntSpec info Nothing of+ Just (GITConst v) -> Just v+ Nothing -> Nothing++forceDecompBool :: (GecodeSolver s, Constraint s ~ GecodeConstraint s) => FDSpecInfoBool (GecodeWrappedSolver s) -> FDInstance (GecodeWrappedSolver s) (GecodeBoolVar s)+forceDecompBool info = + case fdspBoolSpec info $ Just GBSVar of+ Just (GBTVar var) -> return var+ Nothing -> case fdspBoolVal info of+ Just val -> do+ x <- liftFD $ newvar+ addFD $ GCBoolVal x $ transParBool val+ return x+ _ -> case fdspBoolSpec info Nothing of+ Just (GBTVar var) -> return var+ Just (GBTConst v) -> do+ x <- liftFD $ newvar+ addFD $ GCBoolVal x v+ return x+ x -> error $ "unable to decompose bool ("++(show x)++")?"++forceDecompCol :: (GecodeSolver s, Constraint s ~ GecodeConstraint s) => String -> FDSpecInfoCol (GecodeWrappedSolver s) -> FDInstance (GecodeWrappedSolver s) (GecodeColVar s)+forceDecompCol str info = + case fdspColSpec info $ Just GCSVar of+ Just (GCTVar var) -> return var+ Nothing -> case fdspColSpec info Nothing of+ Just (GCTVar var) -> return var+ x -> error $ "unable to decompose col ("++(show x)++"): "++str++"?"++newtype (GecodeSolver s, Constraint s ~ GecodeConstraint s) => GecodeWrappedSolver s a = GecodeWrappedSolver (s a)+newtype (GecodeSolver s, Constraint s ~ GecodeConstraint s) => GecodeWrappedLabel s = GecodeWrappedLabel (Label s)++instance (GecodeSolver s, Constraint s ~ GecodeConstraint s) => Monad (GecodeWrappedSolver s) where+ {-# INLINE (>>=) #-}+ return = GecodeWrappedSolver . return+ (GecodeWrappedSolver m) >>= f = GecodeWrappedSolver (m >>= (\x -> case f x of GecodeWrappedSolver r -> r))++instance (GecodeSolver s, Constraint s ~ GecodeConstraint s) => Solver (GecodeWrappedSolver s) where+ type Constraint (GecodeWrappedSolver s) = GecodeConstraint (GecodeWrappedSolver s)+ type Label (GecodeWrappedSolver s) = GecodeWrappedLabel s+ add x = do+ GecodeWrappedSolver $ procConstraint x+ GecodeWrappedSolver $ add $ unwrapConstraint x+ run (GecodeWrappedSolver w) = run w+ mark = liftGC (mark >>= \x -> return $ GecodeWrappedLabel x)+ markn n = liftGC (markn n >>= \x -> return $ GecodeWrappedLabel x)+ goto (GecodeWrappedLabel l) = liftGC (goto l)++instance (GecodeSolver s, Term s t, Constraint s ~ GecodeConstraint s) => Term (GecodeWrappedSolver s) t where+ newvar = GecodeWrappedSolver newvar+ type Help (GecodeWrappedSolver s) t = ()+ help _ _ = ()++liftGC :: (GecodeSolver s, Constraint s ~ GecodeConstraint s) => s a -> (GecodeWrappedSolver s) a+liftGC = GecodeWrappedSolver++unliftGC :: (GecodeSolver s, Constraint s ~ GecodeConstraint s) => (GecodeWrappedSolver s) a -> s a+unliftGC (GecodeWrappedSolver s) = s++instance (GecodeSolver s, GecodeConstraint s ~ Constraint s) => FDSolver (GecodeWrappedSolver s) where+ type FDIntTerm (GecodeWrappedSolver s) = GecodeIntVar s+ type FDBoolTerm (GecodeWrappedSolver s) = GecodeBoolVar s+ type FDIntSpec (GecodeWrappedSolver s) = GecodeIntSpec s+ type FDBoolSpec (GecodeWrappedSolver s) = GecodeBoolSpec s+ type FDColSpec (GecodeWrappedSolver s) = GecodeColSpec s+ type FDIntSpecType (GecodeWrappedSolver s) = GecodeIntSpecType+ type FDBoolSpecType (GecodeWrappedSolver s) = GecodeBoolSpecType+ type FDColSpecType (GecodeWrappedSolver s) = GecodeColSpecType++ fdIntSpec_const x = (GISConst, return $ GITConst $ transPar x)+ fdBoolSpec_const x = (GBSConst, return $ GBTConst $ transParBool x)+ fdColSpec_const x = (GCSConst, return $ GCTConst $ transParCol x)+ fdIntSpec_term x = (GISVar, return $ GITVar x)+ fdBoolSpec_term x = (GBSVar, return $ GBTVar x)+ fdColSpec_list lst = (GCSVar, do+ let vir = map (\(GITVar v) -> v) lst+ gcv <- newCol_list vir+ return $ GCTVar gcv)+ fdColSpec_size len = (GCSVar, do+ gcv <- newCol_size $ transPar len+ return $ GCTVar gcv)+ fdIntVarSpec (GITVar v) = return $ Just v+ fdIntVarSpec _ = return Nothing+ fdBoolVarSpec (GBTVar v) = return $ Just v+ fdBoolVarSpec _ = return Nothing+ + fdEqualBool (GBTConst a) (GBTConst b) = if a/=b then setFailed else return ()+ fdEqualBool (GBTConst a) (GBTVar b) = addFD $ GCBoolVal b a+ fdEqualBool (GBTVar b) (GBTConst a) = addFD $ GCBoolVal b a+ fdEqualBool (GBTVar a) (GBTVar b) = addFD $ GCBoolEqual a b+ -- TODO: incompatibiliteiten opmerken, en combinatie met var wordt nieuwe constraint op die var+ fdEqualBool (GBTCondConst _ _) _ = return ()+ fdEqualBool _ (GBTCondConst _ _) = return ()+ fdEqualInt (GITConst a) (GITConst b) = if a/=b then setFailed else return ()+ fdEqualInt (GITVar a) (GITConst b) = addFD $ GCIntVal a b+ fdEqualInt (GITConst b) (GITVar a) = addFD $ GCIntVal a b+ fdEqualInt a b = addFD $ GCLinear ((intSpecToLinear a)-(intSpecToLinear b)) GOEqual+ fdEqualCol (GCTVar a) (GCTVar b) = addFD $ GCColEqual a b++ fdTypeReqBool = return typeReqBool+ fdTypeReqInt = return typeReqInt+ fdTypeReqCol = return typeReqCol+ fdTypeVarInt = return $ Set.singleton GISVar+ fdTypeVarBool = return $ Set.singleton GBSVar++ fdSpecify = specify+ fdProcess = process+ fdSplitIntDomain = splitIntDomain+ fdSplitBoolDomain = splitBoolDomain+ fdConstrainIntTerm t v = return $ GCLinear ((termToLinear t)-(constToLinear $ Const v)) GOLess++ fdColInspect (GCTVar c) = do+ s <- col_getSize c+ case s of+ Const ss -> mapM (newInt_at c . toConst) [0..ss-1]+ _ -> error "Inspecting collection of indeterminate size"++-- typeReqBool :: EGEdge -> [(EGVarId,FDBoolSpecTypeSet s)]+-- typeReqBool (EGEdge { egeLinks = EGTypeData { boolData = l }}) = defBoolTypes l+-- typeReqInt _ = []+-- typeReqCol _ = []++linearTypes x = (x,Set.fromList [GISVar,GISConst,GISLinear])+onlyVarType x = (x,Set.singleton GISVar)+onlyConstType x = (x,Set.singleton GISConst)+defTypes x = (x,Set.fromList [GISVar,GISConst])+onlyBoolVarType x = (x,Set.singleton GBSVar)+defBoolTypes x = (x,Set.fromList [GBSVar,GBSConst])+reifBoolTypes x = (x,Set.fromList [GBSVar,GBSConst,GBSCondConst])+allColTypes x = (x,Set.fromList [GCSVar,GCSConst,GCSSection])+allCColTypes x = (x,Set.fromList [GCSVar,GCSConst,GCSSection])+defColTypes x = (x,Set.fromList [GCSVar])+sectionColTypes x = (x,Set.fromList [GCSSection,GCSVar])+constColTypes x = (x,Set.fromList [GCSConst,GCSVar])+constCColTypes x = (x,Set.fromList [GCSConst,GCSVar])+onlyConstColType x = (x,Set.fromList [GCSConst])++typeReqInt (EGEdge { egeCons = EGIntValue _, egeLinks = EGTypeData { intData = l }}) = map linearTypes l+typeReqInt (EGEdge { egeCons = EGPlus, egeLinks = EGTypeData { intData = l }}) = map linearTypes l+typeReqInt (EGEdge { egeCons = EGMinus, egeLinks = EGTypeData { intData = l }}) = map linearTypes l+typeReqInt (EGEdge { egeCons = EGMult, egeLinks = EGTypeData { intData = l }}) = map linearTypes l+typeReqInt (EGEdge { egeCons = EGEqual, egeLinks = EGTypeData { intData = l }}) = map linearTypes l+typeReqInt (EGEdge { egeCons = EGLess _, egeLinks = EGTypeData { intData = l }}) = map linearTypes l+typeReqInt (EGEdge { egeCons = EGDiff, egeLinks = EGTypeData { intData = l }}) = map linearTypes l+-- typeReqInt (EGEdge { egeCons = EGDiv, egeLinks = EGTypeData { intData = l }}) = map onlyVarType l+-- typeReqInt (EGEdge { egeCons = EGMod, egeLinks = EGTypeData { intData = l }}) = map onlyVarType l+-- typeReqInt (EGEdge { egeCons = EGAbs, egeLinks = EGTypeData { intData = l }}) = map onlyVarType l+-- typeReqInt (EGEdge { egeCons = EGChannel, egeLinks = EGTypeData { intData = l }}) = map onlyVarType l+-- typeReqInt (EGEdge { egeCons = EGAllC _ _ _, egeLinks = EGTypeData { intData=a:b:l }}) = (onlyConstType a):(onlyConstType b):(map defTypes l)+typeReqInt (EGEdge { egeLinks = EGTypeData { intData = l }}) = map defTypes l++typeReqBool (EGEdge { egeCons = EGEqual, egeLinks = EGTypeData { boolData = l }}) = map reifBoolTypes l+typeReqBool (EGEdge { egeCons = EGDiff, egeLinks = EGTypeData { boolData = l }}) = map reifBoolTypes l+typeReqBool (EGEdge { egeCons = EGLess _, egeLinks = EGTypeData { boolData = l }}) = map reifBoolTypes l+typeReqBool (EGEdge { egeCons = EGCondEqual, egeLinks = EGTypeData { boolData = [c,a,b] }}) = (reifBoolTypes a):(map defBoolTypes [b,c])+typeReqBool (EGEdge { egeCons = EGAll _ _ _, egeLinks = EGTypeData { boolData = (r:l) }}) = (reifBoolTypes r):(map defBoolTypes l)+typeReqBool (EGEdge { egeCons = EGAny _ _ _, egeLinks = EGTypeData { boolData = (r:l) }}) = (reifBoolTypes r):(map defBoolTypes l)+typeReqBool (EGEdge { egeLinks = EGTypeData { boolData = l }}) = map defBoolTypes l++typeReqCol (EGEdge { egeCons = EGSize, egeLinks = EGTypeData { colData=[c] }}) = [allColTypes c]+typeReqCol (EGEdge { egeCons = EGRange, egeLinks = EGTypeData { colData=[c] }}) = [constCColTypes c]+typeReqCol (EGEdge { egeCons = EGAt, egeLinks = EGTypeData { colData=[c] }}) = [allCColTypes c]+typeReqCol (EGEdge { egeCons = EGCat, egeLinks = EGTypeData { colData=[r,a,b] }}) = [allCColTypes r, allCColTypes a, allCColTypes b]+typeReqCol (EGEdge { egeCons = EGSlice _ _, egeLinks = EGTypeData { colData=[r,c] }}) = [allCColTypes r, allCColTypes c]+typeReqCol (EGEdge { egeCons = EGAllDiff _, egeLinks = EGTypeData { colData=[c] }}) = [sectionColTypes c]+typeReqCol (EGEdge { egeCons = EGSorted _, egeLinks = EGTypeData { colData=[c] }}) = [sectionColTypes c]+typeReqCol (EGEdge { egeLinks = EGTypeData { colData = l }}) = map allColTypes l++fromAll :: [Maybe a] -> Maybe [a]+fromAll [] = Just []+fromAll (Nothing:_) = Nothing+fromAll ((Just x):r) = case fromAll r of+ Nothing -> Nothing+ Just l -> Just $ x:l++fromAllConst :: (GecodeSolver s) => [GecodeIntSpec s] -> Maybe [GecodeIntConst]+fromAllConst [] = Just []+fromAllConst ((GITConst a):r) = case fromAllConst r of+ Nothing -> Nothing+ Just l -> Just $ a:l+fromAllConst _ = Nothing++-- doIntSpec :: (GecodeSolver s, Constraint s ~ GecodeConstraint s, GecodeIntSpec s ~ FDIntSpec s) => FDSpecInfoInt (GecodeWrappedSolver s) -> [FDIntSpecType (GecodeWrappedSolver s)] -> FDInstance (GecodeWrappedSolver s) (Maybe (FDIntSpec s))+doIntSpec _ [] = return Nothing+doIntSpec x (a:b) = do+ case fdspIntSpec x (Just a) of+ Nothing -> doIntSpec x b+ Just (r) -> return $ Just r++-- doBoolSpec :: (GecodeSolver s, Constraint s ~ GecodeConstraint s, GecodeBoolSpec s ~ FDBoolSpec s) => FDSpecInfoBool (GecodeWrappedSolver s) -> [FDBoolSpecType (GecodeWrappedSolver s)] -> FDInstance (GecodeWrappedSolver s) (Maybe (FDBoolSpec s))+doBoolSpec _ [] = return Nothing+doBoolSpec x (a:b) = do+ case fdspBoolSpec x (Just a) of+ Nothing -> doBoolSpec x b+ Just (r) -> return $ Just r++-- doColSpec :: (GecodeSolver s, Constraint s ~ GecodeConstraint s, GecodeColSpec s ~ FDColSpec s) => FDSpecInfoCol (GecodeWrappedSolver s) -> [FDColSpecType (GecodeWrappedSolver s)] -> FDInstance (GecodeWrappedSolver s) (Maybe (FDColSpec s))+doColSpec _ [] = return Nothing+doColSpec x (a:b) = do+ case (fdspColSpec x) (Just a) of+ Nothing -> doColSpec x b+ Just (r) -> return $ Just r++getVarOrSection c = do+ r <- doColSpec c [GCSVar,GCSSection]+ case r of+ Nothing -> return Nothing+ Just (GCTVar v) -> return $ Just $ Left v+ Just (GCTSection x) -> return $ Just $ Right x+ _ -> return Nothing++linearSpec :: (GecodeSolver s, Constraint s ~ GecodeConstraint s) => ([GecodeLinear (GecodeWrappedSolver s)] -> Maybe (GecodeLinear (GecodeWrappedSolver s))) -> [EGVarId] -> FDInstance (GecodeWrappedSolver s) (Maybe (GecodeLinear (GecodeWrappedSolver s)))+linearSpec f l = do+ lst <- mapM getIntSpec l+ debug ("linearSpec: lst="++(show lst)) $ return ()+ case fromAll lst of+ Nothing -> return Nothing+ Just rl -> return $ f $ map intSpecToLinear rl++constSpec :: (GecodeSolver s, Constraint s ~ GecodeConstraint s) => ([GecodeIntConst] -> Maybe GecodeIntConst) -> [EGVarId] -> FDInstance (GecodeWrappedSolver s) (Maybe GecodeIntConst)+constSpec f l = do+ lst <- mapM specConst l+ case fromAll lst of+ Nothing -> return Nothing+ Just spec -> return $ f spec++constMaybeSpec :: (GecodeSolver s, Constraint s ~ GecodeConstraint s) => ([GecodeIntConst] -> Maybe GecodeIntConst) -> [EGVarId] -> EGVarId -> SpecFnRes (GecodeWrappedSolver s)+constMaybeSpec f l r =+ let m = constSpec f l+ in ([],[(900,r,True,do + x <- m+ return $ case x of+ Nothing -> SpecResNone+ Just k -> SpecResSpec (GISConst,return $ (GITConst k,Just $ transIPar k))+ )],[])++constFullSpec :: (GecodeSolver s, Constraint s ~ GecodeConstraint s) => ([GecodeIntConst] -> GecodeIntConst) -> [EGVarId] -> EGVarId -> SpecFnRes (GecodeWrappedSolver s)+constFullSpec f l r = constMaybeSpec (\i -> Just $ f i) l r++linearMaybeSpec :: (GecodeSolver s, Constraint s ~ GecodeConstraint s) => ([GecodeLinear (GecodeWrappedSolver s)] -> Maybe (GecodeLinear (GecodeWrappedSolver s))) -> [EGVarId] -> EGVarId -> SpecFnRes (GecodeWrappedSolver s)+linearMaybeSpec f l r = + let m = linearSpec f l+ in ([],+ [+ (1000,r,True,do + x <- m+ return $ case x of+ Nothing -> SpecResNone+ Just k -> case linearToConst k of+ Nothing -> SpecResNone+ Just c -> SpecResSpec (GISConst,return $ (GITConst c,Just $ transIPar c))+ ),+ (800,r,True,do + x <- m+ return $ case x of+ Nothing -> SpecResNone+ Just k -> case linearToTerm k of+ Nothing -> SpecResNone+ Just c -> SpecResSpec (GISVar,return $ (GITVar c, Nothing))+ ),+ (700,r,True,do + x <- m+ return $ case x of+ Nothing -> SpecResNone+ Just k -> SpecResSpec (GISLinear, return $ (GITLinear k, Nothing))+ )+ ],+ [])++linearFullSpec :: (GecodeSolver s, Constraint s ~ GecodeConstraint s) => ([GecodeLinear (GecodeWrappedSolver s)] -> (GecodeLinear (GecodeWrappedSolver s))) -> [EGVarId] -> EGVarId -> SpecFnRes (GecodeWrappedSolver s)+linearFullSpec f l r = linearMaybeSpec (\i -> Just $ f i) l r++specConst l = do+ r <- getIntSpec_ l $ Set.singleton GISConst+ case r of+ Just (_,GITConst x) -> return $ Just x+ _ -> do+ rr <- getIntVal l+ return $ case rr of+ Nothing -> Nothing+ Just x -> Just $ transPar x++specBoolConst l = do+ r <- getBoolVal l+ case r of+ Just x -> return $ Just $ transParBool x+ _ -> do+ rr <- getBoolSpec_ l $ Set.singleton GBSConst+ return $ case rr of+ Just (_,GBTConst x) -> Just x+ Nothing -> Nothing+ _ -> error $ "Weird result in specBoolConst: " ++ (show rr)++specColConst l = do+ r <- getColVal l+ case r of+ Just x -> return $ Just $ transParCol x+ _ -> do+ rr <- getColSpec_ l $ Set.singleton GCSConst+ return $ case rr of+ Just (_,GCTConst x) -> Just x+ Nothing -> Nothing+ _ -> error $ "Weird result in specColConst: " ++ (show rr)++specMap :: (GecodeSolver s, GecodeConstraint s ~ Constraint s) => EGModel -> ([FDSpecInfoBool (GecodeWrappedSolver s)],[FDSpecInfoInt (GecodeWrappedSolver s)],[FDSpecInfoCol (GecodeWrappedSolver s)]) -> FDInstance (GecodeWrappedSolver s) (Maybe (GecodeIntConst -> GecodeIntConst))+specMap model (lb,li,lc) = do+ let mf cv = + do+ let cc = transIPar cv+ ev2 = myFromJust "specMap1" $ Map.lookup (-2) $ intData $ externMap model+ ev1 = myFromJust "specMap2" $ Map.lookup (-1) $ intData $ externMap model+ sm2 = addEdge (EGIntValue cc) (EGTypeData { boolData=[], intData=[ev2], colData=[] }) model+ fb n = Just $ idx lb n+ fi (-1) = Nothing+ fi (-2) = Nothing+ fi n = Just $ idx li n+ fc n = Just $ idx lc n+ (rb,ri,rc) <- specSubModelEx sm2 (fb,fi,fc)+ return $ case Map.lookup ev1 ri of+ Nothing -> Nothing+ Just x -> case fdspIntVal x of+ Nothing -> Nothing+ Just v -> Just v+ level <- getLevel+ let gt = GIParam (-(1000+level))+ rm <- mf (Term gt)+ case rm of+ Nothing -> return Nothing+ Just rr -> do+ let tf :: GecodeIntConst -> GecodeIntConst+ tf rs =+ let mmi g | g==gt = rs+ mmi x = Term x+ in transformEx (mmi,ColTerm,BoolTerm,Term,ColTerm,BoolTerm) $ transPar rr+ return $ Just tf++specify :: (GecodeSolver s, GecodeConstraint s ~ Constraint s) => Mixin (SpecFn (GecodeWrappedSolver s))+specify sup t edge = case edge of+ EGEdge { egeCons = EGPlus, egeLinks = EGTypeData { intData=[r,a,b] } } -> linearFullSpec (\[x,y] -> x+y) [a,b] r+ EGEdge { egeCons = EGMinus, egeLinks = EGTypeData { intData=[r,a,b] } } -> linearFullSpec (\[x,y] -> x-y) [a,b] r+ EGEdge { egeCons = EGDiv, egeLinks = EGTypeData { intData=[r,a,b] } } -> constFullSpec (\[x,y] -> x `div` y) [a,b] r+ EGEdge { egeCons = EGMod, egeLinks = EGTypeData { intData=[r,a,b] } } -> constFullSpec (\[x,y] -> x `mod` y) [a,b] r+ EGEdge { egeCons = EGMult, egeLinks = EGTypeData { intData=[r,a,b] } } -> linearMaybeSpec (\[x,y] -> linearMultiply x y) [a,b] r+ EGEdge { egeCons = EGSize, egeLinks = EGTypeData { intData=[s], colData=[c] } } ->+ ([],[(900,s,True,do+ cc <- getColSpec c+ case cc of+ (Just (GCTConst c)) -> return $ SpecResSpec (GISConst, return $ (GITConst $ size c, Just $ transIPar $ size c))+ (Just (GCTSection (_,(lll,_)))) -> return $ SpecResSpec (GISConst, return $ (GITConst lll, Just $ transIPar lll))+ (Just (GCTVar v)) -> return $ SpecResSpec (GISConst, col_getSize v >>= (\x -> return $ (GITConst x, Just $ transIPar x)))+ _ -> return SpecResNone+ )],(\(_,_,x) -> x) (sup edge))+ EGEdge { egeCons = EGMap sm (nb,ni,nc), egeLinks = EGTypeData { intData=il, boolData=bl, colData=(r:c:cl) } } -> + ([],[],[(250,r,False,do+ cc <- getColSpec c+ case cc of+ (Just (GCTSection (_,(lll,_)))) -> return $ SpecResSpec (GCSVar, newCol_size lll >>= (\x -> return (GCTVar x, Nothing)))+ (Just (GCTVar v)) -> return $ SpecResSpec (GCSVar, col_getSize v >>= newCol_size >>= (\x -> return (GCTVar x, Nothing)))+ _ -> return SpecResNone+ ),(925,c,True,do+ cc <- getColSpec c+ blm <- mapM (\x -> (getBoolSpec_ x (Set.singleton GBSConst) >> getFullBoolSpec x)) bl+ ilm <- mapM (\x -> (getIntSpec_ x (Set.singleton GISConst) >> getFullIntSpec x)) il+ clm <- mapM (\x -> (getColSpec_ x (Set.singleton GCSConst) >> getFullColSpec x)) cl+ ff <- specMap sm (blm,ilm,clm)+ case (cc,ff) of+ (Just (GCTConst c), Just fff) -> return $ SpecResSpec (GCSConst, return (GCTConst $ xmap fff c, Just $ transIParCol $ xmap fff c))+ _ -> return SpecResNone+ ),(225,c,False,do+ cc <- getColSpec r+ case cc of+ (Just (GCTConst c)) -> return $ SpecResSpec (GCSVar, newCol_size (size c) >>= (\x -> return (GCTVar x, Nothing)))+ (Just (GCTSection (_,(lll,_)))) -> return $ SpecResSpec (GCSVar, newCol_size lll >>= (\x -> return (GCTVar x, Nothing)))+ (Just (GCTVar v)) -> return $ SpecResSpec (GCSVar, col_getSize v >>= newCol_size >>= (\x -> return (GCTVar x, Nothing)))+ _ -> return SpecResNone+ )])+ EGEdge { egeCons = EGRange, egeLinks = EGTypeData { intData=[l,h], colData=[r] } } -> + ([],[],[(560,r,True,do+ -- ll <- getIntVal l+ -- hh <- getIntVal h+ ll <- specConst l+ hh <- specConst h+ case (ll,hh) of+ (Just (Const lll), Just (Const hhh)) -> return $ SpecResSpec (GCSConst, return $ (GCTConst (ColList [Const x | x <- [lll..hhh]]), Just $ ColList [Const x | x <- [lll..hhh]]))+ _ -> return SpecResNone+ ),(550,r,True,do+ -- ll <- getIntVal l+ -- hh <- getIntVal h+ ll <- specConst l+ hh <- specConst h+ case (ll,hh) of+ (Just lll, Just hhh) -> return $ SpecResSpec (GCSConst, return $ (GCTConst (lll @.. hhh), Just $ transIParCol (lll @.. hhh)))+ _ -> return SpecResNone+ )])+ EGEdge { egeCons = EGCondInt, egeLinks = EGTypeData { boolData=[c], intData=[r,t,f] } } ->+ ([],[(999,r,True,do+ cc <- specBoolConst c+ tt <- specConst t+ ff <- specConst f+ case (cc,tt,ff) of+ (Just ccc,Just ttt,Just fff) -> return $ SpecResSpec (GISConst, return $ (GITConst $ simplify $ Cond ccc ttt fff, Just $ transIPar $ simplify $ Cond ccc ttt fff))+ _ -> return SpecResNone+ ),(990,r,True,do+ cc <- specBoolConst c+ tt <- getIntSpec_ t (Set.singleton GISVar)+ ff <- getIntSpec_ f (Set.singleton GISVar)+ case (cc,tt,ff) of+ (Just ccc,Just (_,GITVar ttt),Just (_,GITVar fff)) -> return $ SpecResSpec (GISVar, newInt_cond ccc ttt fff >>= (\x -> return (GITVar x, Nothing)))+-- (ccc,ttt,fff) -> error $ "Unable to use newInt_cond: ccc="++(show ccc)++" ttt="++(show ttt)++" fff="++(show fff)++""+ _ -> return SpecResNone+ )],[])+ EGEdge { egeCons = EGAt, egeLinks = EGTypeData { intData=[r,p], colData=[c] }} ->+ ([],[(600,r,True,do+ pp <- specConst p+ cc <- getColSpec c+ case (pp,cc) of+ (Just ppp, Just (GCTVar ccc)) -> debug ("EGAt spec: newInt_at gctvar c="++(show ccc)++" p="++(show ppp)++" r="++(show r)) $ return $ SpecResSpec (GISVar, newInt_at ccc ppp >>= (\x -> return (GITVar x,Nothing)))+ _ -> return SpecResNone+ ),(850,r,True,do+ pp <- specConst p+ cc <- getColSpec c+ case (pp,cc) of+ (Just ppp, Just (GCTSection (ccc,(lll,fff)))) -> debug ("EGAt spec: newInt_at gctsection c="++(show ccc)++" p="++(show ppp)) $ return $ SpecResSpec (GISVar, newInt_at ccc (fff $ ppp) >>= (\x -> return (GITVar x, Nothing)))+ _ -> return SpecResNone+ ),(900,r,True,do+ cc <- specColConst c+ pp <- specConst p+ case (pp,cc) of+ (Just ppp, Just c) -> return $ SpecResSpec (GISConst, return $ (GITConst $ (c!ppp),Just $ transIPar (c!ppp)))+ _ -> return SpecResNone+ )],[])+ EGEdge { egeCons = EGSlice sm (nb,ni,nc), egeLinks = EGTypeData { intData=(n:il), boolData=bl, colData=(r:c:cl) } } -> ([],[],+ [(500,r,True,do+ blm <- mapM (\x -> (getBoolSpec_ x (Set.singleton GBSConst) >> getFullBoolSpec x)) bl+ ilm <- mapM (\x -> (getIntSpec_ x (Set.singleton GISConst) >> getFullIntSpec x)) il+ clm <- mapM (\x -> (getColSpec_ x (Set.singleton GCSConst) >> getFullColSpec x)) cl+ fff <- specMap sm (blm,ilm,clm)+ cc <- getColSpec c+ nn <- specConst n+ case (cc,nn,fff) of+ (Just (GCTVar ccc),Just nnn,Just ff) -> return $ SpecResSpec (GCSSection, return (GCTSection (ccc,(nnn,ff)),Nothing))+ _ -> debug ("not absorbing egslice/gctvar: cc="++(show cc)++" nn="++(show nn)++" fff="++(show $ isJust $ fff)) $ return SpecResNone+ ),(550,r,True,do+ blm <- mapM (\x -> (getBoolSpec_ x (Set.singleton GBSConst) >> getFullBoolSpec x)) bl+ ilm <- mapM (\x -> (getIntSpec_ x (Set.singleton GISConst) >> getFullIntSpec x)) il+ clm <- mapM (\x -> (getColSpec_ x (Set.singleton GCSConst) >> getFullColSpec x)) cl+ ff <- specMap sm (blm,ilm,clm)+ cc <- getColSpec c+ nn <- specConst n+ case (cc,nn,ff) of+ (Just (GCTSection (ccc,(_,fff))),Just nnn,Just rf) -> return $ SpecResSpec (GCSSection, return (GCTSection (ccc,(nnn,fff . rf)),Nothing))+ _ -> debug ("not absorbing egslice/gctsection: cc="++(show cc)++" nn="++(show nn)++" ff="++(show $ isJust $ ff)) $ return SpecResNone+ ),(575,r,True,do+ blm <- mapM (\x -> (getBoolSpec_ x (Set.singleton GBSConst) >> getFullBoolSpec x)) bl+ ilm <- mapM (\x -> (getIntSpec_ x (Set.singleton GISConst) >> getFullIntSpec x)) il+ clm <- mapM (\x -> (getColSpec_ x (Set.singleton GCSConst) >> getFullColSpec x)) cl+ ff <- specMap sm (blm,ilm,clm)+ cc <- specColConst c+ nn <- specConst n+ case (cc,nn,ff) of+ (Just ll,Just nnn,Just rf) -> return $ SpecResSpec (GCSConst, return (GCTConst $ slice ll (xmap rf ((Const 0) @.. (nnn-1))), Just $ transIParCol $ slice ll (xmap rf ((Const 0) @.. (nnn-1)))))+ _ -> debug ("not absorbing egslice/const: cc="++(show cc)++" nn="++(show nn)++" ff="++(show $ isJust $ ff)) $ return SpecResNone+ ),(580,r,True,do+ blm <- mapM (\x -> (getBoolSpec_ x (Set.singleton GBSConst) >> getFullBoolSpec x)) bl+ ilm <- mapM (\x -> (getIntSpec_ x (Set.singleton GISConst) >> getFullIntSpec x)) il+ clm <- mapM (\x -> (getColSpec_ x (Set.singleton GCSConst) >> getFullColSpec x)) cl+ fff <- specMap sm (blm,ilm,clm)+ cc <- specColConst c+ nn <- specConst n+ case (cc,nn,fff) of+ (Just l,Just (Const p),Just ff) -> do+ let nl = map (ff . Const) [0..p-1]+ case (extractFull (\x -> case x of { Const i -> Just $ fromInteger i; _ -> Nothing }) nl) of+ Just ll -> return $ SpecResSpec (GCSConst, return (GCTConst $ ColList [l ! Const i | i <- ll], Just $ transIParCol $ ColList [l ! Const i | i <- ll]))+ _ -> return SpecResNone+ _ -> debug ("not absorbing egslice/list: cc="++(show cc)++" nn="++(show nn)++" fff="++(show $ isJust $ fff)) $ return SpecResNone+ )])+ EGEdge { egeCons = EGCat, egeLinks = EGTypeData { colData=[r,a,b] }} -> ([],[],+ [(500,r,True,do+ aa <- getColSpec a+ bb <- getColSpec b+ case (aa,bb) of+ (Just (GCTVar aaa),Just (GCTVar bbb)) -> return $ SpecResSpec (GCSVar, newCol_cat aaa bbb >>= (\x -> return (GCTVar x, Nothing)))+ _ -> return SpecResNone+ ),(550,r,True,do+ aa <- getColSpec a+ bb <- getColSpec b+ case (aa,bb) of+ (Just (GCTConst a),Just (GCTConst b)) -> return $ SpecResSpec (GCSConst, return (GCTConst (a @++ b),Just $ transIParCol $ a @++ b))+ _ -> return SpecResNone+ )])+ EGEdge { egeCons = EGCondEqual, egeLinks = EGTypeData { boolData=[c,r,v] }} -> (+ [(999,r,True,do+ dc <- specBoolConst c+ dv <- specBoolConst v+ case (dc,dv) of+ (Just cc,Just vv) -> return $ SpecResSpec (GBSCondConst, return (GBTCondConst cc vv, Nothing))+-- _ -> do+-- cc <- getBoolSpec c+-- vv <- getBoolSpec v+-- error $ "Unable to use conditional equality (c="++(show cc)++", v="++(show vv)++")"+ _ -> return SpecResNone+ )],[],[])+ EGEdge { egeCons = EGChannel, egeLinks = EGTypeData { intData=[i], boolData=[b] }} -> (+ [],[(1000,i,True,do+ db <- specBoolConst b+ case (db) of+ (Just bb) -> return $ SpecResSpec (GISConst, return (GITConst $ channel bb, Just $ transIPar $ channel bb))+ _ -> return SpecResNone+ )],[])+ EGEdge { egeCons = EGEquiv, egeLinks = EGTypeData { boolData=[r,a,b] }} -> (+ [(1000,r,True,do+ da <- specBoolConst a+ db <- specBoolConst b+ case (da,db) of+ (Just aa,Just bb) -> return $ SpecResSpec (GBSConst, return (GBTConst $ boolSimplify $ BoolEqual aa bb, Just $ transIParBool $ boolSimplify $ BoolEqual aa bb))+ _ -> return SpecResNone+ ),(2000,a,True,do+ dr <- specBoolConst r+ case dr of+ (Just (BoolConst True)) -> return $ debug ("bool unification: "++(show a)++","++(show b)) $ SpecResUnify b+ _ -> return $ debug ("no bool unification: "++(show a)++","++(show b)) $ SpecResNone+ ),(2000,b,True,do+ dr <- specBoolConst r+ case dr of+ (Just (BoolConst True)) -> return $ debug ("bool unification: "++(show a)++","++(show b)) $ SpecResUnify a+ _ -> return $ debug ("no bool unification: "++(show a)++","++(show b)) $ SpecResNone+ )],[],[])+ EGEdge { egeCons = EGEqual, egeLinks = EGTypeData { boolData=[r], intData=[a,b] }} -> (+ [(1000,r,True,do+ da <- specConst a+ db <- specConst b+ case (da,db) of+ (Just aa,Just bb) -> return $ SpecResSpec (GBSConst, return (GBTConst $ boolSimplify $ Rel aa EREqual bb, Just $ transIParBool $ boolSimplify $ Rel aa EREqual bb))+ _ -> return SpecResNone+ )],[(2000,a,True,do+ dr <- specBoolConst r+ case dr of+ (Just (BoolConst True)) -> return $ debug ("int unification: "++(show a)++","++(show b)) $ SpecResUnify b+ _ -> return $ debug ("no int unification: "++(show a)++","++(show b)++" r="++(show dr)) $ SpecResNone+ ),(2000,b,True,do+ dr <- specBoolConst r+ case dr of+ (Just (BoolConst True)) -> return $ debug ("int unification: "++(show a)++","++(show b)) $ SpecResUnify a+ _ -> return $ debug ("no int unification: "++(show a)++","++(show b)++" r="++(show dr)) $ SpecResNone+ )],[])+ EGEdge { egeCons = EGDiff, egeLinks = EGTypeData { boolData=[r], intData=[a,b] }} -> (+ [(1000,r,True,do+ da <- specConst a+ db <- specConst b+ case (da,db) of+ (Just aa,Just bb) -> return $ SpecResSpec (GBSConst, return (GBTConst $ boolSimplify $ Rel aa ERDiff bb, Just $ transIParBool $ boolSimplify $ Rel aa ERDiff bb))+ _ -> return SpecResNone+ )],[],[])+ EGEdge { egeCons = EGAnd, egeLinks = EGTypeData { boolData=[r,a,b] }} -> (+ [(1000,r,True,do+ da <- specBoolConst a+ db <- specBoolConst b+ case (da,db) of+ (Just aa,Just bb) -> return $ SpecResSpec (GBSConst, return (GBTConst $ boolSimplify $ BoolAnd aa bb, Just $ transIParBool $ boolSimplify $ BoolAnd aa bb))+ _ -> return SpecResNone+ )],[],[])+ EGEdge { egeCons = EGOr, egeLinks = EGTypeData { boolData=[r,a,b] }} -> (+ [(1000,r,True,do+ da <- specBoolConst a+ db <- specBoolConst b+ case (da,db) of+ (Just aa,Just bb) -> return $ SpecResSpec (GBSConst, return (GBTConst $ boolSimplify $ BoolOr aa bb, Just $ transIParBool $ boolSimplify $ BoolOr aa bb))+ _ -> return SpecResNone+ )],[],[])+ EGEdge { egeCons = EGLess strict, egeLinks = EGTypeData { boolData=[r], intData=[a,b] }} -> (+ [(1000,r,True,do+ da <- specConst a+ db <- specConst b+ case (da,db) of+ (Just aa,Just bb) -> return $ SpecResSpec (GBSConst, return (GBTConst $ (if strict then (@<) else (@<=)) aa bb, Just $ transIParBool $ (if strict then (@<) else (@<=)) aa bb))+ _ -> return SpecResNone+ )],[],[])+ EGEdge { egeCons = EGNot, egeLinks = EGTypeData { boolData=[r,a] }} -> (+ [(1000,r,True,do+ da <- specBoolConst a+ case (da) of+ (Just aa) -> return $ SpecResSpec (GBSConst, return (GBTConst $ boolSimplify $ BoolNot aa, Just $ transIParBool $ boolSimplify $ BoolNot aa))+ _ -> return SpecResNone+ )],[],[])+ _ -> sup edge++removeFrom [] fn = Nothing+removeFrom (a:b) fn = case fn a of+ True -> Just b+ False -> case removeFrom b fn of+ Nothing -> Nothing+ Just r -> Just (a:r)++reduceCountFold :: (GecodeSolver s, GecodeConstraint s ~ Constraint s) => (EGConstraintSpec -> FDSpecInfo (GecodeWrappedSolver s) -> FDInstance (GecodeWrappedSolver s) ()) -> (EGConstraintSpec,FDSpecInfo (GecodeWrappedSolver s)) -> FDInstance (GecodeWrappedSolver s) Bool+reduceCountFold t (EGFold model (nb,ni,nc),(vb,res:init:vi,col:vc)) = do+ let mp = externMap model+ vold = myFromJust "reduceCountFold1" $ Map.lookup (-2) $ intData mp+ vnew = myFromJust "reduceCountFold2" $ Map.lookup (-1) $ intData mp+ varg = myFromJust "reduceCountFold3" $ Map.lookup (-3) $ intData mp+ case + (do+ (plusid,plusedge) <- findEdge model EGIntType vnew (==0) (==EGPlus)+ let plusargs = map ((intData $ egeLinks plusedge)!!) [1,2]+ [channelres] <- debug ("reduceCountFold: plusid="++(show plusid)) $ removeFrom plusargs (==vold)+ (channelid,channeledge) <- debug ("reduceCountFold: channelres="++(show channelres)++" externMap="++(show $ mp)) $ findEdge model EGIntType channelres (==0) (==EGChannel)+ (equalid,equaledge) <- debug ("reduceCountFold: channelid="++(show channelid)) $ findEdge model EGBoolType (head $ boolData $ egeLinks channeledge) (==0) (==EGEqual)+ let equalargs = map ((intData $ egeLinks equaledge)!!) [0,1]+ [valnode] <- debug ("reduceCountFold: equalargs="++(show equalargs)) $ removeFrom equalargs (==varg)+ case findEdge model EGIntType valnode (==0) (\x -> case x of { EGIntValue _ -> True; _ -> False }) of+ Just (valid,valedge) -> return ([plusid,channelid,equalid,valid],case (egeCons valedge) of { EGIntValue val -> Right val })+ _ -> case findEdge model EGIntType valnode (==0) (\x -> case x of { EGIntExtern _ -> True; _ -> False}) of+ Just (extid,extedge) -> do+ return ([plusid,channelid,equalid,extid],case (egeCons extedge) of { EGIntExtern ext -> Left $ ext })+ _ -> fail ""+ ) of+ Nothing -> return False+ Just (edges,val) -> do+ dcs <- doColSpec col [GCSVar]+ case dcs of+ Just (GCTVar dcol) -> do+ dval <- case val of+ Right x -> return $ Right $ transPar x+ Left x -> return $ getIntVarOrConst (vi!!x)+ case (fdspIntVal res,fdspIntVal init) of+ (Just rrr, Just iii) -> do+ addFD $ GCCount dcol dval GOEqual (Right $ transPar $ rrr-iii)+ return True+ _ -> do+ dsum <- liftFD $ newvar+ sum <- liftFD $ specInfoIntTerm dsum+ t EGPlus ([],[res,init,sum],[])+ addFD $ GCCount dcol dval GOEqual (Left dsum)+ return True+ _ -> return False+reduceCountFold _ _ = return False++reduceMultCountFold :: (GecodeSolver s, GecodeConstraint s ~ Constraint s) => (EGConstraintSpec -> FDSpecInfo (GecodeWrappedSolver s) -> FDInstance (GecodeWrappedSolver s) ()) -> (EGConstraintSpec,FDSpecInfo (GecodeWrappedSolver s)) -> FDInstance (GecodeWrappedSolver s) Bool+reduceMultCountFold t (EGFold model (nb,ni,nc),(vb,res:init:vi,col:vc)) = do+ let mp = externMap model+ vold = myFromJust "reduceMultCountFold1" $ Map.lookup (-2) $ intData mp+ vnew = myFromJust "reduceMultCountFold2" $ Map.lookup (-1) $ intData mp+ varg = myFromJust "reduceMultCountFold3" $ Map.lookup (-3) $ intData mp+ case + (do+ (plusid,plusedge) <- findEdge model EGIntType vnew (==0) (==EGPlus)+ let plusargs = map ((intData $ egeLinks plusedge)!!) [1,2]+ [channelres] <- debug ("reduceMultCountFold: plusid="++(show plusid)) $ removeFrom plusargs (==vold)+ (channelid,channeledge) <- debug ("reduceMultCountFold: channelres="++(show channelres)++" externMap="++(show $ mp)) $ findEdge model EGIntType channelres (==0) (==EGChannel)+ (equalid,equaledge) <- debug ("reduceMultCountFold: channelid="++(show channelid)) $ findEdge model EGBoolType (head $ boolData $ egeLinks channeledge) (==0) (==EGEqual)+ let equalargs = map ((intData $ egeLinks equaledge)!!) [0,1]+ [valnode] <- debug ("reduceMultCountFold: equalargs="++(show equalargs)) $ removeFrom equalargs (==varg)+ case findEdge model EGIntType valnode (==0) (\x -> case x of { EGIntValue _ -> True; _ -> False }) of+ Just (valid,valedge) -> return ([plusid,channelid,equalid,valid],case (egeCons valedge) of { EGIntValue val -> Right val })+ _ -> case findEdge model EGIntType valnode (==0) (\x -> case x of { EGIntExtern _ -> True; _ -> False}) of+ Just (extid,extedge) -> do+ return ([plusid,channelid,equalid,extid],case (egeCons extedge) of { EGIntExtern ext -> Left $ ext })+ _ -> fail ""+ ) of+ Nothing -> return False+ Just (edges,val) -> do+ dcs <- doColSpec col [GCSVar]+ case dcs of+ Just (GCTVar dcol) -> do+ dval <- case val of+ Right x -> return $ Right $ transPar x+ Left x -> return $ getIntVarOrConst (vi!!x)+ case (fdspIntVal res,fdspIntVal init) of+ (Just rrr, Just iii) -> do+ addFD $ GCCount dcol dval GOEqual (Right $ transPar $ rrr-iii)+ return True+ _ -> do+ dsum <- liftFD $ newvar+ sum <- liftFD $ specInfoIntTerm dsum+ t EGPlus ([],[res,init,sum],[])+ addFD $ GCCount dcol dval GOEqual (Left dsum)+ return True+ _ -> return False+reduceMultCountFold _ _ = return False++reduceSumFoldToMap :: (GecodeSolver s, GecodeConstraint s ~ Constraint s) => (EGConstraintSpec -> FDSpecInfo (GecodeWrappedSolver s) -> FDInstance (GecodeWrappedSolver s) ()) -> (EGConstraintSpec,FDSpecInfo (GecodeWrappedSolver s)) -> FDInstance (GecodeWrappedSolver s) Bool+reduceSumFoldToMap t (EGFold model (nb,ni,nc),(vb,res:init:vi,col:vc)) = do+ let mp = externMap model+ vold = myFromJust "reduceSumFoldToMap1" $ Map.lookup (-2) $ intData mp+ vnew = myFromJust "reduceSumFoldToMap2" $ Map.lookup (-1) $ intData mp+ varg = myFromJust "reduceSumFoldToMap3" $ Map.lookup (-3) $ intData mp+ ncold = length $ myFromJust "reduceSumFoldToMap4" $ Map.lookup vold $ intData $ egmLinks model+ ncnew = length $ myFromJust "reduceSumFoldToMap5" $ Map.lookup vnew $ intData $ egmLinks model+ ncarg = length $ myFromJust "reduceSumFoldToMap6" $ Map.lookup varg $ intData $ egmLinks model+ filt (EGEdge { egeCons = EGPlus, egeLinks = EGTypeData { intData = [o,i1,i2] } }) | (vnew==o && vold==i1) = Just i2+ filt (EGEdge { egeCons = EGPlus, egeLinks = EGTypeData { intData = [o,i1,i2] } }) | (vnew==o && vold==i2) = Just i1+ filt _ = Nothing+ in if (ncnew==2 && ncold==2)+ then do+ let (nm1,nn) = filterModel model filt+ case nn of+ [ii] -> do+ let filt2 (EGEdge { egeCons = EGIntExtern _ }) = Just ()+ filt2 _ = Nothing+ (nm2,_) = filterModel nm1 filt2+ nm3 = addEdge (EGIntExtern (-1)) (EGTypeData { intData=[ii],colData=[],boolData=[] }) nm2+ nm4 = addEdge (EGIntExtern (-2)) (EGTypeData { intData=[varg],colData=[],boolData=[] }) nm3+ nm5 = delNode EGIntType vold nm4+ nm6 = delNode EGIntType vnew nm5+ nm = nm5+ dcs <- doColSpec col [GCSVar]+ case dcs of+ Just (GCTVar dcol) -> do+ size <- liftFD $ col_getSize dcol+ dmap <- liftFD $ newCol_size size+ let cmap = FDSpecInfoCol { fdspColSpec = const $ Just (GCTVar dmap), fdspColVal = Nothing, fdspColVar = Nothing, fdspColTypes = Set.singleton GCSVar }+ t (EGMap nm (nb,ni,nc)) (vb,vi,cmap:col:vc)+ dsum <- liftFD $ newvar+ sum <- liftFD $ specInfoIntTerm dsum+ addFD $ GCSum (Left dmap) (Left dsum)+ t EGPlus ([],[res,init,sum],[])+ return True+ _ -> return False+ _ -> return False+ else return False+reduceSumFoldToMap _ _ = return False++extractSumFold :: (GecodeSolver s, GecodeConstraint s ~ Constraint s) => EGModel -> FDSpecInfoCol (GecodeWrappedSolver s) -> FDSpecInfoInt (GecodeWrappedSolver s) -> FDSpecInfoInt (GecodeWrappedSolver s) -> (EGConstraintSpec -> FDSpecInfo (GecodeWrappedSolver s) -> FDInstance (GecodeWrappedSolver s) ()) -> FDInstance (GecodeWrappedSolver s) EGModel+extractSumFold model col init res t = do+ let mp = externMap model+ vold = myFromJust "extractSumFold1" $ Map.lookup (-2) $ intData mp+ vnew = myFromJust "extractSumFold2" $ Map.lookup (-1) $ intData mp+ varg = myFromJust "extractSumFold3" $ Map.lookup (-3) $ intData mp+ ncold = length $ myFromJust "extractSumFold4" $ Map.lookup vold $ intData $ egmLinks model+ ncnew = length $ myFromJust "extractSumFold5" $ Map.lookup vnew $ intData $ egmLinks model+ ncarg = length $ myFromJust "extractSumFold6" $ Map.lookup varg $ intData $ egmLinks model+ filt (EGEdge { egeCons = EGPlus, egeLinks = EGTypeData { intData = [o,i1,i2] } }) | (vnew==o && ((vold==i1 && varg==i2) || (vold==i2 && varg==i1))) = Just ()+ filt _ = Nothing+ in if (ncnew==2 && ncold==2 && ncarg==2)+ then do+ let (nm,nn) = filterModel model filt+ if nn==[()]+ then do+ dcs <- doColSpec col [GCSVar,GCSSection]+ case dcs of+ Just (GCTVar dcol) -> do+ case (fdspIntVal res, fdspIntVal init) of+ (Just rrr, Just iii) -> addFD $ GCSum (Left dcol) (Right $ transPar $ rrr-iii)+ _ -> do+ dsum <- liftFD $ newvar+ sum <- liftFD $ specInfoIntTerm dsum+ addFD $ GCSum (Left dcol) (Left dsum)+ t EGPlus ([],[res,init,sum],[])+ return nm+ Just (GCTSection (dcol,(nnn,fff))) -> do+ case (fdspIntVal res, fdspIntVal init) of+ (Just rrr, Just iii) -> addFD $ GCSum (Right (dcol,(nnn,fff))) (Right $ transPar $ rrr-iii)+ _ -> do+ dsum <- liftFD $ newvar+ sum <- liftFD $ specInfoIntTerm dsum+ addFD $ GCSum (Right (dcol,(nnn,fff))) (Left dsum)+ t EGPlus ([],[res,init,sum],[])+ return nm+ _ -> return model+ else return model+ else return model++tryColSpecs s [] = fdspColSpec s Nothing+tryColSpecs s (a:b) = case fdspColSpec s (Just a) of+ Nothing -> tryColSpecs s b+ Just x -> Just x+tryIntSpecs s [] = fdspIntSpec s Nothing+tryIntSpecs s (a:b) = case fdspIntSpec s (Just a) of+ Nothing -> tryIntSpecs s b+ Just x -> Just x+tryBoolSpecs s [] = fdspBoolSpec s Nothing+tryBoolSpecs s (a:b) = case fdspBoolSpec s (Just a) of+ Nothing -> tryBoolSpecs s b+ Just x -> Just x+++process :: (GecodeSolver s, GecodeConstraint s ~ Constraint s) => Mixin (EGConstraintSpec -> FDSpecInfo (GecodeWrappedSolver s) -> FDInstance (GecodeWrappedSolver s) ())+process s t cons info = debug ("gecode_process "++(show cons)++" "++(show info)) $ case (cons,info) of+ (EGPlus, ([],[r,a,b],[])) -> addFD $ GCLinear ((intSpecToLinear $ getDefIntSpec a)+(intSpecToLinear $ getDefIntSpec b)-(intSpecToLinear $ getDefIntSpec r)) GOEqual+ (EGMinus, ([],[r,a,b],[])) -> addFD $ GCLinear ((intSpecToLinear $ getDefIntSpec r)+(intSpecToLinear $ getDefIntSpec b)-(intSpecToLinear $ getDefIntSpec a)) GOEqual+ (EGIntValue c, ([],[r],[])) -> addFD $ GCLinear ((intSpecToLinear $ getDefIntSpec r)-(constToLinear $ transPar c)) GOEqual+ (EGBoolValue c, ([r],[],[])) -> do+ dr <- forceDecompBool r+ addFD $ GCBoolVal dr $ transParBool c+ (EGMult, ([],[r,a,b],[])) -> + case (fdspIntVal a,fdspIntVal b) of+ (Just val,_) -> do+ dr <- forceDecompInt r+ addFD $ GCLinear ((intSpecToLinear $ getDefIntSpec b)*(constToLinear $ transPar val)-(termToLinear dr)) GOEqual+ (_,Just val) -> do+ dr <- forceDecompInt r+ addFD $ GCLinear ((intSpecToLinear $ getDefIntSpec a)*(constToLinear $ transPar val)-(termToLinear dr)) GOEqual+ _ -> do+ da <- forceDecompInt a+ db <- forceDecompInt b+ dr <- forceDecompInt r+ addFD $ GCMult dr da db+ (EGCondEqual, ([c,a,v],[],[])) -> do+ case (getReifSpec c, getReifSpec v) of+ (GBTConst (BoolConst False),_) -> return ()+ (GBTConst (BoolConst True),GBTConst vv) -> do+ da <- forceDecompBool a+ addFD $ GCBoolVal da vv+ (GBTConst cc, GBTConst vv) -> do+ da <- forceDecompBool a+ addFD $ GCCond (GCBoolVal da vv) cc+ (cc,vv) -> error $ "Unsupported conditional equality required: ("++(show cc)++","++(show vv)++")"+ (EGDiv, ([],[r,a,b],[])) -> do+ dr <- forceDecompInt r+ da <- forceDecompInt a+ db <- forceDecompInt b+ addFD $ GCDiv dr da db+ (EGMod, ([],[r,a,b],[])) -> do+ dr <- forceDecompInt r+ da <- forceDecompInt a+ db <- forceDecompInt b+ addFD $ GCMod dr da db+ (EGAbs, ([],[r,a],[])) -> do+ dr <- forceDecompInt r+ da <- forceDecompInt a+ addFD $ GCAbs dr da+ (EGAt, ([],[r,p],[c])) -> do+ let dr = getIntVarOrConst r+ let dp = getIntVarOrConst p+ let dc = getColVarOrConst c+ addFD $ GCAt dr dc dp+ (EGChannel, ([b],[i],[])) -> do+ db <- forceDecompBool b+ di <- forceDecompInt i+ addFD $ GCChannel di db+ (EGCat, ([],[],[r,a,b])) -> do+ da <- forceDecompCol "egCat-A" a+ db <- forceDecompCol "egCat-B" b+ dr <- forceDecompCol "egCat-R" r+ addFD $ GCCat dr da db+{- (EGSlice f n, ([],[],[r,c])) -> do+ dr <- forceDecompCol "egSlice-R" r+ dc <- forceDecompCol "egSlice-C" c+ addFD $ GCSlice dr (dc,(transPar n,transPar . f . transIPar))+ return () -}+ (EGAnd, ([r,a,b],[],[])) -> do+ dr <- forceDecompBool r+ da <- forceDecompBool a+ db <- forceDecompBool b+ addFD $ GCAnd [da,db] dr+ (EGOr, ([r,a,b],[],[])) -> do+ dr <- forceDecompBool r+ da <- forceDecompBool a+ db <- forceDecompBool b+ addFD $ GCOr [da,db] dr+ (EGNot, ([r,a],[],[])) -> do+ dr <- forceDecompBool r+ da <- forceDecompBool a+ addFD $ GCNot dr da+ (EGEquiv, ([a,b,c],[],[])) -> do+ case (fdspBoolVal a, fdspBoolVal b, fdspBoolVal c) of+ (Just (BoolConst True),_,_) -> do + db <- forceDecompBool b+ dc <- forceDecompBool c+ addFD $ GCBoolEqual db dc+ (_,Just (BoolConst True),_) -> do + dc <- forceDecompBool c+ da <- forceDecompBool a+ addFD $ GCBoolEqual dc da+ (_,_,Just (BoolConst True)) -> do + da <- forceDecompBool a + db <- forceDecompBool a+ addFD $ GCBoolEqual da db+ (Just (BoolConst False),_,_) -> do + db <- forceDecompBool b+ dc <- forceDecompBool c+ addFD $ GCNot db dc+ (_,Just (BoolConst False),_) -> do + dc <- forceDecompBool c+ da <- forceDecompBool a+ addFD $ GCNot dc da+ (_,_,Just (BoolConst False)) -> do + da <- forceDecompBool a+ db <- forceDecompBool a+ addFD $ GCNot da db+ _ -> do+ da <- forceDecompBool a+ db <- forceDecompBool b+ dc <- forceDecompBool c+ addFD $ GCEquiv da db dc+ (EGEqual, ([i],[a,b],[])) -> do+ da <- forceLinearInt a+ db <- forceLinearInt b+ case (getReifSpec i) of+ GBTConst (BoolConst True) -> addFD $ GCLinear (da-db) GOEqual+ GBTConst (BoolConst False) -> addFD $ GCLinear (da-db) GODiff+ GBTCondConst (BoolConst True) (BoolConst True) -> addFD $ GCLinear (da-db) GOEqual+ GBTCondConst (BoolConst True) (BoolConst False) -> addFD $ GCLinear (da-db) GODiff+ GBTCondConst (BoolConst False) _ -> return ()+ GBTCondConst cond (BoolConst True) -> addFD $ GCCond (GCLinear (da-db) GOEqual) cond+ GBTCondConst cond (BoolConst False) -> addFD $ GCCond (GCLinear (da-db) GODiff) cond+ _ -> do+ di <- forceDecompBool i+ addFD $ GCLinearReif (da-db) GOEqual di+ (EGDiff, ([i],[a,b],[])) -> do+ da <- forceLinearInt a+ db <- forceLinearInt b+ case getReifSpec i of+ GBTConst (BoolConst True) -> addFD $ GCLinear (da-db) GODiff+ GBTConst (BoolConst False) -> addFD $ GCLinear (da-db) GOEqual+ GBTCondConst (BoolConst True) (BoolConst True) -> addFD $ GCLinear (da-db) GODiff+ GBTCondConst (BoolConst True) (BoolConst False) -> addFD $ GCLinear (da-db) GOEqual+ GBTCondConst (BoolConst False) _ -> return ()+ GBTCondConst cond (BoolConst True) -> addFD $ GCCond (GCLinear (da-db) GODiff) cond+ GBTCondConst cond (BoolConst False) -> addFD $ GCCond (GCLinear (da-db) GOEqual) cond+ _ -> do+ di <- forceDecompBool i+ addFD $ GCLinearReif (da-db) GODiff di+ (EGLess q, ([i],[a,b],[])) -> do+ da <- forceLinearInt a+ db <- forceLinearInt b+ case getReifSpec i of+ GBTConst (BoolConst True) -> addFD $ GCLinear (da-db) (if q then GOLess else GOLessEqual)+ GBTConst (BoolConst False) -> addFD $ GCLinear (db-da) (if q then GOLessEqual else GOLess)+ GBTCondConst (BoolConst True) (BoolConst True) -> addFD $ GCLinear (da-db) (if q then GOLess else GOLessEqual)+ GBTCondConst (BoolConst True) (BoolConst False) -> addFD $ GCLinear (db-da) (if q then GOLessEqual else GOLess)+ GBTCondConst (BoolConst False) _ -> return ()+ GBTCondConst cond (BoolConst True) -> addFD $ GCCond (GCLinear (da-db) (if q then GOLess else GOLessEqual)) cond+ GBTCondConst cond (BoolConst False) -> addFD $ GCCond (GCLinear (db-da) (if q then GOLessEqual else GOLess)) cond+ GBTCondConst c b -> error $ "EGLess: weird conditional: c="++(show c)++" b="++(show b)+ _ -> do+ di <- forceDecompBool i+ addFD $ GCLinearReif (da-db) (if q then GOLess else GOLessEqual) di+ (EGAllDiff b, ([],[],[c])) -> do+ cc <- doColSpec c [GCSVar,GCSSection]+ case cc of+ Just (GCTSection (v,(n,f))) -> addFD $ GCAllDiff b (Right (v,(n,f)))+ Just (GCTVar v) -> addFD $ GCAllDiff b (Left v)+ (EGSorted q, ([],[],[c])) -> do+ cc <- doColSpec c [GCSVar,GCSSection]+ case cc of+ Just (GCTSection (v,(n,f))) -> addFD $ GCSorted (Right (v,(n,f))) (if q then GOLess else GOLessEqual)+ Just (GCTVar v) -> addFD $ GCSorted (Left v) (if q then GOLess else GOLessEqual)+ _ -> error $ "Wth? Sorted this: "++(show cc)++" ??"+ (EGSize, ([],[s],[c])) -> do+ dc <- forceDecompCol "egSize-C" c+ ds <- forceDecompInt s+ addFD $ GCSize dc (Left ds)+ (EGDom, ([],[i],[c])) -> do+ let dc = getColVarOrConst c+ di <- forceDecompInt i+ addFD $ GCDom di dc Nothing+ (EGAll sm (nb,ni,nc) force,(r:vb,vi,c:vc)) -> case tryColSpecs c [GCSConst,GCSVar,GCSSection] of+ Just (GCTVar dc) -> do+ let mf iv bv = + do+ div <- specInfoIntTerm iv+ dbv <- if force then return (error "GCAll undefined 2") else specInfoBoolTerm bv+ let fb (-1) = dbv+ fb n = idx vb n+ fi (-1) = div+ fi n = idx vi n+ runFD $ procSubModel sm (fb,fi,(idx vc))+ case (force,getReifSpec r) of+ (False,GBTCondConst (BoolConst True) (BoolConst True)) -> addFD $ GCAll (GecodeIBFn mf) (Left dc) Nothing+ (_,GBTCondConst (BoolConst False) _) -> return ()+ (False,GBTCondConst cond (BoolConst True)) -> addFD $ GCCond (GCAll (GecodeIBFn mf) (Left dc) Nothing) cond+ (False,_) -> do+ dr <- forceDecompBool r+ addFD $ GCAll (GecodeIBFn mf) (Left dc) (Just dr)+ (True,_) -> addFD $ GCAll (GecodeIBFn mf) (Left dc) Nothing+ Just (GCTSection dc) -> do+ let mf iv bv = + do+ div <- specInfoIntTerm iv+ dbv <- if force then return (error "GCAll undefined 2") else specInfoBoolTerm bv+ let fb (-1) = dbv+ fb n = idx vb n+ fi (-1) = div+ fi n = idx vi n+ runFD $ procSubModel sm (fb,fi,(idx vc))+ case (force,getReifSpec r) of+ (False,GBTCondConst cond (BoolConst True)) -> addFD $ GCCond (GCAll (GecodeIBFn mf) (Right dc) Nothing) cond+ (False,_) -> do+ dr <- forceDecompBool r+ addFD $ GCAll (GecodeIBFn mf) (Right dc) (Just dr)+ (True,_) -> addFD $ GCAll (GecodeIBFn mf) (Right dc) Nothing+ Just (GCTConst dc) -> do+ let mf cv bv =+ do+ let cc = transIPar cv+ dbv <- if force then return (error "GCAllC undefined 2") else specInfoBoolTerm bv+ let ev1 = myFromJust "process:EGAll" $ Map.lookup (-1) $ intData $ externMap sm+ let sm2 = addEdge (EGIntValue cc) (EGTypeData { boolData=[], intData=[ev1], colData=[] }) sm+ let fb (-1) = Just $ dbv+ fb n = Just $ idx vb n+ fi (-1) = Nothing+ fi n = Just $ idx vi n+ fc n = Just $ idx vc n+ runFD $ procSubModelEx sm2 (fb,fi,fc)+ case (force,getReifSpec r) of+ (False,GBTCondConst cond (BoolConst True)) -> addFD $ GCCond (GCAllC (GecodeCBFn mf) (size dc,(dc!)) Nothing) cond+ (False,_) -> do+ dr <- forceDecompBool r+ addFD $ GCAllC (GecodeCBFn mf) (size dc, (dc!)) (Just dr)+ (True,_) -> addFD $ GCAllC (GecodeCBFn mf) (size dc, (dc!)) Nothing+ (EGMap sm (nb,ni,nc),(vb,vi,cr:c:vc)) -> do+ dc <- forceDecompCol "egMap-C" c+ dcr <- forceDecompCol "egMap-CR" cr+ let mf iv rv =+ do+ div <- specInfoIntTerm iv+ drv <- specInfoIntTerm rv+ let fi (-1) = drv+ fi (-2) = div+ fi n = idx vi n+ runFD $ procSubModel sm ((idx vb),fi,(idx vc))+ addFD $ GCMap (GecodeIIFn mf) (Left dc) dcr+ xx@(EGFold om (nb,ni,nc),(vb,res:init:vi,col:vc)) -> do+ sm <- extractSumFold om col init res t+ if emptyModel sm+ then return ()+ else do+ xxx <- reduceCountFold t xx+ case xxx of+ True -> return ()+ False -> do+ zzz <- reduceMultCountFold t xx+ case zzz of+ True -> return ()+ False -> do+ yyy <- reduceSumFoldToMap t xx+ case yyy of+ True -> return ()+ False -> do+ dcs <- getVarOrSection col+ case dcs of+ Nothing -> do+ case fdspColSpec col Nothing of+ Just (GCTConst sss) -> do+ dinit <- forceDecompInt init+ dres <- forceDecompInt res+ let mf iv xv rv = + do+ let xx = transIPar xv+ let ev3 = myFromJust "process:EGMap" $ Map.lookup (-3) $ intData $ externMap sm+ let sm2 = addEdge (EGIntValue xx) (EGTypeData { boolData = [], intData=[ev3], colData=[] }) sm+ drv <- specInfoIntTerm rv+ div <- specInfoIntTerm iv+ let fb n = Just $ idx vb n+ let fi (-1) = Just drv+ fi (-2) = Just div+ fi (-3) = Nothing+ fi n = Just $ idx vi n+ fc n = Just $ idx vc n+ runFD $ procSubModelEx sm2 (fb,fi,fc)+ addFD $ GCFoldC (GecodeICIFn (\prev arg next -> mf prev ((sss!) arg) next)) (size sss) dinit dres+ Just dcol -> do+ dinit <- forceDecompInt init+ dres <- forceDecompInt res+ let mf iv xv rv =+ do+ div <- specInfoIntTerm iv+ drv <- specInfoIntTerm rv+ dxv <- specInfoIntTerm xv+ let fi (-1) = drv+ fi (-2) = div+ fi (-3) = dxv+ fi n = idx vi n+ runFD $ procSubModel sm ((idx vb),fi,(idx vc))+ addFD $ GCFold (GecodeIIIFn mf) dcol dinit dres+ _ -> s cons info++addMeta :: (GecodeSolver s, Constraint s ~ GecodeConstraint s) => Mixin (GecodeConstraint s -> s Bool)+addMeta _ t (GCAllC (GecodeCBFn mf) (Const l,f) Nothing) = do+ let m i = do+ mf (f i) (error "addMeta GCAllC undefined")+ mapM_ m [0..fromIntegral (l-1)]+ return True+addMeta _ t (GCAllC (GecodeCBFn mf) (Const l,f) (Just dr)) = do+ let m i = do+ b <- newvar+ mf (f i) b+ return b+ lst <- mapM m [0..fromIntegral (l-1)]+ t $ GCAnd lst dr+ return True+addMeta s t (GCAll (GecodeIBFn mf) (Left dc) Nothing) = do+ dcs <- col_getSize dc+ let m i = do+ v <- newInt_at dc i+ mf v (error "addMeta GCAll undefined")+ mapM_ m [0..fromIntegral $ dcs-1]+ return True+addMeta s t (GCAll (GecodeIBFn mf) (Left dc) (Just dr)) = do+ dcs <- col_getSize dc+ let m i = do+ v <- newInt_at dc i+ b <- newvar+ mf v b+ return b+ lst <- mapM m [0..fromIntegral $ dcs-1]+ t $ GCAnd lst dr+addMeta s t (GCAny (GecodeIBFn mf) (Left dc) (Just dr)) = do+ dcs <- col_getSize dc+ let m i = do+ v <- newInt_at dc i+ b <- newvar+ mf v b+ return b+ lst <- mapM m [0..fromIntegral $ dcs-1]+ t $ GCOr lst dr+addMeta s t (GCMap (GecodeIIFn mf) (Left dc) dcr) = do+ dcs <- col_getSize dc+ t $ GCSize dcr (Right dcs)+ let m i = do+ v <- newInt_at dc i+ r <- newInt_at dcr i+ mf v r+ mapM_ m [0..fromIntegral $ dcs-1]+ return True+addMeta s t (GCFold (GecodeIIIFn mf) (Left dc) dinit dres) = do+ dcs <- col_getSize dc+ vars <- mapM (\_ -> newvar) [1..fromIntegral $ dcs-1]+ let av = (dinit : vars) ++ [dres]+ let m i = do+ let prev = idx av i+ let next = idx av (i+1)+ elem <- newInt_at dc $ toConst i+ mf prev elem next+ mapM_ m [0..fromIntegral $ dcs-1]+ return True+addMeta s t (GCFoldC (GecodeICIFn mf) (nnn) dinit dres) = do+ let (Const n) = nnn+ vars <- mapM (\_ -> newvar) [1..fromIntegral $ n-1]+ let av = (dinit : vars) ++ [dres]+ let m i = do+ let prev = idx av i+ let next = idx av (i+1)+ let elem = Const $ fromIntegral i+ mf prev elem next+ mapM_ m [0..fromIntegral $ n-1]+ return True+addMeta s t (GCFold a (Right dc) b c) = do+ nc <- buildSection dc+ t $ GCFold a (Left nc) b c+addMeta s t (GCMap a (Right dc) b) = do+ nc <- buildSection dc+ t $ GCMap a (Left nc) b+addMeta s t (GCAll a (Right dc) b) = do+ nc <- buildSection dc+ t $ GCAll a (Left nc) b+addMeta s t (GCAny a (Right dc) b) = do+ nc <- buildSection dc+ t $ GCAny a (Left nc) b+addMeta s t (c@(GCSorted (Right ss) op)) = do+ nc <- buildSection ss+ t $ GCSorted (Left nc) op+addMeta s t (c@(GCAllDiff b (Right ss))) = do+ nc <- buildSection ss+ t $ GCAllDiff b (Left nc)+addMeta s t ((GCSlice c ss)) = do+ nc <- buildSection ss+ t $ GCColEqual nc c+addMeta s t (GCSum (Right ss) f) = do+ nc <- buildSection ss+ t $ GCSum (Left nc) f+addMeta s _ c = s c++toConst :: Integral a => a -> GecodeIntConst+toConst = Const . toInteger++fromConst :: Num a => GecodeIntConst -> a+fromConst (Const x) = fromInteger x++toBoolConst :: Bool -> GecodeBoolConst+toBoolConst = BoolConst++fromBoolConst :: GecodeBoolConst -> Bool+fromBoolConst (BoolConst x) = x
Control/CP/FD/Gecode/Interface.hsc view
@@ -1,73 +1,62 @@ {-# LANGUAGE CPP #-} {-# LANGUAGE ForeignFunctionInterface #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE TypeFamilies #-} {-# CFILES glue/interface.cpp #-} module Control.CP.FD.Gecode.Interface (- CGOperator(..),- CGIntVar(..),- CGBoolVar(..),- CGBool(..),- CGVal(..),- toCGIntVar,- toCGBoolVar,- toCGVal,- fromCGVal,- toCGBool,- fromCGBool,- Space,- Search,- newSpace,- copySpace,- newSearch,- runSearch,- IntTermInfo(..),- getIntTermInfo,- mapGOperator,- c_gecode_int_dom,- c_gecode_int_rel,- c_gecode_int_rel_cf,- c_gecode_int_rel_cs,- c_gecode_int_value,- c_gecode_int_mult,- c_gecode_int_div,- c_gecode_int_mod,- c_gecode_int_abs,- c_gecode_int_linear,- c_gecode_int_alldiff,- c_gecode_int_sorted,- c_gecode_int_newvar,- c_gecode_int_branch,- c_gecode_bool_newvar+ CGIntVar, CGBoolVar, CGColVar,+ Space, Search,+ newSpace, copySpace,+ newSearch, runSearch,+ newInt, newIntAt,+ newBool,+ newColList, newColSize, newColCat, newColTake,+ getColSize,+ addConstraint,+ propagate,+ postBranchers,+ IntInfo(..), getIntInfo,+ getBoolInfo,+ modRefcount,+ setCost ) where #ifdef RGECODE +import Data.Bits+ import Foreign import Foreign.C import Foreign.C.Types import Foreign.ForeignPtr +import Data.Expr.Data+-- import Expr.Util import Control.CP.FD.Gecode.Common+import Data.Linear #include "gecodeglue.h" newtype CGOperator = CGOperator CInt deriving Storable newtype CGIntVar = CGIntVar CInt- deriving Storable+ deriving (Storable, Eq, Ord, Show)+newtype CGColVar = CGColVar CInt+ deriving (Storable, Eq, Ord, Show) newtype CGBoolVar = CGBoolVar CInt- deriving Storable+ deriving (Storable, Eq, Ord, Show) newtype CGBool = CGBool CInt deriving Storable newtype CGVal = CGVal CInt- deriving Storable+ deriving (Storable, Num, Eq, Show) -mapGOperator :: GOperator -> CGOperator-mapGOperator OEqual = CGOperator #const GOPERATOR_OEQUAL-mapGOperator ODiff = CGOperator #const GOPERATOR_ODIFF-mapGOperator OLess = CGOperator #const GOPERATOR_OLESS+mapGOperator :: GecodeOperator -> CGOperator+mapGOperator GOEqual = CGOperator #const GOPERATOR_OEQUAL+mapGOperator GODiff = CGOperator #const GOPERATOR_ODIFF+mapGOperator GOLess = CGOperator #const GOPERATOR_OLESS+mapGOperator GOLessEqual = CGOperator #const GOPERATOR_OLESSEQUAL newtype GecodeModel = GecodeModel (Ptr GecodeModel) newtype GecodeSearch = GecodeSearch (Ptr GecodeSearch)@@ -77,6 +66,7 @@ foreign import ccall unsafe "&gecode_model_destroy" c_gecode_model_finalize :: FunPtr (Ptr GecodeModel -> IO ()) foreign import ccall unsafe "gecode_model_copy" c_gecode_model_copy :: Ptr GecodeModel -> IO (Ptr GecodeModel) foreign import ccall unsafe "gecode_model_fail" c_gecode_model_fail :: Ptr GecodeModel -> IO ()+foreign import ccall unsafe "gecode_model_propagate" c_gecode_model_propagate :: Ptr GecodeModel -> IO () foreign import ccall unsafe "gecode_int_newvar" c_gecode_int_newvar :: Ptr GecodeModel -> IO CGIntVar foreign import ccall unsafe "gecode_int_rel" c_gecode_int_rel :: Ptr GecodeModel -> CGIntVar -> CGOperator -> CGIntVar -> IO CGBool foreign import ccall unsafe "gecode_int_rel_cf" c_gecode_int_rel_cf :: Ptr GecodeModel -> CGVal -> CGOperator -> CGIntVar -> IO CGBool@@ -88,23 +78,70 @@ foreign import ccall unsafe "gecode_int_abs" c_gecode_int_abs :: Ptr GecodeModel -> CGIntVar -> CGIntVar -> IO CGBool foreign import ccall unsafe "gecode_int_dom" c_gecode_int_dom :: Ptr GecodeModel -> CGIntVar -> CGVal -> CGVal -> IO CGBool foreign import ccall unsafe "gecode_int_linear" c_gecode_int_linear :: Ptr GecodeModel -> CInt -> Ptr CGIntVar -> Ptr CGVal -> CGOperator -> CGVal -> IO CGBool-foreign import ccall unsafe "gecode_int_alldiff" c_gecode_int_alldiff :: Ptr GecodeModel -> CInt -> Ptr CGIntVar -> IO CGBool-foreign import ccall unsafe "gecode_int_sorted" c_gecode_int_sorted :: Ptr GecodeModel -> CInt -> Ptr CGIntVar -> CGBool -> IO CGBool-foreign import ccall unsafe "gecode_int_info" c_gecode_int_info :: Ptr GecodeModel -> CGIntVar -> Ptr CGVal -> Ptr CGVal -> Ptr CGVal -> Ptr CInt -> Ptr CGVal -> IO ()+foreign import ccall unsafe "gecode_int_linear_ri" c_gecode_int_linear_ri :: Ptr GecodeModel -> CInt -> Ptr CGIntVar -> Ptr CGVal -> CGOperator -> CGVal -> CGBoolVar -> IO CGBool+foreign import ccall unsafe "gecode_int_alldiff" c_gecode_int_alldiff :: Ptr GecodeModel -> CInt -> Ptr CGIntVar -> CGBool -> IO CGBool +foreign import ccall unsafe "gecode_int_sorted" c_gecode_int_sorted :: Ptr GecodeModel -> CInt -> Ptr CGIntVar -> CGOperator -> IO CGBool+foreign import ccall unsafe "gecode_int_info" c_gecode_int_info :: Ptr GecodeModel -> CGIntVar -> Ptr CGVal -> IO ()+foreign import ccall unsafe "gecode_int_get_size" c_gecode_int_get_size :: Ptr GecodeModel -> CGIntVar -> IO CInt+foreign import ccall unsafe "gecode_int_get_value" c_gecode_int_get_value :: Ptr GecodeModel -> CGIntVar -> IO CInt+foreign import ccall unsafe "gecode_int_get_median" c_gecode_int_get_median :: Ptr GecodeModel -> CGIntVar -> IO CInt foreign import ccall unsafe "gecode_int_branch" c_gecode_int_branch :: Ptr GecodeModel -> CInt -> Ptr CGIntVar -> IO () foreign import ccall unsafe "gecode_bool_newvar" c_gecode_bool_newvar :: Ptr GecodeModel -> IO CGBoolVar+foreign import ccall unsafe "gecode_bool_value" c_gecode_bool_value :: Ptr GecodeModel -> CGBoolVar -> CGBool -> IO CGBool+foreign import ccall unsafe "gecode_bool_equal" c_gecode_bool_equal :: Ptr GecodeModel -> CGBoolVar -> CGBoolVar -> IO CGBool+foreign import ccall unsafe "gecode_bool_and" c_gecode_bool_and :: Ptr GecodeModel -> CGBoolVar -> CGBoolVar -> CGBoolVar -> IO CGBool+foreign import ccall unsafe "gecode_bool_or" c_gecode_bool_or :: Ptr GecodeModel -> CGBoolVar -> CGBoolVar -> CGBoolVar -> IO CGBool+foreign import ccall unsafe "gecode_bool_not" c_gecode_bool_not :: Ptr GecodeModel -> CGBoolVar -> CGBoolVar -> IO CGBool+foreign import ccall unsafe "gecode_bool_equiv" c_gecode_bool_equiv :: Ptr GecodeModel -> CGBoolVar -> CGBoolVar -> CGBoolVar -> IO CGBool foreign import ccall unsafe "gecode_bool_branch" c_gecode_bool_branch :: Ptr GecodeModel -> CInt -> Ptr CGBoolVar -> IO ()+foreign import ccall unsafe "gecode_bool_channel" c_gecode_bool_channel :: Ptr GecodeModel -> CGBoolVar -> CGIntVar -> IO CGBool+foreign import ccall unsafe "gecode_bool_info" c_gecode_bool_info :: Ptr GecodeModel -> CGBoolVar -> Ptr CInt -> IO ()+foreign import ccall unsafe "gecode_bool_all" c_gecode_bool_all :: Ptr GecodeModel -> CInt -> Ptr CGBoolVar -> CGBoolVar -> IO CGBool+foreign import ccall unsafe "gecode_bool_any" c_gecode_bool_any :: Ptr GecodeModel -> CInt -> Ptr CGBoolVar -> CGBoolVar -> IO CGBool+foreign import ccall unsafe "gecode_col_newsize" c_gecode_col_newsize :: Ptr GecodeModel -> CInt -> IO CGColVar+foreign import ccall unsafe "gecode_col_newlist" c_gecode_col_newlist :: Ptr GecodeModel -> CInt -> Ptr CGIntVar -> IO CGColVar+foreign import ccall unsafe "gecode_col_newcat" c_gecode_col_newcat :: Ptr GecodeModel -> CGColVar -> CGColVar -> IO CGColVar+foreign import ccall unsafe "gecode_col_newtake" c_gecode_col_newtake :: Ptr GecodeModel -> CGColVar -> CInt -> CInt -> IO CGColVar+foreign import ccall unsafe "gecode_col_equal" c_gecode_col_equal :: Ptr GecodeModel -> CGColVar -> CGColVar -> IO CGBool+foreign import ccall unsafe "gecode_col_at" c_gecode_col_at :: Ptr GecodeModel -> CGColVar -> CGIntVar -> CGIntVar -> IO CGBool+foreign import ccall unsafe "gecode_col_at_cv" c_gecode_col_at_cv :: Ptr GecodeModel -> CGColVar -> CGIntVar -> CInt -> IO CGBool+foreign import ccall unsafe "gecode_col_at_lst" c_gecode_col_at_lst :: Ptr GecodeModel -> CInt -> Ptr CInt -> CGIntVar -> CGIntVar -> IO CGBool+foreign import ccall unsafe "gecode_col_at_lst_cv" c_gecode_col_at_lst_cv :: Ptr GecodeModel -> CInt -> Ptr CInt -> CGIntVar -> CInt -> IO CGBool+foreign import ccall unsafe "gecode_col_dom" c_gecode_col_dom :: Ptr GecodeModel -> CGIntVar -> CGColVar -> IO CGBool+foreign import ccall unsafe "gecode_int_dom_list" c_gecode_int_dom_list :: Ptr GecodeModel -> CGIntVar -> CInt -> Ptr CInt -> CGBoolVar -> IO CGBool+foreign import ccall unsafe "gecode_col_cat" c_gecode_col_cat :: Ptr GecodeModel -> CGColVar -> CGColVar -> CGColVar -> IO CGBool+foreign import ccall unsafe "gecode_col_take" c_gecode_col_take :: Ptr GecodeModel -> CGColVar -> CInt -> CInt -> CGColVar -> IO CGBool+foreign import ccall unsafe "gecode_col_alldiff" c_gecode_col_alldiff :: Ptr GecodeModel -> CGColVar -> CGBool -> IO CGBool+foreign import ccall unsafe "gecode_col_sorted" c_gecode_col_sorted :: Ptr GecodeModel -> CGColVar -> CGOperator -> IO CGBool+foreign import ccall unsafe "gecode_col_sum" c_gecode_col_sum :: Ptr GecodeModel -> CGColVar -> CGIntVar -> IO CGBool+foreign import ccall unsafe "gecode_col_count" c_gecode_col_count :: Ptr GecodeModel -> CGColVar -> CInt -> CGIntVar -> CGOperator -> CInt -> CGIntVar -> IO CGBool+foreign import ccall unsafe "gecode_col_count" c_gecode_col_count_c1 :: Ptr GecodeModel -> CGColVar -> CInt -> CGVal -> CGOperator -> CInt -> CGIntVar -> IO CGBool+foreign import ccall unsafe "gecode_col_count" c_gecode_col_count_c2 :: Ptr GecodeModel -> CGColVar -> CInt -> CGIntVar -> CGOperator -> CInt -> CGVal -> IO CGBool+foreign import ccall unsafe "gecode_col_count" c_gecode_col_count_c12 :: Ptr GecodeModel -> CGColVar -> CInt -> CGVal -> CGOperator -> CInt -> CGVal -> IO CGBool+foreign import ccall unsafe "gecode_col_sumc" c_gecode_col_sumc :: Ptr GecodeModel -> CGColVar -> CInt -> IO CGBool+foreign import ccall unsafe "gecode_col_getsize" c_gecode_col_getsize :: Ptr GecodeModel -> CGColVar -> IO CInt+foreign import ccall unsafe "gecode_col_branch" c_gecode_col_branch :: Ptr GecodeModel -> CInt -> Ptr CGColVar -> IO () -foreign import ccall unsafe "gecode_search_create" c_gecode_search_create :: Ptr GecodeModel -> IO (Ptr GecodeSearch)+foreign import ccall unsafe "gecode_search_create_dfs" c_gecode_search_create_dfs :: Ptr GecodeModel -> IO (Ptr GecodeSearch)+foreign import ccall unsafe "gecode_search_create_bab" c_gecode_search_create_bab :: Ptr GecodeModel -> IO (Ptr GecodeSearch) foreign import ccall unsafe "&gecode_search_destroy" c_gecode_search_finalize :: FunPtr (Ptr GecodeSearch -> IO ()) foreign import ccall unsafe "gecode_search_destroy" c_gecode_search_destroy :: Ptr GecodeSearch -> IO () foreign import ccall unsafe "gecode_search_next" c_gecode_search_next :: Ptr GecodeSearch -> IO (Ptr GecodeModel) +foreign import ccall unsafe "gecode_space_modrefcount" c_gecode_space_modrefcount :: Ptr GecodeModel -> CInt -> IO CInt+foreign import ccall unsafe "gecode_space_setcost" c_gecode_space_setcost :: Ptr GecodeModel -> CGIntVar -> IO ()+ ---- accessor functions toCGIntVar :: Integral a => a -> CGIntVar toCGIntVar n = CGIntVar $ fromIntegral n +toCGColVar :: Integral a => a -> CGColVar+toCGColVar n = CGColVar $ fromIntegral n++toCGColIntVar :: Integral a => CGColVar -> a -> CGIntVar+toCGColIntVar (CGColVar c) a = CGIntVar $ ((c+1) `shiftL` 16) + (fromIntegral a)+ toCGBoolVar :: Integral a => a -> CGBoolVar toCGBoolVar n = CGBoolVar $ fromIntegral n @@ -120,6 +157,31 @@ fromCGBool :: CGBool -> Bool fromCGBool (CGBool x) = x /= 0 +++getIntTermSize :: Num a => Space -> Int -> IO a+getIntTermSize s i = do+ ret <- withForeignPtr s $ \ptr -> c_gecode_int_get_size ptr (toCGIntVar i)+ return $ fromIntegral ret++getIntTermValue :: Num a => Space -> Int -> IO a+getIntTermValue s i = do+ ret <- withForeignPtr s $ \ptr -> c_gecode_int_get_value ptr (toCGIntVar i)+ return $ fromIntegral ret++getIntTermMedian :: Num a => Space -> Int -> IO a+getIntTermMedian s i = do+ ret <- withForeignPtr s $ \ptr -> c_gecode_int_get_median ptr (toCGIntVar i)+ return $ fromIntegral ret+++fnToBool :: IO CGBool -> IO Bool+fnToBool io = do+ v <- io+ return $ fromCGBool v++---------------------------------------------------- PUBLIC INTERFACE --------------------------------------------------------+ type Space = ForeignPtr GecodeModel type Search = ForeignPtr GecodeSearch @@ -128,14 +190,23 @@ x <- c_gecode_model_create newForeignPtr c_gecode_model_finalize x +modRefcount :: Space -> Int -> IO Int+modRefcount s m = withForeignPtr s $ \ptr -> c_gecode_space_modrefcount ptr (fromIntegral m) >>= (return . fromIntegral)+ copySpace :: Space -> IO Space copySpace s = withForeignPtr s $ \ptr -> do x <- c_gecode_model_copy ptr- newForeignPtr c_gecode_model_finalize x+ if (x == nullPtr)+ then return s+ else newForeignPtr c_gecode_model_finalize x -newSearch :: Space -> IO Search-newSearch s = withForeignPtr s $ \ptr -> do- x <- c_gecode_search_create ptr+propagate :: Space -> IO ()+propagate s = do+ withForeignPtr s $ \ptr -> c_gecode_model_propagate ptr++newSearch :: Space -> Bool -> IO Search+newSearch s optim = withForeignPtr s $ \ptr -> do+ x <- (if optim then c_gecode_search_create_bab else c_gecode_search_create_dfs) ptr newForeignPtr c_gecode_search_finalize x runSearch :: Search -> IO (Maybe Space)@@ -147,27 +218,142 @@ res <- newForeignPtr c_gecode_model_finalize x return $ Just res -data IntTermInfo = IntTermInfo { iti_low :: CInt, iti_high :: CInt, iti_med :: CInt, iti_size :: CInt, iti_val :: Maybe CInt }+addLinearConstraint :: Ptr GecodeModel -> Linear CGIntVar GecodeIntConst -> GecodeOperator -> Maybe (CGBoolVar) -> IO CGBool+addLinearConstraint ptr l o reif = do+ let (Const c,ll) = linearToListEx l+ len = length ll+ vars = map fst ll+ coefs = map (\(_,Const x) -> toCGVal x) ll+ case (c,ll,o,reif) of+ (0,[],GOEqual,_) -> return $ toCGBool True+ (_,[(v,Const f)],GOEqual,Nothing) | (c `mod` f)==0 -> c_gecode_int_value ptr v (toCGVal $ -c `div` f)+ (0,[(v1,Const a),(v2,Const b)],_,Nothing) | a==(-b) && a>0 -> c_gecode_int_rel ptr v1 (mapGOperator o) v2+ (0,[(v1,Const a),(v2,Const b)],_,Nothing) | a==(-b) && b>0 -> c_gecode_int_rel ptr v2 (mapGOperator o) v1+ (_,_,_,Nothing) -> withArray vars $ \pvars -> withArray coefs $ \pcoefs -> c_gecode_int_linear ptr (fromIntegral len) pvars pcoefs (mapGOperator o) (toCGVal $ -c)+ (_,_,_,Just rv) -> withArray vars $ \pvars -> withArray coefs $ \pcoefs -> c_gecode_int_linear_ri ptr (fromIntegral len) pvars pcoefs (mapGOperator o) (toCGVal $ -c) rv -getIntTermInfo :: Integral a => Space -> a -> IO IntTermInfo-getIntTermInfo s i = do- alloca $ \pLow ->- alloca $ \pHigh ->- alloca $ \pMed ->- alloca $ \pSize ->- alloca $ \pVal -> do- withForeignPtr s $ \ptr -> c_gecode_int_info ptr (toCGIntVar i) pLow pHigh pMed pSize pVal- vLow <- peek pLow- vHigh <- peek pHigh- vMed <- peek pMed- vSize <- peek pSize- vVal <- peek pVal- return $ IntTermInfo {- iti_low = fromCGVal vLow,- iti_high = fromCGVal vHigh,- iti_med = fromCGVal vMed,- iti_size = fromIntegral vSize,- iti_val = if (vSize==1) then Just (fromCGVal vVal) else Nothing - }++newInt :: Space -> IO CGIntVar+newInt s = withForeignPtr s $ \ptr -> c_gecode_int_newvar ptr++newIntAt :: Space -> CGColVar -> Int -> IO CGIntVar+newIntAt _ c p = return $ toCGColIntVar c (fromIntegral p)++newBool :: Space -> IO CGBoolVar+newBool s = withForeignPtr s $ \ptr -> c_gecode_bool_newvar ptr++newColList :: Space -> [CGIntVar] -> IO CGColVar+newColList s l = withForeignPtr s $ \ptr -> withArray l $ \lptr -> c_gecode_col_newlist ptr (fromIntegral $ length l) lptr++newColSize :: Space -> Int -> IO CGColVar+newColSize s l = withForeignPtr s $ \ptr -> c_gecode_col_newsize ptr $ fromIntegral l++newColTake :: Space -> CGColVar -> Int -> Int -> IO CGColVar+newColTake s c b l = withForeignPtr s $ \ptr -> c_gecode_col_newtake ptr c (fromIntegral b) (fromIntegral l)++newColCat :: Space -> CGColVar -> CGColVar -> IO CGColVar+newColCat s a b = withForeignPtr s $ \ptr -> c_gecode_col_newcat ptr a b++setCost :: Space -> CGIntVar -> IO ()+setCost s v = withForeignPtr s $ \ptr -> c_gecode_space_setcost ptr v++postBranchers :: Space -> ([CGBoolVar],[CGIntVar],[CGColVar]) -> IO ()+postBranchers s (b,i,c) = withForeignPtr s $ \ptr -> + withArray b $ \bp ->+ withArray i $ \ip ->+ withArray c $ \cp -> do+ if (length c > 0) then c_gecode_col_branch ptr (fromIntegral $ length c) cp else return ()+ if (length i > 0) then c_gecode_int_branch ptr (fromIntegral $ length i) ip else return ()+ if (length b > 0) then c_gecode_bool_branch ptr (fromIntegral $ length b) bp else return ()++buildListConst (Const l,f) = [case f (Const i) of { Const r -> r } | i <- [0..l-1]]++addConstraint :: (GecodeSolver s, GecodeIntVar s ~ CGIntVar, GecodeBoolVar s ~ CGBoolVar, GecodeColVar s ~ CGColVar) => Space -> GecodeConstraint s -> IO Bool+addConstraint s c = withForeignPtr s $ \ptr -> fnToBool $ case c of+ GCBoolVal var c -> case c of+ BoolConst bool -> c_gecode_bool_value ptr var (toCGBool bool)+ _ -> (error $ "Only non-paramterized boolean constants are supported by Gecode interface: ")+ GCBoolEqual b1 b2 -> c_gecode_bool_equal ptr b1 b2+ GCIntVal var c -> case c of+ Const val -> c_gecode_int_value ptr var (toCGVal val)+ _ -> (error $ "Only non-paramterized integer constants are supported by Gecode interface: ")+ GCSize var (Right (Const s)) -> do+ os <- c_gecode_col_getsize ptr var+ if (s /= toInteger os) + then return $ toCGBool False+ else return $ toCGBool True+ GCLinear l o -> addLinearConstraint ptr l o Nothing+ GCLinearReif l o ri -> addLinearConstraint ptr l o $ Just ri+ GCSum (Left c) (Left l) -> c_gecode_col_sum ptr c l+ GCSum (Left c) (Right l) -> c_gecode_col_sumc ptr c $ fromIntegral l+ GCColEqual c1 c2 -> c_gecode_col_equal ptr c1 c2+ GCMult vr v1 v2 -> c_gecode_int_mult ptr v1 v2 vr+ GCDiv vr v1 v2 -> c_gecode_int_div ptr v1 v2 vr+ GCMod vr v1 v2 -> c_gecode_int_mod ptr v1 v2 vr+ GCAbs vr v1 -> c_gecode_int_abs ptr v1 vr+ GCAt (Left vr) (Left vc) (Left vp) -> c_gecode_col_at ptr vc vp vr+ GCAt (Right (Const vv)) (Left vc) (Left vp) -> c_gecode_col_at_cv ptr vc vp $ fromIntegral vv+ GCAt (Left vr) (Right (Left vl)) (Left vp) -> withArray (map fromIntegral vl) $ \ll -> c_gecode_col_at_lst ptr (fromIntegral $ length vl) ll vp vr+ GCAt (Right (Const vv)) (Right (Left vl)) (Left vp) -> withArray (map fromIntegral vl) $ \ll -> c_gecode_col_at_lst_cv ptr (fromIntegral $ length vl) ll vp $ fromIntegral vv+ GCAt (Right (Const vv)) (Right (Right (vl@(Const nl,_)))) (Left vp) -> withArray (map fromIntegral $ buildListConst vl) $ \ll -> c_gecode_col_at_lst_cv ptr (fromIntegral nl) ll vp $ fromIntegral vv+ GCAt (Left vr) (Left vc) (Right (Const vp)) -> do+ ip <- newIntAt s vc $ fromInteger vp+ c_gecode_int_rel ptr ip (mapGOperator GOEqual) vr+ GCAt (Right (Const vr)) (Left vc) (Right (Const vp)) -> do+ ip <- newIntAt s vc $ fromInteger vp+ c_gecode_int_value ptr ip $ fromInteger vr+ GCDom vi (Left vc) Nothing -> c_gecode_col_dom ptr vi vc+ GCDom vi (Right (Left vl)) Nothing -> withArray (map fromIntegral vl) $ \ll -> c_gecode_int_dom_list ptr vi (fromIntegral $ length vl) ll (toCGBoolVar $ -1)+ GCDom vi (Right (Left vl)) (Just vb) -> withArray (map fromIntegral vl) $ \ll -> c_gecode_int_dom_list ptr vi (fromIntegral $ length vl) ll vb+ GCChannel vi vb -> c_gecode_bool_channel ptr vb vi+ GCCat vr v1 v2 -> c_gecode_col_cat ptr v1 v2 vr+ GCAnd [v1,v2] vr -> c_gecode_bool_and ptr v1 v2 vr+ GCOr [v1,v2] vr -> c_gecode_bool_or ptr v1 v2 vr+ GCAnd l r -> withArray l $ \ll -> c_gecode_bool_all ptr (fromIntegral $ length l) ll r+ GCOr l r -> withArray l $ \ll -> c_gecode_bool_any ptr (fromIntegral $ length l) ll r+ GCNot vr v -> c_gecode_bool_not ptr v vr+ GCEquiv vr v1 v2 -> c_gecode_bool_equiv ptr v1 v2 vr+ GCSorted (Left vc) o -> c_gecode_col_sorted ptr vc (mapGOperator o)+ GCAllDiff b (Left vc) -> c_gecode_col_alldiff ptr vc (toCGBool b)+ GCCount col (Left val) rel (Left cnt) -> c_gecode_col_count ptr col 0 val (mapGOperator rel) 0 cnt+ GCCount col (Right (Const val)) rel (Left cnt) -> c_gecode_col_count_c1 ptr col 1 (fromIntegral val) (mapGOperator rel) 0 cnt+ GCCount col (Left val) rel (Right (Const cnt)) -> c_gecode_col_count_c2 ptr col 0 val (mapGOperator rel) 1 (fromIntegral cnt)+ GCCount col (Right (Const val)) rel (Right (Const cnt)) -> c_gecode_col_count_c12 ptr col 0 (fromIntegral val) (mapGOperator rel) 1 (fromIntegral cnt)+ _ -> error $ "Unsupported constraint: " ++ (show c)++data IntInfo = IntInfo { iti_low :: !CInt, iti_high :: !CInt, iti_med :: !CInt, iti_size :: !CInt, iti_val :: !(Maybe CInt) }++getIntInfo :: Space -> CGIntVar -> IO (Maybe IntInfo)+getIntInfo s i =+ allocaBytes (5*sizeOf (undefined::CGVal)) $ \p -> do+ withForeignPtr s $ \ptr -> c_gecode_int_info ptr i p+ vSize <- peekElemOff p 3+ if vSize==0+ then return Nothing+ else do+ vLow <- peekElemOff p 0+ vHigh <- peekElemOff p 1+ vMed <- peekElemOff p 2+ vVal <- peekElemOff p 4+ return $ Just $ IntInfo {+ iti_low = fromCGVal vLow,+ iti_high = fromCGVal vHigh,+ iti_med = fromCGVal vMed,+ iti_size = fromCGVal vSize,+ iti_val = if (vSize==1) then Just (fromCGVal vVal) else Nothing + }++getBoolInfo :: Space -> CGBoolVar -> IO Int+getBoolInfo s i = do+ alloca $ \inf -> do + withForeignPtr s $ \ptr -> c_gecode_bool_info ptr i inf+ r <- peek inf+ return $ fromIntegral r++getColSize :: Space -> CGColVar -> IO GecodeIntConst+getColSize s v = do+ val <- withForeignPtr s $ \ptr -> c_gecode_col_getsize ptr v+ return $ toConst val+ #endif
+ Control/CP/FD/Gecode/Runtime.hs view
@@ -0,0 +1,158 @@+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE CPP #-}++module Control.CP.FD.Gecode.Runtime (+ RuntimeGecodeSolver+) where++import Control.Monad.State.Lazy+import System.IO.Unsafe++import Data.Map (Map)+import qualified Data.Map as Map++import Control.Mixin.Mixin+import Data.Linear++import Control.CP.Debug+import Control.CP.Solver+import Control.CP.EnumTerm+import Control.CP.FD.FD+import Data.Expr.Sugar+import Control.CP.FD.Model+import Control.CP.FD.Gecode.Common++import qualified Control.CP.FD.Gecode.Interface as GCI++-- ################################## RuntimeGecodeSolver #########################################++newtype RuntimeGecodeState = RuntimeGecodeState {+ spaceRef :: GCI.Space+}++newtype RuntimeGecodeSolver a = RuntimeGecodeSolver { rgsStateT :: StateT RuntimeGecodeState IO a }+ deriving (Monad, MonadState RuntimeGecodeState, MonadIO)++newState :: IO RuntimeGecodeState+newState = do+ initSpace <- GCI.newSpace+ return $ RuntimeGecodeState { + spaceRef = initSpace+ }++liftRGS :: (GCI.Space -> IO a) -> RuntimeGecodeSolver a+liftRGS f = do+ RuntimeGecodeState { spaceRef = s } <- get+ liftIO $ f s++runRuntimeGecodeSolver :: RuntimeGecodeSolver a -> (a, RuntimeGecodeState)+runRuntimeGecodeSolver p = unsafePerformIO $ do+ initState <- newState+ runStateT (rgsStateT p) initState++continueRuntimeGecodeSolver :: RuntimeGecodeState -> RuntimeGecodeSolver a -> (a, RuntimeGecodeState)+continueRuntimeGecodeSolver st p = unsafePerformIO $ runStateT (rgsStateT p) st++propagate :: RuntimeGecodeSolver ()+propagate = liftRGS GCI.propagate++intInfo v = liftRGS $ \s -> GCI.getIntInfo s v++boolInfo v = liftRGS $ \s -> GCI.getBoolInfo s v++--------------------------------- Solver Instance ------------------------------------------++instance Solver RuntimeGecodeSolver where+ type Constraint RuntimeGecodeSolver = GecodeConstraint RuntimeGecodeSolver+ type Label RuntimeGecodeSolver = GCI.Space+ run = fst . runRuntimeGecodeSolver+ mark = do+ s <- get+ let ref = spaceRef s+ x <- liftIO $ GCI.copySpace ref+ liftIO $ GCI.modRefcount x (500000000)+ return x+ markn i = do+ s <- get+ let ref = spaceRef s+ liftIO $ GCI.modRefcount ref i+ return ref+ goto ref = do+ s <- get+ fc <- liftIO $ GCI.modRefcount ref (-1)+ if fc==0+ then put s { spaceRef = ref }+ else do+ x <- liftIO $ GCI.copySpace ref+ put s { spaceRef = x }+ add = mixin (addMeta <@> addRGS)++addRGS _ _ c = do+ debug ("addrgs: "++(show c)) $ return ()+ liftRGS $ \s -> GCI.addConstraint s c++instance Term RuntimeGecodeSolver GCI.CGIntVar where+ newvar = liftRGS GCI.newInt+ type Help RuntimeGecodeSolver GCI.CGIntVar = ()+ help _ _ = ()++instance Term RuntimeGecodeSolver GCI.CGBoolVar where+ newvar = liftRGS GCI.newBool+ type Help RuntimeGecodeSolver GCI.CGBoolVar = ()+ help _ _ = ()++------------------------------- GecodeSolver instance --------------------------------------++instance GecodeSolver RuntimeGecodeSolver where+ type GecodeIntVar RuntimeGecodeSolver = GCI.CGIntVar+ type GecodeBoolVar RuntimeGecodeSolver = GCI.CGBoolVar+ type GecodeColVar RuntimeGecodeSolver = GCI.CGColVar+ newInt_at c p = liftRGS $ \s -> GCI.newIntAt s c (fromIntegral p)+ newCol_list l = liftRGS $ \s -> GCI.newColList s l+ newCol_size l = liftRGS $ \s -> GCI.newColSize s (fromIntegral l)+ newCol_cat c1 c2 = liftRGS $ \s -> GCI.newColCat s c1 c2+ col_getSize c = liftRGS $ \s -> GCI.getColSize s c+ splitBoolDomain v = return ([GCBoolVal v $ toBoolExpr False,GCBoolVal v $ toBoolExpr True],True)+ splitIntDomain m = do+ Just info <- intInfo m+ let split = toExpr $ toInteger $ GCI.iti_med info+ let sp = termToLinear m - constToLinear split+ return ([GCLinear sp GOLessEqual, GCLinear (-sp) GOLess],GCI.iti_high info - GCI.iti_low info < 2)++--------------------------------- EnumTerm instances ---------------------------------------++instance EnumTerm RuntimeGecodeSolver GCI.CGIntVar where+ type TermBaseType RuntimeGecodeSolver GCI.CGIntVar = Integer+ getDomainSize v = do+ s <- get+ info <- intInfo v+ case info of+ Nothing -> return 0+ Just x -> return $ fromInteger $ toInteger $ GCI.iti_size x+ getValue v = do+ s <- get+ Just info <- intInfo v+ case GCI.iti_val info of+ Nothing -> return Nothing+ Just i -> return $ Just $ toInteger i+ getDomain v = error "inspection of full runtime domains is not implemented"+ setValue _ _ = error "settinf of runtime variables is not implemented"++instance EnumTerm RuntimeGecodeSolver GCI.CGBoolVar where+ type TermBaseType RuntimeGecodeSolver GCI.CGBoolVar = Bool+ getDomainSize v = do+ x <- boolInfo v+ return $ case x of+ -2 -> 0+ -1 -> 2+ _ -> 1+ getValue v = do+ x <- boolInfo v+ return $ case x of+ 0 -> Just False+ 1 -> Just True+ _ -> Nothing+ getDomain v = error "inspection of full runtime domains is not implemented"+ setValue _ _ = error "settinf of runtime variables is not implemented"
+ Control/CP/FD/Gecode/RuntimeSearch.hs view
@@ -0,0 +1,226 @@+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE MultiParamTypeClasses #-}++module Control.CP.FD.Gecode.RuntimeSearch (+ SearchGecodeSolver,+ SearchGecodeOptions(..),+ setOptions+) where++import Control.Monad.State.Lazy+import System.IO.Unsafe++import Data.Map (Map)+import qualified Data.Map as Map++import Control.Mixin.Mixin++import Control.CP.Debug+import Control.CP.Solver+import Control.CP.EnumTerm+import Control.CP.SearchTree+import Control.CP.FD.FD+import Data.Expr.Sugar+import Control.CP.FD.Model+import Control.CP.FD.Gecode.Common++import qualified Control.CP.FD.Gecode.Interface as GCI++-- ################################## SearchGecodeSolver #########################################++data SearchGecodeState = SearchGecodeState { spaceRef :: GCI.Space, options :: SearchGecodeOptions }++data SearchGecodeOptions = SearchGecodeOptions { minimizeVar :: Maybe GCI.CGIntVar }++initOptions :: SearchGecodeOptions+initOptions = SearchGecodeOptions {+ minimizeVar = Nothing+}++setOptions :: (SearchGecodeOptions -> SearchGecodeOptions) -> SearchGecodeSolver ()+setOptions f = do+ s <- get+ put $ s { options = f $ options s }++newtype SearchGecodeSolver a = SearchGecodeSolver { sgsStateT :: StateT SearchGecodeState IO a }+ deriving (Monad, MonadState SearchGecodeState, MonadIO)++newState :: IO SearchGecodeState+newState = do+ initSpace <- GCI.newSpace+ return $ SearchGecodeState {+ spaceRef = initSpace,+ options = initOptions+ }++liftSGS :: (GCI.Space -> IO a) -> SearchGecodeSolver a+liftSGS f = do+ SearchGecodeState { spaceRef = s } <- get+ liftIO $ f s++liftSGSo :: (GCI.Space -> SearchGecodeOptions -> IO a) -> SearchGecodeSolver a+liftSGSo f = do+ s <- get+ liftIO $ f (spaceRef s) (options s)++runSearchGecodeSolver :: SearchGecodeSolver a -> (a, SearchGecodeState)+runSearchGecodeSolver p = unsafePerformIO $ do+ initState <- newState+ runStateT (sgsStateT p) initState++continueSearchGecodeSolver :: SearchGecodeState -> SearchGecodeSolver a -> (a, SearchGecodeState)+continueSearchGecodeSolver st p = unsafePerformIO $ runStateT (sgsStateT p) st++-- intTermInfo :: (GecodeIntTerm s) -> s IntTermInfo+-- intTermInfo (IntTermRef (IntVarSingle i)) = do+-- GecodeState { spaceRef = s } <- get+-- liftIO $ do +-- doPropagation s+-- getIntTermInfo s i++propagate :: SearchGecodeSolver ()+propagate = liftSGS GCI.propagate++intInfo v = liftSGS $ \s -> GCI.getIntInfo s v++boolInfo v = liftSGS $ \s -> GCI.getBoolInfo s v++--------------------------------- Solver Instance ------------------------------------------++instance Solver SearchGecodeSolver where+ type Constraint SearchGecodeSolver = GecodeConstraint SearchGecodeSolver+ type Label SearchGecodeSolver = GCI.Space+ run = fst . runSearchGecodeSolver+ mark = do+ s <- get+ let ref = spaceRef s+ x <- liftIO $ GCI.copySpace ref+ liftIO $ GCI.modRefcount x (500000000)+ return x+ markn i = do+ s <- get+ let ref = spaceRef s+ liftIO $ GCI.modRefcount ref i+ return ref+ goto ref = do+ s <- get+ fc <- liftIO $ GCI.modRefcount ref (-1)+ if fc==0+ then put s { spaceRef = ref }+ else do+ x <- liftIO $ GCI.copySpace ref+ put s { spaceRef = x }+ add c = do+ r <- mixin (addMeta <@> addSGS) c+ s <- get+ liftIO $ GCI.propagate (spaceRef s)+ return r++addSGS _ _ c = do+ debug ("addsgs: "++(show c)) $ return ()+ liftSGS $ \s -> GCI.addConstraint s c++instance Term SearchGecodeSolver GCI.CGIntVar where+ newvar = liftSGS GCI.newInt+ type Help SearchGecodeSolver GCI.CGIntVar = ()+ help _ _ = ()++instance Term SearchGecodeSolver GCI.CGBoolVar where+ newvar = liftSGS GCI.newBool+ type Help SearchGecodeSolver GCI.CGBoolVar = ()+ help _ _ = ()++------------------------------- GecodeSolver instance --------------------------------------++instance GecodeSolver SearchGecodeSolver where+ type GecodeIntVar SearchGecodeSolver = GCI.CGIntVar+ type GecodeBoolVar SearchGecodeSolver = GCI.CGBoolVar+ type GecodeColVar SearchGecodeSolver = GCI.CGColVar+ newInt_at c p = liftSGS $ \s -> GCI.newIntAt s c (fromIntegral p)+ newCol_list l = liftSGS $ \s -> GCI.newColList s l+ newCol_size l = liftSGS $ \s -> GCI.newColSize s (fromIntegral l)+ newCol_cat c1 c2 = liftSGS $ \s -> GCI.newColCat s c1 c2+-- newCol_take c p l = liftSGS $ \s -> GCI.newColTake s c (fromIntegral p) (fromIntegral l)+ col_getSize c = liftSGS $ \s -> GCI.getColSize s c+-- splitBoolDomains ((m,_):_) = return [m @= toBoolExpr False, m @= toBoolExpr True]+-- splitIntDomains ((m,f):_) = do+-- info <- intInfo f+-- return [m @< toExpr (1 + (toInteger $ GCI.iti_med info)), m @> toExpr (toInteger $ GCI.iti_med info)]+ splitBoolDomain = error "need to split bool domains?"+ splitIntDomain = error "need to split int domains?"++--------------------------------- EnumTerm instances ---------------------------------------++instance EnumTerm SearchGecodeSolver GCI.CGIntVar where+ type TermBaseType SearchGecodeSolver GCI.CGIntVar = Integer+ getDomainSize v = do+ s <- get+ Just info <- intInfo v+ return $ fromInteger $ toInteger $ GCI.iti_size info+ getValue v = do+ s <- get+ Just info <- intInfo v+ case GCI.iti_val info of+ Nothing -> return Nothing+ Just i -> do+ let ti = toInteger i+ return $ Just ti+ setValue var val = undefined+ getDomain _ = undefined+ enumerator = Just $ \l -> label $ liftSGSo $ \s o -> do+ case minimizeVar o of+ Just x -> do+ GCI.postBranchers s ([],[x],[])+ GCI.postBranchers s ([],l,[])+ GCI.setCost s x+ _ -> GCI.postBranchers s ([],l,[])+ search <- liftIO $ GCI.newSearch s (case minimizeVar o of {Nothing -> False; _ -> True})+ let+ go :: (MonadTree m, TreeSolver m ~ SearchGecodeSolver) => Int -> m ()+ go i = unsafePerformIO $ do+ res <- GCI.runSearch search+ case res of+ Nothing -> return $ false+ Just x -> return $ + (label $ do+ st <- get+ put $ st { spaceRef = x }+ return $ true+ ) \/ (go $ i+1)+ return $ go 0++instance EnumTerm SearchGecodeSolver GCI.CGBoolVar where+ type TermBaseType SearchGecodeSolver GCI.CGBoolVar = Bool+ getDomainSize v = do+ x <- boolInfo v+ return $ case x of+ -2 -> 0+ -1 -> 2+ _ -> 1+ getValue v = do+ x <- boolInfo v+ return $ case x of+ 0 -> Just False+ 1 -> Just True+ _ -> Nothing+ setValue var val = undefined+ getDomain _ = undefined+ enumerator = Just $ \l -> label $ liftSGSo $ \s o -> do+ GCI.postBranchers s (l,[],[])+ case minimizeVar o of+ Just x -> GCI.setCost s x+ _ -> return ()+ search <- liftIO $ GCI.newSearch s (case minimizeVar o of {Nothing -> False; _ -> True})+ let+ go :: (MonadTree m, TreeSolver m ~ SearchGecodeSolver) => Int -> m ()+ go i = unsafePerformIO $ do+ res <- GCI.runSearch search+ case res of+ Nothing -> return $ false+ Just x -> return $ + (label $ do+ goto x+ return $ true+ ) \/ (go $ i+1)+ return $ go 0
− Control/CP/FD/Gecode/RuntimeSolver.hs
@@ -1,291 +0,0 @@-{-# LANGUAGE CPP #-}-{-# LANGUAGE UndecidableInstances #-}-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE GeneralizedNewtypeDeriving #-}-{-# LANGUAGE TypeFamilies #-}-{-# LANGUAGE MultiParamTypeClasses #-}--#ifdef RGECODE--module Control.CP.FD.Gecode.RuntimeSolver (- SearchSolver(..),- RuntimeSolver(..)-) where--import Maybe (fromMaybe,catMaybes,isJust,fromJust)-import List (findIndex,find)-import Data.Map hiding (map,filter)--import Control.Monad.State.Lazy-import Control.Monad.Trans-import Control.Monad.Cont--import Data.Bits-import Data.Word-import Foreign-import Foreign.Storable-import Foreign.Marshal-import Foreign.Marshal.Array-import Foreign.Ptr-import Foreign.ForeignPtr-import Foreign.C.String-import Foreign.C.Types--import Control.CP.SearchTree hiding (label)-import Control.CP.Solver-import Control.CP.FD.FD-import Control.CP.FD.Expr-import Control.CP.Debug-import Control.CP.Mixin-import Control.CP.EnumTerm--import Control.CP.FD.Gecode.Common-import Control.CP.FD.Gecode.Interface--class (Monad s, MonadState (GecodeState s) s, MonadIO s, Term s IntTerm) => RuntimeGecodeSolver s where- stateM :: s a -> StateT (GecodeState s) IO a--instance Solver RuntimeSolver where- type Constraint RuntimeSolver = GConstraint- type Label RuntimeSolver = GecodeState RuntimeSolver- add = addRuntimeGecode- run = fst . runRuntimeGecode False- mark = do- s <- get- copyState s- goto s = do- x <- copyState s- put x--instance Solver SearchSolver where- type Constraint SearchSolver = GConstraint- type Label SearchSolver = GecodeState SearchSolver- add = addRuntimeGecode- run = fst . runRuntimeGecode False- mark = do- s <- get- copyState s- goto s = do- x <- copyState s- put x------------------------------------------------------------------------------------- | Gecode terms-----------------------------------------------------------------------------------instance Term SearchSolver IntTerm where- newvar = newVarInt- type Help SearchSolver IntTerm = ()- help _ _ = ()-instance Term RuntimeSolver IntTerm where- newvar = newVarInt- type Help RuntimeSolver IntTerm = ()- help _ _ = ()-instance Term SearchSolver BoolTerm where- newvar = newVarBool- type Help SearchSolver BoolTerm = ()- help _ _ = ()-instance Term RuntimeSolver BoolTerm where- newvar = newVarBool- type Help RuntimeSolver BoolTerm = ()- help _ _ = ()- ------------------------------------------------------------------------------------- | Gecode monad definition -----------------------------------------------------------------------------------data RuntimeGecodeSolver s => GecodeState s = GecodeState { spaceRef :: Space, cexpr :: Map (ExprKey (FDTerm s)) Int }---newtype RuntimeSolver a = RuntimeSolver { rStateM :: StateT (GecodeState RuntimeSolver) IO a }- deriving (Monad, MonadState (GecodeState RuntimeSolver), MonadIO)-newtype SearchSolver a = SearchSolver { sStateM :: StateT (GecodeState SearchSolver) IO a }- deriving (Monad, MonadState (GecodeState SearchSolver), MonadIO)--newState :: RuntimeGecodeSolver s => Bool -> IO (GecodeState s)-newState gcs = do- initSpace <- newSpace- return $ GecodeState { spaceRef = initSpace, cexpr = Data.Map.empty }--copyState :: RuntimeGecodeSolver s => GecodeState s -> s (GecodeState s)-copyState state = do- x <- liftIO $ copySpace (spaceRef state)- return $ state { spaceRef = x }--runRuntimeGecode :: RuntimeGecodeSolver s => Bool -> s a -> (a, GecodeState s)-runRuntimeGecode gcs p = unsafePerformIO $ do- initState <- newState gcs- runStateT (stateM p) initState--continueRuntimeGecode :: RuntimeGecodeSolver s => GecodeState s -> s a -> (a, GecodeState s)-continueRuntimeGecode st p = unsafePerformIO $ runStateT (stateM p) st--intTermInfo :: RuntimeGecodeSolver s => IntTerm -> s IntTermInfo-intTermInfo (IntVar i) = do- GecodeState { spaceRef = s } <- get- liftIO $ getIntTermInfo s i--addRuntimeGecode :: RuntimeGecodeSolver s => GConstraint -> s Bool-addRuntimeGecode (CDom (IntVar i) low high) = proc $ \ptr -> c_gecode_int_dom ptr (toCGIntVar i) (toCGVal low) (toCGVal high)-addRuntimeGecode (CRel (IntVar i1) op (IntVar i2)) = proc $ \ptr -> c_gecode_int_rel ptr (toCGIntVar i1) (mapGOperator op) (toCGIntVar i2)-addRuntimeGecode (CRel (IntConst c1) op (IntVar i2)) = proc $ \ptr -> c_gecode_int_rel_cf ptr (toCGVal c1) (mapGOperator op) (toCGIntVar i2)-addRuntimeGecode (CRel (IntVar i1) op (IntConst c2)) = proc $ \ptr -> c_gecode_int_rel_cs ptr (toCGIntVar i1) (mapGOperator op) (toCGVal c2)-addRuntimeGecode (CValue (IntVar i) val) = proc $ \ptr -> c_gecode_int_value ptr (toCGIntVar i) (toCGVal val)-addRuntimeGecode (CMult (IntVar i1) (IntVar i2) (IntVar ir)) = proc $ \ptr -> c_gecode_int_mult ptr (toCGIntVar i1) (toCGIntVar i2) (toCGIntVar ir)-addRuntimeGecode (CDiv (IntVar i1) (IntVar i2) (IntVar ir)) = proc $ \ptr -> c_gecode_int_div ptr (toCGIntVar i1) (toCGIntVar i2) (toCGIntVar ir)-addRuntimeGecode (CMod (IntVar i1) (IntVar i2) (IntVar ir)) = proc $ \ptr -> c_gecode_int_mod ptr (toCGIntVar i1) (toCGIntVar i2) (toCGIntVar ir)-addRuntimeGecode (CAbs (IntVar i) (IntVar ir)) = proc $ \ptr -> c_gecode_int_abs ptr (toCGIntVar i) (toCGIntVar ir)-addRuntimeGecode (CLinear l op val) = do- GecodeState { spaceRef = s } <- get- let len = length l- let vars = map (\(IntVar var,_) -> toCGIntVar var) l- let coefs = map (\(_,coef) -> toCGVal coef) l- liftIO $ - withArray vars $ \pVars ->- withArray coefs $ \pCoefs -> do- b <- withForeignPtr s $ \ptr -> c_gecode_int_linear ptr (fromIntegral len) pVars pCoefs (mapGOperator op) (toCGVal val)- return $ fromCGBool b-addRuntimeGecode (CAllDiff l) = do- GecodeState { spaceRef = s } <- get- let len = length l- let vars = map (\(IntVar i) -> toCGIntVar i) l- liftIO $- withArray vars $ \pVars -> do- b <- withForeignPtr s $ \ptr -> c_gecode_int_alldiff ptr (fromIntegral len) pVars- return $ fromCGBool b-addRuntimeGecode (CSorted l strict) = do- GecodeState { spaceRef = s } <- get- let len = length l- let vars = map (\(IntVar i) -> toCGIntVar i) l- liftIO $- withArray vars $ \pVars -> do- b <- withForeignPtr s $ \ptr -> c_gecode_int_sorted ptr (fromIntegral len) pVars (toCGBool strict)- return $ fromCGBool b--proc f = do- GecodeState { spaceRef = s } <- get- liftIO $ do- b <- withForeignPtr s f- return $ fromCGBool b------------------------------------------------------------------------------------- | RuntimeSolver solver implementation-----------------------------------------------------------------------------------newVarInt :: RuntimeGecodeSolver s => s IntTerm-newVarInt = do- GecodeState { spaceRef = s } <- get- (CGIntVar r) <- liftIO $ withForeignPtr s $ c_gecode_int_newvar - return (IntVar $ fromIntegral r)--newVarBool :: RuntimeGecodeSolver s => s BoolTerm-newVarBool = do- GecodeState { spaceRef = s } <- get- (CGBoolVar r) <- liftIO $ withForeignPtr s $ c_gecode_bool_newvar- return (BoolVar $ fromIntegral r)------------------------------------------------------------------------------------- | RuntimeSolver FDSolver instance-----------------------------------------------------------------------------------instance (RuntimeGecodeSolver s, Ord (FDTerm s)) => GecodeSolver s where- caching_decompose super this x = Label $ do- s <- get- let wx = ExprKey x- case Data.Map.lookup wx (cexpr s) of- Nothing -> return $ do- n@(IntVar i) <- super x- Label $ do- s <- get- put $ s { cexpr = insert wx i $ cexpr s }- return $ return n- Just i -> return $ return $ IntVar i- setVarImplicit (IntVar i) b = return ()--instance FDSolver RuntimeSolver where- type FDTerm RuntimeSolver = IntTerm- specific_compile_constraint = linearCompile <@> basicCompile- specific_decompose = caching_decompose- specific_fresh_var super this = do- v@(IntVar i) <- super- Label $ do- setVarImplicit (IntVar i) True- return $ Return v--instance FDSolver SearchSolver where- type FDTerm SearchSolver = IntTerm- specific_compile_constraint = linearCompile <@> basicCompile- specific_decompose = caching_decompose- specific_fresh_var super this = do- v@(IntVar i) <- super- Label $ do- setVarImplicit (IntVar i) True- return $ Return v---instance EnumTerm RuntimeSolver IntTerm where- type TermDomain RuntimeSolver IntTerm = CInt- get_domain_size v = do- IntTermInfo { iti_size = size } <- intTermInfo v- return $ fromIntegral size- get_value v = do- IntTermInfo { iti_val = val } <- intTermInfo v- return val- split_domain_partial v@(IntVar it) = do- IntTermInfo { iti_val = val, iti_med = med, iti_size = size } <- intTermInfo v- return $ if size == 0- then []- else if isJust val- then [return ()]- else [Add (CRel v OLess (IntConst $ (fromIntegral med)+1)) $ enumerate [v],Add (CRel (IntConst $ fromIntegral med) OLess v) $ enumerate [v]]---instance EnumTerm SearchSolver IntTerm where- type TermDomain SearchSolver IntTerm = CInt- get_domain_size v = do- IntTermInfo { iti_size = size } <- intTermInfo v- return $ fromIntegral size- get_value v = do- IntTermInfo { iti_val = val } <- intTermInfo v- return val- - split_domains lst = do- let - folder a b = case a of- IntVar i -> (i:b)- _ -> b- let vars = map toCGIntVar $ foldr folder [] lst- state <- get- liftIO $ withArray vars $ \ptr -> withForeignPtr (spaceRef state) $ \sptr -> c_gecode_int_branch sptr (fromIntegral $ length vars) ptr- search <- liftIO $ newSearch $ spaceRef state- let - go i = unsafePerformIO $ do- res <- runSearch search- case res of- Nothing -> return $ return ()- Just x -> return $ Try (Label $ do- put state { spaceRef = x }- return $ return ()- ) (go $ i+1)- return $ go 0-- split_domain_partial v = do- x <- split_domains [v]- return [x]-- label _ = Label . split_domains- enumerate = Label . split_domains-------------------------------------------------- | RuntimeGecodeSolver instances------------------------------------------------instance RuntimeGecodeSolver RuntimeSolver where- stateM = rStateM--instance RuntimeGecodeSolver SearchSolver where- stateM = sStateM--#endif
− Control/CP/FD/Gecode/Translate.hs
@@ -1,203 +0,0 @@--- optimalisaties: zie http://www.cs.mu.oz.au/~pjs/papers/padl2008.pdf--- zie ook http://www.cs.mu.oz.au/~pjs/papers/constraints08b.pdf--- mcp paper: http://www.cs.kuleuven.be/~toms/Research/papers/monadic_cp_draft.pdf--module Control.CP.FD.Gecode.Translate (- generate_gecode-) where--import Maybe (fromJust,isNothing,isJust)-import List (findIndex)-import Data.Map (elems,Map,lookup)--import Control.CP.FD.Gecode.CodegenSolver-import Control.CP.FD.Gecode.Common-import Control.CP.Solver------------------------------------------------------------------------------------- Main compilation function-----------------------------------------------------------------------------------generate_gecode = stateToProg . compile--- generate_gecode = show . compile------------------------------------------------------------------------------------- Implementation-----------------------------------------------------------------------------------countTypeVars :: Store -> GType -> Int -> Int-countTypeVars s t u = foldl (+) 0 $ map (\x -> 1) $ filter (\x -> (u<0 || x<u) && (t == getVarType s x)) $ varsUsed (ctree s) []---maxDepth :: StoreNode -> Int-maxDepth (StoreNode { cons=_, dis=SNLeaf}) = 1-maxDepth (StoreNode { cons=_, dis=SNIntl l r }) = 1 + (maxDepth l `max` maxDepth r)--typeList = [TypeBool, TypeInt]--varsUsed :: StoreNode -> [ Bool ] -> [ Int ]-varsUsed node path = (nvars node) ++ case (dis node,path) of- (SNLeaf,_) -> []- (SNIntl l _,[]) -> (varsUsed l [])- (SNIntl l _,False:o) -> varsUsed l o- (SNIntl _ r,True:o) -> varsUsed r o--typeToString :: GType -> String-typeToString TypeInt = "IntVar"-typeToString TypeBool = "BoolVar"--typeToDefArgs :: GType -> (String,String)-typeToDefArgs TypeInt = ("-1000000000","1000000000")-typeToDefArgs TypeBool = ("0","1")--getVarName :: Store -> String -> Int -> String-getVarName s pre i = pre ++ "bb" ++ (typeToString $ getVarType s i) ++ "[" ++ (show $ countTypeVars s (getVarType s i) i) ++ "]"--getName :: GTerm t => Store -> String -> t -> String-getName s pre v = case (getVarId v) of- Nothing -> case (getIntValue v) of- Nothing -> error "oei"- Just n -> show n- Just i -> getVarName s pre i--stateToExplList :: Store -> [ (String,String,String) ]-stateToExplList s = map (fm) $ filter (\x -> not $ isVarImplicit s x) $ [0..((vars s)-1)]- where fm i = (typeToString $ getVarType s i,"v"++(show i),getVarName s "" i)--stateToConstList :: Store -> Map Int VarBound -> [ String ]-stateToConstList s b = map fm $ elems $ b- where fm (VarBound i l u) = (getVarName s "" i) ++ "(*this," ++ (if isJust l then show $ fromJust l else defl) ++ "," ++ (if isJust u then show $ fromJust u else defu) ++ ")"- where (defl,defu) = typeToDefArgs $ getVarType s i--gopToGCRel :: GOperator -> String-gopToGCRel OEqual = "IRT_EQ"-gopToGCRel ODiff = "IRT_NQ"-gopToGCRel OLess = "IRT_LE"--gopToInvGCRel :: GOperator -> String-gopToInvGCRel OEqual = "IRT_EQ"-gopToInvGCRel ODiff = "IRT_NQ"-gopToInvGCRel OLess = "IRT_GR"--stateToPostList :: Store -> [ GConstraint ] -> [ String ]-stateToPostList s c = map fm $ reverse $ c- where fm (CRel t1 o t2) = "rel(home," ++ (gn t1) ++ "," ++ (gopToGCRel o) ++ "," ++ (gn t2) ++ ")"- fm (CMult t1 t2 t3) = "mult(home," ++ (gn t1) ++ "," ++ (gn t2) ++ "," ++ (gn t3) ++ ")"- fm (CDiv t1 t2 t3) = "div(home," ++ (gn t1) ++ "," ++ (gn t2) ++ "," ++ (gn t3) ++ ")"- fm (CMod t1 t2 t3) = "mod(home," ++ (gn t1) ++ "," ++ (gn t2) ++ "," ++ (gn t3) ++ ")"- fm (CAbs t1 t2) = "abs(home," ++ (gn t1) ++ "," ++ (gn t2) ++ ")"- fm (CDom t l u) = "dom(home," ++ (gn t) ++ "," ++ (show l) ++ "," ++ (show u) ++ ")"- fm (CValue t v) = "rel(home," ++ (gn t) ++ ",IRT_EQ," ++ (show v) ++ ")"- fm (CLinear l o c) = case (c,l) of- (0,[(v1,a),(v2,b)]) | a+b==0 && a>0 -> "rel(home," ++ (gn v1) ++ "," ++ (gopToGCRel o) ++ "," ++ (gn v2) ++ ")"- (0,[(v1,a),(v2,b)]) | a+b==0 && a<0 -> "rel(home," ++ (gn v1) ++ "," ++ (gopToInvGCRel o) ++ "," ++ (gn v2) ++ ")"- (_,[(v1,a)]) | a>0 && ((c `mod` a)==0) -> "rel(home," ++ (gn v1) ++ "," ++ (gopToGCRel o) ++ "," ++ (show (c `div` a)) ++ ")"- (_,[(v1,a)]) | a<0 && ((c `mod` (-a))==0) -> "rel(home," ++ (gn v1) ++ "," ++ (gopToInvGCRel o) ++ "," ++ (show (c `div` a)) ++ ")"- (_,l) | all (\(_,a) -> a==1) l -> case unzip l of- (x,a) -> "{ " ++ (bl "iva" x) ++ " linear(home,iva," ++ (gopToGCRel o) ++ "," ++ (show c) ++ "); }"- _ -> case unzip l of- (x,a) -> "{ IntArgs ia(" ++ (show $ length a) ++ (foldl (\x y -> x ++ "," ++ (show y)) "" a) ++ "); "++(bl "iva" x) ++ " linear(home,ia,iva," ++ (gopToGCRel o) ++ "," ++ (show c) ++ "); }"- fm (CAllDiff l) = "{ " ++ (bl "ia" l) ++ "; distinct(home,ia); }"- fm (CSorted l e) = "{ " ++ (bl "ia" l) ++ "; rel(home,ia,"++(if e then "IRT_LQ" else "IRT_LE")++"); }"- gn t = getName s "p->" t- bl n l = "IntVarArgs "++n++"(" ++ (show $ length l) ++ "); " ++ (foldl (++) "" (map (\i -> n++"[" ++ (show i) ++ "]=" ++ (getVarName s "p->" $ fromJust $ getVarId $ l !! i) ++ "; ") [0..(length l)-1]))--stateToBranchList :: Store -> GType -> [ String ]-stateToBranchList s t = map fm $ filter ff $ [0..((vars s)-1)]- where ff i = (not $ isVarImplicit s i) && (t == getVarType s i)- fm i = getVarName s "" i--stateToBranchCode s t = " " ++ tn ++ "Args b" ++ tn ++ "(" ++ (show (length vars)) ++ ");\n" ++ (- foldl (\x y -> x ++ " b" ++ tn ++ "[" ++ (show y) ++ "]=" ++ (vars !! y) ++ ";\n") "" [0..(length vars)-1]) ++- " branch(*this, b"++tn++", INT_VAR_SIZE_MIN, INT_VAL_SPLIT_MIN);\n"- where tn = typeToString t- vars = stateToBranchList s t--stateToBranches s = foldl (++) [] $ map (stateToBranchCode s) typeList---- countExplicits :: Store -> GType -> Int--- countExplicits s t = foldl (+) 0 $ map (\x -> if isVarImplicit s x then 0 else 1) $ filter (\x -> t == getVarType s x) $ varsUsed (ctree s) []--nodeToProg :: Store -> Map Int VarBound -> StoreNode -> [ Bool ] -> String-nodeToProg store bnds node path = - " static void node" ++ pathS ++ "(Space &home) {\n" ++- " /* varsused" ++ (show vrs) ++ "*/\n" ++- " HaskellProg *p = (HaskellProg *)(&home);\n" ++- (foldl (\x y -> x ++ " " ++ y ++ ";\n") "" $ map (\x -> (getVarName store "p->" x)++".init(home,"++(lowest x)++","++(highest x)++")") $ nvars node) ++- (foldl (\x y -> x ++ " " ++ y ++ ";\n") "" $ stateToPostList store $ cons node) ++- (case dis node of - SNLeaf -> (foldl (++) "" $ map (\x -> " rel(home,p->i["++(show x)++"],IRT_EQ,0);\n") [(length path)..(maxDepth $ ctree store)-2]) ++ - (foldl (++) "" $ map (\x -> " rel(home," ++ (getVarName store "p->" x) ++ ",IRT_EQ,"++(lowest x)++");\n") $ filter (\x -> isNothing $ findIndex (== x) vrs) [0..(vars store)-1])- SNIntl _ _ -> " when(home,p->i[" ++ lenS ++ "],&node"++pathS++"R,&node"++pathS++"L);\n"- ) ++- " }\n" ++- (case (dis node) of- SNLeaf -> ""- SNIntl l r -> nodeToProg store bnds l (path ++ [ False ]) ++ nodeToProg store bnds r (path ++ [ True ])- )- where pathS = foldl (++) "" $ map (\x -> if x then "R" else "L") path- lenS = show $ length path- vrs = varsUsed (ctree store) path- lowest i = case Data.Map.lookup i bnds of- Nothing -> case typeToDefArgs $ getVarType store i of- (x,_) -> x- Just (VarBound _ Nothing _) -> case typeToDefArgs $ getVarType store i of- (x,_) -> x- Just (VarBound _ (Just l) _) -> show l- highest i = case Data.Map.lookup i bnds of- Nothing -> case typeToDefArgs $ getVarType store i of- (_,x) -> x- Just (VarBound _ _ Nothing) -> case typeToDefArgs $ getVarType store i of- (_,x) -> x- Just (VarBound _ _ (Just l)) -> show l- --stateToProg :: Store -> String-stateToProg s = - "#include \"gecode/kernel.hh\"\n"++- "#include \"gecode/support.hh\"\n"++ - "#include \"gecode/int.hh\"\n"++- "#include \"gecode/search.hh\"\n"++- "#include \"gecode/minimodel.hh\"\n"++- "\n"++- "using namespace Gecode;\n"++- "\n"++- "class HaskellProg : public Space {\n"++- "protected:\n"++--- (foldl (\x (y1,y2) -> x ++ " " ++ y1 ++ " " ++ y2 ++ ";\n") "" (stateToDefList s)) ++ - " BoolVarArray i;\n\n"++- (foldl (++) "" $ map (\x -> " " ++ (typeToString x) ++ "Array bb" ++ (typeToString x) ++ ";\n") typeList) ++- "public:\n"++- " HaskellProg() : " ++ - (foldl (\x y -> (if x=="" then "" else x ++ ", ") ++ y) "" $ map (\x -> "bb" ++ typeToString x ++ "(*this," ++ (show $ countTypeVars s x (-1)) ++ ")") typeList) ++ - ", i(*this,"++(show $ (maxDepth (ctree s)) - 1)++",0,1) {\n"++- " node(*this);\n"++- " branch(*this, i, INT_VAR_SIZE_MIN, INT_VAL_MIN);\n" ++ stateToBranches s ++- " };\n"++- " virtual void print(std::ostream& os) {\n"++- (foldl (\x (vType,vName,vExpr) -> x ++ " os << \"" ++ vName ++ ": \" << " ++ vExpr ++ " << std::endl;\n") "" (stateToExplList s)) ++- " }\n"++- " HaskellProg(bool share, HaskellProg &s) : Space(share,s) {\n"++--- (foldl (\x (vType,vName,vExpr) -> x ++ " " ++ vExpr ++ ".update(*this, share, s." ++ vExpr ++ ");\n") "" (stateToExplList s)) ++- " i.update(*this,share,s.i);\n" ++- (foldl (\x y -> x ++ " " ++ y ++ ";\n") "" $ map (\x -> "bb" ++ (typeToString x) ++ ".update(*this,share,s.bb"++(typeToString x)++")") typeList) ++- " }\n"++- " virtual Space* copy(bool share) {\n"++- " return new HaskellProg(share, *this);\n"++- " }\n"++- nodeToProg s bounds (ctree s) [] ++- "};\n"++- "\n"++- "int main(void) {\n"++- " HaskellProg *prog=new HaskellProg();\n"++- " DFS<HaskellProg> srch(prog);\n"++- " delete prog;\n"++- " do {\n"++- " HaskellProg *sol=srch.next();\n"++- " if (sol==NULL) break;\n"++- " sol->print(std::cout);\n"++- " } while(0);\n"++- " return 0;\n"++- "}\n"- where bounds = getAllBounds s- vrs = varsUsed (ctree s) []
+ Control/CP/FD/Graph.hs view
@@ -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
+ Control/CP/FD/Interface.hs view
@@ -0,0 +1,222 @@+{-# 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 hiding (allDiff)+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 ()++type MModel s = Either Model (Constraint s)++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 = 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, 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, 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
+ Control/CP/FD/Model.hs view
@@ -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
Control/CP/FD/OvertonFD/Domain.hs view
@@ -34,7 +34,8 @@ findMin, size, shiftDomain,- mapDomain+ mapDomain,+ absDomain ) where import qualified Data.IntSet as IntSet@@ -44,7 +45,7 @@ data Domain = Set IntSet- | Range Int Int+ | Range !Int !Int deriving Show size :: Domain -> Int@@ -68,7 +69,7 @@ toDomain (a, b) = Range (fromIntegral a) (fromIntegral b) instance ToDomain () where- toDomain () = Range (-10000) 10000 -- minBound maxBound (too sensitive to overflow, e.g. 2 * minBound == 0)+ 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)@@ -136,7 +137,7 @@ null (x@(Range xl xh)) = debug ("[Domain.null] " ++ printDom x) $ xl > xh singleton :: Int -> Domain-singleton x = Set (IntSet.singleton x)+singleton x = Range x x isSingleton :: Domain -> Bool isSingleton (x@(Set xs)) = debugDom "[Domain.isSingleton]" x $ (IntSet.size xs)==1@@ -167,6 +168,16 @@ 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) ++ ")"
Control/CP/FD/OvertonFD/OvertonFD.hs view
@@ -21,6 +21,7 @@ fd_domain, FDVar, OConstraint(..),+ lookup, ) where import Prelude hiding (lookup)@@ -32,10 +33,10 @@ import Control.Monad (liftM,(<=<)) import Control.CP.FD.OvertonFD.Domain as Domain-import Control.CP.FD.FD-import Control.CP.EnumTerm+import Control.CP.FD.FD hiding ((!)) import Control.CP.Solver import Control.CP.SearchTree+import Control.CP.EnumTerm import Control.CP.Debug @@ -48,16 +49,18 @@ | 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 = addFD c- run p = runFD p+ add c = debug ("addOverton("++(show c)++")") $ addOverton c+ run p = debug ("runOverton") $ runOverton p mark = get goto = put @@ -67,33 +70,23 @@ help _ _ = () instance EnumTerm OvertonFD FDVar where- type TermDomain OvertonFD FDVar = Int- get_domain_size v = do- dom <- debug "get_domain_size:fd_domain" $ fd_domain v- return $ length dom- split_domain_partial v = do- dom <- debug "split_domain:fd_domain" $ fd_domain v- case dom of- [] -> return [ return () ]- _ -> return [ addC $ v `OHasValue` c | c <- dom ]- get_value v = do- x <- debug "get_value:fd_domain" $ fd_domain v- case x of- [val] -> return $ Just val- _ -> return Nothing+ type TermBaseType OvertonFD FDVar = Int+ getDomain = fd_domain+ setValue var val = return [var `OHasValue` val] -------------------------------------------------------------------------------- -- Constraints ----------------------------------------------------------------- -------------------------------------------------------------------------------- -addFD (OHasValue v i) = v `hasValue` i-addFD (OSame a b) = a `same` b-addFD (ODiff a b) = a `different` b-addFD (OLess a b) = a .<. b-addFD (OAdd a b c) = addSum a b c-addFD (OSub a b c) = addSub a b c-addFD (OMult a b c) = addMult a b c-addFD (OAbs a b) = addAbs a b+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@@ -107,8 +100,8 @@ -------------------------------------------------------------------------------- -- The FD monad-newtype OvertonFD a = OvertonFD { unFD :: StateT FDState Maybe a }- deriving (Monad, MonadState FDState, MonadPlus)+newtype OvertonFD a = OvertonFD { unFD :: State FDState a }+ deriving (Monad, MonadState FDState) -- FD variables newtype FDVar = FDVar { unFDVar :: Int } deriving (Ord, Eq, Show)@@ -140,9 +133,10 @@ consistentFD = return True -- Run the FD monad and produce a lazy list of possible solutions.-runFD :: OvertonFD a -> a-runFD fd = fromJust $ evalStateT (unFD fd') initState- where fd' = fd -- fd' = newVar () >> fd+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 }@@ -267,6 +261,21 @@ 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.@@ -352,7 +361,7 @@ addMult = addArithmeticConstraint getDomainMult getDomainDiv getDomainDiv -addAbs = addUnaryArithmeticConstraint (\x -> mapDomain x (\i -> [abs i])) (\z -> mapDomain z (\i -> [i,-i]))+addAbs = addUnaryArithmeticConstraint absDomain (\z -> mapDomain z (\i -> [i,-i])) getDomainPlus :: Domain -> Domain -> Domain getDomainPlus xs ys = toDomain (zl, zh) where
Control/CP/FD/OvertonFD/Sugar.hs view
@@ -1,116 +1,112 @@-{- - - Monadic Constraint Programming- - http://www.cs.kuleuven.be/~toms/Haskell/- - Tom Schrijvers- -}-{-# LANGUAGE Rank2Types #-} {-# LANGUAGE TypeFamilies #-} module Control.CP.FD.OvertonFD.Sugar (- newBound,- newBoundBis,- restart,- restartOpt,-) where +) where -import Control.CP.SearchTree hiding (label)-import Control.CP.Transformers-import Control.CP.ComposableTransformers-import Control.CP.Queue-import Control.CP.Solver+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.Expr-import Control.CP.EnumTerm-import Control.CP.Mixin--import qualified Control.CP.PriorityQueue as PriorityQueue-import qualified Data.Sequence+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 -newBound :: NewBound OvertonFD-newBound = do obj <- fd_objective- (val:_) <- fd_domain obj - l <- mark- return ((\tree -> tree `insertTree` (obj @@< val)) :: forall b . Tree OvertonFD b -> Tree OvertonFD b)+newVars :: Term s t => Int -> s [t]+newVars 0 = return []+newVars n = do+ l <- newVars $ n-1+ n <- newvar+ return $ n:l -newBoundBis :: NewBound OvertonFD -newBoundBis = do obj <- fd_objective- (val:_) <- fd_domain obj - let m = val `div` 2- return ((\tree -> (obj @@< (m + 1) \/ ( obj @@> m /\ obj @@< val)) /\ tree) :: forall b . Tree OvertonFD b -> Tree OvertonFD b)+instance FDSolver OvertonFD where+ type FDIntTerm OvertonFD = FDVar+ type FDBoolTerm OvertonFD = FDVar -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)+ type FDIntSpec OvertonFD = FDVar+ type FDBoolSpec OvertonFD = FDVar+ type FDColSpec OvertonFD = [FDVar]+ + type FDIntSpecType OvertonFD = ()+ type FDBoolSpecType OvertonFD = ()+ type FDColSpecType OvertonFD = () -restartOpt :: (Queue q, CTransformer c, CForSolver c ~ OvertonFD,- Elem q ~ (Label OvertonFD,Tree OvertonFD (CForResult c),CTreeState c)) - => q -> [c] -> Tree OvertonFD (CForResult c) -> (Int,[CForResult c])-restartOpt q cs model = run $ eval model q (RestartST (map Seal cs) opt)- where opt tree = newBound >>= \f -> return (f tree)+ 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) ------------------------------------------------------------------------------------ SYNTACTIC SUGAR---------------------------------------------------------------------------------+ fdColSpec_list l = ((),return l)+ fdColSpec_size (Const s) = ((),newVars $ fromInteger s)+ fdColSpec_const l = ((),error "constant collections not yet supported by overton interface") -in_domain v (l,u) = Add (Dom (Term v) l u) true+ fdColInspect = return -(@@<) :: FDVar -> Int -> Tree OvertonFD ()-v @@< i = (compile_constraint $ Less (Term v) (Const $ toInteger i)) /\ return ()+ fdSpecify = specify <@> simple_fdSpecify+ fdProcess = process <@> simple_fdProcess -(@@>) :: FDVar -> Int -> Tree OvertonFD ()-v @@> i = (compile_constraint $ Less (Const $ toInteger i) (Term v)) /\ return ()+ 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 ------------------------------------------------------------------------------------ FD SUGAR---------------------------------------------------------------------------------+ 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) -instance FDSolver OvertonFD where- type FDTerm OvertonFD = FDVar- specific_compile_constraint = convert+-- processBinary :: (EGVarId,EGVarId,EGVarId) -> (FDVar -> FDVar -> FDVar -> OConstraint) -> FDInstance OvertonFD ()+processBinary (v1,v2,va) f = addFD $ f (getDefIntSpec v1) (getDefIntSpec v2) (getDefIntSpec va) --- convert :: Mixin (FDConstraint OvertonFD -> Tree OvertonFD Bool)-convert s t (Same a (Const i)) = debug "convert (Same a (Const i))" $ do- va <- decompose a- addT $ OHasValue va $ fromInteger i-convert s t (Same (Const i) a) = debug "convert (Same (Const i) a)" $ do- va <- decompose a- addT $ OHasValue va $ fromInteger i-convert s t (Same (Plus a b) c) = debug "convert (Same (Plus a b) c)" $ do- va <- decompose a- vb <- decompose b- vc <- decompose c- addT $ OAdd va vb vc-convert s t (Same (Minus a b) c) = debug "convert (Same (Minus a b) c)" $ do- va <- decompose a- vb <- decompose b- vc <- decompose c- addT $ OSub va vb vc-convert s t (Same (Mult a b) c) = debug "convert (Same (Mult a b) c)" $ do- va <- decompose a- vb <- decompose b- vc <- decompose c- addT $ OMult va vb vc-convert s t (Same (Abs a) c) = debug "convert (Same (Abs a) c)" $ do- va <- decompose a- vc <- decompose c- addT $ OAbs va vc-convert s t (Same a b@(Plus _ _)) = debug "convert (Same a Plus)" $ convert s t $ Same b a-convert s t (Same a b@(Minus _ _)) = debug "convert (Same a Minus)" $ convert s t $ Same b a-convert s t (Same a b@(Mult _ _)) = debug "convert (Same a Mult)" $ convert s t $ Same b a-convert s t (Same a b@(Abs _)) = debug "convert (Same a Abs)" $ convert s t $ Same b a-convert s t (Same a b) = debug "convert (Same a b)" $ do- va <- decompose a- vb <- decompose b- addT $ OSame va vb-convert s t (Diff a b) = debug "convert (Diff a b)" $ do- va <- decompose a- vb <- decompose b- addT $ ODiff va vb-convert s t (Less a b) = debug "convert (Less a b)" $ do- va <- decompose a- vb <- decompose b- addT $ OLess va vb-convert s t x = debug "convert _" $ s x+-- 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
+ Control/CP/FD/SimpleFD.hs view
@@ -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
Control/CP/FD/Solvers.hs view
@@ -8,31 +8,34 @@ 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+-- import Control.CP.FD.OvertonFD.Sugar+-- import Control.CP.FD.OvertonFD.OvertonFD+-- import Control.CP.FD.Gecode.CodegenSolver #ifdef RGECODE-import Control.CP.FD.Gecode.RuntimeSolver+-- import Control.CP.FD.Gecode.RuntimeSolver #endif -------------------------------------------------------------------------------- -- FORCE SOLVERS -------------------------------------------------------------------------------- -as_overtonfd :: Tree (FDWrapper OvertonFD) a -> Tree (FDWrapper OvertonFD) a-as_overtonfd = id--as_gecode_codegen :: Tree (FDWrapper CodegenSolver) a -> Tree CodegenSolver a-as_gecode_codegen = unwrap--#ifdef RGECODE-as_gecode_runtime :: Tree (FDWrapper RuntimeSolver) a -> Tree (FDWrapper RuntimeSolver) a-as_gecode_runtime = id--as_gecode_search :: Tree (FDWrapper SearchSolver) a -> Tree (FDWrapper SearchSolver) a-as_gecode_search = id-#endif+-- 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)+-- +-- #ifdef RGECODE+-- as_gecode_runtime :: Tree (FDWrapper RuntimeSolver) a -> Tree RuntimeSolver a+-- as_gecode_runtime = unwrap+-- +-- as_gecode_search :: Tree (FDWrapper SearchSolver) a -> Tree (FDWrapper SearchSolver) a+-- as_gecode_search = id+-- #endif ------------------------------------------------------------------------------ -- SEARCH STRATEGIES
− Control/CP/Herbrand/Herbrand.hs
@@ -1,209 +0,0 @@-{-# LANGUAGE TypeFamilies #-}-{-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE MultiParamTypeClasses #-}-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE PatternGuards #-}--- |This module provides a Herbrand solver.------ The type of terms is parameterized by the "HTerm" type class.-module Control.CP.Herbrand.Herbrand (- HTerm(..),- Herbrand(..),- failure,- success,- unify,- shallow_normalize,- registerAction,- HState,- Unify,- initState,- addH,- newvarH-) where --import Control.Monad.State.Lazy-import Control.Applicative--import Data.Map--import Control.CP.Solver---- |Herbrand terms---- type VarId = Int--class Ord (VarId t) => HTerm t where- type VarId t :: *- data VarSupply t :: *- varSupply :: VarSupply t- supplyVar :: VarSupply t -> (t, VarSupply t)- mkVar :: VarId t -> t- isVar :: t -> Maybe (VarId t)- children :: t -> ([t], [t] -> t)- nonvar_unify- :: (MonadState (HState t m) m) => t -> t -> m Bool---- |Herbrand monad--data Herbrand t a = Herbrand { unH :: State (HState t (Herbrand t)) a }--instance Monad (Herbrand t) where- return x = Herbrand $ return x- m >>= f = Herbrand $ unH m >>= unH . f--instance MonadState (HState t (Herbrand t)) (Herbrand t) where- get = Herbrand $ get- put = Herbrand . put--instance Functor (Herbrand t) where- fmap f fa = fa >>= return . f --instance Applicative (Herbrand t) where- pure = return- (<*>) ff fa = do f <- ff - a <- fa- return $ f a---- |State--type Heap t m = Map (VarId t) (Binding t m)--data Binding t m - = VAR (VarId t) -- ^ indirection to other variable- | NONVAR t -- ^ bound to term- | ACTION (m Bool) -- ^ attributed variable, with given action--data HState t m = HState { var_supply :: VarSupply t- , heap :: Heap t m- }--updateState :: (HTerm t, MonadState (HState t m) m) => (HState t m -> HState t m) -> m ()-updateState f = get >>= put . f---- |Solver instance --instance HTerm t => Solver (Herbrand t) where- type Constraint (Herbrand t) = Unify t - type Label (Herbrand t) = HState t (Herbrand t)- add = addH- mark = get- goto = put- run = flip evalState initState . unH--instance HTerm t => Term (Herbrand t) t where- newvar = newvarH- type Help (Herbrand t) t = ()- help _ _ = ()--initState :: HTerm t => HState t m-initState = HState varSupply Data.Map.empty---- New variable--newvarH :: (HTerm t,MonadState (HState t m) m) => m t-newvarH = do state <- get- let vs = var_supply state- let (var,vs') = supplyVar vs- put state{var_supply = vs'}- return var--{- Representatin of variables- ---------------------------- Each variable is represented by- * a VarId- * a possible Binding on the Heap- - if there is a binding, then the variable's meaning - is that of the binding- - if there is no binding, then variable's meaning is - that of an unbound variable---}---- Unification--data Unify t = t `Unify` t--addH :: (HTerm t, MonadState (HState t m) m) => Unify t -> m Bool-addH (Unify t1 t2) = unify t1 t2---- | unify two arbitrary terms-unify :: (HTerm t, MonadState (HState t m) m) => t -> t -> m Bool-unify t1 t2 = - do nt1 <- shallow_normalize t1- nt2 <- shallow_normalize t2- case (isVar nt1, isVar nt2) of- (Just v1, Just v2) - | v1 == v2 -> success- | otherwise -> bindv v1 v2- (Just v1, Nothing) -> bindt v1 nt2- (Nothing, Just v2) -> bindt v2 nt1- (Nothing, Nothing) -> nonvar_unify nt1 nt2--success, failure :: Monad m => m Bool-success = return True-failure = return False-m1 `andM` m2 = m1 >>= \b -> if b then m2 else return b ---- | bind a variable to a term-bindt :: (HTerm t, MonadState (HState t m) m) => VarId t -> t -> m Bool-bindt v t = do r <- lookupVar v- updater v (NONVAR t)- case r of- Just (ACTION action) -> action- Nothing -> success---- | alias one variable to another-bindv :: (HTerm t, MonadState (HState t m) m) => VarId t -> VarId t -> m Bool-bindv v1 v2 = do r1 <- lookupVar v1- r2 <- lookupVar v2- case (r1,r2) of- (Just (ACTION a1), Just (ACTION a2)) - -> let r3 = noACTION- in do updater v1 r3- updater v2 r3- a1 `andM` a2- (Just _, Nothing) -> updater v1 (VAR v2) >> success- (Nothing, Just _) -> updater v2 (VAR v1) >> success- (Nothing,Nothing) -> updater v1 (VAR v2) >> success-- where noACTION = ACTION success--updater v r = updateState $ \state -> state{heap = insert v r (heap state)}--lookupVar v = do state <- get- return $ Data.Map.lookup v (heap state)---- Actions--registerAction :: (HTerm t, MonadState (HState t m) m) => t -> m Bool -> m ()-registerAction t action =- do nt <- shallow_normalize t- case isVar nt of- Just v ->- do r <- lookupVar v- case r of- Nothing -> updater v (ACTION action)- Just (ACTION a1) -> updater v (ACTION (a1 `andM` action))- Nothing -> return ()---- TODO: unregister action?---- Normalization--shallow_normalize :: (HTerm t, MonadState (HState t m) m) => t -> m t-shallow_normalize t = gnormalize return t--normalize :: (HTerm t, MonadState (HState t m) m) => t -> m t-normalize t = gnormalize nvnormalize t- where nvnormalize t = let (ts,mkt) = children t- in mapM normalize ts >>= return . mkt--gnormalize nvnormalize t- | Just v <- isVar t = vnormalize v- | otherwise = nvnormalize t- where vnormalize v = do state <- get- case Data.Map.lookup v (heap state) of- Just (VAR v') -> vnormalize v'- Just (NONVAR t) -> nvnormalize t- _ -> return $ mkVar v
− Control/CP/Herbrand/HerbrandT.hs
@@ -1,57 +0,0 @@-{-# LANGUAGE TypeFamilies #-}-{-# LANGUAGE MultiParamTypeClasses #-}-{-# LANGUAGE FlexibleInstances #-}---- |This module provides a Herbrand solver as a monad transformer.------ The constraints offered are "Either (Unify t) (Constraint m)"--- where "m" is the transformed solver. Hence, both unification--- and the underlying solver's constraints are available.------ The terms offered are "L t1" where "t1" is the Herbrand solver's--- terms and "R t2" where "t2" are the underlying solver's types.--- -module Control.CP.Herbrand.HerbrandT where--import Control.Monad.Trans-import Control.Monad.State.Lazy--import Control.CP.Solver-import Control.CP.Herbrand.Herbrand (HState, Unify, HTerm,initState,addH,newvarH)--newtype HerbrandT t s a = HerbrandT { unHT :: StateT (HState t (HerbrandT t s)) s a }--instance Monad s => Monad (HerbrandT t s) where- return = HerbrandT . return- m >>= f = HerbrandT $ unHT m >>= unHT . f --instance MonadTrans (HerbrandT t) where- lift = HerbrandT . lift--instance Solver s =>MonadState (HState t (HerbrandT t s)) (HerbrandT t s) where- get = HerbrandT get- put = HerbrandT . put--instance (Solver s, HTerm t) => Solver (HerbrandT t s) where- type Constraint (HerbrandT t s) = Either (Unify t) (Constraint s)- type Label (HerbrandT t s) = (HState t (HerbrandT t s), Label s)- add (Left c) = addH c- add (Right c) = lift $ add c- mark = do l <- get- r <- lift $ mark- return (l,r)- goto (l,r) = put l >> (lift $ goto r)- run = run . flip evalStateT initState . unHT--data L a = L a-data R a = R a--instance (HTerm t, Solver s) => Term (HerbrandT t s) (L t) where- newvar = newvarH >>= return . L - type Help (HerbrandT t s) (L t) = ()- help _ _ = ()--instance (HTerm t, Solver s, Term s st) => Term (HerbrandT t s) (R st) where- newvar = lift newvar >>= return . R- type Help (HerbrandT t s) (R st) = ()- help _ _ = ()
− Control/CP/Herbrand/Prolog.hs
@@ -1,88 +0,0 @@-{-# LANGUAGE TypeFamilies #-}-{-# LANGUAGE MultiParamTypeClasses #-}-{-# LANGUAGE UndecidableInstances #-}-{-# LANGUAGE GeneralizedNewtypeDeriving #-}--module Control.CP.Herbrand.Prolog - ( Prolog- , module Control.CP.Herbrand.PrologTerm- , PConstraint (..) - ) where --import Control.Monad (zipWithM)--import Control.CP.Solver-import Control.CP.Herbrand.Herbrand-import Control.CP.Herbrand.PrologTerm---- Prolog Solver--newtype Prolog a = Prolog { runProlog :: Herbrand PrologTerm a }- deriving Monad--instance Solver Prolog where- type Constraint Prolog = PConstraint - type Label Prolog = Label (Herbrand PrologTerm)- add = addProlog- mark = Prolog $ mark- goto = Prolog . goto- run = run . runProlog--instance Term Prolog PrologTerm where- newvar = Prolog $ newvar- type Help Prolog PrologTerm = ()- help _ _ = ()--data PConstraint = PrologTerm := PrologTerm- | NotFunctor PrologTerm String - | PrologTerm :/= PrologTerm--addProlog :: PConstraint -> Prolog Bool-addProlog (x := y) = Prolog (unify x y)-addProlog (x :/= y) = Prolog (diff x y)-addProlog (NotFunctor x f) = Prolog (notFunctor x f)--notFunctor :: PrologTerm -> String -> Herbrand PrologTerm Bool-notFunctor x f = do t <- shallow_normalize x- case t of- PVar _ ->- registerAction t (notFunctor t f) >> success- PTerm g _ ->- if g == f then failure- else success--diff :: PrologTerm -> PrologTerm -> Herbrand PrologTerm Bool-diff x y =- do x' <- shallow_normalize x- y' <- shallow_normalize y- b <- diff' x' y'- case b of- DYes -> success- DNo -> failure- DMaybe vars -> mapM (\v -> registerAction v (diff x y)) vars >> success- -- where diff' x@(PVar v1) (PVar v2) =- if v1 == v2 then return $ DNo- else return $ DMaybe [x]- diff' x@(PVar _) (PTerm _ _) =- return $ DMaybe [x]- diff' (PTerm _ _) y@(PVar _) =- return $ DMaybe [y]- diff' (PTerm f xs) (PTerm g ys) - | x /= y = return $ DYes- | length xs /= length ys = return $ DYes - | otherwise =- do xs' <- mapM shallow_normalize xs- ys' <- mapM shallow_normalize ys- bs <- zipWithM diff' xs' ys'- return $ foldr dand DYes bs- -data DiffBool = DYes | DNo | DMaybe [PrologTerm]--dand DNo _ = DNo-dand _ DNo = DNo-dand (DMaybe x) (DMaybe y) = DMaybe (x ++ y)-dand DYes x = x-dand x DYes = x-
− Control/CP/Herbrand/PrologTerm.hs
@@ -1,37 +0,0 @@-{-# LANGUAGE TypeFamilies #-}--module Control.CP.Herbrand.PrologTerm (- PrologTerm(..)-) where --import Data.List (intersperse)--import Control.CP.Herbrand.Herbrand--data PrologTerm = PTerm String [PrologTerm] | PVar Int- deriving Eq--instance HTerm PrologTerm where- type VarId PrologTerm = Int- newtype VarSupply PrologTerm = VSPT Int- supplyVar (VSPT n) = (mkVar n, VSPT (n+1))- varSupply = VSPT 0- mkVar = PVar- isVar (PVar v) = Just v- isVar _ = Nothing- children (PTerm f args) - = (args,\args' -> PTerm f args')- children t = ([], \[] -> t)- nonvar_unify (PTerm f1 args1) (PTerm f2 args2)- | f1 == f2 = unify_lists args1 args2- | otherwise = failure- where unify_lists [] [] = success- unify_lists (x:xs) (y:ys) =- do b <- unify x y- if b then unify_lists xs ys- else failure- unify_lists _ _ = failure--instance Show PrologTerm where- show (PVar v) = 'V' : show v- show (PTerm f args) = f ++ "(" ++ (concat $ intersperse "," $ map show args) ++ ")"
− Control/CP/Mixin.hs
@@ -1,24 +0,0 @@-module Control.CP.Mixin (- Mixin,- (<@>),- mixin,- mixinConst,- mixinId-) where--type Mixin a = a -> a -> a--infixl 5 <@>-(<@>) :: Mixin a -> Mixin a -> Mixin a-(f1 <@> f2) s t = f1 (f2 s t) t--mixin :: Mixin a -> a-mixin f = let - x = f (error "super called in top-level mixin") x - in x--mixinConst :: a -> a -> a -> a-mixinConst _ _ c = c--mixinId :: Mixin a-mixinId s _ = s
+ Control/CP/SearchSpec/Generator.hs view
@@ -0,0 +1,1364 @@+{-# LANGUAGE Rank2Types #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE ImpredicativeTypes #-}+{-# LANGUAGE ExistentialQuantification #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE PatternGuards #-}++module Control.CP.SearchSpec.Generator+ ( (<@>) , (<|>) , (<&>)+ , def+ , nb+ , dbs+ , lds+ , fs+ , once+ , bbmin+ , prt+ , search+ , label+ , vlabel+ , glabel+ , foldVarSel+ , ifoldVarSel+ , until+ , failure+ , repeat+ , for, foreach+ , properLDS+ , limit+ , lbV+ , ubV+ , domsizeV + , lbRegretV + , ubRegretV + , degreeV + , wDegreeV+ , domSizeWDegreeV+ , domSizeDegreeV+ , randomV + , maxV+ , minV+ , minD+ , maxD + , meanD + , medianD + , randomD + , ($==)+ , ($/=)+ , ($<) + , ($<=)+ , ($>) + , ($>=)+ , (@>)+ , appStat+ , depthStat+ , nodesStat+ , discrepancyStat+ , solutionsStat+ , failsStat+ , (#>)+ ) where++import Prelude hiding (lex, until, init, repeat)+import Control.CP.SearchSpec.Language+import Text.PrettyPrint hiding (space)+import List (sort, nub)+import Data.Int++{- TODO:+ - completeness+ - restart optimization+ - time limit+ - reinstate advanced variable selection+ -}++import Control.Monatron.Monatron hiding (Abort, L, state)+import Control.Monatron.Zipper hiding (i,r)+import Control.Monatron.IdT++type TreeState = Value+type EvalState = Value++data Eval m = Eval + { structs :: ([Struct],[Struct]) -- auxiliary type declarations+ , treeState_ :: [(String,Type, Info -> Statement)] -- tree state fields (name, type, init)+ , evalState :: [(String,Type,Value)]+ , pushLeft :: Info -> m Statement+ , pushRight :: Info -> m Statement+ , bodyE :: Info -> m Statement+ , addE :: Info -> m Statement+ , returnE :: Info -> m Statement+ , failE :: Info -> m Statement+ , continue :: EvalState -> m Value+ , tryE :: Info -> m Statement+ , tryE_ :: Info -> m Statement+ , intArraysE :: [String]+ , intVarsE :: [String]+ }++entry name ty up = (name, ty, \i -> up (tstate i @-> name))++treeState e = entry "space" (Pointer SpaceType) (assign RootSpace) : treeState_ e +space i = baseTstate i @-> "space"++mkCopy i f = (tstate i @-> f) <== (tstate (old i) @-> f)+mkUpdate i f g = (tstate i @-> f) <== g (tstate (old i) @-> f)+++pushLeftTop e = \i -> pushLeft e (i `onCommit` mkCopy i "space" )+pushRightTop e = \i -> pushRight e (i `onCommit` mkUpdate i "space" Clone)++mapE :: (forall x. m x -> n x) -> Eval m -> Eval n+mapE f e =+ Eval { structs = structs e+ , treeState_ = treeState_ e+ , evalState = evalState e+ , pushLeft = f . pushLeft e+ , pushRight = f . pushRight e+ , bodyE = f . bodyE e+ , addE = f . addE e+ , returnE = f . returnE e+ , failE = f . failE e+ , continue = f . continue e+ , tryE = f . tryE e+ , tryE_ = f . tryE_ e+ , intArraysE = intArraysE e+ , intVarsE = intVarsE e+ } ++data Info = Info { baseTstate :: TreeState+ , path :: TreeState -> TreeState+ , abort :: Statement+ , commit :: Statement+ , old :: Info+ , clone :: Info -> Statement+ , field :: String -> Value+ }++type Field = String++tstate i = path i (baseTstate i)+estate i = tstate i @-> "evalState"++withCommit i f = i { commit = f (commit i) }+onAbort i stmt = i { abort = stmt >>> abort i }+onCommit i stmt = i `withCommit` (stmt >>>)+withPath i p = i { path = p . path i+ , old = old i `withPath` p+ }+withBase i str = i { baseTstate = Var str }++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 }+resetCommit i = i { commit = Delete $ space i }+resetClone i = i { clone = \j -> space j <== Clone (space i) }++mkInfo name =+ let i = Info { baseTstate = Var name+ , path = id+ , abort = Delete $ space i+ , commit = Delete $ space i+ , old = i+ , clone = \j -> space j <== Clone (space i)+ , field = \f -> error ("unknown field `" ++ f ++ "'")+ }+ in i++info = mkInfo "estate"++newinfo i = + Info { baseTstate = Var "nstate"+ , path = id+ , abort = Skip+ , commit = Skip+ , old = resetPath i+ , clone = \j -> space j <== Clone (space i)+ , field = \f -> error ("unknown field `" ++ f ++ "'")+ }++--------------------------------------------------------------------------------+-- LABELING+--------------------------------------------------------------------------------+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]+ , 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 (resetPath i) >>= \ret ->+ tryE_ e (resetPath i) >>= \try ->+ return $ (IfThenElse (Assigned (var i))+ ret+ (val i <== (selVal $ var i) >>> try))+ , intArraysL = []+ , intVarsL = [var1]+ }+ where val i = tstate i @-> "val"+ eq i = tstate i @-> "eq"+ var i = VHook (rp 0 (space i) ++ "->iv[$VAR_" ++ var1 ++ "]") ++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 (resetPath i) >>= \ret ->+ tryE_ e (resetPath i) >>= \try ->+ return $ (selVar i vars+ ret+ (val i <== (selVal $ var i) >>> try))+ , intArraysL = [vars]+ , intVarsL = []+ }+ where val i = tstate i @-> "val"+ pos i = tstate i @-> "pos"+ eq i = tstate i @-> "eq"+ var i = CVar 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"++{-+lexLabel info selVal rel e = + Label { treeStateL = [("pos", Int, 0)+ ,("val", Int, 0)+ ,("eq", Bool, undefined)]+ , leftChild_L = [("eq", const $ true)+ ,("val", \env -> env "val")+ ,("pos",\env -> env "pos")]+ , rightChild_L = [("eq", const $ false)+ ,("val", \env -> env "val")+ ,("pos",\env -> env "pos")]+ , addL = \state -> let space = Field state "space"+ var = CVar space (Field state "pos")+ val = Field state "val"+ in IfThenElse (Field state "eq")+ (Post space (var `rel` val))+ (Post space (neg (var `rel` val)))+ , tryL = \state -> let val = Field state "val"+ space = Field state "space"+ var = CVar space (Field state "pos")+ cmps = [cmp | (_,(cmp,_)) <- info ]+ mtxs = [ (z,f) | (f,(_,z)) <- info ]+ in MFold "estate" mtxs (lex cmps) + >>> IfThenElse (Field state "pos" @< 0)+ (returnE e state)+ (Update val (selVal var) >>> tryE_ e state) + }+-}++maxV = (Gt,IVal minBound)+minV = (Lt,IVal maxBound)++lbV = MinDom+ubV = MaxDom +domsizeV = SizeDom+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++--------------------------------------------------------------------------------+-- SEARCH TRANSFORMERS+--------------------------------------------------------------------------------++baseLoop label this = return $+ Eval { structs = ([],[])+ , treeState_ = map (\(x,y,z) -> entry x y z) $ treeStateL label + , evalState = []+ , pushLeft = \i -> return $ commit i >>> seqs [f i | f <- leftChild_L label] >>> Push new_tstate+ , pushRight = \i -> return $ commit i >>> seqs [f i | f <- rightChild_L label] >>> Push new_tstate+ , bodyE = addE this . resetPath+ , addE = \i -> tryE this (resetPath i) >>= \try ->+ addL label i >>= \a -> + failE this (resetPath i) >>= \fail ->+ return $+ (a + >>> (Var "status" <== VHook (rp 0 (space i) ++ "->status()"))+ >>> IfThenElse (Var "status" @== VHook "SS_FAILED")+ ( fail+ >>> Delete (space i))+ try) + , failE = const $ return Skip+ , returnE = \i -> return $ commit i+ , continue = \_ -> return true+ , tryE = tryL label+ , tryE_ = \i -> + pushRightTop this (newinfo i) >>= \p2 -> + pushLeftTop this (newinfo i) >>= \p4 ->+ return (SHook "TreeState nstate;"+ >>> p2+ >>> p4)+ , intArraysE = intArraysL label+ , intVarsE = intVarsL label+ }+ where new_tstate = Var "nstate"++--------------------------------------------------------------------------------+dummyLoop super = Eval { structs = structs super+ , treeState_ = treeState_ super+ , evalState = evalState super+ , pushLeft = pushLeft super+ , pushRight = pushRight super+ , bodyE = bodyE super+ , addE = addE super+ , failE = failE super+ , returnE = returnE super+ , continue = continue super+ , tryE = tryE super+ , tryE_ = tryE_ super+ , intArraysE = intArraysE super+ , intVarsE = intVarsE super+ }++failLoop super = Eval { structs = ([],[])+ , treeState_ = []+ , evalState = []+ , pushLeft = \_ -> return Skip+ , pushRight = \_ -> return Skip+ , bodyE = \i -> return $ abort i+ , addE = \_ -> return Skip+ , failE = \_ -> return Skip+ , returnE = \_ -> return Skip+ , continue = \_ -> return true+ , tryE = \i -> return $ abort i+ , tryE_ = \_ -> return Skip+ , intArraysE = []+ , intVarsE = []+ }++--------------------------------------------------------------------------------+data SeqPos = OutS | FirstS | SecondS++seqSwitch l r = + do flag <- ask+ case flag of + FirstS -> l+ SecondS -> r+(l1,l2) @++@ (l3,l4) = (l1 ++ l3, l2 ++ l4)++seqLoop :: ReaderM SeqPos m => Int -> Eval m -> Eval m -> Eval m+seqLoop uid lsuper rsuper =+ Eval { structs = structs lsuper @++@ structs rsuper @++@ mystructs + , treeState_ = [entry "is_fst" Bool (assign true)+ , ("seq_union",Union [(SType s3,"fst"),(SType s4,"snd")], + \i -> + let j = i `withPath` in1+ in seqs [init j | (_,init) <- fs3]+ >>> initSubEvalState j s1 fs1+ )]+ , evalState = []+ , pushLeft = push pushLeft+ , pushRight = push pushRight+ , bodyE = \i ->+ let f z j = do stmt <- bodyE z (j `onAbort` dec_ref j)+ cond <- continue z (estate j)+ return $ IfThenElse (cont j)+ (IfThenElse cond+ stmt+ ( (cont j <== false)+ >>> dec_ref j+ >>> abort j)+ )+ ( dec_ref j+ >>> abort j)+ in do s1 <- local (const FirstS) $ inSeq f i+ s2 <- local (const SecondS) $ inSeq f i+ return $ IfThenElse (is_fst i) s1 s2+ , addE = inSeq $ addE+ , failE = inSeq $ \super j -> failE super j @>>>@ return (dec_ref j)+ , returnE = \i -> let j1 = i `withPath` in1+ j2 = i `withPath` in2 `onCommit` dec_ref j2+ j2b = resetCommit j2+ in seqSwitch (do action <- local (const SecondS) $+ do stmt1 <- initTreeState_ j2b rsuper + stmt2 <- tryE rsuper j2b+ return (dec_ref j1+ >>> (is_fst i <== false) + >>> initSubEvalState j2b s2 fs2+ >>> stmt1 >>> stmt2)+ returnE lsuper $ j1 `withCommit` const action+ )+ (returnE rsuper j2)+ , continue = \_ -> return true+ , tryE = inSeq $ tryE+ , tryE_ = inSeq $ \super j -> tryE_ super j @>>>@ return (dec_ref j)+ , intArraysE = intArraysE lsuper ++ intArraysE rsuper+ , intVarsE = intVarsE lsuper ++ intVarsE rsuper+ }+ where mystructs = ([s1,s2],[s3,s4])+ s1 = Struct ("LeftEvalState" ++ show uid) $ (Bool, "cont") : (Int, "ref_count") : [(ty, field) | (field,ty,_) <- evalState lsuper]+ s2 = Struct ("RightEvalState" ++ show uid) $ (Bool, "cont") : (Int, "ref_count") : [(ty, field) | (field,ty,_) <- evalState rsuper]+ s3 = Struct ("LeftTreeState" ++ show uid) $ (Pointer $ SType s1, "evalState") : [(ty, field) | (field,ty,_) <- treeState_ lsuper]+ s4 = Struct ("RightTreeState" ++ show uid) $ (Pointer $ SType s2, "evalState") : [(ty, field) | (field,ty,_) <- treeState_ rsuper]+ fs1 = [(field,init) | (field,_ty,init) <- evalState lsuper ]+ fs2 = [(field,init) | (field,_ty,init) <- evalState rsuper ]+ fs3 = [(field,init) | (field,_ty,init) <- treeState_ lsuper] + is_fst = \i -> tstate i @-> "is_fst"+ cont = \i -> estate i @=> "cont"+ ref_count = \i -> estate i @=> "ref_count"+ withSeq f = seqSwitch (f lsuper in1) (f rsuper in2)+ inSeq f = \i -> withSeq $ \super ins -> f super (i `withPath` ins)+ dec_ref = \j -> dec (ref_count j) >>> ifthen (ref_count j @== 0) (Delete (estate j))+ push dir = \i -> inSeq ( \super j -> dir super (j `onCommit` ( mkCopy i "is_fst"+ >>> mkCopy j "evalState"+ >>> inc (ref_count j)+ ))) i+ initSubEvalState = \j s fs -> (estate j <== New s) + >>> (ref_count j <== 1)+ >>> (cont j <== true)+ >>> seqs [estate j @=> f <== init | (f,init) <- fs] ++in1 = \state -> state @-> "seq_union" @-> "fst"+in2 = \state -> state @-> "seq_union" @-> "snd"+--------------------------------------------------------------------------------++cloneBase i = resetClone $ info { baseTstate = estate i @=> "parent" }++orLoop :: ReaderM SeqPos m => Int -> Eval m -> Eval m -> Eval m+orLoop uid lsuper rsuper =+ Eval { structs = structs lsuper @++@ structs rsuper @++@ mystructs + , treeState_ = [entry "is_fst" Bool (assign true)+ , ("seq_union",Union [(SType s3,"fst"),(SType s4,"snd")], + \i -> + let j = i `withPath` in1+ in (estate j <== New s1)+ >>> (ref_count j <== 1)+ >>> (cont j <== true)+ >>> (parent j <== baseTstate j)+ >>> clone i (cloneBase j)+ >>> seqs [init (j `withClone` (\k -> inc $ ref_count k)) | (f,init) <- fs3]+ >>> seqs [estate j @=> f <== init | (f,init) <- fs1 ]+ )]+ , evalState = []+ , pushLeft = push pushLeft+ , pushRight = push pushRight+ , bodyE = \i ->+ let f y z = + let j = i `withPath` y+ 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 IfThenElse (is_fst i) @$ local (const FirstS) (f in1 lsuper) + @. local (const SecondS) (f in2 rsuper)+ , addE = inSeq $ addE+ , failE = \i -> inSeq failE i @>>>@ dec_ref i+ , returnE = \i -> + let j1 deref = i `withPath` in1 `onCommit` deref+ j2 deref = i `withPath` in2 `onCommit` deref+ in seqSwitch (dec_ref1 i >>= returnE lsuper . j1)+ (dec_ref2 (j2 Skip) >>= returnE rsuper . j2) + , continue = \_ -> return true+ , tryE = inSeq $ tryE + , tryE_ = \i -> inSeq tryE_ i @>>>@ dec_ref i+ , intArraysE = intArraysE lsuper ++ intArraysE rsuper+ , intVarsE = intVarsE lsuper ++ intVarsE rsuper+ }+ where mystructs = ([s1,s2],[s3,s4])+ s1 = Struct ("LeftEvalState" ++ show uid) $ (THook "TreeState", "parent") : (Bool, "cont") : (Int, "ref_count") : [(ty, field) | (field,ty,_) <- evalState lsuper]+ fs1 = [(field,init) | (field,ty,init) <- evalState lsuper ]+ s2 = Struct ("RightEvalState" ++ show uid) $ (Bool, "cont") : (Int, "ref_count") : [(ty, field) | (field,ty,_) <- evalState rsuper]+ fs2 = [(field,init) | (field,ty,init) <- evalState rsuper ]+ s3 = Struct ("LeftTreeState" ++ show uid) $ (Pointer $ SType s1, "evalState") : [(ty, field) | (field,ty,_) <- treeState_ lsuper]+ fs3 = [(field,init) | (field,ty,init) <- treeState_ lsuper]+ s4 = Struct ("RightTreeState" ++ show uid) $ (Pointer $ SType s2, "evalState") : [(ty, field) | (field,ty,_) <- treeState_ rsuper]+ in1 = \state -> state @-> "seq_union" @-> "fst"+ in2 = \state -> state @-> "seq_union" @-> "snd"+ is_fst = \i -> tstate i @-> "is_fst"+ cont = \i -> estate i @=> "cont"+ ref_count = \i -> estate i @=> "ref_count"+ parent = \i -> estate i @=> "parent"+ withSeq f = seqSwitch (f lsuper in1) (f rsuper in2)+ inSeq f = \i -> withSeq $ \super ins -> f super (i `withPath` ins)+ dec_ref = \i -> seqSwitch (dec_ref1 i) (dec_ref2 $ i `withPath` in2)+ dec_ref1 = \i -> let j1 = i `withPath` in1+ i' = resetClone $ resetCommit $ i `withBase` ("or_tstate" ++ show uid)+ j2 = i' `withPath` in2+ in (local (const SecondS) $+ do stmt1 <- initTreeState_ j2 rsuper + stmt2 <- tryE rsuper j2+ return (dec (ref_count j1) + >>> ifthen (ref_count j1 @== 0) + ( SHook ("TreeState or_tstate" ++ show uid ++ ";")+ >>> (baseTstate j2 <== parent j1)+ >>> (is_fst i' <== false)+ >>> Delete (estate j1)+ >>> (estate j2 <== New s2) + >>> (ref_count j2 <== 1)+ >>> (cont j2 <== true)+ >>> seqs [estate j2 @=> f <== init | (f,init) <- fs2 ] + >>> stmt1 >>> stmt2)))+ dec_ref2 = \j -> return $ dec (ref_count j) >>> ifthen (ref_count j @== 0) (Delete (estate j))+ push dir = \i -> seqSwitch (push1 dir i) (push2 dir i)+ push1 dir = \i -> + let j = i `withPath` in1 + in dir lsuper (j `onCommit` ( mkCopy i "is_fst"+ >>> mkCopy j "evalState"+ >>> inc (ref_count j)+ ))+ push2 dir = \i -> + let j = i `withPath` in2 + in dir rsuper (j `onCommit` ( mkCopy i "is_fst"+ >>> mkCopy j "evalState"+ >>> inc (ref_count j)+ ))++(@>>>@) x y = do s1 <- x+ s2 <- y+ return (s1 >>> s2)++f @$ x = x >>= return . f+mf @. x = mf >>= \f -> f @$ x++--------------------------------------------------------------------------------+repeatLoop :: ReaderM Bool m => Int -> Eval m -> Eval m+repeatLoop uid super =+ Eval + { + structs = structs super @++@ mystructs + , treeState_ = ("dummy", Int, + \i -> (parent i <== baseTstate i)+ >>> clone i (cloneBase i)+ ) : treeState_ super -- `withClone` (\k -> inc $ ref_count k)+ , evalState = ("cont",Bool,true) : ("ref_count",Int,1) : ("parent",THook "TreeState",Null) : evalState super+ , pushLeft = push pushLeft+ , pushRight = push pushRight+ , bodyE = \i -> do cond <- continue super (tstate i)+ deref <- dec_ref i+ stmt <- bodyE super (i `onAbort` deref)+ return $ IfThenElse (cont i)+ (IfThenElse cond+ stmt+ ( (cont i <== false)+ >>> deref+ >>> abort i))+ (deref >>> abort i)+ , addE = addE super+ , failE = \i -> failE super i @>>>@ dec_ref i+ , returnE = \i -> let j deref = i `onCommit` deref+ in dec_ref i >>= returnE super . j+ , continue = \_ -> return true+ , tryE = tryE super+ , tryE_ = \i -> tryE_ super i @>>>@ dec_ref i+ , intArraysE = intArraysE super+ , intVarsE = intVarsE super+ }+ where mystructs = ([],[])+ fs1 = [(field,init) | (field,ty,init) <- evalState super]+ cont = \i -> estate i @=> "cont"+ ref_count = \i -> estate i @=> "ref_count"+ parent = \i -> estate i @=> "parent"+ dec_ref = \i -> let i' = resetCommit $ i `withBase` ("or_tstate" ++ show uid)+ in do flag <- ask + if flag + then local (const False) $ do+ stmt1 <- initTreeState_ i' super + stmt2 <- tryE super i'+ return (dec (ref_count i) + >>> ifthen (ref_count i @== 0) + ( SHook ("TreeState or_tstate" ++ show uid ++ ";")+ >>> (baseTstate i' <== parent i)+ >>> clone (cloneBase i) i'+ >>> (ref_count i' <== 1)+ >>> (cont i' <== true)+ >>> seqs [estate i' @=> f <== init | (f,init) <- fs1 ] + >>> stmt1 >>> stmt2))+ else return $dec (ref_count i) >>> ifthen (ref_count i @== 0) (Delete (space $ cloneBase i))+ push dir = \i -> dir super (i `onCommit` inc (ref_count i))++--------------------------------------------------------------------------------+forLoop :: ReaderM Bool m => Int32 -> Int -> (Eval m,IsComplete) -> Eval m+forLoop n uid (super,iscomplete) =+ Eval + { + structs = structs super @++@ mystructs + , treeState_ = ("dummy", Int, + \i -> (parent i <== baseTstate i)+ >>> clone i (cloneBase i)+ ) : treeState_ super+ , evalState = ("counter",Int,0) : ("cont",Bool,true) : ("ref_count",Int,1) : ("parent",THook "TreeState",Null) : evalState super+ , pushLeft = push pushLeft+ , pushRight = push pushRight+ , bodyE = \i -> do cond <- continue super (tstate i)+ deref <- dec_ref i+ stmt <- bodyE super (i `onAbort` deref)+ return $ IfThenElse (cont i)+ (IfThenElse cond+ stmt+ ( (cont i <== false)+ >>> deref+ >>> abort i))+ (deref >>> abort i)+ , addE = addE super+ , failE = \i -> failE super i @>>>@ dec_ref i+ , returnE = \i -> let j deref = i `onCommit` deref+ in dec_ref i >>= returnE super . j+ , continue = \_ -> return true+ , tryE = \i -> tryE super (i `withField` ("counter", counter))+ , tryE_ = \i -> tryE_ super i @>>>@ dec_ref i+ , intArraysE = intArraysE super+ , intVarsE = intVarsE super+ }+ where mystructs = ([],[])+ fs1 = [(field,init) | (field,ty,init) <- evalState super]+ cont = \i -> estate i @=> "cont"+ ref_count = \i -> estate i @=> "ref_count"+ parent = \i -> estate i @=> "parent"+ counter = \i -> estate i @=> "counter"+ dec_ref = \i -> let i' = resetCommit $ i `withBase` ("or_tstate" ++ show uid)+ in do flag <- ask + if flag + then local (const False) $ do+ stmt1 <- initTreeState_ i' super + stmt2 <- tryE super (i' `withField` ("counter", counter))+ return (dec (ref_count i) + >>> ifthen (ref_count i @== 0) + ( inc (counter i)+ >>> ifthen (counter i @< IVal n &&& Not (iscomplete i))+ ( SHook ("TreeState or_tstate" ++ show uid ++ ";")+ >>> (baseTstate i' <== parent i)+ >>> clone (cloneBase i) i'+ >>> (ref_count i' <== 1)+ >>> (cont i' <== true)+ >>> seqs [estate i' @=> f <== init | (f,init) <- fs1 ] + >>> stmt1 >>> stmt2)+ ))+ else return $dec (ref_count i) >>> ifthen (ref_count i @== 0) (Delete (space $ cloneBase i))+ push dir = \i -> dir super (i `onCommit` inc (ref_count i))++--------------------------------------------------------------------------------+untilLoop :: ReaderM SeqPos m => Stat -> Int -> (Eval m, IsComplete) -> (Eval m,IsComplete) -> Eval m+untilLoop cond uid (lsuper', liscomplete) (rsuper, riscomplete) =+ Eval { structs = structs lsuper @++@ structs rsuper @++@ mystructs + , treeState_ = [entry "is_fst" Bool (assign true)+ ,("seq_union", Union [(SType s3,"fst"),(SType s4,"snd")], + \i -> + let j = i `withPath` in1+ in seqs [init j | (f,init) <- fs3]+ >>> initSubEvalState j s1 fs1)+ ]+ , evalState = [("until_complete",Bool,true)]+ , pushLeft = push pushLeft+ , pushRight = push pushRight+ , bodyE = \i ->+ let f y z iscomplete = + let j = i `withPath` y `onAbort` dec_ref i j iscomplete+ in do stmt <- bodyE z j+ cond <- continue z (estate j)+ return $ IfThenElse (cont j)+ (IfThenElse cond+ stmt+ (cont j <== false >>> abort j))+ (abort j)+ in do s1 <- local (const FirstS) $ f in1 lsuper liscomplete+ s2 <- local (const SecondS) $ f in2 rsuper riscomplete+ return $ IfThenElse (is_fst i) s1 s2+ , addE = inSeq $ addE+ , failE = \i -> inSeq' (\super j iscomplete -> failE super j @>>>@ return (dec_ref i j iscomplete)) i+ , returnE = \i -> inSeq' (\super j iscomplete -> returnE super (j `onCommit` dec_ref i j iscomplete)) i+ , continue = \_ -> return true+ , tryE = \i ->let j1 = i `withPath` in1+ j2 = i `withPath` in2 `onAbort` dec_ref i j2 riscomplete+ in seqSwitch (tryE lsuper j1 >>= \stmt ->+ (local (const SecondS) $+ do stmt1 <- initTreeState_ j2 rsuper + stmt2 <- tryE rsuper j2+ return (dec_ref i j1 liscomplete+ >>> (is_fst i <== false) + >>> initSubEvalState j2 s2 fs2+ >>> stmt1 >>> stmt2)+ ) >>= \stmt2 ->+ return $ IfThenElse (readStat cond j1)+ stmt2+ stmt+ )+ (tryE rsuper j2) + , tryE_ = \i -> inSeq' (\super j iscomplete -> tryE_ super j @>>>@ return (dec_ref i j iscomplete)) i+ , intArraysE = intArraysE lsuper ++ intArraysE rsuper+ , intVarsE = intVarsE lsuper ++ intVarsE rsuper+ }+ where mystructs = ([s1,s2],[s3,s4])+ s1 = Struct ("LeftEvalState" ++ show uid) $ (Bool, "cont") : (Int, "ref_count") : [(ty, field) | (field,ty,_) <- evalState lsuper]+ fs1 = [(field,init) | (field,ty,init) <- evalState lsuper ]+ s2 = Struct ("RightEvalState" ++ show uid) $ (Bool, "cont") : (Int, "ref_count") : [(ty, field) | (field,ty,_) <- evalState rsuper]+ fs2 = [(field,init) | (field,ty,init) <- evalState rsuper ]+ s3 = Struct ("LeftTreeState" ++ show uid) $ (Pointer $ SType s1, "evalState") : [(ty, field) | (field,ty,_) <- treeState_ lsuper]+ fs3 = [(field,init) | (field,ty,init) <- treeState_ lsuper]+ s4 = Struct ("RightTreeState" ++ show uid) $ (Pointer $ SType s2, "evalState") : [(ty, field) | (field,ty,_) <- treeState_ rsuper]+ in1 = \state -> state @-> "seq_union" @-> "fst"+ in2 = \state -> state @-> "seq_union" @-> "snd"+ withSeq f = seqSwitch (f lsuper in1) (f rsuper in2)+ inSeq f = \i -> withSeq $ \super ins -> f super (i `withPath` ins)+ inSeq' f = \i -> seqSwitch (f lsuper (i `withPath` in1) liscomplete) + (f rsuper (i `withPath` in2) riscomplete)+ dec_ref = \i j iscomplete+ -> dec (ref_count j) >>> + ifthen (ref_count j @== 0) + (Delete (estate j) >>>+ (complete i <== (complete i &&& iscomplete j))+ )+ push dir = \i -> seqSwitch (push1 dir i) (push2 dir i)+ push1 dir = \i -> + let j = i `withPath` in1 + in dir lsuper (j `onCommit` ( mkCopy i "is_fst"+ >>> mkCopy j "evalState"+ >>> inc (ref_count j)+ ))+ push2 dir = \i -> + let j = i `withPath` in2 + in dir rsuper (j `onCommit` ( mkCopy i "is_fst"+ >>> mkCopy j "evalState"+ >>> inc (ref_count j)+ ))+ lsuper = evalStat cond lsuper'+ is_fst = \i -> tstate i @-> "is_fst"+ cont = \i -> estate i @=> "cont"+ ref_count = \i -> estate i @=> "ref_count"+ complete = \i -> estate i @=> "until_complete"+ initSubEvalState = \j s fs -> (estate j <== New s) + >>> (ref_count j <== 1)+ >>> (cont j <== true)+ >>> seqs [estate j @=> f <== init | (f,init) <- fs] ++--------------------------------------------------------------------------------+ldsLoop :: Monad m => Int32 -> MkEval m+ldsLoop limit super = return $ dummyLoop super+ { treeState_ = entry "lds" Int (assign $ IVal limit) : treeState_ super+ , evalState = ("lds_complete", Bool, true) : evalState super+ , pushLeft = \i -> pushLeft super (i `onCommit` mkCopy i "lds")+ , pushRight = \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))+ }+++--------------------------------------------------------------------------------+dbsLoop :: Monad m => Int32 -> MkEval m+dbsLoop limit super = return $ dummyLoop super+ { treeState_ = entry "depth_limit" Int (assign $ IVal limit) : treeState_ super+ , evalState = ("dbs_complete", Bool, true) : evalState super+ , pushLeft = push pushLeft+ , pushRight = push pushRight+ }+ 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)++--------------------------------------------------------------------------------+nbLoop :: Monad m => Int32 -> MkEval m+nbLoop limit super = return $ dummyLoop super+ { evalState = ("nodes", Int, IVal limit) :+ ("nb_complete", Bool, true) : evalState super,+ bodyE = \i -> bodyE super i >>= \r -> return $ dec (estate i @=> "nodes") >>> r,+ continue = \estate -> continue super estate >>= \r -> return $ (estate @=> "nodes" @> 0) &&& r+ }++--------------------------------------------------------------------------------+printLoop :: Monad m => [String] -> MkEval m+printLoop arrs super = return $ dummyLoop super+ { returnE = \i -> returnE super $ i `onCommit` Print (space i) arrs+ }++--------------------------------------------------------------------------------+onceLoop :: Monad m => MkEval m+onceLoop super = return $ dummyLoop super+ { evalState = ("once",Bool,true) : evalState super+ , returnE = \i -> returnE super (i {commit = (estate i @=> "once" <== false) >>> commit i})+ , continue = \estate -> continue super estate >>= \r -> return $ (estate @=> "once") &&& r+ }++--------------------------------------------------------------------------------+nSolutionsLoop :: Monad m => Int32 -> MkEval m+nSolutionsLoop limit super = return $ dummyLoop super+ { evalState = ("solutions", Int, IVal limit) : evalState super + , returnE = \i -> returnE super (i `onCommit` dec (estate i @=> "solutions"))+ , continue = \estate -> continue super estate >>= \r -> return $ (estate @=> "solutions" @> 0) &&& r+ }++--------------------------------------------------------------------------------+bbLoop :: Monad m => String -> MkEval m +bbLoop var super = return $ dummyLoop super+ { treeState_ = entry "tree_bound_version" Int (assign 0) : treeState_ super+ , evalState = ("bound_version",Int,0) : ("bound",Int,IVal maxBound) : evalState super+ , returnE = \i -> returnE super (i `onCommit`+ let get = VHook (rp 0 (space i) ++ "->getVar($VAR_" ++ var ++ ").min()")+ in (Update (estate i @=> "bound") get >>> inc (estate i @=> "bound_version"))) + , bodyE = \i -> let set = Post (space i) (VHook (rp 0 (space i) ++ "->getVar($VAR_" ++ var ++ ")") $< (estate i @=> "bound"))+ in do r <- bodyE super i+ return $ (ifthen (tstate i @-> "tree_bound_version" @< (estate i @=>"bound_version"))+ (set >>> (Update (tstate i @-> "tree_bound_version") ((tstate i @-> "tree_bound_version") + 1)))+ >>> r)+ , pushLeft = push pushLeft+ , pushRight = push pushRight+ , intVarsE = var : intVarsE super+ }+ where push dir = \i -> dir super (i `onCommit` mkCopy i "tree_bound_version")+++--------------------------------------------------------------------------------+-- PRINTING+--------------------------------------------------------------------------------++printTreeStateType :: Monad m => Eval m -> String+printTreeStateType e =+ render $ pretty $ Struct "TreeState" [ (ty,name) | (name,ty,_) <- treeState e ]++initEvalState :: Monad m => Eval m -> Doc+initEvalState e =+ vcat [pretty ty <+> text name <+> (case val of { Null -> empty ; _ -> text "=" <+> pretty val}) <> text ";" | (name,ty,val) <- evalState e]++initTreeState :: Monad m => Info -> Eval m -> m Statement+initTreeState i e =+ return $ seqs [ init i | (_,_,init) <- treeState e]++initTreeState_ :: Monad m => Info -> Eval m -> m Statement+initTreeState_ i e =+ return $ seqs [ init i | (_,_,init) <- treeState_ e]++initIntArrays :: Eval m -> Doc+initIntArrays eval =+ vcat [ doc arr | arr <- nub $ sort $ intArraysE eval]+ where doc arr = text "vector<int>" <+> text "$ARR_" <> text arr <> + case arr of+ "branch" -> empty <+> text "=" <+> text "root->getBranchVarIds()" <> semi+ "bound" -> text "(1)" <> semi <+> text "$ARR_bound[0]=-1" <> semi++initIntVars :: Eval m -> Doc+initIntVars eval =+ vcat [ doc var | var <- nub $ sort $ intVarsE eval]+ where doc var = text "int" <+> text "$VAR_" <> text var <> + case var of+ "cost" -> empty <+> text "=" <+> text "-1" <> semi++-- initIntVars :: Eval m -> Doc +-- initIntVars eval =+-- vcat [ doc var | var <- nub $ sort $ intVarsE eval]+-- where doc var = (text "int" <+> text "$VAR_" <> text var <> semi) $$+-- (text "vm->getintVarIndex(\"" <> text var <> text "\", " <> text "$VAR_" <> text var <> text ");")++generate eval = + do tell $ (++ "\n") $ render $ vcat $ [text "struct" <+> text name <> semi | Struct name _ <- fst $ structs eval]+ tell $ (++ "\n") $ render $ vcat $ map pretty $ snd $ structs eval+ tell $ printTreeStateType eval + tell $ (++ "\n") $ render $ vcat $ map pretty $ fst $ structs eval+ tell ("\n\nvoid eval(" ++ spacetype ++ "* root) {\n")+ tell $ (++ "\n") $ render $ nest 2 $ initIntVars eval+ tell $ (++ "\n") $ render $ nest 2 $ initIntArrays eval+ tell "\n Gecode::SpaceStatus status = root->status();\n"+ tell "\n"+ tell " std::list<TreeState> *queue = new std::list<TreeState>();\n"+ tell $ render (nest 2 (initEvalState eval)) ++ "\n"+ tell " TreeState estate;\n"+ initTreeState info eval >>= tell . (++ "\n") . rp 2+ tryE eval info >>= tell . (++ "\n") . rp 2+ continue eval (estate info) >>= \c -> tell $ " while ( !queue->empty() && (" ++ rp 0 c ++ ")) {\n"+ tell " /* pop first element */\n" + tell " estate = queue->front();\n"+ tell " queue->pop_front();\n"+ bodyE eval info >>= tell . (++ "\n") . rp 4+ tell " }\n"+ tell "}"++rp n = render . nest n . pretty++--------------------------------------------------------------------------------+-- TESTS+--------------------------------------------------------------------------------+testHorst = search $ prt ["q"] <@> label "q" ubV maxV minD ($==)++--------------------------------------------------------------------------------+test0 = search $ lds 3 <@> dbs 4 <@> prt ["get"] <@> label "get" ubV maxV minD ($==)+ ++t0 = putStrLn test0+w0 f = writeFile f test0++--------------------------------------------------------------------------------+test1 = search $ lds 1000 <@> (b1 <&> (b2 <&> b3 ))+ where+ b1 = label "getP" lbV minV meanD ($<=)+ b2 = prt ["getQ"] <@> label "getQ" ubV maxV minD ($==)+ b3 = label "getP" lbV minV meanD ($<=)++t1 = putStrLn test1+w1 f = writeFile f test1++--------------------------------------------------------------------------------+test2 = search $ nb 100 <@> (b1 <&> (b2 <&> b3))+ where+ b1 = label "get" lbV minV meanD ($<=)+ b2 = nb 5 <@> prt ["get"] <@> label "get" ubV maxV minD ($==)+ b3 = label "get" lbV minV meanD ($<=)++t2 = putStrLn test2+w2 f = writeFile f test2++--------------------------------------------------------------------------------+test3 = search $ nb 1000 <@> (until (appStat (@> 4) depthStat) b1 b2)+ where+ b1 = label "get" lbV minV minD ($==)+ b2 = prt ["get"] <@> label "get" lbV minV maxD ($==)+++t3 = putStrLn test3+w3 f = writeFile f test3++--------------------------------------------------------------------------------+test4 = search $ dbs 10 <@> prt ["get"] <@> label "get" lbV minV minD ($==)+test5 = search $ until (appStat (@> 11) depthStat) (prt ["get"] <@> label "get" lbV minV minD ($==)) failure+--------------------------------------------------------------------------------+test6 = search $ label "get" lbV minV minD ($==) <|> label "get" lbV minV minD ($==)++----+test7 = search $ (nb 10 <@> label "getP" lbV minV minD ($==)) <&> (nb 20 <@> label "getQ" lbV minV minD ($==)) ++--------------------------------------------------------------------------------+test8 = search $ prt ["get"] <@> ((label "get" lbV minV minD ($==) <|> label "get" lbV minV minD ($==)) <|> label "get" lbV minV minD ($==))++--------------------------------------------------------------------------------+test9 = search $ prt ["get"] <@> ((b1 <&> b2) <|> b3) + where b1 = nb 2 <@> label "get" lbV minV minD ($==) + b2 = label "get" lbV minV minD ($==) + b3 = label "get" lbV minV minD ($==)++--------------------------------------------------------------------------------+testa = search $ prt ["get"] <@> repeat (label "get" lbV minV minD ($==))++--------------------------------------------------------------------------------+testb = search $ prt ["get"] <@> for 4 (label "get" lbV minV minD ($==))++--------------------------------------------------------------------------------+testc = search $ prt ["get"] <@> foreach 6 (\index -> until (depthStat #> index) + (label "get" lbV minV minD ($==)) + failure+ )++--------------------------------------------------------------------------------+testd = search $ prt ["q"] <@> properLDS 7 (label "q" lbV minV minD ($==)) ++-- main = putStrLn test0++--------------------------------------------------------------------------------+-- COMPOSITION COMBINATORS+--------------------------------------------------------------------------------++def vars = label vars lbV minV minD ($==)++type MkEval m = Eval m -> State Int (Eval m)++fixall :: MkEval m -> Eval m+fixall f = let this = fst $ runState 0 $ f this+ in this++data Search = forall t2. FMonadT t2 =>+ Search { mkeval :: forall m t1. (Monad m, FMonadT t1) => MkEval ((t1 :> t2) m)+ , runsearch :: forall m x. Monad m => t2 m x -> m x+ , iscomplete :: Info -> Value+ }++type IsComplete = Info -> Value++nb :: Int32 -> Search+nb n = + Search { mkeval = nbLoop n + , runsearch = runIdT+ , iscomplete = const true -- DUMMY VALUE+ }++bbmin :: String -> Search+bbmin var = + Search { mkeval = bbLoop var + , runsearch = runIdT+ , iscomplete = const true+ }++lds :: Int32 -> Search+lds n = + Search { mkeval = ldsLoop n+ , runsearch = runIdT+ , iscomplete = \i -> estate i @=> "lds_complete"+ }++properLDS + :: Int32 + -> Search+ -> Search+properLDS n search = foreach n (\limit -> until (discrepancyStat #> limit)+ search+ failure)+limit :: Int32 -> Stat -> Search -> Search+limit n stat s = until (stat #> const (IVal n)) s failure++once :: Search+once = + Search { mkeval = onceLoop+ , runsearch = runIdT+ , iscomplete = const true -- DUMMY VALUE+ } ++dbs :: Int32 -> Search+dbs n = + Search { mkeval = dbsLoop n+ , runsearch = runIdT+ , iscomplete = \i -> estate i @=> "dbs_complete"+ } ++prt :: [String] -> Search+prt str = + Search { mkeval = printLoop str+ , runsearch = runIdT+ , iscomplete = const true+ }++fs :: Search+fs =+ Search { mkeval = nSolutionsLoop 1+ , runsearch = runIdT+ , iscomplete = const true+ }++failure :: Search+failure = + Search { mkeval = return . failLoop+ , runsearch = runIdT+ , iscomplete = const false+ }++(<@>)+ :: Search -> Search -> Search+s1 <@> s2 = + case s1 of+ Search { mkeval = evals1, runsearch = runs1, iscomplete = iscompletes1 } ->+ case s2 of+ Search { mkeval = evals2, runsearch = runs2, iscomplete = iscompletes2 } ->+ 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+ , iscomplete = \i -> iscompletes1 i &&& iscompletes2 i+ }++(<&>)+ :: Search+ -> Search+ -> Search+s1 <&> s2 = + case s1 of+ Search { mkeval = evals1, runsearch = runs1, iscomplete = iscompletes1 } ->+ case s2 of+ Search { mkeval = evals2, runsearch = runs2, iscomplete = iscompletes2 } ->+ 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) $ + seqLoop uid (mapE (L . mmap (mmap L) . runL . runL) s1')+ (mapE (L . mmap (mmap L) . runL . runL . runL) s2')+ }+ , runsearch = runs2 . runs1 . runL . runReaderT FirstS . runL+ , iscomplete = const true -- DUMMY VALUE+ }++(<|>)+ :: Search+ -> Search+ -> Search+s1 <|> s2 = + case s1 of+ Search { mkeval = evals1, runsearch = runs1, iscomplete = iscompletes1 } ->+ case s2 of+ Search { mkeval = evals2, runsearch = runs2, iscomplete = iscompletes2 } ->+ 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 . runReaderT FirstS . runL+ , iscomplete = \i -> Cond (tstate i @-> "is_fst") (iscompletes1 (i `withPath` in1)) (iscompletes2 (i`withPath` in2))+ }++mmap :: (FMonadT t, Monad m, Monad n) => (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 }++search :: Search -> String+search s = + case s of+ Search { mkeval = evals, runsearch = runs } ->+ snd $ runId $ runs $runWriterT $ generate $ mapE runL $ fixall $ evals++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+ , iscomplete = const true -- PROPER VALUE+ }++vlabel :: String -> (Value -> Value) -> (Value -> Value -> Constraint) -> Search+vlabel get valSel rel = + Search { mkeval = \this -> baseLoop (v1Label get valSel rel this) this + , runsearch = runIdT+ , iscomplete = const true -- PROPER VALUE+ }++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+ , iscomplete = const true -- PROPER VALUE+ }++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+ , iscomplete = const true -- PROPER VALUE+ }++until + :: Stat+ -> Search+ -> Search+ -> Search+until cond s1 s2 = + case s1 of+ Search { mkeval = evals1, runsearch = runs1, iscomplete = iscompletes1 } ->+ case s2 of+ Search { mkeval = evals2, runsearch = runs2, iscomplete = iscompletes2 } ->+ 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) $ + untilLoop cond uid (mapE (L . mmap (mmap L) . runL . runL) s1', iscompletes1)+ (mapE (L . mmap (mmap L) . runL . runL . runL) s2', iscompletes2)+ }+ , runsearch = runs2 . runs1 . runL . runReaderT FirstS . runL+ , iscomplete = \i -> estate i @=> "until_complete"+ } ++repeat + :: Search+ -> Search+repeat s = + case s of+ Search { mkeval = evals, runsearch = runs, iscomplete = iscompletes } ->+ 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 . runReaderT True . runL+ , iscomplete = const true -- PROPER VALUE (TODO: repeat only steps when the search is complete)+ } ++for+ :: Int32+ -> Search+ -> Search+for n s = + case s of+ Search { mkeval = evals, runsearch = runs, iscomplete = iscompletes } ->+ 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', iscompletes)+ }+ , runsearch = runs . runReaderT True . runL+ , iscomplete = iscompletes+ }++foreach+ :: Int32+ -> ((Info -> Value) -> Search)+ -> Search+foreach n mksearch = + case mksearch (\i -> field i "counter") of+ Search { mkeval = eval, runsearch = run, iscomplete = cpl } ->+ 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', cpl)+ }+ , runsearch = run . runReaderT True . runL+ , iscomplete = cpl+ }++-- ========================================================================== --+-- IVALUE+-- ========================================================================== --++type IValue = Info -> Value++instance Show (Info -> Value) where+ show x = "<IValue>"+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 = undefined+ signum = undefined++-- ========================================================================== --+-- STATS+-- ========================================================================== --++data Stat = Stat (forall m. Monad m => Eval m -> Eval m) + IValue++instance Show Stat where+ show x = "<Stat>"+instance Eq Stat where+ x == y = False++readStat (Stat _ r) = r+evalStat (Stat e _) = e++-- -------------------------------------------------------------------------- --++instance Num Stat where+ x - y = undefined+ fromInteger x = Stat dummyLoop (fromInteger x)+ x + y = undefined+ x * y = undefined+ abs = undefined+ signum = undefined++appStat :: (Value -> Value) -> Stat -> Stat+appStat f (Stat e r) = Stat e (f . r)++liftStat :: (Value -> Value -> Value) -> Stat -> IValue -> Stat+liftStat op (Stat e r) x = Stat e (\i -> r i`op` x i)++(#>) :: Stat -> IValue -> Stat+(#>) stat x = liftStat (@>) stat x++-- -------------------------------------------------------------------------- --++depthStat :: Stat+depthStat = + Stat (\super -> + let push dir = \i -> dir super (i `onCommit` mkUpdate i "depth" (\x -> x + 1))+ in super+ { treeState_ = entry "depth" Int (assign $ 0) : treeState_ super+ , pushLeft = push pushLeft+ , pushRight = push pushRight+ })+ (\info -> tstate info @-> "depth")++discrepancyStat :: Stat+discrepancyStat = + Stat + (\super -> + super+ { treeState_ = entry "discrepancy" Int (assign $ 0) : treeState_ super+ , pushLeft = \i -> pushLeft super (i `onCommit` mkCopy i "discrepancy")+ , pushRight = \i -> pushRight super (i `onCommit` mkUpdate i "discrepancy" (\x -> x + 1))+ })+ (\info -> tstate info @-> "discrepancy")++nodesStat :: Stat+nodesStat = + eStat ("nodes", Int, 0) $+ \super -> super { bodyE = \i -> return (inc (estate i @=> "nodes")) @>>>@ bodyE super i }++solutionsStat :: Stat+solutionsStat = + eStat ("solutions", Int, 0) $+ \super -> super {returnE = \i -> returnE super (i `onCommit` dec (solutions i))}+ where solutions i = estate i @=> "solutions"++failsStat :: Stat+failsStat = + eStat ("fails", Int, 0)+ $ \super -> super { failE = \i -> returnE super i @>>>@ return (inc (fails i)) }+ where fails i = estate i @=> "fails"++eStat :: (String, Type, Value) -> (forall m. Monad m => Eval m -> Eval m) -> Stat+eStat entry@(name,_,_) f =+ Stat (\super -> f $ super { evalState = entry : evalState super })+ (\i -> estate i @=> name)
+ Control/CP/SearchSpec/Language.hs view
@@ -0,0 +1,345 @@+module Control.CP.SearchSpec.Language where ++import Text.PrettyPrint+import Data.Monoid+import Data.Int++spacetype = "MCPProgram"++instance Monoid Statement where+ mempty = Skip+ mappend = (>>>)+++class Pretty x where+ pretty :: x -> Doc++data Struct = Struct String [(Type,String)] deriving (Show, Eq)++instance Pretty Struct where+ pretty (Struct name fields) =+ text "struct" <+> text name <+> text "{"+ $+$ nest 2 (vcat [pretty 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)++data Value = IVal Int32+ | BVal Bool+ | RootSpace+ | Minus Value Value+ | Plus Value Value+ | Div Value Value+ | Mod Value Value+ | Abs Value+ | Var String+ | 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+ | CVar String Value Value+ | XVar String Value String+ | MinDom Value+ | MaxDom Value+ | SizeDom Value+ | Degree Value+ | WDegree Value+ | UbRegret Value+ | LbRegret Value+ | Median Value+ | Random + | Null+ | New Struct+ | Base+ | Cond Value Value Value+ | Assigned Value+ deriving (Show, Eq)++instance Num Value where+ (-) = Minus+ fromInteger = IVal . fromInteger+ (+) = Plus+ (*) = undefined+ abs = Abs+ signum = undefined++true = BVal True+false = BVal False+(&&&) = And+(|||) = Or+(@>) = Gt+(@>=) = Gq+(@==) = 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+ _ -> x'+simplValue v = v++instance Pretty Type where+ pretty (Pointer t) = pretty t <> text "*"+ pretty SpaceType = text spacetype+ pretty Int = text "int"+ pretty Bool = text "bool"+ pretty (Union fields) = + text "union" <+> text "{"+ $+$ nest 2 (vcat [pretty ty <+> text f <> text ";" | (ty,f) <- fields])+ $+$ text "}" + pretty (SType (Struct name fields)) =+ text name+ pretty (THook str) = + text str++instance Pretty Value where+ pretty = pretty_ . simplValue+ where+ pretty_ (Cond c t e) = pretty c <+> text "?" <+> pretty t <+> text ":" <+> pretty e+ pretty_ Base = text "<BASE>"+ pretty_ Null = text "NULL"+ pretty_ (IVal i) = int $ fromInteger $ toInteger i+ pretty_ (BVal True) = text "true" + pretty_ (BVal False) = text "false" + pretty_ (Abs x) = text "abs" <> parens (pretty_ x)+ pretty_ RootSpace = text "root"+ pretty_ (Minus v1 v2) = pretty_ v1 <+> text "-" <+> pretty_ v2+ pretty_ (Plus v1 v2) = pretty_ v1 <+> text "+" <+> pretty_ v2+ pretty_ (Div v1 v2) = parens (pretty_ v1) <+> text "/" <+> parens (pretty_ v2)+ pretty_ (Mod v1 v2) = parens (pretty_ v1) <+> text "%" <+> parens (pretty_ v2)+ pretty_ (Var x) = text x+ pretty_ (Clone x) = text ("static_cast<" ++ spacetype ++ "*>(") <> pretty_ x <> text "->clone(true))"+ -- pretty_ (Clone x) = text ("static_cast<" ++ spacetype ++ "*>(") <> pretty_ x <> text "->clone(false))"+ pretty_ (Field r f) = text r <> text "." <> text f+ pretty_ (Field' r f) = pretty_ r <> text "." <> text f+ pretty_ (PField (Field' (Var _) "evalState") f)+ = text f+ pretty_ (PField r f) = pretty_ r <> text "->" <> text f+ pretty_ (Lt x y) = parens (pretty_ x) <+> text "<" <+> parens (pretty_ y) + pretty_ (Gq x y) = parens (pretty_ x) <+> text ">=" <+> parens (pretty_ y) + pretty_ (Gt x y) = parens (pretty_ x) <+> text ">" <+> parens (pretty_ y) + pretty_ (Eq x y) = parens (pretty_ x) <+> text "==" <+> parens (pretty_ y) + pretty_ BaseContinue = text "! queue->empty()"+ pretty_ (And x y) = parens (pretty x) <+> text "&&" <+> parens (pretty y) + pretty_ (Or x y) = parens (pretty x) <+> text "||" <+> parens (pretty y) + pretty_ (Not x) = text "!" <> parens (pretty x)+ pretty_ (VHook s) = text s+ pretty_ (Max x y) = text "max" <> parens (pretty x <> text "," <> pretty y)+ -- pretty_ (CVar vs s i) = pretty_ s <> text "->" <> text vs <> text "()" <> brackets (pretty i)+ pretty_ (CVar vs s i) = pretty_ s <> text "->getVar" <> parens (text "$ARR_" <> text vs <> brackets (pretty i))+ pretty_ (XVar vs s i) = pretty_ s <> text "->getVar" <> parens (text "$ARR_" <> text vs <> brackets (text i))+ pretty_ (MinDom v) = pretty_ v <> text ".min()"+ pretty_ (MaxDom v) = pretty_ v <> text ".max()"+ pretty_ (SizeDom v) = pretty_ v <> text ".size()"+ pretty_ (Degree v) = pretty_ v <> text ".degree()"+ pretty_ (WDegree v) = pretty_ v <> text ".afc()" -- aka accumulated failure count+ pretty_ (UbRegret v) = pretty_ v <> text ".regret_max()"+ pretty_ (LbRegret v) = pretty_ v <> text ".regret_min()"+ pretty_ (Median v) = pretty_ v <> text ".med()"+ pretty_ Random = text "rand()"+ pretty_ (New (Struct name _)) = text "new" <+> text name+ pretty_ (Assigned var) = pretty_ var <> text ".assigned()"++data Constraint = EqC Value Value+ | NqC Value Value+ | LtC Value Value+ | LqC Value Value+ | GtC Value Value+ | GqC Value Value+ ++($==) = 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+ pretty (EqC x y) =+ pretty x <> text "," <> text "IRT_EQ" <> text "," <> pretty y+ pretty (NqC x y) =+ pretty x <> text "," <> text "IRT_NQ" <> text "," <> pretty y+ pretty (LtC x y) =+ pretty x <> text "," <> text "IRT_LE" <> text "," <> pretty y+ pretty (LqC x y) =+ pretty x <> text "," <> text "IRT_LQ" <> text "," <> pretty y+ pretty (GtC x y) =+ pretty x <> text "," <> text "IRT_GR" <> text "," <> pretty y+ pretty (GqC x y) =+ pretty x <> text "," <> text "IRT_GQ" <> text "," <> pretty y+++data Statement = IfThenElse Value Statement Statement+ | Push Value+ | Skip+ | Update Value Value+ | 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)+ | MFold String [(Value, Value->Value)] ([Value] -> [Value] -> Value)+ | Delete Value++dec var = Update var (var - 1)+inc var = Update var (var + 1)+(>>>) = Seq+(<==) = Update+assign = flip Update+ifthen c t = IfThenElse c t Skip+seqs = foldr (>>>) Skip++instance Pretty Statement where+ pretty (Push tstate) = + text "queue->push_front" <> parens (pretty tstate) <> text ";"+ pretty (IfThenElse c t e) =+ let c' = simplValue c+ in case c' of + BVal True -> pretty t+ BVal False -> pretty e+ c -> case e of+ Skip -> text "if" <+> parens (pretty c) <+> text "{" $+$ nest 2 (pretty t) $+$ text "}"+ _ -> text "if" <+> parens (pretty c) <+> text "{" $+$ nest 2 (pretty t) $+$ text "} else {" $+$ nest 2 (pretty e) $+$ text "}"+ pretty Skip =+ empty+ pretty (Update var (Minus val 1))+ | var == val+ = pretty var <> text "--;"+ pretty (Update var (Plus val 1))+ | var == val+ = pretty var <> text "++;"+ pretty (Update var val) =+ pretty var <+> text "=" <+> pretty val <> text ";"+ pretty (Seq s1 s2) =+ pretty s1 $+$ pretty s2+ pretty (Assign x Null) = pretty x+ pretty (Assign x y) =+ pretty x <+> text "=" <+> pretty y <> text ";"+ pretty Abort =+ text "break;"+ pretty (Print space vs) = (vcat $ map (\s -> text ("std::cout << \"[\"; for (int i=0; i<$ARR_" ++ s ++ ".size(); i++) { std::cout << ") <> pretty (XVar s space "i") <> text " << \" \"; }; std::cout << \"] \";") vs) <> text "std::cout << std::endl;"+ pretty (SHook s) =+ text s+ pretty (Post space c) = + text "rel(*" <> parens (pretty space) <> text "," <> pretty c <> text ");" + pretty (Fold vars state space m0 metric better) = + let+ pos = Field' state "pos"+ size = VHook $ render $ text "$ARR_" <> text vars <> text ".size()" + in+ text "int best_pos = -1;" + $+$ pretty (Update pos 0)+ $+$ text "for (int metric = " <> pretty m0 <> text "; " <> pretty (pos @< size ) <> text "; " <> pretty pos <> text "++) {"+ $+$ nest 2 (text "if" <+> parens (text "!" <> pretty (CVar vars space pos) <> text ".assigned()") <+> text "{"+ $+$ nest 2 ( text "int current_metric = " <> pretty (metric (CVar vars space pos)) <> text ";"+ $+$ pretty (IfThenElse (Var "current_metric" `better` Var "metric")+ (Update (Var "metric") (Var "current_metric") >>> (Update (Var "best_pos") pos))+ Skip+ )+ )+ $+$ text "}"+ )+ $+$ text "}" + $+$ pretty (Update pos (Var "best_pos")) + pretty (IFold vars state space m0 metric better) = + let+ pos = Field' state "pos"+ size = VHook $ render $ text "$ARR_" <> text vars <> text ".size()" + in+ text "int best_pos = -1;" + $+$ pretty (Update pos 0)+ $+$ text "for (int metric = " <> pretty m0 <> text "; " <> pretty (pos @< size ) <> text "; " <> pretty pos <> text "++) {"+ $+$ nest 2 (text "if" <+> parens (text "!" <> pretty (CVar vars space pos) <> text ".assigned()") <+> text "{"+ $+$ nest 2 ( text "int current_metric = " <> pretty (metric pos) <> text ";"+ $+$ pretty (IfThenElse (Var "current_metric" `better` Var "metric")+ (Update (Var "metric") (Var "current_metric") >>> (Update (Var "best_pos") pos))+ Skip+ )+ )+ $+$ text "}"+ )+ $+$ text "}" + $+$ pretty (Update pos (Var "best_pos")) + pretty (MFold state metrics better) = + let+ space = Field "estate" "space"+ pos = Field state "pos"+ cvar = CVar "get" space pos+ size = VHook $ render $ pretty 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 [pretty v <+> text "=" <+> pretty z | (v,(z,_)) <- zip acc_vars metrics]+ computations = vcat $ [text "int" <+> pretty (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;" + $+$ pretty (Update pos 0)+ $+$ text "for (int " <> init_list <> text "; " <> pretty (pos @< size ) <> text "; " <> pretty pos <> text "++) {"+ $+$ nest 2 (text "if" <+> parens (text "!" <> pretty cvar <> text ".assigned()") <+> text "{"+ $+$ nest 2 ( computations+ $+$ pretty (IfThenElse (cur_vars `better` acc_vars)+ (updates >>> (Update (Var "best_pos") pos))+ Skip+ )+ )+ $+$ text "}"+ )+ $+$ text "}" + $+$ pretty (Update pos (Var "best_pos")) + pretty (Delete value) =+ text "delete" <+> pretty value <> text ";" +
Control/CP/SearchTree.hs view
@@ -7,6 +7,7 @@ -} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE GADTs #-}+{-# LANGUAGE RankNTypes #-} {-# LANGUAGE FlexibleContexts #-} module Control.CP.SearchTree (@@ -14,7 +15,6 @@ transformTree, bindTree, insertTree,- (\/), (/\), true, disj,@@ -25,20 +25,18 @@ addT, exist, forall,- addTo,- false,- exists,- label, indent, showTree,- MonadTree,+ mapTree,+ MonadTree(..), untree ) where import Control.CP.Solver-import Control.CP.Mixin+import Control.Mixin.Mixin import Control.Monad+import Control.Monad.Cont import Control.Monad.Reader import Control.Monad.Writer import Control.Monad.State@@ -58,6 +56,16 @@ 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@@ -67,6 +75,14 @@ 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 @@ -166,11 +182,11 @@ -- 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+ 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@@ -179,6 +195,14 @@ (\/) = 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 -------------------------------------
Control/CP/Solver.hs view
@@ -16,12 +16,12 @@ Label, add, run,- mark,+ mark, markn, goto, Term, newvar, Help,- help+ help, ) where import Control.Monad.Writer@@ -39,16 +39,30 @@ 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@@ -57,10 +71,10 @@ 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 _ _ = ()-
Control/CP/Transformers.hs view
@@ -6,6 +6,7 @@ {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE Rank2Types #-}+{-# LANGUAGE BangPatterns #-} module Control.CP.Transformers ( eval, eval',@@ -32,15 +33,15 @@ 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 (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 <- mark + 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
+ Control/Mixin/Mixin.hs view
@@ -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
+ Data/Expr/Data.hs view
@@ -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
+ Data/Expr/Sugar.hs view
@@ -0,0 +1,286 @@+{- + - 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,+ ExprClass,+ 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+
+ Data/Expr/Util.hs view
@@ -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<b++-------------------------------------------------------------------------+-- | Transform expressions over one type to expressions over another | --+-------------------------------------------------------------------------++transform :: (Eq a, Eq b, Eq c, Eq d, Eq e, Eq f) => (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<l -> 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],[])+
+ Data/Linear.hs view
@@ -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, 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, 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, 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, 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, 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, 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
+ Language/CPP/Pretty.hs view
@@ -0,0 +1,241 @@+{-# 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<outerL then parens doc else doc++instance Pretty CPPExpr where+ prettyPrec l (CPPConst x) = prettyPrec l x+ prettyPrec l (CPPAssign o1 op o2) = prio 4 l $ (prettyPrec 5 o1) <+> (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
+ Language/CPP/Syntax/AST.hs view
@@ -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)
examples/AllInterval.hs view
@@ -1,18 +1,28 @@-{-# LANGUAGE OverlappingInstances #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE FlexibleContexts #-} -import Control.CP.FD.Example.Example-import Control.CP.FD.FD-import Control.CP.FD.Expr-import Control.CP.SearchTree+import Control.CP.FD.Example -main = example_main_single model+-- 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 n = exist n $ \list -> do- allin list (0,n-1)- let dlist = zipWith (\a b -> abs $ a-b) (take (n-1) list) (tail list)- allin dlist (1,n-1)- allDiff list- allDiff dlist- (list!!0) @< (list!!1)- (dlist!!0) @> (dlist!!(n-2))- return list+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+
examples/Alpha.hs view
@@ -1,61 +1,53 @@--- ----------------------------------------------------------------------------- Benchmark (Finite Domain) INRIA Rocquencourt - ChLoE Project ----- ----- Name : alpha.pl ----- Title : alphacipher ----- Original Source: Daniel Diaz - INRIA France ----- Date : January 1993 ----- Adapted for MCP: Tom Schrijvers ----- ----- This problem comes from the news group rec.puzzle. ----- The numbers 1 - 26 have been randomly assigned to the letters of the ----- alphabet. The numbers beside each word are the total of the values ----- assigned to the letters in the word. e.g for LYRE L,Y,R,E might equal ----- 5,9,20 and 13 respectively or any other combination that add up to 47. ----- Find the value of each letter under the equations: ----- ----- BALLET 45 GLEE 66 POLKA 59 SONG 61 ----- CELLO 43 JAZZ 58 QUARTET 50 SOPRANO 82 ----- CONCERT 74 LYRE 47 SAXOPHONE 134 THEME 72 ----- FLUTE 30 OBOE 53 SCALE 51 VIOLIN 100 ----- FUGUE 50 OPERA 65 SOLO 37 WALTZ 34 ----- ----- Solution: ----- [A, B,C, D, E,F, G, H, I, J, K,L,M, N, O, P,Q, R, S,T,U, V,W, X, Y, Z] ----- [5,13,9,16,20,4,24,21,25,17,23,2,8,12,10,19,7,11,15,3,1,26,6,22,14,18] ----- --------------------------------------------------------------------------+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE FlexibleContexts #-} -import Control.CP.FD.Example.Example-import Control.CP.FD.FD-import Control.CP.FD.Expr+-- 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 -main = example_main_void model -model :: FDSolver solver => Tree (FDWrapper solver) [FDExpr solver]-model =- exist 26 $ - \list@[a,b,c,d,e,f,g,h,i,j,k,l,m,n,o,p,q,r,s,t,u,v,w,x,y,z] ->- allin list (1,26) /\- allDiff list /\- b + a + l + l + e + t @= 45 /\- c + e + l + l + o @= 43 /\- c + o + n + c + e + r + t @= 74 /\- f + l + u + t + e @= 30 /\- f + u + g + u + e @= 50 /\- g + l + e + e @= 66 /\- j + a + z + z @= 58 /\- l + y + r + e @= 47 /\- o + b + o + e @= 53 /\- o + p + e + r + a @= 65 /\- p + o + l + k + a @= 59 /\- q + u + a + r + t + e + t @= 50 /\- s + a + x + o + p + h + o + n + e @= 134 /\- s + c + a + l + e @= 51 /\- s + o + l + o @= 37 /\- s + o + n + g @= 61 /\- s + o + p + r + a + n + o @= 82 /\- t + h + e + m + e @= 72 /\- v + i + o + l + i + n @= 100 /\- w + a + l + t + z @= 34 /\- return list+(@==) :: (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
+ examples/BIBD.hs view
@@ -0,0 +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))++
+ examples/Domino.hs view
@@ -0,0 +1,95 @@+{-# 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 = 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)))
+ examples/EFPA.hs view
@@ -0,0 +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))
+ examples/GolombRuler.hs view
@@ -0,0 +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
+ examples/GraphColor.hs view
@@ -0,0 +1,414 @@+{-# 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 = 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+ ]
examples/Grocery.hs view
@@ -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.Example-import Control.CP.FD.FD-import Control.CP.FD.Expr-import Control.CP.SearchTree+import Control.CP.FD.Example -main = example_main_void model+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 -model :: FDModel-model =- exist 4 $ \list@[a,b,c,d] -> - list `allin` (0,711) /\- a + b + c + d @= 711 /\- (a * b) * (c * d) @= 711*100*100*100 /\- sorted list /\- return list+main = example_sat_main_void model
+ examples/LangfordNumber.hs view
@@ -0,0 +1,27 @@+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE FlexibleContexts #-}++import Control.CP.FD.Example++model :: ExampleModel ModelCol+model c = do+ let 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+
+ examples/MagicSeries.hs view
@@ -0,0 +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
examples/MagicSquare.hs view
@@ -1,31 +1,34 @@-import Control.CP.FD.Example.Example-import Control.CP.FD.FD-import Control.CP.FD.Expr-import Control.CP.SearchTree-import Data.List (transpose)+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE FlexibleContexts #-} -main = example_main_single model+import Control.CP.FD.Example -cutAt p l = case (splitAt p l) of- (l,[]) -> [l]- (b,r) -> b:(cutAt p r)-mexist r c = exist (r*c) $ \list -> return $ cutAt c list-lsum v l = (foldl1 (+) l) @= v-diag bc ic m = map (\x -> (m!!x)!!(bc+ic*x)) [0..(length m)-1]+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)) -interleave [] ys = ys-interleave (x:xs) ys = x : (interleave ys xs)+row :: ModelInt -> ModelCol -> ModelInt -> ModelCol+row n l i = path n l (const i) id -model n = do+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 = nn*(nn+1) `div` (2*n)- let sums = lsum $ cte s- m <- mexist n n- allin (concat m) (1,nn)- conj $ interleave (map sums m) (map sums $ transpose m)- sums $ diag 0 1 m- sums $ diag (n-1) (-1) m- allDiff $ concat m- (m!!0)!!0 @> (m!!0)!!(n-1)- (m!!0)!!0 @> (m!!(n-1))!!0- return $ concat m+ 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
+ examples/MineSweeper.hs view
@@ -0,0 +1,46 @@+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE FlexibleContexts #-}++import Control.CP.FD.Example++aroundY = list [-1,-1,0,1,1,1,0,-1]+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 = 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+ ]
− examples/Olympic.hs
@@ -1,51 +0,0 @@-{--% 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 X1 -- 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.Example-import Control.CP.FD.FD-import Control.CP.FD.Expr-import Control.CP.SearchTree--main = example_main_void model--model :: FDSolver solver => Tree (FDWrapper solver) [Expr (FDTerm solver)]-model = - exist 10 $ \list@[x1,x2,x3,x4,x5,x6,x7,x8,x9,x10] - -> list `allin` (1,10) /\ - allDiff list /\ - 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 list--minus x1 x2 x3 = (abs (x1-x2)) @= x3
examples/Partition.hs view
@@ -1,73 +1,32 @@--- ----------------------------------------------------------------------------- Benchmark (Finite Domain) ----- ----- Name : partit.pl ----- Title : integer partitionning ----- Original Source: Daniel Diaz - INRIA France ----- Adapted by : Daniel Diaz for GNU Prolog ----- Date : September 1993 (modified March 1997) ----- ----- Partition numbers 1,2,...,N into two groups A and B such that: ----- a) A and B have the same length, ----- b) sum of numbers in A = sum of numbers in B, ----- c) sum of squares of numbers in A = sum of squares of numbers in B. ----- ----- This problem admits a solution if N is a multiple of 8. ----- ----- Note: finding a partition of 1,2...,N into 2 groups A and B such that: ----- ----- Sum (k^p) = Sum l^p ----- k in A l in B ----- ----- admits a solution if N mod 2^(p+1) = 0 (N is a multiple of 2^(p+1)). ----- Condition a) is a special case where p=0, b) where p=1 and c) where p=2.----- ----- Two redundant constraints are used: ----- ----- - in order to avoid duplicate solutions (permutations) we impose ----- A1<A2<....<AN/2, B1<B2<...<BN/2 and A1<B1. This achieves much more ----- pruning than only fd_all_differents(A) and fd_all_differents(B). ----- ----- - the half sums are known ----- N ----- Sum k^1 = Sum l^1 = (Sum i) / 2 = N*(N+1) / 4 ----- k in A l in B i=1 ----- N ----- Sum k^2 = Sum l^2 = (Sum i^2)/2 = N*(N+1)*(2*N+1) / 12 ----- k in A l in B i=1 ----import Control.CP.FD.Example.Example-import Control.CP.FD.FD-import Control.CP.FD.Expr-import Control.CP.SearchTree+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE FlexibleContexts #-} -main = example_main_single model+import Control.CP.FD.Example +model :: ExampleModel ModelInt model n =- exist n $ \list1 ->- exist n $ \list2 ->- allin list1 (1,2*n) /\- allin list2 (1,2*n) /\- (let list = list1 ++ list2 - in ascending list1 /\- ascending list2 /\- head list1 @< head list2 /\- allDiff list /\- csum list1 @= csum list2 /\- csum (square list1) @= csum (square list2) /\- csum list1 @= (cte $ hs (2*n)) /\- csum list2 @= (cte $ hs (2*n)) /\- csum (square list1) @= (cte $ hss (2*n)) /\- csum (square list2) @= (cte $ hss (2*n)) /\- return list- ) --ascending list = sSorted list--hs, hss :: Int -> Int-hs n = (n * (n + 1)) `div` 4-hss n = (n * (n + 1) * (2 * n +1)) `div` 12+ 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 -csum l = foldl1 (+) l+main = example_sat_main_single_expr model -square l = map (\x -> x * x) l
+ examples/PerfectSquare.hs view
@@ -0,0 +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
examples/Queens.hs view
@@ -1,20 +1,18 @@-{- - - Monadic Constraint Programming- - http://www.cs.kuleuven.be/~toms/Haskell/- - Tom Schrijvers & Pieter Wuille- -}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE FlexibleContexts #-} -import Control.CP.FD.Example.Example-import Control.CP.FD.FD-import Control.CP.FD.Expr-import Control.CP.SearchTree+import Control.CP.FD.Example -main = example_main_single nqueens+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 -> do+ loopall (i+1,n-1) $ \j -> do+ (p!i) + i @/= (p!j) + j+ (p!i) - i @/= (p!j) - j+ return p -nqueens n = - exist n $ \q -> q `allin` (1,n) /\ conj [ - q!!i @/= q!!j /\ - (q!!i) @+ i @/= (q!!j) @+ j /\ - (q!!i) @- i @/= (q!!j) @- j - | i <- [0..n-1], j <- [0..n-1], i > j - ] /\ return q+main = example_sat_main_single_expr model+
− examples/Ring.hs
@@ -1,30 +0,0 @@-import Control.CP.FD.Example.Example-import Control.CP.FD.FD-import Control.CP.FD.Expr-import Control.CP.SearchTree--import List (tails)-import Data.Map (toList)--main = example_main_single model---- generate a disjunction producing a list of variables, consisting of alr--- prefixed by up to maxlen new variables-varexist :: FDSolver solver => Int -> [FDExpr solver] -> Tree (FDWrapper solver) [FDExpr solver]-varexist maxlen alr = - if maxlen==0- then return alr- else return alr \/ (exists $ \x -> varexist (maxlen-1) (x:alr))---- constr list i = (if (i < (length list)-2) then v2 @= v0 * v1 - i else true) /\ v0 @: (-10,10)-constr list i = 2*v1 @= 2*v2 - v0 /\ - v0 @: (-10,10)- where v0 = list !! i- v1 = list !! ((i+1) `mod` (length list))- v2 = list !! ((i+2) `mod` (length list))--model :: FDSolver solver => Int -> Tree (FDWrapper solver) [FDExpr solver]-model n = exists $ \x -> - do list <- varexist n [x]- conj $ [ constr list i | i <- [0..(length list)-1] ]- return list
− examples/StressDomain.hs
@@ -1,23 +0,0 @@-import List (transpose)--import Control.CP.FD.Example.Example-import Control.CP.FD.FD-import Control.CP.FD.Expr-import Control.CP.SearchTree--main = example_main_single model--cutAt p l = case (splitAt p l) of- (l,[]) -> [l]- (b,r) -> b:(cutAt p r)-mexist r c = exist (r*c) $ \list -> return $ cutAt c list-lsum v l = (foldl1 (+) l) @= v-diag bc ic m = map (\x -> (m!!x)!!(bc+ic*x)) [0..(length m)-1]--model :: FDSolver solver => Int -> Tree (FDWrapper solver) [FDExpr solver]-model n = exist 5 $ \l -> do- allin l (0,5*n)- let forvar v = conj $ map (\p -> conj $ map (\j -> v @/= 5*j+p) [0..(cte (5*n))]) [0,2,4]- conj $ map forvar $ reverse l- conj $ map (\j -> conj $ map (\v -> v @>= cte (5*j) /\ v @<= cte (5*(j+5*(n `div` 2)))) $ reverse l) [0..5*(n `div` 2)]- return l
+ examples/Sudoku.hs view
@@ -0,0 +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
+ examples/Test.hs view
@@ -0,0 +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
+ examples/TestPretty.hs view
@@ -0,0 +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+
− examples/TryDemo.hs
@@ -1,19 +0,0 @@-{- - - Monadic Constraint Programming- - http://www.cs.kuleuven.be/~toms/Haskell/- - Tom Schrijvers & Pieter Wuille- -}--import Control.CP.FD.Example.Example-import Control.CP.FD.FD-import Control.CP.FD.Expr-import Control.CP.SearchTree--main = example_main_void model--model :: FDSolver solver => Tree (FDWrapper solver) [FDExpr solver]-model = exist 2 $ \[a,b] -> a @: (1,5) /\- b @: (0,4) /\- a - b @= 1 /\- (a @= 2 \/ a @= 3 \/ a @= 4) /\- return [a,b]
− examples/Zebra.hs
@@ -1,39 +0,0 @@-import Control.CP.FD.Example.Example-import Control.CP.FD.FD-import Control.CP.FD.Expr-import Control.CP.SearchTree--main = example_main_void model--model :: FDSolver solver => Tree (FDWrapper solver) [FDExpr solver]-model = - exist 5 $ \ns@[n1,n2,n3,n4,n5] -> - exist 5 $ \cs@[c1,c2,c3,c4,c5] -> - exist 5 $ \ps@[p1,p2,p3,p4,p5] -> - exist 5 $ \as@[a1,a2,a3,a4,a5] -> - exist 5 $ \ds@[d1,d2,d3,d4,d5] -> - let vars = ns ++ cs ++ ps ++ as ++ ds in- vars `allin` (1,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
lib/gecodeglue.cpp view
@@ -13,37 +13,79 @@ using namespace std; using namespace Gecode; +#ifndef NDEBUG int static nModels=0; int static nOrigModels=0;+#endif class HaskellModel : public Space { protected: vector<BoolVar> boolVars; vector<IntVar> intVars;+ vector<IntVarArgs> colVars; IntConLevel icl;+ int refcount;+ int minimizeVar; #ifndef NDEBUG int level; int origNum,num; #endif+ //void *dummy; private: static IntRelType mapGoperator(goperator_t op, bool revert=false) { switch(op) { case GOPERATOR_OEQUAL: return IRT_EQ; case GOPERATOR_ODIFF: return IRT_NQ; case GOPERATOR_OLESS: return revert ? IRT_GR : IRT_LE;+ case GOPERATOR_OLESSEQUAL: return revert ? IRT_GQ : IRT_LQ; } #ifndef NDEBUG cerr << "(unknown goperator " << op << "\n"; #endif assert(0);+ return((IntRelType)(-1)); }++ BoolVar inline getBoolVar(int var) const {+#ifndef NDEBUG+ cerr << "getBoolVar(" << var << ")" << endl;+#endif+ assert(var>=0 && var<(int)boolVars.size());+ return (boolVars[var]);+ }+ IntVarArgs inline getColVar(int var) const {+#ifndef NDEBUG+ cerr << "getColVar(" << var << ")" << endl;+#endif+ assert(var>=0 && var<(int)colVars.size());+ return (colVars[var]);+ }+ IntVar inline getIntVar(int var) const {+#ifndef NDEBUG+ cerr << "getIntVar(" << var << ")" << endl;+#endif+ assert(var>=0);+ if (var & ~0xFFFF) {+ IntVarArgs col=getColVar((var >> 16)-1);+ var &= 0xFFFF;+ assert(((int)var)<(int)col.size());+ return (col[var]);+ }+ assert(var<(int)intVars.size());+ return (intVars[var]);+ } + IntVar inline cost(void) const {+ return getIntVar(minimizeVar);+ }+ public:- HaskellModel() : boolVars(), intVars(), icl(ICL_DEF)+ HaskellModel() : boolVars(), intVars(), colVars(), icl(ICL_DEF), refcount(0), minimizeVar(-1) #ifndef NDEBUG , level(0), origNum(++nOrigModels), num(++nModels) #endif {+ //dummy=malloc(8192); #ifndef NDEBUG identify(); cerr << "newmodel\n"; #endif@@ -53,27 +95,39 @@ identify(); cerr << "delmodel\n"; #endif }- HaskellModel(bool share, HaskellModel &model) : Space(share,model), boolVars(model.boolVars.size()), intVars(model.intVars.size()), icl(model.icl)+ HaskellModel(bool share, HaskellModel &model) : Space(share,model), boolVars(model.boolVars.size()), intVars(model.intVars.size()), icl(model.icl), refcount(0), minimizeVar(model.minimizeVar) #ifndef NDEBUG , level(model.level+1), origNum(model.origNum), num(++nModels) #endif {+ //dummy=malloc(8192); #ifndef NDEBUG identify(); cerr << "newmodel from [" << model.origNum << ":" << model.num << "]\n"; #endif- for (int i=0; i<model.boolVars.size(); i++) {+ for (int i=0; i<(int)model.boolVars.size(); i++) { boolVars.at(i).update(*this, share, model.boolVars.at(i)); }- for (int i=0; i<model.intVars.size(); i++) {+ for (int i=0; i<(int)model.intVars.size(); i++) { intVars.at(i).update(*this, share, model.intVars.at(i)); }+ for (int i=0; i<(int)model.colVars.size(); i++) {+ IntVarArgs &col=model.colVars.at(i);+ IntVarArgs ncol=IntVarArgs(col.size());+ for (int j=0; j<(int)(col.size()); j++) {+ ncol[j].update(*this,share,col[j]);+ }+ colVars.push_back(ncol);+ } } virtual Space *copy(bool share) {+#ifndef NDEBUG+ identify(); cerr << "making copy\n";+#endif return new HaskellModel(share, *this); } #ifndef NDEBUG- void identify() {+ void identify() const { for (int i=0; i<level; i++) { cerr << " "; }@@ -99,165 +153,221 @@ #endif return ret; }- void getIntInfo(int var, int *min, int *max, int *med, int *size, int *val) {- assert(var>=0 && var<intVars.size());- IntVar &v = intVars.at(var);+ int addColVarSize(int count, int low, int high) {+ int ret = colVars.size();+#ifndef NDEBUG+ identify(); cerr << "addcolvar v" << ret << " (size " << count << ", ["<<low<<".."<<high<<"])\n";+#endif+ IntVarArray b(*this,count,low,high);+ colVars.push_back(b);+ return ret;+ }+ int addColVarList(int count, int *iids) {+ int ret = colVars.size();+#ifndef NDEBUG+ identify(); cerr << "addcolvar v" << ret << " (list size " << count << ")\n";+#endif+ IntVarArgs b(count);+ for (int i=0; i<count; i++) {+ b[i]=getIntVar(iids[i]);+ }+ colVars.push_back(b);+ return ret;+ }+ int addColVarCat(int c1, int c2) {+ int ret = colVars.size();+#ifndef NDEBUG+ identify(); cerr << "addcolvar v" << ret << " (cat c" << c1 << " c"<< c2 <<")\n";+#endif+ int l1=colVars[c1].size();+ int l2=colVars[c2].size();+ IntVarArgs b(l1+l2);+ for (int i=0; i<l1; i++) {+ b[i]=colVars[c1][i];+ }+ for (int i=0; i<l2; i++) {+ b[i+l1]=colVars[c2][i];+ }+ colVars.push_back(b);+ return ret;+ }+ int addColVarTake(int c, int pos, int len) {+ int ret = colVars.size();+#ifndef NDEBUG+ identify(); cerr << "addcolvar v" << ret << " (take " << len << " from c" << c << " at "<< pos <<")\n";+#endif+ int count = len;+ if (colVars[c].size()-pos < count) count=colVars[c].size()-pos;+ if (count<0) count=0;+ IntVarArgs b(count);+ for (int i=0; i<count; i++) {+ b[i]=colVars[c][i+pos];+ }+ colVars.push_back(b);+ return ret;+ }++ void doPropagation(void) {+ status();+ }+ int getIntSize(int var) {+ IntVar v=getIntVar(var); SpaceStatus state=status(); if (state==SS_FAILED) {- if (min) *min=0;- if (max) *max=0;- if (med) *med=0;- if (size) *size=0;+ return 0;+ }+ return v.size();+ }+ int getIntValue(int var) {+ IntVar v=getIntVar(var);+ return v.val();+ }+ int getIntMedian(int var) {+ return getIntVar(var).med();+ }+ void getIntInfo(int var, int *ptr) { + IntVar v=getIntVar(var);+ SpaceStatus state=status();+ if (state==SS_FAILED) {+ ptr[0]=0;+ ptr[1]=0;+ ptr[2]=0;+ ptr[3]=0; #ifndef NDEBUG identify(); cerr << "getintinfo failed)\n"; #endif return; }- if (min) *min=v.min();- if (max) *max=v.max();- if (med) *med=v.med();+ ptr[0]=v.min();+ ptr[1]=v.max();+ ptr[2]=v.med(); int ss=v.size(); if (ss==1) {- if (size) *size=1;- if (val) *val=v.val();+ ptr[3]=1;+ ptr[4]=v.val(); } else {- if (size) *size=ss;+ ptr[3]=ss; } #ifndef NDEBUG identify(); cerr << "getintinfo v" << var << ": min=" << v.min() << ", max=" << v.max() << ", med=" << v.med() << ", size=" << v.size() << ", val=" << ((v.size()<2) ? v.val() : -666) << "\n"; #endif } int testIntDomain(int var, int val) {- assert(var>=0 && var<intVars.size());- return intVars.at(var).in(val);+ return getIntVar(var).in(val); }- void getBoolInfo(int var, int *bound, int *val) {- assert(var>=0 && var<boolVars.size());- BoolVar &v = boolVars.at(var);+ int getBoolInfo(int var) {+ SpaceStatus state=status();+ if (state==SS_FAILED) return -2;+ BoolVar v = getBoolVar(var); if (v.assigned()) {- if (bound) *bound=1;- if (val) *val=v.val();+ return (v.val() ? 1 : 0); } else {- if (bound) *bound=0;+ return -1; } } void postIntValue(int var, int val) {- assert(var>=0 && var<intVars.size());+ IntVar v=getIntVar(var); #ifndef NDEBUG identify(); cerr << "intvalue v" << var << " = " << val << "\n"; #endif- IntVar &v = intVars.at(var); rel(*this,v,IRT_EQ,val,icl); } void postIntSame(int var1, int var2) {- assert(var1>=0 && var1<intVars.size());- assert(var2>=0 && var2<intVars.size());+ IntVar v1 = getIntVar(var1);+ IntVar v2 = getIntVar(var2); #ifndef NDEBUG identify(); cerr << "intsame v" << var1 << " = v" << var2 << "\n"; #endif- IntVar &v1 = intVars.at(var1);- IntVar &v2 = intVars.at(var2); rel(*this,v1,IRT_EQ,v2,icl); } + void postBoolSame(int var1, int var2) {+#ifndef NDEBUG+ identify(); cerr << "intsame v" << var1 << " = v" << var2 << "\n";+#endif+ rel(*this,getBoolVar(var1),IRT_EQ,getBoolVar(var2),icl);+ }+ void postIntDiff(int var1, int var2) {- assert(var1>=0 && var1<intVars.size());- assert(var2>=0 && var2<intVars.size());+ IntVar v1 = getIntVar(var1);+ IntVar v2 = getIntVar(var2); #ifndef NDEBUG identify(); cerr << "intdiff v" << var1 << " != v" << var2 << "\n"; #endif- IntVar &v1 = intVars.at(var1);- IntVar &v2 = intVars.at(var2); rel(*this,v1,IRT_NQ,v2,icl); } void postIntRel(int var1, goperator_t op, int var2) {- assert(var1>=0 && var1<intVars.size());- assert(var2>=0 && var2<intVars.size());+ IntVar v1 = getIntVar(var1);+ IntVar v2 = getIntVar(var2); #ifndef NDEBUG identify(); cerr << "intrel v" << var1 << " " << (op==GOPERATOR_OEQUAL ? "==" : (op==GOPERATOR_OLESS ? "<" : "!=")) << " v" << var2 << "\n"; #endif- IntVar &v1 = intVars.at(var1);- IntVar &v2 = intVars.at(var2); rel(*this,v1,mapGoperator(op),v2,icl); } void postIntRelCf(int v1, goperator_t op, int var2) {- assert(var2>=0 && var2<intVars.size());+ IntVar v2 = getIntVar(var2); #ifndef NDEBUG identify(); cerr << "intrelcf " << v1 << " " << (op==GOPERATOR_OEQUAL ? "==" : (op==GOPERATOR_OLESS ? "<" : "!=")) << " v" << var2 << "\n"; #endif- IntVar &v2 = intVars.at(var2); rel(*this,v2,mapGoperator(op,true),v1,icl); } void postIntRelCs(int var1, goperator_t op, int v2) {- assert(var1>=0 && var1<intVars.size());+ IntVar v1 = getIntVar(var1); #ifndef NDEBUG identify(); cerr << "intrelcs v" << var1 << " " << (op==GOPERATOR_OEQUAL ? "==" : (op==GOPERATOR_OLESS ? "<" : "!=")) << " " << v2 << "\n"; #endif- IntVar &v1 = intVars.at(var1); rel(*this,v1,mapGoperator(op),v2,icl); } void postIntMult(int var1, int var2, int varr) {- assert(var1>=0 && var1<intVars.size());- assert(var2>=0 && var2<intVars.size());- assert(varr>=0 && varr<intVars.size());+ IntVar v1 = getIntVar(var1);+ IntVar v2 = getIntVar(var2);+ IntVar vr = getIntVar(varr); #ifndef NDEBUG identify(); cerr << "intmult v" << var1 << " * v" << var2 << " = v" << varr << "\n"; #endif- IntVar &v1 = intVars.at(var1);- IntVar &v2 = intVars.at(var2);- IntVar &vr = intVars.at(varr); mult(*this,v1,v2,vr,icl); } void postIntDiv(int var1, int var2, int varr) {- assert(var1>=0 && var1<intVars.size());- assert(var2>=0 && var2<intVars.size());- assert(varr>=0 && varr<intVars.size());+ IntVar v1 = getIntVar(var1);+ IntVar v2 = getIntVar(var2);+ IntVar vr = getIntVar(varr); #ifndef NDEBUG identify(); cerr << "intdiv v" << var1 << " / v" << var2 << " = v" << varr << "\n"; #endif- IntVar &v1 = intVars.at(var1);- IntVar &v2 = intVars.at(var2);- IntVar &vr = intVars.at(varr); div(*this,v1,v2,vr,icl); } void postIntMod(int var1, int var2, int varr) {- assert(var1>=0 && var1<intVars.size());- assert(var2>=0 && var2<intVars.size());- assert(varr>=0 && varr<intVars.size());+ IntVar v1 = getIntVar(var1);+ IntVar v2 = getIntVar(var2);+ IntVar vr = getIntVar(varr); #ifndef NDEBUG identify(); cerr << "intmod v" << var1 << " mod v" << var2 << " = v" << varr << "\n"; #endif- IntVar &v1 = intVars.at(var1);- IntVar &v2 = intVars.at(var2);- IntVar &vr = intVars.at(varr); mod(*this,v1,v2,vr,icl); } void postIntAbs(int var, int varr) {- assert(var>=0 && var<intVars.size());- assert(varr>=0 && varr<intVars.size());+ IntVar v = getIntVar(var);+ IntVar vr = getIntVar(varr); #ifndef NDEBUG identify(); cerr << "intabs abs(v" << var << ") = v" << varr << "\n"; #endif- IntVar &v = intVars.at(var);- IntVar &vr = intVars.at(varr); abs(*this,v,vr,icl); } void postIntDom(int var, int low, int high) {- assert(var>=0 && var<intVars.size());+ IntVar v = getIntVar(var); #ifndef NDEBUG identify(); cerr << "intdom v" << var << " = [" << low << "," << high << "]\n"; #endif- IntVar &v = intVars.at(var); dom(*this,v,low,high,icl); } @@ -265,48 +375,86 @@ IntVarArgs vrs(num); IntArgs vls(num,coef); for (int i=0; i<num; i++) {- int id=vars[i];- assert(id>=0 && id<intVars.size());- vrs[i]=intVars.at(id);+ vrs[i] = getIntVar(vars[i]); } #ifndef NDEBUG- identify(); cerr << "intlinear num=" << num << "\n";+ IntArgs dbg(num,vars);+ identify(); cerr << "intlinear num=" << num << " vars=" << dbg << " coefs=" << vls << " op=" << (op==GOPERATOR_OEQUAL ? "==" : (op==GOPERATOR_OLESS ? "<" : (op==GOPERATOR_OLESSEQUAL ? "<=" : "!="))) << " cte=" << val << "\n"; #endif linear(*this,vls,vrs,mapGoperator(op),val,icl); } - void postIntAlldiff(int num, int *vars) {+ void postIntLinearReif(int num, int *vars, int *coef, goperator_t op, int val, int reif) { IntVarArgs vrs(num);+ IntArgs vls(num,coef); for (int i=0; i<num; i++) {- int id=vars[i];- assert(id>=0 && id<intVars.size());- vrs[i]=intVars.at(id);+ vrs[i] = getIntVar(vars[i]); } #ifndef NDEBUG+ identify(); cerr << "intlinear num=" << num << "\n";+#endif+ linear(*this,vls,vrs,mapGoperator(op),val,getBoolVar(reif),icl);+ }++ void postIntAlldiff(int num, int *vars,int dom) {+ IntVarArgs vrs(num);+ for (int i=0; i<num; i++) {+ vrs[i] = getIntVar(vars[i]);+ }+#ifndef NDEBUG identify(); cerr << "intalldiff num=" << num << "\n"; #endif- distinct(*this,vrs,icl);+ distinct(*this,vrs,dom ? ICL_DOM : icl); } - void postIntSorted(int num, int *vars, int strict) {+ void postColAlldiff(int var, int dom) {+ IntVarArgs vars=getColVar(var);+#ifndef NDEBUG+ identify(); cerr << "colalldiff col=" << var << "\n";+#endif+ distinct(*this,vars,dom ? ICL_DOM : icl);+ }++ void postColSorted(int var, goperator_t op) {+ IntVarArgs vars=getColVar(var);+#ifndef NDEBUG+ identify(); cerr << "colsorted col=" << var << " op=" << op << "\n";+#endif+ rel(*this,vars,mapGoperator(op),icl);+ }++ void postColSum(int col,int var) {+ IntVarArgs vars=getColVar(col);+ IntVar sum=getIntVar(var);+#ifndef NDEBUG+ identify(); cerr << "colsum col=" << col << " sumvar=" << var << "\n";+#endif+ linear(*this,vars,IRT_EQ,sum,icl);+ }++ void postColSumC(int col,int val) {+ IntVarArgs vars=getColVar(col);+#ifndef NDEBUG+ identify(); cerr << "colsum col=" << col << " sumval=" << val << "\n";+#endif+ linear(*this,vars,IRT_EQ,val,icl);+ }++ void postIntSorted(int num, int *vars, goperator_t op) { IntVarArgs vrs(num); for (int i=0; i<num; i++) {- int id=vars[i];- assert(id>=0 && id<intVars.size());- vrs[i]=intVars.at(id);+ vrs[i] = getIntVar(vars[i]); } #ifndef NDEBUG identify(); cerr << "intsorted num=" << num << "\n"; #endif- rel(*this,vrs,strict ? IRT_LE : IRT_LQ,icl);+ rel(*this,vrs,mapGoperator(op),icl); } void postIntBranching(int num, int *vars) { IntVarArgs vrs(num); for (int i=0; i<num; i++) {- int id=vars[i];- assert(id>=0 && id<intVars.size());- vrs[i]=intVars.at(id);+ vrs[i] = getIntVar(vars[i]); } #ifndef NDEBUG identify(); cerr << "intbranch num=" << num << "\n";@@ -315,27 +463,295 @@ } void postBoolBranching(int num, int *vars) {- IntVarArgs vrs(num);+ BoolVarArgs vrs(num); for (int i=0; i<num; i++) {- int id=vars[i];- assert(id>=0 && id<intVars.size());- vrs[i]=intVars.at(id);+ vrs[i] = getBoolVar(vars[i]); } #ifndef NDEBUG- identify(); cerr << "boolbranch num=" << num << "\n";+ identify(); cerr << "intbranch num=" << num << "\n"; #endif branch(*this,vrs, INT_VAR_SIZE_MIN, INT_VAL_SPLIT_MIN); }+ + void postColCount(int col,int isValConst,int val,goperator_t op,int isCountConst,int count) {+ IntVarArgs vcol=getColVar(col);+#ifndef NDEBUG+ identify(); cerr << "count col=" << col << " val=" << (isValConst ? "#" : "v") << val << " rel=" << op << " count=" << (isCountConst ? "#" : "v") << count << "\n";+#endif+ switch ((isValConst!=0) | ((isCountConst!=0)*2)) {+ case 0: {+ IntVar vval=getIntVar(val);+ IntVar vcount=getIntVar(count);+ Gecode::count(*this,vcol,vval,mapGoperator(op),vcount);+ break;+ }+ case 1: {+ IntVar vcount=getIntVar(count);+ Gecode::count(*this,vcol,val,mapGoperator(op),vcount);+ break;+ }+ case 2: {+ IntVar vval=getIntVar(val);+ Gecode::count(*this,vcol,vval,mapGoperator(op),count);+ break;+ }+ case 3: {+ Gecode::count(*this,vcol,val,mapGoperator(op),count);+ break;+ }+ }+ }+ + void postColBranching(int num, int *vars) {+ int n=0;+#ifndef NDEBUG+ identify(); cerr << "colbranch num=" << num << "\n";+#endif+ for (int i=0; i<num; i++) {+ n += getColVar(vars[i]).size();+ }+ IntVarArgs vrs(n);+ int p=0;+ for (int i=0; i<num; i++) {+ IntVarArgs col=(getColVar(vars[i]));+ int s=col.size();+ for (int k=0; k<s; k++) {+ vrs[p++]=col[k];+ }+ }+ branch(*this,vrs,INT_VAR_SIZE_MIN, INT_VAL_SPLIT_MIN);+ } + void postBoolValue(int var, int val) {+#ifndef NDEBUG+ identify(); cerr << "boolval var="<<var<<" val="<<val<<"\n";+#endif+ rel(*this,getBoolVar(var),IRT_EQ,val,icl);+ } + int postColEqual(int c1, int c2) {+ IntVarArgs col1= getColVar(c1);+ IntVarArgs col2= getColVar(c2);+#ifndef NDEBUG+ identify(); cerr << "colequal col1="<<c1<<" col="<<c2<<"\n";+#endif+ int len=col1.size();+ if (len != (int)(col2.size())) return 0;+ for (int i=0; i<len; i++) {+ rel(*this,col1[i],IRT_EQ,col2[i],icl);+ }+ return 1;+ }++ int postColCat(int c1, int c2, int cr) {+#ifndef NDEBUG+ identify(); cerr << "colcat col1="<<c1<<" col2="<<c2<<" colr="<<cr<<"\n";+#endif+ IntVarArgs col1= getColVar(c1);+ IntVarArgs col2= getColVar(c2);+ IntVarArgs colr= getColVar(cr);+ int len1=col1.size();+ int len2=col2.size();+ int lenr=colr.size();+ if (lenr != len1+len2) return 0;+ for (int i=0; i<len1; i++) {+ rel(*this,col1[i],IRT_EQ,colr[i],icl);+ }+ for (int i=0; i<len2; i++) {+ rel(*this,col2[i],IRT_EQ,colr[i+len1],icl);+ }+ return 1;+ }++ int postColTake(int c, int p, int l, int cr) {+#ifndef NDEBUG+ identify(); cerr << "coltake col=v"<<c<<" pos="<<p<<" len="<<l<<" colr="<<cr<<"\n";+#endif+ IntVarArgs col= getColVar(c);+ IntVarArgs colr= getColVar(cr);+ int len=col.size();+ int lenr=colr.size();+ if (l+p>len) l=len-p;+ if (l>0) l=0;+ if (lenr != l) return 0;+ for (int i=0; i<l; i++) {+ rel(*this,col[i+p],IRT_EQ,colr[i],icl);+ }+ return 1;+ }++ void postColAt(int c, int p, int i) {+#ifndef NDEBUG+ identify(); cerr << "colat col=v"<<c<<" pos=v"<<p<<" res=v"<<i<<"\n";+#endif+ element(*this,getColVar(c),getIntVar(p),getIntVar(i),icl);+ }++ void postColAtList(int n, int *l, int p, int i) {+ IntArgs args(n,l);+#ifndef NDEBUG+ identify(); cerr << "colat col=[...] pos=v"<<p<<" res=v"<<i<<"\n";+#endif+ element(*this,args,getIntVar(p),getIntVar(i),icl);+ }++ void postColAtConst(int c, int p, int v) {+#ifndef NDEBUG+ identify(); cerr << "colat col=v"<<c<<" pos=v"<<p<<" res="<<v<<"\n";+#endif+ element(*this,getColVar(c),getIntVar(p),v,icl);+ }++ void postColAtListConst(int n, int *l, int p, int v) {+ IntArgs args(n,l);+#ifndef NDEBUG+ identify(); cerr << "colat col=[...] pos=v"<<p<<" res="<<v<<"\n";+#endif+ element(*this,args,getIntVar(p),v,icl);+ }++ void postDom(int i,int c) {+ IntVar iv = getIntVar(i);+ IntVarArgs iva = getColVar(c);+ count(*this,iva,iv,IRT_GR,0,icl);+ }++ void postDom(int i, int n, const int *c, int r) {+ IntVar iv = getIntVar(i);+ IntArgs ia(n,c);+ IntSet is(ia);+ if (r<0) {+ dom(*this,iv,is,icl);+ } else {+ BoolVar rv = getBoolVar(r);+ dom(*this,iv,is,rv,icl);+ }+ }++ void postBoolChannel(int b, int i) {+#ifndef NDEBUG+ identify(); cerr << "channel bool=v"<<b<<" int=v"<<i<<"\n";+#endif+ channel(*this,getBoolVar(b),getIntVar(i),icl);+ }++ void postBoolAnd(int a, int b, int r) {+#ifndef NDEBUG+ identify(); cerr << "and a=v"<<a<<" b=v"<<b<<" r=v"<<r<<"\n";+#endif+ rel(*this,getBoolVar(a),BOT_AND,getBoolVar(b),getBoolVar(r),icl);+ }++ void postBoolOr(int a, int b, int r) {+#ifndef NDEBUG+ identify(); cerr << "or a=v"<<a<<" b=v"<<b<<" r=v"<<r<<"\n";+#endif+ rel(*this,getBoolVar(a),BOT_OR,getBoolVar(b),getBoolVar(r),icl);+ }++ void postBoolEquiv(int a, int b, int r) {+#ifndef NDEBUG+ identify(); cerr << "boolequiv a=v"<<a<<" b=v"<<b<<" r=v"<<r<<"\n";+#endif+ rel(*this,getBoolVar(a),BOT_EQV,getBoolVar(b),getBoolVar(r),icl);+ }++ void postBoolNot(int a, int r) {+#ifndef NDEBUG+ identify(); cerr << "not a=v"<<a<<" r=v"<<r<<"\n";+#endif+ rel(*this,getBoolVar(a),IRT_NQ,getBoolVar(r),icl);+ }++ void postBoolAll(int num, int *vars, int r) {+#ifndef NDEBUG+ identify(); cerr << "boolall num="<<num<<" r=v"<<r<<"\n";+#endif+ BoolVarArgs vrs(num);+ for (int i=0; i<num; i++) {+ vrs[i] = getBoolVar(vars[i]);+ }+ if (r<0) {+ rel(*this,BOT_AND,vrs,true);+ } else {+ BoolVar reif=getBoolVar(r);+ rel(*this,BOT_AND,vrs,reif);+ }+ }++ void postBoolAny(int num, int *vars, int r) {+#ifndef NDEBUG+ identify(); cerr << "boolany num="<<num<<" r=v"<<r<<"\n";+#endif+ BoolVarArgs vrs(num);+ for (int i=0; i<num; i++) {+ vrs[i] = getBoolVar(vars[i]);+ }+ if (r<0) {+ rel(*this,BOT_OR,vrs,true);+ } else {+ BoolVar reif=getBoolVar(r);+ rel(*this,BOT_OR,vrs,reif);+ }+ }++ int getColSize(int var) const {+ IntVarArgs vr=getColVar(var);+#ifndef NDEBUG+ identify(); cerr << "get colsize: col=v"<<var<<": res="<<vr.size()<<"\n";+#endif+ return vr.size();+ }++ int modRefcount(int m) {+#ifndef NDEBUG+ identify(); cerr << "mod refcount: "<<refcount<<" -> "<<(refcount+m)<<"\n";+#endif+ refcount += m;+ return refcount;+ }++ void message(const string chr) const {+#ifndef NDEBUG+ identify(); cerr << chr << "\n";+#endif+ }++ void setMinimizeVar(int v) {+#ifndef NDEBUG+ identify(); cerr << "set minimizevar: v"<<v<<"\n";+#endif+ minimizeVar=v;+ }++ void constrain(const Space& _best) {+ const HaskellModel *best=(HaskellModel*)(&_best);+ rel(*this,cost(),IRT_LE,best->cost().val());+ } }; extern "C" HaskellModel *gecode_model_create(void) { return new HaskellModel(); }-extern "C" HaskellModel *gecode_model_copy(HaskellModel *model) { return (HaskellModel*)(model->clone(true)); }-extern "C" HaskellModel *gecode_model_copy_reentrant(HaskellModel *model) { return (HaskellModel*)(model->clone(false)); }-extern "C" void gecode_model_fail(HaskellModel *model) { model->fail(); }-extern "C" void gecode_model_destroy(HaskellModel *model) { delete model; }+extern "C" HaskellModel *gecode_model_copy(HaskellModel *model) { + SpaceStatus state=model->status();+ if (state==SS_FAILED) {+ return NULL;+ } else {+ return (HaskellModel*)(model->clone(true));+ }+}+extern "C" HaskellModel *gecode_model_copy_reentrant(HaskellModel *model) {+ SpaceStatus state=model->status();+ if (state==SS_FAILED) {+ return NULL;+ } else {+ return (HaskellModel*)(model->clone(false));+ }+}+extern "C" void gecode_model_fail(HaskellModel *model) { model->message("fail"); model->fail(); }+extern "C" void gecode_model_destroy(HaskellModel *model) { model->message("destroy"); delete model; }+extern "C" void gecode_model_propagate(HaskellModel *model) { model->doPropagation(); } extern "C" int gecode_int_rel(HaskellModel *model, int v1, goperator_t op, int v2) { model->postIntRel(v1,op,v2); return !model->failed(); }+extern "C" int gecode_bool_equal(HaskellModel *model, int v1, goperator_t op, int v2) { model->postBoolSame(v1,v2); return !model->failed(); } extern "C" int gecode_int_rel_cf(HaskellModel *model, int v1, goperator_t op, int v2) { model->postIntRelCf(v1,op,v2); return !model->failed(); } extern "C" int gecode_int_rel_cs(HaskellModel *model, int v1, goperator_t op, int v2) { model->postIntRelCs(v1,op,v2); return !model->failed(); } extern "C" int gecode_int_newvar(HaskellModel *model) { return model->addIntVar(-1000000000,1000000000); }@@ -346,35 +762,124 @@ extern "C" int gecode_int_abs(HaskellModel *model, int v, int vr) { model->postIntAbs(v,vr); return !model->failed(); } extern "C" int gecode_int_dom(HaskellModel *model, int v, int low, int high) { model->postIntDom(v,low,high); return !model->failed(); } extern "C" int gecode_int_linear(HaskellModel *model, int num, int *vars, int *coef, goperator_t op, int val) { model->postIntLinear(num,vars,coef,op,val); return !model->failed(); }-extern "C" int gecode_int_alldiff(HaskellModel *model, int num, int *vars) { model->postIntAlldiff(num,vars); return !model->failed(); }-extern "C" int gecode_int_sorted(HaskellModel *model, int num, int *vars, int strict) { model->postIntSorted(num,vars,strict); return !model->failed(); }+extern "C" int gecode_int_linear_ri(HaskellModel *model, int num, int *vars, int *coef, goperator_t op, int val, int reif) { model->postIntLinearReif(num,vars,coef,op,val,reif); return !model->failed(); }+extern "C" int gecode_int_alldiff(HaskellModel *model, int num, int *vars, int dom) { model->postIntAlldiff(num,vars,dom); return !model->failed(); }+extern "C" int gecode_int_sorted(HaskellModel *model, int num, int *vars, goperator_t op) { model->postIntSorted(num,vars,op); return !model->failed(); } extern "C" void gecode_int_branch(HaskellModel *model, int num, int *vars) { model->postIntBranching(num,vars); }-extern "C" void gecode_int_info(HaskellModel *model, int var, int *min, int *max, int *med, int *size, int *val) { model->getIntInfo(var,min,max,med,size,val); }+extern "C" void gecode_int_info(HaskellModel *model, int var, int *ptr) { model->getIntInfo(var,ptr); }+extern "C" int gecode_int_get_size(HaskellModel *model, int var) { return model->getIntSize(var); }+extern "C" int gecode_int_get_value(HaskellModel *model, int var) { return model->getIntValue(var); }+extern "C" int gecode_int_get_median(HaskellModel *model, int var) { return model->getIntMedian(var); } extern "C" int gecode_bool_newvar(HaskellModel *model) { return model->addBoolVar(0,1); }+extern "C" int gecode_bool_info(HaskellModel *model, int v) { return model->getBoolInfo(v); }+extern "C" int gecode_col_newsize(HaskellModel *model, int size) { return model->addColVarSize(size,-1000000000,1000000000); }+extern "C" int gecode_col_newlist(HaskellModel *model, int size, int *vars) { return model->addColVarList(size,vars); }+extern "C" int gecode_col_newcat(HaskellModel *model, int c1, int c2) { return model->addColVarCat(c1,c2); }+extern "C" int gecode_col_newtake(HaskellModel *model, int c, int p, int l) { return model->addColVarTake(c,p,l); }+extern "C" int gecode_col_cat(HaskellModel *model, int c1, int c2, int cr) { return model->postColCat(c1,c2,cr) && !model->failed(); }+extern "C" int gecode_col_take(HaskellModel *model, int c, int p, int l, int cr) { return model->postColTake(c,p,l,cr) && !model->failed(); }+extern "C" int gecode_col_equal(HaskellModel *model, int c1, int c2) { return model->postColEqual(c1,c2) && !model->failed(); }+extern "C" int gecode_col_at(HaskellModel *model, int c, int p, int i) { model->postColAt(c,p,i); return !model->failed(); }+extern "C" int gecode_col_at_lst(HaskellModel *model, int n, int *l, int p, int i) { model->postColAtList(n,l,p,i); return !model->failed(); }+extern "C" int gecode_col_at_cv(HaskellModel *model, int c, int p, int v) { model->postColAtConst(c,p,v); return !model->failed(); }+extern "C" int gecode_col_at_lst_cv(HaskellModel *model, int n, int *l, int p, int v) { model->postColAtListConst(n,l,p,v); return !model->failed(); }+extern "C" int gecode_col_dom(HaskellModel *model, int i, int c) { model->postDom(i,c); return !model->failed(); }+extern "C" int gecode_int_dom_list(HaskellModel *model, int i, int n, const int *l, int r) { model->postDom(i,n,l,r); return !model->failed(); }+extern "C" int gecode_col_getsize(HaskellModel *model, int c) { return model->getColSize(c); }+extern "C" int gecode_col_sorted(HaskellModel *model, int c, goperator_t op) { model->postColSorted(c,op); return !model->failed(); }+extern "C" int gecode_col_sum(HaskellModel *model, int c, int i) { model->postColSum(c,i); return !model->failed(); }+extern "C" int gecode_col_sumc(HaskellModel *model, int c, int v) { model->postColSumC(c,v); return !model->failed(); }+extern "C" int gecode_col_alldiff(HaskellModel *model, int c, int dom) { model->postColAlldiff(c,dom); return !model->failed(); }+extern "C" int gecode_col_count(HaskellModel *model, int col, int numconst, int num, goperator_t op, int countconst, int count) { model->postColCount(col,numconst,num,op,countconst,count); return !model->failed(); }+extern "C" void gecode_col_branch(HaskellModel *model, int num, int *vars) { model->postColBranching(num,vars); } extern "C" void gecode_bool_branch(HaskellModel *model, int num, int *vars) { model->postBoolBranching(num,vars); }+extern "C" int gecode_bool_value(HaskellModel *model, int v, int val) { model->postBoolValue(v,val); return !model->failed(); }+extern "C" int gecode_bool_channel(HaskellModel *model, int b, int i) { model->postBoolChannel(b,i); return !model->failed(); }+extern "C" int gecode_bool_and(HaskellModel *model, int a, int b, int r) { model->postBoolAnd(a,b,r); return !model->failed(); }+extern "C" int gecode_bool_or(HaskellModel *model, int a, int b, int r) { model->postBoolOr(a,b,r); return !model->failed(); }+extern "C" int gecode_bool_not(HaskellModel *model, int a, int r) { model->postBoolNot(a,r); return !model->failed(); }+extern "C" int gecode_bool_equiv(HaskellModel *model, int a, int b, int r) { model->postBoolEquiv(a,b,r); return !model->failed(); }+extern "C" int gecode_bool_all(HaskellModel *model, int num, int *vars, int reif) { model->postBoolAll(num,vars,reif); return !model->failed(); }+extern "C" int gecode_bool_any(HaskellModel *model, int num, int *vars, int reif) { model->postBoolAny(num,vars,reif); return !model->failed(); } -extern "C" DFS<HaskellModel> *gecode_search_create(HaskellModel *model) { - DFS<HaskellModel> *srch=new DFS<HaskellModel>(model);+extern "C" int gecode_space_modrefcount(HaskellModel *model, int mod) { return model->modRefcount(mod); }+extern "C" void gecode_space_setcost(HaskellModel *model,int var) { model->setMinimizeVar(var); }++enum gecode_search_type {+ GECODE_SEARCH_TYPE_DFS,+ GECODE_SEARCH_TYPE_BAB+};++union gecode_search_data_specific_t {+ DFS<HaskellModel> *dfs;+ BAB<HaskellModel> *bab;+};++typedef struct {+ enum gecode_search_type typ;+ union gecode_search_data_specific_t dat;+} gecode_search_data_t;++gecode_search_data_t static *gecode_search_create(HaskellModel *model, gecode_search_type typ) {+ Search::Options o = Search::Options::Options();+ o.c_d = 1;+ gecode_search_data_t *srch=new gecode_search_data_t; #ifndef NDEBUG- model->identify(); cerr << "search " << srch << " created\n";+ model->identify(); cerr << "create search (type "<<typ<<")\n"; #endif+ srch->typ=typ;+ switch (typ) {+ case GECODE_SEARCH_TYPE_DFS: { + srch->dat.dfs=new DFS<HaskellModel>(model,o);+ break;+ }+ case GECODE_SEARCH_TYPE_BAB: {+ srch->dat.bab=new BAB<HaskellModel>(model,o);+ break;+ }+ } return srch; } -extern "C" void gecode_search_destroy(DFS<HaskellModel> *search) { +extern "C" gecode_search_data_t *gecode_search_create_dfs(HaskellModel *model) { return gecode_search_create(model, GECODE_SEARCH_TYPE_DFS); }+extern "C" gecode_search_data_t *gecode_search_create_bab(HaskellModel *model) { return gecode_search_create(model, GECODE_SEARCH_TYPE_BAB); }++extern "C" void gecode_search_destroy(gecode_search_data_t *srch) { #ifndef NDEBUG- cerr << "[search " << search << "] destroyed\n";+ cerr << "[search " << srch << "] destroyed\n"; #endif- delete search;+ switch (srch->typ) {+ case GECODE_SEARCH_TYPE_DFS: {+ delete srch->dat.dfs;+ srch->dat.dfs=NULL;+ break;+ }+ case GECODE_SEARCH_TYPE_BAB: {+ delete srch->dat.bab;+ srch->dat.bab=NULL;+ break;+ }+ }+ delete srch; } -extern "C" HaskellModel *gecode_search_next(DFS<HaskellModel> *search) { +extern "C" HaskellModel *gecode_search_next(gecode_search_data_t *srch) { #ifndef NDEBUG- cerr << "[search " << search << "] requesting next\n";+ cerr << "[search " << srch << "] requesting next\n"; #endif- HaskellModel *res=search->next();+ HaskellModel *res;+ switch (srch->typ) {+ case GECODE_SEARCH_TYPE_DFS: {+ res=srch->dat.dfs->next();+ break;+ }+ case GECODE_SEARCH_TYPE_BAB: {+ res=srch->dat.bab->next();+ break;+ }+ } #ifndef NDEBUG- cerr << "[search " << search << "] requested next (" << res << ")\n";+ cerr << "[search " << srch << "] requested next (" << res << ")\n"; #endif return res; }
lib/gecodeglue.h view
@@ -4,7 +4,8 @@ typedef enum { GOPERATOR_OEQUAL, GOPERATOR_ODIFF,- GOPERATOR_OLESS+ GOPERATOR_OLESS,+ GOPERATOR_OLESSEQUAL } goperator_t; #ifndef _interface_cpp_@@ -14,6 +15,7 @@ HaskellModel *gecode_model_copy(HaskellModel *model); HaskellModel *gecode_model_copy_reentrant(HaskellModel *model); void gecode_model_destroy(HaskellModel *model);+void gecode_model_propagate(HaskellModel *model); int gecode_int_newvar(HaskellModel *model); int gecode_int_rel(HaskellModel *model, int v1, goperator_t op, int v2); int gecode_int_value(HaskellModel *model, int v, int val);@@ -26,6 +28,9 @@ int gecode_int_alldiif(HaskellModel *model, int num, int *vars); int gecode_int_sorted(HaskellModel *model, int num, int *vars, int strict); void gecode_int_info(HaskellModel *model, int var, int *min, int *max, int *med, int *size, int *val);+int gecode_int_get_size(HaskellModel *model, int var);+int gecode_int_get_value(HaskellModel *model, int var);+int gecode_int_get_median(HaskellModel *model, int var); int gecode_bool_newvar(HaskellModel *model); #endif
monadiccp.cabal view
@@ -1,5 +1,5 @@ Name: monadiccp-Version: 0.6.1+Version: 0.7.0 Description: Monadic Constraint Programming framework License: BSD3 License-file: LICENSE@@ -8,10 +8,10 @@ Build-Type: Simple Category: control Synopsis: Constraint Programming-Homepage: http://www.cs.kuleuven.be/~toms/Haskell/+Homepage: http://www.cs.kuleuven.be/~toms/MCP/ Bug-reports: http://trac.haskell.org/monadiccp/ Cabal-Version: >=1.6-Extra-Source-Files: examples/*.hs lib/gecodeglue.h+Extra-Source-Files: examples/*.hs lib/*.cpp lib/*.h -- examples/Alpha.hs examples/Grocery.hs examples/MagicSquare.hs examples/Olympic.hs examples/Partition.hs examples/Queens.hs examples/Ring.hs examples/StressDomain.hs examples/TryDemo.hs examples/Zebra.hs @@ -24,18 +24,49 @@ Default: False library- Build-Depends: base >= 2 && < 4, containers, mtl, haskell98, random- Exposed-Modules: Control.CP.SearchTree Control.CP.Transformers Control.CP.FD.Gecode.Common Control.CP.FD.Gecode.Translate Control.CP.FD.Gecode.CodegenSolver Control.CP.FD.OvertonFD.Sugar Control.CP.FD.OvertonFD.OvertonFD Control.CP.FD.Solvers Control.CP.FD.FD Control.CP.FD.Example.Example Control.CP.FD.Expr Control.CP.Solver Control.CP.ComposableTransformers Control.CP.EnumTerm Control.CP.PriorityQueue Control.CP.Mixin Control.CP.Herbrand.PrologTerm Control.CP.Herbrand.Prolog Control.CP.Herbrand.Herbrand Control.CP.Herbrand.HerbrandT Control.CP.Queue- Other-Modules: Control.CP.Debug Control.CP.FD.OvertonFD.Domain+ Build-Depends: base >= 2, base < 5, containers, mtl, haskell98, random, pretty, Monatron >= 0.3+ Exposed-Modules: Data.Expr.Sugar+ 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.Gecode.CodegenSolver+ Control.CP.FD.Model+ Control.CP.FD.Example+ Other-Modules: Data.Expr.Data+ Data.Expr.Util+ Data.Linear+ Control.CP.FD.Gecode.Common+ Control.CP.FD.OvertonFD.Domain+ Control.CP.FD.SimpleFD+ Control.CP.FD.Graph+ Control.CP.FD.Decompose+ Control.CP.FD.FD+ Control.CP.Debug+ Control.Mixin.Mixin+ Control.CP.SearchSpec.Language+ Control.CP.SearchSpec.Generator+ Language.CPP.Syntax.AST+ Language.CPP.Pretty+ GHC-Prof-Options: -auto-all -caf-all Include-Dirs: lib if flag(Debug) CPP-Options: -DDEBUG- CC-Options: "-O1" "-ggdb3"+ CC-Options: "-ggdb3" "-Wall" else- CC-Options: "-O3" "-g0" "-DNDEBUG"- if flag(RuntimeGecode)+ CC-Options: "-g0" "-DNDEBUG" "-Wall"+ if flag(runtimegecode) C-Sources: lib/gecodeglue.cpp Extra-Libraries: gecodesupport gecodeset gecodeint gecodekernel gecodesearch- Exposed-Modules: Control.CP.FD.Gecode.RuntimeSolver+ Exposed-Modules: Control.CP.FD.Gecode.Runtime+ Control.CP.FD.Gecode.RuntimeSearch Other-Modules: Control.CP.FD.Gecode.Interface CPP-Options: -DRGECODE+ Frameworks: gecode