monadiccp 0.7.1 → 0.7.2
raw patch · 48 files changed
+5026/−1857 lines, 48 filesdep +parsecdep −Monatron
Dependencies added: parsec
Dependencies removed: Monatron
Files
- Control/CP/ComposableTransformers.hs +27/−8
- Control/CP/FD/FD.hs +32/−27
- Control/CP/FD/Gecode/CodegenSolver.hs +162/−98
- Control/CP/FD/Interface.hs +1/−3
- Control/CP/FD/SearchSpec/Data.hs +111/−0
- Control/CP/FD/Solvers.hs +2/−0
- Control/CP/SearchSpec/Generator.hs +0/−1364
- Control/CP/SearchSpec/Language.hs +0/−345
- Control/Monatron/AutoInstances.hs +16/−0
- Control/Monatron/AutoLift.hs +128/−0
- Control/Monatron/Codensity.hs +36/−0
- Control/Monatron/IdT.hs +13/−0
- Control/Monatron/Monad.hs +67/−0
- Control/Monatron/MonadInfo.hs +74/−0
- Control/Monatron/MonadT.hs +47/−0
- Control/Monatron/Monatron.hs +12/−0
- Control/Monatron/Open.hs +52/−0
- Control/Monatron/Operations.hs +195/−0
- Control/Monatron/Transformer.hs +286/−0
- Control/Monatron/Zipper.hs +118/−0
- Control/Monatron/ZipperExamples.hs +83/−0
- Control/Search/Combinator/And.hs +143/−0
- Control/Search/Combinator/Base.hs +320/−0
- Control/Search/Combinator/Failure.hs +40/−0
- Control/Search/Combinator/For.hs +115/−0
- Control/Search/Combinator/If.hs +151/−0
- Control/Search/Combinator/Let.hs +41/−0
- Control/Search/Combinator/Misc.hs +84/−0
- Control/Search/Combinator/Once.hs +30/−0
- Control/Search/Combinator/Or.hs +174/−0
- Control/Search/Combinator/OrRepeat.hs +95/−0
- Control/Search/Combinator/Post.hs +34/−0
- Control/Search/Combinator/Print.hs +33/−0
- Control/Search/Combinator/Repeat.hs +84/−0
- Control/Search/Combinator/Success.hs +38/−0
- Control/Search/Combinator/Until.hs +188/−0
- Control/Search/Constraints.hs +71/−0
- Control/Search/Generator.hs +855/−0
- Control/Search/GeneratorInfo.hs +120/−0
- Control/Search/Language.hs +531/−0
- Control/Search/Memo.hs +67/−0
- Control/Search/MemoReader.hs +61/−0
- Control/Search/SStateT.hs +47/−0
- Control/Search/Stat.hs +185/−0
- examples/Partition.hs +3/−0
- examples/Queens.hs +8/−4
- lib/gecodeglue.cpp +3/−1
- monadiccp.cabal +43/−7
Control/CP/ComposableTransformers.hs view
@@ -8,12 +8,12 @@ {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE ImpredicativeTypes #-} {-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE ScopedTypeVariables #-} module Control.CP.ComposableTransformers (- solve, + solve, restart, NewBound, - Bound,+ Bound(..),+ Composition(..), CTransformer, CForSolver, CForResult, @@ -24,6 +24,7 @@ CDepthBoundedST(..), CBranchBoundST(..), CFirstSolutionST(..),+ CSolutionBoundST(..), CIdentityCST(..), CRandomST(..), CLimitedDiscrepancyST(..)@@ -46,6 +47,13 @@ => q -> c -> Tree solver (CForResult c) -> (Int,[CForResult c]) solve q c model = run $ eval model q (TStack c) ++restart :: (Queue q, Solver solver, CTransformer c, CForSolver c ~ solver,+ Elem q ~ (Label solver,Tree solver (CForResult c),CTreeState c)) + => q -> [c] -> Tree solver (CForResult c) -> (Int,[CForResult c])+restart q cs model = run $ eval model q (RestartST (map Seal cs) return)++ -------------------------------------------------------------------------------- -- COMPOSABLE TRANSFORMERS --------------------------------------------------------------------------------@@ -192,7 +200,18 @@ exit False completeCT _ es = es +data CSolutionBoundST (solver :: * -> *) a = CSBST Int +instance Solver solver => CTransformer (CSolutionBoundST solver a) where+ type CEvalState (CSolutionBoundST solver a) = Int+ type CTreeState (CSolutionBoundST solver a) = ()+ type CForSolver (CSolutionBoundST solver a) = solver+ type CForResult (CSolutionBoundST solver a) = a+ initCT (CSBST n) = (n,())+ returnCT _ 1 continue exit = exit 0+ returnCT _ n continue exit = continue (n-1)+ completeCT _ es = es==0+ -------------------------------------------------------------------------------- data Composition es ts solver a where (:-) :: (CTransformer c1, CTransformer c2,@@ -231,7 +250,7 @@ newtype CBranchBoundST (solver :: * -> *) a = CBBST (NewBound solver) data BBEvalState solver = BBP Int (Bound solver) -type Bound solver = forall a. (Tree solver a -> Tree solver a)+newtype Bound solver = Bound (forall a. (Tree solver a -> Tree solver a)) type NewBound solver = solver (Bound solver) instance (Solver solver) => CTransformer (CBranchBoundST solver a) where@@ -239,13 +258,13 @@ type CTreeState (CBranchBoundST solver a) = Int type CForSolver (CBranchBoundST solver a) = solver type CForResult (CBranchBoundST solver a) = a- initCT _ = (BBP 0 id,0)- nextCT tree c es@(BBP nv bound) v eval continue exit+ initCT _ = (BBP 0 (Bound id),0)+ nextCT tree c es@(BBP nv (Bound bound)) v eval continue exit | nv > v = eval (bound tree) es nv | otherwise = eval tree es v returnCT (CBBST newBound) (BBP v bound) continue exit =- do bound' :: Bound solver <- newBound - continue (BBP (v + 1) bound')+ do bound' <- newBound+ continue $ BBP (v + 1) bound' -------------------------------------------------------------------------------- -- RESTARTING
Control/CP/FD/FD.hs view
@@ -4,8 +4,6 @@ {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE TypeSynonymInstances #-} {-# LANGUAGE UndecidableInstances #-}-{-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE Rank2Types #-} module Control.CP.FD.FD ( module Data.Expr.Sugar,@@ -174,7 +172,7 @@ -- put s { fdsMinimizeTerm = Just q } -- return $ Just q -boundMinimize :: forall s. (Show (FDIntTerm s), FDSolver s, EnumTerm s (FDIntTerm s), Integral (TermBaseType s (FDIntTerm s))) => NewBound (FDInstance s)+boundMinimize :: (Show (FDIntTerm s), FDSolver s, EnumTerm s (FDIntTerm s), Integral (TermBaseType s (FDIntTerm s))) => NewBound (FDInstance s) boundMinimize = do bound <- getMinimizeTerm case bound of@@ -184,9 +182,8 @@ case x of Just val -> do con <- liftFD $ fdConstrainIntTerm bndvar (toInteger val)- (let f :: Bound (FDInstance s)- f = \x -> (Add (Right con) x)- in (return :: Bound (FDInstance s) -> NewBound (FDInstance s)) (f :: Bound (FDInstance s)) :: NewBound (FDInstance s))+ let f = Bound (\x -> (Add (Right con) x))+ return f _ -> error "bound variable is not assigned" runFD :: FDSolver s => FDInstance s a -> s a@@ -754,27 +751,35 @@ -- colX v = FDSpecInfoCol { fdspColSpec = an $ colS v, fdspColVar = Just v, fdspColVal = getColVal_ v s, fdspColTypes = Set.fromList $ Map.keys $ colS v } return (map boolS $ boolData $ egeLinks edge, map intS $ intData $ egeLinks edge, map colS $ colData $ egeLinks edge) -fdSpecInfo_spec - :: forall s. FDSolver s - => ([Either (FDSpecInfoBool s) (FDBoolSpecType s,FDBoolSpec s)]- ,[Either (FDSpecInfoInt s) (FDIntSpecType s,FDIntSpec s)]- ,[Either (FDSpecInfoCol s) (FDColSpecType s,FDColSpec s)]) - -> FDSpecInfo s-fdSpecInfo_spec (b,i,c) =- (map fb b, map fi i, map fc c)- where- fb :: Either (FDSpecInfoBool s) (FDBoolSpecType s, FDBoolSpec s) -> FDSpecInfoBool s- fb (Left x) = x- fb (Right x) = FDSpecInfoBool { fdspBoolSpec = nt x, fdspBoolVar = Nothing, fdspBoolVal = Nothing, fdspBoolTypes = Set.singleton $ fst x }- fi :: Either (FDSpecInfoInt s) (FDIntSpecType s, FDIntSpec s) -> FDSpecInfoInt s- fi (Right x) = FDSpecInfoInt { fdspIntSpec = nt x, fdspIntVar = Nothing, fdspIntVal = Nothing, fdspIntTypes = Set.singleton $ fst x }- fi (Left x) = x- fc (Right x) = FDSpecInfoCol { fdspColSpec = nt x, fdspColVar = Nothing, fdspColVal = Nothing, fdspColTypes = Set.singleton $ fst x }- fc (Left x) = x- nt :: forall a b. Eq a => (a,b) -> Maybe a -> Maybe b- nt (_,x) Nothing = Just x- nt (t1,x) (Just t2) | t1==t2 = Just x- nt _ _ = Nothing+fdSpecInfo_spec :: FDSolver s => ([Either (FDSpecInfoBool s) (FDBoolSpecType s,FDBoolSpec s)],[Either (FDSpecInfoInt s) (FDIntSpecType s,FDIntSpec s)],[Either (FDSpecInfoCol s) (FDColSpecType s,FDColSpec s)]) -> FDSpecInfo s+fdSpecInfo_spec (b,i,c) = (fdSpecInfo_spec_b b, fdSpecInfo_spec_i i, fdSpecInfo_spec_c c)++fdSpecInfo_spec_b :: FDSolver s => [Either (FDSpecInfoBool s) (FDBoolSpecType s,FDBoolSpec s)] -> [FDSpecInfoBool s]+fdSpecInfo_spec_b b =+ let fb (Right x) = FDSpecInfoBool { fdspBoolSpec = nt x, fdspBoolVar = Nothing, fdspBoolVal = Nothing, fdspBoolTypes = Set.singleton $ fst x }+ fb (Left x) = x+ nt (_,x) Nothing = Just x+ nt (t1,x) (Just t2) | t1==t2 = Just x+ nt _ _ = Nothing+ in (map fb b)++fdSpecInfo_spec_i :: FDSolver s => [Either (FDSpecInfoInt s) (FDIntSpecType s,FDIntSpec s)] -> [FDSpecInfoInt s]+fdSpecInfo_spec_i i =+ let fi (Right x) = FDSpecInfoInt { fdspIntSpec = nt x, fdspIntVar = Nothing, fdspIntVal = Nothing, fdspIntTypes = Set.singleton $ fst x }+ fi (Left x) = x+ nt (_,x) Nothing = Just x+ nt (t1,x) (Just t2) | t1==t2 = Just x+ nt _ _ = Nothing+ in (map fi i)++fdSpecInfo_spec_c :: FDSolver s => [Either (FDSpecInfoCol s) (FDColSpecType s,FDColSpec s)] -> [FDSpecInfoCol s]+fdSpecInfo_spec_c c =+ let fc (Right x) = FDSpecInfoCol { fdspColSpec = nt x, fdspColVar = Nothing, fdspColVal = Nothing, fdspColTypes = Set.singleton $ fst x }+ fc (Left x) = x+ nt (_,x) Nothing = Just x+ nt (t1,x) (Just t2) | t1==t2 = Just x+ nt _ _ = Nothing+ in (map fc c) -- | A solver needs to be an instance of this FDSolver class in order to -- create an FDInstance around it.
Control/CP/FD/Gecode/CodegenSolver.hs view
@@ -14,6 +14,8 @@ 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@@ -31,9 +33,19 @@ -- 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.CP.SearchSpec.Generator as Generator+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 @@ -71,11 +83,13 @@ colList :: [GecodeColConst], colListEnt :: Map GecodeColConst Int, cons :: [GecodeConstraint CodegenGecodeSolver],- ret :: Maybe ColVar,+ intRet :: Set IntVar,+ boolRet :: Set BoolVar,+ colRet :: Set ColVar, level :: Int, parent :: Maybe CodegenGecodeState, options :: CodegenGecodeOptions,- minVar :: Maybe IntVar+ searchSpec :: Maybe (SearchSpec IntVar ColVar BoolVar) } deriving (Show) @@ -102,11 +116,13 @@ colList = [], colListEnt = Map.empty, cons = [],- ret = Nothing,+ intRet = Set.empty,+ boolRet = Set.empty,+ colRet = Set.empty, level = 0, parent = Nothing, options = initOptions,- minVar = Nothing+ searchSpec = Nothing } newIntParam :: CodegenGecodeSolver Int@@ -251,17 +267,59 @@ 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- [GCTVar col] <- getColTerm [res] GCSVar+ 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 { ret = Just col }- min <- getMinimizeTerm+ 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 { minVar = min }+ put s { searchSpec = Just y } instance CompilableModel m => CompilableModel (ModelInt -> m) where specific_compile x = do@@ -424,6 +482,9 @@ 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@@ -448,15 +509,29 @@ 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 state ctx (ColVar 0 r) | (ret state == Just (ColVar 0 r)) = call ctx "ret"++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) @@ -711,14 +786,9 @@ ] else [] ) ++- (case ret state of- Nothing -> []- Just c -> [(CPPProtected,astDecl "ret" (CPPTypePrim "IntVarArray"))]- ) ++- (case minVar state of- Nothing -> []- Just v -> [(CPPProtected,astDecl "cost" (CPPTypePrim "IntVar"))]- ),+ ( 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",@@ -734,34 +804,14 @@ cppDefStor=[CPPVirtual], cppDefArgs=[astDecl "os" $ CPPRef [] $ CPPTypePrim "ostream"], cppDefQual=[CPPQualConst],- cppDefBody = Just $ CPPSimple $ case ret state of- Just r -> CPPBinary (CPPBinary (CPPVar "os") CPPOpShl (call astThis "ret")) CPPOpShl (CPPVar "endl")- _ -> CPPBinary (CPPBinary (CPPVar "os") CPPOpShl (CPPConst $ CPPConstString "Ok")) CPPOpShl (CPPVar "endl")- }),- (CPPPublic,CPPDef {- cppDefName="getVar",- cppDefRetType=CPPTypePrim "IntVar",- cppDefStor=[CPPVirtual],- cppDefArgs=[astDecl "v" $ CPPTypePrim "int"],- cppDefQual=[],- cppDefBody = Just $ case (ret state, minVar state) of- (Just r, Just _) -> CPPReturn $ Just $ CPPCond (CPPBinary (CPPVar "v") CPPOpEq (CPPConst $ CPPConstInt $ -1)) (Just $ CPPVar "cost") $ CPPIndex (astColVar state astThis r) $ CPPVar "v"- (Just r, Nothing) -> CPPReturn $ Just $ CPPIndex (astColVar state astThis r) $ CPPVar "v"- }),- (CPPPublic,CPPDef {- cppDefName="getBranchVarIds",- cppDefRetType=CPPTypePrim "vector<int>",- cppDefStor=[CPPVirtual],- cppDefArgs=[],- cppDefQual=[],- cppDefBody = case ret state of- Just r -> Just $ CPPCompound [- CPPBlockDecl $ astDeclFn "r" (CPPTypePrim "vector<int>") [astColSize r state astThis],- CPPStatement $ CPPFor (Right $ astDeclEq "i" astTInt $ astInt 0) (Just $ CPPBinary (CPPVar "i") CPPOpLe $ astColSize r state astThis) (Just $ CPPUnary CPPOpPostInc $ CPPVar "i") $- CPPSimple $ CPPAssign (CPPIndex (CPPVar "r") (CPPVar "i")) CPPAssOp $ CPPVar "i",- CPPStatement $ CPPReturn $ Just $ CPPVar "r"- ]- })]++(+-- 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 -> @@ -777,8 +827,7 @@ 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= (@@ -808,16 +857,21 @@ "}" ] ])++- (case ret state of+{- (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=[]+ )++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= (@@ -832,17 +886,11 @@ ] else [] )- ), cppConstrBody = Just $ CPPCompound $ - (case (ret state) of- Nothing -> []- Just r -> [CPPStatement $ CPPSimple $ CPPCall (call (call astThis "ret") "update") [astThis,CPPVar "share",call (CPPVar "s") "ret"]]--- (if (nBoolVars state > 0) then [CPPStatement $ CPPSimple $ CPPCall (call (CPPVar $ boolVarName $ BoolVar (level state) ii) "update") [astThis,CPPVar "share",CPPVar $ boolVarName $ BoolVar astBoolVar state (CPPVar "s") ii] | ii <- [0..(nBoolVars state)-1] ] else []) ++--- (if (nIntVars state > 0) then [CPPStatement $ CPPSimple $ CPPCall (call (CPPVar $ intVarName $ IntVar (level state) ii) "update") [astThis,CPPVar "share",CPPVar $ astIntVar state (CPPVar "s") ii] | ii <- [0..(nIntVars state)-1] ] else []) ++--- (if (length (colVars state) > 0) then [CPPStatement $ CPPSimple $ CPPCall (call (CPPVar $ colVarName $ ColVar (level state) ii) "update") [astThis,CPPVar "share",CPPVar $ astColVar state (CPPVar "s") ii] | ii <- [0..(length $ colVars state)-1] ] else [])- ) ++ (case (minVar state) of- Nothing -> []- Just _ -> [CPPStatement $ CPPSimple $ CPPCall (call (call astThis "cost") "update") [astThis,CPPVar "share",call (CPPVar "s") "cost"]]- )+ ), 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]+ ) }) ] }@@ -892,9 +940,9 @@ ] ++ (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"],+-- CPPBlockDecl $ astDeclFn "srch" (CPPTempl (case minVar state of { Nothing -> "DFS"; _ -> "BAB" }) [astMCPType state]) [CPPVar "prog",CPPVar "so"], CPPStatement $ CPPDelete $ CPPVar "prog",- CPPStatement $ CPPWhile (astInt (case minVar state of { Nothing -> 0; _ -> 1 })) True $ CPPCompound [+ 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"]@@ -964,22 +1012,23 @@ x -> error $ "Unsupported operation on constant lists: " ++ (show x) | pos <- [0..(length (colList state))-1] ]) ++- (if (nBoolVars state > 0) - then + ( [CPPComment "decl boolvars"]++[- CPPBlockDecl $ astDeclFn (boolVarName $ BoolVar (level state) j) astTBV [astThis,astInt 0,astInt 1] | j <- [0..nBoolVars state - 1] - ] else []) ++- (if (nIntVars state > 0)- then+ 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"]++[- CPPBlockDecl $ astDeclFn (intVarName $ IntVar (level state) j) astTIV [astThis,astLowerBound,astUpperBound] | j <- [0..nIntVars state - 1]- ] else []+ 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]+ ] ) ++- (if (length (colVars state) > 0) - then + ( [CPPComment "decl colvars"]++[- CPPBlockDecl $ astDeclFn (colVarName $ ColVar (level state) j) astTIVA [astColSize (ColVar (level state) j) state astThis] | j <- [0..(length $ colVars state)-1], not (level state == 0 && isJust (ret state) && ret state == Just (ColVar 0 j)) - ] else []+ 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@@ -988,31 +1037,19 @@ ] ColDefList l -> CPPCompound $ (CPPComment "ColDefList") :- (CPPBlockDecl $ astDeclFn "b" astTIVA [astInt $ toInteger $ length l]) :- ([ CPPStatement $ CPPSimple $ CPPAssign (CPPIndex (CPPVar "b") (astInt $ toInteger i2)) CPPAssOp $ (astIntVar state astThis f2) | (i2,f2) <- zip [0..(length l)-1] l ] ++- [ CPPStatement $ CPPSimple $ CPPAssign (astColVar state astThis i) CPPAssOp (CPPVar "b") ])- ColDefCat a b -> if (astColVar state astThis i) == (call astThis "ret")- then- CPPCompound $ [- CPPComment "ColDefCat-ret",+ [ CPPStatement $ 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")) ]- else- CPPCompound $ [- CPPComment "ColDefCat",- CPPBlockDecl $ astDeclFn "b" astTIVA [astColSize a state astThis + astColSize b state astThis],- CPPStatement $ CPPFor (Right $ astDeclEq "i" astTInt $ astInt 0) (Just $ CPPBinary (CPPVar "i") CPPOpLe $ astColSize a state astThis) (Just $ CPPUnary CPPOpPostInc (CPPVar "i")) $ CPPSimple $ CPPAssign (CPPIndex (CPPVar "b") (CPPVar "i")) CPPAssOp (CPPIndex (astColVar state astThis a) (CPPVar "i")),- CPPStatement $ CPPFor (Right $ astDeclEq "i" astTInt $ astInt 0) (Just $ CPPBinary (CPPVar "i") CPPOpLe $ astColSize b state astThis) (Just $ CPPUnary CPPOpPostInc (CPPVar "i")) $ CPPSimple $ CPPAssign (CPPIndex (CPPVar "b") (CPPVar "i" + astColSize a state astThis)) CPPAssOp (CPPIndex (astColVar state astThis b) (CPPVar "i")),- CPPStatement $ CPPSimple $ CPPAssign (astColVar state astThis i) CPPAssOp (CPPVar "b")- ] {- ColDefTake a p l -> CPPCompound $ [ CPPBlockDecl $ astDeclFn "b" astTIVA [astThis,astIntExpr state astThis l], CPPStatement $ CPPFor (Right $ astDeclEq "i" astTInt $ astInt 0) (Just $ CPPBinary (CPPVar "i") CPPOpLe $ astColSize a state astThis) (Just $ CPPUnary CPPOpPostInc (CPPVar "i")) $ CPPSimple $ CPPAssign (CPPIndex (CPPVar "b") (CPPVar "i")) CPPAssOp (CPPIndex (astColVar state astThis a) (CPPVar "i" + (astIntExpr state astThis p))), CPPStatement $ CPPSimple $ CPPAssign (astColVar state astThis i) CPPAssOp (CPPVar "b") ]-} | (i,x) <- zip (map (ColVar (level state)) [0..(length $ colVars state)-1]) $ colVars state ] ++- (case (ret state) of+{- (case (ret state) of Nothing -> [] Just (ColVar 0 _) | level state == 0 -> [] Just r -> @@ -1020,30 +1057,57 @@ 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+ [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 []+ )++ -}+-- ([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/Interface.hs view
@@ -36,7 +36,7 @@ Control.CP.FD.Interface.loopany, allin, asExpr, asCol, Control.CP.FD.Interface.asBool,- colList, labelCol,+ colList, labelCol, ModelInt, ModelCol, ModelBool, exists, true, false, -- Modelable,@@ -54,8 +54,6 @@ import Control.CP.EnumTerm newtype DummySolver a = DummySolver ()--type MModel s = Either Model (Constraint s) instance Monad DummySolver where return _ = DummySolver ()
+ Control/CP/FD/SearchSpec/Data.hs view
@@ -0,0 +1,111 @@+{-# LANGUAGE StandaloneDeriving #-}++module Control.CP.FD.SearchSpec.Data (+ OptimDirection(..),+ VarExpr(..),+ VarStat(..),+ Labelling(..),+ SearchSpec(..),+ ConstraintExpr,+ ConstraintRefs(..),+ mmapSearch+) where++import Control.CP.Solver+import Control.CP.FD.FD+import Data.Expr.Data+import Control.Search.Generator+import Control.Search.Language++-- Wouter Swierstra - Data Types a la Carte+-- Jacques Carette, Oleg - Finally Tagless++data VarStat =+ DLowerBound+ | DUpperBound+ | DDomSize+ | DLowerRegret+ | DUpperRegret+ | DDegree+ | DWDregree+ | DRandom+ | DMedian+ | DDummy Int+ deriving (Eq,Ord,Show)++data OptimDirection = + Maximize+ | Minimize+ deriving (Eq,Ord,Show)++type VarExpr = Expr VarStat () ()++data ConstraintRefs =+ VarRef+ | ValRef+ deriving (Eq,Ord,Show)++type ConstraintExpr = Expr ConstraintRefs () ()+type ConstraintBoolExpr = BoolExpr ConstraintRefs () ()++data Labelling v a b =+ LabelInt v VarExpr (ConstraintExpr -> ConstraintExpr-> ConstraintBoolExpr)+ | LabelCol a VarExpr OptimDirection VarExpr (ConstraintExpr -> ConstraintExpr -> ConstraintBoolExpr)+ | LabelBool b VarExpr++data SearchSpec v a b =+ Labelling (Labelling v a b)+ | CombineSeq (SearchSpec v a b) (SearchSpec v a b)+ | CombinePar (SearchSpec v a b) (SearchSpec v a b)+ | TryOnce (SearchSpec v a b)+ | LimitSolCount Integer (SearchSpec v a b)+ | LimitDepth Integer (SearchSpec v a b)+ | LimitNodeCount Integer (SearchSpec v a b)+ | LimitDiscrepancy Integer (SearchSpec v a b)+ | BranchBound v OptimDirection (SearchSpec v a b)+ | PrintSol [v] [a] [b] (SearchSpec v a b)++deriving instance (Show v, Show a, Show b) => Show (SearchSpec v a b)++instance (Show v, Show a, Show b) => Show (Labelling v a b) where+ show (LabelInt v x f) = "LabelInt " ++ (show v) ++ " " ++ (show x) ++ " " ++ (show $ f (Term VarRef) (Term ValRef))+ show (LabelCol v x d s f) = "LabelCol " ++ (show v) ++ " " ++ (show x) ++ " " ++ show d ++ " " ++ show s ++ " " ++ (show $ f (Term VarRef) (Term ValRef))+ show (LabelBool v x) = "LabelBool " ++ (show v) ++ " " ++ (show x)++mmapSearch :: (Monad m) => SearchSpec v1 a1 b1 -> (v1 -> m v2) -> (a1 -> m a2) -> (b1 -> m b2) -> m (SearchSpec v2 a2 b2)+mmapSearch (Labelling (LabelInt v x f)) vf af bf = vf v >>= \y -> return $ Labelling $ LabelInt y x f+mmapSearch (Labelling (LabelCol a x d s f)) vf af bf = af a >>= \y -> return $ Labelling $ LabelCol y x d s f+mmapSearch (Labelling (LabelBool v x)) vf af bf = bf v >>= \y -> return $ Labelling $ LabelBool y x+mmapSearch (CombineSeq a b) vf af bf = do+ ad <- mmapSearch a vf af bf+ bd <- mmapSearch b vf af bf+ return (CombineSeq ad bd)+mmapSearch (CombinePar a b) vf af bf = do+ ad <- mmapSearch a vf af bf+ bd <- mmapSearch b vf af bf+ return (CombinePar ad bd)+mmapSearch (TryOnce a) vf af bf = do+ ad <- mmapSearch a vf af bf+ return (TryOnce ad)+mmapSearch (LimitSolCount n a) vf af bf = do+ ad <- mmapSearch a vf af bf+ return (LimitSolCount n ad)+mmapSearch (LimitDepth n a) vf af bf = do+ ad <- mmapSearch a vf af bf+ return $ (LimitDepth n ad)+mmapSearch (LimitNodeCount n a) vf af bf = do+ ad <- mmapSearch a vf af bf+ return $ (LimitNodeCount n ad)+mmapSearch (LimitDiscrepancy n a) vf af bf = do+ ad <- mmapSearch a vf af bf+ return $ (LimitDiscrepancy n ad)+mmapSearch (BranchBound v d a) vf af bf = do+ vd <- vf v+ ad <- mmapSearch a vf af bf+ return (BranchBound vd d ad)+mmapSearch (PrintSol i c b a) iF cF bF = do+ vi <- mapM iF i+ vc <- mapM cF c+ vb <- mapM bF b+ ad <- mmapSearch a iF cF bF+ return (PrintSol vi vc vb ad)
Control/CP/FD/Solvers.hs view
@@ -52,6 +52,8 @@ db = CDBST bb :: NewBound s -> CBranchBoundST s a bb = CBBST+sb :: Int -> CSolutionBoundST s a+sb = CSBST fs :: CFirstSolutionST s a fs = CFSST it :: CIdentityCST s a
− Control/CP/SearchSpec/Generator.hs
@@ -1,1364 +0,0 @@-{-# LANGUAGE Rank2Types #-}-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE TypeOperators #-}-{-# LANGUAGE ImpredicativeTypes #-}-{-# LANGUAGE ExistentialQuantification #-}-{-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE PatternGuards #-}--module Control.CP.SearchSpec.Generator- ( (<@>) , (<|>) , (<&>)- , def- , nb- , dbs- , lds- , fs- , once- , bbmin- , prt- , search- , label- , vlabel- , glabel- , foldVarSel- , ifoldVarSel- , until- , failure- , repeat- , for, foreach- , properLDS- , limit- , lbV- , ubV- , domsizeV - , lbRegretV - , ubRegretV - , degreeV - , wDegreeV- , domSizeWDegreeV- , domSizeDegreeV- , randomV - , maxV- , minV- , minD- , maxD - , meanD - , medianD - , randomD - , ($==)- , ($/=)- , ($<) - , ($<=)- , ($>) - , ($>=)- , (@>)- , appStat- , depthStat- , nodesStat- , discrepancyStat- , solutionsStat- , failsStat- , (#>)- ) where--import Prelude hiding (lex, until, init, repeat)-import Control.CP.SearchSpec.Language-import Text.PrettyPrint hiding (space)-import List (sort, nub)-import Data.Int--{- TODO:- - completeness- - restart optimization- - time limit- - reinstate advanced variable selection- -}--import Control.Monatron.Monatron hiding (Abort, L, state)-import Control.Monatron.Zipper hiding (i,r)-import Control.Monatron.IdT--type TreeState = Value-type EvalState = Value--data Eval m = Eval - { structs :: ([Struct],[Struct]) -- auxiliary type declarations- , treeState_ :: [(String,Type, Info -> Statement)] -- tree state fields (name, type, init)- , evalState :: [(String,Type,Value)]- , pushLeft :: Info -> m Statement- , pushRight :: Info -> m Statement- , bodyE :: Info -> m Statement- , addE :: Info -> m Statement- , returnE :: Info -> m Statement- , failE :: Info -> m Statement- , continue :: EvalState -> m Value- , tryE :: Info -> m Statement- , tryE_ :: Info -> m Statement- , intArraysE :: [String]- , intVarsE :: [String]- }--entry name ty up = (name, ty, \i -> up (tstate i @-> name))--treeState e = entry "space" (Pointer SpaceType) (assign RootSpace) : treeState_ e -space i = baseTstate i @-> "space"--mkCopy i f = (tstate i @-> f) <== (tstate (old i) @-> f)-mkUpdate i f g = (tstate i @-> f) <== g (tstate (old i) @-> f)---pushLeftTop e = \i -> pushLeft e (i `onCommit` mkCopy i "space" )-pushRightTop e = \i -> pushRight e (i `onCommit` mkUpdate i "space" Clone)--mapE :: (forall x. m x -> n x) -> Eval m -> Eval n-mapE f e =- Eval { structs = structs e- , treeState_ = treeState_ e- , evalState = evalState e- , pushLeft = f . pushLeft e- , pushRight = f . pushRight e- , bodyE = f . bodyE e- , addE = f . addE e- , returnE = f . returnE e- , failE = f . failE e- , continue = f . continue e- , tryE = f . tryE e- , tryE_ = f . tryE_ e- , intArraysE = intArraysE e- , intVarsE = intVarsE e- } --data Info = Info { baseTstate :: TreeState- , path :: TreeState -> TreeState- , abort :: Statement- , commit :: Statement- , old :: Info- , clone :: Info -> Statement- , field :: String -> Value- }--type Field = String--tstate i = path i (baseTstate i)-estate i = tstate i @-> "evalState"--withCommit i f = i { commit = f (commit i) }-onAbort i stmt = i { abort = stmt >>> abort i }-onCommit i stmt = i `withCommit` (stmt >>>)-withPath i p = i { path = p . path i- , old = old i `withPath` p- }-withBase i str = i { baseTstate = Var str }--withClone i stmt = i { clone = \j -> clone i j >>> stmt (i { baseTstate = baseTstate j }) }-withField i (f,g) = i { field = \f' -> if f' == f then g i else field i f' }--resetPath i = i { path = id- , old = resetPath $ old i }-resetCommit i = i { commit = Delete $ space i }-resetClone i = i { clone = \j -> space j <== Clone (space i) }--mkInfo name =- let i = Info { baseTstate = Var name- , path = id- , abort = Delete $ space i- , commit = Delete $ space i- , old = i- , clone = \j -> space j <== Clone (space i)- , field = \f -> error ("unknown field `" ++ f ++ "'")- }- in i--info = mkInfo "estate"--newinfo i = - Info { baseTstate = Var "nstate"- , path = id- , abort = Skip- , commit = Skip- , old = resetPath i- , clone = \j -> space j <== Clone (space i)- , field = \f -> error ("unknown field `" ++ f ++ "'")- }------------------------------------------------------------------------------------- LABELING----------------------------------------------------------------------------------data Label m = Label - { treeStateL :: [(String,Type, Value -> Statement)]- , leftChild_L :: [Info -> Statement]- , rightChild_L :: [Info -> Statement]- , addL :: Info -> m Statement- , tryL :: Info -> m Statement- , intArraysL :: [String]- , intVarsL :: [String]- }--v1Label var1 selVal rel e = - Label { treeStateL = [("val", Int, assign 0)- ,("eq", Bool, assign true)]- , leftChild_L = - [ \i -> mkUpdate i "eq" (const true)- , \i -> mkCopy i "val" ]- , rightChild_L =- [ \i -> mkUpdate i "eq" (const false)- , \i -> mkCopy i "val" ]- , addL = \i -> return $- IfThenElse (eq i)- (Post (space i) (var i `rel` val i))- (Post (space i) (neg (var i `rel` val i)))- , tryL = \i -> returnE e (resetPath i) >>= \ret ->- tryE_ e (resetPath i) >>= \try ->- return $ (IfThenElse (Assigned (var i))- ret- (val i <== (selVal $ var i) >>> try))- , intArraysL = []- , intVarsL = [var1]- }- where val i = tstate i @-> "val"- eq i = tstate i @-> "eq"- var i = VHook (rp 0 (space i) ++ "->iv[$VAR_" ++ var1 ++ "]") --vLabel vars selVar selVal rel e = - Label { treeStateL = [("pos", Int, assign 0)- ,("val", Int, assign 0)- ,("eq", Bool, assign true)]- , leftChild_L = - [ \i -> mkUpdate i "eq" (const true)- , \i -> mkCopy i "val"- , \i -> mkCopy i "pos"]- , rightChild_L =- [ \i -> mkUpdate i "eq" (const false)- , \i -> mkCopy i "val"- , \i -> mkCopy i "pos"]- , addL = \i -> return $- IfThenElse (eq i)- (Post (space i) (var i `rel` val i))- (Post (space i) (neg (var i `rel` val i)))- , tryL = \i -> returnE e (resetPath i) >>= \ret ->- tryE_ e (resetPath i) >>= \try ->- return $ (selVar i vars- ret- (val i <== (selVal $ var i) >>> try))- , intArraysL = [vars]- , intVarsL = []- }- where val i = tstate i @-> "val"- pos i = tstate i @-> "pos"- eq i = tstate i @-> "eq"- var i = CVar vars (space i) (pos i)--type ValSel = Value -> Value--type VarSel = Info -> String -> Statement -> Statement -> Statement--foldVarSel metric (better, zero) i vars notfound found =- Fold vars (tstate i) (space i) zero metric better- >>> IfThenElse (pos i @< 0) notfound found- where pos i = tstate i @-> "pos"--ifoldVarSel metric (better, zero) i vars notfound found =- IFold vars (tstate i) (space i) zero metric better- >>> IfThenElse (pos i @< 0) notfound found- where pos i = tstate i @-> "pos"--{--lexLabel info selVal rel e = - Label { treeStateL = [("pos", Int, 0)- ,("val", Int, 0)- ,("eq", Bool, undefined)]- , leftChild_L = [("eq", const $ true)- ,("val", \env -> env "val")- ,("pos",\env -> env "pos")]- , rightChild_L = [("eq", const $ false)- ,("val", \env -> env "val")- ,("pos",\env -> env "pos")]- , addL = \state -> let space = Field state "space"- var = CVar space (Field state "pos")- val = Field state "val"- in IfThenElse (Field state "eq")- (Post space (var `rel` val))- (Post space (neg (var `rel` val)))- , tryL = \state -> let val = Field state "val"- space = Field state "space"- var = CVar space (Field state "pos")- cmps = [cmp | (_,(cmp,_)) <- info ]- mtxs = [ (z,f) | (f,(_,z)) <- info ]- in MFold "estate" mtxs (lex cmps) - >>> IfThenElse (Field state "pos" @< 0)- (returnE e state)- (Update val (selVal var) >>> tryE_ e state) - }--}--maxV = (Gt,IVal minBound)-minV = (Lt,IVal maxBound)--lbV = MinDom-ubV = MaxDom -domsizeV = SizeDom-lbRegretV = LbRegret-ubRegretV = UbRegret-degreeV = Degree-domSizeDegreeV = \v -> domsizeV v `Div` degreeV v-wDegreeV = WDegree-domSizeWDegreeV= \v -> domsizeV v `Div` wDegreeV v-randomV = const Random--minD = MinDom-maxD = MaxDom-meanD = \v -> (maxD v + minD v) `Div` 2-medianD = \v -> Median v-randomD = \v -> (Random `Mod` (domsizeV v)) + minD v------------------------------------------------------------------------------------- SEARCH TRANSFORMERS-----------------------------------------------------------------------------------baseLoop label this = return $- Eval { structs = ([],[])- , treeState_ = map (\(x,y,z) -> entry x y z) $ treeStateL label - , evalState = []- , pushLeft = \i -> return $ commit i >>> seqs [f i | f <- leftChild_L label] >>> Push new_tstate- , pushRight = \i -> return $ commit i >>> seqs [f i | f <- rightChild_L label] >>> Push new_tstate- , bodyE = addE this . resetPath- , addE = \i -> tryE this (resetPath i) >>= \try ->- addL label i >>= \a -> - failE this (resetPath i) >>= \fail ->- return $- (a - >>> (Var "status" <== VHook (rp 0 (space i) ++ "->status()"))- >>> IfThenElse (Var "status" @== VHook "SS_FAILED")- ( fail- >>> Delete (space i))- try) - , failE = const $ return Skip- , returnE = \i -> return $ commit i- , continue = \_ -> return true- , tryE = tryL label- , tryE_ = \i -> - pushRightTop this (newinfo i) >>= \p2 -> - pushLeftTop this (newinfo i) >>= \p4 ->- return (SHook "TreeState nstate;"- >>> p2- >>> p4)- , intArraysE = intArraysL label- , intVarsE = intVarsL label- }- where new_tstate = Var "nstate"-----------------------------------------------------------------------------------dummyLoop super = Eval { structs = structs super- , treeState_ = treeState_ super- , evalState = evalState super- , pushLeft = pushLeft super- , pushRight = pushRight super- , bodyE = bodyE super- , addE = addE super- , failE = failE super- , returnE = returnE super- , continue = continue super- , tryE = tryE super- , tryE_ = tryE_ super- , intArraysE = intArraysE super- , intVarsE = intVarsE super- }--failLoop super = Eval { structs = ([],[])- , treeState_ = []- , evalState = []- , pushLeft = \_ -> return Skip- , pushRight = \_ -> return Skip- , bodyE = \i -> return $ abort i- , addE = \_ -> return Skip- , failE = \_ -> return Skip- , returnE = \_ -> return Skip- , continue = \_ -> return true- , tryE = \i -> return $ abort i- , tryE_ = \_ -> return Skip- , intArraysE = []- , intVarsE = []- }-----------------------------------------------------------------------------------data SeqPos = OutS | FirstS | SecondS--seqSwitch l r = - do flag <- ask- case flag of - FirstS -> l- SecondS -> r-(l1,l2) @++@ (l3,l4) = (l1 ++ l3, l2 ++ l4)--seqLoop :: ReaderM SeqPos m => Int -> Eval m -> Eval m -> Eval m-seqLoop uid lsuper rsuper =- Eval { structs = structs lsuper @++@ structs rsuper @++@ mystructs - , treeState_ = [entry "is_fst" Bool (assign true)- , ("seq_union",Union [(SType s3,"fst"),(SType s4,"snd")], - \i -> - let j = i `withPath` in1- in seqs [init j | (_,init) <- fs3]- >>> initSubEvalState j s1 fs1- )]- , evalState = []- , pushLeft = push pushLeft- , pushRight = push pushRight- , bodyE = \i ->- let f z j = do stmt <- bodyE z (j `onAbort` dec_ref j)- cond <- continue z (estate j)- return $ IfThenElse (cont j)- (IfThenElse cond- stmt- ( (cont j <== false)- >>> dec_ref j- >>> abort j)- )- ( dec_ref j- >>> abort j)- in do s1 <- local (const FirstS) $ inSeq f i- s2 <- local (const SecondS) $ inSeq f i- return $ IfThenElse (is_fst i) s1 s2- , addE = inSeq $ addE- , failE = inSeq $ \super j -> failE super j @>>>@ return (dec_ref j)- , returnE = \i -> let j1 = i `withPath` in1- j2 = i `withPath` in2 `onCommit` dec_ref j2- j2b = resetCommit j2- in seqSwitch (do action <- local (const SecondS) $- do stmt1 <- initTreeState_ j2b rsuper - stmt2 <- tryE rsuper j2b- return (dec_ref j1- >>> (is_fst i <== false) - >>> initSubEvalState j2b s2 fs2- >>> stmt1 >>> stmt2)- returnE lsuper $ j1 `withCommit` const action- )- (returnE rsuper j2)- , continue = \_ -> return true- , tryE = inSeq $ tryE- , tryE_ = inSeq $ \super j -> tryE_ super j @>>>@ return (dec_ref j)- , intArraysE = intArraysE lsuper ++ intArraysE rsuper- , intVarsE = intVarsE lsuper ++ intVarsE rsuper- }- where mystructs = ([s1,s2],[s3,s4])- s1 = Struct ("LeftEvalState" ++ show uid) $ (Bool, "cont") : (Int, "ref_count") : [(ty, field) | (field,ty,_) <- evalState lsuper]- s2 = Struct ("RightEvalState" ++ show uid) $ (Bool, "cont") : (Int, "ref_count") : [(ty, field) | (field,ty,_) <- evalState rsuper]- s3 = Struct ("LeftTreeState" ++ show uid) $ (Pointer $ SType s1, "evalState") : [(ty, field) | (field,ty,_) <- treeState_ lsuper]- s4 = Struct ("RightTreeState" ++ show uid) $ (Pointer $ SType s2, "evalState") : [(ty, field) | (field,ty,_) <- treeState_ rsuper]- fs1 = [(field,init) | (field,_ty,init) <- evalState lsuper ]- fs2 = [(field,init) | (field,_ty,init) <- evalState rsuper ]- fs3 = [(field,init) | (field,_ty,init) <- treeState_ lsuper] - is_fst = \i -> tstate i @-> "is_fst"- cont = \i -> estate i @=> "cont"- ref_count = \i -> estate i @=> "ref_count"- withSeq f = seqSwitch (f lsuper in1) (f rsuper in2)- inSeq f = \i -> withSeq $ \super ins -> f super (i `withPath` ins)- dec_ref = \j -> dec (ref_count j) >>> ifthen (ref_count j @== 0) (Delete (estate j))- push dir = \i -> inSeq ( \super j -> dir super (j `onCommit` ( mkCopy i "is_fst"- >>> mkCopy j "evalState"- >>> inc (ref_count j)- ))) i- initSubEvalState = \j s fs -> (estate j <== New s) - >>> (ref_count j <== 1)- >>> (cont j <== true)- >>> seqs [estate j @=> f <== init | (f,init) <- fs] --in1 = \state -> state @-> "seq_union" @-> "fst"-in2 = \state -> state @-> "seq_union" @-> "snd"-----------------------------------------------------------------------------------cloneBase i = resetClone $ info { baseTstate = estate i @=> "parent" }--orLoop :: ReaderM SeqPos m => Int -> Eval m -> Eval m -> Eval m-orLoop uid lsuper rsuper =- Eval { structs = structs lsuper @++@ structs rsuper @++@ mystructs - , treeState_ = [entry "is_fst" Bool (assign true)- , ("seq_union",Union [(SType s3,"fst"),(SType s4,"snd")], - \i -> - let j = i `withPath` in1- in (estate j <== New s1)- >>> (ref_count j <== 1)- >>> (cont j <== true)- >>> (parent j <== baseTstate j)- >>> clone i (cloneBase j)- >>> seqs [init (j `withClone` (\k -> inc $ ref_count k)) | (f,init) <- fs3]- >>> seqs [estate j @=> f <== init | (f,init) <- fs1 ]- )]- , evalState = []- , pushLeft = push pushLeft- , pushRight = push pushRight- , bodyE = \i ->- let f y z = - let j = i `withPath` y- in do cond <- continue z (estate j)- deref <- dec_ref i- stmt <- bodyE z (j `onAbort` deref)- return $ IfThenElse (cont j)- (IfThenElse cond- stmt- ( (cont j <== false)- >>> deref- >>> abort j))- (deref >>> abort j)- in IfThenElse (is_fst i) @$ local (const FirstS) (f in1 lsuper) - @. local (const SecondS) (f in2 rsuper)- , addE = inSeq $ addE- , failE = \i -> inSeq failE i @>>>@ dec_ref i- , returnE = \i -> - let j1 deref = i `withPath` in1 `onCommit` deref- j2 deref = i `withPath` in2 `onCommit` deref- in seqSwitch (dec_ref1 i >>= returnE lsuper . j1)- (dec_ref2 (j2 Skip) >>= returnE rsuper . j2) - , continue = \_ -> return true- , tryE = inSeq $ tryE - , tryE_ = \i -> inSeq tryE_ i @>>>@ dec_ref i- , intArraysE = intArraysE lsuper ++ intArraysE rsuper- , intVarsE = intVarsE lsuper ++ intVarsE rsuper- }- where mystructs = ([s1,s2],[s3,s4])- s1 = Struct ("LeftEvalState" ++ show uid) $ (THook "TreeState", "parent") : (Bool, "cont") : (Int, "ref_count") : [(ty, field) | (field,ty,_) <- evalState lsuper]- fs1 = [(field,init) | (field,ty,init) <- evalState lsuper ]- s2 = Struct ("RightEvalState" ++ show uid) $ (Bool, "cont") : (Int, "ref_count") : [(ty, field) | (field,ty,_) <- evalState rsuper]- fs2 = [(field,init) | (field,ty,init) <- evalState rsuper ]- s3 = Struct ("LeftTreeState" ++ show uid) $ (Pointer $ SType s1, "evalState") : [(ty, field) | (field,ty,_) <- treeState_ lsuper]- fs3 = [(field,init) | (field,ty,init) <- treeState_ lsuper]- s4 = Struct ("RightTreeState" ++ show uid) $ (Pointer $ SType s2, "evalState") : [(ty, field) | (field,ty,_) <- treeState_ rsuper]- in1 = \state -> state @-> "seq_union" @-> "fst"- in2 = \state -> state @-> "seq_union" @-> "snd"- is_fst = \i -> tstate i @-> "is_fst"- cont = \i -> estate i @=> "cont"- ref_count = \i -> estate i @=> "ref_count"- parent = \i -> estate i @=> "parent"- withSeq f = seqSwitch (f lsuper in1) (f rsuper in2)- inSeq f = \i -> withSeq $ \super ins -> f super (i `withPath` ins)- dec_ref = \i -> seqSwitch (dec_ref1 i) (dec_ref2 $ i `withPath` in2)- dec_ref1 = \i -> let j1 = i `withPath` in1- i' = resetClone $ resetCommit $ i `withBase` ("or_tstate" ++ show uid)- j2 = i' `withPath` in2- in (local (const SecondS) $- do stmt1 <- initTreeState_ j2 rsuper - stmt2 <- tryE rsuper j2- return (dec (ref_count j1) - >>> ifthen (ref_count j1 @== 0) - ( SHook ("TreeState or_tstate" ++ show uid ++ ";")- >>> (baseTstate j2 <== parent j1)- >>> (is_fst i' <== false)- >>> Delete (estate j1)- >>> (estate j2 <== New s2) - >>> (ref_count j2 <== 1)- >>> (cont j2 <== true)- >>> seqs [estate j2 @=> f <== init | (f,init) <- fs2 ] - >>> stmt1 >>> stmt2)))- dec_ref2 = \j -> return $ dec (ref_count j) >>> ifthen (ref_count j @== 0) (Delete (estate j))- push dir = \i -> seqSwitch (push1 dir i) (push2 dir i)- push1 dir = \i -> - let j = i `withPath` in1 - in dir lsuper (j `onCommit` ( mkCopy i "is_fst"- >>> mkCopy j "evalState"- >>> inc (ref_count j)- ))- push2 dir = \i -> - let j = i `withPath` in2 - in dir rsuper (j `onCommit` ( mkCopy i "is_fst"- >>> mkCopy j "evalState"- >>> inc (ref_count j)- ))--(@>>>@) x y = do s1 <- x- s2 <- y- return (s1 >>> s2)--f @$ x = x >>= return . f-mf @. x = mf >>= \f -> f @$ x-----------------------------------------------------------------------------------repeatLoop :: ReaderM Bool m => Int -> Eval m -> Eval m-repeatLoop uid super =- Eval - { - structs = structs super @++@ mystructs - , treeState_ = ("dummy", Int, - \i -> (parent i <== baseTstate i)- >>> clone i (cloneBase i)- ) : treeState_ super -- `withClone` (\k -> inc $ ref_count k)- , evalState = ("cont",Bool,true) : ("ref_count",Int,1) : ("parent",THook "TreeState",Null) : evalState super- , pushLeft = push pushLeft- , pushRight = push pushRight- , bodyE = \i -> do cond <- continue super (tstate i)- deref <- dec_ref i- stmt <- bodyE super (i `onAbort` deref)- return $ IfThenElse (cont i)- (IfThenElse cond- stmt- ( (cont i <== false)- >>> deref- >>> abort i))- (deref >>> abort i)- , addE = addE super- , failE = \i -> failE super i @>>>@ dec_ref i- , returnE = \i -> let j deref = i `onCommit` deref- in dec_ref i >>= returnE super . j- , continue = \_ -> return true- , tryE = tryE super- , tryE_ = \i -> tryE_ super i @>>>@ dec_ref i- , intArraysE = intArraysE super- , intVarsE = intVarsE super- }- where mystructs = ([],[])- fs1 = [(field,init) | (field,ty,init) <- evalState super]- cont = \i -> estate i @=> "cont"- ref_count = \i -> estate i @=> "ref_count"- parent = \i -> estate i @=> "parent"- dec_ref = \i -> let i' = resetCommit $ i `withBase` ("or_tstate" ++ show uid)- in do flag <- ask - if flag - then local (const False) $ do- stmt1 <- initTreeState_ i' super - stmt2 <- tryE super i'- return (dec (ref_count i) - >>> ifthen (ref_count i @== 0) - ( SHook ("TreeState or_tstate" ++ show uid ++ ";")- >>> (baseTstate i' <== parent i)- >>> clone (cloneBase i) i'- >>> (ref_count i' <== 1)- >>> (cont i' <== true)- >>> seqs [estate i' @=> f <== init | (f,init) <- fs1 ] - >>> stmt1 >>> stmt2))- else return $dec (ref_count i) >>> ifthen (ref_count i @== 0) (Delete (space $ cloneBase i))- push dir = \i -> dir super (i `onCommit` inc (ref_count i))-----------------------------------------------------------------------------------forLoop :: ReaderM Bool m => Int32 -> Int -> (Eval m,IsComplete) -> Eval m-forLoop n uid (super,iscomplete) =- Eval - { - structs = structs super @++@ mystructs - , treeState_ = ("dummy", Int, - \i -> (parent i <== baseTstate i)- >>> clone i (cloneBase i)- ) : treeState_ super- , evalState = ("counter",Int,0) : ("cont",Bool,true) : ("ref_count",Int,1) : ("parent",THook "TreeState",Null) : evalState super- , pushLeft = push pushLeft- , pushRight = push pushRight- , bodyE = \i -> do cond <- continue super (tstate i)- deref <- dec_ref i- stmt <- bodyE super (i `onAbort` deref)- return $ IfThenElse (cont i)- (IfThenElse cond- stmt- ( (cont i <== false)- >>> deref- >>> abort i))- (deref >>> abort i)- , addE = addE super- , failE = \i -> failE super i @>>>@ dec_ref i- , returnE = \i -> let j deref = i `onCommit` deref- in dec_ref i >>= returnE super . j- , continue = \_ -> return true- , tryE = \i -> tryE super (i `withField` ("counter", counter))- , tryE_ = \i -> tryE_ super i @>>>@ dec_ref i- , intArraysE = intArraysE super- , intVarsE = intVarsE super- }- where mystructs = ([],[])- fs1 = [(field,init) | (field,ty,init) <- evalState super]- cont = \i -> estate i @=> "cont"- ref_count = \i -> estate i @=> "ref_count"- parent = \i -> estate i @=> "parent"- counter = \i -> estate i @=> "counter"- dec_ref = \i -> let i' = resetCommit $ i `withBase` ("or_tstate" ++ show uid)- in do flag <- ask - if flag - then local (const False) $ do- stmt1 <- initTreeState_ i' super - stmt2 <- tryE super (i' `withField` ("counter", counter))- return (dec (ref_count i) - >>> ifthen (ref_count i @== 0) - ( inc (counter i)- >>> ifthen (counter i @< IVal n &&& Not (iscomplete i))- ( SHook ("TreeState or_tstate" ++ show uid ++ ";")- >>> (baseTstate i' <== parent i)- >>> clone (cloneBase i) i'- >>> (ref_count i' <== 1)- >>> (cont i' <== true)- >>> seqs [estate i' @=> f <== init | (f,init) <- fs1 ] - >>> stmt1 >>> stmt2)- ))- else return $dec (ref_count i) >>> ifthen (ref_count i @== 0) (Delete (space $ cloneBase i))- push dir = \i -> dir super (i `onCommit` inc (ref_count i))-----------------------------------------------------------------------------------untilLoop :: ReaderM SeqPos m => Stat -> Int -> (Eval m, IsComplete) -> (Eval m,IsComplete) -> Eval m-untilLoop cond uid (lsuper', liscomplete) (rsuper, riscomplete) =- Eval { structs = structs lsuper @++@ structs rsuper @++@ mystructs - , treeState_ = [entry "is_fst" Bool (assign true)- ,("seq_union", Union [(SType s3,"fst"),(SType s4,"snd")], - \i -> - let j = i `withPath` in1- in seqs [init j | (f,init) <- fs3]- >>> initSubEvalState j s1 fs1)- ]- , evalState = [("until_complete",Bool,true)]- , pushLeft = push pushLeft- , pushRight = push pushRight- , bodyE = \i ->- let f y z iscomplete = - let j = i `withPath` y `onAbort` dec_ref i j iscomplete- in do stmt <- bodyE z j- cond <- continue z (estate j)- return $ IfThenElse (cont j)- (IfThenElse cond- stmt- (cont j <== false >>> abort j))- (abort j)- in do s1 <- local (const FirstS) $ f in1 lsuper liscomplete- s2 <- local (const SecondS) $ f in2 rsuper riscomplete- return $ IfThenElse (is_fst i) s1 s2- , addE = inSeq $ addE- , failE = \i -> inSeq' (\super j iscomplete -> failE super j @>>>@ return (dec_ref i j iscomplete)) i- , returnE = \i -> inSeq' (\super j iscomplete -> returnE super (j `onCommit` dec_ref i j iscomplete)) i- , continue = \_ -> return true- , tryE = \i ->let j1 = i `withPath` in1- j2 = i `withPath` in2 `onAbort` dec_ref i j2 riscomplete- in seqSwitch (tryE lsuper j1 >>= \stmt ->- (local (const SecondS) $- do stmt1 <- initTreeState_ j2 rsuper - stmt2 <- tryE rsuper j2- return (dec_ref i j1 liscomplete- >>> (is_fst i <== false) - >>> initSubEvalState j2 s2 fs2- >>> stmt1 >>> stmt2)- ) >>= \stmt2 ->- return $ IfThenElse (readStat cond j1)- stmt2- stmt- )- (tryE rsuper j2) - , tryE_ = \i -> inSeq' (\super j iscomplete -> tryE_ super j @>>>@ return (dec_ref i j iscomplete)) i- , intArraysE = intArraysE lsuper ++ intArraysE rsuper- , intVarsE = intVarsE lsuper ++ intVarsE rsuper- }- where mystructs = ([s1,s2],[s3,s4])- s1 = Struct ("LeftEvalState" ++ show uid) $ (Bool, "cont") : (Int, "ref_count") : [(ty, field) | (field,ty,_) <- evalState lsuper]- fs1 = [(field,init) | (field,ty,init) <- evalState lsuper ]- s2 = Struct ("RightEvalState" ++ show uid) $ (Bool, "cont") : (Int, "ref_count") : [(ty, field) | (field,ty,_) <- evalState rsuper]- fs2 = [(field,init) | (field,ty,init) <- evalState rsuper ]- s3 = Struct ("LeftTreeState" ++ show uid) $ (Pointer $ SType s1, "evalState") : [(ty, field) | (field,ty,_) <- treeState_ lsuper]- fs3 = [(field,init) | (field,ty,init) <- treeState_ lsuper]- s4 = Struct ("RightTreeState" ++ show uid) $ (Pointer $ SType s2, "evalState") : [(ty, field) | (field,ty,_) <- treeState_ rsuper]- in1 = \state -> state @-> "seq_union" @-> "fst"- in2 = \state -> state @-> "seq_union" @-> "snd"- withSeq f = seqSwitch (f lsuper in1) (f rsuper in2)- inSeq f = \i -> withSeq $ \super ins -> f super (i `withPath` ins)- inSeq' f = \i -> seqSwitch (f lsuper (i `withPath` in1) liscomplete) - (f rsuper (i `withPath` in2) riscomplete)- dec_ref = \i j iscomplete- -> dec (ref_count j) >>> - ifthen (ref_count j @== 0) - (Delete (estate j) >>>- (complete i <== (complete i &&& iscomplete j))- )- push dir = \i -> seqSwitch (push1 dir i) (push2 dir i)- push1 dir = \i -> - let j = i `withPath` in1 - in dir lsuper (j `onCommit` ( mkCopy i "is_fst"- >>> mkCopy j "evalState"- >>> inc (ref_count j)- ))- push2 dir = \i -> - let j = i `withPath` in2 - in dir rsuper (j `onCommit` ( mkCopy i "is_fst"- >>> mkCopy j "evalState"- >>> inc (ref_count j)- ))- lsuper = evalStat cond lsuper'- is_fst = \i -> tstate i @-> "is_fst"- cont = \i -> estate i @=> "cont"- ref_count = \i -> estate i @=> "ref_count"- complete = \i -> estate i @=> "until_complete"- initSubEvalState = \j s fs -> (estate j <== New s) - >>> (ref_count j <== 1)- >>> (cont j <== true)- >>> seqs [estate j @=> f <== init | (f,init) <- fs] -----------------------------------------------------------------------------------ldsLoop :: Monad m => Int32 -> MkEval m-ldsLoop limit super = return $ dummyLoop super- { treeState_ = entry "lds" Int (assign $ IVal limit) : treeState_ super- , evalState = ("lds_complete", Bool, true) : evalState super- , pushLeft = \i -> pushLeft super (i `onCommit` mkCopy i "lds")- , pushRight = \i -> pushRight super (i `onCommit` mkUpdate i "lds" (\x -> x - 1)) >>= \stmt -> - return $ IfThenElse - (tstate (old i) @-> "lds" @>= 0) - stmt- (abort i >>> (estate i @=> "lds_complete" <== false))- }------------------------------------------------------------------------------------dbsLoop :: Monad m => Int32 -> MkEval m-dbsLoop limit super = return $ dummyLoop super- { treeState_ = entry "depth_limit" Int (assign $ IVal limit) : treeState_ super- , evalState = ("dbs_complete", Bool, true) : evalState super- , pushLeft = push pushLeft- , pushRight = push pushRight- }- where push dir = - \i -> dir super (i `onCommit` mkUpdate i "depth_limit" (\x -> x - 1)) >>= \stmt ->- return $ IfThenElse (tstate (old i) @-> "depth_limit" @>= 0)- stmt- ((estate i @=> "dbs_complete" <== false) >>> abort i)-----------------------------------------------------------------------------------nbLoop :: Monad m => Int32 -> MkEval m-nbLoop limit super = return $ dummyLoop super- { evalState = ("nodes", Int, IVal limit) :- ("nb_complete", Bool, true) : evalState super,- bodyE = \i -> bodyE super i >>= \r -> return $ dec (estate i @=> "nodes") >>> r,- continue = \estate -> continue super estate >>= \r -> return $ (estate @=> "nodes" @> 0) &&& r- }-----------------------------------------------------------------------------------printLoop :: Monad m => [String] -> MkEval m-printLoop arrs super = return $ dummyLoop super- { returnE = \i -> returnE super $ i `onCommit` Print (space i) arrs- }-----------------------------------------------------------------------------------onceLoop :: Monad m => MkEval m-onceLoop super = return $ dummyLoop super- { evalState = ("once",Bool,true) : evalState super- , returnE = \i -> returnE super (i {commit = (estate i @=> "once" <== false) >>> commit i})- , continue = \estate -> continue super estate >>= \r -> return $ (estate @=> "once") &&& r- }-----------------------------------------------------------------------------------nSolutionsLoop :: Monad m => Int32 -> MkEval m-nSolutionsLoop limit super = return $ dummyLoop super- { evalState = ("solutions", Int, IVal limit) : evalState super - , returnE = \i -> returnE super (i `onCommit` dec (estate i @=> "solutions"))- , continue = \estate -> continue super estate >>= \r -> return $ (estate @=> "solutions" @> 0) &&& r- }-----------------------------------------------------------------------------------bbLoop :: Monad m => String -> MkEval m -bbLoop var super = return $ dummyLoop super- { treeState_ = entry "tree_bound_version" Int (assign 0) : treeState_ super- , evalState = ("bound_version",Int,0) : ("bound",Int,IVal maxBound) : evalState super- , returnE = \i -> returnE super (i `onCommit`- let get = VHook (rp 0 (space i) ++ "->getVar($VAR_" ++ var ++ ").min()")- in (Update (estate i @=> "bound") get >>> inc (estate i @=> "bound_version"))) - , bodyE = \i -> let set = Post (space i) (VHook (rp 0 (space i) ++ "->getVar($VAR_" ++ var ++ ")") $< (estate i @=> "bound"))- in do r <- bodyE super i- return $ (ifthen (tstate i @-> "tree_bound_version" @< (estate i @=>"bound_version"))- (set >>> (Update (tstate i @-> "tree_bound_version") ((tstate i @-> "tree_bound_version") + 1)))- >>> r)- , pushLeft = push pushLeft- , pushRight = push pushRight- , intVarsE = var : intVarsE super- }- where push dir = \i -> dir super (i `onCommit` mkCopy i "tree_bound_version")-------------------------------------------------------------------------------------- PRINTING-----------------------------------------------------------------------------------printTreeStateType :: Monad m => Eval m -> String-printTreeStateType e =- render $ pretty $ Struct "TreeState" [ (ty,name) | (name,ty,_) <- treeState e ]--initEvalState :: Monad m => Eval m -> Doc-initEvalState e =- vcat [pretty ty <+> text name <+> (case val of { Null -> empty ; _ -> text "=" <+> pretty val}) <> text ";" | (name,ty,val) <- evalState e]--initTreeState :: Monad m => Info -> Eval m -> m Statement-initTreeState i e =- return $ seqs [ init i | (_,_,init) <- treeState e]--initTreeState_ :: Monad m => Info -> Eval m -> m Statement-initTreeState_ i e =- return $ seqs [ init i | (_,_,init) <- treeState_ e]--initIntArrays :: Eval m -> Doc-initIntArrays eval =- vcat [ doc arr | arr <- nub $ sort $ intArraysE eval]- where doc arr = text "vector<int>" <+> text "$ARR_" <> text arr <> - case arr of- "branch" -> empty <+> text "=" <+> text "root->getBranchVarIds()" <> semi- "bound" -> text "(1)" <> semi <+> text "$ARR_bound[0]=-1" <> semi--initIntVars :: Eval m -> Doc-initIntVars eval =- vcat [ doc var | var <- nub $ sort $ intVarsE eval]- where doc var = text "int" <+> text "$VAR_" <> text var <> - case var of- "cost" -> empty <+> text "=" <+> text "-1" <> semi---- initIntVars :: Eval m -> Doc --- initIntVars eval =--- vcat [ doc var | var <- nub $ sort $ intVarsE eval]--- where doc var = (text "int" <+> text "$VAR_" <> text var <> semi) $$--- (text "vm->getintVarIndex(\"" <> text var <> text "\", " <> text "$VAR_" <> text var <> text ");")--generate eval = - do tell $ (++ "\n") $ render $ vcat $ [text "struct" <+> text name <> semi | Struct name _ <- fst $ structs eval]- tell $ (++ "\n") $ render $ vcat $ map pretty $ snd $ structs eval- tell $ printTreeStateType eval - tell $ (++ "\n") $ render $ vcat $ map pretty $ fst $ structs eval- tell ("\n\nvoid eval(" ++ spacetype ++ "* root) {\n")- tell $ (++ "\n") $ render $ nest 2 $ initIntVars eval- tell $ (++ "\n") $ render $ nest 2 $ initIntArrays eval- tell "\n Gecode::SpaceStatus status = root->status();\n"- tell "\n"- tell " std::list<TreeState> *queue = new std::list<TreeState>();\n"- tell $ render (nest 2 (initEvalState eval)) ++ "\n"- tell " TreeState estate;\n"- initTreeState info eval >>= tell . (++ "\n") . rp 2- tryE eval info >>= tell . (++ "\n") . rp 2- continue eval (estate info) >>= \c -> tell $ " while ( !queue->empty() && (" ++ rp 0 c ++ ")) {\n"- tell " /* pop first element */\n" - tell " estate = queue->front();\n"- tell " queue->pop_front();\n"- bodyE eval info >>= tell . (++ "\n") . rp 4- tell " }\n"- tell "}"--rp n = render . nest n . pretty------------------------------------------------------------------------------------- TESTS----------------------------------------------------------------------------------testHorst = search $ prt ["q"] <@> label "q" ubV maxV minD ($==)-----------------------------------------------------------------------------------test0 = search $ lds 3 <@> dbs 4 <@> prt ["get"] <@> label "get" ubV maxV minD ($==)- --t0 = putStrLn test0-w0 f = writeFile f test0-----------------------------------------------------------------------------------test1 = search $ lds 1000 <@> (b1 <&> (b2 <&> b3 ))- where- b1 = label "getP" lbV minV meanD ($<=)- b2 = prt ["getQ"] <@> label "getQ" ubV maxV minD ($==)- b3 = label "getP" lbV minV meanD ($<=)--t1 = putStrLn test1-w1 f = writeFile f test1-----------------------------------------------------------------------------------test2 = search $ nb 100 <@> (b1 <&> (b2 <&> b3))- where- b1 = label "get" lbV minV meanD ($<=)- b2 = nb 5 <@> prt ["get"] <@> label "get" ubV maxV minD ($==)- b3 = label "get" lbV minV meanD ($<=)--t2 = putStrLn test2-w2 f = writeFile f test2-----------------------------------------------------------------------------------test3 = search $ nb 1000 <@> (until (appStat (@> 4) depthStat) b1 b2)- where- b1 = label "get" lbV minV minD ($==)- b2 = prt ["get"] <@> label "get" lbV minV maxD ($==)---t3 = putStrLn test3-w3 f = writeFile f test3-----------------------------------------------------------------------------------test4 = search $ dbs 10 <@> prt ["get"] <@> label "get" lbV minV minD ($==)-test5 = search $ until (appStat (@> 11) depthStat) (prt ["get"] <@> label "get" lbV minV minD ($==)) failure----------------------------------------------------------------------------------test6 = search $ label "get" lbV minV minD ($==) <|> label "get" lbV minV minD ($==)-------test7 = search $ (nb 10 <@> label "getP" lbV minV minD ($==)) <&> (nb 20 <@> label "getQ" lbV minV minD ($==)) -----------------------------------------------------------------------------------test8 = search $ prt ["get"] <@> ((label "get" lbV minV minD ($==) <|> label "get" lbV minV minD ($==)) <|> label "get" lbV minV minD ($==))-----------------------------------------------------------------------------------test9 = search $ prt ["get"] <@> ((b1 <&> b2) <|> b3) - where b1 = nb 2 <@> label "get" lbV minV minD ($==) - b2 = label "get" lbV minV minD ($==) - b3 = label "get" lbV minV minD ($==)-----------------------------------------------------------------------------------testa = search $ prt ["get"] <@> repeat (label "get" lbV minV minD ($==))-----------------------------------------------------------------------------------testb = search $ prt ["get"] <@> for 4 (label "get" lbV minV minD ($==))-----------------------------------------------------------------------------------testc = search $ prt ["get"] <@> foreach 6 (\index -> until (depthStat #> index) - (label "get" lbV minV minD ($==)) - failure- )-----------------------------------------------------------------------------------testd = search $ prt ["q"] <@> properLDS 7 (label "q" lbV minV minD ($==)) ---- main = putStrLn test0------------------------------------------------------------------------------------- COMPOSITION COMBINATORS-----------------------------------------------------------------------------------def vars = label vars lbV minV minD ($==)--type MkEval m = Eval m -> State Int (Eval m)--fixall :: MkEval m -> Eval m-fixall f = let this = fst $ runState 0 $ f this- in this--data Search = forall t2. FMonadT t2 =>- Search { mkeval :: forall m t1. (Monad m, FMonadT t1) => MkEval ((t1 :> t2) m)- , runsearch :: forall m x. Monad m => t2 m x -> m x- , iscomplete :: Info -> Value- }--type IsComplete = Info -> Value--nb :: Int32 -> Search-nb n = - Search { mkeval = nbLoop n - , runsearch = runIdT- , iscomplete = const true -- DUMMY VALUE- }--bbmin :: String -> Search-bbmin var = - Search { mkeval = bbLoop var - , runsearch = runIdT- , iscomplete = const true- }--lds :: Int32 -> Search-lds n = - Search { mkeval = ldsLoop n- , runsearch = runIdT- , iscomplete = \i -> estate i @=> "lds_complete"- }--properLDS - :: Int32 - -> Search- -> Search-properLDS n search = foreach n (\limit -> until (discrepancyStat #> limit)- search- failure)-limit :: Int32 -> Stat -> Search -> Search-limit n stat s = until (stat #> const (IVal n)) s failure--once :: Search-once = - Search { mkeval = onceLoop- , runsearch = runIdT- , iscomplete = const true -- DUMMY VALUE- } --dbs :: Int32 -> Search-dbs n = - Search { mkeval = dbsLoop n- , runsearch = runIdT- , iscomplete = \i -> estate i @=> "dbs_complete"- } --prt :: [String] -> Search-prt str = - Search { mkeval = printLoop str- , runsearch = runIdT- , iscomplete = const true- }--fs :: Search-fs =- Search { mkeval = nSolutionsLoop 1- , runsearch = runIdT- , iscomplete = const true- }--failure :: Search-failure = - Search { mkeval = return . failLoop- , runsearch = runIdT- , iscomplete = const false- }--(<@>)- :: Search -> Search -> Search-s1 <@> s2 = - case s1 of- Search { mkeval = evals1, runsearch = runs1, iscomplete = iscompletes1 } ->- case s2 of- Search { mkeval = evals2, runsearch = runs2, iscomplete = iscompletes2 } ->- Search {mkeval =- \super -> do { s2' <- evals2 $ mapE (L . L . mmap runL . runL) super- ; s1' <- evals1 (mapE runL s2')- ; return $ mapE (L . mmap L . runL) s1'- }- , runsearch = runs2 . runs1 . runL- , iscomplete = \i -> iscompletes1 i &&& iscompletes2 i- }--(<&>)- :: Search- -> Search- -> Search-s1 <&> s2 = - case s1 of- Search { mkeval = evals1, runsearch = runs1, iscomplete = iscompletes1 } ->- case s2 of- Search { mkeval = evals2, runsearch = runs2, iscomplete = iscompletes2 } ->- Search {mkeval =- \super -> do { s2' <- evals2 $ mapE (L . L . L . mmap (mmap runL . runL) . runL) super- ; s1' <- evals1 $ mapE (L . L . mmap (mmap runL . runL) . runL) super- ; uid <- get- ; put (uid + 1)- ; return $ mapE (L . mmap L . runL) $ - seqLoop uid (mapE (L . mmap (mmap L) . runL . runL) s1')- (mapE (L . mmap (mmap L) . runL . runL . runL) s2')- }- , runsearch = runs2 . runs1 . runL . runReaderT FirstS . runL- , iscomplete = const true -- DUMMY VALUE- }--(<|>)- :: Search- -> Search- -> Search-s1 <|> s2 = - case s1 of- Search { mkeval = evals1, runsearch = runs1, iscomplete = iscompletes1 } ->- case s2 of- Search { mkeval = evals2, runsearch = runs2, iscomplete = iscompletes2 } ->- Search {mkeval =- \super -> do { s2' <- evals2 $ mapE (L . L . L . mmap (mmap runL . runL) . runL) super- ; s1' <- evals1 $ mapE (L . L . mmap (mmap runL . runL) . runL) super- ; uid <- get- ; put (uid + 1)- ; return $ mapE (L . mmap L . runL) $ - orLoop uid (mapE (L . mmap (mmap L) . runL . runL) s1')- (mapE (L . mmap (mmap L) . runL . runL . runL) s2')- }- , runsearch = runs2 . runs1 . runL . runReaderT FirstS . runL- , iscomplete = \i -> Cond (tstate i @-> "is_fst") (iscompletes1 (i `withPath` in1)) (iscompletes2 (i`withPath` in2))- }--mmap :: (FMonadT t, Monad m, Monad n) => (forall x. m x -> n x) -> t m a -> t n a-mmap f x = tmap' mfunctor mfunctor id f x--mfunctor :: Monad m => FunctorD m-mfunctor = FunctorD { fmapD = \f m -> m >>= return . f }--search :: Search -> String-search s = - case s of- Search { mkeval = evals, runsearch = runs } ->- snd $ runId $ runs $runWriterT $ generate $ mapE runL $ fixall $ evals--label :: String -> (Value -> Value) -> (Value -> Value -> Value, Value) -> (Value -> Value) -> (Value -> Value -> Constraint) -> Search-label get varMeasure varComp valSel rel = - Search { mkeval = \this -> baseLoop (vLabel get (foldVarSel varMeasure varComp) valSel rel this) this - , runsearch = runIdT- , iscomplete = const true -- PROPER VALUE- }--vlabel :: String -> (Value -> Value) -> (Value -> Value -> Constraint) -> Search-vlabel get valSel rel = - Search { mkeval = \this -> baseLoop (v1Label get valSel rel this) this - , runsearch = runIdT- , iscomplete = const true -- PROPER VALUE- }--ilabel :: String -> (Value -> Value) -> (Value -> Value -> Value, Value) -> (Value -> Value) -> (Value -> Value -> Constraint) -> Search-ilabel get varMeasure varComp valSel rel = - Search { mkeval = \this -> baseLoop (vLabel get (ifoldVarSel varMeasure varComp) valSel rel this) this - , runsearch = runIdT- , iscomplete = const true -- PROPER VALUE- }--glabel :: String -> VarSel -> (Value -> Value) -> (Value -> Value -> Constraint) -> Search-glabel get varSel valSel rel = - Search { mkeval = \this -> baseLoop (vLabel get varSel valSel rel this) this - , runsearch = runIdT- , iscomplete = const true -- PROPER VALUE- }--until - :: Stat- -> Search- -> Search- -> Search-until cond s1 s2 = - case s1 of- Search { mkeval = evals1, runsearch = runs1, iscomplete = iscompletes1 } ->- case s2 of- Search { mkeval = evals2, runsearch = runs2, iscomplete = iscompletes2 } ->- Search { mkeval =- \super -> do { s2' <- evals2 $ mapE (L . L . L . mmap (mmap runL . runL) . runL) super- ; s1' <- evals1 $ mapE (L . L . mmap (mmap runL . runL) . runL) super- ; uid <- get- ; put (uid + 1)- ; return $ mapE (L . mmap L . runL) $ - untilLoop cond uid (mapE (L . mmap (mmap L) . runL . runL) s1', iscompletes1)- (mapE (L . mmap (mmap L) . runL . runL . runL) s2', iscompletes2)- }- , runsearch = runs2 . runs1 . runL . runReaderT FirstS . runL- , iscomplete = \i -> estate i @=> "until_complete"- } --repeat - :: Search- -> Search-repeat s = - case s of- Search { mkeval = evals, runsearch = runs, iscomplete = iscompletes } ->- Search { mkeval =- \super ->- do { uid <- get- ; put (uid + 1)- ; s' <- evals $ mapE (L . L . mmap runL . runL) super- ; return $ mapE (L . mmap L . runL) $ repeatLoop uid $ mapE runL s' - }- , runsearch = runs . runReaderT True . runL- , iscomplete = const true -- PROPER VALUE (TODO: repeat only steps when the search is complete)- } --for- :: Int32- -> Search- -> Search-for n s = - case s of- Search { mkeval = evals, runsearch = runs, iscomplete = iscompletes } ->- Search { mkeval =- \super ->- do { uid <- get- ; put (uid + 1)- ; s' <- evals $ mapE (L . L . mmap runL . runL) super- ; return $ mapE (L . mmap L . runL) $ forLoop n uid (mapE runL s', iscompletes)- }- , runsearch = runs . runReaderT True . runL- , iscomplete = iscompletes- }--foreach- :: Int32- -> ((Info -> Value) -> Search)- -> Search-foreach n mksearch = - case mksearch (\i -> field i "counter") of- Search { mkeval = eval, runsearch = run, iscomplete = cpl } ->- Search { mkeval = - \super ->- do { uid <- get- ; put (uid + 1)- ; s' <- eval $ mapE (L . L . mmap runL . runL) super- ; return $ mapE (L . mmap L . runL) $ forLoop n uid (mapE runL s', cpl)- }- , runsearch = run . runReaderT True . runL- , iscomplete = cpl- }---- ========================================================================== ----- IVALUE--- ========================================================================== ----type IValue = Info -> Value--instance Show (Info -> Value) where- show x = "<IValue>"-instance Eq (Info -> Value) where- x == y = False--instance Num (Info -> Value) where- x - y = \i -> x i - y i- fromInteger x = \i -> IVal (fromInteger x)- x + y = \i -> x i + y i- x * y = \i -> x i * y i- abs = undefined- signum = undefined---- ========================================================================== ----- STATS--- ========================================================================== ----data Stat = Stat (forall m. Monad m => Eval m -> Eval m) - IValue--instance Show Stat where- show x = "<Stat>"-instance Eq Stat where- x == y = False--readStat (Stat _ r) = r-evalStat (Stat e _) = e---- -------------------------------------------------------------------------- ----instance Num Stat where- x - y = undefined- fromInteger x = Stat dummyLoop (fromInteger x)- x + y = undefined- x * y = undefined- abs = undefined- signum = undefined--appStat :: (Value -> Value) -> Stat -> Stat-appStat f (Stat e r) = Stat e (f . r)--liftStat :: (Value -> Value -> Value) -> Stat -> IValue -> Stat-liftStat op (Stat e r) x = Stat e (\i -> r i`op` x i)--(#>) :: Stat -> IValue -> Stat-(#>) stat x = liftStat (@>) stat x---- -------------------------------------------------------------------------- ----depthStat :: Stat-depthStat = - Stat (\super -> - let push dir = \i -> dir super (i `onCommit` mkUpdate i "depth" (\x -> x + 1))- in super- { treeState_ = entry "depth" Int (assign $ 0) : treeState_ super- , pushLeft = push pushLeft- , pushRight = push pushRight- })- (\info -> tstate info @-> "depth")--discrepancyStat :: Stat-discrepancyStat = - Stat - (\super -> - super- { treeState_ = entry "discrepancy" Int (assign $ 0) : treeState_ super- , pushLeft = \i -> pushLeft super (i `onCommit` mkCopy i "discrepancy")- , pushRight = \i -> pushRight super (i `onCommit` mkUpdate i "discrepancy" (\x -> x + 1))- })- (\info -> tstate info @-> "discrepancy")--nodesStat :: Stat-nodesStat = - eStat ("nodes", Int, 0) $- \super -> super { bodyE = \i -> return (inc (estate i @=> "nodes")) @>>>@ bodyE super i }--solutionsStat :: Stat-solutionsStat = - eStat ("solutions", Int, 0) $- \super -> super {returnE = \i -> returnE super (i `onCommit` dec (solutions i))}- where solutions i = estate i @=> "solutions"--failsStat :: Stat-failsStat = - eStat ("fails", Int, 0)- $ \super -> super { failE = \i -> returnE super i @>>>@ return (inc (fails i)) }- where fails i = estate i @=> "fails"--eStat :: (String, Type, Value) -> (forall m. Monad m => Eval m -> Eval m) -> Stat-eStat entry@(name,_,_) f =- Stat (\super -> f $ super { evalState = entry : evalState super })- (\i -> estate i @=> name)
− Control/CP/SearchSpec/Language.hs
@@ -1,345 +0,0 @@-module Control.CP.SearchSpec.Language where --import Text.PrettyPrint-import Data.Monoid-import Data.Int--spacetype = "MCPProgram"--instance Monoid Statement where- mempty = Skip- mappend = (>>>)---class Pretty x where- pretty :: x -> Doc--data Struct = Struct String [(Type,String)] deriving (Show, Eq)--instance Pretty Struct where- pretty (Struct name fields) =- text "struct" <+> text name <+> text "{"- $+$ nest 2 (vcat [pretty ty <+> text f <> text ";" | (ty,f) <- fields])- $+$ text "};" ---data Type = Pointer Type- | SpaceType- | Int- | Bool- | Union [(Type,String)]- | SType Struct- | THook String- deriving (Show, Eq)--data Value = IVal Int32- | BVal Bool- | RootSpace- | Minus Value Value- | Plus Value Value- | Div Value Value- | Mod Value Value- | Abs Value- | Var String- | Clone Value- | Field String String- | Field' Value String- | PField Value String- | Lt Value Value- | Gq Value Value- | Gt Value Value- | Eq Value Value- | BaseContinue- | And Value Value- | Or Value Value- | Not Value- | VHook String- | Max Value Value- | CVar String Value Value- | XVar String Value String- | MinDom Value- | MaxDom Value- | SizeDom Value- | Degree Value- | WDegree Value- | UbRegret Value- | LbRegret Value- | Median Value- | Random - | Null- | New Struct- | Base- | Cond Value Value Value- | Assigned Value- deriving (Show, Eq)--instance Num Value where- (-) = Minus- fromInteger = IVal . fromInteger- (+) = Plus- (*) = undefined- abs = Abs- signum = undefined--true = BVal True-false = BVal False-(&&&) = And-(|||) = Or-(@>) = Gt-(@>=) = Gq-(@==) = Eq-(@->) = Field' -(@=>) = PField -(@<) = Lt-lex cmps l1 l2 = foldr (\(x,y,cmp) r -> (x `cmp` y) ||| ((x @== y) &&& r)) false (zip3 l1 l2 cmps)--simplValue :: Value -> Value-simplValue (Cond c t e) =- let c' = simplValue c- t' = simplValue t- e' = simplValue e- in case (c',t',e') of- (BVal True, _, _) -> t'- (BVal False, _, _) -> e'- _ | t' == e' -> t'- _ -> Cond c' t' e'-simplValue (Minus (IVal x) (IVal y)) = IVal (x - y)-simplValue (Lt x y) = Lt (simplValue x) (simplValue y)-simplValue (Gq x y) = Gq (simplValue x) (simplValue y)-simplValue (And x y) =- let x' = simplValue x- y' = simplValue y- in case (x',y') of- (x, (BVal True)) -> x - (x, (BVal False)) -> BVal False- _ -> And x' y'-simplValue (Not x) =- let x' = simplValue x- in case x' of- (BVal True) -> BVal False- (BVal False) -> BVal True- _ -> x'-simplValue v = v--instance Pretty Type where- pretty (Pointer t) = pretty t <> text "*"- pretty SpaceType = text spacetype- pretty Int = text "int"- pretty Bool = text "bool"- pretty (Union fields) = - text "union" <+> text "{"- $+$ nest 2 (vcat [pretty ty <+> text f <> text ";" | (ty,f) <- fields])- $+$ text "}" - pretty (SType (Struct name fields)) =- text name- pretty (THook str) = - text str--instance Pretty Value where- pretty = pretty_ . simplValue- where- pretty_ (Cond c t e) = pretty c <+> text "?" <+> pretty t <+> text ":" <+> pretty e- pretty_ Base = text "<BASE>"- pretty_ Null = text "NULL"- pretty_ (IVal i) = int $ fromInteger $ toInteger i- pretty_ (BVal True) = text "true" - pretty_ (BVal False) = text "false" - pretty_ (Abs x) = text "abs" <> parens (pretty_ x)- pretty_ RootSpace = text "root"- pretty_ (Minus v1 v2) = pretty_ v1 <+> text "-" <+> pretty_ v2- pretty_ (Plus v1 v2) = pretty_ v1 <+> text "+" <+> pretty_ v2- pretty_ (Div v1 v2) = parens (pretty_ v1) <+> text "/" <+> parens (pretty_ v2)- pretty_ (Mod v1 v2) = parens (pretty_ v1) <+> text "%" <+> parens (pretty_ v2)- pretty_ (Var x) = text x- pretty_ (Clone x) = text ("static_cast<" ++ spacetype ++ "*>(") <> pretty_ x <> text "->clone(true))"- -- pretty_ (Clone x) = text ("static_cast<" ++ spacetype ++ "*>(") <> pretty_ x <> text "->clone(false))"- pretty_ (Field r f) = text r <> text "." <> text f- pretty_ (Field' r f) = pretty_ r <> text "." <> text f- pretty_ (PField (Field' (Var _) "evalState") f)- = text f- pretty_ (PField r f) = pretty_ r <> text "->" <> text f- pretty_ (Lt x y) = parens (pretty_ x) <+> text "<" <+> parens (pretty_ y) - pretty_ (Gq x y) = parens (pretty_ x) <+> text ">=" <+> parens (pretty_ y) - pretty_ (Gt x y) = parens (pretty_ x) <+> text ">" <+> parens (pretty_ y) - pretty_ (Eq x y) = parens (pretty_ x) <+> text "==" <+> parens (pretty_ y) - pretty_ BaseContinue = text "! queue->empty()"- pretty_ (And x y) = parens (pretty x) <+> text "&&" <+> parens (pretty y) - pretty_ (Or x y) = parens (pretty x) <+> text "||" <+> parens (pretty y) - pretty_ (Not x) = text "!" <> parens (pretty x)- pretty_ (VHook s) = text s- pretty_ (Max x y) = text "max" <> parens (pretty x <> text "," <> pretty y)- -- pretty_ (CVar vs s i) = pretty_ s <> text "->" <> text vs <> text "()" <> brackets (pretty i)- pretty_ (CVar vs s i) = pretty_ s <> text "->getVar" <> parens (text "$ARR_" <> text vs <> brackets (pretty i))- pretty_ (XVar vs s i) = pretty_ s <> text "->getVar" <> parens (text "$ARR_" <> text vs <> brackets (text i))- pretty_ (MinDom v) = pretty_ v <> text ".min()"- pretty_ (MaxDom v) = pretty_ v <> text ".max()"- pretty_ (SizeDom v) = pretty_ v <> text ".size()"- pretty_ (Degree v) = pretty_ v <> text ".degree()"- pretty_ (WDegree v) = pretty_ v <> text ".afc()" -- aka accumulated failure count- pretty_ (UbRegret v) = pretty_ v <> text ".regret_max()"- pretty_ (LbRegret v) = pretty_ v <> text ".regret_min()"- pretty_ (Median v) = pretty_ v <> text ".med()"- pretty_ Random = text "rand()"- pretty_ (New (Struct name _)) = text "new" <+> text name- pretty_ (Assigned var) = pretty_ var <> text ".assigned()"--data Constraint = EqC Value Value- | NqC Value Value- | LtC Value Value- | LqC Value Value- | GtC Value Value- | GqC Value Value- --($==) = EqC-($/=) = NqC-($<) = LtC-($<=) = LqC-($>) = GtC-($>=) = GqC--neg (EqC x y) = NqC x y-neg (NqC x y) = EqC x y-neg (LtC x y) = GqC x y-neg (LqC x y) = GtC x y-neg (GtC x y) = LqC x y-neg (GqC x y) = LtC x y--instance Pretty Constraint where- pretty (EqC x y) =- pretty x <> text "," <> text "IRT_EQ" <> text "," <> pretty y- pretty (NqC x y) =- pretty x <> text "," <> text "IRT_NQ" <> text "," <> pretty y- pretty (LtC x y) =- pretty x <> text "," <> text "IRT_LE" <> text "," <> pretty y- pretty (LqC x y) =- pretty x <> text "," <> text "IRT_LQ" <> text "," <> pretty y- pretty (GtC x y) =- pretty x <> text "," <> text "IRT_GR" <> text "," <> pretty y- pretty (GqC x y) =- pretty x <> text "," <> text "IRT_GQ" <> text "," <> pretty y---data Statement = IfThenElse Value Statement Statement- | Push Value- | Skip- | Update Value Value- | Seq Statement Statement- | Assign Value Value- | Abort- | Print Value [String]- | SHook String- | Post Value Constraint- | Fold String Value Value Value (Value -> Value) (Value -> Value -> Value)- | IFold String Value Value Value (Value -> Value) (Value -> Value -> Value)- | MFold String [(Value, Value->Value)] ([Value] -> [Value] -> Value)- | Delete Value--dec var = Update var (var - 1)-inc var = Update var (var + 1)-(>>>) = Seq-(<==) = Update-assign = flip Update-ifthen c t = IfThenElse c t Skip-seqs = foldr (>>>) Skip--instance Pretty Statement where- pretty (Push tstate) = - text "queue->push_front" <> parens (pretty tstate) <> text ";"- pretty (IfThenElse c t e) =- let c' = simplValue c- in case c' of - BVal True -> pretty t- BVal False -> pretty e- c -> case e of- Skip -> text "if" <+> parens (pretty c) <+> text "{" $+$ nest 2 (pretty t) $+$ text "}"- _ -> text "if" <+> parens (pretty c) <+> text "{" $+$ nest 2 (pretty t) $+$ text "} else {" $+$ nest 2 (pretty e) $+$ text "}"- pretty Skip =- empty- pretty (Update var (Minus val 1))- | var == val- = pretty var <> text "--;"- pretty (Update var (Plus val 1))- | var == val- = pretty var <> text "++;"- pretty (Update var val) =- pretty var <+> text "=" <+> pretty val <> text ";"- pretty (Seq s1 s2) =- pretty s1 $+$ pretty s2- pretty (Assign x Null) = pretty x- pretty (Assign x y) =- pretty x <+> text "=" <+> pretty y <> text ";"- pretty Abort =- text "break;"- pretty (Print space vs) = (vcat $ map (\s -> text ("std::cout << \"[\"; for (int i=0; i<$ARR_" ++ s ++ ".size(); i++) { std::cout << ") <> pretty (XVar s space "i") <> text " << \" \"; }; std::cout << \"] \";") vs) <> text "std::cout << std::endl;"- pretty (SHook s) =- text s- pretty (Post space c) = - text "rel(*" <> parens (pretty space) <> text "," <> pretty c <> text ");" - pretty (Fold vars state space m0 metric better) = - let- pos = Field' state "pos"- size = VHook $ render $ text "$ARR_" <> text vars <> text ".size()" - in- text "int best_pos = -1;" - $+$ pretty (Update pos 0)- $+$ text "for (int metric = " <> pretty m0 <> text "; " <> pretty (pos @< size ) <> text "; " <> pretty pos <> text "++) {"- $+$ nest 2 (text "if" <+> parens (text "!" <> pretty (CVar vars space pos) <> text ".assigned()") <+> text "{"- $+$ nest 2 ( text "int current_metric = " <> pretty (metric (CVar vars space pos)) <> text ";"- $+$ pretty (IfThenElse (Var "current_metric" `better` Var "metric")- (Update (Var "metric") (Var "current_metric") >>> (Update (Var "best_pos") pos))- Skip- )- )- $+$ text "}"- )- $+$ text "}" - $+$ pretty (Update pos (Var "best_pos")) - pretty (IFold vars state space m0 metric better) = - let- pos = Field' state "pos"- size = VHook $ render $ text "$ARR_" <> text vars <> text ".size()" - in- text "int best_pos = -1;" - $+$ pretty (Update pos 0)- $+$ text "for (int metric = " <> pretty m0 <> text "; " <> pretty (pos @< size ) <> text "; " <> pretty pos <> text "++) {"- $+$ nest 2 (text "if" <+> parens (text "!" <> pretty (CVar vars space pos) <> text ".assigned()") <+> text "{"- $+$ nest 2 ( text "int current_metric = " <> pretty (metric pos) <> text ";"- $+$ pretty (IfThenElse (Var "current_metric" `better` Var "metric")- (Update (Var "metric") (Var "current_metric") >>> (Update (Var "best_pos") pos))- Skip- )- )- $+$ text "}"- )- $+$ text "}" - $+$ pretty (Update pos (Var "best_pos")) - pretty (MFold state metrics better) = - let- space = Field "estate" "space"- pos = Field state "pos"- cvar = CVar "get" space pos- size = VHook $ render $ pretty space <> text "->" <> text "get" <> text "().size()" - acc_vars = [Var $ "metric" ++ show i | i <- [1..length metrics]]- cur_vars = [Var $ "current_metric" ++ show i | i <- [1..length metrics]]- init_list = hcat $ punctuate comma [pretty v <+> text "=" <+> pretty z | (v,(z,_)) <- zip acc_vars metrics]- computations = vcat $ [text "int" <+> pretty (Update var (f cvar))| (var,(_,f)) <- zip cur_vars metrics]- updates = foldl (>>>) Skip [Update v1 v2 | (v1,v2) <- zip acc_vars cur_vars]- in- text "int best_pos = -1;" - $+$ pretty (Update pos 0)- $+$ text "for (int " <> init_list <> text "; " <> pretty (pos @< size ) <> text "; " <> pretty pos <> text "++) {"- $+$ nest 2 (text "if" <+> parens (text "!" <> pretty cvar <> text ".assigned()") <+> text "{"- $+$ nest 2 ( computations- $+$ pretty (IfThenElse (cur_vars `better` acc_vars)- (updates >>> (Update (Var "best_pos") pos))- Skip- )- )- $+$ text "}"- )- $+$ text "}" - $+$ pretty (Update pos (Var "best_pos")) - pretty (Delete value) =- text "delete" <+> pretty value <> text ";" -
+ Control/Monatron/AutoInstances.hs view
@@ -0,0 +1,16 @@+{-# OPTIONS+ -XFlexibleInstances+ -XOverlappingInstances+#-}++module Control.Monatron.AutoInstances where++import Control.Monatron.MonadT++------------------------------------------------------------------+instance (Monad m, MonadT t) => Monad (t m) where+ return = treturn+ fail = lift . fail+ (>>=) = tbind++instance (Monad m, MonadT t) => Functor (t m) where fmap = liftM
+ Control/Monatron/AutoLift.hs view
@@ -0,0 +1,128 @@+{-# OPTIONS+ -XFlexibleInstances+ -XMultiParamTypeClasses+ -XFunctionalDependencies+ -XUndecidableInstances+ -XOverlappingInstances+#-}++-- -XOverlappingInstances++module Control.Monatron.AutoLift (+ StateM(..), get,put,+ WriterM (..), tell,+ ReaderM(..), ask,local,+ ExcM(..), throw,handle,+ ContM(..), callCC,+ ListM(..), mZero,mPlus,+ module Control.Monatron.Operations+) where++import Control.Monatron.Operations+import Control.Exception (SomeException)+++------------------------------------------------------------------+-- State+class Monad m => StateM z m | m -> z where+ stateModel :: AlgModel (StateOp z) m++instance Monad m => StateM z (StateT z m) where+ stateModel = modelStateT++instance (StateM z m, MonadT t) => StateM z (t m) where+ stateModel = liftAlgModel stateModel++get :: StateM z m => m z+get = getX stateModel++put :: StateM z m => z -> m ()+put = putX stateModel++------------------------------------------------------------------+-- Traces+class (Monoid z, Monad m) => WriterM z m | m -> z where+ writerModel :: AlgModel (WriterOp z) m++instance (Monoid z, Monad m) => WriterM z (WriterT z m) where+ writerModel = modelWriterT++instance (Monoid z, WriterM z m, MonadT t) => WriterM z (t m) where+ writerModel = liftAlgModel writerModel++tell :: (Monoid z, WriterM z m) => z -> m ()+tell z = traceX writerModel z++------------------------------------------------------------------+-- Environments+class Monad m => ReaderM z m | m -> z where+ readerModel :: Model (ReaderOp z) m++instance Monad m => ReaderM z (ReaderT z m) where+ readerModel = modelReaderT++instance (ReaderM z m, Functor m, FMonadT t) => ReaderM z (t m) where+ readerModel = liftModel readerModel++ask :: ReaderM z m => m z+ask = askX readerModel++local :: ReaderM z m => (z -> z) -> m a -> m a+local = localX readerModel++------------------------------------------------------------------+-- Throw and Handle+class Monad m => ExcM z m | m -> z where+ throwModel :: AlgModel (ThrowOp z) m+ handleModel :: Model (HandleOp z) m++instance Monad m => ExcM z (ExcT z m) where+ throwModel = modelThrowExcT+ handleModel = modelHandleExcT++instance ExcM SomeException IO where+ throwModel = modelThrowIO+ handleModel = modelHandleIO++instance (ExcM z m, Functor m, FMonadT t) => ExcM z (t m) where+ throwModel = liftAlgModel throwModel+ handleModel = liftModel handleModel++throw :: ExcM z m => z -> m a+throw = throwX throwModel++handle :: ExcM z m => m a -> (z -> m a) -> m a+handle = handleX handleModel++------------------------------------------------------------------+-- callCC operation++class Monad m => ContM r m | m -> r where+ contModel :: AlgModel (ContOp r) m++instance Monad m => ContM (m r) (ContT r m) where+ contModel = modelContT++instance (ContM r m, MonadT t) => ContM r (t m) where+ contModel = liftAlgModel contModel++callCC :: ContM r m => ((a -> r) -> a) -> m a+callCC = callCCX contModel++------------------------------------------------------------------+-- MPlus operations++class Monad m => ListM m where+ listModel :: AlgModel ListOp m++instance Monad m => ListM (ListT m) where+ listModel = modelListT++instance (ListM m, MonadT t) => ListM (t m) where+ listModel = liftAlgModel listModel++mZero :: (ListM m) => m a+mZero = zeroListX listModel++mPlus :: ListM m => m a -> m a -> m a+mPlus = plusListX listModel
+ Control/Monatron/Codensity.hs view
@@ -0,0 +1,36 @@+{-# OPTIONS -XRank2Types #-}++module Control.Monatron.Codensity (+ Codensity,+ codensity,+ runCodensity+) where++import Control.Monatron.MonadT+import Control.Monad.Fix+import Control.Monatron.AutoInstances()++----------------------------------------------------------+-- Codensity Monad+----------------------------------------------------------++newtype Codensity f a = Codensity { + unCodensity :: forall b. (a -> f b) -> f b +}++codensity :: (forall b. (a -> f b) -> f b) -> Codensity f a+codensity = Codensity++runCodensity :: Monad m => Codensity m a -> m a+runCodensity c = unCodensity c return ++instance MonadT Codensity where+ lift m = Codensity (m >>=)+ c `tbind` f = Codensity (\k -> unCodensity c (\a -> unCodensity (f a) k))++-- still need to prove that MonadFix laws hold+instance MonadFix m => MonadFix (Codensity m) where+ mfix f = Codensity $ \k -> mfix (runCodensity. f) >>= k++------------------------+
+ Control/Monatron/IdT.hs view
@@ -0,0 +1,13 @@+module Control.Monatron.IdT where ++import Control.Monatron.Monatron++newtype IdT m a = IdT { runIdT :: m a }++instance MonadT IdT where+ lift = IdT+ tbind m f = IdT $ runIdT m >>= runIdT . f + +instance FMonadT IdT where+ tmap' d1 _d2 g f = IdT . f . fmapD d1 g . runIdT+
+ Control/Monatron/Monad.hs view
@@ -0,0 +1,67 @@++module Control.Monatron.Monad (+ State, Writer, Reader, Exception, Cont,+ state,writer,reader,exception,cont,+ runState, runWriter, runReader, runException, runCont,+ Id(..), Lift(..)+) where+ ++import Control.Monatron.Transformer+import Control.Monad+import Control.Monad.Fix++newtype Id a = Id {runId :: a}+data Lift a = L {runLift :: a}++type State s = StateT s Id+type Writer w = WriterT w Id+type Reader r = ReaderT r Id+type Exception x = ExcT x Id+type Cont r = ContT r Id++state :: (s -> (a, s)) -> State s a+state st = stateT $ \s -> Id $ st s++runState :: s -> State s a -> (a,s)+runState s = runId. runStateT s++writer :: Monoid w => (a,w) -> Writer w a+writer = writerT . Id++runWriter :: Monoid w => Writer w a -> (a,w)+runWriter = runId. runWriterT++reader :: (r -> a) -> Reader r a+reader e = readerT $ \r -> Id (e r)++runReader :: r -> Reader r a -> a+runReader r = runId . runReaderT r++exception :: Either x a -> Exception x a+exception = excT . Id++runException :: Exception x a -> Either x a+runException = runId. runExcT++cont :: ((a -> r) -> r) -> Cont r a+cont c = contT $ \k -> Id $ c (runId . k)++runCont :: (a -> r) -> Cont r a -> r+runCont k = runId. runContT (Id. k)++instance Monad Id where+ return = Id+ fail = error+ m >>= f = f (runId m)++instance Monad Lift where+ return x = L x+ fail x = error x+ L x >>= k = k x++instance Functor Id where fmap = liftM+instance Functor Lift where fmap = liftM++instance MonadFix Id where mfix f = let m = f (runId m) in m+instance MonadFix Lift where mfix f = let m = f (runLift m) in m
+ Control/Monatron/MonadInfo.hs view
@@ -0,0 +1,74 @@+{-# LANGUAGE FlexibleInstances #-}+-- {-# LANGUAGE OverlappingInstances #-}+{-# LANGUAGE TypeOperators #-}++module Control.Monatron.MonadInfo (+ MInfo(..), MonadInfo(minfo), MonadInfoT(tminfo),+ miInc+) where++import Control.Monatron.Monad+import Control.Monatron.MonadT+import Control.Monatron.IdT+import Control.Monatron.Transformer+import Control.Monatron.Zipper+import Control.Monatron.Codensity++import Data.Map (Map)+import qualified Data.Map as Map++newtype MInfo = MInfo (Map String Int)+ deriving (Show, Eq, Ord)++miBase = MInfo Map.empty++miInc s (MInfo m) = MInfo $ Map.alter (\x -> case x of { Nothing -> Just 1; Just n -> Just (n+1) }) s m++undef :: a+undef = error "MonadInfo: undefined"++class Monad m => MonadInfo m where+ minfo :: m a -> MInfo++class MonadT t => MonadInfoT t where+ tminfo :: MonadInfo m => t m a -> MInfo++instance MonadInfoT (StateT s) where+ tminfo x = miInc "StateT" (minfo $ runStateT (undef :: s) x)++instance Monoid w => MonadInfoT (WriterT w) where+ tminfo x = miInc "WriterT" (minfo $ runWriterT x)++instance MonadInfoT (ReaderT s) where+ tminfo x = miInc "ReaderT" (minfo $ runReaderT (undef :: s) x)++instance MonadInfoT (ExcT x) where+ tminfo x = miInc "ExcT" (minfo $ runExcT x)++instance MonadInfoT (ContT x) where+ tminfo x = miInc "ContT" (minfo $ runContT (undef) x)++instance MonadInfoT ListT where+ tminfo x = miInc "ListT" (minfo $ runListT x)++instance Functor f => MonadInfoT (StepT f) where+ tminfo x = miInc "StepT" (minfo $ runStepT x)++instance (MonadInfoT t1, MonadInfoT t2) => MonadInfoT (t1 :> t2) where+ tminfo x = miInc ":>" (minfo $ runZipper x)++instance MonadInfoT Codensity where+ tminfo x = miInc "Codensity" (minfo $ runCodensity x)++instance MonadInfo Id where+ minfo _ = miInc "Id" miBase++instance MonadInfo Lift where+ minfo _ = miInc "Lift" miBase++instance MonadInfoT IdT where+ tminfo x = miInc "IdT" (minfo $ runIdT x)++instance (MonadInfo m, MonadInfoT t) => MonadInfo (t m) where+ minfo x = tminfo x+
+ Control/Monatron/MonadT.hs view
@@ -0,0 +1,47 @@+{-# OPTIONS -XRank2Types #-}++module Control.Monatron.MonadT (+ MonadT(..), FMonadT(..), MMonadT(..), FComp(..), FunctorD(..), tmap, mtmap,+ module Control.Monad+) where++import Control.Monad+++----------------------------------------------------------+-- Class of monad transformers with +-- a lifting of first-order operations+----------------------------------------------------------++class MonadT t where+ lift :: Monad m => m a -> t m a+ treturn :: Monad m => a -> t m a+ treturn = lift. return+ tbind :: Monad m => t m a -> (a -> t m b) -> t m b++newtype FunctorD f = FunctorD {fmapD :: forall a b . (a -> b) -> f a -> f b}++functor :: Functor f => FunctorD f+functor = FunctorD fmap++class MonadT t => FMonadT t where+ tmap' :: FunctorD m -> FunctorD n -> (a -> b) -> (forall x. m x -> n x) -> t m a -> t n b+ +tmap :: (FMonadT t, Functor m, Functor n) => (forall b. m b -> n b) -> t m a -> t n a+tmap = tmap' functor functor id++mtmap :: FMonadT t => FunctorD f -> (a -> b) -> t f a -> t f b+mtmap fd f = tmap' fd fd f id++class FMonadT t => MMonadT t where+ flift :: Functor f => f a -> t f a --should coincide with lift!+ monoidalT :: (Functor f, Functor g) => t f (t g a) -> t (FComp f g) a ++----------------------------------------+-- Functor Composition+----------------------------------------+ +newtype (FComp f g) a = Comp {deComp :: (f (g a)) }++instance (Functor f, Functor g) => Functor (FComp f g) where+ fmap f (Comp fga) = Comp (fmap (fmap f) fga)
+ Control/Monatron/Monatron.hs view
@@ -0,0 +1,12 @@++module Control.Monatron.Monatron (+ module Control.Monatron.Monad,+ module Control.Monatron.AutoLift,+ version+)where++import Control.Monatron.Monad+import Control.Monatron.AutoLift++version :: (Int,Int,Int)+version = (0,0,1)
+ Control/Monatron/Open.hs view
@@ -0,0 +1,52 @@+{-# OPTIONS -fglasgow-exts -XNoMonomorphismRestriction -XOverlappingInstances #-}++module Control.Monatron.Open where++import Control.Monatron.Monatron ()+import Control.Monatron.AutoLift++infixr 9 :+:+infixr 9 <@>++data (:+:) f g a = Inl (f a) | Inr (g a)++newtype Fix f = In {out :: f (Fix f)}++type Open e f r = (e -> r) -> (f e -> r)++(<@>) :: Open e f r -> Open e g r -> Open e (f :+: g) r+evalf <@> evalg = \eval e -> + case e of+ Inl el -> evalf eval el+ Inr er -> evalg eval er + +fix :: Open (Fix f) f r -> (Fix f -> r)+fix f = let this = f this . out + in this+ +-- Borrowed from Data types \`a la Carte++class (f :<: g) where+ inj :: f a -> g a+ +instance Functor f => (:<:) f f where+ inj = id+ +instance (Functor g, Functor f) + => (:<:) f (f :+: g) where+ inj = Inl+ +instance (Functor g, Functor h, Functor f, f :<: g) + => (:<:) f (h :+: g) where + inj = Inr . inj++inject :: (f :<: g) => f (Fix g) -> Fix g+inject = In . inj++instance (Functor f, Functor g) => + Functor (f :+: g) where+ fmap f (Inl x) = Inl (fmap f x)+ fmap f (Inr y) = Inr (fmap f y)+ +foldFix :: Functor f => (f a -> a) -> Fix f -> a+foldFix f = f . fmap (foldFix f) . out
+ Control/Monatron/Operations.hs view
@@ -0,0 +1,195 @@+{-# OPTIONS -XRank2Types #-}++module Control.Monatron.Operations (+ ExtModel, Model, AlgModel, toAlg, liftModel, liftAlgModel, liftExtModel, + StateOp(..), modelStateT, getX, putX,+ ReaderOp(..), modelReaderT, askX, inEnvX, localX, + WriterOp(..), modelWriterT, traceX,+ ThrowOp(..),HandleOp(..), modelThrowExcT, modelHandleExcT,+ modelThrowIO, modelHandleIO, throwX, handleX,+ ContOp(..), modelContT, callccX, callCCX, abortX,+ StepOp(..), stepX, modelStepT,+ ListOp(..), modelListT, zeroListX, plusListX,+ module Control.Monatron.Transformer+) where++import Control.Monatron.Codensity+import Control.Monatron.Transformer+import qualified Control.Exception as IO (throwIO,catch,SomeException)++-------------------------------------------------+-- Models and Standard Liftings+-------------------------------------------------+ +type ExtModel f g m = forall a. f (m (g a)) -> m a+type Model f m = forall a. f (m a) -> m a+type AlgModel f m = forall a. f a -> m a++toAlg :: (Functor f, Monad m) => Model f m -> AlgModel f (Codensity m)+toAlg op t = codensity $ \k -> op (fmap k t)++liftModel :: (Functor f, Monad m, Functor m, FMonadT t, Monad (t (Codensity m))) => + Model f m -> Model f (t m)+liftModel op = tmap runCodensity . join . lift . toAlg op . fmap (tmap lift)++liftAlgModel :: (MonadT t, Monad m, Functor f) => AlgModel f m -> AlgModel f (t m)+liftAlgModel op = lift . op++liftExtModel :: ( Functor f, Functor g, Monad m, Functor m, + MMonadT t, Functor (t f), Functor (t m)) => + ExtModel f g m -> ExtModel f g (t m)+liftExtModel op = tmap (op . fmap deComp . deComp) . + monoidalT . flift . fmap (monoidalT . fmap flift) + +----------------------+-- State Operations+----------------------+ +data StateOp s a = Get (s -> a) | Put s a++instance Functor (StateOp s) where+ fmap f (Get g) = Get (f . g)+ fmap f (Put s a) = Put s (f a)++modelStateT :: Monad m => AlgModel (StateOp s) (StateT s m)+modelStateT (Get g) = stateT (\s -> return (g s, s))+modelStateT (Put s a) = stateT (\_ -> return (a, s))++getX :: Monad m => AlgModel (StateOp s) m -> m s+getX op = op $ Get id++putX :: Monad m => AlgModel (StateOp s) m -> s -> m ()+putX op s = op $ Put s ()+ +----------------------+-- Reader Operations+----------------------+ +data ReaderOp s a = Ask (s -> a) | InEnv s a++instance Functor (ReaderOp s) where+ fmap f (Ask g) = Ask (f . g)+ fmap f (InEnv s a) = InEnv s (f a)++modelReaderT :: Monad m => Model (ReaderOp s) (ReaderT s m)+modelReaderT (Ask g) = readerT (\s -> runReaderT s (g s))+modelReaderT (InEnv s a) = readerT (\_ -> runReaderT s a)++askX :: Monad m => Model (ReaderOp s) m -> m s+askX op = op $ Ask return++inEnvX :: Monad m => Model (ReaderOp s) m -> s -> m a -> m a+inEnvX op s m = op $ InEnv s m + +--derived++localX :: Monad m => Model (ReaderOp z) m -> (z -> z) -> m a -> m a+localX m f t = do z <- askX m+ inEnvX m (f z) t++------------------------+-- Exception Operations+------------------------+ +data ThrowOp x a = Throw x+data HandleOp x a = Handle a (x -> a)++instance Functor (ThrowOp x) where+ fmap _ (Throw x) = Throw x++instance Functor (HandleOp x) where+ fmap f (Handle a h) = Handle (f a) (f . h)++modelThrowExcT :: Monad m => AlgModel (ThrowOp x) (ExcT x m)+modelThrowExcT (Throw x) = excT (return (Left x))++modelHandleExcT :: Monad m => Model (HandleOp x) (ExcT x m)+modelHandleExcT (Handle m h) = excT (runExcT m >>= \exa -> case exa of+ Left x -> runExcT (h x)+ Right a -> return (Right a))++modelThrowIO :: AlgModel (ThrowOp IO.SomeException) IO+modelThrowIO (Throw x) = IO.throwIO x++modelHandleIO :: Model (HandleOp IO.SomeException) IO+modelHandleIO (Handle m h) = IO.catch m h++throwX :: Monad m => AlgModel (ThrowOp x) m -> x -> m a+throwX op x = op $ Throw x++handleX :: Monad m => Model(HandleOp x) m -> m a -> (x -> m a) -> m a+handleX op m h = op $ Handle m h+ +------------------------+-- Writer Operations+------------------------+ +data WriterOp w a = Trace w a++instance Functor (WriterOp w) where+ fmap f (Trace w a) = Trace w (f a)++modelWriterT :: (Monad m, Monoid w) => AlgModel (WriterOp w) (WriterT w m)+modelWriterT (Trace w a) = writerT (return (a,w))++traceX :: (Monad m) => AlgModel (WriterOp w) m -> w -> m ()+traceX op w = op $ Trace w ()+ +--------------------------+-- Continuation Operations+--------------------------+ +data ContOp r a = Abort r | CallCC ((a -> r) -> a)++instance Functor (ContOp r) where+ fmap _ (Abort r) = Abort r+ fmap f (CallCC k) = CallCC (\c -> f (k (c . f)))++modelContT :: Monad m => AlgModel (ContOp (m r)) (ContT r m)+modelContT (Abort mr) = contT $ \_ -> mr+modelContT (CallCC k) = contT $ \c -> c (k c)++abortX :: Monad m => AlgModel (ContOp r) m -> r -> m a+abortX op r = op (Abort r)++callCCX :: Monad m => AlgModel (ContOp r) m -> ((a -> r) -> a) -> m a+callCCX op f = op (CallCC f)++callccX :: Monad m => AlgModel (ContOp r) m -> ((a -> m b) -> m a) -> m a+callccX op f = join $ callCCX op (\k -> f (\x -> abortX op (k (return x)))) + +--------------------------+-- Step Operations+--------------------------+ +newtype StepOp f x = StepOp (f x)++instance (Functor f) => Functor (StepOp f) where + fmap h (StepOp fa) = StepOp (fmap h fa)++modelStepT :: (Functor f, Monad m) => Model (StepOp f) (StepT f m)+modelStepT (StepOp fa) = stepT (return (Right fa))++stepX :: (Monad m) => Model (StepOp f) m -> f (m x) -> m x+stepX op = op . StepOp + +--------------------------+-- List Operations+--------------------------+ +data ListOp a = ZeroList | PlusList a a++instance Functor ListOp where+ fmap _ ZeroList = ZeroList+ fmap f (PlusList a b) = PlusList (f a) (f b)++modelListT :: Monad m => AlgModel ListOp (ListT m)+modelListT ZeroList = emptyL+modelListT (PlusList t u) = appendL (return t) (return u)++zeroListX :: Monad m => AlgModel ListOp m -> m a+zeroListX op = op ZeroList++plusListX :: Monad m => AlgModel ListOp m -> m a -> m a -> m a+plusListX op t u = join $ op (PlusList t u)+
+ Control/Monatron/Transformer.hs view
@@ -0,0 +1,286 @@+{-# LANGUAGE ScopedTypeVariables #-}++module Control.Monatron.Transformer (+ StateT, stateT, runStateT,+ WriterT, writerT, runWriterT,+ ReaderT, readerT, runReaderT,+ ExcT, excT, runExcT,+ ContT, contT, runContT,+ StepT, stepT, runStepT, caseStepT, unfoldStepT,+ ListT, listT, runListT, foldListT, collectListT, emptyL, appendL,+-- module Monatron.Operations,+ module Control.Monatron.MonadT,+ module Data.Monoid+) where++--import Monatron.Operations+import Control.Monad.Fix+import Control.Monatron.MonadT+-- for Writer+import Data.Monoid+-- for Error (and Reader?)+--import Monatron.Codensity+import Control.Monatron.AutoInstances()++--State Monad Transformer+newtype StateT s m a = S { unS :: s -> m (a,s) }++stateT :: (s -> m (a, s)) -> StateT s m a+stateT = S++runStateT :: s -> StateT s m a -> m (a,s) +runStateT s m = unS m s++instance MonadT (StateT s) where+ lift m = S $ \s -> m >>= \a -> return (a,s)+ m `tbind` k = S $ \s -> unS m s >>= \ ~(a, s') -> unS (k a) s'++instance (MonadFix m) => MonadFix (StateT s m) where+ mfix f = S $ \s -> mfix (runStateT s . f . fst)++instance FMonadT (StateT s) where+ tmap' d1 _d2 g f (S m) = S (f . fmapD d1 (\(x,s) -> (g x,s)) . m)++instance MMonadT (StateT s) where+ flift t = S (\s -> fmap (\a -> (a,s)) t)+ monoidalT (S t) = S (\s -> Comp $ fmap (\(S t',s') -> t' s') (t s))++{-+-- StateT implementation of operations+withStateT :: Monad m => Fop (With s) (StateT s m)+withStateT (With f) = S $ \s -> runStateT s (f s)++makeStateT :: Monad m => Fop (Make s) (StateT s m)+makeStateT (Make (m,s)) = S $ \_ -> runStateT s m+-}++--------------------------------------------------------------+-- Writer Monad Transformer++newtype WriterT w m a = W {unW :: m (a,w) } ++writerT :: (Monoid w, Monad m) => m (a,w) -> WriterT w m a+writerT = W++runWriterT :: (Monoid w) => WriterT w m a -> m (a,w)+runWriterT = unW+ +instance Monoid w => MonadT (WriterT w) where + tbind (W m) f = W (do (a,w) <- m+ (a',w') <- unW (f a)+ return (a',w `mappend` w'))+ lift m = W (liftM (\a -> (a,mempty)) m)++{-+instance (MonadFix m, Monoid w) => MonadFix (WriterT w m) where+ mfix f = W $ mfix (unW. f) +-}++instance Monoid w => FMonadT (WriterT w) where+ tmap' d1 _d2 g f = W . f . fmapD d1 (\(x,s) -> (g x,s)) . unW++instance Monoid w => MMonadT (WriterT w) where+ flift t = W (fmap (\a -> (a,mempty)) t)+ monoidalT (W t) = W $ Comp $ fmap (\(W t',w) -> + fmap (\(a,w') -> (a,w `mappend` w')) t') $ t++{-+-- WriterT implementation of operations+withWriterT :: (Monoid w, Monad m) => Fop (With w) (WriterT w m)+withWriterT (With c) = W $ S $ \w -> runWriterT (c w)+++makeWriterT :: (Monoid w, Monad m) => Fop (Make w) (WriterT w m)+makeWriterT (Make (m, w)) = writerT $ runWriterT m >>= \(a,w') -> + return (a,w' `mappend` w)+-}+--------------------------------------------------------------+-- Reader Monad Transformer+newtype ReaderT s m a = R { unR :: s -> m a }++runReaderT :: s -> ReaderT s m a -> m a+runReaderT s m = unR m s++instance MonadT (ReaderT s) where+ tbind m k = R (\s -> unR m s >>= \a -> unR (k a) s)+ lift m = R (\_ -> m)++readerT :: Monad m => (e -> m a) -> ReaderT e m a+readerT = R++{-+instance (MonadFix m) => MonadFix (ReaderT w m) where+ mfix f = R $ mfix (unR. f) +-}++instance FMonadT (ReaderT s) where+ tmap' d1 _d2 g f (R m) = R (f . fmapD d1 g . m)++instance MMonadT (ReaderT s) where+ flift t = R (\_ -> t)+ monoidalT (R t) = R (\s -> Comp $ fmap (($ s) . unR) (t s))++{-+-- ReaderT implementation of operations+makeReaderT :: Monad m => Fop (Make e) (ReaderT e m)+makeReaderT = R . makeStateT . fmap unR++withReaderT :: Monad m => Fop (With e) (ReaderT e m)+withReaderT = R . withStateT . fmap unR+-}+--------------------------------------------------------------+-- Exceptions Monad Transformer+newtype ExcT x m a = X {unX :: m (Either x a)}++excT :: Monad m => m (Either x a) -> ExcT x m a+excT = X++runExcT :: Monad m => ExcT x m a -> m (Either x a)+runExcT = unX+--+instance (MonadFix m) => MonadFix (ExcT x m) where+ mfix f = X $ mfix (unX . f . fromRight)+ where fromRight (Right a) = a+ fromRight _ = error "ExceptionT: mfix looped."+++--+instance MonadT (ExcT x) where+ lift m = X (liftM Right m)+ (X m) `tbind` f = X (do a <- m+ case a of+ Left x -> return (Left x)+ Right b -> unX (f b))+++instance FMonadT (ExcT x) where+ tmap' d1 _d2 g f = X . f . fmapD d1 func . unX where+ func (Left x) = Left x+ func (Right y) = Right (g y)++{-+-- internal operations+throwExcT :: Monad m => Fop (Throw x) (ExcT x m)+throwExcT (Throw x) = X $ return (Left x)+--+handleExcT :: Monad m => Fop (Handle x) (ExcT x m)+handleExcT (Handle (m, h)) = X (unX m >>= \exa ->+ case exa of+ Left x -> unX (h x)+ Right a -> return (Right a))++-- Instances of the operations for IO exceptions+throwIO :: Fop (Throw IO.SomeException) IO+throwIO (Throw x) = IO.throwIO x+--+handleIO :: Fop (Handle IO.SomeException) IO+handleIO (Handle (m, h)) = IO.catch m h+-}++--------------------------------------------------------------+-- Continuations Monad Transformer++newtype ContT r m a = C {unC :: (a -> m r) -> m r}++runContT :: (a -> m r) -> ContT r m a -> m r+runContT = flip unC++contT :: ((a -> m r) -> m r) -> ContT r m a+contT = C++instance MonadT (ContT r) where+ lift m = C (m >>=)+ m `tbind` k = C $ \c -> unC m (\a -> unC (k a) c)++{-+callCCContT :: Monad m => Fop (CallCC (m r)) (ContT r m)+callCCContT (CallCC f) = C $ \k -> unC (f (\a -> unC a k)) k++abortContT :: Monad m => Fop (Abort (m r)) (ContT r m)+abortContT (Abort mr) = C $ \_ -> mr+-}+--------------------------------------------------------------+-- List monad transformer++data LSig f a b = NilT b+ | ConsT a (f a)++newtype ListT m a = L {unL :: m (LSig (ListT m) a ())}++runListT :: ListT m a -> m (LSig (ListT m) a ())+runListT = unL++listT :: m (LSig (ListT m) a ()) -> ListT m a+listT = L++emptyL :: Monad m => ListT m a+emptyL = L $ return $ NilT ()++appendL :: Monad m=> ListT m a -> ListT m a -> ListT m a+appendL (L m1) (L m2) = L $ do+ l <- m1+ case l of+ NilT () -> m2+ ConsT a l1 -> return (ConsT a (appendL l1 (L m2)))++foldListT :: Monad m => (a -> m b -> m b) -> m b -> ListT m a -> m b+foldListT c n (L m) = do l <- m + case l of + NilT () -> n + ConsT a l1 -> c a (foldListT c n l1)++collectListT :: Monad m => ListT m a -> m [a]+collectListT lt = foldListT (\a m -> m >>= return. (a:)) (return []) lt++instance MonadT ListT where+ lift m = L $ liftM (`ConsT` emptyL) m+ m `tbind` f = L $ foldListT (\a l -> unL $ f a `appendL` L l)+ (return $ NilT ())+ m++instance FMonadT ListT where+ tmap' d1 d2 g t (L m) = L $ t $ fmapD d1 (\lsig -> case lsig of+ NilT () -> NilT ()+ ConsT a l -> ConsT (g a) (tmap' d1 d2 g t l)) m++{-+mZeroListT :: Monad m => Fop MZero (ListT m)+mZeroListT (MZero _) = emptyL ++mPlusListT :: (Monad m) => Fop MPlus (ListT m)+mPlusListT (MPlus (a, b)) = appendL a b+-}+------------------------------------------------+-- Step Monad Transformer+------------------------------------------------+ +newtype StepT f m x = T {runT :: m (Either x (f (StepT f m x)))}++stepT :: m (Either x (f (StepT f m x))) -> StepT f m x+stepT = T++runStepT :: StepT f m x -> m (Either x (f (StepT f m x)))+runStepT = runT++{-+instance (Functor f, Monad m) => Monad (StepT f m) where+ return = treturn+ (>>=) = tbind+-}++--instance (Functor f, Monad m) => Functor (StepT f m) where fmap = liftM++caseStepT :: (Functor f, Monad m) => + (a -> StepT f m x) -> (f (StepT f m a) -> StepT f m x)+ -> StepT f m a -> StepT f m x+caseStepT v c (T m) = T (m >>= either (runT . v) (runT . c))++unfoldStepT :: (Functor f, Monad m) => (y -> m (Either x (f y))) -> y -> StepT f m x+unfoldStepT k y = T (liftM (fmap (fmap (unfoldStepT k))) (k y))++instance (Functor f) => MonadT (StepT f) where+ tbind t f = caseStepT f (T . return . Right . fmap (`tbind` f)) t+ lift = T . liftM Left++instance (Functor f) => FMonadT (StepT f) where+ tmap' d1 d2 g t (T m) = T (t (fmapD d1 (either (Left . g) (Right . fmap (tmap' d1 d2 g t))) m))
+ Control/Monatron/Zipper.hs view
@@ -0,0 +1,118 @@+{-# OPTIONS -fglasgow-exts -XNoMonomorphismRestriction #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE OverlappingInstances #-}+{-# LANGUAGE UndecidableInstances #-}+{-# LANGUAGE RankNTypes #-}++module Control.Monatron.Zipper where++import Control.Monatron.MonadT ()+import Control.Monatron.IdT ()+import Control.Monatron.AutoLift +import Control.Monatron.Operations+import Control.Monatron.Monad ()+-- import Monatron.AutoInstances()++newtype (t1 :> (t2 :: (* -> *) -> * -> *)) m a = L { runL :: t1 (t2 m) a }++runZipper :: (t1 :> t2) m a -> t1 (t2 m) a+runZipper = runL++zipper :: t1 (t2 m) a -> (t1 :> t2) m a +zipper = L++-- * Relative Navigation++-- | shift focus to left+leftL :: (t1 :> t2) m a -> t1 (t2 m) a+leftL = runL++-- | shift focus to right+rightL :: t1 (t2 m) a -> (t1 :> t2) m a+rightL = L ++-- The zipper is an FMonadT and a MonadT++instance (FMonadT t1, FMonadT t2) => FMonadT (t1 :> t2) where+ tmap' d1 d2 g f = + L . tmap' (FunctorD (mtmap d1)) (FunctorD (mtmap d2)) g (tmap' d1 d2 id f) . runL++instance (MonadT t1, MonadT t2) => MonadT (t1 :> t2) where+ lift = L . lift . lift+ tbind m f = L $ runL m >>= runL . f+ +-- Instances of the zipper for the various effects+ +instance (Monad m, MonadT t1, MonadT t2, StateM z (t2 m)) => StateM z ((t1 :> t2) m) where+ stateModel = L . liftAlgModel stateModel+ +instance (WriterM z (t2 m), MonadT t1, Monad m, MonadT t2) => WriterM z ((t1 :> t2) m) where+ writerModel = L . liftAlgModel writerModel++instance (ReaderM z (t2 m), FMonadT t1, FMonadT t2, Functor (t2 m), Monad m) => + ReaderM z ((t1 :> t2) m) where + readerModel = L . liftModel readerModel . fmap runL + +instance (ExcM z (t2 m), FMonadT t1, FMonadT t2, Functor (t2 m), Monad m) => + ExcM z ((t1 :> t2) m) where+ throwModel = L . liftAlgModel throwModel+ handleModel = L . liftModel handleModel . fmap runL + +instance (ContM r (t2 m), FMonadT t1, FMonadT t2, Functor (t2 m), Monad m) => + ContM r ((t1 :> t2) m) where+ contModel = L . liftAlgModel contModel+ +instance (ListM (t2 m), FMonadT t1, FMonadT t2, Functor (t2 m), Monad m) => + ListM ((t1 :> t2) m) where+ listModel = L . liftAlgModel listModel+ +-- runtest :: (((),Int),Int)+-- runtest = runState 0 $ runStateT 0 $ runZipper (put 3)++-- Views and masks; could be in a different file+ +data (:><:) m n = View {+ to :: forall a . m a -> n a,+ from :: forall a . n a -> m a+}++i :: m :><: m+i = View id id++o :: (Monad m, MonadT t1, MonadT t2) => t1 (t2 m) :><: (t1 :> t2) m+o = View rightL leftL++vlift :: (FMonadT t, Functor m, Functor n) + => (m :><: n) -> (t m :><: t n)+vlift v = View (tmap (to v)) (tmap (from v))+++hcomp :: (n :><: o) -> (m :><: n) -> (m :><: o)+v2 `hcomp` v1 = View (to v2 . to v1) (from v1 . from v2)++vcomp :: (Functor m1, Functor m2, FMonadT t) + => (t m2 :><: m3) -> (m1 :><: m2) -> (t m1 :><: m3)+v2 `vcomp` v1 = v2 `hcomp` (vlift v1)++-- program :: StateM Int m => m Int+-- program = put 3 >> return 4++-- t = runState 1 $ runStateT 0 $ runIdT $ runIdT $ view i program++r :: Monad m => StateT s m :><: ReaderT s m+r = View {+ to = \s -> readerT (\e -> liftM fst $ runStateT e s),+ from = \e -> stateT (\s -> liftM (\x -> (x,s)) $ runReaderT s e)+}++stateIso :: Monad m => (s1 -> s2) -> (s2 -> s1) -> StateT s1 m :><: StateT s2 m+stateIso f fm1 = View {to = iso f fm1, from = iso fm1 f } where + iso g h m = stateT $ \s2 -> do (a, s1) <- runStateT (h s2) m+ return (a, g s1)+ +getv :: StateM s n => (m :><: n) -> m s+getv var = from var get ++putv :: StateM s n => (m :><: n) -> s -> m ()+putv var = from var . put
+ Control/Monatron/ZipperExamples.hs view
@@ -0,0 +1,83 @@+{-# OPTIONS -XTypeOperators -XFlexibleContexts #-}++module Control.Monatron.ZipperExamples where++import Control.Monatron.Monatron+import Control.Monatron.Zipper+import Control.Monatron.Open++-- Don't we need a bidirectional view to implement this combinator?++fmask :: (m :><: n) -> Open e f (n a) -> Open e f (m a)+fmask v evalf eval = from v . evalf (to v . eval)++type Env = [(String,Int)]++type Count = Int++data Mem e = Store e | Retrieve++type Reg = Int+ +evalMem2 :: (StateM Reg (t m), StateM Count m, MonadT t) + => Open e Mem (t m Int)+evalMem2 eval (Store e) =+ do count <- lift $ get+ lift $ put (count + 1)+ n <- eval e+ put n+ return n+evalMem2 eval Retrieve = lift $ get++type M4 = StateT Reg (StateT Env (ExcT String (StateT Count Id)))++data Lit a = Lit Int+data Var a = Var String+data Add e = Add e e++instance Functor Lit where+ fmap _ (Lit l) = Lit l++instance Functor Var where+ fmap _ (Var v) = Var v++instance Functor Add where+ fmap f (Add e1 e2) = Add (f e1) (f e2)+ +instance Functor Mem where+ fmap f (Store x) = Store (f x)+ fmap f Retrieve = Retrieve+ +lit :: (Lit :<: g) => Int -> Fix g+lit l = inject (Lit l)++var :: (Var :<: g) => String -> Fix g +var v = inject (Var v)++add :: (Add :<: g) => Fix g -> Fix g -> Fix g+add e1 e2 = inject (Add e1 e2)++store :: (Mem :<: g) => Fix g -> Fix g+store e = inject (Store e)++retrieve :: (Mem :<: g) => Fix g+retrieve = inject Retrieve++type Expr3 = Fix (Mem :+: Var :+: Lit)++evalLit _ (Lit n) = return n ++evalVar _ (Var v) = do env <- get+ case lookup v env of+ Just n -> return n+ Nothing -> throw "undefined variable"++eval4 :: Expr3 -> M4 Int+eval4 = fix ( fmask (i `vcomp` o `vcomp` o) evalMem2+ <@> fmask o evalVar + <@> evalLit)+ +test = runId $ runStateT 0 $ handleExc $ runStateT [] $ runStateT 0 $ eval4 (store (lit 3))++handleExc :: Monad m => ExcT a m b -> m b+handleExc = liftM (either (error "Error!") id) . runExcT
+ Control/Search/Combinator/And.hs view
@@ -0,0 +1,143 @@+{-# LANGUAGE FlexibleContexts #-}++module Control.Search.Combinator.And (andN,(<&>)) where++import Maybe (fromMaybe, catMaybes, fromJust)++import Control.Search.Language+import Control.Search.GeneratorInfo+import Control.Search.Memo+import Control.Search.MemoReader+import Control.Search.Generator++import Control.Search.Combinator.Success++import Control.Monatron.Monatron hiding (Abort, L, state, cont)+import Control.Monatron.Zipper hiding (i,r)+import Control.Monatron.IdT++seqNLoop :: (ReaderM Int m, Evalable m) => Int -> [Eval m] -> Eval m+seqNLoop uid lst = commentEval $+ Eval { structs = (foldr1 (@++@) $ map (structs) lst) @++@ mystructs + , toString = "seqN" ++ show uid ++ "(" ++ (foldr1 (\x y -> x ++ "," ++ y) $ map (toString) lst) ++ ")"+ , treeState_ = [entry ("seqn_pos",Int,assign 0) -- is the first or the second search active?+ , ("seqn_union",Union [(SType (s3 i),"seq" ++ show i) | i <- [0..nbranches-1]], -- union of both tree states+ \i -> -- init nested state of first search+ let j = xpath i 0+ in initSubEvalState j (s1 0) (fs1 0)+ )]+ , initH = \i -> (local (const 0) $ inits (xsuper 0) (xpath i 0))+ , evalState_ = [("complete",Bool,const $ return true)] -- some global data+ , pushLeftH = push pushLeft+ , pushRightH = push pushRight+ , nextSameH = \i -> let j = i `withBase` "popped_estate"+ in do nd <- inSeq nextDiff i+ ns <- inSeq nextSame i+ return $ IfThenElse ((seq_pos i) @== (seq_pos j)) ns nd+ , nextDiffH = inSeq $ nextDiff+ , bodyH = \i -> + let seqBody super j pos = + do+ dr <- dec_ref "bodyE-stmt" j i pos+ bodyE super (j `onAbort` (comment "seqLoopN.bodyE" >>> dr))+ in do cb <- mapM (\x -> canBranch x >>= \b -> return (if b then 1 else 0)) {- (const $ return 1) -} lst+ let cu n | n==nbranches = 0+ cu n = (cb!!n) + cu (n+1)+ ss <- mapM (\pos -> local (const $ fromIntegral pos) $ inSeq_ seqBody i) [0..nbranches-1]+ let cc n | n==nbranches = Skip+ cc n | cu n <= 1 = if ((cb !! n) == 1) then (ss !! n) else cc (n+1)+ cc n | otherwise = IfThenElse (seq_pos i @== fromIntegral n) (ss !! n) (cc (n+1))+ return $ cc 0+ , addH = inSeq $ addE+ , failH = \i -> inSeq_ (\super j pos -> failE super j @>>>@ (dec_ref "failE" j i pos)) i+ , returnH = \i -> numSwitch (\n -> if (n<nbranches-1)+ then do let j1 = xpath i n+ j2o = xpath i (n+1)+ dr <- dec_ref "returnE-j2A" j2o i (n+1)+ let j2 = j2o `onCommit` dr+ j2b = resetCommit j2+ action <- local (const $ n+1) $ do stmt1 <- inits (xsuper (n+1)) j2b+ stmt2 <- startTryE (xsuper (n+1)) j2b+ init <- initSubEvalState j2b (s1 $ n+1) (fs1 $ n+1)+ dr2 <- dec_ref "returnE-j1" j1 i n+ return ( comment ("Switching from branch" ++ show n ++ " to branch" ++ show (n+1))+ >>> dr2+ >>> (seq_pos i <== fromIntegral (n+1))+ >>> init >>> stmt1 >>> stmt2)+ returnE (xsuper n) $ j1 `withCommit` const action+ else do let j2o = xpath i n+ dr3 <- dec_ref "returnE-j2B" j2o i n+ let j2 = j2o `onCommit` dr3+ returnE (xsuper n) j2+ )+-- , continue = \_ -> return true+ , tryH = \i -> inSeq_ (\super j pos -> do { dr <- dec_ref "tryE" j i pos; return (comment "seqLoop.tryE(a)") @>>>@ tryE super (j `onAbort` (comment "seqLoop.tryE(b)" >>> dr))}) i+ , startTryH = \i -> local (const 0) $ inSeq_ (\super j pos -> do { dr <- dec_ref "startTryE" j i pos; return (comment "seqLoop.startTryE(a)") @>>>@ startTryE super (j `onAbort` (comment "seqLoop.startTryE(b)" >>> dr))}) i+ , tryLH = \i -> inSeq_ (\super j pos -> tryE_ super j @>>>@ (dec_ref "tryE_" j i pos)) i+ , intArraysE = foldr1 (++) $ map (intArraysE) lst+ , boolArraysE = foldr1 (++) $ map (boolArraysE) lst+ , intVarsE = foldr1 (++) $ map (intVarsE) lst+ , deleteH = deleteMe+ , canBranch = do res <- mapM (canBranch) lst+ return $ or res+ , complete = \i -> return $ estate i @=> "complete"+-- , complete = const $ return false+ }+ where nbranches = length lst+ xsuper i = lst !! i+ mystructs = (catMaybes (map s1 [0..nbranches-1]),map s3 [0..nbranches-1])+ evalStruct side super = Just $ -- if (length (evalState_ super) == 0) then Nothing else Just $+ Struct (side ++ "EvalState" ++ show uid) $ +-- (Bool, "cont") : -- continue or not with this search + (Int, "ref_count") : -- how many active nodes of this search+ [(ty, field) | (field,ty,_) <- evalState_ super] -- fields of this search+-- needSide = \pos stm -> if (length (evalState_ (xsuper pos)) == 0) then Skip else stm+ needSide pos stm = stm+ s1 i = evalStruct ("Seq" ++ show i) (xsuper i)+ et i = maybe (THook "void") (Pointer . SType) $ s1 i+ s3 i = Struct ("Seq" ++ show i ++ "TreeState" ++ show uid) $ (case s1 i of { Nothing -> id; Just s -> ((Pointer $ SType s, "evalState"):) }) [(ty, field) | (field,ty,_) <- treeState_ (xsuper i)]+ st i = Pointer . SType $ s3 i+ xpath i n = flip withClone (\i -> inc (ref_count i)) $ withPath i (inN n) (et n) (st n)+ fs1 n = \i -> [(field,init) | (field,_ty,init) <- evalState_ (xsuper n) ]+ fs3 n = \i -> [(field,init) | (field,_ty,init) <- treeState_ (xsuper n) ]+ withSeq f = numSwitch (\n -> f (xsuper n) (inN n))+ inSeq f = \i -> numSwitch (\n -> f (xsuper n) (xpath i n))+ inSeq_ f = \i -> numSwitch (\n -> f (xsuper n) (xpath i n) n)+ push dir = \i -> inSeq_ ( \super j pos -> dir super (j `onCommit` (mkCopy i "seqn_pos"+ >>> needSide pos (mkCopy j "evalState")+ >>> needSide pos (inc (ref_count j))+ )+ )+ ) i+ initSubEvalState = \j s fs -> (case s of { Nothing -> return Skip; Just ss -> return ( (estate j <== New ss)+ >>> (ref_count j <== 1)+-- >>> (cont j <== true)+ )})+ @>>>@ inite (fs j) j+ deleteMe = \i -> inSeq_ (\super j pos -> do delrest <- deleteE super j+ dr <- dec_ref "deleteMe" j i pos+ return (delrest >>> dr)) i+-- dec_ref :: String -> Info -> Info -> Int -> Statement+ dec_ref s j i pos = complete (xsuper pos) j >>= \compl -> decrefx j pos (estate_type i,estate i) (estate_type j,estate j) (ref_count_type, ref_count j) (THook "bool", compl)+ decrefx j pos = memo "dec_ref_and" j (\(_,esti) (_,estj) (_,rcj) (_,xcl) -> return $ ((assign ((esti @=> "complete") &&& (xcl))) (esti @=> "complete") >>> + needSide pos (dec (rcj) >>> ifthen (rcj @== 0) (Delete (estj)))) {- >>> DebugValue ("completeness and" ++ show uid) (esti @=> "complete") -})+ inN n = \state -> state @-> "seqn_union" @-> ("seq" ++ show n)+ seq_pos = \i -> tstate i @-> "seqn_pos"+++andN [] = dummy+andN [s] = s+andN s =+ let sc = buildCombiner s+ in case sc of + SearchCombiner { runner = runner, elems = elems } ->+ Search { mkeval = \super -> do { ss <- extractCombiners elems $ mapE (L . mmap runL . runL) super+ ; uid <- get+ ; put $ uid+1+ ; return $ mapE (L . mmap L . runL) $ memoLoop $ seqNLoop uid ss+ }+ , runsearch = runner . rReaderT 0 . runL+ }++a <&> b = andN [a,b]+
+ Control/Search/Combinator/Base.hs view
@@ -0,0 +1,320 @@+module Control.Search.Combinator.Base (+ label+ , vlabel+ , glabel, gblabel+ , int_assign+ , ilabel+ , maxV, minV, lbV, ubV, domsizeV, lbRegretV, ubRegretV, degreeV, domSizeDegreeV, wDegreeV, domSizeWDegreeV, randomV, minD, maxD, meanD, medianD, randomD+ , foldVarSel, ifoldVarSel, bfoldVarSel, bifoldVarSel+ ) where++import Control.Search.Language+import Control.Search.GeneratorInfo+import Control.Search.Generator++import Control.Monatron.IdT++data Label m = Label + { treeStateL :: [(String,Type, Value -> Statement)]+ , leftChild_L :: [Info -> Statement]+ , rightChild_L :: [Info -> Statement]+ , addL :: Info -> m Statement+ , tryL :: Info -> m Statement+ , intArraysL :: [String]+ , boolArraysL :: [String]+ , intVarsL :: [String]+ }++v1Label var1 selVal rel e = + Label { treeStateL = [("val", Int, assign 0)+ ,("eq", Bool, assign true)]+ , leftChild_L = + [ \i -> mkUpdate i "eq" (const true)+ , \i -> mkCopy i "val" ]+ , rightChild_L =+ [ \i -> mkUpdate i "eq" (const false)+ , \i -> mkCopy i "val" ]+ , addL = \i -> return $+ IfThenElse (eq i)+ (Post (space i) (var i `rel` val i))+ (Post (space i) (neg (var i `rel` val i)))+ , tryL = \i -> returnE e (resetInfo i) >>= \ret -> -- XXX+ tryE_ e (resetInfo i) >>= \try -> -- XXX+ return $ (IfThenElse (Assigned (var i))+ ret+ (val i <== (selVal $ var i) >>> try))+ , intArraysL = []+ , boolArraysL = []+ , intVarsL = [var1]+ }+ where val i = tstate i @-> "val"+ eq i = tstate i @-> "eq"+ var i = IVar var1 (space i)+++vLabel vars selVar selVal rel e = + Label { treeStateL = [("pos", Int, assign 0)+ ,("val", Int, assign 0)+ ,("eq", Bool, assign true)]+ , leftChild_L = + [ \i -> mkUpdate i "eq" (const true)+ , \i -> mkCopy i "val"+ , \i -> mkCopy i "pos"]+ , rightChild_L =+ [ \i -> mkUpdate i "eq" (const false)+ , \i -> mkCopy i "val"+ , \i -> mkCopy i "pos"]+ , addL = \i -> return $+ IfThenElse (eq i)+ (Post (space i) (var i `rel` val i))+ (Post (space i) (neg (var i `rel` val i)))+ , tryL = \i -> returnE e (resetInfo i) >>= \ret -> -- XXX+ tryE_ e (resetInfo i) >>= \try -> -- XXX+ return $ (selVar i vars+ ret+ (val i <== (selVal $ var i) >>> try))+ , intArraysL = [vars]+ , boolArraysL = []+ , intVarsL = []+ }+ where val i = tstate i @-> "val"+ pos i = tstate i @-> "pos"+ eq i = tstate i @-> "eq"+ var i = AVarElem vars (space i) (pos i)++vbLabel vars selVar selVal rel e = + Label { treeStateL = [("pos", Int, assign 0)+ ,("val", Int, assign 0)+ ,("eq", Bool, assign true)]+ , leftChild_L = + [ \i -> mkUpdate i "eq" (const true)+ , \i -> mkCopy i "val"+ , \i -> mkCopy i "pos"]+ , rightChild_L =+ [ \i -> mkUpdate i "eq" (const false)+ , \i -> mkCopy i "val"+ , \i -> mkCopy i "pos"]+ , addL = \i -> return $+ IfThenElse (eq i)+ (Post (space i) (var i `rel` val i))+ (Post (space i) (neg (var i `rel` val i)))+ , tryL = \i -> returnE e (resetInfo i) >>= \ret -> -- XXX+ tryE_ e (resetInfo i) >>= \try -> -- XXX+ return $ (selVar i vars+ ret+ (val i <== (selVal $ var i) >>> try))+ , intArraysL = []+ , boolArraysL = [vars]+ , intVarsL = []+ }+ where val i = tstate i @-> "val"+ pos i = tstate i @-> "pos"+ eq i = tstate i @-> "eq"+ var i = BAVarElem vars (space i) (pos i)++type ValSel = Value -> Value++type VarSel = Info -> String -> Statement -> Statement -> Statement++foldVarSel metric (better, zero) i vars notfound found =+ Fold vars (tstate i) (space i) zero metric better+ >>> IfThenElse (pos i @< 0) notfound found+ where pos i = tstate i @-> "pos"++ifoldVarSel metric (better, zero) i vars notfound found =+ IFold vars (tstate i) (space i) zero metric better+ >>> IfThenElse (pos i @< 0) notfound found+ where pos i = tstate i @-> "pos"++bfoldVarSel metric (better, zero) i vars notfound found =+ BFold vars (tstate i) (space i) zero metric better+ >>> IfThenElse (pos i @< 0) notfound found+ where pos i = tstate i @-> "pos"++bifoldVarSel metric (better, zero) i vars notfound found =+ BIFold vars (tstate i) (space i) zero metric better+ >>> IfThenElse (pos i @< 0) notfound found+ where pos i = tstate i @-> "pos"+++--------------------------------------------------------------------------------+-- SEARCH TRANSFORMERS+--------------------------------------------------------------------------------++pushLeftTop e = \i -> pushLeft e (i `onCommit` mkCopy i "space" )+pushRightTop e = \i -> pushRight e (i `onCommit` mkUpdate i "space" Clone)+++baseLoop label this = return $ commentEval $ current+ where current =+ Eval { structs = ([],[])+ , treeState_ = map entry $ treeStateL label + , initH = const $ return Skip+ , evalState_ = []+ , pushLeftH = \i -> cachedCommit i @>>>@ return (seqs [f i | f <- leftChild_L label])+ , pushRightH = \i -> cachedCommit i @>>>@ return (seqs [f i | f <- rightChild_L label])+ , nextSameH = \i -> return Skip+ , nextDiffH = \i -> return Skip+ , bodyH = addE this . resetInfo -- XXX+ , addH = \i -> tryE this (resetInfo i) >>= \try -> -- XXX+ addL label i >>= \a -> + return (a >>> try)+ , failH = const $ return Skip+ , returnH = \i -> cachedCommit i+-- , continue = \_ -> return true+ , tryH = tr label+ , startTryH = tr label+ , tryLH = \i -> pushRightTop this (newinfo i "R") >>= \p2 -> + pushLeftTop this (newinfo i "L") >>= \p4 ->+ return $ (+ SHook "st->queue->push_back(TreeState());" >>>+ SHook "TreeState& nstateR = st->queue->back();" >>>+ p2 >>>+ SHook "st->queue->push_back(TreeState());" >>>+ SHook "TreeState& nstateL = st->queue->back();" >>>+ p4+ )+ , intArraysE = intArraysL label+ , boolArraysE = boolArraysL label+ , intVarsE = intVarsL label+ , deleteH = \i -> return Skip+ , toString = "base"+ , canBranch = return True+ , complete = const $ return true+ }+ where new_tstate = Var "nstate"+ tr lab i = failE this (resetInfo i) >>= \fail ->+ tryL lab i >>= \tryl ->+ return $ (SHook "Gecode::SpaceStatus status;" >>>+ (Var "status" <== VHook (rp 0 (space i) ++ "->status()")) >>>+ IfThenElse (Var "status" @== VHook "SS_FAILED") (fail >>> Delete (space i)) tryl+ )++label :: String -> (Value -> Value) -> (Value -> Value -> Value, Value) -> (Value -> Value) -> (Value -> Value -> Constraint) -> Search+label get varMeasure varComp valSel rel = + Search { mkeval = \this -> baseLoop (vLabel get (foldVarSel varMeasure varComp) valSel rel this) this + , runsearch = runIdT+ }++vlabel :: String -> (Value -> Value) -> (Value -> Value -> Constraint) -> Search+vlabel get valSel rel = + Search { mkeval = \this -> baseLoop (v1Label get valSel rel this) this + , runsearch = runIdT+ }++ilabel :: String -> (Value -> Value) -> (Value -> Value -> Value, Value) -> (Value -> Value) -> (Value -> Value -> Constraint) -> Search+ilabel get varMeasure varComp valSel rel = + Search { mkeval = \this -> baseLoop (vLabel get (ifoldVarSel varMeasure varComp) valSel rel this) this + , runsearch = runIdT+ }++int_assign :: String -> VarSel -> (Value -> Value) -> (Value -> Value -> Constraint) -> Search+int_assign get varSel valSel rel = + Search { mkeval = \this -> assignLoop (vLabel get varSel valSel rel this) this + , runsearch = runIdT+ }++glabel :: String -> VarSel -> (Value -> Value) -> (Value -> Value -> Constraint) -> Search+glabel get varSel valSel rel = + Search { mkeval = \this -> baseLoop (vLabel get varSel valSel rel this) this + , runsearch = runIdT+ }++gblabel :: String -> VarSel -> (Value -> Value) -> (Value -> Value -> Constraint) -> Search+gblabel get varSel valSel rel = + Search { mkeval = \this -> baseLoop (vbLabel get varSel valSel rel this) this + , runsearch = runIdT+ }++maxV = (Gt,IVal minBound)+minV = (Lt,IVal maxBound)++lbV = MinDom+ubV = MaxDom +domsizeV = \v -> MaxDom v - MinDom v+lbRegretV = LbRegret+ubRegretV = UbRegret+degreeV = Degree+domSizeDegreeV = \v -> domsizeV v `Div` degreeV v+wDegreeV = WDegree+domSizeWDegreeV= \v -> domsizeV v `Div` wDegreeV v+randomV = const Random++minD = MinDom+maxD = MaxDom+meanD = \v -> (maxD v + minD v) `Div` 2+medianD = \v -> Median v+randomD = \v -> (Random `Mod` (domsizeV v)) + minD v++{-+assignLoop label this = return $ commentEval $ current+ where current =+ Eval { structs = ([],[])+ , treeState_ = map entry $ treeStateL label + , initH = const $ return Skip+ , evalState_ = []+ , pushLeftH = error "assignLoop.tyE_"+ , pushRightH = error "assignLoop.tyE_"+ , nextSameH = \i -> return Skip+ , nextDiffH = \i -> return Skip+ , bodyH = addE this . resetInfo -- XXX+ , addH = \i -> tryE this (resetInfo i) >>= \try -> -- XXX+ addL label i >>= \a -> + return (a >>> try)+ , failH = const $ return Skip+ , returnH = \i -> cachedCommit i+ , tryH = returnE this . resetInfo+ , startTryH = \i -> (return $ comment "<startTryE assign>") @>>>@ (returnE this . resetInfo) i @>>>@ (return $ comment "</startTryE succes>")+ , tryLH = error "assignLoop.tryE_"+ , intArraysE = intArraysL label+ , boolArraysE = boolArraysL label+ , intVarsE = intVarsL label+ , deleteH = \i -> return Skip+ , toString = "assign"+ , canBranch = return False+ , complete = const $ return true+ }+-}+assignLoop label this = return $ commentEval $ current+ where current =+ Eval { structs = ([],[])+ , treeState_ = map entry $ treeStateL label + , initH = const $ return Skip+ , evalState_ = []+ , pushLeftH = \i -> cachedCommit i @>>>@ return (seqs [f i | f <- leftChild_L label])+ , pushRightH = \i -> cachedCommit i @>>>@ return (seqs [f i | f <- rightChild_L label])+ , nextSameH = \i -> return Skip+ , nextDiffH = \i -> return Skip+ , bodyH = addE this . resetInfo -- XXX+ , addH = \i -> tryE this (resetInfo i) >>= \try -> -- XXX+ addL label i >>= \a -> + return (a >>> try)+ , failH = const $ return Skip+ , returnH = \i -> cachedCommit i+ , tryH = tr label+ , startTryH = tr label+ , tryLH = \i -> -- pushRightTop this (newinfo i "R") >>= \p2 -> + pushLeftTop this (newinfo i "L") >>= \p4 ->+ return $ (+ -- SHook "queue->push_back(TreeState());" >>>+ -- SHook "TreeState& nstateR = queue->back();" >>>+ -- p2 >>>+ SHook "st->queue->push_back(TreeState());" >>>+ SHook "TreeState& nstateL = st->queue->back();" >>>+ p4+ )+ , intArraysE = intArraysL label+ , boolArraysE = boolArraysL label+ , intVarsE = intVarsL label+ , deleteH = \i -> return Skip+ , toString = "base"+ , canBranch = return True+ , complete = const $ return true+ }+ where new_tstate = Var "nstate"+ tr lab i = failE this (resetInfo i) >>= \fail ->+ tryL lab i >>= \tryl ->+ return $ (+ (Var "status" <== VHook (rp 0 (space i) ++ "->status()")) >>>+ IfThenElse (Var "status" @== VHook "SS_FAILED") (fail >>> Delete (space i)) tryl+ )
+ Control/Search/Combinator/Failure.hs view
@@ -0,0 +1,40 @@+module Control.Search.Combinator.Failure (failure) where++import Control.Search.Language+import Control.Search.GeneratorInfo+import Control.Search.Generator++import Control.Monatron.Monatron hiding (Abort, L, state, cont)+import Control.Monatron.IdT++failLoop uid _super = + commentEval $ Eval { structs = ([],[])+ , treeState_ = []+ , evalState_ = []+ , pushLeftH = \_ -> return Skip+ , pushRightH = \_ -> return Skip+ , nextSameH = \_ -> return Skip+ , nextDiffH = \_ -> return Skip+ , bodyH = \i -> cachedAbort i+ , addH = \_ -> return Skip+ , failH = \i -> cachedAbort i+ , returnH = \i -> cachedAbort i+-- , continue = \_ -> return true+ , tryH = \i -> cachedAbort i+ , startTryH = \i -> cachedAbort i+ , tryLH = \_ -> return Skip+ , intArraysE = []+ , intVarsE = []+ , boolArraysE = []+ , deleteH = \i -> cachedAbort i+ , initH = \_ -> return $ {- DebugOutput $ "fail" ++ show uid >>> -} Skip+ , toString = "fail" ++ show uid+ , canBranch = return False+ , complete = const $ return false+ }++failure :: Search+failure = + Search { mkeval = \super -> get >>= \uid -> return (failLoop uid super)+ , runsearch = runIdT+ }
+ Control/Search/Combinator/For.hs view
@@ -0,0 +1,115 @@+{-# LANGUAGE FlexibleContexts #-}++module Control.Search.Combinator.For (for, foreach) where++import Control.Search.Language+import Control.Search.GeneratorInfo+import Control.Search.Generator+import Control.Search.Memo+import Control.Search.MemoReader++import Data.Int++import Control.Monatron.Zipper hiding (i,r)+import Control.Monatron.Monatron hiding (Abort, L, state, cont)++forLoop :: (ReaderM Bool m, Evalable m) => Int32 -> Int -> (Eval m) -> Eval m+forLoop n uid (super) = commentEval $+ Eval + { + structs = structs super @++@ mystructs + , toString = "for" ++ show uid ++ "(" ++ show n ++ "," ++ toString super ++ ")"+ , treeState_ = treeState_ super+ , initH = \i -> initE super i @>>>@ return (parent i <== baseTstate i) @>>>@ cachedClone i (cloneBase i)+ , evalState_ = ("counter",Int,const $ return 0) : {- ("cont",Bool,const $ return true) : -} ("ref_count",Int,const $ return 1) : ("parent",THook "TreeState",const $ return Null) : evalState_ super+ , pushLeftH = push pushLeft+ , pushRightH = push pushRight+ , nextSameH = nextSame super+ , nextDiffH = nextDiff super + , bodyH = \i -> dec_ref i >>= \deref -> bodyE super (i `onAbort` deref)+ , addH = addE super+ , failH = \i -> failE super i @>>>@ dec_ref i+ , returnH = \i -> let j deref = i `onCommit` deref+ in dec_ref i >>= returnE super . j+ , tryH = \i -> do deref <- dec_ref i+ tryE super ((i `withField` ("counter", counter)) `onAbort` deref)+ , startTryH = \i -> do deref <- dec_ref i+ startTryE super ((i `withField` ("counter", counter)) `onAbort` deref)+ , tryLH = \i -> tryE_ super i @>>>@ dec_ref i+ , intArraysE = intArraysE super+ , boolArraysE = boolArraysE super+ , intVarsE = intVarsE super+ , deleteH = error "forLoop.deleteE NOT YET IMPLEMENTED"+ , canBranch = return True+ , complete = complete super+ }+ where mystructs = ([],[])+ fs1 = [(field,init) | (field,ty,init) <- evalState_ super]+ parent = \i -> estate i @=> "parent"+ counter = \i -> estate i @=> "counter"+ dec_ref = \i -> let i' = resetCommit $ i `withBase` ("for_tstate" ++ show uid)+ in do flag <- ask + if flag + then local (const False) $ do+ stmt1 <- inits super i'+ stmt2 <- startTryE super (i' `withField` ("counter", counter))+ ini <- inite fs1 i'+ cc <- cachedClone (cloneBase i) i'+ compl <- complete super i+ return (dec (ref_count i) + >>> ifthen (ref_count i @== 0) + ( inc (counter i)+ >>> comment ("forLoop: bla 1 (baseTstate i' == \"" ++ rp 0 (baseTstate i') ++ "\", ref_count i' == \"" ++ rp 0 (ref_count i') ++ "\")")+ >>> ifthen (counter i @< IVal n &&& Not compl)+ ( SHook ("TreeState for_tstate" ++ show uid ++ ";")+ >>> comment "forLoop: bla 2"+ >>> (baseTstate i' <== parent i)+ >>> comment "forLoop: bla 3"+ >>> cc+ >>> comment "forLoop: bla 4"+ >>> (ref_count i' <== 1)+ >>> comment "forLoop: bla 5"+-- >>> (cont i' <== true)+ >>> comment "forLoop: bla 6"+ >>> ini + >>> comment "forLoop: bla 7"+ >>> stmt1 + >>> comment "forLoop: bla 8"+ >>> stmt2)+ ))+ else return $ dec (ref_count i) >>> ifthen (ref_count i @== 0) (comment "Delete-forLoop-dec_ref" >>> Delete (space $ cloneBase i))+ push dir = \i -> dir super (i `onCommit` inc (ref_count i))+for+ :: Int32+ -> Search+ -> Search+for n s = + case s of+ Search { mkeval = evals, runsearch = runs } ->+ Search { mkeval =+ \super ->+ do { uid <- get+ ; put (uid + 1)+ ; s' <- evals $ mapE (L . L . mmap runL . runL) super+ ; return $ mapE (L . mmap L . runL) $ forLoop n uid (mapE runL s')+ }+ , runsearch = runs . rReaderT True . runL+ }++foreach+ :: Int32+ -> ((Info -> Value) -> Search)+ -> Search+foreach n mksearch = + case mksearch (\i -> field i "counter") of+ Search { mkeval = eval, runsearch = run } ->+ Search { mkeval = + \super ->+ do { uid <- get+ ; put (uid + 1)+ ; s' <- eval $ mapE (L . L . mmap runL . runL) super+ ; return $ mapE (L . mmap L . runL) $ forLoop n uid (mapE runL s')+ }+ , runsearch = run . rReaderT True . runL+ }+
+ Control/Search/Combinator/If.hs view
@@ -0,0 +1,151 @@+{-# LANGUAGE FlexibleContexts #-}++module Control.Search.Combinator.If (if') where++import Control.Search.Language+import Control.Search.GeneratorInfo+import Control.Search.MemoReader+import Control.Search.Generator+import Control.Search.Stat++import Control.Monatron.Monatron hiding (Abort, L, state, cont)+import Control.Monatron.Zipper hiding (i,r)++xs1 uid lsuper rsuper = Struct ("LeftEvalState" ++ show uid) $ {- (Bool, "cont") : -} (Int, "ref_count") : [(ty, field) | (field,ty,_) <- evalState_ lsuper]+xfs1 uid lsuper rsuper = [(field,init) | (field,ty,init) <- evalState_ rsuper ]+xs2 uid lsuper rsuper = Struct ("RightEvalState" ++ show uid) $ {- (Bool, "cont") : -} (Int, "ref_count") : [(ty, field) | (field,ty,_) <- evalState_ rsuper]+xfs2 uid lsuper rsuper = [(field,init) | (field,ty,init) <- evalState_ rsuper ]+xs3 uid lsuper rsuper = Struct ("LeftTreeState" ++ show uid) $ (Pointer $ SType $ xs1 uid lsuper rsuper, "evalState") : [(ty, field) | (field,ty,_) <- treeState_ lsuper]+xfs3 uid lsuper rsuper = [(field,init) | (field,ty,init) <- treeState_ lsuper]+xs4 uid lsuper rsuper = Struct ("RightTreeState" ++ show uid) $ (Pointer $ SType $ xs2 uid lsuper rsuper, "evalState") : [(ty, field) | (field,ty,_) <- treeState_ rsuper]+xfs4 uid lsuper rsuper = [(field,init) | (field,ty,init) <- treeState_ rsuper]++in1 = \state -> state @-> "if_union" @-> "if_then"+in2 = \state -> state @-> "if_union" @-> "if_else"++xpath uid lsuper rsuper i FirstS = withPath i in1 (SType $ xs1 uid lsuper rsuper) (SType $ xs3 uid lsuper rsuper)+xpath uid lsuper rsuper i SecondS = withPath i in2 (SType $ xs2 uid lsuper rsuper) (SType $ xs4 uid lsuper rsuper)++ifLoop :: (Evalable m, ReaderM SeqPos m) => Stat -> Int -> Eval m -> Eval m -> Eval m+ifLoop cond uid lsuper rsuper = commentEval $+ Eval { structs = structs lsuper @++@ structs rsuper @++@ mystructs + , toString = "if" ++ show uid ++ "(" ++ show cond ++ "," ++ toString lsuper ++ "," ++ toString rsuper ++ ")"+ , treeState_ = [("if_true", Bool,const $ return Skip),+ ("if_union",Union [(SType s3,"if_true"),(SType s4,"if_false")],const $ return Skip)+ ]+ , initH = \i -> (readStat cond >>= \r -> return (assign (r i) (tstate i @-> "if_true"))) @>>>@ initstate i+ , evalState_ = []+ , pushLeftH = push pushLeft+ , pushRightH = push pushRight+ , nextSameH = \i -> let j = i `withBase` "popped_estate"+ in do nS1 <- local (const FirstS) $ inSeq nextSame i+ nS2 <- local (const SecondS) $ inSeq nextSame i+ nD1 <- local (const FirstS) $ inSeq nextDiff i+ nD2 <- local (const SecondS) $ inSeq nextDiff i+ return $ IfThenElse (is_fst i) + (IfThenElse (is_fst j) nS1 nD1)+ (IfThenElse (is_fst j) nD2 nS2) + , nextDiffH = \i -> inSeq nextDiff i+ , bodyH = \i ->+ let f y z p = + let j = mpath i p+{- in do cond <- continue z (estate j)+ deref <- dec_ref i+ stmt <- bodyE z (j `onAbort` deref)+ return $ IfThenElse (cont j)+ (IfThenElse cond+ stmt+ ( (cont j <== false)+ >>> deref+ >>> abort j))+ (deref >>> abort j)+-}+ in dec_ref i >>= \deref -> bodyE z (j `onAbort` deref)+ in IfThenElse (is_fst i) @$ local (const FirstS) (f in1 lsuper FirstS) + @. local (const SecondS) (f in2 rsuper SecondS)+ , addH = inSeq $ addE+ , failH = \i -> inSeq failE i @>>>@ dec_ref i+ , returnH = \i -> + let j1 deref = mpath i FirstS `onCommit` deref+ j2 deref = mpath i SecondS `onCommit` deref+ in IfThenElse (is_fst i) @$ (dec_refx (j1 Skip) >>= returnE lsuper . j1) @. (dec_refx (j2 Skip) >>= returnE rsuper . j2)+-- , continue = \_ -> return true+ , tryH = \i -> IfThenElse (is_fst i) @$ tryE lsuper (mpath i FirstS) @. tryE rsuper (mpath i SecondS)+ , startTryH = \i -> IfThenElse (is_fst i) @$ startTryE lsuper (mpath i FirstS) @. startTryE rsuper (mpath i SecondS)+ , tryLH = \i -> IfThenElse (is_fst i) @$ tryE_ lsuper (mpath i FirstS) @. tryE_ rsuper (mpath i SecondS)+ , boolArraysE = boolArraysE lsuper ++ boolArraysE rsuper+ , intArraysE = intArraysE lsuper ++ intArraysE rsuper+ , intVarsE = intVarsE lsuper ++ intVarsE rsuper+ , deleteH = deleteMe+ , canBranch = canBranch lsuper >>= \l -> canBranch rsuper >>= \r -> return (l || r)+ , complete = \i -> do sid1 <- complete lsuper (mpath i FirstS)+ sid2 <- complete rsuper (mpath i SecondS)+ return $ Cond (tstate i @-> "is_fst") sid1 sid2+ }+ where mystructs = ([s1,s2],[s3,s4])+ s1 = xs1 uid lsuper rsuper+ s2 = xs2 uid lsuper rsuper+ s3 = xs3 uid lsuper rsuper+ s4 = xs4 uid lsuper rsuper+ fs1 = xfs1 uid lsuper rsuper+ fs2 = xfs2 uid lsuper rsuper+ fs3 = xfs3 uid lsuper rsuper+ fs4 = xfs4 uid lsuper rsuper+ mpath = xpath uid lsuper rsuper+ withSeq f = seqSwitch (f lsuper in1) (f rsuper in2)+ withSeq_ f = seqSwitch (f lsuper in1 FirstS) (f rsuper in2 SecondS)+ inSeq f = \i -> withSeq_ $ \super ins pos -> f super (mpath i pos)+ dec_ref = \i -> seqSwitch (dec_refx $ mpath i FirstS) (dec_refx $ mpath i SecondS)+ dec_refx = \j -> return $ dec (ref_count j) >>> ifthen (ref_count j @== 0) (comment "ifLoop-dec_refx" >>> Delete (estate j))+ push dir = \i -> seqSwitch (push1 dir i) (push2 dir i)+ push1 dir = \i -> + let j = mpath i FirstS+ in dir lsuper (j `onCommit` ( mkCopy i "if_true"+ >>> mkCopy j "evalState"+ >>> inc (ref_count j)+ ))+ push2 dir = \i -> + let j = mpath i SecondS+ in dir rsuper (j `onCommit` ( mkCopy i "if_true"+ >>> mkCopy j "evalState"+ >>> inc (ref_count j)+ ))+ initstate = \i -> + let f d = + let j = mpath i (if d then FirstS else SecondS)+ in return ( (estate j <== New (if d then s1 else s2))+ >>> (ref_count j <== 1)+ ) + @>>>@ inite (if d then fs1 else fs2) j+ @>>>@ inits (if d then lsuper else rsuper) j+ in do thenP <- f True+ elseP <- f False+ return $ IfThenElse (tstate i @-> "if_true") thenP elseP+ in1 = \state -> state @-> "if_union" @-> "if_then"+ in2 = \state -> state @-> "if_union" @-> "if_else"+ is_fst = \i -> tstate i @-> "if_true"+ deleteMe = \i -> seqSwitch (deleteE lsuper (mpath i FirstS)) (deleteE rsuper (mpath i SecondS)) @>>>@ dec_ref i++if'+ :: Stat+ -> Search+ -> Search+ -> Search+if' cond s1 s2 = + case s1 of+ Search { mkeval = evals1, runsearch = runs1 } ->+ case s2 of+ Search { mkeval = evals2, runsearch = runs2 } ->+ Search { mkeval =+ \super -> do { s2' <- evals2 $ mapE (L . L . L . mmap (mmap runL . runL) . runL) super+ ; s1' <- evals1 $ mapE (L . L . mmap (mmap runL . runL) . runL) super+ ; uid <- get+ ; put (uid + 1)+ ; return $ mapE (L . mmap L . runL) $ + ifLoop cond uid (mapE (L . mmap (mmap L) . runL . runL) s1')+ (mapE (L . mmap (mmap L) . runL . runL . runL) s2')+ }+ , runsearch = runs2 . runs1 . runL . rReaderT FirstS . runL+ } + where in1 = \state -> state @-> "if_union" @-> "if_then"+ in2 = \state -> state @-> "if_union" @-> "if_else"
+ Control/Search/Combinator/Let.hs view
@@ -0,0 +1,41 @@+module Control.Search.Combinator.Let (let', set') where++import Control.Search.Language+import Control.Search.GeneratorInfo+import Control.Search.Generator+import Control.Search.Stat++stmPrefixLoop stm super = super { tryH = \i -> (stm i) @>>>@ (tryE super) i, startTryH = \i -> (stm i) @>>>@ (startTryH super) i, toString = "prefix(" ++ toString super ++ ")" }++letLoop :: Evalable m => VarId -> Stat -> Eval m -> Eval m+letLoop v@(VarId i) val super'' = + let super' = evalStat val super''+ super = super' { evalState_ = ("var" ++ (show i), Int, \i -> setVarInfo v i >> readStat val >>= \x -> return (x i)) : evalState_ super', + toString = "let(" ++ show v ++ "," ++ show val ++ "," ++ toString super'' ++ ")" }+ in commentEval super++let'+ :: VarId+ -> Stat+ -> Search+ -> Search++let' var val s = + case s of+ Search { mkeval = evals, runsearch = runs } ->+ Search { mkeval = \super -> do { ss <- evals super+ ; return $ letLoop var val ss+ }+ , runsearch = runs+ }++set' :: VarId -> Stat -> Search -> Search+set' var val s = case s of+ Search { mkeval = evals, runsearch = runs } ->+ Search { mkeval = \super -> do { ss <- evals super+ ; let ss1 = evalStat (varStat var) ss+ ; let ss2 = evalStat val ss1+ ; return $ stmPrefixLoop (\i -> readStat (varStat var) >>= \rvar -> readStat val >>= \rval -> return $ Assign (rvar i) (rval i)) ss2+ }+ , runsearch = runs+ }
+ Control/Search/Combinator/Misc.hs view
@@ -0,0 +1,84 @@+{-# LANGUAGE FlexibleContexts #-}++module Control.Search.Combinator.Misc (dbs, lds, bbmin) where++import Control.Search.Language+import Control.Search.GeneratorInfo+import Control.Search.Generator+import Control.Search.Stat++import Data.Int++import Control.Monatron.IdT++ldsLoop :: Monad m => Stat -> MkEval m+ldsLoop limit super' = return $ commentEval $ super+ { treeState_ = entry ("lds",Int,assign 0) : treeState_ super+ , initH = \i -> readStat limit >>= \f -> initH super i @>>>@ return (assign (f i) (tstate i @-> "lds"))+ , evalState_ = ("lds_complete", Bool, const $ return true) : evalState_ super+ , pushLeftH = \i -> pushLeft super (i `onCommit` mkCopy i "lds")+ , pushRightH = \i -> pushRight super (i `onCommit` mkUpdate i "lds" (\x -> x - 1)) >>= \stmt -> + return $ IfThenElse + (tstate (old i) @-> "lds" @>= 0) + stmt+ (abort i >>> (estate i @=> "lds_complete" <== false))+ , toString = "lds(" ++ show limit ++ "," ++ toString super ++ ")"+ , complete = \i -> return $ estate i @=> "lds_complete"+ }+ where super = evalStat limit super'++--------------------------------------------------------------------------------+dbsLoop :: Monad m => Int32 -> MkEval m+dbsLoop limit super = return $ commentEval $ super+ { treeState_ = entry ("depth_limit",Int,assign $ IVal limit) : treeState_ super+ , evalState_ = ("dbs_complete", Bool, const $ return true) : evalState_ super+ , pushLeftH = push pushLeft+ , pushRightH = push pushRight+ , toString = "dbs(" ++ show limit ++ "," ++ toString super ++ ")"+ , complete = \i -> return $ estate i @=> "dbs_complete"+ }+ where push dir = + \i -> dir super (i `onCommit` mkUpdate i "depth_limit" (\x -> x - 1)) >>= \stmt ->+ return $ IfThenElse (tstate (old i) @-> "depth_limit" @>= 0)+ stmt+ ((estate i @=> "dbs_complete" <== false) >>> abort i)++--------------------------------------------------------------------------------+bbLoop :: Monad m => String -> MkEval m +bbLoop var super = return $ commentEval $ super+ { treeState_ = entry ("tree_bound_version",Int,assign 0) : treeState_ super+ , evalState_ = ("bound_version",Int,const $ return 0) : ("bound",Int,const $ return $ IVal maxBound) : evalState_ super+ , returnH = \i -> returnE super (i `onCommit`+ let get = VHook (rp 0 (space i) ++ "->iv[VAR_" ++ var ++ "].min()")+ in (Assign (estate i @=> "bound") get >>> inc (estate i @=> "bound_version"))) + , bodyH = \i -> let set = Post (space i) (VHook (rp 0 (space i) ++ "->iv[VAR_" ++ var ++ "]") $< (estate i @=> "bound"))+ in do r <- bodyE super i+ return $ (ifthen (tstate i @-> "tree_bound_version" @< (estate i @=>"bound_version"))+ (set >>> (Assign (tstate i @-> "tree_bound_version") ((tstate i @-> "tree_bound_version") + 1)))+ >>> r)+ , pushLeftH = push pushLeft+ , pushRightH = push pushRight+ , intVarsE = var : intVarsE super+ , complete = const $ return true+ , toString = "bb(" ++ show var ++ "," ++ toString super ++ ")"+ }+ where push dir = \i -> dir super (i `onCommit` mkCopy i "tree_bound_version")++bbmin :: String -> Search+bbmin var = + Search { mkeval = bbLoop var + , runsearch = runIdT+ }++lds :: Stat -> Search+lds n = + Search { mkeval = ldsLoop n+ , runsearch = runIdT+ }++dbs :: Int32 -> Search+dbs n = + Search { mkeval = dbsLoop n+ , runsearch = runIdT+ } +
+ Control/Search/Combinator/Once.hs view
@@ -0,0 +1,30 @@+module Control.Search.Combinator.Once (once, onceOld) where++import Control.Search.Language+import Control.Search.GeneratorInfo+import Control.Search.Generator+import Control.Search.Memo+import Control.Search.Stat+import Control.Search.Combinator.Until++import Control.Monatron.IdT++onceLoop :: MkEval m+onceLoop super = return $ commentEval $ super+ { evalState_ = ("onceMore", Bool, const $ return true) : evalState_ super+ , bodyH = \i -> do goOn <- bodyE super i+ ca <- cachedAbort i+ return $ IfThenElse (estate i @=> "onceMore")+ goOn+ ca+ , returnH = \i -> returnE super $ i `onCommit` assign false (estate i @=> "onceMore")+ , toString = "once(" ++ toString super ++ ")"+ }++once :: Search+once = + Search { mkeval = onceLoop+ , runsearch = runIdT+ } ++onceOld = limit 1 solutionsStat
+ Control/Search/Combinator/Or.hs view
@@ -0,0 +1,174 @@+{-# LANGUAGE FlexibleContexts #-}++module Control.Search.Combinator.Or ((<|>)) where++import Control.Search.Language+import Control.Search.GeneratorInfo+import Control.Search.Generator+import Control.Search.MemoReader+import Control.Search.Memo++import Control.Monatron.Monatron hiding (Abort, L, state, cont)+import Control.Monatron.Zipper hiding (i,r)++xs1 uid lsuper rsuper = Struct ("LeftEvalState" ++ show uid) $ (THook "TreeState", "parent") : {- (Bool, "cont") : -} (Int, "ref_count") : [(ty, field) | (field,ty,_) <- evalState_ lsuper]+xfs1 uid lsuper rsuper = [(field,init) | (field,ty,init) <- evalState_ lsuper ]+xs2 uid lsuper rsuper = Struct ("RightEvalState" ++ show uid) $ xneedSide uid lsuper rsuper SecondS $ {- (Bool, "cont") : -} (Int, "ref_count") : [(ty, field) | (field,ty,_) <- evalState_ rsuper]+xfs2 uid lsuper rsuper = [(field,init) | (field,ty,init) <- evalState_ rsuper ]+xet uid lsuper rsuper FirstS = SType $ xs1 uid lsuper rsuper+xet uid lsuper rsuper SecondS = SType $ xs2 uid lsuper rsuper+xs3 uid lsuper rsuper = Struct ("LeftTreeState" ++ show uid) $ (Pointer $ SType $ xs1 uid lsuper rsuper, "evalState") : [(ty, field) | (field,ty,_) <- treeState_ lsuper]+xfs3 uid lsuper rsuper = [(field,init) | (field,ty,init) <- treeState_ lsuper]+xs4 uid lsuper rsuper = Struct ("RightTreeState" ++ show uid) $ xneedSide uid lsuper rsuper SecondS [(Pointer $ SType $ xs2 uid lsuper rsuper, "evalState")] ++ [(ty, field) | (field,ty,_) <- treeState_ rsuper]+xst uid lsuper rsuper FirstS = SType $ xs3 uid lsuper rsuper+xst uid lsuper rsuper SecondS = SType $ xs4 uid lsuper rsuper+xneedSide :: Monoid m => Int -> Eval n -> Eval n -> SeqPos -> m -> m+xneedSide uid lsuper rsuper = \pos stm -> case pos of { FirstS -> stm;+ SecondS -> if (length (evalState_ rsuper) == 0) then mempty else stm;+ }++orLoop :: (ReaderM SeqPos m, Evalable m) => Int -> (Eval m) -> (Eval m) -> Eval m+orLoop uid (lsuper) (rsuper) = commentEval $+ Eval { structs = structs lsuper @++@ structs rsuper @++@ mystructs + , toString = "or" ++ show uid ++ "(" ++ toString lsuper ++ "," ++ toString rsuper ++ ")"+ , treeState_ = [entry ("is_fst",Bool,assign true)+ , ("or_union",Union [(SType s3,"fst"),(SType s4,"snd")], + \i -> + let j = withPath i in1 (et FirstS) (st FirstS)+ in do cc <- cachedClone i (cloneBase j)+ return ( (estate j <== New s1)+ >>> (ref_count j <== 1)+-- >>> (cont j <== true)+ >>> (parent j <== baseTstate j)+ >>> cc+ )+ @>>>@ mseqs [init (j `withClone` (\k -> inc $ ref_count k)) | (f,init) <- fs3]+ @>>>@ inite fs1 j+ )]+ , initH = \i -> initE lsuper (withPath i in1 (et FirstS) (st FirstS))+ , evalState_ = []+ , pushLeftH = push pushLeft+ , pushRightH = push pushRight+ , nextSameH = \i -> let j = i `withBase` "popped_estate"+ in do nS1 <- local (const FirstS) $ inSeq nextSame i+ nS2 <- local (const SecondS) $ inSeq nextSame i+ nD1 <- local (const FirstS) $ inSeq nextDiff i+ nD2 <- local (const SecondS) $ inSeq nextDiff i+ return $ IfThenElse (is_fst i) + (IfThenElse (is_fst j) nS1 nD1)+ (IfThenElse (is_fst j) nD2 nS2) + , nextDiffH = \i -> inSeq nextDiff i+ , bodyH = \i ->+ let f y z p = + let j = withPath i y (et p) (st p)+ in dec_ref i >>= \deref -> bodyE z (j `onAbort` deref)+ in IfThenElse (is_fst i) @$ local (const FirstS) (f in1 lsuper FirstS)+ @. local (const SecondS) (f in2 rsuper SecondS)+ , addH = inSeq $ addE+ , failH = \i -> inSeq failE i @>>>@ dec_ref i+ , returnH = \i -> + let j1 deref = (withPath i in1 (et FirstS) (st FirstS)) `onCommit` (comment "returnE-deref-j1" >>> deref >>> comment "end returnE-deref-j1")+ j2 deref = (withPath i in2 (et SecondS) (st SecondS)) `onCommit` (comment "returnE-deref-j2" >>> deref >>> comment "end returnE-deref-j2")+ in seqSwitch (dec_ref1 i >>= returnE lsuper . j1)+ (dec_ref2 (j2 Skip) >>= returnE rsuper . j2) + , tryH = \i -> + do dr <- dec_ref i+ inSeq (\super j -> tryE super (j `onAbort` (comment "Combinator/Or tryH onAbort" >>> dr ))) i+ , startTryH = \i -> local (const FirstS) $ inSeq startTryE i+ , tryLH = \i -> inSeq tryE_ i @>>>@ dec_ref i+ , boolArraysE = boolArraysE lsuper ++ boolArraysE rsuper+ , intArraysE = intArraysE lsuper ++ intArraysE rsuper+ , intVarsE = intVarsE lsuper ++ intVarsE rsuper+ , deleteH = deleteMe+ , canBranch = return True+ , complete = \i -> do sid1 <- complete lsuper (withPath i in1 (et FirstS) (st FirstS))+ sid2 <- complete rsuper (withPath i in2 (et SecondS) (st SecondS))+ return $ (Cond (tstate i @-> "is_fst") sid1 sid2)++-- , complete = const $ return false+ }+ where mystructs = ([s1,s2],[s3,s4])+ s1 = xs1 uid lsuper rsuper+ s2 = xs2 uid lsuper rsuper+ s3 = xs3 uid lsuper rsuper+ s4 = xs4 uid lsuper rsuper+ fs1 = xfs1 uid lsuper rsuper+ fs2 = xfs2 uid lsuper rsuper+ fs3 = xfs3 uid lsuper rsuper+ et = xet uid lsuper rsuper+ st = xst uid lsuper rsuper+ needSide = xneedSide uid lsuper rsuper+ parent = \i -> estate i @=> "parent"+ withSeq f = seqSwitch (f lsuper in1 FirstS) (f rsuper in2 SecondS)+ withSeq_ f = seqSwitch (f lsuper in1 FirstS) (f rsuper in2 SecondS)+ inSeq f = \i -> withSeq_ $ \super ins pos -> f super (withPath i ins (et pos) (st pos))+ dec_ref = \i -> seqSwitch (dec_ref1 i) (dec_ref2 $ withPath i in2 (et SecondS) (st SecondS))+ dec_ref1 = \i -> let j1 = withPath i in1 (et FirstS) (st FirstS)+ i' = resetClone $ resetAbort $ resetCommit $ i `withBase` ("or_tstate" ++ show uid)+ j2 = withPath i' in2 (et SecondS) (st SecondS)+ in (local (const SecondS) $+ do stmt1 <- inits rsuper j2+ stmt2 <- startTryE rsuper j2+ ini <- inite fs2 j2+ compl <- complete lsuper j1+ return ( dec (ref_count j1) + >>> (ifthen (ref_count j1 @== 0) $+ (+ {- DebugValue ("or" ++ show uid ++ ": left finished with complete") (compl)+ >>> -} (ifthen (Not compl) $+ ( SHook ("TreeState or_tstate" ++ show uid ++ ";")+ >>> (baseTstate j2 <== parent j1)+ >>> (is_fst i' <== false)+ >>> comment "orLoop-dec_ref1-Delete" >>> Delete (estate j1)+ >>> needSide SecondS (estate j2 <== New s2) + >>> needSide SecondS (ref_count j2 <== 1)+-- >>> (cont j2 <== true)+ >>> ini+ >>> stmt1 >>> stmt2+ )+ )+ )+ )+ )+ )+ dec_ref2 = \j -> {- return (DebugValue ("or" ++ show uid ++ ": right dec_ref from") (ref_count j)) @>>>@ -} (complete rsuper (withPath (resetClone $ resetAbort $ resetCommit $ j `withBase` ("or_tstate" ++ show uid)) in2 (et SecondS) (st SecondS)) >>= \compl -> (return $ needSide SecondS $ dec (ref_count j) >>> ifthen (ref_count j @== 0) ({- DebugValue ("or" ++ show uid ++ ": right finished with complete") compl >>> -} comment "orLoop-dec_ref2-Delete" >>> Delete (estate j))))+ push dir = \i -> seqSwitch (push1 dir i) (push2 dir i)+ push1 dir = \i -> + let j = withPath i in1 (et FirstS) (st FirstS)+ in dir lsuper (j `onCommit` ( mkCopy i "is_fst"+ >>> mkCopy j "evalState"+ >>> inc (ref_count j)+ ))+ push2 dir = \i -> + let j = withPath i in2 (et SecondS) (st SecondS)+ in dir rsuper (j `onCommit` ( mkCopy i "is_fst"+ >>> needSide SecondS (mkCopy j "evalState")+ >>> needSide SecondS (inc (ref_count j))+ ))+ in1 = \state -> state @-> "or_union" @-> "fst"+ in2 = \state -> state @-> "or_union" @-> "snd"+ is_fst = \i -> tstate i @-> "is_fst"+ deleteMe = \i -> seqSwitch (deleteE lsuper (withPath i in1 (et FirstS) (st FirstS))) (deleteE rsuper (withPath i in2 (et SecondS) (st SecondS))) @>>>@ dec_ref i++(<|>)+ :: Search+ -> Search+ -> Search+s1 <|> s2 = + case s1 of+ Search { mkeval = evals1, runsearch = runs1 } ->+ case s2 of+ Search { mkeval = evals2, runsearch = runs2 } ->+ Search {mkeval =+ \super -> do { s2' <- evals2 $ mapE (L . L . L . mmap (mmap runL . runL) . runL) super+ ; s1' <- evals1 $ mapE (L . L . mmap (mmap runL . runL) . runL) super+ ; uid <- get+ ; put (uid + 1)+ ; return $ mapE (L . mmap L . runL) $ + orLoop uid (mapE (L . mmap (mmap L) . runL . runL) s1')+ (mapE (L . mmap (mmap L) . runL . runL . runL) s2')+ }+ , runsearch = runs2 . runs1 . runL . rReaderT FirstS . runL+ }+ where in1 = \state -> state @-> "or_union" @-> "fst"+ in2 = \state -> state @-> "or_union" @-> "snd"
+ Control/Search/Combinator/OrRepeat.hs view
@@ -0,0 +1,95 @@+{-# LANGUAGE FlexibleContexts #-}++module Control.Search.Combinator.OrRepeat (orRepeat) where++import Control.Search.Language+import Control.Search.GeneratorInfo+import Control.Search.Generator+import Control.Search.MemoReader+import Control.Search.Memo+import Control.Search.Stat++import Control.Monatron.Monatron hiding (Abort, L, state, cont)+import Control.Monatron.Zipper hiding (i,r)++orRepeatLoop :: (Evalable m, ReaderM Bool m) => Stat -> Int -> Eval m -> Eval m+orRepeatLoop cond uid super' = commentEval $+ Eval + { + structs = structs super @++@ mystructs + , treeState_ = treeState_ super+ , toString = "orRepeat" ++ show uid ++ "(" ++ toString super' ++ ")"+ , initH = \i -> initE super i @>>>@ return (parent i <== baseTstate i) @>>>@ cachedClone i (cloneBase i)+ , evalState_ = {- ("cont",Bool,const $ return true) : -} ("ref_count_orr" ++ show uid,Int,const $ return 1) : ("parent",THook "TreeState",const $ return Null) : evalState_ super+ , pushLeftH = push pushLeft+ , pushRightH = push pushRight+ , nextSameH = nextSame super+ , nextDiffH = nextDiff super + , bodyH = \i -> dec_ref i >>= \deref -> bodyE super (i `onAbort` deref)+ , addH = addE super+ , failH = \i -> failE super i @>>>@ dec_ref i+ , returnH = \i -> let j deref = i `onCommit` deref+ in dec_ref i >>= returnE super . j+ , tryH = \i -> do deref <- dec_ref i+ tryE super (i `onAbort` deref)+ , startTryH = \i -> do deref <- dec_ref i+ startTryE super (i `onAbort` deref)+ , tryLH = \i -> tryE_ super i @>>>@ dec_ref i+ , intArraysE = intArraysE super+ , boolArraysE = boolArraysE super+ , intVarsE = intVarsE super+ , deleteH = error "orRepeatLoop.deleteE NOT YET IMPLEMENTED"+ , canBranch = return True+ , complete = complete super+-- , complete = const $ return false+ }+ where mystructs = ([],[])+ super = evalStat cond super'+ fs1 = [(field,init) | (field,ty,init) <- evalState_ super]+ parent = \i -> estate i @=> "parent"+ dec_ref = \i -> let i' = resetAbort $ resetCommit $ i `withBase` ("orr_tstate" ++ show uid)+ ii = resetAbort $ resetCommit $ i+ in do flag <- ask + if flag + then local (const False) $ do+ stmt1 <- inits super i'+ stmt2 <- startTryE super i'+ r <- readStat cond+ ini <- inite fs1 i'+ -- let cc = clone ii i'+ -- cc <- cachedClone (cloneBase ii) i'+ cc1 <- cachedClone (i { baseTstate = parent ii} ) i'+ -- cc2 <- cachedClone (i' ) i'+ compl <- complete super ii+ return (dec (ref_countx ii $ "orr" ++ show uid) + >>> ifthen (ref_countx ii ("orr" ++ show uid) @== 0) + (ifthen (r i' &&& Not compl)+ ( SHook ("TreeState orr_tstate" ++ show uid ++ ";")+ >>> (baseTstate i' <== parent ii)+ -- >>> ((baseTstate i' @-> "space") <== (parent ii @-> "space"))+ -- >>> cc+ >>> cc1+ -- >>> cc2+ >>> (ref_countx i' ("orr" ++ show uid) <== 1)+-- >>> (cont i' <== true)+ >>> ini >>> stmt1 >>> stmt2)+ ))+ else return $ dec (ref_countx ii ("orr" ++ show uid)) >>> ifthen (ref_countx ii ("orr" ++ show uid) @== 0) (comment "orRepeatLoop-dec_ref-Delete" >>> Delete (space $ cloneBase ii))+ push dir = \i -> dir super (i `onCommit'` inc (ref_countx i $ "orr" ++ show uid))++orRepeat+ :: Stat+ -> Search+ -> Search+orRepeat cond s = + case s of+ Search { mkeval = evals, runsearch = runs } ->+ Search { mkeval =+ \super ->+ do { uid <- get+ ; put (uid + 1)+ ; s' <- evals $ mapE (L . L . mmap runL . runL) super+ ; return $ mapE (L . mmap L . runL) $ orRepeatLoop cond uid (mapE runL s')+ }+ , runsearch = runs . rReaderT True . runL+ }
+ Control/Search/Combinator/Post.hs view
@@ -0,0 +1,34 @@+{-# LANGUAGE Rank2Types #-}+{-# LANGUAGE FlexibleContexts #-}++module Control.Search.Combinator.Post (post) where++import Control.Search.Language+import Control.Search.GeneratorInfo+import Control.Search.Generator+import Control.Search.Constraints++postLoop :: VarInfoM m => ConstraintGen -> MkEval m -> MkEval m+postLoop (ConstraintGen c l) par this = do+ super <- par this+ return $ commentEval $ super + { tryH = try tryE super+ , startTryH = try startTryE super+ , toString = "post(<CONSTRAINT>," ++ toString super ++ ")"+ , intVarsE = l ++ intVarsE super+ }+ where try f super = \i -> -- failE super i >>= \fail -> -- XXX+ f super i >>= \body ->+ c i >>= \cc ->+ return $ Post (space i) cc >>> body+-- (Var "status" <== VHook (rp 0 (space i) ++ "->status()")) >>>+-- IfThenElse (Var "status" @== VHook "SS_FAILED") (fail >>> comment "Delete-postLoop-try" >>> Delete (space i)) body+++post :: ConstraintGen -> Search -> Search+post c s =+ case s of + Search { mkeval = m, runsearch = r } ->+ Search { mkeval = postLoop c m+ , runsearch = r+ }
+ Control/Search/Combinator/Print.hs view
@@ -0,0 +1,33 @@+{-# LANGUAGE FlexibleContexts #-}++module Control.Search.Combinator.Print (prt,dbg) where++import Control.Search.Language+import Control.Search.GeneratorInfo+import Control.Search.Generator++import Control.Monatron.IdT++printLoop :: [String] -> MkEval m+printLoop lst super = return $ commentEval $ super+ { returnH = \i -> returnE super $ i `onCommit` Print (space i) lst+ , toString = "print(" ++ toString super ++ ")"+ }++debugLoop :: Evalable m => String -> MkEval m+debugLoop str super = return $ commentEval $ super+ { initH = \i -> return (DebugOutput str) @>>>@ initH super i+ , toString = "debug(" ++ show str ++ "," ++ toString super ++ ")"+ }++prt :: [String] -> Search+prt l = + Search { mkeval = printLoop l+ , runsearch = runIdT+ }++dbg :: String -> Search+dbg str = + Search { mkeval = debugLoop str+ , runsearch = runIdT+ }
+ Control/Search/Combinator/Repeat.hs view
@@ -0,0 +1,84 @@+{-# LANGUAGE FlexibleContexts #-}++module Control.Search.Combinator.Repeat (repeat) where++import Prelude hiding (lex, until, init, repeat)++import Control.Search.Language+import Control.Search.GeneratorInfo+import Control.Search.Generator+import Control.Search.MemoReader+import Control.Search.Memo++import Control.Monatron.Monatron hiding (Abort, L, state, cont)+import Control.Monatron.Zipper hiding (i,r)++repeatLoop :: (ReaderM Bool m, Evalable m) => Int -> Eval m -> Eval m+repeatLoop uid super = commentEval $+ Eval + { + structs = structs super @++@ mystructs + , toString = "repeat" ++ show uid ++ "(" ++ toString super ++ ")"+ , treeState_ = ("dummy", Int, + \i -> do cc <- cachedClone i (cloneBase i)+ return ((parent i <== baseTstate i)+ >>> cc+ )+ ) : treeState_ super -- `withClone` (\k -> inc $ ref_count k)+ , initH = \i -> initE super i+ , evalState_ = {- ("cont",Bool,const $ return true) : -} ("ref_count",Int,const $ return 1) : ("parent",THook "TreeState",const $ return Null) : evalState_ super+ , pushLeftH = push pushLeft+ , pushRightH = push pushRight+ , nextSameH = nextSame super+ , nextDiffH = nextDiff super + , bodyH = \i -> dec_ref i >>= \deref -> bodyE super (i `onAbort` deref)+ , addH = addE super+ , failH = \i -> failE super i @>>>@ dec_ref i+ , returnH = \i -> let j deref = i `onCommit` deref+ in dec_ref i >>= returnE super . j+ , tryH = tryE super+ , startTryH = startTryE super+ , tryLH = \i -> tryE_ super i @>>>@ dec_ref i+ , boolArraysE = boolArraysE super+ , intArraysE = intArraysE super+ , intVarsE = intVarsE super+ , deleteH = error "repeatLoop.deleteE NOT YET IMPLEMENTED"+ , canBranch = canBranch super+ , complete = const $ return true+ }+ where mystructs = ([],[])+ fs1 = [(field,init) | (field,ty,init) <- evalState_ super]+ parent = \i -> estate i @=> "parent"+ dec_ref = \i -> let i' = resetCommit $ i `withBase` ("repeat_tstate" ++ show uid)+ in do flag <- ask + if flag + then local (const False) $ do+ stmt1 <- inits super i'+ stmt2 <- startTryE super i'+ ini <- inite fs1 i'+ return (dec (ref_count i) + >>> ifthen (ref_count i @== 0) + ( SHook ("TreeState repeat_tstate" ++ show uid ++ ";")+ >>> (baseTstate i' <== parent i)+ >>> clone (cloneBase i) i'+ >>> (ref_count i' <== 1)+-- >>> (cont i' <== true)+ >>> ini >>> stmt1 >>> stmt2))+ else return $dec (ref_count i) >>> ifthen (ref_count i @== 0) (comment "Delete-repeatLoop-dec_ref" >>> Delete (space $ cloneBase i))+ push dir = \i -> dir super (i `onCommit` inc (ref_count i))++repeat + :: Search+ -> Search+repeat s = + case s of+ Search { mkeval = evals, runsearch = runs } ->+ Search { mkeval =+ \super ->+ do { uid <- get+ ; put (uid + 1)+ ; s' <- evals $ mapE (L . L . mmap runL . runL) super+ ; return $ mapE (L . mmap L . runL) $ repeatLoop uid $ mapE runL s' + }+ , runsearch = runs . rReaderT True . runL+ }
+ Control/Search/Combinator/Success.hs view
@@ -0,0 +1,38 @@+module Control.Search.Combinator.Success (dummy) where++import Control.Search.Language+import Control.Search.GeneratorInfo+import Control.Search.Generator+import Control.Search.Memo++import Control.Monatron.IdT++successLoop :: Evalable m => Eval m -> Eval m+successLoop this = commentEval $+ Eval { structs = ([],[])+ , treeState_ = []+ , initH = const $ return Skip+ , evalState_ = []+ , pushLeftH = error "succesloop.tyE_"+ , pushRightH = error "succesloop.tyE_"+ , nextSameH = \i -> return Skip+ , nextDiffH = \i -> return Skip+ , bodyH = addE this . resetInfo -- XXX+ , addH = \i -> tryE this (resetInfo i)+ , failH = const $ return Skip+ , returnH = \i -> cachedCommit i+ -- const $ return Skip+-- , continue = \_ -> return true+ , tryH = returnE this . resetInfo+ , startTryH = \i -> (return $ comment "<startTryE success>") @>>>@ (returnE this . resetInfo) i @>>>@ (return $ comment "</startTryE succes>")+ , tryLH = error "succesloop.tryE_"+ , intArraysE = []+ , boolArraysE = []+ , intVarsE = []+ , deleteH = \i -> return Skip+ , toString = "succeed"+ , canBranch = return False+ , complete = const $ return true+ }++dummy = Search { mkeval = return . successLoop, runsearch = runIdT }
+ Control/Search/Combinator/Until.hs view
@@ -0,0 +1,188 @@+{-# LANGUAGE FlexibleContexts #-}++module Control.Search.Combinator.Until (until,limit,glimit) where++import Prelude hiding (until)+import Data.Int++import Control.Search.Language+import Control.Search.GeneratorInfo+import Control.Search.MemoReader+import Control.Search.Generator+import Control.Search.Combinator.Failure+import Control.Search.Stat++import Control.Monatron.Monatron hiding (Abort, L, state, cont)+import Control.Monatron.Zipper hiding (i,r)++untilLoop :: (Evalable m, ReaderM SeqPos m) => Stat -> Int -> (Eval m) -> (Eval m) -> Eval m+untilLoop cond uid lsuper' rsuper = commentEval c+ where c = Eval { structs = structs lsuper @++@ structs rsuper @++@ mystructs + , toString = "until" ++ show uid ++ "(" ++ show cond ++ "," ++ toString lsuper' ++ "," ++ toString rsuper ++ ")"+ , treeState_ = [entry ("is_fst",Bool,assign true)+ ,("until_union", Union [(SType s3,"fst"),(SType s4,"snd")], + \i -> + let j = xpath i FirstS+ in initSubEvalState j s1 fs1 FirstS)+ ]+ , initH = \i -> inits lsuper (i `xpath` FirstS)+ , evalState_ = [("until_complete",Bool,const $ return true)]+ , pushLeftH = push pushLeft+ , pushRightH = push pushRight+ , nextSameH = \i -> let j = i `withBase` "popped_estate"+ in do let nS1 = local (const FirstS) $ inSeq nextSame i+ let nS2 = local (const SecondS) $ inSeq nextSame i+ let nD1 = local (const FirstS) $ inSeq nextDiff i+ let nD2 = local (const SecondS) $ inSeq nextDiff i+ swfst i (swfst j nS1 nD1) (swfst j nD2 nS2)+ , nextDiffH = inSeq nextDiff+ , -- MAIN ENTRY POINT FOR NEW NODE+ -- if (fst) {+ -- if (seq_union.fst.evalState->cont) {+ -- } else {+ -- }+ -- } else {+ -- if (seq_union.snd.evalState->cont) {+ -- } else {+ -- }+ -- }+ bodyH = \i -> + let f y z iscomplete pos = + do compl <- iscomplete (i `xpath` pos)+ let j = i `xpath` pos `onAbort` (comment "untilLoop.bodyE" >>> dec_ref i j compl pos)+ bodyE z j+ in do let s1 = local (const FirstS) $ f in1 lsuper liscomplete FirstS+ s2 = local (const SecondS) $ f in2 rsuper riscomplete SecondS+ swfst i s1 s2+ , addH = inSeq $ addE+ , failH = \i -> inSeq' (\super j iscomplete pos -> iscomplete j >>= \compl -> (failE super j @>>>@ return (dec_ref i j compl pos))) i+ , returnH = \i -> inSeq' (\super j iscomplete pos -> iscomplete j >>= \compl -> (returnE super (j `onCommit` dec_ref i j compl pos))) i+-- , continue = \_ -> return true+ -- IF THE CURRENT STATUS IS NOT FAILED+ -- EITHER (is_fst)+ -- if (<CONDITION>) { // SWITCH TO NEW SEARCH+ -- } else {+ -- <TRY-REC>+ -- }+ -- OR (!is_fst)+ , tryH = tryX tryE+ , startTryH = tryX startTryE+ , tryLH = \i -> inSeq' (\super j iscomplete pos -> iscomplete j >>= \compl -> (tryE_ super j @>>>@ return (dec_ref i j compl pos))) i+ , boolArraysE = boolArraysE lsuper ++ boolArraysE rsuper+ , intArraysE = intArraysE lsuper ++ intArraysE rsuper+ , intVarsE = intVarsE lsuper ++ intVarsE rsuper+ , deleteH = error "untilLoop.deleteE NOT YET IMPLEMENTED"+ , canBranch = canBranch lsuper >>= \l -> canBranch rsuper >>= \r -> return (l || r)+ , complete = \i -> return $ estate i @=> "until_complete"+-- , complete = const $ return false+ }+ needSide_ = \pos stmY stmN -> case pos of { FirstS -> if (length (evalState_ lsuper) == 0) then stmN else stmY;+ SecondS -> if (length (evalState_ rsuper) == 0) then stmN else stmY;+ }+ needSide :: Monoid m => SeqPos -> m -> m+ needSide = \pos stm -> needSide_ pos stm mempty+ mystructs = ([s1,s2],[s3,s4])+ s1 = Struct ("LeftEvalState" ++ show uid) $ needSide FirstS $ {- (Bool, "cont") : -} (Int, "ref_count_until" ++ show uid) : [(ty, field) | (field,ty,_) <- evalState_ lsuper]+ fs1 = [(field,init) | (field,ty,init) <- evalState_ lsuper ]+ s2 = Struct ("RightEvalState" ++ show uid) $ needSide SecondS $ {- (Bool, "cont") : -} (Int, "ref_count_until" ++ show uid) : [(ty, field) | (field,ty,_) <- evalState_ rsuper]+ fs2 = [(field,init) | (field,ty,init) <- evalState_ rsuper ]+ s3 = Struct ("LeftTreeState" ++ show uid) $ needSide FirstS [(Pointer $ SType s1, "evalState")] ++ [(ty, field) | (field,ty,_) <- treeState_ lsuper]+ fs3 = [(field,init) | (field,ty,init) <- treeState_ lsuper]+ s4 = Struct ("RightTreeState" ++ show uid) $ needSide SecondS [(Pointer $ SType s2, "evalState")] ++ [(ty, field) | (field,ty,_) <- treeState_ rsuper]+ xpath i FirstS = withPath i in1 (Pointer $ SType s1) (Pointer $ SType s3)+ xpath i SecondS = withPath i in2 (Pointer $ SType s2) (Pointer $ SType s4)+ in1 = \state -> state @-> "until_union" @-> "fst"+ in2 = \state -> state @-> "until_union" @-> "snd"+ is_fst = \i -> tstate i @-> "is_fst"+ withSeq f = seqSwitch (f lsuper in1) (f rsuper in2)+ withSeq_ f = seqSwitch (f lsuper in1 FirstS) (f rsuper in2 SecondS)+ inSeq f = \i -> withSeq_ $ \super ins pos -> f super (i `xpath` pos)+ inSeq' f = \i -> seqSwitch (f lsuper (i `xpath` FirstS) liscomplete FirstS) + (f rsuper (i `xpath` SecondS) riscomplete SecondS)+ dec_ref = \i j iscomplete pos -> needSide_ pos (dec (ref_countx j $ "until" ++ show uid) >>>+ ifthen (ref_countx j ("until" ++ show uid) @== 0) (+ {- DebugValue ("until" ++ show uid ++ ": left branch finished with complete") iscomplete+ >>> DebugValue ("until" ++ show uid ++ ": until's previous completeness was") (complet i)+ >>> -} (complet i <== (complet i &&& iscomplete)) >>> Delete (estate j)+ )+ ) (complet i <== (complet i &&& iscomplete))+ push dir = \i -> seqSwitch (push1 dir i) (push2 dir i)+ push1 dir = \i -> + let j = i `xpath` FirstS+ in dir lsuper (j `onCommit` ( mkCopy i "is_fst"+ >>> mkCopy j "evalState"+ >>> inc (ref_countx j $ "until" ++ show uid)+ ))+ push2 dir = \i -> + let j = i `xpath` SecondS+ in dir rsuper (j `onCommit` ( mkCopy i "is_fst"+ >>> mkCopy j "evalState"+ >>> inc (ref_countx j $ "until" ++ show uid)+ ))+ lsuper = evalStat cond lsuper'+ complet = \i -> estate i @=> "until_complete"+ liscomplete = complete lsuper'+ riscomplete = complete rsuper+ initSubEvalState = \j s fs pos -> return (needSide pos ( (estate j <== New s) + >>> (ref_countx j ("until" ++ show uid) <== 1)+-- >>> (cont j <== true)+ )+ )+ @>>>@ inite fs j+ tryX = \x i -> do lc <- liscomplete (i `xpath` FirstS)+ rc <- riscomplete (i `xpath` SecondS)+ let j1 = i `xpath` FirstS `onAbort` (comment "untilLoop.tryE j1" >>> dec_ref i j1 lc FirstS)+ j2 = i `xpath` SecondS `onAbort` (comment "untilLoop.tryE j2" >>> dec_ref i j2 rc SecondS)+ j2b = i `xpath` SecondS `onAbort` (comment "untilLoop.tryE j2b" >>> dec_ref i j2b rc SecondS)+ seqSwitch (x lsuper j1 >>= \try1 ->+ deleteE lsuper j1 >>= \delete1 ->+ (local (const SecondS) $+ do stmt1 <- inits rsuper j2b+ stmt2 <- startTryE rsuper j2b+ ini <- initSubEvalState j2b s2 fs2 SecondS+ return ( delete1+ >>> dec_ref i j1 lc FirstS+ >>> (is_fst i <== false)+ >>> ini+ >>> comment "initTreeState_ j2b rsuper" + >>> stmt1 + >>> comment "tryE rsuper j2b" + >>> comment ("length: " ++ show (length (abort_ j2b)))+ >>> stmt2)+ ) >>= \start2 -> readStat cond >>= \r -> return $ IfThenElse (r j1) ({- (DebugOutput $ "until" ++ show uid ++ " switches") >>> -} start2) try1+ )+ (x rsuper j2) + swfst i t e = do b1 <- canBranch lsuper+ b2 <- canBranch rsuper+ if (b1 && b2) then do { tt <- t; ee <- e; return $ IfThenElse (is_fst i) tt ee }+ else if b1 then t+ else e+++limit :: Int32 -> Stat -> Search -> Search+limit n stat s = until (stat #>= constStat (const (IVal n))) s failure++glimit :: Stat -> Search -> Search+glimit cond s = until (cond) s failure++until + :: Stat+ -> Search+ -> Search+ -> Search+until cond s1 s2 = + case s1 of+ Search { mkeval = evals1, runsearch = runs1 } ->+ case s2 of+ Search { mkeval = evals2, runsearch = runs2 } ->+ Search { mkeval =+ \super -> do { s2' <- evals2 $ mapE (L . L . L . mmap (mmap runL . runL) . runL) super+ ; s1' <- evals1 $ mapE (L . L . mmap (mmap runL . runL) . runL) super+ ; uid <- get+ ; put (uid + 1)+ ; return $ mapE (L . mmap L . runL) $ memoLoop $+ untilLoop cond uid (mapE ({- L . mmap (mmap L) . runL . runL-} mmap L . runL) s1')+ (mapE ({- L . mmap (mmap L) . runL . runL . runL-} mmap L . runL . runL) s2')+ }+ , runsearch = runs2 . runs1 . runL . rReaderT FirstS . runL+ }
+ Control/Search/Constraints.hs view
@@ -0,0 +1,71 @@+{-# LANGUAGE Rank2Types #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE ExistentialQuantification #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE PatternGuards #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE OverlappingInstances #-}++module Control.Search.Constraints+ ( clvar, cvar, cvars, cbvars, cval, cop, ctrue, cfalse, cexprStatVal, cexprStatMed, cexprStatMin, cexprStatMax+ , ConstraintExpr(..), ConstraintGen(..)+ ) where++import Text.PrettyPrint hiding (space)+import List (sort, nub, sortBy)+import Unsafe.Coerce++import Control.Search.Language+import Control.Search.GeneratorInfo+import Control.Search.Memo+import Control.Search.Stat+import Control.Search.Generator++import Control.Monatron.Monatron hiding (Abort, L, state, cont)+import Control.Monatron.Zipper hiding (i,r)+import Control.Monatron.IdT++import Data.Maybe (fromJust)+import Data.Map (Map)+import qualified Data.Map as Map++import Control.Search.SStateT++data ConstraintExpr = ConstraintExpr (forall m. VarInfoM m => m IValue) Bool [String]++data ConstraintGen = ConstraintGen (forall m. VarInfoM m => Info -> m Constraint) [String]++cvars :: String -> Integer -> ConstraintExpr+cvars v n = ConstraintExpr (return $ \i -> (AVarElem v (space i) (fromInteger n))) True [v]++cbvars :: String -> Integer -> ConstraintExpr+cbvars v n = ConstraintExpr (return $ \i -> (BAVarElem v (space i) (fromInteger n))) True [v]++cvar :: String -> ConstraintExpr+cvar v = ConstraintExpr (return $ \i -> (IVar v (space i))) True [v]++cval :: Integer -> ConstraintExpr+cval i = ConstraintExpr (return $ const $ fromInteger i) False []++clvar :: VarId -> ConstraintExpr+clvar v@(VarId n) = ConstraintExpr (do inf <- lookupVarInfo v+ return $ const $ estate inf @=> ("var" ++ show n)+ ) False []++cop :: ConstraintExpr -> (Value -> Value -> Constraint) -> ConstraintExpr -> ConstraintGen+cop (ConstraintExpr v1 _ l1) op (ConstraintExpr v2 _ l2) = ConstraintGen (\info -> (v1 >>= \x -> v2 >>= \y -> return (x info `op` y info))) (l1 ++ l2)++ctrue :: ConstraintGen+ctrue = ConstraintGen (const $ return TrueC) []++cfalse :: ConstraintGen+cfalse = ConstraintGen (const $ return FalseC) []++cexprStat f (ConstraintExpr m c l) = Stat (\e -> e { intVarsE = l ++ intVarsE e }) (m >>= \iv -> return (\info -> (if c then iv info @-> (f ++ "()") else iv info)))+cexprStatVal = cexprStat "val"+cexprStatMin = cexprStat "min"+cexprStatMax = cexprStat "max"+cexprStatMed = cexprStat "med"++
+ Control/Search/Generator.hs view
@@ -0,0 +1,855 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE Rank2Types #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE ExistentialQuantification #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE PatternGuards #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE OverlappingInstances #-}+{-# LANGUAGE IncoherentInstances #-}+{-# LANGUAGE UndecidableInstances #-}++module Control.Search.Generator+ ( (<@>)+ , mmap+ , search+ , ($==)+ , ($/=)+ , ($<) + , ($<=)+ , ($>) + , ($>=)+ , (@>)+ , VarId(..)++ , mapE, Eval(..), inite, seqSwitch, VarInfoM(..), MkEval, Evalable+ , SeqPos(..), Search(..), (@.), (@$), (@>>>@)+ , ref_count, ref_countx, ref_count_type, commentEval, (@++@)+ , entry, numSwitch, SearchCombiner(..)+ , buildCombiner, extractCombiners+ , memo+ , memoLoop {- ,MemoWrapper, runMemoWrapper-}+ , rReaderT+#ifndef NOMEMO+ , cacheStatement+#endif+ , cloneBase+ , mkCopy, mkUpdate, rp, inits, mseqs+ , cachedCommit, cachedAbort, cachedClone+ , nextSame, nextDiff, pushLeft, pushRight, bodyE, addE, returnE, initE, failE, tryE, startTryE, tryE_, deleteE+ ) where++import Debug.Trace++import Text.PrettyPrint hiding (space)+import List (sort, nub, sortBy)+import Data.List (intercalate)+import Data.Unique+import Unsafe.Coerce++import Control.Search.Language+import Control.Search.GeneratorInfo+#ifndef NOMEMO+import Control.Search.Memo+import Control.Search.MemoReader+#endif++import Control.Monatron.Monatron hiding (Abort, L, state, cont)+import Control.Monatron.Zipper hiding (i,r)+import Control.Monatron.MonadInfo+import Control.Monatron.IdT++import Data.Maybe (fromJust)+import Data.Map (Map)+import qualified Data.Map as Map++import Control.Search.SStateT++modify :: StateM s f => (s -> s) -> f ()+modify f = get >>= put . f++newtype GenModeT m a = GenModeT { unGenModeT :: ReaderT GenMode m a }+ deriving (MonadT, ReaderM GenMode, FMonadT)++class Monad m => GenModeM m where+ getFlags :: m PrettyFlags+ getMode :: m GenMode+ getFlags = getMode >>= return . PrettyFlags++instance MonadInfoT GenModeT where+ tminfo x = miInc "GenModeT" $ minfo (runReaderT undefined (unGenModeT x))++instance Monad m => GenModeM (GenModeT m) where+ getMode = GenModeT ask++instance (GenModeM m, FMonadT t) => GenModeM (t m) where+ getMode = lift getMode++runGenModeT :: GenMode -> GenModeT m a -> m a+runGenModeT m (GenModeT r) = runReaderT m r++type TreeState = Value++newtype VarId = VarId Int+ deriving (Ord, Eq, Show)++type VarInfo = Map VarId Info++newtype VarInfoT m a = VarInfoT { unVarInfoT :: SStateT VarInfo m a }+ deriving (MonadT,StateM VarInfo, FMonadT)++instance MonadInfoT VarInfoT where+ tminfo x = miInc "VarInfoT" $ minfo (runSStateT undefined (unVarInfoT x))++class Monad m => VarInfoM m where+ lookupVarInfo :: VarId -> m Info+ setVarInfo :: VarId -> Info -> m ()++instance Monad m => VarInfoM (VarInfoT m) where+ lookupVarInfo var = VarInfoT $ get >>= return . fromJust . Map.lookup var+ setVarInfo var val = VarInfoT $ get >>= \tbl -> (put $ Map.insert var val tbl)++instance (VarInfoM m, FMonadT t) => VarInfoM (t m) where+ lookupVarInfo = lift . lookupVarInfo+ setVarInfo var val = lift (setVarInfo var val)++#ifdef NOMEMO+class (VarInfoM m, HookStatsM m, MonadInfo m, GenModeM m, Functor m) => Evalable m+instance (VarInfoM m, HookStatsM m, MonadInfo m, GenModeM m, Functor m) => Evalable m+#else+class (VarInfoM m, HookStatsM m, MonadInfo m, MemoM m, GenModeM m, Functor m) => Evalable m+instance (VarInfoM m, HookStatsM m, MonadInfo m, MemoM m, GenModeM m, Functor m) => Evalable m+#endif++data Eval m = Eval + { structs :: ([Struct],[Struct]) -- auxiliary type declarations+ , treeState_ :: [(String,Type, Info -> m Statement)] -- tree state fields (name, type, init)+ , evalState_ :: [(String,Type, Info -> m Value)]+ , nextSameH :: Info -> m Statement+ , nextDiffH :: Info -> m Statement+ , pushLeftH :: Info -> m Statement+ , pushRightH :: Info -> m Statement+ , bodyH :: Info -> m Statement+ , initH :: Info -> m Statement+ , addH :: Info -> m Statement+ , returnH :: Info -> m Statement+ , failH :: Info -> m Statement+ , tryH :: Info -> m Statement+ , tryLH :: Info -> m Statement+ , startTryH :: Info -> m Statement+ , intArraysE :: [String]+ , boolArraysE :: [String]+ , intVarsE :: [String]+ , -- Free heap allocated memory for search heuristic associated to this node+ -- because it is being abandoned.+ --+ -- BE CAREFUL: deallocate memory only once in case of multiple references.+ --+ -- Example use case: untilLoop+ deleteH :: Info -> m Statement+ , toString :: String+ , canBranch :: m Bool+ , complete :: Info -> m Value+ }++commentStatement :: (HookStatsM m) => String -> Eval m -> (Info -> m Statement) -> (Info -> m Statement)+#ifdef OUTPUTCOMMENTS+commentStatement c e f = \x -> (f x >>= \s -> return (DebugOutput ("begin: " ++ c ++ " @ " ++ toString e) >>> s >>> DebugOutput ("end: " ++ c ++ " @ " ++ toString e)))+#else +commentStatement c e f = \x -> (f x >>= \s -> return (comment ("begin: " ++ c ++ " @ " ++ toString e) >>> s >>> comment ("end: " ++ c ++ " @ " ++ toString e)))+#endif++commentEval :: Evalable m => Eval m -> Eval m+#ifdef COMMENTS+commentEval e = + e { treeState_ = map (\(a,b,c) -> (a,b,commentStatement "treeState" e c)) (treeState_ e)+ , nextSameH = commentStatement "nextSame" e (nextSame e)+ , nextDiffH = commentStatement "nextDiff" e (nextDiff e)+ , pushLeftH = commentStatement "pushLeft" e (pushLeft e)+ , pushRightH = commentStatement "pushRight" e (pushRight e)+ , bodyH = commentStatement "bodyE" e (bodyE e)+ , initH = commentStatement "initE" e (initE e)+ , addH = commentStatement "addE" e (addE e)+ , returnH = commentStatement "returnE" e (returnE e)+ , failH = commentStatement "failE" e (failE e)+ , tryH = commentStatement "tryE" e (tryE e)+ , tryLH = commentStatement "tryE_" e (tryE_ e)+ , deleteH = commentStatement "deleteE" e (deleteE e)+ , startTryH = commentStatement "startTryE" e (startTryE e)+ }+#else+commentEval = id+#endif++entry :: Monad m => (String,Type,Value -> Statement) -> (String,Type,Info -> m Statement)+entry (name,ty,up) = (name, ty, \i -> return (up $ (@->name) $ tstate i))++rootEntry :: Monad m => [(String,Type,Info -> m Statement)]+rootEntry = [ entry ("space",Pointer SpaceType,assign RootSpace)+ ]++inits :: Evalable m => Eval m -> Info -> m Statement+inits e i = initTreeState_ i e @>>>@ initH e i++inite :: Monad m => [(String,Info -> m Value)] -> Info -> m Statement+inite fs i = mseqs [init i >>= \ini -> return (estate i @=> f <== ini) | (f,init) <- fs]++mkCopy i f = (tstate i @-> f) <== (tstate (old i) @-> f)+mkUpdate i f g = (tstate i @-> f) <== g (tstate (old i) @-> f)++mseqs lst = sequence lst >>= \s -> return (seqs s)++mapE :: (HookStatsM m, HookStatsM n) => (forall x. m x -> n x) -> Eval m -> Eval n+mapE x = mapE_ (const x)++data HookStat = HookStat { nCalls :: Integer }++newtype HookStatsT m a = HookStatsT { unHookStatsT :: StateT HookStat m a }+ deriving (Monad, StateM HookStat, FMonadT, MonadT)++runHookStatsT :: Monad m => HookStatsT m a -> m (a, Integer)+runHookStatsT m = do+ (a, s) <- runStateT (HookStat { nCalls = 0 }) $ unHookStatsT m+ return (a, nCalls s)++instance MonadInfoT HookStatsT where+ tminfo = miInc "HookStatsT" . minfo . runHookStatsT++class Monad m => HookStatsM m where+ hookCalled :: m ()++instance Monad m => HookStatsM (HookStatsT m) where+ hookCalled = modify (\st -> st { nCalls = 1 + nCalls st })++instance (MonadT t, HookStatsM m) => HookStatsM (t m) where+ hookCalled = lift hookCalled++callHook :: HookStatsM m => String -> Eval m -> Info -> m ()+callHook s e i = hookCalled++nextSame, nextDiff, pushLeft, pushRight, bodyE, addE, returnE, initE, failE, tryE, startTryE, tryE_, deleteE :: HookStatsM m => Eval m -> Info -> m Statement+nextSame e i = callHook "nextSame" e i >> nextSameH e i+nextDiff e i = callHook "nextDiff" e i >> nextDiffH e i+pushLeft e i = callHook "pushLeft" e i >> pushLeftH e i+pushRight e i = callHook "pushRight" e i >> pushRightH e i+bodyE e i = callHook "body" e i >> bodyH e i+addE e i = callHook "add" e i >> addH e i+returnE e i = callHook "return" e i >> returnH e i+initE e i = callHook "init" e i >> initH e i+failE e i = callHook "fail" e i >> failH e i+tryE e i = callHook "try" e i >> tryH e i+startTryE e i = callHook "startTry" e i >> startTryH e i+tryE_ e i = callHook "tryL" e i >> tryLH e i+deleteE e i = callHook "deleteH" e i >> deleteH e i++mapE_ :: (HookStatsM m, HookStatsM n) => (forall x. Maybe Info -> m x -> n x) -> Eval m -> Eval n+mapE_ f e =+ Eval { structs = structs e+ , treeState_ = map (\(s,t,m) -> (s,t,\i -> f (Just i) (m i))) (treeState_ e)+ , evalState_ = map (\(s,t,m) -> (s,t,\i -> f (Just i) (m i))) (evalState_ e)+ , nextSameH = \i -> f (Just i) (nextSame e i)+ , nextDiffH = \i -> f (Just i) (nextDiff e i)+ , pushLeftH = \i -> f (Just i) (pushLeft e i)+ , pushRightH = \i -> f (Just i) (pushRight e i)+ , bodyH = \i -> f (Just i) (bodyE e i)+ , addH = \i -> f (Just i) (addE e i)+ , returnH = \i -> f (Just i) (returnE e i)+ , initH = \i -> f (Just i) (initE e i)+ , failH = \i -> f (Just i) (failE e i)+ , tryH = \i -> f (Just i) (tryE e i)+ , startTryH = \i -> f (Just i) (startTryE e i)+ , tryLH = \i -> f (Just i) (tryE_ e i)+ , boolArraysE = boolArraysE e+ , intArraysE = intArraysE e+ , intVarsE = intVarsE e+ , deleteH = \i -> f (Just i) (deleteE e i)+ , toString = toString e+ , canBranch = f Nothing $ canBranch e+ , complete = \i -> f (Just i) (complete e i)+ } ++--------------------------------------------------------------------------------+-- SEARCH TRANSFORMERS+--------------------------------------------------------------------------------++#ifndef NOMEMO+buildMemoKey :: MemoM m => String -> Maybe (Eval m) -> Maybe Statement -> Info -> m MemoKey+buildMemoKey fn (Just e) _ i = do + t <- getMemo+ return $ MemoKey { memoFn = fn, memoInfo = Just i , memoStack = Just (toString e), memoExtra = Just (memoRead t), memoStatement = Nothing, memoParams = map fst (stackField i) }+buildMemoKey fn Nothing (Just s) i = do+ return $ MemoKey { memoFn = fn, memoInfo = Nothing, memoStack = Nothing , memoExtra = Nothing , memoStatement = Just s , memoParams = map fst (stackField i) }++lookupMemo :: Evalable m => String -> Maybe (Eval m) -> Maybe Statement -> Info -> m (Maybe MemoValue)+lookupMemo fn e s i = + do t <- getMemo+ key <- buildMemoKey fn e s i+ let r = Map.lookup key $ memoMap t+ case r of+ Nothing -> return ()+ Just k -> setMemo $ t { memoMap = Map.adjust (\x -> x { memoUsed = memoUsed x + 1 }) key (memoMap t) }+ return r++insertMemo :: Evalable m => String -> Maybe (Eval m) -> Statement -> (Int -> ([(String,Type,Value)], m Statement)) -> Info -> m MemoValue+insertMemo fn e s sm i =+ do t <- getMemo+ fl <- getFlags+ let n = memoCount t+ let (lst,ss) = sm n+ let ni = i { stackField = stackField i ++ (map (\(n,t,v) -> (rpx 0 fl t, n)) lst) }+ key <- buildMemoKey fn e (Just s) ni+ s2 <- ss+ let val = MemoValue { memoId = n+ , memoCode = s2+ , memoUsed = 1+ , memoFields = stackField ni+ }+ setMemo $ t { memoMap = Map.insert key val $ memoMap t+ , memoCount = n+1+ }+ return val++invokeMemo :: Evalable m => String -> Eval m -> (Eval m -> (Info -> m Statement)) -> (Info -> m Statement)+invokeMemo fn e x i = + do let def = x e+ r <- lookupMemo fn (Just e) Nothing i+ val <- case r of+ Nothing -> do val <- def i+ case val of+ Skip -> return Nothing+ _ -> do num <- insertMemo fn (Just e) val (const ([],return val)) i+ return $ Just num+ Just val -> return $ Just val+ case val of+ Nothing -> return Skip+ Just x -> cacheCall (fn ++ show (memoId x)) (stackField i) []++-- cacheCall :: String -> Info -> Statement+cacheCall :: Evalable m => String -> [(String,String)] -> [Value] -> m Statement+cacheCall fn i lst = do+ fl@(PrettyFlags pf) <- getFlags+ return $ SHook (fn ++ "(" ++ intercalate "," (map snd (fixArgs pf) ++ (map snd i) ++ (map (rpx 0 fl) lst)) ++ ");")++cacheStatement_ :: Evalable m => String -> (Int -> ([(String,Type,Value)], m Statement)) -> Info -> m Statement+cacheStatement_ fn sm i = + do let (olst,ss) = sm 0+ fl <- getFlags+ let ni = i { stackField = stackField i ++ (map (\(n,t,v) -> (rpx 0 fl t, n)) olst) }+ s <- ss+ x <- lookupMemo fn Nothing (Just s) ni+ val <- case x of+ Nothing -> do case s of+ Skip -> return Nothing+ _ -> do num <- insertMemo fn Nothing s sm i+ return $ Just num+ Just r -> return $ Just r+ case val of+ Nothing -> return Skip+ Just x -> do let (lst,_) = sm (memoId x)+ cacheCall (fn ++ show (memoId x)) (stackField i) (map (\(n,t,v) -> v) lst)++cacheStatement :: Evalable m => String -> Statement -> Info -> m Statement+cacheStatement fn s i = cacheStatement_ fn (const ([],return s)) i++{-+newtype MemoWrapper m a = MemoWrapper { runMemoWrapper :: m a }++instance MonadT MemoWrapper where+ lift = MemoWrapper+ treturn = MemoWrapper . return+ tbind (MemoWrapper a) f = MemoWrapper (a >>= (\x -> runMemoWrapper (f x)))++instance FMonadT MemoWrapper where+ tmap' d1 _d2 g f = MemoWrapper . f . fmapD d1 g . runMemoWrapper+-}++class Memoable m where+ memox :: String -> Info -> (Int -> ([(String,Type,Value)],m)) -> m++instance Memoable m => Memoable ((Type,Value) -> m) where+ memox name info f = \(typ,val) -> + case typ of + THook "void" -> memox name info (\n -> let (lst,m) = f n in (lst,m (typ,Var "WTF??")))+ _ -> memox name info (\n -> let (lst,m) = f n in (((nam n lst,typ,val):lst),m (typ,Var $ nam n lst)))+ where nam n lst = "arg_" ++ name ++ "_" ++ show n ++ "_" ++ show (length lst)++{-+instance Memoable m => Memoable (Value -> m) where+ memox name info f = \val -> memox name info (\n -> let (lst,m) = f n in (((nam n lst,Pointer (THook "void"),val):lst),m (Var $ nam n lst)))+ where nam n lst = "arg_" ++ name ++ "_" ++ show n ++ "_" ++ show (length lst)+-}++instance Evalable m => Memoable (m Statement) where+ memox name info f = cacheStatement_ ("cached_" ++ name) f info++memo :: Memoable m => String -> Info -> m -> m+memo name info m = memox name info (const ([],m))+-- memo name info m = m++++memoLoop super =+ super { startTryH = invokeMemo "startTry" super startTryE + , bodyH = invokeMemo "body" super bodyE + , failH = invokeMemo "fail" super failE+ , tryH = invokeMemo "try" super tryE + , addH = invokeMemo "add" super addE + , returnH = invokeMemo "ret" super returnE+ , tryLH = invokeMemo "try_" super tryE_+ , initH = invokeMemo "init" super initE+ , pushLeftH = invokeMemo "pushL" super pushLeft+ , pushRightH = invokeMemo "pushR" super pushRight+ , deleteH = invokeMemo "delete" super deleteE+ , nextSameH = invokeMemo "nextSame" super nextSame+ , nextDiffH = invokeMemo "nextDiff" super nextDiff+ }++cachedCommit :: Evalable m => Info -> m Statement+cachedCommit i = return (comment "begin commit") @>>>@ cacheStatement "commit" (commit i) i @>>>@ return (comment "end commit")++cachedAbort :: Evalable m => Info -> m Statement+cachedAbort i = return (comment "begin abort") @>>>@ cacheStatement "abort" (abort i) i @>>>@ return (comment "end abort")++-- cachedClone :: MemoM m => Info -> Info -> m Statement+cachedClone i j = return (comment "begin clone") @>>>@ cacheStatement "clone" (cloneIt i j) i @>>>@ return (comment "end clone")+-- cachedClone i j = return $ clone i j++rReaderT x m = runMemoReaderT x m+#else++cachedCommit x = return $ (comment "begin commit" >>> commit x >>> comment "end commit")+cachedAbort x = return $ (comment "begin abort" >>> abort x >>> comment "end abort")+cachedClone i j = return $ (comment "begin clone" >>> cloneIt i j >>> comment "end clone")+memo :: String -> Info -> m -> m+memo name info m = m+memoLoop = id+rReaderT = runReaderT+#endif+--------------------------------------------------------------------------------++--------------------------------------------------------------------------------+data SeqPos = OutS | FirstS | SecondS+ deriving (Show)++seqSwitch :: ReaderM SeqPos m => m a -> m a -> m a+seqSwitch l r = + do flag <- ask+ case flag of + FirstS -> l+ SecondS -> r++numSwitch n = + do flag <- ask+ n flag++(l1,l2) @++@ (l3,l4) = (l1 ++ l3, l2 ++ l4)+++ref_count = \i -> estate i @=> "ref_count"+ref_countx = \i s -> estate i @=> ("ref_count_" ++ s)+ref_count_type = THook "int"+--------------------------------------------------------------------------------++-- cloneBase i = resetClone $ info { baseTstate = estate i @=> "parent" }+cloneBase i = i { baseTstate = estate i @=> "parent" }+++(@>>>@) :: Evalable m => m Statement -> m Statement -> m Statement+(@>>>@) x y = do s1 <- x+ s2 <- y+ return (s1 >>> s2)++f @$ x = x >>= return . f+mf @. x = mf >>= \f -> f @$ x++--------------------------------------------------------------------------------+-- PRINTING+--------------------------------------------------------------------------------++-- printTreeStateType :: Monad m => Eval m -> String+printTreeStateType e =+ {- render $ pretty $-} Struct "TreeState" [ (ty,name) | (name,ty,_) <- treeState_ e ]++-- printEvalStateType :: Monad m => Eval m -> String+printEvalStateType e =+ {-render $ pretty $-} Struct "EvalState" [ (ty,name) | (name,ty,_) <- evalState_ e ]++-- initEvalState :: Monad m => Info -> Eval m -> Doc+initEvalState i e = mconcat $+-- {-vcat-} [SHook ((rp 0 ty) ++ " " ++ name ++ ";") | (name,ty,_) <- evalState_ e]+ [SHook "struct EvalState evalState;"]++initTreeState_ :: Monad m => Info -> Eval m -> m Statement+initTreeState_ i e = mseqs [ init i | (_,_,init) <- treeState_ e]+++-- initIntArrays :: Eval m -> Doc +initIntArrays eval =+ mconcat [ doc arr | arr <- nub $ sort $ intArraysE eval]+ where doc arr + | [(_,"")] <- reads arr :: [(Int,String)]+ = SHook ("vm->getSearchintVarArray(\"" ++ arr ++ "\", VAR_" ++ arr ++ ");")+ | otherwise + = SHook ("vm->getintVarArray(\"" ++ arr ++ "\", VAR_" ++ arr ++ ");")++-- initBoolArrays :: Eval m -> Doc +initBoolArrays eval =+ mconcat [ doc arr | arr <- nub $ sort $ boolArraysE eval]+ where doc arr + | [(_,"")] <- reads arr :: [(Int,String)]+ = SHook ("vm->getSearchboolVarArray(\"" ++ arr ++ "\", VAR_" ++ arr ++ ");")+ | otherwise + = SHook ("vm->getboolVarArray(\"" ++ arr ++ "\", VAR_" ++ arr ++ ");")++-- declIntArrays :: Eval m -> Doc +declIntArrays eval =+ mconcat [ doc arr | arr <- nub $ sort $ intArraysE eval]+ where doc arr + | [(_,"")] <- reads arr :: [(Int,String)]+ = SHook ("vector<int> VAR_" ++ arr ++ ";")+ | otherwise + = SHook ("vector<int> VAR_" ++ arr ++ ";")++declBoolArrays eval =+ mconcat [ doc arr | arr <- nub $ sort $ boolArraysE eval]+ where doc arr + | [(_,"")] <- reads arr :: [(Int,String)]+ = SHook ("vector<int> VAR_" ++ arr ++ ";")+ | otherwise + = SHook ("vector<int> VAR_" ++ arr ++ ";")++-- initIntVars :: Eval m -> Doc +initIntVars eval =+ mconcat [ doc var | var <- nub $ sort $ intVarsE eval]+ where doc var = SHook ("vm->getintVarIndex(\"" ++ var ++ "\", VAR_" ++ var ++ ");")++-- declIntVars :: Eval m -> Doc +declIntVars eval =+ mconcat [ doc var | var <- nub $ sort $ intVarsE eval]+ where doc var = SHook ("int VAR_" ++ var ++ ";")++corefn :: (Evalable m, WriterM ProgramString m) => Eval m -> m Statement+corefn eval =+ do fl <- getFlags+ sInitE <- inite (map (\(a,_,b) -> (a,b)) (evalState_ eval)) info+ sInitS <- inits eval info+ sTry <- startTryE eval info+ sNext <- nextSame eval info+ sBody <- bodyE eval info+ return $ seqs [ -- SHook $ "\n status = " ++ rpx 0 fl RootSpace ++ "->status();"+ SHook "\n"+ , SHook " st->queue = new std::vector<TreeState>();"+ , sInitE+ , sInitS+ , sTry+ , Block (SHook " while (!st->queue->empty())") $ seqs + [ SHook " /* pop first element */" + , SHook " TreeState popped_estate = st->queue->back();"+ , SHook " st->queue->pop_back();"+ , sNext+ , SHook " st->estate = popped_estate;"+ , sBody+ ]+ ]++mainfn :: (Evalable m, WriterM ProgramString m) => Eval m -> m Statement+mainfn eval =+ do core <- corefn eval+ return $ seqs [ SHook ("\n\nvoid eval(" ++ spacetype ModeFZ ++ "* root, VarMap* vm, Printer* p) {")+ , SHook "RootState rootState;"+ , SHook "RootState *st = &rootState;"+ , initIntVars eval+ , initBoolArrays eval+ , initIntArrays eval+ , core+ , SHook "}"+ ]++cppfn :: (Evalable m, WriterM ProgramString m) => Eval m -> m Statement+cppfn eval =+ do core <- corefn eval+ return $ seqs [ SHook ("\n\nvoid eval(" ++ spacetype ModeGecode ++ "* root, Printer *p) {")+ , SHook "RootState rootState;"+ , SHook "RootState *st = &rootState;"+ , SHook (" mgr.root(*root);")+ , core+ , SHook "}"+ ]++mcpfn :: (Evalable m, WriterM ProgramString m) => Eval m -> m Statement+mcpfn eval =+ do core <- corefn eval+ return $ seqs [ SHook ("\n\nvoid eval(" ++ spacetype ModeMCP ++ "* root) {")+ , SHook "RootState rootState;"+ , SHook "RootState *st = &rootState;"+ , core+ , SHook "}"+ ]++typedecls :: Evalable m => Eval m -> m Statement+typedecls eval =+ do fl <- getFlags+ return $ seqs [ SHook ("struct EvalState;")+ , SHook (render $ vcat $ [text "struct" <+> text name <> semi | Struct name _ <- fst $ structs eval])+ , SHook (render $ vcat $ map (prettyX fl) $ snd $ structs eval)+ , SHook (rpx 1 fl $ printTreeStateType eval)+ , SHook (rpx 1 fl $ printEvalStateType eval)+ , SHook (render $ vcat $ map (prettyX fl) $ fst $ structs eval)+ ]++declRootState :: Eval m -> Statement+declRootState eval = seqs [ SHook "typedef struct {"+ , SHook " TreeState estate;"+ , SHook " std::vector<TreeState> *queue;"+ , initEvalState info eval+ , SHook "} RootState;"+ ]+++generate :: (Evalable m, WriterM ProgramString m) => Eval m -> m ()+generate eval_ = + do fl <- getFlags+ types <- typedecls eval+ let header = seqs [ types+ , declIntVars eval+ , declBoolArrays eval+ , declIntArrays eval+ , declRootState eval+ ]+ main <- mainfn eval+ tell $ mempty { main = Just main, header = header }+ where eval = commentEval $ eval_ { treeState_ = rootEntry ++ treeState_ eval_ }++generatemcp :: (Evalable m, WriterM ProgramString m) => Eval m -> m ()+generatemcp eval_ = + do fl <- getFlags+ types <- typedecls eval+ let header = seqs [ types+ , declRootState eval+ ]+ main <- mcpfn eval+ tell $ mempty { main = Just main, header = header }+ where eval = commentEval $ eval_ { treeState_ = rootEntry ++ treeState_ eval_ }+++generatecpp :: (Evalable m, WriterM ProgramString m) => Eval m -> m ()+generatecpp eval_ = + do fl <- getFlags+ types <- typedecls eval+ let header = seqs [ SHook "#include \"statemgr/varaccessor.hh\""+ , types+ , declRootState eval+ , SHook "StateMgr mgr;"+ ]+ main <- cppfn eval+ tell $ mempty { main = Just main, header = header }+ where eval = commentEval $ eval_ { treeState_ = rootEntry ++ treeState_ eval_ }++rp n = render . nest n . pretty+rpx n s = render . nest n . prettyX s++--------------------------------------------------------------------------------+-- COMPOSITION COMBINATORS+--------------------------------------------------------------------------------++-- def vars = label vars lbV minV minD ($==)++type MkEval m = Evalable m => Eval m -> State Int (Eval m)++fixall :: Evalable m => MkEval m -> Eval m+fixall f = let this = fst $ runState 0 $ f this+ in this++data Search = forall t2. (FMonadT t2, MonadInfoT t2) =>+ Search { mkeval :: forall m t1. (HookStatsM m, MonadInfoT t1, FMonadT t1, Evalable m) => MkEval ((t1 :> t2) m)+ , runsearch :: forall m x. (Evalable m) => t2 m x -> m x+ }++#ifndef NOMEMO+memoize :: Search+memoize = + Search { mkeval = return . memoLoop+ , runsearch = runIdT+ }+#endif++{-# RULES+ "L" L = unsafeCoerce+ #-}+{-# RULES+ "runL" runL = unsafeCoerce+ #-}+{-# RULES+ "unsafeCoerce/unsafeCoerce" unsafeCoerce . unsafeCoerce = unsafeCoerce+ #-}+{-# RULES+ "mmap/unsafeCoerce" mmap unsafeCoerce = unsafeCoerce+ #-}+{-# RULES+ "mapE/unsafeCoerce" mapE unsafeCoerce = unsafeCoerce+ #-}++(<@>)+ :: Search -> Search -> Search+s1 <@> s2 = + case s1 of+ Search { mkeval = evals1, runsearch = runs1 } ->+ case s2 of+ Search { mkeval = evals2, runsearch = runs2 } ->+ Search {mkeval =+ \super -> do { s2' <- evals2 $ mapE (L . L . mmap runL . runL) super+ ; s1' <- evals1 (mapE runL s2')+ ; return $ mapE (L . mmap L . runL) s1'+ }+ , runsearch = runs2 . runs1 . runL+ }+++data SearchCombiner = forall t1 t2. (FMonadT t1, FMonadT t2, MonadInfoT t1, MonadInfoT t2) =>+ SearchCombiner { runner :: forall m x. Evalable m => ((t1 :> t2) m) x -> m x+ , elems :: [SearchCombinerElem t1 t2]+ }+++data SearchCombinerElem t1 t2 =+ SearchCombinerElem { mapper :: forall t' m. (FMonadT t', MonadInfoT t', Evalable m) => Eval (t' ((t1 :> t2) m)) -> State Int (Eval (t' ((t1 :> t2) m)))+ }+++extractCombiners :: (Evalable m, FMonadT t', MonadInfoT t', FMonadT t1, MonadInfoT t1, FMonadT t2, MonadInfoT t2) => [SearchCombinerElem t1 t2] -> Eval (t' ((t1 :> t2) m)) -> State Int [(Eval (t' ((t1 :> t2) m)))]+extractCombiners [] _ = return []+extractCombiners (SearchCombinerElem { mapper=m }:b) super = + do prev <- extractCombiners b super+ next <- m super+ return $ (next) : prev+++buildCombiner [s] =+ case s of+ Search { mkeval = evals, runsearch = runs } ->+ SearchCombiner { runner = runIdT . runs . runL+ , elems = [SearchCombinerElem { mapper = liftM (mapE (mmap L . runL)) . evals . mapE (L . mmap runL)+ }]+ }+buildCombiner (s:ss) =+ case s of+ Search { mkeval = evals, runsearch = runs } ->+ case buildCombiner ss of+ SearchCombiner { runner = runner, elems = elems } ->+ SearchCombiner { runner = runner . runs . runL+ , elems = SearchCombinerElem { mapper = liftM (mapE (mmap L . runL)) . evals . mapE (L . mmap runL)+ } : liftSearchCombinerElems elems+ }++++liftSearchCombinerElems :: (FMonadT t1, FMonadT t0, FMonadT t2, MonadInfoT t1, MonadInfoT t0, MonadInfoT t2) => [SearchCombinerElem t1 t2] -> [SearchCombinerElem t0 (t1 :> t2)]+liftSearchCombinerElems [] = []+liftSearchCombinerElems (s:ss) = + case s of + SearchCombinerElem { mapper = m } ->+ SearchCombinerElem { mapper = liftM (mapE (mmap L . runL)) . m . mapE (L . mmap runL)+ } : liftSearchCombinerElems ss++mmap :: (FMonadT t, MonadInfoT t, Monad m, Monad n, MonadInfo m) => (forall x. m x -> n x) -> t m a -> t n a+mmap f x = tmap' mfunctor mfunctor id f x++mfunctor :: Monad m => FunctorD m+mfunctor = FunctorD { fmapD = \f m -> m >>= return . f }++evalSStateT m s = runSStateT m s >>= \t -> case t of { Tup2 a _ -> return a }++data FunctionDef = FunctionDef { funName :: String, funArgs :: [(Type,String)], funBody :: Statement }++genfun :: PrettyFlags -> FunctionDef -> String+genfun fl f = rpx 0 fl $+ Block + (SHook ("void " ++ funName f ++ "(" ++ intercalate "," [ rpx 0 fl t ++ " " ++ an | (t,an) <- funArgs f ] ++ ")"))+ (funBody f)++data ProgramString = ProgramString { header :: Statement+ , functions :: [FunctionDef]+ , main :: Maybe Statement+ , pcomment :: [String]+ }++transformProgram fn p = p { header = inliner fn (header p), functions = map (\f -> f { funBody = inliner fn (funBody f) }) (functions p), main = maybe Nothing (Just . inliner fn) (main p) }++instance Monoid ProgramString where+ mempty = ProgramString { header = Skip, functions = [], main = Nothing, pcomment = [] }+ mappend p1 p2 = ProgramString { header = header p1 >>> header p2, functions = functions p1 ++ functions p2, main = maybe (main p2) Just (main p1), pcomment = pcomment p1 ++ pcomment p2 }++genprog :: PrettyFlags -> ProgramString -> String+genprog fl p = concatMap (\x -> "// " ++ x ++ "\n\n") (pcomment p) ++ rpx 0 fl (header p) ++ concatMap (\x -> "\n" ++ genfun fl x ++ "\n") (functions p) ++ maybe "" (rpx 0 fl) (main p)++monadInfo :: MInfo -> (Int,Int,Int)+monadInfo (MInfo x) = + let total = sum $ map snd $ Map.toList x+ identities = Map.findWithDefault 0 "Id" x + Map.findWithDefault 0 "IdT" x+ zippers = Map.findWithDefault 0 ":>" x+ in (total - (identities+zippers),zippers,identities)++getgen :: (Evalable m, WriterM ProgramString m) => Eval m -> m ()+getgen x = do+ fl <- getFlags+ case genMode fl of+ ModeFZ -> generate x+ ModeMCP -> generatemcp x+ ModeGecode -> generatecpp x+ ModeUnk -> error "Unknown generator?"++search' :: GenMode -> Search -> ProgramString+#ifdef NOMEMO+search' fl s = + case s of+ Search { mkeval = evals, runsearch = runs } -> do+ let fevals = fixall $ evals+ in case runId $ runGenModeT fl $ runHookStatsT $ evalSStateT Map.empty $ unVarInfoT $ runs $ runWriterT $ getgen $ mapE runL $ fevals+ of (((_,eval)),n) -> let cmt = show $ monadInfo $ minfo $ canBranch $ fevals+ in eval { pcomment = ["Combinator stats: " ++ cmt, "Hook calls: " ++ show n]}+#else+refType t n =+ case t of+ x | last x == '*' -> n+ "int" -> n+ "bool" -> n+ _ -> '&' : n++search' fl s = + case memoize <@> s of+ Search { mkeval = evals, runsearch = runs } -> do+ let fevals = fixall $ evals+ in case runId $ runGenModeT fl $ runHookStatsT $ runMemoT $ evalSStateT Map.empty $ unVarInfoT $ runs $ runWriterT $ getgen $ mapE runL $ fevals+ of (((_,eval),t),n) -> let {- m = inlineMap t -}+ p = {- transformProgram m -} (mempty { functions = map toFun (filter (not . needInline) t) } `mappend` eval)+ cmt = show $ monadInfo $ minfo $ canBranch $ fevals+ in p { pcomment = ["Combinator stats: " ++ cmt, "Hook calls: " ++ show n]}+ where toFun (key,val) = FunctionDef { funName = memoFn key ++ show (memoId val), funArgs = mm (map (\x -> (THook (fst x), refType (fst x) $ snd x)) (memoFields val)), funBody = simplify (memoCode val) }+ mm = ((fixArgs fl) ++)++fixArgs ModeMCP = [ -- (Pointer (THook "Gecode::SpaceStatus"), "status") + (Pointer (THook "RootState"), "st")+ ]+fixArgs _ = [ -- (Pointer (THook "Gecode::SpaceStatus"), "status")+ (Pointer (THook "RootState"), "st"),+ (Pointer (THook "Printer"),"p") + ]++needInline (key,val) = False {- (memoUsed val <= 1) -}+{-needInline (key,val) = + let code = simplify $ memoCode val+ res = (memoUsed val <= 1) || (case code of { Seq _ _ -> False; Block _ _ -> False; Skip -> True; _ -> True })+ in trace ("needInline? " ++ show code ++ " -> " ++ show res ++ "\n") res+-}+-- needInline _ = False++inlineMap fl fns = do+ lst <- mapM (\(key,val) -> cacheCall (memoFn key ++ show (memoId val)) (memoFields val) [] >>= \c -> return (c, memoCode val)) [ x | x <- fns, needInline x ]+ return $ Map.fromList lst++#endif+++search :: Search -> String+search s = genprog (PrettyFlags ModeMCP) (search' ModeMCP s)
+ Control/Search/GeneratorInfo.hs view
@@ -0,0 +1,120 @@+module Control.Search.GeneratorInfo where ++import Control.Search.Language++type TreeState = Value+type EvalState = Value+space i = baseTstate i @-> "space"++data Info = Info { baseTstate :: TreeState+ , path :: TreeState -> TreeState+ , abort_ :: [Statement -> Statement] + , commit_ :: [Statement -> Statement]+ , old :: Info+ , clone :: Info -> Statement+ , field :: String -> Value+ , stackField :: [(String,String)]+ , treeStateType :: Type+ , evalStateType :: Type+ }++(@@) :: Ordering -> Ordering -> Ordering+EQ @@ x = x+x @@ _ = x++instance Ord Info where+ compare a b = compare (baseTstate a) (baseTstate b) + @@ compare (path a $ baseTstate a) (path b $ baseTstate b)+ @@ compare (map ($ Skip) $ abort_ a) (map ($ Skip) $ abort_ b)+ @@ compare (map ($ Skip) $ commit_ a) (map ($ Skip) $ commit_ b)+ @@ compare (clone a (resetClone a)) (clone b (resetClone b))++instance Eq Info where+ a == b = case compare a b of { EQ -> True; _ -> False }++type Field = String++tstate i = path i (baseTstate i)+tstate_type i = treeStateType i++-- VHook ("/* " ++ show (estate_type i) ++ " */ null")+estate i = case estate_type i of+ Pointer (SType (Struct "EvalState" _)) -> Ref (Var $ "st->evalState")+ Pointer (THook "EvalState") -> Ref (Var "st->evalState")+ _ -> (tstate i) @-> "evalState"++estate_type i = evalStateType i++withCommit i f = i { commit_ = f : commit_ i }+onAbort i stmt = i { abort_ = (stmt >>>) : abort_ i }+onCommit i stmt = i `withCommit` (stmt >>>)+onCommit' i stmt = i `withCommit` (>>> stmt)+withPath i p e t = i { path = p . path i+ , old = withPath (old i) p e t+ , evalStateType = e+ , treeStateType = t+ }+withBase i str = i { baseTstate = Var str, stackField = ("TreeState",str):(stackField i) }++withClone i stmt = i { clone = \j -> clone i j >>> stmt (i { baseTstate = baseTstate j }) }+withField i (f,g) = i { field = \f' -> if f' == f then g i else field i f' }++resetPath i = i { path = id+ , old = resetPath $ old i + , treeStateType = Pointer (THook "TreeState")+ , evalStateType = Pointer (THook "EvalState")+ }+resetCommit i = i { commit_ = [const $ comment "Delete-resetCommit" >>> (Delete $ space i)] }+shiftCommit i = i { commit_ = tail $ commit_ i }+resetAbort i = i { abort_ = [const $ comment "Delete-resetAbort" >>> (Delete $ space i)] }+shiftAbort i = i { abort_ = tail $ abort_ i }+resetClone i = i { clone = const Skip }++resetInfo i = i { path = id+ , old = resetInfo $ old i+ , commit_ = [ const $ comment "Delete-resetInfo-commit_" >>> (Delete $ space i) ]+ , abort_ = [ const $ comment "Delete-resetInfo-abort_" >>> (Delete $ space i), const (comment "reset")]+ , clone = const Skip+ , treeStateType = Pointer (THook "TreeState")+ , evalStateType = Pointer (THook "EvalState")+ }++mkInfo name =+ let i = Info { baseTstate = Var name+ , path = id+ , abort_ = [const $ comment "Delete-mkInfo-abort_" >>> (Delete $ space i)]+ , commit_ = [const $ comment "Delete-mkInfo-commit_" >>> (Delete $ space i)]+ , old = i+ , clone = const Skip+ , field = \f -> error ("unknown field `" ++ f ++ "'")+ , stackField = []+ , treeStateType = Pointer (THook "TreeState")+ , evalStateType = Pointer (THook "EvalState")+ }+ in i++info = mkInfo "st->estate"++newinfo i n = + Info { baseTstate = Var $ "nstate" ++ n+ , path = id+ , abort_ = [const Skip]+ , commit_ = [const Skip]+ , old = resetPath i+ , clone = const Skip+ , field = \f -> error ("unknown field `" ++ f ++ "'")+ , stackField = [("TreeState","nstate" ++ n)]+ , treeStateType = Pointer (THook "TreeState")+ , evalStateType = Pointer (THook "EvalState")+ }++commit i = go $ commit_ i+ where go [] = Skip+ go (f:fs) = f (go fs)+abort i = go $ abort_ i + where go [] = Skip+ go (f:fs) = f (go fs)++primClone i = \j -> space j <== Clone (space i)++cloneIt i j = primClone i j >>> clone i j
+ Control/Search/Language.hs view
@@ -0,0 +1,531 @@+{-# LANGUAGE FlexibleInstances #-}++module Control.Search.Language where ++import Text.PrettyPrint+import Data.Monoid+import Data.Int+import qualified Data.Map as Map+import Data.Map (Map)+++spacetype ModeFZ = "FlatZincSpace"+spacetype ModeGecode = "State"+spacetype ModeMCP = "MCPProgram"++xsspace fl@(PrettyFlags ModeFZ) x str = prettyX fl (PField x str)+xsspace fl@(PrettyFlags ModeMCP) x str = prettyX fl (PField x str)+xsspace fl@(PrettyFlags ModeGecode) x str = text "((VarAccessorSpace*)msg.space(" <> prettyX fl x <> text "))->" <> text str++instance Monoid Statement where+ mempty = Skip+ mappend = (>>>)++data GenMode = ModeUnk | ModeGecode | ModeFZ | ModeMCP+ deriving Eq++data PrettyFlags = PrettyFlags { genMode :: GenMode }+ deriving Eq++renderVar :: PrettyFlags -> Value -> Doc+renderVar f@(PrettyFlags { genMode = ModeFZ }) x = case x of+ (AVarElem vs s i) -> xsspace f s "iv" <> brackets (text "VAR_" <> text vs <> brackets (pr_ i))+ (AVarSize vs s) -> text "VAR_" <> text vs <> text ".size()"+ (BAVarElem vs s i) -> xsspace f s "bv" <> brackets (text "VAR_" <> text vs <> brackets (pr_ i))+ (BAVarSize vs s) -> text "VAR_" <> text vs <> text ".size()"+ (IVar vs s) -> xsspace f s "iv" <> brackets (text "VAR_" <> text vs)+ where pr_ :: Value -> Doc+ pr_ = prettyX f+renderVar f@(PrettyFlags { genMode = ModeGecode }) x = case x of+ (AVarElem vs s i) -> xsspace f s "va.iv" <> parens (text "idx" <> parens (xsspace f s "va.map()" <> text ",\"" <> text vs <> text "\"") <> text "+" <> pr_ i)+ (AVarSize vs s) -> text "size" <> parens (xsspace f s "va.map()" <> text ",\"" <> text vs <> text "\"")+ (BAVarElem vs s i) -> xsspace f s "va.bv" <> parens (text "idx" <> parens (xsspace f s "va.map()" <> text ",\"" <> text vs <> text "\"") <> text "+" <> pr_ i)+ (BAVarSize vs s) -> text "size" <> parens (xsspace f s "va.map()" <> text ",\"" <> text vs <> text "\"")+ (IVar vs s) -> xsspace f s "va.iv" <> parens (text "idx" <> parens (xsspace f s "va.map()" <> text ",\"" <> text vs <> text "\""))+ where pr_ :: Value -> Doc+ pr_ = prettyX f+renderVar f@(PrettyFlags { genMode = ModeMCP }) x = case x of+ (AVarElem vs s i) -> xsspace f s vs <> brackets (pretty i)+ (AVarSize vs s) -> xsspace f s vs <> text ".size()"+ (BAVarElem vs s i) -> xsspace f s vs <> brackets (pretty i)+ (BAVarSize vs s) -> xsspace f s vs <> text ".size()"+ (IVar vs s) -> xsspace f s vs++renderVar f@(PrettyFlags { genMode = ModeUnk }) _ = error "Cannot generate variable without render mode!"+++class Pretty x where+ prettyX :: PrettyFlags -> x -> Doc+ pretty :: x -> Doc+ prettyX _ = pretty+ pretty = prettyX (PrettyFlags { genMode = ModeUnk })++data Struct = Struct String [(Type,String)] deriving (Show, Eq, Ord)++instance Pretty Struct where+ prettyX x (Struct name fields) =+ text "struct" <+> text name <+> text "{"+ $+$ nest 2 (vcat [prettyX x ty <+> text f <> text ";" | (ty,f) <- fields])+ $+$ text "};" +++data Type = Pointer Type+ | SpaceType+ | Int+ | Bool+ | Union [(Type,String)]+ | SType Struct+ | THook String+ deriving (Show, Eq, Ord)++data Value = IVal Int32+ | BVal Bool+ | RootSpace+ | Minus Value Value+ | Plus Value Value+ | Mult Value Value+ | Div Value Value+ | Mod Value Value+ | Abs Value+ | Var String+ | Ref Value+ | Deref Value+ | Clone Value+ | Field String String+ | Field' Value String+ | PField Value String+ | Lt Value Value+ | Gq Value Value+ | Gt Value Value+ | Eq Value Value+ | BaseContinue+ | And Value Value+ | Or Value Value+ | Not Value+ | VHook String+ | Max Value Value+ | AVarElem String Value Value+ | AVarSize String Value+ | BAVarElem String Value Value+ | BAVarSize String Value+ | IVar String Value+ | MinDom Value+ | MaxDom Value+ | Degree Value+ | WDegree Value+ | UbRegret Value+ | LbRegret Value+ | Median Value+ | Random + | Null+ | New Struct+ | Base+ | Cond Value Value Value+ | Assigned Value+ | Dummy Int+ | MaxVal+ | MinVal+ deriving (Show, Eq, Ord)++instance Num Value where+ (-) = Minus+ fromInteger = IVal . fromInteger+ (+) = Plus+ (*) = Mult+ abs = Abs+ signum = error "signum is not defined for Value"++divValue (IVal x) (IVal y) = IVal (x `div` y)+divValue x y = Div x y++true = BVal True+false = BVal False+(&&&) = And+(|||) = Or+(@>) = Gt+(@>=) = Gq+x @<= y = y `Gq` x+(@==) = Eq+(@->) = Field' +(@=>) = PField +(@<) = Lt+lex cmps l1 l2 = foldr (\(x,y,cmp) r -> (x `cmp` y) ||| ((x @== y) &&& r)) false (zip3 l1 l2 cmps)++simplValue :: Value -> Value+simplValue (Cond c t e) =+ let c' = simplValue c+ t' = simplValue t+ e' = simplValue e+ in case (c',t',e') of+ (BVal True, _, _) -> t'+ (BVal False, _, _) -> e'+ _ | t' == e' -> t'+ _ -> Cond c' t' e'+simplValue (Minus (IVal x) (IVal y)) = IVal (x - y)+simplValue (Lt x y) = Lt (simplValue x) (simplValue y)+simplValue (Gq x y) = Gq (simplValue x) (simplValue y)+simplValue (And x y) =+ let x' = simplValue x+ y' = simplValue y+ in case (x',y') of+ (x, (BVal True)) -> x + (x, (BVal False)) -> BVal False+ _ -> And x' y'+simplValue (Not x) =+ let x' = simplValue x+ in case x' of+ (BVal True) -> BVal False+ (BVal False) -> BVal True+ _ -> Not x'+simplValue (PField (Ref x) f) = Field' (simplValue x) f+simplValue v = v++instance Pretty Type where+ prettyX x (Pointer t) = prettyX x t <> text "*"+ prettyX x SpaceType = text $ spacetype (genMode x)+ prettyX x Int = text "int"+ prettyX x Bool = text "bool"+ prettyX x (Union fields) = + text "union" <+> text "{"+ $+$ nest 2 (vcat [prettyX x ty <+> text f <> text ";" | (ty,f) <- fields])+ $+$ text "}" + prettyX x (SType (Struct name fields)) =+ text name+ prettyX x (THook str) = + text str++instance Pretty Value where+ prettyX x = prettyX_ x . simplValue+ where+ prettyX_ :: PrettyFlags -> Value -> Doc+ prettyX_ _ (Cond c t e) = pr_ c <+> text "?" <+> pr_ t <+> text ":" <+> pr_ e+ prettyX_ _ Base = text "<BASE>"+ prettyX_ _ Null = text "NULL"+ prettyX_ _ (IVal i) = int $ fromInteger $ toInteger i+ prettyX_ _ (BVal True) = text "true" + prettyX_ _ (BVal False) = text "false" + prettyX_ _ (Abs x) = text "abs" <> parens (pr_ x)+ prettyX_ fl RootSpace = case (genMode fl) of+ ModeFZ -> text "root"+ ModeGecode -> text "mgr.root()"+ ModeMCP -> text "root"+ prettyX_ _ (Minus v1 v2) = pr_ v1 <+> text "-" <+> pr_ v2+ prettyX_ _ (Plus v1 v2) = pr_ v1 <+> text "+" <+> pr_ v2+ prettyX_ _ (Mult v1 v2) = pr_ v1 <+> text "*" <+> pr_ v2+ prettyX_ _ (Div v1 v2) = parens (pr_ v1) <+> text "/" <+> parens (pr_ v2)+ prettyX_ _ (Mod v1 v2) = parens (pr_ v1) <+> text "%" <+> parens (pr_ v2)+ prettyX_ _ (Ref x) = parens $ text "&" <> parens (pr_ x)+ prettyX_ _ (Deref x) = parens $ text "*" <> parens (pr_ x)+ prettyX_ _ (Var x) = text x+ prettyX_ f (Clone x) = text ("static_cast<" ++ spacetype (genMode f) ++ "*>(") <> pr_ x <> text "->clone(true))"+ -- prettyX_ (Clone x) = text ("static_cast<" ++ spacetype ++ "*>(") <> pretty_ x <> text "->clone(false))"+ prettyX_ _ (Field r f) = text r <> text "." <> text f+ prettyX_ _ (Field' r f) = pr_ r <> text "." <> text f+-- prettyX_ (PField (Field' (Var "estate") "evalState") f) = text f+-- prettyX_ (PField (Field' (Var "nstate") "evalState") f) = text f+-- prettyX_ (PField (Field' (Var _) "evalState") f) = text f+ prettyX_ _ (PField r f) = pr_ r <> text "->" <> text f+ prettyX_ _ (Lt x y) = parens (pr_ x) <+> text "<" <+> parens (pr_ y) + prettyX_ _ (Gq x y) = parens (pr_ x) <+> text ">=" <+> parens (pr_ y) + prettyX_ _ (Gt x y) = parens (pr_ x) <+> text ">" <+> parens (pr_ y) + prettyX_ _ (Eq x y) = parens (pr_ x) <+> text "==" <+> parens (pr_ y) + prettyX_ _ BaseContinue = text "!st->queue->empty()"+ prettyX_ _ (And x y) = parens (pr_ x) <+> text "&&" <+> parens (pr_ y) + prettyX_ _ (Or x y) = parens (pr_ x) <+> text "||" <+> parens (pr_ y) + prettyX_ _ (Not x) = text "!" <> parens (pr_ x)+ prettyX_ _ (VHook s) = text s+ prettyX_ _ (Max x y) = text "max" <> parens (pr_ x <> text "," <> pr_ y)+ prettyX_ e v@(AVarElem _ _ _) = renderVar e v+ prettyX_ e v@(AVarSize _ _) = renderVar e v+ prettyX_ e v@(BAVarElem _ _ _) = renderVar e v+ prettyX_ e v@(BAVarSize _ _) = renderVar e v+ prettyX_ e v@(IVar _ _) = renderVar e v+ prettyX_ _ (MinDom v) = pr_ v <> text ".min()"+ prettyX_ _ (MaxDom v) = pr_ v <> text ".max()"+ prettyX_ _ (Degree v) = pr_ v <> text ".degree()"+ prettyX_ _ (WDegree v) = pr_ v <> text ".afc()" -- aka accumulated failure count+ prettyX_ _ (UbRegret v) = pr_ v <> text ".regret_max()"+ prettyX_ _ (LbRegret v) = pr_ v <> text ".regret_min()"+ prettyX_ _ (Median v) = pr_ v <> text ".med()"+ prettyX_ _ MaxVal = text "Gecode::Int::Limits::max"+ prettyX_ _ MinVal = text "Gecode::Int::Limits::min"+ prettyX_ _ Random = text "rand()"+ prettyX_ _ (New (Struct name _)) = text "new" <+> text name+ prettyX_ _ (Assigned var) = pr_ var <> text ".assigned()"+ pr :: Value -> Doc+ pr = prettyX x+ pr_ :: Value -> Doc+ pr_ = prettyX_ x++data Constraint = EqC Value Value+ | NqC Value Value+ | LtC Value Value+ | LqC Value Value+ | GtC Value Value+ | GqC Value Value+ | TrueC+ | FalseC+ deriving (Eq, Ord, Show)++($==) = EqC+($/=) = NqC+($<) = LtC+($<=) = LqC+($>) = GtC+($>=) = GqC++neg (EqC x y) = NqC x y+neg (NqC x y) = EqC x y+neg (LtC x y) = GqC x y+neg (LqC x y) = GtC x y+neg (GtC x y) = LqC x y+neg (GqC x y) = LtC x y++instance Pretty Constraint where+ prettyX f (EqC x y) =+ prettyX f x <> text "," <> text "IRT_EQ" <> text "," <> prettyX f y+ prettyX f (NqC x y) =+ prettyX f x <> text "," <> text "IRT_NQ" <> text "," <> prettyX f y+ prettyX f (LtC x y) =+ prettyX f x <> text "," <> text "IRT_LE" <> text "," <> prettyX f y+ prettyX f (LqC x y) =+ prettyX f x <> text "," <> text "IRT_LQ" <> text "," <> prettyX f y+ prettyX f (GtC x y) =+ prettyX f x <> text "," <> text "IRT_GR" <> text "," <> prettyX f y+ prettyX f (GqC x y) =+ prettyX f x <> text "," <> text "IRT_GQ" <> text "," <> prettyX f y+ prettyX f TrueC = error "true constraint can't be posted directly"+ prettyX f FalseC = error "false constraint can't be posted directly"+++data Statement = IfThenElse Value Statement Statement+ | Push Value+ | Skip+ | Seq Statement Statement+ | Assign Value Value+ | Abort+ | Print Value [String]+ | SHook String+ | Post Value Constraint+ | Fold String Value Value Value (Value -> Value) (Value -> Value -> Value)+ | IFold String Value Value Value (Value -> Value) (Value -> Value -> Value)+ | BFold String Value Value Value (Value -> Value) (Value -> Value -> Value)+ | BIFold String Value Value Value (Value -> Value) (Value -> Value -> Value)+-- | MFold String [(Value, Value->Value)] ([Value] -> [Value] -> Value)+ | Delete Value+ | Block Statement Statement+ | DebugOutput String+ | DebugValue String Value+ deriving (Eq,Ord,Show)++inliner :: (Statement -> Maybe Statement) -> Statement -> Statement+inliner f s =+ case f s of+ Just x -> inliner f x+ Nothing -> case s of+ IfThenElse v s1 s2 -> IfThenElse v (inliner f s1) (inliner f s2)+ Seq s1 s2 -> Seq (inliner f s1) (inliner f s2)+ Block s1 s2 -> Block s1 (inliner f s2)+ _ -> s++instance Ord (Value -> Value) where+ compare a b = compare (a (Dummy 0)) (b (Dummy 0))++instance Eq (Value -> Value) where+ a == b = (a (Dummy 1)) == (b (Dummy 1))++instance Show (Value -> Value) where+ show a = show (a (Dummy 1))++instance Ord (Value -> Value -> Value) where+ compare a b = compare (a (Dummy 2) (Dummy 3)) (b (Dummy 2) (Dummy 3))++instance Eq (Value -> Value -> Value) where+ a == b = (a (Dummy 4) (Dummy 5)) == (b (Dummy 4) (Dummy 5))++instance Show (Value -> Value -> Value) where+ show a = show (a (Dummy 1) (Dummy 2))++comment str = SHook ("// " ++ str)++dec var = Assign var (var - 1)+inc var = Assign var (var + 1)+(>>>) = Seq+(<==) = Assign+assign = flip Assign+ifthen c t = IfThenElse c t Skip+seqs = foldr (>>>) Skip++simplStmt :: Statement -> Statement+simplStmt (IfThenElse c t e)+ = let c' = simplValue c+ t' = simplStmt t+ e' = simplStmt e+ in go c' t' e'+ where go (BVal True) t e = t+ go (BVal False) t e = e + go c t e | t == e = t+ go c Skip e = simplStmt $ IfThenElse (Not c) e t+ go c1 (IfThenElse c2 t2 e2) e1 + | e1 == e2 = simplStmt $ IfThenElse (c1 &&& c2) t2 e1 + go c t e = IfThenElse c t e+simplStmt (Assign x y) | x==y = Skip+simplStmt (Seq Skip a) = simplStmt a+simplStmt (Seq a Skip) = simplStmt a+simplStmt s = s++instance Pretty Statement where+ prettyX x = prettyX_ . simplStmt+ where+ prettyX_ (Push tstate) = + text "st->queue->push_back" <> parens (pr tstate) <> text ";"+ prettyX_ (IfThenElse c t Skip) = text "if" <+> parens (pr c) <+> text "{" $+$ nest 2 (pr t) $+$ text "}"+ prettyX_ (IfThenElse c t e) = text "if" <+> parens (pr c) <+> text "{" $+$ nest 2 (pr t) $+$ text "} else {" $+$ nest 2 (pr_ e) $+$ text "}"+ prettyX_ Skip =+ empty+ prettyX_ (Assign var (Minus val 1))+ | var == val+ = pr var <> text "--;"+ prettyX_ (Assign var (Plus val 1))+ | var == val+ = pr var <> text "++;"+ prettyX_ (Block s1 s2) = pr s1 <+> text "{" $+$ nest 2 (pr s2) $+$ text "}"+ prettyX_ (Seq s1 s2) =+ pr s1 $+$ pr s2+ prettyX_ (Assign x Null) = pr x <> text ";"+ prettyX_ (Assign x y) = let y' = simplValue y+ in if x == y' + then pr Skip+ else pr x <+> text "=" <+> pr y' <> text ";"+ prettyX_ Abort =+ text "break;"+ prettyX_ (Print space vs) = + (vcat $ map (\s -> text "std::cout << \"[\"; for (int i=0; i<" <> pr (AVarSize s space) <> text "; i++) { std::cout << " <> pr (AVarElem s space (Var "i")) <> text " << \" \"; }; std::cout << \"] \";") vs) <> text "std::cout << std::endl;"+ prettyX_ (DebugOutput str) = + text "cout << " <> text (show str) <> text " << endl;"+ prettyX_ (DebugValue str val) = + text "cout << " <> text (show $ str ++ ": ") <> text " << " <> pr val <> text " << endl;"+ prettyX_ (SHook s) =+ text s+ prettyX_ (Post space FalseC) = pr space <> text "->fail();"+ prettyX_ (Post space TrueC) = empty+ prettyX_ (Post space c) = + text "rel(*" <> parens (pr space) <> text "," <> pr c <> text ");" + prettyX_ (Fold vars state space m0 metric better) = + let+ pos = Field' state "pos"+ size = AVarSize vars space+ in+ text "int best_pos = -1;" + $+$ pr (Assign pos 0)+ $+$ text "for (int metric = " <> pr m0 <> text "; " <> pr (pos @< size ) <> text "; " <> pr pos <> text "++) {"+ $+$ nest 2 (text "if" <+> parens (text "!" <> pr (AVarElem vars space pos) <> text ".assigned()") <+> text "{"+ $+$ nest 2 ( text "int current_metric = " <> pr (metric (AVarElem vars space pos)) <> text ";"+ $+$ pr (IfThenElse (Var "current_metric" `better` Var "metric")+ (Assign (Var "metric") (Var "current_metric") >>> (Assign (Var "best_pos") pos))+ Skip+ )+ )+ $+$ text "}"+ )+ $+$ text "}" + $+$ pr (Assign pos (Var "best_pos")) + prettyX_ (IFold vars state space m0 metric better) = + let+ pos = Field' state "pos"+ size = AVarSize vars state+ in+ text "int best_pos = -1;" + $+$ pr (Assign pos 0)+ $+$ text "for (int metric = " <> pr m0 <> text "; " <> pr (pos @< size ) <> text "; " <> pr pos <> text "++) {"+ $+$ nest 2 (text "if" <+> parens (text "!" <> pr (AVarElem vars space pos) <> text ".assigned()") <+> text "{"+ $+$ nest 2 ( text "int current_metric = " <> pr (metric pos) <> text ";"+ $+$ pr (IfThenElse (Var "current_metric" `better` Var "metric")+ (Assign (Var "metric") (Var "current_metric") >>> (Assign (Var "best_pos") pos))+ Skip+ )+ )+ $+$ text "}"+ )+ $+$ text "}" + $+$ pr (Assign pos (Var "best_pos")) + prettyX_ (BFold vars state space m0 metric better) = + let+ pos = Field' state "pos"+ size = BAVarSize vars space+ in+ text "int best_pos = -1;" + $+$ pr (Assign pos 0)+ $+$ text "for (int metric = " <> pr m0 <> text "; " <> pr (pos @< size ) <> text "; " <> pr pos <> text "++) {"+ $+$ nest 2 (text "if" <+> parens (text "!" <> pr (BAVarElem vars space pos) <> text ".assigned()") <+> text "{"+ $+$ nest 2 ( text "int current_metric = " <> pr (metric (BAVarElem vars space pos)) <> text ";"+ $+$ pr (IfThenElse (Var "current_metric" `better` Var "metric")+ (Assign (Var "metric") (Var "current_metric") >>> (Assign (Var "best_pos") pos))+ Skip+ )+ )+ $+$ text "}"+ )+ $+$ text "}" + $+$ pr (Assign pos (Var "best_pos")) + prettyX_ (BIFold vars state space m0 metric better) = + let+ pos = Field' state "pos"+ size = BAVarSize vars space+ in+ text "int best_pos = -1;" + $+$ pr (Assign pos 0)+ $+$ text "for (int metric = " <> pr m0 <> text "; " <> pr (pos @< size ) <> text "; " <> pr pos <> text "++) {"+ $+$ nest 2 (text "if" <+> parens (text "!" <> pr (BAVarElem vars space pos) <> text ".assigned()") <+> text "{"+ $+$ nest 2 ( text "int current_metric = " <> pr (metric pos) <> text ";"+ $+$ pr (IfThenElse (Var "current_metric" `better` Var "metric")+ (Assign (Var "metric") (Var "current_metric") >>> (Assign (Var "best_pos") pos))+ Skip+ )+ )+ $+$ text "}"+ )+ $+$ text "}" + $+$ pr (Assign pos (Var "best_pos")) +{- prettyX_ (MFold state metrics better) = + let+ space = Field "estate" "space"+ pos = Field state "pos"+ cvar = CVar "get" space pos+ size = VHook $ render $ pr space <> text "->" <> text "get" <> text "().size()" + acc_vars = [Var $ "metric" ++ show i | i <- [1..length metrics]]+ cur_vars = [Var $ "current_metric" ++ show i | i <- [1..length metrics]]+ init_list = hcat $ punctuate comma [pr v <+> text "=" <+> pretty z | (v,(z,_)) <- zip acc_vars metrics]+ computations = vcat $ [text "int" <+> pr (Update var (f cvar))| (var,(_,f)) <- zip cur_vars metrics]+ updates = foldl (>>>) Skip [Update v1 v2 | (v1,v2) <- zip acc_vars cur_vars]+ in+ text "int best_pos = -1;" + $+$ pr (Update pos 0)+ $+$ text "for (int " <> init_list <> text "; " <> pr (pos @< size ) <> text "; " <> pr pos <> text "++) {"+ $+$ nest 2 (text "if" <+> parens (text "!" <> pr cvar <> text ".assigned()") <+> text "{"+ $+$ nest 2 ( computations+ $+$ pr (IfThenElse (cur_vars `better` acc_vars)+ (updates >>> (Update (Var "best_pos") pos))+ Skip+ )+ )+ $+$ text "}"+ )+ $+$ text "}" + $+$ pr (Update pos (Var "best_pos")) -}+ prettyX_ (Delete value) =+ text "delete" <+> pr value <> text ";" + pr :: Pretty x => x -> Doc+ pr = prettyX x+ pr_ :: Statement -> Doc+ pr_ = prettyX_+++class Simplifiable a where+ simplify :: a -> a++instance Simplifiable Statement where+ simplify = simplStmt++instance Simplifiable Value where+ simplify = simplValue
+ Control/Search/Memo.hs view
@@ -0,0 +1,67 @@+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE OverlappingInstances #-}+++module Control.Search.Memo where++import Control.Monatron.Monatron hiding (Abort, L, state, cont)+import Control.Monatron.Zipper hiding (i,r)+import Control.Monatron.IdT+import Control.Monatron.MonadInfo++import List (sort, nub, sortBy)+import Data.Maybe (fromJust)+import Data.Map (Map)+import qualified Data.Map as Map++import Control.Search.Language+import Control.Search.GeneratorInfo+import Control.Search.SStateT++data MemoKey = MemoKey { memoFn :: String, memoInfo :: Maybe Info, memoStack :: Maybe String, memoExtra :: Maybe (Map Int String), memoStatement :: Maybe Statement, memoParams :: [String] }+ deriving (Eq, Ord)++data MemoValue = MemoValue { memoId :: Int, memoCode :: Statement, memoUsed :: Int, memoFields :: [(String,String)] }++data MemoInfo = MemoInfo { memoMap :: Map MemoKey MemoValue + , memoCount :: Int+ , memoRead :: Map Int String+ }++initMemoInfo = MemoInfo { memoMap = Map.empty+ , memoCount = 0+ , memoRead = Map.empty+ }++newtype MemoT m a = MemoT { unMemoT :: SStateT MemoInfo m a }+ deriving (MonadT,StateM MemoInfo,FMonadT)++instance MonadInfoT MemoT where+ tminfo x = miInc "MemoT" (minfo $ runMemoT x)++-- runMemoT :: Monad m => MemoT m a -> m (a,[(String,Statement,[(String,String)])])+runMemoT m = do (Tup2 a s) <- runSStateT initMemoInfo (unMemoT m)+ return (a, {- map (\(key,val) -> ( memoFn key ++ show (memoId val)+ , comment (" fn=" ++ memoFn key ++ " stack='" ++ show (memoStack key) ++ "' extra='" ++ show (memoExtra key) ++ "' used: " ++ show (memoUsed val)) >>> memoCode val+ , memoFields key+ )+ ) $ -} sortBy (\(ka,va) (kb,vb) -> compare (memoId va) (memoId vb)) $ Map.toList (memoMap s)+ )++-- runReaderMemoT :: (ReaderM r m, ReaderMemoM r (MemoT m)) => MemoT m a -> m (a,[(String,Statement,Info)])+-- runReaderMemoT m = do val <- ask+-- runMemoT (memoLocal (const val) m)++class Monad m => MemoM m where+ getMemo :: m MemoInfo + setMemo :: MemoInfo -> m ()++instance Monad m => MemoM (MemoT m) where+ getMemo = MemoT $ get + setMemo = MemoT . put++instance (MemoM m, FMonadT t) => MemoM (t m) where+ getMemo = lift $ getMemo+ setMemo = lift . setMemo+
+ Control/Search/MemoReader.hs view
@@ -0,0 +1,61 @@+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}++module Control.Search.MemoReader where++import Control.Search.Memo++import Data.Map (Map)+import qualified Data.Map as Map++import Control.Monatron.Monatron hiding (Abort, L, state, cont)+import Control.Monatron.Zipper hiding (i,r)+import Control.Monatron.MonadInfo+import Control.Monatron.IdT++newtype MemoReaderT r m a = MemoReaderT { unMemoReaderT :: Int -> ReaderT r m a }++instance MonadT (MemoReaderT r) where+ lift m = MemoReaderT $ const $ lift m+ tbind (MemoReaderT i) f = MemoReaderT (\n -> i n `tbind` (\r -> unMemoReaderT (f r) n))++instance MonadInfoT (MemoReaderT r) where+ tminfo x = miInc "MemoReaderT" (minfo $ runReaderT undefined (unMemoReaderT x 0))++instance FMonadT (MemoReaderT s) where+ tmap' d1 d2 g f (MemoReaderT m) = MemoReaderT (tmap' d1 d2 g f . m)++memoReaderT :: MemoM m => (e -> Int -> m a) -> MemoReaderT e m a+memoReaderT f = MemoReaderT (\n -> readerT (\e -> f e n))++deMemoReaderT :: MemoM m => e -> Int -> MemoReaderT e m a -> m a+deMemoReaderT e i (MemoReaderT f) = runReaderT e (f i)++runMemoReaderT :: (MemoM m, Show s) => s -> MemoReaderT s m a -> m a+runMemoReaderT s r = + do x1 <- getMemo+ let l = Map.size (memoRead x1)+ setMemo x1 { memoRead = Map.insert l (show s) $ memoRead x1 }+ r <- deMemoReaderT s l r+ x2 <- getMemo+ setMemo x2 { memoRead = Map.delete l $ memoRead x2 }+ return r++modelMemoReaderT :: (Show s, MemoM m) => Model (ReaderOp s) (MemoReaderT s m)+modelMemoReaderT (Ask g) = memoReaderT (\s n -> deMemoReaderT s n (g s))+modelMemoReaderT (InEnv s a) = memoReaderT (\_ n -> deMemoReaderT s n (do { m1 <- getMemo+ ; let oldVal = memoRead m1 Map.! n+ ; setMemo m1 { memoRead = Map.insert n (show s) (memoRead m1) }+ ; x <- a+ ; m2 <- getMemo+ ; setMemo m2 { memoRead = Map.insert n oldVal (memoRead m2) }+ ; return x+ }+ )+ )++instance (MemoM m, Show s) => ReaderM s (MemoReaderT s m) where+ readerModel = modelMemoReaderT+
+ Control/Search/SStateT.hs view
@@ -0,0 +1,47 @@+{-# OPTIONS -fglasgow-exts #-}++module Control.Search.SStateT (+ SStateT, sstateT, runSStateT,+ Tup2(..), snd2, fst2+) where++--import Monatron.Operations+import Control.Monad.Fix+import Control.Monatron.MonadT+import Control.Monatron.AutoInstances ()+import Control.Monatron.Operations+import Control.Monatron.AutoLift++data Tup2 a b = Tup2 a !b++fst2 (Tup2 a _) = a+snd2 (Tup2 _ b) = b++newtype SStateT s m a = SS { unSS :: s -> m (Tup2 a s) }++sstateT :: (s -> m (Tup2 a s)) -> SStateT s m a+sstateT = SS++runSStateT :: s -> SStateT s m a -> m (Tup2 a s) +runSStateT s m = unSS m s++instance MonadT (SStateT s) where+ lift m = SS $ \s -> m >>= \a -> return (Tup2 a s)+ m `tbind` k = SS $ \s -> unSS m s >>= \ ~(Tup2 a s') -> unSS (k a) s'++instance (MonadFix m) => MonadFix (SStateT s m) where+ mfix f = SS $ \s -> mfix (runSStateT s . f . fst2)++instance FMonadT (SStateT s) where+ tmap' d1 _d2 g f (SS m) = SS (f . fmapD d1 (\(Tup2 x s) -> (Tup2 (g x) s)) . m)++instance MMonadT (SStateT s) where+ flift t = SS (\s -> fmap (\a -> (Tup2 a s)) t)+ monoidalT (SS t) = SS (\s -> Comp $ fmap (\(Tup2 (SS t') s') -> t' s') (t s))++instance Monad m => StateM z (SStateT z m) where+ stateModel = modelSStateT++modelSStateT :: Monad m => AlgModel (StateOp s) (SStateT s m)+modelSStateT (Get g) = sstateT (\s -> return (Tup2 (g s) s))+modelSStateT (Put s a) = sstateT (\_ -> return (Tup2 a s))
+ Control/Search/Stat.hs view
@@ -0,0 +1,185 @@+{-# LANGUAGE Rank2Types #-}+{-# LANGUAGE FlexibleInstances #-}++module Control.Search.Stat+ ( appStat+ , constStat+ , depthStat+ , nodesStat+ , discrepancyStat+ , solutionsStat+ , failsStat+ , timeStat+ , notStat+ , Stat(..), IValue, varStat+ , (#>), (#<), (#>=), (#<=), (#=), (#/)+ , readStat, evalStat+ ) where++import Text.PrettyPrint hiding (space)++import Control.Search.Language+import Control.Search.GeneratorInfo+import Control.Search.Memo+import Control.Search.Generator++-- ========================================================================== --+-- IVALUE+-- ========================================================================== --++type IValue = Info -> Value++instance Show (Info -> Value) where+ show x = "<IValue>"+instance Eq (Info -> Value) where+ x == y = False++instance Num (Info -> Value) where+ x - y = \i -> x i - y i+ fromInteger x = \i -> IVal (fromInteger x)+ x + y = \i -> x i + y i+ x * y = \i -> x i * y i+ abs x = \i -> abs (x i)+ signum x = \i -> signum (x i)++-- ========================================================================== --+-- STATS+-- ========================================================================== --++data Stat = Stat (forall m. Evalable m => Eval m -> Eval m) (forall m. Evalable m => m IValue)++instance Show Stat where+ show _ = "<Stat>"++instance Eq Stat where+ _ == _ = False++readStat :: Evalable m => Stat -> m IValue+readStat (Stat _ r) = r++evalStat :: Evalable m => Stat -> Eval m -> Eval m+evalStat (Stat e _) = e++-- -------------------------------------------------------------------------- --++instance Num Stat where+ x - y = liftStat (-) x y+ fromInteger = constStat . fromInteger+ x + y = liftStat (+) x y+ x * y = liftStat (*) x y+ abs = appStat abs+ signum = appStat signum++instance Bounded Stat where+ maxBound = constStat $ const MaxVal+ minBound = constStat $ const MinVal++appStat :: (Value -> Value) -> Stat -> Stat+appStat f (Stat e r) = Stat e (r >>= \x -> return (\i -> f (x i)))++liftStat :: (Value -> Value -> Value) -> Stat -> Stat -> Stat+liftStat op (Stat e1 x) (Stat e2 y) = Stat (e1 . e2) (x >>= \xv -> y >>= \yv -> return (\i -> xv i `op` yv i))++constStat :: IValue -> Stat+constStat x = Stat id (return x)++(#>) :: Stat -> Stat -> Stat+(#>) = liftStat (@>)++(#=) :: Stat -> Stat -> Stat+(#=) = liftStat (@==)++(#<) :: Stat -> Stat -> Stat+(#<) = liftStat (@<)++(#>=) :: Stat -> Stat -> Stat+(#>=) = liftStat (@>=)++(#<=) :: Stat -> Stat -> Stat+(#<=) = liftStat (@<=)++(#/) :: Stat -> Stat -> Stat+(#/) = liftStat (divValue)++notStat :: Stat -> Stat+notStat = appStat Not+-- -------------------------------------------------------------------------- --++depthStat :: Stat+depthStat = + Stat (\super -> + let push dir = \i -> dir super (i `onCommit` mkUpdate i "depth" (\x -> x + 1))+ in commentEval $ super+ { treeState_ = entry ("depth",Int,assign $ 0) : treeState_ super+ , pushLeftH = push pushLeft+ , pushRightH = push pushRight+ , toString = "stat_depth:" ++ toString super+ })+ (return (\info -> tstate info @-> "depth"))++discrepancyStat :: Stat+discrepancyStat = + Stat + (\super -> commentEval $+ super+ { treeState_ = entry ("discrepancy",Int,assign 0) : treeState_ super+ , pushLeftH = \i -> pushLeft super (i `onCommit` mkCopy i "discrepancy")+ , pushRightH = \i -> pushRight super (i `onCommit` mkUpdate i "discrepancy" (\x -> x + 1))+ , toString = "stat_discr:" ++ toString super+ })+ (return (\info -> tstate info @-> "discrepancy"))++nodesStat :: Stat+nodesStat = + eStat ("nodes", Int, const 0) $+ \super -> super { bodyH = \i -> return (inc (estate i @=> "nodes")) @>>>@ bodyE super i }++solutionsStat :: Stat+solutionsStat = + eStat ("solutions", Int, const 0) $+ \super -> super {returnH = \i -> returnE super (i `onCommit` inc (solutions i))}+ where solutions i = estate i @=> "solutions"++varStat :: VarId -> Stat+varStat v@(VarId i) = Stat id (do inf <- lookupVarInfo v+ return (const $ estate inf @=> ("var" ++ show i))+ )++failsStat :: Stat+failsStat = + eStat ("fails", Int, const 0) $+ \super -> super { failH = \i -> returnH super i @>>>@ return (inc (fails i)) }+ where fails i = estate i @=> "fails"++eStat :: (String, Type, Info -> Value) -> (forall m. Evalable m => Eval m -> Eval m) -> Stat+eStat (name,typ,val) f =+ Stat (\super -> commentEval $ f $ super { evalState_ = (name,typ,\i -> return (val i)) : evalState_ super, toString = "stat_" ++ name ++ ":" ++ toString super })+ (return (\i -> estate i @=> name))++-- TIMER STATISTIC+--+-- Based on Gecode::Support::Timer.+--+--+--+timeStat :: Stat+timeStat =+ Stat (\super -> commentEval $+ super { evalState_ = ("total",Int, const $ return 0) : + ("timer",THook "Gecode::Support::Timer",const $ return Null) :+ ("running",Bool,const $ return false) :+ evalState_ super + , nextDiffH = \i ->+ return (ifthen (running i) + ((running i <== false) >>> + (total i <== (total i + (VHook (render $ text "static_cast<int>" <> parens (pretty (timer i) <> text ".stop()"))))))) + , bodyH = \i -> + return (ifthen (Not $ running i) + ((running i <== true) >>> SHook ((render $ pretty $ timer i) ++ ".start();"))) + @>>>@ bodyE super i+ , toString = "stat_time:" ++ toString super+ })+ (return (\i -> total i + Cond (running i) (VHook (render $ text "static_cast<int>" <> parens (pretty (timer i) <> text ".stop()"))) 0))+ where running i = estate i @=> "running"+ timer i = estate i @=> "timer"+ total i = estate i @=> "total"
examples/Partition.hs view
@@ -2,6 +2,9 @@ {-# LANGUAGE FlexibleContexts #-} import Control.CP.FD.Example+import Control.CP.SearchTree+import Control.CP.Solver+import Control.CP.FD.Interface model :: ExampleModel ModelInt model n =
examples/Queens.hs view
@@ -3,15 +3,19 @@ import Control.CP.FD.Example +noattack i j qi qj = do+ qi @/= qj+ qi + i @/= qj + j+ qi - i @/= qj - j+ model :: ExampleModel ModelInt model n = exists $ \p -> do size p @= n p `allin` (cte 0,n-1) allDiff p- loopall (cte 0,n-2) $ \i -> do- loopall (i+1,n-1) $ \j -> do- (p!i) + i @/= (p!j) + j- (p!i) - i @/= (p!j) - j+ loopall (cte 0,n-2) $ \i -> + loopall (i+1,n-1) $ \j ->+ noattack i j (p!i) (p!j) return p main = example_sat_main_single_expr model
lib/gecodeglue.cpp view
@@ -821,7 +821,7 @@ } gecode_search_data_t; gecode_search_data_t static *gecode_search_create(HaskellModel *model, gecode_search_type typ) {- Search::Options o = Search::Options::Options();+ Search::Options o = Search::Options(); o.c_d = 1; gecode_search_data_t *srch=new gecode_search_data_t; #ifndef NDEBUG@@ -877,6 +877,8 @@ res=srch->dat.bab->next(); break; }+ default:+ res=NULL; } #ifndef NDEBUG cerr << "[search " << srch << "] requested next (" << res << ")\n";
monadiccp.cabal view
@@ -1,5 +1,5 @@ Name: monadiccp-Version: 0.7.1+Version: 0.7.2 Description: Monadic Constraint Programming framework License: BSD3 License-file: LICENSE@@ -9,6 +9,7 @@ Category: control Synopsis: Constraint Programming Homepage: http://users.ugent.be/~tschrijv/MCP/+Bug-reports: http://trac.haskell.org/monadiccp/ Cabal-Version: >=1.6 Extra-Source-Files: examples/*.hs lib/*.cpp lib/*.h @@ -23,7 +24,7 @@ Default: False library- Build-Depends: base >= 2, base < 5, containers, mtl, haskell98, random, pretty, Monatron >= 0.3+ Build-Depends: base >= 2, base < 5, containers, mtl, haskell98, random, pretty, parsec >= 3.0 Exposed-Modules: Data.Expr.Sugar Control.CP.SearchTree Control.CP.Transformers@@ -39,21 +40,56 @@ Control.CP.FD.Gecode.CodegenSolver Control.CP.FD.Model Control.CP.FD.Example+ Control.CP.FD.FD+ Control.CP.FD.Gecode.Common Other-Modules: Data.Expr.Data Data.Expr.Util Data.Linear- Control.CP.FD.Gecode.Common Control.CP.FD.OvertonFD.Domain Control.CP.FD.SimpleFD Control.CP.FD.Graph Control.CP.FD.Decompose- Control.CP.FD.FD+ Control.CP.FD.SearchSpec.Data Control.CP.Debug Control.Mixin.Mixin- Control.CP.SearchSpec.Language- Control.CP.SearchSpec.Generator Language.CPP.Syntax.AST Language.CPP.Pretty+ Control.Search.Language+ Control.Search.Stat+ Control.Search.Generator+ Control.Search.Combinator.For+ Control.Search.Combinator.Until+ Control.Search.Combinator.If+ Control.Search.Combinator.OrRepeat+ Control.Search.Combinator.Let+ Control.Search.Combinator.Success+ Control.Search.Combinator.Base+ Control.Search.Combinator.Failure+ Control.Search.Combinator.Once+ Control.Search.Combinator.And+ Control.Search.Combinator.Repeat+ Control.Search.Combinator.Or+ Control.Search.Combinator.Post+ Control.Search.Combinator.Misc+ Control.Search.Combinator.Print+ Control.Search.Memo+ Control.Search.GeneratorInfo+ Control.Search.Constraints+ Control.Search.MemoReader+ Control.Search.SStateT+ Control.Monatron.Monatron+ Control.Monatron.MonadInfo+ Control.Monatron.AutoLift+ Control.Monatron.Operations+ Control.Monatron.Zipper+ Control.Monatron.IdT+ Control.Monatron.Codensity+ Control.Monatron.Transformer+ Control.Monatron.Open+ Control.Monatron.AutoInstances+ Control.Monatron.MonadT+ Control.Monatron.Monad+ Control.Monatron.ZipperExamples GHC-Prof-Options: -auto-all -caf-all Include-Dirs: lib if flag(Debug)@@ -66,6 +102,6 @@ Extra-Libraries: gecodesupport gecodeset gecodeint gecodekernel gecodesearch Exposed-Modules: Control.CP.FD.Gecode.Runtime Control.CP.FD.Gecode.RuntimeSearch- Other-Modules: Control.CP.FD.Gecode.Interface+ Control.CP.FD.Gecode.Interface CPP-Options: -DRGECODE Frameworks: gecode