monadiccp 0.7.5 → 0.7.6
raw patch · 24 files changed
+160/−4677 lines, 24 files
Files
- Control/CP/FD/Example.hs +4/−31
- Control/CP/FD/Gecode/CodegenSolver.hs +0/−1113
- Control/CP/FD/Gecode/Common.hs +0/−1677
- Control/CP/FD/Gecode/Interface.hsc +0/−359
- Control/CP/FD/Gecode/Runtime.hs +0/−158
- Control/CP/FD/Gecode/RuntimeSearch.hs +0/−226
- Control/CP/FD/OvertonFD/Domain.hs +6/−6
- Control/CP/FD/OvertonFD/OvertonFD.hs +0/−1
- Control/CP/FD/Solvers.hs +0/−13
- Control/Search/Generator.hs +20/−20
- Control/Search/SStateT.hs +0/−3
- examples/Domino.hs +1/−0
- examples/GraphColor.hs +1/−0
- examples/LangfordNumber.hs +4/−1
- examples/MineSweeper.hs +4/−0
- examples/Olympic.hs +19/−19
- examples/Partition.hs +0/−3
- examples/Ring.hs +14/−25
- examples/StressDomain.hs +19/−20
- examples/TryDemo.hs +13/−11
- examples/Zebra.hs +39/−35
- lib/gecodeglue.cpp +0/−887
- lib/gecodeglue.h +0/−37
- monadiccp.cabal +16/−32
Control/CP/FD/Example.hs view
@@ -1,6 +1,5 @@ {-# LANGUAGE RankNTypes #-} {-# LANGUAGE TypeFamilies #-}-{-# LANGUAGE CPP #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE ScopedTypeVariables #-} @@ -16,6 +15,9 @@ example_min_main_single, example_min_main_single_expr, example_min_main_coll_expr,+ runSolve,+ labeller,+ postMinimize, ExampleModel, ExampleMinModel, module Control.CP.FD.Interface, ) where@@ -27,8 +29,6 @@ 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@@ -44,21 +44,6 @@ 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)) @@ -70,9 +55,6 @@ 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 @@ -92,17 +74,8 @@ 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"+ [] -> putStr "Solver type required: must be overton_run\n" (a:r) -> putStr ("Unsupported solver: " ++ a ++ "\n") example_min_main :: ExampleMinModel [String] -> ExampleMinModel ModelInt -> ExampleMinModel ModelCol -> IO ()
− Control/CP/FD/Gecode/CodegenSolver.hs
@@ -1,1113 +0,0 @@-{-# LANGUAGE TypeFamilies #-}-{-# LANGUAGE MultiParamTypeClasses #-}-{-# LANGUAGE GeneralizedNewtypeDeriving #-}-{-# 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 Data.Set (Set)-import qualified Data.Set as Set--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 Control.CP.FD.SearchSpec.Data-import Data.Linear--import Control.Search.Generator-import Control.Search.Stat-import Control.Search.Constraints-import Control.Search.Combinator.And-import Control.Search.Combinator.Base as Base-import Control.Search.Combinator.Misc-import Control.Search.Combinator.Print-import Control.Search.Combinator.Until-import Control.Search.Combinator.Once-import Control.Search.Combinator.Or--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],- intRet :: Set IntVar,- boolRet :: Set BoolVar,- colRet :: Set ColVar,- level :: Int,- parent :: Maybe CodegenGecodeState,- options :: CodegenGecodeOptions,- searchSpec :: Maybe (SearchSpec IntVar ColVar BoolVar)-} 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 = [],- intRet = Set.empty,- boolRet = Set.empty,- colRet = Set.empty,- level = 0,- parent = Nothing,- options = initOptions,- searchSpec = 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 ()--resolveVars :: SearchSpec ModelInt ModelCol ModelBool -> FDInstance (GecodeWrappedSolver CodegenGecodeSolver) (SearchSpec IntVar ColVar BoolVar)-resolveVars spec = mmapSearch spec mapInt mapCol mapBool- where mapCol v = do- [GCTVar col] <- getColTerm [v] GCSVar- case col of- ColVar 0 _ -> liftFD $ liftGC $ do- s <- get- put s { colRet = Set.insert col $ colRet s }- return col- ColVar _ _ -> error "Non-toplevel array escapes"- mapInt v = do- [var] <- getIntTerm [v]- case var of- IntVar 0 r -> liftFD $ liftGC $ do- s <- get- put s { intRet = Set.insert var $ intRet s }- return var- IntVar _ _ -> error "Non-toplevel variable escapes"- _ -> liftFD $ liftGC $ do- s <- get- put s { intRet = Set.insert var $ intRet s }- return var- mapBool v = do- [var] <- getBoolTerm [v]- case var of- BoolVar 0 r -> liftFD $ liftGC $ do- s <- get- put s { boolRet = Set.insert var $ boolRet s }- return var- BoolVar _ _ -> error "Non-toplevel boolean escapes"- _ -> liftFD $ liftGC $ do- s <- get- put s { boolRet = Set.insert var $ boolRet s }- return var--instance CompilableModel ((FDInstance (GecodeWrappedSolver CodegenGecodeSolver)) ModelCol) where- specific_compile x = unliftGC $ runFD $ do- res <- x- min <- getMinimizeVar- spec <- resolveVars $ PrintSol [] [res] [] $ case min of- Nothing -> LimitSolCount 1 $ Labelling $ LabelCol res (Term DDomSize) Minimize (Term DMedian) (\var val -> var @<= val)- Just m -> BranchBound m Minimize $ CombineSeq (Labelling $ LabelCol res (Term DDomSize) Minimize (Term DMedian) (\var val -> var @<= val)) (Labelling $ LabelInt m (Term DMedian) (\var val -> var @<= val))- liftFD $ liftGC $ do- s <- get- put s { searchSpec = Just spec }--instance CompilableModel ((FDInstance (GecodeWrappedSolver CodegenGecodeSolver)) (SearchSpec ModelInt ModelCol ModelBool)) where- specific_compile x = unliftGC $ runFD $ do- res <- x- y <- resolveVars res- liftFD $ liftGC $ do- s <- get- put s { searchSpec = Just y }--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--unvar (CPPVar s) = s-unvar x = error $ "Unvarring " ++ show x--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--astBoolExt state r | (Set.member r $ boolRet state) = True-astBoolExt _ _ = False-astColExt state r | (Set.member r $ colRet state) = True-astColExt _ _ = False-astIntExt state r | (Set.member r $ intRet state) = True-astIntExt _ _ = False--astBoolVar :: CodegenGecodeState -> CPPExpr -> BoolVar -> CPPExpr-astBoolVar state ctx q@(BoolVar 0 r) | (Set.member q $ boolRet state) = call ctx ("bR" ++ show r)-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 :: CodegenGecodeState -> CPPExpr -> IntVar -> CPPExpr-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 q@(IntVar 0 r) | (Set.member q $ intRet state) = call ctx ("iR" ++ show r)-astIntVar state ctx (v@(IntVar l _)) | (l < level state) = astIntVar (fromJust $ parent state) ctx v-astIntVar state ctx i = CPPVar $ intVarName i--astColVar :: CodegenGecodeState -> CPPExpr -> ColVar -> CPPExpr-astColVar state ctx q@(ColVar 0 r) | (Set.member q $ colRet state) = call ctx ("cR" ++ show r)-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 []- ) ++- ( map (\c -> (CPPPublic,astDecl (unvar $ astIntVar state astThis c) (CPPTypePrim "IntVar"))) $ Set.toList $ intRet state ) ++- ( map (\c -> (CPPPublic,astDecl (unvar $ astColVar state astThis c) (CPPTypePrim "IntVarArray"))) $ Set.toList $ colRet state ) ++- ( map (\c -> (CPPPublic,astDecl (unvar $ astBoolVar state astThis c) (CPPTypePrim "BoolVar"))) $ Set.toList $ boolRet state ),- 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")- cppDefBody = Just $ CPPReturn Nothing- })- ],-{-- (- 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=[] -{- ( [ (Left $ CPPVar $ boolVarName $ BoolVar (level state) j, [astThis,astInt 0,astInt 1]) | j <- Set.toList $ boolRet state ] ++- [ (Left $ CPPVar $ intVarName $ IntVar (level state) j, [astThis,astLowerBound,astUpperBound]) | j <- Set.toList $ intRet state ] ++- [ (Left $ CPPVar $ colVarName $ ColVar (level state) j, [astThis,astColSize (ColVar (level state) j) state astThis]) | j <- Set.toList $ colRet state ]-- ) -}- }),- (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 (- [let vn = unvar $ astBoolVar state astThis j in CPPStatement $ CPPSimple $ CPPCall (call (call astThis vn) "update") [astThis,CPPVar "share",call (CPPVar "s") vn] | j <- Set.toList $ boolRet state] ++- [let vn = unvar $ astIntVar state astThis j in CPPStatement $ CPPSimple $ CPPCall (call (call astThis vn) "update") [astThis,CPPVar "share",call (CPPVar "s") vn] | j <- Set.toList $ intRet state] ++- [let vn = unvar $ astColVar state astThis j in CPPStatement $ CPPSimple $ CPPCall (call (call astThis vn) "update") [astThis,CPPVar "share",call (CPPVar "s") vn] | j <- Set.toList $ colRet state]- )- })- ]- }- ]--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 0) 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] - ]) ++- (- [CPPComment "decl boolvars"]++[- let glob = (Set.member (BoolVar 0 j) (boolRet state) && level state == 0) - in (if glob then (\x -> CPPStatement $ CPPSimple $ CPPAssign (astBoolVar state astThis $ BoolVar (level state) j) CPPAssOp $ CPPCall (CPPVar "BoolVar") x )else (\x -> CPPBlockDecl $ astDeclFn ((\(CPPVar x) -> x) $ astBoolVar state astThis (BoolVar (level state) j)) astTBV x)) [astThis,astInt 0,astInt 1] | j <- [0..nBoolVars state - 1]- ]- ) ++- (- [CPPComment "decl intvars"]++[- let glob = (Set.member (IntVar 0 j) (intRet state) && level state == 0) - in (if glob then (\x -> CPPStatement $ CPPSimple $ CPPAssign (astIntVar state astThis $ IntVar (level state) j) CPPAssOp $ CPPCall (CPPVar "IntVar") x )else (\x -> CPPBlockDecl $ astDeclFn ((\(CPPVar x) -> x) $ astIntVar state astThis (IntVar (level state) j)) astTIV x)) [astThis,astLowerBound,astUpperBound] | j <- [0..nIntVars state - 1]- ]- ) ++- ( - [CPPComment "decl colvars"]++[- let glob = (Set.member (ColVar 0 j) (colRet state) && level state == 0) - in (if glob then (\x -> CPPStatement $ CPPSimple $ CPPAssign (astColVar state astThis $ ColVar (level state) j) CPPAssOp $ CPPCall (CPPVar "IntVarArray") x ) else (\x -> CPPBlockDecl $ astDeclFn ((\(CPPVar x) -> x) $ astColVar state astThis (ColVar (level state) j)) astTIVA x)) ((if glob then (astThis:) else id) [astColSize (ColVar (level state) j) state astThis]) | j <- [0..length (colVars state) - 1]- ]- ) ++- [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") :- [ CPPStatement $ CPPSimple $ CPPAssign (CPPIndex (astColVar state astThis i) (astInt $ toInteger i2)) CPPAssOp $ (astIntVar state astThis f2) | (i2,f2) <- zip [0..(length l)-1] l ]- ColDefCat a b -> CPPCompound $ [- CPPComment "ColDefCat",- 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"))- ]- {- 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 []- )--transExprV (Term DDomSize) = domsizeV-transExprV (Term DMedian) = medianD--transExprC (Rel (Term VarRef) ERLess (Term ValRef)) = ($<)-transExprC (Rel (Term VarRef) ERLess (Plus (Const 1) (Term ValRef))) = ($<=)-transExprC (Rel (Term ValRef) ERLess (Term VarRef)) = ($>)-transExprC (Rel (Plus (Const 1) (Term ValRef)) ERLess (Term VarRef)) = ($>=)-transExprC (Rel (Term VarRef) EREqual (Term ValRef)) = ($==)-transExprC (Rel (Term ValRef) EREqual (Term VarRef)) = ($==)-transExprC x = error $ "transExprC doesn't support " ++ show x--transDir Maximize = maxV-transDir Minimize = minV--transSearch state (Labelling (LabelInt v x f)) = Base.vlabel (unvar $ astIntVar state astThis v) (transExprV x) (transExprC $ f (Term VarRef) (Term ValRef))-transSearch state (Labelling (LabelCol a x o d f)) = Base.label (unvar $ astColVar state astThis a) (transExprV x) (transDir o) (transExprV d) (transExprC $ f (Term VarRef) (Term ValRef))-transSearch state (CombineSeq a b) = transSearch state a <&> transSearch state b-transSearch state (CombinePar a b) = transSearch state a <|> transSearch state b-transSearch state (TryOnce a) = once <@> transSearch state a-transSearch state (LimitSolCount 1 a) = once <@> transSearch state a-transSearch state (PrintSol _ v _ a) = prt (map (unvar . astColVar state astThis) v) <@> transSearch state a-transSearch state (BranchBound v Minimize a) = bbmin (unvar $ astIntVar state astThis v) <@> transSearch state a--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 -> search $ transSearch state $ fromJust $ searchSpec state-{- 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
@@ -1,1677 +0,0 @@-{-# 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
@@ -1,359 +0,0 @@-{-# LANGUAGE CPP #-}-{-# LANGUAGE ForeignFunctionInterface #-}-{-# LANGUAGE GeneralizedNewtypeDeriving #-}-{-# LANGUAGE TypeFamilies #-}--{-# CFILES glue/interface.cpp #-}--module Control.CP.FD.Gecode.Interface (- 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, Eq, Ord, Show)-newtype CGColVar = CGColVar CInt- deriving (Storable, Eq, Ord, Show)-newtype CGBoolVar = CGBoolVar CInt- deriving (Storable, Eq, Ord, Show)-newtype CGBool = CGBool CInt- deriving Storable-newtype CGVal = CGVal CInt- deriving (Storable, Num, Eq, Show)--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)--foreign import ccall unsafe "gecode_model_create" c_gecode_model_create :: IO (Ptr GecodeModel)-foreign import ccall unsafe "gecode_model_destroy" c_gecode_model_destroy :: Ptr GecodeModel -> IO ()-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-foreign import ccall unsafe "gecode_int_rel_cs" c_gecode_int_rel_cs :: Ptr GecodeModel -> CGIntVar -> CGOperator -> CGVal -> IO CGBool-foreign import ccall unsafe "gecode_int_value" c_gecode_int_value :: Ptr GecodeModel -> CGIntVar -> CGVal -> IO CGBool-foreign import ccall unsafe "gecode_int_mult" c_gecode_int_mult :: Ptr GecodeModel -> CGIntVar -> CGIntVar -> CGIntVar -> IO CGBool-foreign import ccall unsafe "gecode_int_div" c_gecode_int_div :: Ptr GecodeModel -> CGIntVar -> CGIntVar -> CGIntVar -> IO CGBool-foreign import ccall unsafe "gecode_int_mod" c_gecode_int_mod :: Ptr GecodeModel -> CGIntVar -> CGIntVar -> CGIntVar -> IO CGBool-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_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_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--toCGVal :: Integral a => a -> CGVal-toCGVal n = CGVal $ fromIntegral n--fromCGVal :: Num a => CGVal -> a-fromCGVal (CGVal x) = fromIntegral x--toCGBool :: Bool -> CGBool-toCGBool n = CGBool $ if n then 1 else 0--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--newSpace :: IO Space-newSpace = do- 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- if (x == nullPtr)- then return s- else newForeignPtr c_gecode_model_finalize x--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)-runSearch s = withForeignPtr s $ \ptr -> do- x <- c_gecode_search_next ptr- if (x == nullPtr)- then return Nothing- else do- res <- newForeignPtr c_gecode_model_finalize x- return $ Just res--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---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
@@ -1,158 +0,0 @@-{-# 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
@@ -1,226 +0,0 @@-{-# 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/OvertonFD/Domain.hs view
@@ -1,13 +1,13 @@ {- - Origin:- - Constraint Programming in Haskell - - http://overtond.blogspot.com/2008/07/pre.html- - author: David Overton, Melbourne Australia+ - Constraint Programming in Haskell + - http://overtond.blogspot.com/2008/07/pre.html+ - author: David Overton, Melbourne Australia - - Modifications:- - Monadic Constraint Programming- - http://www.cs.kuleuven.be/~toms/Haskell/- - Tom Schrijvers+ - Monadic Constraint Programming+ - http://www.cs.kuleuven.be/~toms/Haskell/+ - Tom Schrijvers -} {-# LANGUAGE FlexibleInstances #-}
Control/CP/FD/OvertonFD/OvertonFD.hs view
@@ -10,7 +10,6 @@ - Tom Schrijvers -} --- {-# OPTIONS_GHC -fglasgow-exts #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-}
Control/CP/FD/Solvers.hs view
@@ -1,5 +1,3 @@-{-# LANGUAGE CPP #-}- module Control.CP.FD.Solvers where import qualified Control.CP.PriorityQueue as PriorityQueue@@ -12,10 +10,6 @@ -- import Control.CP.FD.OvertonFD.OvertonFD -- import Control.CP.FD.Gecode.CodegenSolver -#ifdef RGECODE--- import Control.CP.FD.Gecode.RuntimeSolver-#endif- -------------------------------------------------------------------------------- -- FORCE SOLVERS --------------------------------------------------------------------------------@@ -29,13 +23,6 @@ -- 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/Search/Generator.hs view
@@ -126,28 +126,28 @@ { structs :: ([Struct],[Struct]) -- auxiliary type declarations , treeState_ :: [(String,Type, Info -> m Statement)] -- tree state fields (name, type, init) , evalState_ :: [(String,Type, Info -> m Value)]- , nextSameH :: Info -> m Statement- , nextDiffH :: Info -> m Statement+ , nextSameH :: Info -> m Statement+ , nextDiffH :: Info -> m Statement , pushLeftH :: Info -> m Statement , pushRightH :: Info -> m Statement- , bodyH :: Info -> m Statement+ , bodyH :: Info -> m Statement , initH :: Info -> m Statement , addH :: Info -> m Statement- , returnH :: Info -> m Statement- , failH :: Info -> m Statement+ , returnH :: Info -> m Statement+ , failH :: Info -> m Statement , tryH :: Info -> m Statement , tryLH :: Info -> m Statement , startTryH :: Info -> m Statement , intArraysE :: [String] , boolArraysE :: [String] , intVarsE :: [String]- , -- Free heap allocated memory for search heuristic associated to this node- -- because it is being abandoned.- --- -- BE CAREFUL: deallocate memory only once in case of multiple references.- --- -- Example use case: untilLoop- deleteH :: Info -> m Statement+ , -- Free heap allocated memory for search heuristic associated to this node+ -- because it is being abandoned.+ --+ -- BE CAREFUL: deallocate memory only once in case of multiple references.+ --+ -- Example use case: untilLoop+ deleteH :: Info -> m Statement , toString :: String , canBranch :: m Bool , complete :: Info -> m Value@@ -675,7 +675,7 @@ #endif {-# RULES- "L" L = unsafeCoerce+ "L" L = unsafeCoerce #-} {-# RULES "runL" runL = unsafeCoerce@@ -697,13 +697,13 @@ Search { mkeval = evals1, runsearch = runs1 } -> case s2 of Search { mkeval = evals2, runsearch = runs2 } ->- Search {mkeval =- \super -> do { s2' <- evals2 $ mapE (L . L . mmap runL . runL) super- ; s1' <- evals1 (mapE runL s2')- ; return $ mapE (L . mmap L . runL) s1'- }- , runsearch = runs2 . runs1 . runL- }+ Search {mkeval =+ \super -> do { s2' <- evals2 $ mapE (L . L . mmap runL . runL) super+ ; s1' <- evals1 (mapE runL s2')+ ; return $ mapE (L . mmap L . runL) s1'+ }+ , runsearch = runs2 . runs1 . runL+ } data SearchCombiner = forall t1 t2. (FMonadT t1, FMonadT t2, MonadInfoT t1, MonadInfoT t2) =>
Control/Search/SStateT.hs view
@@ -1,5 +1,3 @@--- {-# OPTIONS -fglasgow-exts #-}- {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE MultiParamTypeClasses #-} @@ -8,7 +6,6 @@ Tup2(..), snd2, fst2 ) where ---import Monatron.Operations import Control.Monad.Fix import Control.Monatron.MonadT import Control.Monatron.AutoInstances ()
examples/Domino.hs view
@@ -35,6 +35,7 @@ main = example_sat_main_single_expr model +specs :: ModelCol specs = list [ 8,7,
examples/GraphColor.hs view
@@ -40,6 +40,7 @@ 5,6,2,4,6,8,10,12,0,1,1,2,2,3,3,4,4,0,2,4 -} +board :: ModelCol board = list $ [ 200,367,
examples/LangfordNumber.hs view
@@ -5,7 +5,8 @@ model :: ExampleModel ModelCol model c = do- let n = c!0+ let c = col+ n = c!0 k = c!1 exists $ \y -> do size y @= k*n@@ -25,3 +26,5 @@ main = example_sat_main_coll_expr model +col :: ModelCol+col = list $ [4,2]
examples/MineSweeper.hs view
@@ -3,7 +3,10 @@ import Control.CP.FD.Example +aroundY :: ModelCol aroundY = list [-1,-1,0,1,1,1,0,-1]++aroundX :: ModelCol aroundX = list [0,1,1,1,0,-1,-1,-1] model :: ExampleModel ()@@ -29,6 +32,7 @@ u = (-1) +board :: ModelCol board = list $ [ 10,
examples/Olympic.hs view
@@ -1,3 +1,6 @@+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE FlexibleContexts #-}+ {- % File : olympic.pl % Author : Neng-Fa ZHOU@@ -10,7 +13,7 @@ X4 X5 X6 - X2 X1 + X2 X3 X1 @@ -27,25 +30,22 @@ -} -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+main = example_sat_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+model :: ExampleModel ()+model _ = exists $ \col -> do+ [x1,x2,x3,x4,x5,x6,x7,x8,x9,x10] <- colList col 10+ col `allin` (cte 1, cte 10) + allDiff col+ x1 @= 3+ minus x2 x3 x1+ minus x4 x5 x2+ minus x5 x6 x3+ minus x7 x8 x4+ minus x8 x9 x5+ minus x9 x10 x6+ return col minus x1 x2 x3 = (abs (x1-x2)) @= x3
examples/Partition.hs view
@@ -2,9 +2,6 @@ {-# LANGUAGE FlexibleContexts #-} import Control.CP.FD.Example-import Control.CP.SearchTree-import Control.CP.Solver-import Control.CP.FD.Interface model :: ExampleModel ModelInt model n =
examples/Ring.hs view
@@ -1,30 +1,19 @@-import Control.CP.FD.Example.Example-import Control.CP.FD.FD-import Control.CP.FD.Expr-import Control.CP.SearchTree+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE FlexibleContexts #-} -import List (tails)-import Data.Map (toList)+import Control.CP.FD.Example -main = example_main_single model+main = example_sat_main_single_expr 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))+model :: ExampleModel ModelInt+model n = exists $ \col -> do+ size col @= n+ loopall (0,(n-1)) $ \i -> do+ let v0 = col ! i+ v1 = col ! ((i+1) `mod` n)+ v2 = col ! ((i+2) `mod` n)+ 2 * v1 @= 2 * v2 - v0+ v0 @: (cte (-10), cte 10)+ return col --- 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 view
@@ -1,23 +1,22 @@-import List (transpose)--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 -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]+main = example_sat_main_single_expr model -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+model :: ExampleModel ModelInt+model n = exists $ \col -> do+ l <- colList col 5+ col `allin` (cte 0, cte 5*n)+ let revCol = list (reverse l)+ colP = list [0,2,4]+ forall revCol $ \v ->+ forall colP $ \p -> + loopall (0,5*n) $ \j ->+ v @/= 5*j+p+ loopall (0,5*(n `div` 2)) $ \j ->+ forall revCol $ \v -> do+ v @>= 5*j+ v @<= 5*(j+5*(n `div` 2))+ return col
examples/TryDemo.hs view
@@ -1,19 +1,21 @@+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE FlexibleContexts #-}+ {- - Monadic Constraint Programming - http://www.cs.kuleuven.be/~toms/Haskell/ - Tom Schrijvers & Pieter Wuille -} -import Control.CP.FD.Example.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+main = example_sat_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]+model :: ExampleModel ()+model _ = exists $ \col -> do+ [a,b] <- colList col 2+ a @: (cte 1, cte 5)+ b @: (cte 0, cte 4)+ a - b @= 1+ (a @= 2) @|| (a @= 3) @|| (a @= 4)+ return col
examples/Zebra.hs view
@@ -1,39 +1,43 @@-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_void model+import Control.CP.FD.Example -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 +main = example_sat_main_void model +model :: ExampleModel ()+model _ = exists $ \vars -> do+ [n1,n2,n3,n4,n5,+ c1,c2,c3,c4,c5,+ p1,p2,p3,p4,p5,+ a1,a2,a3,a4,a5,+ d1,d2,d3,d4,d5] <- colList vars 25+ let ns = slice vars (cte 0 @.. cte 4)+ cs = slice vars (cte 5 @.. cte 9)+ ps = slice vars (cte 10 @.. cte 14)+ as = slice vars (cte 15 @.. cte 19)+ ds = slice vars (cte 20 @.. cte 24)+ vars `allin` (cte 1, cte 5)+ allDiff ns+ allDiff cs+ allDiff ps+ allDiff as+ allDiff ds+ n1 @= c2+ n2 @= a1+ n3 @= p1+ n4 @= d3+ n5 @= 1+ d5 @= 3+ p3 @= d1+ c1 @= d4+ p5 @= a4+ p2 @= c3+ c1 @= c5+1+ plusorminus a3 p4 1+ plusorminus a5 p2 1+ plusorminus n5 c4 1+ return vars+ plusorminus x y c =- x @= y+c \/ x @= y-c+ x @= y+c @|| x @= y-c
− lib/gecodeglue.cpp
@@ -1,887 +0,0 @@-#define _interface_cpp_--#include <vector>-#include <iostream>--#include "gecode/kernel.hh" -#include "gecode/support.hh" -#include "gecode/int.hh" -#include "gecode/search.hh" --#include "gecodeglue.h"--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(), 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- }- ~HaskellModel() {-#ifndef NDEBUG- identify(); cerr << "delmodel\n";-#endif- }- 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<(int)model.boolVars.size(); i++) {- boolVars.at(i).update(*this, share, model.boolVars.at(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() const {- for (int i=0; i<level; i++) {- cerr << " ";- }- cerr << "[" << origNum << ":" << num << "] ";- }-#endif- - int addIntVar(int low, int high) {- int ret = intVars.size();- IntVar b(*this,low,high);- intVars.push_back(b);-#ifndef NDEBUG- identify(); cerr << "addintvar v" << ret << "\n";-#endif- return ret;- }- int addBoolVar(int low, int high) {- int ret = boolVars.size();- BoolVar b(*this,low,high);- boolVars.push_back(b);-#ifndef NDEBUG- identify(); cerr << "addboolvar v" << ret << "\n";-#endif- return ret;- }- 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) {- 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;- }- ptr[0]=v.min();- ptr[1]=v.max();- ptr[2]=v.med();- int ss=v.size();- if (ss==1) {- ptr[3]=1;- ptr[4]=v.val();- } else {- 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) {- return getIntVar(var).in(val);- }- int getBoolInfo(int var) {- SpaceStatus state=status();- if (state==SS_FAILED) return -2;- BoolVar v = getBoolVar(var);- if (v.assigned()) {- return (v.val() ? 1 : 0);- } else {- return -1;- }- }-- void postIntValue(int var, int val) {- IntVar v=getIntVar(var);-#ifndef NDEBUG- identify(); cerr << "intvalue v" << var << " = " << val << "\n";-#endif- rel(*this,v,IRT_EQ,val,icl);- }-- void postIntSame(int var1, int var2) {- IntVar v1 = getIntVar(var1);- IntVar v2 = getIntVar(var2);-#ifndef NDEBUG- identify(); cerr << "intsame v" << var1 << " = v" << var2 << "\n";-#endif- 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) {- IntVar v1 = getIntVar(var1);- IntVar v2 = getIntVar(var2);-#ifndef NDEBUG- identify(); cerr << "intdiff v" << var1 << " != v" << var2 << "\n";-#endif- rel(*this,v1,IRT_NQ,v2,icl);- }- - void postIntRel(int var1, goperator_t op, int var2) {- 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- rel(*this,v1,mapGoperator(op),v2,icl);- }- - void postIntRelCf(int v1, goperator_t op, int var2) {- IntVar v2 = getIntVar(var2);-#ifndef NDEBUG- identify(); cerr << "intrelcf " << v1 << " " << (op==GOPERATOR_OEQUAL ? "==" : (op==GOPERATOR_OLESS ? "<" : "!=")) << " v" << var2 << "\n";-#endif- rel(*this,v2,mapGoperator(op,true),v1,icl);- }-- void postIntRelCs(int var1, goperator_t op, int v2) {- IntVar v1 = getIntVar(var1);-#ifndef NDEBUG- identify(); cerr << "intrelcs v" << var1 << " " << (op==GOPERATOR_OEQUAL ? "==" : (op==GOPERATOR_OLESS ? "<" : "!=")) << " " << v2 << "\n";-#endif- rel(*this,v1,mapGoperator(op),v2,icl);- }-- void postIntMult(int var1, int var2, int varr) {- 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- mult(*this,v1,v2,vr,icl);- }-- void postIntDiv(int var1, int var2, int varr) {- 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- div(*this,v1,v2,vr,icl);- }-- void postIntMod(int var1, int var2, int varr) {- 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- mod(*this,v1,v2,vr,icl);- }-- void postIntAbs(int var, int varr) {- IntVar v = getIntVar(var);- IntVar vr = getIntVar(varr);-#ifndef NDEBUG- identify(); cerr << "intabs abs(v" << var << ") = v" << varr << "\n";-#endif- abs(*this,v,vr,icl);- }-- void postIntDom(int var, int low, int high) {- IntVar v = getIntVar(var);-#ifndef NDEBUG- identify(); cerr << "intdom v" << var << " = [" << low << "," << high << "]\n";-#endif- dom(*this,v,low,high,icl);- }-- void postIntLinear(int num, int *vars, int *coef, goperator_t op, int val) {- IntVarArgs vrs(num);- IntArgs vls(num,coef);- for (int i=0; i<num; i++) {- vrs[i] = getIntVar(vars[i]);- }-#ifndef NDEBUG- 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 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++) {- 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,dom ? ICL_DOM : icl);- }-- 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++) {- vrs[i] = getIntVar(vars[i]);- }-#ifndef NDEBUG- identify(); cerr << "intsorted num=" << num << "\n";-#endif- rel(*this,vrs,mapGoperator(op),icl);- }-- void postIntBranching(int num, int *vars) {- IntVarArgs vrs(num);- for (int i=0; i<num; i++) {- vrs[i] = getIntVar(vars[i]);- }-#ifndef NDEBUG- identify(); cerr << "intbranch num=" << num << "\n";-#endif- branch(*this,vrs, INT_VAR_SIZE_MIN, INT_VAL_SPLIT_MIN);- }-- void postBoolBranching(int num, int *vars) {- BoolVarArgs vrs(num);- for (int i=0; i<num; i++) {- vrs[i] = getBoolVar(vars[i]);- }-#ifndef NDEBUG- 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) { - 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); }-extern "C" int gecode_int_value(HaskellModel *model, int v, int val) { model->postIntValue(v,val); return !model->failed(); }-extern "C" int gecode_int_mult(HaskellModel *model, int v1, int v2, int vr) { model->postIntMult(v1,v2,vr); return !model->failed(); }-extern "C" int gecode_int_div(HaskellModel *model, int v1, int v2, int vr) { model->postIntDiv(v1,v2,vr); return !model->failed(); }-extern "C" int gecode_int_mod(HaskellModel *model, int v1, int v2, int vr) { model->postIntMod(v1,v2,vr); return !model->failed(); }-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_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 *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" 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();- o.c_d = 1;- gecode_search_data_t *srch=new gecode_search_data_t;-#ifndef NDEBUG- 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" 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 " << srch << "] destroyed\n";-#endif- 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(gecode_search_data_t *srch) { -#ifndef NDEBUG- cerr << "[search " << srch << "] requesting next\n";-#endif- 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;- }- default:- res=NULL;- }-#ifndef NDEBUG- cerr << "[search " << srch << "] requested next (" << res << ")\n";-#endif- return res;-}
− lib/gecodeglue.h
@@ -1,37 +0,0 @@-#ifndef _interface_h_-#define _interface_h_ 1--typedef enum {- GOPERATOR_OEQUAL,- GOPERATOR_ODIFF,- GOPERATOR_OLESS,- GOPERATOR_OLESSEQUAL-} goperator_t;--#ifndef _interface_cpp_-typedef struct HaskellModel_ HaskellModel;--HaskellModel *gecode_model_create(void);-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);-int gecode_int_mult(HaskellModel *model, int v1, int v2, int vr);-int gecode_int_div(HaskellModel *model, int v1, int v2, int vr);-int gecode_int_mod(HaskellModel *model, int v1, int v2, int vr);-int gecode_int_abs(HaskellModel *model, int v, int vr);-int gecode_int_dom(HaskellModel *model, int v, int low, int high);-int gecode_int_linear(HaskellModel *model, int num, int *vars, int *coef, goperator_t op, int val);-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--#endif
monadiccp.cabal view
@@ -1,30 +1,25 @@ Name: monadiccp-Version: 0.7.5+Version: 0.7.6 Description: Monadic Constraint Programming framework License: BSD3 License-file: LICENSE Author: Tom Schrijvers, Pieter Wuille-Maintainer: maik.riechert@arcor.de +Maintainer: maik.riechert@arcor.de Build-Type: Simple Category: control Synopsis: Constraint Programming Homepage: http://users.ugent.be/~tschrijv/MCP/ Bug-reports: https://github.com/neothemachine/monadiccp/issues Cabal-Version: >=1.6-Extra-Source-Files: examples/*.hs lib/*.cpp lib/*.h+Extra-Source-Files: examples/*.hs Data-Files: README.md -tested-with: - GHC==7.4.1, - GHC==7.6.2 +tested-with: + GHC==7.6.3 source-repository head type: git- location: git://github.com/neothemachine/monadiccp.git--Flag RuntimeGecode- Description: Include the RuntimeSolver and SearchSolver for Gecode. Requires a working Gecode 3.1 installation.- Default: False+ location: https://github.com/neothemachine/monadiccp.git Flag Debug Description: Generate debug output@@ -33,6 +28,9 @@ library Build-Depends: base >= 2, base < 5, containers, mtl, random, pretty, parsec >= 3.0 Exposed-Modules: Data.Expr.Sugar+ Data.Expr.Data+ Data.Expr.Util+ Data.Linear Control.CP.SearchTree Control.CP.Transformers Control.CP.ComposableTransformers@@ -44,23 +42,15 @@ 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 Control.CP.FD.FD- Control.CP.FD.Gecode.Common- Other-Modules: Data.Expr.Data- Data.Expr.Util- Data.Linear+ Control.CP.Debug+ Control.CP.FD.SearchSpec.Data Control.CP.FD.OvertonFD.Domain Control.CP.FD.SimpleFD Control.CP.FD.Graph- Control.CP.FD.Decompose- Control.CP.FD.SearchSpec.Data- Control.CP.Debug- Control.Mixin.Mixin- Language.CPP.Syntax.AST- Language.CPP.Pretty+ Control.CP.FD.Decompose Control.Search.Language Control.Search.Stat Control.Search.Generator@@ -84,7 +74,10 @@ Control.Search.Constraints Control.Search.MemoReader Control.Search.SStateT- Control.Monatron.Monatron+ Control.Mixin.Mixin+ Language.CPP.Syntax.AST+ Language.CPP.Pretty+ Other-Modules: Control.Monatron.Monatron Control.Monatron.MonadInfo Control.Monatron.AutoLift Control.Monatron.Operations@@ -98,17 +91,8 @@ Control.Monatron.Monad Control.Monatron.ZipperExamples GHC-Prof-Options: -auto-all -caf-all- Include-Dirs: lib if flag(Debug) CPP-Options: -DDEBUG CC-Options: "-ggdb3" "-Wall" else 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.Runtime- Control.CP.FD.Gecode.RuntimeSearch- Control.CP.FD.Gecode.Interface- CPP-Options: -DRGECODE- Frameworks: gecode