diff --git a/ChangeLog.md b/ChangeLog.md --- a/ChangeLog.md +++ b/ChangeLog.md @@ -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. diff --git a/chr-core.cabal b/chr-core.cabal --- a/chr-core.cabal +++ b/chr-core.cabal @@ -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 diff --git a/src/CHR/Solve/MonoBacktrackPrio.hs b/src/CHR/Solve/MonoBacktrackPrio.hs --- a/src/CHR/Solve/MonoBacktrackPrio.hs +++ b/src/CHR/Solve/MonoBacktrackPrio.hs @@ -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 - --} diff --git a/src/CHR/Types.hs b/src/CHR/Types.hs --- a/src/CHR/Types.hs +++ b/src/CHR/Types.hs @@ -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 diff --git a/src/CHR/Types/Core.hs b/src/CHR/Types/Core.hs --- a/src/CHR/Types/Core.hs +++ b/src/CHR/Types/Core.hs @@ -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 --} diff --git a/src/CHR/Types/Rule.hs b/src/CHR/Types/Rule.hs --- a/src/CHR/Types/Rule.hs +++ b/src/CHR/Types/Rule.hs @@ -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 --}