chr-core 0.1.0.1 → 0.1.0.4
raw patch · 6 files changed
+40/−226 lines, 6 filesdep ~chr-datadep ~logict-state
Dependency ranges changed: chr-data, logict-state
Files
- ChangeLog.md +14/−2
- chr-core.cabal +3/−3
- src/CHR/Solve/MonoBacktrackPrio.hs +4/−97
- src/CHR/Types.hs +0/−2
- src/CHR/Types/Core.hs +12/−85
- src/CHR/Types/Rule.hs +7/−37
ChangeLog.md view
@@ -1,5 +1,17 @@ # Revision history for chr -## 0.1.0.0 -- YYYY-mm-dd+## 0.1.0.3 -- 2018-04-27 -* First version. Released on an unsuspecting world.+* comment cleanup++## 0.1.0.2 -- 2018-01-07++* haddock build errors fixed++## 0.1.0.1 -- 2018-01-07++* Restructure and refactor to allow 1 constraint lang to be used with multiple term lang++## 0.1.0.0 -- 2017-12-28++* First version.
chr-core.cabal view
@@ -2,7 +2,7 @@ -- see http://haskell.org/cabal/users-guide/ name: chr-core-version: 0.1.0.1+version: 0.1.0.4 synopsis: Constraint Handling Rules description: Constraint Handling Rules evaluation engine license: BSD3@@ -49,8 +49,8 @@ pqueue >= 1.3.1, -- vector >= 0.11, -- fclabels >= 2.0.3,- chr-data >= 0.1.0.0,+ chr-data >= 0.1.0.1, chr-pretty >= 0.1.0.0,- logict-state >= 0.1.0.4+ logict-state >= 0.1.0.5 hs-source-dirs: src default-language: Haskell2010
src/CHR/Solve/MonoBacktrackPrio.hs view
@@ -37,7 +37,6 @@ , runCHRMonoBacktrackPrioT , addRule- -- , addRule2 , addConstraintAsWork @@ -79,19 +78,17 @@ import Data.Maybe import Control.Monad+-- import Control.Monad.IO.Class import Control.Monad.Except import Control.Monad.State.Strict import Control.Monad.LogicState import CHR.Pretty as Pretty--- import UHC.Util.Serialize import CHR.Types.Core import CHR.Types.Rule import CHR.Data.Substitutable import CHR.Data.AssocL import CHR.Data.Fresh--- --- import UHC.Util.Debug import CHR.Types @@ -248,8 +245,6 @@ { _chrgstStore :: !(CHRStore cnstr guard bprio prio) -- ^ Actual database of rules, to be searched , _chrgstNextFreeRuleInx :: {-# UNPACK #-} !CHRInx -- ^ Next free rule identification, used by solving to identify whether a rule has been used for a constraint. -- The numbering is applied to constraints inside a rule which can be matched.- -- , _chrgstWorkStore :: !(WorkStore cnstr) -- ^ Actual database of solvable constraints- -- , _chrgstNextFreeWorkInx :: {-# UNPACK #-} !WorkTime -- ^ Next free work/constraint identification, used by solving to identify whether a rule has been used for a constraint. , _chrgstScheduleQueue :: !(Que.MinPQueue (CHRPrioEvaluatableVal bprio) (CHRMonoBacktrackPrioT cnstr guard bprio prio subst env m (SolverResult subst))) , _chrgstTrace :: !(SolveTrace' cnstr (StoredCHR cnstr guard bprio prio) subst) , _chrgstStatNrSolveSteps :: {-# UNPACK #-} !Int@@ -300,19 +295,11 @@ {-# INLINE bst #-} -- | All required behavior, as alias-{--class ( IsCHRSolvable env cnstr guard bprio prio subst- , Monad m- , Lookup subst (VarLookupKey subst) (VarLookupVal subst)- , LookupApply subst subst- , Fresh Int (ExtrValVarKey (VarLookupVal subst))- , ExtrValVarKey (VarLookupVal subst) ~ VarLookupKey subst- , VarTerm (VarLookupVal subst)- ) => MonoBacktrackPrio cnstr guard bprio prio subst env m--} type MonoBacktrackPrio cnstr guard bprio prio subst env m = ( IsCHRSolvable env cnstr guard bprio prio subst , Monad m+ -- TODO: replace MonadIO with API abstracting away access to persistent structures+ -- , MonadIO m , Lookup subst (VarLookupKey subst) (VarLookupVal subst) , LookupApply subst subst , Fresh Int (ExtrValVarKey (VarLookupVal subst))@@ -339,14 +326,6 @@ ------------------------------------------------------------------------------------------- -- | Alias API for solving requirements-{--class ( IsCHRConstraint env c s- , IsCHRGuard env g s- , IsCHRBacktrackPrio env bp s- , IsCHRPrio env p s- , PP (VarLookupKey s)- ) => IsCHRSolvable env c g bp p s--} type IsCHRSolvable env c g bp p s = ( IsCHRConstraint env c s , IsCHRGuard env g s@@ -659,7 +638,6 @@ :: MonoBacktrackPrio cnstr guard bprio prio subst env m => CHRGlobState cnstr guard bprio prio subst env m -> CHRBackState cnstr bprio subst env- -- -> CHRPrioEvaluatableVal bprio -> CHRMonoBacktrackPrioT cnstr guard bprio prio subst env m (SolverResult subst) -> m ([SolverResult subst], (CHRGlobState cnstr guard bprio prio subst env m, CHRBackState cnstr bprio subst env)) runCHRMonoBacktrackPrioT gs bs {- bp -} m = observeStateAllT (gs, bs {- _chrbstBacktrackPrio=bp -}) m@@ -799,13 +777,6 @@ ------------------------------------------------------------------------------------------- {-# INLINABLE chrSolve #-}-{- # SPECIALIZE chrSolve- :: ( MonoBacktrackPrio c g bp p s e IO- , PP s- ) => CHRSolveOpts- -> e- -> CHRMonoBacktrackPrioT c g bp p s e IO (SolverResult s)- # -} -- | (Under dev) solve chrSolve :: forall c g bp p s e m .@@ -982,7 +953,7 @@ alts -> do forM alts $ \alt@(FoundBodyAlt {foundBodyAltBacktrackPrio=bprio}) -> do log (Just alt)- (backtrack $ nextwork bprio alt) >>= slvSchedule bprio+ (backtrackWithRoll (\_ _ bs -> {- (liftIO $ putStrLn "TEST") >> -} return bs) $ nextwork bprio alt) >>= slvSchedule bprio slvScheduleRun where@@ -1021,72 +992,25 @@ modifyAndGet (bst ^* chrbstFreshVar) (freshWith $ Just v) >>= \v' -> return $ (Lk.singleton v (varTermMkKey v') :: s) {-# INLINE slvFreshSubst #-} -{- -- | Lookup work in a store part of the global state slvLookup :: ( MonoBacktrackPrio c g bp p s e m- , Ord x- ) => CHRKey c -- ^ work key- -> Lens (CHRGlobState c g bp p s e m) (CHRTrie' c [x])- -> CHRMonoBacktrackPrioT c g bp p s e m [x]-slvLookup key t =- (getl $ gst ^* t) >>= \t -> do- let lkup how = concat $ TreeTrie.lookupResultToList $ TreeTrie.lookupPartialByKey how key t- return $ Set.toList $ Set.fromList $ lkup TTL_WildInTrie ++ lkup TTL_WildInKey--}---- | Lookup work in a store part of the global state-slvLookup- :: ( MonoBacktrackPrio c g bp p s e m , Ord (TT.TrTrKey c) ) => CHRKey c -- ^ work key -> Lens (CHRGlobState c g bp p s e m, CHRBackState c bp s e) (TT.TreeTrie (TT.TrTrKey c) [x]) -> CHRMonoBacktrackPrioT c g bp p s e m [x] slvLookup key t = (getl t) >>= \t -> do- {-- let lkup how = concat $ TreeTrie.lookupResultToList $ TreeTrie.lookupPartialByKey how key t- return $ Set.toList $ Set.fromList $ lkup TTL_WildInTrie ++ lkup TTL_WildInKey- -} return $ concat $ TT.lookupResultToList $ TT.lookup key t {-# INLINE slvLookup #-} -{- -- | Extract candidates matching a CHRKey. -- Return a list of CHR matches, -- each match expressed as the list of constraints (in the form of Work + Key) found in the workList wlTrie, thus giving all combis with constraints as part of a CHR, -- partititioned on before or after last query time (to avoid work duplication later) slvCandidate- :: ( MonoBacktrackPrio c g bp p s e m- -- , Ord (TTKey c), PP (TTKey c)- ) => WorkInxSet -- ^ active in queue- -> Set.Set MatchedCombi -- ^ already matched combis- -> WorkInx -- ^ work inx- -> StoredCHR c g bp p -- ^ found chr for the work- -> Int -- ^ position in the head where work was found- -> CHRMonoBacktrackPrioT c g bp p s e m- ( [[WorkInx]] -- All matches of the head, unfiltered w.r.t. deleted work- )-slvCandidate waitingWk alreadyMatchedCombis wi (StoredCHR {_storedHeadKeys = ks, _storedChrInx = ci}) headInx = do- let [ks1,_,ks2] = splitPlaces [headInx, headInx+1] ks- ws1 <- forM ks1 lkup- ws2 <- forM ks2 lkup- return $ filter (\wi -> all (`IntSet.member` waitingWk) wi- && Set.notMember (MatchedCombi ci wi) alreadyMatchedCombis)- $ combineToDistinguishedEltsBy (==) $ ws1 ++ [[wi]] ++ ws2- where- lkup k = slvLookup k (chrgstWorkStore ^* wkstoreTrie)--}---- | Extract candidates matching a CHRKey.--- Return a list of CHR matches,--- each match expressed as the list of constraints (in the form of Work + Key) found in the workList wlTrie, thus giving all combis with constraints as part of a CHR,--- partititioned on before or after last query time (to avoid work duplication later)-slvCandidate :: forall c g bp p s e m . ( MonoBacktrackPrio c g bp p s e m- -- , Ord (TTKey c), PP (TTKey c)- -- , ExtrValVarKey (VarLookupVal s) ~ VarLookupKey s ) => WorkInxSet -- ^ active in queue -> Set.Set MatchedCombi -- ^ already matched combis -> WorkInx -- ^ work inx@@ -1115,10 +1039,7 @@ , CHRMatchable env c s , CHRCheckable env g s , CHRMatchable env bp s- -- , CHRPrioEvaluatable env p s , CHRPrioEvaluatable env bp s- -- , CHRBuiltinSolvable env b s- -- , PP s ) => env -> StoredCHR c g bp p -> [c]@@ -1141,17 +1062,3 @@ freevars = Set.unions [varFreeSet hc, maybe Set.empty varFreeSet mbbpr] {-# INLINE slvMatch #-} ------------------------------------------------------------------------------------------------ Instances: Serialize----------------------------------------------------------------------------------------------{--instance (Ord (TTKey c), Serialize (TTKey c), Serialize c, Serialize g, Serialize b, Serialize p) => Serialize (CHRStore c g b p) where- sput (CHRStore a) = sput a- sget = liftM CHRStore sget- -instance (Serialize c, Serialize g, Serialize b, Serialize p, Serialize (TTKey c)) => Serialize (StoredCHR c g bp p) where- sput (StoredCHR a b c d) = sput a >> sput b >> sput c >> sput d- sget = liftM4 StoredCHR sget sget sget sget---}
src/CHR/Types.hs view
@@ -25,10 +25,8 @@ import qualified CHR.Data.TreeTrie as TT import CHR.Data.TreeTrie ( TrTrKey )- import CHR.Pretty as Pretty import CHR.Data.AssocL- import CHR.Types.Core ( IVar , NmToVarMp, emptyNmToVarMp , Prio
src/CHR/Types/Core.hs view
@@ -4,26 +4,15 @@ --- Constraint Handling Rules ------------------------------------------------------------------------------------------- -{- |-Derived from work by Gerrit vd Geest, but with searching structures for predicates-to avoid explosion of search space during resolution.--}- module CHR.Types.Core ( IsConstraint(..) , ConstraintSolvesVia(..) , IsCHRConstraint(..)- -- , CHRConstraint(..) , IsCHRGuard(..)- -- , CHRGuard(..)- - -- , IsCHRBuiltin(..)- -- , CHRBuiltin(..)- + , IsCHRPrio(..)- -- , CHRPrio(..) , IsCHRBacktrackPrio(..) @@ -34,8 +23,6 @@ , CHRMatcher , chrmatcherRun' , chrmatcherRun- -- , chrmatcherLift- -- , chrmatcherUnlift , chrmatcherstateEnv , chrmatcherstateVarLookup@@ -48,7 +35,6 @@ , chrMatchSuccess , chrMatchWait , chrMatchSucces- -- , chrMatchVarUpd , CHRMatchEnv(..) , emptyCHRMatchEnv@@ -65,9 +51,7 @@ , Prio(..) , CHRPrioEvaluatable(..) , CHRPrioEvaluatableVal- - -- , CHRBuiltinSolvable(..)- + , CHRTrOpt(..) , IVar@@ -80,11 +64,6 @@ ) where --- import qualified UHC.Util.TreeTrie as TreeTrie-import CHR.Data.VarMp-import CHR.Data.Lookup (Lookup, Stacked, LookupApply)-import qualified CHR.Data.Lookup as Lk-import qualified CHR.Data.Lookup.Stacked as Lk import qualified Data.Map.Strict as Map import qualified Data.HashMap.Strict as MapH import qualified Data.IntMap.Strict as IntMap@@ -92,23 +71,25 @@ import Data.Monoid import Data.Typeable import Data.Function-import Unsafe.Coerce import qualified Data.Set as Set-import CHR.Pretty--- import UHC.Util.CHR.Key-import qualified CHR.Data.TreeTrie as TT++import Unsafe.Coerce+ import Control.Monad import Control.Monad.State -- .Strict import Control.Monad.Except import Control.Monad.Identity++import CHR.Pretty+import CHR.Data.VarMp+import CHR.Data.Lookup (Lookup, Stacked, LookupApply)+import qualified CHR.Data.Lookup as Lk+import qualified CHR.Data.Lookup.Stacked as Lk+import qualified CHR.Data.TreeTrie as TT import CHR.Data.Lens import CHR.Utils--- import UHC.Util.Binary--- import UHC.Util.Serialize import CHR.Data.Substitutable --- import UHC.Util.Debug- ------------------------------------------------------------------------------------------- --- Name <-> Var mapping -------------------------------------------------------------------------------------------@@ -292,24 +273,6 @@ ------------------------------------------------------------------------------------------- -- | Alias API for constraint requirements-{--class ( CHRMatchable env c subst- -- , CHRBuiltinSolvable env c subst- , VarExtractable c- , VarUpdatable c subst- , Typeable c- -- , Serialize c- -- , TTKeyable c- , TT.TreeTrieKeyable c- , IsConstraint c- , Ord c- -- , Ord (TTKey c)- , Ord (TT.TrTrKey c)- , PP c- -- , PP (TTKey c)- , PP (TT.TrTrKey c)- ) => IsCHRConstraint env c subst--} type IsCHRConstraint env c subst = ( CHRMatchable env c subst -- , CHRBuiltinSolvable env c subst@@ -333,15 +296,6 @@ ------------------------------------------------------------------------------------------- -- | Alias API for guard requirements-{--class ( CHRCheckable env g subst- , VarExtractable g- , VarUpdatable g subst- , Typeable g- -- , Serialize g- , PP g- ) => IsCHRGuard env g subst--} type IsCHRGuard env g subst = ( CHRCheckable env g subst , VarExtractable g@@ -356,13 +310,6 @@ ------------------------------------------------------------------------------------------- -- | Alias API for priority requirements-{--class ( CHRPrioEvaluatable env p subst- , Typeable p- -- , Serialize p- , PP p- ) => IsCHRPrio env p subst--} type IsCHRPrio env p subst = ( CHRPrioEvaluatable env p subst , Typeable p@@ -371,13 +318,6 @@ ) -- | Alias API for backtrack priority requirements-{--class ( IsCHRPrio env bp subst- , CHRMatchable env bp subst- , PP (CHRPrioEvaluatableVal bp)- -- -- , Num (CHRPrioEvaluatableVal bp)- ) => IsCHRBacktrackPrio env bp subst--} type IsCHRBacktrackPrio env bp subst = ( IsCHRPrio env bp subst , CHRMatchable env bp subst@@ -571,18 +511,5 @@ ------------------------------------------------------------------------------------------- type instance CHRPrioEvaluatableVal () = Prio--{--instance {-# OVERLAPPABLE #-} Ord x => CHRPrioEvaluatable env x subst where- -- chrPrioEval _ _ _ = minBound- chrPrioCompare _ (_,x) (_,y) = compare x y--}--{--instance {-# OVERLAPPABLE #-} CHRPrioEvaluatable env () subst where- chrPrioLift _ = ()- chrPrioEval _ _ _ = minBound- chrPrioCompare _ _ _ = EQ--}
src/CHR/Types/Rule.hs view
@@ -18,11 +18,8 @@ , Rule(..) , ruleBody, ruleBody'- -- , ruleBodyBuiltin , ruleSz- - -- , CHRRule(..)- + , (/\) , (\/) , (\!)@@ -34,21 +31,19 @@ ) where -import qualified CHR.Data.TreeTrie as TT-import CHR.Data.VarMp-import CHR.Utils import Data.Monoid import Data.List as List import Data.Typeable--- import Data.Data import qualified Data.Set as Set++import qualified CHR.Data.TreeTrie as TT+import CHR.Data.VarMp+import CHR.Utils import CHR.Pretty--- import UHC.Util.CHR.Key-import Control.Monad--- import UHC.Util.Binary--- import UHC.Util.Serialize import CHR.Data.Substitutable +import Control.Monad+ ------------------------------------------------------------------------------------------- --- CHR, derived structures -------------------------------------------------------------------------------------------@@ -221,28 +216,3 @@ l @= r = r =@ l {-# INLINE (@=) #-} ------------------------------------------------------------------------------------------------ Instances: Serialize----------------------------------------------------------------------------------------------{--instance (Serialize c,Serialize p) => Serialize (RuleBodyAlt c p) where- sput (RuleBodyAlt a b) = sput a >> sput b- sget = liftM2 RuleBodyAlt sget sget--instance (Serialize c,Serialize g,Serialize bp,Serialize p) => Serialize (Rule c g bp p) where- sput (Rule a b c d e f g) = sput a >> sput b >> sput c >> sput d >> sput e >> sput f >> sput g- sget = liftM7 Rule sget sget sget sget sget sget sget--}--{--instance (MkSolverConstraint (CHRConstraint e s) x', Serialize x') => Serialize (CHRConstraint e s) where- sput x = maybe (panic "CHR.Types.Rule.Serialize.MkSolverConstraint.sput") sput $ fromSolverConstraint x- sget = liftM toSolverConstraint sget--}--{--instance Serialize (CHRRule e s) where- sput (CHRRule a) = sput a- sget = liftM CHRRule sget--}