packages feed

monadiccp-gecode 0.1.2 → 0.1.3

raw patch · 16 files changed

+3754/−3723 lines, 16 filesdep +monadiccp-gecodedep ~base

Dependencies added: monadiccp-gecode

Dependency ranges changed: base

Files

− 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,1691 +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++"?"---- workaround for collections which contain constant values and variables:--- for each constant value a new variable is introduced which is bound to the value-decompInt :: (GecodeSolver s, Constraint s ~ GecodeConstraint s) => GecodeIntSpec s -> (GecodeWrappedSolver s) (GecodeIntVar s)-decompInt (GITVar v)     = return v-decompInt (GITConst val) = do-  x <- newvar-  add $ GCIntVal x val-  return x-decompInt (GITLinear l)  = do-  x <- newvar-  add $ GCLinear (l-(termToLinear x)) GOEqual-  return x--newtype GecodeWrappedSolver s a = GecodeWrappedSolver (s a)-newtype 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-    vir <- mapM decompInt 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,353 +0,0 @@-{-# 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--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
− 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/GecodeExample.hs 
@@ -1,91 +0,0 @@-{-# LANGUAGE RankNTypes #-}-{-# LANGUAGE TypeFamilies #-}-{-# LANGUAGE FlexibleContexts #-}--module Control.CP.FD.GecodeExample (-  example_main_gecode,-  example_sat_main_gecode,-  example_sat_main_void_gecode,-  example_sat_main_single_gecode,-  example_sat_main_single_expr_gecode,-  example_sat_main_coll_expr_gecode,-  example_min_main_gecode,-  example_min_main_void_gecode,-  example_min_main_single_gecode,-  example_min_main_single_expr_gecode,-  example_min_main_coll_expr_gecode,-  setSearchMinimize,-  module Control.CP.FD.Example-) where--import System.Environment (getArgs)--import Control.CP.FD.Gecode.CodegenSolver-import Control.CP.FD.Gecode.Common-import Control.CP.FD.OvertonFD.OvertonFD-import Control.CP.SearchTree-import Control.CP.FD.FD--import Control.CP.FD.Example-import Control.CP.FD.Gecode.Runtime-import Control.CP.FD.Gecode.RuntimeSearch--import Control.Monad.Cont--codegenOptionset :: (CodegenGecodeOptions -> CodegenGecodeOptions) -> Tree (FDInstance (GecodeWrappedSolver CodegenGecodeSolver)) ()-codegenOptionset f = label ((liftFD $ liftGC $ Control.CP.FD.Gecode.CodegenSolver.setOptions f) >> return true)--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 ()--example_main_gecode :: ExampleModel [String] -> ExampleModel ModelInt -> ExampleModel ModelCol -> Bool -> IO ()-example_main_gecode 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)-    ("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-    ("overton_run":r) -> print $ runSolve typ $ ((f r) :: Tree (FDInstance OvertonFD) ModelCol) >>= labeller-    [] -> putStr "Solver type required: one of gecode_compile, gen_gecode_compile, gecode_run, gecode_run_cont, overton_run\n"-    (a:r) -> putStr ("Unsupported solver: " ++ a ++ "\n")--example_min_main_gecode :: ExampleMinModel [String] -> ExampleMinModel ModelInt -> ExampleMinModel ModelCol -> IO ()-example_min_main_gecode f fx fcx = example_main_gecode (postMinimize f) (postMinimize fx) (postMinimize fcx) True--example_sat_main_gecode :: ExampleModel [String] -> ExampleModel ModelInt -> ExampleModel ModelCol -> IO ()-example_sat_main_gecode f fx fcx = example_main_gecode f fx fcx False--example_sat_main_void_gecode :: ExampleModel () -> IO ()-example_sat_main_void_gecode f = example_sat_main_gecode (const $ f ()) (const $ f ()) (const $ f ())--example_min_main_void_gecode :: ExampleMinModel () -> IO ()-example_min_main_void_gecode f = example_min_main_gecode (const $ f ()) (const $ f ()) (const $ f ())--example_sat_main_single_gecode :: Read n => ExampleModel n -> IO ()-example_sat_main_single_gecode f = example_sat_main_gecode (f . read . head) (error "Uncompilable model") (error "Uncompilable model")--example_min_main_single_gecode :: Read n => ExampleMinModel n -> IO ()-example_min_main_single_gecode f = example_min_main_gecode (f . read . head) (error "Uncompilable model") (error "Uncompilable model")--example_sat_main_single_expr_gecode :: ExampleModel ModelInt -> IO ()-example_sat_main_single_expr_gecode f = example_sat_main_gecode (f . fromInteger . read . head) f (\x -> f $ x!(cte 0))--example_min_main_single_expr_gecode :: ExampleMinModel ModelInt -> IO ()-example_min_main_single_expr_gecode f = example_min_main_gecode (f . fromInteger . read . head) f (\x -> f $ x!(cte 0))--example_sat_main_coll_expr_gecode :: ExampleModel ModelCol -> IO ()-example_sat_main_coll_expr_gecode f = example_sat_main_gecode (f . list . foldr (++) [] . map (map fromInteger . read . (\x -> "[" ++ x ++ "]"))) (f. list . (\x -> [x])) f--example_min_main_coll_expr_gecode :: ExampleMinModel ModelCol -> IO ()-example_min_main_coll_expr_gecode f = example_min_main_gecode (f . list . foldr (++) [] . map (map fromInteger . read . (\x -> "[" ++ x ++ "]"))) (f. list . (\x -> [x])) f
README.md view
@@ -2,12 +2,19 @@ ================  Gecode extension for the Monadic Constraint Programming Framework-containing a code generator and a runtime solver backend for the C++ based constraint library Gecode+containing a code generator and a runtime solver backend for the+C++ based constraint library Gecode -This package requires a working Gecode 3.1.0 installation.-A Gecode 3.1.0 source package can be downloaded from http://www.gecode.org/download/gecode-3.1.0.tar.gz.+This package requires a working Gecode installation.+A Gecode source package can be downloaded from http://www.gecode.org/download/. -After installing Gecode 3.1.0 this package can be installed by running-cabal install --extra-include-dirs=$GECODE/include --extra-lib-dirs=$GECODE/lib+After installing Gecode this package can be installed by running+`cabal install --extra-include-dirs=$GECODE/include --extra-lib-dirs=$GECODE/lib` -$GECODE refers to the installation directory of Gecode 3.1.0+where `$GECODE` refers to the installation directory of Gecode++Acknowledgments+---------------++ * Thanks to Johannes Waldmann for adding support for Gecode 6.0.0 and getting+   the package to compile against GHC 8.4.3
examples/Queens.hs view
@@ -1,8 +1,11 @@ {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE LambdaCase #-}  import Control.CP.FD.GecodeExample +import System.Environment+ noattack i j qi qj = do   qi        @/=  qj   qi  +  i  @/=  qj  +  j@@ -18,5 +21,7 @@       noattack i j (p!i) (p!j)   return p -main = example_sat_main_single_expr_gecode model+main = getArgs >>= \ case+  [] -> withArgs ["gecode_run", "16"] $ example_sat_main_single_expr_gecode model+  _  -> example_sat_main_single_expr_gecode model
lib/gecodeglue.cpp view
@@ -23,7 +23,7 @@   vector<BoolVar> boolVars;   vector<IntVar> intVars;   vector<IntVarArgs> colVars;-  IntConLevel icl;+  IntPropLevel ipl;   int refcount;   int minimizeVar; #ifndef NDEBUG@@ -80,7 +80,7 @@   }  public:-  HaskellModel() : boolVars(), intVars(), colVars(), icl(ICL_DEF), refcount(0), minimizeVar(-1)+  HaskellModel() : boolVars(), intVars(), colVars(), ipl(IPL_DEF), refcount(0), minimizeVar(-1) #ifndef NDEBUG   , level(0), origNum(++nOrigModels), num(++nModels)  #endif@@ -95,7 +95,7 @@     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)+  HaskellModel(HaskellModel &model) : Space(model), boolVars(model.boolVars.size()), intVars(model.intVars.size()), ipl(model.ipl), refcount(0), minimizeVar(model.minimizeVar) #ifndef NDEBUG   , level(model.level+1), origNum(model.origNum), num(++nModels) #endif@@ -105,25 +105,25 @@     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));+      boolVars.at(i).update(*this, model.boolVars.at(i));     }     for (int i=0; i<(int)model.intVars.size(); i++) {-      intVars.at(i).update(*this, share, model.intVars.at(i));+      intVars.at(i).update(*this, 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]);+        ncol[j].update(*this,col[j]);       }       colVars.push_back(ncol);     }   }-  virtual Space *copy(bool share) {+  virtual Space *copy() { #ifndef NDEBUG     identify(); cerr << "making copy\n"; #endif-    return new HaskellModel(share, *this);+    return new HaskellModel(*this);   }  #ifndef NDEBUG@@ -271,7 +271,7 @@ #ifndef NDEBUG     identify(); cerr << "intvalue v" << var << " = " << val << "\n"; #endif-    rel(*this,v,IRT_EQ,val,icl);+    rel(*this,v,IRT_EQ,val,ipl);   }    void postIntSame(int var1, int var2) {@@ -280,14 +280,14 @@ #ifndef NDEBUG     identify(); cerr << "intsame v" << var1 << " = v" << var2 << "\n"; #endif-    rel(*this,v1,IRT_EQ,v2,icl);+    rel(*this,v1,IRT_EQ,v2,ipl);   }    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);+    rel(*this,getBoolVar(var1),IRT_EQ,getBoolVar(var2),ipl);   }    void postIntDiff(int var1, int var2) {@@ -296,7 +296,7 @@ #ifndef NDEBUG     identify(); cerr << "intdiff v" << var1 << " != v" << var2 << "\n"; #endif-    rel(*this,v1,IRT_NQ,v2,icl);+    rel(*this,v1,IRT_NQ,v2,ipl);   }      void postIntRel(int var1, goperator_t op, int var2) {@@ -305,7 +305,7 @@ #ifndef NDEBUG     identify(); cerr << "intrel v" << var1 << " " << (op==GOPERATOR_OEQUAL ? "==" : (op==GOPERATOR_OLESS ? "<" : "!=")) << " v" << var2 << "\n"; #endif-    rel(*this,v1,mapGoperator(op),v2,icl);+    rel(*this,v1,mapGoperator(op),v2,ipl);   }      void postIntRelCf(int v1, goperator_t op, int var2) {@@ -313,7 +313,7 @@ #ifndef NDEBUG     identify(); cerr << "intrelcf " << v1 << " " << (op==GOPERATOR_OEQUAL ? "==" : (op==GOPERATOR_OLESS ? "<" : "!=")) << " v" << var2 << "\n"; #endif-    rel(*this,v2,mapGoperator(op,true),v1,icl);+    rel(*this,v2,mapGoperator(op,true),v1,ipl);   }    void postIntRelCs(int var1, goperator_t op, int v2) {@@ -321,7 +321,7 @@ #ifndef NDEBUG     identify(); cerr << "intrelcs v" << var1 << " " << (op==GOPERATOR_OEQUAL ? "==" : (op==GOPERATOR_OLESS ? "<" : "!=")) << " " << v2 << "\n"; #endif-    rel(*this,v1,mapGoperator(op),v2,icl);+    rel(*this,v1,mapGoperator(op),v2,ipl);   }    void postIntMult(int var1, int var2, int varr) {@@ -331,7 +331,7 @@ #ifndef NDEBUG     identify(); cerr << "intmult v" << var1 << " * v" << var2 << " = v" << varr << "\n"; #endif-    mult(*this,v1,v2,vr,icl);+    mult(*this,v1,v2,vr,ipl);   }    void postIntDiv(int var1, int var2, int varr) {@@ -341,7 +341,7 @@ #ifndef NDEBUG     identify(); cerr << "intdiv v" << var1 << " / v" << var2 << " = v" << varr << "\n"; #endif-    div(*this,v1,v2,vr,icl);+    div(*this,v1,v2,vr,ipl);   }    void postIntMod(int var1, int var2, int varr) {@@ -351,7 +351,7 @@ #ifndef NDEBUG     identify(); cerr << "intmod v" << var1 << " mod v" << var2 << " = v" << varr << "\n"; #endif-    mod(*this,v1,v2,vr,icl);+    mod(*this,v1,v2,vr,ipl);   }    void postIntAbs(int var, int varr) {@@ -360,7 +360,7 @@ #ifndef NDEBUG     identify(); cerr << "intabs abs(v" << var << ") = v" << varr << "\n"; #endif-    abs(*this,v,vr,icl);+    abs(*this,v,vr,ipl);   }    void postIntDom(int var, int low, int high) {@@ -368,7 +368,7 @@ #ifndef NDEBUG     identify(); cerr << "intdom v" << var << " = [" << low << "," << high << "]\n"; #endif-    dom(*this,v,low,high,icl);+    dom(*this,v,low,high,ipl);   }    void postIntLinear(int num, int *vars, int *coef, goperator_t op, int val) {@@ -381,7 +381,7 @@     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);+    linear(*this,vls,vrs,mapGoperator(op),val,ipl);   }    void postIntLinearReif(int num, int *vars, int *coef, goperator_t op, int val, int reif) {@@ -393,7 +393,7 @@ #ifndef NDEBUG     identify(); cerr << "intlinear num=" << num << "\n"; #endif-    linear(*this,vls,vrs,mapGoperator(op),val,getBoolVar(reif),icl);+    linear(*this,vls,vrs,mapGoperator(op),val,getBoolVar(reif),ipl);   }    void postIntAlldiff(int num, int *vars,int dom) {@@ -404,7 +404,7 @@ #ifndef NDEBUG     identify(); cerr << "intalldiff num=" << num << "\n"; #endif-    distinct(*this,vrs,dom ? ICL_DOM : icl);+    distinct(*this,vrs,dom ? IPL_DOM : ipl);   }    void postColAlldiff(int var, int dom) {@@ -412,7 +412,7 @@ #ifndef NDEBUG     identify(); cerr << "colalldiff col=" << var << "\n"; #endif-    distinct(*this,vars,dom ? ICL_DOM : icl);+    distinct(*this,vars,dom ? IPL_DOM : ipl);   }    void postColSorted(int var, goperator_t op) {@@ -420,7 +420,7 @@ #ifndef NDEBUG     identify(); cerr << "colsorted col=" << var << " op=" << op << "\n"; #endif-    rel(*this,vars,mapGoperator(op),icl);+    rel(*this,vars,mapGoperator(op),ipl);   }    void postColSum(int col,int var) {@@ -429,7 +429,7 @@ #ifndef NDEBUG     identify(); cerr << "colsum col=" << col << " sumvar=" << var << "\n"; #endif-    linear(*this,vars,IRT_EQ,sum,icl);+    linear(*this,vars,IRT_EQ,sum,ipl);   }    void postColSumC(int col,int val) {@@ -437,7 +437,7 @@ #ifndef NDEBUG     identify(); cerr << "colsum col=" << col << " sumval=" << val << "\n"; #endif-    linear(*this,vars,IRT_EQ,val,icl);+    linear(*this,vars,IRT_EQ,val,ipl);   }    void postIntSorted(int num, int *vars, goperator_t op) {@@ -448,7 +448,7 @@ #ifndef NDEBUG     identify(); cerr << "intsorted num=" << num << "\n"; #endif-    rel(*this,vrs,mapGoperator(op),icl);+    rel(*this,vrs,mapGoperator(op),ipl);   }    void postIntBranching(int num, int *vars) {@@ -459,7 +459,7 @@ #ifndef NDEBUG     identify(); cerr << "intbranch num=" << num << "\n"; #endif-    branch(*this,vrs, INT_VAR_SIZE_MIN, INT_VAL_SPLIT_MIN);+    branch(*this,vrs, INT_VAR_SIZE_MIN(), INT_VAL_SPLIT_MIN());   }    void postBoolBranching(int num, int *vars) {@@ -470,7 +470,7 @@ #ifndef NDEBUG     identify(); cerr << "intbranch num=" << num << "\n"; #endif-    branch(*this,vrs, INT_VAR_SIZE_MIN, INT_VAL_SPLIT_MIN);+    branch(*this,vrs, BOOL_VAR_NONE(), BOOL_VAL_MIN());   }      void postColCount(int col,int isValConst,int val,goperator_t op,int isCountConst,int count) {@@ -519,14 +519,14 @@         vrs[p++]=col[k];       }     }-    branch(*this,vrs,INT_VAR_SIZE_MIN, INT_VAL_SPLIT_MIN);+    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);+    rel(*this,getBoolVar(var),IRT_EQ,val,ipl);   }    int postColEqual(int c1, int c2) {@@ -538,7 +538,7 @@     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);+      rel(*this,col1[i],IRT_EQ,col2[i],ipl);     }     return 1;   }@@ -555,10 +555,10 @@     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);+      rel(*this,col1[i],IRT_EQ,colr[i],ipl);     }     for (int i=0; i<len2; i++) {-      rel(*this,col2[i],IRT_EQ,colr[i+len1],icl);+      rel(*this,col2[i],IRT_EQ,colr[i+len1],ipl);     }     return 1;   }@@ -575,7 +575,7 @@     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);+      rel(*this,col[i+p],IRT_EQ,colr[i],ipl);     }     return 1;   }@@ -584,7 +584,7 @@ #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);+    element(*this,getColVar(c),getIntVar(p),getIntVar(i),ipl);   }    void postColAtList(int n, int *l, int p, int i) {@@ -592,14 +592,14 @@ #ifndef NDEBUG     identify(); cerr << "colat col=[...] pos=v"<<p<<" res=v"<<i<<"\n"; #endif-    element(*this,args,getIntVar(p),getIntVar(i),icl);+    element(*this,args,getIntVar(p),getIntVar(i),ipl);   }    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);+    element(*this,getColVar(c),getIntVar(p),v,ipl);   }    void postColAtListConst(int n, int *l, int p, int v) {@@ -607,13 +607,13 @@ #ifndef NDEBUG     identify(); cerr << "colat col=[...] pos=v"<<p<<" res="<<v<<"\n"; #endif-    element(*this,args,getIntVar(p),v,icl);+    element(*this,args,getIntVar(p),v,ipl);   }    void postDom(int i,int c) {     IntVar iv = getIntVar(i);     IntVarArgs iva = getColVar(c);-    count(*this,iva,iv,IRT_GR,0,icl);+    count(*this,iva,iv,IRT_GR,0,ipl);   }    void postDom(int i, int n, const int *c, int r) {@@ -621,10 +621,10 @@     IntArgs ia(n,c);     IntSet is(ia);     if (r<0) {-      dom(*this,iv,is,icl);+      dom(*this,iv,is,ipl);     } else {       BoolVar rv = getBoolVar(r);-      dom(*this,iv,is,rv,icl);+      dom(*this,iv,is,rv,ipl);     }   } @@ -632,35 +632,35 @@ #ifndef NDEBUG     identify(); cerr << "channel bool=v"<<b<<" int=v"<<i<<"\n"; #endif-    channel(*this,getBoolVar(b),getIntVar(i),icl);+    channel(*this,getBoolVar(b),getIntVar(i),ipl);   }    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);+    rel(*this,getBoolVar(a),BOT_AND,getBoolVar(b),getBoolVar(r),ipl);   }    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);+    rel(*this,getBoolVar(a),BOT_OR,getBoolVar(b),getBoolVar(r),ipl);   }    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);+    rel(*this,getBoolVar(a),BOT_EQV,getBoolVar(b),getBoolVar(r),ipl);   }    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);+    rel(*this,getBoolVar(a),IRT_NQ,getBoolVar(r),ipl);   }    void postBoolAll(int num, int *vars, int r) {@@ -736,7 +736,7 @@   if (state==SS_FAILED) {     return NULL;   } else {-    return (HaskellModel*)(model->clone(true));+    return (HaskellModel*)(model->clone());   } } extern "C" HaskellModel *gecode_model_copy_reentrant(HaskellModel *model) {@@ -744,7 +744,7 @@   if (state==SS_FAILED) {     return NULL;   } else {-    return (HaskellModel*)(model->clone(false));+    return (HaskellModel*)(model->clone());   } } extern "C" void gecode_model_fail(HaskellModel *model) { model->message("fail"); model->fail(); }
monadiccp-gecode.cabal view
@@ -1,45 +1,54 @@-Name:			monadiccp-gecode-Version:		0.1.2-Description:		Gecode extension for the Monadic Constraint Programming Framework (code generator and runtime solver backend)-License:		BSD3-License-file:		LICENSE-Author:			Tom Schrijvers, Pieter Wuille-Maintainer:		jrt@informatik.uni-kiel.de-Build-Type:		Simple-Category:		control-Synopsis:		Constraint Programming-Homepage:		http://users.ugent.be/~tschrijv/MCP/-Bug-Reports:		https://github.com/JTiko/monadiccp-gecode/issues-Cabal-Version:		>= 1.6-Extra-Source-Files:	examples/*.hs lib/*.cpp lib/*.h-Data-Files:		README.md+Name:                  monadiccp-gecode+Version:               0.1.3+Description:           Gecode extension for the Monadic Constraint Programming Framework (code generator and runtime solver backend)+License:               BSD3+License-file:          LICENSE+Author:                Tom Schrijvers, Pieter Wuille+Maintainer:            jrt@informatik.uni-kiel.de+Build-Type:            Simple+Category:              control+Synopsis:              Constraint Programming+Homepage:              http://users.ugent.be/~tschrijv/MCP/+Bug-Reports:           https://github.com/JTiko/monadiccp-gecode/issues+Cabal-Version:         >= 1.8+Extra-Source-Files:    examples/*.hs lib/*.cpp lib/*.h+Data-Files:            README.md -tested-with:     -                 GHC==7.6.3+tested-with:+                 GHC==8.4.3  source-repository head   type: git-  location: https://github.com/JTiko/monadiccp-gecode.git +  location: https://github.com/JTiko/monadiccp-gecode.git  Flag Debug-    Description:	Generate debug output-    Default:		False+    Description:       Generate debug output+    Default:           False  library-    Include-Dirs:	lib-    Build-Depends:	base >= 2, base < 5, containers, mtl, monadiccp >= 0.7.6-    C-Sources:		lib/gecodeglue.cpp-    Extra-Libraries:	gecodesupport gecodeset gecodeint gecodekernel gecodesearch-    Exposed-Modules:    Control.CP.FD.GecodeExample-                        Control.CP.FD.Gecode.Runtime-                        Control.CP.FD.Gecode.RuntimeSearch-                        Control.CP.FD.Gecode.Interface-                        Control.CP.FD.Gecode.Common-                        Control.CP.FD.Gecode.CodegenSolver-    Frameworks:		gecode+    Hs-Source-Dirs:    src+    Include-Dirs:      lib+                       /opt/gecode/gecode-6.0.0/include+    Build-Depends:     base >= 2, base < 5, containers, mtl, monadiccp >= 0.7.6+    C-Sources:         lib/gecodeglue.cpp+    Extra-Libraries:   gecodesupport gecodeset gecodeint gecodekernel gecodesearch stdc+++    extra-lib-dirs:    /opt/gecode/gecode-6.0.0/lib+    Exposed-Modules:   Control.CP.FD.GecodeExample+                       Control.CP.FD.Gecode.Runtime+                       Control.CP.FD.Gecode.RuntimeSearch+                       Control.CP.FD.Gecode.Interface+                       Control.CP.FD.Gecode.Common+                       Control.CP.FD.Gecode.CodegenSolver+    Frameworks:        gecode      if flag(Debug)-        CPP-Options:	-DDEBUG-        CC-Options:	"-ggdb3" "-Wall"+        CPP-Options:    -DDEBUG+        CC-Options:     "-ggdb3" "-Wall" "-std=c++11"     else-        CC-Options:	"-g0" "-DNDEBUG" "-Wall"+        CC-Options:     "-g0" "-DNDEBUG" "-Wall" "-std=c++11"++test-suite Queens+    hs-source-dirs: examples+    type: exitcode-stdio-1.0+    main-is: Queens.hs+    build-depends: base, monadiccp-gecode
+ src/Control/CP/FD/Gecode/CodegenSolver.hs view
@@ -0,0 +1,1114 @@+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE FlexibleContexts #-}++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 (Functor, Applicative, 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
+ src/Control/CP/FD/Gecode/Common.hs view
@@ -0,0 +1,1699 @@+{-# 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.Monad (liftM,ap)++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++"?"++-- workaround for collections which contain constant values and variables:+-- for each constant value a new variable is introduced which is bound to the value+decompInt :: (GecodeSolver s, Constraint s ~ GecodeConstraint s) => GecodeIntSpec s -> (GecodeWrappedSolver s) (GecodeIntVar s)+decompInt (GITVar v)     = return v+decompInt (GITConst val) = do+  x <- newvar+  add $ GCIntVal x val+  return x+decompInt (GITLinear l)  = do+  x <- newvar+  add $ GCLinear (l-(termToLinear x)) GOEqual+  return x++newtype GecodeWrappedSolver s a = GecodeWrappedSolver (s a)+newtype GecodeWrappedLabel s = GecodeWrappedLabel (Label s)++instance (GecodeSolver s, Constraint s ~ GecodeConstraint s) => Functor (GecodeWrappedSolver s) where+  fmap = liftM++instance (GecodeSolver s, Constraint s ~ GecodeConstraint s) => Applicative (GecodeWrappedSolver s) where+  pure = GecodeWrappedSolver . return+  (<*>) = ap++instance (GecodeSolver s, Constraint s ~ GecodeConstraint s) => Monad (GecodeWrappedSolver s) where+  {-# INLINE (>>=) #-}+  return = pure+  (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+    vir <- mapM decompInt 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
+ src/Control/CP/FD/Gecode/Interface.hsc view
@@ -0,0 +1,353 @@+{-# 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++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
+ src/Control/CP/FD/Gecode/Runtime.hs view
@@ -0,0 +1,158 @@+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE CPP #-}++module Control.CP.FD.Gecode.Runtime (+  RuntimeGecodeSolver+) where++import Control.Monad.State.Lazy+import System.IO.Unsafe++import Data.Map (Map)+import qualified Data.Map as Map++import Control.Mixin.Mixin+import Data.Linear++import Control.CP.Debug+import Control.CP.Solver+import Control.CP.EnumTerm+import Control.CP.FD.FD+import Data.Expr.Sugar+import Control.CP.FD.Model+import Control.CP.FD.Gecode.Common++import qualified Control.CP.FD.Gecode.Interface as GCI++-- ################################## RuntimeGecodeSolver #########################################++newtype RuntimeGecodeState = RuntimeGecodeState {+  spaceRef :: GCI.Space+}++newtype RuntimeGecodeSolver a = RuntimeGecodeSolver { rgsStateT :: StateT RuntimeGecodeState IO a }+  deriving (Functor, Applicative, 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"
+ src/Control/CP/FD/Gecode/RuntimeSearch.hs view
@@ -0,0 +1,226 @@+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE MultiParamTypeClasses #-}++module Control.CP.FD.Gecode.RuntimeSearch (+  SearchGecodeSolver,+  SearchGecodeOptions(..),+  setOptions+) where++import Control.Monad.State.Lazy+import System.IO.Unsafe++import Data.Map (Map)+import qualified Data.Map as Map++import Control.Mixin.Mixin++import Control.CP.Debug+import Control.CP.Solver+import Control.CP.EnumTerm+import Control.CP.SearchTree+import Control.CP.FD.FD+import Data.Expr.Sugar+import Control.CP.FD.Model+import Control.CP.FD.Gecode.Common++import qualified Control.CP.FD.Gecode.Interface as GCI++-- ################################## SearchGecodeSolver #########################################++data SearchGecodeState = SearchGecodeState { spaceRef :: GCI.Space, options :: SearchGecodeOptions }++data SearchGecodeOptions = SearchGecodeOptions { minimizeVar :: Maybe GCI.CGIntVar }++initOptions :: SearchGecodeOptions+initOptions = SearchGecodeOptions {+  minimizeVar = Nothing+}++setOptions :: (SearchGecodeOptions -> SearchGecodeOptions) -> SearchGecodeSolver ()+setOptions f = do+  s <- get+  put $ s { options = f $ options s }++newtype SearchGecodeSolver a = SearchGecodeSolver { sgsStateT :: StateT SearchGecodeState IO a }+  deriving (Functor, Applicative, 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
+ src/Control/CP/FD/GecodeExample.hs view
@@ -0,0 +1,92 @@+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE AllowAmbiguousTypes #-}++module Control.CP.FD.GecodeExample (+  example_main_gecode,+  example_sat_main_gecode,+  example_sat_main_void_gecode,+  example_sat_main_single_gecode,+  example_sat_main_single_expr_gecode,+  example_sat_main_coll_expr_gecode,+  example_min_main_gecode,+  example_min_main_void_gecode,+  example_min_main_single_gecode,+  example_min_main_single_expr_gecode,+  example_min_main_coll_expr_gecode,+  setSearchMinimize,+  module Control.CP.FD.Example+) where++import System.Environment (getArgs)++import Control.CP.FD.Gecode.CodegenSolver+import Control.CP.FD.Gecode.Common+import Control.CP.FD.OvertonFD.OvertonFD+import Control.CP.SearchTree+import Control.CP.FD.FD++import Control.CP.FD.Example+import Control.CP.FD.Gecode.Runtime+import Control.CP.FD.Gecode.RuntimeSearch++import Control.Monad.Cont++codegenOptionset :: (CodegenGecodeOptions -> CodegenGecodeOptions) -> Tree (FDInstance (GecodeWrappedSolver CodegenGecodeSolver)) ()+codegenOptionset f = label ((liftFD $ liftGC $ Control.CP.FD.Gecode.CodegenSolver.setOptions f) >> return true)++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 ()++example_main_gecode :: ExampleModel [String] -> ExampleModel ModelInt -> ExampleModel ModelCol -> Bool -> IO ()+example_main_gecode 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)+    ("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+    ("overton_run":r) -> print $ runSolve typ $ ((f r) :: Tree (FDInstance OvertonFD) ModelCol) >>= labeller+    [] -> putStr "Solver type required: one of gecode_compile, gen_gecode_compile, gecode_run, gecode_run_cont, overton_run\n"+    (a:r) -> putStr ("Unsupported solver: " ++ a ++ "\n")++example_min_main_gecode :: ExampleMinModel [String] -> ExampleMinModel ModelInt -> ExampleMinModel ModelCol -> IO ()+example_min_main_gecode f fx fcx = example_main_gecode (postMinimize f) (postMinimize fx) (postMinimize fcx) True++example_sat_main_gecode :: ExampleModel [String] -> ExampleModel ModelInt -> ExampleModel ModelCol -> IO ()+example_sat_main_gecode f fx fcx = example_main_gecode f fx fcx False++example_sat_main_void_gecode :: ExampleModel () -> IO ()+example_sat_main_void_gecode f = example_sat_main_gecode (const $ f ()) (const $ f ()) (const $ f ())++example_min_main_void_gecode :: ExampleMinModel () -> IO ()+example_min_main_void_gecode f = example_min_main_gecode (const $ f ()) (const $ f ()) (const $ f ())++example_sat_main_single_gecode :: Read n => ExampleModel n -> IO ()+example_sat_main_single_gecode f = example_sat_main_gecode (f . read . head) (error "Uncompilable model") (error "Uncompilable model")++example_min_main_single_gecode :: Read n => ExampleMinModel n -> IO ()+example_min_main_single_gecode f = example_min_main_gecode (f . read . head) (error "Uncompilable model") (error "Uncompilable model")++example_sat_main_single_expr_gecode :: ExampleModel ModelInt -> IO ()+example_sat_main_single_expr_gecode f = example_sat_main_gecode (f . fromInteger . read . head) f (\x -> f $ x!(cte 0))++example_min_main_single_expr_gecode :: ExampleMinModel ModelInt -> IO ()+example_min_main_single_expr_gecode f = example_min_main_gecode (f . fromInteger . read . head) f (\x -> f $ x!(cte 0))++example_sat_main_coll_expr_gecode :: ExampleModel ModelCol -> IO ()+example_sat_main_coll_expr_gecode f = example_sat_main_gecode (f . list . foldr (++) [] . map (map fromInteger . read . (\x -> "[" ++ x ++ "]"))) (f. list . (\x -> [x])) f++example_min_main_coll_expr_gecode :: ExampleMinModel ModelCol -> IO ()+example_min_main_coll_expr_gecode f = example_min_main_gecode (f . list . foldr (++) [] . map (map fromInteger . read . (\x -> "[" ++ x ++ "]"))) (f. list . (\x -> [x])) f