monadiccp 0.7.6 → 0.7.7

raw patch · 153 files changed

+12958/−12908 lines, 153 filesdep +monadiccpdep +semigroupsdep ~basesetup-changedPVP: major bump suggested

API removals or changes: PVP suggests a major version bump

Dependencies added: monadiccp, semigroups

Dependency ranges changed: base

API changes (from Hackage documentation)

- Control.CP.ComposableTransformers: (:-) :: c1 -> c2 -> Composition (CEvalState c1, CEvalState c2) (CTreeState c1, CTreeState c2) solver a

- Control.CP.ComposableTransformers: Seal :: c -> SealedCST (CEvalState c) (CTreeState c) (CForSolver c) (CForResult c)

- Control.CP.ComposableTransformers: instance Solver solver => CTransformer (CBranchBoundST solver a)

- Control.CP.ComposableTransformers: instance Solver solver => CTransformer (CDepthBoundedST solver a)

- Control.CP.ComposableTransformers: instance Solver solver => CTransformer (CFirstSolutionST solver a)

- Control.CP.ComposableTransformers: instance Solver solver => CTransformer (CIdentityCST solver a)

- Control.CP.ComposableTransformers: instance Solver solver => CTransformer (CLimitedDiscrepancyST solver a)

- Control.CP.ComposableTransformers: instance Solver solver => CTransformer (CNodeBoundedST solver a)

- Control.CP.ComposableTransformers: instance Solver solver => CTransformer (CRandomST solver a)

- Control.CP.ComposableTransformers: instance Solver solver => CTransformer (CSolutionBoundST solver a)

- Control.CP.ComposableTransformers: instance Solver solver => CTransformer (Composition es ts solver a)

- Control.CP.ComposableTransformers: instance Solver solver => CTransformer (SealedCST es ts solver a)

- Control.CP.ComposableTransformers: instance Solver solver => Transformer (RestartST es ts solver a)

- Control.CP.ComposableTransformers: instance Solver solver => Transformer (TStack es ts solver a)

- Control.CP.FD.Decompose: instance Monad DCMonad

- Control.CP.FD.Decompose: instance MonadState DCState DCMonad

- Control.CP.FD.FD: fdspBoolSpec :: FDSpecInfoBool s -> Maybe (FDBoolSpecType s) -> Maybe (FDBoolSpec s)

- Control.CP.FD.FD: fdspBoolTypes :: FDSpecInfoBool s -> Set (FDBoolSpecType s)

- Control.CP.FD.FD: fdspBoolVal :: FDSpecInfoBool s -> Maybe EGBoolPar

- Control.CP.FD.FD: fdspBoolVar :: FDSpecInfoBool s -> Maybe EGVarId

- Control.CP.FD.FD: fdspColSpec :: FDSpecInfoCol s -> Maybe (FDColSpecType s) -> Maybe (FDColSpec s)

- Control.CP.FD.FD: fdspColTypes :: FDSpecInfoCol s -> Set (FDColSpecType s)

- Control.CP.FD.FD: fdspColVal :: FDSpecInfoCol s -> Maybe EGColPar

- Control.CP.FD.FD: fdspColVar :: FDSpecInfoCol s -> Maybe EGVarId

- Control.CP.FD.FD: fdspIntSpec :: FDSpecInfoInt s -> Maybe (FDIntSpecType s) -> Maybe (FDIntSpec s)

- Control.CP.FD.FD: fdspIntTypes :: FDSpecInfoInt s -> Set (FDIntSpecType s)

- Control.CP.FD.FD: fdspIntVal :: FDSpecInfoInt s -> Maybe EGPar

- Control.CP.FD.FD: fdspIntVar :: FDSpecInfoInt s -> Maybe EGVarId

- Control.CP.FD.FD: instance (FDSolver s, EnumTerm s (FDBoolTerm s)) => EnumTerm (FDInstance s) ModelBool

- Control.CP.FD.FD: instance (FDSolver s, EnumTerm s (FDIntTerm s)) => EnumTerm (FDInstance s) ModelInt

- Control.CP.FD.FD: instance (Ord (FDBoolSpec s), Ord (FDBoolSpecType s)) => Eq (FDSpecInfoBool s)

- Control.CP.FD.FD: instance (Ord (FDBoolSpec s), Ord (FDBoolSpecType s)) => Ord (FDSpecInfoBool s)

- Control.CP.FD.FD: instance (Ord (FDColSpec s), Ord (FDColSpecType s)) => Eq (FDSpecInfoCol s)

- Control.CP.FD.FD: instance (Ord (FDColSpec s), Ord (FDColSpecType s)) => Ord (FDSpecInfoCol s)

- Control.CP.FD.FD: instance (Ord (FDIntSpec s), Ord (FDIntSpecType s)) => Eq (FDSpecInfoInt s)

- Control.CP.FD.FD: instance (Ord (FDIntSpec s), Ord (FDIntSpecType s)) => Ord (FDSpecInfoInt s)

- Control.CP.FD.FD: instance Bounded TermType

- Control.CP.FD.FD: instance Enum TermType

- Control.CP.FD.FD: instance Eq TermType

- Control.CP.FD.FD: instance FDSolver s => Solver (FDInstance s)

- Control.CP.FD.FD: instance FDSolver s => Term (FDInstance s) ModelBool

- Control.CP.FD.FD: instance FDSolver s => Term (FDInstance s) ModelCol

- Control.CP.FD.FD: instance FDSolver s => Term (FDInstance s) ModelInt

- Control.CP.FD.FD: instance Monad s => Monad (FDInstance s)

- Control.CP.FD.FD: instance Monad s => MonadState (FDState s) (FDInstance s)

- Control.CP.FD.FD: instance Ord TermType

- Control.CP.FD.FD: instance Show (FDBoolSpec s) => Show (FDSpecInfoBool s)

- Control.CP.FD.FD: instance Show (FDColSpec s) => Show (FDSpecInfoCol s)

- Control.CP.FD.FD: instance Show (FDIntSpec s) => Show (FDSpecInfoInt s)

- Control.CP.FD.FD: instance Show (TermTypeSpec s)

- Control.CP.FD.FD: instance Show TermType

- Control.CP.FD.Graph: boolData :: EGTypeData x -> x

- Control.CP.FD.Graph: colData :: EGTypeData x -> x

- Control.CP.FD.Graph: egeCons :: EGEdge -> EGConstraintSpec

- Control.CP.FD.Graph: egeLinks :: EGEdge -> EGTypeData [EGVarId]

- Control.CP.FD.Graph: egmEdges :: EGModel -> Map EGEdgeId EGEdge

- Control.CP.FD.Graph: egmLinks :: EGModel -> EGTypeData (Map EGVarId [(EGEdgeId, Int)])

- Control.CP.FD.Graph: egmNEdges :: EGModel -> Int

- Control.CP.FD.Graph: egmParams :: EGModel -> EGTypeData Int

- Control.CP.FD.Graph: egmVars :: EGModel -> EGTypeData Int

- Control.CP.FD.Graph: instance Display DisplayData

- Control.CP.FD.Graph: instance Display EGEdge

- Control.CP.FD.Graph: instance Display EGModel

- Control.CP.FD.Graph: instance Eq (EGPar -> EGPar)

- Control.CP.FD.Graph: instance Eq EGConstraintSpec

- Control.CP.FD.Graph: instance Eq EGEdge

- Control.CP.FD.Graph: instance Eq EGEdgeId

- Control.CP.FD.Graph: instance Eq EGModel

- Control.CP.FD.Graph: instance Eq EGParBoolTerm

- Control.CP.FD.Graph: instance Eq EGParColTerm

- Control.CP.FD.Graph: instance Eq EGParTerm

- Control.CP.FD.Graph: instance Eq EGVarId

- Control.CP.FD.Graph: instance Eq EGVarType

- Control.CP.FD.Graph: instance Eq x => Eq (EGTypeData x)

- Control.CP.FD.Graph: instance Ord (EGPar -> EGPar)

- Control.CP.FD.Graph: instance Ord EGEdgeId

- Control.CP.FD.Graph: instance Ord EGParBoolTerm

- Control.CP.FD.Graph: instance Ord EGParColTerm

- Control.CP.FD.Graph: instance Ord EGParTerm

- Control.CP.FD.Graph: instance Ord EGVarId

- Control.CP.FD.Graph: instance Show (EGPar -> EGPar)

- Control.CP.FD.Graph: instance Show EGConstraintSpec

- Control.CP.FD.Graph: instance Show EGEdge

- Control.CP.FD.Graph: instance Show EGEdgeId

- Control.CP.FD.Graph: instance Show EGModel

- Control.CP.FD.Graph: instance Show EGParBoolTerm

- Control.CP.FD.Graph: instance Show EGParColTerm

- Control.CP.FD.Graph: instance Show EGParTerm

- Control.CP.FD.Graph: instance Show EGVarId

- Control.CP.FD.Graph: instance Show EGVarType

- Control.CP.FD.Graph: instance Show x => Show (EGTypeData x)

- Control.CP.FD.Graph: intData :: EGTypeData x -> x

- Control.CP.FD.Graph: unVarId :: EGVarId -> Int

- Control.CP.FD.Interface: instance ModelExprClass (Tree DummySolver ())

- Control.CP.FD.Interface: instance ModelExprClass ModelBool

- Control.CP.FD.Interface: instance ModelExprClass ModelCol

- Control.CP.FD.Interface: instance ModelExprClass ModelInt

- Control.CP.FD.Interface: instance ModelTermType t => Term DummySolver t

- Control.CP.FD.Interface: instance Monad DummySolver

- Control.CP.FD.Interface: instance Solver DummySolver

- Control.CP.FD.Model: instance Eq ModelFunctions

- Control.CP.FD.Model: instance Eq ModelIntros

- Control.CP.FD.Model: instance Eq t => Eq (ModelBoolTerm t)

- Control.CP.FD.Model: instance Eq t => Eq (ModelColTerm t)

- Control.CP.FD.Model: instance Eq t => Eq (ModelIntTerm t)

- Control.CP.FD.Model: instance ModelTermType ModelBool

- Control.CP.FD.Model: instance ModelTermType ModelCol

- Control.CP.FD.Model: instance ModelTermType ModelInt

- Control.CP.FD.Model: instance Ord ModelFunctions

- Control.CP.FD.Model: instance Ord ModelIntros

- Control.CP.FD.Model: instance Ord t => Ord (ModelBoolTerm t)

- Control.CP.FD.Model: instance Ord t => Ord (ModelColTerm t)

- Control.CP.FD.Model: instance Ord t => Ord (ModelIntTerm t)

- Control.CP.FD.Model: instance Show (ModelColTerm t)

- Control.CP.FD.Model: instance Show (ModelIntTerm t)

- Control.CP.FD.Model: instance Show ModelFunctions

- Control.CP.FD.Model: instance Show ModelIntros

- Control.CP.FD.Model: instance Show t => Show (ModelBoolTerm t)

- Control.CP.FD.Model: instance ToBoolExpr (ModelIntTerm ModelFunctions) (ModelColTerm ModelFunctions) (ModelBoolTerm ModelFunctions) t => ToModelBool t

- Control.CP.FD.Model: instance ToColExpr (ModelIntTerm ModelFunctions) (ModelColTerm ModelFunctions) (ModelBoolTerm ModelFunctions) t => ToModelCol t

- Control.CP.FD.Model: instance ToExpr (ModelIntTerm ModelFunctions) (ModelColTerm ModelFunctions) (ModelBoolTerm ModelFunctions) t => ToModelInt t

- Control.CP.FD.OvertonFD.Domain: instance [incoherent] (Integral a, Integral b) => ToDomain (a, b)

- Control.CP.FD.OvertonFD.Domain: instance [incoherent] Eq Domain

- Control.CP.FD.OvertonFD.Domain: instance [incoherent] Integral a => ToDomain [a]

- Control.CP.FD.OvertonFD.Domain: instance [incoherent] Integral a => ToDomain a

- Control.CP.FD.OvertonFD.Domain: instance [incoherent] Show Domain

- Control.CP.FD.OvertonFD.Domain: instance [incoherent] ToDomain ()

- Control.CP.FD.OvertonFD.Domain: instance [incoherent] ToDomain Domain

- Control.CP.FD.OvertonFD.Domain: instance [incoherent] ToDomain IntSet

- Control.CP.FD.OvertonFD.OvertonFD: instance EnumTerm OvertonFD FDVar

- Control.CP.FD.OvertonFD.OvertonFD: instance Eq FDState

- Control.CP.FD.OvertonFD.OvertonFD: instance Eq FDVar

- Control.CP.FD.OvertonFD.OvertonFD: instance Eq OConstraint

- Control.CP.FD.OvertonFD.OvertonFD: instance Monad OvertonFD

- Control.CP.FD.OvertonFD.OvertonFD: instance MonadState FDState OvertonFD

- Control.CP.FD.OvertonFD.OvertonFD: instance Ord FDState

- Control.CP.FD.OvertonFD.OvertonFD: instance Ord FDVar

- Control.CP.FD.OvertonFD.OvertonFD: instance Show FDState

- Control.CP.FD.OvertonFD.OvertonFD: instance Show FDVar

- Control.CP.FD.OvertonFD.OvertonFD: instance Show OConstraint

- Control.CP.FD.OvertonFD.OvertonFD: instance Show VarInfo

- Control.CP.FD.OvertonFD.OvertonFD: instance Solver OvertonFD

- Control.CP.FD.OvertonFD.OvertonFD: instance Term OvertonFD FDVar

- Control.CP.FD.OvertonFD.Sugar: instance FDSolver OvertonFD

- Control.CP.FD.SearchSpec.Data: instance (Show v, Show a, Show b) => Show (Labelling v a b)

- Control.CP.FD.SearchSpec.Data: instance (Show v, Show a, Show b) => Show (SearchSpec v a b)

- Control.CP.FD.SearchSpec.Data: instance Eq ConstraintRefs

- Control.CP.FD.SearchSpec.Data: instance Eq OptimDirection

- Control.CP.FD.SearchSpec.Data: instance Eq VarStat

- Control.CP.FD.SearchSpec.Data: instance Ord ConstraintRefs

- Control.CP.FD.SearchSpec.Data: instance Ord OptimDirection

- Control.CP.FD.SearchSpec.Data: instance Ord VarStat

- Control.CP.FD.SearchSpec.Data: instance Show ConstraintRefs

- Control.CP.FD.SearchSpec.Data: instance Show OptimDirection

- Control.CP.FD.SearchSpec.Data: instance Show VarStat

- Control.CP.Queue: instance Ord a => Queue (PriorityQueue a (a, b, c))

- Control.CP.Queue: instance Queue (Seq a)

- Control.CP.Queue: instance Queue [a]

- Control.CP.SearchTree: Add :: Constraint s -> Tree s a -> Tree s a

- Control.CP.SearchTree: Fail :: Tree s a

- Control.CP.SearchTree: Label :: s (Tree s a) -> Tree s a

- Control.CP.SearchTree: NewVar :: (t -> Tree s a) -> Tree s a

- Control.CP.SearchTree: Return :: a -> Tree s a

- Control.CP.SearchTree: Try :: Tree s a -> Tree s a -> Tree s a

- Control.CP.SearchTree: instance (MonadTree m, Solver (TreeSolver m)) => MonadTree (ContT r m)

- Control.CP.SearchTree: instance (Monoid w, MonadTree t) => MonadTree (WriterT w t)

- Control.CP.SearchTree: instance MonadTree t => MonadTree (ReaderT env t)

- Control.CP.SearchTree: instance MonadTree t => MonadTree (StateT s t)

- Control.CP.SearchTree: instance Show (Tree s a)

- Control.CP.SearchTree: instance Solver s => Functor (Tree s)

- Control.CP.SearchTree: instance Solver s => Monad (Tree s)

- Control.CP.SearchTree: instance Solver solver => MonadTree (Tree solver)

- Control.CP.Solver: instance (Monoid w, Solver s) => Solver (WriterT w s)

- Control.CP.Solver: instance (Monoid w, Term s t) => Term (WriterT w s) t

- Control.CP.Transformers: instance Solver solver => Transformer (DepthBoundedST solver a)

- Control.CP.Transformers: instance Solver solver => Transformer (NodeBoundedST solver a)

- Control.Search.Generator: addH :: Eval m -> Info -> m Statement

- Control.Search.Generator: bodyH :: Eval m -> Info -> m Statement

- Control.Search.Generator: boolArraysE :: Eval m -> [String]

- Control.Search.Generator: canBranch :: Eval m -> m Bool

- Control.Search.Generator: complete :: Eval m -> Info -> m Value

- Control.Search.Generator: deleteH :: Eval m -> Info -> m Statement

- Control.Search.Generator: elems :: SearchCombiner -> [SearchCombinerElem t1 t2]

- Control.Search.Generator: evalState_ :: Eval m -> [(String, Type, Info -> m Value)]

- Control.Search.Generator: failH :: Eval m -> Info -> m Statement

- Control.Search.Generator: initH :: Eval m -> Info -> m Statement

- Control.Search.Generator: instance [incoherent] (GenModeM m, FMonadT t) => GenModeM (t m)

- Control.Search.Generator: instance [incoherent] (MonadT t, HookStatsM m) => HookStatsM (t m)

- Control.Search.Generator: instance [incoherent] (VarInfoM m, FMonadT t) => VarInfoM (t m)

- Control.Search.Generator: instance [incoherent] (VarInfoM m, HookStatsM m, MonadInfo m, MemoM m, GenModeM m, Functor m) => Evalable m

- Control.Search.Generator: instance [incoherent] Eq VarId

- Control.Search.Generator: instance [incoherent] Evalable m => Memoable (m Statement)

- Control.Search.Generator: instance [incoherent] FMonadT GenModeT

- Control.Search.Generator: instance [incoherent] FMonadT HookStatsT

- Control.Search.Generator: instance [incoherent] FMonadT VarInfoT

- Control.Search.Generator: instance [incoherent] Memoable m => Memoable ((Type, Value) -> m)

- Control.Search.Generator: instance [incoherent] Monad m => GenModeM (GenModeT m)

- Control.Search.Generator: instance [incoherent] Monad m => HookStatsM (HookStatsT m)

- Control.Search.Generator: instance [incoherent] Monad m => Monad (HookStatsT m)

- Control.Search.Generator: instance [incoherent] Monad m => ReaderM GenMode (GenModeT m)

- Control.Search.Generator: instance [incoherent] Monad m => StateM HookStat (HookStatsT m)

- Control.Search.Generator: instance [incoherent] Monad m => StateM VarInfo (VarInfoT m)

- Control.Search.Generator: instance [incoherent] Monad m => VarInfoM (VarInfoT m)

- Control.Search.Generator: instance [incoherent] MonadInfoT GenModeT

- Control.Search.Generator: instance [incoherent] MonadInfoT HookStatsT

- Control.Search.Generator: instance [incoherent] MonadInfoT VarInfoT

- Control.Search.Generator: instance [incoherent] MonadT GenModeT

- Control.Search.Generator: instance [incoherent] MonadT HookStatsT

- Control.Search.Generator: instance [incoherent] MonadT VarInfoT

- Control.Search.Generator: instance [incoherent] Monoid ProgramString

- Control.Search.Generator: instance [incoherent] Ord VarId

- Control.Search.Generator: instance [incoherent] Show SeqPos

- Control.Search.Generator: instance [incoherent] Show VarId

- Control.Search.Generator: intArraysE :: Eval m -> [String]

- Control.Search.Generator: intVarsE :: Eval m -> [String]

- Control.Search.Generator: mkeval :: Search -> forall m t1. (HookStatsM m, MonadInfoT t1, FMonadT t1, Evalable m) => MkEval ((t1 :> t2) m)

- Control.Search.Generator: nextDiffH :: Eval m -> Info -> m Statement

- Control.Search.Generator: nextSameH :: Eval m -> Info -> m Statement

- Control.Search.Generator: pushLeftH :: Eval m -> Info -> m Statement

- Control.Search.Generator: pushRightH :: Eval m -> Info -> m Statement

- Control.Search.Generator: returnH :: Eval m -> Info -> m Statement

- Control.Search.Generator: runner :: SearchCombiner -> forall m x. Evalable m => ((t1 :> t2) m) x -> m x

- Control.Search.Generator: runsearch :: Search -> forall m x. Evalable m => t2 m x -> m x

- Control.Search.Generator: startTryH :: Eval m -> Info -> m Statement

- Control.Search.Generator: structs :: Eval m -> ([Struct], [Struct])

- Control.Search.Generator: toString :: Eval m -> String

- Control.Search.Generator: treeState_ :: Eval m -> [(String, Type, Info -> m Statement)]

- Control.Search.Generator: tryH :: Eval m -> Info -> m Statement

- Control.Search.Generator: tryLH :: Eval m -> Info -> m Statement

- Control.Search.GeneratorInfo: abort_ :: Info -> [Statement -> Statement]

- Control.Search.GeneratorInfo: baseTstate :: Info -> TreeState

- Control.Search.GeneratorInfo: clone :: Info -> Info -> Statement

- Control.Search.GeneratorInfo: commit_ :: Info -> [Statement -> Statement]

- Control.Search.GeneratorInfo: evalStateType :: Info -> Type

- Control.Search.GeneratorInfo: field :: Info -> String -> Value

- Control.Search.GeneratorInfo: instance Eq Info

- Control.Search.GeneratorInfo: instance Ord Info

- Control.Search.GeneratorInfo: old :: Info -> Info

- Control.Search.GeneratorInfo: path :: Info -> TreeState -> TreeState

- Control.Search.GeneratorInfo: stackField :: Info -> [(String, String)]

- Control.Search.GeneratorInfo: treeStateType :: Info -> Type

- Control.Search.Language: genMode :: PrettyFlags -> GenMode

- Control.Search.Language: instance Eq (Value -> Value -> Value)

- Control.Search.Language: instance Eq (Value -> Value)

- Control.Search.Language: instance Eq Constraint

- Control.Search.Language: instance Eq GenMode

- Control.Search.Language: instance Eq PrettyFlags

- Control.Search.Language: instance Eq Statement

- Control.Search.Language: instance Eq Struct

- Control.Search.Language: instance Eq Type

- Control.Search.Language: instance Eq Value

- Control.Search.Language: instance Monoid Statement

- Control.Search.Language: instance Num Value

- Control.Search.Language: instance Ord (Value -> Value -> Value)

- Control.Search.Language: instance Ord (Value -> Value)

- Control.Search.Language: instance Ord Constraint

- Control.Search.Language: instance Ord Statement

- Control.Search.Language: instance Ord Struct

- Control.Search.Language: instance Ord Type

- Control.Search.Language: instance Ord Value

- Control.Search.Language: instance Pretty Constraint

- Control.Search.Language: instance Pretty Statement

- Control.Search.Language: instance Pretty Struct

- Control.Search.Language: instance Pretty Type

- Control.Search.Language: instance Pretty Value

- Control.Search.Language: instance Show (Value -> Value -> Value)

- Control.Search.Language: instance Show (Value -> Value)

- Control.Search.Language: instance Show Constraint

- Control.Search.Language: instance Show Statement

- Control.Search.Language: instance Show Struct

- Control.Search.Language: instance Show Type

- Control.Search.Language: instance Show Value

- Control.Search.Language: instance Simplifiable Statement

- Control.Search.Language: instance Simplifiable Value

- Control.Search.Memo: instance [overlap ok] (MemoM m, FMonadT t) => MemoM (t m)

- Control.Search.Memo: instance [overlap ok] Eq MemoKey

- Control.Search.Memo: instance [overlap ok] FMonadT MemoT

- Control.Search.Memo: instance [overlap ok] Monad m => MemoM (MemoT m)

- Control.Search.Memo: instance [overlap ok] Monad m => StateM MemoInfo (MemoT m)

- Control.Search.Memo: instance [overlap ok] MonadInfoT MemoT

- Control.Search.Memo: instance [overlap ok] MonadT MemoT

- Control.Search.Memo: instance [overlap ok] Ord MemoKey

- Control.Search.Memo: memoCode :: MemoValue -> Statement

- Control.Search.Memo: memoCount :: MemoInfo -> Int

- Control.Search.Memo: memoExtra :: MemoKey -> Maybe (Map Int String)

- Control.Search.Memo: memoFields :: MemoValue -> [(String, String)]

- Control.Search.Memo: memoFn :: MemoKey -> String

- Control.Search.Memo: memoId :: MemoValue -> Int

- Control.Search.Memo: memoInfo :: MemoKey -> Maybe Info

- Control.Search.Memo: memoMap :: MemoInfo -> Map MemoKey MemoValue

- Control.Search.Memo: memoParams :: MemoKey -> [String]

- Control.Search.Memo: memoRead :: MemoInfo -> Map Int String

- Control.Search.Memo: memoStack :: MemoKey -> Maybe String

- Control.Search.Memo: memoStatement :: MemoKey -> Maybe Statement

- Control.Search.Memo: memoUsed :: MemoValue -> Int

- Control.Search.Memo: unMemoT :: MemoT m a -> SStateT MemoInfo m a

- Control.Search.MemoReader: instance (MemoM m, Show s) => ReaderM s (MemoReaderT s m)

- Control.Search.MemoReader: instance FMonadT (MemoReaderT s)

- Control.Search.MemoReader: instance MonadInfoT (MemoReaderT r)

- Control.Search.MemoReader: instance MonadT (MemoReaderT r)

- Control.Search.MemoReader: unMemoReaderT :: MemoReaderT r m a -> Int -> ReaderT r m a

- Control.Search.SStateT: instance FMonadT (SStateT s)

- Control.Search.SStateT: instance MMonadT (SStateT s)

- Control.Search.SStateT: instance Monad m => StateM z (SStateT z m)

- Control.Search.SStateT: instance MonadFix m => MonadFix (SStateT s m)

- Control.Search.SStateT: instance MonadT (SStateT s)

- Control.Search.Stat: instance Bounded Stat

- Control.Search.Stat: instance Eq (Info -> Value)

- Control.Search.Stat: instance Eq Stat

- Control.Search.Stat: instance Num (Info -> Value)

- Control.Search.Stat: instance Num Stat

- Control.Search.Stat: instance Show (Info -> Value)

- Control.Search.Stat: instance Show Stat

- Data.Expr.Data: instance (Eq t, Eq c, Eq b) => Eq (BoolExpr t c b)

- Data.Expr.Data: instance (Eq t, Eq c, Eq b) => Eq (ColExpr t c b)

- Data.Expr.Data: instance (Eq t, Eq c, Eq b) => Eq (Expr t c b)

- Data.Expr.Data: instance (Ord s, Ord c, Ord b) => Ord (BoolExpr s c b)

- Data.Expr.Data: instance (Ord s, Ord c, Ord b) => Ord (ColExpr s c b)

- Data.Expr.Data: instance (Ord s, Ord c, Ord b) => Ord (Expr s c b)

- Data.Expr.Data: instance (Show t, Show c, Show b) => Show (BoolExpr t c b)

- Data.Expr.Data: instance (Show t, Show c, Show b) => Show (ColExpr t c b)

- Data.Expr.Data: instance (Show t, Show c, Show b) => Show (Expr t c b)

- Data.Expr.Data: instance (Show t, Show c, Show b) => ShowFn (BoolExpr t c b)

- Data.Expr.Data: instance (Show t, Show c, Show b) => ShowFn (ColExpr t c b)

- Data.Expr.Data: instance (Show t, Show c, Show b) => ShowFn (Expr t c b)

- Data.Expr.Data: instance (Show t, Show c, Show b, ShowFn e) => ShowFn (Expr t c b -> e)

- Data.Expr.Data: instance Eq ExprRel

- Data.Expr.Data: instance Ord ExprRel

- Data.Expr.Data: instance Show ExprRel

- Data.Expr.Data: instance ShowFn l => ShowFn [l]

- Data.Expr.Sugar: instance (Eq b, Eq a, Eq t) => ToColExpr t a b [Expr t a b]

- Data.Expr.Sugar: instance (Eq s, Eq c, Eq b) => Enum (Expr s c b)

- Data.Expr.Sugar: instance (Eq s, Eq c, Eq b, Show s, Show c, Show b) => Num (Expr s c b)

- Data.Expr.Sugar: instance (Eq t, Eq a, Eq b) => ToColExpr t a b (Expr t a b)

- Data.Expr.Sugar: instance (Eq t, Eq a, Eq b) => ToExpr t a b (BoolExpr t a b)

- Data.Expr.Sugar: instance (Eq t, Eq c, Eq b) => ExprClass t c b (BoolExpr t c b)

- Data.Expr.Sugar: instance (Eq t, Eq c, Eq b) => ExprClass t c b (ColExpr t c b)

- Data.Expr.Sugar: instance (Eq t, Eq c, Eq b) => ExprClass t c b (Expr t c b)

- Data.Expr.Sugar: instance (Eq t, Eq c, Eq b) => ExprRange t c b (ColExpr t c b)

- Data.Expr.Sugar: instance (Eq t, Eq c, Eq b) => ExprRange t c b (Expr t c b, Expr t c b)

- Data.Expr.Sugar: instance (Ord s, Ord c, Ord b, Eq s, Eq c, Eq b, Show s, Show c, Show b) => Integral (Expr s c b)

- Data.Expr.Sugar: instance (Ord s, Ord c, Ord b, Eq s, Eq c, Eq b, Show s, Show c, Show b) => Real (Expr s c b)

- Data.Expr.Sugar: instance ToBoolExpr t a b (BoolExpr t a b)

- Data.Expr.Sugar: instance ToBoolExpr t a b b

- Data.Expr.Sugar: instance ToBoolExpr tt cc bb Bool

- Data.Expr.Sugar: instance ToColExpr t a b (ColExpr t a b)

- Data.Expr.Sugar: instance ToColExpr t a b a

- Data.Expr.Sugar: instance ToExpr t a b (Expr t a b)

- Data.Expr.Sugar: instance ToExpr t a b t

- Data.Expr.Sugar: instance ToExpr tt cc bb Int

- Data.Expr.Sugar: instance ToExpr tt cc bb Integer

- Data.Expr.Util: instance Enum WalkPhase

- Data.Expr.Util: instance Enum WalkResult

- Data.Expr.Util: instance Eq WalkPhase

- Data.Expr.Util: instance Eq WalkResult

- Data.Expr.Util: instance Ord WalkPhase

- Data.Expr.Util: instance Ord WalkResult

- Data.Expr.Util: instance Show WalkPhase

- Data.Expr.Util: instance Show WalkResult

- Data.Linear: instance (Num v, Eq v, Ord t, Eq t) => Eq (Linear t v)

- Data.Linear: instance (Num v, Eq v, Ord t, Eq t, Show t) => Num (Linear t v)

- Data.Linear: instance (Num v, Ord v, Ord t, Eq t) => Ord (Linear t v)

- Data.Linear: instance (Num v, Show v, Ord t, Show t) => Show (Linear t v)

- Language.CPP.Pretty: instance (Pretty a, Pretty b) => Pretty (Either a b)

- Language.CPP.Pretty: instance Pretty (CPPConstr, String)

- Language.CPP.Pretty: instance Pretty (CPPType, Doc)

- Language.CPP.Pretty: instance Pretty (CPPType, Doc, Int, [CPPQual])

- Language.CPP.Pretty: instance Pretty CPPBlockItem

- Language.CPP.Pretty: instance Pretty CPPClass

- Language.CPP.Pretty: instance Pretty CPPConst

- Language.CPP.Pretty: instance Pretty CPPDecl

- Language.CPP.Pretty: instance Pretty CPPDef

- Language.CPP.Pretty: instance Pretty CPPElement

- Language.CPP.Pretty: instance Pretty CPPExpr

- Language.CPP.Pretty: instance Pretty CPPFile

- Language.CPP.Pretty: instance Pretty CPPMacroStm

- Language.CPP.Pretty: instance Pretty CPPNamespace

- Language.CPP.Pretty: instance Pretty CPPQual

- Language.CPP.Pretty: instance Pretty CPPStat

- Language.CPP.Pretty: instance Pretty CPPStorSpec

- Language.CPP.Pretty: instance Pretty CPPType

- Language.CPP.Pretty: instance Pretty CPPVisibility

- Language.CPP.Pretty: instance Pretty a => Pretty [a]

- Language.CPP.Pretty: instance Pretty s => Pretty (Maybe s)

- Language.CPP.Pretty: instance ToString CPPAssignOp

- Language.CPP.Syntax.AST: cppClassConstrs :: CPPClass -> [(CPPVisibility, CPPConstr)]

- Language.CPP.Syntax.AST: cppClassDecls :: CPPClass -> [(CPPVisibility, CPPDecl)]

- Language.CPP.Syntax.AST: cppClassDefs :: CPPClass -> [(CPPVisibility, CPPDef)]

- Language.CPP.Syntax.AST: cppClassInherit :: CPPClass -> [(CPPVisibility, CPPType)]

- Language.CPP.Syntax.AST: cppClassName :: CPPClass -> String

- Language.CPP.Syntax.AST: cppConstrArgs :: CPPConstr -> [CPPDecl]

- Language.CPP.Syntax.AST: cppConstrBody :: CPPConstr -> Maybe CPPStat

- Language.CPP.Syntax.AST: cppConstrInit :: CPPConstr -> [(Either CPPExpr CPPType, [CPPExpr])]

- Language.CPP.Syntax.AST: cppConstrStor :: CPPConstr -> [CPPStorSpec]

- Language.CPP.Syntax.AST: cppDeclInit :: CPPDecl -> Maybe CPPInit

- Language.CPP.Syntax.AST: cppDeclName :: CPPDecl -> Maybe String

- Language.CPP.Syntax.AST: cppDefArgs :: CPPDef -> [CPPDecl]

- Language.CPP.Syntax.AST: cppDefBody :: CPPDef -> Maybe CPPStat

- Language.CPP.Syntax.AST: cppDefName :: CPPDef -> String

- Language.CPP.Syntax.AST: cppDefQual :: CPPDef -> [CPPQual]

- Language.CPP.Syntax.AST: cppDefRetType :: CPPDef -> CPPType

- Language.CPP.Syntax.AST: cppDefStor :: CPPDef -> [CPPStorSpec]

- Language.CPP.Syntax.AST: cppMacroDefArgs :: CPPMacroStm -> Maybe [String]

- Language.CPP.Syntax.AST: cppMacroDefExpr :: CPPMacroStm -> String

- Language.CPP.Syntax.AST: cppMacroDefName :: CPPMacroStm -> String

- Language.CPP.Syntax.AST: cppMacroStm :: CPPFile -> [CPPMacroStm]

- Language.CPP.Syntax.AST: cppTranslUnit :: CPPFile -> CPPNamespace

- Language.CPP.Syntax.AST: cppType :: CPPDecl -> CPPType

- Language.CPP.Syntax.AST: cppTypeQual :: CPPDecl -> [CPPQual]

- Language.CPP.Syntax.AST: cppTypeStor :: CPPDecl -> [CPPStorSpec]

- Language.CPP.Syntax.AST: cppUsing :: CPPFile -> [String]

- Language.CPP.Syntax.AST: instance Eq CPPAssignOp

- Language.CPP.Syntax.AST: instance Eq CPPBinaryOp

- Language.CPP.Syntax.AST: instance Eq CPPBlockItem

- Language.CPP.Syntax.AST: instance Eq CPPClass

- Language.CPP.Syntax.AST: instance Eq CPPConst

- Language.CPP.Syntax.AST: instance Eq CPPConstr

- Language.CPP.Syntax.AST: instance Eq CPPDecl

- Language.CPP.Syntax.AST: instance Eq CPPDef

- Language.CPP.Syntax.AST: instance Eq CPPElement

- Language.CPP.Syntax.AST: instance Eq CPPExpr

- Language.CPP.Syntax.AST: instance Eq CPPFile

- Language.CPP.Syntax.AST: instance Eq CPPInit

- Language.CPP.Syntax.AST: instance Eq CPPMacroStm

- Language.CPP.Syntax.AST: instance Eq CPPNamespace

- Language.CPP.Syntax.AST: instance Eq CPPQual

- Language.CPP.Syntax.AST: instance Eq CPPStat

- Language.CPP.Syntax.AST: instance Eq CPPStorSpec

- Language.CPP.Syntax.AST: instance Eq CPPType

- Language.CPP.Syntax.AST: instance Eq CPPUnaryOp

- Language.CPP.Syntax.AST: instance Eq CPPVisibility

- Language.CPP.Syntax.AST: instance Ord CPPAssignOp

- Language.CPP.Syntax.AST: instance Ord CPPBinaryOp

- Language.CPP.Syntax.AST: instance Ord CPPBlockItem

- Language.CPP.Syntax.AST: instance Ord CPPClass

- Language.CPP.Syntax.AST: instance Ord CPPConst

- Language.CPP.Syntax.AST: instance Ord CPPConstr

- Language.CPP.Syntax.AST: instance Ord CPPDecl

- Language.CPP.Syntax.AST: instance Ord CPPDef

- Language.CPP.Syntax.AST: instance Ord CPPElement

- Language.CPP.Syntax.AST: instance Ord CPPExpr

- Language.CPP.Syntax.AST: instance Ord CPPFile

- Language.CPP.Syntax.AST: instance Ord CPPInit

- Language.CPP.Syntax.AST: instance Ord CPPMacroStm

- Language.CPP.Syntax.AST: instance Ord CPPNamespace

- Language.CPP.Syntax.AST: instance Ord CPPQual

- Language.CPP.Syntax.AST: instance Ord CPPStat

- Language.CPP.Syntax.AST: instance Ord CPPStorSpec

- Language.CPP.Syntax.AST: instance Ord CPPType

- Language.CPP.Syntax.AST: instance Ord CPPUnaryOp

- Language.CPP.Syntax.AST: instance Ord CPPVisibility

- Language.CPP.Syntax.AST: instance Show CPPAssignOp

- Language.CPP.Syntax.AST: instance Show CPPBinaryOp

- Language.CPP.Syntax.AST: instance Show CPPBlockItem

- Language.CPP.Syntax.AST: instance Show CPPClass

- Language.CPP.Syntax.AST: instance Show CPPConst

- Language.CPP.Syntax.AST: instance Show CPPConstr

- Language.CPP.Syntax.AST: instance Show CPPDecl

- Language.CPP.Syntax.AST: instance Show CPPDef

- Language.CPP.Syntax.AST: instance Show CPPElement

- Language.CPP.Syntax.AST: instance Show CPPExpr

- Language.CPP.Syntax.AST: instance Show CPPFile

- Language.CPP.Syntax.AST: instance Show CPPInit

- Language.CPP.Syntax.AST: instance Show CPPMacroStm

- Language.CPP.Syntax.AST: instance Show CPPNamespace

- Language.CPP.Syntax.AST: instance Show CPPQual

- Language.CPP.Syntax.AST: instance Show CPPStat

- Language.CPP.Syntax.AST: instance Show CPPStorSpec

- Language.CPP.Syntax.AST: instance Show CPPType

- Language.CPP.Syntax.AST: instance Show CPPUnaryOp

- Language.CPP.Syntax.AST: instance Show CPPVisibility

+ Control.CP.ComposableTransformers: [:-] :: (CTransformer c1, CTransformer c2, CForSolver c1 ~ solver, CForSolver c2 ~ solver, CForResult c1 ~ a, CForResult c2 ~ a) => c1 -> c2 -> Composition (CEvalState c1, CEvalState c2) (CTreeState c1, CTreeState c2) solver a

+ Control.CP.ComposableTransformers: [Seal] :: CTransformer c => c -> SealedCST (CEvalState c) (CTreeState c) (CForSolver c) (CForResult c)

+ Control.CP.ComposableTransformers: instance Control.CP.Solver.Solver solver => Control.CP.ComposableTransformers.CTransformer (Control.CP.ComposableTransformers.CBranchBoundST solver a)

+ Control.CP.ComposableTransformers: instance Control.CP.Solver.Solver solver => Control.CP.ComposableTransformers.CTransformer (Control.CP.ComposableTransformers.CDepthBoundedST solver a)

+ Control.CP.ComposableTransformers: instance Control.CP.Solver.Solver solver => Control.CP.ComposableTransformers.CTransformer (Control.CP.ComposableTransformers.CFirstSolutionST solver a)

+ Control.CP.ComposableTransformers: instance Control.CP.Solver.Solver solver => Control.CP.ComposableTransformers.CTransformer (Control.CP.ComposableTransformers.CIdentityCST solver a)

+ Control.CP.ComposableTransformers: instance Control.CP.Solver.Solver solver => Control.CP.ComposableTransformers.CTransformer (Control.CP.ComposableTransformers.CLimitedDiscrepancyST solver a)

+ Control.CP.ComposableTransformers: instance Control.CP.Solver.Solver solver => Control.CP.ComposableTransformers.CTransformer (Control.CP.ComposableTransformers.CNodeBoundedST solver a)

+ Control.CP.ComposableTransformers: instance Control.CP.Solver.Solver solver => Control.CP.ComposableTransformers.CTransformer (Control.CP.ComposableTransformers.CRandomST solver a)

+ Control.CP.ComposableTransformers: instance Control.CP.Solver.Solver solver => Control.CP.ComposableTransformers.CTransformer (Control.CP.ComposableTransformers.CSolutionBoundST solver a)

+ Control.CP.ComposableTransformers: instance Control.CP.Solver.Solver solver => Control.CP.ComposableTransformers.CTransformer (Control.CP.ComposableTransformers.Composition es ts solver a)

+ Control.CP.ComposableTransformers: instance Control.CP.Solver.Solver solver => Control.CP.ComposableTransformers.CTransformer (Control.CP.ComposableTransformers.SealedCST es ts solver a)

+ Control.CP.ComposableTransformers: instance Control.CP.Solver.Solver solver => Control.CP.Transformers.Transformer (Control.CP.ComposableTransformers.RestartST es ts solver a)

+ Control.CP.ComposableTransformers: instance Control.CP.Solver.Solver solver => Control.CP.Transformers.Transformer (Control.CP.ComposableTransformers.TStack es ts solver a)

+ Control.CP.ComposableTransformers: type family CForResult c :: *;

+ Control.CP.ComposableTransformers: }

+ Control.CP.EnumTerm: type family TermBaseType s t :: *;

+ Control.CP.EnumTerm: }

+ Control.CP.FD.Decompose: instance Control.Monad.State.Class.MonadState Control.CP.FD.Decompose.DCState Control.CP.FD.Decompose.DCMonad

+ Control.CP.FD.Decompose: instance GHC.Base.Applicative Control.CP.FD.Decompose.DCMonad

+ Control.CP.FD.Decompose: instance GHC.Base.Functor Control.CP.FD.Decompose.DCMonad

+ Control.CP.FD.Decompose: instance GHC.Base.Monad Control.CP.FD.Decompose.DCMonad

+ Control.CP.FD.FD: [fdspBoolSpec] :: FDSpecInfoBool s -> Maybe (FDBoolSpecType s) -> Maybe (FDBoolSpec s)

+ Control.CP.FD.FD: [fdspBoolTypes] :: FDSpecInfoBool s -> Set (FDBoolSpecType s)

+ Control.CP.FD.FD: [fdspBoolVal] :: FDSpecInfoBool s -> Maybe EGBoolPar

+ Control.CP.FD.FD: [fdspBoolVar] :: FDSpecInfoBool s -> Maybe EGVarId

+ Control.CP.FD.FD: [fdspColSpec] :: FDSpecInfoCol s -> Maybe (FDColSpecType s) -> Maybe (FDColSpec s)

+ Control.CP.FD.FD: [fdspColTypes] :: FDSpecInfoCol s -> Set (FDColSpecType s)

+ Control.CP.FD.FD: [fdspColVal] :: FDSpecInfoCol s -> Maybe EGColPar

+ Control.CP.FD.FD: [fdspColVar] :: FDSpecInfoCol s -> Maybe EGVarId

+ Control.CP.FD.FD: [fdspIntSpec] :: FDSpecInfoInt s -> Maybe (FDIntSpecType s) -> Maybe (FDIntSpec s)

+ Control.CP.FD.FD: [fdspIntTypes] :: FDSpecInfoInt s -> Set (FDIntSpecType s)

+ Control.CP.FD.FD: [fdspIntVal] :: FDSpecInfoInt s -> Maybe EGPar

+ Control.CP.FD.FD: [fdspIntVar] :: FDSpecInfoInt s -> Maybe EGVarId

+ Control.CP.FD.FD: instance (Control.CP.FD.FD.FDSolver s, Control.CP.EnumTerm.EnumTerm s (Control.CP.FD.FD.FDBoolTerm s)) => Control.CP.EnumTerm.EnumTerm (Control.CP.FD.FD.FDInstance s) Control.CP.FD.Model.ModelBool

+ Control.CP.FD.FD: instance (Control.CP.FD.FD.FDSolver s, Control.CP.EnumTerm.EnumTerm s (Control.CP.FD.FD.FDIntTerm s)) => Control.CP.EnumTerm.EnumTerm (Control.CP.FD.FD.FDInstance s) Control.CP.FD.Model.ModelInt

+ Control.CP.FD.FD: instance (GHC.Classes.Ord (Control.CP.FD.FD.FDBoolSpec s), GHC.Classes.Ord (Control.CP.FD.FD.FDBoolSpecType s)) => GHC.Classes.Eq (Control.CP.FD.FD.FDSpecInfoBool s)

+ Control.CP.FD.FD: instance (GHC.Classes.Ord (Control.CP.FD.FD.FDBoolSpec s), GHC.Classes.Ord (Control.CP.FD.FD.FDBoolSpecType s)) => GHC.Classes.Ord (Control.CP.FD.FD.FDSpecInfoBool s)

+ Control.CP.FD.FD: instance (GHC.Classes.Ord (Control.CP.FD.FD.FDColSpec s), GHC.Classes.Ord (Control.CP.FD.FD.FDColSpecType s)) => GHC.Classes.Eq (Control.CP.FD.FD.FDSpecInfoCol s)

+ Control.CP.FD.FD: instance (GHC.Classes.Ord (Control.CP.FD.FD.FDColSpec s), GHC.Classes.Ord (Control.CP.FD.FD.FDColSpecType s)) => GHC.Classes.Ord (Control.CP.FD.FD.FDSpecInfoCol s)

+ Control.CP.FD.FD: instance (GHC.Classes.Ord (Control.CP.FD.FD.FDIntSpec s), GHC.Classes.Ord (Control.CP.FD.FD.FDIntSpecType s)) => GHC.Classes.Eq (Control.CP.FD.FD.FDSpecInfoInt s)

+ Control.CP.FD.FD: instance (GHC.Classes.Ord (Control.CP.FD.FD.FDIntSpec s), GHC.Classes.Ord (Control.CP.FD.FD.FDIntSpecType s)) => GHC.Classes.Ord (Control.CP.FD.FD.FDSpecInfoInt s)

+ Control.CP.FD.FD: instance Control.CP.FD.FD.FDSolver s => Control.CP.Solver.Solver (Control.CP.FD.FD.FDInstance s)

+ Control.CP.FD.FD: instance Control.CP.FD.FD.FDSolver s => Control.CP.Solver.Term (Control.CP.FD.FD.FDInstance s) Control.CP.FD.Model.ModelBool

+ Control.CP.FD.FD: instance Control.CP.FD.FD.FDSolver s => Control.CP.Solver.Term (Control.CP.FD.FD.FDInstance s) Control.CP.FD.Model.ModelCol

+ Control.CP.FD.FD: instance Control.CP.FD.FD.FDSolver s => Control.CP.Solver.Term (Control.CP.FD.FD.FDInstance s) Control.CP.FD.Model.ModelInt

+ Control.CP.FD.FD: instance GHC.Base.Functor s => GHC.Base.Functor (Control.CP.FD.FD.FDInstance s)

+ Control.CP.FD.FD: instance GHC.Base.Monad s => Control.Monad.State.Class.MonadState (Control.CP.FD.FD.FDState s) (Control.CP.FD.FD.FDInstance s)

+ Control.CP.FD.FD: instance GHC.Base.Monad s => GHC.Base.Applicative (Control.CP.FD.FD.FDInstance s)

+ Control.CP.FD.FD: instance GHC.Base.Monad s => GHC.Base.Monad (Control.CP.FD.FD.FDInstance s)

+ Control.CP.FD.FD: instance GHC.Classes.Eq Control.CP.FD.FD.TermType

+ Control.CP.FD.FD: instance GHC.Classes.Ord Control.CP.FD.FD.TermType

+ Control.CP.FD.FD: instance GHC.Enum.Bounded Control.CP.FD.FD.TermType

+ Control.CP.FD.FD: instance GHC.Enum.Enum Control.CP.FD.FD.TermType

+ Control.CP.FD.FD: instance GHC.Show.Show (Control.CP.FD.FD.FDBoolSpec s) => GHC.Show.Show (Control.CP.FD.FD.FDSpecInfoBool s)

+ Control.CP.FD.FD: instance GHC.Show.Show (Control.CP.FD.FD.FDColSpec s) => GHC.Show.Show (Control.CP.FD.FD.FDSpecInfoCol s)

+ Control.CP.FD.FD: instance GHC.Show.Show (Control.CP.FD.FD.FDIntSpec s) => GHC.Show.Show (Control.CP.FD.FD.FDSpecInfoInt s)

+ Control.CP.FD.FD: instance GHC.Show.Show (Control.CP.FD.FD.TermTypeSpec s)

+ Control.CP.FD.FD: instance GHC.Show.Show Control.CP.FD.FD.TermType

+ Control.CP.FD.FD: type family FDColSpecType s :: *;

+ Control.CP.FD.FD: }

+ Control.CP.FD.Graph: [boolData] :: EGTypeData x -> x

+ Control.CP.FD.Graph: [colData] :: EGTypeData x -> x

+ Control.CP.FD.Graph: [egeCons] :: EGEdge -> EGConstraintSpec

+ Control.CP.FD.Graph: [egeLinks] :: EGEdge -> EGTypeData [EGVarId]

+ Control.CP.FD.Graph: [egmEdges] :: EGModel -> Map EGEdgeId EGEdge

+ Control.CP.FD.Graph: [egmLinks] :: EGModel -> EGTypeData (Map EGVarId [(EGEdgeId, Int)])

+ Control.CP.FD.Graph: [egmNEdges] :: EGModel -> Int

+ Control.CP.FD.Graph: [egmParams] :: EGModel -> EGTypeData Int

+ Control.CP.FD.Graph: [egmVars] :: EGModel -> EGTypeData Int

+ Control.CP.FD.Graph: [intData] :: EGTypeData x -> x

+ Control.CP.FD.Graph: [unVarId] :: EGVarId -> Int

+ Control.CP.FD.Graph: instance Control.CP.FD.Graph.Display Control.CP.FD.Graph.DisplayData

+ Control.CP.FD.Graph: instance Control.CP.FD.Graph.Display Control.CP.FD.Graph.EGEdge

+ Control.CP.FD.Graph: instance Control.CP.FD.Graph.Display Control.CP.FD.Graph.EGModel

+ Control.CP.FD.Graph: instance GHC.Classes.Eq (Control.CP.FD.Graph.EGPar -> Control.CP.FD.Graph.EGPar)

+ Control.CP.FD.Graph: instance GHC.Classes.Eq Control.CP.FD.Graph.EGConstraintSpec

+ Control.CP.FD.Graph: instance GHC.Classes.Eq Control.CP.FD.Graph.EGEdge

+ Control.CP.FD.Graph: instance GHC.Classes.Eq Control.CP.FD.Graph.EGEdgeId

+ Control.CP.FD.Graph: instance GHC.Classes.Eq Control.CP.FD.Graph.EGModel

+ Control.CP.FD.Graph: instance GHC.Classes.Eq Control.CP.FD.Graph.EGParBoolTerm

+ Control.CP.FD.Graph: instance GHC.Classes.Eq Control.CP.FD.Graph.EGParColTerm

+ Control.CP.FD.Graph: instance GHC.Classes.Eq Control.CP.FD.Graph.EGParTerm

+ Control.CP.FD.Graph: instance GHC.Classes.Eq Control.CP.FD.Graph.EGVarId

+ Control.CP.FD.Graph: instance GHC.Classes.Eq Control.CP.FD.Graph.EGVarType

+ Control.CP.FD.Graph: instance GHC.Classes.Eq x => GHC.Classes.Eq (Control.CP.FD.Graph.EGTypeData x)

+ Control.CP.FD.Graph: instance GHC.Classes.Ord (Control.CP.FD.Graph.EGPar -> Control.CP.FD.Graph.EGPar)

+ Control.CP.FD.Graph: instance GHC.Classes.Ord Control.CP.FD.Graph.EGEdgeId

+ Control.CP.FD.Graph: instance GHC.Classes.Ord Control.CP.FD.Graph.EGParBoolTerm

+ Control.CP.FD.Graph: instance GHC.Classes.Ord Control.CP.FD.Graph.EGParColTerm

+ Control.CP.FD.Graph: instance GHC.Classes.Ord Control.CP.FD.Graph.EGParTerm

+ Control.CP.FD.Graph: instance GHC.Classes.Ord Control.CP.FD.Graph.EGVarId

+ Control.CP.FD.Graph: instance GHC.Show.Show (Control.CP.FD.Graph.EGPar -> Control.CP.FD.Graph.EGPar)

+ Control.CP.FD.Graph: instance GHC.Show.Show Control.CP.FD.Graph.EGConstraintSpec

+ Control.CP.FD.Graph: instance GHC.Show.Show Control.CP.FD.Graph.EGEdge

+ Control.CP.FD.Graph: instance GHC.Show.Show Control.CP.FD.Graph.EGEdgeId

+ Control.CP.FD.Graph: instance GHC.Show.Show Control.CP.FD.Graph.EGModel

+ Control.CP.FD.Graph: instance GHC.Show.Show Control.CP.FD.Graph.EGParBoolTerm

+ Control.CP.FD.Graph: instance GHC.Show.Show Control.CP.FD.Graph.EGParColTerm

+ Control.CP.FD.Graph: instance GHC.Show.Show Control.CP.FD.Graph.EGParTerm

+ Control.CP.FD.Graph: instance GHC.Show.Show Control.CP.FD.Graph.EGVarId

+ Control.CP.FD.Graph: instance GHC.Show.Show Control.CP.FD.Graph.EGVarType

+ Control.CP.FD.Graph: instance GHC.Show.Show x => GHC.Show.Show (Control.CP.FD.Graph.EGTypeData x)

+ Control.CP.FD.Interface: infix 4 @??

+ Control.CP.FD.Interface: infix 5 @:

+ Control.CP.FD.Interface: infix 9 @..

+ Control.CP.FD.Interface: infixl 6 @-

+ Control.CP.FD.Interface: infixl 7 @%

+ Control.CP.FD.Interface: infixr 2 @||

+ Control.CP.FD.Interface: infixr 3 @&&

+ Control.CP.FD.Interface: infixr 5 @++

+ Control.CP.FD.Interface: instance Control.CP.FD.Interface.ModelExprClass (Control.CP.SearchTree.Tree Control.CP.FD.Interface.DummySolver ())

+ Control.CP.FD.Interface: instance Control.CP.FD.Interface.ModelExprClass Control.CP.FD.Model.ModelBool

+ Control.CP.FD.Interface: instance Control.CP.FD.Interface.ModelExprClass Control.CP.FD.Model.ModelCol

+ Control.CP.FD.Interface: instance Control.CP.FD.Interface.ModelExprClass Control.CP.FD.Model.ModelInt

+ Control.CP.FD.Interface: instance Control.CP.FD.Model.ModelTermType t => Control.CP.Solver.Term Control.CP.FD.Interface.DummySolver t

+ Control.CP.FD.Interface: instance Control.CP.Solver.Solver Control.CP.FD.Interface.DummySolver

+ Control.CP.FD.Interface: instance GHC.Base.Applicative Control.CP.FD.Interface.DummySolver

+ Control.CP.FD.Interface: instance GHC.Base.Functor Control.CP.FD.Interface.DummySolver

+ Control.CP.FD.Interface: instance GHC.Base.Monad Control.CP.FD.Interface.DummySolver

+ Control.CP.FD.Model: instance Control.CP.FD.Model.ModelTermType Control.CP.FD.Model.ModelBool

+ Control.CP.FD.Model: instance Control.CP.FD.Model.ModelTermType Control.CP.FD.Model.ModelCol

+ Control.CP.FD.Model: instance Control.CP.FD.Model.ModelTermType Control.CP.FD.Model.ModelInt

+ Control.CP.FD.Model: instance Data.Expr.Sugar.ToBoolExpr (Control.CP.FD.Model.ModelIntTerm Control.CP.FD.Model.ModelFunctions) (Control.CP.FD.Model.ModelColTerm Control.CP.FD.Model.ModelFunctions) (Control.CP.FD.Model.ModelBoolTerm Control.CP.FD.Model.ModelFunctions) t => Control.CP.FD.Model.ToModelBool t

+ Control.CP.FD.Model: instance Data.Expr.Sugar.ToColExpr (Control.CP.FD.Model.ModelIntTerm Control.CP.FD.Model.ModelFunctions) (Control.CP.FD.Model.ModelColTerm Control.CP.FD.Model.ModelFunctions) (Control.CP.FD.Model.ModelBoolTerm Control.CP.FD.Model.ModelFunctions) t => Control.CP.FD.Model.ToModelCol t

+ Control.CP.FD.Model: instance Data.Expr.Sugar.ToExpr (Control.CP.FD.Model.ModelIntTerm Control.CP.FD.Model.ModelFunctions) (Control.CP.FD.Model.ModelColTerm Control.CP.FD.Model.ModelFunctions) (Control.CP.FD.Model.ModelBoolTerm Control.CP.FD.Model.ModelFunctions) t => Control.CP.FD.Model.ToModelInt t

+ Control.CP.FD.Model: instance GHC.Classes.Eq Control.CP.FD.Model.ModelFunctions

+ Control.CP.FD.Model: instance GHC.Classes.Eq Control.CP.FD.Model.ModelIntros

+ Control.CP.FD.Model: instance GHC.Classes.Eq t => GHC.Classes.Eq (Control.CP.FD.Model.ModelBoolTerm t)

+ Control.CP.FD.Model: instance GHC.Classes.Eq t => GHC.Classes.Eq (Control.CP.FD.Model.ModelColTerm t)

+ Control.CP.FD.Model: instance GHC.Classes.Eq t => GHC.Classes.Eq (Control.CP.FD.Model.ModelIntTerm t)

+ Control.CP.FD.Model: instance GHC.Classes.Ord Control.CP.FD.Model.ModelFunctions

+ Control.CP.FD.Model: instance GHC.Classes.Ord Control.CP.FD.Model.ModelIntros

+ Control.CP.FD.Model: instance GHC.Classes.Ord t => GHC.Classes.Ord (Control.CP.FD.Model.ModelBoolTerm t)

+ Control.CP.FD.Model: instance GHC.Classes.Ord t => GHC.Classes.Ord (Control.CP.FD.Model.ModelColTerm t)

+ Control.CP.FD.Model: instance GHC.Classes.Ord t => GHC.Classes.Ord (Control.CP.FD.Model.ModelIntTerm t)

+ Control.CP.FD.Model: instance GHC.Show.Show (Control.CP.FD.Model.ModelColTerm t)

+ Control.CP.FD.Model: instance GHC.Show.Show (Control.CP.FD.Model.ModelIntTerm t)

+ Control.CP.FD.Model: instance GHC.Show.Show Control.CP.FD.Model.ModelFunctions

+ Control.CP.FD.Model: instance GHC.Show.Show Control.CP.FD.Model.ModelIntros

+ Control.CP.FD.Model: instance GHC.Show.Show t => GHC.Show.Show (Control.CP.FD.Model.ModelBoolTerm t)

+ Control.CP.FD.OvertonFD.Domain: instance (GHC.Real.Integral a, GHC.Real.Integral b) => Control.CP.FD.OvertonFD.Domain.ToDomain (a, b)

+ Control.CP.FD.OvertonFD.Domain: instance Control.CP.FD.OvertonFD.Domain.ToDomain ()

+ Control.CP.FD.OvertonFD.Domain: instance Control.CP.FD.OvertonFD.Domain.ToDomain Control.CP.FD.OvertonFD.Domain.Domain

+ Control.CP.FD.OvertonFD.Domain: instance Control.CP.FD.OvertonFD.Domain.ToDomain Data.IntSet.Internal.IntSet

+ Control.CP.FD.OvertonFD.Domain: instance GHC.Classes.Eq Control.CP.FD.OvertonFD.Domain.Domain

+ Control.CP.FD.OvertonFD.Domain: instance GHC.Real.Integral a => Control.CP.FD.OvertonFD.Domain.ToDomain [a]

+ Control.CP.FD.OvertonFD.Domain: instance GHC.Real.Integral a => Control.CP.FD.OvertonFD.Domain.ToDomain a

+ Control.CP.FD.OvertonFD.Domain: instance GHC.Show.Show Control.CP.FD.OvertonFD.Domain.Domain

+ Control.CP.FD.OvertonFD.OvertonFD: instance Control.CP.EnumTerm.EnumTerm Control.CP.FD.OvertonFD.OvertonFD.OvertonFD Control.CP.FD.OvertonFD.OvertonFD.FDVar

+ Control.CP.FD.OvertonFD.OvertonFD: instance Control.CP.Solver.Solver Control.CP.FD.OvertonFD.OvertonFD.OvertonFD

+ Control.CP.FD.OvertonFD.OvertonFD: instance Control.CP.Solver.Term Control.CP.FD.OvertonFD.OvertonFD.OvertonFD Control.CP.FD.OvertonFD.OvertonFD.FDVar

+ Control.CP.FD.OvertonFD.OvertonFD: instance Control.Monad.State.Class.MonadState Control.CP.FD.OvertonFD.OvertonFD.FDState Control.CP.FD.OvertonFD.OvertonFD.OvertonFD

+ Control.CP.FD.OvertonFD.OvertonFD: instance GHC.Base.Applicative Control.CP.FD.OvertonFD.OvertonFD.OvertonFD

+ Control.CP.FD.OvertonFD.OvertonFD: instance GHC.Base.Functor Control.CP.FD.OvertonFD.OvertonFD.OvertonFD

+ Control.CP.FD.OvertonFD.OvertonFD: instance GHC.Base.Monad Control.CP.FD.OvertonFD.OvertonFD.OvertonFD

+ Control.CP.FD.OvertonFD.OvertonFD: instance GHC.Classes.Eq Control.CP.FD.OvertonFD.OvertonFD.FDState

+ Control.CP.FD.OvertonFD.OvertonFD: instance GHC.Classes.Eq Control.CP.FD.OvertonFD.OvertonFD.FDVar

+ Control.CP.FD.OvertonFD.OvertonFD: instance GHC.Classes.Eq Control.CP.FD.OvertonFD.OvertonFD.OConstraint

+ Control.CP.FD.OvertonFD.OvertonFD: instance GHC.Classes.Ord Control.CP.FD.OvertonFD.OvertonFD.FDState

+ Control.CP.FD.OvertonFD.OvertonFD: instance GHC.Classes.Ord Control.CP.FD.OvertonFD.OvertonFD.FDVar

+ Control.CP.FD.OvertonFD.OvertonFD: instance GHC.Show.Show Control.CP.FD.OvertonFD.OvertonFD.FDState

+ Control.CP.FD.OvertonFD.OvertonFD: instance GHC.Show.Show Control.CP.FD.OvertonFD.OvertonFD.FDVar

+ Control.CP.FD.OvertonFD.OvertonFD: instance GHC.Show.Show Control.CP.FD.OvertonFD.OvertonFD.OConstraint

+ Control.CP.FD.OvertonFD.OvertonFD: instance GHC.Show.Show Control.CP.FD.OvertonFD.OvertonFD.VarInfo

+ Control.CP.FD.OvertonFD.Sugar: instance Control.CP.FD.FD.FDSolver Control.CP.FD.OvertonFD.OvertonFD.OvertonFD

+ Control.CP.FD.SearchSpec.Data: instance (GHC.Show.Show v, GHC.Show.Show a, GHC.Show.Show b) => GHC.Show.Show (Control.CP.FD.SearchSpec.Data.Labelling v a b)

+ Control.CP.FD.SearchSpec.Data: instance (GHC.Show.Show v, GHC.Show.Show a, GHC.Show.Show b) => GHC.Show.Show (Control.CP.FD.SearchSpec.Data.SearchSpec v a b)

+ Control.CP.FD.SearchSpec.Data: instance GHC.Classes.Eq Control.CP.FD.SearchSpec.Data.ConstraintRefs

+ Control.CP.FD.SearchSpec.Data: instance GHC.Classes.Eq Control.CP.FD.SearchSpec.Data.OptimDirection

+ Control.CP.FD.SearchSpec.Data: instance GHC.Classes.Eq Control.CP.FD.SearchSpec.Data.VarStat

+ Control.CP.FD.SearchSpec.Data: instance GHC.Classes.Ord Control.CP.FD.SearchSpec.Data.ConstraintRefs

+ Control.CP.FD.SearchSpec.Data: instance GHC.Classes.Ord Control.CP.FD.SearchSpec.Data.OptimDirection

+ Control.CP.FD.SearchSpec.Data: instance GHC.Classes.Ord Control.CP.FD.SearchSpec.Data.VarStat

+ Control.CP.FD.SearchSpec.Data: instance GHC.Show.Show Control.CP.FD.SearchSpec.Data.ConstraintRefs

+ Control.CP.FD.SearchSpec.Data: instance GHC.Show.Show Control.CP.FD.SearchSpec.Data.OptimDirection

+ Control.CP.FD.SearchSpec.Data: instance GHC.Show.Show Control.CP.FD.SearchSpec.Data.VarStat

+ Control.CP.Queue: instance Control.CP.Queue.Queue (Data.Sequence.Internal.Seq a)

+ Control.CP.Queue: instance Control.CP.Queue.Queue [a]

+ Control.CP.Queue: instance GHC.Classes.Ord a => Control.CP.Queue.Queue (Control.CP.PriorityQueue.PriorityQueue a (a, b, c))

+ Control.CP.Queue: type family Elem q :: *;

+ Control.CP.Queue: }

+ Control.CP.SearchTree: [Add] :: Constraint s -> Tree s a -> Tree s a

+ Control.CP.SearchTree: [Fail] :: Tree s a

+ Control.CP.SearchTree: [Label] :: s (Tree s a) -> Tree s a

+ Control.CP.SearchTree: [NewVar] :: Term s t => (t -> Tree s a) -> Tree s a

+ Control.CP.SearchTree: [Return] :: a -> Tree s a

+ Control.CP.SearchTree: [Try] :: Tree s a -> Tree s a -> Tree s a

+ Control.CP.SearchTree: infixr 3 /\

+ Control.CP.SearchTree: instance (Control.CP.SearchTree.MonadTree m, Control.CP.Solver.Solver (Control.CP.SearchTree.TreeSolver m)) => Control.CP.SearchTree.MonadTree (Control.Monad.Trans.Cont.ContT r m)

+ Control.CP.SearchTree: instance (GHC.Base.Monoid w, Control.CP.SearchTree.MonadTree t) => Control.CP.SearchTree.MonadTree (Control.Monad.Trans.Writer.Lazy.WriterT w t)

+ Control.CP.SearchTree: instance Control.CP.SearchTree.MonadTree t => Control.CP.SearchTree.MonadTree (Control.Monad.Trans.Reader.ReaderT env t)

+ Control.CP.SearchTree: instance Control.CP.SearchTree.MonadTree t => Control.CP.SearchTree.MonadTree (Control.Monad.Trans.State.Lazy.StateT s t)

+ Control.CP.SearchTree: instance Control.CP.Solver.Solver s => GHC.Base.Applicative (Control.CP.SearchTree.Tree s)

+ Control.CP.SearchTree: instance Control.CP.Solver.Solver s => GHC.Base.Functor (Control.CP.SearchTree.Tree s)

+ Control.CP.SearchTree: instance Control.CP.Solver.Solver s => GHC.Base.Monad (Control.CP.SearchTree.Tree s)

+ Control.CP.SearchTree: instance Control.CP.Solver.Solver solver => Control.CP.SearchTree.MonadTree (Control.CP.SearchTree.Tree solver)

+ Control.CP.SearchTree: instance GHC.Show.Show (Control.CP.SearchTree.Tree s a)

+ Control.CP.SearchTree: type family TreeSolver m :: * -> *;

+ Control.CP.SearchTree: }

+ Control.CP.Solver: instance (GHC.Base.Monoid w, Control.CP.Solver.Solver s) => Control.CP.Solver.Solver (Control.Monad.Trans.Writer.Lazy.WriterT w s)

+ Control.CP.Solver: instance (GHC.Base.Monoid w, Control.CP.Solver.Term s t) => Control.CP.Solver.Term (Control.Monad.Trans.Writer.Lazy.WriterT w s) t

+ Control.CP.Solver: type family Help solver term;

+ Control.CP.Solver: }

+ Control.CP.Transformers: instance Control.CP.Solver.Solver solver => Control.CP.Transformers.Transformer (Control.CP.Transformers.DepthBoundedST solver a)

+ Control.CP.Transformers: instance Control.CP.Solver.Solver solver => Control.CP.Transformers.Transformer (Control.CP.Transformers.NodeBoundedST solver a)

+ Control.CP.Transformers: type family ForResult t :: *;

+ Control.CP.Transformers: }

+ Control.Mixin.Mixin: infixl 5 <@>

+ Control.Search.Generator: [addH] :: Eval m -> Info -> m Statement

+ Control.Search.Generator: [bodyH] :: Eval m -> Info -> m Statement

+ Control.Search.Generator: [boolArraysE] :: Eval m -> [String]

+ Control.Search.Generator: [canBranch] :: Eval m -> m Bool

+ Control.Search.Generator: [complete] :: Eval m -> Info -> m Value

+ Control.Search.Generator: [deleteH] :: Eval m -> Info -> m Statement

+ Control.Search.Generator: [elems] :: SearchCombiner -> [SearchCombinerElem t1 t2]

+ Control.Search.Generator: [evalState_] :: Eval m -> [(String, Type, Info -> m Value)]

+ Control.Search.Generator: [failH] :: Eval m -> Info -> m Statement

+ Control.Search.Generator: [initH] :: Eval m -> Info -> m Statement

+ Control.Search.Generator: [intArraysE] :: Eval m -> [String]

+ Control.Search.Generator: [intVarsE] :: Eval m -> [String]

+ Control.Search.Generator: [mkeval] :: Search -> forall m t1. (HookStatsM m, MonadInfoT t1, FMonadT t1, Evalable m) => MkEval ((t1 :> t2) m)

+ Control.Search.Generator: [nextDiffH] :: Eval m -> Info -> m Statement

+ Control.Search.Generator: [nextSameH] :: Eval m -> Info -> m Statement

+ Control.Search.Generator: [pushLeftH] :: Eval m -> Info -> m Statement

+ Control.Search.Generator: [pushRightH] :: Eval m -> Info -> m Statement

+ Control.Search.Generator: [returnH] :: Eval m -> Info -> m Statement

+ Control.Search.Generator: [runner] :: SearchCombiner -> forall m x. Evalable m => ((t1 :> t2) m) x -> m x

+ Control.Search.Generator: [runsearch] :: Search -> forall m x. (Evalable m) => t2 m x -> m x

+ Control.Search.Generator: [startTryH] :: Eval m -> Info -> m Statement

+ Control.Search.Generator: [structs] :: Eval m -> ([Struct], [Struct])

+ Control.Search.Generator: [toString] :: Eval m -> String

+ Control.Search.Generator: [treeState_] :: Eval m -> [(String, Type, Info -> m Statement)]

+ Control.Search.Generator: [tryH] :: Eval m -> Info -> m Statement

+ Control.Search.Generator: [tryLH] :: Eval m -> Info -> m Statement

+ Control.Search.Generator: instance (Control.Monatron.MonadT.MonadT t, Control.Search.Generator.HookStatsM m) => Control.Search.Generator.HookStatsM (t m)

+ Control.Search.Generator: instance (Control.Search.Generator.GenModeM m, Control.Monatron.MonadT.FMonadT t) => Control.Search.Generator.GenModeM (t m)

+ Control.Search.Generator: instance (Control.Search.Generator.VarInfoM m, Control.Monatron.MonadT.FMonadT t) => Control.Search.Generator.VarInfoM (t m)

+ Control.Search.Generator: instance (Control.Search.Generator.VarInfoM m, Control.Search.Generator.HookStatsM m, Control.Monatron.MonadInfo.MonadInfo m, Control.Search.Memo.MemoM m, Control.Search.Generator.GenModeM m, GHC.Base.Functor m) => Control.Search.Generator.Evalable m

+ Control.Search.Generator: instance Control.Monatron.MonadInfo.MonadInfoT Control.Search.Generator.GenModeT

+ Control.Search.Generator: instance Control.Monatron.MonadInfo.MonadInfoT Control.Search.Generator.HookStatsT

+ Control.Search.Generator: instance Control.Monatron.MonadInfo.MonadInfoT Control.Search.Generator.VarInfoT

+ Control.Search.Generator: instance Control.Monatron.MonadT.FMonadT Control.Search.Generator.GenModeT

+ Control.Search.Generator: instance Control.Monatron.MonadT.FMonadT Control.Search.Generator.HookStatsT

+ Control.Search.Generator: instance Control.Monatron.MonadT.FMonadT Control.Search.Generator.VarInfoT

+ Control.Search.Generator: instance Control.Monatron.MonadT.MonadT Control.Search.Generator.GenModeT

+ Control.Search.Generator: instance Control.Monatron.MonadT.MonadT Control.Search.Generator.HookStatsT

+ Control.Search.Generator: instance Control.Monatron.MonadT.MonadT Control.Search.Generator.VarInfoT

+ Control.Search.Generator: instance Control.Search.Generator.Evalable m => Control.Search.Generator.Memoable (m Control.Search.Language.Statement)

+ Control.Search.Generator: instance Control.Search.Generator.Memoable m => Control.Search.Generator.Memoable ((Control.Search.Language.Type, Control.Search.Language.Value) -> m)

+ Control.Search.Generator: instance Data.Semigroup.Semigroup Control.Search.Generator.ProgramString

+ Control.Search.Generator: instance GHC.Base.Monad m => Control.Monatron.AutoLift.ReaderM Control.Search.Language.GenMode (Control.Search.Generator.GenModeT m)

+ Control.Search.Generator: instance GHC.Base.Monad m => Control.Monatron.AutoLift.StateM Control.Search.Generator.HookStat (Control.Search.Generator.HookStatsT m)

+ Control.Search.Generator: instance GHC.Base.Monad m => Control.Monatron.AutoLift.StateM Control.Search.Generator.VarInfo (Control.Search.Generator.VarInfoT m)

+ Control.Search.Generator: instance GHC.Base.Monad m => Control.Search.Generator.GenModeM (Control.Search.Generator.GenModeT m)

+ Control.Search.Generator: instance GHC.Base.Monad m => Control.Search.Generator.HookStatsM (Control.Search.Generator.HookStatsT m)

+ Control.Search.Generator: instance GHC.Base.Monad m => Control.Search.Generator.VarInfoM (Control.Search.Generator.VarInfoT m)

+ Control.Search.Generator: instance GHC.Base.Monad m => GHC.Base.Monad (Control.Search.Generator.HookStatsT m)

+ Control.Search.Generator: instance GHC.Base.Monoid Control.Search.Generator.ProgramString

+ Control.Search.Generator: instance GHC.Classes.Eq Control.Search.Generator.VarId

+ Control.Search.Generator: instance GHC.Classes.Ord Control.Search.Generator.VarId

+ Control.Search.Generator: instance GHC.Show.Show Control.Search.Generator.SeqPos

+ Control.Search.Generator: instance GHC.Show.Show Control.Search.Generator.VarId

+ Control.Search.GeneratorInfo: [abort_] :: Info -> [Statement -> Statement]

+ Control.Search.GeneratorInfo: [baseTstate] :: Info -> TreeState

+ Control.Search.GeneratorInfo: [clone] :: Info -> Info -> Statement

+ Control.Search.GeneratorInfo: [commit_] :: Info -> [Statement -> Statement]

+ Control.Search.GeneratorInfo: [evalStateType] :: Info -> Type

+ Control.Search.GeneratorInfo: [field] :: Info -> String -> Value

+ Control.Search.GeneratorInfo: [old] :: Info -> Info

+ Control.Search.GeneratorInfo: [path] :: Info -> TreeState -> TreeState

+ Control.Search.GeneratorInfo: [stackField] :: Info -> [(String, String)]

+ Control.Search.GeneratorInfo: [treeStateType] :: Info -> Type

+ Control.Search.GeneratorInfo: instance GHC.Classes.Eq Control.Search.GeneratorInfo.Info

+ Control.Search.GeneratorInfo: instance GHC.Classes.Ord Control.Search.GeneratorInfo.Info

+ Control.Search.Language: [genMode] :: PrettyFlags -> GenMode

+ Control.Search.Language: instance Control.Search.Language.Pretty Control.Search.Language.Constraint

+ Control.Search.Language: instance Control.Search.Language.Pretty Control.Search.Language.Statement

+ Control.Search.Language: instance Control.Search.Language.Pretty Control.Search.Language.Struct

+ Control.Search.Language: instance Control.Search.Language.Pretty Control.Search.Language.Type

+ Control.Search.Language: instance Control.Search.Language.Pretty Control.Search.Language.Value

+ Control.Search.Language: instance Control.Search.Language.Simplifiable Control.Search.Language.Statement

+ Control.Search.Language: instance Control.Search.Language.Simplifiable Control.Search.Language.Value

+ Control.Search.Language: instance Data.Semigroup.Semigroup Control.Search.Language.Statement

+ Control.Search.Language: instance GHC.Base.Monoid Control.Search.Language.Statement

+ Control.Search.Language: instance GHC.Classes.Eq (Control.Search.Language.Value -> Control.Search.Language.Value -> Control.Search.Language.Value)

+ Control.Search.Language: instance GHC.Classes.Eq (Control.Search.Language.Value -> Control.Search.Language.Value)

+ Control.Search.Language: instance GHC.Classes.Eq Control.Search.Language.Constraint

+ Control.Search.Language: instance GHC.Classes.Eq Control.Search.Language.GenMode

+ Control.Search.Language: instance GHC.Classes.Eq Control.Search.Language.PrettyFlags

+ Control.Search.Language: instance GHC.Classes.Eq Control.Search.Language.Statement

+ Control.Search.Language: instance GHC.Classes.Eq Control.Search.Language.Struct

+ Control.Search.Language: instance GHC.Classes.Eq Control.Search.Language.Type

+ Control.Search.Language: instance GHC.Classes.Eq Control.Search.Language.Value

+ Control.Search.Language: instance GHC.Classes.Ord (Control.Search.Language.Value -> Control.Search.Language.Value -> Control.Search.Language.Value)

+ Control.Search.Language: instance GHC.Classes.Ord (Control.Search.Language.Value -> Control.Search.Language.Value)

+ Control.Search.Language: instance GHC.Classes.Ord Control.Search.Language.Constraint

+ Control.Search.Language: instance GHC.Classes.Ord Control.Search.Language.Statement

+ Control.Search.Language: instance GHC.Classes.Ord Control.Search.Language.Struct

+ Control.Search.Language: instance GHC.Classes.Ord Control.Search.Language.Type

+ Control.Search.Language: instance GHC.Classes.Ord Control.Search.Language.Value

+ Control.Search.Language: instance GHC.Num.Num Control.Search.Language.Value

+ Control.Search.Language: instance GHC.Show.Show (Control.Search.Language.Value -> Control.Search.Language.Value -> Control.Search.Language.Value)

+ Control.Search.Language: instance GHC.Show.Show (Control.Search.Language.Value -> Control.Search.Language.Value)

+ Control.Search.Language: instance GHC.Show.Show Control.Search.Language.Constraint

+ Control.Search.Language: instance GHC.Show.Show Control.Search.Language.Statement

+ Control.Search.Language: instance GHC.Show.Show Control.Search.Language.Struct

+ Control.Search.Language: instance GHC.Show.Show Control.Search.Language.Type

+ Control.Search.Language: instance GHC.Show.Show Control.Search.Language.Value

+ Control.Search.Memo: [memoCode] :: MemoValue -> Statement

+ Control.Search.Memo: [memoCount] :: MemoInfo -> Int

+ Control.Search.Memo: [memoExtra] :: MemoKey -> Maybe (Map Int String)

+ Control.Search.Memo: [memoFields] :: MemoValue -> [(String, String)]

+ Control.Search.Memo: [memoFn] :: MemoKey -> String

+ Control.Search.Memo: [memoId] :: MemoValue -> Int

+ Control.Search.Memo: [memoInfo] :: MemoKey -> Maybe Info

+ Control.Search.Memo: [memoMap] :: MemoInfo -> Map MemoKey MemoValue

+ Control.Search.Memo: [memoParams] :: MemoKey -> [String]

+ Control.Search.Memo: [memoRead] :: MemoInfo -> Map Int String

+ Control.Search.Memo: [memoStack] :: MemoKey -> Maybe String

+ Control.Search.Memo: [memoStatement] :: MemoKey -> Maybe Statement

+ Control.Search.Memo: [memoUsed] :: MemoValue -> Int

+ Control.Search.Memo: [unMemoT] :: MemoT m a -> SStateT MemoInfo m a

+ Control.Search.Memo: instance (Control.Search.Memo.MemoM m, Control.Monatron.MonadT.FMonadT t) => Control.Search.Memo.MemoM (t m)

+ Control.Search.Memo: instance Control.Monatron.MonadInfo.MonadInfoT Control.Search.Memo.MemoT

+ Control.Search.Memo: instance Control.Monatron.MonadT.FMonadT Control.Search.Memo.MemoT

+ Control.Search.Memo: instance Control.Monatron.MonadT.MonadT Control.Search.Memo.MemoT

+ Control.Search.Memo: instance GHC.Base.Monad m => Control.Monatron.AutoLift.StateM Control.Search.Memo.MemoInfo (Control.Search.Memo.MemoT m)

+ Control.Search.Memo: instance GHC.Base.Monad m => Control.Search.Memo.MemoM (Control.Search.Memo.MemoT m)

+ Control.Search.Memo: instance GHC.Classes.Eq Control.Search.Memo.MemoKey

+ Control.Search.Memo: instance GHC.Classes.Ord Control.Search.Memo.MemoKey

+ Control.Search.MemoReader: [unMemoReaderT] :: MemoReaderT r m a -> Int -> ReaderT r m a

+ Control.Search.MemoReader: instance (Control.Search.Memo.MemoM m, GHC.Show.Show s) => Control.Monatron.AutoLift.ReaderM s (Control.Search.MemoReader.MemoReaderT s m)

+ Control.Search.MemoReader: instance Control.Monatron.MonadInfo.MonadInfoT (Control.Search.MemoReader.MemoReaderT r)

+ Control.Search.MemoReader: instance Control.Monatron.MonadT.FMonadT (Control.Search.MemoReader.MemoReaderT s)

+ Control.Search.MemoReader: instance Control.Monatron.MonadT.MonadT (Control.Search.MemoReader.MemoReaderT r)

+ Control.Search.SStateT: instance Control.Monad.Fix.MonadFix m => Control.Monad.Fix.MonadFix (Control.Search.SStateT.SStateT s m)

+ Control.Search.SStateT: instance Control.Monatron.MonadT.FMonadT (Control.Search.SStateT.SStateT s)

+ Control.Search.SStateT: instance Control.Monatron.MonadT.MMonadT (Control.Search.SStateT.SStateT s)

+ Control.Search.SStateT: instance Control.Monatron.MonadT.MonadT (Control.Search.SStateT.SStateT s)

+ Control.Search.SStateT: instance GHC.Base.Monad m => Control.Monatron.AutoLift.StateM z (Control.Search.SStateT.SStateT z m)

+ Control.Search.Stat: instance GHC.Classes.Eq (Control.Search.GeneratorInfo.Info -> Control.Search.Language.Value)

+ Control.Search.Stat: instance GHC.Classes.Eq Control.Search.Stat.Stat

+ Control.Search.Stat: instance GHC.Enum.Bounded Control.Search.Stat.Stat

+ Control.Search.Stat: instance GHC.Num.Num (Control.Search.GeneratorInfo.Info -> Control.Search.Language.Value)

+ Control.Search.Stat: instance GHC.Num.Num Control.Search.Stat.Stat

+ Control.Search.Stat: instance GHC.Show.Show (Control.Search.GeneratorInfo.Info -> Control.Search.Language.Value)

+ Control.Search.Stat: instance GHC.Show.Show Control.Search.Stat.Stat

+ Data.Expr.Data: infixr 4 <<>>

+ Data.Expr.Data: instance (GHC.Classes.Eq t, GHC.Classes.Eq c, GHC.Classes.Eq b) => GHC.Classes.Eq (Data.Expr.Data.BoolExpr t c b)

+ Data.Expr.Data: instance (GHC.Classes.Eq t, GHC.Classes.Eq c, GHC.Classes.Eq b) => GHC.Classes.Eq (Data.Expr.Data.ColExpr t c b)

+ Data.Expr.Data: instance (GHC.Classes.Eq t, GHC.Classes.Eq c, GHC.Classes.Eq b) => GHC.Classes.Eq (Data.Expr.Data.Expr t c b)

+ Data.Expr.Data: instance (GHC.Classes.Ord s, GHC.Classes.Ord c, GHC.Classes.Ord b) => GHC.Classes.Ord (Data.Expr.Data.BoolExpr s c b)

+ Data.Expr.Data: instance (GHC.Classes.Ord s, GHC.Classes.Ord c, GHC.Classes.Ord b) => GHC.Classes.Ord (Data.Expr.Data.ColExpr s c b)

+ Data.Expr.Data: instance (GHC.Classes.Ord s, GHC.Classes.Ord c, GHC.Classes.Ord b) => GHC.Classes.Ord (Data.Expr.Data.Expr s c b)

+ Data.Expr.Data: instance (GHC.Show.Show t, GHC.Show.Show c, GHC.Show.Show b) => Data.Expr.Data.ShowFn (Data.Expr.Data.BoolExpr t c b)

+ Data.Expr.Data: instance (GHC.Show.Show t, GHC.Show.Show c, GHC.Show.Show b) => Data.Expr.Data.ShowFn (Data.Expr.Data.ColExpr t c b)

+ Data.Expr.Data: instance (GHC.Show.Show t, GHC.Show.Show c, GHC.Show.Show b) => Data.Expr.Data.ShowFn (Data.Expr.Data.Expr t c b)

+ Data.Expr.Data: instance (GHC.Show.Show t, GHC.Show.Show c, GHC.Show.Show b) => GHC.Show.Show (Data.Expr.Data.BoolExpr t c b)

+ Data.Expr.Data: instance (GHC.Show.Show t, GHC.Show.Show c, GHC.Show.Show b) => GHC.Show.Show (Data.Expr.Data.ColExpr t c b)

+ Data.Expr.Data: instance (GHC.Show.Show t, GHC.Show.Show c, GHC.Show.Show b) => GHC.Show.Show (Data.Expr.Data.Expr t c b)

+ Data.Expr.Data: instance (GHC.Show.Show t, GHC.Show.Show c, GHC.Show.Show b, Data.Expr.Data.ShowFn e) => Data.Expr.Data.ShowFn (Data.Expr.Data.Expr t c b -> e)

+ Data.Expr.Data: instance Data.Expr.Data.ShowFn l => Data.Expr.Data.ShowFn [l]

+ Data.Expr.Data: instance GHC.Classes.Eq Data.Expr.Data.ExprRel

+ Data.Expr.Data: instance GHC.Classes.Ord Data.Expr.Data.ExprRel

+ Data.Expr.Data: instance GHC.Show.Show Data.Expr.Data.ExprRel

+ Data.Expr.Sugar: infix 4 @??

+ Data.Expr.Sugar: infix 5 @:

+ Data.Expr.Sugar: infix 9 @..

+ Data.Expr.Sugar: infixl 6 @-

+ Data.Expr.Sugar: infixl 7 @%

+ Data.Expr.Sugar: infixr 2 @||

+ Data.Expr.Sugar: infixr 3 @&&

+ Data.Expr.Sugar: infixr 4 @<=

+ Data.Expr.Sugar: infixr 5 @++

+ Data.Expr.Sugar: instance (GHC.Classes.Eq b, GHC.Classes.Eq a, GHC.Classes.Eq t) => Data.Expr.Sugar.ToColExpr t a b [Data.Expr.Data.Expr t a b]

+ Data.Expr.Sugar: instance (GHC.Classes.Eq s, GHC.Classes.Eq c, GHC.Classes.Eq b) => GHC.Enum.Enum (Data.Expr.Data.Expr s c b)

+ Data.Expr.Sugar: instance (GHC.Classes.Eq s, GHC.Classes.Eq c, GHC.Classes.Eq b, GHC.Show.Show s, GHC.Show.Show c, GHC.Show.Show b) => GHC.Num.Num (Data.Expr.Data.Expr s c b)

+ Data.Expr.Sugar: instance (GHC.Classes.Eq t, GHC.Classes.Eq a, GHC.Classes.Eq b) => Data.Expr.Sugar.ToColExpr t a b (Data.Expr.Data.Expr t a b)

+ Data.Expr.Sugar: instance (GHC.Classes.Eq t, GHC.Classes.Eq a, GHC.Classes.Eq b) => Data.Expr.Sugar.ToExpr t a b (Data.Expr.Data.BoolExpr t a b)

+ Data.Expr.Sugar: instance (GHC.Classes.Eq t, GHC.Classes.Eq c, GHC.Classes.Eq b) => Data.Expr.Sugar.ExprClass t c b (Data.Expr.Data.BoolExpr t c b)

+ Data.Expr.Sugar: instance (GHC.Classes.Eq t, GHC.Classes.Eq c, GHC.Classes.Eq b) => Data.Expr.Sugar.ExprClass t c b (Data.Expr.Data.ColExpr t c b)

+ Data.Expr.Sugar: instance (GHC.Classes.Eq t, GHC.Classes.Eq c, GHC.Classes.Eq b) => Data.Expr.Sugar.ExprClass t c b (Data.Expr.Data.Expr t c b)

+ Data.Expr.Sugar: instance (GHC.Classes.Eq t, GHC.Classes.Eq c, GHC.Classes.Eq b) => Data.Expr.Sugar.ExprRange t c b (Data.Expr.Data.ColExpr t c b)

+ Data.Expr.Sugar: instance (GHC.Classes.Eq t, GHC.Classes.Eq c, GHC.Classes.Eq b) => Data.Expr.Sugar.ExprRange t c b (Data.Expr.Data.Expr t c b, Data.Expr.Data.Expr t c b)

+ Data.Expr.Sugar: instance (GHC.Classes.Ord s, GHC.Classes.Ord c, GHC.Classes.Ord b, GHC.Classes.Eq s, GHC.Classes.Eq c, GHC.Classes.Eq b, GHC.Show.Show s, GHC.Show.Show c, GHC.Show.Show b) => GHC.Real.Integral (Data.Expr.Data.Expr s c b)

+ Data.Expr.Sugar: instance Data.Expr.Sugar.ToBoolExpr t a b (Data.Expr.Data.BoolExpr t a b)

+ Data.Expr.Sugar: instance Data.Expr.Sugar.ToBoolExpr t a b b

+ Data.Expr.Sugar: instance Data.Expr.Sugar.ToBoolExpr tt cc bb GHC.Types.Bool

+ Data.Expr.Sugar: instance Data.Expr.Sugar.ToColExpr t a b (Data.Expr.Data.ColExpr t a b)

+ Data.Expr.Sugar: instance Data.Expr.Sugar.ToColExpr t a b a

+ Data.Expr.Sugar: instance Data.Expr.Sugar.ToExpr t a b (Data.Expr.Data.Expr t a b)

+ Data.Expr.Sugar: instance Data.Expr.Sugar.ToExpr t a b t

+ Data.Expr.Sugar: instance Data.Expr.Sugar.ToExpr tt cc bb GHC.Integer.Type.Integer

+ Data.Expr.Sugar: instance Data.Expr.Sugar.ToExpr tt cc bb GHC.Types.Int

+ Data.Expr.Util: instance GHC.Classes.Eq Data.Expr.Util.WalkPhase

+ Data.Expr.Util: instance GHC.Classes.Eq Data.Expr.Util.WalkResult

+ Data.Expr.Util: instance GHC.Classes.Ord Data.Expr.Util.WalkPhase

+ Data.Expr.Util: instance GHC.Classes.Ord Data.Expr.Util.WalkResult

+ Data.Expr.Util: instance GHC.Enum.Enum Data.Expr.Util.WalkPhase

+ Data.Expr.Util: instance GHC.Enum.Enum Data.Expr.Util.WalkResult

+ Data.Expr.Util: instance GHC.Show.Show Data.Expr.Util.WalkPhase

+ Data.Expr.Util: instance GHC.Show.Show Data.Expr.Util.WalkResult

+ Data.Linear: instance (GHC.Num.Num v, GHC.Classes.Eq v, GHC.Classes.Ord t, GHC.Classes.Eq t) => GHC.Classes.Eq (Data.Linear.Linear t v)

+ Data.Linear: instance (GHC.Num.Num v, GHC.Classes.Eq v, GHC.Classes.Ord t, GHC.Classes.Eq t, GHC.Show.Show t) => GHC.Num.Num (Data.Linear.Linear t v)

+ Data.Linear: instance (GHC.Num.Num v, GHC.Classes.Ord v, GHC.Classes.Ord t, GHC.Classes.Eq t) => GHC.Classes.Ord (Data.Linear.Linear t v)

+ Data.Linear: instance (GHC.Num.Num v, GHC.Show.Show v, GHC.Classes.Ord t, GHC.Show.Show t) => GHC.Show.Show (Data.Linear.Linear t v)

+ Language.CPP.Pretty: instance (Language.CPP.Pretty.Pretty a, Language.CPP.Pretty.Pretty b) => Language.CPP.Pretty.Pretty (Data.Either.Either a b)

+ Language.CPP.Pretty: instance Language.CPP.Pretty.Pretty (Language.CPP.Syntax.AST.CPPConstr, GHC.Base.String)

+ Language.CPP.Pretty: instance Language.CPP.Pretty.Pretty (Language.CPP.Syntax.AST.CPPType, Text.PrettyPrint.HughesPJ.Doc)

+ Language.CPP.Pretty: instance Language.CPP.Pretty.Pretty (Language.CPP.Syntax.AST.CPPType, Text.PrettyPrint.HughesPJ.Doc, GHC.Types.Int, [Language.CPP.Syntax.AST.CPPQual])

+ Language.CPP.Pretty: instance Language.CPP.Pretty.Pretty Language.CPP.Syntax.AST.CPPBlockItem

+ Language.CPP.Pretty: instance Language.CPP.Pretty.Pretty Language.CPP.Syntax.AST.CPPClass

+ Language.CPP.Pretty: instance Language.CPP.Pretty.Pretty Language.CPP.Syntax.AST.CPPConst

+ Language.CPP.Pretty: instance Language.CPP.Pretty.Pretty Language.CPP.Syntax.AST.CPPDecl

+ Language.CPP.Pretty: instance Language.CPP.Pretty.Pretty Language.CPP.Syntax.AST.CPPDef

+ Language.CPP.Pretty: instance Language.CPP.Pretty.Pretty Language.CPP.Syntax.AST.CPPElement

+ Language.CPP.Pretty: instance Language.CPP.Pretty.Pretty Language.CPP.Syntax.AST.CPPExpr

+ Language.CPP.Pretty: instance Language.CPP.Pretty.Pretty Language.CPP.Syntax.AST.CPPFile

+ Language.CPP.Pretty: instance Language.CPP.Pretty.Pretty Language.CPP.Syntax.AST.CPPMacroStm

+ Language.CPP.Pretty: instance Language.CPP.Pretty.Pretty Language.CPP.Syntax.AST.CPPNamespace

+ Language.CPP.Pretty: instance Language.CPP.Pretty.Pretty Language.CPP.Syntax.AST.CPPQual

+ Language.CPP.Pretty: instance Language.CPP.Pretty.Pretty Language.CPP.Syntax.AST.CPPStat

+ Language.CPP.Pretty: instance Language.CPP.Pretty.Pretty Language.CPP.Syntax.AST.CPPStorSpec

+ Language.CPP.Pretty: instance Language.CPP.Pretty.Pretty Language.CPP.Syntax.AST.CPPType

+ Language.CPP.Pretty: instance Language.CPP.Pretty.Pretty Language.CPP.Syntax.AST.CPPVisibility

+ Language.CPP.Pretty: instance Language.CPP.Pretty.Pretty a => Language.CPP.Pretty.Pretty [a]

+ Language.CPP.Pretty: instance Language.CPP.Pretty.Pretty s => Language.CPP.Pretty.Pretty (GHC.Base.Maybe s)

+ Language.CPP.Pretty: instance Language.CPP.Pretty.ToString Language.CPP.Syntax.AST.CPPAssignOp

+ Language.CPP.Syntax.AST: [cppClassConstrs] :: CPPClass -> [(CPPVisibility, CPPConstr)]

+ Language.CPP.Syntax.AST: [cppClassDecls] :: CPPClass -> [(CPPVisibility, CPPDecl)]

+ Language.CPP.Syntax.AST: [cppClassDefs] :: CPPClass -> [(CPPVisibility, CPPDef)]

+ Language.CPP.Syntax.AST: [cppClassInherit] :: CPPClass -> [(CPPVisibility, CPPType)]

+ Language.CPP.Syntax.AST: [cppClassName] :: CPPClass -> String

+ Language.CPP.Syntax.AST: [cppConstrArgs] :: CPPConstr -> [CPPDecl]

+ Language.CPP.Syntax.AST: [cppConstrBody] :: CPPConstr -> Maybe CPPStat

+ Language.CPP.Syntax.AST: [cppConstrInit] :: CPPConstr -> [(Either CPPExpr CPPType, [CPPExpr])]

+ Language.CPP.Syntax.AST: [cppConstrStor] :: CPPConstr -> [CPPStorSpec]

+ Language.CPP.Syntax.AST: [cppDeclInit] :: CPPDecl -> Maybe CPPInit

+ Language.CPP.Syntax.AST: [cppDeclName] :: CPPDecl -> Maybe String

+ Language.CPP.Syntax.AST: [cppDefArgs] :: CPPDef -> [CPPDecl]

+ Language.CPP.Syntax.AST: [cppDefBody] :: CPPDef -> Maybe CPPStat

+ Language.CPP.Syntax.AST: [cppDefName] :: CPPDef -> String

+ Language.CPP.Syntax.AST: [cppDefQual] :: CPPDef -> [CPPQual]

+ Language.CPP.Syntax.AST: [cppDefRetType] :: CPPDef -> CPPType

+ Language.CPP.Syntax.AST: [cppDefStor] :: CPPDef -> [CPPStorSpec]

+ Language.CPP.Syntax.AST: [cppMacroDefArgs] :: CPPMacroStm -> Maybe [String]

+ Language.CPP.Syntax.AST: [cppMacroDefExpr] :: CPPMacroStm -> String

+ Language.CPP.Syntax.AST: [cppMacroDefName] :: CPPMacroStm -> String

+ Language.CPP.Syntax.AST: [cppMacroStm] :: CPPFile -> [CPPMacroStm]

+ Language.CPP.Syntax.AST: [cppTranslUnit] :: CPPFile -> CPPNamespace

+ Language.CPP.Syntax.AST: [cppTypeQual] :: CPPDecl -> [CPPQual]

+ Language.CPP.Syntax.AST: [cppTypeStor] :: CPPDecl -> [CPPStorSpec]

+ Language.CPP.Syntax.AST: [cppType] :: CPPDecl -> CPPType

+ Language.CPP.Syntax.AST: [cppUsing] :: CPPFile -> [String]

+ Language.CPP.Syntax.AST: instance GHC.Classes.Eq Language.CPP.Syntax.AST.CPPAssignOp

+ Language.CPP.Syntax.AST: instance GHC.Classes.Eq Language.CPP.Syntax.AST.CPPBinaryOp

+ Language.CPP.Syntax.AST: instance GHC.Classes.Eq Language.CPP.Syntax.AST.CPPBlockItem

+ Language.CPP.Syntax.AST: instance GHC.Classes.Eq Language.CPP.Syntax.AST.CPPClass

+ Language.CPP.Syntax.AST: instance GHC.Classes.Eq Language.CPP.Syntax.AST.CPPConst

+ Language.CPP.Syntax.AST: instance GHC.Classes.Eq Language.CPP.Syntax.AST.CPPConstr

+ Language.CPP.Syntax.AST: instance GHC.Classes.Eq Language.CPP.Syntax.AST.CPPDecl

+ Language.CPP.Syntax.AST: instance GHC.Classes.Eq Language.CPP.Syntax.AST.CPPDef

+ Language.CPP.Syntax.AST: instance GHC.Classes.Eq Language.CPP.Syntax.AST.CPPElement

+ Language.CPP.Syntax.AST: instance GHC.Classes.Eq Language.CPP.Syntax.AST.CPPExpr

+ Language.CPP.Syntax.AST: instance GHC.Classes.Eq Language.CPP.Syntax.AST.CPPFile

+ Language.CPP.Syntax.AST: instance GHC.Classes.Eq Language.CPP.Syntax.AST.CPPInit

+ Language.CPP.Syntax.AST: instance GHC.Classes.Eq Language.CPP.Syntax.AST.CPPMacroStm

+ Language.CPP.Syntax.AST: instance GHC.Classes.Eq Language.CPP.Syntax.AST.CPPNamespace

+ Language.CPP.Syntax.AST: instance GHC.Classes.Eq Language.CPP.Syntax.AST.CPPQual

+ Language.CPP.Syntax.AST: instance GHC.Classes.Eq Language.CPP.Syntax.AST.CPPStat

+ Language.CPP.Syntax.AST: instance GHC.Classes.Eq Language.CPP.Syntax.AST.CPPStorSpec

+ Language.CPP.Syntax.AST: instance GHC.Classes.Eq Language.CPP.Syntax.AST.CPPType

+ Language.CPP.Syntax.AST: instance GHC.Classes.Eq Language.CPP.Syntax.AST.CPPUnaryOp

+ Language.CPP.Syntax.AST: instance GHC.Classes.Eq Language.CPP.Syntax.AST.CPPVisibility

+ Language.CPP.Syntax.AST: instance GHC.Classes.Ord Language.CPP.Syntax.AST.CPPAssignOp

+ Language.CPP.Syntax.AST: instance GHC.Classes.Ord Language.CPP.Syntax.AST.CPPBinaryOp

+ Language.CPP.Syntax.AST: instance GHC.Classes.Ord Language.CPP.Syntax.AST.CPPBlockItem

+ Language.CPP.Syntax.AST: instance GHC.Classes.Ord Language.CPP.Syntax.AST.CPPClass

+ Language.CPP.Syntax.AST: instance GHC.Classes.Ord Language.CPP.Syntax.AST.CPPConst

+ Language.CPP.Syntax.AST: instance GHC.Classes.Ord Language.CPP.Syntax.AST.CPPConstr

+ Language.CPP.Syntax.AST: instance GHC.Classes.Ord Language.CPP.Syntax.AST.CPPDecl

+ Language.CPP.Syntax.AST: instance GHC.Classes.Ord Language.CPP.Syntax.AST.CPPDef

+ Language.CPP.Syntax.AST: instance GHC.Classes.Ord Language.CPP.Syntax.AST.CPPElement

+ Language.CPP.Syntax.AST: instance GHC.Classes.Ord Language.CPP.Syntax.AST.CPPExpr

+ Language.CPP.Syntax.AST: instance GHC.Classes.Ord Language.CPP.Syntax.AST.CPPFile

+ Language.CPP.Syntax.AST: instance GHC.Classes.Ord Language.CPP.Syntax.AST.CPPInit

+ Language.CPP.Syntax.AST: instance GHC.Classes.Ord Language.CPP.Syntax.AST.CPPMacroStm

+ Language.CPP.Syntax.AST: instance GHC.Classes.Ord Language.CPP.Syntax.AST.CPPNamespace

+ Language.CPP.Syntax.AST: instance GHC.Classes.Ord Language.CPP.Syntax.AST.CPPQual

+ Language.CPP.Syntax.AST: instance GHC.Classes.Ord Language.CPP.Syntax.AST.CPPStat

+ Language.CPP.Syntax.AST: instance GHC.Classes.Ord Language.CPP.Syntax.AST.CPPStorSpec

+ Language.CPP.Syntax.AST: instance GHC.Classes.Ord Language.CPP.Syntax.AST.CPPType

+ Language.CPP.Syntax.AST: instance GHC.Classes.Ord Language.CPP.Syntax.AST.CPPUnaryOp

+ Language.CPP.Syntax.AST: instance GHC.Classes.Ord Language.CPP.Syntax.AST.CPPVisibility

+ Language.CPP.Syntax.AST: instance GHC.Show.Show Language.CPP.Syntax.AST.CPPAssignOp

+ Language.CPP.Syntax.AST: instance GHC.Show.Show Language.CPP.Syntax.AST.CPPBinaryOp

+ Language.CPP.Syntax.AST: instance GHC.Show.Show Language.CPP.Syntax.AST.CPPBlockItem

+ Language.CPP.Syntax.AST: instance GHC.Show.Show Language.CPP.Syntax.AST.CPPClass

+ Language.CPP.Syntax.AST: instance GHC.Show.Show Language.CPP.Syntax.AST.CPPConst

+ Language.CPP.Syntax.AST: instance GHC.Show.Show Language.CPP.Syntax.AST.CPPConstr

+ Language.CPP.Syntax.AST: instance GHC.Show.Show Language.CPP.Syntax.AST.CPPDecl

+ Language.CPP.Syntax.AST: instance GHC.Show.Show Language.CPP.Syntax.AST.CPPDef

+ Language.CPP.Syntax.AST: instance GHC.Show.Show Language.CPP.Syntax.AST.CPPElement

+ Language.CPP.Syntax.AST: instance GHC.Show.Show Language.CPP.Syntax.AST.CPPExpr

+ Language.CPP.Syntax.AST: instance GHC.Show.Show Language.CPP.Syntax.AST.CPPFile

+ Language.CPP.Syntax.AST: instance GHC.Show.Show Language.CPP.Syntax.AST.CPPInit

+ Language.CPP.Syntax.AST: instance GHC.Show.Show Language.CPP.Syntax.AST.CPPMacroStm

+ Language.CPP.Syntax.AST: instance GHC.Show.Show Language.CPP.Syntax.AST.CPPNamespace

+ Language.CPP.Syntax.AST: instance GHC.Show.Show Language.CPP.Syntax.AST.CPPQual

+ Language.CPP.Syntax.AST: instance GHC.Show.Show Language.CPP.Syntax.AST.CPPStat

+ Language.CPP.Syntax.AST: instance GHC.Show.Show Language.CPP.Syntax.AST.CPPStorSpec

+ Language.CPP.Syntax.AST: instance GHC.Show.Show Language.CPP.Syntax.AST.CPPType

+ Language.CPP.Syntax.AST: instance GHC.Show.Show Language.CPP.Syntax.AST.CPPUnaryOp

+ Language.CPP.Syntax.AST: instance GHC.Show.Show Language.CPP.Syntax.AST.CPPVisibility

- Control.CP.ComposableTransformers: Bound :: (forall a. Tree solver a -> Tree solver a) -> Bound solver

+ Control.CP.ComposableTransformers: Bound :: (forall a. (Tree solver a -> Tree solver a)) -> Bound solver

- Control.CP.ComposableTransformers: class Solver (CForSolver c) => CTransformer c where type family CTreeState c :: * type family CForSolver c :: * -> * type family CForResult c :: * leftCT _ = id rightCT = leftCT nextCT = evalCT returnCT = continueCT completeCT _ _ = True

+ Control.CP.ComposableTransformers: class Solver (CForSolver c) => CTransformer c where {

- Control.CP.EnumTerm: class (Solver s, Term s t, Show (TermBaseType s t)) => EnumTerm s t where type family TermBaseType s t :: * getDomainSize x = do { r <- getDomain x; return $ length r } getValue x = do { d <- getDomain x; return $ case d of { [v] -> Just v _ -> Nothing } } splitDomain x = do { d <- getDomain x; case d of { [] -> return ([], True) [_] -> return ([[]], True) _ -> do { rr <- mapM (setValue x) d; return (rr, True) } } } splitDomains [] = return ([[]], []) splitDomains (a@(x : b)) = do { s <- getDomainSize x; if s == 0 then return ([], []) else if s == 1 then splitDomains b else do { (r, v) <- splitDomain x; if v then return (r, b) else return (r, a) } } defaultOrder = firstFail enumerator = Nothing

+ Control.CP.EnumTerm: class (Solver s, Term s t, Show (TermBaseType s t)) => EnumTerm s t where {

- Control.CP.FD.Example: labeller :: (Show (FDIntTerm s), MonadTree m, EnumTerm s (FDIntTerm s), FDSolver s, ~ (* -> *) (TreeSolver m) (FDInstance s)) => ModelCol -> m [TermBaseType s (FDIntTerm s)]

+ Control.CP.FD.Example: labeller :: ((~#) (* -> *) (* -> *) TreeSolver m FDInstance s, Show FDIntTerm s, MonadTree m, FDSolver s, EnumTerm s FDIntTerm s) => ModelCol -> m [TermBaseType s FDIntTerm s]

- Control.CP.FD.Example: runSolve :: (Integral (TermBaseType s (FDIntTerm s)), Show (FDIntTerm s), EnumTerm s (FDIntTerm s), FDSolver s) => Bool -> Tree (FDInstance s) a -> (Int, [a])

+ Control.CP.FD.Example: runSolve :: (Show FDIntTerm s, EnumTerm s FDIntTerm s, Integral TermBaseType s FDIntTerm s, FDSolver s) => Bool -> Tree FDInstance s a -> (Int, [a])

- Control.CP.FD.Example: type ExampleMinModel t = forall s m. (Show (FDIntTerm s), FDSolver s, MonadTree m, TreeSolver m ~ (FDInstance s)) => t -> m (ModelInt, ModelCol)

+ Control.CP.FD.Example: type ExampleMinModel t = (forall s m. (Show (FDIntTerm s), FDSolver s, MonadTree m, TreeSolver m ~ (FDInstance s)) => t -> m (ModelInt, ModelCol))

- Control.CP.FD.FD: class (Solver s, Term s (FDIntTerm s), Term s (FDBoolTerm s), Eq (FDBoolSpecType s), Ord (FDBoolSpecType s), Enum (FDBoolSpecType s), Bounded (FDBoolSpecType s), Show (FDBoolSpecType s), Eq (FDIntSpecType s), Ord (FDIntSpecType s), Enum (FDIntSpecType s), Bounded (FDIntSpecType s), Show (FDIntSpecType s), Eq (FDColSpecType s), Ord (FDColSpecType s), Enum (FDColSpecType s), Bounded (FDColSpecType s), Show (FDColSpecType s), Show (FDIntSpec s), Show (FDColSpec s), Show (FDBoolSpec s)) => FDSolver s where type family FDIntTerm s :: * type family FDBoolTerm s :: * type family FDIntSpec s :: * type family FDBoolSpec s :: * type family FDColSpec s :: * type family FDIntSpecType s :: * type family FDBoolSpecType s :: * type family FDColSpecType s :: * fdTypeReqBool = return (\ (EGEdge {egeLinks = EGTypeData {boolData = l}}) -> map (\ x -> (x, fromList [minBound .. maxBound])) l) fdTypeReqInt = return (\ (EGEdge {egeLinks = EGTypeData {intData = l}}) -> map (\ x -> (x, fromList [minBound .. maxBound])) l) fdTypeReqCol = return (\ (EGEdge {egeLinks = EGTypeData {colData = l}}) -> map (\ x -> (x, fromList [minBound .. maxBound])) l) fdTypeVarInt = return $ singleton maxBound fdTypeVarBool = return $ singleton maxBound fdSpecify = mixinId

+ Control.CP.FD.FD: class (Solver s, Term s (FDIntTerm s), Term s (FDBoolTerm s), Eq (FDBoolSpecType s), Ord (FDBoolSpecType s), Enum (FDBoolSpecType s), Bounded (FDBoolSpecType s), Show (FDBoolSpecType s), Eq (FDIntSpecType s), Ord (FDIntSpecType s), Enum (FDIntSpecType s), Bounded (FDIntSpecType s), Show (FDIntSpecType s), Eq (FDColSpecType s), Ord (FDColSpecType s), Enum (FDColSpecType s), Bounded (FDColSpecType s), Show (FDColSpecType s), Show (FDIntSpec s), Show (FDColSpec s), Show (FDBoolSpec s)) => FDSolver s where {

- Control.CP.FD.FD: getFullBoolSpec :: (MonadState (FDState s) m, FDSolver s) => EGVarId -> m (FDSpecInfoBool s)

+ Control.CP.FD.FD: getFullBoolSpec :: (FDSolver s, MonadState FDState s m) => EGVarId -> m FDSpecInfoBool s

- Control.CP.FD.FD: getFullColSpec :: (MonadState (FDState s) m, FDSolver s) => EGVarId -> m (FDSpecInfoCol s)

+ Control.CP.FD.FD: getFullColSpec :: (FDSolver s, MonadState FDState s m) => EGVarId -> m FDSpecInfoCol s

- Control.CP.FD.FD: getFullIntSpec :: (MonadState (FDState s) m, FDSolver s) => EGVarId -> m (FDSpecInfoInt s)

+ Control.CP.FD.FD: getFullIntSpec :: (FDSolver s, MonadState FDState s m) => EGVarId -> m FDSpecInfoInt s

- Control.CP.FD.FD: specSubModelEx :: FDSolver s => EGModel -> (Int -> Maybe (FDSpecInfoBool s), Int -> Maybe (FDSpecInfoInt s), Int -> Maybe (FDSpecInfoCol s)) -> FDInstance s (Map EGVarId (FDSpecInfoBool s), Map EGVarId (FDSpecInfoInt s), Map EGVarId (FDSpecInfoCol s))

+ Control.CP.FD.FD: specSubModelEx :: FDSolver s => EGModel -> (Int -> Maybe FDSpecInfoBool s, Int -> Maybe FDSpecInfoInt s, Int -> Maybe FDSpecInfoCol s) -> FDInstance s (Map EGVarId FDSpecInfoBool s, Map EGVarId FDSpecInfoInt s, Map EGVarId FDSpecInfoCol s)

- Control.CP.FD.Interface: (@?) :: Tree DummySolver () -> (Expr (ModelIntTerm ModelFunctions) (ModelColTerm ModelFunctions) (ModelBoolTerm ModelFunctions), Expr (ModelIntTerm ModelFunctions) (ModelColTerm ModelFunctions) (ModelBoolTerm ModelFunctions)) -> Expr (ModelIntTerm ModelFunctions) (ModelColTerm ModelFunctions) (ModelBoolTerm ModelFunctions)

+ Control.CP.FD.Interface: (@?) :: Tree DummySolver () -> (Expr ModelIntTerm ModelFunctions ModelColTerm ModelFunctions ModelBoolTerm ModelFunctions, Expr ModelIntTerm ModelFunctions ModelColTerm ModelFunctions ModelBoolTerm ModelFunctions) -> Expr ModelIntTerm ModelFunctions ModelColTerm ModelFunctions ModelBoolTerm ModelFunctions

- Control.CP.FD.Interface: (@??) :: (MonadTree m, ~ * (Constraint (TreeSolver m)) (Either Model q)) => Tree DummySolver () -> (Tree DummySolver (), Tree DummySolver ()) -> m ()

+ Control.CP.FD.Interface: (@??) :: ((~#) * * Constraint TreeSolver m Either Model q, MonadTree m) => Tree DummySolver () -> (Tree DummySolver (), Tree DummySolver ()) -> m ()

- Control.CP.FD.Interface: class (Solver s, Term s (FDIntTerm s), Term s (FDBoolTerm s), Eq (FDBoolSpecType s), Ord (FDBoolSpecType s), Enum (FDBoolSpecType s), Bounded (FDBoolSpecType s), Show (FDBoolSpecType s), Eq (FDIntSpecType s), Ord (FDIntSpecType s), Enum (FDIntSpecType s), Bounded (FDIntSpecType s), Show (FDIntSpecType s), Eq (FDColSpecType s), Ord (FDColSpecType s), Enum (FDColSpecType s), Bounded (FDColSpecType s), Show (FDColSpecType s), Show (FDIntSpec s), Show (FDColSpec s), Show (FDBoolSpec s)) => FDSolver s where fdTypeReqBool = return (\ (EGEdge {egeLinks = EGTypeData {boolData = l}}) -> map (\ x -> (x, fromList [minBound .. maxBound])) l) fdTypeReqInt = return (\ (EGEdge {egeLinks = EGTypeData {intData = l}}) -> map (\ x -> (x, fromList [minBound .. maxBound])) l) fdTypeReqCol = return (\ (EGEdge {egeLinks = EGTypeData {colData = l}}) -> map (\ x -> (x, fromList [minBound .. maxBound])) l) fdTypeVarInt = return $ singleton maxBound fdTypeVarBool = return $ singleton maxBound fdSpecify = mixinId

+ Control.CP.FD.Interface: class (Solver s, Term s (FDIntTerm s), Term s (FDBoolTerm s), Eq (FDBoolSpecType s), Ord (FDBoolSpecType s), Enum (FDBoolSpecType s), Bounded (FDBoolSpecType s), Show (FDBoolSpecType s), Eq (FDIntSpecType s), Ord (FDIntSpecType s), Enum (FDIntSpecType s), Bounded (FDIntSpecType s), Show (FDIntSpecType s), Eq (FDColSpecType s), Ord (FDColSpecType s), Enum (FDColSpecType s), Bounded (FDColSpecType s), Show (FDColSpecType s), Show (FDIntSpec s), Show (FDColSpec s), Show (FDBoolSpec s)) => FDSolver s

- Control.CP.FD.SearchSpec.Data: mmapSearch :: Monad m => SearchSpec v1 a1 b1 -> (v1 -> m v2) -> (a1 -> m a2) -> (b1 -> m b2) -> m (SearchSpec v2 a2 b2)

+ Control.CP.FD.SearchSpec.Data: mmapSearch :: (Monad m) => SearchSpec v1 a1 b1 -> (v1 -> m v2) -> (a1 -> m a2) -> (b1 -> m b2) -> m (SearchSpec v2 a2 b2)

- Control.CP.FD.Solvers: bfs :: Seq a

+ Control.CP.FD.Solvers: bfs :: () => Seq a

- Control.CP.FD.Solvers: dfs :: [a]

+ Control.CP.FD.Solvers: dfs :: () => [a]

- Control.CP.PriorityQueue: is_empty :: PriorityQueue t t1 -> Bool

+ Control.CP.PriorityQueue: is_empty :: () => PriorityQueue k a -> Bool

- Control.CP.Queue: class Queue q where type family Elem q :: *

+ Control.CP.Queue: class Queue q where {

- Control.CP.SearchTree: class (Monad m, Solver (TreeSolver m)) => MonadTree m where type family TreeSolver m :: * -> *

+ Control.CP.SearchTree: class (Monad m, Solver (TreeSolver m)) => MonadTree m where {

- Control.CP.Solver: class Monad solver => Solver solver where type family Constraint solver :: * type family Label solver :: * markn _ = mark

+ Control.CP.Solver: class Monad solver => Solver solver where {

- Control.CP.Solver: class Solver solver => Term solver term where type family Help solver term

+ Control.CP.Solver: class (Solver solver) => Term solver term where {

- Control.CP.Transformers: class Transformer t where type family EvalState t :: * type family TreeState t :: * type family ForSolver t :: * -> * type family ForResult t :: * leftT _ _ = id rightT = leftT nextT = eval' returnT i wl t es = continue i wl t es endT i wl t es = return (i, [])

+ Control.CP.Transformers: class Transformer t where {

- Control.Search.Combinator.Base: randomV :: b -> Value

+ Control.Search.Combinator.Base: randomV :: () => b -> Value

- Control.Search.Generator: (@++@) :: ([a], [a1]) -> ([a], [a1]) -> ([a], [a1])

+ Control.Search.Generator: (@++@) :: () => ([a1], [a2]) -> ([a1], [a2]) -> ([a1], [a2])

- Control.Search.Generator: Search :: (forall m t1. (HookStatsM m, MonadInfoT t1, FMonadT t1, Evalable m) => MkEval ((t1 :> t2) m)) -> (forall m x. Evalable m => t2 m x -> m x) -> Search

+ Control.Search.Generator: Search :: (forall m t1. (HookStatsM m, MonadInfoT t1, FMonadT t1, Evalable m) => MkEval ((t1 :> t2) m)) -> (forall m x. (Evalable m) => t2 m x -> m x) -> Search

- Control.Search.Generator: cachedClone :: (Functor m, MonadInfo m, MemoM m, HookStatsM m, VarInfoM m, GenModeM m) => Info -> Info -> m Statement

+ Control.Search.Generator: cachedClone :: (GenModeM m, MemoM m, MonadInfo m, HookStatsM m, VarInfoM m) => Info -> Info -> m Statement

- Control.Search.Generator: memoLoop :: (Functor m, MonadInfo m, MemoM m, HookStatsM m, VarInfoM m, GenModeM m) => Eval m -> Eval m

+ Control.Search.Generator: memoLoop :: (GenModeM m, MemoM m, MonadInfo m, HookStatsM m, VarInfoM m) => Eval m -> Eval m

- Control.Search.Generator: mseqs :: Monad m => [m Statement] -> m Statement

+ Control.Search.Generator: mseqs :: (Traversable t, Monad m) => t m Statement -> m Statement

- Control.Search.Generator: rp :: Pretty a => Int -> a -> String

+ Control.Search.Generator: rp :: Pretty x => Int -> x -> String

- Control.Search.GeneratorInfo: mkInfo :: [Char] -> Info

+ Control.Search.GeneratorInfo: mkInfo :: String -> Info

- Control.Search.Language: class Pretty x where prettyX _ = pretty pretty = prettyX (PrettyFlags {genMode = ModeUnk})

+ Control.Search.Language: class Pretty x

- Control.Search.Language: seqs :: [Statement] -> Statement

+ Control.Search.Language: seqs :: Foldable t => t Statement -> Statement

- Control.Search.Memo: runMemoT :: Monad m => MemoT m t -> m (t, [(MemoKey, MemoValue)])

+ Control.Search.Memo: runMemoT :: Monad m => MemoT m a -> m (a, [(MemoKey, MemoValue)])

- Control.Search.SStateT: fst2 :: Tup2 t t1 -> t

+ Control.Search.SStateT: fst2 :: () => Tup2 a b -> a

- Control.Search.SStateT: snd2 :: Tup2 t t1 -> t1

+ Control.Search.SStateT: snd2 :: () => Tup2 a b -> b

- Data.Expr.Sugar: (@&&) :: (Eq s, Eq c, Eq b, ToBoolExpr s c b b1, ToBoolExpr s c b b2) => b1 -> b2 -> BoolExpr s c b

+ Data.Expr.Sugar: (@&&) :: (ToBoolExpr s c b1 b3, ToBoolExpr s c b1 b2, Eq b1, Eq c, Eq s) => b2 -> b3 -> BoolExpr s c b1

- Data.Expr.Sugar: (@||) :: (Eq s, Eq c, Eq b, ToBoolExpr s c b b1, ToBoolExpr s c b b2) => b1 -> b2 -> BoolExpr s c b

+ Data.Expr.Sugar: (@||) :: (ToBoolExpr s c b1 b3, ToBoolExpr s c b1 b2, Eq b1, Eq c, Eq s) => b2 -> b3 -> BoolExpr s c b1

- Data.Expr.Sugar: allDiff :: (Eq s, Eq c, Eq b) => ColExpr s c b -> BoolExpr s c b

+ Data.Expr.Sugar: allDiff :: (Eq b, Eq c, Eq s) => ColExpr s c b -> BoolExpr s c b

- Data.Expr.Sugar: allDiffD :: (Eq s, Eq c, Eq b) => ColExpr s c b -> BoolExpr s c b

+ Data.Expr.Sugar: allDiffD :: (Eq b, Eq c, Eq s) => ColExpr s c b -> BoolExpr s c b

- Data.Expr.Sugar: class (Eq tt, Eq cc, Eq bb) => ExprClass tt cc bb a where a @/= b = boolSimplify $ BoolNot $ a @= b

+ Data.Expr.Sugar: class (Eq tt, Eq cc, Eq bb) => ExprClass tt cc bb a

- Data.Expr.Sugar: sSorted :: (Eq s, Eq c, Eq b) => ColExpr s c b -> BoolExpr s c b

+ Data.Expr.Sugar: sSorted :: (Eq b, Eq c, Eq s) => ColExpr s c b -> BoolExpr s c b

- Data.Expr.Sugar: sorted :: (Eq s, Eq c, Eq b) => ColExpr s c b -> BoolExpr s c b

+ Data.Expr.Sugar: sorted :: (Eq b, Eq c, Eq s) => ColExpr s c b -> BoolExpr s c b

- Data.Expr.Util: boolTransformEx :: (Eq a, Eq b, Eq c, Eq d, Eq e, Eq f) => (a -> Expr b d f, c -> ColExpr b d f, e -> BoolExpr b d f, b -> Expr a c e, d -> ColExpr a c e, f -> BoolExpr a c e) -> BoolExpr a c e -> BoolExpr b d f

+ Data.Expr.Util: boolTransformEx :: (Eq a, Eq b, Eq c, Eq d, Eq e, Eq f) => ((a -> Expr b d f), (c -> ColExpr b d f), (e -> BoolExpr b d f), (b -> Expr a c e), (d -> ColExpr a c e), f -> BoolExpr a c e) -> BoolExpr a c e -> BoolExpr b d f

- Data.Expr.Util: boolWalk :: (Eq t, Eq c, Eq b, Monad m) => BoolExpr t c b -> (Expr t c b -> WalkPhase -> m WalkResult, ColExpr t c b -> WalkPhase -> m WalkResult, BoolExpr t c b -> WalkPhase -> m WalkResult) -> m ()

+ Data.Expr.Util: boolWalk :: (Monad m, Eq b, Eq c, Eq t) => BoolExpr t c b -> (Expr t c b -> WalkPhase -> m WalkResult, ColExpr t c b -> WalkPhase -> m WalkResult, BoolExpr t c b -> WalkPhase -> m WalkResult) -> m ()

- Data.Expr.Util: colTransformEx :: (Eq a, Eq b, Eq c, Eq d, Eq e, Eq f) => (a -> Expr b d f, c -> ColExpr b d f, e -> BoolExpr b d f, b -> Expr a c e, d -> ColExpr a c e, f -> BoolExpr a c e) -> ColExpr a c e -> ColExpr b d f

+ Data.Expr.Util: colTransformEx :: (Eq a, Eq b, Eq c, Eq d, Eq e, Eq f) => ((a -> Expr b d f), (c -> ColExpr b d f), (e -> BoolExpr b d f), (b -> Expr a c e), (d -> ColExpr a c e), f -> BoolExpr a c e) -> ColExpr a c e -> ColExpr b d f

- Data.Expr.Util: colWalk :: (Eq t, Eq c, Eq b, Monad m) => ColExpr t c b -> (Expr t c b -> WalkPhase -> m WalkResult, ColExpr t c b -> WalkPhase -> m WalkResult, BoolExpr t c b -> WalkPhase -> m WalkResult) -> m ()

+ Data.Expr.Util: colWalk :: (Monad m, Eq b, Eq c, Eq t) => ColExpr t c b -> (Expr t c b -> WalkPhase -> m WalkResult, ColExpr t c b -> WalkPhase -> m WalkResult, BoolExpr t c b -> WalkPhase -> m WalkResult) -> m ()

- Data.Expr.Util: transformEx :: (Eq a, Eq b, Eq c, Eq d, Eq e, Eq f) => (a -> Expr b d f, c -> ColExpr b d f, e -> BoolExpr b d f, b -> Expr a c e, d -> ColExpr a c e, f -> BoolExpr a c e) -> Expr a c e -> Expr b d f

+ Data.Expr.Util: transformEx :: (Eq a, Eq b, Eq c, Eq d, Eq e, Eq f) => ((a -> Expr b d f), (c -> ColExpr b d f), (e -> BoolExpr b d f), (b -> Expr a c e), (d -> ColExpr a c e), (f -> BoolExpr a c e)) -> Expr a c e -> Expr b d f

Files

Control/CP/ComposableTransformers.hs +0/−312
Control/CP/Debug.hs +0/−22
Control/CP/EnumTerm.hs +0/−113
Control/CP/FD/Decompose.hs +0/−698
Control/CP/FD/Example.hs +0/−109
Control/CP/FD/FD.hs +0/−1555
Control/CP/FD/Graph.hs +0/−411
Control/CP/FD/Interface.hs +0/−220
Control/CP/FD/Model.hs +0/−192
Control/CP/FD/OvertonFD/Domain.hs +0/−187
Control/CP/FD/OvertonFD/OvertonFD.hs +0/−392
Control/CP/FD/OvertonFD/Sugar.hs +0/−112
Control/CP/FD/SearchSpec/Data.hs +0/−111
Control/CP/FD/SimpleFD.hs +0/−190
Control/CP/FD/Solvers.hs +0/−52
Control/CP/PriorityQueue.hs +0/−110
Control/CP/Queue.hs +0/−53
Control/CP/SearchTree.hs +0/−324
Control/CP/Solver.hs +0/−80
Control/CP/Transformers.hs +0/−114
Control/Mixin/Mixin.hs +0/−60
Control/Monatron/AutoInstances.hs +0/−16
Control/Monatron/AutoLift.hs +0/−128
Control/Monatron/Codensity.hs +0/−36
Control/Monatron/IdT.hs +0/−13
Control/Monatron/Monad.hs +0/−67
Control/Monatron/MonadInfo.hs +0/−74
Control/Monatron/MonadT.hs +0/−47
Control/Monatron/Monatron.hs +0/−12
Control/Monatron/Open.hs +0/−58
Control/Monatron/Operations.hs +0/−195
Control/Monatron/Transformer.hs +0/−286
Control/Monatron/Zipper.hs +0/−123
Control/Monatron/ZipperExamples.hs +0/−83
Control/Search/Combinator/And.hs +0/−143
Control/Search/Combinator/Base.hs +0/−320
Control/Search/Combinator/Failure.hs +0/−40
Control/Search/Combinator/For.hs +0/−115
Control/Search/Combinator/If.hs +0/−151
Control/Search/Combinator/Let.hs +0/−41
Control/Search/Combinator/Misc.hs +0/−85
Control/Search/Combinator/Once.hs +0/−30
Control/Search/Combinator/Or.hs +0/−174
Control/Search/Combinator/OrRepeat.hs +0/−95
Control/Search/Combinator/Post.hs +0/−34
Control/Search/Combinator/Print.hs +0/−34
Control/Search/Combinator/Repeat.hs +0/−84
Control/Search/Combinator/Success.hs +0/−38
Control/Search/Combinator/Until.hs +0/−188
Control/Search/Constraints.hs +0/−71
Control/Search/Generator.hs +0/−855
Control/Search/GeneratorInfo.hs +0/−120
Control/Search/Language.hs +0/−531
Control/Search/Memo.hs +0/−67
Control/Search/MemoReader.hs +0/−61
Control/Search/SStateT.hs +0/−47
Control/Search/Stat.hs +0/−185
Data/Expr/Data.hs +0/−297
Data/Expr/Sugar.hs +0/−285
Data/Expr/Util.hs +0/−481
Data/Linear.hs +0/−82
LICENSE +26/−26
Language/CPP/Pretty.hs +0/−241
Language/CPP/Syntax/AST.hs +0/−174
README.md +11/−11
Setup.hs +4/−4
examples/AllInterval.hs +28/−28
examples/Alpha.hs +53/−53
examples/BIBD.hs +29/−29
examples/Domino.hs +96/−96
examples/EFPA.hs +22/−22
examples/GolombRuler.hs +30/−30
examples/GraphColor.hs +415/−415
examples/Grocery.hs +21/−21
examples/LangfordNumber.hs +30/−30
examples/MagicSeries.hs +20/−20
examples/MagicSquare.hs +34/−34
examples/MineSweeper.hs +50/−50
examples/Olympic.hs +52/−51
examples/Partition.hs +32/−32
examples/PerfectSquare.hs +26/−26
examples/Queens.hs +22/−22
examples/Ring.hs +19/−19
examples/StressDomain.hs +22/−22
examples/Sudoku.hs +46/−46
examples/Test.hs +15/−15
examples/TestPretty.hs +20/−20
examples/TryDemo.hs +21/−21
examples/Zebra.hs +43/−43
monadiccp.cabal +106/−98
src/Control/CP/ComposableTransformers.hs +313/−0
src/Control/CP/Debug.hs +22/−0
src/Control/CP/EnumTerm.hs +113/−0
src/Control/CP/FD/Decompose.hs +699/−0
src/Control/CP/FD/Example.hs +110/−0
src/Control/CP/FD/FD.hs +1556/−0
src/Control/CP/FD/Graph.hs +411/−0
src/Control/CP/FD/Interface.hs +229/−0
src/Control/CP/FD/Model.hs +192/−0
src/Control/CP/FD/OvertonFD/Domain.hs +187/−0
src/Control/CP/FD/OvertonFD/OvertonFD.hs +392/−0
src/Control/CP/FD/OvertonFD/Sugar.hs +113/−0
src/Control/CP/FD/SearchSpec/Data.hs +111/−0
src/Control/CP/FD/SimpleFD.hs +190/−0
src/Control/CP/FD/Solvers.hs +52/−0
src/Control/CP/PriorityQueue.hs +112/−0
src/Control/CP/Queue.hs +53/−0
src/Control/CP/SearchTree.hs +328/−0
src/Control/CP/Solver.hs +80/−0
src/Control/CP/Transformers.hs +115/−0
src/Control/Mixin/Mixin.hs +60/−0
src/Control/Monatron/AutoInstances.hs +19/−0
src/Control/Monatron/AutoLift.hs +128/−0
src/Control/Monatron/Codensity.hs +36/−0
src/Control/Monatron/IdT.hs +13/−0
src/Control/Monatron/Monad.hs +70/−0
src/Control/Monatron/MonadInfo.hs +74/−0
src/Control/Monatron/MonadT.hs +47/−0
src/Control/Monatron/Monatron.hs +12/−0
src/Control/Monatron/Open.hs +58/−0
src/Control/Monatron/Operations.hs +195/−0
src/Control/Monatron/Transformer.hs +286/−0
src/Control/Monatron/Zipper.hs +123/−0
src/Control/Monatron/ZipperExamples.hs +83/−0
src/Control/Search/Combinator/And.hs +143/−0
src/Control/Search/Combinator/Base.hs +320/−0
src/Control/Search/Combinator/Failure.hs +40/−0
src/Control/Search/Combinator/For.hs +115/−0
src/Control/Search/Combinator/If.hs +151/−0
src/Control/Search/Combinator/Let.hs +41/−0
src/Control/Search/Combinator/Misc.hs +85/−0
src/Control/Search/Combinator/Once.hs +30/−0
src/Control/Search/Combinator/Or.hs +174/−0
src/Control/Search/Combinator/OrRepeat.hs +95/−0
src/Control/Search/Combinator/Post.hs +34/−0
src/Control/Search/Combinator/Print.hs +34/−0
src/Control/Search/Combinator/Repeat.hs +84/−0
src/Control/Search/Combinator/Success.hs +38/−0
src/Control/Search/Combinator/Until.hs +188/−0
src/Control/Search/Constraints.hs +71/−0
src/Control/Search/Generator.hs +860/−0
src/Control/Search/GeneratorInfo.hs +120/−0
src/Control/Search/Language.hs +538/−0
src/Control/Search/Memo.hs +67/−0
src/Control/Search/MemoReader.hs +61/−0
src/Control/Search/SStateT.hs +47/−0
src/Control/Search/Stat.hs +186/−0
src/Data/Expr/Data.hs +297/−0
src/Data/Expr/Sugar.hs +285/−0
src/Data/Expr/Util.hs +481/−0
src/Data/Linear.hs +82/−0
src/Language/CPP/Pretty.hs +242/−0
src/Language/CPP/Syntax/AST.hs +174/−0

− Control/CP/ComposableTransformers.hs

@@ -1,312 +0,0 @@-{- - - 	Monadic Constraint Programming- - 	http://www.cs.kuleuven.be/~toms/Haskell/- - 	Tom Schrijvers- -}-{-# LANGUAGE GADTs #-}-{-# LANGUAGE Rank2Types #-}-{-# LANGUAGE TypeFamilies #-}-{-# LANGUAGE ImpredicativeTypes #-}-{-# LANGUAGE FlexibleContexts #-}--module Control.CP.ComposableTransformers (-  solve, restart,-  NewBound, -  Bound(..),-  Composition(..),-  CTransformer, -  CForSolver, -  CForResult, -  CTreeState, -  RestartST(..) , -  SealedCST(..), -  CNodeBoundedST(..), -  CDepthBoundedST(..),-  CBranchBoundST(..),-  CFirstSolutionST(..),-  CSolutionBoundST(..),-  CIdentityCST(..),-  CRandomST(..),-  CLimitedDiscrepancyST(..)-) where --import Control.CP.Transformers-import Control.CP.SearchTree-import Control.CP.Solver-import Control.CP.Queue-import Control.CP.Debug--import System.Random (mkStdGen, randoms)------------------------------------------------------------------------------------- EVALUATION-----------------------------------------------------------------------------------solve :: (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])-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-----------------------------------------------------------------------------------data TStack es ts (solver :: * -> *) a where-   TStack :: (CTransformer c, CForSolver c ~ solver, CForResult c ~ a) -          => c -> TStack (CEvalState c) (CTreeState c) solver a--instance Solver solver => Transformer (TStack es ts solver a) where-  type EvalState (TStack es ts solver a) = es-  type TreeState (TStack es ts solver a) = ts-  type ForSolver (TStack es ts solver a) = solver-  type ForResult (TStack es ts solver a) = a-  initT  (TStack c) _  = return $ initCT c-  leftT  (TStack c) _  = leftCT c-  rightT (TStack c) _  = rightCT c-  nextT = nextTStack -  returnT i wl t@(TStack c) es = returnCT c es (\es' -> continue i wl t es') (\es' -> endT i wl t es')--nextTStack :: -     (Solver solver, Queue q, Elem q ~ (Label solver,Tree solver a,ts))-     => Int -> Tree solver a -> q -> (TStack es ts solver a) -> es -> ts -> solver (Int,[a])-nextTStack i tree q t es ts =-    case t of-      TStack c ->-        nextCT tree c es ts (\tree' es' ts' -> eval' i tree' q t es' ts') -                            (\es'       -> continue i q t es')-			    (\es' -> endT i q t es')-----------------------------------------------------------------------------------type CSearchSig c a =-     (Solver (CForSolver c), CTransformer c) -     => Tree (CForSolver c) a -> c -> CEvalState c -> CTreeState c -> (EVAL c a) -> (CONTINUE c a) -> (EXIT c a) -> (CForSolver c) (Int,[a])--type CContinueSig c a =-     (Solver (CForSolver c), CTransformer c) -     => c -> CEvalState c -> (CONTINUE c a) -> (EXIT c a) -> (CForSolver c) (Int,[a])--type EVAL     c a = (Tree (CForSolver c) a -> CEvalState c -> CTreeState c-> (CForSolver c) (Int,[a]))-type CONTINUE c a = (CEvalState c -> (CForSolver c) (Int,[a]))-type EXIT     c a = (CEvalState c) -> (CForSolver c) (Int,[a]) --class Solver (CForSolver c) => CTransformer c where-  type CEvalState c :: *-  type CTreeState c :: *-  type CForSolver c :: (* -> *)-  type CForResult c :: *-  initCT :: c -> (CEvalState c, CTreeState c)-  leftCT, rightCT :: c -> CTreeState c -> CTreeState c-  leftCT  _  = id-  rightCT    = leftCT-  nextCT :: CSearchSig c (CForResult c)-  nextCT   = evalCT-  returnCT :: CContinueSig c (CForResult c) -  returnCT = continueCT-  completeCT :: c -> CEvalState c -> Bool-  completeCT _ _ = True--evalCT :: CSearchSig c a-evalCT tree c es ts eval continue exit =-  eval tree es ts--continueCT :: CContinueSig c a-continueCT c es continue exit =-  continue es--exitCT :: CContinueSig c a-exitCT c es continue exit =-  exit es--newtype CNodeBoundedST (solver :: * -> *) a = CNBST Int--instance Solver solver => CTransformer (CNodeBoundedST solver a) where-  type CEvalState (CNodeBoundedST solver a) = Int-  type CTreeState (CNodeBoundedST solver a) = ()-  type CForSolver (CNodeBoundedST solver a) = solver-  type CForResult (CNodeBoundedST solver a) = a-  initCT (CNBST n)  = (n,())  -  nextCT tree c es ts eval' continue exit-    | es == 0    = exit es-    | otherwise  = eval' tree (es - 1) ts--newtype CDepthBoundedST (solver :: * -> *) a = CDBST Int--instance Solver solver => CTransformer (CDepthBoundedST solver a) where-  type CEvalState (CDepthBoundedST solver a)  = Bool-  type CTreeState (CDepthBoundedST solver a)  = Int-  type CForSolver (CDepthBoundedST solver a)  = solver-  type CForResult (CDepthBoundedST solver a)  = a-  initCT (CDBST n)  = (True,n)-  leftCT _ ts      = ts - 1-  nextCT tree c es ts eval' continue exit-    | ts == 0    = continue False-    | otherwise  = eval' tree es ts-  completeCT _ es  = es--newtype CLimitedDiscrepancyST (solver :: * -> *) a = CLDST Int--instance Solver solver => CTransformer (CLimitedDiscrepancyST solver a) where-  type CEvalState (CLimitedDiscrepancyST solver a) = ()-  type CTreeState (CLimitedDiscrepancyST solver a) = Int-  type CForSolver (CLimitedDiscrepancyST solver a) = solver-  type CForResult (CLimitedDiscrepancyST solver a) = a-  initCT (CLDST n)  = ((),n)-  rightCT _ n  = n - 1-  nextCT tree c es ts eval' continue exit-    | ts == 0    = continue es-    | otherwise  = eval' tree es ts--newtype CRandomST (solver :: * -> *) a  = CRST Int--instance Solver solver => CTransformer (CRandomST solver a) where-  type CEvalState (CRandomST solver a) = [Bool]-  type CTreeState (CRandomST solver a) = ()-  type CForSolver (CRandomST solver a) = solver-  type CForResult (CRandomST solver a) = a-  initCT (CRST n)  = (randoms $ mkStdGen n,())-  nextCT tree@(Try l r) c (switch:es)-    | switch        = evalCT (Try r l) c es-    | otherwise     = evalCT tree      c es-  nextCT tree@(Add d (Try l r)) c (switch:es)-    | switch        = evalCT (Add d (Try r l)) c es-    | otherwise     = evalCT tree      c es-  nextCT tree c es  = evalCT tree      c es--data CIdentityCST (solver :: * -> *) a  = CIST--instance Solver solver => CTransformer (CIdentityCST solver a) where-  type CEvalState (CIdentityCST solver a)  = ()-  type CTreeState (CIdentityCST solver a)  = ()-  type CForSolver (CIdentityCST solver a)  = solver-  type CForResult (CIdentityCST solver a)  = a-  initCT _  = ((),())--data CFirstSolutionST (solver :: * -> *) a  = CFSST--instance Solver solver => CTransformer (CFirstSolutionST solver a) where-  type CEvalState (CFirstSolutionST solver a)  = Bool-  type CTreeState (CFirstSolutionST solver a)  = ()-  type CForSolver (CFirstSolutionST solver a)  = solver-  type CForResult (CFirstSolutionST solver a)  = a-  initCT _  = (True,())-  returnCT _ es continue exit =-    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,-           CForSolver c1 ~ solver, CForSolver c2 ~ solver,-           CForResult c1 ~ a,      CForResult c2 ~ a-          ) -       => c1 -> c2 -> Composition (CEvalState c1,CEvalState c2) (CTreeState c1,CTreeState c2) solver a--instance Solver solver => CTransformer (Composition es ts solver a) where-  type CEvalState (Composition es ts solver a) = es-  type CTreeState (Composition es ts solver a) = ts-  type CForSolver (Composition es ts solver a) = solver-  type CForResult (Composition es ts solver a) = a-  initCT (c1 :- c2)       = let (es1,ts1) = initCT c1 -                                (es2,ts2) = initCT c2 -                            in ((es1,es2),(ts1,ts2))-  leftCT (c1 :- c2) (ts1,ts2)   = (leftCT c1 ts1,leftCT c2 ts2)-  rightCT (c1 :- c2) (ts1,ts2)  = (rightCT c1 ts1,rightCT c2 ts2)-  nextCT tree (c1 :- c2) (es1,es2) (ts1,ts2) eval' continue exit  =-    nextCT tree c1 es1 ts1 -           (\tree' es1' ts1' -> nextCT tree' c2 es2 ts2 -                                   (\tree'' es2' ts2' -> eval' tree'' (es1',es2') (ts1',ts2'))-                                   (\es2' -> continue (es1',es2'))-				   (\es2' -> exit (es1',es2')) ) -           (\es1' -> continue (es1',es2))-           (\es1' -> exit (es1',es2))-  returnCT (c1 :- c2) (es1,es2) continue exit =-    returnCT c1 es1 (\es1' -> returnCT c2 es2 (\es2' -> continue (es1',es2')) (\es2' -> exit (es1',es2'))) -		    (\es1' -> exit (es1',es2))-  completeCT (c1 :- c2) (es1,es2)  = completeCT c1 es1 && completeCT c2 es2------------------------------------------------------------------------------------- BRANCH & BOUND-----------------------------------------------------------------------------------newtype CBranchBoundST (solver :: * -> *) a = CBBST (NewBound solver)-data    BBEvalState solver  = BBP Int (Bound solver)--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-  type CEvalState (CBranchBoundST solver a) = BBEvalState solver-  type CTreeState (CBranchBoundST solver a) = Int-  type CForSolver (CBranchBoundST solver a) = solver-  type CForResult (CBranchBoundST solver a) = a-  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' <- newBound-       continue $ BBP (v + 1) bound' ------------------------------------------------------------------------------------- RESTARTING-----------------------------------------------------------------------------------data SealedCST es ts solver a where-  Seal :: CTransformer c => c -> SealedCST (CEvalState c) (CTreeState c) (CForSolver c) (CForResult c)--instance Solver solver => CTransformer (SealedCST es ts solver a) where-  type CEvalState (SealedCST es ts solver a) = es-  type CTreeState (SealedCST es ts solver a) = ts-  type CForSolver (SealedCST es ts solver a) = solver-  type CForResult (SealedCST es ts solver a) = a-  leftCT (Seal c) 	= leftCT c-  rightCT (Seal c)	= rightCT c-  initCT (Seal c)       = initCT c-  nextCT tree (Seal c)  = nextCT tree c-  returnCT (Seal c)     = returnCT c-  completeCT (Seal c)   = completeCT c--data RestartST es ts (solver :: * -> *) a = RestartST [SealedCST es ts solver a] (Tree solver a -> solver (Tree solver a))--instance Solver solver => Transformer (RestartST es ts solver a) where-  type EvalState (RestartST es ts solver a) = (SealedCST es ts solver a,[SealedCST es ts solver a],es,Label solver,Tree solver a)-  type TreeState (RestartST es ts solver a) = ts-  type ForSolver (RestartST es ts solver a) = solver-  type ForResult (RestartST es ts solver a) = a-  initT  (RestartST (c:cs) _) tree  = - 	let (es,ts) = initCT c-        in do l <-  mark-	      return ((c,cs,es,l,tree),ts)-  leftT  _ (c,_,_,_,_)      = leftCT c-  rightT _ (c,_,_,_,_)      = rightCT c-  nextT i tree q t es@(c,cs,es_c,l,tree0) ts = -        nextCT tree c es_c ts (\tree' es_c' ts' -> eval' i tree' q t (c,cs,es_c',l,tree0) ts') -                              (\es_c'       -> continue i q t (c,cs,es_c',l,tree0))-			      (\es_c' -> endT i q t (c,cs,es_c',l,tree0))-  returnT i wl t es@(c,cs,es_c,l,tree0)  = returnCT c es_c (\es_c' -> continue i wl t (c,cs,es_c',l,tree0)) (\es_c' -> endT i wl t (c,cs,es_c',l,tree0))-  endT i wl t es@(_,[],_,_,_)      = return (i,[])-  endT i wl t@(RestartST _ f) es@(c0,(c:cs),es_c0,l,tree0)   -    | completeCT c0 es_c0  = return (i,[])-    | otherwise            = let (es,ts) = initCT c-                             in  do tree' <- f tree0-                                    continue i (pushQ (l,tree',ts) $ emptyQ wl) t (c,cs,es,l,tree0)-

− Control/CP/Debug.hs

@@ -1,22 +0,0 @@-{-# LANGUAGE CPP #-}--module Control.CP.Debug (-  debug,-  imdebug-) where--import Debug.Trace--debug :: String -> a -> a-imdebug :: Show a => String -> a -> a--{-# INLINE debug #-}-{-# INLINE imdebug #-}--#ifdef DEBUG-debug = trace-imdebug s a = trace ("imdebug " ++ s ++ ": " ++ (show a)) a-#else-debug = flip const-imdebug = flip const-#endif

− Control/CP/EnumTerm.hs

@@ -1,113 +0,0 @@-{-# LANGUAGE TypeFamilies #-}-{-# LANGUAGE TransformListComp #-}-{-# LANGUAGE MultiParamTypeClasses #-}-{-# LANGUAGE FlexibleContexts #-}--module Control.CP.EnumTerm (-  EnumTerm(..),-  assignment, assignments,-  inOrder, firstFail, middleOut, endsOut,-  labelling, levelList, enumerate-) where--import GHC.Exts (sortWith)--import Control.CP.Solver-import Control.CP.SearchTree--class (Solver s, Term s t, Show (TermBaseType s t)) => EnumTerm s t where-  type TermBaseType s t :: *--  getDomainSize :: t -> s (Int)-  getDomain :: t -> s [TermBaseType s t]-  setValue :: t -> TermBaseType s t -> s [Constraint s]-  splitDomain :: t -> s ([[Constraint s]],Bool)-  splitDomains :: [t] -> s ([[Constraint s]],[t])-  getValue :: t -> s (Maybe (TermBaseType s t))-  defaultOrder :: [t] -> s [t]-  enumerator :: (MonadTree m, TreeSolver m ~ s) => Maybe ([t] -> m ())--  getDomainSize x = do-    r <- getDomain x-    return $ length r--  getValue x = do-    d <- getDomain x-    return $ case d of-      [v] -> Just v-      _ -> Nothing-  splitDomain x = do-    d <- getDomain x-    case d of-      [] ->  return ([],True)-      [_] -> return ([[]],True)-      _ ->   do-        rr <- mapM (setValue x) d-        return (rr,True)--  splitDomains [] = return ([[]],[])-  splitDomains (a@(x:b)) = do-    s <- getDomainSize x-    if s==0-      then return ([],[])-      else if s==1 -        then splitDomains b-        else do-          (r,v) <- splitDomain x-          if v-            then return (r,b)-            else return (r,a)--  defaultOrder = firstFail-  enumerator = Nothing--enumerate :: (MonadTree m, TreeSolver m ~ s, EnumTerm s t) => [t] -> m ()-enumerate = case enumerator of-  Nothing -> labelling defaultOrder-  Just x -> x--assignment :: (EnumTerm s t, MonadTree m, TreeSolver m ~ s) => t -> m (TermBaseType s t)-assignment q = label $ getValue q >>= \y -> (case y of Just x -> return $ return x; _ -> return false)--assignments :: (EnumTerm s t, MonadTree m, TreeSolver m ~ s) => [t] -> m [TermBaseType s t]-assignments = mapM assignment--firstFail :: EnumTerm s t => [t] -> s [t]-firstFail qs = do ds <- mapM getDomainSize qs -                  return [ q | (d,q) <- zip ds qs -                             , then sortWith by d ]--inOrder :: EnumTerm s t => [t] -> s [t]-inOrder = return--middleOut :: EnumTerm s t => [t] -> s [t]-middleOut l = let n = (length l) `div` 2 in-              return $ interleave (drop n l) (reverse $ take n l)--endsOut :: EnumTerm s t => [t] -> s [t]-endsOut  l = let n = (length l) `div` 2 in-             return $ interleave (reverse $ drop n l) (take n l)--interleave []     ys = ys-interleave (x:xs) ys = x:interleave ys xs--levelList :: (Solver s, MonadTree m, TreeSolver m ~ s) => [m ()] -> m ()-levelList [] = false-levelList [a] = a-levelList l = -  let len = length l-      (p1,p2) = splitAt (len `div` 2) l-      in (levelList p1) \/ (levelList p2)---levelList [] = false---levelList [a] = a---levelList (a:b) = a \/ levelList b--labelling :: (MonadTree m, TreeSolver m ~ s, EnumTerm s t) => ([t] -> s [t]) -> [t] -> m ()-labelling _ [] = true-labelling o l = label $ do -  ll <- o l-  (cl,c) <- splitDomains ll-  let ml = map (\l -> foldr (/\) true $ map addC l) cl-  return $ do-    levelList ml-    labelling return c

− Control/CP/FD/Decompose.hs

@@ -1,698 +0,0 @@-{- - - 	Monadic Constraint Programming- - 	http://www.cs.kuleuven.be/~toms/MCP/- - 	Pieter Wuille- -}--{-# LANGUAGE GeneralizedNewtypeDeriving #-}--module Control.CP.FD.Decompose (-  DecompData,-  baseDecompData,-  decompose,-  decomposeEx,-  decompBoolLookup,-  decompIntLookup,-  decompColLookup,-) where--import Data.Map (Map)-import qualified Data.Map as Map--import Data.Set (Set)-import qualified Data.Set as Set--import Control.Monad.State.Lazy hiding (state)--import Control.CP.Debug-import Data.Expr.Data-import Data.Expr.Util-import Control.CP.FD.Graph-import Control.CP.FD.Model--data DecompData = DecompData {-  -- expressions currently accessible as variables-  cseMapBool :: Map ModelBool EGVarId,-  cseMapInt :: Map ModelInt EGVarId,-  cseMapCol :: Map ModelCol EGVarId,-  -- parent graph's data-  cseParent :: Maybe DecompData,-  -- expressions imported from parent graph-  cseImports :: ([ModelBool],[ModelInt],[ModelCol]),-  -- counter for unique id's-  cseNIds :: Int,-  -- locked nodes (already shown to the caller, and cannot be unified/replaced anymore)-  cseLocked :: EGTypeData (Set EGVarId),-  -- level of nesting-  cseLevel :: Int-}--decompBoolLookup :: DecompData -> ModelBool -> Maybe EGVarId-decompBoolLookup d v = Map.lookup v $ cseMapBool d--decompIntLookup :: DecompData -> ModelInt -> Maybe EGVarId-decompIntLookup d v = Map.lookup v $ cseMapInt d--decompColLookup :: DecompData -> ModelCol -> Maybe EGVarId-decompColLookup d v = Map.lookup v $ cseMapCol d---- | base instance of DecompData-baseDecompData :: DecompData-baseDecompData = DecompData {-  cseMapBool = Map.empty,-  cseMapInt = Map.empty,-  cseMapCol = Map.empty,-  cseParent = Nothing,-  cseImports = ([],[],[]),-  cseNIds = 0,-  cseLevel = 0,-  cseLocked = baseTypeData (Set.empty)-}---- | the state for the DCMonad-data DCState = DCState {-  dcsData :: DecompData,-  dcsModel :: EGModel-}---- | base state for the DCMonad-baseDCState = DCState {-  dcsData = baseDecompData,-  dcsModel = baseGraph-}---- | definition of a decomposer monad-newtype DCMonad a = DCMonad { state :: State DCState a }-  deriving (Monad, MonadState DCState)---- | transform an expression into a graph, taking and returning an updated state-decomposeEx :: DecompData -> Int -> Model -> ([ModelBool],[ModelInt],[ModelCol]) -> Maybe EGModel -> (DecompData,EGModel,Int)-decomposeEx dat vars model (lb,li,lc) prev = -  let prog = do-        s1 <- get-        put $ s1 { dcsData = (dcsData s1) { cseNIds = max vars (cseNIds $ dcsData s1) } }-        decomposeBoolEx (Just True) model-        mapM_ decomposeBool lb-        mapM_ decomposeInt li-        mapM_ decomposeCol lc-        s2 <- get-        put $ s2 { dcsData = (dcsData s2) { cseLocked = egTypeDataMap (\f -> Set.fromList $ Map.keys $ f $ egmLinks $ dcsModel s2) } }-      pmodel = case prev of-        Nothing -> baseGraph-        Just x -> x-      res = execState (state prog) $ DCState { dcsData = dat, dcsModel = pmodel }-      in (dcsData res,dcsModel res,cseNIds $ dcsData res)---- | easier version of decomposeEx that does not require or return a state-decompose :: Model -> EGModel-decompose x = (\(_,x,_) -> x) $ decomposeEx baseDecompData 0 x ([],[],[]) Nothing---- | decomposition states can be stacked, this function tests whether a property hold--- for a state or any of its parents-stateProperty :: (DecompData -> Bool) -> DecompData -> Bool-stateProperty f s = if f s then True else case (cseParent s) of-  Just p -> stateProperty f p-  _ -> False--newVar :: EGVarType -> DCMonad EGVarId-newVar typ = do-  s <- get-  let (nv,nm) = addNode typ (dcsModel s)-  put $ s { dcsModel = nm }-  return nv--importBool :: Maybe Bool -> ModelBool -> DCMonad EGVarId-importBool val expr = do-  n <- newBoolVar val expr-  s <- get-  if cseLevel (dcsData s) == 0-    then error $ "Boolean expression (value="++(show val)++") escapes: " ++ (show expr)-    else do-      let ni = length $ (\(x,_,_)->x) $ cseImports $ dcsData s-      put $ s { dcsData = (dcsData s) { cseImports = (\(a,b,c) -> (a++[expr],b,c)) (cseImports $ dcsData s) } }-      addConstraint (EGBoolExtern ni) ([n],[],[])-      return n--importInt :: ModelInt -> DCMonad EGVarId-importInt expr = do-  n <- newIntVar expr-  s <- get-  if cseLevel (dcsData s) == 0-    then error $ "Integer expression escapes: " ++ (show expr)-    else do-      let ni = length $ (\(_,x,_)->x) $ cseImports $ dcsData s-      put $ s { dcsData = (dcsData s) { cseImports = (\(a,b,c) -> (a,b++[expr],c)) (cseImports $ dcsData s) } }-      addConstraint (EGIntExtern ni) ([],[n],[])-      return n--importCol :: ModelCol -> DCMonad EGVarId-importCol expr = do-  n <- newColVar expr-  s <- get-  if cseLevel (dcsData s) == 0-    then error $ "Collection expression escapes: " ++ (show expr)-    else do-      let ni = length $ (\(_,_,x)->x) $ cseImports $ dcsData s-      put $ s { dcsData = (dcsData s) { cseImports = (\(a,b,c) -> (a,b,c++[expr])) (cseImports $ dcsData s) } }-      addConstraint (EGColExtern ni) ([],[],[n])-      return n--unifyVars :: EGVarType -> EGVarId -> EGVarId -> DCMonad Bool-unifyVars typ v1 v2 = do-  s <- get-  let rm = egTypeGet typ $ cseLocked $ dcsData s-      i1 = Set.member v1 rm-      i2 = Set.member v2 rm-  if (i1 && i2)-    then return False  -- if both nodes are locked, unification is not possible-    else if i1-      then unifyVars typ v2 v1 -- if only i1 is locked, unify v2 with v1 instead of v1 with v2-      else do -- otherwise, really unify-        let nm = unifyNodes typ v1 v2 (dcsModel s)-        case typ of-          EGBoolType -> put $ s { dcsModel = nm, dcsData = (dcsData s) { cseMapBool = Map.map tran $ cseMapBool $ dcsData s } }-          EGIntType  -> put $ s { dcsModel = nm, dcsData = (dcsData s) { cseMapInt = Map.map tran $ cseMapInt $ dcsData s } }-          EGColType  -> put $ s { dcsModel = nm, dcsData = (dcsData s) { cseMapCol = Map.map tran $ cseMapCol $ dcsData s } }-        return True-  where tran = unifyIds v1 v2--addConstraint :: EGConstraintSpec -> ([EGVarId],[EGVarId],[EGVarId]) -> DCMonad ()-addConstraint spec (lb,li,lc) = do-  s <- get-  let nm = addEdge spec (EGTypeData { boolData=lb, intData=li, colData=lc }) (dcsModel s)-  put $ s { dcsModel = nm }--newBoolVar :: Maybe Bool -> ModelBool -> DCMonad EGVarId-newBoolVar val expr = do-  n <- case val of-    Nothing -> newVar EGBoolType-    Just x -> decomposeBool $ BoolConst x-  s <- get-  let nc = Map.insert expr n (cseMapBool $ dcsData s)-  put $ s { dcsData = (dcsData s) { cseMapBool = nc } }-  return n--newIntVar :: ModelInt -> DCMonad EGVarId-newIntVar expr = do-  n <- newVar EGIntType-  s <- get-  let nc = Map.insert expr n (cseMapInt $ dcsData s)-  put $ s { dcsData = (dcsData s) { cseMapInt = nc } }-  return n--newColVar :: ModelCol -> DCMonad EGVarId-newColVar expr = do-  n <- newVar EGColType-  s <- get-  let nc = Map.insert expr n (cseMapCol $ dcsData s)-  put $ s { dcsData = (dcsData s) { cseMapCol = nc } }-  return n--decomposeSubmodel :: (Int,Int,Int) -> (([ModelBool],[ModelInt],[ModelCol]) -> DCMonad ()) -> DCMonad (EGModel,([EGVarId],[EGVarId],[EGVarId]))-decomposeSubmodel (nArgsBool,nArgsInt,nArgsCol) m = do-  oArgsBool <- mapM (const $ nextId >>= (\x -> return $ BoolTerm $ ModelBoolVar $ x)) [1..nArgsBool]-  oArgsInt  <- mapM (const $ nextId >>= (\x -> return $ Term     $ ModelIntVar  $ x)) [1..nArgsInt]-  oArgsCol  <- mapM (const $ nextId >>= (\x -> return $ ColTerm  $ ModelColVar  $ x)) [1..nArgsCol]-  s <- get-  let sm = m (oArgsBool,oArgsInt,oArgsCol)-      ns = execState (state sm) $ baseDCState { dcsData = (dcsData baseDCState) { cseLevel = 1 + (cseLevel $ dcsData s), cseNIds = 0+(cseNIds $ dcsData s), cseParent = Just $ dcsData s } }-  put $ s { dcsData = (dcsData s) { cseNIds = 0+(cseNIds $ dcsData ns) } }-  argsBool <- mapM decomposeBool $ (\(x,_,_) -> x) $ cseImports $ dcsData ns-  argsInt <-  mapM decomposeInt  $ (\(_,x,_) -> x) $ cseImports $ dcsData ns-  argsCol <-  mapM decomposeCol  $ (\(_,_,x) -> x) $ cseImports $ dcsData ns-  return (dcsModel ns, (argsBool,argsInt,argsCol))--constIntTrans :: ModelIntTerm ModelFunctions -> EGParTerm-constIntTrans (ModelIntPar x) = EGPTParam x-constIntTrans x = error $ "non-constant int transform: "++(show x)-constColTrans :: ModelColTerm ModelFunctions -> EGParColTerm-constColTrans (ModelColPar x) = EGPTColParam x-constColTrans x = error $ "non-constant col transform: "++(show x)-constBoolTrans :: ModelBoolTerm ModelFunctions -> EGParBoolTerm-constBoolTrans (ModelBoolPar x) = EGPTBoolParam x-constBoolTrans x = error $ "non-constant bool transform: "++(show x)-constIntTransInv :: EGParTerm -> ModelIntTerm ModelFunctions-constIntTransInv (EGPTParam x) = ModelIntPar x-constColTransInv :: EGParColTerm -> ModelColTerm ModelFunctions-constColTransInv (EGPTColParam x) = ModelColPar x-constBoolTransInv :: EGParBoolTerm -> ModelBoolTerm ModelFunctions-constBoolTransInv (EGPTBoolParam x) = ModelBoolPar x--constTrans = (constIntTrans,constColTrans,constBoolTrans,constIntTransInv,constColTransInv,constBoolTransInv)-invConstTrans = (constIntTransInv,constColTransInv,constBoolTransInv,constIntTrans,constColTrans,constBoolTrans)--dependenceTester d = -  (-    \x -> if Map.member x (cseMapInt d) && not (x `elem` ((\(_,x,_) -> x) $ cseImports d)) then Just True else Nothing,-    \x -> if Map.member x (cseMapCol d) && not (x `elem` ((\(_,_,x) -> x) $ cseImports d)) then Just True else Nothing,-    \x -> case x of-      BoolTerm (ModelExtra _) -> Just True-      _ -> if Map.member x (cseMapBool d) && not (x `elem` ((\(x,_,_) -> x) $ cseImports d)) then Just True else Nothing-  )--dependentIntExpr :: DecompData -> ModelInt -> Bool-dependentIntExpr d = propertyEx $ dependenceTester d-dependentBoolExpr :: DecompData -> ModelBool -> Bool-dependentBoolExpr d = boolPropertyEx $ dependenceTester d-dependentColExpr :: DecompData -> ModelCol -> Bool-dependentColExpr d = colPropertyEx $ dependenceTester d--nextId :: DCMonad Int-nextId = do-  s <- get-  let n = cseNIds $ dcsData s-  put $ s { dcsData = (dcsData s) { cseNIds = n + 1 } }-  return n---------------------------------------------- | Decomposition of special values | ----------------------------------------------decomposeBool :: ModelBool -> DCMonad EGVarId-decomposeBool expr = do-  (Just x) <- decomposeBoolEx Nothing expr-  return x--decomposeBoolEx :: Maybe Bool -> ModelBool -> DCMonad (Maybe EGVarId)-decomposeBoolEx val expr = do-  s <- get-  debug ("decomposeBoolEx [level "++(show $ cseLevel $ dcsData s)++"] val="++(show val)++" expr="++(show expr)) $ return ()-  let key = expr-  case Map.lookup key (cseMapBool $ dcsData s) of    -- local variable or already locally decomposed expression-    Just i -> do-      debug ("decomposeBoolEx [level "++(show $ cseLevel $ dcsData s)++"] val="++(show val)++" expr="++(show expr)++": already decomposed: "++(show i)) $ return ()-      return $ Just i-    Nothing -> if (modelVariantBool expr)-      then do-        if (stateProperty (Map.member key . cseMapBool) $ dcsData s) && not (dependentBoolExpr (dcsData s) expr) && (cseLevel $ dcsData s) > 0-          then do   -- Loop Invariant Code Motion-            debug ("decomposeBoolEx: [level "++(show $ cseLevel $ dcsData s)++"] [variant indep] "++(show expr)) $ return ()-            n <- importBool val expr-            return $ Just n-          else do-            debug ("decomposeBoolEx: [level "++(show $ cseLevel $ dcsData s)++"] [variant dep] "++(show expr)) $ return ()-            realDecomposeBoolEx val expr-        else do-          debug ("decomposeBoolEx: [level "++(show $ cseLevel $ dcsData s)++"] [invariant] "++(show expr)) $ return ()-          n <- newBoolVar val expr-          let tr = boolTransform constTrans expr-          addConstraint (EGBoolValue tr) ([n],[],[])-          return $ Just n--decomposeInt :: ModelInt -> DCMonad EGVarId-decomposeInt expr = do-  s <- get-  debug ("decomposeInt [level "++(show $ cseLevel $ dcsData s)++"] expr="++(show expr)) $ return ()-  let key = expr-  case Map.lookup key (cseMapInt $ dcsData s) of-    Just i -> return i-    Nothing -> if (modelVariantInt expr)-      then if (stateProperty (Map.member key . cseMapInt) $ dcsData s) && not (dependentIntExpr (dcsData s) expr) && (cseLevel $ dcsData s) > 0-        then do-          debug ("decomposeInt: [level "++(show $ cseLevel $ dcsData s)++"] [variant indep] "++(show expr)) $ return ()-          importInt expr-        else do-          debug ("decomposeInt: [level "++(show $ cseLevel $ dcsData s)++"] [variant dep] "++(show expr)) $ return ()-          realDecomposeInt expr-      else do-        debug ("decomposeInt: [level "++(show $ cseLevel $ dcsData s)++"] [invariant] "++(show expr)) $ return ()-        n <- newIntVar expr-        let tr = transform constTrans expr-        addConstraint (EGIntValue tr) ([],[n],[])-        return n--decomposeCol :: ModelCol -> DCMonad EGVarId-decomposeCol expr = do-  s <- get-  debug ("decomposeCol [level "++(show $ cseLevel $ dcsData s)++"] expr="++(show expr)) $ return ()-  let key = expr-  case Map.lookup key (cseMapCol $ dcsData s) of-    Just i -> return i-    Nothing -> if (modelVariantCol expr)-      then if (stateProperty (Map.member key . cseMapCol) $ dcsData s) && not (dependentColExpr (dcsData s) expr) && (cseLevel $ dcsData s) > 0-        then do-          debug ("decomposeCol: [level "++(show $ cseLevel $ dcsData s)++"] [variant indep] "++(show expr)) $ return ()-          importCol expr-        else do -          debug ("decomposeCol: [level "++(show $ cseLevel $ dcsData s)++"] [variant dep] "++(show expr)) $ return ()-          realDecomposeCol expr-      else do-        debug ("decomposeCol: [level "++(show $ cseLevel $ dcsData s)++"] [invariant] "++(show expr)) $ return ()-        n <- newColVar expr-        let tr = colTransform constTrans expr-        addConstraint (EGColValue tr) ([],[],[n])-        return n------------------------------------------------ | Real decomposers for expressions | -----------------------------------------------realDecomposeBoolEx :: Maybe Bool -> ModelBool -> DCMonad (Maybe EGVarId)-realDecomposeBoolEx val expr = case expr of-  BoolTerm (ModelExtra (ForNewBool f)) -> do-    n <- nextId-    let v = BoolTerm $ ModelBoolVar n-    newBoolVar Nothing v-    decomposeBoolEx val $ f v-  BoolTerm (ModelExtra (ForNewInt f)) -> do-    n <- nextId-    let v = Term $ ModelIntVar n-    newIntVar v-    decomposeBoolEx val $ f v-  BoolTerm (ModelExtra (ForNewCol f)) -> do-    n <- nextId-    let v = ColTerm $ ModelColVar n-    newColVar v-    decomposeBoolEx val $ f v-  BoolTerm (ModelBoolVar i) -> do-    n <- newBoolVar val expr-    return $ Just n-  BoolCond c t f -> case val of-    Just True -> do-      dc <- decomposeBool c-      di <- decomposeBool $ boolSimplify $ BoolNot c-      ct <- decomposeBool (BoolConst True)-      if (t /= BoolConst True) -        then do-          dt <- decomposeBool t-          addConstraint EGCondEqual ([dc,dt,ct],[],[])-        else return ()-      if (f /= BoolConst True)-        then do-          df <- decomposeBool f-          addConstraint EGCondEqual ([di,df,ct],[],[])-        else return ()-      return Nothing-    _ -> error "No reified boolean conditional exists"-  BoolAnd a b -> case val of-    Just True -> do-      decomposeBoolEx val a-      decomposeBoolEx val b-      return Nothing-    _ -> do-      n <- newBoolVar val expr-      ad <- decomposeBool a-      bd <- decomposeBool b-      addConstraint EGAnd ([n,ad,bd],[],[])-      return $ Just n-  BoolOr a b -> case val of-    Just False -> do-      decomposeBoolEx val a-      decomposeBoolEx val b-      return Nothing-    _ -> do-      n <- newBoolVar val expr-      ad <- decomposeBool a-      bd <- decomposeBool b-      addConstraint EGOr ([n,ad,bd],[],[])-      return $ Just n-  BoolNot a -> case val of-    Just True -> do-      decomposeBoolEx (Just False) a-      return Nothing-    Just False -> do-      decomposeBoolEx (Just True) a-      return Nothing-    _ -> do-      n <- newBoolVar val expr-      ad <- decomposeBool a-      addConstraint EGNot ([n,ad],[],[])-      return $ Just n-  Rel a r b -> case (r,val) of-    (EREqual,Just True) -> do-      ad <- decomposeInt a-      bd <- decomposeInt b-      res <- unifyVars EGIntType ad bd-      if res-        then return Nothing-        else do-          n <- decomposeBool (BoolConst True)-          addConstraint EGEqual ([n],[ad,bd],[])-          return Nothing-    (ERDiff,Just False) -> do-      ad <- decomposeInt a -      bd <- decomposeInt b-      res <- unifyVars EGIntType ad bd-      if res-        then return Nothing-        else do-          n <- decomposeBool (BoolConst True)-          addConstraint EGEqual ([n],[ad,bd],[])-          return Nothing-    _ -> do-      n <- newBoolVar val expr-      ad <- decomposeInt a-      bd <- decomposeInt b-      addConstraint (case r of-          EREqual -> EGEqual-          ERDiff -> EGDiff-          ERLess -> EGLess True-        ) ([n],[ad,bd],[])-      return $ Just n-  ColEqual a b -> case val of-    Just True -> do-      ad <- decomposeCol a-      bd <- decomposeCol b-      res <- unifyVars EGColType ad bd-      if not res-        then error "unification of collections failed"-        else return Nothing-    _ -> error "No negated or reified version of ColEqual exists"-  AllDiff b c -> case val of-    Just True -> do-      ac <- decomposeCol c-      addConstraint (EGAllDiff b) ([],[],[ac])-      return Nothing-    _ -> error "No negated or reified version of AllDiff exists"-  Sorted b c -> case val of-    Just True -> do-      ac <- decomposeCol c-      addConstraint (EGSorted b) ([],[],[ac])-      return Nothing-    _ -> error "No negated or reified version of Sorted exists"-  Dom i c -> case val of-    Just True -> do-      ac <- decomposeCol c-      ai <- decomposeInt i-      addConstraint EGDom ([],[ai],[ac])-      return Nothing-    _ -> error "No negated or reified version of Dom exists"-  BoolEqual a b -> case val of-    Just True -> do-      ad <- decomposeBool a-      bd <- decomposeBool b-      res <- unifyVars EGBoolType ad bd-      if res-        then return Nothing-        else do-          n <- decomposeBool (BoolConst True)-          addConstraint EGEquiv ([n,ad,bd],[],[])-          return Nothing-    _ -> do-      n <- newBoolVar val expr-      ad <- decomposeBool a-      bd <- decomposeBool b-      addConstraint EGEquiv ([n,ad,bd],[],[])-      return $ Just n---  BoolAll f (ColRange l h) -> do---    ld <- decomposeInt l---    hd <- decomposeInt h---    n <- newBoolVar val expr---    (smod,(argsBool,argsInt,argsCol)) <- decomposeSubmodel (0,1,0) $ \([],[oarg],[]) -> do---      let sexpr = f oarg---      arg <- newIntVar oarg---      debug ("BoolAllC: arg="++(show arg)++" oarg="++(show oarg)) $ return ()---      addConstraint (EGIntExtern $ -1) ([],[arg],[])---      case val of---        Just True -> do---          decomposeBoolEx (Just True) sexpr---          return ()---        _ -> do---          res <- decomposeBool sexpr---          addConstraint (EGBoolExtern $ -1) ([res],[],[])---    let force = case val of---                Just True -> True---                _ -> False---    addConstraint (EGAllC smod (length argsBool,length argsInt,length argsCol) force) ([n]++argsBool,[ld,hd]++argsInt,argsCol)---    return $ Just n---  BoolAny f (ColRange l h) -> do---    ld <- decomposeInt l---    hd <- decomposeInt h---    n <- newBoolVar val expr---    (smod,(argsBool,argsInt,argsCol)) <- decomposeSubmodel (0,1,0) $ \([],[oarg],[]) -> do---      let sexpr = f oarg---      arg <- newIntVar oarg---      addConstraint (EGIntExtern $ -1) ([],[arg],[])---      case val of---        Just False -> do---          decomposeBoolEx (Just False) sexpr---          return ()---        _ -> do---          res <- decomposeBool sexpr---          addConstraint (EGBoolExtern $ -1) ([res],[],[])---    let force = case val of---                Just False -> True---                _ -> False---    addConstraint (EGAnyC smod (length argsBool,length argsInt,length argsCol) force) ([n]++argsBool,[ld,hd]++argsInt,argsCol)---    return $ Just n-  BoolAll f c -> do-    cd <- decomposeCol c-    n <- newBoolVar val expr-    (smod,(argsBool,argsInt,argsCol)) <- decomposeSubmodel (0,1,0) $ \([],[oarg],[]) -> do-      let sexpr = f oarg-      arg <- newIntVar oarg-      addConstraint (EGIntExtern $ -1) ([],[arg],[])-      case val of-        Just True -> do   {- in case a BoolAll itself must hold, each submodel must hold too -}-          decomposeBoolEx (Just True) sexpr-          return ()-        _ -> do-          res <- decomposeBool sexpr-          addConstraint (EGBoolExtern $ -1) ([res],[],[])-    let force = -          case val of-            Just True -> True-            _ -> False-    addConstraint (EGAll smod (length argsBool,length argsInt,length argsCol) force) ([n] ++ argsBool,argsInt,[cd] ++ argsCol)-    return $ Just n-  BoolAny f c -> do-    cd <- decomposeCol c-    n <- newBoolVar val expr-    (smod,(argsBool,argsInt,argsCol)) <- decomposeSubmodel (0,1,0) $ \([],[oarg],[]) -> do-      let sexpr = f oarg-      arg <- newIntVar oarg-      addConstraint (EGIntExtern $ -1) ([],[arg],[])-      case val of-        Just False -> do   {- in case a BoolAny itself may not hold, each submodel may not hold either -}-          decomposeBoolEx (Just False) sexpr-          return ()-        _ -> do-          res <- decomposeBool sexpr-          addConstraint (EGBoolExtern $ -1) ([res],[],[])-    let force = -          case val of-            Just False -> True-            _ -> False-    addConstraint ((if force then EGAll else EGAny) smod (length argsBool,length argsInt,length argsCol) force) ([n] ++ argsBool,argsInt,[cd] ++ argsCol)-    return $ Just n-  _ -> error $ "Unable to decompose boolean expression: " ++ (show expr) ++ "(== " ++ (show val) ++ ")"--realDecomposeInt :: ModelInt -> DCMonad EGVarId-realDecomposeInt expr = do-  let pIntOp a x b = do-        n <- newIntVar expr-        ad <- decomposeInt a-        bd <- decomposeInt b-        addConstraint x ([],[n,ad,bd],[])-        return n-  case expr of-    Term (ModelIntVar i) -> newIntVar expr-    Plus a b -> pIntOp a EGPlus b-    Minus a b -> pIntOp a EGMinus b-    Mult a b -> pIntOp a EGMult b-    Div a b -> pIntOp a EGDiv b-    Mod a b -> pIntOp a EGMod b-    Abs a -> do-      n <- newIntVar expr-      ad <- decomposeInt a-      addConstraint EGAbs ([],[n,ad],[])-      return n-    At a b -> do-      n <- newIntVar expr-      ad <- decomposeCol a-      bd <- decomposeInt b-      addConstraint EGAt ([],[n,bd],[ad])-      return n-    ColSize a -> do-      n <- newIntVar expr-      ad <- decomposeCol a-      addConstraint EGSize ([],[n],[ad])-      return n-    Channel a -> do-      n <- newIntVar expr-      ad <- decomposeBool a-      addConstraint EGChannel ([ad],[n],[])-      return n-    Cond c t f -> do-      n <- newIntVar expr-      cd <- decomposeBool c-      td <- decomposeInt t-      fd <- decomposeInt f-      addConstraint EGCondInt ([cd],[n,td,fd],[])-      return n-    Fold f i c -> do-      cd <- decomposeCol c-      id <- decomposeInt i-      n <- newIntVar expr-      (smod,(argsBool,argsInt,argsCol)) <- decomposeSubmodel (0,2,0) $ \([],[oacc,oarg],[]) -> do-        let sexpr = f oacc oarg-        acc <- newIntVar oacc-        addConstraint (EGIntExtern $ -2) ([],[acc],[])-        arg <- newIntVar oarg-        addConstraint (EGIntExtern $ -3) ([],[arg],[])-        res <- decomposeInt sexpr-        addConstraint (EGIntExtern $ -1) ([],[res],[])-      addConstraint (EGFold smod (length argsBool,length argsInt,length argsCol)) (argsBool,[n,id]++argsInt,[cd]++argsCol)-      return n-    _ -> error $ "Unable to decompose expression: " ++ (show expr)--listAll :: [a] -> (a -> Maybe b) -> Maybe [b]-listAll [] _ = Just []-listAll (a:b) f = case f a of-  Nothing -> Nothing-  Just r -> case listAll b f of-    Nothing -> Nothing-    Just x -> Just (r:x)--realDecomposeCol :: ModelCol -> DCMonad EGVarId-realDecomposeCol expr = case expr of-  ColList l -> do-    n <- newColVar expr-    ld <- mapM decomposeInt l-    addConstraint (EGList (length l)) ([],ld,[n])-    return n-  ColTerm (ModelColVar i) -> newColVar expr-  ColRange a b -> do-    n <- newColVar expr-    ad <- decomposeInt a-    bd <- decomposeInt b-    addConstraint EGRange ([],[ad,bd],[n])-    return n-  ColCat a b -> do-    n <- newColVar expr-    ad <- decomposeCol a-    bd <- decomposeCol b-    addConstraint EGCat ([],[],[n,ad,bd])-    return n-{-  ColSlice f n c -> do-    nn <- newColVar expr-    cd <- decomposeCol c-    let fd x = debug ("ColSlice: f("++(show x)++")="++(show $ f $ transform invConstTrans x)) $ transform constTrans $ f $ transform invConstTrans x-    let nd = transform constTrans n-    addConstraint (EGSlice fd nd) ([],[],[nn,cd])-    return nn -}-  ColSlice f nn c -> do-    cd <- decomposeCol c-    nd <- decomposeInt nn-    n <- newColVar expr-    (smod,(argsBool,argsInt,argsCol)) <- decomposeSubmodel (0,1,0) $ \([],[oarg],[]) -> do-      let sexpr = f oarg-      arg <- newIntVar oarg-      addConstraint (EGIntExtern $ -2) ([],[arg],[])-      res <- decomposeInt sexpr-      addConstraint (EGIntExtern $ -1) ([],[res],[])-    addConstraint (EGSlice smod (length argsBool,length argsInt,length argsCol)) (argsBool,[nd]++argsInt,[n,cd]++argsCol)-    return n-  ColMap f c -> do-    cd <- decomposeCol c-    n <- newColVar expr-    (smod,(argsBool,argsInt,argsCol)) <- decomposeSubmodel (0,1,0) $ \([],[oarg],[]) -> do-      let sexpr = f oarg-      arg <- newIntVar oarg-      addConstraint (EGIntExtern $ -2) ([],[arg],[])-      res <- decomposeInt sexpr-      addConstraint (EGIntExtern $ -1) ([],[res],[])-    addConstraint (EGMap smod (length argsBool,length argsInt,length argsCol)) (argsBool,argsInt,[n,cd]++argsCol)-    return n-  _ -> error $ "Unable to decompose collection: " ++ (show expr)

− Control/CP/FD/Example.hs

@@ -1,109 +0,0 @@-{-# LANGUAGE RankNTypes #-}-{-# LANGUAGE TypeFamilies #-}-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE ScopedTypeVariables #-}--module Control.CP.FD.Example (-  example_main,-  example_sat_main,-  example_sat_main_void,-  example_sat_main_single,-  example_sat_main_single_expr,-  example_sat_main_coll_expr,-  example_min_main,-  example_min_main_void,-  example_min_main_single,-  example_min_main_single_expr,-  example_min_main_coll_expr,-  runSolve,-  labeller,-  postMinimize,-  ExampleModel, ExampleMinModel, -  module Control.CP.FD.Interface,-) where---import System.Environment (getArgs)-import Data.Maybe (fromJust,isJust)-import Data.Map (Map)-import qualified Data.Map as Map-import Data.List (init,last)--import Control.CP.FD.OvertonFD.OvertonFD-import Control.CP.FD.OvertonFD.Sugar-import Control.CP.FD.FD-import Control.CP.FD.Model--import Control.CP.Debug--import Control.CP.FD.Interface-import Control.CP.SearchTree-import Control.CP.EnumTerm-import Control.CP.ComposableTransformers-import Control.CP.FD.Solvers--import Control.Monad.Cont--type ExampleModel t =    (forall s m. (Show (FDIntTerm s), FDSolver s, MonadTree m, TreeSolver m ~ (FDInstance s)) => t -> m (ModelCol))-type ExampleMinModel t = (forall s m. (Show (FDIntTerm s), FDSolver s, MonadTree m, TreeSolver m ~ (FDInstance s)) => t -> m (ModelInt,ModelCol))--postMinimize :: ExampleMinModel t -> ExampleModel t-postMinimize m = \x -> do-  (min,res) <- m x-  debug ("postMinimize: min="++(show min)) $ return ()-  label $ do-    setMinimizeVar min-    return $ return res--runSolveSAT x = solve dfs fs x-runSolveMIN x = solve dfs (bb boundMinimize) x--runSolve False x = runSolveSAT x-runSolve True  x = runSolveMIN x--labeller col = do-  label $ do-    min <- getMinimizeVar-    case min of-      Nothing -> return $ labelCol col-      Just v -> return $ do-        enumerate [v]-        labelCol col--example_main :: ExampleModel [String] -> ExampleModel ModelInt -> ExampleModel ModelCol -> Bool -> IO ()-example_main f fx fcx typ = do-  args <- getArgs-  case args of-    ("overton_run":r) -> print $ runSolve typ $ ((f r) :: Tree (FDInstance OvertonFD) ModelCol) >>= labeller-    [] -> putStr "Solver type required: must be overton_run\n"-    (a:r) -> putStr ("Unsupported solver: " ++ a ++ "\n")--example_min_main :: ExampleMinModel [String] -> ExampleMinModel ModelInt -> ExampleMinModel ModelCol -> IO ()-example_min_main f fx fcx = example_main (postMinimize f) (postMinimize fx) (postMinimize fcx) True--example_sat_main :: ExampleModel [String] -> ExampleModel ModelInt -> ExampleModel ModelCol -> IO ()-example_sat_main f fx fcx = example_main f fx fcx False--example_sat_main_void :: ExampleModel () -> IO ()-example_sat_main_void f = example_sat_main (const $ f ()) (const $ f ()) (const $ f ())--example_min_main_void :: ExampleMinModel () -> IO ()-example_min_main_void f = example_min_main (const $ f ()) (const $ f ()) (const $ f ())--example_sat_main_single :: Read n => ExampleModel n -> IO ()-example_sat_main_single f = example_sat_main (f . read . head) (error "Uncompilable model") (error "Uncompilable model")--example_min_main_single :: Read n => ExampleMinModel n -> IO ()-example_min_main_single f = example_min_main (f . read . head) (error "Uncompilable model") (error "Uncompilable model")--example_sat_main_single_expr :: ExampleModel ModelInt -> IO ()-example_sat_main_single_expr f = example_sat_main (f . fromInteger . read . head) f (\x -> f $ x!(cte 0))--example_min_main_single_expr :: ExampleMinModel ModelInt -> IO ()-example_min_main_single_expr f = example_min_main (f . fromInteger . read . head) f (\x -> f $ x!(cte 0))--example_sat_main_coll_expr :: ExampleModel ModelCol -> IO ()-example_sat_main_coll_expr f = example_sat_main (f . list . foldr (++) [] . map (map fromInteger . read . (\x -> "[" ++ x ++ "]"))) (f. list . (\x -> [x])) f--example_min_main_coll_expr :: ExampleMinModel ModelCol -> IO ()-example_min_main_coll_expr f = example_min_main (f . list . foldr (++) [] . map (map fromInteger . read . (\x -> "[" ++ x ++ "]"))) (f. list . (\x -> [x])) f

− Control/CP/FD/FD.hs

@@ -1,1555 +0,0 @@-{-# LANGUAGE GeneralizedNewtypeDeriving #-}-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE TypeFamilies #-}-{-# LANGUAGE MultiParamTypeClasses #-}-{-# LANGUAGE TypeSynonymInstances #-}-{-# LANGUAGE UndecidableInstances #-}--module Control.CP.FD.FD (-  module Data.Expr.Sugar,-  FDInstance,-  FDSolver(..),-  FDSpecInfo,-  FDSpecInfoBool(..), FDSpecInfoInt(..), FDSpecInfoCol(..),-  liftFD, addFD,-  SpecFn, SpecFnRes, SpecResult(..),-  getBoolSpec_, getIntSpec_, getColSpec_,-  getBoolSpec,  getIntSpec,  getColSpec,-  getEdge, markEdge,-  setFailed,-  getLevel,-  getIntVal, getBoolVal, getColVal,-  getIntTerm, getBoolTerm, getColTerm,-  getSingleIntTerm,-  getDefBoolSpec, getDefIntSpec, getDefColSpec,-  getFullBoolSpec, getFullIntSpec, getFullColSpec,-  getColItems,-  fdSpecInfo_spec,-  specInfoBoolTerm, specInfoIntTerm,-  Control.CP.FD.FD.newInt, Control.CP.FD.FD.newBool, Control.CP.FD.FD.newCol,-  procSubModel, procSubModelEx, specSubModelEx,-  runFD,-  setMinimizeVar, boundMinimize, getMinimizeTerm, getMinimizeVar,-  fdNewvar,-) where--import Control.Monad.State.Lazy-import Control.Monad.Trans-import qualified Data.Map as Map-import Data.Map(Map)-import Data.Maybe-import Data.List-import qualified Data.Set as Set-import Data.Set(Set)--import Control.CP.Debug-import Data.Expr.Sugar-import Data.Expr.Data--- import Control.CP.FD.Expr.Util-import Control.CP.FD.Model-import Control.CP.FD.Decompose-import Control.CP.FD.Graph-import Control.CP.SearchTree-import Control.CP.ComposableTransformers-import Control.CP.EnumTerm-import Control.CP.Solver-import Control.Mixin.Mixin---- | state kept by FDInstance, in addition to the underlying solver's internal state-data FDSolver s => FDState s = FDState {-  -- | expression representing unprocessed constraints-  fdsExpr :: Model,-  -- | model being processed now-  fdsModel :: Maybe EGModel,-  -- | private data for the decomposer (kept to optimize constraints which aren't added in one go)-  fdsDecomp :: DecompData,-  -- | when adding constraints, the EGEdgeId's occurring in the decomposed model-  fdsNewEdges :: Set EGEdgeId,-  fdsDoneEdges :: Set EGEdgeId,-  -- | expressions that need to be decomposed-  fdsForceBool :: [ModelBool], fdsForcedBool :: Map ModelBool (FDBoolTerm s),-  fdsForceInt :: [ModelInt], fdsForcedInt :: Map ModelInt (FDIntTerm s),-  fdsForceCol :: [ModelCol],-  -- | variable counter-  fdsVars :: Int,--  -- | already introduced integer variables/terms/constants/expressions -  fdsIntVars :: Map EGVarId (FDSpecInfoInt s),-  -- | needed sets of possible types-  fdsIntVarTypes :: Map EGVarId (Set (FDIntSpecTypeSet s)),-  -- | which variables are being decomposed right now-  fdsIntVarBusy :: Set EGVarId,-  -- | which nodes are unified with which others-  fdsIntUnifies :: Map EGVarId (Set EGVarId),--  -- | already introduced boolean variables/terms/constants/expressions -  fdsBoolVars :: Map EGVarId (FDSpecInfoBool s),-  fdsBoolVarTypes :: Map EGVarId (Set (FDBoolSpecTypeSet s)),-  fdsBoolVarBusy :: Set EGVarId,-  fdsBoolUnifies :: Map EGVarId (Set EGVarId),-  -- | already introduced collection variables/terms/constants/expressions -  fdsColVars :: Map EGVarId (FDSpecInfoCol s),-  fdsColVarTypes :: Map EGVarId (Set (FDColSpecTypeSet s)),-  fdsColVarBusy :: Set EGVarId,-  fdsColUnifies :: Map EGVarId (Set EGVarId),--  -- | db of specifiers-  fdsDb :: SpecDb s,--  -- | solver is failed?-  fdsFailed :: Bool,--  -- | level of nesting-  fdsLevel :: Int,--  -- | levels of dummyness-  fdsDummyLevel :: Int,--  fdsMinimizeVar :: Maybe ModelInt,-  fdsMinimizeTerm :: Maybe (FDIntTerm s)-}--myFromJust str m = case m of-  Nothing -> error $ "myFromJust: " ++ str-  Just x -> x--unifyInts a b = do-  s <- get-  let sa = Map.findWithDefault (Set.singleton a) a (fdsIntUnifies s)-  let sb = Map.findWithDefault (Set.singleton b) b (fdsIntUnifies s)-  let sc = Set.union sa sb-  put s { fdsIntUnifies = foldr (\a b -> Map.insert a sc b) (fdsIntUnifies s) $ Set.toList sc }--unifyBools a b = do-  s <- get-  let sa = Map.findWithDefault (Set.singleton a) a (fdsBoolUnifies s)-  let sb = Map.findWithDefault (Set.singleton b) b (fdsBoolUnifies s)-  let sc = Set.union sa sb-  put s { fdsBoolUnifies = foldr (\a b -> Map.insert a sc b) (fdsBoolUnifies s) $ Set.toList sc }--unifyCols a b = do-  s <- get-  let sa = Map.findWithDefault (Set.singleton a) a (fdsColUnifies s)-  let sb = Map.findWithDefault (Set.singleton b) b (fdsColUnifies s)-  let sc = Set.union sa sb-  put s { fdsColUnifies = foldr (\a b -> Map.insert a sc b) (fdsColUnifies s) $ Set.toList sc }--mapVals :: Show b => (a -> Maybe b) -> [a] -> [String]-mapVals f l = nub $ sort $ map show $ catMaybes $ map f l--dumpSpec :: FDSolver s => FDState s -> String-dumpSpec s = -  foldl (++) "" (map (\(i,r) -> "i" ++ (show $ unVarId i) ++ "\n" ++ foldl (++) "" (map (\x -> "  "++x++"\n") (mapVals (fdspIntSpec r) (Nothing : (map Just $ Set.toList $ fdspIntTypes r))))) $ Map.toList (fdsIntVars s)) ++-  foldl (++) "" (map (\(i,r) -> "b" ++ (show $ unVarId i) ++ "\n" ++ foldl (++) "" (map (\x -> "  "++x++"\n") (mapVals (fdspBoolSpec r) (Nothing : (map Just $ Set.toList $ fdspBoolTypes r))))) $ Map.toList (fdsBoolVars s)) ++-  foldl (++) "" (map (\(i,r) -> "c" ++ (show $ unVarId i) ++ "\n" ++ foldl (++) "" (map (\x -> "  "++x++"\n") (mapVals (fdspColSpec r) (Nothing : (map Just $ Set.toList $ fdspColTypes r))))) $ Map.toList (fdsColVars s))--setMinimizeVar :: (Show (FDIntTerm s), FDSolver s) => ModelInt -> FDInstance s ()-setMinimizeVar v = do-  s <- get-  case Map.lookup v (fdsForcedInt s) of-    Just t -> debug ("setMinimizeVar: (cached) var="++(show v)++" term="++(show t)) $ put s { fdsMinimizeVar = Just v, fdsMinimizeTerm = Just t }-    Nothing -> do-      var <- getSingleIntTerm v-      s2 <-  get-      debug ("setMinimizeVar: (not cached) var="++(show v)++" term="++(show var)) $ put s2 { fdsMinimizeVar = Just v, fdsMinimizeTerm = Just var }--getMinimizeVar :: (Show (FDIntTerm s), FDSolver s) => FDInstance s (Maybe ModelInt)-getMinimizeVar = do-  s <- get-  return $ fdsMinimizeVar s--getMinimizeTerm :: (Show (FDIntTerm s), FDSolver s) => FDInstance s (Maybe (FDIntTerm s))-getMinimizeTerm = do-  s <- get-  debug ("getMinimizeTerm: "++(show $ fdsMinimizeTerm s)) $ return ()-  return (fdsMinimizeTerm s)---  case (fdsMinimizeTerm s) of---    q@(Just _) -> return q---    Nothing -> case (fdsMinimizeVar s) of---      Nothing -> return Nothing---      Just v -> do---        q <- getSingleIntTerm v---        put s { fdsMinimizeTerm = Just q }---        return $ Just q--boundMinimize :: (Show (FDIntTerm s), FDSolver s, EnumTerm s (FDIntTerm s), Integral (TermBaseType s (FDIntTerm s))) => NewBound (FDInstance s)-boundMinimize = do-  bound <- getMinimizeTerm-  case bound of-    Nothing -> error "no bound variable defined"-    Just bndvar -> do-      x <- liftFD $ getValue bndvar-      case x of-        Just val -> do-          con <- liftFD $ fdConstrainIntTerm bndvar (toInteger val)-          let f = Bound (\x -> (Add (Right con) x))-          return f-        _ -> error "bound variable is not assigned"--runFD :: FDSolver s => FDInstance s a -> s a-runFD (FDInstance { unFDInstance = u }) = evalStateT u baseFDState--linkExterns :: FDSolver s => (Int -> Maybe (FDSpecInfoBool s), Int -> Maybe (FDSpecInfoInt s), Int -> Maybe (FDSpecInfoCol s)) -> EGEdgeId -> FDInstance s ()-linkExterns (sfb,sfi,sfc) id = do-  s <- get-  let Just jm = fdsModel s-  let Just edge = Map.lookup id $ egmEdges jm-  case (egeCons edge) of-    EGBoolExtern p -> do-      case sfb p of-        Nothing -> return ()-        Just spec -> do-          let [varid] = boolData $ egeLinks edge-          if (Map.member varid $ fdsBoolVars s) then error "double bool import" else return ()-          put $ s { fdsBoolVars = Map.insert varid spec $ fdsBoolVars s, fdsBoolVarTypes = Map.delete varid $ fdsBoolVarTypes s }-      markEdge id-    EGIntExtern p -> do-      case sfi p of-        Nothing -> return ()-        Just spec -> do-          let [varid] = intData $ egeLinks edge-          if (Map.member varid $ fdsIntVars s) then error "double int import" else return ()-          put $ s { fdsIntVars = Map.insert varid spec $ fdsIntVars s, fdsIntVarTypes = Map.delete varid $ fdsIntVarTypes s }-      markEdge id-    EGColExtern p -> do-      case sfc p of-        Nothing -> return ()-        Just spec -> do-          let [varid] = colData $ egeLinks edge-          if (Map.member varid $ fdsColVars s) then error "double col import" else return ()-          put $ s { fdsColVars = Map.insert varid spec $ fdsColVars s, fdsColVarTypes = Map.delete varid $ fdsColVarTypes s }-      markEdge id-    _ -> return ()--procSubModel :: FDSolver s => EGModel -> (Int -> FDSpecInfoBool s, Int -> FDSpecInfoInt s, Int -> FDSpecInfoCol s) -> FDInstance s ()-procSubModel sm (fb,fi,fc) = procSubModelEx sm (Just . fb,Just . fi,Just . fc)--procSubModelEx :: FDSolver s => EGModel -> (Int -> Maybe (FDSpecInfoBool s), Int -> Maybe (FDSpecInfoInt s), Int -> Maybe (FDSpecInfoCol s)) -> FDInstance s ()-procSubModelEx sm specfn = do-  s <- get-  let ss = baseFDState {-    fdsModel = Just sm,-    fdsVars = fdsVars s,-    fdsFailed = fdsFailed s,-    fdsLevel = 1 + fdsLevel s-  }-  put ss-  initForModel-  s2 <- get-  mapM_ (linkExterns specfn) $ Set.toList $ fdsNewEdges s2-  process-  s3 <- get-  put $ s { fdsFailed = fdsFailed s || fdsFailed s3, fdsVars = fdsVars s3 }--getLevel :: FDSolver s => FDInstance s Int-getLevel = do-  s <- get-  return $ fdsLevel s---- specSubModelEx :: FDSolver s => EGModel -> (Int -> Maybe (FDSpecInfoBool s), Int -> Maybe (FDSpecInfoInt s), Int -> Maybe (FDSpecInfoCol s)) -> FDInstance s ()-specSubModelEx sm specfn = do-  s <- get-  let ss = baseFDState {-    fdsModel = Just sm,-    fdsVars = fdsVars s,-    fdsFailed = fdsFailed s,-    fdsLevel = 1 + fdsLevel s-  }-  put ss-  initForModel-  s2 <- get-  mapM_ (linkExterns specfn) $ Set.toList $ fdsNewEdges s2-  s3 <- get-  put s3 { fdsDummyLevel = 1 }-  processEx False-  s4 <- get-  put $ s { fdsFailed = fdsFailed s || fdsFailed s4, fdsVars = fdsVars s4 }-  return (fdsBoolVars s4, fdsIntVars s4, fdsColVars s4)--optimizeSetSet :: Ord a => Set (Set a) -> Set (Set a)-optimizeSetSet x = -  let (min,xx) = Set.deleteFindMin x-      inter = Set.fold Set.intersection min xx-      in if Set.null inter then x else Set.singleton inter--optimizeVarTypes :: FDSolver s => FDInstance s ()-optimizeVarTypes = do-  s <- get-  put $ s {-    fdsBoolVarTypes = Map.map optimizeSetSet $ fdsBoolVarTypes s,-    fdsIntVarTypes = Map.map optimizeSetSet $ fdsIntVarTypes s,-    fdsColVarTypes = Map.map optimizeSetSet $ fdsColVarTypes s-  }--checkNeedSpecType var typ db = any (Set.member typ) $ Set.toList $ Map.findWithDefault Set.empty var db--decompSpec fn db un unfn ex vars typs = do-  s <- get-  let tri [] = do-        debug ("decompSpec vars="++(show vars)++": no spec left, failing") $ return ()-        return Nothing-      tri (((_,_,id),_):rest) | not (Set.member id vars) = tri rest-      tri ((key@(_,_,id),(eid,s)):rest) = case ex s of-        Nothing -> tri rest-        Just spec -> do-          res <- spec-          case res of-            SpecResNone -> tri rest-            SpecResSpec (typ,spec) -> if Set.member typ typs-              then do-                rr <- liftFD spec-                debug ("decompSpec: got spec: " ++ (show rr)) $ return ()-                fn (Set.findMin vars) typ rr-                case eid of-                  Nothing -> return ()-                  Just e -> do-                    debug ("decompSpec: marking edge "++(show e)) $ return ()-                    markEdge e-                return $ Just (typ,rr)-              else tri rest-            SpecResUnify v -> do-              unfn id v-              decompSpec fn db un unfn ex vars typs-  tri $ Map.toDescList $ db--decompBestHelp id spec fn unfn eid prio db = do-  res <- spec-  case res of-    SpecResNone -> do-      debug ("decompBestHelp: level "++(show prio)++" specifier for var "++(show id)++" by edge "++(show eid)++" has failed") $ return ()-      return ()-    SpecResSpec (typ,ss) -> if checkNeedSpecType id typ db-      then do-        rr <- liftFD ss-        res <- fn id typ rr-        case eid of-          Nothing -> return ()-          Just e -> do-            debug ("decompBestHelp: marking edge "++(show e)) $ return ()-            markEdge e-            return ()-        return res-      else do-        debug ("decompBestHelp: typ "++(show typ)++" specifier for id "++(show id)++" seems not needed") $ return ()-        return ()-    SpecResUnify v -> do-      unfn id v-      return ()--decompBest :: FDSolver s => FDInstance s Bool-decompBest = do-  s1 <- debug "in decompBest: get" $ get-  debug "in decompBest" $ return ()-  if Map.null $ fdsDb s1-    then return False-    else do-      let (((prio,knd,id),(eid,spec)),nm) = Map.deleteFindMax $ fdsDb $ debug "s1?" s1-          s2 = debug ("got best spec: prio="++(show prio)++", knd="++(show knd)++", id="++(show id)++", eid="++(show eid)++", spec=?") $ s1 { fdsDb = nm }-      put s2-      case knd of-        FDTBool -> do-          let s3 = s2 { fdsBoolVarBusy = Set.insert id $ fdsBoolVarBusy s2 }-          put s3-          let Just j = fdsBoolSel spec-          decompBestHelp id j addBoolVar unifyBools eid prio $ fdsBoolVarTypes s3-          s4 <- get-          put $ s4 { fdsBoolVarBusy = Set.delete id $ fdsBoolVarBusy s4 }-        FDTInt -> do-          let s3 = s2 { fdsIntVarBusy = Set.insert id $ fdsIntVarBusy s2 }-          put s3-          let Just j = fdsIntSel spec-          decompBestHelp id j addIntVar unifyInts eid prio $ fdsIntVarTypes s3-          s4 <- get-          put $ s4 { fdsIntVarBusy = Set.delete id $ fdsIntVarBusy s4 }-        FDTCol -> do-          let s3 = s2 { fdsColVarBusy = Set.insert id $ fdsColVarBusy s2 }-          put s3-          let Just j = fdsColSel spec-          decompBestHelp id j addColVar unifyCols eid prio $ fdsColVarTypes s3-          s4 <- get-          put $ s4 { fdsColVarBusy = Set.delete id $ fdsColVarBusy s4 }-      return True--decompDefaultBool :: FDSolver s => FDInstance s Bool-decompDefaultBool = do-  s1 <- get-  if Map.null $ fdsBoolVarTypes s1-    then return False-    else do-      let ((varid,set),nm) = Map.deleteFindMin $ fdsBoolVarTypes s1-          s2 = s1 { fdsBoolVarTypes = nm }-      put s2-      if Set.null set-        then return True-        else do-          defaultBoolDecomp varid Nothing-          return True--decompDefaultInt :: FDSolver s => FDInstance s Bool-decompDefaultInt = do-  s1 <- get-  if Map.null $ fdsIntVarTypes s1-    then return False-    else do-      let ((varid,set),nm) = Map.deleteFindMin $ fdsIntVarTypes s1-          s2 = s1 { fdsIntVarTypes = nm }-      put s2-      if Set.null set-        then return True-        else do-          defaultIntDecomp varid Nothing-          return True--defaultBoolDecomp :: FDSolver s => EGVarId -> (Maybe (FDBoolSpecTypeSet s)) -> FDInstance s (Maybe (FDBoolSpecType s, FDBoolSpec s))-defaultBoolDecomp var typs = do-  s <- get-  if fdsDummyLevel s > 0 -    then return Nothing-    else do-      vt <- liftFD $ fdTypeVarBool-      let Just jt = typs-      if (isNothing typs || not (Set.null $ Set.intersection vt jt))-        then do-          Just v <- fdNewvar-          let (ty,sp) = fdBoolSpec_term v-          rs <- liftFD sp-          addBoolVar var ty (rs, Nothing)-          return $ Just (ty,rs)-        else return Nothing--defaultIntDecomp :: FDSolver s => EGVarId -> (Maybe (FDIntSpecTypeSet s)) -> FDInstance s (Maybe (FDIntSpecType s, FDIntSpec s))-defaultIntDecomp var typs = do-  s <- get-  if fdsDummyLevel s > 0-    then return Nothing-    else do-      vt <- liftFD $ fdTypeVarInt-      let Just jt = typs-      if (isNothing typs || not (Set.null $ Set.intersection vt jt))-        then do-          Just v <- fdNewvar-          let (ty,sp) = fdIntSpec_term v-          rs <- liftFD sp-          addIntVar var ty (rs, Nothing)-          return $ Just (ty,rs)-        else return Nothing--getBoolSpec_ :: FDSolver s => EGVarId -> FDBoolSpecTypeSet s -> FDInstance s (Maybe (FDBoolSpecType s, FDBoolSpec s))-getBoolSpec_ var typs = do-  s <- get-  let vars = Map.findWithDefault (Set.singleton var) var $ fdsBoolUnifies s-  getBoolSpec__ vars typs--getBoolSpec__ :: FDSolver s => Set EGVarId -> FDBoolSpecTypeSet s -> FDInstance s (Maybe (FDBoolSpecType s, FDBoolSpec s))-getBoolSpec__ vars typs = do-  s <- get-  let mp = foldl (\b a -> case Map.lookup a (fdsBoolVars s) of { Nothing -> b; Just x -> case b of { Nothing -> Just x; Just r -> Just $ unionSpecBool r x }}) Nothing (Set.toList vars)-  let sp = Set.intersection (maybe Set.empty fdspBoolTypes mp) typs-  let db = fdsDb s-  if Set.null sp-    then if not (Set.null $ Set.intersection vars $ fdsBoolVarBusy s)-      then return Nothing-      else do-        put $ s { fdsBoolVarBusy = Set.union vars $ fdsBoolVarBusy s }-        res <- decompSpec addBoolVar db (\x -> Map.lookup x $ fdsBoolUnifies s) unifyBools fdsBoolSel vars typs-        s2 <- get-        put $ s2 { fdsBoolVarBusy = Set.difference (fdsBoolVarBusy s) vars }-        case res of-          Just (tp,(sp,_)) -> return $ Just (tp,sp)-          _ -> defaultBoolDecomp (Set.findMin vars) $ Just typs-    else do-      let lp = Set.findMin sp-      let Just jmp = mp-      let Just j = fdspBoolSpec jmp $ Just lp-      return $ Just (lp,j)--getBoolSpec :: FDSolver s => EGVarId -> FDInstance s (Maybe (FDBoolSpec s))-getBoolSpec var = do-  s <- allBoolSpec-  q <- getBoolSpec_ var s-  return $ case q of-    Just (_,x) -> Just x-    Nothing -> Nothing--getIntSpec_ :: FDSolver s => EGVarId -> FDIntSpecTypeSet s -> FDInstance s (Maybe (FDIntSpecType s, FDIntSpec s))-getIntSpec_ var typs = do-  s <- get-  let vars = Map.findWithDefault (Set.singleton var) var $ fdsIntUnifies s-  getIntSpec__ vars typs--getIntSpec__ :: FDSolver s => Set EGVarId -> FDIntSpecTypeSet s -> FDInstance s (Maybe (FDIntSpecType s, FDIntSpec s))-getIntSpec__ vars typs = do-  s <- get-  let mp = foldl (\b a -> case Map.lookup a (fdsIntVars s) of { Nothing -> b; Just x -> case b of { Nothing -> Just x; Just r -> Just $ unionSpecInt r x }}) Nothing $ Set.toList vars-  let sp = Set.intersection (maybe Set.empty fdspIntTypes mp) typs-  let db = fdsDb s-  if Set.null sp-    then if not (Set.null $ Set.intersection vars $ fdsIntVarBusy s)-      then do-        debug ("getIntSpec__ "++(show (vars,typs))++": busy, failing") $ return ()-        return Nothing-      else do-        put $ s { fdsIntVarBusy = Set.union vars $ fdsIntVarBusy s }-        res <- decompSpec addIntVar db (\x -> Map.lookup x $ fdsIntUnifies s) unifyInts fdsIntSel vars typs-        s2 <- get-        put $ s2 { fdsIntVarBusy = Set.difference (fdsIntVarBusy s) vars }-        case res of-          Just (tp,(sp,_)) -> return $ Just (tp,sp)-          _ -> defaultIntDecomp (Set.findMin vars) $ Just typs-    else do-      let lp = Set.findMin sp-      let Just jmp = mp-      let Just j = fdspIntSpec jmp $ Just lp-      return $ Just (lp,j)--getIntSpec :: FDSolver s => EGVarId -> FDInstance s (Maybe (FDIntSpec s))-getIntSpec var = do-  s <- allIntSpec-  q <- getIntSpec_ var s-  return $ case q of-    Just (_,x) -> Just x-    Nothing -> Nothing--getColSpec_ :: FDSolver s => EGVarId -> FDColSpecTypeSet s -> FDInstance s (Maybe (FDColSpecType s, FDColSpec s))-getColSpec_ var typs = do-  s <- get-  let vars = Map.findWithDefault (Set.singleton var) var $ fdsColUnifies s-  getColSpec__ vars typs--getColSpec__ :: FDSolver s => Set EGVarId -> FDColSpecTypeSet s -> FDInstance s (Maybe (FDColSpecType s, FDColSpec s))-getColSpec__ vars typs = do-  s <- get-  let mp = foldl (\b a -> case Map.lookup a (fdsColVars s) of { Nothing -> b; Just x -> case b of { Nothing -> Just x; Just r -> Just $ unionSpecCol r x }}) Nothing (Set.toList vars)-  let sp = Set.intersection (maybe Set.empty fdspColTypes mp) typs-  let db = fdsDb s-  if Set.null sp-    then if not (Set.null $ Set.intersection vars $ fdsColVarBusy s)-      then return Nothing-      else do-        put $ s { fdsColVarBusy = Set.union vars $ fdsColVarBusy s }-        res <- decompSpec addColVar db (\x -> Map.lookup x $ fdsColUnifies s) unifyCols fdsColSel vars typs-        s2 <- get-        put $ s2 { fdsColVarBusy = Set.difference (fdsColVarBusy s) vars }-        case res of-          Just (tp,(sp,_)) -> return $ Just (tp,sp)-          _ -> return Nothing-    else do-      let lp = Set.findMin sp-      let Just jmp = mp-      let Just j = fdspColSpec jmp $ Just lp-      return $ Just (lp,j)--getColSpec :: (Show (FDColSpec s), FDSolver s) => EGVarId -> FDInstance s (Maybe (FDColSpec s))-getColSpec var = do-  s <- allColSpec-  q <- getColSpec_ var s-  return $ case q of-    Just (_,x) -> Just x-    Nothing -> Nothing---- | initial FDState state -baseFDState :: FDSolver s => FDState s-baseFDState = FDState {-  fdsVars = 0,-  fdsExpr = BoolConst True,-  fdsForceBool = [],-  fdsForcedBool = Map.empty,-  fdsForceInt = [],-  fdsForcedInt = Map.empty,-  fdsForceCol = [],-  fdsModel = Nothing,-  fdsNewEdges = Set.empty,-  fdsDoneEdges = Set.empty,-  fdsDecomp = baseDecompData,-  fdsIntVars = Map.empty,-  fdsIntVarTypes = Map.empty,-  fdsIntVarBusy = Set.empty,-  fdsIntUnifies = Map.empty,-  fdsBoolVars = Map.empty,-  fdsBoolVarTypes = Map.empty,-  fdsBoolVarBusy = Set.empty,-  fdsBoolUnifies = Map.empty,-  fdsColVars = Map.empty,-  fdsColVarTypes = Map.empty,-  fdsColVarBusy = Set.empty,-  fdsColUnifies = Map.empty,-  fdsDb = Map.empty,-  fdsFailed = False,-  fdsLevel = 0,-  fdsDummyLevel = 0,-  fdsMinimizeVar = Nothing,-  fdsMinimizeTerm = Nothing-}--edgesLeft :: FDSolver s => FDInstance s Bool-edgesLeft = get >>= return . Set.null . fdsNewEdges---- | run the second argument as long as the first one produces true-whileM :: Monad m => m Bool -> m a -> m ()-whileM cond act = do-  x <- cond-  if x-    then do-      act-      whileM cond act-    else return ()--whileM_ :: Monad m => m Bool -> m ()-whileM_ cond = whileM cond $ return ()---- | a label for an FDInstance; must store the FDState plus the Solver's internal state-data FDSolver s => FDLabel s = FDLabel {-  fdlState :: FDState s,-  fdlLabel :: Label s-}---- | definition of FDInstance, a Solver wrapper that adds power to post boolean expressions as constraints-newtype FDSolver s => FDInstance s a = FDInstance { unFDInstance :: StateT (FDState s) s a }-  deriving (Monad, MonadState (FDState s))---- | helper function to combine two Maybe's-joinWith :: (a -> a -> a) -> Maybe a -> Maybe a -> Maybe a-joinWith f a b = case (a,b) of-  (Nothing,_) -> b-  (_,Nothing) -> a-  (Just x,Just y) -> Just $ f x y---- | lift a monad action for the underlying solver to a monad action for an FDInstance around it-liftFD :: FDSolver s => s a -> FDInstance s a-liftFD = FDInstance . lift--liftFDTree :: (FDSolver s, MonadTree m, TreeSolver m ~ (FDInstance s)) => Tree s a -> m a-liftFDTree = mapTree liftFD--data SpecResult t =-    SpecResNone-  | SpecResSpec t-  | SpecResUnify EGVarId--type SpecBool s = FDInstance s (SpecResult (FDBoolSpecType s, s (FDBoolSpec s, Maybe EGBoolPar)))-type SpecInt s = FDInstance s (SpecResult (FDIntSpecType s, s (FDIntSpec s, Maybe EGPar)))-type SpecCol s = FDInstance s (SpecResult (FDColSpecType s, s (FDColSpec s, Maybe EGColPar)))--type SpecFnRes s = -  (-    [(Int, EGVarId, Bool, SpecBool s)],-    [(Int, EGVarId, Bool, SpecInt s)],-    [(Int, EGVarId, Bool, SpecCol s)]-  )--type SpecFn s = EGEdge -> SpecFnRes s--data TermType = FDTBool | FDTInt | FDTCol-  deriving (Eq,Ord,Bounded,Enum,Show)--fdsBoolSel x = case x of-  FDSBool a -> Just a-  _ -> Nothing-fdsIntSel x = case x of-  FDSInt a -> Just a-  _ -> Nothing-fdsColSel x = case x of-  FDSCol a -> Just a-  _ -> Nothing--data TermTypeSpec s = FDSBool (SpecBool s) | FDSInt (SpecInt s) | FDSCol (SpecCol s)--instance Show (TermTypeSpec s) where-  show (FDSBool _) = "FDSBool"-  show (FDSInt _) = "FDSInt"-  show (FDSCol _) = "FDSCol"--type SpecDb s = Map (Int,TermType,EGVarId) (Maybe EGEdgeId,TermTypeSpec s)--addBoolSpec :: FDSolver s => SpecDb s -> (Int,EGVarId,Maybe EGEdgeId,SpecBool s) -> SpecDb s-addBoolSpec db (prio,var,eid,spec) = Map.insert (prio,FDTBool,var) (eid,FDSBool spec) db--addIntSpec :: FDSolver s => SpecDb s -> (Int,EGVarId,Maybe EGEdgeId,SpecInt s) -> SpecDb s-addIntSpec db (prio,var,eid,spec) = Map.insert (prio,FDTInt,var) (eid,FDSInt spec) db--addColSpec :: FDSolver s => SpecDb s -> (Int,EGVarId,Maybe EGEdgeId,SpecCol s) -> SpecDb s-addColSpec db (prio,var,eid,spec) = Map.insert (prio,FDTCol,var) (eid,FDSCol spec) db--emptyFDSpecInfoBool :: FDSolver s => EGVarId -> FDState s -> FDSpecInfoBool s-emptyFDSpecInfoBool v s = FDSpecInfoBool { fdspBoolSpec = const Nothing, fdspBoolVar = Just v, fdspBoolVal = getBoolVal_ v s, fdspBoolTypes = Set.empty }-emptyFDSpecInfoInt :: FDSolver s => EGVarId -> FDState s -> FDSpecInfoInt s-emptyFDSpecInfoInt v s = FDSpecInfoInt { fdspIntSpec = const Nothing, fdspIntVar = Just v, fdspIntVal = getIntVal_ v s, fdspIntTypes = Set.empty }-emptyFDSpecInfoCol :: FDSolver s => EGVarId -> FDState s -> FDSpecInfoCol s-emptyFDSpecInfoCol v s = FDSpecInfoCol { fdspColSpec = const Nothing, fdspColVar = Just v, fdspColVal = getColVal_ v s, fdspColTypes = Set.empty }--data FDSpecInfoBool s = FDSpecInfoBool { fdspBoolSpec :: Maybe (FDBoolSpecType s) -> Maybe (FDBoolSpec s), fdspBoolVar :: Maybe EGVarId, fdspBoolVal :: Maybe EGBoolPar, fdspBoolTypes :: Set (FDBoolSpecType s) }-data FDSpecInfoInt s = FDSpecInfoInt   { fdspIntSpec  :: Maybe (FDIntSpecType s)  -> Maybe (FDIntSpec s),  fdspIntVar ::  Maybe EGVarId, fdspIntVal ::  Maybe EGPar, fdspIntTypes :: Set (FDIntSpecType s) }-data FDSpecInfoCol s = FDSpecInfoCol   { fdspColSpec  :: Maybe (FDColSpecType s)  -> Maybe (FDColSpec s),  fdspColVar ::  Maybe EGVarId, fdspColVal ::  Maybe EGColPar, fdspColTypes :: Set (FDColSpecType s) }--unionSpecBool (FDSpecInfoBool { fdspBoolSpec = s1, fdspBoolVar = n1, fdspBoolVal = v1, fdspBoolTypes = t1 }) (FDSpecInfoBool { fdspBoolSpec = s2, fdspBoolVar = n2, fdspBoolVal = v2, fdspBoolTypes = t2 }) =-  FDSpecInfoBool { fdspBoolSpec = \t -> (s1 t) `mplus` (s2 t), fdspBoolVal = v1 `mplus` v2, fdspBoolVar = n1 `mplus` n2, fdspBoolTypes = Set.union t1 t2 }-unionSpecInt (FDSpecInfoInt { fdspIntSpec = s1, fdspIntVar = n1, fdspIntVal = v1, fdspIntTypes = t1 }) (FDSpecInfoInt { fdspIntSpec = s2, fdspIntVar = n2, fdspIntVal = v2, fdspIntTypes = t2 }) =-  FDSpecInfoInt { fdspIntSpec = \t -> (s1 t) `mplus` (s2 t), fdspIntVal = v1 `mplus` v2, fdspIntVar = n1 `mplus` n2, fdspIntTypes = Set.union t1 t2 }-unionSpecCol (FDSpecInfoCol { fdspColSpec = s1, fdspColVar = n1, fdspColVal = v1, fdspColTypes = t1 }) (FDSpecInfoCol { fdspColSpec = s2, fdspColVar = n2, fdspColVal = v2, fdspColTypes = t2 }) =-  FDSpecInfoCol { fdspColSpec = \t -> (s1 t) `mplus` (s2 t), fdspColVal = v1 `mplus` v2, fdspColVar = n1 `mplus` n2, fdspColTypes = Set.union t1 t2 }--instance (Ord (FDBoolSpec s), Ord (FDBoolSpecType s)) => Eq (FDSpecInfoBool s) where-  a == b = (compare a b) == EQ-instance (Ord (FDBoolSpec s), Ord (FDBoolSpecType s)) => Ord (FDSpecInfoBool s) where-  compare (FDSpecInfoBool { fdspBoolSpec = s1, fdspBoolVar = r1, fdspBoolVal = v1, fdspBoolTypes = t1 }) (FDSpecInfoBool { fdspBoolSpec = s2, fdspBoolVar = r2, fdspBoolVal = v2, fdspBoolTypes = t2 }) =-    compare r1 r2 <<>> compare v1 v2 <<>> compare (s1 Nothing) (s2 Nothing) <<>> compare (Map.fromList $ map (\x -> (x,s1 $ Just x)) $ Set.toList t1) (Map.fromList $ map (\x -> (x,s2 $ Just x)) $ Set.toList t2)--instance (Ord (FDIntSpec s), Ord (FDIntSpecType s)) => Eq (FDSpecInfoInt s) where-  a == b = (compare a b) == EQ-instance (Ord (FDIntSpec s), Ord (FDIntSpecType s)) => Ord (FDSpecInfoInt s) where-  compare (FDSpecInfoInt { fdspIntSpec = s1, fdspIntVar = r1, fdspIntVal = v1, fdspIntTypes = t1 }) (FDSpecInfoInt { fdspIntSpec = s2, fdspIntVar = r2, fdspIntVal = v2, fdspIntTypes = t2 }) =-    compare r1 r2 <<>> compare v1 v2 <<>> compare (s1 Nothing) (s2 Nothing) <<>> compare (Map.fromList $ map (\x -> (x,s1 $ Just x)) $ Set.toList t1) (Map.fromList $ map (\x -> (x,s2 $ Just x)) $ Set.toList t2)--instance (Ord (FDColSpec s), Ord (FDColSpecType s)) => Eq (FDSpecInfoCol s) where-  a == b = (compare a b) == EQ-instance (Ord (FDColSpec s), Ord (FDColSpecType s)) => Ord (FDSpecInfoCol s) where-  compare (FDSpecInfoCol { fdspColSpec = s1, fdspColVar = r1, fdspColVal = v1, fdspColTypes = t1 }) (FDSpecInfoCol { fdspColSpec = s2, fdspColVar = r2, fdspColVal = v2, fdspColTypes = t2 }) =-    compare r1 r2 <<>> compare v1 v2 <<>> compare (s1 Nothing) (s2 Nothing) <<>> compare (Map.fromList $ map (\x -> (x,s1 $ Just x)) $ Set.toList t1) (Map.fromList $ map (\x -> (x,s2 $ Just x)) $ Set.toList t2)--specInfoMapBool :: FDSolver s => FDSpecInfoBool s -> Map (FDBoolSpecType s) (FDBoolSpec s)-specInfoMapBool (FDSpecInfoBool { fdspBoolSpec = f, fdspBoolTypes = t }) = Map.fromList $ map (\t -> (t,myFromJust "specInfoMapBool" $ f $ Just t)) $ Set.toList t--specInfoMapInt :: FDSolver s => FDSpecInfoInt s -> Map (FDIntSpecType s) (FDIntSpec s)-specInfoMapInt (FDSpecInfoInt { fdspIntSpec = f, fdspIntTypes = t }) = Map.fromList $ map (\t -> (t,myFromJust "specInfoMapInt" $ f $ Just t)) $ Set.toList t--specInfoMapCol :: FDSolver s => FDSpecInfoCol s -> Map (FDColSpecType s) (FDColSpec s)-specInfoMapCol (FDSpecInfoCol { fdspColSpec = f, fdspColTypes = t }) = Map.fromList $ map (\t -> (t,myFromJust "specInfoMapCol" $ f $ Just t)) $ Set.toList t--specInfoBoolTerm :: FDSolver s => FDBoolTerm s -> s (FDSpecInfoBool s)-specInfoBoolTerm t = do-  let (tp,sp) = fdBoolSpec_term t-  s <- sp-  return $ FDSpecInfoBool { fdspBoolSpec = \t -> case t of { Nothing -> Just s; Just tt | tp==tt -> Just s; _ -> Nothing }, fdspBoolVar = Nothing, fdspBoolVal = Nothing, fdspBoolTypes = Set.singleton tp }--specInfoIntTerm :: FDSolver s => FDIntTerm s -> s (FDSpecInfoInt s)-specInfoIntTerm t = do-  let (tp,sp) = fdIntSpec_term t-  s <- sp-  return $ FDSpecInfoInt { fdspIntSpec = \t -> case t of { Nothing -> Just s; Just tt | tp==tt -> Just s; _ -> Nothing }, fdspIntVar = Nothing, fdspIntVal = Nothing, fdspIntTypes = Set.singleton tp }--instance Show (FDBoolSpec s) => Show (FDSpecInfoBool s) where-  show (FDSpecInfoBool { fdspBoolSpec = f, fdspBoolVar = e, fdspBoolVal = v }) = "FSSpecInfoBool { default:" ++ (show $ f Nothing) ++ ", var:" ++ (show e) ++ ", val:" ++ (show v) ++ "}"-instance Show (FDIntSpec s) => Show (FDSpecInfoInt s) where-  show (FDSpecInfoInt { fdspIntSpec = f, fdspIntVar = e, fdspIntVal = v }) = "FSSpecInfoInt { default:" ++ (show $ f Nothing) ++ ", var:" ++ (show e) ++ ", val:" ++ (show v) ++ "}"-instance Show (FDColSpec s) => Show (FDSpecInfoCol s) where-  show (FDSpecInfoCol { fdspColSpec = f, fdspColVar = e, fdspColVal = v }) = "FSSpecInfoCol { default:" ++ (show $ f Nothing) ++ ", var:" ++ (show e) ++ ", val:" ++ (show v) ++ "}"--type FDSpecInfo s = ([FDSpecInfoBool s],[FDSpecInfoInt s],[FDSpecInfoCol s])--fdSpecInfo_edge :: FDSolver s => EGEdgeId -> FDInstance s (FDSpecInfo s)-fdSpecInfo_edge f = do-  s <- get-  let edge = getJustEdge f s-      intS p = Map.findWithDefault (emptyFDSpecInfoInt p s) p $ fdsIntVars s-      boolS p = Map.findWithDefault (emptyFDSpecInfoBool p s) p $ fdsBoolVars s-      colS p = Map.findWithDefault (emptyFDSpecInfoCol p s) p $ fdsColVars s---      an m x = case x of---        Just i -> Map.lookup i m---        Nothing -> if Map.null m then Nothing else Just $ snd $ Map.findMin m---      boolX v = FDSpecInfoBool { fdspBoolSpec = an $ boolS v, fdspBoolVar = Just v, fdspBoolVal = getBoolVal_ v s, fdspBoolTypes = Set.fromList $ Map.keys $ boolS v }---      intX v = FDSpecInfoInt { fdspIntSpec = an $ intS v, fdspIntVar = Just v, fdspIntVal = getIntVal_ v s, fdspIntTypes = Set.fromList $ Map.keys $ intS v }---      colX v = FDSpecInfoCol { fdspColSpec = an $ colS v, fdspColVar = Just v, fdspColVal = getColVal_ v s, fdspColTypes = Set.fromList $ Map.keys $ colS v }-  return (map boolS $ boolData $ egeLinks edge, map intS $ intData $ egeLinks edge, map colS $ colData $ egeLinks edge)--fdSpecInfo_spec :: FDSolver s => ([Either (FDSpecInfoBool s) (FDBoolSpecType s,FDBoolSpec s)],[Either (FDSpecInfoInt s) (FDIntSpecType s,FDIntSpec s)],[Either (FDSpecInfoCol s) (FDColSpecType s,FDColSpec s)]) -> FDSpecInfo s-fdSpecInfo_spec (b,i,c) = (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.-class -  (-    Solver s, -    Term s (FDIntTerm s),-    Term s (FDBoolTerm s),-    Eq (FDBoolSpecType s), Ord (FDBoolSpecType s), Enum (FDBoolSpecType s), Bounded (FDBoolSpecType s), Show (FDBoolSpecType s),-    Eq (FDIntSpecType s),  Ord (FDIntSpecType s),  Enum (FDIntSpecType s),  Bounded (FDIntSpecType s), Show (FDIntSpecType s),-    Eq (FDColSpecType s),  Ord (FDColSpecType s),  Enum (FDColSpecType s),  Bounded (FDColSpecType s), Show (FDColSpecType s),---    Integral (TermBaseType s (FDIntTerm s)), Num (TermBaseType s (FDBoolTerm s)),-    Show (FDIntSpec s), Show (FDColSpec s), Show (FDBoolSpec s)-  ) => FDSolver s where-  -- term types-  type FDIntTerm s    :: *    -- a Term of s, representing Integer variables-  type FDBoolTerm s   :: *    -- a Term of s, representing Bool variables-  -- spec types-  type FDIntSpec s    :: *    -- a type specifying an Integer expression; should at least support constant Integer's and FDIntTerm's-  type FDBoolSpec s   :: *    -- a type specifying a Bool expression; should at least support constant Bool's and FDBoolTerm's-  type FDColSpec s    :: *    -- a type specifying a Integer array expression; should at least support lists of Int's and lists of IntTerm's-  -- spec type type-  type FDIntSpecType s :: *   -- a type specifying the type of an FDIntSpec s, in case there is more than one-  type FDBoolSpecType s :: *  -- a type specifying the type of an FDIntSpec s, in case there is more than one-  type FDColSpecType s :: *   -- a type specifying the type of an FDIntSpec s, in case there is more than one-  --  -- constructors for specifiers-  fdIntSpec_const     :: EGPar         -> (FDIntSpecType s, s (FDIntSpec s))-  fdBoolSpec_const    :: EGBoolPar     -> (FDBoolSpecType s, s (FDBoolSpec s))-  fdColSpec_const     :: EGColPar      -> (FDColSpecType s, s (FDColSpec s))-  fdColSpec_list      :: [FDIntSpec s] -> (FDColSpecType s, s (FDColSpec s))-  fdIntSpec_term      :: FDIntTerm s   -> (FDIntSpecType s, s (FDIntSpec s))-  fdBoolSpec_term     :: FDBoolTerm s  -> (FDBoolSpecType s, s (FDBoolSpec s))-  fdColSpec_size      :: EGPar         -> (FDColSpecType s, s (FDColSpec s))-  fdIntVarSpec        :: FDIntSpec s   -> s (Maybe (FDIntTerm s))-  fdBoolVarSpec       :: FDBoolSpec s  -> s (Maybe (FDBoolTerm s))--  -- function to inform about allowed types for nodes-  fdTypeReqBool :: s (EGEdge -> [(EGVarId,FDBoolSpecTypeSet s)])-  fdTypeReqInt ::  s (EGEdge -> [(EGVarId,FDIntSpecTypeSet s)])-  fdTypeReqCol ::  s (EGEdge -> [(EGVarId,FDColSpecTypeSet s)])-  fdTypeReqBool = return (\(EGEdge { egeLinks = EGTypeData { boolData = l } }) -> map (\x -> (x,Set.fromList [minBound..maxBound])) l)-  fdTypeReqInt = return (\(EGEdge { egeLinks = EGTypeData { intData = l } }) -> map (\x -> (x,Set.fromList [minBound..maxBound])) l)-  fdTypeReqCol = return (\(EGEdge { egeLinks = EGTypeData { colData = l } }) -> map (\x -> (x,Set.fromList [minBound..maxBound])) l)--  fdTypeVarInt :: s (Set (FDIntSpecType s))-  fdTypeVarBool :: s (Set (FDBoolSpecType s))-  fdTypeVarInt = return $ Set.singleton maxBound-  fdTypeVarBool = return $ Set.singleton maxBound--  -- rating functions for specification of terms-  fdSpecify :: Mixin (SpecFn s)-  fdSpecify = mixinId--  -- inspect collections-  fdColInspect :: FDColSpec s -> s [FDIntTerm s]--  -- function to request processing an edge in a graph-  fdProcess :: Mixin (EGConstraintSpec -> FDSpecInfo s -> FDInstance s ())--  -- add equality constraints-  fdEqualBool :: FDBoolSpec s -> FDBoolSpec s -> FDInstance s ()-  fdEqualInt :: FDIntSpec s -> FDIntSpec s -> FDInstance s ()-  fdEqualCol :: FDColSpec s -> FDColSpec s -> FDInstance s ()--  fdConstrainIntTerm :: FDIntTerm s -> Integer -> s (Constraint s)-  fdSplitIntDomain :: FDIntTerm s -> s ([Constraint s],Bool)-  fdSplitBoolDomain :: FDBoolTerm s -> s ([Constraint s],Bool)--fdGetValBool :: (FDSolver s, EnumTerm s (FDBoolTerm s)) => FDBoolSpec s -> s (Maybe (TermBaseType s (FDBoolTerm s)))-fdGetValInt :: (FDSolver s, EnumTerm s (FDIntTerm s)) => FDIntSpec s -> s (Maybe (TermBaseType s (FDIntTerm s)))--fdGetValBool s = fdBoolVarSpec s >>= \x -> case x of-  Just t -> getValue t-  _ -> return Nothing--fdGetValInt s = fdIntVarSpec s >>= \x -> case x of-  Just t -> getValue t-  _ -> return Nothing--type FDBoolSpecTypeSet s = Set (FDBoolSpecType s)-type FDIntSpecTypeSet s = Set (FDIntSpecType s)-type FDColSpecTypeSet s = Set (FDColSpecType s)--fdCombineSpecify :: FDSolver s => SpecFn s -> SpecFn s -> SpecFn s-fdCombineSpecify a b edge = -  let (a1,a2,a3) = a edge-      (b1,b2,b3) = b edge-      in (a1++b1,a2++b2,a3++b3)--procEdge :: FDSolver s => FDInstance s Bool-procEdge = do-  s <- get-  if (Set.null $ fdsNewEdges s)-    then return False-    else do-      let f = Set.findMin $ fdsNewEdges s-          edge = getJustEdge f s-      debug ("procEdge("++(show f)++")") $ return ()-      info <- fdSpecInfo_edge f-      full_fdProcess (egeCons edge) info-      debug ("procEdge: marking edge "++(show f)) $ return ()-      markEdge f-      s2 <- get-      return $ not $ Set.null $ fdsNewEdges s2--getEdge :: FDSolver s => EGEdgeId -> FDInstance s (Maybe EGEdge)-getEdge id = do-  s <- get-  return $ do-    v <- fdsModel s-    Map.lookup id $ egmEdges v--markEdge :: FDSolver s => EGEdgeId -> FDInstance s ()-markEdge id = do-  s <- get-  debug ("markEdge: "++(show $ id)) $ return ()-  put $ s { fdsNewEdges = Set.delete id $ fdsNewEdges s, fdsDoneEdges = Set.insert id $ fdsDoneEdges s }--sureMaybe :: [Maybe a] -> Maybe [a]-sureMaybe [] = Just []-sureMaybe (Nothing:_) = Nothing-sureMaybe ((Just a):b) = case sureMaybe b of-  Nothing -> Nothing-  Just l -> Just (a:l)--allIntSpec :: FDSolver s => FDInstance s (Set (FDIntSpecType s))-allIntSpec = return $ Set.fromList [minBound..maxBound]--allBoolSpec :: FDSolver s => FDInstance s (Set (FDBoolSpecType s))-allBoolSpec = return $ Set.fromList [minBound..maxBound]--allColSpec :: FDSolver s => FDInstance s (Set (FDColSpecType s))-allColSpec = return $ Set.fromList [minBound..maxBound]--default_fdSpecify :: FDSolver s => SpecFn s-default_fdSpecify edge = case (debug ("default_fdSpecify("++(show edge)++")") edge) of-  EGEdge { egeCons = EGIntValue c, egeLinks = EGTypeData { intData = [v] } } ->-    ([],[(1000,v,True,do-      let (tp, m) = fdIntSpec_const c-      return $ SpecResSpec (tp,m >>= (\x -> return (x, Just c)))-    )],[])-  EGEdge { egeCons = EGBoolValue c, egeLinks = EGTypeData { boolData = [v] } } ->-    ([(1000,v,True,do-      let (tp, m) = fdBoolSpec_const c-      return $ SpecResSpec (tp, m >>= (\x -> return (x, Just c)))-    )],[],[])-  EGEdge { egeCons = EGColValue c, egeLinks = EGTypeData { colData = [v] } } ->-    ([],[],[(990,v,True,do-      let (tp, m) = fdColSpec_const c-      return $ SpecResSpec (tp, m >>= (\x -> return (x, Just c)))-    )])-  EGEdge { egeCons = EGList s, egeLinks = EGTypeData { colData = [c], intData = l } } -> -    ([],[],[(500,c,True,do-      x <- mapM (\x -> getIntSpec x) l-      case sureMaybe x of-        Nothing -> return SpecResNone-        Just ll -> do-          let (tp, m) = fdColSpec_list ll-          return $ SpecResSpec $ (tp, m >>= (\x -> return (x, Nothing)))-    )])-  EGEdge { egeCons = EGSize, egeLinks = EGTypeData { colData = [c], intData=[s] } } ->-    ([],[],[(250,c,True,do-      ss <- get-      let k = getIntVal_ s ss-      case k of-        Nothing -> return SpecResNone-        Just ll -> do-          let (tp, m) = fdColSpec_size ll-          return $ SpecResSpec $ (tp, m >>= (\x -> return (x, Nothing)))-     )])-  EGEdge { egeCons = EGRange, egeLinks = EGTypeData { colData = [c], intData=[l,h] } } ->-    ([],[],[(250,c,False,do-      ss <- get-      let ll = getIntVal_ l ss-          hh = getIntVal_ h ss-      case (ll,hh) of-        (Just (Const jl), Just (Const jh)) -> do-          let (tp,m) = fdColSpec_size (Const $ jh-jl+1)-          return $ SpecResSpec $ (tp, m >>= (\x -> return (x, Just $ ColList [Const x | x <- [jl..jh]])))-        (Just jl, Just jh) -> do-          let (tp,m) = fdColSpec_size (jh-jl+1)-          return $ SpecResSpec $ (tp, m >>= (\x -> return (x, Nothing)))-        _ -> return SpecResNone-     )])-  _ -> ([],[],[])--default_fdProcess :: FDSolver s => EGConstraintSpec -> FDSpecInfo s -> FDInstance s ()-default_fdProcess cons _ = error $ "Cannot process "++(show cons)---- | mark all new edges(=constraints) of a model given in graph-form as to-be-processed-initForModel :: FDSolver s => FDInstance s ()-initForModel = do-  s <- get-  let Just model = fdsModel s-  put $ s { -    fdsNewEdges = Set.difference (Set.union (fdsNewEdges s) $ Set.fromList $ Map.keys $ egmEdges model) $ fdsDoneEdges s-  }--setAlter :: Ord a => a -> Maybe (Set (Set a)) -> Maybe (Set (Set a))-setAlter _ Nothing = Nothing-setAlter typ (Just x) = let f = fl x in if Set.null f then Nothing else Just f-  where fl = Set.filter $ not . Set.member typ--addSpecInt :: FDSolver s => FDIntSpecType s -> (FDIntSpec s, Maybe EGPar) -> EGVarId -> FDState s -> Maybe (FDSpecInfoInt s) -> Maybe (FDSpecInfoInt s)-addSpecInt tp def id s Nothing = addSpecInt tp def id s (Just $ emptyFDSpecInfoInt id s)-addSpecInt tp (def,val) _ _ (Just (m@(FDSpecInfoInt { fdspIntSpec = f, fdspIntTypes = t }))) =-  Just $ m { -    fdspIntSpec = \x -> case x of-      Just tt | tt==tp -> Just $ def-      Nothing -> case f Nothing of-        Nothing -> Just def-        Just ttt -> Just ttt-      k -> f k,-    fdspIntTypes = Set.insert tp t,-    fdspIntVal = case val of-      Nothing -> fdspIntVal m-      _ -> val-  }--addSpecBool :: FDSolver s => FDBoolSpecType s -> (FDBoolSpec s, Maybe EGBoolPar) -> EGVarId -> FDState s -> Maybe (FDSpecInfoBool s) -> Maybe (FDSpecInfoBool s)-addSpecBool tp def id s Nothing = addSpecBool tp def id s (Just $ emptyFDSpecInfoBool id s)-addSpecBool tp (def,val) _ _ (Just (m@(FDSpecInfoBool { fdspBoolSpec = f, fdspBoolTypes = t }))) = -  Just $ m { -    fdspBoolSpec = \x -> case x of-      Just tt | tt==tp -> Just $ def-      Nothing -> case f Nothing of-        Nothing -> Just def-        Just ttt -> Just ttt-      k -> f k,-    fdspBoolTypes = Set.insert tp t,-    fdspBoolVal = case val of-      Nothing -> fdspBoolVal m-      _ -> val-  }--addSpecCol :: FDSolver s => FDColSpecType s -> (FDColSpec s, Maybe EGColPar) -> EGVarId -> FDState s -> Maybe (FDSpecInfoCol s) -> Maybe (FDSpecInfoCol s)-addSpecCol tp def id s Nothing = addSpecCol tp def id s (Just $ emptyFDSpecInfoCol id s)-addSpecCol tp (def,val) _ _ (Just (m@(FDSpecInfoCol { fdspColSpec = f, fdspColTypes = t }))) = -  Just $ m {-    fdspColSpec = \x -> case x of-      Just tt | tt==tp -> Just $ def-      Nothing -> case f Nothing of-        Nothing -> Just def-        Just ttt -> Just ttt-      k -> f k,-    fdspColTypes = Set.insert tp t,-    fdspColVal = case val of-      Nothing -> fdspColVal m-      _ -> val-  }---- | add an int term-addIntVar :: FDSolver s => EGVarId -> FDIntSpecType s -> (FDIntSpec s, Maybe EGPar) -> FDInstance s ()-addIntVar id typ (spec@(rs,_)) = do---  debug ("addIntVar id="++(show id)++" typ="++(show typ)++" spec="++(show spec)) $ return ()-  s <- get-  case (Map.lookup id $ fdsIntVars s) of-    Just t | not (Set.null $ fdspIntTypes t) -> case (fdspIntSpec t Nothing) of-      Just x -> fdEqualInt rs x-      Nothing -> case fdspIntSpec t $ Just $ Set.findMax $ fdspIntTypes t of-        Just x -> fdEqualInt rs x-        Nothing -> return ()-    _ -> return ()-  s2 <- get-  put $ s2-    {-      fdsIntVars = Map.alter (addSpecInt typ spec id s2) id $ fdsIntVars s2,-      fdsIntVarBusy = Set.delete id $ fdsIntVarBusy s2,-      fdsIntVarTypes = Map.alter (setAlter typ) id $ fdsIntVarTypes s2-    }---- | add a bool term-addBoolVar :: FDSolver s => EGVarId -> FDBoolSpecType s -> (FDBoolSpec s, Maybe EGBoolPar) -> FDInstance s ()-addBoolVar id typ (spec@(rs,_)) = do---  debug ("addBoolVar id="++(show id)++" typ="++(show typ)++" spec="++(show spec)) $ return ()-  s <- get-  case (Map.lookup id $ fdsBoolVars s) of-    Just t | not (Set.null $ fdspBoolTypes t) -> case (fdspBoolSpec t Nothing) of-      Just x -> fdEqualBool rs x-      Nothing -> case fdspBoolSpec t $ Just $ Set.findMax $ fdspBoolTypes t of-        Just x -> fdEqualBool rs x-        Nothing -> return ()-    _ -> return ()-  s2 <- get-  put $ s2-    { -      fdsBoolVars = Map.alter (addSpecBool typ spec id s2) id $ fdsBoolVars s2,-      fdsBoolVarBusy = Set.delete id $ fdsBoolVarBusy s2,-      fdsBoolVarTypes = Map.alter (setAlter typ) id $ fdsBoolVarTypes s2-    }---- | add a col term-addColVar :: FDSolver s => EGVarId -> FDColSpecType s -> (FDColSpec s, Maybe EGColPar) -> FDInstance s ()-addColVar id typ (spec@(rs,_)) = do---  debug ("addColVar id="++(show id)++" typ="++(show typ)++" spec="++(show spec)) $ return ()-  s <- get-  case (Map.lookup id $ fdsColVars s) of-    Just t | not (Set.null $ fdspColTypes t) -> case (fdspColSpec t Nothing) of-      Just x -> fdEqualCol rs x-      Nothing -> case fdspColSpec t $ Just $ Set.findMax $ fdspColTypes t of-        Just x -> fdEqualCol rs x-        Nothing -> return ()-    _ -> return ()-  s2 <- get-  put $ s2-    { -      fdsColVars = Map.alter (addSpecCol typ spec id s2) id $ fdsColVars s2,-      fdsColVarBusy = Set.delete id $ fdsColVarBusy s2,-      fdsColVarTypes = Map.alter (setAlter typ) id $ fdsColVarTypes s2-    }--full_fdProcess :: FDSolver s => EGConstraintSpec -> FDSpecInfo s -> FDInstance s ()-full_fdProcess = mixin (fdProcess <@> mixinLift default_fdProcess)--full_fdSpecify :: FDSolver s => SpecFn s-full_fdSpecify = mixin (fdSpecify <@> mixinLift default_fdSpecify)---getJustEdge :: FDSolver s => EGEdgeId -> FDState s -> EGEdge-getJustEdge i s = -  let Just m = fdsModel s-      Just x = Map.lookup i (egmEdges m)-      in x--buildSpecDb :: FDSolver s => FDInstance s ()-buildSpecDb = do-  s <- get-  let origDb = fdsDb s-      ne = debug "bsdb: ne" $ map (\k -> (k,getJustEdge k s)) $ Set.toList $ debug "bsbd: fdsne" $ fdsNewEdges s-      proc db (eid,edge) = do -        let (lB,lI,lC) = debug ("bsbd: specify("++(show edge)++")") $ full_fdSpecify edge-            dB = foldr (\(prio,var,full,spec) d -> debug "bsbd: addbool" $ addBoolSpec d (prio,var,if full then Just eid else Nothing,spec)) db $ debug ("lB["++(show $ length lB)++"]") lB-            dI = foldr (\(prio,var,full,spec) d -> debug "bsbd: addint" $ addIntSpec d (prio,var,if full then Just eid else Nothing,spec)) dB $ debug ("lI["++(show $ length lI)++"]") lI-            dC = foldr (\(prio,var,full,spec) d -> debug "bsbd: addcol" $ addColSpec d (prio,var,if full then Just eid else Nothing,spec)) dI $ debug ("lC["++(show $ length lC)++"]") lC-            in dC-      newDb = foldl proc origDb ne-  put $ s { fdsDb = newDb }--addBoolTypeReq :: FDSolver s => EGVarId -> FDBoolSpecTypeSet s -> FDInstance s ()-addBoolTypeReq var set = do-  s <- get-  let chk tp = case Map.lookup var (fdsBoolVars s) of-            Nothing -> False-            Just x -> Set.member tp (fdspBoolTypes x)-      sset = Map.findWithDefault Set.empty var (fdsBoolVarTypes s)-  if Set.member set sset-    then return ()-    else if any chk (Set.toList set)-      then return ()-      else do-        let nsset = Set.insert set sset-        put $ s -          { -            fdsBoolVarTypes = Map.insert var nsset $ fdsBoolVarTypes s-          }--addIntTypeReq :: FDSolver s => EGVarId -> FDIntSpecTypeSet s -> FDInstance s ()-addIntTypeReq var set = do-  s <- get-  let chk tp = case Map.lookup var (fdsIntVars s) of-            Nothing -> False-            Just x -> Set.member tp (fdspIntTypes x)-      sset = Map.findWithDefault Set.empty var (fdsIntVarTypes s)-  if Set.member set sset-    then return ()-    else if any chk (Set.toList set)-      then return ()-      else do-        let nsset = Set.insert set sset-        put $ s -          { -            fdsIntVarTypes = Map.insert var nsset $ fdsIntVarTypes s-          }--addColTypeReq :: FDSolver s => EGVarId -> FDColSpecTypeSet s -> FDInstance s ()-addColTypeReq var set = do-  s <- get-  let chk tp = case Map.lookup var (fdsColVars s) of-            Nothing -> False-            Just x  -> Set.member tp (fdspColTypes x)-      sset = Map.findWithDefault Set.empty var (fdsColVarTypes s)-  if Set.member set sset-    then return ()-    else if any chk (Set.toList set)-      then return ()-      else do-        let nsset = Set.insert set sset-        put $ s -          {-            fdsColVarTypes = Map.insert var nsset (fdsColVarTypes s)-          }--addTypeReqs :: FDSolver s => FDInstance s ()-addTypeReqs = do-  s <- get-  fBool <- liftFD fdTypeReqBool-  fInt  <- liftFD fdTypeReqInt-  fCol  <- liftFD fdTypeReqCol-  let ne = map (\k -> getJustEdge k s) $ Set.toList $ fdsNewEdges s-      proc edge = do-        mapM_ (uncurry addBoolTypeReq) $ fBool edge-        mapM_ (uncurry addIntTypeReq) $ fInt edge-        mapM_ (uncurry addColTypeReq) $ fCol edge-  mapM_ proc ne--processEx :: FDSolver s => Bool -> FDInstance s ()-processEx x = do-        ssm1 <- get-        let ss0 = ssm1 { fdsModel = Just $ pruneNodes $ myFromJust "processEx" $ fdsModel ssm1 }-        debug ("process ["++(show $ fdsLevel ss0)++"]") $ return ()-        -- search spec type requirements for all to-be-processed edges-        debug ("addTypeReqs ["++(show $ fdsLevel ss0)++"]") $ addTypeReqs-        -- optimize type requirements-        debug ("optimizeVarTypes["++(show $ fdsLevel ss0)++"]") $ optimizeVarTypes-        ss <- get-        debug ("DUMP type reqs ["++(show $ fdsLevel ss0)++"]: "++(show $ fdsIntVarTypes ss)) $ return ()-        -- build specifier database for all to-be-processed edges-        debug ("buildSpecDb ["++(show $ fdsLevel ss0)++"]") $ buildSpecDb-        ss2 <- get-        debug ("DUMP spec db ["++(show $ fdsLevel ss0)++"]: "++(show $ fdsDb ss2)) $ return ()-        -- create as much specifiers as possible (marking consumed edges as processed)-        whileM_ $ debug ("decompBest ["++(show $ fdsLevel ss0)++"]") decompBest-        -- try default specifier for remaining boolean nodes (=create new underlying term for each)-        whileM_ $ debug ("decompDefBool ["++(show $ fdsLevel ss0)++"]") decompDefaultBool-        -- try default specifier for remaining integer nodes (=create new underlying term for each)-        whileM_ $ debug ("decompDefInt ["++(show $ fdsLevel ss0)++"]") decompDefaultInt-        ss3 <- get-        debug ("DUMP specs: "++(dumpSpec ss3)) $ return ()-        -- process remaining edges-        if x-          then whileM_ $ debug ("procEdge ["++(show $ fdsLevel ss0)++"]") procEdge-          else return ()--process :: FDSolver s => FDInstance s ()-process = processEx True--commit :: FDSolver s => FDInstance s ()-commit = do-  s <- get-  debug "begin commit" $ return ()-  case (fdsExpr s,fdsForceBool s,fdsForceInt s,fdsForceCol s) of-      (BoolConst True,[],[],[]) -> return ()-      (expr,_,_,_) -> do-        debug ("expr=["++(show expr)++"]") $ return ()-        let (dcd,graph,vars) = debug "decomposing" $ decomposeEx (fdsDecomp s) (fdsVars s) expr (fdsForceBool s,fdsForceInt s,fdsForceCol s) $ fdsModel s-        put $ s { fdsExpr = BoolConst True, fdsDecomp = dcd, fdsModel = Just graph, fdsForceBool=[], fdsForceInt=[], fdsForceCol=[], fdsVars = max vars (fdsVars s) }-        debug ("graph=["++(present graph)++"]"++"]") $ return ()-        -- mark all non-yet-processed edges as to-be-processed-        debug "initForModel" $ initForModel-        process--instance FDSolver s => Solver (FDInstance s) where-  type Constraint (FDInstance s) = Either Model (Constraint s)-  type Label (FDInstance s) = FDLabel s-  add (Left expr) = do-    s <- get-    if (fdsFailed s)-      then return False-      else do-        put $ s { fdsExpr = (fdsExpr s) @&& expr }-        return True-  add (Right col) = do-    s <- get-    if (fdsFailed s)-      then return False-      else do-        ret <- liftFD $ add col-        if ret-          then return True-          else do-            setFailed-            return False-  mark = do-    commit-    ss <- get-    sl <- liftFD mark-    return $ FDLabel { fdlState=ss, fdlLabel=sl }-  markn n = do-    commit-    ss <- get-    sl <- liftFD $ markn n-    return $ FDLabel { fdlState=ss, fdlLabel=sl }-  goto label = do-    liftFD $ goto $ fdlLabel label-    put $ fdlState label-  run x = run $ runFD x--instance FDSolver s => Term (FDInstance s) ModelInt where-  newvar = do-    s <- get-    let i = fdsVars s-    put $ s { fdsVars = 1+i }-    return $ Term $ ModelIntVar i-  type Help (FDInstance s) ModelInt = ()-  help _ _ = ()--instance FDSolver s => Term (FDInstance s) ModelBool where-  newvar = do-    s <- get-    let i = fdsVars s-    put $ s { fdsVars = 1+i }-    return $ BoolTerm $ ModelBoolVar i-  type Help (FDInstance s) ModelBool = ()-  help _ _ = ()--instance FDSolver s => Term (FDInstance s) ModelCol where-  newvar = do-    s <- get-    let i = fdsVars s-    put $ s { fdsVars = 1+i }-    return $ ColTerm $ ModelColVar i-  type Help (FDInstance s) ModelCol = ()-  help _ _ = ()--newCol :: FDSolver s => FDInstance s ModelCol-newCol = newvar--newInt :: FDSolver s => FDInstance s ModelInt-newInt = newvar--newBool :: FDSolver s => FDInstance s ModelBool-newBool = newvar--combine :: [Maybe a] -> [a] -> [a]-combine [] _ = []-combine (Nothing:r) (a:b) = a:(combine r b)-combine (Just x:r) b = x:(combine r b)--realGetIntTerm :: FDSolver s => [ModelInt] -> FDInstance s [FDIntTerm s]-realGetIntTerm m = do-  s <- debug ("realGetIntTerm: "++(show m)) $ get-  put $ s { fdsForceInt = m++(fdsForceInt s) }-  commit-  s2 <- get-  let ids = map (\x -> decompIntLookup (fdsDecomp s2) x) m-  tp <- liftFD $ fdTypeVarInt-  specs <- mapM (\(Just id) -> getIntSpec_ id tp) ids-  vars <- mapM (\(Just (_,spec)) -> liftFD $ fdIntVarSpec spec) specs-  let rvars = map (\(Just x) -> x) vars-  s3 <- get-  put $ s3 { fdsForcedInt = Map.union (fdsForcedInt s3) (Map.fromList $ zip m rvars) }-  return rvars--getSingleIntTerm :: FDSolver s => ModelInt -> FDInstance s (FDIntTerm s)-getSingleIntTerm m = do-  s <- get-  case Map.lookup m (fdsForcedInt s) of-    Nothing -> realGetIntTerm [m] >>= return.head-    Just d -> return d--getIntTerm :: FDSolver s => [ModelInt] -> FDInstance s [FDIntTerm s]-getIntTerm m = do-  s <- get-  let lo = map (\x -> (x,Map.lookup x $ fdsForcedInt s)) m-  let go = map fst $ filter (\(_,x) -> isNothing x) lo-  vo <- case go of-    [] -> return []-    _ -> realGetIntTerm go-  return $ combine (map snd lo) vo--realGetBoolTerm :: FDSolver s => [ModelBool] -> FDInstance s [FDBoolTerm s]-realGetBoolTerm m = do-  s <- get-  put $ s { fdsForceBool = m++(fdsForceBool s) }-  commit-  s2 <- get-  let ids = map (\x -> decompBoolLookup (fdsDecomp s2) x) m-  tp <- liftFD $ fdTypeVarBool-  specs <- mapM (\(Just id) -> getBoolSpec_ id tp) ids-  vars <- mapM (\(Just (_,spec)) -> liftFD $ fdBoolVarSpec spec) specs-  let rvars = map (\(Just x) -> x) vars-  s3 <- get-  put $ s3 { fdsForcedBool = Map.union (fdsForcedBool s3) (Map.fromList $ zip m rvars) }-  return rvars--getBoolTerm :: FDSolver s => [ModelBool] -> FDInstance s [FDBoolTerm s]-getBoolTerm m = do-  s <- get-  let lo = map (\x -> (x,Map.lookup x $ fdsForcedBool s)) m-  let go = map fst $ filter (\(_,x) -> isNothing x) lo-  vo <- case go of-    [] -> return []-    _ -> realGetBoolTerm go-  return $ combine (map snd lo) vo--getColTerm :: FDSolver s => [ModelCol] -> FDColSpecType s -> FDInstance s [FDColSpec s]-getColTerm m tp = do-  s <- get-  put $ s { fdsForceCol = m++(fdsForceCol s) }-  commit-  s2 <- get-  let ids = map (\x -> decompColLookup (fdsDecomp s2) x) m-  specs <- mapM (\(Just id) -> getColSpec_ id (Set.singleton tp)) ids-  return $ map (snd . myFromJust ("getColTerm(tp="++(show tp)++")")) specs--getColItems :: FDSolver s => ModelCol -> FDColSpecType s -> FDInstance s [FDIntTerm s]-getColItems c tp = do-  [cc] <- getColTerm [c] tp-  lst <- liftFD $ fdColInspect cc-  return lst--instance (FDSolver s, EnumTerm s (FDIntTerm s)) => EnumTerm (FDInstance s) ModelInt where-  type TermBaseType (FDInstance s) ModelInt = TermBaseType s (FDIntTerm s)-  getDomainSize v = do-    f <- getFailed-    if f -      then return 0-      else do-        var <- getSingleIntTerm v-        liftFD $ getDomainSize var-  getValue v = do-    var <- getSingleIntTerm v-    liftFD $ getValue var---  setValue var val = return [var @== cte val]-  setValue _ = error "setting of boolean variable through FD interface is not implemented"-  getDomain var = error "retrieval of full domain not implemented in FD"-  splitDomain v = do-    var <- getSingleIntTerm v-    (doms,full) <- liftFD $ fdSplitIntDomain var-    return (map (\x -> [Right x]) doms, full)-  enumerator = case enumerator of-    Nothing -> Nothing-    Just e -> Just $ \l -> label $ do-      f <- getFailed-      if f-        then return false-        else do-          ll <- getIntTerm l-          return $ liftFDTree $ e ll--instance (FDSolver s, EnumTerm s (FDBoolTerm s)) => EnumTerm (FDInstance s) ModelBool where-  type TermBaseType (FDInstance s) ModelBool = TermBaseType s (FDBoolTerm s)-  getDomainSize v = do-    f <- getFailed-    if f-      then return 0-      else do-        [var] <- getBoolTerm [v]-        liftFD $ getDomainSize var-  getValue v = do-    [var] <- getBoolTerm [v]-    liftFD $ getValue var---  setValue var val = return [var @= BoolConst (val /]-  setValue _ = error "setting of boolean variable through FD interface is not implemented"-  getDomain var = error "retrieval of full boolean domain not implemented in FD"-  splitDomain v = do-    [var] <- getBoolTerm [v]-    (doms,full) <- liftFD $ fdSplitBoolDomain var-    return (map (\x -> [Right x]) doms, full)-  enumerator = case enumerator of-    Nothing -> Nothing-    Just e -> Just $ \l -> label $ do-      f <- getFailed-      if f-        then return false-        else do-          ll <- getBoolTerm l-          return $ liftFDTree $ e ll--getIntVal_ :: FDSolver s => EGVarId -> FDState s -> Maybe EGPar-getIntVal_ id s =-  let r1 = -        case Map.lookup id (fdsIntVars s) of-          Nothing -> Nothing-          Just x -> fdspIntVal x-      in case r1 of-        Nothing ->-          let Just j = fdsModel s-              ei = findEdge j EGIntType id (==0) (\x -> case x of { EGIntValue _ -> True; _ -> False })-              in case ei of-                Nothing -> Nothing-                Just (_,ed) -> case egeCons ed of { EGIntValue c -> Just c }-        Just x -> r1--getIntVal :: FDSolver s => EGVarId -> FDInstance s (Maybe EGPar)-getIntVal id = gets $ getIntVal_ id--getBoolVal_ :: FDSolver s => EGVarId -> FDState s -> Maybe EGBoolPar-getBoolVal_ id s =-  let r1 = -        case Map.lookup id (fdsBoolVars s) of-          Nothing -> Nothing-          Just x -> fdspBoolVal x-      in case r1 of-        Nothing ->-          let Just j = fdsModel s-              l = getConnectedEdges j EGBoolType id-              f (EGEdge { egeCons = EGBoolValue c },_) _ = Just c-              f _ s = s-              in foldr f Nothing l-        Just x -> r1--getBoolVal :: FDSolver s => EGVarId -> FDInstance s (Maybe EGBoolPar)-getBoolVal id = gets $ getBoolVal_ id--getColVal_ :: FDSolver s => EGVarId -> FDState s -> Maybe EGColPar-getColVal_ id s =-  let r1 = -        case Map.lookup id (fdsColVars s) of-          Nothing -> Nothing-          Just x -> fdspColVal x-      in case r1 of-        Nothing ->-          let Just j = fdsModel s-              l = getConnectedEdges j EGColType id-              f (EGEdge { egeCons = EGColValue c },_) _ = Just c-              f _ s = s-              in foldr f Nothing l-        Just x -> r1--getColVal :: FDSolver s => EGVarId -> FDInstance s (Maybe EGColPar)-getColVal id = gets $ getColVal_ id--setFailed :: FDSolver s => FDInstance s ()-setFailed = do -  s <- get-  debug "setFailed!" $ return ()-  put $ s { fdsFailed = True }--getFailed :: FDSolver s => FDInstance s Bool-getFailed = do-  s <- get-  return $ fdsFailed s--addFD :: (Show (Constraint s), FDSolver s) => Constraint s -> FDInstance s ()-addFD c = do-  s <- get-  if (fdsFailed s)-    then debug ("addFD("++(show c)++"): already failed") $ return ()-    else do-      x <- liftFD $ add c-      debug ("addFD("++(show c)++"): result="++(show x)) $ return ()-      if not x then setFailed else return ()--getDefIntSpec :: FDSolver s => FDSpecInfoInt s -> FDIntSpec s-getDefIntSpec (FDSpecInfoInt { fdspIntSpec = f }) = case f Nothing of-  Just t -> t-  Nothing -> error "getDefIntSpec: no spec"--getDefBoolSpec :: FDSolver s => FDSpecInfoBool s -> FDBoolSpec s-getDefBoolSpec (FDSpecInfoBool { fdspBoolSpec = f }) = case f Nothing of-  Just t -> t-  Nothing -> error "getDefBoolSpec: no spec"--getDefColSpec :: FDSolver s => FDSpecInfoCol s -> FDColSpec s-getDefColSpec (FDSpecInfoCol { fdspColSpec = f }) = case f Nothing of-  Just t -> t-  Nothing -> error "getDefColSpec: no spec"---- getFullIntSpec :: FDSolver s => EGVarId -> s (FDSpecInfoInt s)-getFullIntSpec id = do-  s <- get-  return $ myFromJust "getFullIntSpec" $ Map.lookup id $ fdsIntVars s---- getFullBoolSpec :: FDSolver s => EGVarId -> s (FDSpecInfoBool s)-getFullBoolSpec id = do-  s <- get-  return $ myFromJust "getFullBoolSpec" $ Map.lookup id $ fdsBoolVars s---- getFullColSpec :: FDSolver s => EGVarId -> s (FDSpecInfoCol s)-getFullColSpec id = do-  s <- get-  return $ myFromJust "getFullColSpec" $ Map.lookup id $ fdsColVars s--fdNewvar :: (FDSolver s, Term s t) => FDInstance s (Maybe t)-fdNewvar = do-  s <- get-  if fdsDummyLevel s > 0-    then return Nothing-    else liftFD newvar >>= return . Just

− Control/CP/FD/Graph.hs

@@ -1,411 +0,0 @@-{- - - 	Monadic Constraint Programming- - 	http://www.cs.kuleuven.be/~toms/MCP/- - 	Pieter Wuille- -}--{-# LANGUAGE RankNTypes #-}-{-# LANGUAGE GeneralizedNewtypeDeriving #-}-{-# LANGUAGE StandaloneDeriving #-}-{-# LANGUAGE FlexibleInstances #-}--module Control.CP.FD.Graph (-  EGConstraintSpec(..),-  EGParTerm(..),-  EGParBoolTerm(..),-  EGParColTerm(..),-  EGPar, EGBoolPar, EGColPar,-  EGConsArgs,-  EGEdgeId,-  EGVarId(..),-  EGVarType(..),-  EGTypeData(..),-  EGEdge(..),-  EGModel(..),-  addEdge,-  addNode,-  delNode,-  findEdge,-  unifyNodes,-  unifyIds,-  baseGraph,-  baseTypeData,-  egTypeDataMap, egTypeGet, egTypeMod,-  present,-  getConnectedEdges,-  externMap, filterModel, emptyModel, pruneNodes,-) where--import Control.Monad (foldM)--import Data.Maybe (fromJust)-import Data.Map (Map)-import qualified Data.Map as Map--import Data.Expr.Data--- import Control.CP.FD.Expr.Util---- BoolEqual, Rel _ (EREqual) _, ColEqual are encoded in the graph itself, and--- not represented as constraints between them--data EGVarType = -    EGBoolType-  | EGIntType-  | EGColType-  deriving (Eq,Show)---- instance KeyableExpr EGConstraintSpec where---  keyCompare a b = compare a b--data EGConstraintSpec =-    EGIntValue EGPar                 -- i0 == p-  | EGBoolValue EGBoolPar            -- b0 == p-  | EGColValue EGColPar              -- c0 == p-  | EGIntExtern Int                  -- super[p] == i0-  | EGBoolExtern Int                 -- super[p] == b0-  | EGColExtern Int                  -- super[p] == c0-  | EGPlus                           -- i0==i1+i2-  | EGMinus                          -- i0==i1-i2-  | EGMult                           -- i0==i1*i2-  | EGDiv                            -- i0==i1/i2   {- (i0==i1/i2) is NOT the same as (i1==i0*i2) -}-  | EGMod                            -- i0==i1%i2  -  | EGAbs                            -- i0==abs(i1)-  | EGAt                             -- i0==c0[i1]-  | EGFold EGModel (Int,Int,Int)     -- i0==fold(p,i1,c0)  {- inner intExtern(-1) is fold-function's return value, intExtern(-2) is the accumulator, intExtern(-3) is the argument -}-  | EGSize                           -- i0==size(c0)-  | EGChannel                        -- int(b0) == i0-  | EGList Int                       -- c0 == [i0,i1,i2,...] (len p) -  | EGRange                          -- c0 == [i0..i1]-  | EGMap EGModel (Int,Int,Int)      -- c0 == map(p,c1)    {- inner intExtern(-1) is map-function's return value, intExtern(-2) is its argument -}-  | EGSlice EGModel (Int,Int,Int)    -- c0 == c1[f(0)...f(i0-1)]; inner model defines f: intExtern(-1) is return value, intExtern(-2) is its argument---  | EGSlice (EGPar -> EGPar) EGPar   -- c0 == c1[f(0)...f(n-1)]-  | EGCat                            -- c0 == c1++c2-  | EGAnd                            -- b0 == b1 && b2-  | EGOr                             -- b0 == b1 || b2-  | EGEquiv                          -- b0 == (b1 == b2)-  | EGNot                            -- b0 == !b1-  | EGEqual                          -- b0 <-> i0 == i1-  | EGDiff                           -- b0 <-> i0 /= i1-  | EGLess Bool                      -- false: b0 <-> i0 <= i1 ; true: b0 <-> i0 < i1-  | EGAll EGModel (Int,Int,Int) Bool -- b0 <-> foreach (i from c0): p(i)  {- inner boolExtern(-1) is truth value of predicate, intExtern(-1) is its argument; bool is true if all inner predicates need to be true -}-  | EGAny EGModel (Int,Int,Int) Bool -- b0 <-> forany (i from c0): p(i)   {- inner boolExtern(-1) is truth value of predicate, intExtern(-1) is its argument; bool is true if all inner predicates need to be false -}---  | EGAllC EGModel (Int,Int,Int) Bool -- b0 <-> foreach (i from [i0,i1]: p(i) {- inner boolExtern(-1) is truth value of predicate, intExtern(-1) is its (constant) argument; bool is true if all inner predicates need to be true -}---  | EGAnyC EGModel (Int,Int,Int) Bool -- b0 <-> foreach (i from [i0,i1]: p(i) {- inner boolExtern(-1) is truth value of predicate, intExtern(-1) is its (constant) argument; bool is true if all inner predicates need to be true -}-  | EGSorted Bool                    -- c0 is increasing (false), or strictly increasing (true)-  | EGAllDiff Bool                   -- c0 is all different (b0 means: use in consistency)-  | EGDom                            -- i0 is any of c0-  | EGCondEqual                      -- b0 ? (b1==b2) : true-  | EGCondInt                        -- i0 = b0 ? i1 : i2-  deriving (Eq,Show)--instance Ord (EGPar -> EGPar) where-  compare a b = compare (a (Term (EGPTParam (-1)))) (b (Term (EGPTParam (-1))))--instance Eq (EGPar -> EGPar) where-  a == b = (a (Term (EGPTParam (-1)))) == (b (Term (EGPTParam (-1))))--instance Show (EGPar -> EGPar) where-  show f = show $ f (Term (EGPTParam (-1)))--dummyConstraint :: EGConstraintSpec -> Bool-dummyConstraint c = case c of-  EGIntExtern _ -> True-  EGBoolExtern _ -> True-  EGColExtern _ -> True-  _ -> False--data EGParTerm =-    EGPTParam Int-  deriving (Show,Eq,Ord)-  -data EGParBoolTerm =-    EGPTBoolParam Int-  deriving (Show,Eq,Ord)--data EGParColTerm =-    EGPTColParam Int-  deriving (Show,Eq,Ord)--type EGPar =     Expr     EGParTerm EGParColTerm EGParBoolTerm-type EGBoolPar = BoolExpr EGParTerm EGParColTerm EGParBoolTerm-type EGColPar =  ColExpr  EGParTerm EGParColTerm EGParBoolTerm---- Bools, Ints, Cols-type EGConsArgs = (Int,Int,Int)--getConsArgs :: EGConstraintSpec -> EGTypeData Int-getConsArgs x = case-  case x of-    EGBoolValue _    -> (1,0,0)-    EGIntValue _     -> (0,1,0)-    EGColValue _     -> (0,0,1)-    EGIntExtern _    -> (0,1,0)-    EGBoolExtern _   -> (1,0,0)-    EGColExtern _    -> (0,0,1)-    EGPlus           -> (0,3,0)-    EGMinus          -> (0,3,0)-    EGMult           -> (0,3,0)-    EGDiv            -> (0,3,0)-    EGMod            -> (0,3,0)-    EGAbs            -> (0,2,0)-    EGAt             -> (0,2,1)-    EGFold _ (a,b,c) -> (a,2+b,1+c)-    EGSize           -> (0,1,1)-    EGChannel        -> (1,1,0)-    EGList n         -> (0,n,1)-    EGRange          -> (0,2,1)-    EGMap _ (a,b,c)  -> (a,b,2+c)-    EGSlice _ (a,b,c) -> (a,1+b,2+c)-    EGCat            -> (0,0,3)-    EGAnd            -> (3,0,0)-    EGOr             -> (3,0,0)-    EGEquiv          -> (3,0,0)-    EGNot            -> (2,0,0)-    EGEqual          -> (1,2,0)-    EGDiff           -> (1,2,0)-    EGLess _         -> (1,2,0)-    EGAll _ (a,b,c) _ -> (1+a,b,1+c)-    EGAny _ (a,b,c) _ -> (1+a,b,1+c)---    EGAllC _ (a,b,c) _ -> (1+a,2+b,c)---    EGAnyC _ (a,b,c) _ -> (1+a,2+b,c)-    EGSorted _       -> (0,0,1)-    EGAllDiff _      -> (0,0,1)-    EGDom            -> (0,1,1)-    EGCondEqual      -> (3,0,0)-    EGCondInt        -> (1,3,0)-  of (a,b,c) -> EGTypeData { boolData = a, intData = b, colData =c }--newtype EGEdgeId = EGEdgeId { unEGEdgeId :: Int }-  deriving (Eq,Ord,Show)--data EGVarId = EGVarId { unVarId :: Int }-  deriving (Eq,Ord,Show)--data EGTypeData x = EGTypeData {-  boolData :: x,-  intData :: x,-  colData :: x-}--deriving instance Show x => Show (EGTypeData x)-deriving instance Eq x => Eq (EGTypeData x)--baseTypeData :: x -> EGTypeData x-baseTypeData x = EGTypeData {-  boolData = x,-  intData = x,-  colData = x-}--egTypeDataMap :: ((forall a. EGTypeData a -> a) -> b) -> EGTypeData b-egTypeDataMap f = EGTypeData {-  boolData = f boolData,-  intData = f intData,-  colData = f colData-}--egTypeGet :: EGVarType -> EGTypeData a -> a-egTypeGet EGBoolType = boolData-egTypeGet EGIntType = intData-egTypeGet EGColType = colData--egTypeMod :: EGVarType -> EGTypeData a -> (a -> a) -> EGTypeData a-egTypeMod EGBoolType d f = d { boolData = f $ boolData d }-egTypeMod EGIntType d f = d { intData = f $ intData d }-egTypeMod EGColType d f = d { colData = f $ colData d }--data EGEdge = EGEdge {-  egeCons :: EGConstraintSpec,-  egeLinks :: EGTypeData [EGVarId]-} deriving (Eq,Show)--showBool :: EGVarId -> String-showBool (EGVarId i) = "b" ++ (show i)-showInt :: EGVarId -> String-showInt (EGVarId i) = "i" ++ (show i)-showCol :: EGVarId -> String-showCol (EGVarId i) = "c" ++ (show i)--showLst :: (EGVarId -> String) -> [EGVarId] -> String-showLst _ [] = "[]"-showLst f x = "[" ++ (foldl1 (\x y -> x ++ "," ++ y) $ map f x) ++ "]"--instance Display EGEdge where-  displayer (EGEdge { egeCons = EGBoolValue i, egeLinks = EGTypeData { boolData = [l] } }) = displaySingle $ (showBool l) ++ " == " ++ "#["++(show i)++"]"-  displayer (EGEdge { egeCons = EGIntValue i, egeLinks =  EGTypeData { intData = [l] }}) = displaySingle $ (showInt l) ++ " == " ++ "#["++(show i)++"]"-  displayer (EGEdge { egeCons = EGColValue i, egeLinks =  EGTypeData { colData = [l] }}) = displaySingle $ (showCol l) ++ " == " ++ "#["++(show i)++"]"-  displayer (EGEdge { egeCons = EGBoolExtern i, egeLinks = EGTypeData  { boolData = [l] }}) = displaySingle $ (showBool l) ++ " == parentBool[" ++ (show i) ++ "]"-  displayer (EGEdge { egeCons = EGIntExtern i, egeLinks =  EGTypeData { intData = [l] }}) = displaySingle $ (showInt l) ++ " == parentInt[" ++ (show i) ++ "]"-  displayer (EGEdge { egeCons = EGColExtern i, egeLinks = EGTypeData  { colData = [l] }}) = displaySingle $ (showCol l) ++ " == parentCol[" ++ (show i) ++ "]"-  displayer (EGEdge { egeCons = EGPlus, egeLinks =  EGTypeData { intData=[a,b,c] }}) = displaySingle $ (showInt a) ++ " == " ++ (showInt b) ++ " + " ++ (showInt c)-  displayer (EGEdge { egeCons = EGMinus, egeLinks =  EGTypeData { intData=[a,b,c] }}) = displaySingle $ (showInt a) ++ " == " ++ (showInt b) ++ " - " ++ (showInt c)-  displayer (EGEdge { egeCons = EGMult, egeLinks =  EGTypeData { intData=[a,b,c] }}) = displaySingle $ (showInt a) ++ " == " ++ (showInt b) ++ " * " ++ (showInt c)-  displayer (EGEdge { egeCons = EGDiv, egeLinks =  EGTypeData { intData=[a,b,c] }}) = displaySingle $ (showInt a) ++ " == " ++ (showInt b) ++ " / " ++ (showInt c)-  displayer (EGEdge { egeCons = EGMod, egeLinks =  EGTypeData { intData=[a,b,c] }}) = displaySingle $ (showInt a) ++ " == " ++ (showInt b) ++ " % " ++ (showInt c)-  displayer (EGEdge { egeCons = EGAbs, egeLinks =  EGTypeData { intData=[a,b] }}) = displaySingle $ (showInt a) ++ " == abs(" ++ (showInt b) ++ ")"-  displayer (EGEdge { egeCons = EGAt, egeLinks =  EGTypeData { intData=[a,b], colData=[c] }}) = displaySingle $ (showInt a) ++ " == " ++ (showCol c) ++ "[" ++ (showInt b) ++ "]"-  displayer (EGEdge { egeCons = EGSize, egeLinks =  EGTypeData { intData=[a], colData=[c] }}) = displaySingle $ (showInt a) ++ " == size(" ++ (showCol c) ++ ")"-  displayer (EGEdge { egeCons = EGDom, egeLinks =  EGTypeData { intData=[a], colData=[c] }}) = displaySingle $ ("dom(" ++ (showInt a) ++ ") == " ++ (showCol c))-  displayer (EGEdge { egeCons = EGChannel, egeLinks =  EGTypeData { boolData=[a], intData=[b] }}) = displaySingle $ (showBool a) ++ " == " ++ (showInt b)-  displayer (EGEdge { egeCons = EGList 0, egeLinks =  EGTypeData { colData=[c] }}) = displaySingle $ (showCol c) ++ " == []"-  displayer (EGEdge { egeCons = EGList _, egeLinks =  EGTypeData { intData=l, colData=[c] }}) = displaySingle $ (showCol c) ++ " == ["++(foldl1 (\a b -> a ++","++b) $ map showInt l)++"]"-  displayer (EGEdge { egeCons = EGAllDiff _, egeLinks =  EGTypeData { colData=[c] }}) = displaySingle $ "allDiff " ++ (showCol c)-  displayer (EGEdge { egeCons = EGSorted b, egeLinks =  EGTypeData { colData=[c] }}) = displaySingle $ "sorted " ++ (show b) ++ " " ++ (showCol c)-  displayer (EGEdge { egeCons = EGRange, egeLinks =  EGTypeData { intData=[l,h], colData=[c] }}) = displaySingle $ (showCol c) ++ " == ["++(showInt l)++".."++(showInt h)++"]"---  displayer (EGEdge { egeCons = EGSlice f n, egeLinks =  EGTypeData { colData=[c,o] }}) = displaySingle $ (showCol c) ++ " == "++(showCol o)++"[f(0)..f("++(show n)++"-1)]"-  displayer (EGEdge { egeCons = EGCat, egeLinks =  EGTypeData { colData=[c,a,b] }}) = displaySingle $ (showCol c) ++ " == "++(showCol a)++"++"++(showCol b)-  displayer (EGEdge { egeCons = EGAnd, egeLinks =  EGTypeData { boolData=[c,a,b] }}) = displaySingle $ (showBool c) ++ " == "++(showBool a)++" && "++(showBool b)-  displayer (EGEdge { egeCons = EGOr, egeLinks =  EGTypeData { boolData=[c,a,b] }}) = displaySingle $ (showBool c) ++ " == "++(showBool a)++" || "++(showBool b)-  displayer (EGEdge { egeCons = EGEquiv, egeLinks =  EGTypeData { boolData=[c,a,b] }}) = displaySingle $ (showBool c) ++ " == ("++(showBool a)++" == "++(showBool b)++")"-  displayer (EGEdge { egeCons = EGNot, egeLinks =  EGTypeData { boolData=[c,a] }}) = displaySingle $ (showBool c) ++ " == !"++(showBool a)-  displayer (EGEdge { egeCons = EGEqual, egeLinks =  EGTypeData { boolData=[r], intData=[a,b] }}) = displaySingle $ (showBool r) ++ " == ("++(showInt a)++" == "++(showInt b)++")"-  displayer (EGEdge { egeCons = EGDiff, egeLinks =  EGTypeData { boolData=[r], intData=[a,b] }}) = displaySingle $ (showBool r) ++ " == ("++(showInt a)++" != "++(showInt b)++")"-  displayer (EGEdge { egeCons = EGLess q, egeLinks =  EGTypeData { boolData=[r], intData=[a,b] }}) = displaySingle $ (showBool r) ++ " == ("++(showInt a)++(if q then " < " else " <= ")++(showInt b)++")"-  displayer (EGEdge { egeCons = EGAll s _ _, egeLinks = EGTypeData { boolData=r:ab, intData=ai, colData=c:ac }}) = DisplayData ((showBool r)++" == forall("++(showCol c)++") "++(showLst showBool ab)++" "++(showLst showInt ai)++" "++(showLst showCol ac),[displayer s])-  displayer (EGEdge { egeCons = EGAny s _ _, egeLinks = EGTypeData { boolData=r:ab, intData=ai, colData=c:ac }}) = DisplayData ((showBool r)++" == forany("++(showCol c)++") "++(showLst showBool ab)++" "++(showLst showInt ai)++" "++(showLst showCol ac),[displayer s])---  displayer (EGEdge { egeCons = EGAllC s _ _, egeLinks = EGTypeData { boolData=r:ab, intData=l:h:ai, colData=ac }}) = DisplayData ((showBool r)++" == forall("++(showInt l)++".."++(showInt h)++") "++(showLst showBool ab)++" "++(showLst showInt ai)++" "++(showLst showCol ac),[displayer s])---  displayer (EGEdge { egeCons = EGAnyC s _ _, egeLinks = EGTypeData { boolData=r:ab, intData=l:h:ai, colData=ac }}) = DisplayData ((showBool r)++" == forany("++(showInt l)++".."++(showInt h)++") "++(showLst showBool ab)++" "++(showLst showInt ai)++" "++(showLst showCol ac),[displayer s])-  displayer (EGEdge { egeCons = EGMap s _, egeLinks = EGTypeData { boolData=ab, intData=ai, colData=r:c:ac }}) = DisplayData ((showCol r)++" == map("++(showCol c)++") "++(showLst showBool ab)++" "++(showLst showInt ai)++" "++(showLst showCol ac),[displayer s])-  displayer (EGEdge { egeCons = EGSlice s _, egeLinks = EGTypeData { boolData=ab, intData=n:ai, colData=r:c:ac }}) = DisplayData ((showCol r)++" == slice("++(showCol c)++",0..("++(showInt n)++")-1) "++(showLst showBool ab)++" "++(showLst showInt ai)++" "++(showLst showCol ac),[displayer s])-  displayer (EGEdge { egeCons = EGFold s _, egeLinks = EGTypeData { boolData=ab, intData=r:i:ai, colData=c:ac }}) = DisplayData ((showInt r)++" == fold("++(showCol c)++","++(showInt i)++") "++(showLst showBool ab)++" "++(showLst showInt ai)++" "++(showLst showCol ac),[displayer s])-  displayer (EGEdge { egeCons = EGCondInt, egeLinks = EGTypeData { boolData=[c], intData=[r,t,f] }}) = displaySingle $ (showInt r) ++ " = (if " ++ (showBool c) ++" then (" ++ (showInt t) ++ ") else (" ++ (showInt f)++"))"-  displayer (EGEdge { egeCons = EGCondEqual, egeLinks = EGTypeData { boolData=[c,a,b] }}) = displaySingle $ "if " ++ (showBool c) ++" then " ++ (showBool a) ++ "=="++(showBool b)-  displayer (EGEdge { egeCons = c })  = DisplayData ("???("++(show c)++")",[])--externMap :: EGModel -> EGTypeData (Map Int EGVarId)-externMap md = foldr f (baseTypeData Map.empty) $ map snd $ Map.toList $ egmEdges md-  where f :: EGEdge -> EGTypeData (Map Int EGVarId) -> EGTypeData (Map Int EGVarId)-        f (EGEdge { egeCons = EGIntExtern i, egeLinks = EGTypeData { intData = [v] } }) st = egTypeMod EGIntType st $ \m -> Map.insert i v m-        f (EGEdge { egeCons = EGBoolExtern i, egeLinks = EGTypeData { boolData = [v] } }) st = egTypeMod EGBoolType st $ \m -> Map.insert i v m-        f (EGEdge { egeCons = EGColExtern i, egeLinks = EGTypeData { colData = [v] } }) st = egTypeMod EGColType st $ \m -> Map.insert i v m-        f _ st = st--emptyModel :: EGModel -> Bool-emptyModel mod = -  let mm = externMap mod-      ss = Map.size (intData mm) + Map.size (colData mm) + Map.size (boolData mm)-      in ss == (Map.size $ egmEdges mod)--data EGModel = EGModel {-  egmParams :: EGTypeData Int,-  egmVars :: EGTypeData Int,-  egmNEdges :: Int,-  egmEdges :: Map EGEdgeId EGEdge,-  egmLinks :: EGTypeData (Map EGVarId [(EGEdgeId,Int)])-} deriving (Eq,Show)--filterModel :: EGModel -> (EGEdge -> Maybe a) -> (EGModel,[a])-filterModel mod f = foldl ff (mod,[]) $ Map.toList $ egmEdges mod-  where ff (mm,n) (id,ed) = -           let res = f ed-               in case res of-                 Nothing -> (mm,n)-                 Just a -> (delEdge id mm,a:n)--prefix :: String -> DisplayData -> DisplayData-prefix s (DisplayData (s1,x)) = DisplayData (s++s1,x)--instance Display EGModel where-  displayer (EGModel { egmEdges = x }) = DisplayData ("EGModel",map (\(id,x) -> prefix ((show $ unEGEdgeId id)++": ") $ displayer x) $ Map.toList x)--addEdge :: EGConstraintSpec -> EGTypeData [EGVarId] -> EGModel -> EGModel-addEdge cons links model = -  if (expected == getConsArgs cons)-    then-      let newEdgeId = EGEdgeId $ egmNEdges model-          in model {-               egmNEdges = egmNEdges model + 1,-               egmEdges = Map.insert newEdgeId (EGEdge { egeCons = cons, egeLinks = links }) $ egmEdges model,-               egmLinks = egTypeDataMap $ \f -> -                 foldr (\i ->-                     Map.insertWith (++) ((f links) !! i) [(newEdgeId,i)]-                   ) (f $ egmLinks model) [0..(length (f links) - 1)]-             }-    else-      error $ "incorrect number of arguments for constraint ("++(show cons)++")"-  where expected = egTypeDataMap (\f -> length $ f links)--unifyIds :: EGVarId -> EGVarId -> EGVarId -> EGVarId--- unifyIds fromId toId = (\x -> if x>fromId then x-1 else x) . (\x -> if x==fromId then toId else x)-unifyIds fromId toId = \x -> if x==fromId then toId else x--delEdge :: EGEdgeId -> EGModel -> EGModel-delEdge id mod = do-  let fnd = Map.lookup id $ egmEdges mod-  case fnd of-    Nothing -> error "deleting inexisting edge"-    Just ff -> do-      let nmp = Map.delete id $ egmEdges mod-          mif [] = Nothing-          mif x = Just x-          afn = mif . filter ((/=id) . fst)-          nln = egTypeDataMap $ \f -> foldr (\vid pre -> Map.alter (\(Just x) -> afn x) vid pre) (f $ egmLinks mod) $ f $ egeLinks ff-      mod { egmEdges = nmp, egmLinks = nln }--findEdge :: EGModel -> EGVarType -> EGVarId -> (Int -> Bool) -> (EGConstraintSpec -> Bool) -> Maybe (EGEdgeId,EGEdge)-findEdge model typ varid pos cons =-  let mtc1 = Map.findWithDefault [] varid $ egTypeGet typ $ egmLinks model-      mtc2 = filter (\(_,p) -> pos p) mtc1-      mtc3 = map (\(id,_) -> -        (id,case Map.lookup id (egmEdges model) of-          Nothing -> error $ "cannot find edge id="++(show id)-          Just xx -> xx-        )) mtc2-      mtc4 = filter (\(_,s) -> cons $ egeCons s) mtc3-      in case mtc4 of-        [] -> Nothing-        a:_ -> Just a--pruneNodes :: EGModel -> EGModel-pruneNodes mod = -  mod { egmLinks = egTypeDataMap $ \f -> Map.fromList $ filter (\(_,v) -> case v of [] -> True; _ -> False) $ Map.toList $ f $ egmLinks mod }--unifyNodes :: EGVarType -> EGVarId -> EGVarId -> EGModel -> EGModel-unifyNodes vt fromId toId model = model {---  egmVars = egTypeMod vt (egmVars model) pred,-  egmEdges = Map.map (\x -> x {-    egeLinks = egTypeMod vt (egeLinks x) $ \z -> -      map (unifyIds fromId toId) z-  }) $ egmEdges model,-  egmLinks = egTypeMod vt (egmLinks model) $ \x -> Map.insertWith (++) toId (Map.findWithDefault [] fromId x) x-}--addNode :: EGVarType -> EGModel -> (EGVarId,EGModel)-addNode vt model = (-    EGVarId (egTypeGet vt $ egmVars model),-    model {-      egmVars = egTypeMod vt (egmVars model) succ-    }-  )--delNode :: EGVarType -> EGVarId -> EGModel -> EGModel-delNode vt id model = model { egmLinks = egTypeMod vt (egmLinks model) (Map.delete id) }--baseGraph :: EGModel-baseGraph = EGModel {-  egmParams = baseTypeData 0,-  egmVars = baseTypeData 0,-  egmNEdges = 0,-  egmEdges = Map.empty,-  egmLinks = baseTypeData Map.empty-}--data DisplayData = DisplayData (String,[DisplayData])--class Display a where-  display :: Int -> a -> String-  displayer :: a -> DisplayData-  display n x = display n $ displayer x--present :: Display a => a -> String-present = display 0--instance Display DisplayData where-  displayer = id-  display n (DisplayData (dir,sub)) = foldl (++) ((replicate (n*2) ' ')++dir++"\n") $ map (display $ n+1) sub--displaySingle :: String -> DisplayData-displaySingle x = DisplayData (x,[])--getConnectedEdges :: EGModel -> EGVarType -> EGVarId -> [(EGEdge,Int)]-getConnectedEdges model typ id = map (\(eid,pos) -> (fromJust $ Map.lookup eid $ egmEdges model, pos)) $ fromJust $ Map.lookup id $ egTypeGet typ $ egmLinks model

− Control/CP/FD/Interface.hs

@@ -1,220 +0,0 @@-{-# LANGUAGE GADTs #-}-{-# LANGUAGE RankNTypes #-}-{-# LANGUAGE TypeFamilies #-}-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE MultiParamTypeClasses #-}-{-# LANGUAGE TypeSynonymInstances #-}-{-# LANGUAGE ScopedTypeVariables #-}--module Control.CP.FD.Interface (-  FDSolver,-  FDInstance,-  (@+),(@-),(@*),(@/),(@%),(!),(@!!),(@..),(@++),size,xfold,xsum,xhead,xtail,list,slice,xmap,cte,-  (Control.CP.FD.Interface.@||),-  (Control.CP.FD.Interface.@&&),-  Control.CP.FD.Interface.inv,-  (Control.CP.FD.Interface.@=),-  (Control.CP.FD.Interface.@/=),-  (Control.CP.FD.Interface.@<),-  (Control.CP.FD.Interface.@>),-  (Control.CP.FD.Interface.@<=),-  (Control.CP.FD.Interface.@>=),-  (Control.CP.FD.Interface.@:),-  (Control.CP.FD.Interface.@?),-  (Control.CP.FD.Interface.@??),-  Control.CP.FD.Interface.channel,-  val,---  Control.CP.FD.Interface.newInt, Control.CP.FD.Interface.newBool, Control.CP.FD.Interface.newCol,-  Control.CP.FD.Interface.sorted, -  Control.CP.FD.Interface.sSorted,-  Control.CP.FD.Interface.forall,-  Control.CP.FD.Interface.forany,-  Control.CP.FD.Interface.loopall,-  Control.CP.FD.Interface.allDiff,-  Control.CP.FD.Interface.allDiffD,-  Control.CP.FD.Interface.loopany,-  allin,-  asExpr, asCol, Control.CP.FD.Interface.asBool,-  colList, labelCol, -  ModelInt, ModelCol, ModelBool,-  exists, true, false,---  Modelable,-) where--import Control.CP.FD.FD (FDSolver, FDInstance, FDIntTerm, getColItems)-import qualified Control.CP.FD.Model as Model-import Control.CP.FD.Model (Model, ModelBool, ModelCol, ModelInt, ToModelBool, asBool, asExpr, asCol, cte, newModelTerm, ModelIntArg, ModelBoolArg, ModelColArg)-import qualified Data.Expr.Sugar as Sugar-import Data.Expr.Util-import Data.Expr.Data-import Data.Expr.Sugar ((@+),(@-),(@*),(@/),(@%),(!),(@!!),(@..),(@++),size,xfold,xhead,xtail,slice,xmap,xsum,list)-import Control.CP.Solver-import Control.CP.SearchTree-import Control.CP.EnumTerm--newtype DummySolver a = DummySolver ()--instance Monad DummySolver where-  return _ = DummySolver ()-  _ >>= _ = DummySolver ()--data EQHelp b where-  EQHelp :: Model.ModelTermType b => ((b -> Model) -> Model) -> EQHelp b--instance Model.ModelTermType t => Term DummySolver t where-  type Help DummySolver t = EQHelp t-  help _ _ = EQHelp newModelTerm-  newvar = DummySolver ()--instance Solver DummySolver where-  type Constraint DummySolver = Either Model ()-  type Label DummySolver = ()-  add _ = DummySolver ()-  run _ = error "Attempt to run dummy solver"-  mark = DummySolver ()-  goto _ = DummySolver ()--newtype Model.ModelTermType t => DummyTerm t = DummyTerm t---- class (Solver s, Term s ModelBool, Term s ModelInt, Term s ModelCol) => Modelable s where---- instance Modelable DummySolver where---- instance FDSolver s => Modelable (FDInstance s) where---treeToModel :: Tree DummySolver () -> Model-treeToModel (Return _) = BoolConst True-treeToModel (Try a b) = (Sugar.@||) (treeToModel a) (treeToModel b)-treeToModel (Add (Left c) m) = (Sugar.@&&) c (treeToModel m)-treeToModel Fail = BoolConst False-treeToModel (Label _) = error "Cannot turn labelled trees into expressions"-treeToModel (NewVar (f :: t -> Tree DummySolver ())) = case (help ((error "treeToModel undefined 1") :: DummySolver ()) ((error "treeToModel undefined 2") :: t)) of EQHelp ff -> ff (\x -> treeToModel $ f (x :: t))--addM :: (Constraint s ~ Either Model q, MonadTree m, TreeSolver m ~ s) => Model -> m ()-addM m = addC $ Left m--infixr 2 @||-(@||) :: (Constraint s ~ Either Model q, MonadTree m, TreeSolver m ~ s) => Tree DummySolver () -> Tree DummySolver () -> m ()-(@||) a b = addM $ treeToModel $ a \/ b--infixr 3 @&&-(@&&) :: (Constraint s ~ Either Model q, MonadTree m, TreeSolver m ~ s) => Tree DummySolver () -> Tree DummySolver () -> m ()-(@&&) a b = addM $ treeToModel $ a /\ b--channel :: Tree DummySolver () -> ModelInt-channel a = Sugar.channel $ treeToModel a--inv :: (Constraint s ~ Either Model q, MonadTree m, TreeSolver m ~ s) => Tree DummySolver () -> m ()-inv a = addM $ Sugar.inv $ treeToModel a--infix 4 @=, @/=, @<, @>, @<=, @>=--class ModelExprClass a where-  (@=) :: (Constraint s ~ Either Model q, MonadTree m, TreeSolver m ~ s) => a -> a -> m ()-  (@/=) :: (Constraint s ~ Either Model q, MonadTree m, TreeSolver m ~ s) => a -> a -> m ()--instance ModelExprClass ModelInt where-  a @= b  = addM $ (Sugar.@=)  a b-  a @/= b = addM $ (Sugar.@/=) a b--instance ModelExprClass ModelCol where-  a @= b  = addM $ (Sugar.@=)  a b-  a @/= b = addM $ (Sugar.@/=) a b--instance ModelExprClass ModelBool where-  a @= b  = addM $ (Sugar.@=)  a b-  a @/= b = addM $ (Sugar.@/=) a b--instance ModelExprClass (Tree DummySolver ()) where-  a @= b  = addM $ (Sugar.@=)  (treeToModel a) (treeToModel b)-  a @/= b = addM $ (Sugar.@/=) (treeToModel a) (treeToModel b)--(@<) :: (Constraint s ~ Either Model q, MonadTree m, TreeSolver m ~ s) => ModelInt -> ModelInt -> m ()-(@<) a b = addM $ (Sugar.@<) a b--(@>) :: (Constraint s ~ Either Model q, MonadTree m, TreeSolver m ~ s) => ModelInt -> ModelInt -> m ()-(@>) a b = addM $ (Sugar.@>) a b--(@>=) :: (Constraint s ~ Either Model q, MonadTree m, TreeSolver m ~ s) => ModelInt -> ModelInt -> m ()-(@>=) a b = addM $ (Sugar.@>=) a b--(@<=) :: (Constraint s ~ Either Model q, MonadTree m, TreeSolver m ~ s) => ModelInt -> ModelInt -> m ()-(@<=) a b = addM $ (Sugar.@<=) a b--val :: Tree DummySolver () -> ModelInt-val = Sugar.toExpr . treeToModel--{- newBool :: (Constraint s ~ Either Model q, MonadTree m, TreeSolver m ~ s) => (ModelBool -> Tree DummySolver a) -> m a-newBool = exists--newInt :: (Constraint s ~ Either Model q, MonadTree m, TreeSolver m ~ s) => (ModelInt -> m a) -> m a-newInt = exists--newCol :: (Constraint s ~ Either Model q, MonadTree m, TreeSolver m ~ s) => (ModelCol -> m a) -> m a-newCol = exists--}--asBool :: (FDSolver s, MonadTree m, TreeSolver m ~ FDInstance s, ToModelBool t) => t -> m ()-asBool = addM . Control.CP.FD.Model.asBool--sorted :: (Constraint s ~ Either Model q, MonadTree m, TreeSolver m ~ s) => ModelCol -> m ()-sorted = addM . Sugar.sorted--sSorted :: (Constraint s ~ Either Model q, MonadTree m, TreeSolver m ~ s) => ModelCol -> m ()-sSorted = addM . Sugar.sSorted--allDiff :: (Constraint s ~ Either Model q, MonadTree m, TreeSolver m ~ s) => ModelCol -> m ()-allDiff = addM . Sugar.allDiff--allDiffD :: (Constraint s ~ Either Model q, MonadTree m, TreeSolver m ~ s) => ModelCol -> m ()-allDiffD = addM . Sugar.allDiffD--mm (nv@(Term tv)) m x = -     let tf t = if (t==tv) then x else Term t-         tb t = if (Term t==x) then nv else Term t-         in boolTransformEx (tf,ColTerm,BoolTerm,tb,ColTerm,BoolTerm) m--forall :: (Term s ModelInt, Term s ModelBool, Term s ModelCol, Constraint s ~ Either Model q, MonadTree m, TreeSolver m ~ s) => ModelCol -> (ModelInt -> Tree DummySolver ()) -> m ()--- forall col f = exists $ \nv -> addM $ Sugar.forall col $ mm nv $ treeToModel $ f nv-forall col f = addM $ Sugar.forall col (treeToModel . f)--forany :: (Term s ModelInt, Term s ModelBool, Term s ModelCol, Constraint s ~ Either Model q, MonadTree m, TreeSolver m ~ s) => ModelCol -> (ModelInt -> Tree DummySolver ()) -> m ()--- forany col f = exists $ \nv -> addM $ Sugar.forany col $ mm nv $ treeToModel $ f nv-forany col f = addM $ Sugar.forany col (treeToModel . f)--loopall :: (Term s ModelInt, Term s ModelBool, Term s ModelCol, Constraint s ~ Either Model q, MonadTree m, TreeSolver m ~ s) => (ModelInt,ModelInt) -> (ModelInt -> Tree DummySolver ()) -> m ()--- loopall r f = exists $ \nv -> addM $ Sugar.loopall r $ mm nv $ treeToModel $ f nv-loopall r f = addM $ Sugar.loopall r (treeToModel . f)--loopany :: (Term s ModelInt, Term s ModelBool, Term s ModelCol, Constraint s ~ Either Model q, MonadTree m, TreeSolver m ~ s) => (ModelInt,ModelInt) -> (ModelInt -> Tree DummySolver ()) -> m ()--- loopany r f = exists $ \nv -> addM $ Sugar.loopany r $ mm nv $ treeToModel $ f nv-loopany r f = addM $ Sugar.loopany r (treeToModel . f)--colList :: (Constraint s ~ Either Model q, MonadTree m, TreeSolver m ~ s) => ModelCol -> Int -> m [ModelInt]-colList col len = do-  addM $ (Sugar.@=) (size col) (asExpr len)-  return $ map (\i -> col!cte i) [0..len-1]--labelCol :: (FDSolver s, MonadTree m, TreeSolver m ~ FDInstance s, EnumTerm s (FDIntTerm s)) => ModelCol -> m [TermBaseType s (FDIntTerm s)]-labelCol col = label $ do-  lst <- getColItems col maxBound-  return $ do-    lsti <- colList col $ length lst-    enumerate lsti-    assignments lsti--infix 5 @:--(@:) :: (Constraint s ~ Either Model q, MonadTree m, TreeSolver m ~ s, Sugar.ExprRange ModelIntArg ModelColArg ModelBoolArg r, Term s ModelInt, Term s ModelBool, Term s ModelCol) => ModelInt -> r -> m ()-a @: b = addM $ (Sugar.@:) a b--infix 4 @?-infix 4 @??--a @? (t,f) = (Sugar.@?) (treeToModel a) (t,f)-a @?? (t,f) = addM $ (Sugar.@??) (treeToModel a) (treeToModel t, treeToModel f)--allin :: (Constraint s ~ Either Model q, MonadTree m, TreeSolver m ~ s, Sugar.ExprRange ModelIntArg ModelColArg ModelBoolArg r, Term s ModelInt, Term s ModelBool, Term s ModelCol) => ModelCol -> r -> m ()-allin c b = Control.CP.FD.Interface.forall c $ \x -> addM $ (Sugar.@:) x b

− Control/CP/FD/Model.hs

@@ -1,192 +0,0 @@-{- - - 	Monadic Constraint Programming- - 	http://www.cs.kuleuven.be/~toms/Haskell/- - 	Tom Schrijvers & Pieter Wuille- -}--{-# LANGUAGE StandaloneDeriving #-}-{-# LANGUAGE TypeSynonymInstances #-}-{-# LANGUAGE UndecidableInstances #-}-{-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE FlexibleContexts #-}--module Control.CP.FD.Model (-  Model,-  ModelIntTerm(..),-  ModelBoolTerm(..),-  ModelColTerm(..),-  ModelFunctions(..),-  ModelInt,  ToModelInt(..), ModelIntArg,-  ModelCol,  ToModelCol(..), ModelColArg,-  ModelBool, ToModelBool(..), ModelBoolArg,-  modelVariantInt, modelVariantBool, modelVariantCol,-  ModelTermType(..),-  showModel,-  cte,-) where--import Data.Expr.Data-import Data.Expr.Util-import Data.Expr.Sugar--data ModelIntTerm t = -    ModelIntVar Int-  | ModelIntPar Int-  deriving (Show)--data ModelColTerm t = -    ModelColVar Int-  | ModelColPar Int-  deriving (Show)--data ModelBoolTerm t = -    ModelBoolVar Int-  | ModelBoolPar Int-  | ModelExtra t-  deriving (Show)--data ModelFunctions =-    ForNewBool (ModelBoolExpr ModelFunctions -> Model)-  | ForNewInt (ModelIntExpr ModelFunctions -> Model)-  | ForNewCol (ModelColExpr ModelFunctions -> Model)--data ModelIntros =-     NewBool Int FlatModel-   | NewInt Int FlatModel-   | NewCol Int FlatModel-   deriving (Show,Eq)--instance Ord ModelIntros where-  compare (NewBool n1 m1) (NewBool n2 m2) = compare n1 n2 <<>> compare m1 m2-  compare (NewBool _ _) _ = LT-  compare _ (NewBool _ _) = GT-  compare (NewInt n1 m1) (NewInt n2 m2) = compare n1 n2 <<>> compare m1 m2-  compare (NewInt _ _) _ = LT-  compare _ (NewInt _ _) = GT-  compare (NewCol n1 m1) (NewCol n2 m2) = compare n1 n2 <<>> compare m1 m2--instance Show ModelFunctions where-  show (ForNewBool f) = show $ explicate (-999999) $ f $ BoolTerm $ ModelBoolVar (-1000000)-  show (ForNewInt f) = show $ explicate (-1999999) $ f $ Term $ ModelIntVar (-2000000)-  show (ForNewCol f) = show $ explicate (-2999999) $ f $ ColTerm $ ModelColVar (-3000000)-  -instance Eq ModelFunctions where-  a==b = False--instance Ord ModelFunctions where-  compare _ _ = error "Unable to compare model functions"---- instance Show Model where ---   show x = show $ explicate 0 x--deriving instance Eq t => Eq (ModelBoolTerm t)-deriving instance Ord t => Ord (ModelBoolTerm t)-deriving instance Eq t => Eq (ModelIntTerm t)-deriving instance Ord t => Ord (ModelIntTerm t)-deriving instance Eq t => Eq (ModelColTerm t)-deriving instance Ord t => Ord (ModelColTerm t)--type ModelIntExpr t       = Expr        (ModelIntTerm  t) (ModelColTerm  t) (ModelBoolTerm  t)-type ModelBoolExpr t      = BoolExpr    (ModelIntTerm  t) (ModelColTerm  t) (ModelBoolTerm  t)-type ModelColExpr t       = ColExpr     (ModelIntTerm  t) (ModelColTerm  t) (ModelBoolTerm  t)--type ModelInt = ModelIntExpr ModelFunctions-type ModelBool = ModelBoolExpr ModelFunctions-type ModelCol = ModelColExpr ModelFunctions--type ModelIntArg = ModelIntTerm ModelFunctions-type ModelBoolArg = ModelBoolTerm ModelFunctions-type ModelColArg = ModelColTerm ModelFunctions--type FlatModelInt = ModelIntExpr ModelIntros-type FlatModelBool = ModelBoolExpr ModelIntros-type FlatModelCol = ModelColExpr ModelIntros--type Model = ModelBool-type FlatModel = FlatModelBool--explicate :: Int -> Model -> FlatModel-explicate num mod = boolTransformEx (it,ct,bt,iit,ict,ibt) mod-  where it (ModelIntVar i) = Term $ ModelIntVar i-        it (ModelIntPar i) = Term $ ModelIntPar i-        ct (ModelColVar i) = ColTerm $ ModelColVar i-        ct (ModelColPar i) = ColTerm $ ModelColPar i-        iit (ModelIntVar i) = Term $ ModelIntVar i-        iit (ModelIntPar i) = Term $ ModelIntPar i-        ict (ModelColVar i) = ColTerm $ ModelColVar i-        ict (ModelColPar i) = ColTerm $ ModelColPar i-        ibt (ModelBoolVar i) = BoolTerm $ ModelBoolVar i-        ibt (ModelBoolPar i) = BoolTerm $ ModelBoolPar i-        bt (ModelBoolVar i) = BoolTerm $ ModelBoolVar i-        bt (ModelBoolPar i) = BoolTerm $ ModelBoolPar i-        bt (ModelExtra (ForNewBool f)) = BoolTerm $ ModelExtra $ NewBool num $ explicate (num+1) $ f $ BoolTerm $ ModelBoolVar num-        bt (ModelExtra (ForNewInt f)) = BoolTerm $ ModelExtra $ NewInt num $ explicate (num+1) $ f $ Term $ ModelIntVar num-        bt (ModelExtra (ForNewCol f)) = BoolTerm $ ModelExtra $ NewCol num $ explicate (num+1) $ f $ ColTerm $ ModelColVar num--flatten :: Model -> FlatModel-flatten = explicate 0--showModel :: Model -> String-showModel = show . flatten--variantIntTerm :: ModelIntTerm a -> Bool-variantIntTerm (ModelIntVar _) = True-variantIntTerm (ModelIntPar _) = False--variantBoolTerm :: ModelBoolTerm a -> Bool-variantBoolTerm (ModelBoolVar _) = True-variantBoolTerm (ModelBoolPar _) = False-variantBoolTerm (ModelExtra _) = True--variantColTerm :: ModelColTerm a -> Bool-variantColTerm (ModelColVar _) = True-variantColTerm (ModelColPar _) = False--modelVariantInt  :: ModelIntExpr x -> Bool-modelVariantInt  =     property variantIntTerm variantColTerm variantBoolTerm-modelVariantCol  :: ModelColExpr x -> Bool-modelVariantCol  =  colProperty variantIntTerm variantColTerm variantBoolTerm-modelVariantBool :: ModelBoolExpr x -> Bool-modelVariantBool = boolProperty variantIntTerm variantColTerm variantBoolTerm--newBool :: (ModelBool -> Model) -> Model-newBool = boolSimplify . BoolTerm . ModelExtra . ForNewBool--newInt :: (ModelInt -> Model) -> Model-newInt = boolSimplify . BoolTerm . ModelExtra . ForNewInt--newCol :: (ModelCol -> Model) -> Model-newCol = boolSimplify . BoolTerm . ModelExtra . ForNewCol--class ModelTermType s where-  newModelTerm :: (s -> Model) -> Model--instance ModelTermType ModelBool where-  newModelTerm = newBool--instance ModelTermType ModelInt where-  newModelTerm = newInt--instance ModelTermType ModelCol where-  newModelTerm = newCol--cte :: Integral a => a -> ModelInt-cte = Const . toInteger--class ToModelBool t where-  asBool :: t -> ModelBool--class ToModelInt t where-  asExpr :: t -> ModelInt--class ToModelCol t where-  asCol :: t -> ModelCol--instance ToExpr (ModelIntTerm ModelFunctions) (ModelColTerm ModelFunctions) (ModelBoolTerm ModelFunctions) t => ToModelInt t where-  asExpr = toExpr--instance ToBoolExpr (ModelIntTerm ModelFunctions) (ModelColTerm ModelFunctions) (ModelBoolTerm ModelFunctions) t => ToModelBool t where-  asBool = toBoolExpr--instance ToColExpr (ModelIntTerm ModelFunctions) (ModelColTerm ModelFunctions) (ModelBoolTerm ModelFunctions) t => ToModelCol t where-  asCol = toColExpr

− Control/CP/FD/OvertonFD/Domain.hs

@@ -1,187 +0,0 @@-{- - - Origin:- -     Constraint Programming in Haskell - -     http://overtond.blogspot.com/2008/07/pre.html- -     author: David Overton, Melbourne Australia- -- - Modifications:- -     Monadic Constraint Programming- -     http://www.cs.kuleuven.be/~toms/Haskell/- -     Tom Schrijvers- -} --{-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE IncoherentInstances #-}-{-# LANGUAGE UndecidableInstances #-}--module Control.CP.FD.OvertonFD.Domain (-    Domain,-    ToDomain,-    toDomain,-    member,-    isSubsetOf,-    elems,-    intersection,-    difference,-    union,-    empty,-    null,-    singleton,-    isSingleton,-    filterLessThan,-    filterGreaterThan,-    findMax,-    findMin,-    size,-    shiftDomain,-    mapDomain,-    absDomain-) where--import qualified Data.IntSet as IntSet-import Data.IntSet (IntSet)-import Prelude hiding (null)-import Control.CP.Debug--data Domain-    = Set IntSet-    | Range !Int !Int-    deriving Show--size :: Domain -> Int-size (Range l u) = u - l + 1-size (Set set)   = IntSet.size set---- Domain constructors-class ToDomain a where-    toDomain :: a -> Domain--instance ToDomain Domain where-    toDomain = id--instance ToDomain IntSet where-    toDomain = Set--instance Integral a => ToDomain [a] where-    toDomain = toDomain . IntSet.fromList . map fromIntegral--instance (Integral a, Integral b) => ToDomain (a, b) where-    toDomain (a, b) = Range (fromIntegral a) (fromIntegral b)--instance ToDomain () where-    toDomain () = Range (-1000000000) 1000000000 -- minBound maxBound (too sensitive to overflow, e.g. 2 * minBound == 0)--instance Integral a => ToDomain a where-    toDomain a = toDomain (a, a)---- Operations on Domains-instance Eq Domain where-    (Range xl xh) == (Range yl yh) = xl == yl && xh == yh-    xs == ys = elems xs == elems ys--member :: Int -> Domain -> Bool-member n x@(Set xs) = debugDom "[Domain.member]" x $ n `IntSet.member` xs-member n x@(Range xl xh) = debugDom "[Domain.member]" x $ n >= xl && n <= xh--isSubsetOf :: Domain -> Domain -> Bool-isSubsetOf x@(Set xs) (Set ys) = debugDom "[Domain.isso]" x $ xs `IntSet.isSubsetOf` ys-isSubsetOf x@(Range xl xh) (Range yl yh) = debugDom "[Domain.isso]" x $ xl >= yl && xh <= yh-isSubsetOf x@(Set xs) yd@(Range yl yh) = debugDom "[Domain.isso]" x $ -    isSubsetOf (Range xl xh) yd where-        xl = IntSet.findMin xs-        xh = IntSet.findMax xs-isSubsetOf (Range xl xh) x@(Set ys) = debugDom "[Domain.isso]" x $ -    all (`IntSet.member` ys) [xl..xh]--elems :: Domain -> [Int]-elems x@(Set xs) = debugDom "[Domain.elems]" x $ IntSet.elems xs-elems x@(Range xl xh) = debugDom "[Domain.elems]" x $ [xl..xh]--intersection :: Domain -> Domain -> Domain-intersection x@(Set xs) (Set ys) = debugDom "[Domain.intersection]" x $ Set (xs `IntSet.intersection` ys)-intersection x@(Range xl xh) (Range yl yh) = debugDom "[Domain.intersection]" x $ Range (max xl yl) (min xh yh)-intersection x@(Set xs) (Range yl yh) = debugDom "[Domain.intersection]" x $ -    Set $ IntSet.filter (\x -> x >= yl && x <= yh) xs-intersection x y = intersection y x--union :: Domain -> Domain -> Domain-union x@(Set xs) (Set ys) = debugDom "[Domain.union]" x $ Set (xs `IntSet.union` ys)-union x@(Range xl xh) (Range yl yh) -      | xh + 1 >= yl || yh+1 >= xl = debugDom "[Domain.union]" x $ Range (min xl yl) (max xh yh)-      | otherwise = debugDom "[Domain.union]" x $ union (Set $ IntSet.fromList [xl..xh]) (Set $ IntSet.fromList [yl..yh]) -union x@(Set xs) y@(Range yl yh) = debugDom "[Domain.union]" x $ -      if null x then y -      else-      let xmin = IntSet.findMin xs-          xmax = IntSet.findMax xs-      in -      if (xmin + 1 >= yl && xmax - 1 <= yh) -         then Range (min xmin yl) (max xmax yh)-         else union (Set xs) (Set $ IntSet.fromList [yl..yh])-union x y = union y x--difference :: Domain -> Domain -> Domain-difference (x@(Set xs)) (y@(Set ys)) = debugDom "[Domain.difference]" x $ Set (xs `IntSet.difference` ys)-difference xd@(Range xl xh) (Range yl yh)-    | yl > xh || yh < xl = debugDom "[Domain.difference]" xd $ xd-    | otherwise = debugDom "[Domain.difference]" xd $ Set $ IntSet.fromList [x | x <- [xl..xh], x < yl || x > yh]-difference (x@(Set xs)) (Range yl yh) =-    debugDom "[Domain.difference]" x $ Set $ IntSet.filter (\x -> x < yl || x > yh) xs-difference (x@(Range xl xh)) (Set ys)-    | IntSet.findMin ys > xh || IntSet.findMax ys < xl = debugDom "[Domain.difference]" x $ Range xl xh-    | otherwise = debugDom "[Domain.difference]" x $ Set $-        IntSet.fromList [x | x <- [xl..xh], not (x `IntSet.member` ys)]--null :: Domain -> Bool-null (x@(Set xs)) = debug ("[Domain.null] " ++ printDom x) $ IntSet.null xs-null (x@(Range xl xh)) = debug ("[Domain.null] " ++ printDom x) $ xl > xh--singleton :: Int -> Domain-singleton x = Range x x--isSingleton :: Domain -> Bool-isSingleton (x@(Set xs)) = debugDom "[Domain.isSingleton]" x $ (IntSet.size xs)==1-isSingleton (x@(Range xl xh)) = debug ("[Domain.isSingleton] " ++ printDom x) $ xl == xh--filterLessThan :: Int -> Domain -> Domain-filterLessThan n (x@(Set xs)) = debug ("[Domain.filterLess] " ++ printDom x) $ Set $ IntSet.filter (< n) xs-filterLessThan n (x@(Range xl xh)) = debug ("[Domain.filterLess] " ++ printDom x) $ Range xl (min (n-1) xh)--filterGreaterThan :: Int -> Domain -> Domain-filterGreaterThan n (x@(Set xs)) = debug ("[Domain.filterGreater] " ++ printDom x) $ Set $ IntSet.filter (> n) xs-filterGreaterThan n (x@(Range xl xh)) = debug ("[Domain.filterGreater] " ++ printDom x) $ Range (max (n+1) xl) xh--findMax :: Domain -> Int-findMax (x@(Set xs)) = debug ("[Domain.findMax] " ++ printDom x) $ IntSet.findMax xs-findMax (x@(Range xl xh)) = debug ("[Domain.findMax] " ++ printDom x) $ xh--findMin :: Domain -> Int-findMin (Set xs) = IntSet.findMin xs-findMin (Range xl xh) = xl--empty :: Domain-empty = Range 1 0--shiftDomain :: Domain -> Int -> Domain-shiftDomain (x@(Range l u)) d = debug ("[Domain.shift] " ++ printDom x) $ Range (l + d) (u + d)-shiftDomain (x@(Set xs)) d = debug ("[Domain.shift] " ++ printDom x) $ Set $ IntSet.fromList $ map (+d) (IntSet.elems xs)--mapDomain :: Domain -> (Int -> [Int]) -> Domain-mapDomain d f = debug ("[Domain.map] " ++ printDom d) $ Set $ IntSet.fromList $ concatMap f $ elems d--absDomain :: Domain -> Domain-absDomain d@(Range l u)  | l >= 0     = d-                         | u <  0     = Range (abs u) (abs l)-                         | otherwise  = Range 0 (max (abs l) u)-absDomain d@(Set s)      | IntSet.findMin s >= 0  = d-                         | otherwise              = Set $ IntSet.map abs s--mirrorDomain :: Domain -> Domain-mirrorDomain d@(Range l u)   | l <= 0 && u >= 0  = Range (min l (-u)) (max (-l) u)--printDom :: Domain -> String-printDom (Set cs) = "dom:Set(#" ++ (show $ IntSet.size cs) ++ ")"-printDom (Range l h) = "dom:Range(#" ++ (show $ h-l+1) ++ ":" ++ (show l) ++ "-" ++ (show h) ++ ")"--debugDom :: String -> Domain -> a -> a-debugDom s d a = debug ("[Domain.findMax] " ++ printDom d) a

− Control/CP/FD/OvertonFD/OvertonFD.hs

@@ -1,392 +0,0 @@-{- - - Origin:- - 	Constraint Programming in Haskell - - 	http://overtond.blogspot.com/2008/07/pre.html- - 	author: David Overton, Melbourne Australia- -- - Modifications:- - 	Monadic Constraint Programming- - 	http://www.cs.kuleuven.be/~toms/Haskell/- - 	Tom Schrijvers- -} --{-# LANGUAGE TypeFamilies #-}-{-# LANGUAGE MultiParamTypeClasses #-}-{-# LANGUAGE GeneralizedNewtypeDeriving #-}--module Control.CP.FD.OvertonFD.OvertonFD (-  OvertonFD,-  fd_objective,-  fd_domain,-  FDVar,-  OConstraint(..),-  lookup,-) where--import Prelude hiding (lookup)-import Data.Maybe (fromJust,isJust)-import Control.Monad.State.Lazy-import Control.Monad.Trans-import qualified Data.Map as Map-import Data.Map ((!), Map)-import Control.Monad (liftM,(<=<))--import Control.CP.FD.OvertonFD.Domain as Domain-import Control.CP.FD.FD hiding ((!))-import Control.CP.Solver-import Control.CP.SearchTree-import Control.CP.EnumTerm--import Control.CP.Debug------------------------------------------------------------------------------------- Solver instance ------------------------------------------------------------------------------------------------------------------------------------------------data OConstraint =-    OHasValue FDVar Int-  | OSame FDVar FDVar-  | ODiff FDVar FDVar-  | OLess FDVar FDVar-  | OLessEq FDVar FDVar-  | OAdd FDVar FDVar FDVar-  | OSub FDVar FDVar FDVar-  | OMult FDVar FDVar FDVar-  | OAbs FDVar FDVar-  deriving (Show,Eq)--instance Solver OvertonFD where-  type Constraint OvertonFD  = OConstraint-  type Label      OvertonFD  = FDState-  add c  	= debug ("addOverton("++(show c)++")") $ addOverton c-  run p   	= debug ("runOverton") $ runOverton p-  mark	= get-  goto	= put --instance Term OvertonFD FDVar where-  newvar 	= newVar ()-  type Help OvertonFD FDVar = ()-  help _ _ = ()--instance EnumTerm OvertonFD FDVar where-  type TermBaseType OvertonFD FDVar = Int-  getDomain = fd_domain-  setValue var val = return [var `OHasValue` val]------------------------------------------------------------------------------------- Constraints ----------------------------------------------------------------------------------------------------------------------------------------------------addOverton (OHasValue v i) = v `hasValue` i-addOverton (OSame a b) = a `same` b-addOverton (ODiff a b) = a `different` b-addOverton (OLess a b) = a .<. b-addOverton (OLessEq a b) = a .<=. b-addOverton (OAdd a b c) = addSum a b c-addOverton (OSub a b c) = addSub a b c-addOverton (OMult a b c) = addMult a b c-addOverton (OAbs a b) = addAbs a b--fd_domain :: FDVar -> OvertonFD [Int]-fd_domain v = do d <- lookup v-	         return $ elems d--fd_objective :: OvertonFD FDVar-fd_objective =-  do s <- get-     return $ objective s-------------------------------------------------------------------------------------- The FD monad-newtype OvertonFD a = OvertonFD { unFD :: State FDState a }-    deriving (Monad, MonadState FDState)---- FD variables-newtype FDVar = FDVar { unFDVar :: Int } deriving (Ord, Eq, Show)--type VarSupply = FDVar--data VarInfo = VarInfo-     { delayedConstraints :: OvertonFD Bool, domain :: Domain }--instance Show VarInfo where-  show x = show $ domain x--type VarMap = Map FDVar VarInfo--data FDState = FDState-     { varSupply :: VarSupply, varMap :: VarMap, objective :: FDVar }-     deriving Show--instance Eq FDState where-  s1 == s2 = f s1 == f s2-           where f s = head $ elems $ domain $ varMap s ! (objective s) --instance Ord FDState where-  compare s1 s2  = compare (f s1) (f s2)-           where f s = head $ elems $  domain $ varMap s ! (objective s) --  -- TOM: inconsistency is not observable within the OvertonFD monad-consistentFD :: OvertonFD Bool-consistentFD = return True---- Run the FD monad and produce a lazy list of possible solutions.-runOverton :: OvertonFD a -> a-runOverton fd = -  let j = evalState (unFD fd) initState-      in j--initState :: FDState-initState = FDState { varSupply = FDVar 0, varMap = Map.empty, objective = FDVar 0 }---- Get a new FDVar-newVar :: ToDomain a => a -> OvertonFD FDVar-newVar d = do-    s <- get-    let v = varSupply s-    put $ s { varSupply = FDVar (unFDVar v + 1) }-    modify $ \s ->-        let vm = varMap s-            vi = VarInfo {-                delayedConstraints = return True,-                domain = toDomain d}-        in-        s { varMap = Map.insert v vi vm }-    return v--newVars :: ToDomain a => Int -> a -> OvertonFD [FDVar]-newVars n d = replicateM n (newVar d)---- Lookup the current domain of a variable.-lookup :: FDVar -> OvertonFD Domain-lookup x = do-    s <- get-    return . domain $ varMap s ! x---- Update the domain of a variable and fire all delayed constraints--- associated with that variable.-update :: FDVar -> Domain -> OvertonFD Bool-update x i = do-    debug (show x ++ " <- " ++ show i)  (return ())-    s <- get-    let vm = varMap s-    let vi = vm ! x-    debug ("where old domain = " ++ show (domain vi)) (return ())-    put $ s { varMap = Map.insert x (vi { domain = i}) vm }-    delayedConstraints vi---- Add a new constraint for a variable to the constraint store.-addConstraint :: FDVar -> OvertonFD Bool -> OvertonFD ()-addConstraint x constraint = do-    s <- get-    let vm = varMap s-    let vi = vm ! x-    let cs = delayedConstraints vi-    put $ s { varMap =-        Map.insert x (vi { delayedConstraints = do b <- cs -                                                   if b then constraint-                                                        else return False}) vm }- --- Useful helper function for adding binary constraints between FDVars.-type BinaryConstraint = FDVar -> FDVar -> OvertonFD Bool-addBinaryConstraint :: BinaryConstraint -> BinaryConstraint -addBinaryConstraint f x y = do-    let constraint  = f x y-    b <- constraint -    when b $ (do addConstraint x constraint-                 addConstraint y constraint)-    return b---- Constrain a variable to a particular value.-hasValue :: FDVar -> Int -> OvertonFD Bool-var `hasValue` val = do-    vals <- lookup var-    if val `member` vals-       then do let i = singleton val-               if (i /= vals) -                  then update var i-                  else return True-       else return False---- Constrain two variables to have the same value.-same :: FDVar -> FDVar -> OvertonFD Bool-same = addBinaryConstraint $ \x y -> do -    debug "inside same" $ return ()-    xv <- lookup x-    yv <- lookup y-    debug (show xv ++ " same " ++ show yv) $ return ()-    let i = xv `intersection` yv-    if not $ Domain.null i-       then whenwhen (i /= xv)  (i /= yv) (update x i) (update y i)-       else return False--whenwhen c1 c2 a1 a2  =-  if c1-     then do b1 <- a1-             if b1 -                then if c2-                        then a2-                        else return True-                else return False -     else if c2-             then a2-             else return True---- Constrain two variables to have different values.-different :: FDVar  -> FDVar  -> OvertonFD Bool-different = addBinaryConstraint $ \x y -> do-    xv <- lookup x-    yv <- lookup y-    if not (isSingleton xv) || not (isSingleton yv) || xv /= yv-       then whenwhen (isSingleton xv && xv `isSubsetOf` yv)-                     (isSingleton yv && yv `isSubsetOf` xv)-                     (update y (yv `difference` xv))-                     (update x (xv `difference` yv))-       else return False---- Constrain one variable to have a value less than the value of another--- variable.-infix 4 .<.-(.<.) :: FDVar -> FDVar -> OvertonFD Bool-(.<.) = addBinaryConstraint $ \x y -> do-    xv <- lookup x-    yv <- lookup y-    let xv' = filterLessThan (findMax yv) xv-    let yv' = filterGreaterThan (findMin xv) yv-    if  not $ Domain.null xv'-        then if not $ Domain.null yv'-                then whenwhen (xv /= xv') (yv /= yv') (update x xv') (update y yv')-	        else return False-        else return False---- Constrain one variable to have a value less than or equal to the value of another --- variable.-infix 4 .<=.-(.<=.) :: FDVar -> FDVar -> OvertonFD Bool-(.<=.) = addBinaryConstraint $ \x y -> do-    xv <- lookup x-    yv <- lookup y-    let xv' = filterLessThan (1 + findMax yv) xv-    let yv' = filterGreaterThan ((findMin xv) - 1) yv-    if  not $ Domain.null xv'-        then if not $ Domain.null yv'-                then whenwhen (xv /= xv') (yv /= yv') (update x xv') (update y yv')-	        else return False-        else return False--{---- Get all solutions for a constraint without actually updating the--- constraint store.-solutions :: OvertonFD s a -> OvertonFD s [a]-solutions constraint = do-    s <- get-    return $ evalStateT (unFD constraint) s---- Label variables using a depth-first left-to-right search.-labelling :: [FDVar s] -> OvertonFD s [Int]-labelling = mapM label where-    label var = do-        vals <- lookup var-        val <- OvertonFD . lift $ elems vals-        var `hasValue` val-        return val--}--dump :: [FDVar] -> OvertonFD [Domain]-dump = mapM lookup---- Add constraint (z = x `op` y) for var z-addArithmeticConstraint :: -    (Domain -> Domain -> Domain) ->-    (Domain -> Domain -> Domain) ->-    (Domain -> Domain -> Domain) ->-    FDVar -> FDVar -> FDVar -> OvertonFD Bool-addArithmeticConstraint getZDomain getXDomain getYDomain x y z = do-    xv <- lookup x-    yv <- lookup y-    let constraint z x y getDomain = do-        xv <- lookup x-        yv <- lookup y-        zv <- lookup z-        let znew = debug "binaryArith:intersection" $ (debug "binaryArith:zv" $ zv) `intersection` (debug "binaryArith:getDomain" $ getDomain xv yv)-	debug ("binaryArith:" ++ show z ++ " before: "  ++ show zv ++ show "; after: " ++ show znew) (return ())-        if debug "binaryArith:null?" $ not $ Domain.null (debug "binaryArith:null?:znew" $ znew)-           then if (znew /= zv) -                   then debug ("binaryArith:update") $ update z znew-                   else return True-           else return False-    let zConstraint = debug "binaryArith: zConstraint" $ constraint z x y getZDomain-        xConstraint = debug "binaryArith: xConstraint" $ constraint x z y getXDomain-        yConstraint = debug "binaryArith: yConstraint" $ constraint y z x getYDomain-    debug ("addBinaryArith: z x") (return ())-    addConstraint z xConstraint-    debug ("addBinaryArith: z y") (return ())-    addConstraint z yConstraint-    debug ("addBinaryArith: x z") (return ())-    addConstraint x zConstraint-    debug ("addBinaryArith: x y") (return ())-    addConstraint x yConstraint-    debug ("addBinaryArith: y z") (return ())-    addConstraint y zConstraint-    debug ("addBinaryArith: y x") (return ())-    addConstraint y xConstraint-    debug ("addBinaryArith: done") (return ())-    return True---- Add constraint (z = op x) for var z-addUnaryArithmeticConstraint :: (Domain -> Domain) -> (Domain -> Domain) -> FDVar -> FDVar -> OvertonFD Bool-addUnaryArithmeticConstraint getZDomain getXDomain x z = do-    xv <- lookup x-    let constraint z x getDomain = do-        xv <- lookup x-        zv <- lookup z-        let znew = zv `intersection` (getDomain xv)-	debug ("unaryArith:" ++ show z ++ " before: "  ++ show zv ++ show "; after: " ++ show znew) (return ())-        if not $ Domain.null znew-           then if (znew /= zv) -                   then update z znew-                   else return True-           else return False-    let zConstraint = constraint z x getZDomain-        xConstraint = constraint x z getXDomain-    addConstraint z xConstraint-    addConstraint x zConstraint-    return True--addSum = addArithmeticConstraint getDomainPlus getDomainMinus getDomainMinus--addSub = addArithmeticConstraint getDomainMinus getDomainPlus (flip getDomainMinus)--addMult = addArithmeticConstraint getDomainMult getDomainDiv getDomainDiv--addAbs = addUnaryArithmeticConstraint absDomain (\z -> mapDomain z (\i -> [i,-i]))--getDomainPlus :: Domain -> Domain -> Domain-getDomainPlus xs ys = toDomain (zl, zh) where-    zl = findMin xs + findMin ys-    zh = findMax xs + findMax ys--getDomainMinus :: Domain -> Domain -> Domain-getDomainMinus xs ys = toDomain (zl, zh) where-    zl = findMin xs - findMax ys-    zh = findMax xs - findMin ys--getDomainMult :: Domain -> Domain -> Domain-getDomainMult xs ys = (\d -> debug ("multDomain" ++ show d ++ "=" ++ show xs ++ "*" ++ show ys ) d) $ toDomain (zl, zh) where-    zl = minimum products-    zh = maximum products-    products = [x * y |-        x <- [findMin xs, findMax xs],-        y <- [findMin ys, findMax ys]]--getDomainDiv :: Domain -> Domain -> Domain-getDomainDiv xs ys = toDomain (zl, zh) where-    zl = minimum quotientsl-    zh = maximum quotientsh-    quotientsl = [if y /= 0 then x `div` y else minBound |-        x <- [findMin xs, findMax xs],-        y <- [findMin ys, findMax ys]]-    quotientsh = [if y /= 0 then x `div` y else maxBound |-        x <- [findMin xs, findMax xs],-        y <- [findMin ys, findMax ys]]

− Control/CP/FD/OvertonFD/Sugar.hs

@@ -1,112 +0,0 @@-{-# LANGUAGE TypeFamilies #-}--module Control.CP.FD.OvertonFD.Sugar (-) where--import Data.Set(Set)-import qualified Data.Set as Set--import Control.CP.Debug-import Control.Mixin.Mixin-import Control.CP.Solver-import Control.CP.FD.FD-import Control.CP.FD.SimpleFD-import Data.Expr.Data-import Data.Expr.Sugar--- import Control.CP.FD.Expr.Util-import Control.CP.FD.Model-import Control.CP.FD.Graph-import Control.CP.FD.OvertonFD.OvertonFD--newVars :: Term s t => Int -> s [t]-newVars 0 = return []-newVars n = do-  l <- newVars $ n-1-  n <- newvar-  return $ n:l--instance FDSolver OvertonFD where-  type FDIntTerm OvertonFD = FDVar-  type FDBoolTerm OvertonFD = FDVar--  type FDIntSpec OvertonFD = FDVar-  type FDBoolSpec OvertonFD = FDVar-  type FDColSpec OvertonFD = [FDVar]-  -  type FDIntSpecType OvertonFD = ()-  type FDBoolSpecType OvertonFD = ()-  type FDColSpecType OvertonFD = ()--  fdIntSpec_const (Const i) = ((),do-    v <- newvar-    add $ OHasValue v $ fromInteger i-    return v)-  fdIntSpec_term i = ((),return i)-  -  fdBoolSpec_const (BoolConst i) = ((),do-    v <- newvar -    add $ OHasValue v $ if i then 1 else 0-    return v)-  fdBoolSpec_term i = ((),return i)--  fdColSpec_list l = ((),return l)-  fdColSpec_size (Const s) = ((),newVars $ fromInteger s)-  fdColSpec_const l = ((),error "constant collections not yet supported by overton interface")--  fdColInspect = return--  fdSpecify = specify <@> simple_fdSpecify-  fdProcess = process <@> simple_fdProcess--  fdEqualInt v1 v2 = addFD $ OSame v1 v2-  fdEqualBool v1 v2 = addFD $ OSame v1 v2-  fdEqualCol v1 v2 = do-    if length v1 /= length v2-      then setFailed-      else sequence_ $ zipWith (\a b -> addFD $ OSame a b) v1 v2--  fdIntVarSpec = return . Just-  fdBoolVarSpec = return . Just-  fdSplitIntDomain b = do-    d <- fd_domain b-    return $ (map (b `OHasValue`) d, True)-  fdSplitBoolDomain b = do-    d <- fd_domain b-    return $ (map (b `OHasValue`) $ filter (\x -> x==0 || x==1) d, True)---- processBinary :: (EGVarId,EGVarId,EGVarId) -> (FDVar -> FDVar -> FDVar -> OConstraint) -> FDInstance OvertonFD ()-processBinary (v1,v2,va) f = addFD $ f (getDefIntSpec v1) (getDefIntSpec v2) (getDefIntSpec va)---- processUnary :: (EGVarId,EGVarId) -> (FDVar -> FDVar -> OConstraint) -> FDInstance OvertonFD ()-processUnary (v1,va) f = addFD $ f (getDefIntSpec v1) (getDefIntSpec va)--specify :: Mixin (SpecFn OvertonFD)-specify s t edge = case (debug ("overton-specify("++(show edge)++")") edge) of-  EGEdge { egeCons = EGChannel, egeLinks = EGTypeData { intData=[i], boolData=[b] } } -> -    ([(1000,b,True,do-      s <- getIntSpec i-      case s of-        Just ss -> return $ SpecResSpec ((),return (ss,Nothing))-        _ -> return SpecResNone-     )],[(1000,i,True,do-      s <- getBoolSpec b-      case s of-        Just ss -> return $ SpecResSpec ((),return (ss,Nothing))-        _ -> return SpecResNone-     )],[])-  _ -> s edge---- process :: Mixin (EGEdge -> FDInstance OvertonFD ())-process s t con info = case (con,info) of-    (EGIntValue c, ([],[a],[])) -> case c of-      Const v -> addFD $ OHasValue (getDefIntSpec a) (fromInteger v)-      _ -> error "Overton solver does not support parametrized values"-    (EGPlus, ([],[a,b,c],[])) -> processBinary (b,c,a) OAdd-    (EGMinus, ([],[a,b,c],[])) -> processBinary (a,c,b) OAdd-    (EGMult, ([],[a,b,c],[])) -> processBinary (b,c,a) OMult-    (EGAbs, ([],[a,b],[])) -> processUnary (b,a) OAbs-    (EGDiff, ([FDSpecInfoBool {fdspBoolVal = Just (BoolConst True)}],[a,b],[])) -> addFD $ ODiff (getDefIntSpec a) (getDefIntSpec b)-    (EGLess True, ([FDSpecInfoBool {fdspBoolVal = Just (BoolConst True)}],[a,b],[])) -> addFD $ OLess (getDefIntSpec a) (getDefIntSpec b)-    (EGLess False, ([FDSpecInfoBool {fdspBoolVal = Just (BoolConst True)}],[a,b],[])) -> addFD $ OLessEq (getDefIntSpec a) (getDefIntSpec b)-    (EGEqual, ([FDSpecInfoBool {fdspBoolVal = Just (BoolConst True)}],[a,b],[])) -> addFD $ OSame (getDefIntSpec a) (getDefIntSpec b)-    _ -> s con info

− Control/CP/FD/SearchSpec/Data.hs

@@ -1,111 +0,0 @@-{-# 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/SimpleFD.hs

@@ -1,190 +0,0 @@-{-# LANGUAGE TypeFamilies #-}--module Control.CP.FD.SimpleFD (-  simple_fdSpecify,-  simple_fdProcess,-) where--import Data.List (tails)-import qualified Data.Set as Set--import Control.CP.Debug-import Control.Mixin.Mixin-import Control.CP.FD.FD-import Control.CP.Solver-import Control.CP.FD.Graph-import Data.Expr.Data--- import Control.CP.FD.Expr.Util--itake :: [a] -> Int -> Int -> [a]-itake _ _ 0 = []-itake [] _ _ = []-itake (a:ar) 0 l = a:(itake ar 0 (l-1))-itake (a:ar) p l = itake ar (p-1) l--simple_fdSpecify :: (FDSolver s, FDColSpec s ~ [FDIntTerm s], FDIntSpec s ~ FDIntTerm s, FDBoolSpec s ~ FDBoolTerm s) => Mixin (SpecFn s)-simple_fdSpecify s t edge = case (debug ("simple_fdSpecify("++(show edge)++")") edge) of-  EGEdge { egeCons=EGAt, egeLinks = EGTypeData { colData=[c], intData=[r,p] } } -> -    ([],[(500,r,True,do-      k <- getIntVal p-      case k of-        Just (Const kk) -> do-          Just cc <- getColSpec c-          let trm = cc !! fromInteger kk-          return $ SpecResSpec (minBound,return $ (trm, Nothing))-        _ -> return SpecResNone-    )],[])-{-  EGEdge { egeCons=EGSlice f n, egeLinks = EGTypeData { colData=[r,s] } } ->-    ([],[],[(500,r,True,do-      (Just ss) <- getColSpec s-      return $ SpecResSpec (minBound,return $ [ss !! (\(Const x) -> fromInteger x) (f i) | i <- [0..n-1]])-    )]) -}-  EGEdge { egeCons=EGCat, egeLinks = EGTypeData { colData=[r,a,b] } } ->-    ([],[],[(500,r,True,do-      Just aa <- getColSpec a-      Just bb <- getColSpec b-      return $ SpecResSpec (minBound,return (aa++bb,Nothing))-    )])-{-  EGEdge { egeCons=EGRange, egeLinks = EGTypeData { intData=[l,h], colData=[c] } } ->-    ([],[],[(550,c,False,do-      ll <- getIntVal l-      hh <- getIntVal h-      case (ll,hh) of-        (Just lll, Just hhh) -> return $ SpecResSpec (fdColSpec_size (hhh-lll+1) >>= \(t,v) -> return (t,(v,Nothing)))-        _ -> return SpecResNone-    )]) -}-  _ -> s edge--trueSpec = FDSpecInfoBool {fdspBoolSpec=const Nothing,fdspBoolVar=Nothing,fdspBoolVal=Just $ BoolConst True,fdspBoolTypes=Set.empty}--simple_fdProcess :: (FDSolver s, FDColSpec s ~ [FDIntTerm s], FDIntSpec s ~ FDIntTerm s, FDBoolSpec s ~ FDBoolTerm s) => Mixin (EGConstraintSpec -> FDSpecInfo s -> FDInstance s ())-simple_fdProcess s t cons info = case (cons,info) of-    (EGAt,(_,[r,FDSpecInfoInt {fdspIntVal = Just (Const n)}],[c])) -> do-      let cc = getDefColSpec c-          sr = getDefIntSpec r-      fdEqualInt (cc !! fromInteger n) sr-    (EGAt,(_,[r,p],[c])) -> error ("Unsupported EGAt in simple_fdProcess r="++(show r)++" p="++(show p)++" c="++(show c))-    (EGList n,(_,l,[c])) -> do-      let cc = getDefColSpec c-      sequence_ $ zipWith (\id ce -> fdEqualInt ce $ getDefIntSpec id) l cc-    (EGRange, ([],[FDSpecInfoInt {fdspIntVal = Just (Const ll)},FDSpecInfoInt {fdspIntVal=Just (Const hh)}],[c])) -> do-      let cc = getDefColSpec c-      sequence_ $ zipWith (\val var -> t (EGIntValue (Const val)) $ fdSpecInfo_spec ([],[Right (minBound,var)],[])) [ll..hh] cc-    (EGRange, ([],[FDSpecInfoInt {fdspIntVar = Just ll},FDSpecInfoInt {fdspIntVar=Just hh}],[c])) -> do-      let cc = getDefColSpec c-      l <- getIntVal ll-      h <- getIntVal hh-      case (l,h) of-        (Just (Const lll), Just (Const hhh)) -> sequence_ $ zipWith (\val var -> t (EGIntValue (Const val)) $ fdSpecInfo_spec ([],[Right (minBound,var)],[])) [lll..hhh] cc-        _ -> s cons info-    (EGRange, ([],[l,h],[c])) -> do-      error ("Unsupported EGRange in simple_fdProcess: l=("++(show l)++") h=("++(show h)++") c=("++(show c)++")")-    (EGSorted q, (_,_,[c])) -> do-      let cc = getDefColSpec c-      sequence_ $ zipWith (\a b -> t (EGLess q) $ fdSpecInfo_spec ([Left trueSpec],[Right (minBound,a), Right (minBound,b)],[])) cc (tail cc)-    (EGAllDiff _, (_,_,[c])) -> do-      let cc = getDefColSpec c-      sequence_ [ t EGDiff $ fdSpecInfo_spec ([Left trueSpec],[Right (minBound,x), Right (minBound,e)],[])  | (x:xs) <- tails cc, e <- xs ]-    (EGAll sm (nb,ni,nc) force,(r:vb,vi,c:vc)) -> do-      let dr = getDefBoolSpec r-      let dc = getDefColSpec c-      let dcs = length dc-      debug ("iter_process EGAll: dcs="++(show dcs)) $ return ()-      if force-        then do-          let mf i = do-                let v = dc!!i-                dv <- liftFD $ specInfoIntTerm v-                let fb (-1) = error "SimpleFD EGAll undefined 1"-                    fb n = vb!!n-                    fi (-1) = dv-                    fi n = vi!!n-                procSubModel sm (fb,fi,(vc!!))-          mapM_ mf [0..fromIntegral $ dcs-1]-        else do-          let mf i = do-                let v = dc!!i-                b <- liftFD $ newvar-                db <- liftFD $ specInfoBoolTerm b-                dv <- liftFD $ specInfoIntTerm v-                let fb (-1) = db-                    fb n = vb!!n-                    fi (-1) = dv-                    fi n = vi!!n-                procSubModel sm (fb,fi,(vc!!))-                return b-          bools <- mapM mf [0..fromIntegral $ dcs-1]-          treeAll t EGAnd True bools-          return ()-    (EGAny sm (nb,ni,nc) _,(r:vb,vi,c:vc)) -> do-      let dr = getDefBoolSpec r-      let dc = getDefColSpec c-      let dcs = length dc-      let mf i = do-            let v = dc!!i-            b <- liftFD $ newvar-            db <- liftFD $ specInfoBoolTerm b-            dv <- liftFD $ specInfoIntTerm v-            let fb (-1) = db-                fb n = vb!!n-                fi (-1) = dv-                fi n = vi!!n-                fc n = vc!!n-            procSubModel sm (fb,fi,fc)-            return b-      bools <- mapM mf [0..fromIntegral $ dcs-1]-      treeAll t EGOr False bools-      return ()-    (EGMap sm (nb,ni,nc),(vb,vi,cr:c:vc)) -> do-      let dc = getDefColSpec c-      let dcr = getDefColSpec cr-      let dcs = length dc-      let mf i = do-            let vin = dc!!i-            let vout = dcr!!i-            din <- liftFD $ specInfoIntTerm vin-            dout <- liftFD $ specInfoIntTerm vout-            let fi (-1) = dout-                fi (-2) = din-                fi n = vi!!n-                fb n = vb!!n-                fc n = vc!!n-            procSubModel sm (fb,fi,fc)-      mapM_ mf [0..fromIntegral $ dcs-1]-    (EGFold sm (nb,ni,nc),(vb,r:ss:vi,c:vc)) -> do-      let dc = getDefColSpec c-      let dinit = getDefIntSpec ss-      let dcs = length dc-      let dres = getDefIntSpec r-      tmp <- mapM (const $ liftFD newvar) [0..dcs-2]-      let tmpv = tmp++[dres]-      let mf i = do-            let vin1 = if (i==0) then dinit else tmpv!!(i-1)-                vout = tmpv!!i-            let vin2 = dc!!i-            din1 <- liftFD $ specInfoIntTerm vin1-            din2 <- liftFD $ specInfoIntTerm vin2-            dout <- liftFD $ specInfoIntTerm vout-            let fi (-1) = dout-                fi (-2) = din1-                fi (-3) = din2-                fi n = vi!!n-                fb n = vb!!n-                fc n = vc!!n-            procSubModel sm (fb,fi,fc)-      mapM_ mf [0..fromIntegral $ dcs-1]-    _ -> s cons info--treeAll :: (FDSolver s, FDBoolSpec s ~ FDBoolTerm s) => (EGConstraintSpec -> FDSpecInfo s -> FDInstance s ()) -> EGConstraintSpec -> Bool -> [FDBoolSpec s] -> FDInstance s (FDBoolSpec s)-treeAll p c d [] = return $ error "SimpleFD treeAll undefined"-treeAll p c d [a] = return a-treeAll p c d x = do-  let (l,r) = splitAt ((length x) `div` 2) x-  ld <- treeAll p c d l-  rd <- treeAll p c d r-  ldi <- liftFD $ specInfoBoolTerm ld-  rdi <- liftFD $ specInfoBoolTerm rd-  o <- liftFD $ newvar-  oi <- liftFD $ specInfoBoolTerm o-  p c ([oi,ldi,rdi],[],[])-  return o

− Control/CP/FD/Solvers.hs

@@ -1,52 +0,0 @@-module Control.CP.FD.Solvers where--import qualified Control.CP.PriorityQueue as PriorityQueue-import qualified Data.Sequence--import Control.CP.ComposableTransformers-import Control.CP.SearchTree-import Control.CP.FD.FD--- import Control.CP.FD.OvertonFD.Sugar--- import Control.CP.FD.OvertonFD.OvertonFD--- import Control.CP.FD.Gecode.CodegenSolver------------------------------------------------------------------------------------- FORCE SOLVERS------------------------------------------------------------------------------------- as_overtonfd :: Tree (FDWrapper OvertonFD) a -> Tree OvertonFD a--- as_overtonfd = unwrap--- --- as_gecode_codegen :: Tree (FDWrapper CodegenSolver) a -> Tree CodegenSolver a--- as_gecode_codegen = unwrap--- --- as_gen_gecode_codegen :: (FDExpr CodegenSolver -> Tree (FDWrapper CodegenSolver) a) -> (FDExpr CodegenSolver -> Tree CodegenSolver a)--- as_gen_gecode_codegen f = (\x -> unwrap $ f x)--- ----------------------------------------------------------------------------------- SEARCH STRATEGIES---------------------------------------------------------------------------------dfs = []-bfs = Data.Sequence.empty-pfs :: Ord a => PriorityQueue.PriorityQueue a (a,b,c)-pfs = PriorityQueue.empty--nb :: Int -> CNodeBoundedST s a-nb = CNBST-db :: Int -> CDepthBoundedST s a-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-it = CIST-ra :: Int -> CRandomST s a-ra = CRST-ld :: Int -> CLimitedDiscrepancyST s a-ld = CLDST-

− Control/CP/PriorityQueue.hs

@@ -1,110 +0,0 @@-{- Copyright (c) 2008 the authors listed at the following URL, and/or-the authors of referenced articles or incorporated external code:-http://en.literateprograms.org/Priority_Queue_(Haskell)?action=history&offset=20080608152146--Permission is hereby granted, free of charge, to any person obtaining-a copy of this software and associated documentation files (the-"Software"), to deal in the Software without restriction, including-without limitation the rights to use, copy, modify, merge, publish,-distribute, sublicense, and/or sell copies of the Software, and to-permit persons to whom the Software is furnished to do so, subject to-the following conditions:--The above copyright notice and this permission notice shall be-included in all copies or substantial portions of the Software.--THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,-EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF-MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT.-IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY-CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT,-TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE-SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE.--Retrieved from: http://en.literateprograms.org/Priority_Queue_(Haskell)?oldid=13634--}--module Control.CP.PriorityQueue (-    PriorityQueue,-    empty,-    is_empty,-    minKey,-    minKeyValue,-    insert,-    deleteMin,-    deleteMinAndInsert-) where-- -import Prelude----- Declare the data type constructors.--data Ord k => PriorityQueue k a = Nil | Branch k a (PriorityQueue k a) (PriorityQueue k a)- ---- Declare the exported interface functions.---- Return an empty priority queue.--is_empty Nil = True-is_empty _   = False--empty :: Ord k => PriorityQueue k a-empty = Nil----- Return the highest-priority key.--minKey :: Ord k => PriorityQueue k a -> k-minKey = fst . minKeyValue----- Return the highest-priority key plus its associated value.--minKeyValue :: Ord k => PriorityQueue k a -> (k, a)-minKeyValue Nil              = error "empty queue"-minKeyValue (Branch k a _ _) = (k, a)----- Insert a key/value pair into a queue.--insert :: Ord k => k -> a -> PriorityQueue k a -> PriorityQueue k a-insert k a q = union (singleton k a) q--deleteMin :: Ord k => PriorityQueue k a -> ((k,a), PriorityQueue k a)-deleteMin(Branch k a l r) = ((k,a),union l r)---- Delete the highest-priority key/value pair and insert a new key/value pair into the queue.--deleteMinAndInsert :: Ord k => k -> a -> PriorityQueue k a -> PriorityQueue k a-deleteMinAndInsert k a Nil              = singleton k a-deleteMinAndInsert k a (Branch _ _ l r) = union (insert k a l) r------ Declare the private helper functions.---- Join two queues in sorted order.--union :: Ord k => PriorityQueue k a -> PriorityQueue k a -> PriorityQueue k a-union l Nil = l-union Nil r = r-union l@(Branch kl _ _ _) r@(Branch kr _ _ _)-    | kl <= kr  = link l r-    | otherwise = link r l----- Join two queues without regard to order.---- (This is a helper to the union helper.)--link (Branch k a Nil m) r = Branch k a r m-link (Branch k a ll lr) r = Branch k a lr (union ll r)----- Return a queue with a single item from a key/value pair.--singleton :: Ord k => k -> a -> PriorityQueue k a-singleton k a = Branch k a Nil Nil

− Control/CP/Queue.hs

@@ -1,53 +0,0 @@-{-# LANGUAGE TypeFamilies #-}-{-# LANGUAGE ViewPatterns #-}-{-# LANGUAGE FlexibleInstances #-}-{-- - The Queue data type, a worklist data type for search.- -- - 	Monadic Constraint Programming- - 	http://www.cs.kuleuven.be/~toms/Haskell/- - 	Tom Schrijvers- -}--module Control.CP.Queue (-  Queue,-  Elem,-  emptyQ,-  isEmptyQ,-  popQ,-  pushQ-) where--import qualified Data.Sequence-import qualified Control.CP.PriorityQueue as PriorityQueue--class Queue q where   -  type Elem q :: *-  emptyQ   :: q -> q-  isEmptyQ :: q -> Bool-  popQ     :: q -> (Elem q,q)-  pushQ    :: Elem q -> q -> q--instance Queue [a] where-  type Elem [a] = a-  emptyQ _     = []-  isEmptyQ     = Prelude.null-  popQ (x:xs)  = (x,xs)-  pushQ        = (:)--instance Queue (Data.Sequence.Seq a) where-  type Elem (Data.Sequence.Seq a)  = a-  emptyQ _                   = Data.Sequence.empty-  isEmptyQ                   = Data.Sequence.null ---  popQ (Data.Sequence.viewl -> x Data.Sequence.:< xs)  = (x,xs)-  popQ l                     = case Data.Sequence.viewl l of-    x Data.Sequence.:< xs -> (x,xs)-  pushQ                      = flip (Data.Sequence.|>)--instance Ord a => Queue (PriorityQueue.PriorityQueue a (a,b,c)) where-  type Elem (PriorityQueue.PriorityQueue a (a,b,c)) = (a,b,c)-  emptyQ _ = PriorityQueue.empty-  isEmptyQ = PriorityQueue.is_empty -  pushQ x@(k,_,_)  = PriorityQueue.insert k x-  popQ q   = let ((_,x),q') = PriorityQueue.deleteMin q-             in (x,q')

− Control/CP/SearchTree.hs

@@ -1,324 +0,0 @@-{-- - The Tree data type, a generic modelling language for constraint solvers.- -- - 	Monadic Constraint Programming- - 	http://www.cs.kuleuven.be/~toms/Haskell/- - 	Tom Schrijvers- -}-{-# LANGUAGE TypeFamilies #-}-{-# LANGUAGE GADTs #-}-{-# LANGUAGE RankNTypes #-}-{-# LANGUAGE FlexibleContexts #-}--module Control.CP.SearchTree (-  Tree(..),-  transformTree,-  bindTree,-  insertTree,-  (/\),-  true,-  disj,-  conj,-  disj2,-  prim,-  addC,-  addT,-  exist,-  forall,-  indent,-  showTree,-  mapTree,-  MonadTree(..),-  untree-) where--import Control.CP.Solver-import Control.Mixin.Mixin--import Control.Monad-import Control.Monad.Cont-import Control.Monad.Reader-import Control.Monad.Writer-import Control.Monad.State--import Data.Monoid---------------------------------------------------------------------------------------------------------------------- Tree ------------------------------------------------------------------------------------------------------------------------data Tree s a where-  Fail    :: Tree s a                                  -- failure-  Return  :: a -> Tree s a                             -- finished-  Try     :: Tree s a -> Tree s a -> Tree s a          -- disjunction-  Add     :: Constraint s -> Tree s a -> Tree s a      -- sequentially adding a constraint to a tree-  NewVar  :: Term s t => (t -> Tree s a) -> Tree s a   -- add a new variable to a tree-  Label   :: s (Tree s a) -> Tree s a      	       -- label with a strategy--flattenTree :: Solver s => Tree s a -> Maybe ([Constraint s],a)-flattenTree Fail = Nothing-flattenTree (Return a) = Just ([],a)-flattenTree (Try _ _) = Nothing-flattenTree (Add c t) = case flattenTree t of-  Nothing -> Nothing-  Just (l,a) -> Just (c:l,a)-flattenTree (NewVar _) = Nothing-flattenTree (Label _) = Nothing--transformTree :: Solver s => Mixin (Tree s a -> Tree s a)-transformTree _ _ Fail = Fail-transformTree _ _ (Return x) = Return x-transformTree _ t (Try x y) = Try (t x) (t y)-transformTree _ t (Add c x) = Add c (t x)-transformTree _ t (NewVar f) = NewVar (\x -> t $ f x)-transformTree _ t (Label m) = Label $ m >>= return . t--- transformTree s _ x = s x--mapTree :: (Solver s1, Solver s2, MonadTree m, TreeSolver m ~ s2) => (forall t. s1 t -> s2 t) -> Tree s1 a -> m a-mapTree _ Fail = false-mapTree _ (Return a) = return a-mapTree f (Try a b) = mapTree f a \/ mapTree f b--- mapTree f (Add c n) = label $ f $ (add c >>= \t -> if t then return (mapTree f n) else return false)--- mapTree (NewVar _) = undefined-mapTree f (Label l) = label $ (f l) >>= (\t -> return (mapTree f t))--instance Solver s => Functor (Tree s) where-	fmap  = liftM - -instance Solver s => Monad (Tree s) where-  return = Return-  (>>=)  = bindTree-  --bindTree     :: Solver s => Tree s a -> (a -> Tree s b) -> Tree s b-Fail           `bindTree` k  = Fail-(Return x)     `bindTree` k  = k x-(Try m n)      `bindTree` k  = Try (m `bindTree` k) (n `bindTree` k)-(Add c m)      `bindTree` k  = Add c (m `bindTree` k)-(NewVar f)   `bindTree` k  = NewVar (\x -> f x `bindTree` k)    -(Label m)      `bindTree` k  = Label (m >>= \t -> return (t `bindTree` k))--insertTree     :: Solver s => Tree s a -> Tree s () -> Tree s a-(NewVar f)   `insertTree` t  = NewVar (\x -> f x `insertTree` t)    -(Add c  o)     `insertTree` t  = Add c (o `insertTree` t)-other 	       `insertTree` t  = t /\ other--{- Monad laws:- -- - 1. return x >>= f  ==  f x- -- -    return a >>= f  - -    == Return a >>= f		(return def)- -    == f x			(bind def) - -- - 2. m >>= return  =  m- -- -   By induction- -     case m of- -     1) Return x -> - -          Return x >>= return- -          == return x			(bind def)- -          == Return x        		(return def)- -     2) Fail ->- -          Fail >>= return- -          == Fail			(bind def)- -     3)  Try l r >>= return- -         == Try (l >>= return) (r >>= return) (bind def)- -         == Try l r				(induction)- -      4) Add c m >>= return- -         == Add c (m >>= return) 	(bind def)- -         == Add c m 			(induction) - - 	5) NewVar i f >>= return- - 	   == NewVar i (\v -> f v >>= return) 	(bind def) - - 	   == NewVar i (\v -> f v)		((co)-induction?)- - 	   == NewVar i f				(eta reduction)- - 	6) Label sm >>= return- - 	   == Label (sm >>= \m -> return (m >>= return))	(bind def)- - 	   == Label (sm >>= \m -> return m)			(co-induction)- - 	   == Label (sm >>= return)				(eta reduction)- - 	   == Label sm						(2nd monad law for Monad s)- -- - 3. (m >>= f) >>= g = m >>= (\x -> f x >>= g)- - - -   By induction- -     case m of- -     1) (Return y >>= f) >>= g - -	  == f y >>= g					(bind def)- -	  == (\x -> f x >>= g) y			(beta expansion)- -	  == Return y >>= (\x -> f x >>= g)		(bind def)- -     2) (Fail >>= f) >>= g- -        == Fail >>= g					(bind def)- -        == Fail					(bind def)- -        == Fail >>= (\x -> f x >>= g)			(bind def) - -     3) (Try l r >>= f) >>= g- -        == Try (l >>= f) (r >>= f)) >>= g 				(bind def)- -        == Try ((l >>= f) >>= g) ((r >>= f) >>= g)			(bind def)- -        == Try (l >>= (\x -> f x >>= g)) (r >>= (\x -> f x >>= g)) 	(induction)- -        == Try l r >>= (\x -> f x >>= g)				(bind def)- -     4) (NewVar i m >>= f) >>= g- -        == NewVar i (\v -> m v >>= f) >>= g			(bind def)- -        == NewVar i (\w -> (\v -> m v >>= f) w >>= g)		(bind def)- -        == NewVar i (\w -> (m w >>= f) >>= g)			(beta reduction)  - -        == NewVar i (\w -> m w >>= (\x -> f x >>= g))		(co-induction)- -        == NewVar i m >>= (\x -> f x >>= g)			(bind def)- -     5) (Label sm >>= f) >>= g- -         == Label (sm >>= \m -> return (m >>= f)) >>= g 	(bind def) - -         == Label ((sm >>= \m -> return (m >>= f)) >>= \m' -> return (m' >>= g))- -         == Label (sm >>= (\m -> return (m >>= f) >>= \m' -> return (m' >>= g)))- -         == Label (sm >>= \m -> return ((m >>= f) >>= g))- -         == Label (sm >>= \m -> return (m >>= (\x -> f x >>= g)))- -         == Label sm >>= (\x -> f x >>= g)- -- -}--------------------------------------------------------------------------------------------------------------------- Monad Subclass --------------------------------------------------------------------------------------------------------------infixl 2 \/---- | Generalization of the search tree data type,---   allowing monad transformer decoration.-class (Monad m, Solver (TreeSolver m)) => MonadTree m where-  type TreeSolver m :: * -> *-  addTo   :: Constraint (TreeSolver m) -> m a -> m a-  false   :: m a-  (\/)    :: m a -> m a -> m a-  exists  :: Term (TreeSolver m) t => (t -> m a) -> m a-  label   :: (TreeSolver m) (m a) -> m a--instance Solver solver => MonadTree (Tree solver) where-  type TreeSolver (Tree solver)  = solver-  addTo   =  Add-  false   =  Fail-  (\/)    =  Try-  exists  =  NewVar-  label   =  Label--instance (MonadTree m, Solver (TreeSolver m)) => MonadTree (ContT r m) where-  type TreeSolver (ContT r m) = TreeSolver m-  addTo constraint cm = ContT $ \k -> addTo constraint (runContT cm k) -  false               = lift false-  l \/ r              = ContT $ \k -> (runContT l k) \/ (runContT r k)-  exists f            = ContT $ \k -> exists (\t -> runContT (f t) k)-  label scm           = ContT $ \k -> label (scm >>= \cm -> return $ runContT cm k)--------------------------------------------------------------------------------------------------------------------- Sugar ---------------------------------------------------------------------------------------------------------------------- -infixr 3 /\-(/\) :: MonadTree tree => tree a -> tree b -> tree b-(/\) = (>>)- -true :: MonadTree tree  => tree ()-true = return ()--disj :: MonadTree tree => [tree a] -> tree a-disj [] = false-disj a = foldr1 (\/) a--conj :: MonadTree tree => [tree ()] -> tree ()-conj [] = true-conj a = foldr1 (/\) a--disj2 :: MonadTree tree => [tree a] -> tree a-disj2 (x:  [])  = x-disj2 l        = let (xs,ys)      = split l-                     split []     = ([],[])-                     split (a:as) = let (bs,cs) = split as-                                    in  (a:cs,bs)-                 in  (disj2 xs) \/ (disj2 ys)--prim :: MonadTree tree => TreeSolver tree a -> tree a-prim action = label (action >>= return . return)--addC :: MonadTree tree => Constraint (TreeSolver tree) -> tree ()-addC c = c `addTo` true--addT :: MonadTree tree => Constraint (TreeSolver tree) -> tree Bool-addT c = c `addTo` (return True)--exist :: (MonadTree tree, Term (TreeSolver tree) t) => Int -> ([t] -> tree a) -> tree a-exist n ftree = f n []-         where f 0 acc  = ftree $ reverse acc-               f n acc  = exists $ \v -> f (n-1) (v:acc)--forall :: (MonadTree tree, Term (TreeSolver tree) t)  => [t] -> (t -> tree ()) -> tree ()-forall list ftree = conj $ map ftree list---- Shortcut the search procedure for a Tree that does not contain Try nodes.--- create a solver monad that returns the result of the Tree, or a specified--- value upon failure-untree :: Solver s => v -> Tree s v -> s v-untree _ (Return x) = return x-untree _ (Try _ _) = error "convertion of Try nodes to solver is not supported"-untree e (Fail) = return e-untree e (Label s) = s >>= untree e-untree e (Add c t) = (add c) >>= (\x -> if x then untree e t else return e)-untree e (NewVar f) = do-    v <- newvar-    untree e (f v)---- | show--indent :: Int -> String-indent l = replicate (2*l) ' '--showTree :: (Show (Constraint s), Show a, Solver s) => Int -> Tree s a -> s String-showTree l Fail = return $ indent l ++ "Fail\n"-showTree l (Return x) = return $ indent l ++ "Return [" ++ (show x) ++ "]\n"-showTree l (Try a b) = do-  m <- mark-  s1 <- showTree (l+1) a-  goto m-  s2 <- showTree (l+1) b-  return $ indent l ++ "Try\n" ++ s1 ++ s2-showTree l (Add c t) = do-  s <- showTree (l+1) t-  return $ indent l ++ "Add (" ++ (show c) ++ ")\n" ++ s-showTree l (NewVar f) = do-  n <- newvar-  s <- showTree (l+1) (f n)-  return $ indent l ++ "NewVar\n" ++ s-showTree l (Label a) = do-  r <- a-  s <- showTree (l+1) r-  return $ indent l ++ "Label\n" ++ s--instance Show (Tree s a)  where-  show Fail		= "Fail"-  show (Return _)	= "Return"-  show (Try l r)	= "Try (" ++ show l ++ ") (" ++ show r ++ ")"-  show (Add _ t)	= "Add (" ++ show t ++ ")"-  show (NewVar _)	= "NewVar <function>"-  show (Label _)	= "Label <monadic value>"--------------------------------------------------------------------------- Monad Transformer Instances-------------------------------------------------------------------------instance MonadTree t => MonadTree (ReaderT env t) where-  type TreeSolver (ReaderT env t) = TreeSolver t-  addTo constraint tree  = ReaderT $ \env -> addTo constraint (runReaderT tree env)-  false     = lift false-  l \/ r    = ReaderT $ \env -> runReaderT l env \/ runReaderT r env-  exists f  = ReaderT $ \env -> exists (\var -> runReaderT (f var) env)-  label p   = ReaderT $ \env -> label (p >>= \m -> return $ runReaderT m env)--instance (Monoid w, MonadTree t) => MonadTree (WriterT w t) where-  type TreeSolver (WriterT w t)  = TreeSolver t-  addTo constraint tree  = WriterT $ addTo constraint (runWriterT tree)-  false     = lift false -  l \/ r    = WriterT $ runWriterT l \/ runWriterT r-  exists f  = WriterT $ exists (\var -> runWriterT (f var))-  label p   = WriterT $ label (p >>= \m -> return $ runWriterT m)--instance MonadTree t => MonadTree (StateT s t) where-  type TreeSolver (StateT s t) = TreeSolver t-  addTo constraint tree  = StateT $ \s -> addTo constraint (runStateT tree s)-  false     = lift false-  l \/ r    = StateT $ \s -> runStateT l s \/ runStateT r s-  exists f  = StateT $ \s -> exists (\var -> runStateT (f var) s)-  label p   = StateT $ \s -> label (p >>= \m -> return $ runStateT m s)

− Control/CP/Solver.hs

@@ -1,80 +0,0 @@-{-- - The Solver class, a generic interface for constraint solvers.- -- - 	Monadic Constraint Programming- - 	http://www.cs.kuleuven.be/~toms/Haskell/- - 	Tom Schrijvers- -}--{-# LANGUAGE TypeFamilies #-}-{-# LANGUAGE MultiParamTypeClasses #-}-{-# LANGUAGE FlexibleInstances #-}--module Control.CP.Solver (-  Solver,-  Constraint,-  Label,-  add,-  run,-  mark, markn,-  goto,-  Term,-  newvar,-  Help,-  help,-) where --import Control.Monad.Writer-import Data.Monoid--class Monad solver => Solver solver where-	-- | the constraints-	type Constraint solver 	:: *- 	-- | the labels-	type Label solver	:: *-	-- | add a constraint to the current state, and-	--   return whether the resulting state is consistent-	add		:: Constraint solver -> solver Bool-	-- | run a computation-	run		:: solver a -> a-	-- | mark the current state, and return its label-	mark		:: solver (Label solver)-	-- | mark the current state as discontinued, yet return a label that is usable n times-	markn		:: Int -> solver (Label solver)-	-- | go to the state with given label-	goto		:: Label solver -> solver ()-	-	markn _ = mark--class (Solver solver) => Term solver term where-	-- | produce a fresh constraint variable-	newvar 	:: solver term--        -- see note [Solver-Specific Term Operations]-        type Help solver term-        help :: solver () -> term -> Help solver term---- [Solver-Specific Term Operations]------ Terms of solvers in general only support the 'newvar' operation.--- However, for specific solvers, all terms may support additional--- operations.------ The 'Help'/'help' infrastructure allows accessing this solver-specific--- term operations.---- | WriterT decoration of a solver---   useful for producing statistics during solving-instance (Monoid w, Solver s) => Solver (WriterT w s) where-  type Constraint (WriterT w s)  = Constraint s-  type Label (WriterT w s)       = Label s-  add  = lift . add-  run  = fst . run . runWriterT-  mark = lift mark-  markn = lift . markn-  goto = lift . goto --instance (Monoid w, Term s t) => Term (WriterT w s) t where-  newvar  = lift newvar-  type Help (WriterT w s) t = ()-  help _ _ = ()

− Control/CP/Transformers.hs

@@ -1,114 +0,0 @@-{- - - 	Monadic Constraint Programming- - 	http://www.cs.kuleuven.be/~toms/Haskell/- - 	Tom Schrijvers- -}-{-# LANGUAGE TypeFamilies #-}-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE Rank2Types #-}-{-# LANGUAGE BangPatterns #-}-module Control.CP.Transformers (-  eval,-  eval',-  continue,-  NodeBoundedST,-  DepthBoundedST,-  Transformer(..),-) where --import Control.CP.Solver-import Control.CP.SearchTree-import Control.CP.Queue-import Control.CP.Debug------------------------------------------------------------------------------------- EVALUATION-----------------------------------------------------------------------------------eval :: (Solver solver, Queue q, Elem q ~ (Label solver,Tree solver (ForResult t),TreeState t), Transformer t,-         ForSolver t ~ solver) -     => Tree solver (ForResult t) -> q -> t -> solver (Int,[ForResult t])-eval tree q t  = debug "eval" $ -                   do (es,ts) <- initT t tree-                      eval' 0 tree q t es ts--eval' :: SearchSig solver q t (ForResult t) -eval' !i (Return x) wl t es ts  = do (j,xs) <- returnT (i+1) wl t es-                                     return (j,(x:xs)) -eval' i (Add c k)  wl t es ts = do b <- Control.CP.Solver.add c -                                   if b then eval' (i+1) k wl t es ts-                                        else continue (i+1) wl t es-eval' i (NewVar f) wl t es ts = do v <- newvar-                                   eval' (i+1) (f v) wl t es ts-eval' i (Try l r)  wl t es ts  = -  do now <- markn 2-     let wl' = pushQ (now,l,leftT t es ts) $ pushQ (now,r,rightT t es ts) wl-     continue (i+1) wl' t es-eval' i Fail       wl t es ts  = continue (i+1) wl t es-eval' i (Label m)  wl t es ts  = do tree <- m-                                    eval' (i+1) tree wl t es ts- -continue :: ContinueSig solver q t (ForResult t) -continue i wl t es  -	| isEmptyQ wl  = endT i wl t es -- return (i,[])-        | otherwise    = let ((past,tree,ts),wl') = popQ wl-                         in  do goto past-                                nextT i tree wl' t es ts ------------------------------------------------------------------------------------- TRANSFORMER-----------------------------------------------------------------------------------type SearchSig solver q t a =-     (Solver solver, Queue q, Transformer t,   -          Elem q ~ (Label solver,Tree solver a,TreeState t),-	  ForSolver t ~ solver) -     => Int -> Tree solver a -> q -> t -> EvalState t -> TreeState t -> solver (Int,[a])--type ContinueSig solver q t a =-     (Solver solver, Queue q, Transformer t,   -          Elem q ~ (Label solver,Tree solver a,TreeState t),-	  ForSolver t ~ solver) -     => Int -> q -> t -> EvalState t -> solver (Int,[a])--class Transformer t where-  type EvalState t :: *-  type TreeState t :: *-  type ForSolver t :: (* -> *)-  type ForResult t :: *-  leftT, rightT :: t -> EvalState t -> TreeState t -> TreeState t-  leftT  _ _ = id-  rightT    = leftT-  nextT :: SearchSig (ForSolver t) q t (ForResult t)-  nextT  = eval'-  initT :: t -> Tree (ForSolver t) (ForResult t) -> (ForSolver t) (EvalState t,TreeState t)-  returnT :: ContinueSig solver q t (ForResult t) -  returnT i wl t es  = continue i wl t es-  endT  :: ContinueSig solver q t (ForResult t)-  endT i wl t es     = return (i,[])--newtype DepthBoundedST (solver :: * -> *) a = DBST Int--instance Solver solver => Transformer (DepthBoundedST solver a) where-  type EvalState (DepthBoundedST solver a)  = ()-  type TreeState (DepthBoundedST solver a)  = Int-  type ForSolver (DepthBoundedST solver a)  = solver-  type ForResult (DepthBoundedST solver a)  = a-  initT (DBST n) _  = return ((),n)-  leftT _ _ ts      = ts - 1-  nextT i tree q t es ts-    | ts == 0    = continue i q t es-    | otherwise  = eval' i tree q t es ts--newtype NodeBoundedST (solver :: * -> *) a = NBST Int--instance Solver solver => Transformer (NodeBoundedST solver a)  where-  type EvalState (NodeBoundedST solver a) = Int-  type TreeState (NodeBoundedST solver a) = ()-  type ForSolver (NodeBoundedST solver a) = solver-  type ForResult (NodeBoundedST solver a) = a-  initT (NBST n) _  = return (n,())-  nextT i tree q t es ts-    | es == 0    = return (i,[])-    | otherwise  = eval' i tree q t (es - 1) ts-

− Control/Mixin/Mixin.hs

@@ -1,60 +0,0 @@--- | Module with basic infrastructure for function inheritance---   based on open rercusion.------   See the work of William Cook.------   We use the following terminology.------     * A /closed/ function is an ordinary function. ------     * A /mixin/ function is an open function that can be---       inherited from, or that extends another open function.------   We obtain a closed function from a base mixin 'base'---   and a number of mixin extensions 'e1',...,'en' as follows:------ >  mixin (en <@> ... <@> e1 <@> base)---  -module Control.Mixin.Mixin (-  Mixin,-  (<@>),-  mixin,-  mixinId,-  mixinLift-) where--infixl 5 <@>---- | Type of mixin functions.-type Mixin a =  a -- the 'super' function-	     -> a -- the 'this'  function-	     -> a -- the current function---- | Mixin composition.-(<@>) :: Mixin a -> Mixin a -> Mixin a-(f1 <@> f2) super this = f1 (f2 super this) this---- | Turn a mixin into a closed function.-mixin :: Mixin a -> a-mixin openF -  = let closedF = openF errorF closedF -        errorF  = error $ "super called in base mixin"-    in closedF---- | Mixin identity function.------ Identity for mixin composition:--- ---   --- > mixinId <@> f  ==  f--- > f <@> mixinId  ==  f---  -mixinId :: Mixin a-mixinId super this = super---- | Mixin lift function------ > mixin . mixinLift = id--mixinLift :: (a -> b) -> Mixin (a -> b)-mixinLift f _ _ = f

− Control/Monatron/AutoInstances.hs

@@ -1,16 +0,0 @@-{-# 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

@@ -1,128 +0,0 @@-{-# 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

@@ -1,36 +0,0 @@-{-# 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

@@ -1,13 +0,0 @@-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

@@ -1,67 +0,0 @@--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

@@ -1,74 +0,0 @@-{-# 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

@@ -1,47 +0,0 @@-{-# 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

@@ -1,12 +0,0 @@--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

@@ -1,58 +0,0 @@--- {-# OPTIONS -fglasgow-exts -XNoMonomorphismRestriction -XOverlappingInstances #-}--{-# LANGUAGE NoMonomorphismRestriction #-}-{-# LANGUAGE OverlappingInstances #-}-{-# LANGUAGE TypeOperators #-}-{-# LANGUAGE MultiParamTypeClasses #-}-{-# LANGUAGE FlexibleInstances #-}--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

@@ -1,195 +0,0 @@-{-# 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

@@ -1,286 +0,0 @@-{-# 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 hiding ((<>))--- 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

@@ -1,123 +0,0 @@--- {-# OPTIONS -fglasgow-exts -XNoMonomorphismRestriction #-}-{-# LANGUAGE NoMonomorphismRestriction #-}-{-# LANGUAGE KindSignatures #-}-{-# LANGUAGE TypeOperators #-}-{-# LANGUAGE MultiParamTypeClasses #-}--{-# 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

@@ -1,83 +0,0 @@-{-# 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

@@ -1,143 +0,0 @@-{-# LANGUAGE FlexibleContexts #-}--module Control.Search.Combinator.And (andN,(<&>)) where--import Data.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

@@ -1,320 +0,0 @@-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

@@ -1,40 +0,0 @@-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

@@ -1,115 +0,0 @@-{-# 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

@@ -1,151 +0,0 @@-{-# 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

@@ -1,41 +0,0 @@-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

@@ -1,85 +0,0 @@-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE RankNTypes #-}--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

@@ -1,30 +0,0 @@-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

@@ -1,174 +0,0 @@-{-# 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

@@ -1,95 +0,0 @@-{-# 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

@@ -1,34 +0,0 @@-{-# 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

@@ -1,34 +0,0 @@-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE RankNTypes #-}--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

@@ -1,84 +0,0 @@-{-# 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

@@ -1,38 +0,0 @@-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

@@ -1,188 +0,0 @@-{-# 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

@@ -1,71 +0,0 @@-{-# 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 Data.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

@@ -1,855 +0,0 @@-{-# 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 Data.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

@@ -1,120 +0,0 @@-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

@@ -1,531 +0,0 @@-{-# LANGUAGE FlexibleInstances #-}--module Control.Search.Language  where --import Text.PrettyPrint-import Data.Monoid hiding ((<>))-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

@@ -1,67 +0,0 @@-{-# 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 Data.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

@@ -1,61 +0,0 @@-{-# 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

@@ -1,47 +0,0 @@-{-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE MultiParamTypeClasses #-}--module Control.Search.SStateT (-  SStateT, sstateT, runSStateT,-  Tup2(..), snd2, fst2-) where--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

@@ -1,185 +0,0 @@-{-# 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"

− Data/Expr/Data.hs

@@ -1,297 +0,0 @@-{- - - 	Monadic Constraint Programming- - 	http://www.cs.kuleuven.be/~toms/MCP/- - 	Pieter Wuille- -}--{-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE StandaloneDeriving #-}--module Data.Expr.Data (-  Expr(..),-  ColExpr(..),-  BoolExpr(..),-  ExprRel(..),-  (<<>>)-) where ------------------------- | Data types | --------------------------- some simple kinds of expressions-data Expr t c b =-    Term t-  | ExprHole Int-  | Const Integer-  | Plus (Expr t c b) (Expr t c b)-  | Minus (Expr t c b) (Expr t c b)-  | Mult (Expr t c b) (Expr t c b)-  | Div (Expr t c b) (Expr t c b)-  | Mod (Expr t c b) (Expr t c b)-  | Abs (Expr t c b)-  | At (ColExpr t c b) (Expr t c b)-  | Fold (Expr t c b -> Expr t c b -> Expr t c b) (Expr t c b) (ColExpr t c b)-  | Cond (BoolExpr t c b) (Expr t c b) (Expr t c b)-  | ColSize (ColExpr t c b)-  | Channel (BoolExpr t c b)--data ColExpr t c b = -    ColTerm c-  | ColList [Expr t c b]-  | ColRange (Expr t c b) (Expr t c b)-  | ColMap (Expr t c b -> Expr t c b) (ColExpr t c b)-  | ColSlice (Expr t c b -> Expr t c b) (Expr t c b) (ColExpr t c b)   -- ColSlice f n c -> c[f(0)..f(n-1)]-  | ColCat (ColExpr t c b) (ColExpr t c b)--data ExprRel =-    EREqual-  | ERDiff-  | ERLess-  deriving (Show,Eq,Ord)--data BoolExpr t c b =-    BoolTerm b-  | BoolConst Bool-  | BoolAnd (BoolExpr t c b) (BoolExpr t c b)-  | BoolOr (BoolExpr t c b) (BoolExpr t c b)-  | BoolNot (BoolExpr t c b)-  | BoolCond (BoolExpr t c b) (BoolExpr t c b) (BoolExpr t c b)-  | Rel (Expr t c b) ExprRel (Expr t c b)-  | BoolAll (Expr t c b -> BoolExpr t c b) (ColExpr t c b)-  | BoolAny (Expr t c b -> BoolExpr t c b) (ColExpr t c b)-  | ColEqual (ColExpr t c b) (ColExpr t c b)-  | BoolEqual (BoolExpr t c b) (BoolExpr t c b)-  | AllDiff Bool (ColExpr t c b)-  | Sorted Bool (ColExpr t c b)-  | Dom (Expr t c b) (ColExpr t c b)---------------------------- | Show instance | ----------------------------class ShowFn t where-  showFn :: Int -> t -> String-instance (Show t, Show c, Show b) => ShowFn (Expr t c b) where-  showFn _ (Term a) = "Term ("++(show a)++")"-  showFn _ (ExprHole a) = "par"++(show a)-  showFn _ (Const a) = "Const "++(show a)-  showFn l (Plus a b) = "Plus ("++(showFn l a)++") ("++(showFn l b)++")"-  showFn l (Minus a b) = "Minus ("++(showFn l a)++") ("++(showFn l b)++")"-  showFn l (Mult a b) = "Mult ("++(showFn l a)++") ("++(showFn l b)++")"-  showFn l (Div a b) = "Div ("++(showFn l a)++") ("++(showFn l b)++")"-  showFn l (Mod a b) = "Mod ("++(showFn l a)++") ("++(showFn l b)++")"-  showFn l (Abs a) = "Abs ("++(showFn l a)++")"-  showFn l (At a b) = "At ("++(showFn l a)++") ("++(showFn l b)++")"-  showFn l (Fold a b c) = "Fold ("++(showFn l a)++") ("++(showFn l b)++") ("++(showFn l c)++")"-  showFn l (ColSize a) = "ColSize ("++(showFn l a)++")"-  showFn l (Channel b) = "Channel ("++(showFn l b)++")"-  showFn l (Cond c t f) = "Cond ("++(showFn l c)++") ("++(showFn l t)++") ("++(showFn l f)++")"-instance (ShowFn l) => ShowFn [l] where-  showFn d l = "[" ++ (foldr1 (\a b -> a++","++b) $ map (showFn d) l) ++ "]"-instance (Show t, Show c, Show b) => ShowFn (ColExpr t c b) where-  showFn d (ColTerm a) = "ColTerm ("++(show a)++")"-  showFn d (ColList l) = "ColList ("++(showFn d l)++")"-  showFn d (ColMap f l) = "ColMap ("++(showFn d f)++") ("++(showFn d l)++")"-  showFn d (ColSlice f l c) = "ColSlice ("++(showFn d f)++") ("++(showFn d l)++") ("++(showFn d c)++")"-  showFn d (ColCat a b) = "ColCat ("++(showFn d a)++") ("++(showFn d b)++")"-  showFn d (ColRange a b) = "ColRange ("++(showFn d a)++") ("++(showFn d b)++")"-instance (Show t, Show c, Show b) => ShowFn (BoolExpr t c b) where-  showFn d (BoolTerm b) = "BoolTerm ("++(show b)++")"-  showFn d (BoolConst b) = "BoolConst "++(show b)-  showFn d (BoolAnd a b) = "BoolAnd ("++(showFn d a)++") ("++(showFn d b)++")"-  showFn d (BoolOr a b) = "BoolOr ("++(showFn d a)++") ("++(showFn d b)++")"-  showFn d (BoolNot a) = "BoolNot ("++(showFn d a)++")"-  showFn d (BoolEqual a b) = "BoolEqual ("++(showFn d a)++") ("++(showFn d b)++")"-  showFn d (Rel a r b) = "Rel ("++(showFn d a)++") "++(show r)++" ("++(showFn d b)++")"-  showFn d (BoolAll f c) = "BoolAll ("++(showFn d f)++") ("++(showFn d c)++")"-  showFn d (BoolAny f c) = "BoolAny ("++(showFn d f)++") ("++(showFn d c)++")"-  showFn d (ColEqual a b) = "ColEqual ("++(showFn d a)++") ("++(showFn d b)++")"-  showFn d (AllDiff _ c) = "AllDiff ("++(showFn d c)++")"-  showFn d (Sorted b c) = "Sorted "++(show b)++"("++(showFn d c)++")"-  showFn l (BoolCond c t f) = "BoolCond ("++(showFn l c)++") ("++(showFn l t)++") ("++(showFn l f)++")"-  showFn d (Dom i c) = "Dom ("++(showFn d i)++") ("++(showFn d c)++")"-instance (Show t, Show c, Show b, ShowFn e) => ShowFn (Expr t c b -> e) where-  showFn l f = "\\par"++(show l)++" -> "++(showFn (l+1) (f (ExprHole l)))-instance (Show t, Show c, Show b) => Show (Expr t c b) where-  show = showFn 0-instance (Show t, Show c, Show b) => Show (ColExpr t c b) where-  show = showFn 0-instance (Show t, Show c, Show b) => Show (BoolExpr t c b) where-  show = showFn 0-------------------------- | Eq instance | --------------------------equalExpr :: (Eq t, Eq c, Eq b) => Int -> Expr t c b -> Expr t c b -> Bool-equalExpr _ (Term a) (Term b) = a==b-equalExpr _ (ExprHole a) (ExprHole b) = a==b-equalExpr _ (Const a) (Const b) = a==b-equalExpr l (Plus a c) (Plus b d) = equalExpr l a b && equalExpr l d c-equalExpr l (Minus a c) (Minus b d) = equalExpr l a b && equalExpr l d c-equalExpr l (Mult a c) (Mult b d) = equalExpr l a b && equalExpr l d c-equalExpr l (Div a c) (Plus b d) = equalExpr l a b && equalExpr l d c-equalExpr l (Mod a c) (Plus b d) = equalExpr l a b && equalExpr l d c-equalExpr l (Abs a) (Abs b) = equalExpr l a b-equalExpr l (At a c) (At b d) = equalExpr l c d && equalColExpr l a b-equalExpr l (ColSize a) (ColSize b) = equalColExpr l a b-equalExpr l (Fold f a c) (Fold g b d) = equalExpr l a b && equalColExpr l c d && equalExpr (l+2) (f (ExprHole l) (ExprHole $ l+1)) (g (ExprHole l) (ExprHole $ l+1))-equalExpr l (Channel a) (Channel b) = equalBoolExpr l a b-equalExpr l (Cond c t f) (Cond d u g) = equalBoolExpr l c d && equalExpr l t u && equalExpr l f g-equalExpr _ _ _ = False--equalColExpr :: (Eq t, Eq c, Eq b) => Int -> ColExpr t c b -> ColExpr t c b -> Bool-equalColExpr _ (ColTerm a) (ColTerm b) = a==b-equalColExpr _ (ColList []) (ColList []) = True-equalColExpr l (ColList (a:ar)) (ColList (b:br)) = equalExpr l a b && equalColExpr l (ColList ar) (ColList br)-equalColExpr l (ColMap f a) (ColMap g b) = equalColExpr l a b && equalExpr (l+1) (f (ExprHole l)) (g (ExprHole l))-equalColExpr l (ColSlice a c e) (ColSlice b d f) = equalExpr (l+1) (a (ExprHole l)) (b  (ExprHole l)) && equalExpr l c d && equalColExpr l e f-equalColExpr l (ColCat a c) (ColCat b d) = equalColExpr l a b && equalColExpr l c d-equalColExpr l (ColRange a c) (ColRange b d) = equalExpr l a b && equalExpr l c d-equalColExpr _ _ _ = False--equalBoolExpr :: (Eq t, Eq c, Eq b) => Int -> BoolExpr t c b -> BoolExpr t c b -> Bool-equalBoolExpr _ (BoolTerm a) (BoolTerm b) = a==b-equalBoolExpr _ (BoolConst a) (BoolConst b) = a==b-equalBoolExpr l (BoolAnd a c) (BoolAnd b d) = equalBoolExpr l a b && equalBoolExpr l c d-equalBoolExpr l (BoolOr a c) (BoolOr b d) = equalBoolExpr l a b && equalBoolExpr l c d-equalBoolExpr l (BoolEqual a c) (BoolEqual b d) = equalBoolExpr l a b && equalBoolExpr l c d-equalBoolExpr l (BoolNot a) (BoolNot b) = equalBoolExpr l a b-equalBoolExpr l (Rel a r c) (Rel b s d) = r==s && equalExpr l a b && equalExpr l c d-equalBoolExpr l (BoolAll f c) (BoolAll g d) = equalColExpr l c d && equalBoolExpr (l+1) (f $ ExprHole l) (g $ ExprHole l)-equalBoolExpr l (BoolAny f c) (BoolAny g d) = equalColExpr l c d && equalBoolExpr (l+1) (f $ ExprHole l) (g $ ExprHole l)-equalBoolExpr l (ColEqual a c) (ColEqual b d) = equalColExpr l a b && equalColExpr l c d-equalBoolExpr l (AllDiff _ c) (AllDiff _ d) = equalColExpr l c d-equalBoolExpr l (Sorted a c) (Sorted b d) = a==b && equalColExpr l c d-equalBoolExpr l (BoolCond c t f) (BoolCond d u g) = equalBoolExpr l c d && equalBoolExpr l t u && equalBoolExpr l f g-equalBoolExpr l (Dom a c) (Dom b d) = equalExpr l a b && equalColExpr l c d-equalBoolExpr _ _ _ = False--instance (Eq t, Eq c, Eq b) => Eq (Expr t c b) where-  a == b = equalExpr 0 a b-instance (Eq t, Eq c, Eq b) => Eq (ColExpr t c b) where-  a == b = equalColExpr 0 a b-instance (Eq t, Eq c, Eq b) => Eq (BoolExpr t c b) where-  a == b = equalBoolExpr 0 a b---------------------------------------------------------- | ExprKey: Provides ordering over expressions | ----------------------------------------------------------infixr 4 <<>>-a <<>> b = case a of-  EQ -> b-  _ -> a--compareColExpr :: (Ord s, Ord c, Ord b) => Int -> ColExpr s c b -> ColExpr s c b -> Ordering-compareColExpr _ (ColList []) (ColList []) = EQ-compareColExpr l (ColList (a:ar)) (ColList (b:br)) = compareExpr l a b <<>> compareColExpr l (ColList ar) (ColList br)-compareColExpr _ (ColList _) _ = LT-compareColExpr _ _ (ColList _) = GT-compareColExpr l (ColMap f1 c1) (ColMap f2 c2) = compareColExpr l c1 c2 <<>> compareExpr (l+1) (f1 $ ExprHole l) (f2 $ ExprHole l)-compareColExpr _ (ColMap _ _) _ = LT-compareColExpr _ _ (ColMap _ _) = GT-compareColExpr l (ColSlice p1 l1 c1) (ColSlice p2 l2 c2) = compareExpr (l+1) (p1 $ ExprHole l) (p2 $ ExprHole l) <<>> compareExpr l l1 l2 <<>> compareColExpr l c1 c2-compareColExpr _ (ColSlice _ _ _) _ = LT-compareColExpr _ _ (ColSlice _ _ _) = GT-compareColExpr l (ColCat a1 b1) (ColCat a2 b2) = compareColExpr l a1 a2 <<>> compareColExpr l b1 b2-compareColExpr _ (ColCat _ _) _ = LT-compareColExpr _ _ (ColCat _ _) = GT-compareColExpr l (ColRange l1 h1) (ColRange l2 h2) = compareExpr l l1 l2 <<>> compareExpr l l2 h2-compareColExpr _ (ColRange _ _) _ = LT-compareColExpr _ _ (ColRange _ _) = GT-compareColExpr _ (ColTerm t1) (ColTerm t2) = compare t1 t2--compareBoolExpr :: (Ord s, Ord c, Ord b) => Int -> BoolExpr s c b -> BoolExpr s c b -> Ordering-compareBoolExpr _ (BoolConst a) (BoolConst b) = compare a b-compareBoolExpr _ (BoolConst _) _ = LT-compareBoolExpr _ _ (BoolConst _) = GT-compareBoolExpr l (BoolAnd a1 b1) (BoolAnd a2 b2) = compareBoolExpr l a1 a2 <<>> compareBoolExpr l b1 b2-compareBoolExpr _ (BoolAnd _ _) _ = LT-compareBoolExpr _ _ (BoolAnd _ _) = GT-compareBoolExpr l (BoolOr a1 b1) (BoolOr a2 b2) = compareBoolExpr l a1 a2 <<>> compareBoolExpr l b1 b2-compareBoolExpr _ (BoolOr _ _) _ = LT-compareBoolExpr _ _ (BoolOr _ _) = GT-compareBoolExpr l (BoolEqual a1 b1) (BoolEqual a2 b2) = compareBoolExpr l a1 a2 <<>> compareBoolExpr l b1 b2-compareBoolExpr _ (BoolEqual _ _) _ = LT-compareBoolExpr _ _ (BoolEqual _ _) = GT-compareBoolExpr l (BoolNot a1) (BoolNot a2) = compareBoolExpr l a1 a2-compareBoolExpr _ (BoolNot _) _ = LT-compareBoolExpr _ _ (BoolNot _) = GT-compareBoolExpr l (Rel a1 r1 b1) (Rel a2 r2 b2) = compare r1 r2 <<>> compareExpr l a1 a2 <<>> compareExpr l b1 b2-compareBoolExpr _ (Rel _ _ _) _ = LT-compareBoolExpr _ _ (Rel _ _ _) = GT-compareBoolExpr l (BoolAll f1 c1) (BoolAll f2 c2) = compareColExpr l c1 c2 <<>> compareBoolExpr (l+1) (f1 $ ExprHole l) (f2 $ ExprHole l)-compareBoolExpr _ (BoolAll _ _) _ = LT-compareBoolExpr _ _ (BoolAll _ _) = GT-compareBoolExpr l (BoolAny f1 c1) (BoolAny f2 c2) = compareColExpr l c1 c2 <<>> compareBoolExpr (l+1) (f1 $ ExprHole l) (f2 $ ExprHole l)-compareBoolExpr _ (BoolAny _ _) _ = LT-compareBoolExpr _ _ (BoolAny _ _) = GT-compareBoolExpr l (ColEqual a1 b1) (ColEqual a2 b2) = compareColExpr l a1 a2 <<>> compareColExpr l b1 b2-compareBoolExpr _ (ColEqual _ _) _ = LT-compareBoolExpr _ _ (ColEqual _ _) = GT-compareBoolExpr l (Sorted a1 b1) (Sorted a2 b2) = compare a1 a2 <<>> compareColExpr l b1 b2-compareBoolExpr _ (Sorted _ _) _ = LT-compareBoolExpr _ _ (Sorted _ _) = GT-compareBoolExpr l (AllDiff _ b1) (AllDiff _ b2) = compareColExpr l b1 b2-compareBoolExpr _ (AllDiff _ _) _ = LT-compareBoolExpr _ _ (AllDiff _ _) = GT-compareBoolExpr l (BoolCond c1 t1 f1) (BoolCond c2 t2 f2) = compareBoolExpr l c1 c2 <<>> compareBoolExpr l t1 t2 <<>> compareBoolExpr l f1 f2-compareBoolExpr _ (BoolCond _ _ _) _ = LT-compareBoolExpr _ _ (BoolCond _ _ _) = GT-compareBoolExpr l (Dom i1 c1) (Dom i2 c2) = compareExpr l i1 i2 <<>> compareColExpr l c1 c2-compareBoolExpr _ (Dom _ _) _ = LT-compareBoolExpr _ _ (Dom _ _) = GT-compareBoolExpr _ (BoolTerm a) (BoolTerm b) = compare a b--compareExpr :: (Ord s, Ord c, Ord b) => Int -> Expr s c b -> Expr s c b -> Ordering-compareExpr _ (Const i1) (Const i2) = compare i1 i2-compareExpr _ (Const _) _ = LT-compareExpr _ _ (Const _) = GT-compareExpr _ (ExprHole i1) (ExprHole i2) = compare i1 i2-compareExpr _ (ExprHole _) _ = LT-compareExpr _ _ (ExprHole _) = GT-compareExpr l (Plus a1 b1) (Plus a2 b2) = compareExpr l a1 a2 <<>> compareExpr l b1 b2-compareExpr _ (Plus _ _) _ = LT-compareExpr _ _ (Plus _ _) = GT-compareExpr l (Minus a1 b1) (Minus a2 b2) = compareExpr l a1 a2 <<>> compareExpr l b1 b2-compareExpr _ (Minus _ _) _ = LT-compareExpr _ _ (Minus _ _) = GT-compareExpr l (Mult a1 b1) (Mult a2 b2) = compareExpr l a1 a2 <<>> compareExpr l b1 b2-compareExpr _ (Mult _ _) _ = LT-compareExpr _ _ (Mult _ _) = GT-compareExpr l (Div a1 b1) (Div a2 b2) = compareExpr l a1 a2 <<>> compareExpr l b1 b2-compareExpr _ (Div _ _) _ = LT-compareExpr _ _ (Div _ _) = GT-compareExpr l (Mod a1 b1) (Mod a2 b2) = compareExpr l a1 a2 <<>> compareExpr l b1 b2-compareExpr _ (Mod _ _) _ = LT-compareExpr _ _ (Mod _ _) = GT-compareExpr l (Abs a1) (Abs a2) = compareExpr l a1 a2-compareExpr _ (Abs _) _ = LT-compareExpr _ _ (Abs _) = GT-compareExpr l (At c1 a1) (At c2 a2) = compareExpr l a1 a2 <<>> compareColExpr l c1 c2-compareExpr _ (At _ _) _ = LT-compareExpr _ _ (At _ _) = GT-compareExpr l (ColSize c1) (ColSize c2) = compareColExpr l c1 c2-compareExpr _ (ColSize _) _ = LT-compareExpr _ _ (ColSize _) = GT-compareExpr l (Fold f1 i1 c1) (Fold f2 i2 c2) = compareExpr l i1 i2 <<>> compareColExpr l c1 c2 <<>> compareExpr (l+2) (f1 (ExprHole l) (ExprHole $ l+1)) (f2 (ExprHole l) (ExprHole $ l+1))-compareExpr _ (Fold _ _ _) _ = LT-compareExpr _ _ (Fold _ _ _) = GT-compareExpr l (Channel b1) (Channel b2) = compareBoolExpr l b1 b2-compareExpr _ (Channel _) _ = LT-compareExpr _ _ (Channel _) = GT-compareExpr l (Cond c1 t1 f1) (Cond c2 t2 f2) = compareBoolExpr l c1 c2 <<>> compareExpr l t1 t2 <<>> compareExpr l f1 f2-compareExpr _ (Cond _ _ _) _ = LT-compareExpr _ _ (Cond _ _ _) = GT-compareExpr _ (Term t1) (Term t2) = compare t1 t2--instance (Ord s, Ord c, Ord b) => Ord (Expr s c b) where-  compare = compareExpr 0--instance (Ord s, Ord c, Ord b) => Ord (ColExpr s c b) where-  compare = compareColExpr 0--instance (Ord s, Ord c, Ord b) => Ord (BoolExpr s c b) where-  compare = compareBoolExpr 0

− Data/Expr/Sugar.hs

@@ -1,285 +0,0 @@-{- - - 	Monadic Constraint Programming- - 	http://www.cs.kuleuven.be/~toms/MCP/- - 	Pieter Wuille- -}--{-# LANGUAGE MultiParamTypeClasses #-}-{-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE FlexibleContexts #-}--module Data.Expr.Sugar (-  (@+), (@-), (@*), (@/), (@%), (@?), (@??), (@:),-  (!), (@!!), (@++), (@..), size, slice, xhead, xtail, xmap, xfold, list, channel, xsum,-  (@||), (@&&), inv,-  (@/=), (@>), (@<), (@>=), (@<=), (@=), -  loopall, loopany, forall, forany,-  Expr(), ColExpr(), BoolExpr(),-  ToExpr(..), ToColExpr(..), ToBoolExpr(..),-  sorted, sSorted, allDiff, allDiffD,-  ExprClass, ExprRange,-) where --import Data.Expr.Data-import Data.Expr.Util--------------------------------------- | Built-in class instances | ---------------------------------------instance (Eq s, Eq c, Eq b, Show s, Show c, Show b) => Num (Expr s c b) where-  a + b = simplify $ a `Plus` b-  a - b = simplify $ a `Minus` b-  a * b = simplify $ a `Mult` b-  abs a = simplify $ Abs a-  negate a = simplify $ (Const 0) `Minus` a-  fromInteger c = Const $ fromInteger c-  signum (Const a) = Const $ signum a-  signum a = error "signum not possible for generic Expr"--instance (Ord s, Ord c, Ord b, Eq s, Eq c, Eq b, Show s, Show c, Show b) => Real (Expr s c b) where-  toRational (Const x) = toRational x-  toRational _ = error "toRational not possible for generic Expr"--instance (Eq s, Eq c, Eq b) => Enum (Expr s c b) where-  succ a = simplify $ a `Plus` (Const 1)-  pred a = simplify $ a `Minus` (Const 1)-  toEnum = Const . toEnum-  fromEnum (Const a) = fromEnum a-  fromEnum _ = error "fromEnum not possible for generic Expr"--instance (Ord s, Ord c, Ord b, Eq s, Eq c, Eq b, Show s, Show c, Show b) => Integral (Expr s c b) where-  toInteger (Const a) = toInteger a-  toInteger _ = error "toInteger not possible for generic Expr"-  divMod a b = (simplify $ a `Div` b, simplify $ a `Mod` b)-  quotRem (Const a) (Const b) = case quotRem a b of (c,d) -> (Const c,Const d)-  quotRem (Const 0) b = (Const 0,Const 0)-  quotRem a (Const 1) = (a,Const 0)-  quotRem a (Const (-1)) = (negate a,Const 0)-  quotRem _ _ = error "quotRem not possible for generic Expr"-------------------------------------------------- | convertion from/to expression types | ---------------------------------------------------- convertible to expressions:-class ToExpr tt cc bb t where-  toExpr :: t -> Expr tt cc bb---- convertible to collection-expressions:-class ToColExpr tt cc bb c where-  toColExpr :: c -> ColExpr tt cc bb---- convertible to boolean expressions:-class ToBoolExpr tt cc bb b where-  toBoolExpr :: b -> BoolExpr tt cc bb---- infix 4 @=, @/=--class (Eq tt, Eq cc, Eq bb) => ExprClass tt cc bb a where-  (@=)  :: a -> a -> BoolExpr tt cc bb-  (@/=) :: a -> a -> BoolExpr tt cc bb-  a @/= b = boolSimplify $ BoolNot $ a @= b--class (Eq tt, Eq cc, Eq bb) => ExprRange tt cc bb r where-  (@:)  :: Expr tt cc bb -> r -> BoolExpr tt cc bb---- integers can be used as constant expressions-instance ToExpr tt cc bb Integer where-  toExpr = Const---- expressions themselves are trivially convertible to expressions-instance ToExpr t a b (Expr t a b) where-  toExpr = id---- ints can be used as constant expressions-instance ToExpr tt cc bb Int where-  toExpr = Const . toInteger---- boolean expressions can be used as integer expressions (being 0 or 1)-instance (Eq t, Eq a, Eq b) => ToExpr t a b (BoolExpr t a b) where-  toExpr = simplify . Channel---- collection expressions themselves are trivially convertible to collection expressions-instance ToColExpr t a b (ColExpr t a b) where-  toColExpr = id---- an expression can be used as a collection of one expressions-instance (Eq t, Eq a, Eq b) => ToColExpr t a b (Expr t a b) where-  toColExpr a = colSimplify $ ColList [a]---- a list of expressions van be used as a collection-instance (Eq b, Eq a, Eq t) => ToColExpr t a b [Expr t a b] where-  toColExpr = colSimplify . ColList---- a boolean constant can be used as a constant boolean expression-instance ToBoolExpr tt cc bb Bool where-  toBoolExpr = BoolConst---- boolean expressions are trivially convertible to boolean expressions-instance ToBoolExpr t a b (BoolExpr t a b) where-  toBoolExpr = id---- the integer terms used by an expression can be used as interger expressions-instance ToExpr t a b t where-  toExpr = Term---- the collections terms used by an expression can be used as collection expressions-instance ToColExpr t a b a where-  toColExpr = ColTerm---- the boolean terms used by an expression can be used as boolean expressions-instance ToBoolExpr t a b b where-  toBoolExpr = BoolTerm------------------------------------------ | integer operators/functions | -------------------------------------------- @+ @- @* @/ @% are identical to + - * / % for integer expressions, except--- that they also accept types convertible to expressions, instead of only--- expressions themselves--infixl 6 @+, @--infixl 7 @*-infixl 7 @/-infixl 7 @%--(@+) :: (Eq t, Eq c, Eq b, ToExpr t c b p, ToExpr t c b q) => p -> q -> Expr t c b-(@-) :: (Eq t, Eq c, Eq b, ToExpr t c b p, ToExpr t c b q) => p -> q -> Expr t c b-(@*) :: (Eq t, Eq c, Eq b, ToExpr t c b p, ToExpr t c b q) => p -> q -> Expr t c b-(@/) :: (Eq t, Eq c, Eq b, ToExpr t c b p, ToExpr t c b q) => p -> q -> Expr t c b-(@%) :: (Eq t, Eq c, Eq b, ToExpr t c b p, ToExpr t c b q) => p -> q -> Expr t c b--a @+ b = simplify $ (toExpr a) `Plus` (toExpr b)-a @- b = simplify $ (toExpr a) `Minus` (toExpr b)-a @* b = simplify $ (toExpr a) `Mult` (toExpr b)-a @/ b = simplify $ (toExpr a) `Div` (toExpr b)-a @% b = simplify $ (toExpr a) `Mod` (toExpr b)--------------------------------------- | list operators/functions | ---------------------------------------infix 9 !-infix 9 @!!-infix 9 @..-infixr 5 @++-infix 4 @?-infix 4 @??-infix 5 @:--(!) :: (Eq t, Eq c, Eq b) => ColExpr t c b -> Expr t c b -> Expr t c b-(@!!) :: (Eq t, Eq c, Eq b) => ColExpr t c b -> Integer -> Expr t c b-(@..) :: (Eq t, Eq c, Eq b) => Expr t c b -> Expr t c b -> ColExpr t c b-(@++) :: (Eq t, Eq c, Eq b) => ColExpr t c b -> ColExpr t c b -> ColExpr t c b--(@?) :: (Eq t, Eq c, Eq b) => BoolExpr t c b -> (Expr t c b, Expr t c b) -> Expr t c b-c @? (t,f) = simplify $ Cond c t f--(@??) :: (Eq t, Eq c, Eq b) => BoolExpr t c b -> (BoolExpr t c b, BoolExpr t c b) -> BoolExpr t c b-c @?? (t,f) = boolSimplify $ BoolCond c t f--c!p = simplify $ At c p-c @!! p = simplify $ At c (Const p)-a @.. b = colSimplify $ ColRange (toExpr a) (toExpr b)-a @++ b = colSimplify $ ColCat (toColExpr a) (toColExpr b)--size :: (Eq t, Eq c, Eq b) => ColExpr t c b -> Expr t c b-size a = simplify $ ColSize a--xfold :: (Eq t, Eq c, Eq b) => (Expr t c b -> Expr t c b -> Expr t c b) -> Expr t c b -> ColExpr t c b -> Expr t c b-xfold f i c = simplify $ Fold (\a b -> f a b) i c--xsum :: (Num (Expr t c b), Eq t, Eq c, Eq b) => ColExpr t c b -> Expr t c b-xsum c = xfold (+) (Const 0) c--list :: (Eq t, Eq c, Eq b) => [Expr t c b] -> ColExpr t c b-list x = colSimplify $ ColList x--xhead :: (Eq t, Eq c, Eq b, ToColExpr t c b p) => p -> Expr t c b-xhead c = simplify $ At (toColExpr c) (Const 0)--xtail :: (Eq t, Eq c, Eq b, ToColExpr t c b p) => p -> ColExpr t c b-xtail c = let cc = toColExpr c in colSimplify $ ColSlice (\x -> simplify (x `Plus` (Const 1))) (simplify $ (size cc) `Minus` (Const 1)) cc--slice :: (Eq t, Eq c, Eq b) => ColExpr t c b -> ColExpr t c b -> ColExpr t c b-slice c p = case (c,p) of-  (_,ColRange l h) -> colSimplify $ ColSlice (\x -> simplify (l `Plus` x)) (simplify $ Const 1 `Plus` (simplify $ h `Minus` l)) c-  (_,ColMap f (ColRange l h)) -> colSimplify $ ColSlice (\i -> simplify $ f $ simplify (l `Plus` i)) (simplify $ Const 1 `Plus` (simplify $ h `Minus` l)) c-  (_,ColSlice f n c2) -> colSimplify $ ColSlice (\i -> simplify $ c2 `At` (f i)) n c-  _ -> xmap (\i -> simplify $ c `At` i) p--xmap :: (Eq t, Eq c, Eq b) => (Expr t c b -> Expr t c b) -> ColExpr t c b -> ColExpr t c b-xmap f c = colSimplify $ ColMap f c--loopall :: (Eq t, Eq c, Eq b) => (Expr t c b,Expr t c b) -> (Expr t c b -> BoolExpr t c b) -> BoolExpr t c b-loopall (l,h) f = boolSimplify $ BoolAll f $ colSimplify $ ColRange l h--loopany :: (Eq t, Eq c, Eq b) => (Expr t c b,Expr t c b) -> (Expr t c b -> BoolExpr t c b) -> BoolExpr t c b-loopany (l,h) f = boolSimplify $ BoolAny f $ colSimplify $ ColRange l h--forall :: (Eq t, Eq c, Eq b) => (ColExpr t c b) -> (Expr t c b -> BoolExpr t c b) -> BoolExpr t c b-forall c f = boolSimplify $ BoolAll f c--forany :: (Eq t, Eq c, Eq b) => (ColExpr t c b) -> (Expr t c b -> BoolExpr t c b) -> BoolExpr t c b-forany c f = boolSimplify $ BoolAny f c--channel :: (Eq t, Eq c, Eq b) => BoolExpr t c b -> Expr t c b-channel = simplify . Channel ------------------------------------------ | boolean operators/functions | -------------------------------------------- infixr 1 /\--- infixr 1 \/-infixr 2 @||-infixr 3 @&&---- (\/) :: (Eq t, Eq c, Eq b, ToBoolExpr t c b p, ToBoolExpr t c b q) => p -> q -> BoolExpr t c b--- (/\) :: (Eq t, Eq c, Eq b, ToBoolExpr t c b p, ToBoolExpr t c b q) => p -> q -> BoolExpr t c b-inv :: (Eq t, Eq c, Eq b, ToBoolExpr t c b p) => p -> BoolExpr t c b--a @|| b = boolSimplify $ BoolOr (toBoolExpr a) (toBoolExpr b)-a @&& b = boolSimplify $ BoolAnd (toBoolExpr a) (toBoolExpr b)-inv a = boolSimplify $ BoolNot (toBoolExpr a)--- a \/ b = a @|| b--- a /\ b = a @&& b--------------------------------------------- | relational operators/functions | ---------------------------------------------instance (Eq t, Eq c, Eq b) => ExprClass t c b (Expr t c b) where-  a @= b = boolSimplify $ Rel a EREqual b--instance (Eq t, Eq c, Eq b) => ExprClass t c b (BoolExpr t c b) where-  a @= b = boolSimplify $ BoolEqual a b--instance (Eq t, Eq c, Eq b) => ExprClass t c b (ColExpr t c b) where-  a @= b = boolSimplify $ ColEqual a b--  -infixr 4 @<,@<=,@>,@>=-(@<) ::  (Eq t, Eq c, Eq b) => Expr t c b -> Expr t c b -> BoolExpr t c b-(@>) ::  (Eq t, Eq c, Eq b) => Expr t c b -> Expr t c b -> BoolExpr t c b-(@<=) :: (Eq t, Eq c, Eq b) => Expr t c b -> Expr t c b -> BoolExpr t c b-(@>=) :: (Eq t, Eq c, Eq b) => Expr t c b -> Expr t c b -> BoolExpr t c b--a @< b = boolSimplify $ Rel a ERLess b-a @> b = boolSimplify $ Rel b ERLess a-a @<= b = boolSimplify $ Rel a ERLess (simplify $ b `Plus` (Const 1))-a @>= b = boolSimplify $ Rel b ERLess (simplify $ a `Plus` (Const 1))--sorted c = boolSimplify $ Sorted False c-sSorted c = boolSimplify $ Sorted True c-allDiff c = boolSimplify $ AllDiff False c-allDiffD c = boolSimplify $ AllDiff True c--instance (Eq t, Eq c, Eq b) => ExprRange t c b (Expr t c b,Expr t c b) where-  a @: (l,h) = (a @>= l) @&& (a @<= h)--instance (Eq t, Eq c, Eq b) => ExprRange t c b (ColExpr t c b) where-  a @: c = boolSimplify $ Dom a c-

− Data/Expr/Util.hs

@@ -1,481 +0,0 @@-{- - - 	Monadic Constraint Programming- - 	http://www.cs.kuleuven.be/~toms/MCP/- - 	Pieter Wuille- -}--{-# LANGUAGE StandaloneDeriving #-}--module Data.Expr.Util (-  Expr(), BoolExpr(), ColExpr(),-  transform, colTransform, boolTransform,-  transformEx, colTransformEx, boolTransformEx,-  property, colProperty, boolProperty,-  propertyEx, colPropertyEx, boolPropertyEx,-  collapse, colCollapse, boolCollapse,-  simplify, colSimplify, boolSimplify,-  WalkPhase(..), WalkResult(..), walk, colWalk, boolWalk,-) where --import Data.Expr.Data------------------------------ | Helper functions |------------------------------relCheck :: Integer -> ExprRel -> Integer -> Bool-relCheck a EREqual b = a==b-relCheck a ERDiff b = a/=b-relCheck a ERLess b = a<b------------------------------------------------------------------------------ | Transform expressions over one type to expressions over another | ------------------------------------------------------------------------------transform :: (Eq a, Eq b, Eq c, Eq d, Eq e, Eq f) => (a->b,c->d,e->f,b->a,d->c,f->e) -> Expr a c e -> Expr b d f-transform (f,fc,fb,fi,fic,fib) = transformEx (Term . f, ColTerm . fc, BoolTerm . fb, Term . fi, ColTerm . fic, BoolTerm . fib)--transformEx :: (Eq a, Eq b, Eq c, Eq d, Eq e, Eq f) => ((a -> Expr b d f),(c -> ColExpr b d f),(e -> BoolExpr b d f),(b -> Expr a c e),(d -> ColExpr a c e),(f -> BoolExpr a c e)) -> Expr a c e -> Expr b d f-transformEx (f,_,_,_,_,_) (Term v) = f v-transformEx f (Const i) = Const i-transformEx f (ExprHole i) = ExprHole i-transformEx f (Plus a b) = simplify $ Plus (transformEx f a) (transformEx f b)-transformEx f (Minus a b) = simplify $ Minus (transformEx f a) (transformEx f b)-transformEx f (Mult a b) = simplify $ Mult (transformEx f a) (transformEx f b)-transformEx f (Div a b) = simplify $ Div (transformEx f a) (transformEx f b)-transformEx f (Mod a b) = simplify $ Mod (transformEx f a) (transformEx f b)-transformEx f (Abs a) = simplify $ Abs (transformEx f a)-transformEx f (At c a) = simplify $ At (colTransformEx f c) (transformEx f a)-transformEx f (ColSize c) = simplify $ ColSize $ colTransformEx f c-transformEx f (Channel a) = simplify $ Channel $ boolTransformEx f a-transformEx f (Cond c t e) = simplify $ Cond (boolTransformEx f c) (transformEx f t) (transformEx f e)-transformEx t@(f,fc,fb,fi,fic,fib) (Fold m i c) = simplify $ Fold (\a b -> transformEx t (m (transformEx (fi,fic,fib,f,fc,fb) a) (transformEx (fi,fic,fib,f,fc,fb) b))) (transformEx t i) (colTransformEx t c)--colTransform :: (Eq a, Eq b, Eq c, Eq d, Eq e, Eq f) => (a->b,c->d,e->f,b->a,d->c,f->e) -> ColExpr a c e -> ColExpr b d f-colTransform (f,fc,fb,fi,fic,fib) = colTransformEx (Term . f, ColTerm . fc, BoolTerm . fb, Term . fi, ColTerm . fic, BoolTerm . fib)--colTransformEx :: (Eq a, Eq b, Eq c, Eq d, Eq e, Eq f) => ((a -> Expr b d f),(c -> ColExpr b d f),(e -> BoolExpr b d f),(b -> Expr a c e),(d -> ColExpr a c e),f -> BoolExpr a c e) -> ColExpr a c e -> ColExpr b d f-colTransformEx (_,f,_,_,_,_)  (ColTerm c) = f c-colTransformEx f (ColList l) = colSimplify $ ColList $ map (transformEx f) l-colTransformEx t@(f,fc,fb,fi,fic,fib) (ColMap m c) = colSimplify $ ColMap (\a -> transformEx t (m (transformEx (fi,fic,fib,f,fc,fb) a))) (colTransformEx t c)-colTransformEx t@(f,fc,fb,fi,fic,fib) (ColSlice p l c) = colSimplify $ ColSlice (\a -> transformEx t (p (transformEx (fi,fic,fib,f,fc,fb) a))) (transformEx t l) (colTransformEx t c)-colTransformEx f (ColCat a b) = colSimplify $ ColCat (colTransformEx f a) (colTransformEx f b)-colTransformEx f (ColRange a b) = colSimplify $ ColRange (transformEx f a) (transformEx f b)--boolTransform :: (Eq a, Eq b, Eq c, Eq d, Eq e, Eq f) => (a->b,c->d,e->f,b->a,d->c,f->e) -> BoolExpr a c e -> BoolExpr b d f-boolTransform (f,fc,fb,fi,fic,fib) = boolTransformEx (Term . f, ColTerm . fc, BoolTerm . fb, Term . fi, ColTerm . fic, BoolTerm . fib)--boolTransformEx :: (Eq a, Eq b, Eq c, Eq d, Eq e, Eq f) => ((a -> Expr b d f),(c -> ColExpr b d f),(e -> BoolExpr b d f),(b -> Expr a c e),(d -> ColExpr a c e),f -> BoolExpr a c e) -> BoolExpr a c e -> BoolExpr b d f-boolTransformEx (_,_,f,_,_,_) (BoolTerm v) = f v-boolTransformEx f (BoolConst c) = BoolConst c-boolTransformEx f (BoolAnd a b) = boolSimplify $ BoolAnd (boolTransformEx f a) (boolTransformEx f b)-boolTransformEx f (BoolOr a b) = boolSimplify $ BoolOr (boolTransformEx f a) (boolTransformEx f b)-boolTransformEx f (BoolEqual a b) = boolSimplify $ BoolEqual (boolTransformEx f a) (boolTransformEx f b)-boolTransformEx f (BoolNot a) = boolSimplify $ BoolNot (boolTransformEx f a)-boolTransformEx f (Rel a r b) = boolSimplify $ Rel (transformEx f a) r (transformEx f b)-boolTransformEx t@(f,fc,fb,fi,fic,fib) (BoolAll m c) = boolSimplify $ BoolAll (\a -> boolTransformEx t (m (transformEx (fi,fic,fib,f,fc,fb) a))) (colTransformEx t c)-boolTransformEx t@(f,fc,fb,fi,fic,fib) (BoolAny m c) = boolSimplify $ BoolAny (\a -> boolTransformEx t (m (transformEx (fi,fic,fib,f,fc,fb) a))) (colTransformEx t c)-boolTransformEx f (ColEqual a b) = boolSimplify $ ColEqual (colTransformEx f a) (colTransformEx f b)-boolTransformEx f (Sorted b c) = boolSimplify $ Sorted b (colTransformEx f c)-boolTransformEx f (AllDiff b c) = boolSimplify $ AllDiff b (colTransformEx f c)-boolTransformEx f (BoolCond c t e) = boolSimplify $ BoolCond (boolTransformEx f c) (boolTransformEx f t) (boolTransformEx f e)-boolTransformEx f (Dom i c) = boolSimplify $ Dom (transformEx f i) (colTransformEx f c)----------------------------------------------------------------------------------------------- | Check whether an expression is possibly referring to terms with a given property | -----------------------------------------------------------------------------------------------propertyEx :: (Expr a b c -> Maybe Bool, ColExpr a b c -> Maybe Bool, BoolExpr a b c -> Maybe Bool) -> Expr a b c -> Bool-propertyEx f@(fi,fc,fb) t = case fi t of-  Just a -> a-  Nothing -> case t of-    Plus a b -> propertyEx f a || propertyEx f b-    Minus a b -> propertyEx f a || propertyEx f b-    Mult a b -> propertyEx f a || propertyEx f b-    Div a b -> propertyEx f a || propertyEx f b-    Mod a b -> propertyEx f a || propertyEx f b-    Abs a -> propertyEx f a-    At a b -> propertyEx f b || colPropertyEx f a-    ColSize a -> colPropertyEx f a-    Fold _ _ _ -> True-    Channel b -> boolPropertyEx f b-    Cond c t e -> boolPropertyEx f c || propertyEx f t || propertyEx f e-    _ -> False--colPropertyEx :: (Expr a b c -> Maybe Bool, ColExpr a b c -> Maybe Bool, BoolExpr a b c -> Maybe Bool) -> ColExpr a b c -> Bool-colPropertyEx f@(fi,fc,fb) t = case fc t of-  Just a -> a-  Nothing -> case t of-    ColList l -> any (propertyEx f) l-    ColMap _ _ -> True-    ColSlice p l c -> propertyEx f (p (ExprHole (-1))) || propertyEx f l || colPropertyEx f c-    ColRange l h -> propertyEx f l || propertyEx f h-    ColCat a b -> colPropertyEx f a || colPropertyEx f b-    _ -> False--boolPropertyEx :: (Expr a b c -> Maybe Bool, ColExpr a b c -> Maybe Bool, BoolExpr a b c -> Maybe Bool) -> BoolExpr a b c -> Bool-boolPropertyEx f@(fi,fc,fb) t = case fb t of-  Just a -> a-  Nothing -> case t of-    BoolAnd a b -> boolPropertyEx f a || boolPropertyEx f b-    BoolOr a b -> boolPropertyEx f a || boolPropertyEx f b-    BoolNot a -> boolPropertyEx f a-    BoolEqual a b -> boolPropertyEx f a || boolPropertyEx f b-    Rel a _ b -> propertyEx f a || propertyEx f b-    BoolAll _ _ -> True-    BoolAny _ _ -> True-    ColEqual a b -> colPropertyEx f a || colPropertyEx f b-    AllDiff _ c -> colPropertyEx f c-    Sorted _ c -> colPropertyEx f c-    BoolCond c t e -> boolPropertyEx f c || boolPropertyEx f t || boolPropertyEx f e-    Dom i c -> propertyEx f i || colPropertyEx f c-    _ -> False---property :: (a -> Bool) -> (b -> Bool) -> (c -> Bool) -> Expr a b c -> Bool-property fit fct fbt = propertyEx (propInt fit, propCol fct, propBool fbt)-colProperty :: (a -> Bool) -> (b -> Bool) -> (c -> Bool) -> ColExpr a b c -> Bool-colProperty fit fct fbt = colPropertyEx (propInt fit, propCol fct, propBool fbt)-boolProperty :: (a -> Bool) -> (b -> Bool) -> (c -> Bool) -> BoolExpr a b c -> Bool-boolProperty fit fct fbt = boolPropertyEx (propInt fit, propCol fct, propBool fbt)--propInt :: (a -> Bool) -> Expr a b c -> Maybe Bool-propInt ft t = case t of-  Term x -> Just $ ft x-  _ -> Nothing--propCol :: (b -> Bool) -> ColExpr a b c -> Maybe Bool-propCol ft t = case t of-  ColTerm x -> Just $ ft x-  _ -> Nothing--propBool :: (c -> Bool) -> BoolExpr a b c -> Maybe Bool-propBool ft t = case t of-  BoolTerm x -> Just $ ft x-  _ -> Nothing------------------------------------------------------------------------- | Count how many references to terms an expression contains | ------------------------------------------------------------------------varrefs :: Expr a b c -> Int-varrefs (Term _)     = 1-varrefs (Const _)    = 0-varrefs (ExprHole _) = 0-varrefs (Plus a b)   = varrefs a + varrefs b-varrefs (Minus a b)  = varrefs a + varrefs b-varrefs (Mult a b)   = varrefs a + varrefs b-varrefs (Div a b)    = varrefs a + varrefs b-varrefs (Mod a b)    = varrefs a + varrefs b-varrefs (Abs a)      = varrefs a-varrefs (At c i)     = varrefs i + colVarrefs c-varrefs (ColSize c)  = colVarrefs c-varrefs (Fold f i c) = varrefs i + colVarrefs c + varrefs (f (ExprHole 0) (ExprHole 1))-varrefs (Channel b)  = boolVarrefs b-varrefs (Cond c t e) = boolVarrefs c + varrefs t + varrefs e--colVarrefs :: ColExpr a b c -> Int-colVarrefs (ColTerm _) = 1-colVarrefs (ColList lst) = sum $ map varrefs lst-colVarrefs (ColMap m c) = colVarrefs c + varrefs (m (ExprHole 0))-colVarrefs (ColSlice p l c) = varrefs (p (ExprHole 0)) + varrefs l + colVarrefs c-colVarrefs (ColCat a b) = colVarrefs a + colVarrefs b-colVarrefs (ColRange a b) = varrefs a + varrefs b--boolVarrefs :: BoolExpr a b c -> Int-boolVarrefs (BoolTerm _) = 1-boolVarrefs (BoolConst _) = 0-boolVarrefs (BoolAnd a b) = boolVarrefs a + boolVarrefs b-boolVarrefs (BoolOr a b) = boolVarrefs a + boolVarrefs b-boolVarrefs (BoolEqual a b) = boolVarrefs a + boolVarrefs b-boolVarrefs (BoolNot a) = boolVarrefs a-boolVarrefs (BoolAll f c) = boolVarrefs (f $ ExprHole 0) + colVarrefs c-boolVarrefs (BoolAny f c) = boolVarrefs (f $ ExprHole 0) + colVarrefs c-boolVarrefs (Rel a _ b) = varrefs a + varrefs b-boolVarrefs (ColEqual a b) = colVarrefs a + colVarrefs b-boolVarrefs (Sorted _ c) = colVarrefs c-boolVarrefs (AllDiff _ c) = colVarrefs c-boolVarrefs (BoolCond c t e) = boolVarrefs c + boolVarrefs t + boolVarrefs e-boolVarrefs (Dom i c)    = varrefs i + colVarrefs c----------------------------------- | Simplify expressions | -----------------------------------simplify :: (Eq s, Eq c, Eq b) => Expr s c b -> Expr s c b--- dropout rules (things that won't ever be changed)-simplify a@(Const _) = a-simplify a@(Term _) = a-simplify a@(ExprHole _) = a--- simplification rules (either decrease # of variable references, or leave that equal and decrease # of tree nodes)---- level 0 (result in a final expression)-simplify (Mult a@(Const 0) _) = a-simplify (Div a@(Const 0) _) = a-simplify (Mod a@(Const 0) _) = a-simplify (Mod _ (Const 1)) = Const 0-simplify (Mod _ (Const (-1))) = Const 0-simplify (Mod (Mult (Const a) b) (Const c)) | (a `mod` c)==0 = Const 0-simplify (Minus a b) | a==b = Const 0-simplify (Plus (Const a) (Const b)) = Const (a+b)-simplify (Minus (Const a) (Const b)) = Const (a-b)-simplify (Mult (Const a) (Const b)) = Const (a*b)-simplify (Div (Const a) (Const b)) = Const $ (a `div` b)-simplify (Abs (Const a)) = Const (abs a)-simplify (Mod (Const a) (Const b)) = Const $ (a `mod` b)-simplify (Plus (Const 0) a) = a-simplify (Mult (Const 1) a) = a-simplify (Div a (Const 1)) = a-simplify (At (ColList l) (Const c)) = l!!(fromInteger c)-simplify (ColSize (ColList l)) = Const $ toInteger $ length l-simplify (ColSize (ColSlice _ l _)) = l-simplify (Channel (BoolConst False)) = Const 0-simplify (Channel (BoolConst True)) = Const 1-simplify (Cond (BoolConst True) t _) = t-simplify (Cond (BoolConst False) _ f) = f---- level 1 (result in one recursive call to simplify)-simplify (Plus a b) | a==b = simplify $ Mult (Const 2) a-simplify (Div a (Const (-1))) = simplify $ Minus (Const 0) a-simplify (Plus (Const c) (Plus (Const a) b)) = simplify $ Plus (Const $ c+a) b-simplify (Plus (Const c) (Minus (Const a) b)) = simplify $ Minus (Const $ c+a) b-simplify (Minus (Const c) (Plus (Const a) b)) = simplify $ Minus (Const $ c-a) b-simplify (Minus (Const c) (Minus (Const a) b)) = simplify $ Plus (Const $ c-a) b-simplify (Mult (Const c) (Mult (Const a) b)) = simplify $ Mult (Const $ a*c) b-simplify (Div (Mult (Const a) b) (Const c)) | (a `mod` c)==0 = simplify $ Mult (Const (a `div` c)) b-simplify (ColSize (ColMap _ c)) = simplify $ ColSize c-simplify (Fold f1 i (ColMap f2 c)) = simplify $ Fold (\a b -> f1 a (f2 b)) i c-simplify (At (ColRange l h) p) = simplify $ Plus l p-simplify (Cond (BoolNot c) t f) = simplify $ Cond c f t---- level 2 (result in two recursive calls to simplify)-simplify (Plus a (Mult b c)) | a==b && ((varrefs a)>0) = simplify $ Mult (simplify $ Plus c (Const 1)) a-simplify (Plus a (Mult b c)) | a==c && ((varrefs a)>0) = simplify $ Mult (simplify $ Plus b (Const 1)) a-simplify (Plus (Mult b c) a) | a==b && ((varrefs a)>0) = simplify $ Mult (simplify $ Plus c (Const 1)) a-simplify (Plus (Mult b c) a) | a==c && ((varrefs a)>0) = simplify $ Mult (simplify $ Plus b (Const 1)) a-simplify (Plus (Mult a b) (Mult c d)) | a==c = simplify $ Mult (simplify $ Plus b d) a-simplify (Plus (Mult a b) (Mult c d)) | a==d = simplify $ Mult (simplify $ Plus b c) a-simplify (Plus (Mult a b) (Mult c d)) | b==c = simplify $ Mult (simplify $ Plus a d) b-simplify (Plus (Mult a b) (Mult c d)) | b==d = simplify $ Mult (simplify $ Plus a c) b-simplify (Minus a (Mult b c)) | a==b && ((varrefs a)>0) = simplify $ Mult (simplify $ Minus (Const 1) c) a-simplify (Minus a (Mult b c)) | a==c && ((varrefs a)>0) = simplify $ Mult (simplify $ Minus (Const 1) b) a-simplify (Minus (Mult b c) a) | a==b && ((varrefs a)>0) = simplify $ Mult (simplify $ Minus c (Const 1)) a-simplify (Minus (Mult b c) a) | a==c && ((varrefs a)>0) = simplify $ Mult (simplify $ Minus b (Const 1)) a-simplify (Minus (Mult a b) (Mult c d)) | a==c = simplify $ Mult (simplify $ Minus b d) a-simplify (Minus (Mult a b) (Mult c d)) | a==d = simplify $ Mult (simplify $ Minus b c) a-simplify (Minus (Mult a b) (Mult c d)) | b==c = simplify $ Mult (simplify $ Minus a d) b-simplify (Minus (Mult a b) (Mult c d)) | b==d = simplify $ Mult (simplify $ Minus a c) b-simplify (Mult (Abs a) (Abs b)) = simplify $ Abs (simplify $ Mult a b)-simplify (Div (Abs a) (Abs b)) = simplify $ Abs (simplify $ Div a b)-simplify (ColSize (ColRange l h)) = simplify $ Plus (Const 1) $ simplify $ Minus h l-simplify (At (ColSlice f _ c) i) = simplify $ At c (f i)-simplify (At (ColMap m c) i) = simplify $ m $ simplify $ At c i-simplify t@(At (ColCat c1 c2) c@(Const p)) = case simplify (ColSize c1) of-  Const l | p<l -> simplify $ At c1 c-  Const l | p>=l -> simplify $ At c2 (Const $ p-l)-  _ -> t    {- no further (At _ _) rules may follow after this -}---- level 3 (results in three recursive calls to simplify)-simplify (ColSize (ColCat a b)) = simplify $ Plus (simplify $ ColSize a) (simplify $ ColSize b)--- reordering rules (do not decrease # of variables or # of tree nodes, but normalize an expression in such a way that the same normalization cannot be applied anymore - possibly because that can only occur in a case already matched by a simplification rule above)---- level 1-simplify (Plus a (Const c)) = simplify $ Plus (Const c) a-simplify (Minus a (Const c)) = simplify $ Plus (Const (-c)) a-simplify (Mult a (Const c)) = simplify $ Mult (Const c) a-simplify (Mult (Const (-1)) a) = simplify $ Minus (Const 0) a---- level 2-simplify (Mult t@(Const c) (Plus (Const a) b)) = simplify $ Plus (Const (a*c)) (simplify $ Mult t b)-simplify (Mult t@(Const c) (Minus (Const a) b)) = simplify $ Minus (Const (a*c)) (simplify $ Mult t b)-simplify (Plus a (Plus t@(Const b) c)) = simplify $ Plus t (simplify $ Plus a c)-simplify (Plus a (Minus t@(Const b) c)) = simplify $ Plus t (simplify $ Minus a c)-simplify (Minus a (Plus (Const b) c)) = simplify $ Plus (Const (-b)) (simplify $ Minus a c)-simplify (Minus a (Minus (Const b) c)) = simplify $ Plus (Const (-b)) (simplify $ Plus a c)-simplify (Mult a (Mult t@(Const b) c)) = simplify $ Mult t (simplify $ Mult a c)-simplify (Plus (Plus t@(Const a) b) c) = simplify $ Plus t (simplify $ Plus b c)-simplify (Plus (Minus t@(Const a) b) c) = simplify $ Plus t (simplify $ Minus c b)-simplify (Minus (Plus t@(Const a) b) c) = simplify $ Plus t (simplify $ Minus b c)-simplify (Minus (Minus t@(Const a) b) c) = simplify $ Minus t (simplify $ Plus b c)-simplify (Mult (Mult t@(Const a) b) c) = simplify $ Mult t (simplify $ Mult b c)-simplify (Mult a (Minus t@(Const 0) b)) = simplify $ Minus t (simplify $ Mult a b)-simplify (Mult (Minus t@(Const 0) b) a) = simplify $ Minus t (simplify $ Mult a b)-simplify (Div (Minus t@(Const 0) a) b) = simplify $ Minus t (simplify $ Div a b)-simplify (Div a (Minus t@(Const 0) b)) = simplify $ Minus t (simplify $ Div a b)--- fallback rule-simplify a = a--colSimplify :: (Eq s, Eq c, Eq b) => ColExpr s c b -> ColExpr s c b--- dropout rules-colSimplify t@(ColTerm _) = t--- simplify rules---- level 1-colSimplify (ColMap f1 (ColMap f2 c)) = colSimplify $ ColMap (f1.f2) c-colSimplify (ColMap f (ColList l)) = colSimplify $ ColList (map f l)---- level 2-colSimplify (ColSlice p1 l1 (ColSlice p2 l2 c)) = colSimplify $ ColSlice (p1 . p2) l1 c--- reordering rules---- level 2-colSimplify (ColCat (ColCat c1 c2) c3) = colSimplify $ ColCat c1 (colSimplify $ ColCat c2 c3)-colSimplify (ColSlice p l (ColMap f c)) = colSimplify $ ColMap f $ colSimplify $ ColSlice p l c--- fallback rule-colSimplify x = x--boolSimplify :: (Eq s, Eq c, Eq b) => BoolExpr s c b -> BoolExpr s c b--- dropout rules-boolSimplify t@(BoolTerm _) = t-boolSimplify t@(BoolConst _) = t--- simplify rules---- level 0-boolSimplify (BoolAnd (BoolConst False) _) = BoolConst False-boolSimplify (BoolAnd (BoolConst True) a) = a-boolSimplify (BoolAnd _ (BoolConst False)) = BoolConst False-boolSimplify (BoolAnd a (BoolConst True)) = a-boolSimplify (BoolOr (BoolConst True) _) = BoolConst True-boolSimplify (BoolOr (BoolConst False) a) = a-boolSimplify (BoolOr _ (BoolConst True)) = BoolConst True-boolSimplify (BoolOr a (BoolConst False)) = a-boolSimplify (BoolNot (BoolConst a)) = BoolConst (not a)-boolSimplify (BoolEqual (BoolConst True) a) = a-boolSimplify (BoolEqual a (BoolConst True)) = a-boolSimplify (BoolNot (BoolNot a)) = a-boolSimplify (BoolOr a b) | a==b = a-boolSimplify (BoolAnd a b) | a==b = a-boolSimplify (BoolEqual a b) | a==b = BoolConst False-boolSimplify (Rel (Const a) r (Const b)) = BoolConst $ relCheck a r b-boolSimplify (BoolAll f (ColList [])) = BoolConst True-boolSimplify (BoolAny f (ColList [])) = BoolConst False-boolSimplify (BoolAll f (ColList [a])) = f a-boolSimplify (BoolAny f (ColList [a])) = f a-boolSimplify (ColEqual (ColList []) (ColList [])) = BoolConst True-boolSimplify (ColEqual (ColList []) (ColList _)) = BoolConst False-boolSimplify (ColEqual (ColList _) (ColList [])) = BoolConst False-boolSimplify (BoolCond (BoolConst True) t _) = t-boolSimplify (BoolCond (BoolConst False) _ f) = f---- level 1-boolSimplify (BoolEqual (BoolNot a) (BoolNot b)) = boolSimplify $ BoolEqual a b-boolSimplify (BoolEqual (BoolConst False) a) = boolSimplify $ BoolNot a-boolSimplify (BoolEqual a (BoolConst False)) = boolSimplify $ BoolNot a-boolSimplify (BoolNot (Rel a EREqual b)) = boolSimplify $ Rel a ERDiff b-boolSimplify (BoolNot (Rel a ERDiff b)) = boolSimplify $ Rel a EREqual b-boolSimplify (BoolAll f (ColList [a,b])) = boolSimplify $ f a `BoolAnd` f b-boolSimplify (BoolAny f (ColList [a,b])) = boolSimplify $ f a `BoolOr` f b-boolSimplify (ColEqual (ColList [a]) (ColList [b])) = boolSimplify $ Rel a EREqual b-boolSimplify (Rel (Channel a) EREqual (Channel b)) = boolSimplify $ BoolEqual a b-boolSimplify (BoolCond (BoolNot c) t f) = boolSimplify $ BoolCond c f t---- level 2-boolSimplify (BoolAnd (BoolNot a) (BoolNot b)) = boolSimplify $ BoolNot $ boolSimplify $ BoolOr a b-boolSimplify (BoolOr (BoolNot a) (BoolNot b)) = boolSimplify $ BoolNot $ boolSimplify $ BoolAnd a b-boolSimplify (Rel (Channel a) ERDiff (Channel b)) = boolSimplify $ BoolNot $ boolSimplify $ BoolEqual a b-boolSimplify (Rel (Channel a) ERLess (Channel b)) = boolSimplify $ BoolAnd b $ boolSimplify $ BoolNot a     -- int(b1) < int(b2)   <=>  !b1 && b2--- fallback-boolSimplify a = a------------------------------------------------------------------------ | Turn expressions over expressions into simply expressions | ------------------------------------------------------------------------collapse :: (Eq t, Eq c, Eq b) => Expr (Expr t c b) (ColExpr t c b) (BoolExpr t c b) -> Expr t c b-collapse (Term t) = t-collapse (Const i) = Const i-collapse (Plus a b) = simplify $ Plus (collapse a) (collapse b)-collapse (Minus a b) = simplify $ Minus (collapse a) (collapse b)-collapse (Mult a b) = simplify $ Mult (collapse a) (collapse b)-collapse (Div a b) = simplify $ Div (collapse a) (collapse b)-collapse (Mod a b) = simplify $ Mod (collapse a) (collapse b)-collapse (Abs a) = simplify $ Abs (collapse a)-collapse (At c a) = simplify $ At (colCollapse c) (collapse a)-collapse (ColSize c) = simplify $ ColSize (colCollapse c)-collapse (Fold f i c) = simplify $ Fold (\a b -> collapse $ f (Term a) (Term b)) (collapse i) (colCollapse c)-collapse (Channel b) = simplify $ Channel (boolCollapse b)-collapse (Cond c t e) = simplify $ Cond (boolCollapse c) (collapse t) (collapse e)--colCollapse :: (Eq t, Eq c, Eq b) => ColExpr (Expr t c b) (ColExpr t c b) (BoolExpr t c b) -> ColExpr t c b-colCollapse (ColTerm t) = t-colCollapse (ColList l) = colSimplify $ ColList $ map collapse l-colCollapse (ColMap f c) = colSimplify $ ColMap (\a -> collapse $ f (Term a)) (colCollapse c)-colCollapse (ColSlice p l c) = colSimplify $ ColSlice (\x -> collapse $ p (Term x)) (collapse l) (colCollapse c)-colCollapse (ColCat a b) = colSimplify $ ColCat (colCollapse a) (colCollapse b)-colCollapse (ColRange a b) = colSimplify $ ColRange (collapse a) (collapse b)--boolCollapse :: (Eq t, Eq c, Eq b) => BoolExpr (Expr t c b) (ColExpr t c b) (BoolExpr t c b) -> BoolExpr t c b-boolCollapse (BoolTerm t) = t-boolCollapse (BoolConst c) = BoolConst c-boolCollapse (BoolAnd a b) = boolSimplify $ BoolAnd (boolCollapse a) (boolCollapse b)-boolCollapse (BoolOr a b) = boolSimplify $ BoolOr (boolCollapse a) (boolCollapse b)-boolCollapse (BoolEqual a b) = boolSimplify $ BoolEqual (boolCollapse a) (boolCollapse b)-boolCollapse (BoolNot a) = boolSimplify $ BoolNot (boolCollapse a)-boolCollapse (Rel a r b) = boolSimplify $ Rel (collapse a) r (collapse b)-boolCollapse (BoolAll f c) = boolSimplify $ BoolAll (\a -> boolCollapse $ f (Term a)) (colCollapse c)-boolCollapse (BoolAny f c) = boolSimplify $ BoolAny (\a -> boolCollapse $ f (Term a)) (colCollapse c)-boolCollapse (ColEqual a b) = boolSimplify $ ColEqual (colCollapse a) (colCollapse b)-boolCollapse (Sorted b c) = boolSimplify $ Sorted b (colCollapse c)-boolCollapse (AllDiff b c) = boolSimplify $ AllDiff b (colCollapse c)-boolCollapse (BoolCond c t e) = boolSimplify $ BoolCond (boolCollapse c) (boolCollapse t) (boolCollapse e)-boolCollapse (Dom i c) = boolSimplify $ Dom (collapse i) (colCollapse c)---------------------------------------------- | walk through expressions--------------------------------------------data WalkPhase = WalkPre | WalkSingle | WalkPost-  deriving (Ord,Eq,Enum,Show)--data WalkResult = WalkSkip | WalkDescend-  deriving (Ord,Eq,Enum,Show)--xwalker :: (Eq t, Eq c, Eq b, Monad m) => (WalkPhase -> m WalkResult) -> (Expr t c b -> WalkPhase -> m WalkResult, ColExpr t c b -> WalkPhase -> m WalkResult, BoolExpr t c b -> WalkPhase -> m WalkResult) -> ([Expr t c b],[ColExpr t c b],[BoolExpr t c b]) -> m ()-xwalker q f ([],[],[]) = do-  q WalkSingle-  return ()-xwalker q f (li,lc,lb) = do-  r <- q WalkPre-  case r of-    WalkSkip -> return ()-    WalkDescend -> do-      mapM_ (\p -> walk p f) li-      mapM_ (\p -> colWalk p f) lc-      mapM_ (\p -> boolWalk p f) lb-      q WalkPost-      return ()--walker :: (Eq t, Eq c, Eq b, Monad m) => Expr t c b -> (Expr t c b -> WalkPhase -> m WalkResult, ColExpr t c b -> WalkPhase -> m WalkResult, BoolExpr t c b -> WalkPhase -> m WalkResult) -> ([Expr t c b],[ColExpr t c b],[BoolExpr t c b]) -> m ()-walker x f@(i,c,b) l = xwalker (i x) f l-colWalker :: (Eq t, Eq c, Eq b, Monad m) => ColExpr t c b -> (Expr t c b -> WalkPhase -> m WalkResult, ColExpr t c b -> WalkPhase -> m WalkResult, BoolExpr t c b -> WalkPhase -> m WalkResult) -> ([Expr t c b],[ColExpr t c b],[BoolExpr t c b]) -> m ()-colWalker x f@(i,c,b) l = xwalker (c x) f l-boolWalker :: (Eq t, Eq c, Eq b, Monad m) => BoolExpr t c b -> (Expr t c b -> WalkPhase -> m WalkResult, ColExpr t c b -> WalkPhase -> m WalkResult, BoolExpr t c b -> WalkPhase -> m WalkResult) -> ([Expr t c b],[ColExpr t c b],[BoolExpr t c b]) -> m ()-boolWalker x f@(i,c,b) l = xwalker (b x) f l--walk :: (Eq t, Eq c, Eq b, Monad m) => Expr t c b -> (Expr t c b -> WalkPhase -> m WalkResult, ColExpr t c b -> WalkPhase -> m WalkResult, BoolExpr t c b -> WalkPhase -> m WalkResult) -> m ()-walk x@(Term _) f = walker x f ([],[],[])-walk x@(Const _) f = walker x f ([],[],[])-walk x@(Plus a b) f = walker x f ([a,b],[],[])-walk x@(Minus a b) f = walker x f ([a,b],[],[])-walk x@(Mult a b) f = walker x f ([a,b],[],[])-walk x@(Div a b) f = walker x f ([a,b],[],[])-walk x@(Mod a b) f = walker x f ([a,b],[],[])-walk x@(Abs a) f = walker x f ([a],[],[])-walk x@(At c a) f = walker x f ([a],[c],[])-walk x@(ColSize c) f = walker x f ([],[c],[])-walk x@(Fold _ i c) f = walker x f ([i],[c],[])-walk x@(Channel b) f = walker x f ([],[],[b])-walk x@(Cond c t e) f = walker x f ([t,e],[],[c])-walk x@(ExprHole _) f = return ()--colWalk x@(ColTerm _) f = colWalker x f ([],[],[])-colWalk x@(ColList l) f = colWalker x f (l,[],[])-colWalk x@(ColMap _ c) f = colWalker x f ([],[c],[])-colWalk x@(ColSlice _ l c) f = colWalker x f ([l],[c],[])-colWalk x@(ColCat a b) f = colWalker x f ([],[a,b],[])-colWalk x@(ColRange a b) f = colWalker x f ([a,b],[],[])--boolWalk x@(BoolTerm _) f = boolWalker x f ([],[],[])-boolWalk x@(BoolConst _) f = boolWalker x f ([],[],[])-boolWalk x@(BoolAnd a b) f = boolWalker x f ([],[],[a,b])-boolWalk x@(BoolOr a b) f = boolWalker x f ([],[],[a,b])-boolWalk x@(BoolEqual a b) f = boolWalker x f ([],[],[a,b])-boolWalk x@(BoolNot a) f = boolWalker x f ([],[],[a])-boolWalk x@(Rel a _ b) f = boolWalker x f ([a,b],[],[])-boolWalk x@(BoolAll _ c) f = boolWalker x f ([],[c],[])-boolWalk x@(BoolAny _ c) f = boolWalker x f ([],[c],[])-boolWalk x@(ColEqual a b) f = boolWalker x f ([],[a,b],[])-boolWalk x@(Sorted _ c) f = boolWalker x f ([],[c],[])-boolWalk x@(AllDiff _ c) f = boolWalker x f ([],[c],[])-boolWalk x@(BoolCond c t e) f = boolWalker x f ([],[],[c,t,e])-boolWalk x@(Dom i c) f = boolWalker x f ([i],[c],[])-

− Data/Linear.hs

@@ -1,82 +0,0 @@-{-# LANGUAGE MultiParamTypeClasses #-}-{-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE StandaloneDeriving #-}-{-# LANGUAGE ScopedTypeVariables #-}--module Data.Linear (-  Linear,-  integerToLinear,-  constToLinear,-  termToLinear,---  linearOpLinear,---  linearOpLinears,-  linearToConst,-  linearToTerm,-  linearMultiply,-  linearMult,-  linearToList, linearToListEx,-  getCoef,-) where--import qualified Data.Map as Map-import Data.Map(Map)--data (Ord t, Num v) => Linear t v = Linear v (Map t v)--deriving instance (Num v, Eq v, Ord t, Eq t) => Eq (Linear t v)-deriving instance (Num v, Ord v, Ord t, Eq t) => Ord (Linear t v)-deriving instance (Num v, Show v, Ord t, Show t) => Show (Linear t v)--termToLinear :: (Num v, Ord t) => t -> Linear t v-termToLinear x = Linear 0 $ Map.singleton x 1--integerToLinear :: (Num v, Ord t) => Integer -> Linear t v-integerToLinear = constToLinear . fromInteger--constToLinear :: (Num v, Ord t) => v -> Linear t v-constToLinear x = Linear x Map.empty---- linearOpLinear :: (Num v, Ord t) => v -> Linear t v -> v -> Linear t v -> Linear t v--- linearOpLinear a (Linear ac am) b (Linear bc bm) = Linear (a*ac+b*bc) $ Map.filter (/=0) $ Map.unionWith (\ax bx -> ax*a+bx*b) am bm---- linearOpLinears :: (Num v, Ord t) => [(v,Linear t v)] -> Linear t v--- linearOpLinears l = foldr (\(c,t) a -> linearOpLinear 1 a c t) (integerToLinear 0) l--linearToList :: (Ord t, Num v) => Linear t v -> [(Maybe t,v)]-linearToList (Linear c m) = [(Nothing,c)] ++ (map (\(a,b) -> (Just a,b)) $ Map.toList m)--linearToListEx :: (Ord t, Num v) => Linear t v -> (v,[(t,v)])-linearToListEx (Linear c m) = (c,Map.toList m)--getCoef :: (Num v, Ord t) => Maybe t -> Linear t v -> v-getCoef Nothing (Linear c _) = c-getCoef (Just t) (Linear _ m) = Map.findWithDefault 0 t m--linearMult :: (Num v, Eq v, Ord t) => v -> Linear t v -> Linear t v-linearMult m (Linear ac am) = Linear (m*ac) $ if (m==0) then Map.empty else Map.filter (/=0) $ Map.map (m*) am--linearMultiply :: (Num v, Eq v, Ord t) => Linear t v -> Linear t v -> Maybe (Linear t v)-linearMultiply (Linear ac am) bl | (Map.null am) = Just $ linearMult ac bl-linearMultiply bl (Linear ac am) | (Map.null am) = Just $ linearMult ac bl-linearMultiply _ _ = Nothing--linearToConst :: (Num v, Ord t) => Linear t v -> Maybe v-linearToConst (Linear c m) | Map.null m = Just c-linearToConst _ = Nothing--linearToTerm :: (Num v, Eq v, Ord t) => Linear t v -> Maybe t-linearToTerm (Linear c m) | (c==0 && (Map.size m)==1) = -  let (t,v) = Map.findMin m-      in if (v==1) then Just t else Nothing-linearToTerm _ = Nothing--instance (Num v, Eq v, Ord t, Eq t, Show t) => Num (Linear t v) where-  (Linear ac am) + (Linear bc bm) = Linear (ac+bc) $ Map.filter (/=0) $ Map.unionWith (+) am bm-  (Linear ac am) - (Linear bc bm) = Linear (ac-bc) $ Map.filter (/=0) $ Map.unionWith (+) am $ Map.map negate bm-  a * b = case linearMultiply a b of Just x -> x; Nothing -> error "Cannot multiply generic linear expressions"-  negate (Linear ac am) = Linear (-ac) $ Map.map negate am-  abs (Linear ac am) | (Map.null am) = Linear (abs ac) Map.empty-  abs _ = error "Cannot take abs of generic linear expressions"-  signum (Linear ac am) | (Map.null am) = Linear (signum ac) Map.empty-  signum _ = error "Cannot take signum of generic linear expressions"-  fromInteger x = integerToLinear x

LICENSE view

@@ -1,26 +1,26 @@-Redistribution and use in source and binary forms, with or without-modification, are permitted provided that the following conditions-are met:--Redistributions of source code must retain the above copyright-notice, this list of conditions and the following disclaimer.--Redistributions in binary form must reproduce the above copyright-notice, this list of conditions and the following disclaimer in the-documentation and/or other materials provided with the distribution.--The names of its contributors may not be used to endorse or promote products-derived from this software without specific prior written permission.--THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS-"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT-LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR-A PARTICULAR PURPOSE ARE DISCLAIMED.  IN NO EVENT SHALL THE COPYRIGHT OWNER OR-CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL,-EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO,-PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR-PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF-LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING-NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS-SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.-+Redistribution and use in source and binary forms, with or without
+modification, are permitted provided that the following conditions
+are met:
+
+Redistributions of source code must retain the above copyright
+notice, this list of conditions and the following disclaimer.
+
+Redistributions in binary form must reproduce the above copyright
+notice, this list of conditions and the following disclaimer in the
+documentation and/or other materials provided with the distribution.
+
+The names of its contributors may not be used to endorse or promote products
+derived from this software without specific prior written permission.
+
+THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
+A PARTICULAR PURPOSE ARE DISCLAIMED.  IN NO EVENT SHALL THE COPYRIGHT OWNER OR
+CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL,
+EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO,
+PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR
+PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF
+LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING
+NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS
+SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+

− Language/CPP/Pretty.hs

@@ -1,241 +0,0 @@-{-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE TypeSynonymInstances #-}--module Language.CPP.Pretty (-  codegen-) where --import Text.PrettyPrint.HughesPJ-import Language.CPP.Syntax.AST--class Pretty t where-  pretty :: t -> Doc-  prettyPrec :: Int -> t -> Doc-  pretty = prettyPrec 0-  prettyPrec _ = pretty--class ToString t where-  toString :: t -> String--instance ToString CPPAssignOp where-  toString x = case x of-    CPPAssOp    -> "="-    CPPAssOpMul -> "*="-    CPPAssOpDiv -> "/="-    CPPAssOpRmd -> "%="-    CPPAssOpAdd -> "+="-    CPPAssOpSub -> "-="-    CPPAssOpShl -> "<<="-    CPPAssOpShr -> ">>="-    CPPAssOpAnd -> "&="-    CPPAssOpOr  ->  "|="-    CPPAssOpXor -> "^="--{--  Priorities in C (http://www.difranco.net/cop2220/op-prec.htm)- -  2:  comma-  4:  assignments-  6:  conditional-  8:  logical or-  10:  logical and-  12:  bitwise or-  14:  bitwise xor-  16:  bitwise and-  18:  equality/inequality test-  20: relational tests-  22: bitshift-  24: addition/subtraction-  26: multiplication/division/modulus-  28: preincrement/predecrement/negation/complement/cast/dereference/address/sizeof-  30: brackets/index/member/postincrement/postdecrement/--}---instance Pretty CPPConst where-  pretty (CPPConstInt x) = text $ show x-  pretty (CPPConstChar x) = text $ "'" ++ x ++ "'"   -- TODO: character escaping-  pretty (CPPConstString x) = text $ "\"" ++ x ++ "\""-  pretty (CPPConstFloat x) = text x--prio :: Int -> Int -> Doc -> Doc-prio myL outerL doc = if myL<outerL then parens doc else doc--instance Pretty CPPExpr where-  prettyPrec l (CPPConst x) = prettyPrec l x-  prettyPrec l (CPPAssign o1 op o2) = prio 4 l $ (prettyPrec 5 o1) <+> (text $ toString op) <+> (prettyPrec 4 o2)-  prettyPrec l (CPPVar v) = text v-  prettyPrec l (CPPComma lst) = lparen <> (foldl (<>) empty $ punctuate comma $ map (prettyPrec 2) lst) <> rparen-  prettyPrec l (CPPBinary o1 CPPOpMul  o2) = prio 26 l $ (prettyPrec 26 o1) <> text "*"  <> (prettyPrec 27 o2)-  prettyPrec l (CPPBinary o1 CPPOpDiv  o2) = prio 26 l $ (prettyPrec 26 o1) <> text "/"  <> (prettyPrec 27 o2)-  prettyPrec l (CPPBinary o1 CPPOpRmd  o2) = prio 26 l $ (prettyPrec 26 o1) <> text "%"  <> (prettyPrec 27 o2)-  prettyPrec l (CPPBinary o1 CPPOpAdd  o2) = prio 24 l $ (prettyPrec 24 o1) <> text "+"  <> (prettyPrec 24 o2)-  prettyPrec l (CPPBinary o1 CPPOpSub  o2) = prio 24 l $ (prettyPrec 24 o1) <> text "-"  <> (prettyPrec 25 o2)-  prettyPrec l (CPPBinary o1 CPPOpShl  o2) = prio 22 l $ (prettyPrec 22 o1) <> text "<<" <> (prettyPrec 23 o2)-  prettyPrec l (CPPBinary o1 CPPOpShr  o2) = prio 22 l $ (prettyPrec 22 o1) <> text ">>" <> (prettyPrec 23 o2)-  prettyPrec l (CPPBinary o1 CPPOpLe   o2) = prio 20 l $ (prettyPrec 20 o1) <> text "<"  <> (prettyPrec 21 o2)-  prettyPrec l (CPPBinary o1 CPPOpGr   o2) = prio 20 l $ (prettyPrec 20 o1) <> text ">"  <> (prettyPrec 21 o2)-  prettyPrec l (CPPBinary o1 CPPOpGeq  o2) = prio 20 l $ (prettyPrec 20 o1) <> text ">=" <> (prettyPrec 21 o2)-  prettyPrec l (CPPBinary o1 CPPOpLeq  o2) = prio 20 l $ (prettyPrec 20 o1) <> text "<=" <> (prettyPrec 21 o2)-  prettyPrec l (CPPBinary o1 CPPOpEq   o2) = prio 18 l $ (prettyPrec 18 o1) <> text "==" <> (prettyPrec 19 o2)-  prettyPrec l (CPPBinary o1 CPPOpNeq  o2) = prio 18 l $ (prettyPrec 18 o1) <> text "!=" <> (prettyPrec 19 o2)-  prettyPrec l (CPPBinary o1 CPPOpAnd  o2) = prio 16 l $ (prettyPrec 16 o1) <> text "&"  <> (prettyPrec 16 o2)-  prettyPrec l (CPPBinary o1 CPPOpXor  o2) = prio 14 l $ (prettyPrec 14 o1) <> text "^"  <> (prettyPrec 14 o2)-  prettyPrec l (CPPBinary o1 CPPOpOr   o2) = prio 12 l $ (prettyPrec 12 o1) <> text "|"  <> (prettyPrec 12 o2)-  prettyPrec l (CPPBinary o1 CPPOpLAnd o2) = prio 10 l $ (prettyPrec 10 o1) <> text "&&" <> (prettyPrec 10 o2)-  prettyPrec l (CPPBinary o1 CPPOpLOr  o2) = prio  8 l $ (prettyPrec  8 o1) <> text "||" <> (prettyPrec 8  o2)-  prettyPrec l (CPPUnary  CPPOpPreInc o)   = prio 28 l $                       text "++" <> (prettyPrec 28 o )-  prettyPrec l (CPPUnary  CPPOpPreDec o)   = prio 28 l $                       text "--" <> (prettyPrec 28 o )-  prettyPrec l (CPPUnary  CPPOpPostInc o)  = prio 28 l $ (prettyPrec 28 o ) <> text "++"-  prettyPrec l (CPPUnary  CPPOpPostDec o)  = prio 28 l $ (prettyPrec 28 o ) <> text "--"-  prettyPrec l (CPPUnary  CPPOpAdr o)      = prio 28 l $                       text "&"  <> (prettyPrec 28 o )-  prettyPrec l (CPPUnary  CPPOpInd o)      = prio 28 l $                       text "*"  <> (prettyPrec 28 o )-  prettyPrec l (CPPUnary  CPPOpPlus o)     = prio 28 l $                       text "+"  <> (prettyPrec 28 o )-  prettyPrec l (CPPUnary  CPPOpMinus o)    = prio 28 l $                       text "-"  <> (prettyPrec 28 o )-  prettyPrec l (CPPUnary  CPPOpComp o)     = prio 28 l $                       text "~"  <> (prettyPrec 28 o )-  prettyPrec l (CPPUnary  CPPOpNeg o)      = prio 28 l $                       text "!"  <> (prettyPrec 28 o )-  prettyPrec l (CPPCond c (Just t) f)      = prio  6 l $ (prettyPrec 7  c ) <+> text "?"  <+> (prettyPrec 7  t ) <+> text ":" <+> (prettyPrec 6 f)-  prettyPrec l (CPPCond c Nothing t)       = prio  6 l $ (prettyPrec 7  c ) <> text "?:" <> (prettyPrec 6  t )-  prettyPrec l (CPPCast t e)               = prio 28 l $ lparen <> (pretty t) <> rparen <>  (prettyPrec 28 e )-  prettyPrec l (CPPSizeOfExpr e)           = prio 28 l $ text "sizeof" <> lparen <> (pretty e) <> rparen-  prettyPrec l (CPPSizeOfType t)           = prio 28 l $ text "sizeof" <> lparen <> (pretty t) <> rparen-  prettyPrec l (CPPIndex a b)              = prio 28 l $ (prettyPrec 28 a) <> lbrack <> (pretty b) <> rbrack-  prettyPrec l (CPPCall a b)               = prio 28 l $ (prettyPrec 28 a) <> lparen <> (hcat $ punctuate comma $ map pretty b) <> rparen-  prettyPrec l (CPPMember a m False)       = prio 28 l $ (prettyPrec 28 a) <> text "." <> text m-  prettyPrec l (CPPMember a m True)        = prio 28 l $ (prettyPrec 28 a) <> text "->" <> text m-  prettyPrec l (CPPNew a b)                = prio 28 l $ text "new" <+> (pretty a) <> lparen <> (hcat $ punctuate comma $ map pretty b) <> rparen--instance Pretty s => Pretty (Maybe s) where-  prettyPrec _ Nothing = empty-  prettyPrec l (Just x) = prettyPrec l x--instance (Pretty a, Pretty b) => Pretty (Either a b) where-  prettyPrec l (Left x) = prettyPrec l x-  prettyPrec l (Right x) = prettyPrec l x--instance Pretty CPPStat where-  pretty (CPPLabel s b) = (nest (-1000) $ (text s) <> char ':') $$ pretty b-  pretty (CPPCase x b) = (text "case" <+> pretty x <> char ':') $+$ (nest 2 (pretty b))-  pretty (CPPDefault b) = (text "default:") $+$ (nest 2 $ pretty b)-  pretty (CPPSimple x) = (pretty x) <> char ';'-  pretty (CPPCompound []) = empty-  pretty (CPPCompound [CPPStatement (c@(CPPCompound _))]) = pretty c-  pretty (CPPCompound [CPPStatement (c@(CPPVerbStat _))]) = pretty c-  pretty (CPPCompound [CPPStatement a]) = pretty a-  pretty (CPPCompound l) = lbrace $+$ (nest 2 $ vcat $ map pretty l) $+$ rbrace-  pretty (CPPIf c t (Just f)) = text "if" <+> parens (pretty c) <+> braces (pretty t) <+> text "else" <+> braces (pretty f)-  pretty (CPPIf c t Nothing) = text "if" <+> parens (pretty c) <+> braces (pretty t)-  pretty (CPPSwitch x b) = text "switch (" <> pretty x <> text ") {" <+> pretty b <+> text "}"-  pretty (CPPWhile x False b) = text "while" <> (parens $ pretty x) <+> (braces $ pretty b)-  pretty (CPPWhile x True b) = text "do" <+> (braces $ pretty b) <+> text "while" <> (parens $ pretty x) <> semi-  pretty (CPPFor f1 f2 f3 b) = text "for (" <> pretty f1 <> text ";" <+> pretty f2 <> text ";" <+> pretty f3 <> text ") {" $+$ nest 2 (pretty b) $+$ text "}"-  pretty (CPPGoto l) = text ("goto " ++ l ++ ";")-  pretty (CPPCont) = text "continue;"-  pretty (CPPBreak) = text "break;"-  pretty (CPPReturn x) = (text "return" <+> pretty x) <> text ";"-  pretty (CPPDelete x) = (text "delete" <+> pretty x) <> text ";"-  pretty (CPPVerbStat l) = lbrace $+$ (nest 2 $ vcat $ map text l) $+$ rbrace--instance Pretty CPPQual where-  pretty (CPPQualConst) = text "const"-  pretty (CPPQualVolatile) = text "volatile"--instance Pretty CPPStorSpec where-  pretty (CPPAuto) = text "auto"-  pretty (CPPRegister) = text "register"-  pretty (CPPStatic) = text "static"-  pretty (CPPExtern) = text "extern"-  pretty (CPPTypedef) = text "typedef"-  pretty (CPPInline) = text "inline"-  pretty (CPPVirtual) = text "virtual"--instance Pretty a => Pretty [a] where-  pretty [] = empty-  pretty [a] = pretty a-  pretty (a:b) = pretty a <+> pretty b--instance Pretty CPPVisibility where-  pretty CPPPublic = text "public"-  pretty CPPPrivate = text "private"-  pretty CPPProtected = text "protected"--instance Pretty (CPPType,Doc,Int,[CPPQual]) where-  pretty (CPPPtr qual typ,s,l,q) = pretty (typ,char '*' <> (pretty q <+> (prio 4 l s)),4::Int,qual)-  pretty (CPPRef qual typ,s,l,q) = pretty (typ,char '&' <> (pretty q <+> (prio 4 l s)),4::Int,qual)-  pretty (CPPArray qual typ len,s,l,_) = pretty (typ,((prio 2 l s) <> lbrack <> pretty len <> rbrack),2::Int,qual)-  pretty (CPPTypePrim prim,s,l,q) = pretty q <+> (text prim <+> s)-  pretty (CPPTempl prim lst,s,l,q) = pretty q <+> (text prim <> char '<' <> (hcat $ punctuate comma $ map pretty lst) <> char '>') <+> s--instance Pretty (CPPType,Doc) where-  pretty (typ,doc) = pretty (typ,doc,0 :: Int,[]::[CPPQual])--instance Pretty CPPType where-  pretty x = pretty (x,empty)--prettyString Nothing = empty-prettyString (Just x) = text x--instance Pretty CPPDecl where-  pretty (CPPDecl { cppDeclName=name, cppType = typ, cppTypeQual = qual, cppTypeStor = stor, cppDeclInit=Nothing }) = pretty stor <+> pretty (typ,prettyString name,0 :: Int,qual)-  pretty (CPPDecl { cppDeclName=name, cppType = typ, cppTypeQual = qual, cppTypeStor = stor, cppDeclInit=Just (CPPInitValue code) }) = pretty stor <+> pretty (typ,prettyString name,0 :: Int,qual) <> char '=' <> pretty code-  pretty (CPPDecl { cppDeclName=name, cppType = typ, cppTypeQual = qual, cppTypeStor = stor, cppDeclInit=Just (CPPInitCall  args) }) = pretty stor <+> pretty (typ,prettyString name,0 :: Int,qual) <> lparen <> (hcat $ punctuate comma $ map pretty args) <> rparen-  pretty (CPPDecl { cppDeclName=name, cppType = typ, cppTypeQual = qual, cppTypeStor = stor, cppDeclInit=Just (CPPInitArray args) }) = pretty stor <+> pretty (typ,prettyString name,0 :: Int,qual) <> char '=' <> lbrace <> (hcat $ punctuate comma $ map pretty args) <> rbrace--instance Pretty CPPDef where-  pretty (CPPDef { cppDefName=name, cppDefRetType=typ, cppDefStor=stor, cppDefArgs=args, cppDefBody = body, cppDefQual=qual }) =-    let pre = (pretty stor <+> pretty (typ, text name)) <> parens (hcat $ punctuate comma $ map pretty args) <+> (hsep $ map pretty qual)-        in case body of-          Nothing -> pre <> text ";"-          Just b -> pre <+> text "{" $+$ (nest 2 $ pretty b) $+$ text "}"--instance Pretty (CPPConstr,String) where-  pretty (CPPConstr { cppConstrStor=stor, cppConstrArgs=args, cppConstrBody=body, cppConstrInit=ini },name) =-    let pre = (pretty stor <+> text name) <> parens (hcat $ punctuate comma $ map pretty args)-        init [] = empty-        init lst = colon <+> (hcat $ punctuate (text ", ") $ map (\(tp,args) -> pretty tp <> (parens $ hcat $ punctuate comma $ map pretty args)) lst)-        in case body of-          Nothing -> (pre <+> init ini) <> text ";"-          Just b -> (pre <+> init ini) <+> text "{" $+$ (nest 2 $ pretty b) $+$ text "}"--instance Pretty CPPBlockItem where-  pretty (CPPStatement stat) = pretty stat-  pretty (CPPBlockDecl decl) = pretty decl <> text ";"-  pretty (CPPComment str) = text "//" <+> text str--instance Pretty CPPMacroStm where-  pretty (CPPMacroIncludeUser str) = text "#include" <+> (text $ "\"" ++ str ++"\"")-  pretty (CPPMacroIncludeSys str)  = text "#include" <+> (text $ "<" ++ str ++ ">")-  pretty (CPPMacroDefine { cppMacroDefName = name, cppMacroDefArgs = Nothing, cppMacroDefExpr = expr }) = text "#define" <+> text name <+> text expr-  pretty (CPPMacroDefine { cppMacroDefName = name, cppMacroDefArgs = Just lst, cppMacroDefExpr = expr }) = text $ "#define " ++ name ++ "(" ++ (foldr1 (\a b -> a++","++b) lst) ++ ")" ++ " " ++ expr--instance Pretty CPPElement where-  pretty (CPPElemNamespace (name,ns)) = (text "namespace" <+> text name <+> lbrace) $+$ nest 2 (pretty ns) $+$ rbrace-  pretty (CPPElemDecl decl) = pretty decl <> semi-  pretty (CPPElemDef def) = pretty def-  pretty (CPPElemClass cls) = pretty cls--instance Pretty CPPNamespace where-  pretty (CPPNamespace list) = vcat $ map (\x -> pretty x $+$ char ' ') list--instance Pretty CPPClass where-  pretty (CPPClass { cppClassName = name, cppClassInherit = inh, cppClassDecls = decls, cppClassDefs = defs, cppClassConstrs = constrs }) = -    let sel vis lst = map snd $ filter (\x -> fst x == vis) lst-        inhh [] = empty-        inhh lst = colon <+> (hcat $ punctuate (text ", ") $ map (\(vis,tp) -> pretty vis <+> pretty tp) lst)-        decl vis = case sel vis decls of-          [] -> empty-          lst -> (nest (-2) (pretty vis) <> char ':') $+$ vcat (map (\x -> pretty x <> semi) lst) $+$ text " "-        def vis = case sel vis defs of-          [] -> empty-          lst -> (nest (-2) (pretty vis) <> char ':') $+$ vcat (map pretty lst) $+$ text " "-        constr vis = case sel vis constrs of-          [] -> empty-          lst -> (nest (-2) (pretty vis) <> char ':') $+$ vcat (map (\x -> pretty (x,name)) lst) $+$ text " "-        comb vis = constr vis $+$ def vis-        in (text "class" <+> text name <+> inhh inh <+> char '{') $+$ nest 2 (decl CPPPrivate $+$ decl CPPProtected $+$ decl CPPPublic $+$ comb CPPPrivate $+$ comb CPPProtected $+$ comb CPPPublic) $+$ char '}' <> semi--instance Pretty CPPFile where-  pretty (CPPFile { cppMacroStm = macro, cppUsing = using, cppTranslUnit = unit }) = vcat (map pretty macro) $+$ text " " $+$ vcat (map (\x -> text "using" <+> text "namespace" <+> text x <> semi) using) $+$ text " " $+$ pretty unit--codegen :: Pretty x => x -> String-codegen = render . pretty

− Language/CPP/Syntax/AST.hs

@@ -1,174 +0,0 @@--- AST for C++ code--{- based on:-   language-c-0.3.1.1: Analysis and generation of C code-   Language.C.Syntax.AST--   Abstract syntax of C++ source and header files.--}--module Language.CPP.Syntax.AST where--data CPPFile = CPPFile { cppMacroStm :: [CPPMacroStm], cppUsing :: [String], cppTranslUnit :: CPPNamespace }-  deriving (Eq,Ord,Show)--data CPPMacroStm = -    CPPMacroIncludeUser String-  | CPPMacroIncludeSys String-  | CPPMacroDefine { cppMacroDefName:: String, cppMacroDefArgs :: Maybe [String], cppMacroDefExpr :: String }-  deriving (Eq,Ord,Show)--data CPPElement =-    CPPElemNamespace (String,CPPNamespace)-  | CPPElemDecl CPPDecl-  | CPPElemDef CPPDef-  | CPPElemClass CPPClass-  deriving (Eq,Ord,Show)--data CPPNamespace = CPPNamespace [CPPElement]-  deriving (Eq,Ord,Show)--data CPPClass = CPPClass { cppClassName :: String, cppClassInherit :: [(CPPVisibility,CPPType)], cppClassDecls :: [(CPPVisibility,CPPDecl)], cppClassDefs :: [(CPPVisibility,CPPDef)], cppClassConstrs :: [(CPPVisibility,CPPConstr)] }-  deriving (Eq,Ord,Show)--data CPPVisibility =-    CPPPublic-  | CPPProtected-  | CPPPrivate-  deriving (Eq,Ord,Show)---- TODO: function pointers--- TODO: struct/union/enum-data CPPType =-    CPPTypePrim String-  | CPPArray [CPPQual] CPPType (Maybe CPPExpr)-  | CPPPtr [CPPQual] CPPType-  | CPPRef [CPPQual] CPPType-  | CPPTempl String [CPPType]-  deriving (Eq,Ord,Show)--data CPPStorSpec =-    CPPAuto-  | CPPRegister-  | CPPStatic-  | CPPExtern-  | CPPTypedef-  | CPPInline-  | CPPVirtual-  deriving (Eq,Ord,Show)--data CPPQual =-    CPPQualConst-  | CPPQualVolatile-  deriving (Eq,Ord,Show)--data CPPInit =-    CPPInitValue CPPExpr-  | CPPInitCall  [CPPExpr]-  | CPPInitArray [CPPExpr]-  deriving (Eq,Ord,Show)--data CPPDecl = CPPDecl { cppDeclName :: Maybe String, cppType :: CPPType, cppTypeQual :: [CPPQual], cppTypeStor :: [CPPStorSpec], cppDeclInit :: Maybe CPPInit }-  deriving (Eq,Ord,Show)--data CPPDef = CPPDef { cppDefName :: String, cppDefRetType :: CPPType, cppDefStor :: [CPPStorSpec], cppDefQual :: [CPPQual], cppDefArgs :: [CPPDecl], cppDefBody :: Maybe CPPStat }-  deriving (Eq,Ord,Show)--data CPPConstr = CPPConstr { cppConstrStor :: [CPPStorSpec], cppConstrArgs :: [CPPDecl], cppConstrBody :: Maybe CPPStat, cppConstrInit :: [(Either CPPExpr CPPType,[CPPExpr])] }-  deriving (Eq,Ord,Show)--data CPPStat = -    CPPLabel String CPPStat-  | CPPCase CPPExpr CPPStat-  | CPPDefault CPPStat-  | CPPSimple CPPExpr-  | CPPCompound [CPPBlockItem]-  | CPPVerbStat [String]-  | CPPIf CPPExpr CPPStat (Maybe CPPStat)-  | CPPSwitch CPPExpr CPPStat-  | CPPWhile CPPExpr Bool CPPStat-  | CPPFor (Either (Maybe CPPExpr) CPPDecl) (Maybe CPPExpr) (Maybe CPPExpr) CPPStat-  | CPPGoto String-  | CPPCont-  | CPPBreak-  | CPPReturn (Maybe CPPExpr)-  | CPPDelete CPPExpr-  deriving (Eq,Ord,Show)--data CPPBlockItem =-    CPPStatement CPPStat-  | CPPBlockDecl CPPDecl-  | CPPComment String-  deriving (Eq,Ord,Show)--data CPPExpr =-    CPPComma [CPPExpr]-  | CPPAssign CPPExpr CPPAssignOp CPPExpr-  | CPPBinary CPPExpr CPPBinaryOp CPPExpr-  | CPPUnary CPPUnaryOp CPPExpr-  | CPPCond CPPExpr (Maybe CPPExpr) CPPExpr-  | CPPCast CPPType CPPExpr-  | CPPSizeOfExpr CPPExpr-  | CPPSizeOfType CPPType-  | CPPIndex CPPExpr CPPExpr-  | CPPCall CPPExpr [CPPExpr]-  | CPPMember CPPExpr String Bool-  | CPPVar String-  | CPPConst CPPConst-  | CPPNew CPPType [CPPExpr]-  deriving (Eq,Ord,Show)--data CPPConst =-    CPPConstInt Integer-  | CPPConstChar String-  | CPPConstFloat String-  | CPPConstString String-  deriving (Eq,Ord,Show)--data CPPAssignOp =-    CPPAssOp-  | CPPAssOpMul-  | CPPAssOpDiv-  | CPPAssOpRmd-  | CPPAssOpAdd-  | CPPAssOpSub-  | CPPAssOpShl-  | CPPAssOpShr-  | CPPAssOpAnd-  | CPPAssOpOr-  | CPPAssOpXor-  deriving (Eq,Ord,Show)--data CPPUnaryOp =-    CPPOpPreInc-  | CPPOpPostInc-  | CPPOpPreDec-  | CPPOpPostDec-  | CPPOpAdr-  | CPPOpInd-  | CPPOpPlus-  | CPPOpMinus-  | CPPOpComp-  | CPPOpNeg-  deriving (Eq,Ord,Show)--data CPPBinaryOp =-    CPPOpMul-  | CPPOpDiv-  | CPPOpRmd-  | CPPOpAdd-  | CPPOpSub-  | CPPOpShl-  | CPPOpShr-  | CPPOpLe-  | CPPOpGr-  | CPPOpLeq-  | CPPOpGeq-  | CPPOpEq-  | CPPOpNeq-  | CPPOpAnd-  | CPPOpOr-  | CPPOpXor-  | CPPOpLAnd-  | CPPOpLOr-  deriving (Eq,Ord,Show)

README.md view

@@ -1,11 +1,11 @@-monadiccp [![Build Status](https://secure.travis-ci.org/neothemachine/monadiccp.png?branch=master)](http://travis-ci.org/neothemachine/monadiccp)-=========---Acknowledgments------------------- Thanks to Chris Mears for a patch to get-  the package to compile against GHC 7.4.1.-- Thanks to Nicholas Tung for a patch to get-  the package to compile against GHC 7.2.2.+monadiccp [![Build Status](https://travis-ci.org/letmaik/monadiccp.svg?branch=master)](https://travis-ci.org/letmaik/monadiccp)
+=========
+
+
+Acknowledgments
+---------------
+
+- Thanks to Chris Mears for a patch to get
+  the package to compile against GHC 7.4.1.
+- Thanks to Nicholas Tung for a patch to get
+  the package to compile against GHC 7.2.2.

Setup.hs view

@@ -1,4 +1,4 @@-#! /usr/bin/env runhaskell- -import Distribution.Simple-main = defaultMain+#! /usr/bin/env runhaskell
+ 
+import Distribution.Simple
+main = defaultMain

examples/AllInterval.hs view

@@ -1,28 +1,28 @@-{-# LANGUAGE TypeFamilies #-}-{-# LANGUAGE FlexibleContexts #-}--import Control.CP.FD.Example---- diffList: the differences between successive elements of a list-diffList l = exists $ \d -> do     -- request a (collection) variable d-  let n = size l                   -- introduce n as alias for size l-  size d @= n-1                    -- size of d must be one less than l-  loopall (0,n-2) $ \i -> do       -- for each i in [0..n-2]-    d!i @= abs (l!i - l!(i+1))     -- d[i] = abs(l[i]-l[i+1])-  return d                         -- and return d to the caller--model :: ExampleModel ModelInt     -- type signature-model n =                          -- function 'model' takes argument n-  exists $ \x -> do                -- request a (collection) variable x-    size x @= n                    -- whose size must be n-    d <- diffList x                -- d becomes the diffList of x-    x `allin` (cte 0,n-1)          -- all x elements are in [0..n-1]-    d `allin` (cte 1,n-1)          -- all d elements are in [1..n-1]-    allDiff x                      -- all x elements are different-    allDiff d                      -- all d elements are different-    x @!! 0 @< x @!! 1             -- some symmetry breaking-    d @!! 0 @> d ! (n-2)           -- some symmetry breaking-    return x                       -- return the list itself--main = example_sat_main_single_expr model-+{-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE FlexibleContexts #-}
+
+import Control.CP.FD.Example
+
+-- diffList: the differences between successive elements of a list
+diffList l = exists $ \d -> do     -- request a (collection) variable d
+  let n = size l                   -- introduce n as alias for size l
+  size d @= n-1                    -- size of d must be one less than l
+  loopall (0,n-2) $ \i -> do       -- for each i in [0..n-2]
+    d!i @= abs (l!i - l!(i+1))     -- d[i] = abs(l[i]-l[i+1])
+  return d                         -- and return d to the caller
+
+model :: ExampleModel ModelInt     -- type signature
+model n =                          -- function 'model' takes argument n
+  exists $ \x -> do                -- request a (collection) variable x
+    size x @= n                    -- whose size must be n
+    d <- diffList x                -- d becomes the diffList of x
+    x `allin` (cte 0,n-1)          -- all x elements are in [0..n-1]
+    d `allin` (cte 1,n-1)          -- all d elements are in [1..n-1]
+    allDiff x                      -- all x elements are different
+    allDiff d                      -- all d elements are different
+    x @!! 0 @< x @!! 1             -- some symmetry breaking
+    d @!! 0 @> d ! (n-2)           -- some symmetry breaking
+    return x                       -- return the list itself
+
+main = example_sat_main_single_expr model
+

examples/Alpha.hs view

@@ -1,53 +1,53 @@-{-# LANGUAGE TypeFamilies #-}-{-# LANGUAGE FlexibleContexts #-}---- A kid goes into a grocery store and buys four items. The cashier charges $7.11. --- The kid pays and is about to leave when the cashier calls the kid back, and says --- "Hold on, I multiplied the four items instead of adding them; I'll try again... --- Gosh, with adding them the price still comes to $7.11"! What were the prices of --- the four items?--import Data.Char (ord)--import Control.CP.FD.Example-import Control.CP.FD.Interface-import Control.CP.FD.Model-import Control.CP.SearchTree-import Control.CP.Solver---(@==) :: (MonadTree m, TreeSolver m ~ s, Constraint s ~ Either Model q) => ModelInt -> ModelInt -> m ()-(@==) = (@=)---word :: ModelCol -> String -> ModelInt-word lst = foldr (\x -> (lst!(cte $ ord x - ord 'a')+)) (cte 0)--model :: ExampleModel ()-model _ = exists $ \col -> do-  size col @= cte 26-  allDiff col-  col `allin` (cte 1,cte 26)-  word col "ballet"    @== 45-  word col "cello"     @== 43-  word col "concert"   @== 74-  word col "flute"     @== 30-  word col "fugue"     @== 50-  word col "glee"      @== 66-  word col "jazz"      @== 58-  word col "lyre"      @== 47-  word col "oboe"      @== 53-  word col "opera"     @== 65-  word col "polka"     @== 59-  word col "quartet"   @== 50-  word col "saxophone" @== 134-  word col "scale"     @== 51-  word col "solo"      @== 37-  word col "song"      @== 61-  word col "soprano"   @== 82-  word col "theme"     @== 72-  word col "violin"    @== 100-  word col "waltz"     @== 34-  return col--main = example_sat_main_void model+{-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE FlexibleContexts #-}
+
+-- A kid goes into a grocery store and buys four items. The cashier charges $7.11. 
+-- The kid pays and is about to leave when the cashier calls the kid back, and says 
+-- "Hold on, I multiplied the four items instead of adding them; I'll try again... 
+-- Gosh, with adding them the price still comes to $7.11"! What were the prices of 
+-- the four items?
+
+import Data.Char (ord)
+
+import Control.CP.FD.Example
+import Control.CP.FD.Interface
+import Control.CP.FD.Model
+import Control.CP.SearchTree
+import Control.CP.Solver
+
+
+(@==) :: (MonadTree m, TreeSolver m ~ s, Constraint s ~ Either Model q) => ModelInt -> ModelInt -> m ()
+(@==) = (@=)
+
+
+word :: ModelCol -> String -> ModelInt
+word lst = foldr (\x -> (lst!(cte $ ord x - ord 'a')+)) (cte 0)
+
+model :: ExampleModel ()
+model _ = exists $ \col -> do
+  size col @= cte 26
+  allDiff col
+  col `allin` (cte 1,cte 26)
+  word col "ballet"    @== 45
+  word col "cello"     @== 43
+  word col "concert"   @== 74
+  word col "flute"     @== 30
+  word col "fugue"     @== 50
+  word col "glee"      @== 66
+  word col "jazz"      @== 58
+  word col "lyre"      @== 47
+  word col "oboe"      @== 53
+  word col "opera"     @== 65
+  word col "polka"     @== 59
+  word col "quartet"   @== 50
+  word col "saxophone" @== 134
+  word col "scale"     @== 51
+  word col "solo"      @== 37
+  word col "song"      @== 61
+  word col "soprano"   @== 82
+  word col "theme"     @== 72
+  word col "violin"    @== 100
+  word col "waltz"     @== 34
+  return col
+
+main = example_sat_main_void model

examples/BIBD.hs view

@@ -1,29 +1,29 @@-{-# LANGUAGE TypeFamilies #-}-{-# LANGUAGE FlexibleContexts #-}--import Control.CP.FD.Example---- path :: ModelInt -> ModelCol -> (ModelInt -> ModelInt) -> (ModelInt -> ModelInt) -> ModelCol--- row :: ModelInt -> ModelCol -> ModelInt -> ModelCol--- col :: ModelInt -> ModelCol -> ModelInt -> ModelCol-path nc ne l r c = slice l $ xmap (\k -> nc*(r k)+(c k)) (0 @.. (ne-1))-row nc ne l i = path nc ne l (const i) id-col nc ne l i = path nc ne l id (const i)--model :: ExampleModel (ModelInt,ModelInt,ModelInt)-model (v,k,lambda) = exists $ \mm -> do-  let b = (v*(v-1)*lambda) `div` (k*(k-1))-  let r = (lambda*(v-1)) `div` (k-1)-  size mm @= b*v-  let p r c = mm!(r*b+c)-  mm `allin` (cte 0,cte 1)-  loopall (0,v-1) $ \rr -> xsum (row b b mm rr) @= r-  loopall (0,b-1) $ \cc -> xsum (col b v mm cc) @= k-  loopall (0,v-1) $ \r1 -> do-    loopall (r1+1,v-1) $ \r2 -> do-      xsum (xmap (\i -> (p r1 i) * (p r2 i)) (0 @.. (b-1))) @= lambda-  return mm--main = example_sat_main_void (\_ -> model (6,3,2))--+{-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE FlexibleContexts #-}
+
+import Control.CP.FD.Example
+
+-- path :: ModelInt -> ModelCol -> (ModelInt -> ModelInt) -> (ModelInt -> ModelInt) -> ModelCol
+-- row :: ModelInt -> ModelCol -> ModelInt -> ModelCol
+-- col :: ModelInt -> ModelCol -> ModelInt -> ModelCol
+path nc ne l r c = slice l $ xmap (\k -> nc*(r k)+(c k)) (0 @.. (ne-1))
+row nc ne l i = path nc ne l (const i) id
+col nc ne l i = path nc ne l id (const i)
+
+model :: ExampleModel (ModelInt,ModelInt,ModelInt)
+model (v,k,lambda) = exists $ \mm -> do
+  let b = (v*(v-1)*lambda) `div` (k*(k-1))
+  let r = (lambda*(v-1)) `div` (k-1)
+  size mm @= b*v
+  let p r c = mm!(r*b+c)
+  mm `allin` (cte 0,cte 1)
+  loopall (0,v-1) $ \rr -> xsum (row b b mm rr) @= r
+  loopall (0,b-1) $ \cc -> xsum (col b v mm cc) @= k
+  loopall (0,v-1) $ \r1 -> do
+    loopall (r1+1,v-1) $ \r2 -> do
+      xsum (xmap (\i -> (p r1 i) * (p r2 i)) (0 @.. (b-1))) @= lambda
+  return mm
+
+main = example_sat_main_void (\_ -> model (6,3,2))
+
+

examples/Domino.hs view

@@ -1,96 +1,96 @@-{-# LANGUAGE TypeFamilies #-}-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE ScopedTypeVariables #-}--import Control.CP.FD.Example--model :: ExampleModel ModelInt-model num = do-  let spc = spec num-      width = (spc!  cte 0)-      height = (spc! cte 1) -      board0 = (slice spc (cte 2 @.. (width*height+1))) @++ (list [cte $ -1])-      brd = slice board0 $ xmap (\i -> ((i @% (width+1)) @= width) @? (width*height,width*(i @/ (width+1))+(i @% (width+1)))) (cte 0 @.. ((width+1)*height-1))-  exists $ \board -> do-    board @= brd-    exists $ \ps -> do-      size ps @= 56-      let p1 i = ps!(2*i)-          p2 i = ps!(2*i+1)-          posdiffs = list [1,width+1]-      exists $ \x -> do-        size x @= (width+1)*height-        loopall (0,height-1) $ \i -> x!(i*(width+1)+width) @= cte 28-        loopall (0,6) $ \i ->-          loopall (i,6) $ \j -> do-            let dc = j-i+((1+17*i-(i+1)*(i+1)) `div` 2)-                diff = abs $ (p1 dc) - (p2 dc)-            diff @: posdiffs-            (j @= i) @?? (p1 dc @< p2 dc,true)-            board!(p1 dc) @= i-            board!(p2 dc) @= j-            x!(p1 dc) @= dc-            x!(p2 dc) @= dc-      return ps--main = example_sat_main_single_expr model--specs :: ModelCol-specs = list -  [-      8,7,-      2,1,0,3,0,4,5,5,-      6,2,0,6,3,1,4,0,-      3,2,3,6,2,5,4,3,-      5,4,5,1,1,2,1,2,-      0,0,1,5,0,5,4,4,-      4,6,2,1,3,6,6,1,-      4,2,0,6,5,3,3,6,--      8,7,-      5,1,2,4,6,2,0,5,-      6,6,4,3,5,0,1,5,-      2,0,4,0,4,0,5,0,-      6,1,3,6,3,5,4,3,-      3,1,0,1,2,2,1,4,-      3,6,6,2,4,0,5,4,-      1,3,6,1,2,3,5,2,--      8,7,-      4,4,5,4,0,3,6,5,-      1,6,0,1,5,3,4,1,-      2,6,2,2,5,3,6,0,-      1,3,0,6,4,4,2,3,-      3,5,5,2,4,2,2,1,-      2,1,3,3,5,6,6,1,-      5,1,6,0,0,0,4,0,--      8,7,-      3,0,2,3,3,4,4,3,-      6,5,3,4,2,0,2,1,-      6,5,1,2,3,0,2,0,-      4,5,4,1,6,6,2,5,-      4,3,6,1,0,4,5,5,-      1,3,2,5,6,0,0,1,-      0,5,4,6,2,1,6,1,--      8,7,-      4,1,5,2,4,4,6,2,-      2,5,6,1,4,6,0,2,-      6,5,1,1,0,1,4,3,-      6,2,1,1,3,2,0,6,-      3,6,3,3,5,5,0,5,-      3,0,1,0,0,5,4,3,-      3,2,4,5,4,2,6,0,--      8,7,-      4,1,2,1,0,2,4,4,-      5,5,6,6,0,4,6,3,-      6,0,5,1,1,0,5,3,-      3,4,2,2,0,3,1,2,-      3,6,5,6,1,2,3,2,-      2,5,0,6,6,3,3,5,-      4,1,0,0,4,1,4,5-  ]--spec n = slice specs ((58*n) @.. (58*(n+1)))+{-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+
+import Control.CP.FD.Example
+
+model :: ExampleModel ModelInt
+model num = do
+  let spc = spec num
+      width = (spc!  cte 0)
+      height = (spc! cte 1) 
+      board0 = (slice spc (cte 2 @.. (width*height+1))) @++ (list [cte $ -1])
+      brd = slice board0 $ xmap (\i -> ((i @% (width+1)) @= width) @? (width*height,width*(i @/ (width+1))+(i @% (width+1)))) (cte 0 @.. ((width+1)*height-1))
+  exists $ \board -> do
+    board @= brd
+    exists $ \ps -> do
+      size ps @= 56
+      let p1 i = ps!(2*i)
+          p2 i = ps!(2*i+1)
+          posdiffs = list [1,width+1]
+      exists $ \x -> do
+        size x @= (width+1)*height
+        loopall (0,height-1) $ \i -> x!(i*(width+1)+width) @= cte 28
+        loopall (0,6) $ \i ->
+          loopall (i,6) $ \j -> do
+            let dc = j-i+((1+17*i-(i+1)*(i+1)) `div` 2)
+                diff = abs $ (p1 dc) - (p2 dc)
+            diff @: posdiffs
+            (j @= i) @?? (p1 dc @< p2 dc,true)
+            board!(p1 dc) @= i
+            board!(p2 dc) @= j
+            x!(p1 dc) @= dc
+            x!(p2 dc) @= dc
+      return ps
+
+main = example_sat_main_single_expr model
+
+specs :: ModelCol
+specs = list 
+  [
+      8,7,
+      2,1,0,3,0,4,5,5,
+      6,2,0,6,3,1,4,0,
+      3,2,3,6,2,5,4,3,
+      5,4,5,1,1,2,1,2,
+      0,0,1,5,0,5,4,4,
+      4,6,2,1,3,6,6,1,
+      4,2,0,6,5,3,3,6,
+
+      8,7,
+      5,1,2,4,6,2,0,5,
+      6,6,4,3,5,0,1,5,
+      2,0,4,0,4,0,5,0,
+      6,1,3,6,3,5,4,3,
+      3,1,0,1,2,2,1,4,
+      3,6,6,2,4,0,5,4,
+      1,3,6,1,2,3,5,2,
+
+      8,7,
+      4,4,5,4,0,3,6,5,
+      1,6,0,1,5,3,4,1,
+      2,6,2,2,5,3,6,0,
+      1,3,0,6,4,4,2,3,
+      3,5,5,2,4,2,2,1,
+      2,1,3,3,5,6,6,1,
+      5,1,6,0,0,0,4,0,
+
+      8,7,
+      3,0,2,3,3,4,4,3,
+      6,5,3,4,2,0,2,1,
+      6,5,1,2,3,0,2,0,
+      4,5,4,1,6,6,2,5,
+      4,3,6,1,0,4,5,5,
+      1,3,2,5,6,0,0,1,
+      0,5,4,6,2,1,6,1,
+
+      8,7,
+      4,1,5,2,4,4,6,2,
+      2,5,6,1,4,6,0,2,
+      6,5,1,1,0,1,4,3,
+      6,2,1,1,3,2,0,6,
+      3,6,3,3,5,5,0,5,
+      3,0,1,0,0,5,4,3,
+      3,2,4,5,4,2,6,0,
+
+      8,7,
+      4,1,2,1,0,2,4,4,
+      5,5,6,6,0,4,6,3,
+      6,0,5,1,1,0,5,3,
+      3,4,2,2,0,3,1,2,
+      3,6,5,6,1,2,3,2,
+      2,5,0,6,6,3,3,5,
+      4,1,0,0,4,1,4,5
+  ]
+
+spec n = slice specs ((58*n) @.. (58*(n+1)))

examples/EFPA.hs view

@@ -1,22 +1,22 @@-{-# LANGUAGE TypeFamilies #-}-{-# LANGUAGE FlexibleContexts #-}--import Control.CP.FD.Example--model :: ExampleModel (ModelInt,ModelInt,ModelInt,ModelInt)-model (v,q,l,d) = do-  let n = q*l-  let nseqpair = (v*(v-1)) `div` 2-  exists $ \c -> do-    size c @= n*v-    c `allin` (cte 1,q)-    let el ro co = c ! (ro*n+co)-    loopall (cte 0,v-1) $ \row -> do-      loopall (1,q) $ \val -> do-        xsum (xmap (\col -> channel (el row col @= val)) (0 @.. (n-1))) @= l-    loopall (cte 0,v-1) $ \a -> do-      loopall (a+1,v-1) $ \b -> do-        xsum (xmap (\col -> channel (el a col @/= el b col)) (0 @.. (n-1))) @= d-    return c--main = example_sat_main_void (\_ -> model (5,3,2,4))+{-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE FlexibleContexts #-}
+
+import Control.CP.FD.Example
+
+model :: ExampleModel (ModelInt,ModelInt,ModelInt,ModelInt)
+model (v,q,l,d) = do
+  let n = q*l
+  let nseqpair = (v*(v-1)) `div` 2
+  exists $ \c -> do
+    size c @= n*v
+    c `allin` (cte 1,q)
+    let el ro co = c ! (ro*n+co)
+    loopall (cte 0,v-1) $ \row -> do
+      loopall (1,q) $ \val -> do
+        xsum (xmap (\col -> channel (el row col @= val)) (0 @.. (n-1))) @= l
+    loopall (cte 0,v-1) $ \a -> do
+      loopall (a+1,v-1) $ \b -> do
+        xsum (xmap (\col -> channel (el a col @/= el b col)) (0 @.. (n-1))) @= d
+    return c
+
+main = example_sat_main_void (\_ -> model (5,3,2,4))

examples/GolombRuler.hs view

@@ -1,30 +1,30 @@-{-# LANGUAGE TypeFamilies #-}-{-# LANGUAGE FlexibleContexts #-}--import Control.CP.FD.Example--model :: ExampleMinModel ModelInt-model n =-  exists $ \m -> do-    size m @= n-    m `allin` (cte 0,n*n)-    let dn = (n*n-n) `div` 2-    exists $ \d -> do-      size d @= dn-      d `allin` (cte 0,n*n)-      let diag i j = d ! (((i*(2*n-i-1)) `div` 2) + j - i - 1)-      m!(cte 0) @= cte 0-      loopall (cte 1,n-1) $ \j -> do-        diag 0 j @= m!j-      loopall (cte 1,n-2) $ \i ->-        loopall (i+1,n-1) $ \j -> do-          diag i j @= (m!j) - (m!i)-      loopall (cte 0,n-1) $ \i ->-        loopall (i+1,n-1) $ \j -> do-          diag i j @>= (j-i)*(j-i+1) `div` 2-      diag 0 1 @<= diag (n-2) (n-1)-      allDiff d-    sSorted m-    return (m!(n-1),m)--main = example_min_main_single_expr model+{-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE FlexibleContexts #-}
+
+import Control.CP.FD.Example
+
+model :: ExampleMinModel ModelInt
+model n =
+  exists $ \m -> do
+    size m @= n
+    m `allin` (cte 0,n*n)
+    let dn = (n*n-n) `div` 2
+    exists $ \d -> do
+      size d @= dn
+      d `allin` (cte 0,n*n)
+      let diag i j = d ! (((i*(2*n-i-1)) `div` 2) + j - i - 1)
+      m!(cte 0) @= cte 0
+      loopall (cte 1,n-1) $ \j -> do
+        diag 0 j @= m!j
+      loopall (cte 1,n-2) $ \i ->
+        loopall (i+1,n-1) $ \j -> do
+          diag i j @= (m!j) - (m!i)
+      loopall (cte 0,n-1) $ \i ->
+        loopall (i+1,n-1) $ \j -> do
+          diag i j @>= (j-i)*(j-i+1) `div` 2
+      diag 0 1 @<= diag (n-2) (n-1)
+      allDiff d
+    sSorted m
+    return (m!(n-1),m)
+
+main = example_min_main_single_expr model

examples/GraphColor.hs view

@@ -1,415 +1,415 @@-{-# LANGUAGE TypeFamilies #-}-{-# LANGUAGE FlexibleContexts #-}--import Control.CP.FD.Example--model :: ExampleMinModel ()-model () = do-  let c = board-  let numNodes = c!0-      numEdges = c!1-      edgePos  = slice c ((cte 2) @.. (1+numEdges))-      edge i   = slice c ((2+numEdges+((i@=0) @? (cte 0,edgePos!(i-1)))) @.. (1+numEdges+(edgePos!i)))-  exists $ \numColors -> do-    exists $ \colors -> do-      numColors @: (cte 0,numNodes)-      size colors @= numNodes-      colors `allin` (cte 0,numColors)-      loopall (0,(size (edge 0)-1)) $ \i -> colors!((edge 0)!i) @= (size (edge 0)-1-i)-      loopall (1,numEdges-1) $ allDiffD . slice colors . edge-      return (numColors,colors)--main = example_min_main_void model--{---  [numNodes,numEdges,[cumul. clique sizes],[clique elems]]--  0--1-  |  |-  2--3--  4,4,2,4,6,8,0,1,1,3,3,2,2,0--     0-1-    /   \-   4-----2-    \   /-     \3/--  5,6,2,4,6,8,10,12,0,1,1,2,2,3,3,4,4,0,2,4--}--board :: ModelCol-board = list $- [-  200,367,-  30,60,85,110,135,160,185,210,235,260,285,305,325,345,365,385,405,425,445,465,485,505,525,545,565,585,600,615,630,645,660,675,690,705,720,735,750,765,780,795,810,825,840,855,870,885,900,910,920,930,940,950,955,960,965,970,975,980,985,990,995,1000,1005,1010,1015,1020,1025,1027,1029,1031,1033,1035,1037,1039,1041,1043,1045,1047,1049,1051,1053,1055,1057,1059,1061,1063,1065,1067,1069,1071,1073,1075,1077,1079,1081,1083,1085,1087,1089,1091,1093,1095,1097,1099,1101,1103,1105,1107,1109,1111,1113,1115,1117,1119,1121,1123,1125,1127,1129,1131,1133,1135,1137,1139,1141,1143,1145,1147,1149,1151,1153,1155,1157,1159,1161,1163,1165,1167,1169,1171,1173,1175,1177,1179,1181,1183,1185,1187,1189,1191,1193,1195,1197,1199,1201,1203,1205,1207,1209,1211,1213,1215,1217,1219,1221,1223,1225,1227,1229,1231,1233,1235,1237,1239,1241,1243,1245,1247,1249,1251,1253,1255,1257,1259,1261,1263,1265,1267,1269,1271,1273,1275,1277,1279,1281,1283,1285,1287,1289,1291,1293,1295,1297,1299,1301,1303,1305,1307,1309,1311,1313,1315,1317,1319,1321,1323,1325,1327,1329,1331,1333,1335,1337,1339,1341,1343,1345,1347,1349,1351,1353,1355,1357,1359,1361,1363,1365,1367,1369,1371,1373,1375,1377,1379,1381,1383,1385,1387,1389,1391,1393,1395,1397,1399,1401,1403,1405,1407,1409,1411,1413,1415,1417,1419,1421,1423,1425,1427,1429,1431,1433,1435,1437,1439,1441,1443,1445,1447,1449,1451,1453,1455,1457,1459,1461,1463,1465,1467,1469,1471,1473,1475,1477,1479,1481,1483,1485,1487,1489,1491,1493,1495,1497,1499,1501,1503,1505,1507,1509,1511,1513,1515,1517,1519,1521,1523,1525,1527,1529,1531,1533,1535,1537,1539,1541,1543,1545,1547,1549,1551,1553,1555,1557,1559,1561,1563,1565,1567,1569,1571,1573,1575,1577,1579,1581,1583,1585,1587,1589,1591,1593,1595,1597,1599,1601,1603,1605,1607,1609,1611,1613,1615,1617,1619,1621,1623,1625,-  6,11,14,25,40,42,48,53,61,76,80,87,89,92,108,115,120,131,132,137,145,159,162,163,164,168,172,173,176,182,-  3,15,16,31,34,35,37,38,49,58,67,78,86,91,100,110,114,123,129,132,133,140,143,154,167,168,174,175,193,197,-  3,10,33,38,43,45,48,51,65,66,82,88,90,93,94,103,107,128,131,141,152,155,168,185,199,-  0,4,7,26,28,33,36,58,61,72,79,81,90,99,105,114,115,124,135,152,159,161,173,181,192,-  12,15,28,39,43,44,45,66,83,84,85,99,102,108,112,115,120,126,131,152,157,163,171,182,183,-  13,14,15,38,55,66,76,78,87,91,95,99,109,110,125,130,134,137,148,153,159,169,181,185,195,-  3,4,31,35,41,42,57,60,65,66,72,74,84,86,90,91,94,96,110,139,140,141,165,179,199,-  0,4,5,9,28,31,42,49,54,63,65,72,74,75,76,82,91,99,107,109,140,147,154,169,182,-  4,5,10,17,41,43,48,58,65,85,92,97,107,112,114,129,131,146,150,153,158,169,176,184,191,-  4,8,15,16,20,21,37,55,68,84,87,104,109,112,117,119,122,123,126,133,142,164,167,180,195,-  5,6,10,11,28,30,43,46,53,60,66,79,82,105,114,116,119,124,127,147,157,171,184,195,196,-  15,16,30,35,36,56,66,78,81,84,99,126,128,129,138,151,152,153,166,190,-  5,21,23,29,39,40,49,69,88,114,122,127,128,142,148,155,161,171,188,190,-  0,3,15,23,31,41,57,60,69,76,89,107,109,128,153,155,161,169,174,183,-  9,33,43,61,64,69,85,98,100,101,114,120,138,144,172,182,184,187,188,198,-  4,6,8,10,23,27,45,57,66,68,71,93,110,122,139,146,150,155,156,188,-  4,14,18,22,63,77,78,83,94,98,104,114,150,166,172,177,183,186,196,199,-  22,35,46,47,63,64,70,78,87,99,102,112,116,119,125,131,152,165,174,186,-  1,3,13,15,19,26,46,51,65,73,76,110,114,149,152,163,166,170,178,186,-  9,29,33,40,50,54,102,105,111,112,119,120,124,128,136,138,144,175,190,199,-  39,75,79,102,106,112,123,125,138,145,154,155,159,162,165,168,175,181,189,196,-  0,11,12,23,42,63,68,71,79,83,89,98,113,117,121,141,156,176,177,193,-  10,17,31,56,77,89,102,115,116,117,118,120,136,157,163,168,172,182,193,196,-  9,34,35,43,44,57,60,64,79,87,88,94,103,133,156,157,166,171,174,189,-  13,21,22,31,41,45,66,67,79,86,112,116,119,146,160,171,175,181,192,195,-  11,24,26,45,57,91,99,102,122,123,135,141,144,146,154,156,167,191,194,199,-  17,44,53,61,82,90,95,103,107,122,124,145,169,186,190,-  2,14,26,37,58,61,75,95,103,109,115,116,141,154,199,-  5,13,21,28,61,64,65,73,105,115,119,132,148,154,185,-  10,20,38,45,61,75,109,111,115,143,150,157,163,179,186,-  9,45,48,49,51,52,57,64,70,128,158,163,182,183,192,-  47,55,57,64,79,80,105,131,152,163,172,180,186,190,197,-  16,36,69,84,99,113,118,121,126,137,160,162,165,177,196,-  16,44,50,53,54,65,69,80,96,112,125,139,150,153,193,-  6,54,72,76,86,95,96,144,145,148,151,164,168,180,183,-  10,18,19,37,65,85,90,104,112,128,147,158,164,192,198,-  20,21,36,50,53,74,90,96,99,124,129,140,163,171,183,-  13,20,27,53,65,77,86,98,110,125,133,139,147,188,196,-  23,41,43,49,58,74,77,86,111,126,150,168,173,185,189,-  11,35,62,89,125,132,134,141,149,163,166,167,171,194,196,-  14,28,30,52,114,115,122,125,132,135,172,177,179,181,195,-  0,8,9,20,23,53,77,93,121,136,141,147,150,191,199,-  3,21,47,49,91,102,106,113,124,136,140,143,177,178,194,-  44,46,52,53,68,82,89,90,120,128,144,147,175,178,192,-  8,16,19,21,67,72,79,82,86,90,115,116,149,152,199,-  12,30,78,80,97,120,122,123,143,146,151,165,173,177,178,-  9,19,39,46,91,109,128,130,131,146,148,150,178,185,198,-  29,44,69,74,96,115,122,126,189,199,-  22,42,52,53,97,113,146,151,160,195,-  19,20,32,77,81,133,134,138,147,177,-  0,4,56,59,107,109,144,149,158,167,-  6,69,99,104,110,114,118,134,152,172,-  25,76,126,140,143,-  4,54,67,116,142,-  47,52,124,151,192,-  32,55,61,64,73,-  11,65,128,134,190,-  45,48,63,131,139,-  34,55,82,108,151,-  24,34,54,112,156,-  12,47,72,148,163,-  74,126,145,162,170,-  73,78,104,175,192,-  19,83,127,130,166,-  20,90,98,137,165,-  22,24,29,49,132,-  82,92,116,134,184,-  160,184,-  192,199,-  0,129,-  20,80,-  8,29,-  93,171,-  101,165,-  124,193,-  2,100,-  66,173,-  151,191,-  164,187,-  3,130,-  118,176,-  121,184,-  25,106,-  159,193,-  121,123,-  5,62,-  97,101,-  6,143,-  123,163,-  19,125,-  17,108,-  122,168,-  181,184,-  25,41,-  62,70,-  29,103,-  48,67,-  46,160,-  79,170,-  143,152,-  38,184,-  2,40,-  191,195,-  7,196,-  62,199,-  76,141,-  82,166,-  36,80,-  51,189,-  13,97,-  3,192,-  90,180,-  47,176,-  13,172,-  92,121,-  50,64,-  65,113,-  108,123,-  26,106,-  34,153,-  90,123,-  34,39,-  116,178,-  22,179,-  50,61,-  84,105,-  84,93,-  19,108,-  29,59,-  63,185,-  119,129,-  50,177,-  80,194,-  13,36,-  46,56,-  38,144,-  82,193,-  72,93,-  49,95,-  42,155,-  117,140,-  109,189,-  19,35,-  31,125,-  118,191,-  163,169,-  40,167,-  91,127,-  3,121,-  124,149,-  40,174,-  30,175,-  19,132,-  18,165,-  34,93,-  37,63,-  10,55,-  88,95,-  76,122,-  7,91,-  25,141,-  29,173,-  139,173,-  8,130,-  110,158,-  81,174,-  113,114,-  95,182,-  136,149,-  5,199,-  56,106,-  36,120,-  133,187,-  111,172,-  19,34,-  96,197,-  32,108,-  27,63,-  50,188,-  20,116,-  50,118,-  10,50,-  24,172,-  86,138,-  35,50,-  141,153,-  98,132,-  70,143,-  1,97,-  8,160,-  37,170,-  4,73,-  1,94,-  88,146,-  59,61,-  104,156,-  62,172,-  117,139,-  66,189,-  33,134,-  122,169,-  95,163,-  95,152,-  83,140,-  110,189,-  147,159,-  22,147,-  59,173,-  30,41,-  33,183,-  181,187,-  88,105,-  93,151,-  6,130,-  24,30,-  84,130,-  72,120,-  118,159,-  147,189,-  122,149,-  24,175,-  39,169,-  164,186,-  93,187,-  13,156,-  119,176,-  73,91,-  174,178,-  71,198,-  10,134,-  30,101,-  79,93,-  180,187,-  1,50,-  51,59,-  18,169,-  73,153,-  1,198,-  137,154,-  61,106,-  80,113,-  48,142,-  100,111,-  97,133,-  82,97,-  136,170,-  53,134,-  65,177,-  7,80,-  73,137,-  6,70,-  115,166,-  72,196,-  40,109,-  91,101,-  2,177,-  120,185,-  55,65,-  72,166,-  104,165,-  173,187,-  54,71,-  3,61,-  52,56,-  120,149,-  64,72,-  42,43,-  75,185,-  62,68,-  108,147,-  30,111,-  25,58,-  39,93,-  75,117,-  61,194,-  140,153,-  80,121,-  93,102,-  9,177,-  7,163,-  17,70,-  5,168,-  63,178,-  74,160,-  148,158,-  9,84,-  30,76,-  63,80,-  68,99,-  20,152,-  7,182,-  7,22,-  71,134,-  32,100,-  107,164,-  23,62,-  5,98,-  130,192,-  65,144,-  139,161,-  24,124,-  31,47,-  29,140,-  61,153,-  53,109,-  20,26,-  143,160,-  47,195,-  171,172,-  185,193,-  128,173,-  38,96,-  14,171,-  176,199,-  111,139,-  21,54,-  80,171,-  116,185,-  184,199,-  37,88,-  62,133,-  3,150,-  48,109,-  46,176,-  24,178,-  59,172,-  180,198,-  64,109,-  110,111,-  101,146,-  66,164,-  5,117,-  144,179,-  71,126,-  166,169,-  107,151,-  46,85,-  106,139,-  27,153,-  97,148,-  68,185,-  17,179,-  10,142,-  168,169,-  4,46,-  113,152,-  52,176,-  6,38,-  22,48,-  20,120,-  2,84,-  71,85,-  91,116,-  0,189,-  116,197,-  142,147,-  33,165,-  86,198,-  146,149,-  152,187,-  44,62,-  48,175,-  56,150,-  63,161,-  71,164,-  17,171,-  19,66- ]+{-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE FlexibleContexts #-}
+
+import Control.CP.FD.Example
+
+model :: ExampleMinModel ()
+model () = do
+  let c = board
+  let numNodes = c!0
+      numEdges = c!1
+      edgePos  = slice c ((cte 2) @.. (1+numEdges))
+      edge i   = slice c ((2+numEdges+((i@=0) @? (cte 0,edgePos!(i-1)))) @.. (1+numEdges+(edgePos!i)))
+  exists $ \numColors -> do
+    exists $ \colors -> do
+      numColors @: (cte 0,numNodes)
+      size colors @= numNodes
+      colors `allin` (cte 0,numColors)
+      loopall (0,(size (edge 0)-1)) $ \i -> colors!((edge 0)!i) @= (size (edge 0)-1-i)
+      loopall (1,numEdges-1) $ allDiffD . slice colors . edge
+      return (numColors,colors)
+
+main = example_min_main_void model
+
+{-
+
+  [numNodes,numEdges,[cumul. clique sizes],[clique elems]]
+
+  0--1
+  |  |
+  2--3
+
+  4,4,2,4,6,8,0,1,1,3,3,2,2,0
+
+     0-1
+    /   \
+   4-----2
+    \   /
+     \3/
+
+  5,6,2,4,6,8,10,12,0,1,1,2,2,3,3,4,4,0,2,4
+-}
+
+board :: ModelCol
+board = list $
+ [
+  200,367,
+  30,60,85,110,135,160,185,210,235,260,285,305,325,345,365,385,405,425,445,465,485,505,525,545,565,585,600,615,630,645,660,675,690,705,720,735,750,765,780,795,810,825,840,855,870,885,900,910,920,930,940,950,955,960,965,970,975,980,985,990,995,1000,1005,1010,1015,1020,1025,1027,1029,1031,1033,1035,1037,1039,1041,1043,1045,1047,1049,1051,1053,1055,1057,1059,1061,1063,1065,1067,1069,1071,1073,1075,1077,1079,1081,1083,1085,1087,1089,1091,1093,1095,1097,1099,1101,1103,1105,1107,1109,1111,1113,1115,1117,1119,1121,1123,1125,1127,1129,1131,1133,1135,1137,1139,1141,1143,1145,1147,1149,1151,1153,1155,1157,1159,1161,1163,1165,1167,1169,1171,1173,1175,1177,1179,1181,1183,1185,1187,1189,1191,1193,1195,1197,1199,1201,1203,1205,1207,1209,1211,1213,1215,1217,1219,1221,1223,1225,1227,1229,1231,1233,1235,1237,1239,1241,1243,1245,1247,1249,1251,1253,1255,1257,1259,1261,1263,1265,1267,1269,1271,1273,1275,1277,1279,1281,1283,1285,1287,1289,1291,1293,1295,1297,1299,1301,1303,1305,1307,1309,1311,1313,1315,1317,1319,1321,1323,1325,1327,1329,1331,1333,1335,1337,1339,1341,1343,1345,1347,1349,1351,1353,1355,1357,1359,1361,1363,1365,1367,1369,1371,1373,1375,1377,1379,1381,1383,1385,1387,1389,1391,1393,1395,1397,1399,1401,1403,1405,1407,1409,1411,1413,1415,1417,1419,1421,1423,1425,1427,1429,1431,1433,1435,1437,1439,1441,1443,1445,1447,1449,1451,1453,1455,1457,1459,1461,1463,1465,1467,1469,1471,1473,1475,1477,1479,1481,1483,1485,1487,1489,1491,1493,1495,1497,1499,1501,1503,1505,1507,1509,1511,1513,1515,1517,1519,1521,1523,1525,1527,1529,1531,1533,1535,1537,1539,1541,1543,1545,1547,1549,1551,1553,1555,1557,1559,1561,1563,1565,1567,1569,1571,1573,1575,1577,1579,1581,1583,1585,1587,1589,1591,1593,1595,1597,1599,1601,1603,1605,1607,1609,1611,1613,1615,1617,1619,1621,1623,1625,
+  6,11,14,25,40,42,48,53,61,76,80,87,89,92,108,115,120,131,132,137,145,159,162,163,164,168,172,173,176,182,
+  3,15,16,31,34,35,37,38,49,58,67,78,86,91,100,110,114,123,129,132,133,140,143,154,167,168,174,175,193,197,
+  3,10,33,38,43,45,48,51,65,66,82,88,90,93,94,103,107,128,131,141,152,155,168,185,199,
+  0,4,7,26,28,33,36,58,61,72,79,81,90,99,105,114,115,124,135,152,159,161,173,181,192,
+  12,15,28,39,43,44,45,66,83,84,85,99,102,108,112,115,120,126,131,152,157,163,171,182,183,
+  13,14,15,38,55,66,76,78,87,91,95,99,109,110,125,130,134,137,148,153,159,169,181,185,195,
+  3,4,31,35,41,42,57,60,65,66,72,74,84,86,90,91,94,96,110,139,140,141,165,179,199,
+  0,4,5,9,28,31,42,49,54,63,65,72,74,75,76,82,91,99,107,109,140,147,154,169,182,
+  4,5,10,17,41,43,48,58,65,85,92,97,107,112,114,129,131,146,150,153,158,169,176,184,191,
+  4,8,15,16,20,21,37,55,68,84,87,104,109,112,117,119,122,123,126,133,142,164,167,180,195,
+  5,6,10,11,28,30,43,46,53,60,66,79,82,105,114,116,119,124,127,147,157,171,184,195,196,
+  15,16,30,35,36,56,66,78,81,84,99,126,128,129,138,151,152,153,166,190,
+  5,21,23,29,39,40,49,69,88,114,122,127,128,142,148,155,161,171,188,190,
+  0,3,15,23,31,41,57,60,69,76,89,107,109,128,153,155,161,169,174,183,
+  9,33,43,61,64,69,85,98,100,101,114,120,138,144,172,182,184,187,188,198,
+  4,6,8,10,23,27,45,57,66,68,71,93,110,122,139,146,150,155,156,188,
+  4,14,18,22,63,77,78,83,94,98,104,114,150,166,172,177,183,186,196,199,
+  22,35,46,47,63,64,70,78,87,99,102,112,116,119,125,131,152,165,174,186,
+  1,3,13,15,19,26,46,51,65,73,76,110,114,149,152,163,166,170,178,186,
+  9,29,33,40,50,54,102,105,111,112,119,120,124,128,136,138,144,175,190,199,
+  39,75,79,102,106,112,123,125,138,145,154,155,159,162,165,168,175,181,189,196,
+  0,11,12,23,42,63,68,71,79,83,89,98,113,117,121,141,156,176,177,193,
+  10,17,31,56,77,89,102,115,116,117,118,120,136,157,163,168,172,182,193,196,
+  9,34,35,43,44,57,60,64,79,87,88,94,103,133,156,157,166,171,174,189,
+  13,21,22,31,41,45,66,67,79,86,112,116,119,146,160,171,175,181,192,195,
+  11,24,26,45,57,91,99,102,122,123,135,141,144,146,154,156,167,191,194,199,
+  17,44,53,61,82,90,95,103,107,122,124,145,169,186,190,
+  2,14,26,37,58,61,75,95,103,109,115,116,141,154,199,
+  5,13,21,28,61,64,65,73,105,115,119,132,148,154,185,
+  10,20,38,45,61,75,109,111,115,143,150,157,163,179,186,
+  9,45,48,49,51,52,57,64,70,128,158,163,182,183,192,
+  47,55,57,64,79,80,105,131,152,163,172,180,186,190,197,
+  16,36,69,84,99,113,118,121,126,137,160,162,165,177,196,
+  16,44,50,53,54,65,69,80,96,112,125,139,150,153,193,
+  6,54,72,76,86,95,96,144,145,148,151,164,168,180,183,
+  10,18,19,37,65,85,90,104,112,128,147,158,164,192,198,
+  20,21,36,50,53,74,90,96,99,124,129,140,163,171,183,
+  13,20,27,53,65,77,86,98,110,125,133,139,147,188,196,
+  23,41,43,49,58,74,77,86,111,126,150,168,173,185,189,
+  11,35,62,89,125,132,134,141,149,163,166,167,171,194,196,
+  14,28,30,52,114,115,122,125,132,135,172,177,179,181,195,
+  0,8,9,20,23,53,77,93,121,136,141,147,150,191,199,
+  3,21,47,49,91,102,106,113,124,136,140,143,177,178,194,
+  44,46,52,53,68,82,89,90,120,128,144,147,175,178,192,
+  8,16,19,21,67,72,79,82,86,90,115,116,149,152,199,
+  12,30,78,80,97,120,122,123,143,146,151,165,173,177,178,
+  9,19,39,46,91,109,128,130,131,146,148,150,178,185,198,
+  29,44,69,74,96,115,122,126,189,199,
+  22,42,52,53,97,113,146,151,160,195,
+  19,20,32,77,81,133,134,138,147,177,
+  0,4,56,59,107,109,144,149,158,167,
+  6,69,99,104,110,114,118,134,152,172,
+  25,76,126,140,143,
+  4,54,67,116,142,
+  47,52,124,151,192,
+  32,55,61,64,73,
+  11,65,128,134,190,
+  45,48,63,131,139,
+  34,55,82,108,151,
+  24,34,54,112,156,
+  12,47,72,148,163,
+  74,126,145,162,170,
+  73,78,104,175,192,
+  19,83,127,130,166,
+  20,90,98,137,165,
+  22,24,29,49,132,
+  82,92,116,134,184,
+  160,184,
+  192,199,
+  0,129,
+  20,80,
+  8,29,
+  93,171,
+  101,165,
+  124,193,
+  2,100,
+  66,173,
+  151,191,
+  164,187,
+  3,130,
+  118,176,
+  121,184,
+  25,106,
+  159,193,
+  121,123,
+  5,62,
+  97,101,
+  6,143,
+  123,163,
+  19,125,
+  17,108,
+  122,168,
+  181,184,
+  25,41,
+  62,70,
+  29,103,
+  48,67,
+  46,160,
+  79,170,
+  143,152,
+  38,184,
+  2,40,
+  191,195,
+  7,196,
+  62,199,
+  76,141,
+  82,166,
+  36,80,
+  51,189,
+  13,97,
+  3,192,
+  90,180,
+  47,176,
+  13,172,
+  92,121,
+  50,64,
+  65,113,
+  108,123,
+  26,106,
+  34,153,
+  90,123,
+  34,39,
+  116,178,
+  22,179,
+  50,61,
+  84,105,
+  84,93,
+  19,108,
+  29,59,
+  63,185,
+  119,129,
+  50,177,
+  80,194,
+  13,36,
+  46,56,
+  38,144,
+  82,193,
+  72,93,
+  49,95,
+  42,155,
+  117,140,
+  109,189,
+  19,35,
+  31,125,
+  118,191,
+  163,169,
+  40,167,
+  91,127,
+  3,121,
+  124,149,
+  40,174,
+  30,175,
+  19,132,
+  18,165,
+  34,93,
+  37,63,
+  10,55,
+  88,95,
+  76,122,
+  7,91,
+  25,141,
+  29,173,
+  139,173,
+  8,130,
+  110,158,
+  81,174,
+  113,114,
+  95,182,
+  136,149,
+  5,199,
+  56,106,
+  36,120,
+  133,187,
+  111,172,
+  19,34,
+  96,197,
+  32,108,
+  27,63,
+  50,188,
+  20,116,
+  50,118,
+  10,50,
+  24,172,
+  86,138,
+  35,50,
+  141,153,
+  98,132,
+  70,143,
+  1,97,
+  8,160,
+  37,170,
+  4,73,
+  1,94,
+  88,146,
+  59,61,
+  104,156,
+  62,172,
+  117,139,
+  66,189,
+  33,134,
+  122,169,
+  95,163,
+  95,152,
+  83,140,
+  110,189,
+  147,159,
+  22,147,
+  59,173,
+  30,41,
+  33,183,
+  181,187,
+  88,105,
+  93,151,
+  6,130,
+  24,30,
+  84,130,
+  72,120,
+  118,159,
+  147,189,
+  122,149,
+  24,175,
+  39,169,
+  164,186,
+  93,187,
+  13,156,
+  119,176,
+  73,91,
+  174,178,
+  71,198,
+  10,134,
+  30,101,
+  79,93,
+  180,187,
+  1,50,
+  51,59,
+  18,169,
+  73,153,
+  1,198,
+  137,154,
+  61,106,
+  80,113,
+  48,142,
+  100,111,
+  97,133,
+  82,97,
+  136,170,
+  53,134,
+  65,177,
+  7,80,
+  73,137,
+  6,70,
+  115,166,
+  72,196,
+  40,109,
+  91,101,
+  2,177,
+  120,185,
+  55,65,
+  72,166,
+  104,165,
+  173,187,
+  54,71,
+  3,61,
+  52,56,
+  120,149,
+  64,72,
+  42,43,
+  75,185,
+  62,68,
+  108,147,
+  30,111,
+  25,58,
+  39,93,
+  75,117,
+  61,194,
+  140,153,
+  80,121,
+  93,102,
+  9,177,
+  7,163,
+  17,70,
+  5,168,
+  63,178,
+  74,160,
+  148,158,
+  9,84,
+  30,76,
+  63,80,
+  68,99,
+  20,152,
+  7,182,
+  7,22,
+  71,134,
+  32,100,
+  107,164,
+  23,62,
+  5,98,
+  130,192,
+  65,144,
+  139,161,
+  24,124,
+  31,47,
+  29,140,
+  61,153,
+  53,109,
+  20,26,
+  143,160,
+  47,195,
+  171,172,
+  185,193,
+  128,173,
+  38,96,
+  14,171,
+  176,199,
+  111,139,
+  21,54,
+  80,171,
+  116,185,
+  184,199,
+  37,88,
+  62,133,
+  3,150,
+  48,109,
+  46,176,
+  24,178,
+  59,172,
+  180,198,
+  64,109,
+  110,111,
+  101,146,
+  66,164,
+  5,117,
+  144,179,
+  71,126,
+  166,169,
+  107,151,
+  46,85,
+  106,139,
+  27,153,
+  97,148,
+  68,185,
+  17,179,
+  10,142,
+  168,169,
+  4,46,
+  113,152,
+  52,176,
+  6,38,
+  22,48,
+  20,120,
+  2,84,
+  71,85,
+  91,116,
+  0,189,
+  116,197,
+  142,147,
+  33,165,
+  86,198,
+  146,149,
+  152,187,
+  44,62,
+  48,175,
+  56,150,
+  63,161,
+  71,164,
+  17,171,
+  19,66
+ ]

examples/Grocery.hs view

@@ -1,21 +1,21 @@-{-# LANGUAGE TypeFamilies #-}-{-# LANGUAGE FlexibleContexts #-}---- A kid goes into a grocery store and buys four items. The cashier charges $7.11. --- The kid pays and is about to leave when the cashier calls the kid back, and says --- "Hold on, I multiplied the four items instead of adding them; I'll try again... --- Gosh, with adding them the price still comes to $7.11"! What were the prices of --- the four items?--import Control.CP.FD.Example--model :: ExampleModel ()-model _ = exists $ \col -> do-  [a,b,c,d] <- colList col 4-  sorted col-  allin col (cte 0,cte 711)-  a+b+c+d @= 711-  (a*b)*(c*d) @= 711000000-  return col--main = example_sat_main_void model+{-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE FlexibleContexts #-}
+
+-- A kid goes into a grocery store and buys four items. The cashier charges $7.11. 
+-- The kid pays and is about to leave when the cashier calls the kid back, and says 
+-- "Hold on, I multiplied the four items instead of adding them; I'll try again... 
+-- Gosh, with adding them the price still comes to $7.11"! What were the prices of 
+-- the four items?
+
+import Control.CP.FD.Example
+
+model :: ExampleModel ()
+model _ = exists $ \col -> do
+  [a,b,c,d] <- colList col 4
+  sorted col
+  allin col (cte 0,cte 711)
+  a+b+c+d @= 711
+  (a*b)*(c*d) @= 711000000
+  return col
+
+main = example_sat_main_void model

examples/LangfordNumber.hs view

@@ -1,30 +1,30 @@-{-# LANGUAGE TypeFamilies #-}-{-# LANGUAGE FlexibleContexts #-}--import Control.CP.FD.Example--model :: ExampleModel ModelCol-model c = do-  let c = col-      n = c!0-      k = c!1-  exists $ \y -> do-    size y @= k*n-    y `allin` (cte 1,n)-    exists $ \p -> do-      size p @= k*n-      p `allin` (cte 0,k*n-1)-      loopall (cte 0,n-1) $ \i ->-        loopall (cte 0,k-2) $ \j ->-          p!(i*k+j) + i+2 @= p!(i*k+j+1)-      allDiffD p-      loopall (cte 0,n-1) $ \i ->-        loopall (cte 0,k-1) $ \j ->-          y!(p!(i*k+j)) @= i+1-    y!0 @< y!(n*k-1)-    return y--main = example_sat_main_coll_expr model--col :: ModelCol-col = list $ [4,2]+{-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE FlexibleContexts #-}
+
+import Control.CP.FD.Example
+
+model :: ExampleModel ModelCol
+model c = do
+  let c = col
+      n = c!0
+      k = c!1
+  exists $ \y -> do
+    size y @= k*n
+    y `allin` (cte 1,n)
+    exists $ \p -> do
+      size p @= k*n
+      p `allin` (cte 0,k*n-1)
+      loopall (cte 0,n-1) $ \i ->
+        loopall (cte 0,k-2) $ \j ->
+          p!(i*k+j) + i+2 @= p!(i*k+j+1)
+      allDiffD p
+      loopall (cte 0,n-1) $ \i ->
+        loopall (cte 0,k-1) $ \j ->
+          y!(p!(i*k+j)) @= i+1
+    y!0 @< y!(n*k-1)
+    return y
+
+main = example_sat_main_coll_expr model
+
+col :: ModelCol
+col = list $ [4,2]

examples/MagicSeries.hs view

@@ -1,20 +1,20 @@-{-# LANGUAGE TypeFamilies #-}-{-# LANGUAGE FlexibleContexts #-}--import Control.CP.FD.Example--count col val =                -- count c v = #{foreach i: c[i]==v}-  xsum $ xmap (\v -> channel (v @= val)) col--model :: ExampleModel ModelInt-model n = exists $ \col -> do  -- request a (collection) variable col-  size col @= n                -- col has length n-  col `allin` (cte 0,n-1)      -- all col elements are in [0..n-1]-  loopall (0,n-1) $ \i -> do   -- foreach i in [0..n-1]:-    count col i @= (col!i)        -- col[i] == count col i-  xsum col @= n                -- sum(col) = n-                               -- sum(i*col[i]) = n-  (xsum (xmap (\i -> (i-1)*(col!i)) ((cte 0) @.. (n-1)))) @= cte 0-  return col                   -- return col--main = example_sat_main_single_expr model+{-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE FlexibleContexts #-}
+
+import Control.CP.FD.Example
+
+count col val =                -- count c v = #{foreach i: c[i]==v}
+  xsum $ xmap (\v -> channel (v @= val)) col
+
+model :: ExampleModel ModelInt
+model n = exists $ \col -> do  -- request a (collection) variable col
+  size col @= n                -- col has length n
+  col `allin` (cte 0,n-1)      -- all col elements are in [0..n-1]
+  loopall (0,n-1) $ \i -> do   -- foreach i in [0..n-1]:
+    count col i @= (col!i)        -- col[i] == count col i
+  xsum col @= n                -- sum(col) = n
+                               -- sum(i*col[i]) = n
+  (xsum (xmap (\i -> (i-1)*(col!i)) ((cte 0) @.. (n-1)))) @= cte 0
+  return col                   -- return col
+
+main = example_sat_main_single_expr model

examples/MagicSquare.hs view

@@ -1,34 +1,34 @@-{-# LANGUAGE TypeFamilies #-}-{-# LANGUAGE FlexibleContexts #-}--import Control.CP.FD.Example--path :: ModelInt -> ModelCol -> (ModelInt -> ModelInt) -> (ModelInt -> ModelInt) -> ModelCol-path n l r c = slice l $ xmap (\k -> n*(r k)+(c k)) (0 @.. (n-1))--row :: ModelInt -> ModelCol -> ModelInt -> ModelCol-row n l i = path n l (const i) id--col :: ModelInt -> ModelCol -> ModelInt -> ModelCol-col n l i = path n l id (const i)--diag1 n l = path n l id id-diag2 n l = path n l id (\x -> n-x-1)--model :: ExampleModel ModelInt-model n = exists $ \mat -> do-  let nn = n*n-  let s = n*(nn+1) `div` 2-  size mat @= n*n-  loopall (0,n-1) $ \i -> do-    xfold (+) (cte 0) (col n mat i) @= s-    xfold (+) (cte 0) (row n mat i) @= s-  xfold (+) (cte 0) (diag1 n mat) @= s-  xfold (+) (cte 0) (diag2 n mat) @= s-  mat `allin` (cte 1,nn)-  allDiff mat-  (mat @!! 0) @> (mat!(n-1))-  (mat @!! 0) @> (mat!(n*n-n))-  return mat--main = example_sat_main_single_expr model+{-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE FlexibleContexts #-}
+
+import Control.CP.FD.Example
+
+path :: ModelInt -> ModelCol -> (ModelInt -> ModelInt) -> (ModelInt -> ModelInt) -> ModelCol
+path n l r c = slice l $ xmap (\k -> n*(r k)+(c k)) (0 @.. (n-1))
+
+row :: ModelInt -> ModelCol -> ModelInt -> ModelCol
+row n l i = path n l (const i) id
+
+col :: ModelInt -> ModelCol -> ModelInt -> ModelCol
+col n l i = path n l id (const i)
+
+diag1 n l = path n l id id
+diag2 n l = path n l id (\x -> n-x-1)
+
+model :: ExampleModel ModelInt
+model n = exists $ \mat -> do
+  let nn = n*n
+  let s = n*(nn+1) `div` 2
+  size mat @= n*n
+  loopall (0,n-1) $ \i -> do
+    xfold (+) (cte 0) (col n mat i) @= s
+    xfold (+) (cte 0) (row n mat i) @= s
+  xfold (+) (cte 0) (diag1 n mat) @= s
+  xfold (+) (cte 0) (diag2 n mat) @= s
+  mat `allin` (cte 1,nn)
+  allDiff mat
+  (mat @!! 0) @> (mat!(n-1))
+  (mat @!! 0) @> (mat!(n*n-n))
+  return mat
+
+main = example_sat_main_single_expr model

examples/MineSweeper.hs view

@@ -1,50 +1,50 @@-{-# LANGUAGE TypeFamilies #-}-{-# LANGUAGE FlexibleContexts #-}--import Control.CP.FD.Example--aroundY :: ModelCol-aroundY = list [-1,-1,0,1,1,1,0,-1]--aroundX :: ModelCol-aroundX = list [0,1,1,1,0,-1,-1,-1]--model :: ExampleModel ()-model () = do -  let c = board-  let s = c!0-      spec x y = c!(1+y*s+x)-  exists $ \m -> do-    m `allin` (cte 0,cte 1)-    size m @= s*s+1-    m!(s*s) @= cte 0-    let v x y = (x@>=s @|| x@<0 @|| y@>=s @|| y@<0) @? (s*s,y*s+x)-    let around x y = slice m $ xmap (\p -> v (x+(aroundX!p)) (y+(aroundY!p))) (cte 0 @.. cte 7)-    loopall (cte 0,s-1) $ \x -> -      loopall (cte 0,s-1) $ \y -> do-        ((spec x y) @< (cte 0)) @?? (true,do-            m!(y*s+x) @= 0-            xsum (around x y) @= (spec x y)-          )-    return m--main = example_sat_main_void model--u = (-1)--board :: ModelCol-board = list $-  [-    10,--    1,u,u,2,u,2,u,2,u,u,-    u,3,2,u,u,u,4,u,u,1,-    u,u,u,1,3,u,u,u,4,u,-    3,u,1,u,u,u,3,u,u,u,-    u,2,1,u,1,u,u,3,u,2,-    u,3,u,2,u,u,2,u,1,u,-    2,u,u,3,2,u,u,2,u,u,-    u,3,u,u,u,3,2,u,u,3,-    u,u,3,u,3,3,u,u,u,u,-    u,2,u,2,u,u,u,2,2,u-  ]+{-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE FlexibleContexts #-}
+
+import Control.CP.FD.Example
+
+aroundY :: ModelCol
+aroundY = list [-1,-1,0,1,1,1,0,-1]
+
+aroundX :: ModelCol
+aroundX = list [0,1,1,1,0,-1,-1,-1]
+
+model :: ExampleModel ()
+model () = do 
+  let c = board
+  let s = c!0
+      spec x y = c!(1+y*s+x)
+  exists $ \m -> do
+    m `allin` (cte 0,cte 1)
+    size m @= s*s+1
+    m!(s*s) @= cte 0
+    let v x y = (x@>=s @|| x@<0 @|| y@>=s @|| y@<0) @? (s*s,y*s+x)
+    let around x y = slice m $ xmap (\p -> v (x+(aroundX!p)) (y+(aroundY!p))) (cte 0 @.. cte 7)
+    loopall (cte 0,s-1) $ \x -> 
+      loopall (cte 0,s-1) $ \y -> do
+        ((spec x y) @< (cte 0)) @?? (true,do
+            m!(y*s+x) @= 0
+            xsum (around x y) @= (spec x y)
+          )
+    return m
+
+main = example_sat_main_void model
+
+u = (-1)
+
+board :: ModelCol
+board = list $
+  [
+    10,
+
+    1,u,u,2,u,2,u,2,u,u,
+    u,3,2,u,u,u,4,u,u,1,
+    u,u,u,1,3,u,u,u,4,u,
+    3,u,1,u,u,u,3,u,u,u,
+    u,2,1,u,1,u,u,3,u,2,
+    u,3,u,2,u,u,2,u,1,u,
+    2,u,u,3,2,u,u,2,u,u,
+    u,3,u,u,u,3,2,u,u,3,
+    u,u,3,u,3,3,u,u,u,u,
+    u,2,u,2,u,u,u,2,2,u
+  ]

examples/Olympic.hs view

@@ -1,51 +1,52 @@-{-# LANGUAGE TypeFamilies #-}-{-# LANGUAGE FlexibleContexts #-}--{--%   File   : olympic.pl-%   Author : Neng-Fa ZHOU-%   Date   : 1993-%   Purpose: solve a puzzle taken from Olympic Arithmetic Contest-/***********************************************************************-   Given ten variables with the following configuration:--               X7   X8   X9   X10--                  X4   X5   X6--                     X2   X3             --                        X1--  We already know that X1 is equal to 3 and want to assign each variable-  with a different integer from {1,2,...,10} such that for any three-  variables -                      Xi   Xj--                         Xk-  the following constraint is satisfied:--                    |Xi-Xj| = Xk-***********************************************************************/--}---import Control.CP.FD.Example--main = example_sat_main_void model--model :: ExampleModel ()-model _ = exists $ \col -> do-  [x1,x2,x3,x4,x5,x6,x7,x8,x9,x10] <- colList col 10-  col `allin` (cte 1, cte 10) -  allDiff col-  x1 @= 3-  minus x2 x3 x1-  minus x4 x5 x2-  minus x5 x6 x3-  minus x7 x8 x4-  minus x8 x9 x5-  minus x9 x10 x6-  return col--minus x1 x2 x3 = (abs (x1-x2)) @= x3+{-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE FlexibleContexts #-}
+
+{-
+%   File   : olympic.pl
+%   Author : Neng-Fa ZHOU
+%   Date   : 1993
+%   Purpose: solve a puzzle taken from Olympic Arithmetic Contest
+/***********************************************************************
+   Given ten variables with the following configuration:
+
+               X7   X8   X9   X10
+
+                  X4   X5   X6
+
+                     X2   X3             
+
+                        X1
+
+  We already know that X1 is equal to 3 and want to assign each variable
+  with a different integer from {1,2,...,10} such that for any three
+  variables 
+                      Xi   Xj
+
+                         Xk
+  the following constraint is satisfied:
+
+                    |Xi-Xj| = Xk
+***********************************************************************/
+-}
+
+
+import Control.CP.FD.Example
+import System.Environment
+
+main = withArgs ["overton_run"] $ example_sat_main_void model
+
+model :: ExampleModel ()
+model _ = exists $ \col -> do
+  [x1,x2,x3,x4,x5,x6,x7,x8,x9,x10] <- colList col 10
+  col `allin` (cte (1 :: Integer), cte (10 :: Integer)) 
+  allDiff col
+  x1 @= 3
+  minus x2 x3 x1
+  minus x4 x5 x2
+  minus x5 x6 x3
+  minus x7 x8 x4
+  minus x8 x9 x5
+  minus x9 x10 x6
+  return col
+
+minus x1 x2 x3 = (abs (x1-x2)) @= x3

examples/Partition.hs view

@@ -1,32 +1,32 @@-{-# LANGUAGE TypeFamilies #-}-{-# LANGUAGE FlexibleContexts #-}--import Control.CP.FD.Example--model :: ExampleModel ModelInt-model n =-  exists $ \x -> do-  exists $ \y -> do-    let xy = x @++ y-    size x @= n-    size y @= n-    x `allin` (cte 1,2*n)-    y `allin` (cte 1,2*n)-    sSorted x-    sSorted y-    (x!cte 0) @< (y!cte 0)-    allDiff xy-    let sx = xmap (\v -> v*v) x-    let sy = xmap (\v -> v*v) y-    xsum x @=  xsum y-    xsum sx @= xsum sy-    let t1 = 2*n*(2*n+1) `div` 4-    let t2 = 2*n*(2*n+1)*(4*n+1) `div` 12-    xsum x @= t1-    xsum y @= t1-    xsum sx @= t2-    xsum sy @= t2-    return xy--main = example_sat_main_single_expr model-+{-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE FlexibleContexts #-}
+
+import Control.CP.FD.Example
+
+model :: ExampleModel ModelInt
+model n =
+  exists $ \x -> do
+  exists $ \y -> do
+    let xy = x @++ y
+    size x @= n
+    size y @= n
+    x `allin` (cte 1,2*n)
+    y `allin` (cte 1,2*n)
+    sSorted x
+    sSorted y
+    (x!cte 0) @< (y!cte 0)
+    allDiff xy
+    let sx = xmap (\v -> v*v) x
+    let sy = xmap (\v -> v*v) y
+    xsum x @=  xsum y
+    xsum sx @= xsum sy
+    let t1 = 2*n*(2*n+1) `div` 4
+    let t2 = 2*n*(2*n+1)*(4*n+1) `div` 12
+    xsum x @= t1
+    xsum y @= t1
+    xsum sx @= t2
+    xsum sy @= t2
+    return xy
+
+main = example_sat_main_single_expr model
+

examples/PerfectSquare.hs view

@@ -1,26 +1,26 @@-{-# LANGUAGE TypeFamilies #-}-{-# LANGUAGE FlexibleContexts #-}--import Control.CP.FD.Example--model :: ExampleModel ModelCol-model c = do-  let numSquares = c!0-      totalSize = c!1-      s = slice c ((cte 2) @.. (1+numSquares))-  exists $ \pos -> do-    size pos @= 2*numSquares-    let x i = pos!i-        y i = pos!(i+numSquares)-    pos `allin` (cte 0,totalSize-1)-    loopall (0,numSquares-1) $ \i -> do-      x i @<= totalSize - (s!i)-      y i @<= totalSize - (s!i)-    loopall (0,numSquares-1) $ \i ->-      loopall (i+1,numSquares-1) $ \j -> ((x i)+(s!i) @<= (x j)) @|| ((x j)+(s!j) @<= (x i)) @|| ((y i)+(s!i) @<= (y j)) @|| ((y j)+(s!j) @<= (y i))---  loopall (0,totalSize-1) $ \c -> do---    totalSize @= xsum (xmap (\i -> (s!i)*channel((x i) @: (c-(s!i)+1,c))) ((cte 0) @.. (numSquares-1)))---    totalSize @= xsum (xmap (\i -> (s!i)*channel((y i) @: (c-(s!i)+1,c))) ((cte 0) @.. (numSquares-1)))-    return pos--main = example_sat_main_coll_expr model+{-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE FlexibleContexts #-}
+
+import Control.CP.FD.Example
+
+model :: ExampleModel ModelCol
+model c = do
+  let numSquares = c!0
+      totalSize = c!1
+      s = slice c ((cte 2) @.. (1+numSquares))
+  exists $ \pos -> do
+    size pos @= 2*numSquares
+    let x i = pos!i
+        y i = pos!(i+numSquares)
+    pos `allin` (cte 0,totalSize-1)
+    loopall (0,numSquares-1) $ \i -> do
+      x i @<= totalSize - (s!i)
+      y i @<= totalSize - (s!i)
+    loopall (0,numSquares-1) $ \i ->
+      loopall (i+1,numSquares-1) $ \j -> ((x i)+(s!i) @<= (x j)) @|| ((x j)+(s!j) @<= (x i)) @|| ((y i)+(s!i) @<= (y j)) @|| ((y j)+(s!j) @<= (y i))
+--  loopall (0,totalSize-1) $ \c -> do
+--    totalSize @= xsum (xmap (\i -> (s!i)*channel((x i) @: (c-(s!i)+1,c))) ((cte 0) @.. (numSquares-1)))
+--    totalSize @= xsum (xmap (\i -> (s!i)*channel((y i) @: (c-(s!i)+1,c))) ((cte 0) @.. (numSquares-1)))
+    return pos
+
+main = example_sat_main_coll_expr model

examples/Queens.hs view

@@ -1,22 +1,22 @@-{-# LANGUAGE TypeFamilies #-}-{-# LANGUAGE FlexibleContexts #-}--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 -> -    loopall (i+1,n-1) $ \j ->-      noattack i j (p!i) (p!j)-  return p--main = example_sat_main_single_expr model-+{-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE FlexibleContexts #-}
+
+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 -> 
+    loopall (i+1,n-1) $ \j ->
+      noattack i j (p!i) (p!j)
+  return p
+
+main = example_sat_main_single_expr model
+

examples/Ring.hs view

@@ -1,19 +1,19 @@-{-# LANGUAGE TypeFamilies #-}-{-# LANGUAGE FlexibleContexts #-}--import Control.CP.FD.Example--main = example_sat_main_single_expr model--model :: ExampleModel ModelInt-model n = exists $ \col -> do-  size col @= n-  loopall (0,(n-1)) $ \i -> do-    let v0 = col ! i-        v1 = col ! ((i+1) `mod` n)-        v2 = col ! ((i+2) `mod` n)-    2 * v1 @= 2 * v2 - v0-    v0 @: (cte (-10), cte 10)-  return col--+{-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE FlexibleContexts #-}
+
+import Control.CP.FD.Example
+
+main = example_sat_main_single_expr model
+
+model :: ExampleModel ModelInt
+model n = exists $ \col -> do
+  size col @= n
+  loopall (0,(n-1)) $ \i -> do
+    let v0 = col ! i
+        v1 = col ! ((i+1) `mod` n)
+        v2 = col ! ((i+2) `mod` n)
+    2 * v1 @= 2 * v2 - v0
+    v0 @: (cte (-10), cte 10)
+  return col
+
+

examples/StressDomain.hs view

@@ -1,22 +1,22 @@-{-# LANGUAGE TypeFamilies #-}-{-# LANGUAGE FlexibleContexts #-}--import Control.CP.FD.Example--main = example_sat_main_single_expr model--model :: ExampleModel ModelInt-model n = exists $ \col -> do-  l <- colList col 5-  col `allin` (cte 0, cte 5*n)-  let revCol = list (reverse l)-      colP   = list [0,2,4]-  forall revCol $ \v ->-    forall colP $ \p -> -      loopall (0,5*n) $ \j ->-        v @/= 5*j+p-  loopall (0,5*(n `div` 2)) $ \j ->-    forall revCol $ \v -> do-       v @>= 5*j-       v @<= 5*(j+5*(n `div` 2))-  return col+{-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE FlexibleContexts #-}
+
+import Control.CP.FD.Example
+
+main = example_sat_main_single_expr model
+
+model :: ExampleModel ModelInt
+model n = exists $ \col -> do
+  l <- colList col 5
+  col `allin` (cte 0, cte 5*n)
+  let revCol = list (reverse l)
+      colP   = list [0,2,4]
+  forall revCol $ \v ->
+    forall colP $ \p -> 
+      loopall (0,5*n) $ \j ->
+        v @/= 5*j+p
+  loopall (0,5*(n `div` 2)) $ \j ->
+    forall revCol $ \v -> do
+       v @>= 5*j
+       v @<= 5*(j+5*(n `div` 2))
+  return col

examples/Sudoku.hs view

@@ -1,46 +1,46 @@-{-# LANGUAGE TypeFamilies #-}-{-# LANGUAGE FlexibleContexts #-}--import Control.CP.FD.Example--model :: ExampleModel ()-model () = exists $ \mat -> do-  size mat @= 81-  allin mat (cte 1,cte 9)-  let row i = slice mat $ xmap (\p -> i*9+p) (cte 0 @.. cte 8)-  let col i = slice mat $ xmap (\p -> i+9*p) (cte 0 @.. cte 8)-  let block r c = slice mat $ xmap (\p -> 3*c+27*r+p) $ list [0,1,2,9,10,11,18,19,20]-  let pos r c = mat!(r*9+c)-  loopall (cte 0,cte 2) $ \i ->-    loopall (cte 0,cte 2) $ \j -> do-      allDiffD $ row $ i*3+j-      allDiffD $ col $ i*3+j-      allDiffD $ block i j-  pos 0 8 @= cte 2-  pos 1 0 @= cte 4-  pos 1 4 @= cte 3-  pos 1 8 @= cte 1-  pos 2 4 @= cte 1-  pos 2 6 @= cte 9-  pos 2 7 @= cte 5-  pos 3 0 @= cte 5-  pos 3 2 @= cte 2-  pos 3 3 @= cte 8-  pos 3 6 @= cte 1-  pos 4 3 @= cte 7-  pos 4 5 @= cte 2-  pos 5 2 @= cte 7-  pos 5 5 @= cte 9-  pos 5 6 @= cte 2-  pos 5 8 @= cte 4-  pos 6 1 @= cte 4-  pos 6 4 @= cte 2-  pos 7 0 @= cte 1-  pos 7 2 @= cte 9-  pos 7 4 @= cte 7-  pos 7 8 @= cte 6-  pos 8 0 @= cte 3-  pos 8 3 @= cte 5-  return mat--main = example_sat_main_void model+{-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE FlexibleContexts #-}
+
+import Control.CP.FD.Example
+
+model :: ExampleModel ()
+model () = exists $ \mat -> do
+  size mat @= 81
+  allin mat (cte 1,cte 9)
+  let row i = slice mat $ xmap (\p -> i*9+p) (cte 0 @.. cte 8)
+  let col i = slice mat $ xmap (\p -> i+9*p) (cte 0 @.. cte 8)
+  let block r c = slice mat $ xmap (\p -> 3*c+27*r+p) $ list [0,1,2,9,10,11,18,19,20]
+  let pos r c = mat!(r*9+c)
+  loopall (cte 0,cte 2) $ \i ->
+    loopall (cte 0,cte 2) $ \j -> do
+      allDiffD $ row $ i*3+j
+      allDiffD $ col $ i*3+j
+      allDiffD $ block i j
+  pos 0 8 @= cte 2
+  pos 1 0 @= cte 4
+  pos 1 4 @= cte 3
+  pos 1 8 @= cte 1
+  pos 2 4 @= cte 1
+  pos 2 6 @= cte 9
+  pos 2 7 @= cte 5
+  pos 3 0 @= cte 5
+  pos 3 2 @= cte 2
+  pos 3 3 @= cte 8
+  pos 3 6 @= cte 1
+  pos 4 3 @= cte 7
+  pos 4 5 @= cte 2
+  pos 5 2 @= cte 7
+  pos 5 5 @= cte 9
+  pos 5 6 @= cte 2
+  pos 5 8 @= cte 4
+  pos 6 1 @= cte 4
+  pos 6 4 @= cte 2
+  pos 7 0 @= cte 1
+  pos 7 2 @= cte 9
+  pos 7 4 @= cte 7
+  pos 7 8 @= cte 6
+  pos 8 0 @= cte 3
+  pos 8 3 @= cte 5
+  return mat
+
+main = example_sat_main_void model

examples/Test.hs view

@@ -1,15 +1,15 @@-{-# LANGUAGE TypeFamilies #-}-{-# LANGUAGE FlexibleContexts #-}--import Control.CP.FD.Example--model :: ExampleModel ()-model _ = exists $ \arr -> do-  arr `allin` (cte 0,cte 10)-  size arr @= 4-  xsum arr @= 10-  xsum (xmap (\x -> x*x) arr) @= 30-  sorted arr-  return arr--main = example_sat_main_void model+{-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE FlexibleContexts #-}
+
+import Control.CP.FD.Example
+
+model :: ExampleModel ()
+model _ = exists $ \arr -> do
+  arr `allin` (cte 0,cte 10)
+  size arr @= 4
+  xsum arr @= 10
+  xsum (xmap (\x -> x*x) arr) @= 30
+  sorted arr
+  return arr
+
+main = example_sat_main_void model

examples/TestPretty.hs view

@@ -1,20 +1,20 @@-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE TypeFamilies #-}-{-# LANGUAGE ScopedTypeVariables #-}--import Control.CP.FD.Example--model :: ExampleModel ModelInt-model i = exists $ \col -> do-  [a,b,c,d] <- colList col 4-  forall col (@>0)-  forall col (@<=10)---  loopall (1,4) $ \(x :: ModelInt) -> (xfold (+) (cte 0) (xlist [col!x,col!(4-x)]) @== 5)-  loopall (1,4) $ \i -> i*(col!(i-1)) @<= 100-  allDiff col-  sorted col-  xfold (+) (cte 0) col @= i-  return col--main = example_sat_main_single_expr model-+{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+
+import Control.CP.FD.Example
+
+model :: ExampleModel ModelInt
+model i = exists $ \col -> do
+  [a,b,c,d] <- colList col 4
+  forall col (@>0)
+  forall col (@<=10)
+--  loopall (1,4) $ \(x :: ModelInt) -> (xfold (+) (cte 0) (xlist [col!x,col!(4-x)]) @== 5)
+  loopall (1,4) $ \i -> i*(col!(i-1)) @<= 100
+  allDiff col
+  sorted col
+  xfold (+) (cte 0) col @= i
+  return col
+
+main = example_sat_main_single_expr model
+

examples/TryDemo.hs view

@@ -1,21 +1,21 @@-{-# LANGUAGE TypeFamilies #-}-{-# LANGUAGE FlexibleContexts #-}--{- - - 	Monadic Constraint Programming- - 	http://www.cs.kuleuven.be/~toms/Haskell/- - 	Tom Schrijvers & Pieter Wuille- -}--import Control.CP.FD.Example--main = example_sat_main_void model--model :: ExampleModel ()-model _ = exists $ \col -> do-  [a,b] <- colList col 2-  a @: (cte 1, cte 5)-  b @: (cte 0, cte 4)-  a - b @= 1-  (a @= 2) @|| (a @= 3) @|| (a @= 4)-  return col+{-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE FlexibleContexts #-}
+
+{- 
+ - 	Monadic Constraint Programming
+ - 	http://www.cs.kuleuven.be/~toms/Haskell/
+ - 	Tom Schrijvers & Pieter Wuille
+ -}
+
+import Control.CP.FD.Example
+
+main = example_sat_main_void model
+
+model :: ExampleModel ()
+model _ = exists $ \col -> do
+  [a,b] <- colList col 2
+  a @: (cte 1, cte 5)
+  b @: (cte 0, cte 4)
+  a - b @= 1
+  (a @= 2) @|| (a @= 3) @|| (a @= 4)
+  return col

examples/Zebra.hs view

@@ -1,43 +1,43 @@-{-# LANGUAGE TypeFamilies #-}-{-# LANGUAGE FlexibleContexts #-}--import Control.CP.FD.Example--main = example_sat_main_void model--model :: ExampleModel ()-model _ = exists $ \vars -> do-  [n1,n2,n3,n4,n5,-   c1,c2,c3,c4,c5,-   p1,p2,p3,p4,p5,-   a1,a2,a3,a4,a5,-   d1,d2,d3,d4,d5] <- colList vars 25-  let ns = slice vars (cte 0 @.. cte 4)-      cs = slice vars (cte 5 @.. cte 9)-      ps = slice vars (cte 10 @.. cte 14)-      as = slice vars (cte 15 @.. cte 19)-      ds = slice vars (cte 20 @.. cte 24)-  vars `allin` (cte 1, cte 5)-  allDiff ns-  allDiff cs-  allDiff ps-  allDiff as-  allDiff ds-  n1 @= c2-  n2 @= a1-  n3 @= p1-  n4 @= d3-  n5 @= 1-  d5 @= 3-  p3 @= d1-  c1 @= d4-  p5 @= a4-  p2 @= c3-  c1 @= c5+1-  plusorminus a3 p4 1-  plusorminus a5 p2 1-  plusorminus n5 c4 1-  return vars--plusorminus x y c =-  x @= y+c @|| x @= y-c+{-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE FlexibleContexts #-}
+
+import Control.CP.FD.Example
+
+main = example_sat_main_void model
+
+model :: ExampleModel ()
+model _ = exists $ \vars -> do
+  [n1,n2,n3,n4,n5,
+   c1,c2,c3,c4,c5,
+   p1,p2,p3,p4,p5,
+   a1,a2,a3,a4,a5,
+   d1,d2,d3,d4,d5] <- colList vars 25
+  let ns = slice vars (cte 0 @.. cte 4)
+      cs = slice vars (cte 5 @.. cte 9)
+      ps = slice vars (cte 10 @.. cte 14)
+      as = slice vars (cte 15 @.. cte 19)
+      ds = slice vars (cte 20 @.. cte 24)
+  vars `allin` (cte 1, cte 5)
+  allDiff ns
+  allDiff cs
+  allDiff ps
+  allDiff as
+  allDiff ds
+  n1 @= c2
+  n2 @= a1
+  n3 @= p1
+  n4 @= d3
+  n5 @= 1
+  d5 @= 3
+  p3 @= d1
+  c1 @= d4
+  p5 @= a4
+  p2 @= c3
+  c1 @= c5+1
+  plusorminus a3 p4 1
+  plusorminus a5 p2 1
+  plusorminus n5 c4 1
+  return vars
+
+plusorminus x y c =
+  x @= y+c @|| x @= y-c

monadiccp.cabal view

@@ -1,98 +1,106 @@-Name:			monadiccp-Version:		0.7.6-Description:		Monadic Constraint Programming framework-License:		BSD3-License-file:		LICENSE-Author:			Tom Schrijvers, Pieter Wuille-Maintainer:		maik.riechert@arcor.de-Build-Type:		Simple-Category:		control-Synopsis:		Constraint Programming-Homepage:		http://users.ugent.be/~tschrijv/MCP/-Bug-reports:		https://github.com/neothemachine/monadiccp/issues-Cabal-Version:		>=1.6-Extra-Source-Files: 	examples/*.hs-Data-Files:		README.md--tested-with:     -                 GHC==7.6.3--source-repository head-  type:      git-  location:  https://github.com/neothemachine/monadiccp.git--Flag Debug-    Description:	Generate debug output-    Default:		False--library-    Build-Depends:	base >= 2, base < 5, containers, mtl, random, pretty, parsec >= 3.0-    Exposed-Modules:	Data.Expr.Sugar-                        Data.Expr.Data-                        Data.Expr.Util-                        Data.Linear-                        Control.CP.SearchTree-                        Control.CP.Transformers-                        Control.CP.ComposableTransformers-                        Control.CP.Solver-                        Control.CP.PriorityQueue-                        Control.CP.Queue-                        Control.CP.FD.Interface-                        Control.CP.FD.OvertonFD.OvertonFD-                        Control.CP.FD.OvertonFD.Sugar-                        Control.CP.EnumTerm-                        Control.CP.FD.Solvers-                        Control.CP.FD.Model-                        Control.CP.FD.Example-                        Control.CP.FD.FD-                        Control.CP.Debug-                        Control.CP.FD.SearchSpec.Data-                        Control.CP.FD.OvertonFD.Domain-                        Control.CP.FD.SimpleFD-                        Control.CP.FD.Graph-                        Control.CP.FD.Decompose             -                        Control.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.Mixin.Mixin-                        Language.CPP.Syntax.AST-                        Language.CPP.Pretty-    Other-Modules:	    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-    if flag(Debug)-        CPP-Options:	-DDEBUG-        CC-Options:	"-ggdb3" "-Wall"-    else-        CC-Options:	"-g0" "-DNDEBUG" "-Wall"+Name:			monadiccp
+Version:		0.7.7
+Description:		Monadic Constraint Programming framework
+License:		BSD3
+License-file:		LICENSE
+Author:			Tom Schrijvers, Pieter Wuille
+Maintainer:		maik.riechert@arcor.de
+Build-Type:		Simple
+Category:		control
+Synopsis:		Constraint Programming
+Homepage:		https://people.cs.kuleuven.be/~tom.schrijvers/MCP/
+Bug-reports:		https://github.com/letmaik/monadiccp/issues
+Cabal-Version:		>=1.8
+Extra-Source-Files: 	examples/*.hs
+Data-Files:		README.md
+
+tested-with:     
+                 GHC==7.6.3
+
+source-repository head
+  type:      git
+  location:  https://github.com/letmaik/monadiccp.git
+
+Flag Debug
+    Description:	Generate debug output
+    Default:		False
+
+library
+    hs-source-dirs: src
+    Build-Depends:	base >= 2, base < 5, containers, mtl, random, pretty, parsec >= 3.0,
+                        semigroups
+    Exposed-Modules:	Data.Expr.Sugar
+                        Data.Expr.Data
+                        Data.Expr.Util
+                        Data.Linear
+                        Control.CP.SearchTree
+                        Control.CP.Transformers
+                        Control.CP.ComposableTransformers
+                        Control.CP.Solver
+                        Control.CP.PriorityQueue
+                        Control.CP.Queue
+                        Control.CP.FD.Interface
+                        Control.CP.FD.OvertonFD.OvertonFD
+                        Control.CP.FD.OvertonFD.Sugar
+                        Control.CP.EnumTerm
+                        Control.CP.FD.Solvers
+                        Control.CP.FD.Model
+                        Control.CP.FD.Example
+                        Control.CP.FD.FD
+                        Control.CP.Debug
+                        Control.CP.FD.SearchSpec.Data
+                        Control.CP.FD.OvertonFD.Domain
+                        Control.CP.FD.SimpleFD
+                        Control.CP.FD.Graph
+                        Control.CP.FD.Decompose             
+                        Control.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.Mixin.Mixin
+                        Language.CPP.Syntax.AST
+                        Language.CPP.Pretty
+    Other-Modules:	    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
+    if flag(Debug)
+        CPP-Options:	-DDEBUG
+        CC-Options:	"-ggdb3" "-Wall"
+    else
+        CC-Options:	"-g0" "-DNDEBUG" "-Wall"
+
+test-suite olympic
+   hs-source-dirs: examples
+   type: exitcode-stdio-1.0
+   main-is: Olympic.hs
+   build-depends: base, monadiccp

+ src/Control/CP/ComposableTransformers.hs view

@@ -0,0 +1,313 @@+{- 
+ -      Monadic Constraint Programming
+ -      http://www.cs.kuleuven.be/~toms/Haskell/
+ -      Tom Schrijvers
+ -}
+{-# LANGUAGE GADTs #-}
+{-# LANGUAGE Rank2Types #-}
+{-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE ImpredicativeTypes #-}
+{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE ConstrainedClassMethods #-}
+
+module Control.CP.ComposableTransformers (
+  solve, restart,
+  NewBound, 
+  Bound(..),
+  Composition(..),
+  CTransformer, 
+  CForSolver, 
+  CForResult, 
+  CTreeState, 
+  RestartST(..) , 
+  SealedCST(..), 
+  CNodeBoundedST(..), 
+  CDepthBoundedST(..),
+  CBranchBoundST(..),
+  CFirstSolutionST(..),
+  CSolutionBoundST(..),
+  CIdentityCST(..),
+  CRandomST(..),
+  CLimitedDiscrepancyST(..)
+) where 
+
+import Control.CP.Transformers
+import Control.CP.SearchTree
+import Control.CP.Solver
+import Control.CP.Queue
+import Control.CP.Debug
+
+import System.Random (mkStdGen, randoms)
+
+--------------------------------------------------------------------------------
+-- EVALUATION
+--------------------------------------------------------------------------------
+
+solve :: (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])
+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
+--------------------------------------------------------------------------------
+
+data TStack es ts (solver :: * -> *) a where
+   TStack :: (CTransformer c, CForSolver c ~ solver, CForResult c ~ a) 
+          => c -> TStack (CEvalState c) (CTreeState c) solver a
+
+instance Solver solver => Transformer (TStack es ts solver a) where
+  type EvalState (TStack es ts solver a) = es
+  type TreeState (TStack es ts solver a) = ts
+  type ForSolver (TStack es ts solver a) = solver
+  type ForResult (TStack es ts solver a) = a
+  initT  (TStack c) _  = return $ initCT c
+  leftT  (TStack c) _  = leftCT c
+  rightT (TStack c) _  = rightCT c
+  nextT = nextTStack 
+  returnT i wl t@(TStack c) es = returnCT c es (\es' -> continue i wl t es') (\es' -> endT i wl t es')
+
+nextTStack :: 
+     (Solver solver, Queue q, Elem q ~ (Label solver,Tree solver a,ts))
+     => Int -> Tree solver a -> q -> (TStack es ts solver a) -> es -> ts -> solver (Int,[a])
+nextTStack i tree q t es ts =
+    case t of
+      TStack c ->
+        nextCT tree c es ts (\tree' es' ts' -> eval' i tree' q t es' ts') 
+                            (\es'       -> continue i q t es')
+                            (\es' -> endT i q t es')
+
+--------------------------------------------------------------------------------
+type CSearchSig c a =
+     (Solver (CForSolver c), CTransformer c) 
+     => Tree (CForSolver c) a -> c -> CEvalState c -> CTreeState c -> (EVAL c a) -> (CONTINUE c a) -> (EXIT c a) -> (CForSolver c) (Int,[a])
+
+type CContinueSig c a =
+     (Solver (CForSolver c), CTransformer c) 
+     => c -> CEvalState c -> (CONTINUE c a) -> (EXIT c a) -> (CForSolver c) (Int,[a])
+
+type EVAL     c a = (Tree (CForSolver c) a -> CEvalState c -> CTreeState c-> (CForSolver c) (Int,[a]))
+type CONTINUE c a = (CEvalState c -> (CForSolver c) (Int,[a]))
+type EXIT     c a = (CEvalState c) -> (CForSolver c) (Int,[a]) 
+
+class Solver (CForSolver c) => CTransformer c where
+  type CEvalState c :: *
+  type CTreeState c :: *
+  type CForSolver c :: (* -> *)
+  type CForResult c :: *
+  initCT :: c -> (CEvalState c, CTreeState c)
+  leftCT, rightCT :: c -> CTreeState c -> CTreeState c
+  leftCT  _  = id
+  rightCT    = leftCT
+  nextCT :: CSearchSig c (CForResult c)
+  nextCT   = evalCT
+  returnCT :: CContinueSig c (CForResult c) 
+  returnCT = continueCT
+  completeCT :: c -> CEvalState c -> Bool
+  completeCT _ _ = True
+
+evalCT :: CSearchSig c a
+evalCT tree c es ts eval continue exit =
+  eval tree es ts
+
+continueCT :: CContinueSig c a
+continueCT c es continue exit =
+  continue es
+
+exitCT :: CContinueSig c a
+exitCT c es continue exit =
+  exit es
+
+newtype CNodeBoundedST (solver :: * -> *) a = CNBST Int
+
+instance Solver solver => CTransformer (CNodeBoundedST solver a) where
+  type CEvalState (CNodeBoundedST solver a) = Int
+  type CTreeState (CNodeBoundedST solver a) = ()
+  type CForSolver (CNodeBoundedST solver a) = solver
+  type CForResult (CNodeBoundedST solver a) = a
+  initCT (CNBST n)  = (n,())  
+  nextCT tree c es ts eval' continue exit
+    | es == 0    = exit es
+    | otherwise  = eval' tree (es - 1) ts
+
+newtype CDepthBoundedST (solver :: * -> *) a = CDBST Int
+
+instance Solver solver => CTransformer (CDepthBoundedST solver a) where
+  type CEvalState (CDepthBoundedST solver a)  = Bool
+  type CTreeState (CDepthBoundedST solver a)  = Int
+  type CForSolver (CDepthBoundedST solver a)  = solver
+  type CForResult (CDepthBoundedST solver a)  = a
+  initCT (CDBST n)  = (True,n)
+  leftCT _ ts      = ts - 1
+  nextCT tree c es ts eval' continue exit
+    | ts == 0    = continue False
+    | otherwise  = eval' tree es ts
+  completeCT _ es  = es
+
+newtype CLimitedDiscrepancyST (solver :: * -> *) a = CLDST Int
+
+instance Solver solver => CTransformer (CLimitedDiscrepancyST solver a) where
+  type CEvalState (CLimitedDiscrepancyST solver a) = ()
+  type CTreeState (CLimitedDiscrepancyST solver a) = Int
+  type CForSolver (CLimitedDiscrepancyST solver a) = solver
+  type CForResult (CLimitedDiscrepancyST solver a) = a
+  initCT (CLDST n)  = ((),n)
+  rightCT _ n  = n - 1
+  nextCT tree c es ts eval' continue exit
+    | ts == 0    = continue es
+    | otherwise  = eval' tree es ts
+
+newtype CRandomST (solver :: * -> *) a  = CRST Int
+
+instance Solver solver => CTransformer (CRandomST solver a) where
+  type CEvalState (CRandomST solver a) = [Bool]
+  type CTreeState (CRandomST solver a) = ()
+  type CForSolver (CRandomST solver a) = solver
+  type CForResult (CRandomST solver a) = a
+  initCT (CRST n)  = (randoms $ mkStdGen n,())
+  nextCT tree@(Try l r) c (switch:es)
+    | switch        = evalCT (Try r l) c es
+    | otherwise     = evalCT tree      c es
+  nextCT tree@(Add d (Try l r)) c (switch:es)
+    | switch        = evalCT (Add d (Try r l)) c es
+    | otherwise     = evalCT tree      c es
+  nextCT tree c es  = evalCT tree      c es
+
+data CIdentityCST (solver :: * -> *) a  = CIST
+
+instance Solver solver => CTransformer (CIdentityCST solver a) where
+  type CEvalState (CIdentityCST solver a)  = ()
+  type CTreeState (CIdentityCST solver a)  = ()
+  type CForSolver (CIdentityCST solver a)  = solver
+  type CForResult (CIdentityCST solver a)  = a
+  initCT _  = ((),())
+
+data CFirstSolutionST (solver :: * -> *) a  = CFSST
+
+instance Solver solver => CTransformer (CFirstSolutionST solver a) where
+  type CEvalState (CFirstSolutionST solver a)  = Bool
+  type CTreeState (CFirstSolutionST solver a)  = ()
+  type CForSolver (CFirstSolutionST solver a)  = solver
+  type CForResult (CFirstSolutionST solver a)  = a
+  initCT _  = (True,())
+  returnCT _ es continue exit =
+    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,
+           CForSolver c1 ~ solver, CForSolver c2 ~ solver,
+           CForResult c1 ~ a,      CForResult c2 ~ a
+          ) 
+       => c1 -> c2 -> Composition (CEvalState c1,CEvalState c2) (CTreeState c1,CTreeState c2) solver a
+
+instance Solver solver => CTransformer (Composition es ts solver a) where
+  type CEvalState (Composition es ts solver a) = es
+  type CTreeState (Composition es ts solver a) = ts
+  type CForSolver (Composition es ts solver a) = solver
+  type CForResult (Composition es ts solver a) = a
+  initCT (c1 :- c2)       = let (es1,ts1) = initCT c1 
+                                (es2,ts2) = initCT c2 
+                            in ((es1,es2),(ts1,ts2))
+  leftCT (c1 :- c2) (ts1,ts2)   = (leftCT c1 ts1,leftCT c2 ts2)
+  rightCT (c1 :- c2) (ts1,ts2)  = (rightCT c1 ts1,rightCT c2 ts2)
+  nextCT tree (c1 :- c2) (es1,es2) (ts1,ts2) eval' continue exit  =
+    nextCT tree c1 es1 ts1 
+           (\tree' es1' ts1' -> nextCT tree' c2 es2 ts2 
+                                   (\tree'' es2' ts2' -> eval' tree'' (es1',es2') (ts1',ts2'))
+                                   (\es2' -> continue (es1',es2'))
+                                   (\es2' -> exit (es1',es2')) ) 
+           (\es1' -> continue (es1',es2))
+           (\es1' -> exit (es1',es2))
+  returnCT (c1 :- c2) (es1,es2) continue exit =
+    returnCT c1 es1 (\es1' -> returnCT c2 es2 (\es2' -> continue (es1',es2')) (\es2' -> exit (es1',es2'))) 
+                    (\es1' -> exit (es1',es2))
+  completeCT (c1 :- c2) (es1,es2)  = completeCT c1 es1 && completeCT c2 es2
+
+--------------------------------------------------------------------------------
+-- BRANCH & BOUND
+--------------------------------------------------------------------------------
+
+newtype CBranchBoundST (solver :: * -> *) a = CBBST (NewBound solver)
+data    BBEvalState solver  = BBP Int (Bound solver)
+
+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
+  type CEvalState (CBranchBoundST solver a) = BBEvalState solver
+  type CTreeState (CBranchBoundST solver a) = Int
+  type CForSolver (CBranchBoundST solver a) = solver
+  type CForResult (CBranchBoundST solver a) = a
+  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' <- newBound
+       continue $ BBP (v + 1) bound' 
+
+--------------------------------------------------------------------------------
+-- RESTARTING
+--------------------------------------------------------------------------------
+
+data SealedCST es ts solver a where
+  Seal :: CTransformer c => c -> SealedCST (CEvalState c) (CTreeState c) (CForSolver c) (CForResult c)
+
+instance Solver solver => CTransformer (SealedCST es ts solver a) where
+  type CEvalState (SealedCST es ts solver a) = es
+  type CTreeState (SealedCST es ts solver a) = ts
+  type CForSolver (SealedCST es ts solver a) = solver
+  type CForResult (SealedCST es ts solver a) = a
+  leftCT (Seal c)       = leftCT c
+  rightCT (Seal c)      = rightCT c
+  initCT (Seal c)       = initCT c
+  nextCT tree (Seal c)  = nextCT tree c
+  returnCT (Seal c)     = returnCT c
+  completeCT (Seal c)   = completeCT c
+
+data RestartST es ts (solver :: * -> *) a = RestartST [SealedCST es ts solver a] (Tree solver a -> solver (Tree solver a))
+
+instance Solver solver => Transformer (RestartST es ts solver a) where
+  type EvalState (RestartST es ts solver a) = (SealedCST es ts solver a,[SealedCST es ts solver a],es,Label solver,Tree solver a)
+  type TreeState (RestartST es ts solver a) = ts
+  type ForSolver (RestartST es ts solver a) = solver
+  type ForResult (RestartST es ts solver a) = a
+  initT  (RestartST (c:cs) _) tree  = 
+        let (es,ts) = initCT c
+        in do l <-  mark
+              return ((c,cs,es,l,tree),ts)
+  leftT  _ (c,_,_,_,_)      = leftCT c
+  rightT _ (c,_,_,_,_)      = rightCT c
+  nextT i tree q t es@(c,cs,es_c,l,tree0) ts = 
+        nextCT tree c es_c ts (\tree' es_c' ts' -> eval' i tree' q t (c,cs,es_c',l,tree0) ts') 
+                              (\es_c'       -> continue i q t (c,cs,es_c',l,tree0))
+                              (\es_c' -> endT i q t (c,cs,es_c',l,tree0))
+  returnT i wl t es@(c,cs,es_c,l,tree0)  = returnCT c es_c (\es_c' -> continue i wl t (c,cs,es_c',l,tree0)) (\es_c' -> endT i wl t (c,cs,es_c',l,tree0))
+  endT i wl t es@(_,[],_,_,_)      = return (i,[])
+  endT i wl t@(RestartST _ f) es@(c0,(c:cs),es_c0,l,tree0)   
+    | completeCT c0 es_c0  = return (i,[])
+    | otherwise            = let (es,ts) = initCT c
+                             in  do tree' <- f tree0
+                                    continue i (pushQ (l,tree',ts) $ emptyQ wl) t (c,cs,es,l,tree0)
+

+ src/Control/CP/Debug.hs view

@@ -0,0 +1,22 @@+{-# LANGUAGE CPP #-}
+
+module Control.CP.Debug (
+  debug,
+  imdebug
+) where
+
+import Debug.Trace
+
+debug :: String -> a -> a
+imdebug :: Show a => String -> a -> a
+
+{-# INLINE debug #-}
+{-# INLINE imdebug #-}
+
+#ifdef DEBUG
+debug = trace
+imdebug s a = trace ("imdebug " ++ s ++ ": " ++ (show a)) a
+#else
+debug = flip const
+imdebug = flip const
+#endif

+ src/Control/CP/EnumTerm.hs view

@@ -0,0 +1,113 @@+{-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE TransformListComp #-}
+{-# LANGUAGE MultiParamTypeClasses #-}
+{-# LANGUAGE FlexibleContexts #-}
+
+module Control.CP.EnumTerm (
+  EnumTerm(..),
+  assignment, assignments,
+  inOrder, firstFail, middleOut, endsOut,
+  labelling, levelList, enumerate
+) where
+
+import GHC.Exts (sortWith)
+
+import Control.CP.Solver
+import Control.CP.SearchTree
+
+class (Solver s, Term s t, Show (TermBaseType s t)) => EnumTerm s t where
+  type TermBaseType s t :: *
+
+  getDomainSize :: t -> s (Int)
+  getDomain :: t -> s [TermBaseType s t]
+  setValue :: t -> TermBaseType s t -> s [Constraint s]
+  splitDomain :: t -> s ([[Constraint s]],Bool)
+  splitDomains :: [t] -> s ([[Constraint s]],[t])
+  getValue :: t -> s (Maybe (TermBaseType s t))
+  defaultOrder :: [t] -> s [t]
+  enumerator :: (MonadTree m, TreeSolver m ~ s) => Maybe ([t] -> m ())
+
+  getDomainSize x = do
+    r <- getDomain x
+    return $ length r
+
+  getValue x = do
+    d <- getDomain x
+    return $ case d of
+      [v] -> Just v
+      _ -> Nothing
+  splitDomain x = do
+    d <- getDomain x
+    case d of
+      [] ->  return ([],True)
+      [_] -> return ([[]],True)
+      _ ->   do
+        rr <- mapM (setValue x) d
+        return (rr,True)
+
+  splitDomains [] = return ([[]],[])
+  splitDomains (a@(x:b)) = do
+    s <- getDomainSize x
+    if s==0
+      then return ([],[])
+      else if s==1 
+        then splitDomains b
+        else do
+          (r,v) <- splitDomain x
+          if v
+            then return (r,b)
+            else return (r,a)
+
+  defaultOrder = firstFail
+  enumerator = Nothing
+
+enumerate :: (MonadTree m, TreeSolver m ~ s, EnumTerm s t) => [t] -> m ()
+enumerate = case enumerator of
+  Nothing -> labelling defaultOrder
+  Just x -> x
+
+assignment :: (EnumTerm s t, MonadTree m, TreeSolver m ~ s) => t -> m (TermBaseType s t)
+assignment q = label $ getValue q >>= \y -> (case y of Just x -> return $ return x; _ -> return false)
+
+assignments :: (EnumTerm s t, MonadTree m, TreeSolver m ~ s) => [t] -> m [TermBaseType s t]
+assignments = mapM assignment
+
+firstFail :: EnumTerm s t => [t] -> s [t]
+firstFail qs = do ds <- mapM getDomainSize qs 
+                  return [ q | (d,q) <- zip ds qs 
+                             , then sortWith by d ]
+
+inOrder :: EnumTerm s t => [t] -> s [t]
+inOrder = return
+
+middleOut :: EnumTerm s t => [t] -> s [t]
+middleOut l = let n = (length l) `div` 2 in
+              return $ interleave (drop n l) (reverse $ take n l)
+
+endsOut :: EnumTerm s t => [t] -> s [t]
+endsOut  l = let n = (length l) `div` 2 in
+             return $ interleave (reverse $ drop n l) (take n l)
+
+interleave []     ys = ys
+interleave (x:xs) ys = x:interleave ys xs
+
+levelList :: (Solver s, MonadTree m, TreeSolver m ~ s) => [m ()] -> m ()
+levelList [] = false
+levelList [a] = a
+levelList l = 
+  let len = length l
+      (p1,p2) = splitAt (len `div` 2) l
+      in (levelList p1) \/ (levelList p2)
+--levelList [] = false
+--levelList [a] = a
+--levelList (a:b) = a \/ levelList b
+
+labelling :: (MonadTree m, TreeSolver m ~ s, EnumTerm s t) => ([t] -> s [t]) -> [t] -> m ()
+labelling _ [] = true
+labelling o l = label $ do 
+  ll <- o l
+  (cl,c) <- splitDomains ll
+  let ml = map (\l -> foldr (/\) true $ map addC l) cl
+  return $ do
+    levelList ml
+    labelling return c

+ src/Control/CP/FD/Decompose.hs view

@@ -0,0 +1,699 @@+{- 
+ -      Monadic Constraint Programming
+ -      http://www.cs.kuleuven.be/~toms/MCP/
+ -      Pieter Wuille
+ -}
+
+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
+{-# LANGUAGE DatatypeContexts #-}
+
+module Control.CP.FD.Decompose (
+  DecompData,
+  baseDecompData,
+  decompose,
+  decomposeEx,
+  decompBoolLookup,
+  decompIntLookup,
+  decompColLookup,
+) where
+
+import Data.Map (Map)
+import qualified Data.Map as Map
+
+import Data.Set (Set)
+import qualified Data.Set as Set
+
+import Control.Monad.State.Lazy hiding (state)
+
+import Control.CP.Debug
+import Data.Expr.Data
+import Data.Expr.Util
+import Control.CP.FD.Graph
+import Control.CP.FD.Model
+
+data DecompData = DecompData {
+  -- expressions currently accessible as variables
+  cseMapBool :: Map ModelBool EGVarId,
+  cseMapInt :: Map ModelInt EGVarId,
+  cseMapCol :: Map ModelCol EGVarId,
+  -- parent graph's data
+  cseParent :: Maybe DecompData,
+  -- expressions imported from parent graph
+  cseImports :: ([ModelBool],[ModelInt],[ModelCol]),
+  -- counter for unique id's
+  cseNIds :: Int,
+  -- locked nodes (already shown to the caller, and cannot be unified/replaced anymore)
+  cseLocked :: EGTypeData (Set EGVarId),
+  -- level of nesting
+  cseLevel :: Int
+}
+
+decompBoolLookup :: DecompData -> ModelBool -> Maybe EGVarId
+decompBoolLookup d v = Map.lookup v $ cseMapBool d
+
+decompIntLookup :: DecompData -> ModelInt -> Maybe EGVarId
+decompIntLookup d v = Map.lookup v $ cseMapInt d
+
+decompColLookup :: DecompData -> ModelCol -> Maybe EGVarId
+decompColLookup d v = Map.lookup v $ cseMapCol d
+
+-- | base instance of DecompData
+baseDecompData :: DecompData
+baseDecompData = DecompData {
+  cseMapBool = Map.empty,
+  cseMapInt = Map.empty,
+  cseMapCol = Map.empty,
+  cseParent = Nothing,
+  cseImports = ([],[],[]),
+  cseNIds = 0,
+  cseLevel = 0,
+  cseLocked = baseTypeData (Set.empty)
+}
+
+-- | the state for the DCMonad
+data DCState = DCState {
+  dcsData :: DecompData,
+  dcsModel :: EGModel
+}
+
+-- | base state for the DCMonad
+baseDCState = DCState {
+  dcsData = baseDecompData,
+  dcsModel = baseGraph
+}
+
+-- | definition of a decomposer monad
+newtype DCMonad a = DCMonad { state :: State DCState a }
+  deriving (Monad, Applicative, Functor, MonadState DCState)
+
+-- | transform an expression into a graph, taking and returning an updated state
+decomposeEx :: DecompData -> Int -> Model -> ([ModelBool],[ModelInt],[ModelCol]) -> Maybe EGModel -> (DecompData,EGModel,Int)
+decomposeEx dat vars model (lb,li,lc) prev = 
+  let prog = do
+        s1 <- get
+        put $ s1 { dcsData = (dcsData s1) { cseNIds = max vars (cseNIds $ dcsData s1) } }
+        decomposeBoolEx (Just True) model
+        mapM_ decomposeBool lb
+        mapM_ decomposeInt li
+        mapM_ decomposeCol lc
+        s2 <- get
+        put $ s2 { dcsData = (dcsData s2) { cseLocked = egTypeDataMap (\f -> Set.fromList $ Map.keys $ f $ egmLinks $ dcsModel s2) } }
+      pmodel = case prev of
+        Nothing -> baseGraph
+        Just x -> x
+      res = execState (state prog) $ DCState { dcsData = dat, dcsModel = pmodel }
+      in (dcsData res,dcsModel res,cseNIds $ dcsData res)
+
+-- | easier version of decomposeEx that does not require or return a state
+decompose :: Model -> EGModel
+decompose x = (\(_,x,_) -> x) $ decomposeEx baseDecompData 0 x ([],[],[]) Nothing
+
+-- | decomposition states can be stacked, this function tests whether a property hold
+-- for a state or any of its parents
+stateProperty :: (DecompData -> Bool) -> DecompData -> Bool
+stateProperty f s = if f s then True else case (cseParent s) of
+  Just p -> stateProperty f p
+  _ -> False
+
+newVar :: EGVarType -> DCMonad EGVarId
+newVar typ = do
+  s <- get
+  let (nv,nm) = addNode typ (dcsModel s)
+  put $ s { dcsModel = nm }
+  return nv
+
+importBool :: Maybe Bool -> ModelBool -> DCMonad EGVarId
+importBool val expr = do
+  n <- newBoolVar val expr
+  s <- get
+  if cseLevel (dcsData s) == 0
+    then error $ "Boolean expression (value="++(show val)++") escapes: " ++ (show expr)
+    else do
+      let ni = length $ (\(x,_,_)->x) $ cseImports $ dcsData s
+      put $ s { dcsData = (dcsData s) { cseImports = (\(a,b,c) -> (a++[expr],b,c)) (cseImports $ dcsData s) } }
+      addConstraint (EGBoolExtern ni) ([n],[],[])
+      return n
+
+importInt :: ModelInt -> DCMonad EGVarId
+importInt expr = do
+  n <- newIntVar expr
+  s <- get
+  if cseLevel (dcsData s) == 0
+    then error $ "Integer expression escapes: " ++ (show expr)
+    else do
+      let ni = length $ (\(_,x,_)->x) $ cseImports $ dcsData s
+      put $ s { dcsData = (dcsData s) { cseImports = (\(a,b,c) -> (a,b++[expr],c)) (cseImports $ dcsData s) } }
+      addConstraint (EGIntExtern ni) ([],[n],[])
+      return n
+
+importCol :: ModelCol -> DCMonad EGVarId
+importCol expr = do
+  n <- newColVar expr
+  s <- get
+  if cseLevel (dcsData s) == 0
+    then error $ "Collection expression escapes: " ++ (show expr)
+    else do
+      let ni = length $ (\(_,_,x)->x) $ cseImports $ dcsData s
+      put $ s { dcsData = (dcsData s) { cseImports = (\(a,b,c) -> (a,b,c++[expr])) (cseImports $ dcsData s) } }
+      addConstraint (EGColExtern ni) ([],[],[n])
+      return n
+
+unifyVars :: EGVarType -> EGVarId -> EGVarId -> DCMonad Bool
+unifyVars typ v1 v2 = do
+  s <- get
+  let rm = egTypeGet typ $ cseLocked $ dcsData s
+      i1 = Set.member v1 rm
+      i2 = Set.member v2 rm
+  if (i1 && i2)
+    then return False  -- if both nodes are locked, unification is not possible
+    else if i1
+      then unifyVars typ v2 v1 -- if only i1 is locked, unify v2 with v1 instead of v1 with v2
+      else do -- otherwise, really unify
+        let nm = unifyNodes typ v1 v2 (dcsModel s)
+        case typ of
+          EGBoolType -> put $ s { dcsModel = nm, dcsData = (dcsData s) { cseMapBool = Map.map tran $ cseMapBool $ dcsData s } }
+          EGIntType  -> put $ s { dcsModel = nm, dcsData = (dcsData s) { cseMapInt = Map.map tran $ cseMapInt $ dcsData s } }
+          EGColType  -> put $ s { dcsModel = nm, dcsData = (dcsData s) { cseMapCol = Map.map tran $ cseMapCol $ dcsData s } }
+        return True
+  where tran = unifyIds v1 v2
+
+addConstraint :: EGConstraintSpec -> ([EGVarId],[EGVarId],[EGVarId]) -> DCMonad ()
+addConstraint spec (lb,li,lc) = do
+  s <- get
+  let nm = addEdge spec (EGTypeData { boolData=lb, intData=li, colData=lc }) (dcsModel s)
+  put $ s { dcsModel = nm }
+
+newBoolVar :: Maybe Bool -> ModelBool -> DCMonad EGVarId
+newBoolVar val expr = do
+  n <- case val of
+    Nothing -> newVar EGBoolType
+    Just x -> decomposeBool $ BoolConst x
+  s <- get
+  let nc = Map.insert expr n (cseMapBool $ dcsData s)
+  put $ s { dcsData = (dcsData s) { cseMapBool = nc } }
+  return n
+
+newIntVar :: ModelInt -> DCMonad EGVarId
+newIntVar expr = do
+  n <- newVar EGIntType
+  s <- get
+  let nc = Map.insert expr n (cseMapInt $ dcsData s)
+  put $ s { dcsData = (dcsData s) { cseMapInt = nc } }
+  return n
+
+newColVar :: ModelCol -> DCMonad EGVarId
+newColVar expr = do
+  n <- newVar EGColType
+  s <- get
+  let nc = Map.insert expr n (cseMapCol $ dcsData s)
+  put $ s { dcsData = (dcsData s) { cseMapCol = nc } }
+  return n
+
+decomposeSubmodel :: (Int,Int,Int) -> (([ModelBool],[ModelInt],[ModelCol]) -> DCMonad ()) -> DCMonad (EGModel,([EGVarId],[EGVarId],[EGVarId]))
+decomposeSubmodel (nArgsBool,nArgsInt,nArgsCol) m = do
+  oArgsBool <- mapM (const $ nextId >>= (\x -> return $ BoolTerm $ ModelBoolVar $ x)) [1..nArgsBool]
+  oArgsInt  <- mapM (const $ nextId >>= (\x -> return $ Term     $ ModelIntVar  $ x)) [1..nArgsInt]
+  oArgsCol  <- mapM (const $ nextId >>= (\x -> return $ ColTerm  $ ModelColVar  $ x)) [1..nArgsCol]
+  s <- get
+  let sm = m (oArgsBool,oArgsInt,oArgsCol)
+      ns = execState (state sm) $ baseDCState { dcsData = (dcsData baseDCState) { cseLevel = 1 + (cseLevel $ dcsData s), cseNIds = 0+(cseNIds $ dcsData s), cseParent = Just $ dcsData s } }
+  put $ s { dcsData = (dcsData s) { cseNIds = 0+(cseNIds $ dcsData ns) } }
+  argsBool <- mapM decomposeBool $ (\(x,_,_) -> x) $ cseImports $ dcsData ns
+  argsInt <-  mapM decomposeInt  $ (\(_,x,_) -> x) $ cseImports $ dcsData ns
+  argsCol <-  mapM decomposeCol  $ (\(_,_,x) -> x) $ cseImports $ dcsData ns
+  return (dcsModel ns, (argsBool,argsInt,argsCol))
+
+constIntTrans :: ModelIntTerm ModelFunctions -> EGParTerm
+constIntTrans (ModelIntPar x) = EGPTParam x
+constIntTrans x = error $ "non-constant int transform: "++(show x)
+constColTrans :: ModelColTerm ModelFunctions -> EGParColTerm
+constColTrans (ModelColPar x) = EGPTColParam x
+constColTrans x = error $ "non-constant col transform: "++(show x)
+constBoolTrans :: ModelBoolTerm ModelFunctions -> EGParBoolTerm
+constBoolTrans (ModelBoolPar x) = EGPTBoolParam x
+constBoolTrans x = error $ "non-constant bool transform: "++(show x)
+constIntTransInv :: EGParTerm -> ModelIntTerm ModelFunctions
+constIntTransInv (EGPTParam x) = ModelIntPar x
+constColTransInv :: EGParColTerm -> ModelColTerm ModelFunctions
+constColTransInv (EGPTColParam x) = ModelColPar x
+constBoolTransInv :: EGParBoolTerm -> ModelBoolTerm ModelFunctions
+constBoolTransInv (EGPTBoolParam x) = ModelBoolPar x
+
+constTrans = (constIntTrans,constColTrans,constBoolTrans,constIntTransInv,constColTransInv,constBoolTransInv)
+invConstTrans = (constIntTransInv,constColTransInv,constBoolTransInv,constIntTrans,constColTrans,constBoolTrans)
+
+dependenceTester d = 
+  (
+    \x -> if Map.member x (cseMapInt d) && not (x `elem` ((\(_,x,_) -> x) $ cseImports d)) then Just True else Nothing,
+    \x -> if Map.member x (cseMapCol d) && not (x `elem` ((\(_,_,x) -> x) $ cseImports d)) then Just True else Nothing,
+    \x -> case x of
+      BoolTerm (ModelExtra _) -> Just True
+      _ -> if Map.member x (cseMapBool d) && not (x `elem` ((\(x,_,_) -> x) $ cseImports d)) then Just True else Nothing
+  )
+
+dependentIntExpr :: DecompData -> ModelInt -> Bool
+dependentIntExpr d = propertyEx $ dependenceTester d
+dependentBoolExpr :: DecompData -> ModelBool -> Bool
+dependentBoolExpr d = boolPropertyEx $ dependenceTester d
+dependentColExpr :: DecompData -> ModelCol -> Bool
+dependentColExpr d = colPropertyEx $ dependenceTester d
+
+nextId :: DCMonad Int
+nextId = do
+  s <- get
+  let n = cseNIds $ dcsData s
+  put $ s { dcsData = (dcsData s) { cseNIds = n + 1 } }
+  return n
+
+-----------------------------------------
+-- | Decomposition of special values | --
+-----------------------------------------
+
+decomposeBool :: ModelBool -> DCMonad EGVarId
+decomposeBool expr = do
+  (Just x) <- decomposeBoolEx Nothing expr
+  return x
+
+decomposeBoolEx :: Maybe Bool -> ModelBool -> DCMonad (Maybe EGVarId)
+decomposeBoolEx val expr = do
+  s <- get
+  debug ("decomposeBoolEx [level "++(show $ cseLevel $ dcsData s)++"] val="++(show val)++" expr="++(show expr)) $ return ()
+  let key = expr
+  case Map.lookup key (cseMapBool $ dcsData s) of    -- local variable or already locally decomposed expression
+    Just i -> do
+      debug ("decomposeBoolEx [level "++(show $ cseLevel $ dcsData s)++"] val="++(show val)++" expr="++(show expr)++": already decomposed: "++(show i)) $ return ()
+      return $ Just i
+    Nothing -> if (modelVariantBool expr)
+      then do
+        if (stateProperty (Map.member key . cseMapBool) $ dcsData s) && not (dependentBoolExpr (dcsData s) expr) && (cseLevel $ dcsData s) > 0
+          then do   -- Loop Invariant Code Motion
+            debug ("decomposeBoolEx: [level "++(show $ cseLevel $ dcsData s)++"] [variant indep] "++(show expr)) $ return ()
+            n <- importBool val expr
+            return $ Just n
+          else do
+            debug ("decomposeBoolEx: [level "++(show $ cseLevel $ dcsData s)++"] [variant dep] "++(show expr)) $ return ()
+            realDecomposeBoolEx val expr
+        else do
+          debug ("decomposeBoolEx: [level "++(show $ cseLevel $ dcsData s)++"] [invariant] "++(show expr)) $ return ()
+          n <- newBoolVar val expr
+          let tr = boolTransform constTrans expr
+          addConstraint (EGBoolValue tr) ([n],[],[])
+          return $ Just n
+
+decomposeInt :: ModelInt -> DCMonad EGVarId
+decomposeInt expr = do
+  s <- get
+  debug ("decomposeInt [level "++(show $ cseLevel $ dcsData s)++"] expr="++(show expr)) $ return ()
+  let key = expr
+  case Map.lookup key (cseMapInt $ dcsData s) of
+    Just i -> return i
+    Nothing -> if (modelVariantInt expr)
+      then if (stateProperty (Map.member key . cseMapInt) $ dcsData s) && not (dependentIntExpr (dcsData s) expr) && (cseLevel $ dcsData s) > 0
+        then do
+          debug ("decomposeInt: [level "++(show $ cseLevel $ dcsData s)++"] [variant indep] "++(show expr)) $ return ()
+          importInt expr
+        else do
+          debug ("decomposeInt: [level "++(show $ cseLevel $ dcsData s)++"] [variant dep] "++(show expr)) $ return ()
+          realDecomposeInt expr
+      else do
+        debug ("decomposeInt: [level "++(show $ cseLevel $ dcsData s)++"] [invariant] "++(show expr)) $ return ()
+        n <- newIntVar expr
+        let tr = transform constTrans expr
+        addConstraint (EGIntValue tr) ([],[n],[])
+        return n
+
+decomposeCol :: ModelCol -> DCMonad EGVarId
+decomposeCol expr = do
+  s <- get
+  debug ("decomposeCol [level "++(show $ cseLevel $ dcsData s)++"] expr="++(show expr)) $ return ()
+  let key = expr
+  case Map.lookup key (cseMapCol $ dcsData s) of
+    Just i -> return i
+    Nothing -> if (modelVariantCol expr)
+      then if (stateProperty (Map.member key . cseMapCol) $ dcsData s) && not (dependentColExpr (dcsData s) expr) && (cseLevel $ dcsData s) > 0
+        then do
+          debug ("decomposeCol: [level "++(show $ cseLevel $ dcsData s)++"] [variant indep] "++(show expr)) $ return ()
+          importCol expr
+        else do 
+          debug ("decomposeCol: [level "++(show $ cseLevel $ dcsData s)++"] [variant dep] "++(show expr)) $ return ()
+          realDecomposeCol expr
+      else do
+        debug ("decomposeCol: [level "++(show $ cseLevel $ dcsData s)++"] [invariant] "++(show expr)) $ return ()
+        n <- newColVar expr
+        let tr = colTransform constTrans expr
+        addConstraint (EGColValue tr) ([],[],[n])
+        return n
+
+
+------------------------------------------
+-- | Real decomposers for expressions | --
+------------------------------------------
+
+realDecomposeBoolEx :: Maybe Bool -> ModelBool -> DCMonad (Maybe EGVarId)
+realDecomposeBoolEx val expr = case expr of
+  BoolTerm (ModelExtra (ForNewBool f)) -> do
+    n <- nextId
+    let v = BoolTerm $ ModelBoolVar n
+    newBoolVar Nothing v
+    decomposeBoolEx val $ f v
+  BoolTerm (ModelExtra (ForNewInt f)) -> do
+    n <- nextId
+    let v = Term $ ModelIntVar n
+    newIntVar v
+    decomposeBoolEx val $ f v
+  BoolTerm (ModelExtra (ForNewCol f)) -> do
+    n <- nextId
+    let v = ColTerm $ ModelColVar n
+    newColVar v
+    decomposeBoolEx val $ f v
+  BoolTerm (ModelBoolVar i) -> do
+    n <- newBoolVar val expr
+    return $ Just n
+  BoolCond c t f -> case val of
+    Just True -> do
+      dc <- decomposeBool c
+      di <- decomposeBool $ boolSimplify $ BoolNot c
+      ct <- decomposeBool (BoolConst True)
+      if (t /= BoolConst True) 
+        then do
+          dt <- decomposeBool t
+          addConstraint EGCondEqual ([dc,dt,ct],[],[])
+        else return ()
+      if (f /= BoolConst True)
+        then do
+          df <- decomposeBool f
+          addConstraint EGCondEqual ([di,df,ct],[],[])
+        else return ()
+      return Nothing
+    _ -> error "No reified boolean conditional exists"
+  BoolAnd a b -> case val of
+    Just True -> do
+      decomposeBoolEx val a
+      decomposeBoolEx val b
+      return Nothing
+    _ -> do
+      n <- newBoolVar val expr
+      ad <- decomposeBool a
+      bd <- decomposeBool b
+      addConstraint EGAnd ([n,ad,bd],[],[])
+      return $ Just n
+  BoolOr a b -> case val of
+    Just False -> do
+      decomposeBoolEx val a
+      decomposeBoolEx val b
+      return Nothing
+    _ -> do
+      n <- newBoolVar val expr
+      ad <- decomposeBool a
+      bd <- decomposeBool b
+      addConstraint EGOr ([n,ad,bd],[],[])
+      return $ Just n
+  BoolNot a -> case val of
+    Just True -> do
+      decomposeBoolEx (Just False) a
+      return Nothing
+    Just False -> do
+      decomposeBoolEx (Just True) a
+      return Nothing
+    _ -> do
+      n <- newBoolVar val expr
+      ad <- decomposeBool a
+      addConstraint EGNot ([n,ad],[],[])
+      return $ Just n
+  Rel a r b -> case (r,val) of
+    (EREqual,Just True) -> do
+      ad <- decomposeInt a
+      bd <- decomposeInt b
+      res <- unifyVars EGIntType ad bd
+      if res
+        then return Nothing
+        else do
+          n <- decomposeBool (BoolConst True)
+          addConstraint EGEqual ([n],[ad,bd],[])
+          return Nothing
+    (ERDiff,Just False) -> do
+      ad <- decomposeInt a 
+      bd <- decomposeInt b
+      res <- unifyVars EGIntType ad bd
+      if res
+        then return Nothing
+        else do
+          n <- decomposeBool (BoolConst True)
+          addConstraint EGEqual ([n],[ad,bd],[])
+          return Nothing
+    _ -> do
+      n <- newBoolVar val expr
+      ad <- decomposeInt a
+      bd <- decomposeInt b
+      addConstraint (case r of
+          EREqual -> EGEqual
+          ERDiff -> EGDiff
+          ERLess -> EGLess True
+        ) ([n],[ad,bd],[])
+      return $ Just n
+  ColEqual a b -> case val of
+    Just True -> do
+      ad <- decomposeCol a
+      bd <- decomposeCol b
+      res <- unifyVars EGColType ad bd
+      if not res
+        then error "unification of collections failed"
+        else return Nothing
+    _ -> error "No negated or reified version of ColEqual exists"
+  AllDiff b c -> case val of
+    Just True -> do
+      ac <- decomposeCol c
+      addConstraint (EGAllDiff b) ([],[],[ac])
+      return Nothing
+    _ -> error "No negated or reified version of AllDiff exists"
+  Sorted b c -> case val of
+    Just True -> do
+      ac <- decomposeCol c
+      addConstraint (EGSorted b) ([],[],[ac])
+      return Nothing
+    _ -> error "No negated or reified version of Sorted exists"
+  Dom i c -> case val of
+    Just True -> do
+      ac <- decomposeCol c
+      ai <- decomposeInt i
+      addConstraint EGDom ([],[ai],[ac])
+      return Nothing
+    _ -> error "No negated or reified version of Dom exists"
+  BoolEqual a b -> case val of
+    Just True -> do
+      ad <- decomposeBool a
+      bd <- decomposeBool b
+      res <- unifyVars EGBoolType ad bd
+      if res
+        then return Nothing
+        else do
+          n <- decomposeBool (BoolConst True)
+          addConstraint EGEquiv ([n,ad,bd],[],[])
+          return Nothing
+    _ -> do
+      n <- newBoolVar val expr
+      ad <- decomposeBool a
+      bd <- decomposeBool b
+      addConstraint EGEquiv ([n,ad,bd],[],[])
+      return $ Just n
+--  BoolAll f (ColRange l h) -> do
+--    ld <- decomposeInt l
+--    hd <- decomposeInt h
+--    n <- newBoolVar val expr
+--    (smod,(argsBool,argsInt,argsCol)) <- decomposeSubmodel (0,1,0) $ \([],[oarg],[]) -> do
+--      let sexpr = f oarg
+--      arg <- newIntVar oarg
+--      debug ("BoolAllC: arg="++(show arg)++" oarg="++(show oarg)) $ return ()
+--      addConstraint (EGIntExtern $ -1) ([],[arg],[])
+--      case val of
+--        Just True -> do
+--          decomposeBoolEx (Just True) sexpr
+--          return ()
+--        _ -> do
+--          res <- decomposeBool sexpr
+--          addConstraint (EGBoolExtern $ -1) ([res],[],[])
+--    let force = case val of
+--                Just True -> True
+--                _ -> False
+--    addConstraint (EGAllC smod (length argsBool,length argsInt,length argsCol) force) ([n]++argsBool,[ld,hd]++argsInt,argsCol)
+--    return $ Just n
+--  BoolAny f (ColRange l h) -> do
+--    ld <- decomposeInt l
+--    hd <- decomposeInt h
+--    n <- newBoolVar val expr
+--    (smod,(argsBool,argsInt,argsCol)) <- decomposeSubmodel (0,1,0) $ \([],[oarg],[]) -> do
+--      let sexpr = f oarg
+--      arg <- newIntVar oarg
+--      addConstraint (EGIntExtern $ -1) ([],[arg],[])
+--      case val of
+--        Just False -> do
+--          decomposeBoolEx (Just False) sexpr
+--          return ()
+--        _ -> do
+--          res <- decomposeBool sexpr
+--          addConstraint (EGBoolExtern $ -1) ([res],[],[])
+--    let force = case val of
+--                Just False -> True
+--                _ -> False
+--    addConstraint (EGAnyC smod (length argsBool,length argsInt,length argsCol) force) ([n]++argsBool,[ld,hd]++argsInt,argsCol)
+--    return $ Just n
+  BoolAll f c -> do
+    cd <- decomposeCol c
+    n <- newBoolVar val expr
+    (smod,(argsBool,argsInt,argsCol)) <- decomposeSubmodel (0,1,0) $ \([],[oarg],[]) -> do
+      let sexpr = f oarg
+      arg <- newIntVar oarg
+      addConstraint (EGIntExtern $ -1) ([],[arg],[])
+      case val of
+        Just True -> do   {- in case a BoolAll itself must hold, each submodel must hold too -}
+          decomposeBoolEx (Just True) sexpr
+          return ()
+        _ -> do
+          res <- decomposeBool sexpr
+          addConstraint (EGBoolExtern $ -1) ([res],[],[])
+    let force = 
+          case val of
+            Just True -> True
+            _ -> False
+    addConstraint (EGAll smod (length argsBool,length argsInt,length argsCol) force) ([n] ++ argsBool,argsInt,[cd] ++ argsCol)
+    return $ Just n
+  BoolAny f c -> do
+    cd <- decomposeCol c
+    n <- newBoolVar val expr
+    (smod,(argsBool,argsInt,argsCol)) <- decomposeSubmodel (0,1,0) $ \([],[oarg],[]) -> do
+      let sexpr = f oarg
+      arg <- newIntVar oarg
+      addConstraint (EGIntExtern $ -1) ([],[arg],[])
+      case val of
+        Just False -> do   {- in case a BoolAny itself may not hold, each submodel may not hold either -}
+          decomposeBoolEx (Just False) sexpr
+          return ()
+        _ -> do
+          res <- decomposeBool sexpr
+          addConstraint (EGBoolExtern $ -1) ([res],[],[])
+    let force = 
+          case val of
+            Just False -> True
+            _ -> False
+    addConstraint ((if force then EGAll else EGAny) smod (length argsBool,length argsInt,length argsCol) force) ([n] ++ argsBool,argsInt,[cd] ++ argsCol)
+    return $ Just n
+  _ -> error $ "Unable to decompose boolean expression: " ++ (show expr) ++ "(== " ++ (show val) ++ ")"
+
+realDecomposeInt :: ModelInt -> DCMonad EGVarId
+realDecomposeInt expr = do
+  let pIntOp a x b = do
+        n <- newIntVar expr
+        ad <- decomposeInt a
+        bd <- decomposeInt b
+        addConstraint x ([],[n,ad,bd],[])
+        return n
+  case expr of
+    Term (ModelIntVar i) -> newIntVar expr
+    Plus a b -> pIntOp a EGPlus b
+    Minus a b -> pIntOp a EGMinus b
+    Mult a b -> pIntOp a EGMult b
+    Div a b -> pIntOp a EGDiv b
+    Mod a b -> pIntOp a EGMod b
+    Abs a -> do
+      n <- newIntVar expr
+      ad <- decomposeInt a
+      addConstraint EGAbs ([],[n,ad],[])
+      return n
+    At a b -> do
+      n <- newIntVar expr
+      ad <- decomposeCol a
+      bd <- decomposeInt b
+      addConstraint EGAt ([],[n,bd],[ad])
+      return n
+    ColSize a -> do
+      n <- newIntVar expr
+      ad <- decomposeCol a
+      addConstraint EGSize ([],[n],[ad])
+      return n
+    Channel a -> do
+      n <- newIntVar expr
+      ad <- decomposeBool a
+      addConstraint EGChannel ([ad],[n],[])
+      return n
+    Cond c t f -> do
+      n <- newIntVar expr
+      cd <- decomposeBool c
+      td <- decomposeInt t
+      fd <- decomposeInt f
+      addConstraint EGCondInt ([cd],[n,td,fd],[])
+      return n
+    Fold f i c -> do
+      cd <- decomposeCol c
+      id <- decomposeInt i
+      n <- newIntVar expr
+      (smod,(argsBool,argsInt,argsCol)) <- decomposeSubmodel (0,2,0) $ \([],[oacc,oarg],[]) -> do
+        let sexpr = f oacc oarg
+        acc <- newIntVar oacc
+        addConstraint (EGIntExtern $ -2) ([],[acc],[])
+        arg <- newIntVar oarg
+        addConstraint (EGIntExtern $ -3) ([],[arg],[])
+        res <- decomposeInt sexpr
+        addConstraint (EGIntExtern $ -1) ([],[res],[])
+      addConstraint (EGFold smod (length argsBool,length argsInt,length argsCol)) (argsBool,[n,id]++argsInt,[cd]++argsCol)
+      return n
+    _ -> error $ "Unable to decompose expression: " ++ (show expr)
+
+listAll :: [a] -> (a -> Maybe b) -> Maybe [b]
+listAll [] _ = Just []
+listAll (a:b) f = case f a of
+  Nothing -> Nothing
+  Just r -> case listAll b f of
+    Nothing -> Nothing
+    Just x -> Just (r:x)
+
+realDecomposeCol :: ModelCol -> DCMonad EGVarId
+realDecomposeCol expr = case expr of
+  ColList l -> do
+    n <- newColVar expr
+    ld <- mapM decomposeInt l
+    addConstraint (EGList (length l)) ([],ld,[n])
+    return n
+  ColTerm (ModelColVar i) -> newColVar expr
+  ColRange a b -> do
+    n <- newColVar expr
+    ad <- decomposeInt a
+    bd <- decomposeInt b
+    addConstraint EGRange ([],[ad,bd],[n])
+    return n
+  ColCat a b -> do
+    n <- newColVar expr
+    ad <- decomposeCol a
+    bd <- decomposeCol b
+    addConstraint EGCat ([],[],[n,ad,bd])
+    return n
+{-  ColSlice f n c -> do
+    nn <- newColVar expr
+    cd <- decomposeCol c
+    let fd x = debug ("ColSlice: f("++(show x)++")="++(show $ f $ transform invConstTrans x)) $ transform constTrans $ f $ transform invConstTrans x
+    let nd = transform constTrans n
+    addConstraint (EGSlice fd nd) ([],[],[nn,cd])
+    return nn -}
+  ColSlice f nn c -> do
+    cd <- decomposeCol c
+    nd <- decomposeInt nn
+    n <- newColVar expr
+    (smod,(argsBool,argsInt,argsCol)) <- decomposeSubmodel (0,1,0) $ \([],[oarg],[]) -> do
+      let sexpr = f oarg
+      arg <- newIntVar oarg
+      addConstraint (EGIntExtern $ -2) ([],[arg],[])
+      res <- decomposeInt sexpr
+      addConstraint (EGIntExtern $ -1) ([],[res],[])
+    addConstraint (EGSlice smod (length argsBool,length argsInt,length argsCol)) (argsBool,[nd]++argsInt,[n,cd]++argsCol)
+    return n
+  ColMap f c -> do
+    cd <- decomposeCol c
+    n <- newColVar expr
+    (smod,(argsBool,argsInt,argsCol)) <- decomposeSubmodel (0,1,0) $ \([],[oarg],[]) -> do
+      let sexpr = f oarg
+      arg <- newIntVar oarg
+      addConstraint (EGIntExtern $ -2) ([],[arg],[])
+      res <- decomposeInt sexpr
+      addConstraint (EGIntExtern $ -1) ([],[res],[])
+    addConstraint (EGMap smod (length argsBool,length argsInt,length argsCol)) (argsBool,argsInt,[n,cd]++argsCol)
+    return n
+  _ -> error $ "Unable to decompose collection: " ++ (show expr)

+ src/Control/CP/FD/Example.hs view

@@ -0,0 +1,110 @@+{-# LANGUAGE RankNTypes #-}
+{-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE AllowAmbiguousTypes #-}
+
+module Control.CP.FD.Example (
+  example_main,
+  example_sat_main,
+  example_sat_main_void,
+  example_sat_main_single,
+  example_sat_main_single_expr,
+  example_sat_main_coll_expr,
+  example_min_main,
+  example_min_main_void,
+  example_min_main_single,
+  example_min_main_single_expr,
+  example_min_main_coll_expr,
+  runSolve,
+  labeller,
+  postMinimize,
+  ExampleModel, ExampleMinModel, 
+  module Control.CP.FD.Interface,
+) where
+
+
+import System.Environment (getArgs)
+import Data.Maybe (fromJust,isJust)
+import Data.Map (Map)
+import qualified Data.Map as Map
+import Data.List (init,last)
+
+import Control.CP.FD.OvertonFD.OvertonFD
+import Control.CP.FD.OvertonFD.Sugar
+import Control.CP.FD.FD
+import Control.CP.FD.Model
+
+import Control.CP.Debug
+
+import Control.CP.FD.Interface
+import Control.CP.SearchTree
+import Control.CP.EnumTerm
+import Control.CP.ComposableTransformers
+import Control.CP.FD.Solvers
+
+import Control.Monad.Cont
+
+type ExampleModel t =    (forall s m. (Show (FDIntTerm s), FDSolver s, MonadTree m, TreeSolver m ~ (FDInstance s)) => t -> m (ModelCol))
+type ExampleMinModel t = (forall s m. (Show (FDIntTerm s), FDSolver s, MonadTree m, TreeSolver m ~ (FDInstance s)) => t -> m (ModelInt,ModelCol))
+
+postMinimize :: ExampleMinModel t -> ExampleModel t
+postMinimize m = \x -> do
+  (min,res) <- m x
+  debug ("postMinimize: min="++(show min)) $ return ()
+  label $ do
+    setMinimizeVar min
+    return $ return res
+
+runSolveSAT x = solve dfs fs x
+runSolveMIN x = solve dfs (bb boundMinimize) x
+
+runSolve False x = runSolveSAT x
+runSolve True  x = runSolveMIN x
+
+labeller col = do
+  label $ do
+    min <- getMinimizeVar
+    case min of
+      Nothing -> return $ labelCol col
+      Just v -> return $ do
+        enumerate [v]
+        labelCol col
+
+example_main :: ExampleModel [String] -> ExampleModel ModelInt -> ExampleModel ModelCol -> Bool -> IO ()
+example_main f fx fcx typ = do
+  args <- getArgs
+  case args of
+    ("overton_run":r) -> print $ runSolve typ $ ((f r) :: Tree (FDInstance OvertonFD) ModelCol) >>= labeller
+    [] -> putStr "Solver type required: must be overton_run\n"
+    (a:r) -> putStr ("Unsupported solver: " ++ a ++ "\n")
+
+example_min_main :: ExampleMinModel [String] -> ExampleMinModel ModelInt -> ExampleMinModel ModelCol -> IO ()
+example_min_main f fx fcx = example_main (postMinimize f) (postMinimize fx) (postMinimize fcx) True
+
+example_sat_main :: ExampleModel [String] -> ExampleModel ModelInt -> ExampleModel ModelCol -> IO ()
+example_sat_main f fx fcx = example_main f fx fcx False
+
+example_sat_main_void :: ExampleModel () -> IO ()
+example_sat_main_void f = example_sat_main (const $ f ()) (const $ f ()) (const $ f ())
+
+example_min_main_void :: ExampleMinModel () -> IO ()
+example_min_main_void f = example_min_main (const $ f ()) (const $ f ()) (const $ f ())
+
+example_sat_main_single :: Read n => ExampleModel n -> IO ()
+example_sat_main_single f = example_sat_main (f . read . head) (error "Uncompilable model") (error "Uncompilable model")
+
+example_min_main_single :: Read n => ExampleMinModel n -> IO ()
+example_min_main_single f = example_min_main (f . read . head) (error "Uncompilable model") (error "Uncompilable model")
+
+example_sat_main_single_expr :: ExampleModel ModelInt -> IO ()
+example_sat_main_single_expr f = example_sat_main (f . fromInteger . read . head) f (\x -> f $ x!(cte (0::Integer)))
+
+example_min_main_single_expr :: ExampleMinModel ModelInt -> IO ()
+example_min_main_single_expr f = example_min_main (f . fromInteger . read . head) f (\x -> f $ x!(cte (0::Integer)))
+
+example_sat_main_coll_expr :: ExampleModel ModelCol -> IO ()
+example_sat_main_coll_expr f = example_sat_main (f . list . foldr (++) [] . map (map fromInteger . read . (\x -> "[" ++ x ++ "]"))) (f. list . (\x -> [x])) f
+
+example_min_main_coll_expr :: ExampleMinModel ModelCol -> IO ()
+example_min_main_coll_expr f = example_min_main (f . list . foldr (++) [] . map (map fromInteger . read . (\x -> "[" ++ x ++ "]"))) (f. list . (\x -> [x])) f

+ src/Control/CP/FD/FD.hs view

@@ -0,0 +1,1556 @@+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
+{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE MultiParamTypeClasses #-}
+{-# LANGUAGE TypeSynonymInstances #-}
+{-# LANGUAGE UndecidableInstances #-}
+{-# LANGUAGE DatatypeContexts #-}
+
+module Control.CP.FD.FD (
+  module Data.Expr.Sugar,
+  FDInstance,
+  FDSolver(..),
+  FDSpecInfo,
+  FDSpecInfoBool(..), FDSpecInfoInt(..), FDSpecInfoCol(..),
+  liftFD, addFD,
+  SpecFn, SpecFnRes, SpecResult(..),
+  getBoolSpec_, getIntSpec_, getColSpec_,
+  getBoolSpec,  getIntSpec,  getColSpec,
+  getEdge, markEdge,
+  setFailed,
+  getLevel,
+  getIntVal, getBoolVal, getColVal,
+  getIntTerm, getBoolTerm, getColTerm,
+  getSingleIntTerm,
+  getDefBoolSpec, getDefIntSpec, getDefColSpec,
+  getFullBoolSpec, getFullIntSpec, getFullColSpec,
+  getColItems,
+  fdSpecInfo_spec,
+  specInfoBoolTerm, specInfoIntTerm,
+  Control.CP.FD.FD.newInt, Control.CP.FD.FD.newBool, Control.CP.FD.FD.newCol,
+  procSubModel, procSubModelEx, specSubModelEx,
+  runFD,
+  setMinimizeVar, boundMinimize, getMinimizeTerm, getMinimizeVar,
+  fdNewvar,
+) where
+
+import Control.Monad.State.Lazy
+import Control.Monad.Trans
+import qualified Data.Map as Map
+import Data.Map(Map)
+import Data.Maybe
+import Data.List
+import qualified Data.Set as Set
+import Data.Set(Set)
+
+import Control.CP.Debug
+import Data.Expr.Sugar
+import Data.Expr.Data
+-- import Control.CP.FD.Expr.Util
+import Control.CP.FD.Model
+import Control.CP.FD.Decompose
+import Control.CP.FD.Graph
+import Control.CP.SearchTree
+import Control.CP.ComposableTransformers
+import Control.CP.EnumTerm
+import Control.CP.Solver
+import Control.Mixin.Mixin
+
+-- | state kept by FDInstance, in addition to the underlying solver's internal state
+data FDSolver s => FDState s = FDState {
+  -- | expression representing unprocessed constraints
+  fdsExpr :: Model,
+  -- | model being processed now
+  fdsModel :: Maybe EGModel,
+  -- | private data for the decomposer (kept to optimize constraints which aren't added in one go)
+  fdsDecomp :: DecompData,
+  -- | when adding constraints, the EGEdgeId's occurring in the decomposed model
+  fdsNewEdges :: Set EGEdgeId,
+  fdsDoneEdges :: Set EGEdgeId,
+  -- | expressions that need to be decomposed
+  fdsForceBool :: [ModelBool], fdsForcedBool :: Map ModelBool (FDBoolTerm s),
+  fdsForceInt :: [ModelInt], fdsForcedInt :: Map ModelInt (FDIntTerm s),
+  fdsForceCol :: [ModelCol],
+  -- | variable counter
+  fdsVars :: Int,
+
+  -- | already introduced integer variables/terms/constants/expressions 
+  fdsIntVars :: Map EGVarId (FDSpecInfoInt s),
+  -- | needed sets of possible types
+  fdsIntVarTypes :: Map EGVarId (Set (FDIntSpecTypeSet s)),
+  -- | which variables are being decomposed right now
+  fdsIntVarBusy :: Set EGVarId,
+  -- | which nodes are unified with which others
+  fdsIntUnifies :: Map EGVarId (Set EGVarId),
+
+  -- | already introduced boolean variables/terms/constants/expressions 
+  fdsBoolVars :: Map EGVarId (FDSpecInfoBool s),
+  fdsBoolVarTypes :: Map EGVarId (Set (FDBoolSpecTypeSet s)),
+  fdsBoolVarBusy :: Set EGVarId,
+  fdsBoolUnifies :: Map EGVarId (Set EGVarId),
+  -- | already introduced collection variables/terms/constants/expressions 
+  fdsColVars :: Map EGVarId (FDSpecInfoCol s),
+  fdsColVarTypes :: Map EGVarId (Set (FDColSpecTypeSet s)),
+  fdsColVarBusy :: Set EGVarId,
+  fdsColUnifies :: Map EGVarId (Set EGVarId),
+
+  -- | db of specifiers
+  fdsDb :: SpecDb s,
+
+  -- | solver is failed?
+  fdsFailed :: Bool,
+
+  -- | level of nesting
+  fdsLevel :: Int,
+
+  -- | levels of dummyness
+  fdsDummyLevel :: Int,
+
+  fdsMinimizeVar :: Maybe ModelInt,
+  fdsMinimizeTerm :: Maybe (FDIntTerm s)
+}
+
+myFromJust str m = case m of
+  Nothing -> error $ "myFromJust: " ++ str
+  Just x -> x
+
+unifyInts a b = do
+  s <- get
+  let sa = Map.findWithDefault (Set.singleton a) a (fdsIntUnifies s)
+  let sb = Map.findWithDefault (Set.singleton b) b (fdsIntUnifies s)
+  let sc = Set.union sa sb
+  put s { fdsIntUnifies = foldr (\a b -> Map.insert a sc b) (fdsIntUnifies s) $ Set.toList sc }
+
+unifyBools a b = do
+  s <- get
+  let sa = Map.findWithDefault (Set.singleton a) a (fdsBoolUnifies s)
+  let sb = Map.findWithDefault (Set.singleton b) b (fdsBoolUnifies s)
+  let sc = Set.union sa sb
+  put s { fdsBoolUnifies = foldr (\a b -> Map.insert a sc b) (fdsBoolUnifies s) $ Set.toList sc }
+
+unifyCols a b = do
+  s <- get
+  let sa = Map.findWithDefault (Set.singleton a) a (fdsColUnifies s)
+  let sb = Map.findWithDefault (Set.singleton b) b (fdsColUnifies s)
+  let sc = Set.union sa sb
+  put s { fdsColUnifies = foldr (\a b -> Map.insert a sc b) (fdsColUnifies s) $ Set.toList sc }
+
+mapVals :: Show b => (a -> Maybe b) -> [a] -> [String]
+mapVals f l = nub $ sort $ map show $ catMaybes $ map f l
+
+dumpSpec :: FDSolver s => FDState s -> String
+dumpSpec s = 
+  foldl (++) "" (map (\(i,r) -> "i" ++ (show $ unVarId i) ++ "\n" ++ foldl (++) "" (map (\x -> "  "++x++"\n") (mapVals (fdspIntSpec r) (Nothing : (map Just $ Set.toList $ fdspIntTypes r))))) $ Map.toList (fdsIntVars s)) ++
+  foldl (++) "" (map (\(i,r) -> "b" ++ (show $ unVarId i) ++ "\n" ++ foldl (++) "" (map (\x -> "  "++x++"\n") (mapVals (fdspBoolSpec r) (Nothing : (map Just $ Set.toList $ fdspBoolTypes r))))) $ Map.toList (fdsBoolVars s)) ++
+  foldl (++) "" (map (\(i,r) -> "c" ++ (show $ unVarId i) ++ "\n" ++ foldl (++) "" (map (\x -> "  "++x++"\n") (mapVals (fdspColSpec r) (Nothing : (map Just $ Set.toList $ fdspColTypes r))))) $ Map.toList (fdsColVars s))
+
+setMinimizeVar :: (Show (FDIntTerm s), FDSolver s) => ModelInt -> FDInstance s ()
+setMinimizeVar v = do
+  s <- get
+  case Map.lookup v (fdsForcedInt s) of
+    Just t -> debug ("setMinimizeVar: (cached) var="++(show v)++" term="++(show t)) $ put s { fdsMinimizeVar = Just v, fdsMinimizeTerm = Just t }
+    Nothing -> do
+      var <- getSingleIntTerm v
+      s2 <-  get
+      debug ("setMinimizeVar: (not cached) var="++(show v)++" term="++(show var)) $ put s2 { fdsMinimizeVar = Just v, fdsMinimizeTerm = Just var }
+
+getMinimizeVar :: (Show (FDIntTerm s), FDSolver s) => FDInstance s (Maybe ModelInt)
+getMinimizeVar = do
+  s <- get
+  return $ fdsMinimizeVar s
+
+getMinimizeTerm :: (Show (FDIntTerm s), FDSolver s) => FDInstance s (Maybe (FDIntTerm s))
+getMinimizeTerm = do
+  s <- get
+  debug ("getMinimizeTerm: "++(show $ fdsMinimizeTerm s)) $ return ()
+  return (fdsMinimizeTerm s)
+--  case (fdsMinimizeTerm s) of
+--    q@(Just _) -> return q
+--    Nothing -> case (fdsMinimizeVar s) of
+--      Nothing -> return Nothing
+--      Just v -> do
+--        q <- getSingleIntTerm v
+--        put s { fdsMinimizeTerm = Just q }
+--        return $ Just q
+
+boundMinimize :: (Show (FDIntTerm s), FDSolver s, EnumTerm s (FDIntTerm s), Integral (TermBaseType s (FDIntTerm s))) => NewBound (FDInstance s)
+boundMinimize = do
+  bound <- getMinimizeTerm
+  case bound of
+    Nothing -> error "no bound variable defined"
+    Just bndvar -> do
+      x <- liftFD $ getValue bndvar
+      case x of
+        Just val -> do
+          con <- liftFD $ fdConstrainIntTerm bndvar (toInteger val)
+          let f = Bound (\x -> (Add (Right con) x))
+          return f
+        _ -> error "bound variable is not assigned"
+
+runFD :: FDSolver s => FDInstance s a -> s a
+runFD (FDInstance { unFDInstance = u }) = evalStateT u baseFDState
+
+linkExterns :: FDSolver s => (Int -> Maybe (FDSpecInfoBool s), Int -> Maybe (FDSpecInfoInt s), Int -> Maybe (FDSpecInfoCol s)) -> EGEdgeId -> FDInstance s ()
+linkExterns (sfb,sfi,sfc) id = do
+  s <- get
+  let Just jm = fdsModel s
+  let Just edge = Map.lookup id $ egmEdges jm
+  case (egeCons edge) of
+    EGBoolExtern p -> do
+      case sfb p of
+        Nothing -> return ()
+        Just spec -> do
+          let [varid] = boolData $ egeLinks edge
+          if (Map.member varid $ fdsBoolVars s) then error "double bool import" else return ()
+          put $ s { fdsBoolVars = Map.insert varid spec $ fdsBoolVars s, fdsBoolVarTypes = Map.delete varid $ fdsBoolVarTypes s }
+      markEdge id
+    EGIntExtern p -> do
+      case sfi p of
+        Nothing -> return ()
+        Just spec -> do
+          let [varid] = intData $ egeLinks edge
+          if (Map.member varid $ fdsIntVars s) then error "double int import" else return ()
+          put $ s { fdsIntVars = Map.insert varid spec $ fdsIntVars s, fdsIntVarTypes = Map.delete varid $ fdsIntVarTypes s }
+      markEdge id
+    EGColExtern p -> do
+      case sfc p of
+        Nothing -> return ()
+        Just spec -> do
+          let [varid] = colData $ egeLinks edge
+          if (Map.member varid $ fdsColVars s) then error "double col import" else return ()
+          put $ s { fdsColVars = Map.insert varid spec $ fdsColVars s, fdsColVarTypes = Map.delete varid $ fdsColVarTypes s }
+      markEdge id
+    _ -> return ()
+
+procSubModel :: FDSolver s => EGModel -> (Int -> FDSpecInfoBool s, Int -> FDSpecInfoInt s, Int -> FDSpecInfoCol s) -> FDInstance s ()
+procSubModel sm (fb,fi,fc) = procSubModelEx sm (Just . fb,Just . fi,Just . fc)
+
+procSubModelEx :: FDSolver s => EGModel -> (Int -> Maybe (FDSpecInfoBool s), Int -> Maybe (FDSpecInfoInt s), Int -> Maybe (FDSpecInfoCol s)) -> FDInstance s ()
+procSubModelEx sm specfn = do
+  s <- get
+  let ss = baseFDState {
+    fdsModel = Just sm,
+    fdsVars = fdsVars s,
+    fdsFailed = fdsFailed s,
+    fdsLevel = 1 + fdsLevel s
+  }
+  put ss
+  initForModel
+  s2 <- get
+  mapM_ (linkExterns specfn) $ Set.toList $ fdsNewEdges s2
+  process
+  s3 <- get
+  put $ s { fdsFailed = fdsFailed s || fdsFailed s3, fdsVars = fdsVars s3 }
+
+getLevel :: FDSolver s => FDInstance s Int
+getLevel = do
+  s <- get
+  return $ fdsLevel s
+
+-- specSubModelEx :: FDSolver s => EGModel -> (Int -> Maybe (FDSpecInfoBool s), Int -> Maybe (FDSpecInfoInt s), Int -> Maybe (FDSpecInfoCol s)) -> FDInstance s ()
+specSubModelEx sm specfn = do
+  s <- get
+  let ss = baseFDState {
+    fdsModel = Just sm,
+    fdsVars = fdsVars s,
+    fdsFailed = fdsFailed s,
+    fdsLevel = 1 + fdsLevel s
+  }
+  put ss
+  initForModel
+  s2 <- get
+  mapM_ (linkExterns specfn) $ Set.toList $ fdsNewEdges s2
+  s3 <- get
+  put s3 { fdsDummyLevel = 1 }
+  processEx False
+  s4 <- get
+  put $ s { fdsFailed = fdsFailed s || fdsFailed s4, fdsVars = fdsVars s4 }
+  return (fdsBoolVars s4, fdsIntVars s4, fdsColVars s4)
+
+optimizeSetSet :: Ord a => Set (Set a) -> Set (Set a)
+optimizeSetSet x = 
+  let (min,xx) = Set.deleteFindMin x
+      inter = Set.fold Set.intersection min xx
+      in if Set.null inter then x else Set.singleton inter
+
+optimizeVarTypes :: FDSolver s => FDInstance s ()
+optimizeVarTypes = do
+  s <- get
+  put $ s {
+    fdsBoolVarTypes = Map.map optimizeSetSet $ fdsBoolVarTypes s,
+    fdsIntVarTypes = Map.map optimizeSetSet $ fdsIntVarTypes s,
+    fdsColVarTypes = Map.map optimizeSetSet $ fdsColVarTypes s
+  }
+
+checkNeedSpecType var typ db = any (Set.member typ) $ Set.toList $ Map.findWithDefault Set.empty var db
+
+decompSpec fn db un unfn ex vars typs = do
+  s <- get
+  let tri [] = do
+        debug ("decompSpec vars="++(show vars)++": no spec left, failing") $ return ()
+        return Nothing
+      tri (((_,_,id),_):rest) | not (Set.member id vars) = tri rest
+      tri ((key@(_,_,id),(eid,s)):rest) = case ex s of
+        Nothing -> tri rest
+        Just spec -> do
+          res <- spec
+          case res of
+            SpecResNone -> tri rest
+            SpecResSpec (typ,spec) -> if Set.member typ typs
+              then do
+                rr <- liftFD spec
+                debug ("decompSpec: got spec: " ++ (show rr)) $ return ()
+                fn (Set.findMin vars) typ rr
+                case eid of
+                  Nothing -> return ()
+                  Just e -> do
+                    debug ("decompSpec: marking edge "++(show e)) $ return ()
+                    markEdge e
+                return $ Just (typ,rr)
+              else tri rest
+            SpecResUnify v -> do
+              unfn id v
+              decompSpec fn db un unfn ex vars typs
+  tri $ Map.toDescList $ db
+
+decompBestHelp id spec fn unfn eid prio db = do
+  res <- spec
+  case res of
+    SpecResNone -> do
+      debug ("decompBestHelp: level "++(show prio)++" specifier for var "++(show id)++" by edge "++(show eid)++" has failed") $ return ()
+      return ()
+    SpecResSpec (typ,ss) -> if checkNeedSpecType id typ db
+      then do
+        rr <- liftFD ss
+        res <- fn id typ rr
+        case eid of
+          Nothing -> return ()
+          Just e -> do
+            debug ("decompBestHelp: marking edge "++(show e)) $ return ()
+            markEdge e
+            return ()
+        return res
+      else do
+        debug ("decompBestHelp: typ "++(show typ)++" specifier for id "++(show id)++" seems not needed") $ return ()
+        return ()
+    SpecResUnify v -> do
+      unfn id v
+      return ()
+
+decompBest :: FDSolver s => FDInstance s Bool
+decompBest = do
+  s1 <- debug "in decompBest: get" $ get
+  debug "in decompBest" $ return ()
+  if Map.null $ fdsDb s1
+    then return False
+    else do
+      let (((prio,knd,id),(eid,spec)),nm) = Map.deleteFindMax $ fdsDb $ debug "s1?" s1
+          s2 = debug ("got best spec: prio="++(show prio)++", knd="++(show knd)++", id="++(show id)++", eid="++(show eid)++", spec=?") $ s1 { fdsDb = nm }
+      put s2
+      case knd of
+        FDTBool -> do
+          let s3 = s2 { fdsBoolVarBusy = Set.insert id $ fdsBoolVarBusy s2 }
+          put s3
+          let Just j = fdsBoolSel spec
+          decompBestHelp id j addBoolVar unifyBools eid prio $ fdsBoolVarTypes s3
+          s4 <- get
+          put $ s4 { fdsBoolVarBusy = Set.delete id $ fdsBoolVarBusy s4 }
+        FDTInt -> do
+          let s3 = s2 { fdsIntVarBusy = Set.insert id $ fdsIntVarBusy s2 }
+          put s3
+          let Just j = fdsIntSel spec
+          decompBestHelp id j addIntVar unifyInts eid prio $ fdsIntVarTypes s3
+          s4 <- get
+          put $ s4 { fdsIntVarBusy = Set.delete id $ fdsIntVarBusy s4 }
+        FDTCol -> do
+          let s3 = s2 { fdsColVarBusy = Set.insert id $ fdsColVarBusy s2 }
+          put s3
+          let Just j = fdsColSel spec
+          decompBestHelp id j addColVar unifyCols eid prio $ fdsColVarTypes s3
+          s4 <- get
+          put $ s4 { fdsColVarBusy = Set.delete id $ fdsColVarBusy s4 }
+      return True
+
+decompDefaultBool :: FDSolver s => FDInstance s Bool
+decompDefaultBool = do
+  s1 <- get
+  if Map.null $ fdsBoolVarTypes s1
+    then return False
+    else do
+      let ((varid,set),nm) = Map.deleteFindMin $ fdsBoolVarTypes s1
+          s2 = s1 { fdsBoolVarTypes = nm }
+      put s2
+      if Set.null set
+        then return True
+        else do
+          defaultBoolDecomp varid Nothing
+          return True
+
+decompDefaultInt :: FDSolver s => FDInstance s Bool
+decompDefaultInt = do
+  s1 <- get
+  if Map.null $ fdsIntVarTypes s1
+    then return False
+    else do
+      let ((varid,set),nm) = Map.deleteFindMin $ fdsIntVarTypes s1
+          s2 = s1 { fdsIntVarTypes = nm }
+      put s2
+      if Set.null set
+        then return True
+        else do
+          defaultIntDecomp varid Nothing
+          return True
+
+defaultBoolDecomp :: FDSolver s => EGVarId -> (Maybe (FDBoolSpecTypeSet s)) -> FDInstance s (Maybe (FDBoolSpecType s, FDBoolSpec s))
+defaultBoolDecomp var typs = do
+  s <- get
+  if fdsDummyLevel s > 0 
+    then return Nothing
+    else do
+      vt <- liftFD $ fdTypeVarBool
+      let Just jt = typs
+      if (isNothing typs || not (Set.null $ Set.intersection vt jt))
+        then do
+          Just v <- fdNewvar
+          let (ty,sp) = fdBoolSpec_term v
+          rs <- liftFD sp
+          addBoolVar var ty (rs, Nothing)
+          return $ Just (ty,rs)
+        else return Nothing
+
+defaultIntDecomp :: FDSolver s => EGVarId -> (Maybe (FDIntSpecTypeSet s)) -> FDInstance s (Maybe (FDIntSpecType s, FDIntSpec s))
+defaultIntDecomp var typs = do
+  s <- get
+  if fdsDummyLevel s > 0
+    then return Nothing
+    else do
+      vt <- liftFD $ fdTypeVarInt
+      let Just jt = typs
+      if (isNothing typs || not (Set.null $ Set.intersection vt jt))
+        then do
+          Just v <- fdNewvar
+          let (ty,sp) = fdIntSpec_term v
+          rs <- liftFD sp
+          addIntVar var ty (rs, Nothing)
+          return $ Just (ty,rs)
+        else return Nothing
+
+getBoolSpec_ :: FDSolver s => EGVarId -> FDBoolSpecTypeSet s -> FDInstance s (Maybe (FDBoolSpecType s, FDBoolSpec s))
+getBoolSpec_ var typs = do
+  s <- get
+  let vars = Map.findWithDefault (Set.singleton var) var $ fdsBoolUnifies s
+  getBoolSpec__ vars typs
+
+getBoolSpec__ :: FDSolver s => Set EGVarId -> FDBoolSpecTypeSet s -> FDInstance s (Maybe (FDBoolSpecType s, FDBoolSpec s))
+getBoolSpec__ vars typs = do
+  s <- get
+  let mp = foldl (\b a -> case Map.lookup a (fdsBoolVars s) of { Nothing -> b; Just x -> case b of { Nothing -> Just x; Just r -> Just $ unionSpecBool r x }}) Nothing (Set.toList vars)
+  let sp = Set.intersection (maybe Set.empty fdspBoolTypes mp) typs
+  let db = fdsDb s
+  if Set.null sp
+    then if not (Set.null $ Set.intersection vars $ fdsBoolVarBusy s)
+      then return Nothing
+      else do
+        put $ s { fdsBoolVarBusy = Set.union vars $ fdsBoolVarBusy s }
+        res <- decompSpec addBoolVar db (\x -> Map.lookup x $ fdsBoolUnifies s) unifyBools fdsBoolSel vars typs
+        s2 <- get
+        put $ s2 { fdsBoolVarBusy = Set.difference (fdsBoolVarBusy s) vars }
+        case res of
+          Just (tp,(sp,_)) -> return $ Just (tp,sp)
+          _ -> defaultBoolDecomp (Set.findMin vars) $ Just typs
+    else do
+      let lp = Set.findMin sp
+      let Just jmp = mp
+      let Just j = fdspBoolSpec jmp $ Just lp
+      return $ Just (lp,j)
+
+getBoolSpec :: FDSolver s => EGVarId -> FDInstance s (Maybe (FDBoolSpec s))
+getBoolSpec var = do
+  s <- allBoolSpec
+  q <- getBoolSpec_ var s
+  return $ case q of
+    Just (_,x) -> Just x
+    Nothing -> Nothing
+
+getIntSpec_ :: FDSolver s => EGVarId -> FDIntSpecTypeSet s -> FDInstance s (Maybe (FDIntSpecType s, FDIntSpec s))
+getIntSpec_ var typs = do
+  s <- get
+  let vars = Map.findWithDefault (Set.singleton var) var $ fdsIntUnifies s
+  getIntSpec__ vars typs
+
+getIntSpec__ :: FDSolver s => Set EGVarId -> FDIntSpecTypeSet s -> FDInstance s (Maybe (FDIntSpecType s, FDIntSpec s))
+getIntSpec__ vars typs = do
+  s <- get
+  let mp = foldl (\b a -> case Map.lookup a (fdsIntVars s) of { Nothing -> b; Just x -> case b of { Nothing -> Just x; Just r -> Just $ unionSpecInt r x }}) Nothing $ Set.toList vars
+  let sp = Set.intersection (maybe Set.empty fdspIntTypes mp) typs
+  let db = fdsDb s
+  if Set.null sp
+    then if not (Set.null $ Set.intersection vars $ fdsIntVarBusy s)
+      then do
+        debug ("getIntSpec__ "++(show (vars,typs))++": busy, failing") $ return ()
+        return Nothing
+      else do
+        put $ s { fdsIntVarBusy = Set.union vars $ fdsIntVarBusy s }
+        res <- decompSpec addIntVar db (\x -> Map.lookup x $ fdsIntUnifies s) unifyInts fdsIntSel vars typs
+        s2 <- get
+        put $ s2 { fdsIntVarBusy = Set.difference (fdsIntVarBusy s) vars }
+        case res of
+          Just (tp,(sp,_)) -> return $ Just (tp,sp)
+          _ -> defaultIntDecomp (Set.findMin vars) $ Just typs
+    else do
+      let lp = Set.findMin sp
+      let Just jmp = mp
+      let Just j = fdspIntSpec jmp $ Just lp
+      return $ Just (lp,j)
+
+getIntSpec :: FDSolver s => EGVarId -> FDInstance s (Maybe (FDIntSpec s))
+getIntSpec var = do
+  s <- allIntSpec
+  q <- getIntSpec_ var s
+  return $ case q of
+    Just (_,x) -> Just x
+    Nothing -> Nothing
+
+getColSpec_ :: FDSolver s => EGVarId -> FDColSpecTypeSet s -> FDInstance s (Maybe (FDColSpecType s, FDColSpec s))
+getColSpec_ var typs = do
+  s <- get
+  let vars = Map.findWithDefault (Set.singleton var) var $ fdsColUnifies s
+  getColSpec__ vars typs
+
+getColSpec__ :: FDSolver s => Set EGVarId -> FDColSpecTypeSet s -> FDInstance s (Maybe (FDColSpecType s, FDColSpec s))
+getColSpec__ vars typs = do
+  s <- get
+  let mp = foldl (\b a -> case Map.lookup a (fdsColVars s) of { Nothing -> b; Just x -> case b of { Nothing -> Just x; Just r -> Just $ unionSpecCol r x }}) Nothing (Set.toList vars)
+  let sp = Set.intersection (maybe Set.empty fdspColTypes mp) typs
+  let db = fdsDb s
+  if Set.null sp
+    then if not (Set.null $ Set.intersection vars $ fdsColVarBusy s)
+      then return Nothing
+      else do
+        put $ s { fdsColVarBusy = Set.union vars $ fdsColVarBusy s }
+        res <- decompSpec addColVar db (\x -> Map.lookup x $ fdsColUnifies s) unifyCols fdsColSel vars typs
+        s2 <- get
+        put $ s2 { fdsColVarBusy = Set.difference (fdsColVarBusy s) vars }
+        case res of
+          Just (tp,(sp,_)) -> return $ Just (tp,sp)
+          _ -> return Nothing
+    else do
+      let lp = Set.findMin sp
+      let Just jmp = mp
+      let Just j = fdspColSpec jmp $ Just lp
+      return $ Just (lp,j)
+
+getColSpec :: (Show (FDColSpec s), FDSolver s) => EGVarId -> FDInstance s (Maybe (FDColSpec s))
+getColSpec var = do
+  s <- allColSpec
+  q <- getColSpec_ var s
+  return $ case q of
+    Just (_,x) -> Just x
+    Nothing -> Nothing
+
+-- | initial FDState state 
+baseFDState :: FDSolver s => FDState s
+baseFDState = FDState {
+  fdsVars = 0,
+  fdsExpr = BoolConst True,
+  fdsForceBool = [],
+  fdsForcedBool = Map.empty,
+  fdsForceInt = [],
+  fdsForcedInt = Map.empty,
+  fdsForceCol = [],
+  fdsModel = Nothing,
+  fdsNewEdges = Set.empty,
+  fdsDoneEdges = Set.empty,
+  fdsDecomp = baseDecompData,
+  fdsIntVars = Map.empty,
+  fdsIntVarTypes = Map.empty,
+  fdsIntVarBusy = Set.empty,
+  fdsIntUnifies = Map.empty,
+  fdsBoolVars = Map.empty,
+  fdsBoolVarTypes = Map.empty,
+  fdsBoolVarBusy = Set.empty,
+  fdsBoolUnifies = Map.empty,
+  fdsColVars = Map.empty,
+  fdsColVarTypes = Map.empty,
+  fdsColVarBusy = Set.empty,
+  fdsColUnifies = Map.empty,
+  fdsDb = Map.empty,
+  fdsFailed = False,
+  fdsLevel = 0,
+  fdsDummyLevel = 0,
+  fdsMinimizeVar = Nothing,
+  fdsMinimizeTerm = Nothing
+}
+
+edgesLeft :: FDSolver s => FDInstance s Bool
+edgesLeft = get >>= return . Set.null . fdsNewEdges
+
+-- | run the second argument as long as the first one produces true
+whileM :: Monad m => m Bool -> m a -> m ()
+whileM cond act = do
+  x <- cond
+  if x
+    then do
+      act
+      whileM cond act
+    else return ()
+
+whileM_ :: Monad m => m Bool -> m ()
+whileM_ cond = whileM cond $ return ()
+
+-- | a label for an FDInstance; must store the FDState plus the Solver's internal state
+data FDSolver s => FDLabel s = FDLabel {
+  fdlState :: FDState s,
+  fdlLabel :: Label s
+}
+
+-- | definition of FDInstance, a Solver wrapper that adds power to post boolean expressions as constraints
+newtype FDSolver s => FDInstance s a = FDInstance { unFDInstance :: StateT (FDState s) s a }
+  deriving (Monad, Applicative, Functor, MonadState (FDState s))
+
+-- | helper function to combine two Maybe's
+joinWith :: (a -> a -> a) -> Maybe a -> Maybe a -> Maybe a
+joinWith f a b = case (a,b) of
+  (Nothing,_) -> b
+  (_,Nothing) -> a
+  (Just x,Just y) -> Just $ f x y
+
+-- | lift a monad action for the underlying solver to a monad action for an FDInstance around it
+liftFD :: FDSolver s => s a -> FDInstance s a
+liftFD = FDInstance . lift
+
+liftFDTree :: (FDSolver s, MonadTree m, TreeSolver m ~ (FDInstance s)) => Tree s a -> m a
+liftFDTree = mapTree liftFD
+
+data SpecResult t =
+    SpecResNone
+  | SpecResSpec t
+  | SpecResUnify EGVarId
+
+type SpecBool s = FDInstance s (SpecResult (FDBoolSpecType s, s (FDBoolSpec s, Maybe EGBoolPar)))
+type SpecInt s = FDInstance s (SpecResult (FDIntSpecType s, s (FDIntSpec s, Maybe EGPar)))
+type SpecCol s = FDInstance s (SpecResult (FDColSpecType s, s (FDColSpec s, Maybe EGColPar)))
+
+type SpecFnRes s = 
+  (
+    [(Int, EGVarId, Bool, SpecBool s)],
+    [(Int, EGVarId, Bool, SpecInt s)],
+    [(Int, EGVarId, Bool, SpecCol s)]
+  )
+
+type SpecFn s = EGEdge -> SpecFnRes s
+
+data TermType = FDTBool | FDTInt | FDTCol
+  deriving (Eq,Ord,Bounded,Enum,Show)
+
+fdsBoolSel x = case x of
+  FDSBool a -> Just a
+  _ -> Nothing
+fdsIntSel x = case x of
+  FDSInt a -> Just a
+  _ -> Nothing
+fdsColSel x = case x of
+  FDSCol a -> Just a
+  _ -> Nothing
+
+data TermTypeSpec s = FDSBool (SpecBool s) | FDSInt (SpecInt s) | FDSCol (SpecCol s)
+
+instance Show (TermTypeSpec s) where
+  show (FDSBool _) = "FDSBool"
+  show (FDSInt _) = "FDSInt"
+  show (FDSCol _) = "FDSCol"
+
+type SpecDb s = Map (Int,TermType,EGVarId) (Maybe EGEdgeId,TermTypeSpec s)
+
+addBoolSpec :: FDSolver s => SpecDb s -> (Int,EGVarId,Maybe EGEdgeId,SpecBool s) -> SpecDb s
+addBoolSpec db (prio,var,eid,spec) = Map.insert (prio,FDTBool,var) (eid,FDSBool spec) db
+
+addIntSpec :: FDSolver s => SpecDb s -> (Int,EGVarId,Maybe EGEdgeId,SpecInt s) -> SpecDb s
+addIntSpec db (prio,var,eid,spec) = Map.insert (prio,FDTInt,var) (eid,FDSInt spec) db
+
+addColSpec :: FDSolver s => SpecDb s -> (Int,EGVarId,Maybe EGEdgeId,SpecCol s) -> SpecDb s
+addColSpec db (prio,var,eid,spec) = Map.insert (prio,FDTCol,var) (eid,FDSCol spec) db
+
+emptyFDSpecInfoBool :: FDSolver s => EGVarId -> FDState s -> FDSpecInfoBool s
+emptyFDSpecInfoBool v s = FDSpecInfoBool { fdspBoolSpec = const Nothing, fdspBoolVar = Just v, fdspBoolVal = getBoolVal_ v s, fdspBoolTypes = Set.empty }
+emptyFDSpecInfoInt :: FDSolver s => EGVarId -> FDState s -> FDSpecInfoInt s
+emptyFDSpecInfoInt v s = FDSpecInfoInt { fdspIntSpec = const Nothing, fdspIntVar = Just v, fdspIntVal = getIntVal_ v s, fdspIntTypes = Set.empty }
+emptyFDSpecInfoCol :: FDSolver s => EGVarId -> FDState s -> FDSpecInfoCol s
+emptyFDSpecInfoCol v s = FDSpecInfoCol { fdspColSpec = const Nothing, fdspColVar = Just v, fdspColVal = getColVal_ v s, fdspColTypes = Set.empty }
+
+data FDSpecInfoBool s = FDSpecInfoBool { fdspBoolSpec :: Maybe (FDBoolSpecType s) -> Maybe (FDBoolSpec s), fdspBoolVar :: Maybe EGVarId, fdspBoolVal :: Maybe EGBoolPar, fdspBoolTypes :: Set (FDBoolSpecType s) }
+data FDSpecInfoInt s = FDSpecInfoInt   { fdspIntSpec  :: Maybe (FDIntSpecType s)  -> Maybe (FDIntSpec s),  fdspIntVar ::  Maybe EGVarId, fdspIntVal ::  Maybe EGPar, fdspIntTypes :: Set (FDIntSpecType s) }
+data FDSpecInfoCol s = FDSpecInfoCol   { fdspColSpec  :: Maybe (FDColSpecType s)  -> Maybe (FDColSpec s),  fdspColVar ::  Maybe EGVarId, fdspColVal ::  Maybe EGColPar, fdspColTypes :: Set (FDColSpecType s) }
+
+unionSpecBool (FDSpecInfoBool { fdspBoolSpec = s1, fdspBoolVar = n1, fdspBoolVal = v1, fdspBoolTypes = t1 }) (FDSpecInfoBool { fdspBoolSpec = s2, fdspBoolVar = n2, fdspBoolVal = v2, fdspBoolTypes = t2 }) =
+  FDSpecInfoBool { fdspBoolSpec = \t -> (s1 t) `mplus` (s2 t), fdspBoolVal = v1 `mplus` v2, fdspBoolVar = n1 `mplus` n2, fdspBoolTypes = Set.union t1 t2 }
+unionSpecInt (FDSpecInfoInt { fdspIntSpec = s1, fdspIntVar = n1, fdspIntVal = v1, fdspIntTypes = t1 }) (FDSpecInfoInt { fdspIntSpec = s2, fdspIntVar = n2, fdspIntVal = v2, fdspIntTypes = t2 }) =
+  FDSpecInfoInt { fdspIntSpec = \t -> (s1 t) `mplus` (s2 t), fdspIntVal = v1 `mplus` v2, fdspIntVar = n1 `mplus` n2, fdspIntTypes = Set.union t1 t2 }
+unionSpecCol (FDSpecInfoCol { fdspColSpec = s1, fdspColVar = n1, fdspColVal = v1, fdspColTypes = t1 }) (FDSpecInfoCol { fdspColSpec = s2, fdspColVar = n2, fdspColVal = v2, fdspColTypes = t2 }) =
+  FDSpecInfoCol { fdspColSpec = \t -> (s1 t) `mplus` (s2 t), fdspColVal = v1 `mplus` v2, fdspColVar = n1 `mplus` n2, fdspColTypes = Set.union t1 t2 }
+
+instance (Ord (FDBoolSpec s), Ord (FDBoolSpecType s)) => Eq (FDSpecInfoBool s) where
+  a == b = (compare a b) == EQ
+instance (Ord (FDBoolSpec s), Ord (FDBoolSpecType s)) => Ord (FDSpecInfoBool s) where
+  compare (FDSpecInfoBool { fdspBoolSpec = s1, fdspBoolVar = r1, fdspBoolVal = v1, fdspBoolTypes = t1 }) (FDSpecInfoBool { fdspBoolSpec = s2, fdspBoolVar = r2, fdspBoolVal = v2, fdspBoolTypes = t2 }) =
+    compare r1 r2 <<>> compare v1 v2 <<>> compare (s1 Nothing) (s2 Nothing) <<>> compare (Map.fromList $ map (\x -> (x,s1 $ Just x)) $ Set.toList t1) (Map.fromList $ map (\x -> (x,s2 $ Just x)) $ Set.toList t2)
+
+instance (Ord (FDIntSpec s), Ord (FDIntSpecType s)) => Eq (FDSpecInfoInt s) where
+  a == b = (compare a b) == EQ
+instance (Ord (FDIntSpec s), Ord (FDIntSpecType s)) => Ord (FDSpecInfoInt s) where
+  compare (FDSpecInfoInt { fdspIntSpec = s1, fdspIntVar = r1, fdspIntVal = v1, fdspIntTypes = t1 }) (FDSpecInfoInt { fdspIntSpec = s2, fdspIntVar = r2, fdspIntVal = v2, fdspIntTypes = t2 }) =
+    compare r1 r2 <<>> compare v1 v2 <<>> compare (s1 Nothing) (s2 Nothing) <<>> compare (Map.fromList $ map (\x -> (x,s1 $ Just x)) $ Set.toList t1) (Map.fromList $ map (\x -> (x,s2 $ Just x)) $ Set.toList t2)
+
+instance (Ord (FDColSpec s), Ord (FDColSpecType s)) => Eq (FDSpecInfoCol s) where
+  a == b = (compare a b) == EQ
+instance (Ord (FDColSpec s), Ord (FDColSpecType s)) => Ord (FDSpecInfoCol s) where
+  compare (FDSpecInfoCol { fdspColSpec = s1, fdspColVar = r1, fdspColVal = v1, fdspColTypes = t1 }) (FDSpecInfoCol { fdspColSpec = s2, fdspColVar = r2, fdspColVal = v2, fdspColTypes = t2 }) =
+    compare r1 r2 <<>> compare v1 v2 <<>> compare (s1 Nothing) (s2 Nothing) <<>> compare (Map.fromList $ map (\x -> (x,s1 $ Just x)) $ Set.toList t1) (Map.fromList $ map (\x -> (x,s2 $ Just x)) $ Set.toList t2)
+
+specInfoMapBool :: FDSolver s => FDSpecInfoBool s -> Map (FDBoolSpecType s) (FDBoolSpec s)
+specInfoMapBool (FDSpecInfoBool { fdspBoolSpec = f, fdspBoolTypes = t }) = Map.fromList $ map (\t -> (t,myFromJust "specInfoMapBool" $ f $ Just t)) $ Set.toList t
+
+specInfoMapInt :: FDSolver s => FDSpecInfoInt s -> Map (FDIntSpecType s) (FDIntSpec s)
+specInfoMapInt (FDSpecInfoInt { fdspIntSpec = f, fdspIntTypes = t }) = Map.fromList $ map (\t -> (t,myFromJust "specInfoMapInt" $ f $ Just t)) $ Set.toList t
+
+specInfoMapCol :: FDSolver s => FDSpecInfoCol s -> Map (FDColSpecType s) (FDColSpec s)
+specInfoMapCol (FDSpecInfoCol { fdspColSpec = f, fdspColTypes = t }) = Map.fromList $ map (\t -> (t,myFromJust "specInfoMapCol" $ f $ Just t)) $ Set.toList t
+
+specInfoBoolTerm :: FDSolver s => FDBoolTerm s -> s (FDSpecInfoBool s)
+specInfoBoolTerm t = do
+  let (tp,sp) = fdBoolSpec_term t
+  s <- sp
+  return $ FDSpecInfoBool { fdspBoolSpec = \t -> case t of { Nothing -> Just s; Just tt | tp==tt -> Just s; _ -> Nothing }, fdspBoolVar = Nothing, fdspBoolVal = Nothing, fdspBoolTypes = Set.singleton tp }
+
+specInfoIntTerm :: FDSolver s => FDIntTerm s -> s (FDSpecInfoInt s)
+specInfoIntTerm t = do
+  let (tp,sp) = fdIntSpec_term t
+  s <- sp
+  return $ FDSpecInfoInt { fdspIntSpec = \t -> case t of { Nothing -> Just s; Just tt | tp==tt -> Just s; _ -> Nothing }, fdspIntVar = Nothing, fdspIntVal = Nothing, fdspIntTypes = Set.singleton tp }
+
+instance Show (FDBoolSpec s) => Show (FDSpecInfoBool s) where
+  show (FDSpecInfoBool { fdspBoolSpec = f, fdspBoolVar = e, fdspBoolVal = v }) = "FSSpecInfoBool { default:" ++ (show $ f Nothing) ++ ", var:" ++ (show e) ++ ", val:" ++ (show v) ++ "}"
+instance Show (FDIntSpec s) => Show (FDSpecInfoInt s) where
+  show (FDSpecInfoInt { fdspIntSpec = f, fdspIntVar = e, fdspIntVal = v }) = "FSSpecInfoInt { default:" ++ (show $ f Nothing) ++ ", var:" ++ (show e) ++ ", val:" ++ (show v) ++ "}"
+instance Show (FDColSpec s) => Show (FDSpecInfoCol s) where
+  show (FDSpecInfoCol { fdspColSpec = f, fdspColVar = e, fdspColVal = v }) = "FSSpecInfoCol { default:" ++ (show $ f Nothing) ++ ", var:" ++ (show e) ++ ", val:" ++ (show v) ++ "}"
+
+type FDSpecInfo s = ([FDSpecInfoBool s],[FDSpecInfoInt s],[FDSpecInfoCol s])
+
+fdSpecInfo_edge :: FDSolver s => EGEdgeId -> FDInstance s (FDSpecInfo s)
+fdSpecInfo_edge f = do
+  s <- get
+  let edge = getJustEdge f s
+      intS p = Map.findWithDefault (emptyFDSpecInfoInt p s) p $ fdsIntVars s
+      boolS p = Map.findWithDefault (emptyFDSpecInfoBool p s) p $ fdsBoolVars s
+      colS p = Map.findWithDefault (emptyFDSpecInfoCol p s) p $ fdsColVars s
+--      an m x = case x of
+--        Just i -> Map.lookup i m
+--        Nothing -> if Map.null m then Nothing else Just $ snd $ Map.findMin m
+--      boolX v = FDSpecInfoBool { fdspBoolSpec = an $ boolS v, fdspBoolVar = Just v, fdspBoolVal = getBoolVal_ v s, fdspBoolTypes = Set.fromList $ Map.keys $ boolS v }
+--      intX v = FDSpecInfoInt { fdspIntSpec = an $ intS v, fdspIntVar = Just v, fdspIntVal = getIntVal_ v s, fdspIntTypes = Set.fromList $ Map.keys $ intS v }
+--      colX v = FDSpecInfoCol { fdspColSpec = an $ colS v, fdspColVar = Just v, fdspColVal = getColVal_ v s, fdspColTypes = Set.fromList $ Map.keys $ colS v }
+  return (map boolS $ boolData $ egeLinks edge, map intS $ intData $ egeLinks edge, map colS $ colData $ egeLinks edge)
+
+fdSpecInfo_spec :: FDSolver s => ([Either (FDSpecInfoBool s) (FDBoolSpecType s,FDBoolSpec s)],[Either (FDSpecInfoInt s) (FDIntSpecType s,FDIntSpec s)],[Either (FDSpecInfoCol s) (FDColSpecType s,FDColSpec s)]) -> FDSpecInfo s
+fdSpecInfo_spec (b,i,c) = (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.
+class 
+  (
+    Solver s, 
+    Term s (FDIntTerm s),
+    Term s (FDBoolTerm s),
+    Eq (FDBoolSpecType s), Ord (FDBoolSpecType s), Enum (FDBoolSpecType s), Bounded (FDBoolSpecType s), Show (FDBoolSpecType s),
+    Eq (FDIntSpecType s),  Ord (FDIntSpecType s),  Enum (FDIntSpecType s),  Bounded (FDIntSpecType s), Show (FDIntSpecType s),
+    Eq (FDColSpecType s),  Ord (FDColSpecType s),  Enum (FDColSpecType s),  Bounded (FDColSpecType s), Show (FDColSpecType s),
+--    Integral (TermBaseType s (FDIntTerm s)), Num (TermBaseType s (FDBoolTerm s)),
+    Show (FDIntSpec s), Show (FDColSpec s), Show (FDBoolSpec s)
+  ) => FDSolver s where
+  -- term types
+  type FDIntTerm s    :: *    -- a Term of s, representing Integer variables
+  type FDBoolTerm s   :: *    -- a Term of s, representing Bool variables
+  -- spec types
+  type FDIntSpec s    :: *    -- a type specifying an Integer expression; should at least support constant Integer's and FDIntTerm's
+  type FDBoolSpec s   :: *    -- a type specifying a Bool expression; should at least support constant Bool's and FDBoolTerm's
+  type FDColSpec s    :: *    -- a type specifying a Integer array expression; should at least support lists of Int's and lists of IntTerm's
+  -- spec type type
+  type FDIntSpecType s :: *   -- a type specifying the type of an FDIntSpec s, in case there is more than one
+  type FDBoolSpecType s :: *  -- a type specifying the type of an FDIntSpec s, in case there is more than one
+  type FDColSpecType s :: *   -- a type specifying the type of an FDIntSpec s, in case there is more than one
+  
+
+  -- constructors for specifiers
+  fdIntSpec_const     :: EGPar         -> (FDIntSpecType s, s (FDIntSpec s))
+  fdBoolSpec_const    :: EGBoolPar     -> (FDBoolSpecType s, s (FDBoolSpec s))
+  fdColSpec_const     :: EGColPar      -> (FDColSpecType s, s (FDColSpec s))
+  fdColSpec_list      :: [FDIntSpec s] -> (FDColSpecType s, s (FDColSpec s))
+  fdIntSpec_term      :: FDIntTerm s   -> (FDIntSpecType s, s (FDIntSpec s))
+  fdBoolSpec_term     :: FDBoolTerm s  -> (FDBoolSpecType s, s (FDBoolSpec s))
+  fdColSpec_size      :: EGPar         -> (FDColSpecType s, s (FDColSpec s))
+  fdIntVarSpec        :: FDIntSpec s   -> s (Maybe (FDIntTerm s))
+  fdBoolVarSpec       :: FDBoolSpec s  -> s (Maybe (FDBoolTerm s))
+
+  -- function to inform about allowed types for nodes
+  fdTypeReqBool :: s (EGEdge -> [(EGVarId,FDBoolSpecTypeSet s)])
+  fdTypeReqInt ::  s (EGEdge -> [(EGVarId,FDIntSpecTypeSet s)])
+  fdTypeReqCol ::  s (EGEdge -> [(EGVarId,FDColSpecTypeSet s)])
+  fdTypeReqBool = return (\(EGEdge { egeLinks = EGTypeData { boolData = l } }) -> map (\x -> (x,Set.fromList [minBound..maxBound])) l)
+  fdTypeReqInt = return (\(EGEdge { egeLinks = EGTypeData { intData = l } }) -> map (\x -> (x,Set.fromList [minBound..maxBound])) l)
+  fdTypeReqCol = return (\(EGEdge { egeLinks = EGTypeData { colData = l } }) -> map (\x -> (x,Set.fromList [minBound..maxBound])) l)
+
+  fdTypeVarInt :: s (Set (FDIntSpecType s))
+  fdTypeVarBool :: s (Set (FDBoolSpecType s))
+  fdTypeVarInt = return $ Set.singleton maxBound
+  fdTypeVarBool = return $ Set.singleton maxBound
+
+  -- rating functions for specification of terms
+  fdSpecify :: Mixin (SpecFn s)
+  fdSpecify = mixinId
+
+  -- inspect collections
+  fdColInspect :: FDColSpec s -> s [FDIntTerm s]
+
+  -- function to request processing an edge in a graph
+  fdProcess :: Mixin (EGConstraintSpec -> FDSpecInfo s -> FDInstance s ())
+
+  -- add equality constraints
+  fdEqualBool :: FDBoolSpec s -> FDBoolSpec s -> FDInstance s ()
+  fdEqualInt :: FDIntSpec s -> FDIntSpec s -> FDInstance s ()
+  fdEqualCol :: FDColSpec s -> FDColSpec s -> FDInstance s ()
+
+  fdConstrainIntTerm :: FDIntTerm s -> Integer -> s (Constraint s)
+  fdSplitIntDomain :: FDIntTerm s -> s ([Constraint s],Bool)
+  fdSplitBoolDomain :: FDBoolTerm s -> s ([Constraint s],Bool)
+
+fdGetValBool :: (FDSolver s, EnumTerm s (FDBoolTerm s)) => FDBoolSpec s -> s (Maybe (TermBaseType s (FDBoolTerm s)))
+fdGetValInt :: (FDSolver s, EnumTerm s (FDIntTerm s)) => FDIntSpec s -> s (Maybe (TermBaseType s (FDIntTerm s)))
+
+fdGetValBool s = fdBoolVarSpec s >>= \x -> case x of
+  Just t -> getValue t
+  _ -> return Nothing
+
+fdGetValInt s = fdIntVarSpec s >>= \x -> case x of
+  Just t -> getValue t
+  _ -> return Nothing
+
+type FDBoolSpecTypeSet s = Set (FDBoolSpecType s)
+type FDIntSpecTypeSet s = Set (FDIntSpecType s)
+type FDColSpecTypeSet s = Set (FDColSpecType s)
+
+fdCombineSpecify :: FDSolver s => SpecFn s -> SpecFn s -> SpecFn s
+fdCombineSpecify a b edge = 
+  let (a1,a2,a3) = a edge
+      (b1,b2,b3) = b edge
+      in (a1++b1,a2++b2,a3++b3)
+
+procEdge :: FDSolver s => FDInstance s Bool
+procEdge = do
+  s <- get
+  if (Set.null $ fdsNewEdges s)
+    then return False
+    else do
+      let f = Set.findMin $ fdsNewEdges s
+          edge = getJustEdge f s
+      debug ("procEdge("++(show f)++")") $ return ()
+      info <- fdSpecInfo_edge f
+      full_fdProcess (egeCons edge) info
+      debug ("procEdge: marking edge "++(show f)) $ return ()
+      markEdge f
+      s2 <- get
+      return $ not $ Set.null $ fdsNewEdges s2
+
+getEdge :: FDSolver s => EGEdgeId -> FDInstance s (Maybe EGEdge)
+getEdge id = do
+  s <- get
+  return $ do
+    v <- fdsModel s
+    Map.lookup id $ egmEdges v
+
+markEdge :: FDSolver s => EGEdgeId -> FDInstance s ()
+markEdge id = do
+  s <- get
+  debug ("markEdge: "++(show $ id)) $ return ()
+  put $ s { fdsNewEdges = Set.delete id $ fdsNewEdges s, fdsDoneEdges = Set.insert id $ fdsDoneEdges s }
+
+sureMaybe :: [Maybe a] -> Maybe [a]
+sureMaybe [] = Just []
+sureMaybe (Nothing:_) = Nothing
+sureMaybe ((Just a):b) = case sureMaybe b of
+  Nothing -> Nothing
+  Just l -> Just (a:l)
+
+allIntSpec :: FDSolver s => FDInstance s (Set (FDIntSpecType s))
+allIntSpec = return $ Set.fromList [minBound..maxBound]
+
+allBoolSpec :: FDSolver s => FDInstance s (Set (FDBoolSpecType s))
+allBoolSpec = return $ Set.fromList [minBound..maxBound]
+
+allColSpec :: FDSolver s => FDInstance s (Set (FDColSpecType s))
+allColSpec = return $ Set.fromList [minBound..maxBound]
+
+default_fdSpecify :: FDSolver s => SpecFn s
+default_fdSpecify edge = case (debug ("default_fdSpecify("++(show edge)++")") edge) of
+  EGEdge { egeCons = EGIntValue c, egeLinks = EGTypeData { intData = [v] } } ->
+    ([],[(1000,v,True,do
+      let (tp, m) = fdIntSpec_const c
+      return $ SpecResSpec (tp,m >>= (\x -> return (x, Just c)))
+    )],[])
+  EGEdge { egeCons = EGBoolValue c, egeLinks = EGTypeData { boolData = [v] } } ->
+    ([(1000,v,True,do
+      let (tp, m) = fdBoolSpec_const c
+      return $ SpecResSpec (tp, m >>= (\x -> return (x, Just c)))
+    )],[],[])
+  EGEdge { egeCons = EGColValue c, egeLinks = EGTypeData { colData = [v] } } ->
+    ([],[],[(990,v,True,do
+      let (tp, m) = fdColSpec_const c
+      return $ SpecResSpec (tp, m >>= (\x -> return (x, Just c)))
+    )])
+  EGEdge { egeCons = EGList s, egeLinks = EGTypeData { colData = [c], intData = l } } -> 
+    ([],[],[(500,c,True,do
+      x <- mapM (\x -> getIntSpec x) l
+      case sureMaybe x of
+        Nothing -> return SpecResNone
+        Just ll -> do
+          let (tp, m) = fdColSpec_list ll
+          return $ SpecResSpec $ (tp, m >>= (\x -> return (x, Nothing)))
+    )])
+  EGEdge { egeCons = EGSize, egeLinks = EGTypeData { colData = [c], intData=[s] } } ->
+    ([],[],[(250,c,True,do
+      ss <- get
+      let k = getIntVal_ s ss
+      case k of
+        Nothing -> return SpecResNone
+        Just ll -> do
+          let (tp, m) = fdColSpec_size ll
+          return $ SpecResSpec $ (tp, m >>= (\x -> return (x, Nothing)))
+     )])
+  EGEdge { egeCons = EGRange, egeLinks = EGTypeData { colData = [c], intData=[l,h] } } ->
+    ([],[],[(250,c,False,do
+      ss <- get
+      let ll = getIntVal_ l ss
+          hh = getIntVal_ h ss
+      case (ll,hh) of
+        (Just (Const jl), Just (Const jh)) -> do
+          let (tp,m) = fdColSpec_size (Const $ jh-jl+1)
+          return $ SpecResSpec $ (tp, m >>= (\x -> return (x, Just $ ColList [Const x | x <- [jl..jh]])))
+        (Just jl, Just jh) -> do
+          let (tp,m) = fdColSpec_size (jh-jl+1)
+          return $ SpecResSpec $ (tp, m >>= (\x -> return (x, Nothing)))
+        _ -> return SpecResNone
+     )])
+  _ -> ([],[],[])
+
+default_fdProcess :: FDSolver s => EGConstraintSpec -> FDSpecInfo s -> FDInstance s ()
+default_fdProcess cons _ = error $ "Cannot process "++(show cons)
+
+-- | mark all new edges(=constraints) of a model given in graph-form as to-be-processed
+initForModel :: FDSolver s => FDInstance s ()
+initForModel = do
+  s <- get
+  let Just model = fdsModel s
+  put $ s { 
+    fdsNewEdges = Set.difference (Set.union (fdsNewEdges s) $ Set.fromList $ Map.keys $ egmEdges model) $ fdsDoneEdges s
+  }
+
+setAlter :: Ord a => a -> Maybe (Set (Set a)) -> Maybe (Set (Set a))
+setAlter _ Nothing = Nothing
+setAlter typ (Just x) = let f = fl x in if Set.null f then Nothing else Just f
+  where fl = Set.filter $ not . Set.member typ
+
+addSpecInt :: FDSolver s => FDIntSpecType s -> (FDIntSpec s, Maybe EGPar) -> EGVarId -> FDState s -> Maybe (FDSpecInfoInt s) -> Maybe (FDSpecInfoInt s)
+addSpecInt tp def id s Nothing = addSpecInt tp def id s (Just $ emptyFDSpecInfoInt id s)
+addSpecInt tp (def,val) _ _ (Just (m@(FDSpecInfoInt { fdspIntSpec = f, fdspIntTypes = t }))) =
+  Just $ m { 
+    fdspIntSpec = \x -> case x of
+      Just tt | tt==tp -> Just $ def
+      Nothing -> case f Nothing of
+        Nothing -> Just def
+        Just ttt -> Just ttt
+      k -> f k,
+    fdspIntTypes = Set.insert tp t,
+    fdspIntVal = case val of
+      Nothing -> fdspIntVal m
+      _ -> val
+  }
+
+addSpecBool :: FDSolver s => FDBoolSpecType s -> (FDBoolSpec s, Maybe EGBoolPar) -> EGVarId -> FDState s -> Maybe (FDSpecInfoBool s) -> Maybe (FDSpecInfoBool s)
+addSpecBool tp def id s Nothing = addSpecBool tp def id s (Just $ emptyFDSpecInfoBool id s)
+addSpecBool tp (def,val) _ _ (Just (m@(FDSpecInfoBool { fdspBoolSpec = f, fdspBoolTypes = t }))) = 
+  Just $ m { 
+    fdspBoolSpec = \x -> case x of
+      Just tt | tt==tp -> Just $ def
+      Nothing -> case f Nothing of
+        Nothing -> Just def
+        Just ttt -> Just ttt
+      k -> f k,
+    fdspBoolTypes = Set.insert tp t,
+    fdspBoolVal = case val of
+      Nothing -> fdspBoolVal m
+      _ -> val
+  }
+
+addSpecCol :: FDSolver s => FDColSpecType s -> (FDColSpec s, Maybe EGColPar) -> EGVarId -> FDState s -> Maybe (FDSpecInfoCol s) -> Maybe (FDSpecInfoCol s)
+addSpecCol tp def id s Nothing = addSpecCol tp def id s (Just $ emptyFDSpecInfoCol id s)
+addSpecCol tp (def,val) _ _ (Just (m@(FDSpecInfoCol { fdspColSpec = f, fdspColTypes = t }))) = 
+  Just $ m {
+    fdspColSpec = \x -> case x of
+      Just tt | tt==tp -> Just $ def
+      Nothing -> case f Nothing of
+        Nothing -> Just def
+        Just ttt -> Just ttt
+      k -> f k,
+    fdspColTypes = Set.insert tp t,
+    fdspColVal = case val of
+      Nothing -> fdspColVal m
+      _ -> val
+  }
+
+-- | add an int term
+addIntVar :: FDSolver s => EGVarId -> FDIntSpecType s -> (FDIntSpec s, Maybe EGPar) -> FDInstance s ()
+addIntVar id typ (spec@(rs,_)) = do
+--  debug ("addIntVar id="++(show id)++" typ="++(show typ)++" spec="++(show spec)) $ return ()
+  s <- get
+  case (Map.lookup id $ fdsIntVars s) of
+    Just t | not (Set.null $ fdspIntTypes t) -> case (fdspIntSpec t Nothing) of
+      Just x -> fdEqualInt rs x
+      Nothing -> case fdspIntSpec t $ Just $ Set.findMax $ fdspIntTypes t of
+        Just x -> fdEqualInt rs x
+        Nothing -> return ()
+    _ -> return ()
+  s2 <- get
+  put $ s2
+    {
+      fdsIntVars = Map.alter (addSpecInt typ spec id s2) id $ fdsIntVars s2,
+      fdsIntVarBusy = Set.delete id $ fdsIntVarBusy s2,
+      fdsIntVarTypes = Map.alter (setAlter typ) id $ fdsIntVarTypes s2
+    }
+
+-- | add a bool term
+addBoolVar :: FDSolver s => EGVarId -> FDBoolSpecType s -> (FDBoolSpec s, Maybe EGBoolPar) -> FDInstance s ()
+addBoolVar id typ (spec@(rs,_)) = do
+--  debug ("addBoolVar id="++(show id)++" typ="++(show typ)++" spec="++(show spec)) $ return ()
+  s <- get
+  case (Map.lookup id $ fdsBoolVars s) of
+    Just t | not (Set.null $ fdspBoolTypes t) -> case (fdspBoolSpec t Nothing) of
+      Just x -> fdEqualBool rs x
+      Nothing -> case fdspBoolSpec t $ Just $ Set.findMax $ fdspBoolTypes t of
+        Just x -> fdEqualBool rs x
+        Nothing -> return ()
+    _ -> return ()
+  s2 <- get
+  put $ s2
+    { 
+      fdsBoolVars = Map.alter (addSpecBool typ spec id s2) id $ fdsBoolVars s2,
+      fdsBoolVarBusy = Set.delete id $ fdsBoolVarBusy s2,
+      fdsBoolVarTypes = Map.alter (setAlter typ) id $ fdsBoolVarTypes s2
+    }
+
+-- | add a col term
+addColVar :: FDSolver s => EGVarId -> FDColSpecType s -> (FDColSpec s, Maybe EGColPar) -> FDInstance s ()
+addColVar id typ (spec@(rs,_)) = do
+--  debug ("addColVar id="++(show id)++" typ="++(show typ)++" spec="++(show spec)) $ return ()
+  s <- get
+  case (Map.lookup id $ fdsColVars s) of
+    Just t | not (Set.null $ fdspColTypes t) -> case (fdspColSpec t Nothing) of
+      Just x -> fdEqualCol rs x
+      Nothing -> case fdspColSpec t $ Just $ Set.findMax $ fdspColTypes t of
+        Just x -> fdEqualCol rs x
+        Nothing -> return ()
+    _ -> return ()
+  s2 <- get
+  put $ s2
+    { 
+      fdsColVars = Map.alter (addSpecCol typ spec id s2) id $ fdsColVars s2,
+      fdsColVarBusy = Set.delete id $ fdsColVarBusy s2,
+      fdsColVarTypes = Map.alter (setAlter typ) id $ fdsColVarTypes s2
+    }
+
+full_fdProcess :: FDSolver s => EGConstraintSpec -> FDSpecInfo s -> FDInstance s ()
+full_fdProcess = mixin (fdProcess <@> mixinLift default_fdProcess)
+
+full_fdSpecify :: FDSolver s => SpecFn s
+full_fdSpecify = mixin (fdSpecify <@> mixinLift default_fdSpecify)
+
+
+getJustEdge :: FDSolver s => EGEdgeId -> FDState s -> EGEdge
+getJustEdge i s = 
+  let Just m = fdsModel s
+      Just x = Map.lookup i (egmEdges m)
+      in x
+
+buildSpecDb :: FDSolver s => FDInstance s ()
+buildSpecDb = do
+  s <- get
+  let origDb = fdsDb s
+      ne = debug "bsdb: ne" $ map (\k -> (k,getJustEdge k s)) $ Set.toList $ debug "bsbd: fdsne" $ fdsNewEdges s
+      proc db (eid,edge) = do 
+        let (lB,lI,lC) = debug ("bsbd: specify("++(show edge)++")") $ full_fdSpecify edge
+            dB = foldr (\(prio,var,full,spec) d -> debug "bsbd: addbool" $ addBoolSpec d (prio,var,if full then Just eid else Nothing,spec)) db $ debug ("lB["++(show $ length lB)++"]") lB
+            dI = foldr (\(prio,var,full,spec) d -> debug "bsbd: addint" $ addIntSpec d (prio,var,if full then Just eid else Nothing,spec)) dB $ debug ("lI["++(show $ length lI)++"]") lI
+            dC = foldr (\(prio,var,full,spec) d -> debug "bsbd: addcol" $ addColSpec d (prio,var,if full then Just eid else Nothing,spec)) dI $ debug ("lC["++(show $ length lC)++"]") lC
+            in dC
+      newDb = foldl proc origDb ne
+  put $ s { fdsDb = newDb }
+
+addBoolTypeReq :: FDSolver s => EGVarId -> FDBoolSpecTypeSet s -> FDInstance s ()
+addBoolTypeReq var set = do
+  s <- get
+  let chk tp = case Map.lookup var (fdsBoolVars s) of
+            Nothing -> False
+            Just x -> Set.member tp (fdspBoolTypes x)
+      sset = Map.findWithDefault Set.empty var (fdsBoolVarTypes s)
+  if Set.member set sset
+    then return ()
+    else if any chk (Set.toList set)
+      then return ()
+      else do
+        let nsset = Set.insert set sset
+        put $ s 
+          { 
+            fdsBoolVarTypes = Map.insert var nsset $ fdsBoolVarTypes s
+          }
+
+addIntTypeReq :: FDSolver s => EGVarId -> FDIntSpecTypeSet s -> FDInstance s ()
+addIntTypeReq var set = do
+  s <- get
+  let chk tp = case Map.lookup var (fdsIntVars s) of
+            Nothing -> False
+            Just x -> Set.member tp (fdspIntTypes x)
+      sset = Map.findWithDefault Set.empty var (fdsIntVarTypes s)
+  if Set.member set sset
+    then return ()
+    else if any chk (Set.toList set)
+      then return ()
+      else do
+        let nsset = Set.insert set sset
+        put $ s 
+          { 
+            fdsIntVarTypes = Map.insert var nsset $ fdsIntVarTypes s
+          }
+
+addColTypeReq :: FDSolver s => EGVarId -> FDColSpecTypeSet s -> FDInstance s ()
+addColTypeReq var set = do
+  s <- get
+  let chk tp = case Map.lookup var (fdsColVars s) of
+            Nothing -> False
+            Just x  -> Set.member tp (fdspColTypes x)
+      sset = Map.findWithDefault Set.empty var (fdsColVarTypes s)
+  if Set.member set sset
+    then return ()
+    else if any chk (Set.toList set)
+      then return ()
+      else do
+        let nsset = Set.insert set sset
+        put $ s 
+          {
+            fdsColVarTypes = Map.insert var nsset (fdsColVarTypes s)
+          }
+
+addTypeReqs :: FDSolver s => FDInstance s ()
+addTypeReqs = do
+  s <- get
+  fBool <- liftFD fdTypeReqBool
+  fInt  <- liftFD fdTypeReqInt
+  fCol  <- liftFD fdTypeReqCol
+  let ne = map (\k -> getJustEdge k s) $ Set.toList $ fdsNewEdges s
+      proc edge = do
+        mapM_ (uncurry addBoolTypeReq) $ fBool edge
+        mapM_ (uncurry addIntTypeReq) $ fInt edge
+        mapM_ (uncurry addColTypeReq) $ fCol edge
+  mapM_ proc ne
+
+processEx :: FDSolver s => Bool -> FDInstance s ()
+processEx x = do
+        ssm1 <- get
+        let ss0 = ssm1 { fdsModel = Just $ pruneNodes $ myFromJust "processEx" $ fdsModel ssm1 }
+        debug ("process ["++(show $ fdsLevel ss0)++"]") $ return ()
+        -- search spec type requirements for all to-be-processed edges
+        debug ("addTypeReqs ["++(show $ fdsLevel ss0)++"]") $ addTypeReqs
+        -- optimize type requirements
+        debug ("optimizeVarTypes["++(show $ fdsLevel ss0)++"]") $ optimizeVarTypes
+        ss <- get
+        debug ("DUMP type reqs ["++(show $ fdsLevel ss0)++"]: "++(show $ fdsIntVarTypes ss)) $ return ()
+        -- build specifier database for all to-be-processed edges
+        debug ("buildSpecDb ["++(show $ fdsLevel ss0)++"]") $ buildSpecDb
+        ss2 <- get
+        debug ("DUMP spec db ["++(show $ fdsLevel ss0)++"]: "++(show $ fdsDb ss2)) $ return ()
+        -- create as much specifiers as possible (marking consumed edges as processed)
+        whileM_ $ debug ("decompBest ["++(show $ fdsLevel ss0)++"]") decompBest
+        -- try default specifier for remaining boolean nodes (=create new underlying term for each)
+        whileM_ $ debug ("decompDefBool ["++(show $ fdsLevel ss0)++"]") decompDefaultBool
+        -- try default specifier for remaining integer nodes (=create new underlying term for each)
+        whileM_ $ debug ("decompDefInt ["++(show $ fdsLevel ss0)++"]") decompDefaultInt
+        ss3 <- get
+        debug ("DUMP specs: "++(dumpSpec ss3)) $ return ()
+        -- process remaining edges
+        if x
+          then whileM_ $ debug ("procEdge ["++(show $ fdsLevel ss0)++"]") procEdge
+          else return ()
+
+process :: FDSolver s => FDInstance s ()
+process = processEx True
+
+commit :: FDSolver s => FDInstance s ()
+commit = do
+  s <- get
+  debug "begin commit" $ return ()
+  case (fdsExpr s,fdsForceBool s,fdsForceInt s,fdsForceCol s) of
+      (BoolConst True,[],[],[]) -> return ()
+      (expr,_,_,_) -> do
+        debug ("expr=["++(show expr)++"]") $ return ()
+        let (dcd,graph,vars) = debug "decomposing" $ decomposeEx (fdsDecomp s) (fdsVars s) expr (fdsForceBool s,fdsForceInt s,fdsForceCol s) $ fdsModel s
+        put $ s { fdsExpr = BoolConst True, fdsDecomp = dcd, fdsModel = Just graph, fdsForceBool=[], fdsForceInt=[], fdsForceCol=[], fdsVars = max vars (fdsVars s) }
+        debug ("graph=["++(present graph)++"]"++"]") $ return ()
+        -- mark all non-yet-processed edges as to-be-processed
+        debug "initForModel" $ initForModel
+        process
+
+instance FDSolver s => Solver (FDInstance s) where
+  type Constraint (FDInstance s) = Either Model (Constraint s)
+  type Label (FDInstance s) = FDLabel s
+  add (Left expr) = do
+    s <- get
+    if (fdsFailed s)
+      then return False
+      else do
+        put $ s { fdsExpr = (fdsExpr s) @&& expr }
+        return True
+  add (Right col) = do
+    s <- get
+    if (fdsFailed s)
+      then return False
+      else do
+        ret <- liftFD $ add col
+        if ret
+          then return True
+          else do
+            setFailed
+            return False
+  mark = do
+    commit
+    ss <- get
+    sl <- liftFD mark
+    return $ FDLabel { fdlState=ss, fdlLabel=sl }
+  markn n = do
+    commit
+    ss <- get
+    sl <- liftFD $ markn n
+    return $ FDLabel { fdlState=ss, fdlLabel=sl }
+  goto label = do
+    liftFD $ goto $ fdlLabel label
+    put $ fdlState label
+  run x = run $ runFD x
+
+instance FDSolver s => Term (FDInstance s) ModelInt where
+  newvar = do
+    s <- get
+    let i = fdsVars s
+    put $ s { fdsVars = 1+i }
+    return $ Term $ ModelIntVar i
+  type Help (FDInstance s) ModelInt = ()
+  help _ _ = ()
+
+instance FDSolver s => Term (FDInstance s) ModelBool where
+  newvar = do
+    s <- get
+    let i = fdsVars s
+    put $ s { fdsVars = 1+i }
+    return $ BoolTerm $ ModelBoolVar i
+  type Help (FDInstance s) ModelBool = ()
+  help _ _ = ()
+
+instance FDSolver s => Term (FDInstance s) ModelCol where
+  newvar = do
+    s <- get
+    let i = fdsVars s
+    put $ s { fdsVars = 1+i }
+    return $ ColTerm $ ModelColVar i
+  type Help (FDInstance s) ModelCol = ()
+  help _ _ = ()
+
+newCol :: FDSolver s => FDInstance s ModelCol
+newCol = newvar
+
+newInt :: FDSolver s => FDInstance s ModelInt
+newInt = newvar
+
+newBool :: FDSolver s => FDInstance s ModelBool
+newBool = newvar
+
+combine :: [Maybe a] -> [a] -> [a]
+combine [] _ = []
+combine (Nothing:r) (a:b) = a:(combine r b)
+combine (Just x:r) b = x:(combine r b)
+
+realGetIntTerm :: FDSolver s => [ModelInt] -> FDInstance s [FDIntTerm s]
+realGetIntTerm m = do
+  s <- debug ("realGetIntTerm: "++(show m)) $ get
+  put $ s { fdsForceInt = m++(fdsForceInt s) }
+  commit
+  s2 <- get
+  let ids = map (\x -> decompIntLookup (fdsDecomp s2) x) m
+  tp <- liftFD $ fdTypeVarInt
+  specs <- mapM (\(Just id) -> getIntSpec_ id tp) ids
+  vars <- mapM (\(Just (_,spec)) -> liftFD $ fdIntVarSpec spec) specs
+  let rvars = map (\(Just x) -> x) vars
+  s3 <- get
+  put $ s3 { fdsForcedInt = Map.union (fdsForcedInt s3) (Map.fromList $ zip m rvars) }
+  return rvars
+
+getSingleIntTerm :: FDSolver s => ModelInt -> FDInstance s (FDIntTerm s)
+getSingleIntTerm m = do
+  s <- get
+  case Map.lookup m (fdsForcedInt s) of
+    Nothing -> realGetIntTerm [m] >>= return.head
+    Just d -> return d
+
+getIntTerm :: FDSolver s => [ModelInt] -> FDInstance s [FDIntTerm s]
+getIntTerm m = do
+  s <- get
+  let lo = map (\x -> (x,Map.lookup x $ fdsForcedInt s)) m
+  let go = map fst $ filter (\(_,x) -> isNothing x) lo
+  vo <- case go of
+    [] -> return []
+    _ -> realGetIntTerm go
+  return $ combine (map snd lo) vo
+
+realGetBoolTerm :: FDSolver s => [ModelBool] -> FDInstance s [FDBoolTerm s]
+realGetBoolTerm m = do
+  s <- get
+  put $ s { fdsForceBool = m++(fdsForceBool s) }
+  commit
+  s2 <- get
+  let ids = map (\x -> decompBoolLookup (fdsDecomp s2) x) m
+  tp <- liftFD $ fdTypeVarBool
+  specs <- mapM (\(Just id) -> getBoolSpec_ id tp) ids
+  vars <- mapM (\(Just (_,spec)) -> liftFD $ fdBoolVarSpec spec) specs
+  let rvars = map (\(Just x) -> x) vars
+  s3 <- get
+  put $ s3 { fdsForcedBool = Map.union (fdsForcedBool s3) (Map.fromList $ zip m rvars) }
+  return rvars
+
+getBoolTerm :: FDSolver s => [ModelBool] -> FDInstance s [FDBoolTerm s]
+getBoolTerm m = do
+  s <- get
+  let lo = map (\x -> (x,Map.lookup x $ fdsForcedBool s)) m
+  let go = map fst $ filter (\(_,x) -> isNothing x) lo
+  vo <- case go of
+    [] -> return []
+    _ -> realGetBoolTerm go
+  return $ combine (map snd lo) vo
+
+getColTerm :: FDSolver s => [ModelCol] -> FDColSpecType s -> FDInstance s [FDColSpec s]
+getColTerm m tp = do
+  s <- get
+  put $ s { fdsForceCol = m++(fdsForceCol s) }
+  commit
+  s2 <- get
+  let ids = map (\x -> decompColLookup (fdsDecomp s2) x) m
+  specs <- mapM (\(Just id) -> getColSpec_ id (Set.singleton tp)) ids
+  return $ map (snd . myFromJust ("getColTerm(tp="++(show tp)++")")) specs
+
+getColItems :: FDSolver s => ModelCol -> FDColSpecType s -> FDInstance s [FDIntTerm s]
+getColItems c tp = do
+  [cc] <- getColTerm [c] tp
+  lst <- liftFD $ fdColInspect cc
+  return lst
+
+instance (FDSolver s, EnumTerm s (FDIntTerm s)) => EnumTerm (FDInstance s) ModelInt where
+  type TermBaseType (FDInstance s) ModelInt = TermBaseType s (FDIntTerm s)
+  getDomainSize v = do
+    f <- getFailed
+    if f 
+      then return 0
+      else do
+        var <- getSingleIntTerm v
+        liftFD $ getDomainSize var
+  getValue v = do
+    var <- getSingleIntTerm v
+    liftFD $ getValue var
+--  setValue var val = return [var @== cte val]
+  setValue _ = error "setting of boolean variable through FD interface is not implemented"
+  getDomain var = error "retrieval of full domain not implemented in FD"
+  splitDomain v = do
+    var <- getSingleIntTerm v
+    (doms,full) <- liftFD $ fdSplitIntDomain var
+    return (map (\x -> [Right x]) doms, full)
+  enumerator = case enumerator of
+    Nothing -> Nothing
+    Just e -> Just $ \l -> label $ do
+      f <- getFailed
+      if f
+        then return false
+        else do
+          ll <- getIntTerm l
+          return $ liftFDTree $ e ll
+
+instance (FDSolver s, EnumTerm s (FDBoolTerm s)) => EnumTerm (FDInstance s) ModelBool where
+  type TermBaseType (FDInstance s) ModelBool = TermBaseType s (FDBoolTerm s)
+  getDomainSize v = do
+    f <- getFailed
+    if f
+      then return 0
+      else do
+        [var] <- getBoolTerm [v]
+        liftFD $ getDomainSize var
+  getValue v = do
+    [var] <- getBoolTerm [v]
+    liftFD $ getValue var
+--  setValue var val = return [var @= BoolConst (val /]
+  setValue _ = error "setting of boolean variable through FD interface is not implemented"
+  getDomain var = error "retrieval of full boolean domain not implemented in FD"
+  splitDomain v = do
+    [var] <- getBoolTerm [v]
+    (doms,full) <- liftFD $ fdSplitBoolDomain var
+    return (map (\x -> [Right x]) doms, full)
+  enumerator = case enumerator of
+    Nothing -> Nothing
+    Just e -> Just $ \l -> label $ do
+      f <- getFailed
+      if f
+        then return false
+        else do
+          ll <- getBoolTerm l
+          return $ liftFDTree $ e ll
+
+getIntVal_ :: FDSolver s => EGVarId -> FDState s -> Maybe EGPar
+getIntVal_ id s =
+  let r1 = 
+        case Map.lookup id (fdsIntVars s) of
+          Nothing -> Nothing
+          Just x -> fdspIntVal x
+      in case r1 of
+        Nothing ->
+          let Just j = fdsModel s
+              ei = findEdge j EGIntType id (==0) (\x -> case x of { EGIntValue _ -> True; _ -> False })
+              in case ei of
+                Nothing -> Nothing
+                Just (_,ed) -> case egeCons ed of { EGIntValue c -> Just c }
+        Just x -> r1
+
+getIntVal :: FDSolver s => EGVarId -> FDInstance s (Maybe EGPar)
+getIntVal id = gets $ getIntVal_ id
+
+getBoolVal_ :: FDSolver s => EGVarId -> FDState s -> Maybe EGBoolPar
+getBoolVal_ id s =
+  let r1 = 
+        case Map.lookup id (fdsBoolVars s) of
+          Nothing -> Nothing
+          Just x -> fdspBoolVal x
+      in case r1 of
+        Nothing ->
+          let Just j = fdsModel s
+              l = getConnectedEdges j EGBoolType id
+              f (EGEdge { egeCons = EGBoolValue c },_) _ = Just c
+              f _ s = s
+              in foldr f Nothing l
+        Just x -> r1
+
+getBoolVal :: FDSolver s => EGVarId -> FDInstance s (Maybe EGBoolPar)
+getBoolVal id = gets $ getBoolVal_ id
+
+getColVal_ :: FDSolver s => EGVarId -> FDState s -> Maybe EGColPar
+getColVal_ id s =
+  let r1 = 
+        case Map.lookup id (fdsColVars s) of
+          Nothing -> Nothing
+          Just x -> fdspColVal x
+      in case r1 of
+        Nothing ->
+          let Just j = fdsModel s
+              l = getConnectedEdges j EGColType id
+              f (EGEdge { egeCons = EGColValue c },_) _ = Just c
+              f _ s = s
+              in foldr f Nothing l
+        Just x -> r1
+
+getColVal :: FDSolver s => EGVarId -> FDInstance s (Maybe EGColPar)
+getColVal id = gets $ getColVal_ id
+
+setFailed :: FDSolver s => FDInstance s ()
+setFailed = do 
+  s <- get
+  debug "setFailed!" $ return ()
+  put $ s { fdsFailed = True }
+
+getFailed :: FDSolver s => FDInstance s Bool
+getFailed = do
+  s <- get
+  return $ fdsFailed s
+
+addFD :: (Show (Constraint s), FDSolver s) => Constraint s -> FDInstance s ()
+addFD c = do
+  s <- get
+  if (fdsFailed s)
+    then debug ("addFD("++(show c)++"): already failed") $ return ()
+    else do
+      x <- liftFD $ add c
+      debug ("addFD("++(show c)++"): result="++(show x)) $ return ()
+      if not x then setFailed else return ()
+
+getDefIntSpec :: FDSolver s => FDSpecInfoInt s -> FDIntSpec s
+getDefIntSpec (FDSpecInfoInt { fdspIntSpec = f }) = case f Nothing of
+  Just t -> t
+  Nothing -> error "getDefIntSpec: no spec"
+
+getDefBoolSpec :: FDSolver s => FDSpecInfoBool s -> FDBoolSpec s
+getDefBoolSpec (FDSpecInfoBool { fdspBoolSpec = f }) = case f Nothing of
+  Just t -> t
+  Nothing -> error "getDefBoolSpec: no spec"
+
+getDefColSpec :: FDSolver s => FDSpecInfoCol s -> FDColSpec s
+getDefColSpec (FDSpecInfoCol { fdspColSpec = f }) = case f Nothing of
+  Just t -> t
+  Nothing -> error "getDefColSpec: no spec"
+
+-- getFullIntSpec :: FDSolver s => EGVarId -> s (FDSpecInfoInt s)
+getFullIntSpec id = do
+  s <- get
+  return $ myFromJust "getFullIntSpec" $ Map.lookup id $ fdsIntVars s
+
+-- getFullBoolSpec :: FDSolver s => EGVarId -> s (FDSpecInfoBool s)
+getFullBoolSpec id = do
+  s <- get
+  return $ myFromJust "getFullBoolSpec" $ Map.lookup id $ fdsBoolVars s
+
+-- getFullColSpec :: FDSolver s => EGVarId -> s (FDSpecInfoCol s)
+getFullColSpec id = do
+  s <- get
+  return $ myFromJust "getFullColSpec" $ Map.lookup id $ fdsColVars s
+
+fdNewvar :: (FDSolver s, Term s t) => FDInstance s (Maybe t)
+fdNewvar = do
+  s <- get
+  if fdsDummyLevel s > 0
+    then return Nothing
+    else liftFD newvar >>= return . Just

+ src/Control/CP/FD/Graph.hs view

@@ -0,0 +1,411 @@+{- 
+ - 	Monadic Constraint Programming
+ - 	http://www.cs.kuleuven.be/~toms/MCP/
+ - 	Pieter Wuille
+ -}
+
+{-# LANGUAGE RankNTypes #-}
+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
+{-# LANGUAGE StandaloneDeriving #-}
+{-# LANGUAGE FlexibleInstances #-}
+
+module Control.CP.FD.Graph (
+  EGConstraintSpec(..),
+  EGParTerm(..),
+  EGParBoolTerm(..),
+  EGParColTerm(..),
+  EGPar, EGBoolPar, EGColPar,
+  EGConsArgs,
+  EGEdgeId,
+  EGVarId(..),
+  EGVarType(..),
+  EGTypeData(..),
+  EGEdge(..),
+  EGModel(..),
+  addEdge,
+  addNode,
+  delNode,
+  findEdge,
+  unifyNodes,
+  unifyIds,
+  baseGraph,
+  baseTypeData,
+  egTypeDataMap, egTypeGet, egTypeMod,
+  present,
+  getConnectedEdges,
+  externMap, filterModel, emptyModel, pruneNodes,
+) where
+
+import Control.Monad (foldM)
+
+import Data.Maybe (fromJust)
+import Data.Map (Map)
+import qualified Data.Map as Map
+
+import Data.Expr.Data
+-- import Control.CP.FD.Expr.Util
+
+-- BoolEqual, Rel _ (EREqual) _, ColEqual are encoded in the graph itself, and
+-- not represented as constraints between them
+
+data EGVarType = 
+    EGBoolType
+  | EGIntType
+  | EGColType
+  deriving (Eq,Show)
+
+-- instance KeyableExpr EGConstraintSpec where
+--  keyCompare a b = compare a b
+
+data EGConstraintSpec =
+    EGIntValue EGPar                 -- i0 == p
+  | EGBoolValue EGBoolPar            -- b0 == p
+  | EGColValue EGColPar              -- c0 == p
+  | EGIntExtern Int                  -- super[p] == i0
+  | EGBoolExtern Int                 -- super[p] == b0
+  | EGColExtern Int                  -- super[p] == c0
+  | EGPlus                           -- i0==i1+i2
+  | EGMinus                          -- i0==i1-i2
+  | EGMult                           -- i0==i1*i2
+  | EGDiv                            -- i0==i1/i2   {- (i0==i1/i2) is NOT the same as (i1==i0*i2) -}
+  | EGMod                            -- i0==i1%i2  
+  | EGAbs                            -- i0==abs(i1)
+  | EGAt                             -- i0==c0[i1]
+  | EGFold EGModel (Int,Int,Int)     -- i0==fold(p,i1,c0)  {- inner intExtern(-1) is fold-function's return value, intExtern(-2) is the accumulator, intExtern(-3) is the argument -}
+  | EGSize                           -- i0==size(c0)
+  | EGChannel                        -- int(b0) == i0
+  | EGList Int                       -- c0 == [i0,i1,i2,...] (len p) 
+  | EGRange                          -- c0 == [i0..i1]
+  | EGMap EGModel (Int,Int,Int)      -- c0 == map(p,c1)    {- inner intExtern(-1) is map-function's return value, intExtern(-2) is its argument -}
+  | EGSlice EGModel (Int,Int,Int)    -- c0 == c1[f(0)...f(i0-1)]; inner model defines f: intExtern(-1) is return value, intExtern(-2) is its argument
+--  | EGSlice (EGPar -> EGPar) EGPar   -- c0 == c1[f(0)...f(n-1)]
+  | EGCat                            -- c0 == c1++c2
+  | EGAnd                            -- b0 == b1 && b2
+  | EGOr                             -- b0 == b1 || b2
+  | EGEquiv                          -- b0 == (b1 == b2)
+  | EGNot                            -- b0 == !b1
+  | EGEqual                          -- b0 <-> i0 == i1
+  | EGDiff                           -- b0 <-> i0 /= i1
+  | EGLess Bool                      -- false: b0 <-> i0 <= i1 ; true: b0 <-> i0 < i1
+  | EGAll EGModel (Int,Int,Int) Bool -- b0 <-> foreach (i from c0): p(i)  {- inner boolExtern(-1) is truth value of predicate, intExtern(-1) is its argument; bool is true if all inner predicates need to be true -}
+  | EGAny EGModel (Int,Int,Int) Bool -- b0 <-> forany (i from c0): p(i)   {- inner boolExtern(-1) is truth value of predicate, intExtern(-1) is its argument; bool is true if all inner predicates need to be false -}
+--  | EGAllC EGModel (Int,Int,Int) Bool -- b0 <-> foreach (i from [i0,i1]: p(i) {- inner boolExtern(-1) is truth value of predicate, intExtern(-1) is its (constant) argument; bool is true if all inner predicates need to be true -}
+--  | EGAnyC EGModel (Int,Int,Int) Bool -- b0 <-> foreach (i from [i0,i1]: p(i) {- inner boolExtern(-1) is truth value of predicate, intExtern(-1) is its (constant) argument; bool is true if all inner predicates need to be true -}
+  | EGSorted Bool                    -- c0 is increasing (false), or strictly increasing (true)
+  | EGAllDiff Bool                   -- c0 is all different (b0 means: use in consistency)
+  | EGDom                            -- i0 is any of c0
+  | EGCondEqual                      -- b0 ? (b1==b2) : true
+  | EGCondInt                        -- i0 = b0 ? i1 : i2
+  deriving (Eq,Show)
+
+instance Ord (EGPar -> EGPar) where
+  compare a b = compare (a (Term (EGPTParam (-1)))) (b (Term (EGPTParam (-1))))
+
+instance Eq (EGPar -> EGPar) where
+  a == b = (a (Term (EGPTParam (-1)))) == (b (Term (EGPTParam (-1))))
+
+instance Show (EGPar -> EGPar) where
+  show f = show $ f (Term (EGPTParam (-1)))
+
+dummyConstraint :: EGConstraintSpec -> Bool
+dummyConstraint c = case c of
+  EGIntExtern _ -> True
+  EGBoolExtern _ -> True
+  EGColExtern _ -> True
+  _ -> False
+
+data EGParTerm =
+    EGPTParam Int
+  deriving (Show,Eq,Ord)
+  
+data EGParBoolTerm =
+    EGPTBoolParam Int
+  deriving (Show,Eq,Ord)
+
+data EGParColTerm =
+    EGPTColParam Int
+  deriving (Show,Eq,Ord)
+
+type EGPar =     Expr     EGParTerm EGParColTerm EGParBoolTerm
+type EGBoolPar = BoolExpr EGParTerm EGParColTerm EGParBoolTerm
+type EGColPar =  ColExpr  EGParTerm EGParColTerm EGParBoolTerm
+
+-- Bools, Ints, Cols
+type EGConsArgs = (Int,Int,Int)
+
+getConsArgs :: EGConstraintSpec -> EGTypeData Int
+getConsArgs x = case
+  case x of
+    EGBoolValue _    -> (1,0,0)
+    EGIntValue _     -> (0,1,0)
+    EGColValue _     -> (0,0,1)
+    EGIntExtern _    -> (0,1,0)
+    EGBoolExtern _   -> (1,0,0)
+    EGColExtern _    -> (0,0,1)
+    EGPlus           -> (0,3,0)
+    EGMinus          -> (0,3,0)
+    EGMult           -> (0,3,0)
+    EGDiv            -> (0,3,0)
+    EGMod            -> (0,3,0)
+    EGAbs            -> (0,2,0)
+    EGAt             -> (0,2,1)
+    EGFold _ (a,b,c) -> (a,2+b,1+c)
+    EGSize           -> (0,1,1)
+    EGChannel        -> (1,1,0)
+    EGList n         -> (0,n,1)
+    EGRange          -> (0,2,1)
+    EGMap _ (a,b,c)  -> (a,b,2+c)
+    EGSlice _ (a,b,c) -> (a,1+b,2+c)
+    EGCat            -> (0,0,3)
+    EGAnd            -> (3,0,0)
+    EGOr             -> (3,0,0)
+    EGEquiv          -> (3,0,0)
+    EGNot            -> (2,0,0)
+    EGEqual          -> (1,2,0)
+    EGDiff           -> (1,2,0)
+    EGLess _         -> (1,2,0)
+    EGAll _ (a,b,c) _ -> (1+a,b,1+c)
+    EGAny _ (a,b,c) _ -> (1+a,b,1+c)
+--    EGAllC _ (a,b,c) _ -> (1+a,2+b,c)
+--    EGAnyC _ (a,b,c) _ -> (1+a,2+b,c)
+    EGSorted _       -> (0,0,1)
+    EGAllDiff _      -> (0,0,1)
+    EGDom            -> (0,1,1)
+    EGCondEqual      -> (3,0,0)
+    EGCondInt        -> (1,3,0)
+  of (a,b,c) -> EGTypeData { boolData = a, intData = b, colData =c }
+
+newtype EGEdgeId = EGEdgeId { unEGEdgeId :: Int }
+  deriving (Eq,Ord,Show)
+
+data EGVarId = EGVarId { unVarId :: Int }
+  deriving (Eq,Ord,Show)
+
+data EGTypeData x = EGTypeData {
+  boolData :: x,
+  intData :: x,
+  colData :: x
+}
+
+deriving instance Show x => Show (EGTypeData x)
+deriving instance Eq x => Eq (EGTypeData x)
+
+baseTypeData :: x -> EGTypeData x
+baseTypeData x = EGTypeData {
+  boolData = x,
+  intData = x,
+  colData = x
+}
+
+egTypeDataMap :: ((forall a. EGTypeData a -> a) -> b) -> EGTypeData b
+egTypeDataMap f = EGTypeData {
+  boolData = f boolData,
+  intData = f intData,
+  colData = f colData
+}
+
+egTypeGet :: EGVarType -> EGTypeData a -> a
+egTypeGet EGBoolType = boolData
+egTypeGet EGIntType = intData
+egTypeGet EGColType = colData
+
+egTypeMod :: EGVarType -> EGTypeData a -> (a -> a) -> EGTypeData a
+egTypeMod EGBoolType d f = d { boolData = f $ boolData d }
+egTypeMod EGIntType d f = d { intData = f $ intData d }
+egTypeMod EGColType d f = d { colData = f $ colData d }
+
+data EGEdge = EGEdge {
+  egeCons :: EGConstraintSpec,
+  egeLinks :: EGTypeData [EGVarId]
+} deriving (Eq,Show)
+
+showBool :: EGVarId -> String
+showBool (EGVarId i) = "b" ++ (show i)
+showInt :: EGVarId -> String
+showInt (EGVarId i) = "i" ++ (show i)
+showCol :: EGVarId -> String
+showCol (EGVarId i) = "c" ++ (show i)
+
+showLst :: (EGVarId -> String) -> [EGVarId] -> String
+showLst _ [] = "[]"
+showLst f x = "[" ++ (foldl1 (\x y -> x ++ "," ++ y) $ map f x) ++ "]"
+
+instance Display EGEdge where
+  displayer (EGEdge { egeCons = EGBoolValue i, egeLinks = EGTypeData { boolData = [l] } }) = displaySingle $ (showBool l) ++ " == " ++ "#["++(show i)++"]"
+  displayer (EGEdge { egeCons = EGIntValue i, egeLinks =  EGTypeData { intData = [l] }}) = displaySingle $ (showInt l) ++ " == " ++ "#["++(show i)++"]"
+  displayer (EGEdge { egeCons = EGColValue i, egeLinks =  EGTypeData { colData = [l] }}) = displaySingle $ (showCol l) ++ " == " ++ "#["++(show i)++"]"
+  displayer (EGEdge { egeCons = EGBoolExtern i, egeLinks = EGTypeData  { boolData = [l] }}) = displaySingle $ (showBool l) ++ " == parentBool[" ++ (show i) ++ "]"
+  displayer (EGEdge { egeCons = EGIntExtern i, egeLinks =  EGTypeData { intData = [l] }}) = displaySingle $ (showInt l) ++ " == parentInt[" ++ (show i) ++ "]"
+  displayer (EGEdge { egeCons = EGColExtern i, egeLinks = EGTypeData  { colData = [l] }}) = displaySingle $ (showCol l) ++ " == parentCol[" ++ (show i) ++ "]"
+  displayer (EGEdge { egeCons = EGPlus, egeLinks =  EGTypeData { intData=[a,b,c] }}) = displaySingle $ (showInt a) ++ " == " ++ (showInt b) ++ " + " ++ (showInt c)
+  displayer (EGEdge { egeCons = EGMinus, egeLinks =  EGTypeData { intData=[a,b,c] }}) = displaySingle $ (showInt a) ++ " == " ++ (showInt b) ++ " - " ++ (showInt c)
+  displayer (EGEdge { egeCons = EGMult, egeLinks =  EGTypeData { intData=[a,b,c] }}) = displaySingle $ (showInt a) ++ " == " ++ (showInt b) ++ " * " ++ (showInt c)
+  displayer (EGEdge { egeCons = EGDiv, egeLinks =  EGTypeData { intData=[a,b,c] }}) = displaySingle $ (showInt a) ++ " == " ++ (showInt b) ++ " / " ++ (showInt c)
+  displayer (EGEdge { egeCons = EGMod, egeLinks =  EGTypeData { intData=[a,b,c] }}) = displaySingle $ (showInt a) ++ " == " ++ (showInt b) ++ " % " ++ (showInt c)
+  displayer (EGEdge { egeCons = EGAbs, egeLinks =  EGTypeData { intData=[a,b] }}) = displaySingle $ (showInt a) ++ " == abs(" ++ (showInt b) ++ ")"
+  displayer (EGEdge { egeCons = EGAt, egeLinks =  EGTypeData { intData=[a,b], colData=[c] }}) = displaySingle $ (showInt a) ++ " == " ++ (showCol c) ++ "[" ++ (showInt b) ++ "]"
+  displayer (EGEdge { egeCons = EGSize, egeLinks =  EGTypeData { intData=[a], colData=[c] }}) = displaySingle $ (showInt a) ++ " == size(" ++ (showCol c) ++ ")"
+  displayer (EGEdge { egeCons = EGDom, egeLinks =  EGTypeData { intData=[a], colData=[c] }}) = displaySingle $ ("dom(" ++ (showInt a) ++ ") == " ++ (showCol c))
+  displayer (EGEdge { egeCons = EGChannel, egeLinks =  EGTypeData { boolData=[a], intData=[b] }}) = displaySingle $ (showBool a) ++ " == " ++ (showInt b)
+  displayer (EGEdge { egeCons = EGList 0, egeLinks =  EGTypeData { colData=[c] }}) = displaySingle $ (showCol c) ++ " == []"
+  displayer (EGEdge { egeCons = EGList _, egeLinks =  EGTypeData { intData=l, colData=[c] }}) = displaySingle $ (showCol c) ++ " == ["++(foldl1 (\a b -> a ++","++b) $ map showInt l)++"]"
+  displayer (EGEdge { egeCons = EGAllDiff _, egeLinks =  EGTypeData { colData=[c] }}) = displaySingle $ "allDiff " ++ (showCol c)
+  displayer (EGEdge { egeCons = EGSorted b, egeLinks =  EGTypeData { colData=[c] }}) = displaySingle $ "sorted " ++ (show b) ++ " " ++ (showCol c)
+  displayer (EGEdge { egeCons = EGRange, egeLinks =  EGTypeData { intData=[l,h], colData=[c] }}) = displaySingle $ (showCol c) ++ " == ["++(showInt l)++".."++(showInt h)++"]"
+--  displayer (EGEdge { egeCons = EGSlice f n, egeLinks =  EGTypeData { colData=[c,o] }}) = displaySingle $ (showCol c) ++ " == "++(showCol o)++"[f(0)..f("++(show n)++"-1)]"
+  displayer (EGEdge { egeCons = EGCat, egeLinks =  EGTypeData { colData=[c,a,b] }}) = displaySingle $ (showCol c) ++ " == "++(showCol a)++"++"++(showCol b)
+  displayer (EGEdge { egeCons = EGAnd, egeLinks =  EGTypeData { boolData=[c,a,b] }}) = displaySingle $ (showBool c) ++ " == "++(showBool a)++" && "++(showBool b)
+  displayer (EGEdge { egeCons = EGOr, egeLinks =  EGTypeData { boolData=[c,a,b] }}) = displaySingle $ (showBool c) ++ " == "++(showBool a)++" || "++(showBool b)
+  displayer (EGEdge { egeCons = EGEquiv, egeLinks =  EGTypeData { boolData=[c,a,b] }}) = displaySingle $ (showBool c) ++ " == ("++(showBool a)++" == "++(showBool b)++")"
+  displayer (EGEdge { egeCons = EGNot, egeLinks =  EGTypeData { boolData=[c,a] }}) = displaySingle $ (showBool c) ++ " == !"++(showBool a)
+  displayer (EGEdge { egeCons = EGEqual, egeLinks =  EGTypeData { boolData=[r], intData=[a,b] }}) = displaySingle $ (showBool r) ++ " == ("++(showInt a)++" == "++(showInt b)++")"
+  displayer (EGEdge { egeCons = EGDiff, egeLinks =  EGTypeData { boolData=[r], intData=[a,b] }}) = displaySingle $ (showBool r) ++ " == ("++(showInt a)++" != "++(showInt b)++")"
+  displayer (EGEdge { egeCons = EGLess q, egeLinks =  EGTypeData { boolData=[r], intData=[a,b] }}) = displaySingle $ (showBool r) ++ " == ("++(showInt a)++(if q then " < " else " <= ")++(showInt b)++")"
+  displayer (EGEdge { egeCons = EGAll s _ _, egeLinks = EGTypeData { boolData=r:ab, intData=ai, colData=c:ac }}) = DisplayData ((showBool r)++" == forall("++(showCol c)++") "++(showLst showBool ab)++" "++(showLst showInt ai)++" "++(showLst showCol ac),[displayer s])
+  displayer (EGEdge { egeCons = EGAny s _ _, egeLinks = EGTypeData { boolData=r:ab, intData=ai, colData=c:ac }}) = DisplayData ((showBool r)++" == forany("++(showCol c)++") "++(showLst showBool ab)++" "++(showLst showInt ai)++" "++(showLst showCol ac),[displayer s])
+--  displayer (EGEdge { egeCons = EGAllC s _ _, egeLinks = EGTypeData { boolData=r:ab, intData=l:h:ai, colData=ac }}) = DisplayData ((showBool r)++" == forall("++(showInt l)++".."++(showInt h)++") "++(showLst showBool ab)++" "++(showLst showInt ai)++" "++(showLst showCol ac),[displayer s])
+--  displayer (EGEdge { egeCons = EGAnyC s _ _, egeLinks = EGTypeData { boolData=r:ab, intData=l:h:ai, colData=ac }}) = DisplayData ((showBool r)++" == forany("++(showInt l)++".."++(showInt h)++") "++(showLst showBool ab)++" "++(showLst showInt ai)++" "++(showLst showCol ac),[displayer s])
+  displayer (EGEdge { egeCons = EGMap s _, egeLinks = EGTypeData { boolData=ab, intData=ai, colData=r:c:ac }}) = DisplayData ((showCol r)++" == map("++(showCol c)++") "++(showLst showBool ab)++" "++(showLst showInt ai)++" "++(showLst showCol ac),[displayer s])
+  displayer (EGEdge { egeCons = EGSlice s _, egeLinks = EGTypeData { boolData=ab, intData=n:ai, colData=r:c:ac }}) = DisplayData ((showCol r)++" == slice("++(showCol c)++",0..("++(showInt n)++")-1) "++(showLst showBool ab)++" "++(showLst showInt ai)++" "++(showLst showCol ac),[displayer s])
+  displayer (EGEdge { egeCons = EGFold s _, egeLinks = EGTypeData { boolData=ab, intData=r:i:ai, colData=c:ac }}) = DisplayData ((showInt r)++" == fold("++(showCol c)++","++(showInt i)++") "++(showLst showBool ab)++" "++(showLst showInt ai)++" "++(showLst showCol ac),[displayer s])
+  displayer (EGEdge { egeCons = EGCondInt, egeLinks = EGTypeData { boolData=[c], intData=[r,t,f] }}) = displaySingle $ (showInt r) ++ " = (if " ++ (showBool c) ++" then (" ++ (showInt t) ++ ") else (" ++ (showInt f)++"))"
+  displayer (EGEdge { egeCons = EGCondEqual, egeLinks = EGTypeData { boolData=[c,a,b] }}) = displaySingle $ "if " ++ (showBool c) ++" then " ++ (showBool a) ++ "=="++(showBool b)
+  displayer (EGEdge { egeCons = c })  = DisplayData ("???("++(show c)++")",[])
+
+externMap :: EGModel -> EGTypeData (Map Int EGVarId)
+externMap md = foldr f (baseTypeData Map.empty) $ map snd $ Map.toList $ egmEdges md
+  where f :: EGEdge -> EGTypeData (Map Int EGVarId) -> EGTypeData (Map Int EGVarId)
+        f (EGEdge { egeCons = EGIntExtern i, egeLinks = EGTypeData { intData = [v] } }) st = egTypeMod EGIntType st $ \m -> Map.insert i v m
+        f (EGEdge { egeCons = EGBoolExtern i, egeLinks = EGTypeData { boolData = [v] } }) st = egTypeMod EGBoolType st $ \m -> Map.insert i v m
+        f (EGEdge { egeCons = EGColExtern i, egeLinks = EGTypeData { colData = [v] } }) st = egTypeMod EGColType st $ \m -> Map.insert i v m
+        f _ st = st
+
+emptyModel :: EGModel -> Bool
+emptyModel mod = 
+  let mm = externMap mod
+      ss = Map.size (intData mm) + Map.size (colData mm) + Map.size (boolData mm)
+      in ss == (Map.size $ egmEdges mod)
+
+data EGModel = EGModel {
+  egmParams :: EGTypeData Int,
+  egmVars :: EGTypeData Int,
+  egmNEdges :: Int,
+  egmEdges :: Map EGEdgeId EGEdge,
+  egmLinks :: EGTypeData (Map EGVarId [(EGEdgeId,Int)])
+} deriving (Eq,Show)
+
+filterModel :: EGModel -> (EGEdge -> Maybe a) -> (EGModel,[a])
+filterModel mod f = foldl ff (mod,[]) $ Map.toList $ egmEdges mod
+  where ff (mm,n) (id,ed) = 
+           let res = f ed
+               in case res of
+                 Nothing -> (mm,n)
+                 Just a -> (delEdge id mm,a:n)
+
+prefix :: String -> DisplayData -> DisplayData
+prefix s (DisplayData (s1,x)) = DisplayData (s++s1,x)
+
+instance Display EGModel where
+  displayer (EGModel { egmEdges = x }) = DisplayData ("EGModel",map (\(id,x) -> prefix ((show $ unEGEdgeId id)++": ") $ displayer x) $ Map.toList x)
+
+addEdge :: EGConstraintSpec -> EGTypeData [EGVarId] -> EGModel -> EGModel
+addEdge cons links model = 
+  if (expected == getConsArgs cons)
+    then
+      let newEdgeId = EGEdgeId $ egmNEdges model
+          in model {
+               egmNEdges = egmNEdges model + 1,
+               egmEdges = Map.insert newEdgeId (EGEdge { egeCons = cons, egeLinks = links }) $ egmEdges model,
+               egmLinks = egTypeDataMap $ \f -> 
+                 foldr (\i ->
+                     Map.insertWith (++) ((f links) !! i) [(newEdgeId,i)]
+                   ) (f $ egmLinks model) [0..(length (f links) - 1)]
+             }
+    else
+      error $ "incorrect number of arguments for constraint ("++(show cons)++")"
+  where expected = egTypeDataMap (\f -> length $ f links)
+
+unifyIds :: EGVarId -> EGVarId -> EGVarId -> EGVarId
+-- unifyIds fromId toId = (\x -> if x>fromId then x-1 else x) . (\x -> if x==fromId then toId else x)
+unifyIds fromId toId = \x -> if x==fromId then toId else x
+
+delEdge :: EGEdgeId -> EGModel -> EGModel
+delEdge id mod = do
+  let fnd = Map.lookup id $ egmEdges mod
+  case fnd of
+    Nothing -> error "deleting inexisting edge"
+    Just ff -> do
+      let nmp = Map.delete id $ egmEdges mod
+          mif [] = Nothing
+          mif x = Just x
+          afn = mif . filter ((/=id) . fst)
+          nln = egTypeDataMap $ \f -> foldr (\vid pre -> Map.alter (\(Just x) -> afn x) vid pre) (f $ egmLinks mod) $ f $ egeLinks ff
+      mod { egmEdges = nmp, egmLinks = nln }
+
+findEdge :: EGModel -> EGVarType -> EGVarId -> (Int -> Bool) -> (EGConstraintSpec -> Bool) -> Maybe (EGEdgeId,EGEdge)
+findEdge model typ varid pos cons =
+  let mtc1 = Map.findWithDefault [] varid $ egTypeGet typ $ egmLinks model
+      mtc2 = filter (\(_,p) -> pos p) mtc1
+      mtc3 = map (\(id,_) -> 
+        (id,case Map.lookup id (egmEdges model) of
+          Nothing -> error $ "cannot find edge id="++(show id)
+          Just xx -> xx
+        )) mtc2
+      mtc4 = filter (\(_,s) -> cons $ egeCons s) mtc3
+      in case mtc4 of
+        [] -> Nothing
+        a:_ -> Just a
+
+pruneNodes :: EGModel -> EGModel
+pruneNodes mod = 
+  mod { egmLinks = egTypeDataMap $ \f -> Map.fromList $ filter (\(_,v) -> case v of [] -> True; _ -> False) $ Map.toList $ f $ egmLinks mod }
+
+unifyNodes :: EGVarType -> EGVarId -> EGVarId -> EGModel -> EGModel
+unifyNodes vt fromId toId model = model {
+--  egmVars = egTypeMod vt (egmVars model) pred,
+  egmEdges = Map.map (\x -> x {
+    egeLinks = egTypeMod vt (egeLinks x) $ \z -> 
+      map (unifyIds fromId toId) z
+  }) $ egmEdges model,
+  egmLinks = egTypeMod vt (egmLinks model) $ \x -> Map.insertWith (++) toId (Map.findWithDefault [] fromId x) x
+}
+
+addNode :: EGVarType -> EGModel -> (EGVarId,EGModel)
+addNode vt model = (
+    EGVarId (egTypeGet vt $ egmVars model),
+    model {
+      egmVars = egTypeMod vt (egmVars model) succ
+    }
+  )
+
+delNode :: EGVarType -> EGVarId -> EGModel -> EGModel
+delNode vt id model = model { egmLinks = egTypeMod vt (egmLinks model) (Map.delete id) }
+
+baseGraph :: EGModel
+baseGraph = EGModel {
+  egmParams = baseTypeData 0,
+  egmVars = baseTypeData 0,
+  egmNEdges = 0,
+  egmEdges = Map.empty,
+  egmLinks = baseTypeData Map.empty
+}
+
+data DisplayData = DisplayData (String,[DisplayData])
+
+class Display a where
+  display :: Int -> a -> String
+  displayer :: a -> DisplayData
+  display n x = display n $ displayer x
+
+present :: Display a => a -> String
+present = display 0
+
+instance Display DisplayData where
+  displayer = id
+  display n (DisplayData (dir,sub)) = foldl (++) ((replicate (n*2) ' ')++dir++"\n") $ map (display $ n+1) sub
+
+displaySingle :: String -> DisplayData
+displaySingle x = DisplayData (x,[])
+
+getConnectedEdges :: EGModel -> EGVarType -> EGVarId -> [(EGEdge,Int)]
+getConnectedEdges model typ id = map (\(eid,pos) -> (fromJust $ Map.lookup eid $ egmEdges model, pos)) $ fromJust $ Map.lookup id $ egTypeGet typ $ egmLinks model

+ src/Control/CP/FD/Interface.hs view

@@ -0,0 +1,229 @@+{-# LANGUAGE GADTs #-}
+{-# LANGUAGE RankNTypes #-}
+{-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE MultiParamTypeClasses #-}
+{-# LANGUAGE TypeSynonymInstances #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE DatatypeContexts #-}
+
+module Control.CP.FD.Interface (
+  FDSolver,
+  FDInstance,
+  (@+),(@-),(@*),(@/),(@%),(!),(@!!),(@..),(@++),size,xfold,xsum,xhead,xtail,list,slice,xmap,cte,
+  (Control.CP.FD.Interface.@||),
+  (Control.CP.FD.Interface.@&&),
+  Control.CP.FD.Interface.inv,
+  (Control.CP.FD.Interface.@=),
+  (Control.CP.FD.Interface.@/=),
+  (Control.CP.FD.Interface.@<),
+  (Control.CP.FD.Interface.@>),
+  (Control.CP.FD.Interface.@<=),
+  (Control.CP.FD.Interface.@>=),
+  (Control.CP.FD.Interface.@:),
+  (Control.CP.FD.Interface.@?),
+  (Control.CP.FD.Interface.@??),
+  Control.CP.FD.Interface.channel,
+  val,
+--  Control.CP.FD.Interface.newInt, Control.CP.FD.Interface.newBool, Control.CP.FD.Interface.newCol,
+  Control.CP.FD.Interface.sorted, 
+  Control.CP.FD.Interface.sSorted,
+  Control.CP.FD.Interface.forall,
+  Control.CP.FD.Interface.forany,
+  Control.CP.FD.Interface.loopall,
+  Control.CP.FD.Interface.allDiff,
+  Control.CP.FD.Interface.allDiffD,
+  Control.CP.FD.Interface.loopany,
+  allin,
+  asExpr, asCol, Control.CP.FD.Interface.asBool,
+  colList, labelCol, 
+  ModelInt, ModelCol, ModelBool,
+  exists, true, false,
+--  Modelable,
+) where
+
+import Control.CP.FD.FD (FDSolver, FDInstance, FDIntTerm, getColItems)
+import qualified Control.CP.FD.Model as Model
+import Control.CP.FD.Model (Model, ModelBool, ModelCol, ModelInt, ToModelBool, asBool, asExpr, asCol, cte, newModelTerm, ModelIntArg, ModelBoolArg, ModelColArg)
+import qualified Data.Expr.Sugar as Sugar
+import Data.Expr.Util
+import Data.Expr.Data
+import Data.Expr.Sugar ((@+),(@-),(@*),(@/),(@%),(!),(@!!),(@..),(@++),size,xfold,xhead,xtail,slice,xmap,xsum,list)
+import Control.CP.Solver
+import Control.CP.SearchTree
+import Control.CP.EnumTerm
+import Control.Monad (ap, liftM)
+
+newtype DummySolver a = DummySolver ()
+
+instance Monad DummySolver where
+  return = pure
+  _ >>= _ = DummySolver ()
+
+instance Applicative DummySolver where
+  pure _ = DummySolver ()
+  (<*>) = ap
+
+instance Functor DummySolver where
+  fmap = liftM
+
+data EQHelp b where
+  EQHelp :: Model.ModelTermType b => ((b -> Model) -> Model) -> EQHelp b
+
+instance Model.ModelTermType t => Term DummySolver t where
+  type Help DummySolver t = EQHelp t
+  help _ _ = EQHelp newModelTerm
+  newvar = DummySolver ()
+
+instance Solver DummySolver where
+  type Constraint DummySolver = Either Model ()
+  type Label DummySolver = ()
+  add _ = DummySolver ()
+  run _ = error "Attempt to run dummy solver"
+  mark = DummySolver ()
+  goto _ = DummySolver ()
+
+newtype Model.ModelTermType t => DummyTerm t = DummyTerm t
+
+-- class (Solver s, Term s ModelBool, Term s ModelInt, Term s ModelCol) => Modelable s where
+
+-- instance Modelable DummySolver where
+
+-- instance FDSolver s => Modelable (FDInstance s) where
+
+
+treeToModel :: Tree DummySolver () -> Model
+treeToModel (Return _) = BoolConst True
+treeToModel (Try a b) = (Sugar.@||) (treeToModel a) (treeToModel b)
+treeToModel (Add (Left c) m) = (Sugar.@&&) c (treeToModel m)
+treeToModel Fail = BoolConst False
+treeToModel (Label _) = error "Cannot turn labelled trees into expressions"
+treeToModel (NewVar (f :: t -> Tree DummySolver ())) = case (help ((error "treeToModel undefined 1") :: DummySolver ()) ((error "treeToModel undefined 2") :: t)) of EQHelp ff -> ff (\x -> treeToModel $ f (x :: t))
+
+addM :: (Constraint s ~ Either Model q, MonadTree m, TreeSolver m ~ s) => Model -> m ()
+addM m = addC $ Left m
+
+infixr 2 @||
+(@||) :: (Constraint s ~ Either Model q, MonadTree m, TreeSolver m ~ s) => Tree DummySolver () -> Tree DummySolver () -> m ()
+(@||) a b = addM $ treeToModel $ a \/ b
+
+infixr 3 @&&
+(@&&) :: (Constraint s ~ Either Model q, MonadTree m, TreeSolver m ~ s) => Tree DummySolver () -> Tree DummySolver () -> m ()
+(@&&) a b = addM $ treeToModel $ a /\ b
+
+channel :: Tree DummySolver () -> ModelInt
+channel a = Sugar.channel $ treeToModel a
+
+inv :: (Constraint s ~ Either Model q, MonadTree m, TreeSolver m ~ s) => Tree DummySolver () -> m ()
+inv a = addM $ Sugar.inv $ treeToModel a
+
+infix 4 @=, @/=, @<, @>, @<=, @>=
+
+class ModelExprClass a where
+  (@=) :: (Constraint s ~ Either Model q, MonadTree m, TreeSolver m ~ s) => a -> a -> m ()
+  (@/=) :: (Constraint s ~ Either Model q, MonadTree m, TreeSolver m ~ s) => a -> a -> m ()
+
+instance ModelExprClass ModelInt where
+  a @= b  = addM $ (Sugar.@=)  a b
+  a @/= b = addM $ (Sugar.@/=) a b
+
+instance ModelExprClass ModelCol where
+  a @= b  = addM $ (Sugar.@=)  a b
+  a @/= b = addM $ (Sugar.@/=) a b
+
+instance ModelExprClass ModelBool where
+  a @= b  = addM $ (Sugar.@=)  a b
+  a @/= b = addM $ (Sugar.@/=) a b
+
+instance ModelExprClass (Tree DummySolver ()) where
+  a @= b  = addM $ (Sugar.@=)  (treeToModel a) (treeToModel b)
+  a @/= b = addM $ (Sugar.@/=) (treeToModel a) (treeToModel b)
+
+(@<) :: (Constraint s ~ Either Model q, MonadTree m, TreeSolver m ~ s) => ModelInt -> ModelInt -> m ()
+(@<) a b = addM $ (Sugar.@<) a b
+
+(@>) :: (Constraint s ~ Either Model q, MonadTree m, TreeSolver m ~ s) => ModelInt -> ModelInt -> m ()
+(@>) a b = addM $ (Sugar.@>) a b
+
+(@>=) :: (Constraint s ~ Either Model q, MonadTree m, TreeSolver m ~ s) => ModelInt -> ModelInt -> m ()
+(@>=) a b = addM $ (Sugar.@>=) a b
+
+(@<=) :: (Constraint s ~ Either Model q, MonadTree m, TreeSolver m ~ s) => ModelInt -> ModelInt -> m ()
+(@<=) a b = addM $ (Sugar.@<=) a b
+
+val :: Tree DummySolver () -> ModelInt
+val = Sugar.toExpr . treeToModel
+
+{- newBool :: (Constraint s ~ Either Model q, MonadTree m, TreeSolver m ~ s) => (ModelBool -> Tree DummySolver a) -> m a
+newBool = exists
+
+newInt :: (Constraint s ~ Either Model q, MonadTree m, TreeSolver m ~ s) => (ModelInt -> m a) -> m a
+newInt = exists
+
+newCol :: (Constraint s ~ Either Model q, MonadTree m, TreeSolver m ~ s) => (ModelCol -> m a) -> m a
+newCol = exists
+-}
+
+asBool :: (FDSolver s, MonadTree m, TreeSolver m ~ FDInstance s, ToModelBool t) => t -> m ()
+asBool = addM . Control.CP.FD.Model.asBool
+
+sorted :: (Constraint s ~ Either Model q, MonadTree m, TreeSolver m ~ s) => ModelCol -> m ()
+sorted = addM . Sugar.sorted
+
+sSorted :: (Constraint s ~ Either Model q, MonadTree m, TreeSolver m ~ s) => ModelCol -> m ()
+sSorted = addM . Sugar.sSorted
+
+allDiff :: (Constraint s ~ Either Model q, MonadTree m, TreeSolver m ~ s) => ModelCol -> m ()
+allDiff = addM . Sugar.allDiff
+
+allDiffD :: (Constraint s ~ Either Model q, MonadTree m, TreeSolver m ~ s) => ModelCol -> m ()
+allDiffD = addM . Sugar.allDiffD
+
+mm (nv@(Term tv)) m x = 
+     let tf t = if (t==tv) then x else Term t
+         tb t = if (Term t==x) then nv else Term t
+         in boolTransformEx (tf,ColTerm,BoolTerm,tb,ColTerm,BoolTerm) m
+
+forall :: (Term s ModelInt, Term s ModelBool, Term s ModelCol, Constraint s ~ Either Model q, MonadTree m, TreeSolver m ~ s) => ModelCol -> (ModelInt -> Tree DummySolver ()) -> m ()
+-- forall col f = exists $ \nv -> addM $ Sugar.forall col $ mm nv $ treeToModel $ f nv
+forall col f = addM $ Sugar.forall col (treeToModel . f)
+
+forany :: (Term s ModelInt, Term s ModelBool, Term s ModelCol, Constraint s ~ Either Model q, MonadTree m, TreeSolver m ~ s) => ModelCol -> (ModelInt -> Tree DummySolver ()) -> m ()
+-- forany col f = exists $ \nv -> addM $ Sugar.forany col $ mm nv $ treeToModel $ f nv
+forany col f = addM $ Sugar.forany col (treeToModel . f)
+
+loopall :: (Term s ModelInt, Term s ModelBool, Term s ModelCol, Constraint s ~ Either Model q, MonadTree m, TreeSolver m ~ s) => (ModelInt,ModelInt) -> (ModelInt -> Tree DummySolver ()) -> m ()
+-- loopall r f = exists $ \nv -> addM $ Sugar.loopall r $ mm nv $ treeToModel $ f nv
+loopall r f = addM $ Sugar.loopall r (treeToModel . f)
+
+loopany :: (Term s ModelInt, Term s ModelBool, Term s ModelCol, Constraint s ~ Either Model q, MonadTree m, TreeSolver m ~ s) => (ModelInt,ModelInt) -> (ModelInt -> Tree DummySolver ()) -> m ()
+-- loopany r f = exists $ \nv -> addM $ Sugar.loopany r $ mm nv $ treeToModel $ f nv
+loopany r f = addM $ Sugar.loopany r (treeToModel . f)
+
+colList :: (Constraint s ~ Either Model q, MonadTree m, TreeSolver m ~ s) => ModelCol -> Int -> m [ModelInt]
+colList col len = do
+  addM $ (Sugar.@=) (size col) (asExpr len)
+  return $ map (\i -> col!cte i) [0..len-1]
+
+labelCol :: (FDSolver s, MonadTree m, TreeSolver m ~ FDInstance s, EnumTerm s (FDIntTerm s)) => ModelCol -> m [TermBaseType s (FDIntTerm s)]
+labelCol col = label $ do
+  lst <- getColItems col maxBound
+  return $ do
+    lsti <- colList col $ length lst
+    enumerate lsti
+    assignments lsti
+
+infix 5 @:
+
+(@:) :: (Constraint s ~ Either Model q, MonadTree m, TreeSolver m ~ s, Sugar.ExprRange ModelIntArg ModelColArg ModelBoolArg r, Term s ModelInt, Term s ModelBool, Term s ModelCol) => ModelInt -> r -> m ()
+a @: b = addM $ (Sugar.@:) a b
+
+infix 4 @?
+infix 4 @??
+
+a @? (t,f) = (Sugar.@?) (treeToModel a) (t,f)
+a @?? (t,f) = addM $ (Sugar.@??) (treeToModel a) (treeToModel t, treeToModel f)
+
+allin :: (Constraint s ~ Either Model q, MonadTree m, TreeSolver m ~ s, Sugar.ExprRange ModelIntArg ModelColArg ModelBoolArg r, Term s ModelInt, Term s ModelBool, Term s ModelCol) => ModelCol -> r -> m ()
+allin c b = Control.CP.FD.Interface.forall c $ \x -> addM $ (Sugar.@:) x b

+ src/Control/CP/FD/Model.hs view

@@ -0,0 +1,192 @@+{- 
+ - 	Monadic Constraint Programming
+ - 	http://www.cs.kuleuven.be/~toms/Haskell/
+ - 	Tom Schrijvers & Pieter Wuille
+ -}
+
+{-# LANGUAGE StandaloneDeriving #-}
+{-# LANGUAGE TypeSynonymInstances #-}
+{-# LANGUAGE UndecidableInstances #-}
+{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE FlexibleContexts #-}
+
+module Control.CP.FD.Model (
+  Model,
+  ModelIntTerm(..),
+  ModelBoolTerm(..),
+  ModelColTerm(..),
+  ModelFunctions(..),
+  ModelInt,  ToModelInt(..), ModelIntArg,
+  ModelCol,  ToModelCol(..), ModelColArg,
+  ModelBool, ToModelBool(..), ModelBoolArg,
+  modelVariantInt, modelVariantBool, modelVariantCol,
+  ModelTermType(..),
+  showModel,
+  cte,
+) where
+
+import Data.Expr.Data
+import Data.Expr.Util
+import Data.Expr.Sugar
+
+data ModelIntTerm t = 
+    ModelIntVar Int
+  | ModelIntPar Int
+  deriving (Show)
+
+data ModelColTerm t = 
+    ModelColVar Int
+  | ModelColPar Int
+  deriving (Show)
+
+data ModelBoolTerm t = 
+    ModelBoolVar Int
+  | ModelBoolPar Int
+  | ModelExtra t
+  deriving (Show)
+
+data ModelFunctions =
+    ForNewBool (ModelBoolExpr ModelFunctions -> Model)
+  | ForNewInt (ModelIntExpr ModelFunctions -> Model)
+  | ForNewCol (ModelColExpr ModelFunctions -> Model)
+
+data ModelIntros =
+     NewBool Int FlatModel
+   | NewInt Int FlatModel
+   | NewCol Int FlatModel
+   deriving (Show,Eq)
+
+instance Ord ModelIntros where
+  compare (NewBool n1 m1) (NewBool n2 m2) = compare n1 n2 <<>> compare m1 m2
+  compare (NewBool _ _) _ = LT
+  compare _ (NewBool _ _) = GT
+  compare (NewInt n1 m1) (NewInt n2 m2) = compare n1 n2 <<>> compare m1 m2
+  compare (NewInt _ _) _ = LT
+  compare _ (NewInt _ _) = GT
+  compare (NewCol n1 m1) (NewCol n2 m2) = compare n1 n2 <<>> compare m1 m2
+
+instance Show ModelFunctions where
+  show (ForNewBool f) = show $ explicate (-999999) $ f $ BoolTerm $ ModelBoolVar (-1000000)
+  show (ForNewInt f) = show $ explicate (-1999999) $ f $ Term $ ModelIntVar (-2000000)
+  show (ForNewCol f) = show $ explicate (-2999999) $ f $ ColTerm $ ModelColVar (-3000000)
+  
+instance Eq ModelFunctions where
+  a==b = False
+
+instance Ord ModelFunctions where
+  compare _ _ = error "Unable to compare model functions"
+
+-- instance Show Model where 
+--   show x = show $ explicate 0 x
+
+deriving instance Eq t => Eq (ModelBoolTerm t)
+deriving instance Ord t => Ord (ModelBoolTerm t)
+deriving instance Eq t => Eq (ModelIntTerm t)
+deriving instance Ord t => Ord (ModelIntTerm t)
+deriving instance Eq t => Eq (ModelColTerm t)
+deriving instance Ord t => Ord (ModelColTerm t)
+
+type ModelIntExpr t       = Expr        (ModelIntTerm  t) (ModelColTerm  t) (ModelBoolTerm  t)
+type ModelBoolExpr t      = BoolExpr    (ModelIntTerm  t) (ModelColTerm  t) (ModelBoolTerm  t)
+type ModelColExpr t       = ColExpr     (ModelIntTerm  t) (ModelColTerm  t) (ModelBoolTerm  t)
+
+type ModelInt = ModelIntExpr ModelFunctions
+type ModelBool = ModelBoolExpr ModelFunctions
+type ModelCol = ModelColExpr ModelFunctions
+
+type ModelIntArg = ModelIntTerm ModelFunctions
+type ModelBoolArg = ModelBoolTerm ModelFunctions
+type ModelColArg = ModelColTerm ModelFunctions
+
+type FlatModelInt = ModelIntExpr ModelIntros
+type FlatModelBool = ModelBoolExpr ModelIntros
+type FlatModelCol = ModelColExpr ModelIntros
+
+type Model = ModelBool
+type FlatModel = FlatModelBool
+
+explicate :: Int -> Model -> FlatModel
+explicate num mod = boolTransformEx (it,ct,bt,iit,ict,ibt) mod
+  where it (ModelIntVar i) = Term $ ModelIntVar i
+        it (ModelIntPar i) = Term $ ModelIntPar i
+        ct (ModelColVar i) = ColTerm $ ModelColVar i
+        ct (ModelColPar i) = ColTerm $ ModelColPar i
+        iit (ModelIntVar i) = Term $ ModelIntVar i
+        iit (ModelIntPar i) = Term $ ModelIntPar i
+        ict (ModelColVar i) = ColTerm $ ModelColVar i
+        ict (ModelColPar i) = ColTerm $ ModelColPar i
+        ibt (ModelBoolVar i) = BoolTerm $ ModelBoolVar i
+        ibt (ModelBoolPar i) = BoolTerm $ ModelBoolPar i
+        bt (ModelBoolVar i) = BoolTerm $ ModelBoolVar i
+        bt (ModelBoolPar i) = BoolTerm $ ModelBoolPar i
+        bt (ModelExtra (ForNewBool f)) = BoolTerm $ ModelExtra $ NewBool num $ explicate (num+1) $ f $ BoolTerm $ ModelBoolVar num
+        bt (ModelExtra (ForNewInt f)) = BoolTerm $ ModelExtra $ NewInt num $ explicate (num+1) $ f $ Term $ ModelIntVar num
+        bt (ModelExtra (ForNewCol f)) = BoolTerm $ ModelExtra $ NewCol num $ explicate (num+1) $ f $ ColTerm $ ModelColVar num
+
+flatten :: Model -> FlatModel
+flatten = explicate 0
+
+showModel :: Model -> String
+showModel = show . flatten
+
+variantIntTerm :: ModelIntTerm a -> Bool
+variantIntTerm (ModelIntVar _) = True
+variantIntTerm (ModelIntPar _) = False
+
+variantBoolTerm :: ModelBoolTerm a -> Bool
+variantBoolTerm (ModelBoolVar _) = True
+variantBoolTerm (ModelBoolPar _) = False
+variantBoolTerm (ModelExtra _) = True
+
+variantColTerm :: ModelColTerm a -> Bool
+variantColTerm (ModelColVar _) = True
+variantColTerm (ModelColPar _) = False
+
+modelVariantInt  :: ModelIntExpr x -> Bool
+modelVariantInt  =     property variantIntTerm variantColTerm variantBoolTerm
+modelVariantCol  :: ModelColExpr x -> Bool
+modelVariantCol  =  colProperty variantIntTerm variantColTerm variantBoolTerm
+modelVariantBool :: ModelBoolExpr x -> Bool
+modelVariantBool = boolProperty variantIntTerm variantColTerm variantBoolTerm
+
+newBool :: (ModelBool -> Model) -> Model
+newBool = boolSimplify . BoolTerm . ModelExtra . ForNewBool
+
+newInt :: (ModelInt -> Model) -> Model
+newInt = boolSimplify . BoolTerm . ModelExtra . ForNewInt
+
+newCol :: (ModelCol -> Model) -> Model
+newCol = boolSimplify . BoolTerm . ModelExtra . ForNewCol
+
+class ModelTermType s where
+  newModelTerm :: (s -> Model) -> Model
+
+instance ModelTermType ModelBool where
+  newModelTerm = newBool
+
+instance ModelTermType ModelInt where
+  newModelTerm = newInt
+
+instance ModelTermType ModelCol where
+  newModelTerm = newCol
+
+cte :: Integral a => a -> ModelInt
+cte = Const . toInteger
+
+class ToModelBool t where
+  asBool :: t -> ModelBool
+
+class ToModelInt t where
+  asExpr :: t -> ModelInt
+
+class ToModelCol t where
+  asCol :: t -> ModelCol
+
+instance ToExpr (ModelIntTerm ModelFunctions) (ModelColTerm ModelFunctions) (ModelBoolTerm ModelFunctions) t => ToModelInt t where
+  asExpr = toExpr
+
+instance ToBoolExpr (ModelIntTerm ModelFunctions) (ModelColTerm ModelFunctions) (ModelBoolTerm ModelFunctions) t => ToModelBool t where
+  asBool = toBoolExpr
+
+instance ToColExpr (ModelIntTerm ModelFunctions) (ModelColTerm ModelFunctions) (ModelBoolTerm ModelFunctions) t => ToModelCol t where
+  asCol = toColExpr

+ src/Control/CP/FD/OvertonFD/Domain.hs view

@@ -0,0 +1,187 @@+{- 
+ - Origin:
+ -     Constraint Programming in Haskell 
+ -     http://overtond.blogspot.com/2008/07/pre.html
+ -     author: David Overton, Melbourne Australia
+ -
+ - Modifications:
+ -     Monadic Constraint Programming
+ -     http://www.cs.kuleuven.be/~toms/Haskell/
+ -     Tom Schrijvers
+ -} 
+
+{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE IncoherentInstances #-}
+{-# LANGUAGE UndecidableInstances #-}
+
+module Control.CP.FD.OvertonFD.Domain (
+    Domain,
+    ToDomain,
+    toDomain,
+    member,
+    isSubsetOf,
+    elems,
+    intersection,
+    difference,
+    union,
+    empty,
+    null,
+    singleton,
+    isSingleton,
+    filterLessThan,
+    filterGreaterThan,
+    findMax,
+    findMin,
+    size,
+    shiftDomain,
+    mapDomain,
+    absDomain
+) where
+
+import qualified Data.IntSet as IntSet
+import Data.IntSet (IntSet)
+import Prelude hiding (null)
+import Control.CP.Debug
+
+data Domain
+    = Set IntSet
+    | Range !Int !Int
+    deriving Show
+
+size :: Domain -> Int
+size (Range l u) = u - l + 1
+size (Set set)   = IntSet.size set
+
+-- Domain constructors
+class ToDomain a where
+    toDomain :: a -> Domain
+
+instance ToDomain Domain where
+    toDomain = id
+
+instance ToDomain IntSet where
+    toDomain = Set
+
+instance Integral a => ToDomain [a] where
+    toDomain = toDomain . IntSet.fromList . map fromIntegral
+
+instance (Integral a, Integral b) => ToDomain (a, b) where
+    toDomain (a, b) = Range (fromIntegral a) (fromIntegral b)
+
+instance ToDomain () where
+    toDomain () = Range (-1000000000) 1000000000 -- minBound maxBound (too sensitive to overflow, e.g. 2 * minBound == 0)
+
+instance Integral a => ToDomain a where
+    toDomain a = toDomain (a, a)
+
+-- Operations on Domains
+instance Eq Domain where
+    (Range xl xh) == (Range yl yh) = xl == yl && xh == yh
+    xs == ys = elems xs == elems ys
+
+member :: Int -> Domain -> Bool
+member n x@(Set xs) = debugDom "[Domain.member]" x $ n `IntSet.member` xs
+member n x@(Range xl xh) = debugDom "[Domain.member]" x $ n >= xl && n <= xh
+
+isSubsetOf :: Domain -> Domain -> Bool
+isSubsetOf x@(Set xs) (Set ys) = debugDom "[Domain.isso]" x $ xs `IntSet.isSubsetOf` ys
+isSubsetOf x@(Range xl xh) (Range yl yh) = debugDom "[Domain.isso]" x $ xl >= yl && xh <= yh
+isSubsetOf x@(Set xs) yd@(Range yl yh) = debugDom "[Domain.isso]" x $ 
+    isSubsetOf (Range xl xh) yd where
+        xl = IntSet.findMin xs
+        xh = IntSet.findMax xs
+isSubsetOf (Range xl xh) x@(Set ys) = debugDom "[Domain.isso]" x $ 
+    all (`IntSet.member` ys) [xl..xh]
+
+elems :: Domain -> [Int]
+elems x@(Set xs) = debugDom "[Domain.elems]" x $ IntSet.elems xs
+elems x@(Range xl xh) = debugDom "[Domain.elems]" x $ [xl..xh]
+
+intersection :: Domain -> Domain -> Domain
+intersection x@(Set xs) (Set ys) = debugDom "[Domain.intersection]" x $ Set (xs `IntSet.intersection` ys)
+intersection x@(Range xl xh) (Range yl yh) = debugDom "[Domain.intersection]" x $ Range (max xl yl) (min xh yh)
+intersection x@(Set xs) (Range yl yh) = debugDom "[Domain.intersection]" x $ 
+    Set $ IntSet.filter (\x -> x >= yl && x <= yh) xs
+intersection x y = intersection y x
+
+union :: Domain -> Domain -> Domain
+union x@(Set xs) (Set ys) = debugDom "[Domain.union]" x $ Set (xs `IntSet.union` ys)
+union x@(Range xl xh) (Range yl yh) 
+      | xh + 1 >= yl || yh+1 >= xl = debugDom "[Domain.union]" x $ Range (min xl yl) (max xh yh)
+      | otherwise = debugDom "[Domain.union]" x $ union (Set $ IntSet.fromList [xl..xh]) (Set $ IntSet.fromList [yl..yh]) 
+union x@(Set xs) y@(Range yl yh) = debugDom "[Domain.union]" x $ 
+      if null x then y 
+      else
+      let xmin = IntSet.findMin xs
+          xmax = IntSet.findMax xs
+      in 
+      if (xmin + 1 >= yl && xmax - 1 <= yh) 
+         then Range (min xmin yl) (max xmax yh)
+         else union (Set xs) (Set $ IntSet.fromList [yl..yh])
+union x y = union y x
+
+difference :: Domain -> Domain -> Domain
+difference (x@(Set xs)) (y@(Set ys)) = debugDom "[Domain.difference]" x $ Set (xs `IntSet.difference` ys)
+difference xd@(Range xl xh) (Range yl yh)
+    | yl > xh || yh < xl = debugDom "[Domain.difference]" xd $ xd
+    | otherwise = debugDom "[Domain.difference]" xd $ Set $ IntSet.fromList [x | x <- [xl..xh], x < yl || x > yh]
+difference (x@(Set xs)) (Range yl yh) =
+    debugDom "[Domain.difference]" x $ Set $ IntSet.filter (\x -> x < yl || x > yh) xs
+difference (x@(Range xl xh)) (Set ys)
+    | IntSet.findMin ys > xh || IntSet.findMax ys < xl = debugDom "[Domain.difference]" x $ Range xl xh
+    | otherwise = debugDom "[Domain.difference]" x $ Set $
+        IntSet.fromList [x | x <- [xl..xh], not (x `IntSet.member` ys)]
+
+null :: Domain -> Bool
+null (x@(Set xs)) = debug ("[Domain.null] " ++ printDom x) $ IntSet.null xs
+null (x@(Range xl xh)) = debug ("[Domain.null] " ++ printDom x) $ xl > xh
+
+singleton :: Int -> Domain
+singleton x = Range x x
+
+isSingleton :: Domain -> Bool
+isSingleton (x@(Set xs)) = debugDom "[Domain.isSingleton]" x $ (IntSet.size xs)==1
+isSingleton (x@(Range xl xh)) = debug ("[Domain.isSingleton] " ++ printDom x) $ xl == xh
+
+filterLessThan :: Int -> Domain -> Domain
+filterLessThan n (x@(Set xs)) = debug ("[Domain.filterLess] " ++ printDom x) $ Set $ IntSet.filter (< n) xs
+filterLessThan n (x@(Range xl xh)) = debug ("[Domain.filterLess] " ++ printDom x) $ Range xl (min (n-1) xh)
+
+filterGreaterThan :: Int -> Domain -> Domain
+filterGreaterThan n (x@(Set xs)) = debug ("[Domain.filterGreater] " ++ printDom x) $ Set $ IntSet.filter (> n) xs
+filterGreaterThan n (x@(Range xl xh)) = debug ("[Domain.filterGreater] " ++ printDom x) $ Range (max (n+1) xl) xh
+
+findMax :: Domain -> Int
+findMax (x@(Set xs)) = debug ("[Domain.findMax] " ++ printDom x) $ IntSet.findMax xs
+findMax (x@(Range xl xh)) = debug ("[Domain.findMax] " ++ printDom x) $ xh
+
+findMin :: Domain -> Int
+findMin (Set xs) = IntSet.findMin xs
+findMin (Range xl xh) = xl
+
+empty :: Domain
+empty = Range 1 0
+
+shiftDomain :: Domain -> Int -> Domain
+shiftDomain (x@(Range l u)) d = debug ("[Domain.shift] " ++ printDom x) $ Range (l + d) (u + d)
+shiftDomain (x@(Set xs)) d = debug ("[Domain.shift] " ++ printDom x) $ Set $ IntSet.fromList $ map (+d) (IntSet.elems xs)
+
+mapDomain :: Domain -> (Int -> [Int]) -> Domain
+mapDomain d f = debug ("[Domain.map] " ++ printDom d) $ Set $ IntSet.fromList $ concatMap f $ elems d
+
+absDomain :: Domain -> Domain
+absDomain d@(Range l u)  | l >= 0     = d
+                         | u <  0     = Range (abs u) (abs l)
+                         | otherwise  = Range 0 (max (abs l) u)
+absDomain d@(Set s)      | IntSet.findMin s >= 0  = d
+                         | otherwise              = Set $ IntSet.map abs s
+
+mirrorDomain :: Domain -> Domain
+mirrorDomain d@(Range l u)   | l <= 0 && u >= 0  = Range (min l (-u)) (max (-l) u)
+
+printDom :: Domain -> String
+printDom (Set cs) = "dom:Set(#" ++ (show $ IntSet.size cs) ++ ")"
+printDom (Range l h) = "dom:Range(#" ++ (show $ h-l+1) ++ ":" ++ (show l) ++ "-" ++ (show h) ++ ")"
+
+debugDom :: String -> Domain -> a -> a
+debugDom s d a = debug ("[Domain.findMax] " ++ printDom d) a

+ src/Control/CP/FD/OvertonFD/OvertonFD.hs view

@@ -0,0 +1,392 @@+{- 
+ - Origin:
+ -      Constraint Programming in Haskell 
+ -      http://overtond.blogspot.com/2008/07/pre.html
+ -      author: David Overton, Melbourne Australia
+ -
+ - Modifications:
+ -      Monadic Constraint Programming
+ -      http://www.cs.kuleuven.be/~toms/Haskell/
+ -      Tom Schrijvers
+ -} 
+
+{-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE MultiParamTypeClasses #-}
+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
+
+module Control.CP.FD.OvertonFD.OvertonFD (
+  OvertonFD,
+  fd_objective,
+  fd_domain,
+  FDVar,
+  OConstraint(..),
+  lookup,
+) where
+
+import Prelude hiding (lookup)
+import Data.Maybe (fromJust,isJust)
+import Control.Monad.State.Lazy
+import Control.Monad.Trans
+import qualified Data.Map as Map
+import Data.Map ((!), Map)
+import Control.Monad (liftM,(<=<))
+
+import Control.CP.FD.OvertonFD.Domain as Domain
+import Control.CP.FD.FD hiding ((!))
+import Control.CP.Solver
+import Control.CP.SearchTree
+import Control.CP.EnumTerm
+
+import Control.CP.Debug
+
+--------------------------------------------------------------------------------
+-- Solver instance -------------------------------------------------------------
+--------------------------------------------------------------------------------
+
+data OConstraint =
+    OHasValue FDVar Int
+  | OSame FDVar FDVar
+  | ODiff FDVar FDVar
+  | OLess FDVar FDVar
+  | OLessEq FDVar FDVar
+  | OAdd FDVar FDVar FDVar
+  | OSub FDVar FDVar FDVar
+  | OMult FDVar FDVar FDVar
+  | OAbs FDVar FDVar
+  deriving (Show,Eq)
+
+instance Solver OvertonFD where
+  type Constraint OvertonFD  = OConstraint
+  type Label      OvertonFD  = FDState
+  add c         = debug ("addOverton("++(show c)++")") $ addOverton c
+  run p         = debug ("runOverton") $ runOverton p
+  mark  = get
+  goto  = put 
+
+instance Term OvertonFD FDVar where
+  newvar        = newVar ()
+  type Help OvertonFD FDVar = ()
+  help _ _ = ()
+
+instance EnumTerm OvertonFD FDVar where
+  type TermBaseType OvertonFD FDVar = Int
+  getDomain = fd_domain
+  setValue var val = return [var `OHasValue` val]
+
+--------------------------------------------------------------------------------
+-- Constraints -----------------------------------------------------------------
+--------------------------------------------------------------------------------
+
+addOverton (OHasValue v i) = v `hasValue` i
+addOverton (OSame a b) = a `same` b
+addOverton (ODiff a b) = a `different` b
+addOverton (OLess a b) = a .<. b
+addOverton (OLessEq a b) = a .<=. b
+addOverton (OAdd a b c) = addSum a b c
+addOverton (OSub a b c) = addSub a b c
+addOverton (OMult a b c) = addMult a b c
+addOverton (OAbs a b) = addAbs a b
+
+fd_domain :: FDVar -> OvertonFD [Int]
+fd_domain v = do d <- lookup v
+                 return $ elems d
+
+fd_objective :: OvertonFD FDVar
+fd_objective =
+  do s <- get
+     return $ objective s
+
+--------------------------------------------------------------------------------
+
+-- The FD monad
+newtype OvertonFD a = OvertonFD { unFD :: State FDState a }
+    deriving (Monad, Applicative, Functor, MonadState FDState)
+
+-- FD variables
+newtype FDVar = FDVar { unFDVar :: Int } deriving (Ord, Eq, Show)
+
+type VarSupply = FDVar
+
+data VarInfo = VarInfo
+     { delayedConstraints :: OvertonFD Bool, domain :: Domain }
+
+instance Show VarInfo where
+  show x = show $ domain x
+
+type VarMap = Map FDVar VarInfo
+
+data FDState = FDState
+     { varSupply :: VarSupply, varMap :: VarMap, objective :: FDVar }
+     deriving Show
+
+instance Eq FDState where
+  s1 == s2 = f s1 == f s2
+           where f s = head $ elems $ domain $ varMap s ! (objective s) 
+
+instance Ord FDState where
+  compare s1 s2  = compare (f s1) (f s2)
+           where f s = head $ elems $  domain $ varMap s ! (objective s) 
+
+  -- TOM: inconsistency is not observable within the OvertonFD monad
+consistentFD :: OvertonFD Bool
+consistentFD = return True
+
+-- Run the FD monad and produce a lazy list of possible solutions.
+runOverton :: OvertonFD a -> a
+runOverton fd = 
+  let j = evalState (unFD fd) initState
+      in j
+
+initState :: FDState
+initState = FDState { varSupply = FDVar 0, varMap = Map.empty, objective = FDVar 0 }
+
+-- Get a new FDVar
+newVar :: ToDomain a => a -> OvertonFD FDVar
+newVar d = do
+    s <- get
+    let v = varSupply s
+    put $ s { varSupply = FDVar (unFDVar v + 1) }
+    modify $ \s ->
+        let vm = varMap s
+            vi = VarInfo {
+                delayedConstraints = return True,
+                domain = toDomain d}
+        in
+        s { varMap = Map.insert v vi vm }
+    return v
+
+newVars :: ToDomain a => Int -> a -> OvertonFD [FDVar]
+newVars n d = replicateM n (newVar d)
+
+-- Lookup the current domain of a variable.
+lookup :: FDVar -> OvertonFD Domain
+lookup x = do
+    s <- get
+    return . domain $ varMap s ! x
+
+-- Update the domain of a variable and fire all delayed constraints
+-- associated with that variable.
+update :: FDVar -> Domain -> OvertonFD Bool
+update x i = do
+    debug (show x ++ " <- " ++ show i)  (return ())
+    s <- get
+    let vm = varMap s
+    let vi = vm ! x
+    debug ("where old domain = " ++ show (domain vi)) (return ())
+    put $ s { varMap = Map.insert x (vi { domain = i}) vm }
+    delayedConstraints vi
+
+-- Add a new constraint for a variable to the constraint store.
+addConstraint :: FDVar -> OvertonFD Bool -> OvertonFD ()
+addConstraint x constraint = do
+    s <- get
+    let vm = varMap s
+    let vi = vm ! x
+    let cs = delayedConstraints vi
+    put $ s { varMap =
+        Map.insert x (vi { delayedConstraints = do b <- cs 
+                                                   if b then constraint
+                                                        else return False}) vm }
+ 
+-- Useful helper function for adding binary constraints between FDVars.
+type BinaryConstraint = FDVar -> FDVar -> OvertonFD Bool
+addBinaryConstraint :: BinaryConstraint -> BinaryConstraint 
+addBinaryConstraint f x y = do
+    let constraint  = f x y
+    b <- constraint 
+    when b $ (do addConstraint x constraint
+                 addConstraint y constraint)
+    return b
+
+-- Constrain a variable to a particular value.
+hasValue :: FDVar -> Int -> OvertonFD Bool
+var `hasValue` val = do
+    vals <- lookup var
+    if val `member` vals
+       then do let i = singleton val
+               if (i /= vals) 
+                  then update var i
+                  else return True
+       else return False
+
+-- Constrain two variables to have the same value.
+same :: FDVar -> FDVar -> OvertonFD Bool
+same = addBinaryConstraint $ \x y -> do 
+    debug "inside same" $ return ()
+    xv <- lookup x
+    yv <- lookup y
+    debug (show xv ++ " same " ++ show yv) $ return ()
+    let i = xv `intersection` yv
+    if not $ Domain.null i
+       then whenwhen (i /= xv)  (i /= yv) (update x i) (update y i)
+       else return False
+
+whenwhen c1 c2 a1 a2  =
+  if c1
+     then do b1 <- a1
+             if b1 
+                then if c2
+                        then a2
+                        else return True
+                else return False 
+     else if c2
+             then a2
+             else return True
+
+-- Constrain two variables to have different values.
+different :: FDVar  -> FDVar  -> OvertonFD Bool
+different = addBinaryConstraint $ \x y -> do
+    xv <- lookup x
+    yv <- lookup y
+    if not (isSingleton xv) || not (isSingleton yv) || xv /= yv
+       then whenwhen (isSingleton xv && xv `isSubsetOf` yv)
+                     (isSingleton yv && yv `isSubsetOf` xv)
+                     (update y (yv `difference` xv))
+                     (update x (xv `difference` yv))
+       else return False
+
+-- Constrain one variable to have a value less than the value of another
+-- variable.
+infix 4 .<.
+(.<.) :: FDVar -> FDVar -> OvertonFD Bool
+(.<.) = addBinaryConstraint $ \x y -> do
+    xv <- lookup x
+    yv <- lookup y
+    let xv' = filterLessThan (findMax yv) xv
+    let yv' = filterGreaterThan (findMin xv) yv
+    if  not $ Domain.null xv'
+        then if not $ Domain.null yv'
+                then whenwhen (xv /= xv') (yv /= yv') (update x xv') (update y yv')
+                else return False
+        else return False
+
+-- Constrain one variable to have a value less than or equal to the value of another 
+-- variable.
+infix 4 .<=.
+(.<=.) :: FDVar -> FDVar -> OvertonFD Bool
+(.<=.) = addBinaryConstraint $ \x y -> do
+    xv <- lookup x
+    yv <- lookup y
+    let xv' = filterLessThan (1 + findMax yv) xv
+    let yv' = filterGreaterThan ((findMin xv) - 1) yv
+    if  not $ Domain.null xv'
+        then if not $ Domain.null yv'
+                then whenwhen (xv /= xv') (yv /= yv') (update x xv') (update y yv')
+                else return False
+        else return False
+
+{-
+-- Get all solutions for a constraint without actually updating the
+-- constraint store.
+solutions :: OvertonFD s a -> OvertonFD s [a]
+solutions constraint = do
+    s <- get
+    return $ evalStateT (unFD constraint) s
+
+-- Label variables using a depth-first left-to-right search.
+labelling :: [FDVar s] -> OvertonFD s [Int]
+labelling = mapM label where
+    label var = do
+        vals <- lookup var
+        val <- OvertonFD . lift $ elems vals
+        var `hasValue` val
+        return val
+-}
+
+dump :: [FDVar] -> OvertonFD [Domain]
+dump = mapM lookup
+
+-- Add constraint (z = x `op` y) for var z
+addArithmeticConstraint :: 
+    (Domain -> Domain -> Domain) ->
+    (Domain -> Domain -> Domain) ->
+    (Domain -> Domain -> Domain) ->
+    FDVar -> FDVar -> FDVar -> OvertonFD Bool
+addArithmeticConstraint getZDomain getXDomain getYDomain x y z = do
+    xv <- lookup x
+    yv <- lookup y
+    let constraint z x y getDomain = do
+        xv <- lookup x
+        yv <- lookup y
+        zv <- lookup z
+        let znew = debug "binaryArith:intersection" $ (debug "binaryArith:zv" $ zv) `intersection` (debug "binaryArith:getDomain" $ getDomain xv yv)
+        debug ("binaryArith:" ++ show z ++ " before: "  ++ show zv ++ show "; after: " ++ show znew) (return ())
+        if debug "binaryArith:null?" $ not $ Domain.null (debug "binaryArith:null?:znew" $ znew)
+           then if (znew /= zv) 
+                   then debug ("binaryArith:update") $ update z znew
+                   else return True
+           else return False
+    let zConstraint = debug "binaryArith: zConstraint" $ constraint z x y getZDomain
+        xConstraint = debug "binaryArith: xConstraint" $ constraint x z y getXDomain
+        yConstraint = debug "binaryArith: yConstraint" $ constraint y z x getYDomain
+    debug ("addBinaryArith: z x") (return ())
+    addConstraint z xConstraint
+    debug ("addBinaryArith: z y") (return ())
+    addConstraint z yConstraint
+    debug ("addBinaryArith: x z") (return ())
+    addConstraint x zConstraint
+    debug ("addBinaryArith: x y") (return ())
+    addConstraint x yConstraint
+    debug ("addBinaryArith: y z") (return ())
+    addConstraint y zConstraint
+    debug ("addBinaryArith: y x") (return ())
+    addConstraint y xConstraint
+    debug ("addBinaryArith: done") (return ())
+    return True
+
+-- Add constraint (z = op x) for var z
+addUnaryArithmeticConstraint :: (Domain -> Domain) -> (Domain -> Domain) -> FDVar -> FDVar -> OvertonFD Bool
+addUnaryArithmeticConstraint getZDomain getXDomain x z = do
+    xv <- lookup x
+    let constraint z x getDomain = do
+        xv <- lookup x
+        zv <- lookup z
+        let znew = zv `intersection` (getDomain xv)
+        debug ("unaryArith:" ++ show z ++ " before: "  ++ show zv ++ show "; after: " ++ show znew) (return ())
+        if not $ Domain.null znew
+           then if (znew /= zv) 
+                   then update z znew
+                   else return True
+           else return False
+    let zConstraint = constraint z x getZDomain
+        xConstraint = constraint x z getXDomain
+    addConstraint z xConstraint
+    addConstraint x zConstraint
+    return True
+
+addSum = addArithmeticConstraint getDomainPlus getDomainMinus getDomainMinus
+
+addSub = addArithmeticConstraint getDomainMinus getDomainPlus (flip getDomainMinus)
+
+addMult = addArithmeticConstraint getDomainMult getDomainDiv getDomainDiv
+
+addAbs = addUnaryArithmeticConstraint absDomain (\z -> mapDomain z (\i -> [i,-i]))
+
+getDomainPlus :: Domain -> Domain -> Domain
+getDomainPlus xs ys = toDomain (zl, zh) where
+    zl = findMin xs + findMin ys
+    zh = findMax xs + findMax ys
+
+getDomainMinus :: Domain -> Domain -> Domain
+getDomainMinus xs ys = toDomain (zl, zh) where
+    zl = findMin xs - findMax ys
+    zh = findMax xs - findMin ys
+
+getDomainMult :: Domain -> Domain -> Domain
+getDomainMult xs ys = (\d -> debug ("multDomain" ++ show d ++ "=" ++ show xs ++ "*" ++ show ys ) d) $ toDomain (zl, zh) where
+    zl = minimum products
+    zh = maximum products
+    products = [x * y |
+        x <- [findMin xs, findMax xs],
+        y <- [findMin ys, findMax ys]]
+
+getDomainDiv :: Domain -> Domain -> Domain
+getDomainDiv xs ys = toDomain (zl, zh) where
+    zl = minimum quotientsl
+    zh = maximum quotientsh
+    quotientsl = [if y /= 0 then x `div` y else minBound |
+        x <- [findMin xs, findMax xs],
+        y <- [findMin ys, findMax ys]]
+    quotientsh = [if y /= 0 then x `div` y else maxBound |
+        x <- [findMin xs, findMax xs],
+        y <- [findMin ys, findMax ys]]

+ src/Control/CP/FD/OvertonFD/Sugar.hs view

@@ -0,0 +1,113 @@+{-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE FlexibleContexts #-}
+
+module Control.CP.FD.OvertonFD.Sugar (
+) where
+
+import Data.Set(Set)
+import qualified Data.Set as Set
+
+import Control.CP.Debug
+import Control.Mixin.Mixin
+import Control.CP.Solver
+import Control.CP.FD.FD
+import Control.CP.FD.SimpleFD
+import Data.Expr.Data
+import Data.Expr.Sugar
+-- import Control.CP.FD.Expr.Util
+import Control.CP.FD.Model
+import Control.CP.FD.Graph
+import Control.CP.FD.OvertonFD.OvertonFD
+
+newVars :: Term s t => Int -> s [t]
+newVars 0 = return []
+newVars n = do
+  l <- newVars $ n-1
+  n <- newvar
+  return $ n:l
+
+instance FDSolver OvertonFD where
+  type FDIntTerm OvertonFD = FDVar
+  type FDBoolTerm OvertonFD = FDVar
+
+  type FDIntSpec OvertonFD = FDVar
+  type FDBoolSpec OvertonFD = FDVar
+  type FDColSpec OvertonFD = [FDVar]
+  
+  type FDIntSpecType OvertonFD = ()
+  type FDBoolSpecType OvertonFD = ()
+  type FDColSpecType OvertonFD = ()
+
+  fdIntSpec_const (Const i) = ((),do
+    v <- newvar
+    add $ OHasValue v $ fromInteger i
+    return v)
+  fdIntSpec_term i = ((),return i)
+  
+  fdBoolSpec_const (BoolConst i) = ((),do
+    v <- newvar 
+    add $ OHasValue v $ if i then 1 else 0
+    return v)
+  fdBoolSpec_term i = ((),return i)
+
+  fdColSpec_list l = ((),return l)
+  fdColSpec_size (Const s) = ((),newVars $ fromInteger s)
+  fdColSpec_const l = ((),error "constant collections not yet supported by overton interface")
+
+  fdColInspect = return
+
+  fdSpecify = specify <@> simple_fdSpecify
+  fdProcess = process <@> simple_fdProcess
+
+  fdEqualInt v1 v2 = addFD $ OSame v1 v2
+  fdEqualBool v1 v2 = addFD $ OSame v1 v2
+  fdEqualCol v1 v2 = do
+    if length v1 /= length v2
+      then setFailed
+      else sequence_ $ zipWith (\a b -> addFD $ OSame a b) v1 v2
+
+  fdIntVarSpec = return . Just
+  fdBoolVarSpec = return . Just
+  fdSplitIntDomain b = do
+    d <- fd_domain b
+    return $ (map (b `OHasValue`) d, True)
+  fdSplitBoolDomain b = do
+    d <- fd_domain b
+    return $ (map (b `OHasValue`) $ filter (\x -> x==0 || x==1) d, True)
+
+-- processBinary :: (EGVarId,EGVarId,EGVarId) -> (FDVar -> FDVar -> FDVar -> OConstraint) -> FDInstance OvertonFD ()
+processBinary (v1,v2,va) f = addFD $ f (getDefIntSpec v1) (getDefIntSpec v2) (getDefIntSpec va)
+
+-- processUnary :: (EGVarId,EGVarId) -> (FDVar -> FDVar -> OConstraint) -> FDInstance OvertonFD ()
+processUnary (v1,va) f = addFD $ f (getDefIntSpec v1) (getDefIntSpec va)
+
+specify :: Mixin (SpecFn OvertonFD)
+specify s t edge = case (debug ("overton-specify("++(show edge)++")") edge) of
+  EGEdge { egeCons = EGChannel, egeLinks = EGTypeData { intData=[i], boolData=[b] } } -> 
+    ([(1000,b,True,do
+      s <- getIntSpec i
+      case s of
+        Just ss -> return $ SpecResSpec ((),return (ss,Nothing))
+        _ -> return SpecResNone
+     )],[(1000,i,True,do
+      s <- getBoolSpec b
+      case s of
+        Just ss -> return $ SpecResSpec ((),return (ss,Nothing))
+        _ -> return SpecResNone
+     )],[])
+  _ -> s edge
+
+-- process :: Mixin (EGEdge -> FDInstance OvertonFD ())
+process s t con info = case (con,info) of
+    (EGIntValue c, ([],[a],[])) -> case c of
+      Const v -> addFD $ OHasValue (getDefIntSpec a) (fromInteger v)
+      _ -> error "Overton solver does not support parametrized values"
+    (EGPlus, ([],[a,b,c],[])) -> processBinary (b,c,a) OAdd
+    (EGMinus, ([],[a,b,c],[])) -> processBinary (a,c,b) OAdd
+    (EGMult, ([],[a,b,c],[])) -> processBinary (b,c,a) OMult
+    (EGAbs, ([],[a,b],[])) -> processUnary (b,a) OAbs
+    (EGDiff, ([FDSpecInfoBool {fdspBoolVal = Just (BoolConst True)}],[a,b],[])) -> addFD $ ODiff (getDefIntSpec a) (getDefIntSpec b)
+    (EGLess True, ([FDSpecInfoBool {fdspBoolVal = Just (BoolConst True)}],[a,b],[])) -> addFD $ OLess (getDefIntSpec a) (getDefIntSpec b)
+    (EGLess False, ([FDSpecInfoBool {fdspBoolVal = Just (BoolConst True)}],[a,b],[])) -> addFD $ OLessEq (getDefIntSpec a) (getDefIntSpec b)
+    (EGEqual, ([FDSpecInfoBool {fdspBoolVal = Just (BoolConst True)}],[a,b],[])) -> addFD $ OSame (getDefIntSpec a) (getDefIntSpec b)
+    _ -> s con info

+ src/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)

+ src/Control/CP/FD/SimpleFD.hs view

@@ -0,0 +1,190 @@+{-# LANGUAGE TypeFamilies #-}
+
+module Control.CP.FD.SimpleFD (
+  simple_fdSpecify,
+  simple_fdProcess,
+) where
+
+import Data.List (tails)
+import qualified Data.Set as Set
+
+import Control.CP.Debug
+import Control.Mixin.Mixin
+import Control.CP.FD.FD
+import Control.CP.Solver
+import Control.CP.FD.Graph
+import Data.Expr.Data
+-- import Control.CP.FD.Expr.Util
+
+itake :: [a] -> Int -> Int -> [a]
+itake _ _ 0 = []
+itake [] _ _ = []
+itake (a:ar) 0 l = a:(itake ar 0 (l-1))
+itake (a:ar) p l = itake ar (p-1) l
+
+simple_fdSpecify :: (FDSolver s, FDColSpec s ~ [FDIntTerm s], FDIntSpec s ~ FDIntTerm s, FDBoolSpec s ~ FDBoolTerm s) => Mixin (SpecFn s)
+simple_fdSpecify s t edge = case (debug ("simple_fdSpecify("++(show edge)++")") edge) of
+  EGEdge { egeCons=EGAt, egeLinks = EGTypeData { colData=[c], intData=[r,p] } } -> 
+    ([],[(500,r,True,do
+      k <- getIntVal p
+      case k of
+        Just (Const kk) -> do
+          Just cc <- getColSpec c
+          let trm = cc !! fromInteger kk
+          return $ SpecResSpec (minBound,return $ (trm, Nothing))
+        _ -> return SpecResNone
+    )],[])
+{-  EGEdge { egeCons=EGSlice f n, egeLinks = EGTypeData { colData=[r,s] } } ->
+    ([],[],[(500,r,True,do
+      (Just ss) <- getColSpec s
+      return $ SpecResSpec (minBound,return $ [ss !! (\(Const x) -> fromInteger x) (f i) | i <- [0..n-1]])
+    )]) -}
+  EGEdge { egeCons=EGCat, egeLinks = EGTypeData { colData=[r,a,b] } } ->
+    ([],[],[(500,r,True,do
+      Just aa <- getColSpec a
+      Just bb <- getColSpec b
+      return $ SpecResSpec (minBound,return (aa++bb,Nothing))
+    )])
+{-  EGEdge { egeCons=EGRange, egeLinks = EGTypeData { intData=[l,h], colData=[c] } } ->
+    ([],[],[(550,c,False,do
+      ll <- getIntVal l
+      hh <- getIntVal h
+      case (ll,hh) of
+        (Just lll, Just hhh) -> return $ SpecResSpec (fdColSpec_size (hhh-lll+1) >>= \(t,v) -> return (t,(v,Nothing)))
+        _ -> return SpecResNone
+    )]) -}
+  _ -> s edge
+
+trueSpec = FDSpecInfoBool {fdspBoolSpec=const Nothing,fdspBoolVar=Nothing,fdspBoolVal=Just $ BoolConst True,fdspBoolTypes=Set.empty}
+
+simple_fdProcess :: (FDSolver s, FDColSpec s ~ [FDIntTerm s], FDIntSpec s ~ FDIntTerm s, FDBoolSpec s ~ FDBoolTerm s) => Mixin (EGConstraintSpec -> FDSpecInfo s -> FDInstance s ())
+simple_fdProcess s t cons info = case (cons,info) of
+    (EGAt,(_,[r,FDSpecInfoInt {fdspIntVal = Just (Const n)}],[c])) -> do
+      let cc = getDefColSpec c
+          sr = getDefIntSpec r
+      fdEqualInt (cc !! fromInteger n) sr
+    (EGAt,(_,[r,p],[c])) -> error ("Unsupported EGAt in simple_fdProcess r="++(show r)++" p="++(show p)++" c="++(show c))
+    (EGList n,(_,l,[c])) -> do
+      let cc = getDefColSpec c
+      sequence_ $ zipWith (\id ce -> fdEqualInt ce $ getDefIntSpec id) l cc
+    (EGRange, ([],[FDSpecInfoInt {fdspIntVal = Just (Const ll)},FDSpecInfoInt {fdspIntVal=Just (Const hh)}],[c])) -> do
+      let cc = getDefColSpec c
+      sequence_ $ zipWith (\val var -> t (EGIntValue (Const val)) $ fdSpecInfo_spec ([],[Right (minBound,var)],[])) [ll..hh] cc
+    (EGRange, ([],[FDSpecInfoInt {fdspIntVar = Just ll},FDSpecInfoInt {fdspIntVar=Just hh}],[c])) -> do
+      let cc = getDefColSpec c
+      l <- getIntVal ll
+      h <- getIntVal hh
+      case (l,h) of
+        (Just (Const lll), Just (Const hhh)) -> sequence_ $ zipWith (\val var -> t (EGIntValue (Const val)) $ fdSpecInfo_spec ([],[Right (minBound,var)],[])) [lll..hhh] cc
+        _ -> s cons info
+    (EGRange, ([],[l,h],[c])) -> do
+      error ("Unsupported EGRange in simple_fdProcess: l=("++(show l)++") h=("++(show h)++") c=("++(show c)++")")
+    (EGSorted q, (_,_,[c])) -> do
+      let cc = getDefColSpec c
+      sequence_ $ zipWith (\a b -> t (EGLess q) $ fdSpecInfo_spec ([Left trueSpec],[Right (minBound,a), Right (minBound,b)],[])) cc (tail cc)
+    (EGAllDiff _, (_,_,[c])) -> do
+      let cc = getDefColSpec c
+      sequence_ [ t EGDiff $ fdSpecInfo_spec ([Left trueSpec],[Right (minBound,x), Right (minBound,e)],[])  | (x:xs) <- tails cc, e <- xs ]
+    (EGAll sm (nb,ni,nc) force,(r:vb,vi,c:vc)) -> do
+      let dr = getDefBoolSpec r
+      let dc = getDefColSpec c
+      let dcs = length dc
+      debug ("iter_process EGAll: dcs="++(show dcs)) $ return ()
+      if force
+        then do
+          let mf i = do
+                let v = dc!!i
+                dv <- liftFD $ specInfoIntTerm v
+                let fb (-1) = error "SimpleFD EGAll undefined 1"
+                    fb n = vb!!n
+                    fi (-1) = dv
+                    fi n = vi!!n
+                procSubModel sm (fb,fi,(vc!!))
+          mapM_ mf [0..fromIntegral $ dcs-1]
+        else do
+          let mf i = do
+                let v = dc!!i
+                b <- liftFD $ newvar
+                db <- liftFD $ specInfoBoolTerm b
+                dv <- liftFD $ specInfoIntTerm v
+                let fb (-1) = db
+                    fb n = vb!!n
+                    fi (-1) = dv
+                    fi n = vi!!n
+                procSubModel sm (fb,fi,(vc!!))
+                return b
+          bools <- mapM mf [0..fromIntegral $ dcs-1]
+          treeAll t EGAnd True bools
+          return ()
+    (EGAny sm (nb,ni,nc) _,(r:vb,vi,c:vc)) -> do
+      let dr = getDefBoolSpec r
+      let dc = getDefColSpec c
+      let dcs = length dc
+      let mf i = do
+            let v = dc!!i
+            b <- liftFD $ newvar
+            db <- liftFD $ specInfoBoolTerm b
+            dv <- liftFD $ specInfoIntTerm v
+            let fb (-1) = db
+                fb n = vb!!n
+                fi (-1) = dv
+                fi n = vi!!n
+                fc n = vc!!n
+            procSubModel sm (fb,fi,fc)
+            return b
+      bools <- mapM mf [0..fromIntegral $ dcs-1]
+      treeAll t EGOr False bools
+      return ()
+    (EGMap sm (nb,ni,nc),(vb,vi,cr:c:vc)) -> do
+      let dc = getDefColSpec c
+      let dcr = getDefColSpec cr
+      let dcs = length dc
+      let mf i = do
+            let vin = dc!!i
+            let vout = dcr!!i
+            din <- liftFD $ specInfoIntTerm vin
+            dout <- liftFD $ specInfoIntTerm vout
+            let fi (-1) = dout
+                fi (-2) = din
+                fi n = vi!!n
+                fb n = vb!!n
+                fc n = vc!!n
+            procSubModel sm (fb,fi,fc)
+      mapM_ mf [0..fromIntegral $ dcs-1]
+    (EGFold sm (nb,ni,nc),(vb,r:ss:vi,c:vc)) -> do
+      let dc = getDefColSpec c
+      let dinit = getDefIntSpec ss
+      let dcs = length dc
+      let dres = getDefIntSpec r
+      tmp <- mapM (const $ liftFD newvar) [0..dcs-2]
+      let tmpv = tmp++[dres]
+      let mf i = do
+            let vin1 = if (i==0) then dinit else tmpv!!(i-1)
+                vout = tmpv!!i
+            let vin2 = dc!!i
+            din1 <- liftFD $ specInfoIntTerm vin1
+            din2 <- liftFD $ specInfoIntTerm vin2
+            dout <- liftFD $ specInfoIntTerm vout
+            let fi (-1) = dout
+                fi (-2) = din1
+                fi (-3) = din2
+                fi n = vi!!n
+                fb n = vb!!n
+                fc n = vc!!n
+            procSubModel sm (fb,fi,fc)
+      mapM_ mf [0..fromIntegral $ dcs-1]
+    _ -> s cons info
+
+treeAll :: (FDSolver s, FDBoolSpec s ~ FDBoolTerm s) => (EGConstraintSpec -> FDSpecInfo s -> FDInstance s ()) -> EGConstraintSpec -> Bool -> [FDBoolSpec s] -> FDInstance s (FDBoolSpec s)
+treeAll p c d [] = return $ error "SimpleFD treeAll undefined"
+treeAll p c d [a] = return a
+treeAll p c d x = do
+  let (l,r) = splitAt ((length x) `div` 2) x
+  ld <- treeAll p c d l
+  rd <- treeAll p c d r
+  ldi <- liftFD $ specInfoBoolTerm ld
+  rdi <- liftFD $ specInfoBoolTerm rd
+  o <- liftFD $ newvar
+  oi <- liftFD $ specInfoBoolTerm o
+  p c ([oi,ldi,rdi],[],[])
+  return o

+ src/Control/CP/FD/Solvers.hs view

@@ -0,0 +1,52 @@+module Control.CP.FD.Solvers where
+
+import qualified Control.CP.PriorityQueue as PriorityQueue
+import qualified Data.Sequence
+
+import Control.CP.ComposableTransformers
+import Control.CP.SearchTree
+import Control.CP.FD.FD
+-- import Control.CP.FD.OvertonFD.Sugar
+-- import Control.CP.FD.OvertonFD.OvertonFD
+-- import Control.CP.FD.Gecode.CodegenSolver
+
+--------------------------------------------------------------------------------
+-- FORCE SOLVERS
+--------------------------------------------------------------------------------
+
+-- as_overtonfd :: Tree (FDWrapper OvertonFD) a -> Tree OvertonFD a
+-- as_overtonfd = unwrap
+-- 
+-- as_gecode_codegen :: Tree (FDWrapper CodegenSolver) a -> Tree CodegenSolver a
+-- as_gecode_codegen = unwrap
+-- 
+-- as_gen_gecode_codegen :: (FDExpr CodegenSolver -> Tree (FDWrapper CodegenSolver) a) -> (FDExpr CodegenSolver -> Tree CodegenSolver a)
+-- as_gen_gecode_codegen f = (\x -> unwrap $ f x)
+-- 
+
+------------------------------------------------------------------------------
+-- SEARCH STRATEGIES
+------------------------------------------------------------------------------
+
+dfs = []
+bfs = Data.Sequence.empty
+pfs :: Ord a => PriorityQueue.PriorityQueue a (a,b,c)
+pfs = PriorityQueue.empty
+
+nb :: Int -> CNodeBoundedST s a
+nb = CNBST
+db :: Int -> CDepthBoundedST s a
+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
+it = CIST
+ra :: Int -> CRandomST s a
+ra = CRST
+ld :: Int -> CLimitedDiscrepancyST s a
+ld = CLDST
+

+ src/Control/CP/PriorityQueue.hs view

@@ -0,0 +1,112 @@+{- Copyright (c) 2008 the authors listed at the following URL, and/or
+the authors of referenced articles or incorporated external code:
+http://en.literateprograms.org/Priority_Queue_(Haskell)?action=history&offset=20080608152146
+
+Permission is hereby granted, free of charge, to any person obtaining
+a copy of this software and associated documentation files (the
+"Software"), to deal in the Software without restriction, including
+without limitation the rights to use, copy, modify, merge, publish,
+distribute, sublicense, and/or sell copies of the Software, and to
+permit persons to whom the Software is furnished to do so, subject to
+the following conditions:
+
+The above copyright notice and this permission notice shall be
+included in all copies or substantial portions of the Software.
+
+THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,
+EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF
+MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT.
+IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY
+CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT,
+TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE
+SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE.
+
+Retrieved from: http://en.literateprograms.org/Priority_Queue_(Haskell)?oldid=13634
+-}
+
+{-# LANGUAGE DatatypeContexts #-}
+
+module Control.CP.PriorityQueue (
+    PriorityQueue,
+    empty,
+    is_empty,
+    minKey,
+    minKeyValue,
+    insert,
+    deleteMin,
+    deleteMinAndInsert
+) where
+
+ 
+import Prelude
+
+
+-- Declare the data type constructors.
+
+data Ord k => PriorityQueue k a = Nil | Branch k a (PriorityQueue k a) (PriorityQueue k a)
+ 
+
+-- Declare the exported interface functions.
+
+-- Return an empty priority queue.
+
+is_empty Nil = True
+is_empty _   = False
+
+empty :: Ord k => PriorityQueue k a
+empty = Nil
+
+
+-- Return the highest-priority key.
+
+minKey :: Ord k => PriorityQueue k a -> k
+minKey = fst . minKeyValue
+
+
+-- Return the highest-priority key plus its associated value.
+
+minKeyValue :: Ord k => PriorityQueue k a -> (k, a)
+minKeyValue Nil              = error "empty queue"
+minKeyValue (Branch k a _ _) = (k, a)
+
+
+-- Insert a key/value pair into a queue.
+
+insert :: Ord k => k -> a -> PriorityQueue k a -> PriorityQueue k a
+insert k a q = union (singleton k a) q
+
+deleteMin :: Ord k => PriorityQueue k a -> ((k,a), PriorityQueue k a)
+deleteMin(Branch k a l r) = ((k,a),union l r)
+
+-- Delete the highest-priority key/value pair and insert a new key/value pair into the queue.
+
+deleteMinAndInsert :: Ord k => k -> a -> PriorityQueue k a -> PriorityQueue k a
+deleteMinAndInsert k a Nil              = singleton k a
+deleteMinAndInsert k a (Branch _ _ l r) = union (insert k a l) r
+
+
+
+-- Declare the private helper functions.
+
+-- Join two queues in sorted order.
+
+union :: Ord k => PriorityQueue k a -> PriorityQueue k a -> PriorityQueue k a
+union l Nil = l
+union Nil r = r
+union l@(Branch kl _ _ _) r@(Branch kr _ _ _)
+    | kl <= kr  = link l r
+    | otherwise = link r l
+
+
+-- Join two queues without regard to order.
+
+-- (This is a helper to the union helper.)
+
+link (Branch k a Nil m) r = Branch k a r m
+link (Branch k a ll lr) r = Branch k a lr (union ll r)
+
+
+-- Return a queue with a single item from a key/value pair.
+
+singleton :: Ord k => k -> a -> PriorityQueue k a
+singleton k a = Branch k a Nil Nil

+ src/Control/CP/Queue.hs view

@@ -0,0 +1,53 @@+{-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE ViewPatterns #-}
+{-# LANGUAGE FlexibleInstances #-}
+{-
+ - The Queue data type, a worklist data type for search.
+ -
+ - 	Monadic Constraint Programming
+ - 	http://www.cs.kuleuven.be/~toms/Haskell/
+ - 	Tom Schrijvers
+ -}
+
+module Control.CP.Queue (
+  Queue,
+  Elem,
+  emptyQ,
+  isEmptyQ,
+  popQ,
+  pushQ
+) where
+
+import qualified Data.Sequence
+import qualified Control.CP.PriorityQueue as PriorityQueue
+
+class Queue q where   
+  type Elem q :: *
+  emptyQ   :: q -> q
+  isEmptyQ :: q -> Bool
+  popQ     :: q -> (Elem q,q)
+  pushQ    :: Elem q -> q -> q
+
+instance Queue [a] where
+  type Elem [a] = a
+  emptyQ _     = []
+  isEmptyQ     = Prelude.null
+  popQ (x:xs)  = (x,xs)
+  pushQ        = (:)
+
+instance Queue (Data.Sequence.Seq a) where
+  type Elem (Data.Sequence.Seq a)  = a
+  emptyQ _                   = Data.Sequence.empty
+  isEmptyQ                   = Data.Sequence.null 
+--  popQ (Data.Sequence.viewl -> x Data.Sequence.:< xs)  = (x,xs)
+  popQ l                     = case Data.Sequence.viewl l of
+    x Data.Sequence.:< xs -> (x,xs)
+  pushQ                      = flip (Data.Sequence.|>)
+
+instance Ord a => Queue (PriorityQueue.PriorityQueue a (a,b,c)) where
+  type Elem (PriorityQueue.PriorityQueue a (a,b,c)) = (a,b,c)
+  emptyQ _ = PriorityQueue.empty
+  isEmptyQ = PriorityQueue.is_empty 
+  pushQ x@(k,_,_)  = PriorityQueue.insert k x
+  popQ q   = let ((_,x),q') = PriorityQueue.deleteMin q
+             in (x,q')

+ src/Control/CP/SearchTree.hs view

@@ -0,0 +1,328 @@+{-
+ - The Tree data type, a generic modelling language for constraint solvers.
+ -
+ -      Monadic Constraint Programming
+ -      http://www.cs.kuleuven.be/~toms/Haskell/
+ -      Tom Schrijvers
+ -}
+{-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE GADTs #-}
+{-# LANGUAGE RankNTypes #-}
+{-# LANGUAGE FlexibleContexts #-}
+
+module Control.CP.SearchTree (
+  Tree(..),
+  transformTree,
+  bindTree,
+  insertTree,
+  (/\),
+  true,
+  disj,
+  conj,
+  disj2,
+  prim,
+  addC,
+  addT,
+  exist,
+  forall,
+  indent,
+  showTree,
+  mapTree,
+  MonadTree(..),
+  untree
+) where
+
+import Control.CP.Solver
+import Control.Mixin.Mixin
+
+import Control.Monad
+import Control.Monad.Cont
+import Control.Monad.Reader
+import Control.Monad.Writer
+import Control.Monad.State
+
+import Data.Monoid
+
+
+-------------------------------------------------------------------------------
+----------------------------------- Tree --------------------------------------
+-------------------------------------------------------------------------------
+
+data Tree s a where
+  Fail    :: Tree s a                                  -- failure
+  Return  :: a -> Tree s a                             -- finished
+  Try     :: Tree s a -> Tree s a -> Tree s a          -- disjunction
+  Add     :: Constraint s -> Tree s a -> Tree s a      -- sequentially adding a constraint to a tree
+  NewVar  :: Term s t => (t -> Tree s a) -> Tree s a   -- add a new variable to a tree
+  Label   :: s (Tree s a) -> Tree s a                  -- label with a strategy
+
+flattenTree :: Solver s => Tree s a -> Maybe ([Constraint s],a)
+flattenTree Fail = Nothing
+flattenTree (Return a) = Just ([],a)
+flattenTree (Try _ _) = Nothing
+flattenTree (Add c t) = case flattenTree t of
+  Nothing -> Nothing
+  Just (l,a) -> Just (c:l,a)
+flattenTree (NewVar _) = Nothing
+flattenTree (Label _) = Nothing
+
+transformTree :: Solver s => Mixin (Tree s a -> Tree s a)
+transformTree _ _ Fail = Fail
+transformTree _ _ (Return x) = Return x
+transformTree _ t (Try x y) = Try (t x) (t y)
+transformTree _ t (Add c x) = Add c (t x)
+transformTree _ t (NewVar f) = NewVar (\x -> t $ f x)
+transformTree _ t (Label m) = Label $ m >>= return . t
+-- transformTree s _ x = s x
+
+mapTree :: (Solver s1, Solver s2, MonadTree m, TreeSolver m ~ s2) => (forall t. s1 t -> s2 t) -> Tree s1 a -> m a
+mapTree _ Fail = false
+mapTree _ (Return a) = return a
+mapTree f (Try a b) = mapTree f a \/ mapTree f b
+-- mapTree f (Add c n) = label $ f $ (add c >>= \t -> if t then return (mapTree f n) else return false)
+-- mapTree (NewVar _) = undefined
+mapTree f (Label l) = label $ (f l) >>= (\t -> return (mapTree f t))
+
+instance Solver s => Functor (Tree s) where
+        fmap  = liftM 
+
+instance Solver s => Applicative (Tree s) where
+  pure = Return
+  (<*>) = ap
+        
+instance Solver s => Monad (Tree s) where
+  return = pure
+  (>>=)  = bindTree
+  
+
+bindTree     :: Solver s => Tree s a -> (a -> Tree s b) -> Tree s b
+Fail           `bindTree` k  = Fail
+(Return x)     `bindTree` k  = k x
+(Try m n)      `bindTree` k  = Try (m `bindTree` k) (n `bindTree` k)
+(Add c m)      `bindTree` k  = Add c (m `bindTree` k)
+(NewVar f)   `bindTree` k  = NewVar (\x -> f x `bindTree` k)    
+(Label m)      `bindTree` k  = Label (m >>= \t -> return (t `bindTree` k))
+
+insertTree     :: Solver s => Tree s a -> Tree s () -> Tree s a
+(NewVar f)   `insertTree` t  = NewVar (\x -> f x `insertTree` t)    
+(Add c  o)     `insertTree` t  = Add c (o `insertTree` t)
+other          `insertTree` t  = t /\ other
+
+{- Monad laws:
+ -
+ - 1. return x >>= f  ==  f x
+ -
+ -    return a >>= f  
+ -    == Return a >>= f         (return def)
+ -    == f x                    (bind def) 
+ -
+ - 2. m >>= return  =  m
+ -
+ -   By induction
+ -     case m of
+ -     1) Return x -> 
+ -          Return x >>= return
+ -          == return x                 (bind def)
+ -          == Return x                 (return def)
+ -     2) Fail ->
+ -          Fail >>= return
+ -          == Fail                     (bind def)
+ -     3)  Try l r >>= return
+ -         == Try (l >>= return) (r >>= return) (bind def)
+ -         == Try l r                           (induction)
+ -      4) Add c m >>= return
+ -         == Add c (m >>= return)      (bind def)
+ -         == Add c m                   (induction) 
+ -      5) NewVar i f >>= return
+ -         == NewVar i (\v -> f v >>= return)   (bind def) 
+ -         == NewVar i (\v -> f v)              ((co)-induction?)
+ -         == NewVar i f                                (eta reduction)
+ -      6) Label sm >>= return
+ -         == Label (sm >>= \m -> return (m >>= return))        (bind def)
+ -         == Label (sm >>= \m -> return m)                     (co-induction)
+ -         == Label (sm >>= return)                             (eta reduction)
+ -         == Label sm                                          (2nd monad law for Monad s)
+ -
+ - 3. (m >>= f) >>= g = m >>= (\x -> f x >>= g)
+ - 
+ -   By induction
+ -     case m of
+ -     1) (Return y >>= f) >>= g 
+ -        == f y >>= g                                  (bind def)
+ -        == (\x -> f x >>= g) y                        (beta expansion)
+ -        == Return y >>= (\x -> f x >>= g)             (bind def)
+ -     2) (Fail >>= f) >>= g
+ -        == Fail >>= g                                 (bind def)
+ -        == Fail                                       (bind def)
+ -        == Fail >>= (\x -> f x >>= g)                 (bind def) 
+ -     3) (Try l r >>= f) >>= g
+ -        == Try (l >>= f) (r >>= f)) >>= g                             (bind def)
+ -        == Try ((l >>= f) >>= g) ((r >>= f) >>= g)                    (bind def)
+ -        == Try (l >>= (\x -> f x >>= g)) (r >>= (\x -> f x >>= g))    (induction)
+ -        == Try l r >>= (\x -> f x >>= g)                              (bind def)
+ -     4) (NewVar i m >>= f) >>= g
+ -        == NewVar i (\v -> m v >>= f) >>= g                   (bind def)
+ -        == NewVar i (\w -> (\v -> m v >>= f) w >>= g)         (bind def)
+ -        == NewVar i (\w -> (m w >>= f) >>= g)                 (beta reduction)  
+ -        == NewVar i (\w -> m w >>= (\x -> f x >>= g))         (co-induction)
+ -        == NewVar i m >>= (\x -> f x >>= g)                   (bind def)
+ -     5) (Label sm >>= f) >>= g
+ -         == Label (sm >>= \m -> return (m >>= f)) >>= g       (bind def) 
+ -         == Label ((sm >>= \m -> return (m >>= f)) >>= \m' -> return (m' >>= g))
+ -         == Label (sm >>= (\m -> return (m >>= f) >>= \m' -> return (m' >>= g)))
+ -         == Label (sm >>= \m -> return ((m >>= f) >>= g))
+ -         == Label (sm >>= \m -> return (m >>= (\x -> f x >>= g)))
+ -         == Label sm >>= (\x -> f x >>= g)
+ -
+ -}
+
+-------------------------------------------------------------------------------
+----------------------------------- Monad Subclass ----------------------------
+-------------------------------------------------------------------------------
+
+infixl 2 \/
+
+-- | Generalization of the search tree data type,
+--   allowing monad transformer decoration.
+class (Monad m, Solver (TreeSolver m)) => MonadTree m where
+  type TreeSolver m :: * -> *
+  addTo   :: Constraint (TreeSolver m) -> m a -> m a
+  false   :: m a
+  (\/)    :: m a -> m a -> m a
+  exists  :: Term (TreeSolver m) t => (t -> m a) -> m a
+  label   :: (TreeSolver m) (m a) -> m a
+
+instance Solver solver => MonadTree (Tree solver) where
+  type TreeSolver (Tree solver)  = solver
+  addTo   =  Add
+  false   =  Fail
+  (\/)    =  Try
+  exists  =  NewVar
+  label   =  Label
+
+instance (MonadTree m, Solver (TreeSolver m)) => MonadTree (ContT r m) where
+  type TreeSolver (ContT r m) = TreeSolver m
+  addTo constraint cm = ContT $ \k -> addTo constraint (runContT cm k) 
+  false               = lift false
+  l \/ r              = ContT $ \k -> (runContT l k) \/ (runContT r k)
+  exists f            = ContT $ \k -> exists (\t -> runContT (f t) k)
+  label scm           = ContT $ \k -> label (scm >>= \cm -> return $ runContT cm k)
+
+-------------------------------------------------------------------------------
+----------------------------------- Sugar -------------------------------------
+-------------------------------------------------------------------------------
+ 
+infixr 3 /\
+(/\) :: MonadTree tree => tree a -> tree b -> tree b
+(/\) = (>>)
+ 
+true :: MonadTree tree  => tree ()
+true = return ()
+
+disj :: MonadTree tree => [tree a] -> tree a
+disj [] = false
+disj a = foldr1 (\/) a
+
+conj :: MonadTree tree => [tree ()] -> tree ()
+conj [] = true
+conj a = foldr1 (/\) a
+
+disj2 :: MonadTree tree => [tree a] -> tree a
+disj2 (x:  [])  = x
+disj2 l        = let (xs,ys)      = split l
+                     split []     = ([],[])
+                     split (a:as) = let (bs,cs) = split as
+                                    in  (a:cs,bs)
+                 in  (disj2 xs) \/ (disj2 ys)
+
+prim :: MonadTree tree => TreeSolver tree a -> tree a
+prim action = label (action >>= return . return)
+
+addC :: MonadTree tree => Constraint (TreeSolver tree) -> tree ()
+addC c = c `addTo` true
+
+addT :: MonadTree tree => Constraint (TreeSolver tree) -> tree Bool
+addT c = c `addTo` (return True)
+
+exist :: (MonadTree tree, Term (TreeSolver tree) t) => Int -> ([t] -> tree a) -> tree a
+exist n ftree = f n []
+         where f 0 acc  = ftree $ reverse acc
+               f n acc  = exists $ \v -> f (n-1) (v:acc)
+
+forall :: (MonadTree tree, Term (TreeSolver tree) t)  => [t] -> (t -> tree ()) -> tree ()
+forall list ftree = conj $ map ftree list
+
+-- Shortcut the search procedure for a Tree that does not contain Try nodes.
+-- create a solver monad that returns the result of the Tree, or a specified
+-- value upon failure
+untree :: Solver s => v -> Tree s v -> s v
+untree _ (Return x) = return x
+untree _ (Try _ _) = error "convertion of Try nodes to solver is not supported"
+untree e (Fail) = return e
+untree e (Label s) = s >>= untree e
+untree e (Add c t) = (add c) >>= (\x -> if x then untree e t else return e)
+untree e (NewVar f) = do
+    v <- newvar
+    untree e (f v)
+
+-- | show
+
+indent :: Int -> String
+indent l = replicate (2*l) ' '
+
+showTree :: (Show (Constraint s), Show a, Solver s) => Int -> Tree s a -> s String
+showTree l Fail = return $ indent l ++ "Fail\n"
+showTree l (Return x) = return $ indent l ++ "Return [" ++ (show x) ++ "]\n"
+showTree l (Try a b) = do
+  m <- mark
+  s1 <- showTree (l+1) a
+  goto m
+  s2 <- showTree (l+1) b
+  return $ indent l ++ "Try\n" ++ s1 ++ s2
+showTree l (Add c t) = do
+  s <- showTree (l+1) t
+  return $ indent l ++ "Add (" ++ (show c) ++ ")\n" ++ s
+showTree l (NewVar f) = do
+  n <- newvar
+  s <- showTree (l+1) (f n)
+  return $ indent l ++ "NewVar\n" ++ s
+showTree l (Label a) = do
+  r <- a
+  s <- showTree (l+1) r
+  return $ indent l ++ "Label\n" ++ s
+
+instance Show (Tree s a)  where
+  show Fail             = "Fail"
+  show (Return _)       = "Return"
+  show (Try l r)        = "Try (" ++ show l ++ ") (" ++ show r ++ ")"
+  show (Add _ t)        = "Add (" ++ show t ++ ")"
+  show (NewVar _)       = "NewVar <function>"
+  show (Label _)        = "Label <monadic value>"
+
+----------------------------------------------------------------------
+-- Monad Transformer Instances
+----------------------------------------------------------------------
+
+instance MonadTree t => MonadTree (ReaderT env t) where
+  type TreeSolver (ReaderT env t) = TreeSolver t
+  addTo constraint tree  = ReaderT $ \env -> addTo constraint (runReaderT tree env)
+  false     = lift false
+  l \/ r    = ReaderT $ \env -> runReaderT l env \/ runReaderT r env
+  exists f  = ReaderT $ \env -> exists (\var -> runReaderT (f var) env)
+  label p   = ReaderT $ \env -> label (p >>= \m -> return $ runReaderT m env)
+
+instance (Monoid w, MonadTree t) => MonadTree (WriterT w t) where
+  type TreeSolver (WriterT w t)  = TreeSolver t
+  addTo constraint tree  = WriterT $ addTo constraint (runWriterT tree)
+  false     = lift false 
+  l \/ r    = WriterT $ runWriterT l \/ runWriterT r
+  exists f  = WriterT $ exists (\var -> runWriterT (f var))
+  label p   = WriterT $ label (p >>= \m -> return $ runWriterT m)
+
+instance MonadTree t => MonadTree (StateT s t) where
+  type TreeSolver (StateT s t) = TreeSolver t
+  addTo constraint tree  = StateT $ \s -> addTo constraint (runStateT tree s)
+  false     = lift false
+  l \/ r    = StateT $ \s -> runStateT l s \/ runStateT r s
+  exists f  = StateT $ \s -> exists (\var -> runStateT (f var) s)
+  label p   = StateT $ \s -> label (p >>= \m -> return $ runStateT m s)

+ src/Control/CP/Solver.hs view

@@ -0,0 +1,80 @@+{-
+ - The Solver class, a generic interface for constraint solvers.
+ -
+ - 	Monadic Constraint Programming
+ - 	http://www.cs.kuleuven.be/~toms/Haskell/
+ - 	Tom Schrijvers
+ -}
+
+{-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE MultiParamTypeClasses #-}
+{-# LANGUAGE FlexibleInstances #-}
+
+module Control.CP.Solver (
+  Solver,
+  Constraint,
+  Label,
+  add,
+  run,
+  mark, markn,
+  goto,
+  Term,
+  newvar,
+  Help,
+  help,
+) where 
+
+import Control.Monad.Writer
+import Data.Monoid
+
+class Monad solver => Solver solver where
+	-- | the constraints
+	type Constraint solver 	:: *
+ 	-- | the labels
+	type Label solver	:: *
+	-- | add a constraint to the current state, and
+	--   return whether the resulting state is consistent
+	add		:: Constraint solver -> solver Bool
+	-- | run a computation
+	run		:: solver a -> a
+	-- | mark the current state, and return its label
+	mark		:: solver (Label solver)
+	-- | mark the current state as discontinued, yet return a label that is usable n times
+	markn		:: Int -> solver (Label solver)
+	-- | go to the state with given label
+	goto		:: Label solver -> solver ()
+	
+	markn _ = mark
+
+class (Solver solver) => Term solver term where
+	-- | produce a fresh constraint variable
+	newvar 	:: solver term
+
+        -- see note [Solver-Specific Term Operations]
+        type Help solver term
+        help :: solver () -> term -> Help solver term
+
+-- [Solver-Specific Term Operations]
+--
+-- Terms of solvers in general only support the 'newvar' operation.
+-- However, for specific solvers, all terms may support additional
+-- operations.
+--
+-- The 'Help'/'help' infrastructure allows accessing this solver-specific
+-- term operations.
+
+-- | WriterT decoration of a solver
+--   useful for producing statistics during solving
+instance (Monoid w, Solver s) => Solver (WriterT w s) where
+  type Constraint (WriterT w s)  = Constraint s
+  type Label (WriterT w s)       = Label s
+  add  = lift . add
+  run  = fst . run . runWriterT
+  mark = lift mark
+  markn = lift . markn
+  goto = lift . goto 
+
+instance (Monoid w, Term s t) => Term (WriterT w s) t where
+  newvar  = lift newvar
+  type Help (WriterT w s) t = ()
+  help _ _ = ()

+ src/Control/CP/Transformers.hs view

@@ -0,0 +1,115 @@+{- 
+ -      Monadic Constraint Programming
+ -      http://www.cs.kuleuven.be/~toms/Haskell/
+ -      Tom Schrijvers
+ -}
+{-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE Rank2Types #-}
+{-# LANGUAGE BangPatterns #-}
+{-# LANGUAGE ConstrainedClassMethods #-}
+module Control.CP.Transformers (
+  eval,
+  eval',
+  continue,
+  NodeBoundedST,
+  DepthBoundedST,
+  Transformer(..),
+) where 
+
+import Control.CP.Solver
+import Control.CP.SearchTree
+import Control.CP.Queue
+import Control.CP.Debug
+
+--------------------------------------------------------------------------------
+-- EVALUATION
+--------------------------------------------------------------------------------
+
+eval :: (Solver solver, Queue q, Elem q ~ (Label solver,Tree solver (ForResult t),TreeState t), Transformer t,
+         ForSolver t ~ solver) 
+     => Tree solver (ForResult t) -> q -> t -> solver (Int,[ForResult t])
+eval tree q t  = debug "eval" $ 
+                   do (es,ts) <- initT t tree
+                      eval' 0 tree q t es ts
+
+eval' :: SearchSig solver q t (ForResult t) 
+eval' !i (Return x) wl t es ts  = do (j,xs) <- returnT (i+1) wl t es
+                                     return (j,(x:xs)) 
+eval' i (Add c k)  wl t es ts = do b <- Control.CP.Solver.add c 
+                                   if b then eval' (i+1) k wl t es ts
+                                        else continue (i+1) wl t es
+eval' i (NewVar f) wl t es ts = do v <- newvar
+                                   eval' (i+1) (f v) wl t es ts
+eval' i (Try l r)  wl t es ts  = 
+  do now <- markn 2
+     let wl' = pushQ (now,l,leftT t es ts) $ pushQ (now,r,rightT t es ts) wl
+     continue (i+1) wl' t es
+eval' i Fail       wl t es ts  = continue (i+1) wl t es
+eval' i (Label m)  wl t es ts  = do tree <- m
+                                    eval' (i+1) tree wl t es ts
+ 
+continue :: ContinueSig solver q t (ForResult t) 
+continue i wl t es  
+        | isEmptyQ wl  = endT i wl t es -- return (i,[])
+        | otherwise    = let ((past,tree,ts),wl') = popQ wl
+                         in  do goto past
+                                nextT i tree wl' t es ts 
+
+--------------------------------------------------------------------------------
+-- TRANSFORMER
+--------------------------------------------------------------------------------
+
+type SearchSig solver q t a =
+     (Solver solver, Queue q, Transformer t,   
+          Elem q ~ (Label solver,Tree solver a,TreeState t),
+          ForSolver t ~ solver) 
+     => Int -> Tree solver a -> q -> t -> EvalState t -> TreeState t -> solver (Int,[a])
+
+type ContinueSig solver q t a =
+     (Solver solver, Queue q, Transformer t,   
+          Elem q ~ (Label solver,Tree solver a,TreeState t),
+          ForSolver t ~ solver) 
+     => Int -> q -> t -> EvalState t -> solver (Int,[a])
+
+class Transformer t where
+  type EvalState t :: *
+  type TreeState t :: *
+  type ForSolver t :: (* -> *)
+  type ForResult t :: *
+  leftT, rightT :: t -> EvalState t -> TreeState t -> TreeState t
+  leftT  _ _ = id
+  rightT    = leftT
+  nextT :: SearchSig (ForSolver t) q t (ForResult t)
+  nextT  = eval'
+  initT :: t -> Tree (ForSolver t) (ForResult t) -> (ForSolver t) (EvalState t,TreeState t)
+  returnT :: ContinueSig solver q t (ForResult t) 
+  returnT i wl t es  = continue i wl t es
+  endT  :: ContinueSig solver q t (ForResult t)
+  endT i wl t es     = return (i,[])
+
+newtype DepthBoundedST (solver :: * -> *) a = DBST Int
+
+instance Solver solver => Transformer (DepthBoundedST solver a) where
+  type EvalState (DepthBoundedST solver a)  = ()
+  type TreeState (DepthBoundedST solver a)  = Int
+  type ForSolver (DepthBoundedST solver a)  = solver
+  type ForResult (DepthBoundedST solver a)  = a
+  initT (DBST n) _  = return ((),n)
+  leftT _ _ ts      = ts - 1
+  nextT i tree q t es ts
+    | ts == 0    = continue i q t es
+    | otherwise  = eval' i tree q t es ts
+
+newtype NodeBoundedST (solver :: * -> *) a = NBST Int
+
+instance Solver solver => Transformer (NodeBoundedST solver a)  where
+  type EvalState (NodeBoundedST solver a) = Int
+  type TreeState (NodeBoundedST solver a) = ()
+  type ForSolver (NodeBoundedST solver a) = solver
+  type ForResult (NodeBoundedST solver a) = a
+  initT (NBST n) _  = return (n,())
+  nextT i tree q t es ts
+    | es == 0    = return (i,[])
+    | otherwise  = eval' i tree q t (es - 1) ts
+

+ src/Control/Mixin/Mixin.hs view

@@ -0,0 +1,60 @@+-- | Module with basic infrastructure for function inheritance
+--   based on open rercusion.
+--
+--   See the work of William Cook.
+--
+--   We use the following terminology.
+--
+--     * A /closed/ function is an ordinary function. 
+--
+--     * A /mixin/ function is an open function that can be
+--       inherited from, or that extends another open function.
+--
+--   We obtain a closed function from a base mixin 'base'
+--   and a number of mixin extensions 'e1',...,'en' as follows:
+--
+-- >  mixin (en <@> ... <@> e1 <@> base)
+--  
+module Control.Mixin.Mixin (
+  Mixin,
+  (<@>),
+  mixin,
+  mixinId,
+  mixinLift
+) where
+
+infixl 5 <@>
+
+-- | Type of mixin functions.
+type Mixin a =  a -- the 'super' function
+	     -> a -- the 'this'  function
+	     -> a -- the current function
+
+-- | Mixin composition.
+(<@>) :: Mixin a -> Mixin a -> Mixin a
+(f1 <@> f2) super this = f1 (f2 super this) this
+
+-- | Turn a mixin into a closed function.
+mixin :: Mixin a -> a
+mixin openF 
+  = let closedF = openF errorF closedF 
+        errorF  = error $ "super called in base mixin"
+    in closedF
+
+-- | Mixin identity function.
+--
+-- Identity for mixin composition:
+-- 
+--   
+-- > mixinId <@> f  ==  f
+-- > f <@> mixinId  ==  f
+--  
+mixinId :: Mixin a
+mixinId super this = super
+
+-- | Mixin lift function
+--
+-- > mixin . mixinLift = id
+
+mixinLift :: (a -> b) -> Mixin (a -> b)
+mixinLift f _ _ = f

+ src/Control/Monatron/AutoInstances.hs view

@@ -0,0 +1,19 @@+{-# Language FlexibleInstances #-}
+{-# language OverlappingInstances #-}
+{-# language IncoherentInstances #-}
+
+module Control.Monatron.AutoInstances where
+
+import Control.Monatron.MonadT
+
+------------------------------------------------------------------
+instance (Monad m, MonadT t) => Monad (t m) where
+    return = pure
+    fail   = lift . fail
+    (>>=)  = tbind
+
+instance (Monad m, MonadT t) => Functor (t m) where fmap = liftM
+
+instance (Monad m, MonadT t) => Applicative (t m) where
+  pure = treturn
+  (<*>) = ap

+ src/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

+ src/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
+
+------------------------
+

+ src/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
+

+ src/Control/Monatron/Monad.hs view

@@ -0,0 +1,70 @@+
+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  = pure
+    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 Applicative Id where pure = Id ; (<*>) = ap
+instance Applicative Lift where pure = L ; (<*>) = ap
+
+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

+ src/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
+

+ src/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)

+ src/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)

+ src/Control/Monatron/Open.hs view

@@ -0,0 +1,58 @@+-- {-# OPTIONS -fglasgow-exts -XNoMonomorphismRestriction -XOverlappingInstances #-}
+
+{-# LANGUAGE NoMonomorphismRestriction #-}
+{-# LANGUAGE OverlappingInstances #-}
+{-# LANGUAGE TypeOperators #-}
+{-# LANGUAGE MultiParamTypeClasses #-}
+{-# LANGUAGE FlexibleInstances #-}
+
+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

+ src/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)
+

+ src/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 hiding ((<>))
+-- 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))

+ src/Control/Monatron/Zipper.hs view

@@ -0,0 +1,123 @@+-- {-# OPTIONS -fglasgow-exts -XNoMonomorphismRestriction #-}
+{-# LANGUAGE NoMonomorphismRestriction #-}
+{-# LANGUAGE KindSignatures #-}
+{-# LANGUAGE TypeOperators #-}
+{-# LANGUAGE MultiParamTypeClasses #-}
+
+{-# 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

+ src/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

+ src/Control/Search/Combinator/And.hs view

@@ -0,0 +1,143 @@+{-# LANGUAGE FlexibleContexts #-}
+
+module Control.Search.Combinator.And (andN,(<&>)) where
+
+import Data.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]
+

+ src/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
+                   )

+ src/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
+         }

+ src/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
+                  }
+

+ src/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"

+ src/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
+            }

+ src/Control/Search/Combinator/Misc.hs view

@@ -0,0 +1,85 @@+{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE RankNTypes #-}
+
+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
+         } 
+

+ src/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

+ src/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"

+ src/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
+	         }

+ src/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
+             }

+ src/Control/Search/Combinator/Print.hs view

@@ -0,0 +1,34 @@+{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE RankNTypes #-}
+
+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
+         }

+ src/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
+	         }

+ src/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 }

+ src/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
+	         }

+ src/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 Data.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"
+
+

+ src/Control/Search/Generator.hs view

@@ -0,0 +1,860 @@+{-# 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 Prelude hiding ((<>))
+import Data.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 qualified Data.Semigroup as DS
+
+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 }
+
+instance DS.Semigroup ProgramString where
+  (<>) = mappend
+
+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)

+ src/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

+ src/Control/Search/Language.hs view

@@ -0,0 +1,538 @@+{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE NoMonomorphismRestriction #-}
+{-# LANGUAGE CPP #-}
+
+module Control.Search.Language  where 
+
+import Text.PrettyPrint
+import Data.Monoid hiding ((<>))
+import Prelude hiding ((<>))
+import qualified Data.Semigroup as DS
+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 = (>>>)
+
+instance DS.Semigroup Statement where
+  (<>) = (>>>)
+
+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

+ src/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 Data.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
+

+ src/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
+

+ src/Control/Search/SStateT.hs view

@@ -0,0 +1,47 @@+{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE MultiParamTypeClasses #-}
+
+module Control.Search.SStateT (
+  SStateT, sstateT, runSStateT,
+  Tup2(..), snd2, fst2
+) where
+
+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))

+ src/Control/Search/Stat.hs view

@@ -0,0 +1,186 @@+{-# 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 Prelude hiding ((<>))
+
+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"

+ src/Data/Expr/Data.hs view

@@ -0,0 +1,297 @@+{- 
+ - 	Monadic Constraint Programming
+ - 	http://www.cs.kuleuven.be/~toms/MCP/
+ - 	Pieter Wuille
+ -}
+
+{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE StandaloneDeriving #-}
+
+module Data.Expr.Data (
+  Expr(..),
+  ColExpr(..),
+  BoolExpr(..),
+  ExprRel(..),
+  (<<>>)
+) where 
+
+--------------------
+-- | Data types | --
+--------------------
+
+-- some simple kinds of expressions
+data Expr t c b =
+    Term t
+  | ExprHole Int
+  | Const Integer
+  | Plus (Expr t c b) (Expr t c b)
+  | Minus (Expr t c b) (Expr t c b)
+  | Mult (Expr t c b) (Expr t c b)
+  | Div (Expr t c b) (Expr t c b)
+  | Mod (Expr t c b) (Expr t c b)
+  | Abs (Expr t c b)
+  | At (ColExpr t c b) (Expr t c b)
+  | Fold (Expr t c b -> Expr t c b -> Expr t c b) (Expr t c b) (ColExpr t c b)
+  | Cond (BoolExpr t c b) (Expr t c b) (Expr t c b)
+  | ColSize (ColExpr t c b)
+  | Channel (BoolExpr t c b)
+
+data ColExpr t c b = 
+    ColTerm c
+  | ColList [Expr t c b]
+  | ColRange (Expr t c b) (Expr t c b)
+  | ColMap (Expr t c b -> Expr t c b) (ColExpr t c b)
+  | ColSlice (Expr t c b -> Expr t c b) (Expr t c b) (ColExpr t c b)   -- ColSlice f n c -> c[f(0)..f(n-1)]
+  | ColCat (ColExpr t c b) (ColExpr t c b)
+
+data ExprRel =
+    EREqual
+  | ERDiff
+  | ERLess
+  deriving (Show,Eq,Ord)
+
+data BoolExpr t c b =
+    BoolTerm b
+  | BoolConst Bool
+  | BoolAnd (BoolExpr t c b) (BoolExpr t c b)
+  | BoolOr (BoolExpr t c b) (BoolExpr t c b)
+  | BoolNot (BoolExpr t c b)
+  | BoolCond (BoolExpr t c b) (BoolExpr t c b) (BoolExpr t c b)
+  | Rel (Expr t c b) ExprRel (Expr t c b)
+  | BoolAll (Expr t c b -> BoolExpr t c b) (ColExpr t c b)
+  | BoolAny (Expr t c b -> BoolExpr t c b) (ColExpr t c b)
+  | ColEqual (ColExpr t c b) (ColExpr t c b)
+  | BoolEqual (BoolExpr t c b) (BoolExpr t c b)
+  | AllDiff Bool (ColExpr t c b)
+  | Sorted Bool (ColExpr t c b)
+  | Dom (Expr t c b) (ColExpr t c b)
+
+-----------------------
+-- | Show instance | --
+-----------------------
+
+class ShowFn t where
+  showFn :: Int -> t -> String
+instance (Show t, Show c, Show b) => ShowFn (Expr t c b) where
+  showFn _ (Term a) = "Term ("++(show a)++")"
+  showFn _ (ExprHole a) = "par"++(show a)
+  showFn _ (Const a) = "Const "++(show a)
+  showFn l (Plus a b) = "Plus ("++(showFn l a)++") ("++(showFn l b)++")"
+  showFn l (Minus a b) = "Minus ("++(showFn l a)++") ("++(showFn l b)++")"
+  showFn l (Mult a b) = "Mult ("++(showFn l a)++") ("++(showFn l b)++")"
+  showFn l (Div a b) = "Div ("++(showFn l a)++") ("++(showFn l b)++")"
+  showFn l (Mod a b) = "Mod ("++(showFn l a)++") ("++(showFn l b)++")"
+  showFn l (Abs a) = "Abs ("++(showFn l a)++")"
+  showFn l (At a b) = "At ("++(showFn l a)++") ("++(showFn l b)++")"
+  showFn l (Fold a b c) = "Fold ("++(showFn l a)++") ("++(showFn l b)++") ("++(showFn l c)++")"
+  showFn l (ColSize a) = "ColSize ("++(showFn l a)++")"
+  showFn l (Channel b) = "Channel ("++(showFn l b)++")"
+  showFn l (Cond c t f) = "Cond ("++(showFn l c)++") ("++(showFn l t)++") ("++(showFn l f)++")"
+instance (ShowFn l) => ShowFn [l] where
+  showFn d l = "[" ++ (foldr1 (\a b -> a++","++b) $ map (showFn d) l) ++ "]"
+instance (Show t, Show c, Show b) => ShowFn (ColExpr t c b) where
+  showFn d (ColTerm a) = "ColTerm ("++(show a)++")"
+  showFn d (ColList l) = "ColList ("++(showFn d l)++")"
+  showFn d (ColMap f l) = "ColMap ("++(showFn d f)++") ("++(showFn d l)++")"
+  showFn d (ColSlice f l c) = "ColSlice ("++(showFn d f)++") ("++(showFn d l)++") ("++(showFn d c)++")"
+  showFn d (ColCat a b) = "ColCat ("++(showFn d a)++") ("++(showFn d b)++")"
+  showFn d (ColRange a b) = "ColRange ("++(showFn d a)++") ("++(showFn d b)++")"
+instance (Show t, Show c, Show b) => ShowFn (BoolExpr t c b) where
+  showFn d (BoolTerm b) = "BoolTerm ("++(show b)++")"
+  showFn d (BoolConst b) = "BoolConst "++(show b)
+  showFn d (BoolAnd a b) = "BoolAnd ("++(showFn d a)++") ("++(showFn d b)++")"
+  showFn d (BoolOr a b) = "BoolOr ("++(showFn d a)++") ("++(showFn d b)++")"
+  showFn d (BoolNot a) = "BoolNot ("++(showFn d a)++")"
+  showFn d (BoolEqual a b) = "BoolEqual ("++(showFn d a)++") ("++(showFn d b)++")"
+  showFn d (Rel a r b) = "Rel ("++(showFn d a)++") "++(show r)++" ("++(showFn d b)++")"
+  showFn d (BoolAll f c) = "BoolAll ("++(showFn d f)++") ("++(showFn d c)++")"
+  showFn d (BoolAny f c) = "BoolAny ("++(showFn d f)++") ("++(showFn d c)++")"
+  showFn d (ColEqual a b) = "ColEqual ("++(showFn d a)++") ("++(showFn d b)++")"
+  showFn d (AllDiff _ c) = "AllDiff ("++(showFn d c)++")"
+  showFn d (Sorted b c) = "Sorted "++(show b)++"("++(showFn d c)++")"
+  showFn l (BoolCond c t f) = "BoolCond ("++(showFn l c)++") ("++(showFn l t)++") ("++(showFn l f)++")"
+  showFn d (Dom i c) = "Dom ("++(showFn d i)++") ("++(showFn d c)++")"
+instance (Show t, Show c, Show b, ShowFn e) => ShowFn (Expr t c b -> e) where
+  showFn l f = "\\par"++(show l)++" -> "++(showFn (l+1) (f (ExprHole l)))
+instance (Show t, Show c, Show b) => Show (Expr t c b) where
+  show = showFn 0
+instance (Show t, Show c, Show b) => Show (ColExpr t c b) where
+  show = showFn 0
+instance (Show t, Show c, Show b) => Show (BoolExpr t c b) where
+  show = showFn 0
+
+---------------------
+-- | Eq instance | --
+---------------------
+
+equalExpr :: (Eq t, Eq c, Eq b) => Int -> Expr t c b -> Expr t c b -> Bool
+equalExpr _ (Term a) (Term b) = a==b
+equalExpr _ (ExprHole a) (ExprHole b) = a==b
+equalExpr _ (Const a) (Const b) = a==b
+equalExpr l (Plus a c) (Plus b d) = equalExpr l a b && equalExpr l d c
+equalExpr l (Minus a c) (Minus b d) = equalExpr l a b && equalExpr l d c
+equalExpr l (Mult a c) (Mult b d) = equalExpr l a b && equalExpr l d c
+equalExpr l (Div a c) (Plus b d) = equalExpr l a b && equalExpr l d c
+equalExpr l (Mod a c) (Plus b d) = equalExpr l a b && equalExpr l d c
+equalExpr l (Abs a) (Abs b) = equalExpr l a b
+equalExpr l (At a c) (At b d) = equalExpr l c d && equalColExpr l a b
+equalExpr l (ColSize a) (ColSize b) = equalColExpr l a b
+equalExpr l (Fold f a c) (Fold g b d) = equalExpr l a b && equalColExpr l c d && equalExpr (l+2) (f (ExprHole l) (ExprHole $ l+1)) (g (ExprHole l) (ExprHole $ l+1))
+equalExpr l (Channel a) (Channel b) = equalBoolExpr l a b
+equalExpr l (Cond c t f) (Cond d u g) = equalBoolExpr l c d && equalExpr l t u && equalExpr l f g
+equalExpr _ _ _ = False
+
+equalColExpr :: (Eq t, Eq c, Eq b) => Int -> ColExpr t c b -> ColExpr t c b -> Bool
+equalColExpr _ (ColTerm a) (ColTerm b) = a==b
+equalColExpr _ (ColList []) (ColList []) = True
+equalColExpr l (ColList (a:ar)) (ColList (b:br)) = equalExpr l a b && equalColExpr l (ColList ar) (ColList br)
+equalColExpr l (ColMap f a) (ColMap g b) = equalColExpr l a b && equalExpr (l+1) (f (ExprHole l)) (g (ExprHole l))
+equalColExpr l (ColSlice a c e) (ColSlice b d f) = equalExpr (l+1) (a (ExprHole l)) (b  (ExprHole l)) && equalExpr l c d && equalColExpr l e f
+equalColExpr l (ColCat a c) (ColCat b d) = equalColExpr l a b && equalColExpr l c d
+equalColExpr l (ColRange a c) (ColRange b d) = equalExpr l a b && equalExpr l c d
+equalColExpr _ _ _ = False
+
+equalBoolExpr :: (Eq t, Eq c, Eq b) => Int -> BoolExpr t c b -> BoolExpr t c b -> Bool
+equalBoolExpr _ (BoolTerm a) (BoolTerm b) = a==b
+equalBoolExpr _ (BoolConst a) (BoolConst b) = a==b
+equalBoolExpr l (BoolAnd a c) (BoolAnd b d) = equalBoolExpr l a b && equalBoolExpr l c d
+equalBoolExpr l (BoolOr a c) (BoolOr b d) = equalBoolExpr l a b && equalBoolExpr l c d
+equalBoolExpr l (BoolEqual a c) (BoolEqual b d) = equalBoolExpr l a b && equalBoolExpr l c d
+equalBoolExpr l (BoolNot a) (BoolNot b) = equalBoolExpr l a b
+equalBoolExpr l (Rel a r c) (Rel b s d) = r==s && equalExpr l a b && equalExpr l c d
+equalBoolExpr l (BoolAll f c) (BoolAll g d) = equalColExpr l c d && equalBoolExpr (l+1) (f $ ExprHole l) (g $ ExprHole l)
+equalBoolExpr l (BoolAny f c) (BoolAny g d) = equalColExpr l c d && equalBoolExpr (l+1) (f $ ExprHole l) (g $ ExprHole l)
+equalBoolExpr l (ColEqual a c) (ColEqual b d) = equalColExpr l a b && equalColExpr l c d
+equalBoolExpr l (AllDiff _ c) (AllDiff _ d) = equalColExpr l c d
+equalBoolExpr l (Sorted a c) (Sorted b d) = a==b && equalColExpr l c d
+equalBoolExpr l (BoolCond c t f) (BoolCond d u g) = equalBoolExpr l c d && equalBoolExpr l t u && equalBoolExpr l f g
+equalBoolExpr l (Dom a c) (Dom b d) = equalExpr l a b && equalColExpr l c d
+equalBoolExpr _ _ _ = False
+
+instance (Eq t, Eq c, Eq b) => Eq (Expr t c b) where
+  a == b = equalExpr 0 a b
+instance (Eq t, Eq c, Eq b) => Eq (ColExpr t c b) where
+  a == b = equalColExpr 0 a b
+instance (Eq t, Eq c, Eq b) => Eq (BoolExpr t c b) where
+  a == b = equalBoolExpr 0 a b
+
+-----------------------------------------------------
+-- | ExprKey: Provides ordering over expressions | --
+-----------------------------------------------------
+
+infixr 4 <<>>
+a <<>> b = case a of
+  EQ -> b
+  _ -> a
+
+compareColExpr :: (Ord s, Ord c, Ord b) => Int -> ColExpr s c b -> ColExpr s c b -> Ordering
+compareColExpr _ (ColList []) (ColList []) = EQ
+compareColExpr l (ColList (a:ar)) (ColList (b:br)) = compareExpr l a b <<>> compareColExpr l (ColList ar) (ColList br)
+compareColExpr _ (ColList _) _ = LT
+compareColExpr _ _ (ColList _) = GT
+compareColExpr l (ColMap f1 c1) (ColMap f2 c2) = compareColExpr l c1 c2 <<>> compareExpr (l+1) (f1 $ ExprHole l) (f2 $ ExprHole l)
+compareColExpr _ (ColMap _ _) _ = LT
+compareColExpr _ _ (ColMap _ _) = GT
+compareColExpr l (ColSlice p1 l1 c1) (ColSlice p2 l2 c2) = compareExpr (l+1) (p1 $ ExprHole l) (p2 $ ExprHole l) <<>> compareExpr l l1 l2 <<>> compareColExpr l c1 c2
+compareColExpr _ (ColSlice _ _ _) _ = LT
+compareColExpr _ _ (ColSlice _ _ _) = GT
+compareColExpr l (ColCat a1 b1) (ColCat a2 b2) = compareColExpr l a1 a2 <<>> compareColExpr l b1 b2
+compareColExpr _ (ColCat _ _) _ = LT
+compareColExpr _ _ (ColCat _ _) = GT
+compareColExpr l (ColRange l1 h1) (ColRange l2 h2) = compareExpr l l1 l2 <<>> compareExpr l l2 h2
+compareColExpr _ (ColRange _ _) _ = LT
+compareColExpr _ _ (ColRange _ _) = GT
+compareColExpr _ (ColTerm t1) (ColTerm t2) = compare t1 t2
+
+compareBoolExpr :: (Ord s, Ord c, Ord b) => Int -> BoolExpr s c b -> BoolExpr s c b -> Ordering
+compareBoolExpr _ (BoolConst a) (BoolConst b) = compare a b
+compareBoolExpr _ (BoolConst _) _ = LT
+compareBoolExpr _ _ (BoolConst _) = GT
+compareBoolExpr l (BoolAnd a1 b1) (BoolAnd a2 b2) = compareBoolExpr l a1 a2 <<>> compareBoolExpr l b1 b2
+compareBoolExpr _ (BoolAnd _ _) _ = LT
+compareBoolExpr _ _ (BoolAnd _ _) = GT
+compareBoolExpr l (BoolOr a1 b1) (BoolOr a2 b2) = compareBoolExpr l a1 a2 <<>> compareBoolExpr l b1 b2
+compareBoolExpr _ (BoolOr _ _) _ = LT
+compareBoolExpr _ _ (BoolOr _ _) = GT
+compareBoolExpr l (BoolEqual a1 b1) (BoolEqual a2 b2) = compareBoolExpr l a1 a2 <<>> compareBoolExpr l b1 b2
+compareBoolExpr _ (BoolEqual _ _) _ = LT
+compareBoolExpr _ _ (BoolEqual _ _) = GT
+compareBoolExpr l (BoolNot a1) (BoolNot a2) = compareBoolExpr l a1 a2
+compareBoolExpr _ (BoolNot _) _ = LT
+compareBoolExpr _ _ (BoolNot _) = GT
+compareBoolExpr l (Rel a1 r1 b1) (Rel a2 r2 b2) = compare r1 r2 <<>> compareExpr l a1 a2 <<>> compareExpr l b1 b2
+compareBoolExpr _ (Rel _ _ _) _ = LT
+compareBoolExpr _ _ (Rel _ _ _) = GT
+compareBoolExpr l (BoolAll f1 c1) (BoolAll f2 c2) = compareColExpr l c1 c2 <<>> compareBoolExpr (l+1) (f1 $ ExprHole l) (f2 $ ExprHole l)
+compareBoolExpr _ (BoolAll _ _) _ = LT
+compareBoolExpr _ _ (BoolAll _ _) = GT
+compareBoolExpr l (BoolAny f1 c1) (BoolAny f2 c2) = compareColExpr l c1 c2 <<>> compareBoolExpr (l+1) (f1 $ ExprHole l) (f2 $ ExprHole l)
+compareBoolExpr _ (BoolAny _ _) _ = LT
+compareBoolExpr _ _ (BoolAny _ _) = GT
+compareBoolExpr l (ColEqual a1 b1) (ColEqual a2 b2) = compareColExpr l a1 a2 <<>> compareColExpr l b1 b2
+compareBoolExpr _ (ColEqual _ _) _ = LT
+compareBoolExpr _ _ (ColEqual _ _) = GT
+compareBoolExpr l (Sorted a1 b1) (Sorted a2 b2) = compare a1 a2 <<>> compareColExpr l b1 b2
+compareBoolExpr _ (Sorted _ _) _ = LT
+compareBoolExpr _ _ (Sorted _ _) = GT
+compareBoolExpr l (AllDiff _ b1) (AllDiff _ b2) = compareColExpr l b1 b2
+compareBoolExpr _ (AllDiff _ _) _ = LT
+compareBoolExpr _ _ (AllDiff _ _) = GT
+compareBoolExpr l (BoolCond c1 t1 f1) (BoolCond c2 t2 f2) = compareBoolExpr l c1 c2 <<>> compareBoolExpr l t1 t2 <<>> compareBoolExpr l f1 f2
+compareBoolExpr _ (BoolCond _ _ _) _ = LT
+compareBoolExpr _ _ (BoolCond _ _ _) = GT
+compareBoolExpr l (Dom i1 c1) (Dom i2 c2) = compareExpr l i1 i2 <<>> compareColExpr l c1 c2
+compareBoolExpr _ (Dom _ _) _ = LT
+compareBoolExpr _ _ (Dom _ _) = GT
+compareBoolExpr _ (BoolTerm a) (BoolTerm b) = compare a b
+
+compareExpr :: (Ord s, Ord c, Ord b) => Int -> Expr s c b -> Expr s c b -> Ordering
+compareExpr _ (Const i1) (Const i2) = compare i1 i2
+compareExpr _ (Const _) _ = LT
+compareExpr _ _ (Const _) = GT
+compareExpr _ (ExprHole i1) (ExprHole i2) = compare i1 i2
+compareExpr _ (ExprHole _) _ = LT
+compareExpr _ _ (ExprHole _) = GT
+compareExpr l (Plus a1 b1) (Plus a2 b2) = compareExpr l a1 a2 <<>> compareExpr l b1 b2
+compareExpr _ (Plus _ _) _ = LT
+compareExpr _ _ (Plus _ _) = GT
+compareExpr l (Minus a1 b1) (Minus a2 b2) = compareExpr l a1 a2 <<>> compareExpr l b1 b2
+compareExpr _ (Minus _ _) _ = LT
+compareExpr _ _ (Minus _ _) = GT
+compareExpr l (Mult a1 b1) (Mult a2 b2) = compareExpr l a1 a2 <<>> compareExpr l b1 b2
+compareExpr _ (Mult _ _) _ = LT
+compareExpr _ _ (Mult _ _) = GT
+compareExpr l (Div a1 b1) (Div a2 b2) = compareExpr l a1 a2 <<>> compareExpr l b1 b2
+compareExpr _ (Div _ _) _ = LT
+compareExpr _ _ (Div _ _) = GT
+compareExpr l (Mod a1 b1) (Mod a2 b2) = compareExpr l a1 a2 <<>> compareExpr l b1 b2
+compareExpr _ (Mod _ _) _ = LT
+compareExpr _ _ (Mod _ _) = GT
+compareExpr l (Abs a1) (Abs a2) = compareExpr l a1 a2
+compareExpr _ (Abs _) _ = LT
+compareExpr _ _ (Abs _) = GT
+compareExpr l (At c1 a1) (At c2 a2) = compareExpr l a1 a2 <<>> compareColExpr l c1 c2
+compareExpr _ (At _ _) _ = LT
+compareExpr _ _ (At _ _) = GT
+compareExpr l (ColSize c1) (ColSize c2) = compareColExpr l c1 c2
+compareExpr _ (ColSize _) _ = LT
+compareExpr _ _ (ColSize _) = GT
+compareExpr l (Fold f1 i1 c1) (Fold f2 i2 c2) = compareExpr l i1 i2 <<>> compareColExpr l c1 c2 <<>> compareExpr (l+2) (f1 (ExprHole l) (ExprHole $ l+1)) (f2 (ExprHole l) (ExprHole $ l+1))
+compareExpr _ (Fold _ _ _) _ = LT
+compareExpr _ _ (Fold _ _ _) = GT
+compareExpr l (Channel b1) (Channel b2) = compareBoolExpr l b1 b2
+compareExpr _ (Channel _) _ = LT
+compareExpr _ _ (Channel _) = GT
+compareExpr l (Cond c1 t1 f1) (Cond c2 t2 f2) = compareBoolExpr l c1 c2 <<>> compareExpr l t1 t2 <<>> compareExpr l f1 f2
+compareExpr _ (Cond _ _ _) _ = LT
+compareExpr _ _ (Cond _ _ _) = GT
+compareExpr _ (Term t1) (Term t2) = compare t1 t2
+
+instance (Ord s, Ord c, Ord b) => Ord (Expr s c b) where
+  compare = compareExpr 0
+
+instance (Ord s, Ord c, Ord b) => Ord (ColExpr s c b) where
+  compare = compareColExpr 0
+
+instance (Ord s, Ord c, Ord b) => Ord (BoolExpr s c b) where
+  compare = compareBoolExpr 0

+ src/Data/Expr/Sugar.hs view

@@ -0,0 +1,285 @@+{- 
+ - 	Monadic Constraint Programming
+ - 	http://www.cs.kuleuven.be/~toms/MCP/
+ - 	Pieter Wuille
+ -}
+
+{-# LANGUAGE MultiParamTypeClasses #-}
+{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE FlexibleContexts #-}
+
+module Data.Expr.Sugar (
+  (@+), (@-), (@*), (@/), (@%), (@?), (@??), (@:),
+  (!), (@!!), (@++), (@..), size, slice, xhead, xtail, xmap, xfold, list, channel, xsum,
+  (@||), (@&&), inv,
+  (@/=), (@>), (@<), (@>=), (@<=), (@=), 
+  loopall, loopany, forall, forany,
+  Expr(), ColExpr(), BoolExpr(),
+  ToExpr(..), ToColExpr(..), ToBoolExpr(..),
+  sorted, sSorted, allDiff, allDiffD,
+  ExprClass, ExprRange,
+) where 
+
+import Data.Expr.Data
+import Data.Expr.Util
+
+----------------------------------
+-- | Built-in class instances | --
+----------------------------------
+
+instance (Eq s, Eq c, Eq b, Show s, Show c, Show b) => Num (Expr s c b) where
+  a + b = simplify $ a `Plus` b
+  a - b = simplify $ a `Minus` b
+  a * b = simplify $ a `Mult` b
+  abs a = simplify $ Abs a
+  negate a = simplify $ (Const 0) `Minus` a
+  fromInteger c = Const $ fromInteger c
+  signum (Const a) = Const $ signum a
+  signum a = error "signum not possible for generic Expr"
+
+instance (Ord s, Ord c, Ord b, Eq s, Eq c, Eq b, Show s, Show c, Show b) => Real (Expr s c b) where
+  toRational (Const x) = toRational x
+  toRational _ = error "toRational not possible for generic Expr"
+
+instance (Eq s, Eq c, Eq b) => Enum (Expr s c b) where
+  succ a = simplify $ a `Plus` (Const 1)
+  pred a = simplify $ a `Minus` (Const 1)
+  toEnum = Const . toEnum
+  fromEnum (Const a) = fromEnum a
+  fromEnum _ = error "fromEnum not possible for generic Expr"
+
+instance (Ord s, Ord c, Ord b, Eq s, Eq c, Eq b, Show s, Show c, Show b) => Integral (Expr s c b) where
+  toInteger (Const a) = toInteger a
+  toInteger _ = error "toInteger not possible for generic Expr"
+  divMod a b = (simplify $ a `Div` b, simplify $ a `Mod` b)
+  quotRem (Const a) (Const b) = case quotRem a b of (c,d) -> (Const c,Const d)
+  quotRem (Const 0) b = (Const 0,Const 0)
+  quotRem a (Const 1) = (a,Const 0)
+  quotRem a (Const (-1)) = (negate a,Const 0)
+  quotRem _ _ = error "quotRem not possible for generic Expr"
+
+---------------------------------------------
+-- | convertion from/to expression types | --
+---------------------------------------------
+
+-- convertible to expressions:
+class ToExpr tt cc bb t where
+  toExpr :: t -> Expr tt cc bb
+
+-- convertible to collection-expressions:
+class ToColExpr tt cc bb c where
+  toColExpr :: c -> ColExpr tt cc bb
+
+-- convertible to boolean expressions:
+class ToBoolExpr tt cc bb b where
+  toBoolExpr :: b -> BoolExpr tt cc bb
+
+-- infix 4 @=, @/=
+
+class (Eq tt, Eq cc, Eq bb) => ExprClass tt cc bb a where
+  (@=)  :: a -> a -> BoolExpr tt cc bb
+  (@/=) :: a -> a -> BoolExpr tt cc bb
+  a @/= b = boolSimplify $ BoolNot $ a @= b
+
+class (Eq tt, Eq cc, Eq bb) => ExprRange tt cc bb r where
+  (@:)  :: Expr tt cc bb -> r -> BoolExpr tt cc bb
+
+-- integers can be used as constant expressions
+instance ToExpr tt cc bb Integer where
+  toExpr = Const
+
+-- expressions themselves are trivially convertible to expressions
+instance ToExpr t a b (Expr t a b) where
+  toExpr = id
+
+-- ints can be used as constant expressions
+instance ToExpr tt cc bb Int where
+  toExpr = Const . toInteger
+
+-- boolean expressions can be used as integer expressions (being 0 or 1)
+instance (Eq t, Eq a, Eq b) => ToExpr t a b (BoolExpr t a b) where
+  toExpr = simplify . Channel
+
+-- collection expressions themselves are trivially convertible to collection expressions
+instance ToColExpr t a b (ColExpr t a b) where
+  toColExpr = id
+
+-- an expression can be used as a collection of one expressions
+instance (Eq t, Eq a, Eq b) => ToColExpr t a b (Expr t a b) where
+  toColExpr a = colSimplify $ ColList [a]
+
+-- a list of expressions van be used as a collection
+instance (Eq b, Eq a, Eq t) => ToColExpr t a b [Expr t a b] where
+  toColExpr = colSimplify . ColList
+
+-- a boolean constant can be used as a constant boolean expression
+instance ToBoolExpr tt cc bb Bool where
+  toBoolExpr = BoolConst
+
+-- boolean expressions are trivially convertible to boolean expressions
+instance ToBoolExpr t a b (BoolExpr t a b) where
+  toBoolExpr = id
+
+-- the integer terms used by an expression can be used as interger expressions
+instance ToExpr t a b t where
+  toExpr = Term
+
+-- the collections terms used by an expression can be used as collection expressions
+instance ToColExpr t a b a where
+  toColExpr = ColTerm
+
+-- the boolean terms used by an expression can be used as boolean expressions
+instance ToBoolExpr t a b b where
+  toBoolExpr = BoolTerm
+
+-------------------------------------
+-- | integer operators/functions | --
+-------------------------------------
+
+-- @+ @- @* @/ @% are identical to + - * / % for integer expressions, except
+-- that they also accept types convertible to expressions, instead of only
+-- expressions themselves
+
+infixl 6 @+, @-
+infixl 7 @*
+infixl 7 @/
+infixl 7 @%
+
+(@+) :: (Eq t, Eq c, Eq b, ToExpr t c b p, ToExpr t c b q) => p -> q -> Expr t c b
+(@-) :: (Eq t, Eq c, Eq b, ToExpr t c b p, ToExpr t c b q) => p -> q -> Expr t c b
+(@*) :: (Eq t, Eq c, Eq b, ToExpr t c b p, ToExpr t c b q) => p -> q -> Expr t c b
+(@/) :: (Eq t, Eq c, Eq b, ToExpr t c b p, ToExpr t c b q) => p -> q -> Expr t c b
+(@%) :: (Eq t, Eq c, Eq b, ToExpr t c b p, ToExpr t c b q) => p -> q -> Expr t c b
+
+a @+ b = simplify $ (toExpr a) `Plus` (toExpr b)
+a @- b = simplify $ (toExpr a) `Minus` (toExpr b)
+a @* b = simplify $ (toExpr a) `Mult` (toExpr b)
+a @/ b = simplify $ (toExpr a) `Div` (toExpr b)
+a @% b = simplify $ (toExpr a) `Mod` (toExpr b)
+
+----------------------------------
+-- | list operators/functions | --
+----------------------------------
+
+infix 9 !
+infix 9 @!!
+infix 9 @..
+infixr 5 @++
+infix 4 @?
+infix 4 @??
+infix 5 @:
+
+(!) :: (Eq t, Eq c, Eq b) => ColExpr t c b -> Expr t c b -> Expr t c b
+(@!!) :: (Eq t, Eq c, Eq b) => ColExpr t c b -> Integer -> Expr t c b
+(@..) :: (Eq t, Eq c, Eq b) => Expr t c b -> Expr t c b -> ColExpr t c b
+(@++) :: (Eq t, Eq c, Eq b) => ColExpr t c b -> ColExpr t c b -> ColExpr t c b
+
+(@?) :: (Eq t, Eq c, Eq b) => BoolExpr t c b -> (Expr t c b, Expr t c b) -> Expr t c b
+c @? (t,f) = simplify $ Cond c t f
+
+(@??) :: (Eq t, Eq c, Eq b) => BoolExpr t c b -> (BoolExpr t c b, BoolExpr t c b) -> BoolExpr t c b
+c @?? (t,f) = boolSimplify $ BoolCond c t f
+
+c!p = simplify $ At c p
+c @!! p = simplify $ At c (Const p)
+a @.. b = colSimplify $ ColRange (toExpr a) (toExpr b)
+a @++ b = colSimplify $ ColCat (toColExpr a) (toColExpr b)
+
+size :: (Eq t, Eq c, Eq b) => ColExpr t c b -> Expr t c b
+size a = simplify $ ColSize a
+
+xfold :: (Eq t, Eq c, Eq b) => (Expr t c b -> Expr t c b -> Expr t c b) -> Expr t c b -> ColExpr t c b -> Expr t c b
+xfold f i c = simplify $ Fold (\a b -> f a b) i c
+
+xsum :: (Num (Expr t c b), Eq t, Eq c, Eq b) => ColExpr t c b -> Expr t c b
+xsum c = xfold (+) (Const 0) c
+
+list :: (Eq t, Eq c, Eq b) => [Expr t c b] -> ColExpr t c b
+list x = colSimplify $ ColList x
+
+xhead :: (Eq t, Eq c, Eq b, ToColExpr t c b p) => p -> Expr t c b
+xhead c = simplify $ At (toColExpr c) (Const 0)
+
+xtail :: (Eq t, Eq c, Eq b, ToColExpr t c b p) => p -> ColExpr t c b
+xtail c = let cc = toColExpr c in colSimplify $ ColSlice (\x -> simplify (x `Plus` (Const 1))) (simplify $ (size cc) `Minus` (Const 1)) cc
+
+slice :: (Eq t, Eq c, Eq b) => ColExpr t c b -> ColExpr t c b -> ColExpr t c b
+slice c p = case (c,p) of
+  (_,ColRange l h) -> colSimplify $ ColSlice (\x -> simplify (l `Plus` x)) (simplify $ Const 1 `Plus` (simplify $ h `Minus` l)) c
+  (_,ColMap f (ColRange l h)) -> colSimplify $ ColSlice (\i -> simplify $ f $ simplify (l `Plus` i)) (simplify $ Const 1 `Plus` (simplify $ h `Minus` l)) c
+  (_,ColSlice f n c2) -> colSimplify $ ColSlice (\i -> simplify $ c2 `At` (f i)) n c
+  _ -> xmap (\i -> simplify $ c `At` i) p
+
+xmap :: (Eq t, Eq c, Eq b) => (Expr t c b -> Expr t c b) -> ColExpr t c b -> ColExpr t c b
+xmap f c = colSimplify $ ColMap f c
+
+loopall :: (Eq t, Eq c, Eq b) => (Expr t c b,Expr t c b) -> (Expr t c b -> BoolExpr t c b) -> BoolExpr t c b
+loopall (l,h) f = boolSimplify $ BoolAll f $ colSimplify $ ColRange l h
+
+loopany :: (Eq t, Eq c, Eq b) => (Expr t c b,Expr t c b) -> (Expr t c b -> BoolExpr t c b) -> BoolExpr t c b
+loopany (l,h) f = boolSimplify $ BoolAny f $ colSimplify $ ColRange l h
+
+forall :: (Eq t, Eq c, Eq b) => (ColExpr t c b) -> (Expr t c b -> BoolExpr t c b) -> BoolExpr t c b
+forall c f = boolSimplify $ BoolAll f c
+
+forany :: (Eq t, Eq c, Eq b) => (ColExpr t c b) -> (Expr t c b -> BoolExpr t c b) -> BoolExpr t c b
+forany c f = boolSimplify $ BoolAny f c
+
+channel :: (Eq t, Eq c, Eq b) => BoolExpr t c b -> Expr t c b
+channel = simplify . Channel 
+
+-------------------------------------
+-- | boolean operators/functions | --
+-------------------------------------
+
+-- infixr 1 /\
+-- infixr 1 \/
+infixr 2 @||
+infixr 3 @&&
+
+-- (\/) :: (Eq t, Eq c, Eq b, ToBoolExpr t c b p, ToBoolExpr t c b q) => p -> q -> BoolExpr t c b
+-- (/\) :: (Eq t, Eq c, Eq b, ToBoolExpr t c b p, ToBoolExpr t c b q) => p -> q -> BoolExpr t c b
+inv :: (Eq t, Eq c, Eq b, ToBoolExpr t c b p) => p -> BoolExpr t c b
+
+a @|| b = boolSimplify $ BoolOr (toBoolExpr a) (toBoolExpr b)
+a @&& b = boolSimplify $ BoolAnd (toBoolExpr a) (toBoolExpr b)
+inv a = boolSimplify $ BoolNot (toBoolExpr a)
+-- a \/ b = a @|| b
+-- a /\ b = a @&& b
+
+----------------------------------------
+-- | relational operators/functions | --
+----------------------------------------
+
+instance (Eq t, Eq c, Eq b) => ExprClass t c b (Expr t c b) where
+  a @= b = boolSimplify $ Rel a EREqual b
+
+instance (Eq t, Eq c, Eq b) => ExprClass t c b (BoolExpr t c b) where
+  a @= b = boolSimplify $ BoolEqual a b
+
+instance (Eq t, Eq c, Eq b) => ExprClass t c b (ColExpr t c b) where
+  a @= b = boolSimplify $ ColEqual a b
+
+  
+infixr 4 @<,@<=,@>,@>=
+(@<) ::  (Eq t, Eq c, Eq b) => Expr t c b -> Expr t c b -> BoolExpr t c b
+(@>) ::  (Eq t, Eq c, Eq b) => Expr t c b -> Expr t c b -> BoolExpr t c b
+(@<=) :: (Eq t, Eq c, Eq b) => Expr t c b -> Expr t c b -> BoolExpr t c b
+(@>=) :: (Eq t, Eq c, Eq b) => Expr t c b -> Expr t c b -> BoolExpr t c b
+
+a @< b = boolSimplify $ Rel a ERLess b
+a @> b = boolSimplify $ Rel b ERLess a
+a @<= b = boolSimplify $ Rel a ERLess (simplify $ b `Plus` (Const 1))
+a @>= b = boolSimplify $ Rel b ERLess (simplify $ a `Plus` (Const 1))
+
+sorted c = boolSimplify $ Sorted False c
+sSorted c = boolSimplify $ Sorted True c
+allDiff c = boolSimplify $ AllDiff False c
+allDiffD c = boolSimplify $ AllDiff True c
+
+instance (Eq t, Eq c, Eq b) => ExprRange t c b (Expr t c b,Expr t c b) where
+  a @: (l,h) = (a @>= l) @&& (a @<= h)
+
+instance (Eq t, Eq c, Eq b) => ExprRange t c b (ColExpr t c b) where
+  a @: c = boolSimplify $ Dom a c
+

+ src/Data/Expr/Util.hs view

@@ -0,0 +1,481 @@+{- 
+ - 	Monadic Constraint Programming
+ - 	http://www.cs.kuleuven.be/~toms/MCP/
+ - 	Pieter Wuille
+ -}
+
+{-# LANGUAGE StandaloneDeriving #-}
+
+module Data.Expr.Util (
+  Expr(), BoolExpr(), ColExpr(),
+  transform, colTransform, boolTransform,
+  transformEx, colTransformEx, boolTransformEx,
+  property, colProperty, boolProperty,
+  propertyEx, colPropertyEx, boolPropertyEx,
+  collapse, colCollapse, boolCollapse,
+  simplify, colSimplify, boolSimplify,
+  WalkPhase(..), WalkResult(..), walk, colWalk, boolWalk,
+) where 
+
+import Data.Expr.Data
+
+-------------------------
+-- | Helper functions |--
+-------------------------
+
+relCheck :: Integer -> ExprRel -> Integer -> Bool
+relCheck a EREqual b = a==b
+relCheck a ERDiff b = a/=b
+relCheck a ERLess b = a<b
+
+-------------------------------------------------------------------------
+-- | Transform expressions over one type to expressions over another | --
+-------------------------------------------------------------------------
+
+transform :: (Eq a, Eq b, Eq c, Eq d, Eq e, Eq f) => (a->b,c->d,e->f,b->a,d->c,f->e) -> Expr a c e -> Expr b d f
+transform (f,fc,fb,fi,fic,fib) = transformEx (Term . f, ColTerm . fc, BoolTerm . fb, Term . fi, ColTerm . fic, BoolTerm . fib)
+
+transformEx :: (Eq a, Eq b, Eq c, Eq d, Eq e, Eq f) => ((a -> Expr b d f),(c -> ColExpr b d f),(e -> BoolExpr b d f),(b -> Expr a c e),(d -> ColExpr a c e),(f -> BoolExpr a c e)) -> Expr a c e -> Expr b d f
+transformEx (f,_,_,_,_,_) (Term v) = f v
+transformEx f (Const i) = Const i
+transformEx f (ExprHole i) = ExprHole i
+transformEx f (Plus a b) = simplify $ Plus (transformEx f a) (transformEx f b)
+transformEx f (Minus a b) = simplify $ Minus (transformEx f a) (transformEx f b)
+transformEx f (Mult a b) = simplify $ Mult (transformEx f a) (transformEx f b)
+transformEx f (Div a b) = simplify $ Div (transformEx f a) (transformEx f b)
+transformEx f (Mod a b) = simplify $ Mod (transformEx f a) (transformEx f b)
+transformEx f (Abs a) = simplify $ Abs (transformEx f a)
+transformEx f (At c a) = simplify $ At (colTransformEx f c) (transformEx f a)
+transformEx f (ColSize c) = simplify $ ColSize $ colTransformEx f c
+transformEx f (Channel a) = simplify $ Channel $ boolTransformEx f a
+transformEx f (Cond c t e) = simplify $ Cond (boolTransformEx f c) (transformEx f t) (transformEx f e)
+transformEx t@(f,fc,fb,fi,fic,fib) (Fold m i c) = simplify $ Fold (\a b -> transformEx t (m (transformEx (fi,fic,fib,f,fc,fb) a) (transformEx (fi,fic,fib,f,fc,fb) b))) (transformEx t i) (colTransformEx t c)
+
+colTransform :: (Eq a, Eq b, Eq c, Eq d, Eq e, Eq f) => (a->b,c->d,e->f,b->a,d->c,f->e) -> ColExpr a c e -> ColExpr b d f
+colTransform (f,fc,fb,fi,fic,fib) = colTransformEx (Term . f, ColTerm . fc, BoolTerm . fb, Term . fi, ColTerm . fic, BoolTerm . fib)
+
+colTransformEx :: (Eq a, Eq b, Eq c, Eq d, Eq e, Eq f) => ((a -> Expr b d f),(c -> ColExpr b d f),(e -> BoolExpr b d f),(b -> Expr a c e),(d -> ColExpr a c e),f -> BoolExpr a c e) -> ColExpr a c e -> ColExpr b d f
+colTransformEx (_,f,_,_,_,_)  (ColTerm c) = f c
+colTransformEx f (ColList l) = colSimplify $ ColList $ map (transformEx f) l
+colTransformEx t@(f,fc,fb,fi,fic,fib) (ColMap m c) = colSimplify $ ColMap (\a -> transformEx t (m (transformEx (fi,fic,fib,f,fc,fb) a))) (colTransformEx t c)
+colTransformEx t@(f,fc,fb,fi,fic,fib) (ColSlice p l c) = colSimplify $ ColSlice (\a -> transformEx t (p (transformEx (fi,fic,fib,f,fc,fb) a))) (transformEx t l) (colTransformEx t c)
+colTransformEx f (ColCat a b) = colSimplify $ ColCat (colTransformEx f a) (colTransformEx f b)
+colTransformEx f (ColRange a b) = colSimplify $ ColRange (transformEx f a) (transformEx f b)
+
+boolTransform :: (Eq a, Eq b, Eq c, Eq d, Eq e, Eq f) => (a->b,c->d,e->f,b->a,d->c,f->e) -> BoolExpr a c e -> BoolExpr b d f
+boolTransform (f,fc,fb,fi,fic,fib) = boolTransformEx (Term . f, ColTerm . fc, BoolTerm . fb, Term . fi, ColTerm . fic, BoolTerm . fib)
+
+boolTransformEx :: (Eq a, Eq b, Eq c, Eq d, Eq e, Eq f) => ((a -> Expr b d f),(c -> ColExpr b d f),(e -> BoolExpr b d f),(b -> Expr a c e),(d -> ColExpr a c e),f -> BoolExpr a c e) -> BoolExpr a c e -> BoolExpr b d f
+boolTransformEx (_,_,f,_,_,_) (BoolTerm v) = f v
+boolTransformEx f (BoolConst c) = BoolConst c
+boolTransformEx f (BoolAnd a b) = boolSimplify $ BoolAnd (boolTransformEx f a) (boolTransformEx f b)
+boolTransformEx f (BoolOr a b) = boolSimplify $ BoolOr (boolTransformEx f a) (boolTransformEx f b)
+boolTransformEx f (BoolEqual a b) = boolSimplify $ BoolEqual (boolTransformEx f a) (boolTransformEx f b)
+boolTransformEx f (BoolNot a) = boolSimplify $ BoolNot (boolTransformEx f a)
+boolTransformEx f (Rel a r b) = boolSimplify $ Rel (transformEx f a) r (transformEx f b)
+boolTransformEx t@(f,fc,fb,fi,fic,fib) (BoolAll m c) = boolSimplify $ BoolAll (\a -> boolTransformEx t (m (transformEx (fi,fic,fib,f,fc,fb) a))) (colTransformEx t c)
+boolTransformEx t@(f,fc,fb,fi,fic,fib) (BoolAny m c) = boolSimplify $ BoolAny (\a -> boolTransformEx t (m (transformEx (fi,fic,fib,f,fc,fb) a))) (colTransformEx t c)
+boolTransformEx f (ColEqual a b) = boolSimplify $ ColEqual (colTransformEx f a) (colTransformEx f b)
+boolTransformEx f (Sorted b c) = boolSimplify $ Sorted b (colTransformEx f c)
+boolTransformEx f (AllDiff b c) = boolSimplify $ AllDiff b (colTransformEx f c)
+boolTransformEx f (BoolCond c t e) = boolSimplify $ BoolCond (boolTransformEx f c) (boolTransformEx f t) (boolTransformEx f e)
+boolTransformEx f (Dom i c) = boolSimplify $ Dom (transformEx f i) (colTransformEx f c)
+
+------------------------------------------------------------------------------------------
+-- | Check whether an expression is possibly referring to terms with a given property | --
+------------------------------------------------------------------------------------------
+
+propertyEx :: (Expr a b c -> Maybe Bool, ColExpr a b c -> Maybe Bool, BoolExpr a b c -> Maybe Bool) -> Expr a b c -> Bool
+propertyEx f@(fi,fc,fb) t = case fi t of
+  Just a -> a
+  Nothing -> case t of
+    Plus a b -> propertyEx f a || propertyEx f b
+    Minus a b -> propertyEx f a || propertyEx f b
+    Mult a b -> propertyEx f a || propertyEx f b
+    Div a b -> propertyEx f a || propertyEx f b
+    Mod a b -> propertyEx f a || propertyEx f b
+    Abs a -> propertyEx f a
+    At a b -> propertyEx f b || colPropertyEx f a
+    ColSize a -> colPropertyEx f a
+    Fold _ _ _ -> True
+    Channel b -> boolPropertyEx f b
+    Cond c t e -> boolPropertyEx f c || propertyEx f t || propertyEx f e
+    _ -> False
+
+colPropertyEx :: (Expr a b c -> Maybe Bool, ColExpr a b c -> Maybe Bool, BoolExpr a b c -> Maybe Bool) -> ColExpr a b c -> Bool
+colPropertyEx f@(fi,fc,fb) t = case fc t of
+  Just a -> a
+  Nothing -> case t of
+    ColList l -> any (propertyEx f) l
+    ColMap _ _ -> True
+    ColSlice p l c -> propertyEx f (p (ExprHole (-1))) || propertyEx f l || colPropertyEx f c
+    ColRange l h -> propertyEx f l || propertyEx f h
+    ColCat a b -> colPropertyEx f a || colPropertyEx f b
+    _ -> False
+
+boolPropertyEx :: (Expr a b c -> Maybe Bool, ColExpr a b c -> Maybe Bool, BoolExpr a b c -> Maybe Bool) -> BoolExpr a b c -> Bool
+boolPropertyEx f@(fi,fc,fb) t = case fb t of
+  Just a -> a
+  Nothing -> case t of
+    BoolAnd a b -> boolPropertyEx f a || boolPropertyEx f b
+    BoolOr a b -> boolPropertyEx f a || boolPropertyEx f b
+    BoolNot a -> boolPropertyEx f a
+    BoolEqual a b -> boolPropertyEx f a || boolPropertyEx f b
+    Rel a _ b -> propertyEx f a || propertyEx f b
+    BoolAll _ _ -> True
+    BoolAny _ _ -> True
+    ColEqual a b -> colPropertyEx f a || colPropertyEx f b
+    AllDiff _ c -> colPropertyEx f c
+    Sorted _ c -> colPropertyEx f c
+    BoolCond c t e -> boolPropertyEx f c || boolPropertyEx f t || boolPropertyEx f e
+    Dom i c -> propertyEx f i || colPropertyEx f c
+    _ -> False
+
+
+property :: (a -> Bool) -> (b -> Bool) -> (c -> Bool) -> Expr a b c -> Bool
+property fit fct fbt = propertyEx (propInt fit, propCol fct, propBool fbt)
+colProperty :: (a -> Bool) -> (b -> Bool) -> (c -> Bool) -> ColExpr a b c -> Bool
+colProperty fit fct fbt = colPropertyEx (propInt fit, propCol fct, propBool fbt)
+boolProperty :: (a -> Bool) -> (b -> Bool) -> (c -> Bool) -> BoolExpr a b c -> Bool
+boolProperty fit fct fbt = boolPropertyEx (propInt fit, propCol fct, propBool fbt)
+
+propInt :: (a -> Bool) -> Expr a b c -> Maybe Bool
+propInt ft t = case t of
+  Term x -> Just $ ft x
+  _ -> Nothing
+
+propCol :: (b -> Bool) -> ColExpr a b c -> Maybe Bool
+propCol ft t = case t of
+  ColTerm x -> Just $ ft x
+  _ -> Nothing
+
+propBool :: (c -> Bool) -> BoolExpr a b c -> Maybe Bool
+propBool ft t = case t of
+  BoolTerm x -> Just $ ft x
+  _ -> Nothing
+
+
+-------------------------------------------------------------------
+-- | Count how many references to terms an expression contains | --
+-------------------------------------------------------------------
+
+varrefs :: Expr a b c -> Int
+varrefs (Term _)     = 1
+varrefs (Const _)    = 0
+varrefs (ExprHole _) = 0
+varrefs (Plus a b)   = varrefs a + varrefs b
+varrefs (Minus a b)  = varrefs a + varrefs b
+varrefs (Mult a b)   = varrefs a + varrefs b
+varrefs (Div a b)    = varrefs a + varrefs b
+varrefs (Mod a b)    = varrefs a + varrefs b
+varrefs (Abs a)      = varrefs a
+varrefs (At c i)     = varrefs i + colVarrefs c
+varrefs (ColSize c)  = colVarrefs c
+varrefs (Fold f i c) = varrefs i + colVarrefs c + varrefs (f (ExprHole 0) (ExprHole 1))
+varrefs (Channel b)  = boolVarrefs b
+varrefs (Cond c t e) = boolVarrefs c + varrefs t + varrefs e
+
+colVarrefs :: ColExpr a b c -> Int
+colVarrefs (ColTerm _) = 1
+colVarrefs (ColList lst) = sum $ map varrefs lst
+colVarrefs (ColMap m c) = colVarrefs c + varrefs (m (ExprHole 0))
+colVarrefs (ColSlice p l c) = varrefs (p (ExprHole 0)) + varrefs l + colVarrefs c
+colVarrefs (ColCat a b) = colVarrefs a + colVarrefs b
+colVarrefs (ColRange a b) = varrefs a + varrefs b
+
+boolVarrefs :: BoolExpr a b c -> Int
+boolVarrefs (BoolTerm _) = 1
+boolVarrefs (BoolConst _) = 0
+boolVarrefs (BoolAnd a b) = boolVarrefs a + boolVarrefs b
+boolVarrefs (BoolOr a b) = boolVarrefs a + boolVarrefs b
+boolVarrefs (BoolEqual a b) = boolVarrefs a + boolVarrefs b
+boolVarrefs (BoolNot a) = boolVarrefs a
+boolVarrefs (BoolAll f c) = boolVarrefs (f $ ExprHole 0) + colVarrefs c
+boolVarrefs (BoolAny f c) = boolVarrefs (f $ ExprHole 0) + colVarrefs c
+boolVarrefs (Rel a _ b) = varrefs a + varrefs b
+boolVarrefs (ColEqual a b) = colVarrefs a + colVarrefs b
+boolVarrefs (Sorted _ c) = colVarrefs c
+boolVarrefs (AllDiff _ c) = colVarrefs c
+boolVarrefs (BoolCond c t e) = boolVarrefs c + boolVarrefs t + boolVarrefs e
+boolVarrefs (Dom i c)    = varrefs i + colVarrefs c
+
+------------------------------
+-- | Simplify expressions | --
+------------------------------
+
+simplify :: (Eq s, Eq c, Eq b) => Expr s c b -> Expr s c b
+-- dropout rules (things that won't ever be changed)
+simplify a@(Const _) = a
+simplify a@(Term _) = a
+simplify a@(ExprHole _) = a
+-- simplification rules (either decrease # of variable references, or leave that equal and decrease # of tree nodes)
+--- level 0 (result in a final expression)
+simplify (Mult a@(Const 0) _) = a
+simplify (Div a@(Const 0) _) = a
+simplify (Mod a@(Const 0) _) = a
+simplify (Mod _ (Const 1)) = Const 0
+simplify (Mod _ (Const (-1))) = Const 0
+simplify (Mod (Mult (Const a) b) (Const c)) | (a `mod` c)==0 = Const 0
+simplify (Minus a b) | a==b = Const 0
+simplify (Plus (Const a) (Const b)) = Const (a+b)
+simplify (Minus (Const a) (Const b)) = Const (a-b)
+simplify (Mult (Const a) (Const b)) = Const (a*b)
+simplify (Div (Const a) (Const b)) = Const $ (a `div` b)
+simplify (Abs (Const a)) = Const (abs a)
+simplify (Mod (Const a) (Const b)) = Const $ (a `mod` b)
+simplify (Plus (Const 0) a) = a
+simplify (Mult (Const 1) a) = a
+simplify (Div a (Const 1)) = a
+simplify (At (ColList l) (Const c)) = l!!(fromInteger c)
+simplify (ColSize (ColList l)) = Const $ toInteger $ length l
+simplify (ColSize (ColSlice _ l _)) = l
+simplify (Channel (BoolConst False)) = Const 0
+simplify (Channel (BoolConst True)) = Const 1
+simplify (Cond (BoolConst True) t _) = t
+simplify (Cond (BoolConst False) _ f) = f
+--- level 1 (result in one recursive call to simplify)
+simplify (Plus a b) | a==b = simplify $ Mult (Const 2) a
+simplify (Div a (Const (-1))) = simplify $ Minus (Const 0) a
+simplify (Plus (Const c) (Plus (Const a) b)) = simplify $ Plus (Const $ c+a) b
+simplify (Plus (Const c) (Minus (Const a) b)) = simplify $ Minus (Const $ c+a) b
+simplify (Minus (Const c) (Plus (Const a) b)) = simplify $ Minus (Const $ c-a) b
+simplify (Minus (Const c) (Minus (Const a) b)) = simplify $ Plus (Const $ c-a) b
+simplify (Mult (Const c) (Mult (Const a) b)) = simplify $ Mult (Const $ a*c) b
+simplify (Div (Mult (Const a) b) (Const c)) | (a `mod` c)==0 = simplify $ Mult (Const (a `div` c)) b
+simplify (ColSize (ColMap _ c)) = simplify $ ColSize c
+simplify (Fold f1 i (ColMap f2 c)) = simplify $ Fold (\a b -> f1 a (f2 b)) i c
+simplify (At (ColRange l h) p) = simplify $ Plus l p
+simplify (Cond (BoolNot c) t f) = simplify $ Cond c f t
+--- level 2 (result in two recursive calls to simplify)
+simplify (Plus a (Mult b c)) | a==b && ((varrefs a)>0) = simplify $ Mult (simplify $ Plus c (Const 1)) a
+simplify (Plus a (Mult b c)) | a==c && ((varrefs a)>0) = simplify $ Mult (simplify $ Plus b (Const 1)) a
+simplify (Plus (Mult b c) a) | a==b && ((varrefs a)>0) = simplify $ Mult (simplify $ Plus c (Const 1)) a
+simplify (Plus (Mult b c) a) | a==c && ((varrefs a)>0) = simplify $ Mult (simplify $ Plus b (Const 1)) a
+simplify (Plus (Mult a b) (Mult c d)) | a==c = simplify $ Mult (simplify $ Plus b d) a
+simplify (Plus (Mult a b) (Mult c d)) | a==d = simplify $ Mult (simplify $ Plus b c) a
+simplify (Plus (Mult a b) (Mult c d)) | b==c = simplify $ Mult (simplify $ Plus a d) b
+simplify (Plus (Mult a b) (Mult c d)) | b==d = simplify $ Mult (simplify $ Plus a c) b
+simplify (Minus a (Mult b c)) | a==b && ((varrefs a)>0) = simplify $ Mult (simplify $ Minus (Const 1) c) a
+simplify (Minus a (Mult b c)) | a==c && ((varrefs a)>0) = simplify $ Mult (simplify $ Minus (Const 1) b) a
+simplify (Minus (Mult b c) a) | a==b && ((varrefs a)>0) = simplify $ Mult (simplify $ Minus c (Const 1)) a
+simplify (Minus (Mult b c) a) | a==c && ((varrefs a)>0) = simplify $ Mult (simplify $ Minus b (Const 1)) a
+simplify (Minus (Mult a b) (Mult c d)) | a==c = simplify $ Mult (simplify $ Minus b d) a
+simplify (Minus (Mult a b) (Mult c d)) | a==d = simplify $ Mult (simplify $ Minus b c) a
+simplify (Minus (Mult a b) (Mult c d)) | b==c = simplify $ Mult (simplify $ Minus a d) b
+simplify (Minus (Mult a b) (Mult c d)) | b==d = simplify $ Mult (simplify $ Minus a c) b
+simplify (Mult (Abs a) (Abs b)) = simplify $ Abs (simplify $ Mult a b)
+simplify (Div (Abs a) (Abs b)) = simplify $ Abs (simplify $ Div a b)
+simplify (ColSize (ColRange l h)) = simplify $ Plus (Const 1) $ simplify $ Minus h l
+simplify (At (ColSlice f _ c) i) = simplify $ At c (f i)
+simplify (At (ColMap m c) i) = simplify $ m $ simplify $ At c i
+simplify t@(At (ColCat c1 c2) c@(Const p)) = case simplify (ColSize c1) of
+  Const l | p<l -> simplify $ At c1 c
+  Const l | p>=l -> simplify $ At c2 (Const $ p-l)
+  _ -> t    {- no further (At _ _) rules may follow after this -}
+--- level 3 (results in three recursive calls to simplify)
+simplify (ColSize (ColCat a b)) = simplify $ Plus (simplify $ ColSize a) (simplify $ ColSize b)
+-- reordering rules (do not decrease # of variables or # of tree nodes, but normalize an expression in such a way that the same normalization cannot be applied anymore - possibly because that can only occur in a case already matched by a simplification rule above)
+--- level 1
+simplify (Plus a (Const c)) = simplify $ Plus (Const c) a
+simplify (Minus a (Const c)) = simplify $ Plus (Const (-c)) a
+simplify (Mult a (Const c)) = simplify $ Mult (Const c) a
+simplify (Mult (Const (-1)) a) = simplify $ Minus (Const 0) a
+--- level 2
+simplify (Mult t@(Const c) (Plus (Const a) b)) = simplify $ Plus (Const (a*c)) (simplify $ Mult t b)
+simplify (Mult t@(Const c) (Minus (Const a) b)) = simplify $ Minus (Const (a*c)) (simplify $ Mult t b)
+simplify (Plus a (Plus t@(Const b) c)) = simplify $ Plus t (simplify $ Plus a c)
+simplify (Plus a (Minus t@(Const b) c)) = simplify $ Plus t (simplify $ Minus a c)
+simplify (Minus a (Plus (Const b) c)) = simplify $ Plus (Const (-b)) (simplify $ Minus a c)
+simplify (Minus a (Minus (Const b) c)) = simplify $ Plus (Const (-b)) (simplify $ Plus a c)
+simplify (Mult a (Mult t@(Const b) c)) = simplify $ Mult t (simplify $ Mult a c)
+simplify (Plus (Plus t@(Const a) b) c) = simplify $ Plus t (simplify $ Plus b c)
+simplify (Plus (Minus t@(Const a) b) c) = simplify $ Plus t (simplify $ Minus c b)
+simplify (Minus (Plus t@(Const a) b) c) = simplify $ Plus t (simplify $ Minus b c)
+simplify (Minus (Minus t@(Const a) b) c) = simplify $ Minus t (simplify $ Plus b c)
+simplify (Mult (Mult t@(Const a) b) c) = simplify $ Mult t (simplify $ Mult b c)
+simplify (Mult a (Minus t@(Const 0) b)) = simplify $ Minus t (simplify $ Mult a b)
+simplify (Mult (Minus t@(Const 0) b) a) = simplify $ Minus t (simplify $ Mult a b)
+simplify (Div (Minus t@(Const 0) a) b) = simplify $ Minus t (simplify $ Div a b)
+simplify (Div a (Minus t@(Const 0) b)) = simplify $ Minus t (simplify $ Div a b)
+-- fallback rule
+simplify a = a
+
+colSimplify :: (Eq s, Eq c, Eq b) => ColExpr s c b -> ColExpr s c b
+-- dropout rules
+colSimplify t@(ColTerm _) = t
+-- simplify rules
+--- level 1
+colSimplify (ColMap f1 (ColMap f2 c)) = colSimplify $ ColMap (f1.f2) c
+colSimplify (ColMap f (ColList l)) = colSimplify $ ColList (map f l)
+--- level 2
+colSimplify (ColSlice p1 l1 (ColSlice p2 l2 c)) = colSimplify $ ColSlice (p1 . p2) l1 c
+-- reordering rules
+--- level 2
+colSimplify (ColCat (ColCat c1 c2) c3) = colSimplify $ ColCat c1 (colSimplify $ ColCat c2 c3)
+colSimplify (ColSlice p l (ColMap f c)) = colSimplify $ ColMap f $ colSimplify $ ColSlice p l c
+-- fallback rule
+colSimplify x = x
+
+boolSimplify :: (Eq s, Eq c, Eq b) => BoolExpr s c b -> BoolExpr s c b
+-- dropout rules
+boolSimplify t@(BoolTerm _) = t
+boolSimplify t@(BoolConst _) = t
+-- simplify rules
+--- level 0
+boolSimplify (BoolAnd (BoolConst False) _) = BoolConst False
+boolSimplify (BoolAnd (BoolConst True) a) = a
+boolSimplify (BoolAnd _ (BoolConst False)) = BoolConst False
+boolSimplify (BoolAnd a (BoolConst True)) = a
+boolSimplify (BoolOr (BoolConst True) _) = BoolConst True
+boolSimplify (BoolOr (BoolConst False) a) = a
+boolSimplify (BoolOr _ (BoolConst True)) = BoolConst True
+boolSimplify (BoolOr a (BoolConst False)) = a
+boolSimplify (BoolNot (BoolConst a)) = BoolConst (not a)
+boolSimplify (BoolEqual (BoolConst True) a) = a
+boolSimplify (BoolEqual a (BoolConst True)) = a
+boolSimplify (BoolNot (BoolNot a)) = a
+boolSimplify (BoolOr a b) | a==b = a
+boolSimplify (BoolAnd a b) | a==b = a
+boolSimplify (BoolEqual a b) | a==b = BoolConst False
+boolSimplify (Rel (Const a) r (Const b)) = BoolConst $ relCheck a r b
+boolSimplify (BoolAll f (ColList [])) = BoolConst True
+boolSimplify (BoolAny f (ColList [])) = BoolConst False
+boolSimplify (BoolAll f (ColList [a])) = f a
+boolSimplify (BoolAny f (ColList [a])) = f a
+boolSimplify (ColEqual (ColList []) (ColList [])) = BoolConst True
+boolSimplify (ColEqual (ColList []) (ColList _)) = BoolConst False
+boolSimplify (ColEqual (ColList _) (ColList [])) = BoolConst False
+boolSimplify (BoolCond (BoolConst True) t _) = t
+boolSimplify (BoolCond (BoolConst False) _ f) = f
+--- level 1
+boolSimplify (BoolEqual (BoolNot a) (BoolNot b)) = boolSimplify $ BoolEqual a b
+boolSimplify (BoolEqual (BoolConst False) a) = boolSimplify $ BoolNot a
+boolSimplify (BoolEqual a (BoolConst False)) = boolSimplify $ BoolNot a
+boolSimplify (BoolNot (Rel a EREqual b)) = boolSimplify $ Rel a ERDiff b
+boolSimplify (BoolNot (Rel a ERDiff b)) = boolSimplify $ Rel a EREqual b
+boolSimplify (BoolAll f (ColList [a,b])) = boolSimplify $ f a `BoolAnd` f b
+boolSimplify (BoolAny f (ColList [a,b])) = boolSimplify $ f a `BoolOr` f b
+boolSimplify (ColEqual (ColList [a]) (ColList [b])) = boolSimplify $ Rel a EREqual b
+boolSimplify (Rel (Channel a) EREqual (Channel b)) = boolSimplify $ BoolEqual a b
+boolSimplify (BoolCond (BoolNot c) t f) = boolSimplify $ BoolCond c f t
+--- level 2
+boolSimplify (BoolAnd (BoolNot a) (BoolNot b)) = boolSimplify $ BoolNot $ boolSimplify $ BoolOr a b
+boolSimplify (BoolOr (BoolNot a) (BoolNot b)) = boolSimplify $ BoolNot $ boolSimplify $ BoolAnd a b
+boolSimplify (Rel (Channel a) ERDiff (Channel b)) = boolSimplify $ BoolNot $ boolSimplify $ BoolEqual a b
+boolSimplify (Rel (Channel a) ERLess (Channel b)) = boolSimplify $ BoolAnd b $ boolSimplify $ BoolNot a     -- int(b1) < int(b2)   <=>  !b1 && b2
+-- fallback
+boolSimplify a = a
+
+-------------------------------------------------------------------
+-- | Turn expressions over expressions into simply expressions | --
+-------------------------------------------------------------------
+
+collapse :: (Eq t, Eq c, Eq b) => Expr (Expr t c b) (ColExpr t c b) (BoolExpr t c b) -> Expr t c b
+collapse (Term t) = t
+collapse (Const i) = Const i
+collapse (Plus a b) = simplify $ Plus (collapse a) (collapse b)
+collapse (Minus a b) = simplify $ Minus (collapse a) (collapse b)
+collapse (Mult a b) = simplify $ Mult (collapse a) (collapse b)
+collapse (Div a b) = simplify $ Div (collapse a) (collapse b)
+collapse (Mod a b) = simplify $ Mod (collapse a) (collapse b)
+collapse (Abs a) = simplify $ Abs (collapse a)
+collapse (At c a) = simplify $ At (colCollapse c) (collapse a)
+collapse (ColSize c) = simplify $ ColSize (colCollapse c)
+collapse (Fold f i c) = simplify $ Fold (\a b -> collapse $ f (Term a) (Term b)) (collapse i) (colCollapse c)
+collapse (Channel b) = simplify $ Channel (boolCollapse b)
+collapse (Cond c t e) = simplify $ Cond (boolCollapse c) (collapse t) (collapse e)
+
+colCollapse :: (Eq t, Eq c, Eq b) => ColExpr (Expr t c b) (ColExpr t c b) (BoolExpr t c b) -> ColExpr t c b
+colCollapse (ColTerm t) = t
+colCollapse (ColList l) = colSimplify $ ColList $ map collapse l
+colCollapse (ColMap f c) = colSimplify $ ColMap (\a -> collapse $ f (Term a)) (colCollapse c)
+colCollapse (ColSlice p l c) = colSimplify $ ColSlice (\x -> collapse $ p (Term x)) (collapse l) (colCollapse c)
+colCollapse (ColCat a b) = colSimplify $ ColCat (colCollapse a) (colCollapse b)
+colCollapse (ColRange a b) = colSimplify $ ColRange (collapse a) (collapse b)
+
+boolCollapse :: (Eq t, Eq c, Eq b) => BoolExpr (Expr t c b) (ColExpr t c b) (BoolExpr t c b) -> BoolExpr t c b
+boolCollapse (BoolTerm t) = t
+boolCollapse (BoolConst c) = BoolConst c
+boolCollapse (BoolAnd a b) = boolSimplify $ BoolAnd (boolCollapse a) (boolCollapse b)
+boolCollapse (BoolOr a b) = boolSimplify $ BoolOr (boolCollapse a) (boolCollapse b)
+boolCollapse (BoolEqual a b) = boolSimplify $ BoolEqual (boolCollapse a) (boolCollapse b)
+boolCollapse (BoolNot a) = boolSimplify $ BoolNot (boolCollapse a)
+boolCollapse (Rel a r b) = boolSimplify $ Rel (collapse a) r (collapse b)
+boolCollapse (BoolAll f c) = boolSimplify $ BoolAll (\a -> boolCollapse $ f (Term a)) (colCollapse c)
+boolCollapse (BoolAny f c) = boolSimplify $ BoolAny (\a -> boolCollapse $ f (Term a)) (colCollapse c)
+boolCollapse (ColEqual a b) = boolSimplify $ ColEqual (colCollapse a) (colCollapse b)
+boolCollapse (Sorted b c) = boolSimplify $ Sorted b (colCollapse c)
+boolCollapse (AllDiff b c) = boolSimplify $ AllDiff b (colCollapse c)
+boolCollapse (BoolCond c t e) = boolSimplify $ BoolCond (boolCollapse c) (boolCollapse t) (boolCollapse e)
+boolCollapse (Dom i c) = boolSimplify $ Dom (collapse i) (colCollapse c)
+
+-----------------------------------------
+-- | walk through expressions
+-----------------------------------------
+
+data WalkPhase = WalkPre | WalkSingle | WalkPost
+  deriving (Ord,Eq,Enum,Show)
+
+data WalkResult = WalkSkip | WalkDescend
+  deriving (Ord,Eq,Enum,Show)
+
+xwalker :: (Eq t, Eq c, Eq b, Monad m) => (WalkPhase -> m WalkResult) -> (Expr t c b -> WalkPhase -> m WalkResult, ColExpr t c b -> WalkPhase -> m WalkResult, BoolExpr t c b -> WalkPhase -> m WalkResult) -> ([Expr t c b],[ColExpr t c b],[BoolExpr t c b]) -> m ()
+xwalker q f ([],[],[]) = do
+  q WalkSingle
+  return ()
+xwalker q f (li,lc,lb) = do
+  r <- q WalkPre
+  case r of
+    WalkSkip -> return ()
+    WalkDescend -> do
+      mapM_ (\p -> walk p f) li
+      mapM_ (\p -> colWalk p f) lc
+      mapM_ (\p -> boolWalk p f) lb
+      q WalkPost
+      return ()
+
+walker :: (Eq t, Eq c, Eq b, Monad m) => Expr t c b -> (Expr t c b -> WalkPhase -> m WalkResult, ColExpr t c b -> WalkPhase -> m WalkResult, BoolExpr t c b -> WalkPhase -> m WalkResult) -> ([Expr t c b],[ColExpr t c b],[BoolExpr t c b]) -> m ()
+walker x f@(i,c,b) l = xwalker (i x) f l
+colWalker :: (Eq t, Eq c, Eq b, Monad m) => ColExpr t c b -> (Expr t c b -> WalkPhase -> m WalkResult, ColExpr t c b -> WalkPhase -> m WalkResult, BoolExpr t c b -> WalkPhase -> m WalkResult) -> ([Expr t c b],[ColExpr t c b],[BoolExpr t c b]) -> m ()
+colWalker x f@(i,c,b) l = xwalker (c x) f l
+boolWalker :: (Eq t, Eq c, Eq b, Monad m) => BoolExpr t c b -> (Expr t c b -> WalkPhase -> m WalkResult, ColExpr t c b -> WalkPhase -> m WalkResult, BoolExpr t c b -> WalkPhase -> m WalkResult) -> ([Expr t c b],[ColExpr t c b],[BoolExpr t c b]) -> m ()
+boolWalker x f@(i,c,b) l = xwalker (b x) f l
+
+walk :: (Eq t, Eq c, Eq b, Monad m) => Expr t c b -> (Expr t c b -> WalkPhase -> m WalkResult, ColExpr t c b -> WalkPhase -> m WalkResult, BoolExpr t c b -> WalkPhase -> m WalkResult) -> m ()
+walk x@(Term _) f = walker x f ([],[],[])
+walk x@(Const _) f = walker x f ([],[],[])
+walk x@(Plus a b) f = walker x f ([a,b],[],[])
+walk x@(Minus a b) f = walker x f ([a,b],[],[])
+walk x@(Mult a b) f = walker x f ([a,b],[],[])
+walk x@(Div a b) f = walker x f ([a,b],[],[])
+walk x@(Mod a b) f = walker x f ([a,b],[],[])
+walk x@(Abs a) f = walker x f ([a],[],[])
+walk x@(At c a) f = walker x f ([a],[c],[])
+walk x@(ColSize c) f = walker x f ([],[c],[])
+walk x@(Fold _ i c) f = walker x f ([i],[c],[])
+walk x@(Channel b) f = walker x f ([],[],[b])
+walk x@(Cond c t e) f = walker x f ([t,e],[],[c])
+walk x@(ExprHole _) f = return ()
+
+colWalk x@(ColTerm _) f = colWalker x f ([],[],[])
+colWalk x@(ColList l) f = colWalker x f (l,[],[])
+colWalk x@(ColMap _ c) f = colWalker x f ([],[c],[])
+colWalk x@(ColSlice _ l c) f = colWalker x f ([l],[c],[])
+colWalk x@(ColCat a b) f = colWalker x f ([],[a,b],[])
+colWalk x@(ColRange a b) f = colWalker x f ([a,b],[],[])
+
+boolWalk x@(BoolTerm _) f = boolWalker x f ([],[],[])
+boolWalk x@(BoolConst _) f = boolWalker x f ([],[],[])
+boolWalk x@(BoolAnd a b) f = boolWalker x f ([],[],[a,b])
+boolWalk x@(BoolOr a b) f = boolWalker x f ([],[],[a,b])
+boolWalk x@(BoolEqual a b) f = boolWalker x f ([],[],[a,b])
+boolWalk x@(BoolNot a) f = boolWalker x f ([],[],[a])
+boolWalk x@(Rel a _ b) f = boolWalker x f ([a,b],[],[])
+boolWalk x@(BoolAll _ c) f = boolWalker x f ([],[c],[])
+boolWalk x@(BoolAny _ c) f = boolWalker x f ([],[c],[])
+boolWalk x@(ColEqual a b) f = boolWalker x f ([],[a,b],[])
+boolWalk x@(Sorted _ c) f = boolWalker x f ([],[c],[])
+boolWalk x@(AllDiff _ c) f = boolWalker x f ([],[c],[])
+boolWalk x@(BoolCond c t e) f = boolWalker x f ([],[],[c,t,e])
+boolWalk x@(Dom i c) f = boolWalker x f ([i],[c],[])
+

+ src/Data/Linear.hs view

@@ -0,0 +1,82 @@+{-# LANGUAGE MultiParamTypeClasses #-}
+{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE StandaloneDeriving #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+
+module Data.Linear (
+  Linear,
+  integerToLinear,
+  constToLinear,
+  termToLinear,
+--  linearOpLinear,
+--  linearOpLinears,
+  linearToConst,
+  linearToTerm,
+  linearMultiply,
+  linearMult,
+  linearToList, linearToListEx,
+  getCoef,
+) where
+
+import qualified Data.Map as Map
+import Data.Map(Map)
+
+data (Ord t, Num v) => Linear t v = Linear v (Map t v)
+
+deriving instance (Num v, Eq v, Ord t, Eq t) => Eq (Linear t v)
+deriving instance (Num v, Ord v, Ord t, Eq t) => Ord (Linear t v)
+deriving instance (Num v, Show v, Ord t, Show t) => Show (Linear t v)
+
+termToLinear :: (Num v, Ord t) => t -> Linear t v
+termToLinear x = Linear 0 $ Map.singleton x 1
+
+integerToLinear :: (Num v, Ord t) => Integer -> Linear t v
+integerToLinear = constToLinear . fromInteger
+
+constToLinear :: (Num v, Ord t) => v -> Linear t v
+constToLinear x = Linear x Map.empty
+
+-- linearOpLinear :: (Num v, Ord t) => v -> Linear t v -> v -> Linear t v -> Linear t v
+-- linearOpLinear a (Linear ac am) b (Linear bc bm) = Linear (a*ac+b*bc) $ Map.filter (/=0) $ Map.unionWith (\ax bx -> ax*a+bx*b) am bm
+
+-- linearOpLinears :: (Num v, Ord t) => [(v,Linear t v)] -> Linear t v
+-- linearOpLinears l = foldr (\(c,t) a -> linearOpLinear 1 a c t) (integerToLinear 0) l
+
+linearToList :: (Ord t, Num v) => Linear t v -> [(Maybe t,v)]
+linearToList (Linear c m) = [(Nothing,c)] ++ (map (\(a,b) -> (Just a,b)) $ Map.toList m)
+
+linearToListEx :: (Ord t, Num v) => Linear t v -> (v,[(t,v)])
+linearToListEx (Linear c m) = (c,Map.toList m)
+
+getCoef :: (Num v, Ord t) => Maybe t -> Linear t v -> v
+getCoef Nothing (Linear c _) = c
+getCoef (Just t) (Linear _ m) = Map.findWithDefault 0 t m
+
+linearMult :: (Num v, Eq v, Ord t) => v -> Linear t v -> Linear t v
+linearMult m (Linear ac am) = Linear (m*ac) $ if (m==0) then Map.empty else Map.filter (/=0) $ Map.map (m*) am
+
+linearMultiply :: (Num v, Eq v, Ord t) => Linear t v -> Linear t v -> Maybe (Linear t v)
+linearMultiply (Linear ac am) bl | (Map.null am) = Just $ linearMult ac bl
+linearMultiply bl (Linear ac am) | (Map.null am) = Just $ linearMult ac bl
+linearMultiply _ _ = Nothing
+
+linearToConst :: (Num v, Ord t) => Linear t v -> Maybe v
+linearToConst (Linear c m) | Map.null m = Just c
+linearToConst _ = Nothing
+
+linearToTerm :: (Num v, Eq v, Ord t) => Linear t v -> Maybe t
+linearToTerm (Linear c m) | (c==0 && (Map.size m)==1) = 
+  let (t,v) = Map.findMin m
+      in if (v==1) then Just t else Nothing
+linearToTerm _ = Nothing
+
+instance (Num v, Eq v, Ord t, Eq t, Show t) => Num (Linear t v) where
+  (Linear ac am) + (Linear bc bm) = Linear (ac+bc) $ Map.filter (/=0) $ Map.unionWith (+) am bm
+  (Linear ac am) - (Linear bc bm) = Linear (ac-bc) $ Map.filter (/=0) $ Map.unionWith (+) am $ Map.map negate bm
+  a * b = case linearMultiply a b of Just x -> x; Nothing -> error "Cannot multiply generic linear expressions"
+  negate (Linear ac am) = Linear (-ac) $ Map.map negate am
+  abs (Linear ac am) | (Map.null am) = Linear (abs ac) Map.empty
+  abs _ = error "Cannot take abs of generic linear expressions"
+  signum (Linear ac am) | (Map.null am) = Linear (signum ac) Map.empty
+  signum _ = error "Cannot take signum of generic linear expressions"
+  fromInteger x = integerToLinear x

+ src/Language/CPP/Pretty.hs view

@@ -0,0 +1,242 @@+{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE TypeSynonymInstances #-}
+
+module Language.CPP.Pretty (
+  codegen
+) where 
+
+import Text.PrettyPrint.HughesPJ
+import Prelude hiding ((<>))
+import Language.CPP.Syntax.AST
+
+class Pretty t where
+  pretty :: t -> Doc
+  prettyPrec :: Int -> t -> Doc
+  pretty = prettyPrec 0
+  prettyPrec _ = pretty
+
+class ToString t where
+  toString :: t -> String
+
+instance ToString CPPAssignOp where
+  toString x = case x of
+    CPPAssOp    -> "="
+    CPPAssOpMul -> "*="
+    CPPAssOpDiv -> "/="
+    CPPAssOpRmd -> "%="
+    CPPAssOpAdd -> "+="
+    CPPAssOpSub -> "-="
+    CPPAssOpShl -> "<<="
+    CPPAssOpShr -> ">>="
+    CPPAssOpAnd -> "&="
+    CPPAssOpOr  ->  "|="
+    CPPAssOpXor -> "^="
+
+{-
+  Priorities in C (http://www.difranco.net/cop2220/op-prec.htm)
+ 
+  2:  comma
+  4:  assignments
+  6:  conditional
+  8:  logical or
+  10:  logical and
+  12:  bitwise or
+  14:  bitwise xor
+  16:  bitwise and
+  18:  equality/inequality test
+  20: relational tests
+  22: bitshift
+  24: addition/subtraction
+  26: multiplication/division/modulus
+  28: preincrement/predecrement/negation/complement/cast/dereference/address/sizeof
+  30: brackets/index/member/postincrement/postdecrement/
+-}
+
+
+instance Pretty CPPConst where
+  pretty (CPPConstInt x) = text $ show x
+  pretty (CPPConstChar x) = text $ "'" ++ x ++ "'"   -- TODO: character escaping
+  pretty (CPPConstString x) = text $ "\"" ++ x ++ "\""
+  pretty (CPPConstFloat x) = text x
+
+prio :: Int -> Int -> Doc -> Doc
+prio myL outerL doc = if myL<outerL then parens doc else doc
+
+instance Pretty CPPExpr where
+  prettyPrec l (CPPConst x) = prettyPrec l x
+  prettyPrec l (CPPAssign o1 op o2) = prio 4 l $ (prettyPrec 5 o1) <+> (text $ toString op) <+> (prettyPrec 4 o2)
+  prettyPrec l (CPPVar v) = text v
+  prettyPrec l (CPPComma lst) = lparen <> (foldl (<>) empty $ punctuate comma $ map (prettyPrec 2) lst) <> rparen
+  prettyPrec l (CPPBinary o1 CPPOpMul  o2) = prio 26 l $ (prettyPrec 26 o1) <> text "*"  <> (prettyPrec 27 o2)
+  prettyPrec l (CPPBinary o1 CPPOpDiv  o2) = prio 26 l $ (prettyPrec 26 o1) <> text "/"  <> (prettyPrec 27 o2)
+  prettyPrec l (CPPBinary o1 CPPOpRmd  o2) = prio 26 l $ (prettyPrec 26 o1) <> text "%"  <> (prettyPrec 27 o2)
+  prettyPrec l (CPPBinary o1 CPPOpAdd  o2) = prio 24 l $ (prettyPrec 24 o1) <> text "+"  <> (prettyPrec 24 o2)
+  prettyPrec l (CPPBinary o1 CPPOpSub  o2) = prio 24 l $ (prettyPrec 24 o1) <> text "-"  <> (prettyPrec 25 o2)
+  prettyPrec l (CPPBinary o1 CPPOpShl  o2) = prio 22 l $ (prettyPrec 22 o1) <> text "<<" <> (prettyPrec 23 o2)
+  prettyPrec l (CPPBinary o1 CPPOpShr  o2) = prio 22 l $ (prettyPrec 22 o1) <> text ">>" <> (prettyPrec 23 o2)
+  prettyPrec l (CPPBinary o1 CPPOpLe   o2) = prio 20 l $ (prettyPrec 20 o1) <> text "<"  <> (prettyPrec 21 o2)
+  prettyPrec l (CPPBinary o1 CPPOpGr   o2) = prio 20 l $ (prettyPrec 20 o1) <> text ">"  <> (prettyPrec 21 o2)
+  prettyPrec l (CPPBinary o1 CPPOpGeq  o2) = prio 20 l $ (prettyPrec 20 o1) <> text ">=" <> (prettyPrec 21 o2)
+  prettyPrec l (CPPBinary o1 CPPOpLeq  o2) = prio 20 l $ (prettyPrec 20 o1) <> text "<=" <> (prettyPrec 21 o2)
+  prettyPrec l (CPPBinary o1 CPPOpEq   o2) = prio 18 l $ (prettyPrec 18 o1) <> text "==" <> (prettyPrec 19 o2)
+  prettyPrec l (CPPBinary o1 CPPOpNeq  o2) = prio 18 l $ (prettyPrec 18 o1) <> text "!=" <> (prettyPrec 19 o2)
+  prettyPrec l (CPPBinary o1 CPPOpAnd  o2) = prio 16 l $ (prettyPrec 16 o1) <> text "&"  <> (prettyPrec 16 o2)
+  prettyPrec l (CPPBinary o1 CPPOpXor  o2) = prio 14 l $ (prettyPrec 14 o1) <> text "^"  <> (prettyPrec 14 o2)
+  prettyPrec l (CPPBinary o1 CPPOpOr   o2) = prio 12 l $ (prettyPrec 12 o1) <> text "|"  <> (prettyPrec 12 o2)
+  prettyPrec l (CPPBinary o1 CPPOpLAnd o2) = prio 10 l $ (prettyPrec 10 o1) <> text "&&" <> (prettyPrec 10 o2)
+  prettyPrec l (CPPBinary o1 CPPOpLOr  o2) = prio  8 l $ (prettyPrec  8 o1) <> text "||" <> (prettyPrec 8  o2)
+  prettyPrec l (CPPUnary  CPPOpPreInc o)   = prio 28 l $                       text "++" <> (prettyPrec 28 o )
+  prettyPrec l (CPPUnary  CPPOpPreDec o)   = prio 28 l $                       text "--" <> (prettyPrec 28 o )
+  prettyPrec l (CPPUnary  CPPOpPostInc o)  = prio 28 l $ (prettyPrec 28 o ) <> text "++"
+  prettyPrec l (CPPUnary  CPPOpPostDec o)  = prio 28 l $ (prettyPrec 28 o ) <> text "--"
+  prettyPrec l (CPPUnary  CPPOpAdr o)      = prio 28 l $                       text "&"  <> (prettyPrec 28 o )
+  prettyPrec l (CPPUnary  CPPOpInd o)      = prio 28 l $                       text "*"  <> (prettyPrec 28 o )
+  prettyPrec l (CPPUnary  CPPOpPlus o)     = prio 28 l $                       text "+"  <> (prettyPrec 28 o )
+  prettyPrec l (CPPUnary  CPPOpMinus o)    = prio 28 l $                       text "-"  <> (prettyPrec 28 o )
+  prettyPrec l (CPPUnary  CPPOpComp o)     = prio 28 l $                       text "~"  <> (prettyPrec 28 o )
+  prettyPrec l (CPPUnary  CPPOpNeg o)      = prio 28 l $                       text "!"  <> (prettyPrec 28 o )
+  prettyPrec l (CPPCond c (Just t) f)      = prio  6 l $ (prettyPrec 7  c ) <+> text "?"  <+> (prettyPrec 7  t ) <+> text ":" <+> (prettyPrec 6 f)
+  prettyPrec l (CPPCond c Nothing t)       = prio  6 l $ (prettyPrec 7  c ) <> text "?:" <> (prettyPrec 6  t )
+  prettyPrec l (CPPCast t e)               = prio 28 l $ lparen <> (pretty t) <> rparen <>  (prettyPrec 28 e )
+  prettyPrec l (CPPSizeOfExpr e)           = prio 28 l $ text "sizeof" <> lparen <> (pretty e) <> rparen
+  prettyPrec l (CPPSizeOfType t)           = prio 28 l $ text "sizeof" <> lparen <> (pretty t) <> rparen
+  prettyPrec l (CPPIndex a b)              = prio 28 l $ (prettyPrec 28 a) <> lbrack <> (pretty b) <> rbrack
+  prettyPrec l (CPPCall a b)               = prio 28 l $ (prettyPrec 28 a) <> lparen <> (hcat $ punctuate comma $ map pretty b) <> rparen
+  prettyPrec l (CPPMember a m False)       = prio 28 l $ (prettyPrec 28 a) <> text "." <> text m
+  prettyPrec l (CPPMember a m True)        = prio 28 l $ (prettyPrec 28 a) <> text "->" <> text m
+  prettyPrec l (CPPNew a b)                = prio 28 l $ text "new" <+> (pretty a) <> lparen <> (hcat $ punctuate comma $ map pretty b) <> rparen
+
+instance Pretty s => Pretty (Maybe s) where
+  prettyPrec _ Nothing = empty
+  prettyPrec l (Just x) = prettyPrec l x
+
+instance (Pretty a, Pretty b) => Pretty (Either a b) where
+  prettyPrec l (Left x) = prettyPrec l x
+  prettyPrec l (Right x) = prettyPrec l x
+
+instance Pretty CPPStat where
+  pretty (CPPLabel s b) = (nest (-1000) $ (text s) <> char ':') $$ pretty b
+  pretty (CPPCase x b) = (text "case" <+> pretty x <> char ':') $+$ (nest 2 (pretty b))
+  pretty (CPPDefault b) = (text "default:") $+$ (nest 2 $ pretty b)
+  pretty (CPPSimple x) = (pretty x) <> char ';'
+  pretty (CPPCompound []) = empty
+  pretty (CPPCompound [CPPStatement (c@(CPPCompound _))]) = pretty c
+  pretty (CPPCompound [CPPStatement (c@(CPPVerbStat _))]) = pretty c
+  pretty (CPPCompound [CPPStatement a]) = pretty a
+  pretty (CPPCompound l) = lbrace $+$ (nest 2 $ vcat $ map pretty l) $+$ rbrace
+  pretty (CPPIf c t (Just f)) = text "if" <+> parens (pretty c) <+> braces (pretty t) <+> text "else" <+> braces (pretty f)
+  pretty (CPPIf c t Nothing) = text "if" <+> parens (pretty c) <+> braces (pretty t)
+  pretty (CPPSwitch x b) = text "switch (" <> pretty x <> text ") {" <+> pretty b <+> text "}"
+  pretty (CPPWhile x False b) = text "while" <> (parens $ pretty x) <+> (braces $ pretty b)
+  pretty (CPPWhile x True b) = text "do" <+> (braces $ pretty b) <+> text "while" <> (parens $ pretty x) <> semi
+  pretty (CPPFor f1 f2 f3 b) = text "for (" <> pretty f1 <> text ";" <+> pretty f2 <> text ";" <+> pretty f3 <> text ") {" $+$ nest 2 (pretty b) $+$ text "}"
+  pretty (CPPGoto l) = text ("goto " ++ l ++ ";")
+  pretty (CPPCont) = text "continue;"
+  pretty (CPPBreak) = text "break;"
+  pretty (CPPReturn x) = (text "return" <+> pretty x) <> text ";"
+  pretty (CPPDelete x) = (text "delete" <+> pretty x) <> text ";"
+  pretty (CPPVerbStat l) = lbrace $+$ (nest 2 $ vcat $ map text l) $+$ rbrace
+
+instance Pretty CPPQual where
+  pretty (CPPQualConst) = text "const"
+  pretty (CPPQualVolatile) = text "volatile"
+
+instance Pretty CPPStorSpec where
+  pretty (CPPAuto) = text "auto"
+  pretty (CPPRegister) = text "register"
+  pretty (CPPStatic) = text "static"
+  pretty (CPPExtern) = text "extern"
+  pretty (CPPTypedef) = text "typedef"
+  pretty (CPPInline) = text "inline"
+  pretty (CPPVirtual) = text "virtual"
+
+instance Pretty a => Pretty [a] where
+  pretty [] = empty
+  pretty [a] = pretty a
+  pretty (a:b) = pretty a <+> pretty b
+
+instance Pretty CPPVisibility where
+  pretty CPPPublic = text "public"
+  pretty CPPPrivate = text "private"
+  pretty CPPProtected = text "protected"
+
+instance Pretty (CPPType,Doc,Int,[CPPQual]) where
+  pretty (CPPPtr qual typ,s,l,q) = pretty (typ,char '*' <> (pretty q <+> (prio 4 l s)),4::Int,qual)
+  pretty (CPPRef qual typ,s,l,q) = pretty (typ,char '&' <> (pretty q <+> (prio 4 l s)),4::Int,qual)
+  pretty (CPPArray qual typ len,s,l,_) = pretty (typ,((prio 2 l s) <> lbrack <> pretty len <> rbrack),2::Int,qual)
+  pretty (CPPTypePrim prim,s,l,q) = pretty q <+> (text prim <+> s)
+  pretty (CPPTempl prim lst,s,l,q) = pretty q <+> (text prim <> char '<' <> (hcat $ punctuate comma $ map pretty lst) <> char '>') <+> s
+
+instance Pretty (CPPType,Doc) where
+  pretty (typ,doc) = pretty (typ,doc,0 :: Int,[]::[CPPQual])
+
+instance Pretty CPPType where
+  pretty x = pretty (x,empty)
+
+prettyString Nothing = empty
+prettyString (Just x) = text x
+
+instance Pretty CPPDecl where
+  pretty (CPPDecl { cppDeclName=name, cppType = typ, cppTypeQual = qual, cppTypeStor = stor, cppDeclInit=Nothing }) = pretty stor <+> pretty (typ,prettyString name,0 :: Int,qual)
+  pretty (CPPDecl { cppDeclName=name, cppType = typ, cppTypeQual = qual, cppTypeStor = stor, cppDeclInit=Just (CPPInitValue code) }) = pretty stor <+> pretty (typ,prettyString name,0 :: Int,qual) <> char '=' <> pretty code
+  pretty (CPPDecl { cppDeclName=name, cppType = typ, cppTypeQual = qual, cppTypeStor = stor, cppDeclInit=Just (CPPInitCall  args) }) = pretty stor <+> pretty (typ,prettyString name,0 :: Int,qual) <> lparen <> (hcat $ punctuate comma $ map pretty args) <> rparen
+  pretty (CPPDecl { cppDeclName=name, cppType = typ, cppTypeQual = qual, cppTypeStor = stor, cppDeclInit=Just (CPPInitArray args) }) = pretty stor <+> pretty (typ,prettyString name,0 :: Int,qual) <> char '=' <> lbrace <> (hcat $ punctuate comma $ map pretty args) <> rbrace
+
+instance Pretty CPPDef where
+  pretty (CPPDef { cppDefName=name, cppDefRetType=typ, cppDefStor=stor, cppDefArgs=args, cppDefBody = body, cppDefQual=qual }) =
+    let pre = (pretty stor <+> pretty (typ, text name)) <> parens (hcat $ punctuate comma $ map pretty args) <+> (hsep $ map pretty qual)
+        in case body of
+          Nothing -> pre <> text ";"
+          Just b -> pre <+> text "{" $+$ (nest 2 $ pretty b) $+$ text "}"
+
+instance Pretty (CPPConstr,String) where
+  pretty (CPPConstr { cppConstrStor=stor, cppConstrArgs=args, cppConstrBody=body, cppConstrInit=ini },name) =
+    let pre = (pretty stor <+> text name) <> parens (hcat $ punctuate comma $ map pretty args)
+        init [] = empty
+        init lst = colon <+> (hcat $ punctuate (text ", ") $ map (\(tp,args) -> pretty tp <> (parens $ hcat $ punctuate comma $ map pretty args)) lst)
+        in case body of
+          Nothing -> (pre <+> init ini) <> text ";"
+          Just b -> (pre <+> init ini) <+> text "{" $+$ (nest 2 $ pretty b) $+$ text "}"
+
+instance Pretty CPPBlockItem where
+  pretty (CPPStatement stat) = pretty stat
+  pretty (CPPBlockDecl decl) = pretty decl <> text ";"
+  pretty (CPPComment str) = text "//" <+> text str
+
+instance Pretty CPPMacroStm where
+  pretty (CPPMacroIncludeUser str) = text "#include" <+> (text $ "\"" ++ str ++"\"")
+  pretty (CPPMacroIncludeSys str)  = text "#include" <+> (text $ "<" ++ str ++ ">")
+  pretty (CPPMacroDefine { cppMacroDefName = name, cppMacroDefArgs = Nothing, cppMacroDefExpr = expr }) = text "#define" <+> text name <+> text expr
+  pretty (CPPMacroDefine { cppMacroDefName = name, cppMacroDefArgs = Just lst, cppMacroDefExpr = expr }) = text $ "#define " ++ name ++ "(" ++ (foldr1 (\a b -> a++","++b) lst) ++ ")" ++ " " ++ expr
+
+instance Pretty CPPElement where
+  pretty (CPPElemNamespace (name,ns)) = (text "namespace" <+> text name <+> lbrace) $+$ nest 2 (pretty ns) $+$ rbrace
+  pretty (CPPElemDecl decl) = pretty decl <> semi
+  pretty (CPPElemDef def) = pretty def
+  pretty (CPPElemClass cls) = pretty cls
+
+instance Pretty CPPNamespace where
+  pretty (CPPNamespace list) = vcat $ map (\x -> pretty x $+$ char ' ') list
+
+instance Pretty CPPClass where
+  pretty (CPPClass { cppClassName = name, cppClassInherit = inh, cppClassDecls = decls, cppClassDefs = defs, cppClassConstrs = constrs }) = 
+    let sel vis lst = map snd $ filter (\x -> fst x == vis) lst
+        inhh [] = empty
+        inhh lst = colon <+> (hcat $ punctuate (text ", ") $ map (\(vis,tp) -> pretty vis <+> pretty tp) lst)
+        decl vis = case sel vis decls of
+          [] -> empty
+          lst -> (nest (-2) (pretty vis) <> char ':') $+$ vcat (map (\x -> pretty x <> semi) lst) $+$ text " "
+        def vis = case sel vis defs of
+          [] -> empty
+          lst -> (nest (-2) (pretty vis) <> char ':') $+$ vcat (map pretty lst) $+$ text " "
+        constr vis = case sel vis constrs of
+          [] -> empty
+          lst -> (nest (-2) (pretty vis) <> char ':') $+$ vcat (map (\x -> pretty (x,name)) lst) $+$ text " "
+        comb vis = constr vis $+$ def vis
+        in (text "class" <+> text name <+> inhh inh <+> char '{') $+$ nest 2 (decl CPPPrivate $+$ decl CPPProtected $+$ decl CPPPublic $+$ comb CPPPrivate $+$ comb CPPProtected $+$ comb CPPPublic) $+$ char '}' <> semi
+
+instance Pretty CPPFile where
+  pretty (CPPFile { cppMacroStm = macro, cppUsing = using, cppTranslUnit = unit }) = vcat (map pretty macro) $+$ text " " $+$ vcat (map (\x -> text "using" <+> text "namespace" <+> text x <> semi) using) $+$ text " " $+$ pretty unit
+
+codegen :: Pretty x => x -> String
+codegen = render . pretty

+ src/Language/CPP/Syntax/AST.hs view

@@ -0,0 +1,174 @@+-- AST for C++ code
+
+{- based on:
+   language-c-0.3.1.1: Analysis and generation of C code
+   Language.C.Syntax.AST
+
+   Abstract syntax of C++ source and header files.
+-}
+
+module Language.CPP.Syntax.AST where
+
+data CPPFile = CPPFile { cppMacroStm :: [CPPMacroStm], cppUsing :: [String], cppTranslUnit :: CPPNamespace }
+  deriving (Eq,Ord,Show)
+
+data CPPMacroStm = 
+    CPPMacroIncludeUser String
+  | CPPMacroIncludeSys String
+  | CPPMacroDefine { cppMacroDefName:: String, cppMacroDefArgs :: Maybe [String], cppMacroDefExpr :: String }
+  deriving (Eq,Ord,Show)
+
+data CPPElement =
+    CPPElemNamespace (String,CPPNamespace)
+  | CPPElemDecl CPPDecl
+  | CPPElemDef CPPDef
+  | CPPElemClass CPPClass
+  deriving (Eq,Ord,Show)
+
+data CPPNamespace = CPPNamespace [CPPElement]
+  deriving (Eq,Ord,Show)
+
+data CPPClass = CPPClass { cppClassName :: String, cppClassInherit :: [(CPPVisibility,CPPType)], cppClassDecls :: [(CPPVisibility,CPPDecl)], cppClassDefs :: [(CPPVisibility,CPPDef)], cppClassConstrs :: [(CPPVisibility,CPPConstr)] }
+  deriving (Eq,Ord,Show)
+
+data CPPVisibility =
+    CPPPublic
+  | CPPProtected
+  | CPPPrivate
+  deriving (Eq,Ord,Show)
+
+-- TODO: function pointers
+-- TODO: struct/union/enum
+data CPPType =
+    CPPTypePrim String
+  | CPPArray [CPPQual] CPPType (Maybe CPPExpr)
+  | CPPPtr [CPPQual] CPPType
+  | CPPRef [CPPQual] CPPType
+  | CPPTempl String [CPPType]
+  deriving (Eq,Ord,Show)
+
+data CPPStorSpec =
+    CPPAuto
+  | CPPRegister
+  | CPPStatic
+  | CPPExtern
+  | CPPTypedef
+  | CPPInline
+  | CPPVirtual
+  deriving (Eq,Ord,Show)
+
+data CPPQual =
+    CPPQualConst
+  | CPPQualVolatile
+  deriving (Eq,Ord,Show)
+
+data CPPInit =
+    CPPInitValue CPPExpr
+  | CPPInitCall  [CPPExpr]
+  | CPPInitArray [CPPExpr]
+  deriving (Eq,Ord,Show)
+
+data CPPDecl = CPPDecl { cppDeclName :: Maybe String, cppType :: CPPType, cppTypeQual :: [CPPQual], cppTypeStor :: [CPPStorSpec], cppDeclInit :: Maybe CPPInit }
+  deriving (Eq,Ord,Show)
+
+data CPPDef = CPPDef { cppDefName :: String, cppDefRetType :: CPPType, cppDefStor :: [CPPStorSpec], cppDefQual :: [CPPQual], cppDefArgs :: [CPPDecl], cppDefBody :: Maybe CPPStat }
+  deriving (Eq,Ord,Show)
+
+data CPPConstr = CPPConstr { cppConstrStor :: [CPPStorSpec], cppConstrArgs :: [CPPDecl], cppConstrBody :: Maybe CPPStat, cppConstrInit :: [(Either CPPExpr CPPType,[CPPExpr])] }
+  deriving (Eq,Ord,Show)
+
+data CPPStat = 
+    CPPLabel String CPPStat
+  | CPPCase CPPExpr CPPStat
+  | CPPDefault CPPStat
+  | CPPSimple CPPExpr
+  | CPPCompound [CPPBlockItem]
+  | CPPVerbStat [String]
+  | CPPIf CPPExpr CPPStat (Maybe CPPStat)
+  | CPPSwitch CPPExpr CPPStat
+  | CPPWhile CPPExpr Bool CPPStat
+  | CPPFor (Either (Maybe CPPExpr) CPPDecl) (Maybe CPPExpr) (Maybe CPPExpr) CPPStat
+  | CPPGoto String
+  | CPPCont
+  | CPPBreak
+  | CPPReturn (Maybe CPPExpr)
+  | CPPDelete CPPExpr
+  deriving (Eq,Ord,Show)
+
+data CPPBlockItem =
+    CPPStatement CPPStat
+  | CPPBlockDecl CPPDecl
+  | CPPComment String
+  deriving (Eq,Ord,Show)
+
+data CPPExpr =
+    CPPComma [CPPExpr]
+  | CPPAssign CPPExpr CPPAssignOp CPPExpr
+  | CPPBinary CPPExpr CPPBinaryOp CPPExpr
+  | CPPUnary CPPUnaryOp CPPExpr
+  | CPPCond CPPExpr (Maybe CPPExpr) CPPExpr
+  | CPPCast CPPType CPPExpr
+  | CPPSizeOfExpr CPPExpr
+  | CPPSizeOfType CPPType
+  | CPPIndex CPPExpr CPPExpr
+  | CPPCall CPPExpr [CPPExpr]
+  | CPPMember CPPExpr String Bool
+  | CPPVar String
+  | CPPConst CPPConst
+  | CPPNew CPPType [CPPExpr]
+  deriving (Eq,Ord,Show)
+
+data CPPConst =
+    CPPConstInt Integer
+  | CPPConstChar String
+  | CPPConstFloat String
+  | CPPConstString String
+  deriving (Eq,Ord,Show)
+
+data CPPAssignOp =
+    CPPAssOp
+  | CPPAssOpMul
+  | CPPAssOpDiv
+  | CPPAssOpRmd
+  | CPPAssOpAdd
+  | CPPAssOpSub
+  | CPPAssOpShl
+  | CPPAssOpShr
+  | CPPAssOpAnd
+  | CPPAssOpOr
+  | CPPAssOpXor
+  deriving (Eq,Ord,Show)
+
+data CPPUnaryOp =
+    CPPOpPreInc
+  | CPPOpPostInc
+  | CPPOpPreDec
+  | CPPOpPostDec
+  | CPPOpAdr
+  | CPPOpInd
+  | CPPOpPlus
+  | CPPOpMinus
+  | CPPOpComp
+  | CPPOpNeg
+  deriving (Eq,Ord,Show)
+
+data CPPBinaryOp =
+    CPPOpMul
+  | CPPOpDiv
+  | CPPOpRmd
+  | CPPOpAdd
+  | CPPOpSub
+  | CPPOpShl
+  | CPPOpShr
+  | CPPOpLe
+  | CPPOpGr
+  | CPPOpLeq
+  | CPPOpGeq
+  | CPPOpEq
+  | CPPOpNeq
+  | CPPOpAnd
+  | CPPOpOr
+  | CPPOpXor
+  | CPPOpLAnd
+  | CPPOpLOr
+  deriving (Eq,Ord,Show)