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.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
| 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
| IntVarIdx ColVar GecodeIntConst
| IntVarCPP (CPPExpr -> CPPExpr)
| IntVarCond GecodeBoolConst IntVar IntVar
deriving (Eq,Ord,Show)
data BoolVar =
BoolVar Int Int
| BoolVarCPP (CPPExpr -> CPPExpr)
deriving (Eq,Ord,Show)
data ColVar = ColVar Int Int
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
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
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 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
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 $ CPPReturn Nothing
})
],
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);",
"}"
]
])++
[CPPComment "begin of main post"]
)++pst, cppConstrInit=[]
}),
(CPPPublic,CPPConstr { cppConstrStor=[], cppConstrArgs=[astDecl "share" $ CPPTypePrim "bool",astDecl "s" $ CPPRef [] $ astMCPType state], cppConstrInit=
(
[(Right (CPPTypePrim "Space"),[CPPVar "share",CPPVar "s"])] ++
(if nIntPars state > 0
then [(Left (CPPVar "iP"),[call (CPPVar "s") "iP"])]
else []
) ++
(if nColPars state > 0
then [(Left (CPPVar "cP" ),[call (CPPVar "s") "cP" ]),
(Left (CPPVar "cPs"),[call (CPPVar "s") "cPs"])
]
else []
)
), cppConstrBody = Just $ CPPCompound (
[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 []) ++ [
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"))
]
| (i,x) <- zip (map (ColVar (level state)) [0..(length $ colVars state)1]) $ colVars state ] ++
[CPPComment "constraints"]++[ CPPStatement x | x <- conss ] ++
(if level state == 0
then
[CPPComment "branchers" ]
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
ret = codegen tru ++ sru ++ codegen mnu
in ret