diff --git a/executable/Main.hs b/executable/Main.hs --- a/executable/Main.hs +++ b/executable/Main.hs @@ -1,277 +1,594 @@ -{-# LANGUAGE TypeSynonymInstances, FlexibleInstances, CPP, GeneralizedNewtypeDeriving, TypeFamilies, RecordWildCards, FlexibleContexts, UndecidableInstances, NondecreasingIndentation #-} -#include "errors.h" - -#if __GLASGOW_HASKELL__ < 710 -import Control.Applicative -#endif - +{-# LANGUAGE CPP, RecordWildCards, FlexibleInstances, PatternGuards #-} import Control.Monad -import Control.Monad.Trans.State.Strict import Data.Char import Data.Either -import Twee hiding (info) -import Twee.Base hiding (char, lookup, (<>)) -import Twee.Rule +import Twee hiding (message) +import Twee.Base hiding (char, lookup, vars) +import Twee.Rule(lhs, rhs, unorient) +import Twee.Equation +import qualified Twee.Proof as Proof +import Twee.Proof hiding (Config, defaultConfig) +import qualified Twee.Join as Join import Twee.Utils -import Twee.Queue +import qualified Twee.CP as CP import Data.Ord -import qualified Twee.Indexes as Indexes import qualified Data.Map.Strict as Map import qualified Twee.KBO as KBO -import qualified Twee.LPO as LPO -import qualified Data.Set as Set -import Data.Reflection -import qualified Data.IntMap as IntMap -import Data.IntMap(IntMap) import Data.List.Split import Data.List import Data.Maybe import Jukebox.Options import Jukebox.Toolbox -import Jukebox.Name +import Jukebox.Name hiding (lhs, rhs) import qualified Jukebox.Form as Jukebox -import Jukebox.Form hiding ((:=:), Var, Symbolic(..), Term) -import qualified Twee.Label as Label +import Jukebox.Form hiding ((:=:), Var, Symbolic(..), Term, Axiom, size, Lemma) +import Jukebox.Tools.EncodeTypes +import Jukebox.TPTP.Print +import Jukebox.Tools.Clausify(ClausifyFlags(..), clausify) +import qualified Data.Set as Set +import qualified Data.IntMap.Strict as IntMap +import System.IO +import System.Exit -parseInitialState :: OptionParser (Twee f) -parseInitialState = - go <$> maxSize <*> general - <*> groundJoin <*> conn <*> set <*> setGoals <*> tracing <*> moreTracing <*> lweight <*> rweight <*> splits <*> cpSetSize <*> mixFIFO <*> mixPrio <*> skipComposite <*> interreduce <*> unsafeInterreduce <*> cancel <*> cancelSize <*> cancelConsts <*> atomicCancellation - where - go maxSize general groundJoin conn set setGoals tracing moreTracing lweight rweight splits cpSetSize mixFIFO mixPrio skipComposite interreduce unsafeInterreduce cancel cancelSize cancelConsts atomicCancellation = - (initialState mixFIFO mixPrio) { - maxSize = maxSize, - cpSplits = splits, - minimumCPSetSize = cpSetSize, - useGeneralSuperpositions = general, - useGroundJoining = groundJoin, - useConnectedness = conn, - useSetJoining = set, - useSetJoiningForGoals = setGoals, - useCancellation = cancel, - maxCancellationSize = cancelSize, - atomicCancellation = atomicCancellation, - unifyConstantsInCancellation = cancelConsts, - useInterreduction = interreduce, - useUnsafeInterreduction = unsafeInterreduce, - skipCompositeSuperpositions = skipComposite, - tracing = tracing, - moreTracing = moreTracing, - lhsWeight = lweight, - rhsWeight = rweight } - maxSize = flag "max-size" ["Maximum critical pair size"] Nothing (Just <$> argNum) - general = not <$> bool "no-general-superpositions" ["Disable considering only general superpositions"] - groundJoin = not <$> bool "no-ground-join" ["Disable ground joinability testing"] - conn = not <$> bool "no-connectedness" ["Disable connectedness testing"] - set = bool "set-join" ["Join by computing set of normal forms"] - setGoals = not <$> bool "no-set-join-goals" ["Disable joining goals by computing set of normal forms"] - tracing = not <$> bool "no-tracing" ["Disable tracing output"] - moreTracing = bool "more-tracing" ["Produce even more tracing output"] - lweight = flag "lhs-weight" ["Weight given to LHS of critical pair (default 2)"] 2 argNum - rweight = flag "rhs-weight" ["Weight given to RHS of critical pair (default 1)"] 1 argNum - splits = flag "split" ["Split CP sets into this many pieces on selection (default 20)"] 20 argNum - cpSetSize = flag "cp-set-minimum" ["Decay CP sets into single CPs when they get this small (default 20)"] 20 argNum - mixFIFO = flag "mix-fifo" ["Take this many CPs at a time from FIFO (default 0)"] 0 argNum - mixPrio = flag "mix-prio" ["Take this many CPs at a time from priority queue (default 10)"] 10 argNum - interreduce = bool "interreduce" ["Enable interreduction of left hand sides"] - unsafeInterreduce = not <$> bool "safe-interreduce" ["Disable some incomplete interreductions"] - cancel = not <$> bool "no-cancellation" ["Disable cancellation"] - cancelSize = flag "max-cancellation-size" ["Maximum size of cancellation laws"] Nothing (Just <$> argNum) - cancelConsts = bool "unify-consts-in-cancellation" ["Allow unification with a constant in cancellation"] - skipComposite = not <$> bool "composite-superpositions" ["Generate composite superpositions"] - atomicCancellation = not <$> bool "compound-cancellation" ["Allow cancellation laws to have non-atomic RHS"] +data MainFlags = + MainFlags { + flags_proof :: Bool, + flags_trace :: Maybe (String, String) } -data Order = KBO | LPO +parseMainFlags :: OptionParser MainFlags +parseMainFlags = + MainFlags <$> proof <*> trace + where + proof = + inGroup "Output options" $ + bool "proof" ["Produce proofs (on by default)."] + True + trace = + expert $ + inGroup "Output options" $ + flag "trace" + ["Write a Prolog-format execution trace to this file (off by default)."] + Nothing ((\x y -> Just (x, y)) <$> argFile <*> argModule) + argModule = arg "" "expected a Prolog module name" Just -parseOrder :: OptionParser Order -parseOrder = - f <$> - bool "lpo" ["Use lexicographic path ordering instead of KBO"] +parseConfig :: OptionParser Config +parseConfig = + Config <$> maxSize <*> maxCPs <*> maxCPDepth <*> simplify <*> normPercent <*> + (CP.Config <$> lweight <*> rweight <*> funweight <*> varweight <*> depthweight <*> dupcost <*> dupfactor) <*> + (Join.Config <$> ground_join <*> connectedness <*> set_join) <*> + (Proof.Config <$> all_lemmas <*> flat_proof <*> show_instances) where - f False = KBO - f True = LPO + maxSize = + inGroup "Resource limits" $ + flag "max-term-size" ["Discard rewrite rules whose left-hand side is bigger than this limit (unlimited by default)."] maxBound argNum + maxCPs = + inGroup "Resource limits" $ + flag "max-cps" ["Give up after considering this many critical pairs (unlimited by default)."] maxBound argNum + maxCPDepth = + inGroup "Resource limits" $ + flag "max-cp-depth" ["Only consider critical pairs up to this depth (unlimited by default)."] maxBound argNum + simplify = + expert $ + inGroup "Completion heuristics" $ + bool "simplify" + ["Simplify rewrite rules with respect to one another (on by default)."] + True + normPercent = + expert $ + inGroup "Completion heuristics" $ + defaultFlag "normalise-queue-percent" "Percent of time spent renormalising queued critical pairs" (cfg_renormalise_percent) argNum + lweight = + expert $ + inGroup "Critical pair weighting heuristics" $ + defaultFlag "lhs-weight" "Weight given to LHS of critical pair" (CP.cfg_lhsweight . cfg_critical_pairs) argNum + rweight = + expert $ + inGroup "Critical pair weighting heuristics" $ + defaultFlag "rhs-weight" "Weight given to RHS of critical pair" (CP.cfg_rhsweight . cfg_critical_pairs) argNum + funweight = + expert $ + inGroup "Critical pair weighting heuristics" $ + defaultFlag "fun-weight" "Weight given to function symbols" (CP.cfg_funweight . cfg_critical_pairs) argNum + varweight = + expert $ + inGroup "Critical pair weighting heuristics" $ + defaultFlag "var-weight" "Weight given to variable symbols" (CP.cfg_varweight . cfg_critical_pairs) argNum + depthweight = + expert $ + inGroup "Critical pair weighting heuristics" $ + defaultFlag "depth-weight" "Weight given to critical pair depth" (CP.cfg_depthweight . cfg_critical_pairs) argNum + dupcost = + expert $ + inGroup "Critical pair weighting heuristics" $ + defaultFlag "dup-cost" "Cost of duplicate subterms" (CP.cfg_dupcost . cfg_critical_pairs) argNum + dupfactor = + expert $ + inGroup "Critical pair weighting heuristics" $ + defaultFlag "dup-factor" "Size factor of duplicate subterms" (CP.cfg_dupfactor . cfg_critical_pairs) argNum + ground_join = + expert $ + inGroup "Critical pair joining heuristics" $ + bool "ground-joining" + ["Test terms for ground joinability (on by default)."] + True + connectedness = + expert $ + inGroup "Critical pair joining heuristics" $ + bool "connectedness" + ["Test terms for subconnectedness (off by default)."] + False + set_join = + expert $ + inGroup "Critical pair joining heuristics" $ + bool "set-join" + ["Compute all normal forms when joining critical pairs (off by default)."] + False + all_lemmas = + expert $ + inGroup "Proof presentation" $ + bool "all-lemmas" + ["Produce a proof with one lemma for each critical pair (off by default)."] + False + flat_proof = + expert $ + inGroup "Proof presentation" $ + bool "no-lemmas" + ["Produce a proof with no lemmas (off by default).", + "May lead to exponentially large proofs."] + False + show_instances = + expert $ + inGroup "Proof presentation" $ + bool "show-instances" + ["Show which instances of each axiom and lemma were used (off by default)."] + False + defaultFlag name desc field parser = + flag name [desc ++ " (" ++ show def ++ " by default)."] def parser + where + def = field defaultConfig parsePrecedence :: OptionParser [String] parsePrecedence = + expert $ + inGroup "Term order options" $ fmap (splitOn ",") - (flag "precedence" ["List of functions in descending order of precedence"] [] (arg "" "expected a function name" Just)) + (flag "precedence" ["List of functions in descending order of precedence."] [] (arg "" "expected a function name" Just)) data Constant = Constant { - conIndex :: Int, - conArity :: Int, - conSize :: Int, - conName :: String } - | Builtin Builtin + con_prec :: {-# UNPACK #-} !Precedence, + con_id :: {-# UNPACK #-} !Jukebox.Function, + con_arity :: {-# UNPACK #-} !Int } + deriving (Eq, Ord) -data Builtin = CFalse | CTrue | CEquals deriving (Eq, Ord) +data Precedence = Precedence !Bool !(Maybe Int) !Int + deriving (Eq, Ord) -instance Eq Constant where - x == y = x `compare` y == EQ -instance Ord Constant where - compare Constant{conIndex = x} Constant{conIndex = y} = compare x y - compare Constant{} Builtin{} = LT - compare Builtin{} Constant{} = GT - compare (Builtin x) (Builtin y) = compare x y instance Sized Constant where - size Constant{conSize = n} = fromIntegral n - size Builtin{} = 0 + size Constant{..} = 1 + --if con_arity <= 1 then 1 else 0 instance Arity Constant where - arity Constant{conSize = n} = n - arity (Builtin CEquals) = 2 - arity (Builtin _) = 0 + arity Constant{..} = con_arity instance Pretty Constant where - pPrint Constant{conName = name} = text name - pPrint (Builtin CEquals) = text "$equals" - pPrint (Builtin CTrue) = text "$true" - pPrint (Builtin CFalse) = text "$false" + pPrint Constant{..} = text (base con_id) + instance PrettyTerm Constant where - termStyle con@Constant{} - | not (any isAlphaNum (conName con)) = - case conArity con of + termStyle Constant{..} + | any isAlphaNum (base con_id) = uncurried + | otherwise = + case con_arity of 1 -> prefix 2 -> infixStyle 5 _ -> uncurried - termStyle _ = uncurried -instance Given (IntMap Constant) => Numbered Constant where - fromInt 0 = Builtin CFalse - fromInt 1 = Builtin CTrue - fromInt 2 = Builtin CEquals - fromInt n = IntMap.findWithDefault __ (n-3) given - toInt Constant{conIndex = n} = n+3 - toInt (Builtin CFalse) = 0 - toInt (Builtin CTrue) = 1 - toInt (Builtin CEquals) = 2 +instance Ordered (Extended Constant) where + lessEq t u = {-# SCC lessEq #-} KBO.lessEq t u + lessIn model t u = {-# SCC lessIn #-} KBO.lessIn model t u -instance (Given Order, Given (IntMap Constant)) => Ordered (Extended Constant) where - lessEq = - case given of - KBO -> KBO.lessEq - LPO -> LPO.lessEq - lessIn = - case given of - KBO -> KBO.lessIn - LPO -> LPO.lessIn +data TweeContext = + TweeContext { + ctx_var :: Jukebox.Variable, + ctx_minimal :: Jukebox.Function, + ctx_true :: Jukebox.Function, + ctx_false :: Jukebox.Function, + ctx_equals :: Jukebox.Function, + ctx_type :: Type } -instance Label.Labelled Jukebox.Function where - cache = functionCache +-- Convert back and forth between Twee and Jukebox. +tweeConstant :: TweeContext -> Precedence -> Jukebox.Function -> Extended Constant +tweeConstant TweeContext{..} prec fun + | fun == ctx_minimal = Minimal + | fun == ctx_true = TrueCon + | fun == ctx_false = FalseCon + | fun == ctx_equals = EqualsCon + | otherwise = Function (Constant prec fun (Jukebox.arity fun)) -{-# NOINLINE functionCache #-} -functionCache :: Label.Cache Jukebox.Function -functionCache = Label.mkCache +jukeboxFunction :: TweeContext -> Extended Constant -> Jukebox.Function +jukeboxFunction _ (Function Constant{..}) = con_id +jukeboxFunction TweeContext{..} EqualsCon = ctx_equals +jukeboxFunction TweeContext{..} TrueCon = ctx_true +jukeboxFunction TweeContext{..} FalseCon = ctx_false +jukeboxFunction TweeContext{..} Minimal = ctx_minimal +jukeboxFunction TweeContext{..} (Skolem _) = + error "Skolem variable leaked into rule" -instance Numbered Jukebox.Function where - fromInt n = fromMaybe __ (Label.find n) - toInt = Label.label +tweeTerm :: TweeContext -> (Jukebox.Function -> Precedence) -> Jukebox.Term -> Term (Extended Constant) +tweeTerm ctx prec t = build (tm t) + where + tm (Jukebox.Var (Unique x _ _ ::: _)) = + var (V (fromIntegral x)) + tm (f :@: ts) = + app (fun (tweeConstant ctx (prec f) f)) (map tm ts) -toTwee :: Problem Clause -> ([Equation Jukebox.Function], [Term Jukebox.Function]) -toTwee prob = (lefts eqs, goals) +jukeboxTerm :: TweeContext -> Term (Extended Constant) -> Jukebox.Term +jukeboxTerm TweeContext{..} (Var (V x)) = + Jukebox.Var (Unique (fromIntegral x) "X" defaultRenamer ::: ctx_type) +jukeboxTerm ctx@TweeContext{..} (App f t) = + jukeboxFunction ctx (fun_value f) :@: map (jukeboxTerm ctx) ts where - eq Input{what = Clause (Bind _ [Pos (t Jukebox.:=: u)])} = - Left (tm t :=: tm u) - eq Input{what = Clause (Bind _ [Neg (t Jukebox.:=: u)])} = - Right (tm t :=: tm u) - eq _ = ERROR("Problem is not unit equality") + ts = unpack t - eqs = map eq prob +makeContext :: Problem Clause -> TweeContext +makeContext prob = run prob $ \prob -> do + let + ty = + case types' prob of + [] -> indType + [ty] -> ty - goals = - case rights eqs of - [] -> [] - [t :=: u] -> [t, u] - _ -> ERROR("Problem is not unit equality") + var <- newSymbol "X" ty + minimal <- newFunction "$constant" [] ty + equals <- newFunction "$equals" [ty, ty] ty + false <- newFunction "$false_term" [] ty + true <- newFunction "$true_term" [] ty - tm (Jukebox.Var (Unique x _ _ ::: _)) = - build (var (MkVar (fromIntegral x))) - tm (f :@: ts) = - app f (map tm ts) + return TweeContext { + ctx_var = var, + ctx_minimal = minimal, + ctx_equals = equals, + ctx_false = false, + ctx_true = true, + ctx_type = ty } -addNarrowing :: - Given (IntMap Constant) => - ([Equation (Extended Constant)], [Term (Extended Constant)]) -> - ([Equation (Extended Constant)], [Term (Extended Constant)]) -addNarrowing (axioms, goals) - | length goals < 2 = (axioms, [app false [], app true []]) - where - false = Function (Builtin CFalse) - true = Function (Builtin CTrue) -addNarrowing (axioms, goals) - | length goals >= 2 && all isGround goals = (axioms, goals) -addNarrowing (axioms, [t, u]) - | otherwise = (axioms ++ equalities, [app false [], app true []]) - where - false = Function (Builtin CFalse) - true = Function (Builtin CTrue) - equals = Function (Builtin CEquals) +-- Encode existentials so that all goals are ground. +addNarrowing :: TweeContext -> Problem Clause -> Problem Clause +addNarrowing TweeContext{..} prob = + unchanged ++ equalityClauses + where + (unchanged, nonGroundGoals) = partitionEithers (map f prob) + where + f inp@Input{what = Clause (Bind _ [Neg (x Jukebox.:=: y)])} + | not (ground x) || not (ground y) = + Right (inp, (x, y)) + f inp = Left inp - equalities = - [app equals [build (var (MkVar 0)), build (var (MkVar 0))] :=: app true [], - app equals [t, u] :=: app false []] -addNarrowing _ = - ERROR("Don't know how to handle several non-ground goals") + equalityClauses + | null nonGroundGoals = [] + | otherwise = + -- Turn a != b & c != d & ... + -- into eq(a,b)=false & eq(c,d)=false & eq(X,X)=true & true!=false (esa) + -- and then extract the individual components (thm) + let + equalityLiterals = + -- true != false + ("true_equals_false", Neg ((ctx_true :@:) [] Jukebox.:=: (ctx_false :@: []))): + -- eq(X,X)=true + ("reflexivity", Pos (ctx_equals :@: [Jukebox.Var ctx_var, Jukebox.Var ctx_var] Jukebox.:=: (ctx_true :@: []))): + -- [eq(a,b)=false, eq(c,d)=false, ...] + [ (tag, Pos (ctx_equals :@: [x, y] Jukebox.:=: (ctx_false :@: []))) + | (Input{tag = tag}, (x, y)) <- nonGroundGoals ] -runTwee :: Twee (Extended Constant) -> Order -> [String] -> Problem Clause -> IO Answer -runTwee state order precedence obligs = do - let (axioms0, goals0) = toTwee obligs - prec c = (isNothing (elemIndex (base c) precedence), - fmap negate (elemIndex (base c) precedence), - negate (occ (toFun c) (axioms0, goals0))) - fs0 = map fromFun (usort (funs (axioms0, goals0))) - fs1 = sortBy (comparing prec) fs0 - fs2 = zipWith (\i (c ::: (FunType args _)) -> Constant i (length args) 1 (show c)) [1..] fs1 - m = IntMap.fromList [(conIndex f, f) | f <- fs2] - m' = Map.fromList (zip fs1 (map Function fs2)) - give m $ give order $ do - let replace = build . mapFun (toFun . flip (Map.findWithDefault __) m' . fromFun) - axioms1 = [replace t :=: replace u | t :=: u <- axioms0] - goals1 = map replace goals0 - (axioms2, goals2) = addNarrowing (axioms1, goals1) + -- Equisatisfiable to the input clauses + justification = + Input { + tag = "new_negated_conjecture", + kind = Jukebox.Ax NegatedConjecture, + what = + let form = And (map (Literal . snd) equalityLiterals) in + ForAll (Bind (Set.fromList (vars form)) form), + source = + Inference "encode_existential" "esa" + (map (fmap toForm . fst) nonGroundGoals) } - putStrLn "Axioms:" - mapM_ prettyPrint axioms2 - putStrLn "\nGoals:" - mapM_ prettyPrint goals2 - putStrLn "\nGo!" + input tag form = + Input { + tag = tag, + kind = Conj Conjecture, + what = clause [form], + source = + Inference "split_conjunct" "thm" [justification] } + in [input tag form | (tag, form) <- equalityLiterals] + +data PreEquation = + PreEquation { + pre_name :: String, + pre_form :: Input Form, + pre_eqn :: (Jukebox.Term, Jukebox.Term) } + +-- Split the problem into axioms and ground goals. +identifyProblem :: + TweeContext -> Problem Clause -> Either (Input Clause) ([PreEquation], [PreEquation]) +identifyProblem TweeContext{..} prob = + fmap partitionEithers (mapM identify prob) + + where + pre inp x = + PreEquation { + pre_name = tag inp, + pre_form = fmap toForm inp, + pre_eqn = x } + + identify inp@Input{what = Clause (Bind _ [Pos (t Jukebox.:=: u)])} = + return $ Left (pre inp (t, u)) + identify inp@Input{what = Clause (Bind _ [Neg (t Jukebox.:=: u)])} + | ground t && ground u = + return $ Right (pre inp (t, u)) + identify inp@Input{what = Clause (Bind _ [])} = + -- The empty clause can appear after clausification if + -- the conjecture was trivial + return $ Left (pre inp (Jukebox.Var ctx_var, ctx_minimal :@: [])) + identify inp = Left inp + +runTwee :: GlobalFlags -> TSTPFlags -> MainFlags -> Config -> [String] -> (IO () -> IO ()) -> Problem Clause -> IO Answer +runTwee globals (TSTPFlags tstp) main config precedence later obligs = {-# SCC runTwee #-} do let - identical xs = not (Set.null (foldr1 Set.intersection xs)) + -- Encode whatever needs encoding in the problem + ctx = makeContext obligs + prob = addNarrowing ctx obligs - loop = do - res <- complete1 - goals <- gets goals - when (res && (length goals <= 1 || not (identical goals))) loop + (axioms0, goals0) <- + case identifyProblem ctx prob of + Left inp -> do + mapM_ (hPutStrLn stderr) [ + "The problem contains the following clause, which is not a unit equality:", + indent (show (pPrintClauses [inp])), + "Twee only handles unit equality problems."] + exitWith (ExitFailure 1) + Right x -> return x - s = - flip execState (addGoals (map Set.singleton goals2) state) $ do - mapM_ newEquation axioms2 - loop + let + -- Work out a precedence for function symbols + prec c = + Precedence + (isNothing (elemIndex (base c) precedence)) + (fmap negate (elemIndex (base c) precedence)) + (negate (funOcc c prob)) - rs = map (critical . modelled . peel) (Indexes.elems (labelledRules s)) + -- Translate everything to Twee. + toEquation (t, u) = + canonicalise (tweeTerm ctx prec t :=: tweeTerm ctx prec u) - putStrLn "\nFinal rules:" - mapM_ prettyPrint rs - putStrLn "" + goals = + [ goal n pre_name (toEquation pre_eqn) + | (n, PreEquation{..}) <- zip [1..] goals0 ] + axioms = + [ Axiom n pre_name (toEquation pre_eqn) + | (n, PreEquation{..}) <- zip [1..] axioms0 ] - putStrLn (report s) - putStrLn "Normalised goal terms:" - forM_ goals2 $ \t -> - prettyPrint (Rule Oriented t (result (normalise s t))) + withGoals = foldl' (addGoal config) initialState goals + withAxioms = foldl' (addAxiom config) withGoals axioms + -- Set up tracing. + sayTrace <- + case flags_trace main of + Nothing -> return $ \_ -> return () + Just (file, mod) -> do + h <- openFile file WriteMode + hSetBuffering h LineBuffering + let put msg = hPutStrLn h msg + put $ ":- module(" ++ mod ++ ", [step/1, lemma/1])." + put ":- discontiguous(step/1)." + put ":- discontiguous(lemma/1)." + put ":- style_check(-singleton)." + return $ \msg -> hPutStrLn h msg + + let + say msg = unless (quiet globals) (putStrLn msg) + line = say "" + output = Output { + output_report = \_ -> return (), + output_message = \msg -> do + say (prettyShow msg) + sayTrace (show (traceMsg msg)) } + + traceMsg (NewActive active) = + step "add" [traceActive active] + traceMsg (NewEquation eqn) = + step "hard" [traceEqn eqn] + traceMsg (DeleteActive active) = + step "delete" [traceActive active] + traceMsg SimplifyQueue = + step "simplify_queue" [] + traceMsg Interreduce = + step "interreduce" [] + + traceActive Active{..} = + traceApp "rule" [pPrint active_id, traceEqn (unorient active_rule)] + traceEqn (t :=: u) = + pPrintPrec prettyNormal 6 t <+> text "=" <+> pPrintPrec prettyNormal 6 u + traceApp f xs = + pPrintTerm uncurried prettyNormal 0 (text f) xs + + step :: String -> [Doc] -> Doc + step f xs = traceApp "step" [traceApp f xs] <> text "." + + say "Here is the input problem:" + forM_ axioms $ \Axiom{..} -> + say $ show $ nest 2 $ + describeEquation "Axiom" + (show axiom_number) (Just axiom_name) axiom_eqn + forM_ goals $ \Goal{..} -> + say $ show $ nest 2 $ + describeEquation "Goal" + (show goal_number) (Just goal_name) goal_eqn + line + + state <- complete output config withAxioms + line + + when (solved state && flags_proof main) $ later $ do + let + pres = present (cfg_proof_presentation config) (solutions state) + + sayTrace "" + forM_ (pres_lemmas pres) $ \Lemma{..} -> + sayTrace $ show $ + traceApp "lemma" [traceEqn (equation lemma_proof)] <> text "." + + when tstp $ do + putStrLn "% SZS output start CNFRefutation" + print $ pPrintProof $ + presentToJukebox ctx (curry toEquation) + (zip (map axiom_number axioms) (map pre_form axioms0)) + (zip (map goal_number goals) (map pre_form goals0)) + pres + putStrLn "% SZS output end CNFRefutation" + putStrLn "" + + putStrLn "The conjecture is true! Here is a proof." + putStrLn "" + print $ pPrintPresentation (cfg_proof_presentation config) pres + putStrLn "" + + when (not (quiet globals) && not (solved state)) $ later $ do + let + state' = interreduce config state + score rule = + (size (lhs rule), lhs rule, + size (rhs rule), rhs rule) + actives = + sortBy (comparing (score . active_rule)) $ + IntMap.elems (st_active_ids state') + + when (tstp && configIsComplete config) $ do + putStrLn "% SZS output start Saturation" + print $ pPrintProof $ + map pre_form axioms0 ++ + map pre_form goals0 ++ + [ Input "rule" (Jukebox.Ax Jukebox.Axiom) Unknown $ + toForm $ clause + [Pos (jukeboxTerm ctx (lhs rule) Jukebox.:=: jukeboxTerm ctx (rhs rule))] + | rule <- rules state ] + putStrLn "% SZS output end Saturation" + putStrLn "" + + if configIsComplete config then do + putStrLn "Ran out of critical pairs. This means the conjecture is not true." + else do + putStrLn "Gave up on reaching the given resource limit." + putStrLn "Here is the final rewrite system:" + forM_ actives $ \active -> + putStrLn (" " ++ prettyShow (canonicalise (active_rule active))) + putStrLn "" + return $ - case () of - _ | identical (goals s) -> Unsatisfiable - | isJust (maxSize s) -> NoAnswer GaveUp - | otherwise -> Satisfiable + if solved state then Unsat Unsatisfiable + else if configIsComplete config then Sat Satisfiable + else NoAnswer GaveUp +-- Transform a proof presentation into a Jukebox proof. +presentToJukebox :: + TweeContext -> + (Jukebox.Term -> Jukebox.Term -> Equation (Extended Constant)) -> + -- Axioms, indexed by axiom number. + [(Int, Input Form)] -> + -- N.B. the formula here proves the negated goal. + [(Int, Input Form)] -> + Presentation (Extended Constant) -> + Problem Form +presentToJukebox ctx toEquation axioms goals Presentation{..} = + [ Input { + tag = pg_name, + kind = Jukebox.Ax Jukebox.Axiom, + what = false, + source = + Inference "resolution" "thm" + [-- A proof of t != u + existentialHack pg_goal_hint (fromJust (lookup pg_number goals)), + -- A proof of t = u + fromJust (Map.lookup pg_number goal_proofs)] } + | ProvedGoal{..} <- pres_goals ] + + where + axiom_proofs = + Map.fromList + [ (axiom_number, fromJust (lookup axiom_number axioms)) + | Axiom{..} <- pres_axioms ] + + lemma_proofs = + Map.fromList [(lemma_id, tstp lemma_proof) | Lemma{..} <- pres_lemmas] + + goal_proofs = + Map.fromList [(pg_number, tstp pg_proof) | ProvedGoal{..} <- pres_goals] + + tstp :: Proof (Extended Constant) -> Input Form + tstp = deriv . derivation + + deriv :: Derivation (Extended Constant) -> Input Form + deriv p@(Trans q r) = derivFrom (deriv r:sources q) p + deriv p = derivFrom (sources p) p + + derivFrom :: [Input Form] -> Derivation (Extended Constant) -> Input Form + derivFrom sources p = + Input { + tag = "step", + kind = Jukebox.Ax Jukebox.Axiom, + what = jukeboxEquation (equation (certify p)), + source = + Inference "rw" "thm" sources } + + jukeboxEquation :: Equation (Extended Constant) -> Form + jukeboxEquation (t :=: u) = + toForm $ clause [Pos (jukeboxTerm ctx t Jukebox.:=: jukeboxTerm ctx u)] + + sources :: Derivation (Extended Constant) -> [Input Form] + sources p = + [ fromJust (Map.lookup lemma_id lemma_proofs) + | Lemma{..} <- usortBy (comparing lemma_id) (usedLemmas p) ] ++ + [ fromJust (Map.lookup axiom_number axiom_proofs) + | Axiom{..} <- usort (usedAxioms p) ] + + -- An ugly hack: since Twee.Proof decodes $true = $false into a + -- proof of the existentially quantified goal, we need to do the + -- same decoding at the Jukebox level. + existentialHack eqn input = + case find input of + [] -> error $ "bug in TSTP output: can't fix up decoded existential" + (inp:_) -> inp + where + -- Check if this looks like the correct clause; + -- if not, try its ancestors. + find inp | ok inp = [inp] + find Input{source = Inference _ _ inps} = + concatMap find inps + find _ = [] + + ok inp = + case toClause (what inp) of + Nothing -> False + Just (Clause (Bind _ [Neg (t' Jukebox.:=: u')])) -> + let + eqn' = toEquation t' u' + ts = buildList [eqn_lhs eqn, eqn_rhs eqn] + us = buildList [eqn_lhs eqn', eqn_rhs eqn'] + in + isJust (matchList ts us) && isJust (matchList us ts) + main = do - let twee = Tool "twee" "twee - the Wonderful Equation Engine" "1" "Proves equations." - join . parseCommandLine twee . tool twee $ - greetingBox twee =>> - allFilesBox <*> - (parseProblemBox =>>= - toFofBox =>>= - clausifyBox =>>= - allObligsBox <*> - (runTwee <$> parseInitialState <*> parseOrder <*> parsePrecedence)) + let + -- Always use splitting + clausifyBox = + pure (\prob -> return $! clausify (ClausifyFlags True) prob) + hSetBuffering stdout LineBuffering + join . parseCommandLine "Twee, an equational theorem prover" . + version ("twee version " ++ VERSION_twee) $ + globalFlags *> parseMainFlags *> + -- hack: get --quiet and --no-proof options to appear before --tstp + forAllFilesBox <*> + (readProblemBox =>>= + expert (toFof <$> clausifyBox <*> pure (tags True)) =>>= + expert clausifyBox =>>= + forAllConjecturesBox <*> + (runTwee <$> globalFlags <*> tstpFlags <*> parseMainFlags <*> parseConfig <*> parsePrecedence)) diff --git a/src/Data/Primitive/ByteArray/Checked.hs b/src/Data/Primitive/ByteArray/Checked.hs new file mode 100644 --- /dev/null +++ b/src/Data/Primitive/ByteArray/Checked.hs @@ -0,0 +1,71 @@ +{-# LANGUAGE ScopedTypeVariables #-} +module Data.Primitive.ByteArray.Checked( + module Data.Primitive.ByteArray, + module Data.Primitive.ByteArray.Checked) where + +import Control.Monad.Primitive +import qualified Data.Primitive.ByteArray as P +import Data.Primitive(Prim) +import Data.Primitive.ByteArray( + ByteArray(..), MutableByteArray(..), + newByteArray, newPinnedByteArray, newAlignedPinnedByteArray, + byteArrayContents, mutableByteArrayContents, + sameMutableByteArray, + unsafeFreezeByteArray, unsafeThawByteArray, + sizeofByteArray, sizeofMutableByteArray) +import Data.Primitive.Checked +import Data.Word + +instance Sized ByteArray where + size = sizeofByteArray +instance Sized (MutableByteArray m) where + size = sizeofMutableByteArray + +{-# INLINE readByteArray #-} +readByteArray :: forall m a. (PrimMonad m, Prim a) => MutableByteArray (PrimState m) -> Int -> m a +readByteArray arr n = + checkPrim (undefined :: a) arr n $ + P.readByteArray arr n + +{-# INLINE writeByteArray #-} +writeByteArray :: (PrimMonad m, Prim a) => MutableByteArray (PrimState m) -> Int -> a -> m () +writeByteArray arr n x = + checkPrim x arr n $ + P.writeByteArray arr n x + +{-# INLINE indexByteArray #-} +indexByteArray :: forall a. Prim a => ByteArray -> Int -> a +indexByteArray arr n = + checkPrim (undefined :: a) arr n $ + P.indexByteArray arr n + +{-# INLINE copyByteArray #-} +copyByteArray :: PrimMonad m => MutableByteArray (PrimState m) -> Int -> ByteArray -> Int -> Int -> m () +copyByteArray arr1 n1 arr2 n2 len = + range arr1 n1 len $ + range arr2 n2 len $ + P.copyByteArray arr1 n1 arr2 n2 len + +{-# INLINE moveByteArray #-} +moveByteArray :: PrimMonad m => MutableByteArray (PrimState m) -> Int -> MutableByteArray (PrimState m) -> Int -> Int -> m () +moveByteArray arr1 n1 arr2 n2 len = + range arr1 n1 len $ + range arr2 n2 len $ + P.moveByteArray arr1 n1 arr2 n2 len + +{-# INLINE copyMutableByteArray #-} +copyMutableByteArray :: PrimMonad m => MutableByteArray (PrimState m) -> Int -> MutableByteArray (PrimState m) -> Int -> Int -> m () +copyMutableByteArray arr1 n1 arr2 n2 len = + range arr1 n1 len $ + range arr2 n2 len $ + P.copyMutableByteArray arr1 n1 arr2 n2 len + +{-# INLINE setByteArray #-} +setByteArray :: (Prim a, PrimMonad m) => MutableByteArray (PrimState m) -> Int -> Int -> a -> m () +setByteArray arr n len x = + rangePrim x arr n len $ + P.setByteArray arr n len x + +{-# INLINE fillByteArray #-} +fillByteArray :: PrimMonad m => MutableByteArray (PrimState m) -> Int -> Int -> Word8 -> m () +fillByteArray = setByteArray diff --git a/src/Data/Primitive/Checked.hs b/src/Data/Primitive/Checked.hs new file mode 100644 --- /dev/null +++ b/src/Data/Primitive/Checked.hs @@ -0,0 +1,32 @@ +module Data.Primitive.Checked where + +import Data.Primitive(Prim, sizeOf) + +class Sized a where + size :: a -> Int + +{-# INLINE check #-} +check :: Sized a => a -> Int -> b -> b +check arr n x + | n >= 0 && n < size arr = x + | otherwise = error "out-of-bounds array access" + +{-# INLINE range #-} +range :: Sized a => a -> Int -> Int -> b -> b +range arr n len x + | len < 0 = error "array slice has negative length" + | len == 0 = x + | otherwise = + check arr n $ + check arr (n+len-1) $ x + +{-# INLINE checkPrim #-} +checkPrim :: (Sized a, Prim b) => b -> a -> Int -> c -> c +checkPrim x arr n res = + range arr (n*sizeOf x) (sizeOf x) res + +{-# INLINE rangePrim #-} +rangePrim :: (Sized a, Prim b) => b -> a -> Int -> Int -> c -> c +rangePrim x arr n len res = + range arr (n*sizeOf x) (len*sizeOf x) res + diff --git a/src/Data/Primitive/SmallArray/Checked.hs b/src/Data/Primitive/SmallArray/Checked.hs new file mode 100644 --- /dev/null +++ b/src/Data/Primitive/SmallArray/Checked.hs @@ -0,0 +1,77 @@ +module Data.Primitive.SmallArray.Checked( + module Data.Primitive.SmallArray, + module Data.Primitive.SmallArray.Checked) where + +import Control.Monad.Primitive +import qualified Data.Primitive.SmallArray as P +import Data.Primitive.SmallArray( + SmallArray(..), SmallMutableArray(..), newSmallArray, unsafeFreezeSmallArray, + unsafeThawSmallArray, sizeofSmallArray, sizeofSmallMutableArray) +import Data.Primitive.Checked + +instance Sized (SmallArray a) where + size = sizeofSmallArray +instance Sized (SmallMutableArray m a) where + size = sizeofSmallMutableArray + +{-# INLINE readSmallArray #-} +readSmallArray :: PrimMonad m => SmallMutableArray (PrimState m) a -> Int -> m a +readSmallArray arr n = + check arr n $ + P.readSmallArray arr n + +{-# INLINE writeSmallArray #-} +writeSmallArray :: PrimMonad m => SmallMutableArray (PrimState m) a -> Int -> a -> m () +writeSmallArray arr n x = + check arr n $ + P.writeSmallArray arr n x + +{-# INLINE indexSmallArrayM #-} +indexSmallArrayM :: Monad m => SmallArray a -> Int -> m a +indexSmallArrayM arr n = + check arr n $ + P.indexSmallArrayM arr n + +{-# INLINE indexSmallArray #-} +indexSmallArray :: SmallArray a -> Int -> a +indexSmallArray arr n = + check arr n $ + P.indexSmallArray arr n + +{-# INLINE cloneSmallArray #-} +cloneSmallArray :: SmallArray a -> Int -> Int -> SmallArray a +cloneSmallArray arr n len = + range arr n len $ + P.cloneSmallArray arr n len + +{-# INLINE cloneSmallMutableArray #-} +cloneSmallMutableArray :: PrimMonad m => SmallMutableArray (PrimState m) a -> Int -> Int -> m (SmallMutableArray (PrimState m) a) +cloneSmallMutableArray arr n len = + range arr n len $ + P.cloneSmallMutableArray arr n len + +{-# INLINE freezeSmallArray #-} +freezeSmallArray :: PrimMonad m => SmallMutableArray (PrimState m) a -> Int -> Int -> m (SmallArray a) +freezeSmallArray arr n len = + range arr n len $ + P.freezeSmallArray arr n len + +{-# INLINE thawSmallArray #-} +thawSmallArray :: PrimMonad m => SmallArray a -> Int -> Int -> m (SmallMutableArray (PrimState m) a) +thawSmallArray arr n len = + range arr n len $ + P.thawSmallArray arr n len + +{-# INLINE copySmallArray #-} +copySmallArray :: PrimMonad m => SmallMutableArray (PrimState m) a -> Int -> SmallArray a -> Int -> Int -> m () +copySmallArray arr1 n1 arr2 n2 len = + range arr1 n1 len $ + range arr2 n2 len $ + P.copySmallArray arr1 n1 arr2 n2 len + +{-# INLINE copySmallMutableArray #-} +copySmallMutableArray :: PrimMonad m => SmallMutableArray (PrimState m) a -> Int -> SmallMutableArray (PrimState m) a -> Int -> Int -> m () +copySmallMutableArray arr1 n1 arr2 n2 len = + range arr1 n1 len $ + range arr2 n2 len $ + P.copySmallMutableArray arr1 n1 arr2 n2 len diff --git a/src/Twee.hs b/src/Twee.hs --- a/src/Twee.hs +++ b/src/Twee.hs @@ -1,982 +1,666 @@ --- Knuth-Bendix completion, with lots of exciting tricks for --- unorientable equations. - -{-# LANGUAGE CPP, TypeFamilies, FlexibleContexts, RecordWildCards, ScopedTypeVariables, UndecidableInstances, StandaloneDeriving, PatternGuards, BangPatterns #-} -module Twee where - -#include "errors.h" -import Twee.Base hiding (empty, lookup) -import Twee.Constraints hiding (funs) -import Twee.Rule -import qualified Twee.Indexes as Indexes -import Twee.Indexes(Indexes, Rated(..)) -import qualified Twee.Index as Index -import Twee.Index(Index, Frozen) -import Twee.Queue hiding (queue) -import Twee.Utils -import Control.Monad -import Data.Maybe -import Data.Ord -import qualified Debug.Trace -import Control.Monad.Trans.State.Strict -import Data.List -import Text.Printf -import qualified Data.Set as Set -import Data.Set(Set) -import Data.Either -import qualified Data.Map.Strict as Map -import Data.Map.Strict(Map) - --------------------------------------------------------------------------------- --- Completion engine state. --------------------------------------------------------------------------------- - -data Twee f = - Twee { - maxSize :: Maybe Int, - labelledRules :: {-# UNPACK #-} !(Indexes (Labelled (Modelled (Critical (Rule f))))), - extraRules :: {-# UNPACK #-} !(Indexes (Rule f)), - cancellationRules :: !(Index (Labelled (CancellationRule f))), - goals :: [Set (Term f)], - totalCPs :: Int, - processedCPs :: Int, - renormaliseAt :: Int, - minimumCPSetSize :: Int, - cpSplits :: Int, - queue :: !(Queue (Mix (Either1 FIFO Heap)) (Passive f)), - useGeneralSuperpositions :: Bool, - useGroundJoining :: Bool, - useConnectedness :: Bool, - useSetJoining :: Bool, - useSetJoiningForGoals :: Bool, - useCancellation :: Bool, - maxCancellationSize :: Maybe Int, - atomicCancellation :: Bool, - unifyConstantsInCancellation :: Bool, - useInterreduction :: Bool, - useUnsafeInterreduction :: Bool, - skipCompositeSuperpositions :: Bool, - tracing :: Bool, - moreTracing :: Bool, - lhsWeight :: Int, - rhsWeight :: Int, - joinStatistics :: Map JoinReason Int } - deriving Show - -initialState :: Int -> Int -> Twee f -initialState mixFIFO mixPrio = - Twee { - maxSize = Nothing, - labelledRules = Indexes.empty, - extraRules = Indexes.empty, - cancellationRules = Index.Nil, - goals = [], - totalCPs = 0, - processedCPs = 0, - renormaliseAt = 50, - minimumCPSetSize = 20, - cpSplits = 20, - queue = empty (emptyMix mixFIFO mixPrio (Left1 emptyFIFO) (Right1 emptyHeap)), - useGeneralSuperpositions = True, - useGroundJoining = True, - useConnectedness = True, - useSetJoining = False, - useSetJoiningForGoals = True, - useInterreduction = False, - useUnsafeInterreduction = True, - useCancellation = True, - atomicCancellation = True, - maxCancellationSize = Nothing, - unifyConstantsInCancellation = False, - skipCompositeSuperpositions = True, - tracing = True, - moreTracing = False, - lhsWeight = 2, - rhsWeight = 1, - joinStatistics = Map.empty } - -addGoals :: [Set (Term f)] -> Twee f -> Twee f -addGoals gs s = s { goals = gs ++ goals s } - -report :: Function f => Twee f -> String -report Twee{..} = - printf "Rules: %d total, %d oriented, %d unoriented, %d permutative, %d weakly oriented. " - (length rs) - (length [ () | Rule Oriented _ _ <- rs ]) - (length [ () | Rule Unoriented _ _ <- rs ]) - (length [ () | (Rule (Permutative _) _ _) <- rs ]) - (length [ () | (Rule (WeaklyOriented _) _ _) <- rs ]) ++ - printf "%d extra. %d historical.\n" - (length (Indexes.elems extraRules)) - n ++ - printf "Critical pairs: %d total, %d processed, %d queued compressed into %d.\n\n" - totalCPs - processedCPs - s - (length (toList queue)) ++ - printf "Critical pairs joined:\n" ++ - concat [printf "%6d %s.\n" n (prettyShow x) | (x, n) <- Map.toList joinStatistics] - where - rs = map (critical . modelled . peel) (Indexes.elems labelledRules) - Label n = nextLabel queue - s = sum (map passiveCount (toList queue)) - -enqueueM :: Function f => Passive f -> State (Twee f) () -enqueueM cps = do - traceM (NewCP cps) - modify' $ \s -> s { - queue = enqueue cps (queue s), - totalCPs = totalCPs s + passiveCount cps } - -reenqueueM :: Function f => Passive f -> State (Twee f) () -reenqueueM cps = do - modify' $ \s -> s { - queue = reenqueue cps (queue s) } - -dequeueM :: Function f => State (Twee f) (Maybe (Passive f)) -dequeueM = - state $ \s -> - case dequeue (queue s) of - Nothing -> (Nothing, s) - Just (x, q) -> (Just x, s { queue = q }) - -newLabelM :: State (Twee f) Label -newLabelM = - state $ \s -> - case newLabel (queue s) of - (l, q) -> (l, s { queue = q }) - -data Modelled a = - Modelled { - model :: Model (ConstantOf a), - positions :: [Int], - modelled :: a } - -instance Eq a => Eq (Modelled a) where x == y = modelled x == modelled y -instance Ord a => Ord (Modelled a) where compare = comparing modelled - -instance (PrettyTerm (ConstantOf a), Pretty a) => Pretty (Modelled a) where - pPrint Modelled{..} = pPrint modelled - -deriving instance (Show a, Show (ConstantOf a)) => Show (Modelled a) - -instance Symbolic a => Symbolic (Modelled a) where - type ConstantOf (Modelled a) = ConstantOf a - - term = term . modelled - termsDL = termsDL . modelled - replace f Modelled{..} = Modelled model positions (replace f modelled) - --------------------------------------------------------------------------------- --- Rewriting. --------------------------------------------------------------------------------- - -instance Rated a => Rated (Labelled a) where - rating = rating . peel - maxRating = maxRating . peel -instance Rated a => Rated (Modelled a) where - rating = rating . modelled - maxRating = maxRating . modelled -instance Rated a => Rated (Critical a) where - rating = rating . critical - maxRating = maxRating . critical -instance Rated (Rule f) where - rating (Rule Oriented _ _) = 0 - rating (Rule WeaklyOriented{} _ _) = 0 - rating _ = 1 - maxRating _ = 1 - -{-# INLINE rulesFor #-} -rulesFor :: Function f => Int -> Twee f -> Frozen (Rule f) -rulesFor n k = - Index.map (critical . modelled . peel) (Indexes.freeze n (labelledRules k)) - -easyRules, rules, allRules :: Function f => Twee f -> Frozen (Rule f) -easyRules k = rulesFor 0 k -rules k = rulesFor 1 k `Index.union` Indexes.freeze 0 (extraRules k) -allRules k = rulesFor 1 k `Index.union` Indexes.freeze 1 (extraRules k) - -normaliseQuickly :: Function f => Twee f -> Term f -> Reduction f -normaliseQuickly s t = normaliseWith (rewrite "simplify" simplifies (easyRules s)) t - -normalise :: Function f => Twee f -> Term f -> Reduction f -normalise s t = normaliseWith (rewrite "reduce" reduces (rules s)) t - -normaliseIn :: Function f => Twee f -> Model f -> Term f -> Reduction f -normaliseIn s model t = - normaliseWith (rewrite "model" (reducesInModel model) (rules s)) t - -normaliseSub :: Function f => Twee f -> Term f -> Term f -> Reduction f -normaliseSub s top t - | useConnectedness s && lessEq t top && isNothing (unify t top) = - normaliseWith (rewrite "sub" (reducesSub top) (rules s)) t - | otherwise = Parallel [] t - -normaliseSkolem :: Function f => Twee f -> Term f -> Reduction f -normaliseSkolem s t = normaliseWith (rewrite "skolem" reducesSkolem (rules s)) t - -reduceCP :: - Function f => - Twee f -> JoinStage -> (Term f -> Term f) -> - Critical (Equation f) -> Either JoinReason (Critical (Equation f)) -reduceCP s stage f (Critical top (t :=: u)) - | t' == u' = Left (Trivial stage) - | subsumed s t' u' = Left (Subsumed stage) - | otherwise = Right (Critical top (t' :=: u')) - where - t' = f t - u' = f u - - subsumed s t u = here || there t u - where - here = - or [ rhs x == u | x <- Index.lookup t rs ] - there (Var x) (Var y) | x == y = True - there (Fun f ts) (Fun g us) | f == g = and (zipWith (subsumed s) (fromTermList ts) (fromTermList us)) - there _ _ = False - rs = allRules s - -data JoinStage = Initial | Simplification | Reducing | Subjoining deriving (Eq, Ord, Show) -data JoinReason = Trivial JoinStage | Subsumed JoinStage | SetJoining | GroundJoined deriving (Eq, Ord, Show) - -instance Pretty JoinStage where - pPrint Initial = text "no rewriting" - pPrint Simplification = text "simplification" - pPrint Reducing = text "reduction" - pPrint Subjoining = text "connectedness testing" - -instance Pretty JoinReason where - pPrint (Trivial stage) = text "joined after" <+> pPrint stage - pPrint (Subsumed stage) = text "subsumed after" <+> pPrint stage - pPrint SetJoining = text "joined with set of normal forms" - pPrint GroundJoined = text "ground joined" - -normaliseCPQuickly, normaliseCPReducing, normaliseCP :: - Function f => - Twee f -> Critical (Equation f) -> Either JoinReason (Critical (Equation f)) -normaliseCPQuickly s cp = - reduceCP s Initial id cp >>= - reduceCP s Simplification (result . normaliseQuickly s) - -normaliseCPReducing s cp = - normaliseCPQuickly s cp >>= - reduceCP s Reducing (result . normalise s) - -normaliseCP s cp@(Critical info _) = - case (cp1, cp2, cp3, cp4) of - (Right cp, Right _, Right _, Right _) -> Right cp - (Right _, Right _, Right _, Left x) -> Left x - (Right _, Right _, Left x, _) -> Left x - (Right _, Left x, _, _) -> Left x - (Left x, _, _, _) -> Left x - where - cp1 = - normaliseCPReducing s cp >>= - reduceCP s Subjoining (result . normaliseSub s (top info)) - - cp2 = - normaliseCPReducing s cp >>= - reduceCP s Subjoining (result . normaliseSub s (flipCP (top info))) . flipCP - - cp3 = setJoin cp - cp4 = setJoin (flipCP cp) - - flipCP :: Symbolic a => a -> a - flipCP t = replace (substList sub) t - where - n = maximum (0:map fromEnum (vars t)) - sub (MkVar x) = var (MkVar (n - x)) - - -- XXX shouldn't this also check subsumption? - setJoin (Critical info (t :=: u)) - | not (useSetJoining s) || - Set.null (norm t `Set.intersection` norm u) = - Right (Critical info (t :=: u)) - | otherwise = - Debug.Trace.traceShow (sep [text "Joined", nest 2 (pPrint (Critical info (t :=: u))), text "to", nest 2 (pPrint v)]) - Left SetJoining - where - norm t - | lessEq t (top info) && isNothing (unify t (top info)) = - normalForms (rewrite "setjoin" (reducesSub (top info)) (rules s)) [t] - | otherwise = Set.singleton t - v = Set.findMin (norm t `Set.intersection` norm u) - --------------------------------------------------------------------------------- --- Completion loop. --------------------------------------------------------------------------------- - -complete :: Function f => State (Twee f) () -complete = do - res <- complete1 - when res complete - -complete1 :: Function f => State (Twee f) Bool -complete1 = do - Twee{..} <- get - let Label n = nextLabel queue - when (n >= renormaliseAt) $ do - normaliseCPs - modify (\s -> s { renormaliseAt = renormaliseAt * 3 `div` 2 }) - - res <- dequeueM - case res of - Just (SingleCP (CP info cp l1 l2)) -> do - res <- consider (cpWeight info) l1 l2 cp - when res renormaliseGoals - return True - Just (ManyCPs (CPs _ l lower upper size rule)) -> do - s <- get - modify (\s@Twee{..} -> s { totalCPs = totalCPs - size }) - - queueCPsSplit reenqueueM lower (l-1) rule - mapM_ (reenqueueM . SingleCP) (toCPs s l l rule) - queueCPsSplit reenqueueM (l+1) upper rule - complete1 - Nothing -> - return False - -renormaliseGoals :: Function f => State (Twee f) () -renormaliseGoals = do - Twee{..} <- get - if useSetJoiningForGoals then - modify $ \s -> s { goals = map (normalForms (rewrite "goal" reduces (rules s)) . Set.toList) goals } - else - modify $ \s -> s { goals = map (Set.fromList . map (result . normaliseWith (rewrite "goal" reduces (rules s))) . Set.toList) goals } - -normaliseCPs :: forall f. Function f => State (Twee f) () -normaliseCPs = do - s@Twee{..} <- get - traceM (NormaliseCPs s) - put s { queue = emptyFrom queue } - forM_ (toList queue) $ \cp -> - case cp of - SingleCP (CP _ cp l1 l2) -> queueCP enqueueM trivial l1 l2 cp - ManyCPs (CPs _ _ lower upper _ rule) -> queueCPs enqueueM lower upper (const ()) rule - modify (\s -> s { totalCPs = totalCPs }) - -consider :: - Function f => - Int -> Label -> Label -> Critical (Equation f) -> State (Twee f) Bool -consider w l1 l2 pair = do - traceM (Consider pair) - modify' (\s -> s { processedCPs = processedCPs s + 1 }) - s <- get - let record reason = modify' (\s -> s { joinStatistics = Map.insertWith (+) reason 1 (joinStatistics s) }) - hard (Trivial Subjoining) = True - hard (Subsumed Subjoining) = True - hard SetJoining = True - hard _ = False - tooBig (Critical _ (t :=: u)) = - case maxSize s of - Nothing -> False - Just sz -> size t > sz || size u > sz - if tooBig pair then return False else - case normaliseCP s pair of - Left reason -> do - record reason - when (hard reason) $ forM_ (map canonicalise (orient (critical pair))) $ \(Rule _ t u0) -> do - s <- get - let u = result (normaliseSub s t u0) - r = rule t u - addExtraRule r - traceM (Joined pair reason) - return False - Right pair | tooBig pair -> - return False - Right pair@(Critical _ eq) - | cancelledWeight s (groundJoinableEq s) eq > w -> do - traceM (Delay pair) - queueCP enqueueM (groundJoinableEq s) l1 l2 pair - return False - Right pair@(Critical _ eq) - | (_, eq') <- bestCancellation s (groundJoinableEq s) eq, - eq /= eq' -> do - traceM (Cancel pair eq') - res <- consider maxBound l1 l2 (Critical noCritInfo eq') - s <- get - queueCP enqueueM (groundJoinableEq s) l1 l2 pair - return res - Right (Critical info eq) -> - fmap or $ forM (map canonicalise (orient eq)) $ \r0@(Rule _ t u0) -> do - s <- get - let u = result (normaliseSub s t u0) - r = rule t u - info' = info { top = t } - case normaliseCP s (Critical info' (t :=: u)) of - Left reason -> do - when (hard reason) $ record reason - addExtraRule r - addExtraRule r0 - return False - Right eq -> - case groundJoin s (branches (And [])) eq of - Right eqs -> do - record GroundJoined - mapM_ (consider maxBound l1 l2) [ eq { critInfo = info' } | eq <- eqs ] - addExtraRule r - addExtraRule r0 - return False - Left model -> do - traceM (NewRule r) - l <- addRule (Modelled model (ruleOverlaps s (lhs r)) (Critical info r)) - queueCPsSplit enqueueM noLabel l (Labelled l r) - interreduce r - return True - -groundJoinableEq :: Function f => Twee f -> Equation f -> Bool -groundJoinableEq s eq = groundJoinable s (Critical noCritInfo eq) - -groundJoinable :: Function f => Twee f -> Critical (Equation f) -> Bool -groundJoinable s pair = - case normaliseCP s pair of - Left _ -> True - Right pair' -> - case groundJoin s (branches (And [])) pair' of - Left _ -> False - Right pairs -> all (groundJoinable s) pairs - -groundJoin :: Function f => - Twee f -> [Branch f] -> Critical (Equation f) -> Either (Model f) [Critical (Equation f)] -groundJoin s ctx r@(Critical info (t :=: u)) = - case partitionEithers (map (solve (usort (atoms t ++ atoms u))) ctx) of - ([], instances) -> - let rs = [ subst sub r | sub <- instances ] in - Right (usort (map canonicalise rs)) - (model:_, _) - | not (useGroundJoining s) -> Left model - | isRight (normaliseCP s (Critical info (t' :=: u'))) -> Left model - | otherwise -> - let model1 = optimise model weakenModel (\m -> valid m nt && valid m nu) - model2 = optimise model1 weakenModel (\m -> isLeft (normaliseCP s (Critical info (result (normaliseIn s m t) :=: result (normaliseIn s m u))))) - - diag [] = Or [] - diag (r:rs) = negateFormula r ||| (weaken r &&& diag rs) - weaken (LessEq t u) = Less t u - weaken x = x - ctx' = formAnd (diag (modelToLiterals model2)) ctx in - - trace s (Discharge r model2) $ - groundJoin s ctx' r - where - nt = normaliseIn s model t - nu = normaliseIn s model u - t' = result nt - u' = result nu - -valid :: Function f => Model f -> Reduction f -> Bool -valid model red = all valid1 (steps red) - where - valid1 (rule, sub) = reducesInModel model rule sub - -optimise :: a -> (a -> [a]) -> (a -> Bool) -> a -optimise x f p = - case filter p (f x) of - y:_ -> optimise y f p - _ -> x - -addRule :: Function f => Modelled (Critical (Rule f)) -> State (Twee f) Label -addRule rule = do - l <- newLabelM - modify (\s -> s { labelledRules = Indexes.insert (Labelled l rule) (labelledRules s) }) - modify (addCancellationRule l (critical (modelled rule))) - return l - -addExtraRule :: Function f => Rule f -> State (Twee f) () -addExtraRule rule = do - s <- get - when (extraRuleSafe s rule) $ do - traceM (ExtraRule rule) - modify (\s -> s { extraRules = Indexes.insert rule (extraRules s) }) - -extraRuleSafe :: Function f => Twee f -> Rule f -> Bool -extraRuleSafe s _ | useUnsafeInterreduction s = True -extraRuleSafe s (Rule _ l _) = - null $ do - Index.Match (Rule _ l' _) _ <- Index.matches l (allRules s) - guard (l' `isInstanceOf` l) - -deleteRule :: Function f => Label -> Modelled (Critical (Rule f)) -> State (Twee f) () -deleteRule l rule = do - modify $ \s -> - s { labelledRules = Indexes.delete (Labelled l rule) (labelledRules s), - queue = deleteLabel l (queue s) } - modify (deleteCancellationRule l (critical (modelled rule))) - -data Simplification f = Simplify (Model f) (Modelled (Critical (Rule f))) | Reorient (Modelled (Critical (Rule f))) deriving Show - -instance (Numbered f, PrettyTerm f) => Pretty (Simplification f) where - pPrint (Simplify _ rule) = text "Simplify" <+> pPrint rule - pPrint (Reorient rule) = text "Reorient" <+> pPrint rule - -interreduce :: Function f => Rule f -> State (Twee f) () -interreduce new = do - rules <- gets (\s -> Indexes.elems (labelledRules s)) - forM_ rules $ \(Labelled l old) -> do - s <- get - case reduceWith s l new old of - Nothing -> return () - Just red -> do - traceM (Reduce red new) - case red of - Simplify model rule -> simplifyRule l model rule - Reorient rule@(Modelled _ _ (Critical info (Rule _ t u))) -> - when (useInterreduction s) $ do - deleteRule l rule - consider maxBound noLabel noLabel (Critical info (t :=: u)) - return () - -reduceWith :: Function f => Twee f -> Label -> Rule f -> Modelled (Critical (Rule f)) -> Maybe (Simplification f) -reduceWith s lab new old0@(Modelled model _ (Critical info old@(Rule _ l r))) - | not (isWeak new) && - not (lhs new `isInstanceOf` l) && - not (null (anywhere (tryRule reduces new) l)) = - Just (Reorient old0) - | not (isWeak new) && - not (lhs new `isInstanceOf` l) && - not (oriented (orientation new)) && - not (all isNothing [ match (lhs new) l' | l' <- subterms l ]) && - modelJoinable = - tryGroundJoin - | not (null (anywhere (tryRule reduces new) (rhs old))) = - Just (Simplify model old0) - | not (oriented (orientation old)) && - not (oriented (orientation new)) && - not (lhs new `isInstanceOf` r) && - not (all isNothing [ match (lhs new) r' | r' <- subterms r ]) && - modelJoinable = - tryGroundJoin - | otherwise = Nothing - where - s' = s { labelledRules = Indexes.delete (Labelled lab old0) (labelledRules s) } - modelJoinable = isLeft (normaliseCP s' (Critical info (lm :=: rm))) - lm = result (normaliseIn s' model l) - rm = result (normaliseIn s' model r) - tryGroundJoin = - case groundJoin s' (branches (And [])) (Critical info (l :=: r)) of - Left model' -> - Just (Simplify model' old0) - Right _ -> - Just (Reorient old0) - isWeak (Rule (WeaklyOriented _) _ _) = True - isWeak _ = False - -simplifyRule :: Function f => Label -> Model f -> Modelled (Critical (Rule f)) -> State (Twee f) () -simplifyRule l model r@(Modelled _ positions (Critical info (Rule _ lhs rhs))) = do - modify $ \s -> - s { - labelledRules = - Indexes.insert (Labelled l (Modelled model positions (Critical info (rule lhs (result (normalise s rhs)))))) - (Indexes.delete (Labelled l r) (labelledRules s)) } - modify (deleteCancellationRule l (critical (modelled r))) - modify (addCancellationRule l (critical (modelled r))) - -newEquation :: Function f => Equation f -> State (Twee f) () -newEquation (t :=: u) = do - consider maxBound noLabel noLabel (Critical noCritInfo (t :=: u)) - renormaliseGoals - return () - -noCritInfo :: Function f => CritInfo f -noCritInfo = CritInfo minimalTerm 0 - --------------------------------------------------------------------------------- --- Cancellation rules. --------------------------------------------------------------------------------- - -data CancellationRule f = - CancellationRule { - cr_unified :: [[Term f]], - cr_rule :: {-# UNPACK #-} !(Rule f) } - deriving Show - -instance (Numbered f, PrettyTerm f) => Pretty (CancellationRule f) where - pPrint (CancellationRule tss rule) = - pPrint rule <+> text "cancelling" <+> pPrint tss - -instance Symbolic (CancellationRule f) where - type ConstantOf (CancellationRule f) = f - term (CancellationRule _ rule) = term rule - termsDL (CancellationRule tss rule) = - termsDL rule `mplus` termsDL tss - replace sub (CancellationRule tss rule) = - CancellationRule (replace sub tss) (replace sub rule) - -toCancellationRule :: Function f => Twee f -> Rule f -> Maybe (CancellationRule f) -toCancellationRule _ (Rule Permutative{} _ _) = Nothing -toCancellationRule _ (Rule WeaklyOriented{} _ _) = Nothing -toCancellationRule s (Rule or l r) - | not (null vs) && - (not (atomicCancellation s) || atomic r) = - Just (CancellationRule tss (Rule or' l' r)) - | otherwise = Nothing - where - consts = unifyConstantsInCancellation s - atomic (Var _) = True - atomic (Fun _ Empty) = True - atomic _ = False - - -- Variables that occur on lhs more than once, but not rhs - vs = usort (vars l \\ usort (vars l)) \\ usort (vars r) - cs = usort [ c | consts, Fun c Empty <- subterms l ] - - n = bound l `max` bound r - - l' = build (freshenVars (n + length cs) (singleton l)) - freshenVars !_ Empty = mempty - freshenVars n (Cons (Var x) ts) = - var y `mappend` freshenVars (n+1) ts - where - y = if x `elem` vs then MkVar n else x - freshenVars i (Cons (Fun f Empty) ts) | f `elem` cs = - var (MkVar m) `mappend` freshenVars (i+1) ts - where - m = n + fromMaybe __ (elemIndex f cs) - freshenVars n (Cons (Fun f ts) us) = - fun f (freshenVars (n+1) ts) `mappend` - freshenVars (n+lenList ts+1) us - - tss = - map (map (build . var . snd)) (partitionBy fst pairs) ++ - zipWith (\i c -> [build (con c), build (var (MkVar i))]) [n..] cs - pairs = concat (zipWith f (subterms l) (subterms l')) - where - f (Var x) (Var y) - | x `elem` vs = [(x, y)] - f _ _ = [] - - or' = subst (var . f) or - where - f x = fromMaybe __ (lookup x pairs) - -addCancellationRule :: Function f => Label -> Rule f -> Twee f -> Twee f -addCancellationRule _ (Rule _ t u) s - | Just n <- maxCancellationSize s, size (t :=: u) > n = s -addCancellationRule l r s = - case toCancellationRule s r of - Nothing -> s - Just c - | moreTracing s && - Debug.Trace.traceShow (sep [text "Adding cancellation rule", nest 2 (pPrint c)]) False -> __ - Just c -> s { - cancellationRules = - Index.insert (Labelled l c) (cancellationRules s) } - -deleteCancellationRule :: Function f => Label -> Rule f -> Twee f -> Twee f -deleteCancellationRule l r s = - case toCancellationRule s r of - Nothing -> s - Just c -> s { - cancellationRules = - Index.delete (Labelled l c) (cancellationRules s) } - --------------------------------------------------------------------------------- --- Critical pairs. --------------------------------------------------------------------------------- - -data Critical a = - Critical { - critInfo :: CritInfo (ConstantOf a), - critical :: a } - -data CritInfo f = - CritInfo { - top :: Term f, - overlap :: Int } - -instance Eq a => Eq (Critical a) where x == y = critical x == critical y -instance Ord a => Ord (Critical a) where compare = comparing critical - -instance (PrettyTerm (ConstantOf a), Pretty a) => Pretty (Critical a) where - pPrint Critical{..} = pPrint critical - -deriving instance (Show a, Show (ConstantOf a)) => Show (Critical a) -deriving instance Show f => Show (CritInfo f) - -instance Symbolic a => Symbolic (Critical a) where - type ConstantOf (Critical a) = ConstantOf a - - term = term . critical - termsDL Critical{..} = termsDL (critical, critInfo) - replace f Critical{..} = Critical (replace f critInfo) (replace f critical) - -instance Symbolic (CritInfo f) where - type ConstantOf (CritInfo f) = f - - term = __ - termsDL = termsDL . top - replace f CritInfo{..} = CritInfo (replace f top) overlap - -data CPInfo = - CPInfo { - cpWeight :: {-# UNPACK #-} !Int, - cpWeight2 :: {-# UNPACK #-} !Int, - cpAge1 :: {-# UNPACK #-} !Label, - cpAge2 :: {-# UNPACK #-} !Label } - deriving (Eq, Ord, Show) - -data CP f = - CP { - info :: {-# UNPACK #-} !CPInfo, - cp :: {-# UNPACK #-} !(Critical (Equation f)), - l1 :: {-# UNPACK #-} !Label, - l2 :: {-# UNPACK #-} !Label } - deriving Show - -instance Eq (CP f) where x == y = info x == info y -instance Ord (CP f) where compare = comparing info -instance Labels (CP f) where labels x = [l1 x, l2 x] -instance (Numbered f, PrettyTerm f) => Pretty (CP f) where - pPrint = pPrint . cp - -data CPs f = - CPs { - best :: {-# UNPACK #-} !CPInfo, - label :: {-# UNPACK #-} !Label, - lower :: {-# UNPACK #-} !Label, - upper :: {-# UNPACK #-} !Label, - count :: {-# UNPACK #-} !Int, - from :: {-# UNPACK #-} !(Labelled (Rule f)) } - deriving Show - -instance Eq (CPs f) where x == y = best x == best y -instance Ord (CPs f) where compare = comparing best -instance Labels (CPs f) where labels (CPs _ _ _ _ _ (Labelled l _)) = [l] -instance (Numbered f, PrettyTerm f) => Pretty (CPs f) where - pPrint CPs{..} = text "Family of size" <+> pPrint count <+> text "from" <+> pPrint from - -data Passive f = - SingleCP {-# UNPACK #-} !(CP f) - | ManyCPs {-# UNPACK #-} !(CPs f) - deriving (Eq, Show) - -instance Ord (Passive f) where - compare = comparing f - where - f (SingleCP x) = info x - f (ManyCPs x) = best x -instance Labels (Passive f) where - labels (SingleCP x) = labels x - labels (ManyCPs x) = labels x -instance (Numbered f, PrettyTerm f) => Pretty (Passive f) where - pPrint (SingleCP cp) = pPrint cp - pPrint (ManyCPs cps) = pPrint cps - -passiveCount :: Passive f -> Int -passiveCount SingleCP{} = 1 -passiveCount (ManyCPs x) = count x - -data InitialCP f = - InitialCP { - cpId :: (Term f, Label), - cpOK :: Bool, - cpCP :: Labelled (Critical (Equation f)) } - -criticalPairs :: Function f => Twee f -> Label -> Label -> Rule f -> [Labelled (Critical (Equation f))] -criticalPairs s lower upper rule = - criticalPairs1 s (ruleOverlaps s (lhs rule)) rule (map (fmap (critical . modelled)) rules) ++ - [ cp - | Labelled l' (Modelled _ ns (Critical _ old)) <- rules, - cp <- criticalPairs1 s ns old [Labelled l' rule] ] - where - rules = filter (p . labelOf) (Indexes.elems (labelledRules s)) - p l = lower <= l && l <= upper - -ruleOverlaps :: Twee f -> Term f -> [Int] -ruleOverlaps s t = aux 0 Set.empty (singleton t) - where - aux !_ !_ Empty = [] - aux n m (Cons (Var _) t) = aux (n+1) m t - aux n m (ConsSym t@Fun{} u) - | useGeneralSuperpositions s && t `Set.member` m = aux (n+1) m u - | otherwise = n:aux (n+1) (Set.insert t m) u - -overlaps :: [Int] -> Term f -> Term f -> [(Subst f, Int)] -overlaps ns t1 t2@(Fun g _) = go 0 ns (singleton t1) [] - where - go !_ _ !_ _ | False = __ - go _ [] _ rest = rest - go _ _ Empty rest = rest - go n (m:ms) (ConsSym ~t@(Fun f _) u) rest - | m == n && f == g = here ++ go (n+1) ms u rest - | m == n = go (n+1) ms u rest - | otherwise = go (n+1) (m:ms) u rest - where - here = - case unify t t2 of - Nothing -> [] - Just sub -> [(sub, n)] -overlaps _ _ _ = [] - -emitReplacement :: Int -> Term f -> TermList f -> Builder f -emitReplacement n t = aux n - where - aux !_ !_ | False = __ - aux _ Empty = mempty - aux 0 (Cons _ u) = builder t `mappend` builder u - aux n (Cons (Var x) u) = var x `mappend` aux (n-1) u - aux n (Cons t@(Fun f ts) u) - | n < len t = - fun f (aux (n-1) ts) `mappend` builder u - | otherwise = - builder t `mappend` aux (n-len t) u - -criticalPairs1 :: Function f => Twee f -> [Int] -> Rule f -> [Labelled (Rule f)] -> [Labelled (Critical (Equation f))] -criticalPairs1 s ns r rs = do - let b = maximum (0:[ bound t | Labelled _ (Rule _ t _) <- rs ]) - Rule or t u = subst (\(MkVar x) -> var (MkVar (x+b))) r - Labelled l (Rule or' t' u') <- rs - (sub, pos) <- overlaps ns t t' - let left = subst sub u - right = subst sub (build (emitReplacement pos u' (singleton t))) - top = subst sub t - overlap = at pos (singleton t) - - inner = subst sub overlap - osz = size overlap + (size u - size t) + (size u' - size t') - - guard (left /= top && right /= top && left /= right) - when (or /= Oriented) $ guard (not (lessEq top right)) - when (or' /= Oriented) $ guard (not (lessEq top left)) - when (skipCompositeSuperpositions s) $ - guard (null (nested (anywhere (rewrite "prime" simplifies (easyRules s))) inner)) - return (Labelled l (Critical (CritInfo top osz) (left :=: right))) - -queueCP :: - Function f => - (Passive f -> State (Twee f) ()) -> - (Equation f -> Bool) -> Label -> Label -> Critical (Equation f) -> State (Twee f) () -queueCP enq joinable l1 l2 eq = do - s <- get - case toCP s l1 l2 joinable eq of - Nothing -> return () - Just cp -> enq (SingleCP cp) - -queueCPs :: - (Function f, Ord a) => - (Passive f -> State (Twee f) ()) -> - Label -> Label -> (Label -> a) -> Labelled (Rule f) -> State (Twee f) () -queueCPs enq lower upper f rule = do - s <- get - let cps = toCPs s lower upper rule - cpss = partitionBy (f . l2) cps - forM_ cpss $ \xs -> do - if length xs <= minimumCPSetSize s then - mapM_ (enq . SingleCP) xs - else - let best = minimum xs - l1' = minimum (map l1 xs) - l2' = minimum (map l2 xs) in - enq (ManyCPs (CPs (info best) (l2 best) l1' l2' (length xs) rule)) - -queueCPsSplit :: - Function f => - (Passive f -> State (Twee f) ()) -> - Label -> Label -> Labelled (Rule f) -> State (Twee f) () -queueCPsSplit enq l u rule = do - s <- get - let f x = fromIntegral (cpSplits s)*(x-l) `div` (u-l+1) - queueCPs enq l u f rule - -toCPs :: - Function f => - Twee f -> Label -> Label -> Labelled (Rule f) -> [CP f] -toCPs s lower upper (Labelled l rule) = - catMaybes [toCP s l l' trivial eqn | Labelled l' eqn <- criticalPairs s lower upper rule] - -toCP :: - Function f => - Twee f -> Label -> Label -> (Equation f -> Bool) -> Critical (Equation f) -> Maybe (CP f) -toCP s l1 l2 joinable cp = fmap toCP' (norm cp) - where - norm (Critical info (t :=: u)) = do - guard (t /= u) - let t' = result (normaliseQuickly s t) - u' = result (normaliseQuickly s u) - eq' = Critical info (t' :=: u') - guard (t' /= u') - return eq' - - toCP' eq@(Critical info (t :=: u)) = - CP (CPInfo w (-(overlap info)) l2 l1) eq l1 l2 - where - w = cancelledWeight s joinable (t :=: u) - -cancelledWeight :: Function f => Twee f -> (Equation f -> Bool) -> Equation f -> Int -cancelledWeight s joinable eq = fst (bestCancellation s joinable eq) - -bestCancellation :: Function f => Twee f -> (Equation f -> Bool) -> Equation f -> (Int, Equation f) -bestCancellation s _ eq | not (useCancellation s) = (weight s eq, eq) -bestCancellation s joinable (t :=: u) = (w, best) - where - cs = cancellations s joinable (t :=: u) - ws = zipWith (+) [0..] (map (weight s) cs) - w = minimum ws - best = snd (minimumBy (comparing fst) (zip ws cs)) - -weight, weight' :: Function f => Twee f -> Equation f -> Int -weight s eq = weight' s (order eq) - -weight' s (t :=: u) = - lhsWeight s*size' t + rhsWeight s*size' u - where - size' t = 4*(size t + len t) - length (vars t) - length (nub (vars t)) - -cancellations :: Function f => Twee f -> (Equation f -> Bool) -> Equation f -> [Equation f] -cancellations s joinable (t :=: u) = - t :=: u: - case cands of - [] -> [] - _ -> cancellations s joinable (minimumBy (comparing size) cands) - where - cands = - filter (\eq -> size eq < size (t :=: u)) $ - [ t' :=: u' | (sub, t') <- cancel t, let u' = result (normaliseQuickly s (subst sub u)), not (joinable (t' :=: u')) ] ++ - [ t' :=: u' | (sub, u') <- cancel u, let t' = result (normaliseQuickly s (subst sub t)), not (joinable (t' :=: u')) ] - cancel t = do - (i, u) <- zip [0..] (subterms t) - Labelled _ (CancellationRule tss (Rule _ _ u')) <- - Index.lookup u (Index.freeze (cancellationRules s)) - sub <- maybeToList (unifyMany [(t, u) | t:ts <- tss, u <- ts]) - let t' = result (normaliseQuickly s (subst sub (build (emitReplacement i u' (singleton t))))) - return (sub, t') - - unifyMany ps = - unifyList (buildList (map fst ps)) (buildList (map snd ps)) - --------------------------------------------------------------------------------- --- Tracing. --------------------------------------------------------------------------------- - -data Event f = - NewRule (Rule f) - | ExtraRule (Rule f) - | NewCP (Passive f) - | Reduce (Simplification f) (Rule f) - | Consider (Critical (Equation f)) - | Joined (Critical (Equation f)) JoinReason - | Delay (Critical (Equation f)) - | Cancel (Critical (Equation f)) (Equation f) - | Discharge (Critical (Equation f)) (Model f) - | NormaliseCPs (Twee f) - -trace :: Function f => Twee f -> Event f -> a -> a -trace Twee{..} (NewRule rule) = traceIf tracing (hang (text "New rule") 2 (pPrint rule)) -trace Twee{..} (ExtraRule rule) = traceIf tracing (hang (text "Extra rule") 2 (pPrint rule)) -trace Twee{..} (NewCP cp) = traceIf moreTracing (hang (text "Critical pair") 2 (pPrint cp)) -trace Twee{..} (Reduce red rule) = traceIf tracing (sep [pPrint red, nest 2 (text "using"), nest 2 (pPrint rule)]) -trace Twee{..} (Consider eq) = traceIf moreTracing (sep [text "Considering", nest 2 (pPrint eq), text "under", nest 2 (pPrint (top (critInfo eq)))]) -trace Twee{..} (Joined eq reason) = traceIf moreTracing (sep [text "Joined", nest 2 (pPrint eq), text "under", nest 2 (pPrint (top (critInfo eq))), text "by", nest 2 (pPrint reason)]) -trace Twee{..} (Delay eq) = traceIf moreTracing (sep [text "Delaying", nest 2 (pPrint eq)]) -trace Twee{..} (Cancel eq eq') = traceIf tracing (sep [text "Cancelled", nest 2 (pPrint eq), text "into", nest 2 (pPrint eq')]) -trace Twee{..} (Discharge eq fs) = traceIf tracing (sep [text "Discharge", nest 2 (pPrint eq), text "under", nest 2 (pPrint fs)]) -trace Twee{..} (NormaliseCPs s) = traceIf tracing (text "" $$ text "Normalising unprocessed critical pairs." $$ text (report s) $$ text "") - -traceM :: Function f => Event f -> State (Twee f) () -traceM x = do - s <- get - trace s x (return ()) - -traceIf :: Bool -> Doc -> a -> a -traceIf True x = Debug.Trace.trace (show x) -traceIf False _ = id +{-# LANGUAGE RecordWildCards, MultiParamTypeClasses, GADTs, BangPatterns, OverloadedStrings, ScopedTypeVariables, GeneralizedNewtypeDeriving, PatternGuards, TypeFamilies #-} +module Twee where + +import Twee.Base +import Twee.Rule +import Twee.Equation +import qualified Twee.Proof as Proof +import Twee.Proof(Proof, Axiom(..), Lemma(..), ProvedGoal(..), provedGoal, certify, derivation, symm) +import Twee.CP hiding (Config) +import qualified Twee.CP as CP +import Twee.Join hiding (Config, defaultConfig) +import qualified Twee.Join as Join +import qualified Twee.Rule.Index as RuleIndex +import Twee.Rule.Index(RuleIndex(..)) +import qualified Twee.Index as Index +import Twee.Index(Index) +import Twee.Constraints +import Twee.Utils +import Twee.Task +import qualified Twee.Heap as Heap +import Twee.Heap(Heap) +import qualified Data.IntMap.Strict as IntMap +import Data.IntMap(IntMap) +import Data.Maybe +import Data.List +import Data.Function +import qualified Data.Set as Set +import Data.Set(Set) +import Text.Printf +import Data.Int +import Data.Ord +import Control.Monad +import Control.Monad.IO.Class +import Control.Monad.Trans.Class +import qualified Control.Monad.Trans.State.Strict as StateM +import Data.Word +import Data.Bits + +---------------------------------------------------------------------- +-- Configuration and prover state. +---------------------------------------------------------------------- + +data Config = + Config { + cfg_max_term_size :: Int, + cfg_max_critical_pairs :: Int64, + cfg_max_cp_depth :: Int, + cfg_simplify :: Bool, + cfg_renormalise_percent :: Int, + cfg_critical_pairs :: CP.Config, + cfg_join :: Join.Config, + cfg_proof_presentation :: Proof.Config } + +data State f = + State { + st_rules :: !(RuleIndex f (ActiveRule f)), + st_active_ids :: !(IntMap (Active f)), + st_rule_ids :: !(IntMap (ActiveRule f)), + st_joinable :: !(Index f (Equation f)), + st_goals :: ![Goal f], + st_queue :: !(Heap (PackedPassive f)), + st_next_active :: {-# UNPACK #-} !Id, + st_next_rule :: {-# UNPACK #-} !RuleId, + st_considered :: {-# UNPACK #-} !Int64, + st_messages_rev :: ![Message f] } + +defaultConfig :: Config +defaultConfig = + Config { + cfg_max_term_size = maxBound, + cfg_max_critical_pairs = maxBound, + cfg_max_cp_depth = maxBound, + cfg_simplify = True, + cfg_renormalise_percent = 5, + cfg_critical_pairs = + CP.Config { + cfg_lhsweight = 3, + cfg_rhsweight = 1, + cfg_funweight = 7, + cfg_varweight = 6, + cfg_depthweight = 16, + cfg_dupcost = 7, + cfg_dupfactor = 0 }, + cfg_join = Join.defaultConfig, + cfg_proof_presentation = Proof.defaultConfig } + +configIsComplete :: Config -> Bool +configIsComplete Config{..} = + cfg_max_term_size == maxBound && + cfg_max_critical_pairs == maxBound && + cfg_max_cp_depth == maxBound + +initialState :: State f +initialState = + State { + st_rules = RuleIndex.nil, + st_active_ids = IntMap.empty, + st_rule_ids = IntMap.empty, + st_joinable = Index.Nil, + st_goals = [], + st_queue = Heap.empty, + st_next_active = 1, + st_next_rule = 0, + st_considered = 0, + st_messages_rev = [] } + +---------------------------------------------------------------------- +-- Messages. +---------------------------------------------------------------------- + +data Message f = + NewActive !(Active f) + | NewEquation !(Equation f) + | DeleteActive !(Active f) + | SimplifyQueue + | Interreduce + +instance Function f => Pretty (Message f) where + pPrint (NewActive rule) = pPrint rule + pPrint (NewEquation eqn) = + text " (hard)" <+> pPrint eqn + pPrint (DeleteActive rule) = + text " (delete rule " <> pPrint (active_id rule) <> text ")" + pPrint SimplifyQueue = + text " (simplifying queued critical pairs...)" + pPrint Interreduce = + text " (simplifying rules with respect to one another...)" + +message :: PrettyTerm f => Message f -> State f -> State f +message !msg state@State{..} = + state { st_messages_rev = msg:st_messages_rev } + +clearMessages :: State f -> State f +clearMessages state@State{..} = + state { st_messages_rev = [] } + +messages :: State f -> [Message f] +messages state = reverse (st_messages_rev state) + +---------------------------------------------------------------------- +-- The CP queue. +---------------------------------------------------------------------- + +data Passive f = + Passive { + passive_score :: {-# UNPACK #-} !Int32, + passive_rule1 :: {-# UNPACK #-} !RuleId, + passive_rule2 :: {-# UNPACK #-} !RuleId, + passive_pos :: {-# UNPACK #-} !Int32 } + deriving (Eq, Show) + +instance Ord (Passive f) where + compare = comparing f + where + f Passive{..} = + (passive_score, + intMax (fromIntegral passive_rule1) (fromIntegral passive_rule2), + passive_rule1, + passive_rule2, + passive_pos) + +data PackedPassive f = + PackedPassive {-# UNPACK #-} !Word64 {-# UNPACK #-} !Word64 + deriving (Eq, Ord, Show) + +packPassive :: Passive f -> PackedPassive f +packPassive (Passive score rule1 rule2 pos) = + -- Do this so that Ord instance matches with Passive + if rule1 > rule2 then + PackedPassive + (pack score (fromIntegral rule1)) + (pack (fromIntegral rule2) (pos `shiftL` 1)) + else + PackedPassive + (pack score (fromIntegral rule2)) + (pack (fromIntegral rule1) (pos `shiftL` 1 + 1)) + where + pack :: Int32 -> Int32 -> Word64 + pack x y = + fromIntegral x `shiftL` 32 + fromIntegral y + +unpackPassive :: PackedPassive f -> Passive f +unpackPassive (PackedPassive x y) = + if testBit pos1 0 then + Passive score (fromIntegral rule2) (fromIntegral rule1) pos + else + Passive score (fromIntegral rule1) (fromIntegral rule2) pos + where + (score, rule1) = unpack x + (rule2, pos1) = unpack y + pos = pos1 `shiftR` 1 + + unpack :: Word64 -> (Int32, Int32) + unpack x = (fromIntegral (x `shiftR` 32), fromIntegral x) + +-- Compute all critical pairs from a rule and condense into a Passive. +{-# INLINEABLE makePassive #-} +makePassive :: Function f => Config -> State f -> ActiveRule f -> [Passive f] +makePassive Config{..} State{..} rule = + {-# SCC makePassive #-} + [ Passive (fromIntegral (score cfg_critical_pairs o)) (rule_rid rule1) (rule_rid rule2) (fromIntegral (overlap_pos o)) + | (rule1, rule2, o) <- overlaps (Depth cfg_max_cp_depth) (index_oriented st_rules) rules rule ] + where + rules = IntMap.elems st_rule_ids + +-- Turn a Passive back into an overlap. +-- Doesn't try to simplify it. +{-# INLINEABLE findPassive #-} +findPassive :: forall f. Function f => Config -> State f -> Passive f -> Maybe (ActiveRule f, ActiveRule f, Overlap f) +findPassive Config{..} State{..} Passive{..} = {-# SCC findPassive #-} do + rule1 <- IntMap.lookup (fromIntegral passive_rule1) st_rule_ids + rule2 <- IntMap.lookup (fromIntegral passive_rule2) st_rule_ids + let !depth = 1 + max (the rule1) (the rule2) + overlap <- + overlapAt (fromIntegral passive_pos) depth + (renameAvoiding (the rule2 :: Rule f) (the rule1)) (the rule2) + return (rule1, rule2, overlap) + +-- Renormalise a queued Passive. +{-# INLINEABLE simplifyPassive #-} +simplifyPassive :: Function f => Config -> State f -> Passive f -> Maybe (Passive f) +simplifyPassive config@Config{..} state@State{..} passive = {-# SCC simplifyPassive #-} do + (_, _, overlap) <- findPassive config state passive + overlap <- simplifyOverlap (index_oriented st_rules) overlap + return passive { + passive_score = fromIntegral $ + fromIntegral (passive_score passive) `intMin` + score cfg_critical_pairs overlap } + +-- Renormalise the entire queue. +{-# INLINEABLE simplifyQueue #-} +simplifyQueue :: Function f => Config -> State f -> State f +simplifyQueue config state = + {-# SCC simplifyQueue #-} + state { st_queue = simp (st_queue state) } + where + simp = + Heap.mapMaybe (fmap packPassive . simplifyPassive config state . unpackPassive) + +-- Enqueue a critical pair. +{-# INLINEABLE enqueue #-} +enqueue :: Function f => State f -> Passive f -> State f +enqueue state passive = + {-# SCC enqueue #-} + state { st_queue = Heap.insert (packPassive passive) (st_queue state) } + +-- Dequeue a critical pair. +-- Also takes care of: +-- * removing any orphans from the head of the queue +-- * splitting ManyCPs up as necessary +-- * ignoring CPs that are too big +{-# INLINEABLE dequeue #-} +dequeue :: Function f => Config -> State f -> (Maybe (CriticalPair f, ActiveRule f, ActiveRule f), State f) +dequeue config@Config{..} state@State{..} = + {-# SCC dequeue #-} + case deq 0 st_queue of + -- Explicitly make the queue empty, in case it e.g. contained a + -- lot of orphans + Nothing -> (Nothing, state { st_queue = Heap.empty }) + Just (overlap, n, queue) -> + (Just overlap, + state { st_queue = queue, st_considered = st_considered + n }) + where + deq !n queue = do + (packedPassive, queue) <- Heap.removeMin queue + let passive = unpackPassive packedPassive + case findPassive config state passive of + Just (rule1, rule2, overlap) + | passive_score passive >= 0, + Just Overlap{overlap_eqn = t :=: u} <- + simplifyOverlap (index_oriented st_rules) overlap, + size t <= cfg_max_term_size, + size u <= cfg_max_term_size, + Just cp <- makeCriticalPair rule1 rule2 overlap -> + return ((cp, rule1, rule2), n+1, queue) + _ -> deq (n+1) queue + +---------------------------------------------------------------------- +-- Active rewrite rules. +---------------------------------------------------------------------- + +data Active f = + Active { + active_id :: {-# UNPACK #-} !Id, + active_depth :: {-# UNPACK #-} !Depth, + active_rule :: {-# UNPACK #-} !(Rule f), + active_top :: !(Maybe (Term f)), + active_proof :: {-# UNPACK #-} !(Proof f), + -- A model in which the rule is false (used when reorienting) + active_model :: !(Model f), + active_rules :: ![ActiveRule f] } + +active_cp :: Active f -> CriticalPair f +active_cp Active{..} = + CriticalPair { + cp_eqn = unorient active_rule, + cp_depth = active_depth, + cp_top = active_top, + cp_proof = derivation active_proof } + +-- An active oriented in a particular direction. +data ActiveRule f = + ActiveRule { + rule_active :: {-# UNPACK #-} !Id, + rule_rid :: {-# UNPACK #-} !RuleId, + rule_depth :: {-# UNPACK #-} !Depth, + rule_rule :: {-# UNPACK #-} !(Rule f), + rule_proof :: {-# UNPACK #-} !(Proof f), + rule_positions :: !(Positions f) } + +instance PrettyTerm f => Symbolic (ActiveRule f) where + type ConstantOf (ActiveRule f) = f + termsDL ActiveRule{..} = + termsDL rule_rule `mplus` + termsDL (derivation rule_proof) + subst_ sub r@ActiveRule{..} = + r { + rule_rule = rule', + rule_proof = certify (subst_ sub (derivation rule_proof)), + rule_positions = positions (lhs rule') } + where + rule' = subst_ sub rule_rule + +instance Eq (Active f) where + (==) = (==) `on` active_id + +instance Eq (ActiveRule f) where + (==) = (==) `on` rule_rid + +instance Function f => Pretty (Active f) where + pPrint Active{..} = + pPrint active_id <> text "." <+> pPrint (canonicalise active_rule) + +instance Has (ActiveRule f) Id where the = rule_active +instance Has (ActiveRule f) Depth where the = rule_depth +instance f ~ g => Has (ActiveRule f) (Rule g) where the = rule_rule +instance f ~ g => Has (ActiveRule f) (Proof g) where the = rule_proof +instance f ~ g => Has (ActiveRule f) (Lemma g) where the x = Lemma (the x) (the x) +instance f ~ g => Has (ActiveRule f) (Positions g) where the = rule_positions + +newtype RuleId = RuleId Id deriving (Eq, Ord, Show, Num, Real, Integral, Enum) + +-- Add a new active. +{-# INLINEABLE addActive #-} +addActive :: Function f => Config -> State f -> (Id -> RuleId -> RuleId -> Active f) -> State f +addActive config state@State{..} active0 = + {-# SCC addActive #-} + let + active@Active{..} = active0 st_next_active st_next_rule (succ st_next_rule) + state' = + message (NewActive active) $ + addActiveOnly state{st_next_active = st_next_active+1, st_next_rule = st_next_rule+2} active + passives = + concatMap (makePassive config state') active_rules + in if subsumed st_joinable st_rules (unorient active_rule) then + state + else + normaliseGoals $ + foldl' enqueue state' passives + +-- Add an active without generating critical pairs. Used in interreduction. +{-# INLINEABLE addActiveOnly #-} +addActiveOnly :: Function f => State f -> Active f -> State f +addActiveOnly state@State{..} active@Active{..} = + state { + st_rules = foldl' insertRule st_rules active_rules, + st_active_ids = IntMap.insert (fromIntegral active_id) active st_active_ids, + st_rule_ids = foldl' insertRuleId st_rule_ids active_rules } + where + insertRule rules rule@ActiveRule{..} = + RuleIndex.insert (lhs rule_rule) rule rules + insertRuleId rules rule@ActiveRule{..} = + IntMap.insert (fromIntegral rule_rid) rule rules + +-- Delete an active. Used in interreduction, not suitable for general use. +{-# INLINE deleteActive #-} +deleteActive :: Function f => State f -> Active f -> State f +deleteActive state@State{..} Active{..} = + state { + st_rules = foldl' deleteRule st_rules active_rules, + st_active_ids = IntMap.delete (fromIntegral active_id) st_active_ids, + st_rule_ids = foldl' deleteRuleId st_rule_ids active_rules } + where + deleteRule rules rule = + RuleIndex.delete (lhs (rule_rule rule)) rule rules + deleteRuleId rules ActiveRule{..} = + IntMap.delete (fromIntegral rule_rid) rules + +-- Try to join a critical pair. +{-# INLINEABLE consider #-} +consider :: Function f => Config -> State f -> CriticalPair f -> State f +consider config state cp = + considerUsing (st_rules state) config state cp + +-- Try to join a critical pair, but using a different set of critical +-- pairs for normalisation. +{-# INLINEABLE considerUsing #-} +considerUsing :: + Function f => + RuleIndex f (ActiveRule f) -> Config -> State f -> CriticalPair f -> State f +considerUsing rules config@Config{..} state@State{..} cp0 = + {-# SCC consider #-} + -- Important to canonicalise the rule so that we don't get + -- bigger and bigger variable indices over time + let cp = canonicalise cp0 in + case joinCriticalPair cfg_join st_joinable rules Nothing cp of + Right (mcp, cps) -> + let + state' = foldl' (considerUsing rules config) state cps + in case mcp of + Just cp -> addJoinable state' (cp_eqn cp) + Nothing -> state' + + Left (cp, model) -> + foldl' (addCP config model) state (split cp) + +{-# INLINEABLE addCP #-} +addCP :: Function f => Config -> Model f -> State f -> CriticalPair f -> State f +addCP config model state@State{..} CriticalPair{..} = + addActive config state $ \n k1 k2 -> + let + pf = certify cp_proof + rule = orient cp_eqn + + makeRule k r p = + ActiveRule { + rule_active = n, + rule_rid = k, + rule_depth = cp_depth, + rule_rule = r rule, + rule_proof = p pf, + rule_positions = positions (lhs (r rule)) } + in + Active { + active_id = n, + active_depth = cp_depth, + active_rule = rule, + active_model = model, + active_top = cp_top, + active_proof = pf, + active_rules = + usortBy (comparing (canonicalise . rule_rule)) $ + makeRule k1 id id: + [ makeRule k2 backwards (certify . symm . derivation) + | not (oriented (orientation rule)) ] } + +-- Add a new equation. +{-# INLINEABLE addAxiom #-} +addAxiom :: Function f => Config -> State f -> Axiom f -> State f +addAxiom config state axiom = + consider config state $ + CriticalPair { + cp_eqn = axiom_eqn axiom, + cp_depth = 0, + cp_top = Nothing, + cp_proof = Proof.axiom axiom } + +-- Record an equation as being joinable. +{-# INLINEABLE addJoinable #-} +addJoinable :: Function f => State f -> Equation f -> State f +addJoinable state eqn@(t :=: u) = + message (NewEquation eqn) $ + state { + st_joinable = + Index.insert t (t :=: u) $ + Index.insert u (u :=: t) (st_joinable state) } + +-- For goal terms we store the set of all their normal forms. +-- Name and number are for information only. +data Goal f = + Goal { + goal_name :: String, + goal_number :: Int, + goal_eqn :: Equation f, + goal_lhs :: Set (Resulting f), + goal_rhs :: Set (Resulting f) } + +-- Add a new goal. +{-# INLINEABLE addGoal #-} +addGoal :: Function f => Config -> State f -> Goal f -> State f +addGoal _config state@State{..} goal = + normaliseGoals state { st_goals = goal:st_goals } + +-- Normalise all goals. +{-# INLINEABLE normaliseGoals #-} +normaliseGoals :: Function f => State f -> State f +normaliseGoals state@State{..} = + {-# SCC normaliseGoals #-} + state { + st_goals = + map (goalMap (successors (rewrite reduces (index_all st_rules)) . Set.toList)) st_goals } + where + goalMap f goal@Goal{..} = + goal { goal_lhs = f goal_lhs, goal_rhs = f goal_rhs } + +-- Create a goal. +{-# INLINE goal #-} +goal :: Int -> String -> Equation f -> Goal f +goal n name (t :=: u) = + Goal { + goal_name = name, + goal_number = n, + goal_eqn = t :=: u, + goal_lhs = Set.singleton (reduce (Refl t)), + goal_rhs = Set.singleton (reduce (Refl u)) } + +---------------------------------------------------------------------- +-- Interreduction. +---------------------------------------------------------------------- + +-- Simplify all rules. +{-# INLINEABLE interreduce #-} +interreduce :: Function f => Config -> State f -> State f +interreduce config@Config{..} state = + {-# SCC interreduce #-} + let + state' = + foldl' (interreduce1 config) + -- Clear out st_joinable, since we don't know which + -- equations have made use of each active. + state { st_joinable = Index.Nil } + (IntMap.elems (st_active_ids state)) + in state' { st_joinable = st_joinable state } + +{-# INLINEABLE interreduce1 #-} +interreduce1 :: Function f => Config -> State f -> Active f -> State f +interreduce1 config@Config{..} state active = + -- Exclude the active from the rewrite rules when testing + -- joinability, otherwise it will be trivially joinable. + case + joinCriticalPair cfg_join + (st_joinable state) + (st_rules (deleteActive state active)) + (Just (active_model active)) (active_cp active) + of + Right (_, cps) -> + flip (foldl' (consider config)) cps $ + message (DeleteActive active) $ + deleteActive state active + Left (cp, model) + | not (cp_eqn cp `isInstanceOf` cp_eqn (active_cp active)) -> + flip (foldl' (addCP config model)) (split cp) $ + message (DeleteActive active) $ + deleteActive state active + | model /= active_model active -> + flip addActiveOnly active { active_model = model } $ + deleteActive state active + | otherwise -> + state + where + (t :=: u) `isInstanceOf` (t' :=: u') = isJust $ do + sub <- match t' t + matchIn sub u' u + + +---------------------------------------------------------------------- +-- The main loop. +---------------------------------------------------------------------- + +data Output m f = + Output { + output_report :: State f -> m (), + output_message :: Message f -> m () } + +{-# INLINE complete #-} +complete :: (Function f, MonadIO m) => Output m f -> Config -> State f -> m (State f) +complete Output{..} config@Config{..} state = + flip StateM.execStateT state $ do + tasks <- sequence + [newTask 1 (fromIntegral cfg_renormalise_percent / 100) $ do + lift $ output_message SimplifyQueue + state <- StateM.get + StateM.put $! simplifyQueue config state, + newTask 0.25 0.05 $ do + when cfg_simplify $ do + lift $ output_message Interreduce + state <- StateM.get + StateM.put $! interreduce config state, + newTask 10 1 $ do + state <- StateM.get + lift $ output_report state] + + let + loop = do + progress <- StateM.state (complete1 config) + state <- StateM.get + lift $ mapM_ output_message (messages state) + StateM.put (clearMessages state) + mapM_ checkTask tasks + when progress loop + + loop + +{-# INLINEABLE complete1 #-} +complete1 :: Function f => Config -> State f -> (Bool, State f) +complete1 config@Config{..} state + | st_considered state >= cfg_max_critical_pairs = + (False, state) + | solved state = (False, state) + | otherwise = + case dequeue config state of + (Nothing, state) -> (False, state) + (Just (overlap, _, _), state) -> + (True, consider config state overlap) + +{-# INLINEABLE solved #-} +solved :: Function f => State f -> Bool +solved = not . null . solutions + +-- Return whatever goals we have proved and their proofs. +{-# INLINEABLE solutions #-} +solutions :: Function f => State f -> [ProvedGoal f] +solutions State{..} = {-# SCC solutions #-} do + Goal{goal_lhs = ts, goal_rhs = us, ..} <- st_goals + guard (not (null (Set.intersection ts us))) + let t:_ = filter (`Set.member` us) (Set.toList ts) + u:_ = filter (== t) (Set.toList us) + -- Strict so that we check the proof before returning a solution + !p = + Proof.certify $ + reductionProof (reduction t) `Proof.trans` + Proof.symm (reductionProof (reduction u)) + return (provedGoal goal_number goal_name p) + +-- Return all current rewrite rules. +{-# INLINEABLE rules #-} +rules :: Function f => State f -> [Rule f] +rules = map active_rule . IntMap.elems . st_active_ids + +{-# INLINEABLE report #-} +report :: Function f => State f -> String +report State{..} = + printf "Statistics:\n" ++ + printf " %d rules, of which %d oriented, %d unoriented, %d permutative, %d weakly oriented.\n" + (length orients) + (length [ () | Oriented <- orients ]) + (length [ () | Unoriented <- orients ]) + (length [ () | Permutative{} <- orients ]) + (length [ () | WeaklyOriented{} <- orients ]) ++ + printf " %d queued critical pairs.\n" queuedPairs ++ + printf " %d critical pairs considered so far." st_considered + where + orients = map (orientation . active_rule) (IntMap.elems st_active_ids) + queuedPairs = Heap.size st_queue + +---------------------------------------------------------------------- +-- For code which uses twee as a library. +---------------------------------------------------------------------- + +{-# INLINEABLE completePure #-} +completePure :: Function f => Config -> State f -> State f +completePure cfg state + | progress = completePure cfg (clearMessages state') + | otherwise = state' + where + (progress, state') = complete1 cfg state + +{-# INLINEABLE normaliseTerm #-} +normaliseTerm :: Function f => State f -> Term f -> Resulting f +normaliseTerm State{..} t = + normaliseWith (const True) (rewrite reduces (index_all st_rules)) t + +{-# INLINEABLE simplifyTerm #-} +simplifyTerm :: Function f => State f -> Term f -> Term f +simplifyTerm State{..} t = + simplify (index_oriented st_rules) t diff --git a/src/Twee/Array.hs b/src/Twee/Array.hs --- a/src/Twee/Array.hs +++ b/src/Twee/Array.hs @@ -1,25 +1,36 @@ +-- | Zero-indexed dynamic arrays, optimised for lookup. +-- Modification is slow. Uninitialised indices have a default value. {-# LANGUAGE CPP #-} module Twee.Array where -#include "errors.h" -import qualified Data.Primitive as P +#ifdef BOUNDS_CHECKS +import qualified Data.Primitive.SmallArray.Checked as P +#else +import qualified Data.Primitive.SmallArray as P +#endif import Control.Monad.ST import Data.List --- Zero-indexed dynamic arrays. --- Optimised for lookup. Modification is slow. +-- | A type which has a default value. +class Default a where + -- | The default value. + def :: a + +-- | An array. data Array a = Array { + -- | The size of the array. arraySize :: {-# UNPACK #-} !Int, - arrayContents :: {-# UNPACK #-} !(P.Array a) } - -class Default a where def :: a + -- | The contents of the array. + arrayContents :: {-# UNPACK #-} !(P.SmallArray a) } +-- | Convert an array to a list of (index, value) pairs. +{-# INLINE toList #-} toList :: Array a -> [(Int, a)] toList arr = [ (i, x) | i <- [0..arraySize arr-1], - let x = P.indexArray (arrayContents arr) i ] + let x = P.indexSmallArray (arrayContents arr) i ] instance Show a => Show (Array a) where show arr = @@ -29,25 +40,28 @@ | (i, x) <- toList arr ] ++ "}" +-- | Create an empty array. newArray :: Default a => Array a newArray = runST $ do - marr <- P.newArray 0 def - arr <- P.unsafeFreezeArray marr + marr <- P.newSmallArray 0 def + arr <- P.unsafeFreezeSmallArray marr return (Array 0 arr) +-- | Index into an array. O(1) time. {-# INLINE (!) #-} (!) :: Default a => Array a -> Int -> a arr ! n | 0 <= n && n < arraySize arr = - P.indexArray (arrayContents arr) n + P.indexSmallArray (arrayContents arr) n | otherwise = def +-- | Update the array. O(n) time. {-# INLINEABLE update #-} update :: Default a => Int -> a -> Array a -> Array a update n x arr = runST $ do let size = arraySize arr `max` (n+1) - marr <- P.newArray size def - P.copyArray marr 0 (arrayContents arr) 0 (arraySize arr) - P.writeArray marr n x - arr' <- P.unsafeFreezeArray marr + marr <- P.newSmallArray size def + P.copySmallArray marr 0 (arrayContents arr) 0 (arraySize arr) + P.writeSmallArray marr n $! x + arr' <- P.unsafeFreezeSmallArray marr return (Array size arr') diff --git a/src/Twee/Base.hs b/src/Twee/Base.hs --- a/src/Twee/Base.hs +++ b/src/Twee/Base.hs @@ -1,12 +1,13 @@ -{-# LANGUAGE TypeSynonymInstances, TypeFamilies, FlexibleContexts, FlexibleInstances, GeneralizedNewtypeDeriving, CPP, ConstraintKinds, UndecidableInstances, DeriveFunctor, StandaloneDeriving #-} +{-# LANGUAGE TypeFamilies, FlexibleInstances, UndecidableInstances, DeriveFunctor, DefaultSignatures, FlexibleContexts, DeriveGeneric, TypeOperators, MultiParamTypeClasses, GeneralizedNewtypeDeriving, ConstraintKinds, RecordWildCards #-} +-- To suppress a warning about hiding Arity +{-# OPTIONS_GHC -fno-warn-dodgy-imports #-} module Twee.Base( - Symbolic(..), terms, subst, TermOf, TermListOf, SubstOf, BuilderOf, FunOf, - vars, isGround, funs, occ, canonicalise, - Minimal(..), minimalTerm, isMinimal, - Skolem(..), Arity(..), Sized(..), Ordered(..), Strictness(..), Function, Extended(..), extended, unextended, + Id(..), Symbolic(..), subst, GSymbolic(..), Has(..), terms, TermOf, TermListOf, SubstOf, TriangleSubstOf, BuilderOf, FunOf, + vars, isGround, funs, occ, occVar, canonicalise, renameAvoiding, + Minimal(..), minimalTerm, isMinimal, erase, + Skolem(..), Arity(..), Sized(..), Ordered(..), lessThan, orientTerms, Equals(..), Strictness(..), Function, Extended(..), module Twee.Term, module Twee.Pretty) where -#include "errors.h" import Prelude hiding (lookup) import Control.Monad import qualified Data.DList as DList @@ -15,61 +16,103 @@ import Twee.Pretty import Twee.Constraints hiding (funs) import Data.DList(DList) +import GHC.Generics hiding (Arity) +import Data.Typeable +import Data.Int +import Data.Maybe +import qualified Data.IntMap.Strict as IntMap +-- Represents a unique identifier (e.g., for a rule). +newtype Id = Id { unId :: Int32 } + deriving (Eq, Ord, Show, Enum, Bounded, Num, Real, Integral) + +instance Pretty Id where + pPrint = text . show . unId + -- Generalisation of term functionality to things that contain terms. class Symbolic a where type ConstantOf a - term :: a -> TermOf a termsDL :: a -> DList (TermListOf a) - replace :: (TermListOf a -> BuilderOf a) -> a -> a + default termsDL :: (Generic a, GSymbolic (ConstantOf a) (Rep a)) => a -> DList (TermListOf a) + termsDL = gtermsDL . from + subst_ :: (Var -> BuilderOf a) -> a -> a + default subst_ :: (Generic a, GSymbolic (ConstantOf a) (Rep a)) => (Var -> BuilderOf a) -> a -> a + subst_ sub = to . gsubst sub . from +class GSymbolic k f where + gtermsDL :: f a -> DList (TermList k) + gsubst :: (Var -> Builder k) -> f a -> f a + +instance GSymbolic k V1 where + gtermsDL _ = undefined + gsubst _ x = x +instance GSymbolic k U1 where + gtermsDL _ = mzero + gsubst _ x = x +instance (GSymbolic k f, GSymbolic k g) => GSymbolic k (f :*: g) where + gtermsDL (x :*: y) = gtermsDL x `mplus` gtermsDL y + gsubst sub (x :*: y) = gsubst sub x :*: gsubst sub y +instance (GSymbolic k f, GSymbolic k g) => GSymbolic k (f :+: g) where + gtermsDL (L1 x) = gtermsDL x + gtermsDL (R1 x) = gtermsDL x + gsubst sub (L1 x) = L1 (gsubst sub x) + gsubst sub (R1 x) = R1 (gsubst sub x) +instance GSymbolic k f => GSymbolic k (M1 i c f) where + gtermsDL (M1 x) = gtermsDL x + gsubst sub (M1 x) = M1 (gsubst sub x) +instance (Symbolic a, ConstantOf a ~ k) => GSymbolic k (K1 i a) where + gtermsDL (K1 x) = termsDL x + gsubst sub (K1 x) = K1 (subst_ sub x) + +subst :: (Symbolic a, Substitution s, SubstFun s ~ ConstantOf a) => s -> a -> a +subst sub x = subst_ (evalSubst sub) x + terms :: Symbolic a => a -> [TermListOf a] terms = DList.toList . termsDL -{-# INLINE subst #-} -subst :: (Symbolic a, Substitution (ConstantOf a) s) => s -> a -> a -subst sub x = replace (substList sub) x - type TermOf a = Term (ConstantOf a) type TermListOf a = TermList (ConstantOf a) type SubstOf a = Subst (ConstantOf a) +type TriangleSubstOf a = TriangleSubst (ConstantOf a) type BuilderOf a = Builder (ConstantOf a) type FunOf a = Fun (ConstantOf a) instance Symbolic (Term f) where type ConstantOf (Term f) = f - term = id - termsDL = return . singleton - replace f = build . f . singleton + termsDL = return . singleton + subst_ sub = build . Term.subst sub instance Symbolic (TermList f) where type ConstantOf (TermList f) = f - term = __ - termsDL = return - replace f = buildList . f + termsDL = return + subst_ sub = buildList . Term.substList sub -instance (ConstantOf a ~ ConstantOf b, - Symbolic a, Symbolic b) => Symbolic (a, b) where +instance Symbolic (Subst f) where + type ConstantOf (Subst f) = f + termsDL (Subst sub) = termsDL (IntMap.elems sub) + subst_ sub (Subst s) = Subst (fmap (subst_ sub) s) + +instance (ConstantOf a ~ ConstantOf b, Symbolic a, Symbolic b) => Symbolic (a, b) where type ConstantOf (a, b) = ConstantOf a - term (x, _) = term x - termsDL (x, y) = termsDL x `mplus` termsDL y - replace f (x, y) = (replace f x, replace f y) instance (ConstantOf a ~ ConstantOf b, ConstantOf a ~ ConstantOf c, Symbolic a, Symbolic b, Symbolic c) => Symbolic (a, b, c) where type ConstantOf (a, b, c) = ConstantOf a - term (x, _, _) = term x - termsDL (x, y, z) = termsDL x `mplus` termsDL y `mplus` termsDL z - replace f (x, y, z) = (replace f x, replace f y, replace f z) instance Symbolic a => Symbolic [a] where type ConstantOf [a] = ConstantOf a - term _ = __ - termsDL = msum . map termsDL - replace f = map (replace f) +instance Symbolic a => Symbolic (Maybe a) where + type ConstantOf (Maybe a) = ConstantOf a + +class Has a b where + the :: a -> b + +instance Has a a where + the = id + {-# INLINE vars #-} vars :: Symbolic a => a -> [Var] vars x = [ v | t <- DList.toList (termsDL x), Var v <- subtermsList t ] @@ -80,81 +123,86 @@ {-# INLINE funs #-} funs :: Symbolic a => a -> [FunOf a] -funs x = [ f | t <- DList.toList (termsDL x), Fun f _ <- subtermsList t ] +funs x = [ f | t <- DList.toList (termsDL x), App f _ <- subtermsList t ] {-# INLINE occ #-} occ :: Symbolic a => FunOf a -> a -> Int occ x t = length (filter (== x) (funs t)) +{-# INLINE occVar #-} +occVar :: Symbolic a => Var -> a -> Int +occVar x t = length (filter (== x) (vars t)) + +{-# INLINEABLE canonicalise #-} canonicalise :: Symbolic a => a -> a -canonicalise t = replace (Term.substList sub) t +canonicalise t = subst sub t where sub = Term.canonicalise (DList.toList (termsDL t)) -isMinimal :: (Numbered f, Minimal f) => Term f -> Bool -isMinimal (Fun f Empty) | f == minimal = True +{-# INLINEABLE renameAvoiding #-} +renameAvoiding :: (Symbolic a, Symbolic b) => a -> b -> b +renameAvoiding x y = + subst (\(V x) -> var (V (x+n))) y + where + V n = maximum (V 0:map boundList (terms x)) + +isMinimal :: Minimal f => Term f -> Bool +isMinimal (App f Empty) | f == minimal = True isMinimal _ = False -minimalTerm :: (Numbered f, Minimal f) => Term f +minimalTerm :: Minimal f => Term f minimalTerm = build (con minimal) -class Skolem f where - skolem :: Var -> f +erase :: (Symbolic a, ConstantOf a ~ f, Minimal f) => [Var] -> a -> a +erase [] t = t +erase xs t = subst sub t + where + sub = fromMaybe undefined $ flattenSubst [(x, minimalTerm) | x <- xs] -instance (Numbered f, Skolem f) => Skolem (Fun f) where - skolem = toFun . skolem +class Skolem f where + skolem :: Var -> Fun f class Arity f where arity :: f -> Int -instance (Numbered f, Arity f) => Arity (Fun f) where - arity = arity . fromFun +instance Arity f => Arity (Fun f) where + arity = arity . fun_value class Sized a where size :: a -> Int -instance (Sized f, Numbered f) => Sized (Fun f) where - size = size . fromFun +instance Sized f => Sized (Fun f) where + size = size . fun_value -instance (Sized f, Numbered f) => Sized (TermList f) where +instance Sized f => Sized (TermList f) where size = aux 0 where aux n Empty = n - aux n (ConsSym (Fun f _) t) = aux (n+size f) t + aux n (ConsSym (App f _) t) = aux (n+size f) t aux n (Cons (Var _) t) = aux (n+1) t -instance (Sized f, Numbered f) => Sized (Term f) where +instance Sized f => Sized (Term f) where size = size . singleton -class (Numbered f, Ordered f, Arity f, Sized f, Minimal f, Skolem f, PrettyTerm f) => Function f -instance (Numbered f, Ordered f, Arity f, Sized f, Minimal f, Skolem f, PrettyTerm f) => Function f +type Function f = (Ordered f, Arity f, Sized f, Minimal f, Skolem f, PrettyTerm f, Equals f) +class Equals f where + equalsCon, trueCon, falseCon :: Fun f + data Extended f = Minimal - | Skolem Int + | Skolem Var | Function f + | EqualsCon | TrueCon | FalseCon deriving (Eq, Ord, Show, Functor) -instance Minimal (Extended f) where - minimal = Minimal - -instance Skolem (Extended f) where - skolem (MkVar x) = Skolem x - -instance Numbered f => Numbered (Extended f) where - fromInt 0 = Minimal - fromInt n - | odd n = Skolem ((n-1) `div` 2) - | otherwise = Function (fromInt ((n-2) `div` 2)) - - toInt Minimal = 0 - toInt (Skolem n) = 2*n+1 - toInt (Function f) = 2*toInt f+2 - instance Pretty f => Pretty (Extended f) where - pPrintPrec _ _ Minimal = text "⊥" - pPrintPrec _ _ (Skolem n) = text "sk" <> pPrint n + pPrintPrec _ _ Minimal = text "?" + pPrintPrec _ _ (Skolem (V n)) = text "sk" <> pPrint n pPrintPrec l p (Function f) = pPrintPrec l p f + pPrintPrec _ _ EqualsCon = text "$equals" + pPrintPrec _ _ TrueCon = text "$true" + pPrintPrec _ _ FalseCon = text "$false" instance PrettyTerm f => PrettyTerm (Extended f) where termStyle (Function f) = termStyle f @@ -162,26 +210,23 @@ instance Sized f => Sized (Extended f) where size (Function f) = size f + size EqualsCon = 0 + size TrueCon = 0 + size FalseCon = 0 size _ = 1 instance Arity f => Arity (Extended f) where arity (Function f) = arity f + arity EqualsCon = 2 arity _ = 0 -{-# INLINEABLE extended #-} -extended :: Numbered f => TermList f -> Builder (Extended f) -extended Empty = mempty -extended (Cons (Var x) ts) = var x `mappend` extended ts -extended (Cons (Fun f ts) us) = - fun (toFun (Function (fromFun f))) (extended ts) `mappend` - extended us +instance (Typeable f, Ord f) => Minimal (Extended f) where + minimal = fun Minimal -{-# INLINEABLE unextended #-} -unextended :: Numbered f => TermList (Extended f) -> Builder f -unextended Empty = mempty -unextended (Cons (Var x) ts) = var x `mappend` unextended ts -unextended (Cons (Fun f ts) us) = - case fromFun f of - Function g -> fun (toFun g) (unextended ts) `mappend` unextended us - Minimal -> var (MkVar 0) `mappend` unextended us - Skolem n -> var (MkVar n) `mappend` unextended us +instance (Typeable f, Ord f) => Skolem (Extended f) where + skolem x = fun (Skolem x) + +instance (Typeable f, Ord f) => Equals (Extended f) where + equalsCon = fun EqualsCon + trueCon = fun TrueCon + falseCon = fun FalseCon diff --git a/src/Twee/CP.hs b/src/Twee/CP.hs new file mode 100644 --- /dev/null +++ b/src/Twee/CP.hs @@ -0,0 +1,325 @@ +-- Critical pairs. +{-# LANGUAGE BangPatterns, FlexibleContexts, ScopedTypeVariables, MultiParamTypeClasses, RecordWildCards, OverloadedStrings, TypeFamilies, DeriveGeneric, GeneralizedNewtypeDeriving #-} +module Twee.CP where + +import qualified Twee.Term as Term +import Twee.Base +import Twee.Rule +import Twee.Index(Index) +import qualified Data.Set as Set +import Control.Monad +import Data.Maybe +import Data.List +import qualified Twee.ChurchList as ChurchList +import Twee.ChurchList (ChurchList(..)) +import Twee.Utils +import Twee.Equation +import qualified Twee.Proof as Proof +import Twee.Proof(Derivation, Lemma, congPath) +import GHC.Generics + +-- The set of positions at which a term can have critical overlaps. +data Positions f = NilP | ConsP {-# UNPACK #-} !Int !(Positions f) +type PositionsOf a = Positions (ConstantOf a) + +instance Show (Positions f) where + show = show . ChurchList.toList . positionsChurch + +positions :: Term f -> Positions f +positions t = aux 0 Set.empty (singleton t) + where + -- Consider only general superpositions. + aux !_ !_ Empty = NilP + aux n m (Cons (Var _) t) = aux (n+1) m t + aux n m (ConsSym t@App{} u) + | t `Set.member` m = aux (n+1) m u + | otherwise = ConsP n (aux (n+1) (Set.insert t m) u) + +{-# INLINE positionsChurch #-} +positionsChurch :: Positions f -> ChurchList Int +positionsChurch posns = + ChurchList $ \c n -> + let + pos NilP = n + pos (ConsP x posns) = c x (pos posns) + in + pos posns + +-- A critical overlap of one rule with another. +data Overlap f = + Overlap { + overlap_depth :: {-# UNPACK #-} !Depth, + overlap_top :: {-# UNPACK #-} !(Term f), + overlap_inner :: {-# UNPACK #-} !(Term f), + overlap_pos :: {-# UNPACK #-} !Int, + overlap_eqn :: {-# UNPACK #-} !(Equation f) } + deriving Show +type OverlapOf a = Overlap (ConstantOf a) + +newtype Depth = Depth Int deriving (Eq, Ord, Num, Real, Enum, Integral, Show) + +-- Compute all overlaps of a rule with a set of rules. +{-# INLINEABLE overlaps #-} +overlaps :: + (Function f, Has a (Rule f), Has a (Positions f), Has a Depth) => + Depth -> Index f a -> [a] -> a -> [(a, a, Overlap f)] +overlaps max_depth idx rules r = + ChurchList.toList (overlapsChurch max_depth idx rules r) + +{-# INLINE overlapsChurch #-} +overlapsChurch :: forall f a. + (Function f, Has a (Rule f), Has a (Positions f), Has a Depth) => + Depth -> Index f a -> [a] -> a -> ChurchList (a, a, Overlap f) +overlapsChurch max_depth idx rules r1 = do + guard (the r1 < max_depth) + r2 <- ChurchList.fromList rules + guard (the r2 < max_depth) + let !depth = 1 + max (the r1) (the r2) + do { o <- asymmetricOverlaps idx depth (the r1) r1' (the r2); return (r1, r2, o) } `mplus` + do { o <- asymmetricOverlaps idx depth (the r2) (the r2) r1'; return (r2, r1, o) } + where + !r1' = renameAvoiding (map the rules :: [Rule f]) (the r1) + +{-# INLINE asymmetricOverlaps #-} +asymmetricOverlaps :: + (Function f, Has a (Rule f), Has a Depth) => + Index f a -> Depth -> Positions f -> Rule f -> Rule f -> ChurchList (Overlap f) +asymmetricOverlaps idx depth posns r1 r2 = do + n <- positionsChurch posns + ChurchList.fromMaybe $ + overlapAt n depth r1 r2 >>= + simplifyOverlap idx + +-- Create an overlap at a particular position in a term. +-- Doesn't simplify or check for primeness. +{-# INLINE overlapAt #-} +overlapAt :: Int -> Depth -> Rule f -> Rule f -> Maybe (Overlap f) +overlapAt !n !depth (Rule _ !outer !outer') (Rule _ !inner !inner') = do + let t = at n (singleton outer) + sub <- unifyTri inner t + let + top = {-# SCC overlap_top #-} termSubst sub outer + innerTerm = {-# SCC overlap_inner #-} termSubst sub inner + -- Make sure to keep in sync with overlapProof + lhs = {-# SCC overlap_eqn_1 #-} termSubst sub outer' + rhs = {-# SCC overlap_eqn_2 #-} + buildReplacePositionSub sub n (singleton inner') (singleton outer) + + guard (lhs /= rhs) + return Overlap { + overlap_depth = depth, + overlap_top = top, + overlap_inner = innerTerm, + overlap_pos = n, + overlap_eqn = lhs :=: rhs } + +-- Simplify an overlap and remove it if it's trivial. +{-# INLINE simplifyOverlap #-} +simplifyOverlap :: (Function f, Has a (Rule f)) => Index f a -> Overlap f -> Maybe (Overlap f) +simplifyOverlap idx overlap@Overlap{overlap_eqn = lhs :=: rhs, ..} + | lhs == rhs' = Nothing + | lhs' == rhs' = Nothing + | otherwise = Just overlap{overlap_eqn = lhs' :=: rhs'} + where + lhs' = simplify idx lhs + rhs' = simplify idx rhs + +-- Put these in separate functions to avoid code blowup +buildReplacePositionSub :: TriangleSubst f -> Int -> TermList f -> TermList f -> Term f +buildReplacePositionSub !sub !n !inner' !outer = + build (replacePositionSub sub n inner' outer) + +termSubst :: TriangleSubst f -> Term f -> Term f +termSubst sub t = build (Term.subst sub t) + +-- The critical pair ordering heuristic. +data Config = + Config { + cfg_lhsweight :: !Int, + cfg_rhsweight :: !Int, + cfg_funweight :: !Int, + cfg_varweight :: !Int, + cfg_depthweight :: !Int, + cfg_dupcost :: !Int, + cfg_dupfactor :: !Int } + +-- We compute: +-- cfg_lhsweight * size l + cfg_rhsweight * size r +-- where l is the biggest term and r is the smallest, +-- and variables have weight 1 and functions have weight cfg_funweight. +{-# INLINEABLE score #-} +score :: Function f => Config -> Overlap f -> Int +score config overlap@Overlap{overlap_eqn = t :=: u} = + -- Look at the length to decide on various special cases + case (len t, len u) of + (1, 1) -> + -- true = false + fromMaybe (normalScore config overlap) + (trueEqualsFalse t u `mplus` trueEqualsFalse u t) + (1, _) -> + -- false = equals(t, u) where t, u unifiable + fromMaybe (normalScore config overlap) + (equalsFalse t u) + (_, 1) -> + -- equals(t, u) = false where t, u unifiable + fromMaybe (normalScore config overlap) + (equalsFalse u t) + _ -> normalScore config overlap + where + -- N.B. the code above puts the arguments in the right order + trueEqualsFalse (App true Empty) (App false Empty) + | true == trueCon && false == falseCon = Just 1 + trueEqualsFalse _ _ = Nothing + + equalsFalse (App false Empty) (App equals (Cons t (Cons u Empty))) + | false == falseCon && equals == equalsCon = + if isJust (unify t u) then Just 2 + else Just (normalScore config overlap{overlap_eqn = t :=: u}) + equalsFalse _ _ = Nothing + +{-# INLINEABLE normalScore #-} +normalScore :: Function f => Config -> Overlap f -> Int +normalScore Config{..} Overlap{..} = + fromIntegral overlap_depth * cfg_depthweight + + (m + n) * cfg_rhsweight + + intMax m n * (cfg_lhsweight - cfg_rhsweight) + where + l :=: r = overlap_eqn + m = size' 0 (singleton l) + n = size' 0 (singleton r) + + size' !n Empty = n + size' n (Cons t ts) + | len t > 1, t `isSubtermOfList` ts = + size' (n+cfg_dupcost+cfg_dupfactor*size t) ts + size' n (Cons (Var _) ts) = + size' (n+cfg_varweight) ts + size' n (ConsSym (App f _) ts) = + size' (n+cfg_funweight*size f) ts + +---------------------------------------------------------------------- +-- Higher-level handling of critical pairs. +---------------------------------------------------------------------- + +-- A critical pair together with information about how it was derived +data CriticalPair f = + CriticalPair { + cp_eqn :: {-# UNPACK #-} !(Equation f), + cp_depth :: {-# UNPACK #-} !Depth, + cp_top :: !(Maybe (Term f)), + cp_proof :: !(Derivation f) } + deriving Generic + +instance Symbolic (CriticalPair f) where + type ConstantOf (CriticalPair f) = f + termsDL CriticalPair{..} = + termsDL cp_eqn `mplus` termsDL cp_top `mplus` termsDL cp_proof + subst_ sub CriticalPair{..} = + CriticalPair { + cp_eqn = subst_ sub cp_eqn, + cp_depth = cp_depth, + cp_top = subst_ sub cp_top, + cp_proof = subst_ sub cp_proof } + +instance PrettyTerm f => Pretty (CriticalPair f) where + pPrint CriticalPair{..} = + vcat [ + pPrint cp_eqn, + nest 2 (text "top:" <+> pPrint cp_top) ] + +-- Split a critical pair so that it can be turned into rules. +-- See the comment below. +split :: Function f => CriticalPair f -> [CriticalPair f] +split CriticalPair{cp_eqn = l :=: r, ..} + | l == r = [] + | otherwise = + -- If we have something which is almost a rule, except that some + -- variables appear only on the right-hand side, e.g.: + -- f x y -> g x z + -- then we replace it with the following two rules: + -- f x y -> g x ? + -- g x z -> g x ? + -- where the second rule is weakly oriented and ? is the minimal + -- constant. + -- + -- If we have an unoriented equation with a similar problem, e.g.: + -- f x y = g x z + -- then we replace it with potentially three rules: + -- f x ? = g x ? + -- f x y -> f x ? + -- g x z -> g x ? + + -- The main rule l -> r' or r -> l' or l' = r' + [ CriticalPair { + cp_eqn = l :=: r', + cp_depth = cp_depth, + cp_top = eraseExcept (vars l) cp_top, + cp_proof = eraseExcept (vars l) cp_proof } + | ord == Just GT ] ++ + [ CriticalPair { + cp_eqn = r :=: l', + cp_depth = cp_depth, + cp_top = eraseExcept (vars r) cp_top, + cp_proof = Proof.symm (eraseExcept (vars r) cp_proof) } + | ord == Just LT ] ++ + [ CriticalPair { + cp_eqn = l' :=: r', + cp_depth = cp_depth, + cp_top = eraseExcept (vars l) $ eraseExcept (vars r) cp_top, + cp_proof = eraseExcept (vars l) $ eraseExcept (vars r) cp_proof } + | ord == Nothing ] ++ + + -- Weak rules l -> l' or r -> r' + [ CriticalPair { + cp_eqn = l :=: l', + cp_depth = cp_depth + 1, + cp_top = Nothing, + cp_proof = cp_proof `Proof.trans` Proof.symm (erase ls cp_proof) } + | not (null ls), ord /= Just GT ] ++ + [ CriticalPair { + cp_eqn = r :=: r', + cp_depth = cp_depth + 1, + cp_top = Nothing, + cp_proof = Proof.symm cp_proof `Proof.trans` erase rs cp_proof } + | not (null rs), ord /= Just LT ] + where + ord = orientTerms l' r' + l' = erase ls l + r' = erase rs r + ls = usort (vars l) \\ usort (vars r) + rs = usort (vars r) \\ usort (vars l) + + eraseExcept vs t = + erase (usort (vars t) \\ usort vs) t + +{-# INLINEABLE makeCriticalPair #-} +makeCriticalPair :: + (Has a (Rule f), Has a (Lemma f), Has a Id, Function f) => + a -> a -> Overlap f -> Maybe (CriticalPair f) +makeCriticalPair r1 r2 overlap@Overlap{..} + | lessEq overlap_top t = Nothing + | lessEq overlap_top u = Nothing + | otherwise = + Just $ + CriticalPair overlap_eqn + overlap_depth + (Just overlap_top) + (overlapProof r1 r2 overlap) + where + t :=: u = overlap_eqn + +-- Return a proof for a critical pair. +{-# INLINEABLE overlapProof #-} +overlapProof :: + forall a f. + (Has a (Rule f), Has a (Lemma f), Has a Id) => + a -> a -> Overlap f -> Derivation f +overlapProof left right Overlap{..} = + Proof.symm (reductionProof (step left leftSub)) + `Proof.trans` + congPath path overlap_top (reductionProof (step right rightSub)) + where + Just leftSub = match (lhs (the left)) overlap_top + Just rightSub = match (lhs (the right)) overlap_inner + + path = positionToPath (lhs (the left) :: Term f) overlap_pos diff --git a/src/Twee/ChurchList.hs b/src/Twee/ChurchList.hs new file mode 100644 --- /dev/null +++ b/src/Twee/ChurchList.hs @@ -0,0 +1,99 @@ +-- Church-encoded lists. Used in Twee.CP to make sure that fusion happens. +{-# LANGUAGE Rank2Types, BangPatterns #-} +module Twee.ChurchList where + +import Prelude(Functor(..), Applicative(..), Monad(..), Bool(..), Maybe(..), (.), ($), id) +import qualified Prelude +import GHC.Magic(oneShot) +import GHC.Exts(build) +import Control.Monad(MonadPlus(..), liftM2) +import Control.Applicative(Alternative(..)) + +newtype ChurchList a = + ChurchList (forall b. (a -> b -> b) -> b -> b) + +{-# INLINE foldr #-} +foldr :: (a -> b -> b) -> b -> ChurchList a -> b +foldr op e (ChurchList f) = eta (f op (eta e)) + -- Using eta here seems to help with eta-expanding foldl' + +{-# INLINE[0] eta #-} +eta :: a -> a +eta x = x +{-# RULES "eta" forall f. eta f = \x -> f x #-} + +{-# INLINE nil #-} +nil :: ChurchList a +nil = ChurchList (\_ n -> n) + +{-# INLINE unit #-} +unit :: a -> ChurchList a +unit x = ChurchList (\c n -> c x n) + +{-# INLINE cons #-} +cons :: a -> ChurchList a -> ChurchList a +cons x xs = ChurchList (\c n -> c x (foldr c n xs)) + +{-# INLINE append #-} +append :: ChurchList a -> ChurchList a -> ChurchList a +append xs ys = ChurchList (\c n -> foldr c (foldr c n ys) xs) + +{-# INLINE join #-} +join :: ChurchList (ChurchList a) -> ChurchList a +join xss = ChurchList (\c n -> foldr (\xs ys -> foldr c ys xs) n xss) + +instance Functor ChurchList where + {-# INLINE fmap #-} + fmap f xs = ChurchList (\c n -> foldr (c . f) n xs) + +instance Applicative ChurchList where + {-# INLINE pure #-} + pure = return + {-# INLINE (<*>) #-} + (<*>) = liftM2 ($) + +instance Monad ChurchList where + {-# INLINE return #-} + return = unit + {-# INLINE (>>=) #-} + xs >>= f = join (fmap f xs) + +instance Alternative ChurchList where + {-# INLINE empty #-} + empty = nil + {-# INLINE (<|>) #-} + (<|>) = append + +instance MonadPlus ChurchList where + {-# INLINE mzero #-} + mzero = empty + {-# INLINE mplus #-} + mplus = (<|>) + +{-# INLINE fromList #-} +fromList :: [a] -> ChurchList a +fromList xs = ChurchList (\c n -> Prelude.foldr c n xs) + +{-# INLINE toList #-} +toList :: ChurchList a -> [a] +toList (ChurchList f) = build f + +{-# INLINE foldl' #-} +foldl' :: (b -> a -> b) -> b -> ChurchList a -> b +foldl' op e xs = + foldr (\x f -> oneShot (\ (!acc) -> f (op acc x))) id xs e + +{-# INLINE filter #-} +filter :: (a -> Bool) -> ChurchList a -> ChurchList a +filter p xs = + ChurchList $ \c n -> + let + {-# INLINE op #-} + op x xs = if p x then c x xs else xs + in + foldr op n xs + +{-# INLINE fromMaybe #-} +fromMaybe :: Maybe a -> ChurchList a +fromMaybe Nothing = nil +fromMaybe (Just x) = unit x diff --git a/src/Twee/Constraints.hs b/src/Twee/Constraints.hs --- a/src/Twee/Constraints.hs +++ b/src/Twee/Constraints.hs @@ -1,7 +1,6 @@ -{-# LANGUAGE TypeFamilies, CPP, FlexibleContexts, UndecidableInstances, StandaloneDeriving, RecordWildCards, GADTs, ScopedTypeVariables, PatternGuards, PatternSynonyms #-} +{-# LANGUAGE FlexibleContexts, UndecidableInstances, RecordWildCards #-} module Twee.Constraints where -#include "errors.h" --import Twee.Base hiding (equals, Term, pattern Fun, pattern Var, lookup, funs) import qualified Twee.Term as Flat import qualified Data.Map.Strict as Map @@ -15,16 +14,14 @@ import Data.Ord import Twee.Term hiding (lookup) -data Atom f = Constant (Fun f) | Variable Var deriving Show -deriving instance Eq (Fun f) => Eq (Atom f) -deriving instance Ord (Fun f) => Ord (Atom f) +data Atom f = Constant (Fun f) | Variable Var deriving (Show, Eq, Ord) {-# INLINE atoms #-} atoms :: Term f -> [Atom f] atoms t = aux (singleton t) where aux Empty = [] - aux (Cons (Fun f Empty) t) = Constant f:aux t + aux (Cons (App f Empty) t) = Constant f:aux t aux (Cons (Var x) t) = Variable x:aux t aux (ConsSym _ t) = aux t @@ -33,11 +30,11 @@ toTerm (Variable x) = build (var x) fromTerm :: Flat.Term f -> Maybe (Atom f) -fromTerm (Fun f Empty) = Just (Constant f) +fromTerm (App f Empty) = Just (Constant f) fromTerm (Var x) = Just (Variable x) fromTerm _ = Nothing -instance (Numbered f, PrettyTerm f) => Pretty (Atom f) where +instance PrettyTerm f => Pretty (Atom f) where pPrint = pPrint . toTerm data Formula f = @@ -45,11 +42,9 @@ | LessEq (Atom f) (Atom f) | And [Formula f] | Or [Formula f] - deriving Show -deriving instance Eq (Fun f) => Eq (Formula f) -deriving instance Ord (Fun f) => Ord (Formula f) + deriving (Eq, Ord, Show) -instance (Numbered f, PrettyTerm f) => Pretty (Formula f) where +instance PrettyTerm f => Pretty (Formula f) where pPrintPrec _ _ (Less t u) = hang (pPrint t <+> text "<") 2 (pPrint u) pPrintPrec _ _ (LessEq t u) = hang (pPrint t <+> text "<=") 2 (pPrint u) pPrintPrec _ _ (And []) = text "true" @@ -59,13 +54,13 @@ (fsep (punctuate (text " &") (nest_ (map (pPrintPrec l 11) xs)))) where nest_ (x:xs) = x:map (nest 2) xs - nest_ [] = __ + nest_ [] = undefined pPrintPrec l p (Or xs) = pPrintParen (p > 10) (fsep (punctuate (text " |") (nest_ (map (pPrintPrec l 11) xs)))) where nest_ (x:xs) = x:map (nest 2) xs - nest_ [] = __ + nest_ [] = undefined negateFormula :: Formula f -> Formula f negateFormula (Less t u) = LessEq u t @@ -103,12 +98,11 @@ -- Branches are kept normalised wrt equals Branch { funs :: [Fun f], - less :: [(Atom f, Atom f)], - equals :: [(Atom f, Atom f)] } -- greatest atom first -deriving instance Eq (Fun f) => Eq (Branch f) -deriving instance Ord (Fun f) => Ord (Branch f) + less :: [(Atom f, Atom f)], -- sorted + equals :: [(Atom f, Atom f)] } -- sorted, greatest atom first in each pair + deriving (Eq, Ord) -instance (Numbered f, PrettyTerm f) => Pretty (Branch f) where +instance PrettyTerm f => Pretty (Branch f) where pPrint Branch{..} = braces $ fsep $ punctuate (text ",") $ [pPrint x <+> text "<" <+> pPrint y | (x, y) <- less ] ++ @@ -120,7 +114,7 @@ norm :: Eq f => Branch f -> Atom f -> Atom f norm Branch{..} x = fromMaybe x (lookup x equals) -contradictory :: (Numbered f, Minimal f, Ord f) => Branch f -> Bool +contradictory :: (Minimal f, Ord f) => Branch f -> Bool contradictory Branch{..} = or [f == minimal | (_, Constant f) <- less] || or [f /= g | (Constant f, Constant g) <- equals] || @@ -130,7 +124,7 @@ cyclic (AcyclicSCC _) = False cyclic (CyclicSCC _) = True -formAnd :: (Numbered f, Minimal f, Ord f) => Formula f -> [Branch f] -> [Branch f] +formAnd :: (Minimal f, Ordered f) => Formula f -> [Branch f] -> [Branch f] formAnd f bs = usort (bs >>= add f) where add (Less t u) b = addLess t u b @@ -139,7 +133,7 @@ add (And (f:fs)) b = add f b >>= add (And fs) add (Or fs) b = usort (concat [ add f b | f <- fs ]) -branches :: (Numbered f, Minimal f, Ord f) => Formula f -> [Branch f] +branches :: (Minimal f, Ordered f) => Formula f -> [Branch f] branches x = aux [x] where aux [] = [Branch [] [] []] @@ -151,7 +145,7 @@ concatMap (addLess t u) (aux xs) ++ concatMap (addEquals u t) (aux xs) -addLess :: (Numbered f, Minimal f, Ord f) => Atom f -> Atom f -> Branch f -> [Branch f] +addLess :: (Minimal f, Ordered f) => Atom f -> Atom f -> Branch f -> [Branch f] addLess _ (Constant min) _ | min == minimal = [] addLess (Constant min) _ b | min == minimal = [b] addLess t0 u0 b@Branch{..} = @@ -161,7 +155,7 @@ t = norm b t0 u = norm b u0 -addEquals :: (Numbered f, Minimal f, Ord f) => Atom f -> Atom f -> Branch f -> [Branch f] +addEquals :: (Minimal f, Ordered f) => Atom f -> Atom f -> Branch f -> [Branch f] addEquals t0 u0 b@Branch{..} | t == u || (t, u) `elem` equals = [b] | otherwise = @@ -177,22 +171,24 @@ | x == t = u | otherwise = x -addTerm :: (Numbered f, Minimal f, Ord f) => Atom f -> Branch f -> Branch f +addTerm :: (Minimal f, Ordered f) => Atom f -> Branch f -> Branch f addTerm (Constant f) b | f `notElem` funs b = b { funs = f:funs b, - less = [ (Constant f, Constant g) | g <- funs b, f < g ] ++ - [ (Constant g, Constant f) | g <- funs b, g < f ] ++ less b } + less = + usort $ + [ (Constant f, Constant g) | g <- funs b, f << g ] ++ + [ (Constant g, Constant f) | g <- funs b, g << f ] ++ less b } addTerm _ b = b newtype Model f = Model (Map (Atom f) (Int, Int)) - deriving Show + deriving (Eq, Show) -- Representation: map from atom to (major, minor) -- x < y if major x < major y -- x <= y if major x = major y and minor x < minor y -instance (Numbered f, PrettyTerm f) => Pretty (Model f) where +instance PrettyTerm f => Pretty (Model f) where pPrint (Model m) | Map.size m <= 1 = text "empty" | otherwise = fsep (go (sortBy (comparing snd) (Map.toList m))) @@ -213,13 +209,13 @@ where rel = if i == j then LessEq else Less -modelFromOrder :: (Numbered f, Minimal f, Ord f) => [Atom f] -> Model f +modelFromOrder :: (Minimal f, Ord f) => [Atom f] -> Model f modelFromOrder xs = Model (Map.fromList [(x, (i, i)) | (x, i) <- zip xs [0..]]) -weakenModel :: Ord (Fun f) => Model f -> [Model f] +weakenModel :: Model f -> [Model f] weakenModel (Model m) = - [ Model (Map.delete x m) | x <- Map.keys m ] ++ + [ Model (Map.delete x m) | x <- Map.keys m ] ++ [ Model (Map.fromList xs) | xs <- glue (sortBy (comparing snd) (Map.toList m)), all ok (groupBy ((==) `on` (fst . snd)) xs) ] @@ -233,10 +229,10 @@ -- We must never make two constants equal ok xs = length [x | (Constant x, _) <- xs] <= 1 -varInModel :: (Numbered f, Minimal f, Ord f) => Model f -> Var -> Bool +varInModel :: (Minimal f, Ord f) => Model f -> Var -> Bool varInModel (Model m) x = Variable x `Map.member` m -varGroups :: (Numbered f, Minimal f, Ord f) => Model f -> [(Fun f, [Var], Maybe (Fun f))] +varGroups :: (Minimal f, Ord f) => Model f -> [(Fun f, [Var], Maybe (Fun f))] varGroups (Model m) = filter nonempty (go minimal (map fst (sortBy (comparing snd) (Map.toList m)))) where go f xs = @@ -250,14 +246,11 @@ nonempty (_, [], _) = False nonempty _ = True -class Minimal a where - minimal :: a - -instance (Numbered f, Minimal f) => Minimal (Fun f) where - minimal = toFun minimal +class Minimal f where + minimal :: Fun f {-# INLINE lessEqInModel #-} -lessEqInModel :: (Numbered f, Minimal f, Ord f) => Model f -> Atom f -> Atom f -> Maybe Strictness +lessEqInModel :: (Minimal f, Ordered f) => Model f -> Atom f -> Atom f -> Maybe Strictness lessEqInModel (Model m) x y | Just (a, _) <- Map.lookup x m, Just (b, _) <- Map.lookup y m, @@ -266,36 +259,39 @@ Just b <- Map.lookup y m, a < b = Just Nonstrict | x == y = Just Nonstrict - | Constant a <- x, Constant b <- y, a < b = Just Strict + | Constant a <- x, Constant b <- y, a << b = Just Strict | Constant a <- x, a == minimal = Just Nonstrict | otherwise = Nothing -solve :: (Numbered f, Minimal f, Ord f, PrettyTerm f) => [Atom f] -> Branch f -> Either (Model f) (Subst f) +solve :: (Minimal f, Ordered f, PrettyTerm f) => [Atom f] -> Branch f -> Either (Model f) (Subst f) solve xs branch@Branch{..} | null equals && not (all true less) = - ERROR("Model " ++ prettyShow model ++ " is not a model of " ++ prettyShow branch ++ " (edges = " ++ prettyShow edges ++ ", vs = " ++ prettyShow vs ++ ")") + error $ "Model " ++ prettyShow model ++ " is not a model of " ++ prettyShow branch ++ " (edges = " ++ prettyShow edges ++ ", vs = " ++ prettyShow vs ++ ")" | null equals = Left model | otherwise = Right sub where - sub = fromMaybe __ . flattenSubst $ + sub = fromMaybe undefined . flattenSubst $ [(x, toTerm y) | (Variable x, y) <- equals] ++ [(y, toTerm x) | (x@Constant{}, Variable y) <- equals] vs = Constant minimal:reverse (flattenSCCs (stronglyConnComp edges)) - edges = [(x, x, [y | (x', y) <- less', x == x']) | x <- as] - less' = less ++ [(Constant x, Constant y) | Constant x <- as, Constant y <- as, x < y] + edges = [(x, x, [y | (x', y) <- less', x == x']) | x <- as, x /= Constant minimal] + less' = less ++ [(Constant x, Constant y) | Constant x <- as, Constant y <- as, x << y] as = usort $ xs ++ map fst less ++ map snd less model = modelFromOrder vs true (t, u) = lessEqInModel model t u == Just Strict class Ord f => Ordered f where - orientTerms :: Term f -> Term f -> Maybe Ordering - orientTerms t u - | t == u = Just EQ - | lessEq t u = Just LT - | lessEq u t = Just GT - | otherwise = Nothing - lessEq :: Term f -> Term f -> Bool lessIn :: Model f -> Term f -> Term f -> Maybe Strictness data Strictness = Strict | Nonstrict deriving (Eq, Show) + +lessThan :: Ordered f => Term f -> Term f -> Bool +lessThan t u = lessEq t u && isNothing (unify t u) + +orientTerms :: Ordered f => Term f -> Term f -> Maybe Ordering +orientTerms t u + | t == u = Just EQ + | lessEq t u = Just LT + | lessEq u t = Just GT + | otherwise = Nothing diff --git a/src/Twee/Equation.hs b/src/Twee/Equation.hs new file mode 100644 --- /dev/null +++ b/src/Twee/Equation.hs @@ -0,0 +1,55 @@ +{-# LANGUAGE DeriveGeneric, TypeFamilies #-} +module Twee.Equation where + +import Twee.Base +import GHC.Generics +import Data.Maybe + +-------------------------------------------------------------------------------- +-- Equations. +-------------------------------------------------------------------------------- + +data Equation f = + (:=:) { + eqn_lhs :: {-# UNPACK #-} !(Term f), + eqn_rhs :: {-# UNPACK #-} !(Term f) } + deriving (Eq, Ord, Show, Generic) +type EquationOf a = Equation (ConstantOf a) + +instance Symbolic (Equation f) where + type ConstantOf (Equation f) = f + +instance PrettyTerm f => Pretty (Equation f) where + pPrint (x :=: y) = pPrint x <+> text "=" <+> pPrint y + +instance Sized f => Sized (Equation f) where + size (x :=: y) = size x + size y + +-- Order an equation roughly left-to-right. +-- However, there is no guarantee that the result is oriented. +order :: Function f => Equation f -> Equation f +order (l :=: r) + | l == r = l :=: r + | otherwise = + case compare (size l) (size r) of + LT -> r :=: l + GT -> l :=: r + EQ -> if lessEq l r then r :=: l else l :=: r + +-- Apply a function to both sides of an equation. +bothSides :: (Term f -> Term f') -> Equation f -> Equation f' +bothSides f (t :=: u) = f t :=: f u + +-- Is an equation of the form t = t? +trivial :: Eq f => Equation f -> Bool +trivial (t :=: u) = t == u + +simplerThan :: Function f => Equation f -> Equation f -> Bool +eq1 `simplerThan` eq2 = + t1 `lessEq` t2 && + (isNothing (unify t1 t2) || (u1 `lessEq` u2)) + where + t1 :=: u1 = skolemise eq1 + t2 :=: u2 = skolemise eq2 + + skolemise = subst (con . skolem) diff --git a/src/Twee/Heap.hs b/src/Twee/Heap.hs new file mode 100644 --- /dev/null +++ b/src/Twee/Heap.hs @@ -0,0 +1,130 @@ +{-# LANGUAGE BangPatterns, ScopedTypeVariables #-} +-- Skew heaps. +module Twee.Heap( + Heap, empty, insert, removeMin, mapMaybe, size) where + +data Heap a = Heap {-# UNPACK #-} !Int !(Heap1 a) deriving Show +data Heap1 a = Nil | Node a (Heap1 a) (Heap1 a) deriving Show + +{-# INLINEABLE merge #-} +merge :: Ord a => Heap a -> Heap a -> Heap a +merge (Heap n1 h1) (Heap n2 h2) = Heap (n1+n2) (merge1 h1 h2) + +{-# INLINEABLE merge1 #-} +merge1 :: forall a. Ord a => Heap1 a -> Heap1 a -> Heap1 a +merge1 = m1 + where + -- For some reason using m1 improves the code generation... + m1 :: Heap1 a -> Heap1 a -> Heap1 a + m1 Nil h = h + m1 h Nil = h + m1 h1@(Node x1 l1 r1) h2@(Node x2 l2 r2) + | x1 <= x2 = (Node x1 $! m1 r1 h2) l1 + | otherwise = (Node x2 $! m1 r2 h1) l2 + +{-# INLINE unit #-} +unit :: a -> Heap a +unit !x = Heap 1 (Node x Nil Nil) + +{-# INLINE empty #-} +empty :: Heap a +empty = Heap 0 Nil + +{-# INLINEABLE insert #-} +insert :: Ord a => a -> Heap a -> Heap a +insert x h = merge (unit x) h + +{-# INLINEABLE removeMin #-} +removeMin :: Ord a => Heap a -> Maybe (a, Heap a) +removeMin (Heap _ Nil) = Nothing +removeMin (Heap n (Node x l r)) = Just (x, Heap (n-1) (merge1 l r)) + +{-# INLINEABLE mapMaybe #-} +mapMaybe :: Ord b => (a -> Maybe b) -> Heap a -> Heap b +mapMaybe f (Heap _ h) = Heap (sz 0 h') h' + where + sz !n Nil = n + sz !n (Node _ l r) = sz (sz (n+1) l) r + + h' = go h + + go Nil = Nil + go (Node x l r) = + case f x of + Nothing -> merge1 l' r' + Just !y -> down y l' r' + where + !l' = go l + !r' = go r + + down x l@(Node y ll lr) r@(Node z rl rr) + | y < x && y <= z = + (Node y $! down x ll lr) r + | z < x && z <= y = + Node z l $! down x rl rr + down x Nil (Node y l r) + | y < x = + Node y Nil $! down x l r + down x (Node y l r) Nil + | y < x = + (Node y $! down x l r) Nil + down x l r = Node x l r + +{-# INLINE size #-} +size :: Heap a -> Int +size (Heap n _) = n + +-- Testing code: +-- import Test.QuickCheck +-- import qualified Data.List as List +-- import qualified Data.Maybe as Maybe + +-- instance (Arbitrary a, Ord a) => Arbitrary (Heap a) where +-- arbitrary = sized arb +-- where +-- arb 0 = return empty +-- arb n = +-- frequency +-- [(1, unit <$> arbitrary), +-- (n-1, merge <$> arb' <*> arb')] +-- where +-- arb' = arb (n `div` 2) + +-- toList :: Ord a => Heap a -> [a] +-- toList = List.unfoldr removeMin + +-- invariant :: Ord a => Heap a -> Bool +-- invariant h@(Heap n h1) = +-- n == length (toList h) && ord h1 +-- where +-- ord Nil = True +-- ord (Node x l r) = ord1 x l && ord1 x r + +-- ord1 _ Nil = True +-- ord1 x h@(Node y _ _) = x <= y && ord h + +-- prop_1 h = withMaxSuccess 10000 $ invariant h +-- prop_2 x h = withMaxSuccess 10000 $ invariant (insert x h) +-- prop_3 h = +-- withMaxSuccess 1000 $ +-- case removeMin h of +-- Nothing -> discard +-- Just (_, h) -> invariant h +-- prop_4 h = withMaxSuccess 10000 $ List.sort (toList h) == toList h +-- prop_5 x h = withMaxSuccess 10000 $ toList (insert x h) == List.insert x (toList h) +-- prop_6 x h = +-- withMaxSuccess 1000 $ +-- case removeMin h of +-- Nothing -> discard +-- Just (x, h') -> toList h == List.insert x (toList h') +-- prop_7 h1 h2 = withMaxSuccess 10000 $ +-- invariant (merge h1 h2) +-- prop_8 h1 h2 = withMaxSuccess 10000 $ +-- toList (merge h1 h2) == List.sort (toList h1 ++ toList h2) +-- prop_9 (Blind f) h = withMaxSuccess 10000 $ +-- invariant (mapMaybe f h) +-- prop_10 (Blind f) h = withMaxSuccess 1000000 $ +-- toList (mapMaybe f h) == List.sort (Maybe.mapMaybe f (toList h)) + +-- return [] +-- main = $quickCheckAll diff --git a/src/Twee/Index.hs b/src/Twee/Index.hs --- a/src/Twee/Index.hs +++ b/src/Twee/Index.hs @@ -1,180 +1,161 @@ --- Term indexing (perfect discrimination trees). -{-# LANGUAGE BangPatterns, CPP, TypeFamilies, RecordWildCards #-} +-- Term indexing (perfect-ish discrimination trees). +{-# LANGUAGE BangPatterns, RecordWildCards, OverloadedStrings, FlexibleContexts #-} -- We get some bogus warnings because of pattern synonyms. {-# OPTIONS_GHC -fno-warn-overlapping-patterns #-} -{-# OPTIONS_GHC -funfolding-creation-threshold=1000000 -funfolding-use-threshold=1000000 #-} -module Twee.Index where +module Twee.Index(module Twee.Index, module Twee.Index.Lookup) where -#include "errors.h" import qualified Prelude import Prelude hiding (filter, map, null) -import Twee.Base hiding (var, fun, empty, vars, size) +import Data.Maybe +import Twee.Base hiding (var, fun, empty, size, singleton, prefix, funs, lookupList) import qualified Twee.Term as Term import Twee.Array import qualified Data.List as List -import Data.Maybe - -data Index a = - Index { - size :: {-# UNPACK #-} !Int, - here :: [Entry a], - fun :: {-# UNPACK #-} !(Array (Index a)), - var :: !(Index a) } | - Singleton { - key :: {-# UNPACK #-} !(TermListOf a), - value :: {-# UNPACK #-} !(Entry a) } | - Nil - deriving Show - -instance Default (Index a) where def = Nil - -data Entry a = - Entry { - e_key :: {-# UNPACK #-} !(TermOf a), - e_value :: a } - deriving (Eq, Show) +import Twee.Utils +import Twee.Index.Lookup {-# INLINE null #-} -null :: Index a -> Bool +null :: Index f a -> Bool null Nil = True null _ = False {-# INLINEABLE singleton #-} -singleton :: Symbolic a => a -> Index a -singleton x = Singleton (Term.singleton t) (Entry t x) - where - t = term x +singleton :: Term f -> a -> Index f a +singleton !t x = singletonEntry (key t) x -{-# INLINEABLE insert #-} -insert :: Symbolic a => a -> Index a -> Index a -insert x0 !idx = aux (Term.singleton t) idx +{-# INLINE singletonEntry #-} +singletonEntry :: TermList f -> a -> Index f a +singletonEntry t x = Index 0 t [x] newArray newVarIndex + +{-# INLINE withPrefix #-} +withPrefix :: TermList f -> Index f a -> Index f a +withPrefix Empty idx = idx +withPrefix _ Nil = Nil +withPrefix t idx@Index{..} = + idx{prefix = buildList (builder t `mappend` builder prefix)} + +insert :: Term f -> a -> Index f a -> Index f a +insert !t x !idx = {-# SCC insert #-} aux (key t) idx where - aux t Nil = Singleton t x - aux t (Singleton u x) = aux t (expand u x) - aux Empty idx@Index{..} = idx { size = 0, here = x:here } - aux t@(ConsSym (Fun (MkFun f) _) u) idx = + aux t Nil = singletonEntry t x + aux (Cons t ts) idx@Index{prefix = Cons u us} | t == u = + withPrefix (Term.singleton t) (aux ts idx{prefix = us}) + aux t idx@Index{prefix = Cons{}} = aux t (expand idx) + + aux Empty idx = + idx { size = 0, here = x:here idx } + aux t@(ConsSym (App f _) u) idx = idx { size = lenList t `min` size idx, - fun = update f idx' (fun idx) } + fun = update (fun_id f) idx' (fun idx) } where - idx' = aux u (fun idx ! f) - aux t@(ConsSym (Var _) u) idx = + idx' = aux u (fun idx ! fun_id f) + aux t@(ConsSym (Var v) u) idx = idx { size = lenList t `min` size idx, - var = aux u (var idx) } - t = term x0 - x = Entry t x0 + var = updateVarIndex v idx' (var idx) } + where + idx' = aux u (lookupVarIndex v (var idx)) {-# INLINE expand #-} -expand :: TermListOf a -> Entry a -> Index a -expand Empty x = Index 0 [x] newArray Nil -expand (ConsSym s t) x = - Index (1+lenList t) [] fun var +expand :: Index f a -> Index f a +expand idx@Index{prefix = ConsSym t ts} = + case t of + Var v -> + Index (size idx + 1 + lenList ts) emptyTermList [] newArray + (updateVarIndex v idx { prefix = ts } newVarIndex) + App f _ -> + Index (size idx + 1 + lenList ts) emptyTermList [] + (update (fun_id f) idx { prefix = ts } newArray) newVarIndex + +key :: Term f -> TermList f +key t = buildList . aux . Term.singleton $ t where - (fun, var) = - case s of - Fun (MkFun f) _ -> - (update f (Singleton t x) newArray, Nil) - Var _ -> - (newArray, Singleton t x) + repeatedVars = [x | x <- usort (vars t), occVar x t > 1] + aux Empty = mempty + aux (ConsSym (App f _) t) = + con f `mappend` aux t + aux (ConsSym (Var x) t) = + Term.var ( + case List.elemIndex x (take varIndexCapacity repeatedVars) of + Nothing -> V 2 + Just n -> V n) `mappend` aux t + {-# INLINEABLE delete #-} -delete :: (Eq a, Symbolic a) => a -> Index a -> Index a -delete x0 !idx = aux (Term.singleton t) idx +delete :: Eq a => Term f -> a -> Index f a -> Index f a +delete !t x !idx = {-# SCC delete #-} aux (key t) idx where aux _ Nil = Nil - aux t idx@(Singleton u y) - | t == u && x == y = Nil - | otherwise = idx - aux Empty idx = idx { here = List.delete x (here idx) } - aux (ConsSym (Fun (MkFun f) _) t) idx = - idx { fun = update f (aux t (fun idx ! f)) (fun idx) } - aux (ConsSym (Var _) t) idx = - idx { var = aux t (var idx) } - t = term x0 - x = Entry t x0 + aux (Cons t ts) idx@Index{prefix = Cons u us} | t == u = + withPrefix (Term.singleton t) (aux ts idx{prefix = us}) + aux _ idx@Index{prefix = Cons{}} = idx + aux Empty idx + | x `List.elem` here idx = + idx { here = List.delete x (here idx) } + | otherwise = + error "deleted term not found in index" + aux (ConsSym (App f _) t) idx = + idx { fun = update (fun_id f) (aux t (fun idx ! fun_id f)) (fun idx) } + aux (ConsSym (Var v) t) idx = + idx { var = updateVarIndex v (aux t (lookupVarIndex v (var idx))) (var idx) } + {-# INLINEABLE elem #-} -elem :: (Eq a, Symbolic a) => a -> Index a -> Bool -elem x0 !idx = aux (Term.singleton t) idx +elem :: Eq a => Term f -> a -> Index f a -> Bool +elem !t x !idx = aux (key t) idx where aux _ Nil = False - aux t (Singleton u y) - | t == u && x == y = True - | otherwise = False - aux Empty idx = List.elem x (here idx) - aux (ConsSym (Fun (MkFun f) _) t) idx = - aux t (fun idx ! f) - aux (ConsSym (Var _) t) idx = aux t (var idx) - t = term x0 - x = Entry t x0 + aux (Cons t ts) idx@Index{prefix = Cons u us} | t == u = + aux ts idx{prefix = us} + aux _ Index{prefix = Cons{}} = False -data Match a = - Match { - matchResult :: a, - matchSubst :: SubstOf a } + aux Empty idx = List.elem x (here idx) + aux (ConsSym (App f _) t) idx = + aux t (fun idx ! fun_id f) + aux (ConsSym (Var v) t) idx = + aux t (lookupVarIndex v (var idx)) -newtype Frozen a = Frozen { matchesList_ :: TermListOf a -> [Match a] } +approxMatchesList :: TermList f -> Index f a -> [a] +approxMatchesList t idx = + {-# SCC approxMatchesList #-} + run (Frame emptySubst2 t idx Stop) -matchesList :: TermListOf a -> Frozen a -> [Match a] -matchesList = flip matchesList_ +{-# INLINE approxMatches #-} +approxMatches :: Term f -> Index f a -> [a] +approxMatches t idx = approxMatchesList (Term.singleton t) idx -{-# INLINEABLE lookup #-} -lookup :: Symbolic a => TermOf a -> Frozen a -> [a] -lookup t idx = [subst sub x | Match x sub <- matches t idx] +{-# INLINEABLE matchesList #-} +matchesList :: Has a (Term f) => TermList f -> Index f a -> [(Subst f, a)] +matchesList t idx = + [ (sub, x) + | x <- approxMatchesList t idx, + sub <- maybeToList (matchList (Term.singleton (the x)) t)] {-# INLINE matches #-} -matches :: TermOf a -> Frozen a -> [Match a] +matches :: Has a (Term f) => Term f -> Index f a -> [(Subst f, a)] matches t idx = matchesList (Term.singleton t) idx -freeze :: Index a -> Frozen a -freeze idx = Frozen $ \t -> find t idx [] +{-# INLINEABLE lookupList #-} +lookupList :: (Has a b, Symbolic b, Has b (TermOf b)) => TermListOf b -> Index (ConstantOf b) a -> [b] +lookupList t idx = + [ subst sub x + | x <- List.map the (approxMatchesList t idx), + sub <- maybeToList (matchList (Term.singleton (the x)) t)] -find :: TermListOf a -> Index a -> [Match a] -> [Match a] -find t idx xs = aux t idx xs - where - aux !_ !_ _ | False = __ - aux _ Nil rest = rest - aux t Index{size = size} rest - | lenList t < size = rest - aux Empty Index{here = here} rest = {-# SCC "try_here" #-} try here rest - aux t (Singleton u x) rest - | isJust (matchList u t) = {-# SCC "try_singleton" #-} try [x] rest - | otherwise = rest - aux t@(ConsSym (Fun (MkFun n) _) ts) Index{fun = fun, var = var} rest = - case var of - Nil -> aux ts (fun ! n) rest - _ -> aux ts (fun ! n) (aux us var rest) - where - Cons _ us = t - aux (Cons _ ts) Index{var = var} rest = aux ts var rest +{-# INLINE lookup #-} +lookup :: (Has a b, Symbolic b, Has b (TermOf b)) => TermOf b -> Index (ConstantOf b) a -> [b] +lookup t idx = lookupList (Term.singleton t) idx - {-# INLINE try #-} - try [] rest = rest - try xs rest = - {-# SCC "try" #-} - [ Match x sub - | Entry u x <- xs, - sub <- maybeToList (matchList (Term.singleton u) t) ] ++ - rest +{-# NOINLINE run #-} +run :: Stack f a -> [a] +run Stop = [] +run Frame{..} = run ({-# SCC run_inner #-} step frame_subst frame_term frame_index frame_rest) +run Yield{..} = {-# SCC run_found #-} yield_found ++ run yield_rest -elems :: Index a -> [a] +elems :: Index f a -> [a] elems Nil = [] -elems (Singleton _ x) = [e_value x] elems idx = - Prelude.map e_value (here idx) ++ + here idx ++ concatMap elems (Prelude.map snd (toList (fun idx))) ++ - elems (var idx) - -{-# INLINE map #-} -map :: (ConstantOf a ~ ConstantOf b) => (a -> b) -> Frozen a -> Frozen b -map f (Frozen matches) = Frozen $ \t -> [Match (f x) sub | Match x sub <- matches t] - -{-# INLINE filter #-} -filter :: (a -> Bool) -> Frozen a -> Frozen a -filter p (Frozen matches) = Frozen $ \t -> - [ m | m@(Match x _) <- matches t, p x ] - -{-# INLINE union #-} -union :: Frozen a -> Frozen a -> Frozen a -union (Frozen f1) (Frozen f2) = Frozen $ \t -> f1 t ++ f2 t + concatMap elems (varIndexElems (var idx)) diff --git a/src/Twee/Index/Lookup.hs b/src/Twee/Index/Lookup.hs new file mode 100644 --- /dev/null +++ b/src/Twee/Index/Lookup.hs @@ -0,0 +1,119 @@ +-- Term indexing (perfect-ish discrimination trees). +-- This module contains the type definitions and lookup function. +-- We put lookup in a separate module because it needs to be compiled +-- with inlining switched up to max, and compiling the rest of the module +-- like that is too slow. +{-# LANGUAGE BangPatterns, RecordWildCards #-} +{-# OPTIONS_GHC -funfolding-creation-threshold=10000 -funfolding-use-threshold=10000 #-} +module Twee.Index.Lookup where + +import Twee.Base hiding (var, fun, empty, size, singleton, prefix, funs) +import qualified Twee.Term as Term +import Twee.Term.Core(TermList(..)) +import Twee.Array + +data Index f a = + Index { + size :: {-# UNPACK #-} !Int, -- size of smallest term, not including prefix + prefix :: {-# UNPACK #-} !(TermList f), + here :: [a], + fun :: {-# UNPACK #-} !(Array (Index f a)), + var :: {-# UNPACK #-} !(VarIndex f a) } | + Nil + deriving Show + +instance Default (Index f a) where def = Nil + +data VarIndex f a = + VarIndex { + var0 :: !(Index f a), + var1 :: !(Index f a), + hole :: !(Index f a) } + deriving Show + +{-# INLINE newVarIndex #-} +newVarIndex :: VarIndex f a +newVarIndex = VarIndex Nil Nil Nil + +{-# INLINE lookupVarIndex #-} +lookupVarIndex :: Var -> VarIndex f a -> Index f a +lookupVarIndex (V 0) vidx = var0 vidx +lookupVarIndex (V 1) vidx = var1 vidx +lookupVarIndex _ vidx = hole vidx + +{-# INLINE updateVarIndex #-} +updateVarIndex :: Var -> Index f a -> VarIndex f a -> VarIndex f a +updateVarIndex (V 0) idx vidx = vidx { var0 = idx } +updateVarIndex (V 1) idx vidx = vidx { var1 = idx } +updateVarIndex _ idx vidx = vidx { hole = idx } + +varIndexElems :: VarIndex f a -> [Index f a] +varIndexElems vidx = [var0 vidx, var1 vidx, hole vidx] + +varIndexToList :: VarIndex f a -> [(Int, Index f a)] +varIndexToList vidx = [(0, var0 vidx), (1, var1 vidx), (2, hole vidx)] + +varIndexCapacity :: Int +varIndexCapacity = 2 + +data Subst2 f = Subst2 {-# UNPACK #-} !Int {-# UNPACK #-} !Int {-# UNPACK #-} !Int {-# UNPACK #-} !Int + +emptySubst2 :: Subst2 f +emptySubst2 = Subst2 0 0 0 0 + +{-# INLINE extend2 #-} +extend2 :: Var -> TermList f -> Subst2 f -> Maybe (Subst2 f) +extend2 (V 0) t (Subst2 _ 0 x y) = Just (Subst2 (low t) (high t) x y) +extend2 (V 0) t (Subst2 x y _ _) | t /= TermList x y (array t) = Nothing +extend2 (V 1) u (Subst2 x y _ 0) = Just (Subst2 x y (low u) (high u)) +extend2 (V 1) u (Subst2 _ _ x y) | u /= TermList x y (array u) = Nothing +extend2 _ _ sub = Just sub + +data Stack f a = + Frame { + frame_subst :: {-# UNPACK #-} !(Subst2 f), + frame_term :: {-# UNPACK #-} !(TermList f), + frame_index :: !(Index f a), + frame_rest :: !(Stack f a) } + | Yield { + yield_found :: [a], + yield_rest :: !(Stack f a) } + | Stop + +step !_ !_ _ _ | False = undefined +step _ _ Nil rest = rest +step _ t Index{size = size, prefix = prefix} rest + | lenList t < size + lenList prefix = rest +step sub t Index{..} rest = pref sub t prefix here fun var rest + +pref !_ !_ !_ _ !_ !_ _ | False = undefined +pref _ Empty Empty [] _ _ rest = rest +pref _ Empty Empty here _ _ rest = Yield here rest +pref _ Empty _ _ _ _ _ = undefined -- implies lenList t < size + lenList prefix above +pref sub (Cons t ts) (Cons (Var x) us) here fun var rest = + case extend2 x (Term.singleton t) sub of + Nothing -> rest + Just sub -> pref sub ts us here fun var rest +pref sub (ConsSym (App f _) ts) (ConsSym (App g _) us) here fun var rest + | f == g = pref sub ts us here fun var rest +pref _ _ (Cons _ _) _ _ _ rest = rest +pref sub t@(Cons u us) Empty _ fun var rest = + tryFun sub v vs fun (tryVar sub u us var rest) + where + UnsafeConsSym v vs = t + + {-# INLINE tryFun #-} + tryFun sub (App f _) ts fun rest = + case fun ! fun_id f of + Nil -> rest + idx -> Frame sub ts idx rest + tryFun _ _ _ _ rest = rest + + {-# INLINE tryVar #-} + tryVar sub t ts var rest = + foldr op rest (varIndexToList var) + where + op (x, idx@Index{}) rest + | Just sub <- extend2 (V x) (Term.singleton t) sub = + Frame sub ts idx rest + op _ rest = rest diff --git a/src/Twee/Indexes.hs b/src/Twee/Indexes.hs deleted file mode 100644 --- a/src/Twee/Indexes.hs +++ /dev/null @@ -1,44 +0,0 @@ --- Term indexing, where the inserted values can be given categories. -{-# LANGUAGE CPP, TypeFamilies, ScopedTypeVariables #-} -module Twee.Indexes where - -#include "errors.h" -import Twee.Base hiding (empty) -import qualified Twee.Index as Index -import Twee.Index(Index) -import Data.Array - -class Rated a where - rating :: a -> Int - maxRating :: a -> Int - -newtype Indexes a = - Indexes { - unIndexes :: Array Int (Index a) } - deriving Show - -{-# INLINE empty #-} -empty :: forall a. Rated a => Indexes a -empty = Indexes (listArray (0, maxRating (undefined :: a)) (repeat Index.Nil)) - -{-# INLINE singleton #-} -singleton :: (Symbolic a, Rated a) => a -> Indexes a -singleton x = insert x empty - -{-# INLINE insert #-} -insert :: forall a. (Symbolic a, Rated a) => a -> Indexes a -> Indexes a -insert x (Indexes idxs) = - Indexes (idxs // [(i, Index.insert x (idxs ! i)) | i <- [rating x..maxRating (undefined :: a)]]) - -{-# INLINE delete #-} -delete :: forall a. (Eq a, Symbolic a, Rated a) => a -> Indexes a -> Indexes a -delete x (Indexes idxs) = - Indexes (idxs // [(i, Index.delete x (idxs ! i)) | i <- [rating x..maxRating (undefined :: a)]]) - -{-# INLINE freeze #-} -freeze :: Int -> Indexes a -> Index.Frozen a -freeze n (Indexes idxs) = Index.freeze (idxs ! n) - -{-# INLINE elems #-} -elems :: forall a. Rated a => Indexes a -> [a] -elems (Indexes idxs) = Index.elems (idxs ! maxRating (undefined :: a)) diff --git a/src/Twee/Join.hs b/src/Twee/Join.hs new file mode 100644 --- /dev/null +++ b/src/Twee/Join.hs @@ -0,0 +1,212 @@ +-- Tactics for joining critical pairs. +{-# LANGUAGE FlexibleContexts, BangPatterns, RecordWildCards, TypeFamilies, DeriveGeneric #-} +module Twee.Join where + +import Twee.Base +import Twee.Rule +import Twee.Equation +import Twee.Proof(Lemma) +import qualified Twee.Proof as Proof +import Twee.CP hiding (Config) +import Twee.Constraints +import qualified Twee.Index as Index +import Twee.Index(Index) +import Twee.Rule.Index(RuleIndex(..)) +import Twee.Utils +import Data.Maybe +import Data.Either +import Data.Ord +import qualified Data.Set as Set + +data Config = + Config { + cfg_ground_join :: !Bool, + cfg_use_connectedness :: !Bool, + cfg_set_join :: !Bool } + +defaultConfig :: Config +defaultConfig = + Config { + cfg_ground_join = True, + cfg_use_connectedness = False, + cfg_set_join = False } + +{-# INLINEABLE joinCriticalPair #-} +joinCriticalPair :: + (Function f, Has a (Rule f), Has a (Lemma f)) => + Config -> + Index f (Equation f) -> RuleIndex f a -> + Maybe (Model f) -> -- A model to try before checking ground joinability + CriticalPair f -> + Either + -- Failed to join critical pair. + -- Returns simplified critical pair and model in which it failed to hold. + (CriticalPair f, Model f) + -- Split critical pair into several instances. + -- Returns list of instances which must be joined, + -- and an optional equation which can be added to the joinable set + -- after successfully joining all instances. + (Maybe (CriticalPair f), [CriticalPair f]) +joinCriticalPair config eqns idx mmodel cp@CriticalPair{cp_eqn = t :=: u} = + {-# SCC joinCriticalPair #-} + case allSteps config eqns idx cp of + Nothing -> + Right (Nothing, []) + _ | cfg_set_join config && + not (null $ Set.intersection + (normalForms (rewrite reduces (index_all idx)) [reduce (Refl t)]) + (normalForms (rewrite reduces (index_all idx)) [reduce (Refl u)])) -> + Right (Just cp, []) + Just cp -> + case groundJoinFromMaybe config eqns idx mmodel (branches (And [])) cp of + Left model -> Left (cp, model) + Right cps -> Right (Just cp, cps) + +{-# INLINEABLE step1 #-} +{-# INLINEABLE step2 #-} +{-# INLINEABLE step3 #-} +{-# INLINEABLE allSteps #-} +step1, step2, step3, allSteps :: + (Function f, Has a (Rule f), Has a (Lemma f)) => + Config -> Index f (Equation f) -> RuleIndex f a -> CriticalPair f -> Maybe (CriticalPair f) +allSteps config eqns idx cp = + step1 config eqns idx cp >>= + step2 config eqns idx >>= + step3 config eqns idx +step1 _ eqns idx = joinWith eqns idx (\t _ -> normaliseWith (const True) (rewrite reducesOriented (index_oriented idx)) t) +step2 _ eqns idx = joinWith eqns idx (\t _ -> normaliseWith (const True) (rewrite reduces (index_all idx)) t) +step3 Config{..} eqns idx cp + | not cfg_use_connectedness = Just cp + | otherwise = + case cp_top cp of + Just top -> + case (join (cp, top), join (flipCP (cp, top))) of + (Just _, Just _) -> Just cp + _ -> Nothing + _ -> Just cp + where + join (cp, top) = + joinWith eqns idx (\t u -> normaliseWith (`lessThan` top) (rewrite (ok t u) (index_all idx)) t) cp + + ok t u rule sub = + unorient rule `simplerThan` (t :=: u) && + reducesSkolem rule sub + + flipCP :: Symbolic a => a -> a + flipCP t = subst sub t + where + n = maximum (0:map fromEnum (vars t)) + sub (V x) = var (V (n - x)) + + +{-# INLINEABLE joinWith #-} +joinWith :: + (Has a (Rule f), Has a (Lemma f)) => + Index f (Equation f) -> RuleIndex f a -> (Term f -> Term f -> Resulting f) -> CriticalPair f -> Maybe (CriticalPair f) +joinWith eqns idx reduce cp@CriticalPair{cp_eqn = lhs :=: rhs, ..} + | subsumed eqns idx eqn = Nothing + | otherwise = + Just cp { + cp_eqn = eqn, + cp_proof = + Proof.symm (reductionProof (reduction lred)) `Proof.trans` + cp_proof `Proof.trans` + reductionProof (reduction rred) } + where + lred = reduce lhs rhs + rred = reduce rhs lhs + eqn = result lred :=: result rred + +{-# INLINEABLE subsumed #-} +subsumed :: + (Has a (Rule f), Has a (Lemma f)) => + Index f (Equation f) -> RuleIndex f a -> Equation f -> Bool +subsumed eqns idx (t :=: u) + | t == u = True + | or [ rhs rule == u | rule <- Index.lookup t (index_all idx) ] = True + | or [ rhs rule == t | rule <- Index.lookup u (index_all idx) ] = True + -- No need to do this symmetrically because addJoinable adds + -- both orientations of each equation + | or [ u == subst sub u' + | t' :=: u' <- Index.approxMatches t eqns, + sub <- maybeToList (match t' t) ] = True +subsumed eqns idx (App f ts :=: App g us) + | f == g = + let + sub Empty Empty = False + sub (Cons t ts) (Cons u us) = + subsumed eqns idx (t :=: u) && sub ts us + sub _ _ = error "Function used with multiple arities" + in + sub ts us +subsumed _ _ _ = False + +{-# INLINEABLE groundJoin #-} +groundJoin :: + (Function f, Has a (Rule f), Has a (Lemma f)) => + Config -> Index f (Equation f) -> RuleIndex f a -> [Branch f] -> CriticalPair f -> Either (Model f) [CriticalPair f] +groundJoin config eqns idx ctx cp@CriticalPair{cp_eqn = t :=: u, ..} = + case partitionEithers (map (solve (usort (atoms t ++ atoms u))) ctx) of + ([], instances) -> + let cps = [ subst sub cp | sub <- instances ] in + Right (usortBy (comparing (canonicalise . order . cp_eqn)) cps) + (model:_, _) -> + groundJoinFrom config eqns idx model ctx cp + +{-# INLINEABLE groundJoinFrom #-} +groundJoinFrom :: + (Function f, Has a (Rule f), Has a (Lemma f)) => + Config -> Index f (Equation f) -> RuleIndex f a -> Model f -> [Branch f] -> CriticalPair f -> Either (Model f) [CriticalPair f] +groundJoinFrom config@Config{..} eqns idx model ctx cp@CriticalPair{cp_eqn = t :=: u, ..} + | not cfg_ground_join || + (modelOK model && isJust (allSteps config eqns idx cp { cp_eqn = t' :=: u' })) = Left model + | otherwise = + let model1 = optimise model weakenModel (\m -> not (modelOK m) || (valid m (reduction nt) && valid m (reduction nu))) + model2 = optimise model1 weakenModel (\m -> not (modelOK m) || isNothing (allSteps config eqns idx cp { cp_eqn = result (normaliseIn m t u) :=: result (normaliseIn m u t) })) + + diag [] = Or [] + diag (r:rs) = negateFormula r ||| (weaken r &&& diag rs) + weaken (LessEq t u) = Less t u + weaken x = x + ctx' = formAnd (diag (modelToLiterals model2)) ctx in + + groundJoin config eqns idx ctx' cp + where + normaliseIn m t u = normaliseWith (const True) (rewrite (ok t u m) (index_all idx)) t + ok t u m rule sub = + reducesInModel m rule sub && + unorient rule `simplerThan` (t :=: u) + + nt = normaliseIn model t u + nu = normaliseIn model u t + t' = result nt + u' = result nu + + -- XXX not safe to exploit the top term if we then add the equation to + -- the joinable set. (It might then be used to join a CP with an entirely + -- different top term.) + modelOK _ = True +{- modelOK m = + case cp_top of + Nothing -> True + Just top -> + isNothing (lessIn m top t) && isNothing (lessIn m top u)-} + +{-# INLINEABLE groundJoinFromMaybe #-} +groundJoinFromMaybe :: + (Function f, Has a (Rule f), Has a (Lemma f)) => + Config -> Index f (Equation f) -> RuleIndex f a -> Maybe (Model f) -> [Branch f] -> CriticalPair f -> Either (Model f) [CriticalPair f] +groundJoinFromMaybe config eqns idx Nothing = groundJoin config eqns idx +groundJoinFromMaybe config eqns idx (Just model) = groundJoinFrom config eqns idx model + +{-# INLINEABLE valid #-} +valid :: Function f => Model f -> Reduction f -> Bool +valid model red = + and [ reducesInModel model rule sub + | Step _ rule sub <- steps red ] + +optimise :: a -> (a -> [a]) -> (a -> Bool) -> a +optimise x f p = + case filter p (f x) of + y:_ -> optimise y f p + _ -> x diff --git a/src/Twee/KBO.hs b/src/Twee/KBO.hs --- a/src/Twee/KBO.hs +++ b/src/Twee/KBO.hs @@ -1,7 +1,6 @@ -{-# LANGUAGE CPP, PatternGuards #-} +{-# LANGUAGE PatternGuards #-} module Twee.KBO where -#include "errors.h" import Twee.Base hiding (lessEq, lessIn) import Data.List import Twee.Constraints hiding (lessEq, lessIn) @@ -11,13 +10,13 @@ import Control.Monad lessEq :: Function f => Term f -> Term f -> Bool -lessEq (Fun f Empty) _ | f == minimal = True +lessEq (App f Empty) _ | f == minimal = True lessEq (Var x) (Var y) | x == y = True lessEq _ (Var _) = False lessEq (Var x) t = x `elem` vars t -lessEq t@(Fun f ts) u@(Fun g us) = +lessEq t@(App f ts) u@(App g us) = (st < su || - (st == su && f < g) || + (st == su && f << g) || (st == su && f == g && lexLess ts us)) && xs `isSubsequenceOf` ys where @@ -29,9 +28,9 @@ case unify t u of Nothing -> True Just sub - | not (allSubst (\_ (Cons t Empty) -> isMinimal t) sub) -> ERROR("weird term inequality") + | not (allSubst (\_ (Cons t Empty) -> isMinimal t) sub) -> error "weird term inequality" | otherwise -> lexLess (subst sub ts) (subst sub us) - lexLess _ _ = ERROR("incorrect function arity") + lexLess _ _ = error "incorrect function arity" xs = sort (vars t) ys = sort (vars u) st = size t @@ -56,7 +55,7 @@ foldr (addSize id) (foldr (addSize negate) (0, Map.empty) (subterms t)) (subterms u) - addSize op (Fun f _) (k, m) = (k + op (size f), m) + addSize op (App f _) (k, m) = (k + op (size f), m) addSize op (Var x) (k, m) = (k, Map.insertWith (+) x (op 1) m) minimumIn :: Function f => Model f -> Map Var Int -> Maybe Int @@ -95,11 +94,10 @@ [ lessEqInModel cond a b | v <- properSubterms u, Just b <- [fromTerm v]] = Just Strict -lexLessIn cond (Fun f ts) (Fun g us) = - case compare f g of - LT -> Just Strict - GT -> Nothing - EQ -> loop ts us +lexLessIn cond (App f ts) (App g us) + | f == g = loop ts us + | f << g = Just Strict + | otherwise = Nothing where loop Empty Empty = Just Nonstrict loop (Cons t ts) (Cons u us) @@ -111,6 +109,6 @@ Just Nonstrict -> let Just sub = unify t u in loop (subst sub ts) (subst sub us) - loop _ _ = ERROR("incorrect function arity") + loop _ _ = error "incorrect function arity" lexLessIn _ t _ | isMinimal t = Just Nonstrict lexLessIn _ _ _ = Nothing diff --git a/src/Twee/LPO.hs b/src/Twee/LPO.hs deleted file mode 100644 --- a/src/Twee/LPO.hs +++ /dev/null @@ -1,69 +0,0 @@ -{-# LANGUAGE CPP, PatternGuards #-} -module Twee.LPO where - -#include "errors.h" -import Twee.Base hiding (lessEq, lessIn) -import Twee.Constraints hiding (lessEq, lessIn) -import Data.Maybe -import Control.Monad - -lessEq :: Function f => Term f -> Term f -> Bool -lessEq (Var x) (Var y) = x == y -lessEq (Var x) t = x `elem` vars t -lessEq (Fun f _) (Var _) = f == minimal -lessEq t@(Fun f ts) u@(Fun g us) = - case compare f g of - LT -> - and [ lessEq t u | t <- fromTermList ts ] && - and [ isNothing (match u t) | t <- fromTermList ts ] - EQ -> lexLess t u ts us - GT -> or [ lessEq t u | u <- fromTermList us ] - where - lexLess _ _ Empty Empty = True - lexLess t u (Cons t' ts) (Cons u' us) - | t' == u' = lexLess t u ts us - | lessEq t' u' = - and [ lessEq t u | t <- fromTermList ts ] && - and [ isNothing (match u t) | t <- fromTermList ts ] && - case match u' t' of - Nothing -> True - Just sub -> - lexLess (subst sub t) (subst sub u) (subst sub ts) (subst sub us) - | otherwise = - or [ lessEq t u | u <- fromTermList us ] - lexLess _ _ _ _ = ERROR("incorrect function arity") - -lessIn :: Function f => Model f -> Term f -> Term f -> Maybe Strictness -lessIn model (Var x) t - | or [isJust (varLessIn x u) | u <- properSubterms t] = Just Strict - | Just str <- varLessIn x t = Just str - | otherwise = Nothing - where - varLessIn x t = fromTerm t >>= lessEqInModel model (Variable x) -lessIn model t (Var x) = do - a <- fromTerm t - lessEqInModel model a (Variable x) -lessIn model t@(Fun f ts) u@(Fun g us) = - case compare f g of - LT -> do - guard (and [ lessIn model t u == Just Strict | t <- fromTermList ts ]) - return Strict - EQ -> lexLess t u ts us - GT -> do - msum [ lessIn model t u | u <- fromTermList us ] - return Strict - where - lexLess _ _ Empty Empty = Just Nonstrict - lexLess t u (Cons t' ts) (Cons u' us) - | t' == u' = lexLess t u ts us - | Just str <- lessIn model t' u' = do - guard (and [ lessIn model t u == Just Strict | t <- fromTermList ts ]) - case str of - Strict -> Just Strict - Nonstrict -> - let Just sub = unify t' u' in - lexLess (subst sub t) (subst sub u) (subst sub ts) (subst sub us) - | otherwise = do - msum [ lessIn model t u | u <- fromTermList us ] - return Strict - lexLess _ _ _ _ = ERROR("incorrect function arity") diff --git a/src/Twee/Label.hs b/src/Twee/Label.hs --- a/src/Twee/Label.hs +++ b/src/Twee/Label.hs @@ -1,48 +1,111 @@ -- | Assignment of unique IDs to values. -- Inspired by the 'intern' package. -{-# LANGUAGE RecordWildCards, ScopedTypeVariables #-} -module Twee.Label where +{-# LANGUAGE RecordWildCards, ScopedTypeVariables, BangPatterns #-} +module Twee.Label(Label, unsafeMkLabel, labelNum, label, find) where import Data.IORef import System.IO.Unsafe -import qualified Data.IntMap.Strict as IntMap -import Data.IntMap.Strict(IntMap) import qualified Data.Map.Strict as Map import Data.Map.Strict(Map) +import qualified Data.IntMap.Strict as IntMap +import Data.IntMap.Strict(IntMap) +import Data.Typeable +import GHC.Exts +import Unsafe.Coerce +import Data.Int -class Ord a => Labelled a where - cache :: Cache a - initialId :: a -> Int - initialId _ = 0 +newtype Label a = Label { labelNum :: Int32 } + deriving (Eq, Ord, Show) +unsafeMkLabel :: Int32 -> Label a +unsafeMkLabel = Label -type Cache a = IORef (CacheState a) -data CacheState a = - CacheState { - nextId :: {-# UNPACK #-} !Int, - to :: !(IntMap a), - from :: !(Map a Int) } - deriving Show +type Cache a = Map a Int32 -mkCache :: forall a. Labelled a => Cache a -mkCache = unsafePerformIO (newIORef (CacheState (initialId (undefined :: a)) IntMap.empty Map.empty)) +data Caches = + Caches { + caches_nextId :: {-# UNPACK #-} !Int32, + caches_from :: !(Map TypeRep (Cache Any)), + caches_to :: !(IntMap Any) } -label :: Labelled a => a -> Int -label x = - compare x x `seq` - unsafeDupablePerformIO $ - atomicModifyIORef' cache $ \cache@CacheState{..} -> - case Map.lookup x from of - Nothing -> - (CacheState - (nextId+1) - (IntMap.insert nextId x to) - (Map.insert x nextId from), - nextId) - Just n -> (cache, n) +{-# NOINLINE cachesRef #-} +cachesRef :: IORef Caches +cachesRef = unsafePerformIO (newIORef (Caches 0 Map.empty IntMap.empty)) -find :: Labelled a => Int -> Maybe a -find n = +atomicModifyCaches :: (Caches -> (Caches, a)) -> IO a +atomicModifyCaches f = do + -- N.B. atomicModifyIORef' ref f evaluates f ref *after* doing the + -- compare-and-swap. This causes bad things to happen when 'label' + -- is used reentrantly (i.e. the Ord instance itself calls label). + -- This function only lets the swap happen if caches_nextId didn't + -- change (i.e., no new values were inserted). + !caches <- readIORef cachesRef + -- First compute the update. + let !(!caches', !x) = f caches + -- Now see if anyone else updated the cache in between + -- (can happen if f called 'label', or in a concurrent setting). + ok <- atomicModifyIORef' cachesRef $ \cachesNow -> + if caches_nextId caches == caches_nextId cachesNow + then (caches', True) + else (cachesNow, False) + if ok then return x else atomicModifyCaches f + +toAnyCache :: Cache a -> Cache Any +toAnyCache = unsafeCoerce + +fromAnyCache :: Cache Any -> Cache a +fromAnyCache = unsafeCoerce + +toAny :: a -> Any +toAny = unsafeCoerce + +fromAny :: Any -> a +fromAny = unsafeCoerce + +{-# NOINLINE label #-} +label :: forall a. (Typeable a, Ord a) => a -> Label a +label x = unsafeDupablePerformIO $ do - CacheState{..} <- readIORef cache - return (IntMap.lookup n to) + -- Common case: label is already there. + caches <- readIORef cachesRef + case tryFind caches of + Just l -> return l + Nothing -> do + -- Rare case: label was not there. + x <- atomicModifyCaches $ \caches -> + case tryFind caches of + Just l -> (caches, l) + Nothing -> + insert caches + return x + + where + ty = typeOf x + + tryFind :: Caches -> Maybe (Label a) + tryFind Caches{..} = + Label <$> (Map.lookup ty caches_from >>= Map.lookup x . fromAnyCache) + + insert :: Caches -> (Caches, Label a) + insert caches@Caches{..} = + if n < 0 then error "label overflow" else + (caches { + caches_nextId = n+1, + caches_from = Map.insert ty (toAnyCache (Map.insert x n cache)) caches_from, + caches_to = IntMap.insert (fromIntegral n) (toAny x) caches_to }, + Label n) + where + n = caches_nextId + cache = + fromAnyCache $ + Map.findWithDefault Map.empty ty caches_from + +find :: Label a -> a +-- N.B. must force n before calling readIORef, otherwise a call of +-- the form +-- find (label x) +-- doesn't work. +find (Label !n) = unsafeDupablePerformIO $ do + Caches{..} <- readIORef cachesRef + x <- return $! fromAny (IntMap.findWithDefault undefined (fromIntegral n) caches_to) + return x diff --git a/src/Twee/Pretty.hs b/src/Twee/Pretty.hs --- a/src/Twee/Pretty.hs +++ b/src/Twee/Pretty.hs @@ -1,9 +1,10 @@ -- | Pretty-printing of terms and assorted other values. -{-# LANGUAGE Rank2Types, FlexibleContexts #-} +{-# LANGUAGE Rank2Types #-} module Twee.Pretty(module Twee.Pretty, module Text.PrettyPrint.HughesPJClass, Pretty(..)) where -import Text.PrettyPrint.HughesPJClass +import Text.PrettyPrint.HughesPJClass hiding (empty) +import qualified Text.PrettyPrint.HughesPJClass as PP import qualified Data.Map as Map import Data.Map(Map) import qualified Data.Set as Set @@ -20,6 +21,9 @@ pPrintParen True d = parens d pPrintParen False d = d +pPrintEmpty :: Doc +pPrintEmpty = PP.empty + instance Pretty Doc where pPrint = id pPrintTuple :: [Doc] -> Doc @@ -32,7 +36,14 @@ pPrintSet = braces . fsep . punctuate comma instance Pretty Var where - pPrint (MkVar x) = text "X" <> pPrint (x+1) + pPrint (V n) = + text $ + vars !! (n `mod` length vars): + case n `div` length vars of + 0 -> "" + m -> show (m+1) + where + vars = "XYZWVUTS" instance (Pretty k, Pretty v) => Pretty (Map k v) where pPrint = pPrintSet . map binding . Map.toList @@ -52,18 +63,21 @@ -- * Pretty-printing of terms. -instance (Numbered f, Pretty f) => Pretty (Fun f) where - pPrintPrec l p = pPrintPrec l p . fromFun +instance Pretty f => Pretty (Fun f) where + pPrintPrec l p = pPrintPrec l p . fun_value -instance (Numbered f, PrettyTerm f) => Pretty (Term f) where +instance PrettyTerm f => PrettyTerm (Fun f) where + termStyle f = termStyle (fun_value f) + +instance PrettyTerm f => Pretty (Term f) where pPrintPrec l p (Var x) = pPrintPrec l p x - pPrintPrec l p (Fun f xs) = - pPrintTerm (termStyle (fromFun f)) l p (pPrint f) (termListToList xs) + pPrintPrec l p (App f xs) = + pPrintTerm (termStyle f) l p (pPrint f) (termListToList xs) -instance (Numbered f, PrettyTerm f) => Pretty (TermList f) where +instance PrettyTerm f => Pretty (TermList f) where pPrintPrec _ _ = pPrint . termListToList -instance (Numbered f, PrettyTerm f) => Pretty (Subst f) where +instance PrettyTerm f => Pretty (Subst f) where pPrint sub = text "{" <> fsep (punctuate (text ",") docs) <> text "}" where docs = @@ -125,7 +139,7 @@ | length xs < arity = pPrintTerm curried l p (parens d) xs | length xs > arity = pPrintParen (p > 10) $ - hsep (parens (pPrintTerm style l 0 d ys): + hsep (pPrintTerm style l 11 d ys: map (pPrintPrec l 11) zs) | otherwise = pPrintTerm style l p d xs where diff --git a/src/Twee/Proof.hs b/src/Twee/Proof.hs new file mode 100644 --- /dev/null +++ b/src/Twee/Proof.hs @@ -0,0 +1,660 @@ +{-# LANGUAGE TypeFamilies, PatternGuards, RecordWildCards, ScopedTypeVariables #-} +module Twee.Proof( + Proof, Derivation(..), Lemma(..), Axiom(..), + certify, equation, derivation, + lemma, axiom, symm, trans, cong, simplify, congPath, + usedLemmas, usedAxioms, usedLemmasAndSubsts, usedAxiomsAndSubsts, + Config(..), defaultConfig, Presentation(..), + ProvedGoal(..), provedGoal, checkProvedGoal, + pPrintPresentation, present, describeEquation) where + +import Twee.Base +import Twee.Equation +import Twee.Utils +import Control.Monad +import Data.Maybe +import Data.List +import Data.Ord +import qualified Data.Set as Set +import qualified Data.Map.Strict as Map + +---------------------------------------------------------------------- +-- Equational proofs. Only valid proofs can be constructed. +---------------------------------------------------------------------- + +-- A checked proof. If you have a value of type Proof f, +-- it should jolly well represent a valid proof! +data Proof f = + Proof { + equation :: !(Equation f), + derivation :: !(Derivation f) } + deriving (Eq, Show) + +-- A derivation is an unchecked proof. It might be wrong! +-- The way to check it is to call "certify" to turn it into a Proof. +data Derivation f = + -- Apply an existing rule (with proof!) to the root of a term + UseLemma {-# UNPACK #-} !(Lemma f) !(Subst f) + -- Apply an axiom to the root of a term + | UseAxiom {-# UNPACK #-} !(Axiom f) !(Subst f) + -- Reflexivity + | Refl !(Term f) + -- Symmetry + | Symm !(Derivation f) + -- Transivitity + | Trans !(Derivation f) !(Derivation f) + -- Congruence + | Cong {-# UNPACK #-} !(Fun f) ![Derivation f] + deriving (Eq, Show) + +-- A lemma, which includes a proof. +data Lemma f = + Lemma { + lemma_id :: {-# UNPACK #-} !Id, + lemma_proof :: !(Proof f) } + deriving Show + +-- An axiom, which comes without proof. +data Axiom f = + Axiom { + axiom_number :: {-# UNPACK #-} !Int, + axiom_name :: !String, + axiom_eqn :: !(Equation f) } + deriving (Eq, Ord, Show) + +-- The trusted core of the module. +-- Turns a derivation into a proof, while checking the derivation. +{-# INLINEABLE certify #-} +certify :: PrettyTerm f => Derivation f -> Proof f +certify p = + {-# SCC certify #-} + case check p of + Nothing -> error ("Invalid proof created!\n" ++ prettyShow p) + Just eqn -> Proof eqn p + where + check (UseLemma Lemma{..} sub) = + return (subst sub (equation lemma_proof)) + check (UseAxiom Axiom{..} sub) = + return (subst sub axiom_eqn) + check (Refl t) = + return (t :=: t) + check (Symm p) = do + t :=: u <- check p + return (u :=: t) + check (Trans p q) = do + t :=: u1 <- check p + u2 :=: v <- check q + guard (u1 == u2) + return (t :=: v) + check (Cong f ps) = do + eqns <- mapM check ps + return + (build (app f (map eqn_lhs eqns)) :=: + build (app f (map eqn_rhs eqns))) + +---------------------------------------------------------------------- +-- Everything below this point need not be trusted, since all proof +-- construction goes through the "proof" function. +---------------------------------------------------------------------- + +-- Typeclass instances. +instance Eq (Lemma f) where + x == y = compare x y == EQ +instance Ord (Lemma f) where + compare = + comparing (\x -> + -- Don't look into lemma proofs when comparing derivations, + -- to avoid exponential blowup + (lemma_id x, equation (lemma_proof x))) + +instance Symbolic (Derivation f) where + type ConstantOf (Derivation f) = f + termsDL (UseLemma _ sub) = termsDL sub + termsDL (UseAxiom _ sub) = termsDL sub + termsDL (Refl t) = termsDL t + termsDL (Symm p) = termsDL p + termsDL (Trans p q) = termsDL p `mplus` termsDL q + termsDL (Cong _ ps) = termsDL ps + + subst_ sub (UseLemma lemma s) = UseLemma lemma (subst_ sub s) + subst_ sub (UseAxiom axiom s) = UseAxiom axiom (subst_ sub s) + subst_ sub (Refl t) = Refl (subst_ sub t) + subst_ sub (Symm p) = symm (subst_ sub p) + subst_ sub (Trans p q) = trans (subst_ sub p) (subst_ sub q) + subst_ sub (Cong f ps) = cong f (subst_ sub ps) + +instance Function f => Pretty (Proof f) where + pPrint = pPrintLemma defaultConfig prettyShow +instance PrettyTerm f => Pretty (Derivation f) where + pPrint (UseLemma lemma sub) = + text "subst" <> pPrintTuple [pPrint lemma, pPrint sub] + pPrint (UseAxiom axiom sub) = + text "subst" <> pPrintTuple [pPrint axiom, pPrint sub] + pPrint (Refl t) = + text "refl" <> pPrintTuple [pPrint t] + pPrint (Symm p) = + text "symm" <> pPrintTuple [pPrint p] + pPrint (Trans p q) = + text "trans" <> pPrintTuple [pPrint p, pPrint q] + pPrint (Cong f ps) = + text "cong" <> pPrintTuple (pPrint f:map pPrint ps) + +instance PrettyTerm f => Pretty (Axiom f) where + pPrint Axiom{..} = + text "axiom" <> + pPrintTuple [pPrint axiom_number, text axiom_name, pPrint axiom_eqn] + +instance PrettyTerm f => Pretty (Lemma f) where + pPrint Lemma{..} = + text "lemma" <> + pPrintTuple [pPrint lemma_id, pPrint (equation lemma_proof)] + +-- Simplify a derivation. +-- After simplification, a derivation has the following properties: +-- * Symm is pushed down next to Step +-- * Refl only occurs inside Cong or at the top level +-- * Trans is right-associated and is pushed inside Cong if possible +simplify :: Minimal f => (Lemma f -> Maybe (Derivation f)) -> Derivation f -> Derivation f +simplify lem p = simp p + where + simp p@(UseLemma lemma sub) = + case lem lemma of + Nothing -> p + Just q -> + let + -- Get rid of any variables that are not bound by sub + -- (e.g., ones which only occur internally in q) + dead = usort (vars q) \\ substDomain sub + in simp (subst sub (erase dead q)) + simp (Symm p) = symm (simp p) + simp (Trans p q) = trans (simp p) (simp q) + simp (Cong f ps) = cong f (map simp ps) + simp p = p + +-- Smart constructors for derivations. +lemma :: Lemma f -> Subst f -> Derivation f +lemma lem@Lemma{..} sub = UseLemma lem sub + +axiom :: Axiom f -> Derivation f +axiom ax@Axiom{..} = + UseAxiom ax $ + fromJust $ + flattenSubst [(x, build (var x)) | x <- vars axiom_eqn] + +symm :: Derivation f -> Derivation f +symm (Refl t) = Refl t +symm (Symm p) = p +symm (Trans p q) = trans (symm q) (symm p) +symm (Cong f ps) = cong f (map symm ps) +symm p = Symm p + +trans :: Derivation f -> Derivation f -> Derivation f +trans Refl{} p = p +trans p Refl{} = p +trans (Trans p q) r = + -- Right-associate uses of transitivity. + -- p cannot be a Trans (if it was created with the smart + -- constructors) but q could be. + Trans p (trans q r) +-- Collect adjacent uses of congruence. +trans (Cong f ps) (Cong g qs) | f == g = + transCong f ps qs +trans (Cong f ps) (Trans (Cong g qs) r) | f == g = + trans (transCong f ps qs) r +trans p q = Trans p q + +transCong :: Fun f -> [Derivation f] -> [Derivation f] -> Derivation f +transCong f ps qs = + cong f (zipWith trans ps qs) + +cong :: Fun f -> [Derivation f] -> Derivation f +cong f ps = + case sequence (map unRefl ps) of + Nothing -> Cong f ps + Just ts -> Refl (build (app f ts)) + where + unRefl (Refl t) = Just t + unRefl _ = Nothing + +-- Find all lemmas which are used in a derivation. +usedLemmas :: Derivation f -> [Lemma f] +usedLemmas p = map fst (usedLemmasAndSubsts p) + +usedLemmasAndSubsts :: Derivation f -> [(Lemma f, Subst f)] +usedLemmasAndSubsts p = lem p [] + where + lem (UseLemma lemma sub) = ((lemma, sub):) + lem (Symm p) = lem p + lem (Trans p q) = lem p . lem q + lem (Cong _ ps) = foldr (.) id (map lem ps) + lem _ = id + +-- Find all axioms which are used in a derivation. +usedAxioms :: Derivation f -> [Axiom f] +usedAxioms p = map fst (usedAxiomsAndSubsts p) + +usedAxiomsAndSubsts :: Derivation f -> [(Axiom f, Subst f)] +usedAxiomsAndSubsts p = ax p [] + where + ax (UseAxiom axiom sub) = ((axiom, sub):) + ax (Symm p) = ax p + ax (Trans p q) = ax p . ax q + ax (Cong _ ps) = foldr (.) id (map ax ps) + ax _ = id + +-- Applies a derivation at a particular path in a term. +congPath :: [Int] -> Term f -> Derivation f -> Derivation f +congPath [] _ p = p +congPath (n:ns) (App f t) p | n <= length ts = + cong f $ + map Refl (take n ts) ++ + [congPath ns (ts !! n) p] ++ + map Refl (drop (n+1) ts) + where + ts = unpack t +congPath _ _ _ = error "bad path" + +---------------------------------------------------------------------- +-- Pretty-printing of proofs. +---------------------------------------------------------------------- + +-- Options for proof presentation. +data Config = + Config { + cfg_all_lemmas :: !Bool, + cfg_no_lemmas :: !Bool, + cfg_show_instances :: !Bool } + +defaultConfig :: Config +defaultConfig = + Config { + cfg_all_lemmas = False, + cfg_no_lemmas = False, + cfg_show_instances = False } + +-- A proof, with all axioms and lemmas explicitly listed. +data Presentation f = + Presentation { + pres_axioms :: [Axiom f], + pres_lemmas :: [Lemma f], + pres_goals :: [ProvedGoal f] } + deriving Show + +-- Note: only the pg_proof field should be trusted! +-- The remaining fields are for information only. +data ProvedGoal f = + ProvedGoal { + pg_number :: Int, + pg_name :: String, + pg_proof :: Proof f, + + -- Extra fields for existentially-quantified goals, giving the original goal + -- and the existential witness. These fields are not verified. If you want + -- to check them, use checkProvedGoal. + -- + -- In general, subst pg_witness_hint pg_goal_hint == equation pg_proof. + -- For non-existential goals, pg_goal_hint == equation pg_proof + -- and pg_witness_hint is the empty substitution. + pg_goal_hint :: Equation f, + pg_witness_hint :: Subst f } + deriving Show + +provedGoal :: Int -> String -> Proof f -> ProvedGoal f +provedGoal number name proof = + ProvedGoal { + pg_number = number, + pg_name = name, + pg_proof = proof, + pg_goal_hint = equation proof, + pg_witness_hint = emptySubst } + +-- Check that pg_goal/pg_witness match up with pg_proof. +checkProvedGoal :: Function f => ProvedGoal f -> ProvedGoal f +checkProvedGoal pg@ProvedGoal{..} + | subst pg_witness_hint pg_goal_hint == equation pg_proof = + pg + | otherwise = + error $ show $ + text "Invalid ProvedGoal!" $$ + text "Claims to prove" <+> pPrint pg_goal_hint $$ + text "with witness" <+> pPrint pg_witness_hint <> text "," $$ + text "but actually proves" <+> pPrint (equation pg_proof) + +instance Function f => Pretty (Presentation f) where + pPrint = pPrintPresentation defaultConfig + +present :: Function f => Config -> [ProvedGoal f] -> Presentation f +present config goals = + -- First find all the used lemmas, then hand off to presentWithGoals + presentWithGoals config goals + (used Set.empty (concatMap (usedLemmas . derivation . pg_proof) goals)) + where + used lems [] = Set.elems lems + used lems (x:xs) + | x `Set.member` lems = used lems xs + | otherwise = + used (Set.insert x lems) + (usedLemmas (derivation (lemma_proof x)) ++ xs) + +presentWithGoals :: + Function f => + Config -> [ProvedGoal f] -> [Lemma f] -> Presentation f +presentWithGoals config@Config{..} goals lemmas + -- We inline a lemma if one of the following holds: + -- * It only has one step + -- * It is subsumed by an earlier lemma + -- * It is only used once + -- * It has to do with $equals (for printing of the goal proof) + -- * The option cfg_no_lemmas is true + -- First we compute all inlinings, then apply simplify to remove them, + -- then repeat if any lemma was inlined + | Map.null inlinings = + let + axioms = usort $ + concatMap (usedAxioms . derivation . pg_proof) goals ++ + concatMap (usedAxioms . derivation . lemma_proof) lemmas + in + Presentation axioms + [ lemma { lemma_proof = flattenProof lemma_proof } + | lemma@Lemma{..} <- lemmas ] + [ decodeGoal (goal { pg_proof = flattenProof pg_proof }) + | goal@ProvedGoal{..} <- goals ] + + | otherwise = + let + inline lemma = Map.lookup lemma inlinings + + goals' = + [ decodeGoal (goal { pg_proof = certify $ simplify inline (derivation pg_proof) }) + | goal@ProvedGoal{..} <- goals ] + lemmas' = + [ Lemma n (certify $ simplify inline (derivation p)) + | lemma@(Lemma n p) <- lemmas, not (lemma `Map.member` inlinings) ] + in + presentWithGoals config goals' lemmas' + + where + inlinings = + Map.fromList + [ (lemma, p) + | lemma <- lemmas, Just p <- [tryInline lemma]] + + tryInline (Lemma n p) + | shouldInline n p = Just (derivation p) + tryInline (Lemma n p) + -- Check for subsumption by an earlier lemma + | Just (Lemma m q) <- Map.lookup (canonicalise (t :=: u)) equations, m < n = + Just (subsume p (derivation q)) + | Just (Lemma m q) <- Map.lookup (canonicalise (u :=: t)) equations, m < n = + Just (subsume p (Symm (derivation q))) + where + t :=: u = equation p + tryInline _ = Nothing + + shouldInline n p = + cfg_no_lemmas || + oneStep (derivation p) || + (not cfg_all_lemmas && + (isJust (decodeEquality (eqn_lhs (equation p))) || + isJust (decodeEquality (eqn_rhs (equation p))) || + Map.lookup n uses == Just 1)) + + subsume p q = + -- Rename q so its variables match p's + subst sub q + where + t :=: u = equation p + t' :=: u' = equation (certify q) + Just sub = matchList (buildList [t', u']) (buildList [t, u]) + + -- Record which lemma proves each equation + equations = + Map.fromList + [ (canonicalise (equation lemma_proof), lemma) + | lemma@Lemma{..} <- lemmas] + + -- Count how many times each lemma is used + uses = + Map.fromListWith (+) + [ (lemma_id, 1) + | Lemma{..} <- + concatMap usedLemmas + (map (derivation . pg_proof) goals ++ + map (derivation . lemma_proof) lemmas) ] + + -- Check if a proof only has one step. + -- Trans only occurs at the top level by this point. + oneStep Trans{} = False + oneStep _ = True + +-- Pretty-print the proof of a single lemma. +pPrintLemma :: Function f => Config -> (Id -> String) -> Proof f -> Doc +pPrintLemma Config{..} lemmaName p = + ppTerm (eqn_lhs (equation q)) $$ pp (derivation q) + where + q = flattenProof p + + pp (Trans p q) = pp p $$ pp q + pp p = + (text "= { by" <+> + ppStep + (nub (map (show . ppLemma) (usedLemmasAndSubsts p)) ++ + nub (map (show . ppAxiom) (usedAxiomsAndSubsts p))) <+> + text "}" $$ + ppTerm (eqn_rhs (equation (certify p)))) + + ppTerm t = text " " <> pPrint t + + ppStep [] = text "reflexivity" -- ?? + ppStep [x] = text x + ppStep xs = + hcat (punctuate (text ", ") (map text (init xs))) <+> + text "and" <+> + text (last xs) + + ppLemma (Lemma{..}, sub) = + text "lemma" <+> text (lemmaName lemma_id) <> showSubst sub + ppAxiom (Axiom{..}, sub) = + text "axiom" <+> pPrint axiom_number <+> parens (text axiom_name) <> showSubst sub + + showSubst sub + | cfg_show_instances && not (null (listSubst sub)) = + text " with " <> + fsep (punctuate comma + [ pPrint x <+> text "->" <+> pPrint t + | (x, t) <- listSubst sub ]) + | otherwise = pPrintEmpty + +-- Transform a proof so that each step uses exactly one axiom +-- or lemma. The proof will have the following form afterwards: +-- * Trans only occurs at the outermost level and is right-associated +-- * Each Cong has exactly one non-Refl argument (no parallel rewriting) +-- * Symm only occurs innermost, i.e., next to UseLemma or UseAxiom +-- * Refl only occurs as an argument to Cong, or outermost if the +-- whole proof is a single reflexivity step +flattenProof :: Function f => Proof f -> Proof f +flattenProof = + certify . flat . simplify (const Nothing) . derivation + where + flat (Trans p q) = trans (flat p) (flat q) + flat p@(Cong f ps) = + foldr trans (reflAfter p) + [ Cong f $ + map reflAfter (take i ps) ++ + [p] ++ + map reflBefore (drop (i+1) ps) + | (i, q) <- zip [0..] qs, + p <- steps q ] + where + qs = map flat ps + flat p = p + + reflBefore p = Refl (eqn_lhs (equation (certify p))) + reflAfter p = Refl (eqn_rhs (equation (certify p))) + + steps Refl{} = [] + steps (Trans p q) = steps p ++ steps q + steps p = [p] + + trans (Trans p q) r = trans p (trans q r) + trans Refl{} p = p + trans p Refl{} = p + trans p q = Trans p q + +-- Transform a derivation into a list of single steps. +-- Each step has the following form: +-- * Trans does not occur +-- * Symm only occurs innermost, i.e., next to UseLemma or UseAxiom +-- * Each Cong has exactly one non-Refl argument (no parallel rewriting) +-- * Refl only occurs as an argument to Cong +derivSteps :: Function f => Derivation f -> [Derivation f] +derivSteps = steps . derivation . flattenProof . certify + where + steps Refl{} = [] + steps (Trans p q) = steps p ++ steps q + steps p = [p] + +pPrintPresentation :: forall f. Function f => Config -> Presentation f -> Doc +pPrintPresentation config (Presentation axioms lemmas goals) = + vcat $ intersperse (text "") $ + vcat [ describeEquation "Axiom" (show n) (Just name) eqn + | Axiom n name eqn <- axioms ]: + [ pp "Lemma" (num n) Nothing (equation p) emptySubst p + | Lemma n p <- lemmas ] ++ + [ pp "Goal" (show num) (Just pg_name) pg_goal_hint pg_witness_hint pg_proof + | (num, ProvedGoal{..}) <- zip [1..] goals ] + where + pp kind n mname eqn witness p = + describeEquation kind n mname eqn $$ + ppWitness witness $$ + text "Proof:" $$ + pPrintLemma config num p + + num x = show (fromJust (Map.lookup x nums)) + nums = Map.fromList (zip (map lemma_id lemmas) [n+1 ..]) + n = maximum $ 0:map axiom_number axioms + + ppWitness sub + | sub == emptySubst = pPrintEmpty + | otherwise = + vcat [ + text "The goal is true when:", + nest 2 $ vcat + [ pPrint x <+> text "=" <+> pPrint t + | (x, t) <- listSubst sub ], + if minimal `elem` funs sub then + text "where" <+> doubleQuotes (pPrint (minimal :: Fun f)) <+> + text "stands for an arbitrary term of your choice." + else pPrintEmpty, + text ""] + +-- Format an equation nicely. Used both here and in the main file. +describeEquation :: + PrettyTerm f => + String -> String -> Maybe String -> Equation f -> Doc +describeEquation kind num mname eqn = + text kind <+> text num <> + (case mname of + Nothing -> text "" + Just name -> text (" (" ++ name ++ ")")) <> + text ":" <+> pPrint eqn <> text "." + +---------------------------------------------------------------------- +-- Making proofs of existential goals more readable. +---------------------------------------------------------------------- + +-- The idea: the only axioms which mention $equals, $true and $false +-- are: +-- * $equals(x,x) = $true (reflexivity) +-- * $equals(t,u) = $false (conjecture) +-- This implies that a proof $true = $false must have the following +-- structure, if we expand out all lemmas: +-- $true = $equals(s,s) = ... = $equals(t,u) = $false. +-- +-- The substitution in the last step $equals(t,u) = $false is in fact the +-- witness to the existential. +-- +-- Furthermore, we can make it so that the inner "..." doesn't use the $equals +-- axioms. If it does, one of the "..." steps results in either $true or $false, +-- and we can chop off everything before the $true or after the $false. +-- +-- Once we have done that, every proof step in the "..." must be a congruence +-- step of the shape +-- $equals(t, u) = $equals(v, w). +-- This is because there are no other axioms which mention $equals. Hence we can +-- split the proof of $equals(s,s) = $equals(t,u) into separate proofs of s=t +-- and s=u. +-- +-- What we have got out is: +-- * the witness to the existential +-- * a proof that both sides of the conjecture are equal +-- and we can present that to the user. + +-- Decode $equals(t,u) into an equation t=u. +decodeEquality :: Function f => Term f -> Maybe (Equation f) +decodeEquality (App equals (Cons t (Cons u Empty))) + | equals == equalsCon = Just (t :=: u) +decodeEquality _ = Nothing + +-- Tries to transform a proof of $true = $false into a proof of +-- the original existentially-quantified formula. +decodeGoal :: Function f => ProvedGoal f -> ProvedGoal f +decodeGoal pg = + case maybeDecodeGoal pg of + Nothing -> pg + Just (name, witness, goal, deriv) -> + checkProvedGoal $ + pg { + pg_name = name, + pg_proof = certify deriv, + pg_goal_hint = goal, + pg_witness_hint = witness } + +maybeDecodeGoal :: forall f. Function f => + ProvedGoal f -> Maybe (String, Subst f, Equation f, Derivation f) +maybeDecodeGoal ProvedGoal{..} + -- N.B. presentWithGoals takes care of expanding any lemma which mentions + -- $equals, and flattening the proof. + | u == false = extract (derivSteps deriv) + -- Orient the equation so that $false is the RHS. + | t == false = extract (derivSteps (symm deriv)) + | otherwise = Nothing + where + false = build (con falseCon) + true = build (con trueCon) + t :=: u = equation pg_proof + deriv = derivation pg_proof + + -- Detect $true = $equals(t, t). + decodeReflexivity :: Derivation f -> Maybe (Term f) + decodeReflexivity (Symm (UseAxiom Axiom{..} sub)) = do + guard (eqn_rhs axiom_eqn == true) + (t :=: u) <- decodeEquality (eqn_lhs axiom_eqn) + guard (t == u) + return (subst sub t) + decodeReflexivity _ = Nothing + + -- Detect $equals(t, u) = $false. + decodeConjecture :: Derivation f -> Maybe (String, Equation f, Subst f) + decodeConjecture (UseAxiom Axiom{..} sub) = do + guard (eqn_rhs axiom_eqn == false) + eqn <- decodeEquality (eqn_lhs axiom_eqn) + return (axiom_name, eqn, sub) + decodeConjecture _ = Nothing + + extract (p:ps) = do + -- Start by finding $true = $equals(t,u). + t <- decodeReflexivity p + cont (Refl t) (Refl t) ps + extract [] = Nothing + + cont p1 p2 (p:ps) + | Just t <- decodeReflexivity p = + cont (Refl t) (Refl t) ps + | Just (name, eqn, sub) <- decodeConjecture p = + -- If p1: s=t and p2: s=u + -- then symm p1 `trans` p2: t=u. + return (name, sub, eqn, symm p1 `trans` p2) + | Cong eq [p1', p2'] <- p, eq == equalsCon = + cont (p1 `trans` p1') (p2 `trans` p2') ps + cont _ _ _ = Nothing diff --git a/src/Twee/Queue.hs b/src/Twee/Queue.hs deleted file mode 100644 --- a/src/Twee/Queue.hs +++ /dev/null @@ -1,157 +0,0 @@ --- A priority queue, with orphan murder. -{-# LANGUAGE TypeFamilies, GeneralizedNewtypeDeriving, DeriveFunctor, RecordWildCards, BangPatterns #-} -module Twee.Queue(module Twee.Queue, Heap.Heap) where - -import Twee.Base -import Data.Ord -import qualified Data.Set as Set -import Data.Set(Set) -import qualified Data.List as List -import qualified Data.Heap as Heap -import Control.Monad - -class Heuristic h where - insert :: Ord a => a -> h a -> h a - remove :: Ord a => h a -> Maybe (a, h a) - - reinsert :: Ord a => a -> h a -> h a - reinsert = insert - - members :: Ord a => h a -> [a] - members = List.unfoldr remove - -instance Heuristic Heap.Heap where - insert = Heap.insert - remove = Heap.viewMin - members = Heap.toUnsortedList - -emptyHeap :: Heap.Heap a -emptyHeap = Heap.empty - -data FIFO a = FIFO [a] [a] deriving Show - -emptyFIFO :: FIFO a -emptyFIFO = FIFO [] [] - -instance Heuristic FIFO where - insert x (FIFO xs ys) = FIFO (x:xs) ys - remove (FIFO [] []) = Nothing - remove (FIFO xs []) = remove (FIFO [] (reverse xs)) - remove (FIFO xs (y:ys)) = Just (y, FIFO xs ys) - - reinsert x (FIFO xs ys) = FIFO xs (x:ys) - members (FIFO xs ys) = ys ++ reverse xs - -data Either1 h1 h2 a = Left1 (h1 a) | Right1 (h2 a) deriving Show - -instance (Heuristic h1, Heuristic h2) => Heuristic (Either1 h1 h2) where - insert x (Left1 q) = Left1 (insert x q) - insert x (Right1 q) = Right1 (insert x q) - reinsert x (Left1 q) = Left1 (reinsert x q) - reinsert x (Right1 q) = Right1 (reinsert x q) - remove (Left1 q) = fmap (fmap Left1) (remove q) - remove (Right1 q) = fmap (fmap Right1) (remove q) - members (Left1 q) = members q - members (Right1 q) = members q - -data Mix h a = - Mix { - takeLeft :: {-# UNPACK #-} !Int, - takeRight :: {-# UNPACK #-} !Int, - takeNext :: {-# UNPACK #-} !Int, - left :: !(h a), - right :: !(h a) } - deriving Show - -emptyMix :: Int -> Int -> h a -> h a -> Mix h a -emptyMix m n l r = Mix m n m l r - -instance Heuristic h => Heuristic (Mix h) where - insert x mix = - mix { left = insert x (left mix), - right = insert x (right mix) } - - remove mix = go mix `mplus` go (swap mix) `mplus` go (reset mix) - where - go mix@Mix{..} = do - guard (takeNext > 0) - (x, left') <- remove left - return (x, mix { takeNext = takeNext - 1, left = left' }) - swap Mix{..} = Mix takeRight takeLeft takeRight right left - reset Mix{..} = Mix takeLeft takeRight takeLeft left right - - reinsert x mix = - mix { left = reinsert x (left mix), - right = reinsert x (right mix) } - - members mix = members (left mix) - -data Queue h a = - Queue { - queue :: !(h a), - emptyQueue :: h a, - queueLabels :: Set Label, - nextLabel :: Label } - deriving Show - -class Ord a => Labels a where - labels :: a -> [Label] - -empty :: h a -> Queue h a -empty q = Queue q q (Set.singleton noLabel) (noLabel+1) - -emptyFrom :: Queue q a -> Queue q a -emptyFrom q = q { queue = emptyQueue q } - -enqueue :: (Heuristic h, Labels a) => a -> Queue h a -> Queue h a -enqueue x q = q { queue = insert x (queue q) } - -reenqueue :: (Heuristic h, Labels a) => a -> Queue h a -> Queue h a -reenqueue x q = q { queue = reinsert x (queue q) } - -dequeue :: (Heuristic h, Labels a) => Queue h a -> Maybe (a, Queue h a) -dequeue q@Queue{queueLabels = ls, queue = q0} = aux q0 - where - aux q0 = do - (x, q1) <- remove q0 - if or [ l `Set.notMember` ls | l <- labels x ] then - aux q1 - else return (x, q { queue = q1 }) - -queueSize :: (Heuristic h, Labels a) => Queue h a -> Int -queueSize q = length (toList q) - -toList :: (Heuristic h, Labels a) => Queue h a -> [a] -toList Queue{..} = filter p (members queue) - where - p x = and [ l `Set.member` queueLabels | l <- labels x ] - -newtype Label = Label Int deriving (Eq, Ord, Num, Show, Integral, Enum, Real) - -noLabel :: Label -noLabel = 0 - -newLabel :: Queue h a -> (Label, Queue h a) -newLabel q@Queue{nextLabel = n, queueLabels = ls} = - (n, q { nextLabel = n+1, queueLabels = Set.insert n ls } ) - -deleteLabel :: Label -> Queue h a -> Queue h a -deleteLabel l q@Queue{queueLabels = ls} = q { queueLabels = Set.delete l ls } - -data Labelled a = Labelled { labelOf :: Label, peel :: a } deriving (Show, Functor) - -instance Eq (Labelled a) where x == y = labelOf x == labelOf y -instance Ord (Labelled a) where compare = comparing labelOf -instance Symbolic a => Symbolic (Labelled a) where - type ConstantOf (Labelled a) = ConstantOf a - term = term . peel - termsDL = termsDL . peel - replace f (Labelled l x) = Labelled l (replace f x) -instance Pretty a => Pretty (Labelled a) where pPrint = pPrint . peel - -moveLabel :: Functor f => Labelled (f a) -> f (Labelled a) -moveLabel (Labelled l x) = fmap (Labelled l) x - -unlabelled :: a -> Labelled a -unlabelled = Labelled noLabel - diff --git a/src/Twee/Rule.hs b/src/Twee/Rule.hs --- a/src/Twee/Rule.hs +++ b/src/Twee/Rule.hs @@ -1,11 +1,10 @@ -{-# LANGUAGE TypeFamilies, StandaloneDeriving, FlexibleContexts, UndecidableInstances, RecordWildCards, PatternGuards, CPP, BangPatterns #-} +{-# LANGUAGE TypeFamilies, FlexibleContexts, RecordWildCards, BangPatterns, OverloadedStrings, DeriveGeneric, MultiParamTypeClasses, ScopedTypeVariables, GeneralizedNewtypeDeriving #-} module Twee.Rule where -#include "errors.h" import Twee.Base import Twee.Constraints import qualified Twee.Index as Index -import Twee.Index(Frozen) +import Twee.Index(Index) import Control.Monad import Control.Monad.Trans.Class import Control.Monad.Trans.State.Strict @@ -15,6 +14,12 @@ import qualified Data.Set as Set import Data.Set(Set) import qualified Twee.Term as Term +import GHC.Generics +import Data.Ord +import Twee.Equation +import qualified Twee.Proof as Proof +import Twee.Proof(Derivation, Lemma(..)) +import Data.Tuple -------------------------------------------------------------------------------- -- Rewrite rules. @@ -22,14 +27,20 @@ data Rule f = Rule { - orientation :: Orientation f, - lhs :: Term f, - rhs :: Term f } - deriving (Eq, Ord, Show) + orientation :: !(Orientation f), + -- Invariant: + -- For oriented rules: vars rhs `isSubsetOf` vars lhs + -- For unoriented rules: vars lhs == vars rhs + lhs :: {-# UNPACK #-} !(Term f), + rhs :: {-# UNPACK #-} !(Term f) } + deriving (Eq, Ord, Show, Generic) +type RuleOf a = Rule (ConstantOf a) data Orientation f = + -- Oriented rules: used only left-to-right Oriented - | WeaklyOriented [Term f] + | WeaklyOriented {-# UNPACK #-} !(Fun f) [Term f] + -- Unoriented rules: used bidirectionally | Permutative [(Term f, Term f)] | Unoriented deriving Show @@ -38,107 +49,62 @@ instance Ord (Orientation f) where compare _ _ = EQ oriented :: Orientation f -> Bool -oriented Oriented = True -oriented (WeaklyOriented _) = True +oriented Oriented{} = True +oriented WeaklyOriented{} = True oriented _ = False +weaklyOriented :: Orientation f -> Bool +weaklyOriented WeaklyOriented{} = True +weaklyOriented _ = False + instance Symbolic (Rule f) where type ConstantOf (Rule f) = f - term = lhs - termsDL Rule{..} = termsDL (lhs, (rhs, orientation)) - replace f (Rule or l r) = Rule (replace f or) (replace f l) (replace f r) +instance f ~ g => Has (Rule f) (Term g) where + the = lhs + instance Symbolic (Orientation f) where type ConstantOf (Orientation f) = f - term = __ - termsDL Oriented = mempty - termsDL (WeaklyOriented ts) = termsDL ts - termsDL (Permutative ts) = termsDL ts - termsDL Unoriented = mempty - replace _ Oriented = Oriented - replace f (WeaklyOriented ts) = WeaklyOriented (replace f ts) - replace f (Permutative ts) = Permutative (replace f ts) - replace _ Unoriented = Unoriented -instance (Numbered f, PrettyTerm f) => Pretty (Rule f) where - pPrint (Rule Oriented l r) = pPrintRule l r - pPrint (Rule (WeaklyOriented ts) l r) = hang (pPrintRule l r) 2 (text "(weak on" <+> pPrint ts <> text ")") - pPrint (Rule (Permutative ts) l r) = hang (pPrintRule l r) 2 (text "(permutative on" <+> pPrint ts <> text ")") - pPrint (Rule Unoriented l r) = hang (pPrintRule l r) 2 (text "(unoriented)") - -pPrintRule :: (Numbered f, PrettyTerm f) => Term f -> Term f -> Doc -pPrintRule l r = hang (pPrint l <+> text "->") 2 (pPrint r) - --------------------------------------------------------------------------------- --- Equations. --------------------------------------------------------------------------------- - -data Equation f = Term f :=: Term f deriving (Eq, Ord, Show) -type EquationOf a = Equation (ConstantOf a) - -instance Symbolic (Equation f) where - type ConstantOf (Equation f) = f - term = __ - termsDL (t :=: u) = termsDL (t, u) - replace f (t :=: u) = replace f t :=: replace f u - -instance (Numbered f, PrettyTerm f) => Pretty (Equation f) where - pPrint (x :=: y) = hang (pPrint x <+> text "=") 2 (pPrint y) + termsDL Oriented = mzero + termsDL (WeaklyOriented _ ts) = termsDL ts + termsDL (Permutative ts) = termsDL ts + termsDL Unoriented = mzero -instance (Numbered f, Sized f) => Sized (Equation f) where - size (x :=: y) = size x + size y + subst_ _ Oriented = Oriented + subst_ sub (WeaklyOriented min ts) = WeaklyOriented min (subst_ sub ts) + subst_ sub (Permutative ts) = Permutative (subst_ sub ts) + subst_ _ Unoriented = Unoriented -order :: Function f => Equation f -> Equation f -order (l :=: r) - | l == r = l :=: r - | otherwise = - case compare (size l) (size r) of - LT -> r :=: l - GT -> l :=: r - EQ -> if lessEq l r then r :=: l else l :=: r +instance PrettyTerm f => Pretty (Rule f) where + pPrint (Rule or l r) = + pPrint l <+> text (showOrientation or) <+> pPrint r + where + showOrientation Oriented = "->" + showOrientation WeaklyOriented{} = "~>" + showOrientation Permutative{} = "<->" + showOrientation Unoriented = "=" +-- Turn a rule into an equation. unorient :: Rule f -> Equation f unorient (Rule _ l r) = l :=: r -orient :: Function f => Equation f -> [Rule f] -orient (l :=: r) | l == r = [] -orient (l :=: r) = - -- If we have an equation where some variables appear only on one side, e.g.: - -- f x y = g x z - -- then replace it with the equations: - -- f x y = f x k - -- g x z = g x k - -- f x k = g x k - -- where k is an arbitrary constant - [ rule l r' | ord /= Just LT && ord /= Just EQ ] ++ - [ rule r l' | ord /= Just GT && ord /= Just EQ ] ++ - [ rule l l' | not (null ls), ord /= Just GT ] ++ - [ rule r r' | not (null rs), ord /= Just LT ] - where - ord = orientTerms l' r' - l' = erase ls l - r' = erase rs r - ls = usort (vars l) \\ usort (vars r) - rs = usort (vars r) \\ usort (vars l) - - erase [] t = t - erase xs t = subst sub t - where - sub = fromMaybe __ $ flattenSubst [(x, minimalTerm) | x <- xs] - -rule :: Function f => Term f -> Term f -> Rule f -rule t u = Rule o t u +-- Turn an equation t :=: u into a rule t -> u by computing the +-- orientation info (e.g. oriented, permutative or unoriented). +-- Crashes if t -> u is not a valid rule. +orient :: Function f => Equation f -> Rule f +orient (t :=: u) = Rule o t u where o | lessEq u t = case unify t u of Nothing -> Oriented Just sub | allSubst (\_ (Cons t Empty) -> isMinimal t) sub -> - WeaklyOriented (map (build . var . fst) (listSubst sub)) + WeaklyOriented minimal (map (build . var . fst) (listSubst sub)) | otherwise -> Unoriented - | lessEq t u = ERROR("wrongly-oriented rule") + | lessEq t u = error "wrongly-oriented rule" | not (null (usort (vars u) \\ usort (vars t))) = - ERROR("unbound variables in rule") + error "unbound variables in rule" | Just ts <- evalStateT (makePermutative t u) [], permutativeOK t u ts = Permutative ts @@ -165,161 +131,288 @@ modify ((x, build $ var y):) return [(build $ var x, build $ var y)] - aux (Fun f ts) (Fun g us) + aux (App f ts) (App g us) | f == g = - fmap concat (zipWithM makePermutative (fromTermList ts) (fromTermList us)) + fmap concat (zipWithM makePermutative (unpack ts) (unpack us)) aux _ _ = mzero -bothSides :: (Term f -> Term f') -> Equation f -> Equation f' -bothSides f (t :=: u) = f t :=: f u +-- Flip an unoriented rule so that it goes right-to-left. +backwards :: Rule f -> Rule f +backwards (Rule or t u) = Rule (back or) u t + where + back (Permutative xs) = Permutative (map swap xs) + back Unoriented = Unoriented + back _ = error "Can't turn oriented rule backwards" -trivial :: Eq f => Equation f -> Bool -trivial (t :=: u) = t == u +-------------------------------------------------------------------------------- +-- Extra-fast rewriting, without proof output or unorientable rules. +-------------------------------------------------------------------------------- +-- Compute the normal form of a term wrt only oriented rules. +{-# INLINEABLE simplify #-} +simplify :: (Function f, Has a (Rule f)) => Index f a -> Term f -> Term f +simplify !idx !t = {-# SCC simplify #-} simplify1 idx t + +{-# INLINEABLE simplify1 #-} +simplify1 :: (Function f, Has a (Rule f)) => Index f a -> Term f -> Term f +simplify1 idx t + | t == u = t + | otherwise = simplify idx u + where + u = build (simp (singleton t)) + + simp Empty = mempty + simp (Cons (Var x) t) = var x `mappend` simp t + simp (Cons t u) + | Just (rule, sub) <- simpleRewrite idx t = + Term.subst sub (rhs rule) `mappend` simp u + simp (Cons (App f ts) us) = + app f (simp ts) `mappend` simp us + +-- Check if a term can be simplified. +{-# INLINEABLE canSimplify #-} +canSimplify :: (Function f, Has a (Rule f)) => Index f a -> Term f -> Bool +canSimplify idx t = canSimplifyList idx (singleton t) + +{-# INLINEABLE canSimplifyList #-} +canSimplifyList :: (Function f, Has a (Rule f)) => Index f a -> TermList f -> Bool +canSimplifyList idx t = + {-# SCC canSimplifyList #-} + any (isJust . simpleRewrite idx) (filter isApp (subtermsList t)) + +-- Find a simplification step that applies to a term. +{-# INLINEABLE simpleRewrite #-} +simpleRewrite :: (Function f, Has a (Rule f)) => Index f a -> Term f -> Maybe (Rule f, Subst f) +simpleRewrite idx t = + -- Use instead of maybeToList to make fusion work + foldr (\x _ -> Just x) Nothing $ do + rule <- the <$> Index.approxMatches t idx + guard (oriented (orientation rule)) + sub <- maybeToList (match (lhs rule) t) + guard (reducesOriented rule sub) + return (rule, sub) + -------------------------------------------------------------------------------- --- Rewriting. +-- Rewriting, with proof output. -------------------------------------------------------------------------------- type Strategy f = Term f -> [Reduction f] +-- A multi-step rewrite proof t ->* u data Reduction f = - Step (Rule f) (Subst f) - | Trans (Reduction f) (Reduction f) - | Parallel [(Int, Reduction f)] (Term f) + -- Apply a single rewrite rule to the root of a term + Step {-# UNPACK #-} !(Lemma f) !(Rule f) !(Subst f) + -- Reflexivity + | Refl {-# UNPACK #-} !(Term f) + -- Transivitity + | Trans !(Reduction f) !(Reduction f) + -- Congruence + | Cong {-# UNPACK #-} !(Fun f) ![Reduction f] deriving Show -result :: Reduction f -> Term f -result (Parallel [] t) = t -result (Trans _ p) = result p -result t = build (emitReduction t) - where - emitReduction (Step r sub) = Term.subst sub (rhs r) - emitReduction (Trans _ p) = emitReduction p - emitReduction (Parallel ps t) = emitParallel 0 ps (singleton t) +instance Symbolic (Reduction f) where + type ConstantOf (Reduction f) = f + termsDL (Step _ _ sub) = termsDL sub + termsDL (Refl t) = termsDL t + termsDL (Trans p q) = termsDL p `mplus` termsDL q + termsDL (Cong _ ps) = termsDL ps - emitParallel !_ _ _ | False = __ - emitParallel _ _ Empty = mempty - emitParallel _ [] t = builder t - emitParallel n ((m, _):_) t | m >= n + lenList t = builder t - emitParallel n ps@((m, _):_) (Cons t u) | m >= n + len t = - builder t `mappend` emitParallel (n + len t) ps u - emitParallel n ((m, _):ps) t | m < n = emitParallel n ps t - emitParallel n ((m, p):ps) (Cons t u) | m == n = - emitReduction p `mappend` emitParallel (n + len t) ps u - emitParallel n ps (Cons (Var x) u) = - var x `mappend` emitParallel (n + 1) ps u - emitParallel n ps (Cons (Fun f t) u) = - fun f (emitParallel (n+1) ps t) `mappend` - emitParallel (n + 1 + lenList t) ps u + subst_ sub (Step lemma rule s) = Step lemma rule (subst_ sub s) + subst_ sub (Refl t) = Refl (subst_ sub t) + subst_ sub (Trans p q) = Trans (subst_ sub p) (subst_ sub q) + subst_ sub (Cong f ps) = Cong f (subst_ sub ps) -instance (Numbered f, PrettyTerm f) => Pretty (Reduction f) where - pPrint = pPrintReduction +instance Function f => Pretty (Reduction f) where + pPrint = pPrint . reductionProof -pPrintReduction :: (Numbered f, PrettyTerm f) => Reduction f -> Doc -pPrintReduction p = - case flatten p of - [p] -> pp p - ps -> pPrint (map pp ps) - where - flatten (Trans p q) = flatten p ++ flatten q - flatten p = [p] +-- Smart constructors for Trans and Cong which simplify Refl. +trans :: Reduction f -> Reduction f -> Reduction f +trans Refl{} p = p +trans p Refl{} = p +-- Make right-associative to improve performance of 'result' +trans p (Trans q r) = Trans (Trans p q) r +trans p q = Trans p q - pp p = sep [pp0 p, nest 2 (text "giving" <+> pPrint (result p))] - pp0 (Step rule sub) = - sep [pPrint rule, - nest 2 (text "at" <+> pPrint sub)] - pp0 (Parallel [] _) = text "refl" - pp0 (Parallel [(0, p)] _) = pp0 p - pp0 (Parallel ps _) = - sep (punctuate (text " and") - [hang (pPrint n <+> text "->") 2 (pPrint p) | (n, p) <- ps]) +cong :: Fun f -> [Reduction f] -> Reduction f +cong f ps + | all isRefl ps = Refl (result (reduce (Cong f ps))) + | otherwise = Cong f ps + where + isRefl Refl{} = True + isRefl _ = False -steps :: Reduction f -> [(Rule f, Subst f)] +-- The list of all rewrite rules used in a rewrite proof +steps :: Reduction f -> [Reduction f] steps r = aux r [] where - aux (Step r sub) = ((r, sub):) + aux step@Step{} = (step:) + aux (Refl _) = id aux (Trans p q) = aux p . aux q - aux (Parallel ps _) = foldr (.) id (map (aux . snd) ps) + aux (Cong _ ps) = foldr (.) id (map aux ps) -anywhere1 :: (Numbered f, PrettyTerm f) => Strategy f -> Reduction f -> Maybe (Reduction f) -anywhere1 strat p = aux [] 0 (singleton t) p t +-- Turn a reduction into a proof. +reductionProof :: Reduction f -> Derivation f +reductionProof (Step lemma _ sub) = + Proof.lemma lemma sub +reductionProof (Refl t) = Proof.Refl t +reductionProof (Trans p q) = + Proof.trans (reductionProof p) (reductionProof q) +reductionProof (Cong f ps) = Proof.cong f (map reductionProof ps) + +-- Construct a basic rewrite step. +{-# INLINE step #-} +step :: (Has a (Rule f), Has a (Lemma f)) => a -> Subst f -> Reduction f +step x sub = Step (the x) (the x) sub + +---------------------------------------------------------------------- +-- A rewrite proof with the final term attached. +-- Has an Ord instance which compares the final term. +---------------------------------------------------------------------- + +data Resulting f = + Resulting { + result :: {-# UNPACK #-} !(Term f), + reduction :: !(Reduction f) } + deriving (Show, Generic) + +instance Eq (Resulting f) where x == y = compare x y == EQ +instance Ord (Resulting f) where compare = comparing result + +instance Symbolic (Resulting f) where + type ConstantOf (Resulting f) = f + +instance Function f => Pretty (Resulting f) where + pPrint = pPrint . reduction + +reduce :: Reduction f -> Resulting f +reduce p = + Resulting (res p) p where - aux _ !_ !_ _ !_ | False = __ - aux [] _ Empty _ _ = Nothing - aux ps _ Empty p t = Just (p `Trans` Parallel (reverse ps) t) - aux ps n (Cons (Var _) t) p u = aux ps (n+1) t p u - aux ps n (Cons t u) p v | q:_ <- strat t = - aux ((n, q):ps) (n+len t) u p v - aux ps n (ConsSym (Fun _ _) t) p u = - aux ps (n+1) t p u + res (Trans _ q) = res q + res (Refl t) = t + res p = {-# SCC res_emitRes #-} build (emitResult p) - t = result p + emitResult (Step _ r sub) = Term.subst sub (rhs r) + emitResult (Refl t) = builder t + emitResult (Trans _ q) = emitResult q + emitResult (Cong f ps) = app f (map emitResult ps) -normaliseWith :: (Numbered f, PrettyTerm f) => Strategy f -> Term f -> Reduction f -normaliseWith strat t = aux 0 (Parallel [] t) +-------------------------------------------------------------------------------- +-- Strategy combinators. +-------------------------------------------------------------------------------- + +-- Normalise a term wrt a particular strategy. +{-# INLINE normaliseWith #-} +normaliseWith :: Function f => (Term f -> Bool) -> Strategy f -> Term f -> Resulting f +normaliseWith ok strat t = {-# SCC normaliseWith #-} res where - aux 1000 p = - ERROR("Possibly nonterminating rewrite:\n" ++ - prettyShow p) - aux n p = - case anywhere1 strat p of - Nothing -> p - Just q -> aux (n+1) q + res = aux 0 (Refl t) t + aux 1000 p _ = + error $ + "Possibly nonterminating rewrite:\n" ++ prettyShow p + aux n p t = + case parallel strat t of + (q:_) | u <- result (reduce q), ok u -> + aux (n+1) (p `trans` q) u + _ -> Resulting t p -normalForms :: Function f => Strategy f -> [Term f] -> Set (Term f) -normalForms strat ts = go Set.empty Set.empty ts +-- Compute all normal forms of a set of terms wrt a particular strategy. +normalForms :: Function f => Strategy f -> [Resulting f] -> Set (Resulting f) +normalForms strat ps = snd (successorsAndNormalForms strat ps) + +-- Compute all successors of a set of terms (a successor of a term t +-- is a term u such that t ->* u). +successors :: Function f => Strategy f -> [Resulting f] -> Set (Resulting f) +successors strat ps = Set.union qs rs where - go _ norm [] = norm - go dead norm (t:ts) - | t `Set.member` dead = go dead norm ts - | t `Set.member` norm = go dead norm ts - | null us = go dead (Set.insert t norm) ts + (qs, rs) = successorsAndNormalForms strat ps + +{-# INLINEABLE successorsAndNormalForms #-} +successorsAndNormalForms :: Function f => Strategy f -> [Resulting f] -> + (Set (Resulting f), Set (Resulting f)) +successorsAndNormalForms strat ps = + {-# SCC successorsAndNormalForms #-} go Set.empty Set.empty ps + where + go dead norm [] = (dead, norm) + go dead norm (p:ps) + | p `Set.member` dead = go dead norm ps + | p `Set.member` norm = go dead norm ps + | null qs = go dead (Set.insert p norm) ps | otherwise = - go (Set.insert t dead) norm (us ++ ts) + go (Set.insert p dead) norm (qs ++ ps) where - us = map result (anywhere strat t) + qs = + [ reduce (reduction p `Trans` q) + | q <- anywhere strat (result p) ] +-- Apply a strategy anywhere in a term. anywhere :: Strategy f -> Strategy f -anywhere strat t = aux 0 (singleton t) - where - aux !_ Empty = [] - aux n (Cons Var{} u) = aux (n+1) u - aux n (ConsSym u v) = - [Parallel [(n,p)] t | p <- strat u] ++ aux (n+1) v +anywhere strat t = strat t ++ nested (anywhere strat) t +-- Apply a strategy to some child of the root function. nested :: Strategy f -> Strategy f -nested strat t = [Parallel [(1,p)] t | p <- aux 0 (children t)] +nested _ Var{} = [] +nested strat (App f ts) = + cong f <$> inner [] ts where - aux !_ Empty = [] - aux n (Cons Var{} u) = aux (n+1) u - aux n (Cons u v) = - [Parallel [(n,p)] t | p <- strat u] ++ aux (n+len t) v + inner _ Empty = [] + inner before (Cons t u) = + [ reverse before ++ [p] ++ map Refl (unpack u) + | p <- strat t ] ++ + inner (Refl t:before) u +-- Apply a strategy in parallel in as many places as possible. +-- Takes only the first rewrite of each strategy. +{-# INLINE parallel #-} +parallel :: PrettyTerm f => Strategy f -> Strategy f +parallel strat t = + case par t of + Refl{} -> [] + p -> [p] + where + par t | p:_ <- strat t = p + par (App f ts) = cong f (inner [] ts) + par t = Refl t + + inner before Empty = reverse before + inner before (Cons t u) = inner (par t:before) u + +-------------------------------------------------------------------------------- +-- Basic strategies. These only apply at the root of the term. +-------------------------------------------------------------------------------- + +-- A strategy which rewrites using an index. {-# INLINE rewrite #-} -rewrite :: Function f => String -> (Rule f -> Subst f -> Bool) -> Frozen (Rule f) -> Strategy f -rewrite _phase p rules t = do - Index.Match rule sub <- Index.matches t rules - guard (p rule sub) - return (Step rule sub) +rewrite :: (Function f, Has a (Rule f), Has a (Lemma f)) => (Rule f -> Subst f -> Bool) -> Index f a -> Strategy f +rewrite p rules t = do + rule <- Index.approxMatches t rules + tryRule p rule t -tryRule :: Function f => (Rule f -> Subst f -> Bool) -> Rule f -> Strategy f +-- A strategy which applies one rule only. +{-# INLINEABLE tryRule #-} +tryRule :: (Function f, Has a (Rule f), Has a (Lemma f)) => (Rule f -> Subst f -> Bool) -> a -> Strategy f tryRule p rule t = do - sub <- maybeToList (match (lhs rule) t) - guard (p rule sub) - return (Step rule sub) - -simplifies :: Function f => Rule f -> Subst f -> Bool -simplifies (Rule Oriented _ _) _ = True -simplifies (Rule (WeaklyOriented ts) _ _) sub = - or [ not (isMinimal t) | t <- subst sub ts ] -simplifies (Rule (Permutative _) _ _) _ = False -simplifies (Rule Unoriented _ _) _ = False + sub <- maybeToList (match (lhs (the rule)) t) + guard (p (the rule) sub) + return (step rule sub) +-- Check if a rule can be applied, given an ordering <= on terms. +{-# INLINEABLE reducesWith #-} reducesWith :: Function f => (Term f -> Term f -> Bool) -> Rule f -> Subst f -> Bool reducesWith _ (Rule Oriented _ _) _ = True -reducesWith _ (Rule (WeaklyOriented ts) _ _) sub = - or [ not (isMinimal t) | t <- subst sub ts ] +reducesWith _ (Rule (WeaklyOriented min ts) _ _) sub = + -- Be a bit careful here not to build new terms + -- (reducesWith is used in simplify). + -- This is the same as: + -- any (not . isMinimal) (subst sub ts) + any (not . isMinimal . expand) ts + where + expand t@(Var x) = fromMaybe t (Term.lookup x sub) + expand t = t + + isMinimal (App f Empty) = f == min + isMinimal _ = False reducesWith p (Rule (Permutative ts) _ _) sub = aux ts where @@ -336,19 +429,26 @@ t' = subst sub t u' = subst sub u +-- Check if a rule can be applied normally. +{-# INLINEABLE reduces #-} reduces :: Function f => Rule f -> Subst f -> Bool -reduces rule = reducesWith lessEq rule +reduces rule sub = reducesWith lessEq rule sub +-- Check if a rule can be applied and is oriented. +{-# INLINEABLE reducesOriented #-} +reducesOriented :: Function f => Rule f -> Subst f -> Bool +reducesOriented rule sub = + oriented (orientation rule) && reducesWith undefined rule sub + +-- Check if a rule can be applied in various circumstances. +{-# INLINEABLE reducesInModel #-} reducesInModel :: Function f => Model f -> Rule f -> Subst f -> Bool -reducesInModel cond rule = reducesWith (\t u -> isJust (lessIn cond t u)) rule +reducesInModel cond rule sub = + reducesWith (\t u -> isJust (lessIn cond t u)) rule sub +{-# INLINEABLE reducesSkolem #-} reducesSkolem :: Function f => Rule f -> Subst f -> Bool -reducesSkolem = reducesWith (\t u -> lessEq (subst skolemise t) (subst skolemise u)) +reducesSkolem rule sub = + reducesWith (\t u -> lessEq (subst skolemise t) (subst skolemise u)) rule sub where skolemise = con . skolem - -reducesSub :: Function f => Term f -> Rule f -> Subst f -> Bool -reducesSub top rule sub = - reducesSkolem rule sub && lessEq u top && isNothing (unify u top) - where - u = subst sub (rhs rule) diff --git a/src/Twee/Rule/Index.hs b/src/Twee/Rule/Index.hs new file mode 100644 --- /dev/null +++ b/src/Twee/Rule/Index.hs @@ -0,0 +1,45 @@ +{-# LANGUAGE RecordWildCards, ScopedTypeVariables, FlexibleContexts #-} +module Twee.Rule.Index( + RuleIndex(..), + nil, insert, delete, + approxMatches, matches, lookup) where + +import Prelude hiding (lookup) +import Twee.Base hiding (lookup) +import Twee.Rule +import Twee.Index hiding (insert, delete) +import qualified Twee.Index as Index + +data RuleIndex f a = + RuleIndex { + index_oriented :: !(Index f a), + index_weak :: !(Index f a), + index_all :: !(Index f a) } + deriving Show + +nil :: RuleIndex f a +nil = RuleIndex Nil Nil Nil + +insert :: forall f a. Has a (Rule f) => Term f -> a -> RuleIndex f a -> RuleIndex f a +insert t x RuleIndex{..} = + RuleIndex { + index_oriented = insertWhen (oriented or) index_oriented, + index_weak = insertWhen (weaklyOriented or) index_weak, + index_all = insertWhen True index_all } + where + Rule or _ _ = the x :: Rule f + + insertWhen False idx = idx + insertWhen True idx = Index.insert t x idx + +delete :: forall f a. (Eq a, Has a (Rule f)) => Term f -> a -> RuleIndex f a -> RuleIndex f a +delete t x RuleIndex{..} = + RuleIndex { + index_oriented = deleteWhen (oriented or) index_oriented, + index_weak = deleteWhen (weaklyOriented or) index_weak, + index_all = deleteWhen True index_all } + where + Rule or _ _ = the x :: Rule f + + deleteWhen False idx = idx + deleteWhen True idx = Index.delete t x idx diff --git a/src/Twee/Task.hs b/src/Twee/Task.hs new file mode 100644 --- /dev/null +++ b/src/Twee/Task.hs @@ -0,0 +1,52 @@ +-- A module which can run housekeeping tasks every so often. +{-# LANGUAGE RecordWildCards #-} +module Twee.Task where + +import System.CPUTime +import Data.IORef +import Control.Monad.IO.Class + +data TaskData m a = + Task { + -- When was the task created? + task_start :: !Integer, + -- When was the task last run? + task_last :: !Integer, + -- How long have we spent on this task so far? + task_spent :: !Integer, + -- How often should we run this task at most, in seconds? + task_frequency :: !Double, + -- What proportion of our time should we spend on the task? + task_budget :: !Double, + -- The task itself + task_what :: m a } +type Task m a = IORef (TaskData m a) + +-- Create a new task that should be run a certain proportion +-- of the time. +newTask :: MonadIO m => Double -> Double -> m a -> m (Task m a) +newTask freq budget what = liftIO $ do + now <- getCPUTime + newIORef (Task now now 0 freq budget what) + +-- Run a task if it's time to run it. +checkTask :: MonadIO m => Task m a -> m (Maybe a) +checkTask ref = do + task@Task{..} <- liftIO $ readIORef ref + now <- liftIO getCPUTime + if not (taskDue now task) then return Nothing else do + res <- task_what + after <- liftIO getCPUTime + liftIO $ writeIORef ref task { + task_last = after, + task_spent = task_spent + (after-now) } + return (Just res) + +-- Check if a task should be run now. +taskDue :: Integer -> TaskData m a -> Bool +taskDue now Task{..} = + -- Don't run more than the frequency says. + fromInteger (now - task_last) >= task_frequency * 10^12 && + -- Run if we spent less than task_budget proportion of the total time so far. + -- Use > rather than >= so that tasks with zero budget never get run. + fromInteger (now - task_start) * task_budget > fromInteger task_spent diff --git a/src/Twee/Term.hs b/src/Twee/Term.hs --- a/src/Twee/Term.hs +++ b/src/Twee/Term.hs @@ -2,21 +2,20 @@ -- This module implements the usual term manipulation stuff -- (matching, unification, etc.) on top of the primitives -- in Twee.Term.Core. -{-# LANGUAGE BangPatterns, CPP, PatternSynonyms, RankNTypes, FlexibleContexts, ViewPatterns, FlexibleInstances, UndecidableInstances, ScopedTypeVariables, RecordWildCards, MultiParamTypeClasses, FunctionalDependencies, GADTs #-} +{-# LANGUAGE BangPatterns, PatternSynonyms, ViewPatterns, TypeFamilies, OverloadedStrings, ScopedTypeVariables #-} module Twee.Term( module Twee.Term, -- Stuff from Twee.Term.Core. Term, TermList, at, lenList, + isSubtermOfList, isVarOf, pattern Empty, pattern Cons, pattern ConsSym, pattern UnsafeCons, pattern UnsafeConsSym, - Fun(..), Var(..), pattern Var, pattern Fun, singleton, Builder) where + Fun, fun, fun_id, fun_value, Var(..), pattern Var, pattern App, singleton, Builder) where -#include "errors.h" import Prelude hiding (lookup) import Twee.Term.Core -import Data.List hiding (lookup) +import Data.List hiding (lookup, find) import Data.Maybe -import Data.Ord import Data.Monoid import Data.IntMap.Strict(IntMap) import qualified Data.IntMap.Strict as IntMap @@ -25,50 +24,55 @@ -- A type class for builders. -------------------------------------------------------------------------------- -class Build f a | a -> f where - builder :: a -> Builder f +class Build a where + type BuildFun a + builder :: a -> Builder (BuildFun a) -instance Build f (Builder f) where +instance Build (Builder f) where + type BuildFun (Builder f) = f builder = id -instance Build f (Term f) where +instance Build (Term f) where + type BuildFun (Term f) = f builder = emitTerm -instance Build f (TermList f) where +instance Build (TermList f) where + type BuildFun (TermList f) = f builder = emitTermList -instance Build f a => Build f [a] where +instance Build a => Build [a] where + type BuildFun [a] = BuildFun a {-# INLINE builder #-} builder = mconcat . map builder {-# INLINE build #-} -build :: Build f a => a -> Term f +build :: Build a => a -> Term (BuildFun a) build x = case buildList x of Cons t Empty -> t {-# INLINE buildList #-} -buildList :: Build f a => a -> TermList f -buildList x = buildTermList (builder x) +buildList :: Build a => a -> TermList (BuildFun a) +buildList x = {-# SCC buildList #-} buildTermList (builder x) {-# INLINE con #-} con :: Fun f -> Builder f -con x = emitFun x mempty +con x = emitApp x mempty -{-# INLINE fun #-} -fun :: Build f a => Fun f -> a -> Builder f -fun f ts = emitFun f (builder ts) +{-# INLINE app #-} +app :: Build a => Fun (BuildFun a) -> a -> Builder (BuildFun a) +app f ts = emitApp f (builder ts) var :: Var -> Builder f var = emitVar -------------------------------------------------------------------------------- --- Pattern synonyms for substitutions. +-- Functions for substitutions. -------------------------------------------------------------------------------- {-# INLINE listSubstList #-} listSubstList :: Subst f -> [(Var, TermList f)] -listSubstList (Subst sub) = [(MkVar x, t) | (x, t) <- IntMap.toList sub] +listSubstList (Subst sub) = [(V x, t) | (x, t) <- IntMap.toList sub] {-# INLINE listSubst #-} listSubst :: Subst f -> [(Var, Term f)] @@ -86,18 +90,35 @@ forMSubst_ :: Monad m => Subst f -> (Var -> TermList f -> m ()) -> m () forMSubst_ sub f = foldSubst (\x t m -> do { f x t; m }) (return ()) sub +{-# INLINE substDomain #-} +substDomain :: Subst f -> [Var] +substDomain (Subst sub) = map V (IntMap.keys sub) + -------------------------------------------------------------------------------- -- Substitution. -------------------------------------------------------------------------------- -class Substitution f s | s -> f where - evalSubst :: s -> Var -> Builder f +class Substitution s where + type SubstFun s + evalSubst :: s -> Var -> Builder (SubstFun s) -instance (Build f a, v ~ Var) => Substitution f (v -> a) where + {-# INLINE substList #-} + substList :: s -> TermList (SubstFun s) -> Builder (SubstFun s) + substList sub ts = aux ts + where + aux Empty = mempty + aux (Cons (Var x) ts) = evalSubst sub x <> aux ts + aux (Cons (App f ts) us) = app f (aux ts) <> aux us + +instance (Build a, v ~ Var) => Substitution (v -> a) where + type SubstFun (v -> a) = BuildFun a + {-# INLINE evalSubst #-} evalSubst sub x = builder (sub x) -instance Substitution f (Subst f) where +instance Substitution (Subst f) where + type SubstFun (Subst f) = f + {-# INLINE evalSubst #-} evalSubst sub x = case lookupList x sub of @@ -105,20 +126,13 @@ Just ts -> builder ts {-# INLINE subst #-} -subst :: Substitution f s => s -> Term f -> Builder f +subst :: Substitution s => s -> Term (SubstFun s) -> Builder (SubstFun s) subst sub t = substList sub (singleton t) -{-# INLINE substList #-} -substList :: Substitution f s => s -> TermList f -> Builder f -substList sub ts = aux ts - where - aux Empty = mempty - aux (Cons (Var x) ts) = evalSubst sub x <> aux ts - aux (Cons (Fun f ts) us) = fun f (aux ts) <> aux us - newtype Subst f = Subst { unSubst :: IntMap (TermList f) } + deriving Eq {-# INLINE substSize #-} substSize :: Subst f -> Int @@ -129,14 +143,14 @@ -- Look up a variable. {-# INLINE lookupList #-} lookupList :: Var -> Subst f -> Maybe (TermList f) -lookupList (MkVar x) (Subst sub) = IntMap.lookup x sub +lookupList x (Subst sub) = IntMap.lookup (var_id x) sub -- Add a new binding to a substitution. {-# INLINE extendList #-} extendList :: Var -> TermList f -> Subst f -> Maybe (Subst f) -extendList (MkVar x) !t (Subst sub) = - case IntMap.lookup x sub of - Nothing -> Just $! Subst (IntMap.insert x t sub) +extendList x !t (Subst sub) = + case IntMap.lookup (var_id x) sub of + Nothing -> Just $! Subst (IntMap.insert (var_id x) t sub) Just u | t == u -> Just (Subst sub) | otherwise -> Nothing @@ -144,16 +158,16 @@ -- Remove a binding from a substitution. {-# INLINE retract #-} retract :: Var -> Subst f -> Subst f -retract (MkVar x) (Subst sub) = Subst (IntMap.delete x sub) +retract x (Subst sub) = Subst (IntMap.delete (var_id x) sub) -- Add a new binding to a substitution. -- Overwrites any existing binding. {-# INLINE unsafeExtendList #-} unsafeExtendList :: Var -> TermList f -> Subst f -> Subst f -unsafeExtendList (MkVar x) !t (Subst sub) = Subst (IntMap.insert x t sub) +unsafeExtendList x !t (Subst sub) = Subst (IntMap.insert (var_id x) t sub) -- Composition of substitutions. -substCompose :: Substitution f s => Subst f -> s -> Subst f +substCompose :: Substitution s => Subst (SubstFun s) -> s -> Subst (SubstFun s) substCompose (Subst !sub1) !sub2 = Subst (IntMap.map (buildList . substList sub2) sub1) @@ -184,7 +198,7 @@ idempotentOn !sub = aux where aux Empty = True - aux (ConsSym Fun{} t) = aux t + aux (ConsSym App{} t) = aux t aux (Cons (Var x) t) = isNothing (lookupList x sub) && aux t -- Iterate a substitution to make it idempotent. @@ -198,15 +212,15 @@ canonicalise [] = emptySubst canonicalise (t:ts) = loop emptySubst vars t ts where - n = maximum (0:map boundList (t:ts)) + n = maximum (V 0:map boundList (t:ts)) vars = buildTermList $ - mconcat [emitVar (MkVar i) | i <- [0..n]] + mconcat [emitVar x | x <- [V 0..n]] - loop !_ !_ !_ !_ | False = __ + loop !_ !_ !_ !_ | False = undefined loop sub _ Empty [] = sub loop sub vs Empty (t:ts) = loop sub vs t ts - loop sub vs (ConsSym Fun{} t) ts = loop sub vs t ts + loop sub vs (ConsSym App{} t) ts = loop sub vs t ts loop sub vs0@(Cons v vs) (Cons (Var x) t) ts = case extend x v sub of Just sub -> loop sub vs t ts @@ -231,20 +245,28 @@ match :: Term f -> Term f -> Maybe (Subst f) match pat t = matchList (singleton pat) (singleton t) +{-# INLINE matchIn #-} +matchIn :: Subst f -> Term f -> Term f -> Maybe (Subst f) +matchIn sub pat t = matchListIn sub (singleton pat) (singleton t) + +{-# INLINE matchList #-} matchList :: TermList f -> TermList f -> Maybe (Subst f) -matchList !pat !t +matchList pat t = matchListIn emptySubst pat t + +matchListIn :: Subst f -> TermList f -> TermList f -> Maybe (Subst f) +matchListIn !sub !pat !t | lenList t < lenList pat = Nothing | otherwise = - let loop !_ !_ !_ | False = __ + let loop !_ !_ !_ | False = undefined loop sub Empty _ = Just sub - loop _ _ Empty = __ - loop sub (ConsSym (Fun f _) pat) (ConsSym (Fun g _) t) + loop _ _ Empty = undefined -- implies lenList t < lenList pat + loop sub (ConsSym (App f _) pat) (ConsSym (App g _) t) | f == g = loop sub pat t loop sub (Cons (Var x) pat) (Cons t u) = do sub <- extend x t sub loop sub pat u loop _ _ _ = Nothing - in loop emptySubst pat t + in {-# SCC match #-} loop sub pat t -------------------------------------------------------------------------------- -- Unification. @@ -253,19 +275,28 @@ newtype TriangleSubst f = Triangle { unTriangle :: Subst f } deriving Show -instance Substitution f (TriangleSubst f) where - evalSubst (Triangle sub) x = substTri sub x +instance Substitution (TriangleSubst f) where + type SubstFun (TriangleSubst f) = f -{-# INLINE substTri #-} -substTri :: Subst f -> Var -> Builder f -substTri sub x = aux x - where - aux x = - case lookupList x sub of - Nothing -> var x - Just ts -> substList aux ts + {-# INLINE evalSubst #-} + evalSubst (Triangle sub) x = + case lookupList x sub of + Nothing -> var x + Just ts -> substList (Triangle sub) ts -{-# INLINE unify #-} + -- Redefine substList to get better inlining behaviour + {-# INLINE substList #-} + substList (Triangle sub) ts = aux ts + where + aux Empty = mempty + aux (Cons (Var x) ts) = auxVar x <> aux ts + aux (Cons (App f ts) us) = app f (aux ts) <> aux us + + auxVar x = + case lookupList x sub of + Nothing -> var x + Just ts -> aux ts + unify :: Term f -> Term f -> Maybe (Subst f) unify t u = unifyList (singleton t) (singleton u) @@ -274,17 +305,18 @@ sub <- unifyListTri t u return $! close sub -{-# INLINE unifyTri #-} unifyTri :: Term f -> Term f -> Maybe (TriangleSubst f) unifyTri t u = unifyListTri (singleton t) (singleton u) unifyListTri :: TermList f -> TermList f -> Maybe (TriangleSubst f) -unifyListTri !t !u = fmap Triangle (loop emptySubst t u) +unifyListTri !t !u = fmap Triangle ({-# SCC unify #-} loop emptySubst t u) where - loop !_ !_ !_ | False = __ + loop !_ !_ !_ | False = undefined loop sub Empty _ = Just sub - loop _ _ Empty = __ - loop sub (ConsSym (Fun f _) t) (ConsSym (Fun g _) u) + loop _ _ Empty = error "funny term in unification" + -- could happen if input lists have different lengths, + -- or a function is used with inconsistent arities + loop sub (ConsSym (App f _) t) (ConsSym (App g _) u) | f == g = loop sub t u loop sub (Cons (Var x) t) (Cons u v) = do sub <- var sub x u @@ -311,7 +343,7 @@ extend x t sub occurs !_ !_ Empty = Just () - occurs sub x (ConsSym Fun{} t) = occurs sub x t + occurs sub x (ConsSym App{} t) = occurs sub x t occurs sub x (ConsSym (Var y) t) | x == y = Nothing | otherwise = do @@ -324,29 +356,34 @@ -- Miscellaneous stuff. -------------------------------------------------------------------------------- +empty :: forall f. TermList f +empty = buildList (mempty :: Builder f) + children :: Term f -> TermList f children t = case singleton t of UnsafeConsSym _ ts -> ts -fromTermList :: TermList f -> [Term f] -fromTermList Empty = [] -fromTermList (Cons t ts) = t:fromTermList ts +unpack :: TermList f -> [Term f] +unpack t = unfoldr op t + where + op Empty = Nothing + op (Cons t ts) = Just (t, ts) instance Show (Term f) where show (Var x) = show x - show (Fun f Empty) = show f - show (Fun f ts) = show f ++ "(" ++ intercalate "," (map show (fromTermList ts)) ++ ")" + show (App f Empty) = show f + show (App f ts) = show f ++ "(" ++ intercalate "," (map show (unpack ts)) ++ ")" instance Show (TermList f) where - show = show . fromTermList + show = show . unpack instance Show (Subst f) where show subst = show [ (i, t) | i <- [0..substSize subst-1], - Just t <- [lookup (MkVar i) subst] ] + Just t <- [lookup (V i) subst] ] {-# INLINE lookup #-} lookup :: Var -> Subst f -> Maybe (Term f) @@ -368,17 +405,17 @@ -- Find the lowest-numbered variable that doesn't appear in a term. {-# INLINE bound #-} -bound :: Term f -> Int +bound :: Term f -> Var bound t = boundList (singleton t) {-# INLINE boundList #-} -boundList :: TermList f -> Int -boundList t = aux 0 t +boundList :: TermList f -> Var +boundList t = aux (V 0) t where aux n Empty = n - aux n (ConsSym Fun{} t) = aux n t - aux n (ConsSym (Var (MkVar x)) t) - | x >= n = aux (x+1) t + aux n (ConsSym App{} t) = aux n t + aux n (ConsSym (Var x) t) + | x >= n = aux (succ x) t | otherwise = aux n t -- Check if a variable occurs in a term. @@ -391,7 +428,7 @@ occursList !x = aux where aux Empty = False - aux (ConsSym Fun{} t) = aux t + aux (ConsSym App{} t) = aux t aux (ConsSym (Var y) t) = x == y || aux t {-# INLINE termListToList #-} @@ -404,8 +441,6 @@ emptyTermList :: TermList f emptyTermList = buildList (mempty :: Builder f) --- Functions for building terms. - {-# INLINE subtermsList #-} subtermsList :: TermList f -> [Term f] subtermsList t = unfoldr op t @@ -417,18 +452,13 @@ subterms :: Term f -> [Term f] subterms = subtermsList . singleton -{-# INLINE properSubtermsList #-} -properSubtermsList :: TermList f -> [Term f] -properSubtermsList Empty = [] -properSubtermsList (ConsSym _ t) = subtermsList t - {-# INLINE properSubterms #-} properSubterms :: Term f -> [Term f] -properSubterms = properSubtermsList . singleton +properSubterms = subtermsList . children -isFun :: Term f -> Bool -isFun Fun{} = True -isFun _ = False +isApp :: Term f -> Bool +isApp App{} = True +isApp _ = False isVar :: Term f -> Bool isVar Var{} = True @@ -440,6 +470,9 @@ isVariantOf :: Term f -> Term f -> Bool t `isVariantOf` u = t `isInstanceOf` u && u `isInstanceOf` t +isSubtermOf :: Term f -> Term f -> Bool +t `isSubtermOf` u = t `isSubtermOfList` singleton u + mapFun :: (Fun f -> Fun g) -> Term f -> Builder g mapFun f = mapFunList f . singleton @@ -448,26 +481,64 @@ where aux Empty = mempty aux (Cons (Var x) ts) = var x `mappend` aux ts - aux (Cons (Fun ff ts) us) = fun (f ff) (aux ts) `mappend` aux us + aux (Cons (App ff ts) us) = app (f ff) (aux ts) `mappend` aux us --------------------------------------------------------------------------------- --- Typeclass for getting at the 'f' in a 'Term f'. --------------------------------------------------------------------------------- +{-# INLINE replacePosition #-} +replacePosition :: (Build a, BuildFun a ~ f) => Int -> a -> TermList f -> Builder f +replacePosition n !x = aux n + where + aux !_ !_ | False = undefined + aux _ Empty = mempty + aux 0 (Cons _ t) = builder x `mappend` builder t + aux n (Cons (Var x) t) = var x `mappend` aux (n-1) t + aux n (Cons t@(App f ts) u) + | n < len t = + app f (aux (n-1) ts) `mappend` builder u + | otherwise = + builder t `mappend` aux (n-len t) u -class Numbered f where - fromInt :: Int -> f - toInt :: f -> Int +{-# INLINE replacePositionSub #-} +replacePositionSub :: (Substitution sub, SubstFun sub ~ f) => sub -> Int -> TermList f -> TermList f -> Builder f +replacePositionSub sub n !x = aux n + where + aux !_ !_ | False = undefined + aux _ Empty = mempty + aux n (Cons t u) + | n < len t = inside n t `mappend` outside u + | otherwise = outside (singleton t) `mappend` aux (n-len t) u -fromFun :: Numbered f => Fun f -> f -fromFun (MkFun n) = fromInt n + inside 0 _ = outside x + inside n (App f ts) = app f (aux (n-1) ts) + inside _ _ = undefined -- implies n >= len t -toFun :: Numbered f => f -> Fun f -toFun f = MkFun (toInt f) + outside t = substList sub t -instance (Ord f, Numbered f) => Ord (Fun f) where - compare = comparing fromFun +-- Convert a position in a term into a path. +positionToPath :: Term f -> Int -> [Int] +positionToPath t n = term t n + where + term _ 0 = [] + term t n = list 0 (children t) (n-1) -pattern App f ts <- Fun (fromFun -> f) (fromTermList -> ts) + list _ Empty _ = error "bad position" + list k (Cons t u) n + | n < len t = k:term t n + | otherwise = list (k+1) u (n-len t) -app :: Numbered a => a -> [Term a] -> Term a -app f ts = build (fun (toFun f) ts) +-- Convert a path in a term into a position. +pathToPosition :: Term f -> [Int] -> Int +pathToPosition t ns = term 0 t ns + where + term k _ [] = k + term k t (n:ns) = list (k+1) (children t) n ns + + list _ Empty _ _ = error "bad path" + list k (Cons t _) 0 ns = term k t ns + list k (Cons t u) n ns = + list (k+len t) u (n-1) ns + +pattern F :: f -> Fun f +pattern F x <- (fun_value -> x) + +(<<) :: Ord f => Fun f -> Fun f -> Bool +f << g = fun_value f < fun_value g diff --git a/src/Twee/Term/Core.hs b/src/Twee/Term/Core.hs --- a/src/Twee/Term/Core.hs +++ b/src/Twee/Term/Core.hs @@ -1,11 +1,17 @@ -- Terms and substitutions, implemented using flatterms. -- This module contains all the low-level icky bits -- and provides primitives for building higher-level stuff. -{-# LANGUAGE BangPatterns, CPP, PatternGuards, PatternSynonyms, ViewPatterns, RecordWildCards, GeneralizedNewtypeDeriving, RankNTypes, MagicHash, UnboxedTuples, MultiParamTypeClasses, FlexibleInstances, FunctionalDependencies, ScopedTypeVariables #-} +{-# LANGUAGE CPP, PatternSynonyms, ViewPatterns, + MagicHash, UnboxedTuples, BangPatterns, + RankNTypes, RecordWildCards, GeneralizedNewtypeDeriving #-} module Twee.Term.Core where -#include "errors.h" -import Data.Primitive +import Data.Primitive(sizeOf) +#ifdef BOUNDS_CHECKS +import Data.Primitive.ByteArray.Checked +#else +import Data.Primitive.ByteArray +#endif import Control.Monad.ST.Strict import Data.Bits import Data.Int @@ -13,6 +19,8 @@ import GHC.Prim import GHC.ST hiding (liftST) import Data.Ord +import Twee.Label +import Data.Typeable -------------------------------------------------------------------------------- -- Symbols. A symbol is a single function or variable in a flatterm. @@ -29,8 +37,8 @@ instance Show Symbol where show Symbol{..} - | isFun = show (MkFun index) ++ "=" ++ show size - | otherwise = show (MkVar index) + | isFun = show (F index) ++ "=" ++ show size + | otherwise = show (V index) -- Convert symbols to/from Int64 for storage in flatterms. -- The encoding: @@ -46,7 +54,6 @@ {-# INLINE fromSymbol #-} fromSymbol :: Symbol -> Int64 -fromSymbol Symbol{..} | index < 0 = ERROR("negative symbol index") fromSymbol Symbol{..} = fromIntegral size + fromIntegral index `unsafeShiftL` 32 + @@ -65,10 +72,10 @@ at :: Int -> TermList f -> Term f at n (TermList lo hi arr) - | n < 0 || n + lo >= hi = ERROR("term index out of bounds") + | n < 0 || lo+n >= hi = error "term index out of bounds" | otherwise = case TermList (lo+n) hi arr of - Cons t _ -> t + UnsafeCons t _ -> t {-# INLINE lenList #-} -- The length (number of symbols in) a flatterm. @@ -111,7 +118,7 @@ TermList (low+1) high array, TermList (low+size) high array) where - x = indexByteArray array low + !x = indexByteArray array low Symbol{..} = toSymbol x {-# INLINE patHead #-} @@ -122,26 +129,35 @@ -- Pattern synonyms for single terms. -- * Var :: Var -> Term f --- * Fun :: Fun f -> TermList f -> Term f -newtype Fun f = MkFun Int deriving Eq -newtype Var = MkVar Int deriving (Eq, Ord, Enum) -instance Show (Fun f) where show (MkFun x) = "f" ++ show x -instance Show Var where show (MkVar x) = "x" ++ show x +-- * App :: Fun f -> TermList f -> Term f -pattern Var x <- Term (patRoot -> Left x) _ -pattern Fun f ts <- Term (patRoot -> Right (f :: Fun f)) (patNext -> (ts :: TermList f)) +newtype Fun f = F { fun_id :: Int } +instance Eq (Fun f) where + f == g = fun_id f == fun_id g +instance Ord (Fun f) where + compare = comparing fun_id -{-# INLINE patRoot #-} -patRoot :: Int64 -> Either Var (Fun f) -patRoot root - | isFun = Right (MkFun index) - | otherwise = Left (MkVar index) +fun :: (Ord f, Typeable f) => f -> Fun f +fun f = F (fromIntegral (labelNum (label f))) + +fun_value :: Fun f -> f +fun_value f = find (unsafeMkLabel (fromIntegral (fun_id f))) + +newtype Var = V { var_id :: Int } deriving (Eq, Ord, Enum) +instance Show (Fun f) where show f = "f" ++ show (fun_id f) +instance Show Var where show x = "x" ++ show (var_id x) + +pattern Var x <- (patTerm -> Left x) +pattern App f ts <- (patTerm -> Right (f, ts)) + +{-# INLINE patTerm #-} +patTerm :: Term f -> Either Var (Fun f, TermList f) +patTerm t@Term{..} + | isFun = Right (F index, ts) + | otherwise = Left (V index) where Symbol{..} = toSymbol root - -{-# INLINE patNext #-} -patNext :: TermList f -> TermList f -patNext (TermList lo hi array) = TermList (lo+1) hi array + !(UnsafeConsSym _ ts) = singleton t -- Convert a term to a termlist. {-# INLINE singleton #-} @@ -152,14 +168,30 @@ -- internal representation of the termlists, but we cheat by -- comparing Int64s instead of Symbols. instance Eq (TermList f) where - {-# INLINE (==) #-} - t == u = lenList t == lenList u && eqSameLength t u + -- Manual worker-wrapper to prevent too much from being inlined. + t == u = eqTermList t u -eqSameLength :: TermList f -> TermList f -> Bool -eqSameLength Empty !_ = True -eqSameLength (ConsSym s1 t) (UnsafeConsSym s2 u) = - root s1 == root s2 && eqSameLength t u +{-# INLINE eqTermList #-} +eqTermList :: TermList f -> TermList f -> Bool +eqTermList + (TermList (I# low1) (I# high1) (ByteArray array1)) + (TermList (I# low2) (I# high2) (ByteArray array2)) = + weqTermList low1 high1 array1 low2 high2 array2 +{-# NOINLINE weqTermList #-} +weqTermList :: + Int# -> Int# -> ByteArray# -> + Int# -> Int# -> ByteArray# -> + Bool +weqTermList low1 high1 array1 low2 high2 array2 = + lenList t == lenList u && eqSameLength t u + where + t = TermList (I# low1) (I# high1) (ByteArray array1) + u = TermList (I# low2) (I# high2) (ByteArray array2) + eqSameLength Empty !_ = True + eqSameLength (ConsSym s1 t) (UnsafeConsSym s2 u) = + root s1 == root s2 && eqSameLength t u + instance Ord (TermList f) where {-# INLINE compare #-} compare t u = @@ -184,9 +216,9 @@ unBuilder :: -- Takes: the term array and size, and current position in the term. -- Returns the final position, which may be out of bounds. - forall s. Builder1 s } + forall s. Builder1 s f } -type Builder1 s = State# s -> MutableByteArray# s -> Int# -> Int# -> (# State# s, Int# #) +type Builder1 s f = State# s -> MutableByteArray# s -> Int# -> Int# -> (# State# s, Int# #) instance Monoid (Builder f) where {-# INLINE mempty #-} @@ -200,54 +232,54 @@ let Builder m = builder loop n@(I# n#) = do - MutableByteArray marray# <- - newByteArray (n * sizeOf (fromSymbol __)) + MutableByteArray mbytearray# <- + newByteArray (n * sizeOf (fromSymbol undefined)) n' <- ST $ \s -> - case m s marray# n# 0# of + case m s mbytearray# n# 0# of (# s, n# #) -> (# s, I# n# #) if n' <= n then do - !array <- unsafeFreezeByteArray (MutableByteArray marray#) - return (TermList 0 n' array) + !bytearray <- unsafeFreezeByteArray (MutableByteArray mbytearray#) + return (TermList 0 n' bytearray) else loop (n'*2) - loop 16 + loop 32 -{-# INLINE getArray #-} -getArray :: (MutableByteArray s -> Builder1 s) -> Builder1 s -getArray k = \s array n i -> k (MutableByteArray array) s array n i +{-# INLINE getByteArray #-} +getByteArray :: (MutableByteArray s -> Builder1 s f) -> Builder1 s f +getByteArray k = \s bytearray n i -> k (MutableByteArray bytearray) s bytearray n i {-# INLINE getSize #-} -getSize :: (Int -> Builder1 s) -> Builder1 s -getSize k = \s array n i -> k (I# n) s array n i +getSize :: (Int -> Builder1 s f) -> Builder1 s f +getSize k = \s bytearray n i -> k (I# n) s bytearray n i {-# INLINE getIndex #-} -getIndex :: (Int -> Builder1 s) -> Builder1 s -getIndex k = \s array n i -> k (I# i) s array n i +getIndex :: (Int -> Builder1 s f) -> Builder1 s f +getIndex k = \s bytearray n i -> k (I# i) s bytearray n i {-# INLINE putIndex #-} -putIndex :: Int -> Builder1 s +putIndex :: Int -> Builder1 s f putIndex (I# i) = \s _ _ _ -> (# s, i #) {-# INLINE liftST #-} -liftST :: ST s () -> Builder1 s +liftST :: ST s () -> Builder1 s f liftST (ST m) = \s _ _ i -> case m s of (# s, () #) -> (# s, i #) {-# INLINE built #-} -built :: Builder1 s +built :: Builder1 s f built = \s _ _ i -> (# s, i #) {-# INLINE then_ #-} -then_ :: Builder1 s -> Builder1 s -> Builder1 s +then_ :: Builder1 s f -> Builder1 s f -> Builder1 s f then_ m1 m2 = - \s array n i -> - case m1 s array n i of - (# s, i #) -> m2 s array n i + \s bytearray n i -> + case m1 s bytearray n i of + (# s, i #) -> m2 s bytearray n i {-# INLINE checked #-} -checked :: Int -> Builder1 s -> Builder1 s +checked :: Int -> Builder1 s f -> Builder1 s f checked j m = getSize $ \n -> getIndex $ \i -> @@ -257,31 +289,62 @@ emitSymbolBuilder :: Symbol -> Builder f -> Builder f emitSymbolBuilder x inner = Builder $ checked 1 $ - getArray $ \array -> + getByteArray $ \bytearray -> getIndex $ \n -> putIndex (n+1) `then_` unBuilder inner `then_` getIndex (\m -> - liftST $ writeByteArray array n (fromSymbol x { size = m - n })) + liftST $ writeByteArray bytearray n (fromSymbol x { size = m - n })) --- Emit a function symbol. --- The second argument is called to emit the function's arguments. -{-# INLINE emitFun #-} -emitFun :: Fun f -> Builder f -> Builder f -emitFun (MkFun f) inner = emitSymbolBuilder (Symbol True f 0) inner +-- Emit a function application. +{-# INLINE emitApp #-} +emitApp :: Fun f -> Builder f -> Builder f +emitApp (F n) inner = emitSymbolBuilder (Symbol True n 0) inner -- Emit a variable. {-# INLINE emitVar #-} emitVar :: Var -> Builder f -emitVar (MkVar x) = emitSymbolBuilder (Symbol False x 1) mempty +emitVar x = emitSymbolBuilder (Symbol False (var_id x) 1) mempty -- Emit a whole termlist. {-# INLINE emitTermList #-} emitTermList :: TermList f -> Builder f emitTermList (TermList lo hi array) = Builder $ checked (hi-lo) $ - getArray $ \marray -> + getByteArray $ \mbytearray -> getIndex $ \n -> - let k = sizeOf (fromSymbol __) in - liftST (copyByteArray marray (n*k) array (lo*k) ((hi-lo)*k)) `then_` + let k = sizeOf (fromSymbol undefined) in + liftST (copyByteArray mbytearray (n*k) array (lo*k) ((hi-lo)*k)) `then_` putIndex (n + hi-lo) + +---------------------------------------------------------------------- +-- Efficient subterm testing. +---------------------------------------------------------------------- + +{-# INLINE isSubtermOfList #-} +isSubtermOfList :: Term f -> TermList f -> Bool +isSubtermOfList t u = + isSubArrayOf (singleton t) u + +-- N.B. this one should not be exported from Twee.Term +-- because subarray is not the same as subterm if t is not +-- a singleton +isSubArrayOf :: TermList f -> TermList f -> Bool +isSubArrayOf t u = + lenList t <= lenList u && (here t u || next t u) + where + here Empty _ = True + here (ConsSym s1 t) (UnsafeConsSym s2 u) = + root s1 == root s2 && here t u + + -- This is safe because lenList t <= lenList u + -- so if u = Empty, then t = Empty and here t u = True. + next t (UnsafeConsSym _ u) = isSubArrayOf t u + +{-# INLINE isVarOf #-} +isVarOf :: Var -> TermList f -> Bool +isVarOf (V x) t = isSymbolOf (fromSymbol (Symbol False x 1)) t + +isSymbolOf :: Int64 -> TermList f -> Bool +isSymbolOf !_ Empty = False +isSymbolOf n (ConsSym t ts) = root t == n || isSymbolOf n ts diff --git a/src/Twee/Utils.hs b/src/Twee/Utils.hs --- a/src/Twee/Utils.hs +++ b/src/Twee/Utils.hs @@ -1,6 +1,6 @@ -- | Miscellaneous utility functions. -{-# LANGUAGE CPP #-} +{-# LANGUAGE CPP, MagicHash #-} module Twee.Utils where import Control.Arrow((&&&)) @@ -8,6 +8,10 @@ import Data.List(groupBy, sortBy) import Data.Ord(comparing) import System.IO +import GHC.Prim +import GHC.Types +import Data.Bits +--import Test.QuickCheck hiding ((.&.)) repeatM :: Monad m => m a -> m [a] repeatM = sequence . repeat @@ -87,3 +91,55 @@ | x == y = xs `isSubsequenceOf` ys | otherwise = (x:xs) `isSubsequenceOf` ys #endif + +{-# INLINE fixpoint #-} +fixpoint :: Eq a => (a -> a) -> a -> a +fixpoint f x = fxp x + where + fxp x + | x == y = x + | otherwise = fxp y + where + y = f x + +-- From "Bit twiddling hacks": branchless min and max +{-# INLINE intMin #-} +intMin :: Int -> Int -> Int +intMin x y = + y `xor` ((x `xor` y) .&. negate (x .<. y)) + where + I# x .<. I# y = I# (x <# y) + +{-# INLINE intMax #-} +intMax :: Int -> Int -> Int +intMax x y = + x `xor` ((x `xor` y) .&. negate (x .<. y)) + where + I# x .<. I# y = I# (x <# y) + +-- Split an interval (inclusive bounds) into a particular number of blocks +splitInterval :: Integral a => a -> (a, a) -> [(a, a)] +splitInterval k (lo, hi) = + [ (lo+i*blockSize, (lo+(i+1)*blockSize-1) `min` hi) + | i <- [0..k-1] ] + where + size = (hi-lo+1) + blockSize = (size + k - 1) `div` k -- division rounding up +{- +prop_split_1 (Positive k) (lo, hi) = + -- Check that all elements occur exactly once + concat [[x..y] | (x, y) <- splitInterval k (lo, hi)] === [lo..hi] + +-- Check that we have the correct number and distribution of blocks +prop_split_2 (Positive k) (lo, hi) = + counterexample (show splits) $ conjoin + [counterexample "Reason: too many splits" $ + length splits <= k, + counterexample "Reason: too few splits" $ + length [lo..hi] >= k ==> length splits == k, + counterexample "Reason: uneven distribution" $ + not (null splits) ==> + minimum (map length splits) + 1 >= maximum (map length splits)] + where + splits = splitInterval k (lo, hi) +-} diff --git a/src/errors.h b/src/errors.h deleted file mode 100644 --- a/src/errors.h +++ /dev/null @@ -1,3 +0,0 @@ --- Inspired by Agda's undefined.h -#define __ ERROR("internal error") -#define ERROR(msg) (error (__FILE__ ++ ", line " ++ show (__LINE__ :: Int) ++ ": " ++ msg)) diff --git a/tests/BOO067-1.p b/tests/BOO067-1.p new file mode 100644 --- /dev/null +++ b/tests/BOO067-1.p @@ -0,0 +1,32 @@ +%-------------------------------------------------------------------------- +% File : BOO067-1 : TPTP v6.3.0. Released v2.6.0. +% Domain : Boolean Algebra (Ternary) +% Problem : Ternary Boolean Algebra Single axiom is complete, part 1 +% Version : [MP96] (equality) axioms. +% English : + +% Refs : [McC98] McCune (1998), Email to G. Sutcliffe +% : [MP96] McCune & Padmanabhan (1996), Automated Deduction in Eq +% Source : [TPTP] +% Names : + +% Status : Unsatisfiable +% Rating : 0.42 v6.3.0, 0.35 v6.2.0, 0.29 v6.1.0, 0.31 v6.0.0, 0.48 v5.5.0, 0.47 v5.4.0, 0.33 v5.3.0, 0.25 v5.2.0, 0.29 v5.1.0, 0.33 v5.0.0, 0.29 v4.1.0, 0.18 v4.0.1, 0.36 v4.0.0, 0.38 v3.7.0, 0.11 v3.4.0, 0.12 v3.3.0, 0.21 v3.1.0, 0.33 v2.7.0, 0.27 v2.6.0 +% Syntax : Number of clauses : 2 ( 0 non-Horn; 2 unit; 1 RR) +% Number of atoms : 2 ( 2 equality) +% Maximal clause size : 1 ( 1 average) +% Number of predicates : 1 ( 0 propositional; 2-2 arity) +% Number of functors : 7 ( 5 constant; 0-3 arity) +% Number of variables : 7 ( 0 singleton) +% Maximal term depth : 5 ( 3 average) +% SPC : CNF_UNS_RFO_PEQ_UEQ + +% Comments : A UEQ part of BOO035-1 +%-------------------------------------------------------------------------- +cnf(single_axiom,axiom, + ( multiply(multiply(A,inverse(A),B),inverse(multiply(multiply(C,D,E),F,multiply(C,D,G))),multiply(D,multiply(G,F,E),C)) = B )). + +cnf(prove_tba_axioms_1,negated_conjecture, + ( multiply(multiply(d,e,a),b,multiply(d,e,c)) != multiply(d,e,multiply(a,b,c)) )). + +%-------------------------------------------------------------------------- diff --git a/tests/LAT072-1.p b/tests/LAT072-1.p new file mode 100644 --- /dev/null +++ b/tests/LAT072-1.p @@ -0,0 +1,37 @@ +%-------------------------------------------------------------------------- +% File : LAT072-1 : TPTP v6.3.0. Released v2.6.0. +% Domain : Lattice Theory (Ortholattices) +% Problem : Given single axiom OML-23A, prove associativity +% Version : [MRV03] (equality) axioms. +% English : Given a single axiom candidate OML-23A for orthomodular lattices +% (OML) in terms of the Sheffer Stroke, prove a Sheffer stroke form +% of associativity. + +% Refs : [MRV03] McCune et al. (2003), Sheffer Stroke Bases for Ortholatt +% Source : [MRV03] +% Names : OML-23A-associativity [MRV03] + +% Status : Unsatisfiable +% Rating : 0.95 v6.3.0, 0.94 v6.2.0, 0.93 v6.1.0, 0.94 v6.0.0, 0.95 v5.4.0, 1.00 v2.6.0 +% Syntax : Number of clauses : 2 ( 0 non-Horn; 2 unit; 1 RR) +% Number of atoms : 2 ( 2 equality) +% Maximal clause size : 1 ( 1 average) +% Number of predicates : 1 ( 0 propositional; 2-2 arity) +% Number of functors : 4 ( 3 constant; 0-2 arity) +% Number of variables : 4 ( 2 singleton) +% Maximal term depth : 7 ( 4 average) +% SPC : CNF_UNS_RFO_PEQ_UEQ + +% Comments : +%-------------------------------------------------------------------------- +%----Single axiom OML-23A +cnf(oml_23A,axiom, + ( f(f(f(f(B,A),f(A,C)),D),f(A,f(f(C,f(f(A,A),C)),C))) = A )). + +cnf(a, axiom, f(X,Y) = f(Y, X)). + +%----Denial of Sheffer stroke associativity +cnf(associativity,negated_conjecture, + ( f(a,f(f(b,c),f(b,c))) != f(c,f(f(b,a),f(b,a))) )). + +%-------------------------------------------------------------------------- diff --git a/tests/ROB007-1.p b/tests/ROB007-1.p deleted file mode 100644 --- a/tests/ROB007-1.p +++ /dev/null @@ -1,41 +0,0 @@ -% Goes into a loop! - -%-------------------------------------------------------------------------- -% File : ROB007-1 : TPTP v6.2.0. Released v1.0.0. -% Domain : Robbins Algebra -% Problem : Absorbed within negation element => Boolean -% Version : [Win90] (equality) axioms. -% English : If there exist a, b such that -(a+b) = -b, then the algebra -% is Boolean. - -% Refs : [HMT71] Henkin et al. (1971), Cylindrical Algebras -% : [Win90] Winker (1990), Robbins Algebra: Conditions that make a -% : [LW92] Lusk & Wos (1992), Benchmark Problems in Which Equalit -% Source : [Win90] -% Names : Theorem 1.2 [Win90] -% : RA5 [LW92] - -% Status : Unknown -% Rating : 1.00 v2.0.0 -% Syntax : Number of clauses : 5 ( 0 non-Horn; 5 unit; 2 RR) -% Number of atoms : 5 ( 5 equality) -% Maximal clause size : 1 ( 1 average) -% Number of predicates : 1 ( 0 propositional; 2-2 arity) -% Number of functors : 4 ( 2 constant; 0-2 arity) -% Number of variables : 7 ( 0 singleton) -% Maximal term depth : 6 ( 3 average) -% SPC : CNF_UNK_UEQ - -% Comments : Commutativity, associativity, and Huntington's axiom -% axiomatize Boolean algebra. -%-------------------------------------------------------------------------- -%----Include axioms for Robbins algebra -include('Axioms/ROB001-0.ax'). -%-------------------------------------------------------------------------- -cnf(condition,hypothesis, - ( negate(add(a,b)) = negate(b) )). - -cnf(prove_huntingtons_axiom,negated_conjecture, - ( add(negate(add(a,negate(b))),negate(add(negate(a),negate(b)))) != b )). - -%-------------------------------------------------------------------------- diff --git a/tests/ROB010-1.p b/tests/ROB010-1.p new file mode 100644 --- /dev/null +++ b/tests/ROB010-1.p @@ -0,0 +1,11 @@ +cnf(condition,hypothesis, + ( negate(add(a,negate(b))) = c )). + +cnf(prove_result,negated_conjecture, + ( negate(add(c,negate(add(b,a)))) != a )). + +cnf(commutativity_of_add,axiom, + ( add(X,Y) = add(Y,X) )). + +cnf(robbins_axiom,axiom, + ( negate(add(negate(add(X,Y)),negate(add(X,negate(Y))))) = X )). diff --git a/tests/abelian.p b/tests/abelian.p deleted file mode 100644 --- a/tests/abelian.p +++ /dev/null @@ -1,4 +0,0 @@ -cnf(a, axiom, '+'(X, Y) = '+'(Y, X)). -cnf(a, axiom, '+'(X, '+'(Y, Z)) = '+'('+'(X, Y), Z)). -cnf(a, axiom, '+'('0', X) = X). -cnf(a, axiom, '+'(X, '-'(X)) = '0'). diff --git a/tests/and-or.p b/tests/and-or.p deleted file mode 100644 --- a/tests/and-or.p +++ /dev/null @@ -1,12 +0,0 @@ -cnf(a, axiom, '+'(X, Y) = '+'(Y, X)). -cnf(a, axiom, '+'(X, '+'(Y, Z)) = '+'('+'(X, Y), Z)). -cnf(a, axiom, '*'(X, Y) = '*'(Y, X)). -cnf(a, axiom, '*'(X, '*'(Y, Z)) = '*'('*'(X, Y), Z)). -cnf(a, axiom, '+'(X, '0') = X). -cnf(a, axiom, '*'(X, '0') = '0'). -cnf(a, axiom, '*'(X, '+'(Y, Z)) = '+'('*'(X, Y), '*'(X, Z))). -cnf(a, axiom, '+'(X, '*'(Y, Z)) = '*'('+'(X, Y), '+'(X, Z))). -cnf(a, axiom, not(not(X)) = X). -cnf(a, axiom, not('+'(X, Y)) = '*'(not(X), not(Y))). -cnf(a, axiom, '+'(X, not(X)) = '1'). -cnf(a, axiom, '*'(X, not(X)) = '0'). diff --git a/tests/append-rev.p b/tests/append-rev.p --- a/tests/append-rev.p +++ b/tests/append-rev.p @@ -1,4 +1,4 @@ -cnf(a, axiom, rev(rev(X)) = X). -cnf(a, axiom, '++'(X,'++'(Y,Z)) = '++'('++'(X,Y),Z)). -cnf(a, axiom, '++'(rev(X),rev(Y)) = rev('++'(Y,X))). -cnf(a, axiom, '++'(a,rev(b)) != rev('++'(b, rev(a)))). +cnf(rev_rev, axiom, rev(rev(X)) = X). +cnf(app_assoc, axiom, '++'(X,'++'(Y,Z)) = '++'('++'(X,Y),Z)). +cnf(rev_app, axiom, '++'(rev(X),rev(Y)) = rev('++'(Y,X))). +cnf(conjecture, negated_conjecture, '++'(a,rev(b)) != rev('++'(b, rev(a)))). diff --git a/tests/db.p b/tests/db.p new file mode 100644 --- /dev/null +++ b/tests/db.p @@ -0,0 +1,17 @@ +% http://www.dcs.bbk.ac.uk/~szabolcs/rellat-jlamp-second-submission-2.pdf +% appendix b. theorem 3.4, clause 8. +cnf(a, axiom, '^'(X, Y) = '^'(Y, X)). +cnf(a, axiom, '^'(X, '^'(Y, Z)) = '^'(Y, '^'(X, Z))). +cnf(a, axiom, '^'('^'(X, Y), Z) = '^'(X, '^'(Y, Z))). +cnf(a, axiom, v(X, Y) = v(Y, X)). +cnf(a, axiom, v(X, v(Y, Z)) = v(Y, v(X, Z))). +cnf(a, axiom, v(v(X, Y), Z) = v(X, v(Y, Z))). +cnf(a, axiom, v(X, '^'(X, Y)) = X). +cnf(a, axiom, '^'(X, v(X, Y)) = X). +cnf(a, axiom, upme(X,Y,Z) = '^'(X, v(Y, Z))). +cnf(a, axiom, lome(X,Y,Z) = v('^'(X, Y), '^'(X, Z))). +cnf(a, axiom, upjo(X,Y,Z) = '^'(v(X, Y), v(X, Z))). +cnf(a, axiom, lojo(X,Y,Z) = v(X, '^'(Y, Z))). +cnf(a, axiom, v(upme('^'(a, X1),Y1,Z1), '^'(Y1, Z1)) = '^'(v('^'('^'(a, X1), Y1), Z1), v('^'('^'(a, X1), Z1), Y1))). +cnf(a, axiom, upme(X,Y,Z) = v(upme(X,Y,'^'(a, Z)), upme(X,Z,'^'(a, Y)))). +fof(a, conjecture, (upme(a,x2,y2) = upme(a,x2,z2) => upme(x2,y2,z2) = lome(x2,y2,z2))). diff --git a/tests/diff.p b/tests/diff.p --- a/tests/diff.p +++ b/tests/diff.p @@ -1,4 +1,4 @@ -cnf(a, axiom, diff(X, diff(Y, X)) = X). -cnf(a, axiom, diff(X, diff(X, Y)) = diff(Y, diff(Y, X))). -cnf(a, axiom, diff(diff(X, Y), Z) = diff(diff(X, Z), diff(Y, Z))). -cnf(a, axiom, diff(diff(a, c), b) != diff(diff(a, b), c)). +cnf('x\\(y\\x)=x', axiom, '\\'(X, '\\'(Y, X)) = X). +cnf('x\\(x\\y)=y\\(y\\x)', axiom, '\\'(X, '\\'(X, Y)) = '\\'(Y, '\\'(Y, X))). +cnf('(x\\y)\\z=(x\\z)\\(y\\z)', axiom, '\\'('\\'(X, Y), Z) = '\\'('\\'(X, Z), '\\'(Y, Z))). +cnf(conjecture, negated_conjecture, '\\'('\\'(a, c), b) != '\\'('\\'(a, b), c)). diff --git a/tests/groupoid.p b/tests/groupoid.p deleted file mode 100644 --- a/tests/groupoid.p +++ /dev/null @@ -1,3 +0,0 @@ -% Entropic groupoid, taken from unfailing completion paper -cnf(a, axiom, '*'('*'(X,Y),'*'(Z,W)) = '*'('*'(X,Z),'*'(Y,W))). -cnf(a, axiom, '*'('*'(X,Y),X) = X). diff --git a/tests/lat.p b/tests/lat.p --- a/tests/lat.p +++ b/tests/lat.p @@ -11,6 +11,6 @@ cnf(equation_H34, axiom, meet(X, join(Y, meet(Z, U)))=meet(X, join(Y, meet(Z, join(Y, meet(U, join(Y, Z))))))). -cnf(prove_H28, axiom, +cnf(prove_H28, negated_conjecture, meet(a, join(b, meet(a, meet(c, d))))!=meet(a, join(b, meet(c, meet(d, join(a, meet(b, d))))))). diff --git a/tests/lcl.p b/tests/lcl.p --- a/tests/lcl.p +++ b/tests/lcl.p @@ -4,4 +4,4 @@ cnf(wajsberg_4, axiom, implies(implies(not(X), not(Y)), implies(Y, X))=truth). cnf(lemma_antecedent, axiom, implies(X, Y)=implies(Y, X)). -cnf(prove_wajsberg_lemma, axiom, x!=y). +cnf(prove_wajsberg_lemma, negated_conjecture, x!=y). diff --git a/tests/length.p b/tests/length.p deleted file mode 100644 --- a/tests/length.p +++ /dev/null @@ -1,2 +0,0 @@ -cnf(a, axiom, '++'(Xs, '++'(Ys, Zs)) = '++'('++'(Xs, Ys), Zs)). -cnf(a, axiom, length('++'(Xs, Ys)) = length('++'(Ys, Xs))). diff --git a/tests/length2.p b/tests/length2.p deleted file mode 100644 --- a/tests/length2.p +++ /dev/null @@ -1,3 +0,0 @@ -cnf(a, axiom, '++'(Xs, '++'(Ys, Zs)) = '++'('++'(Xs, Ys), Zs)). -cnf(a, axiom, length('++'(Xs, Ys)) = length('++'(Ys, Xs))). -cnf(a, axiom, length('++'('++'(c,a),b)) != length('++'(a,'++'(b,c)))). diff --git a/tests/length3.p b/tests/length3.p deleted file mode 100644 --- a/tests/length3.p +++ /dev/null @@ -1,2 +0,0 @@ -cnf(a, axiom, length('++'(Xs, '++'(Ys, '++'(Zs, Ws)))) = length('++'(Ws, '++'(Xs, '++'(Ys, Zs))))). -cnf(a, axiom, length('++'(Xs, '++'(Xs, '++'(Ys, Zs)))) = length('++'(Xs, '++'(Ys, '++'(Zs, Xs))))). diff --git a/tests/loop.p b/tests/loop.p --- a/tests/loop.p +++ b/tests/loop.p @@ -1,6 +1,6 @@ -cnf(a, axiom, '*'(X, '^'(X, Y)) = Y). -cnf(a, axiom, '^'(X, '*'(X, Y)) = Y). -cnf(a, axiom, '*'('/'(X, Y), Y) = X). -cnf(a, axiom, '/'('*'(X, Y), Y) = X). -cnf(a, axiom, '*'(X, '*'(Y, '*'(X, Z))) = '*'('*'('*'(X, Y), X), Z)). -cnf(a, axiom, '^'(a,a) != '/'(a,a)). +cnf(mult_ld, axiom, '*'(X, '^'(X, Y)) = Y). +cnf(ld_mult, axiom, '^'(X, '*'(X, Y)) = Y). +cnf(mult_rd, axiom, '*'('/'(X, Y), Y) = X). +cnf(rd_mult, axiom, '/'('*'(X, Y), Y) = X). +cnf(moufang, axiom, '*'(X, '*'(Y, '*'(X, Z))) = '*'('*'('*'(X, Y), X), Z)). +cnf(conjecture, negated_conjecture, '^'(a,a) != '/'(a,a)). diff --git a/tests/loop2.p b/tests/loop2.p --- a/tests/loop2.p +++ b/tests/loop2.p @@ -1,6 +1,6 @@ -cnf(a, axiom, mult(X, ld(X, Y)) = Y). -cnf(a, axiom, ld(X, mult(X, Y)) = Y). -cnf(a, axiom, mult(rd(X, Y), Y) = X). -cnf(a, axiom, rd(mult(X, Y), Y) = X). -cnf(a, axiom, mult(X, mult(Y, mult(X, Z))) = mult(mult(mult(X, Y), X), Z)). -cnf(a, axiom, mult(a,rd(b,b)) != a). +cnf('*-\\', axiom, '*'(X, '\\'(X, Y)) = Y). +cnf('\\-*', axiom, '\\'(X, '*'(X, Y)) = Y). +cnf('*-/', axiom, '*'('/'(X, Y), Y) = X). +cnf('/-*', axiom, '/'('*'(X, Y), Y) = X). +cnf(moufang, axiom, '*'(X, '*'(Y, '*'(X, Z))) = '*'('*'('*'(X, Y), X), Z)). +cnf(conjecture, negated_conjecture, '*'(a,'/'(b,b)) != a). diff --git a/tests/lukasiewicz.p b/tests/lukasiewicz.p --- a/tests/lukasiewicz.p +++ b/tests/lukasiewicz.p @@ -1,6 +1,6 @@ -cnf(a, axiom, implies(true, X) = X). -cnf(a, axiom, implies(implies(X, Y), implies(implies(Y, Z), implies(X, Z))) = true). -cnf(a, axiom, implies(implies(not(X), not(Y)), implies(Y, X)) = true). -cnf(a, axiom, implies(implies(X, Y), Y) = implies(implies(Y, X), X)). -cnf(a, axiom, or(X, Y) = implies(not(X), Y)). -cnf(a, axiom, or(a,or(b,c)) != or(or(a,b),c)). +cnf(imp_true, axiom, implies(true, X) = X). +cnf(imp_compose, axiom, implies(implies(X, Y), implies(implies(Y, Z), implies(X, Z))) = true). +cnf(imp_not, axiom, implies(implies(not(X), not(Y)), implies(Y, X)) = true). +cnf(imp_switch, axiom, implies(implies(X, Y), Y) = implies(implies(Y, X), X)). +cnf(or_def, axiom, or(X, Y) = implies(not(X), Y)). +cnf(conjecture, negated_conjecture, or(a,or(b,c)) != or(or(a,b),c)). diff --git a/tests/martin-nipkow-2.p b/tests/martin-nipkow-2.p deleted file mode 100644 --- a/tests/martin-nipkow-2.p +++ /dev/null @@ -1,1 +0,0 @@ -cnf(a, axiom, '*'('*'(X,X),Y) = '*'(Y,'*'(X,X))). diff --git a/tests/martin-nipkow.p b/tests/martin-nipkow.p deleted file mode 100644 --- a/tests/martin-nipkow.p +++ /dev/null @@ -1,1 +0,0 @@ -cnf(a, axiom, '*'('*'(X,Y),Z) = '*'(Z,'*'(X,Y))). diff --git a/tests/nicomachus.p b/tests/nicomachus.p --- a/tests/nicomachus.p +++ b/tests/nicomachus.p @@ -1,18 +1,18 @@ -cnf(a, axiom, plus(X, Y) = plus(Y, X)). -cnf(a, axiom, plus(X, plus(Y, Z)) = plus(plus(X, Y), Z)). -cnf(a, axiom, times(X, Y) = times(Y, X)). -cnf(a, axiom, times(X, times(Y, Z)) = times(times(X, Y), Z)). -cnf(a, axiom, plus(X, zero) = X). -cnf(a, axiom, times(X, zero) = zero). -cnf(a, axiom, times(X, one) = X). -cnf(a, axiom, times(X, plus(Y, Z)) = plus(times(X, Y), times(X, Z))). -cnf(a, axiom, times(plus(X, Y), Z) = plus(times(X, Z), times(Y, Z))). -cnf(a, axiom, plus(s(X), Y) = s(plus(X, Y))). -cnf(a, axiom, times(s(X), Y) = plus(Y, times(X, Y))). -cnf(a, axiom, sum(zero) = zero). -cnf(a, axiom, sum(s(N)) = plus(s(N), sum(N))). -cnf(a, axiom, cubes(zero) = zero). -cnf(a, axiom, cubes(s(N)) = plus(times(s(N), times(s(N), s(N))), cubes(N))). -cnf(a, axiom, plus(sum(N), sum(N)) = times(N, s(N))). -cnf(a, axiom, times(sum(a), sum(a)) = cubes(a)). -cnf(a, axiom, times(sum(s(a)), sum(s(a))) != cubes(s(a))). +cnf(plus_comm, axiom, plus(X, Y) = plus(Y, X)). +cnf(plus_assoc, axiom, plus(X, plus(Y, Z)) = plus(plus(X, Y), Z)). +cnf(times_comm, axiom, times(X, Y) = times(Y, X)). +cnf(times_assoc, axiom, times(X, times(Y, Z)) = times(times(X, Y), Z)). +cnf(plus_zero, axiom, plus(X, zero) = X). +cnf(times_zero, axiom, times(X, zero) = zero). +cnf(times_one, axiom, times(X, one) = X). +cnf(distr, axiom, times(X, plus(Y, Z)) = plus(times(X, Y), times(X, Z))). +cnf(distr, axiom, times(plus(X, Y), Z) = plus(times(X, Z), times(Y, Z))). +cnf(plus_s, axiom, plus(s(X), Y) = s(plus(X, Y))). +cnf(times_s, axiom, times(s(X), Y) = plus(Y, times(X, Y))). +cnf(sum_zero, axiom, sum(zero) = zero). +cnf(sum_s, axiom, sum(s(N)) = plus(s(N), sum(N))). +cnf(cubes_zero, axiom, cubes(zero) = zero). +cnf(cubes_s, axiom, cubes(s(N)) = plus(times(s(N), times(s(N), s(N))), cubes(N))). +cnf(plus_sum, axiom, plus(sum(N), sum(N)) = times(N, s(N))). +cnf(ih, axiom, times(sum(a), sum(a)) = cubes(a)). +cnf(conjecture, negated_conjecture, times(sum(s(a)), sum(s(a))) != cubes(s(a))). diff --git a/tests/plus-combinator.p b/tests/plus-combinator.p deleted file mode 100644 --- a/tests/plus-combinator.p +++ /dev/null @@ -1,2 +0,0 @@ -cnf(a, axiom, app(app('+', X), Y) = app(app('+', Y), X)). -cnf(a, axiom, app(app('+', X), app(app('+', Y), Z)) = app(app('+', app(app('+', X), Y)), Z)). diff --git a/tests/plus-times.p b/tests/plus-times.p deleted file mode 100644 --- a/tests/plus-times.p +++ /dev/null @@ -1,8 +0,0 @@ -cnf(a, axiom, '+'(X, Y) = '+'(Y, X)). -cnf(a, axiom, '+'(X, '+'(Y, Z)) = '+'('+'(X, Y), Z)). -cnf(a, axiom, '*'(X, Y) = '*'(Y, X)). -cnf(a, axiom, '*'(X, '*'(Y, Z)) = '*'('*'(X, Y), Z)). -cnf(a, axiom, '+'(X, '0') = X). -cnf(a, axiom, '*'(X, '0') = '0'). -cnf(a, axiom, '*'(X, '1') = X). -cnf(a, axiom, '*'(X, '+'(Y, Z)) = '+'('*'(X, Y), '*'(X, Z))). diff --git a/tests/plus.p b/tests/plus.p deleted file mode 100644 --- a/tests/plus.p +++ /dev/null @@ -1,4 +0,0 @@ -cnf(a, axiom, '+'(X, Y) = '+'(Y, X)). -cnf(a, axiom, '+'(X, '+'(Y, Z)) = '+'('+'(X, Y), Z)). -cnf(a, axiom, '+'(X, '0') = X). -cnf(a, axiom, '+'(X, X) = X). diff --git a/tests/pretty.p b/tests/pretty.p deleted file mode 100644 --- a/tests/pretty.p +++ /dev/null @@ -1,19 +0,0 @@ -cnf(a, axiom, length('[]') = '0'). -cnf(a, axiom, '+'(X, '0') = X). -cnf(a, axiom, '+'(X, Y) = '+'(Y, X)). -cnf(a, axiom, '+'(X, '+'(Y, Z)) = '+'('+'(X, Y), Z)). -cnf(a, axiom, '++'(Xs, '[]') = Xs). -cnf(a, axiom, '++'('[]', Xs) = Xs). -cnf(a, axiom, '++'(Xs, '++'(Ys, Zs)) = '++'('++'(Xs, Ys), Zs)). -cnf(a, axiom, length('++'(Xs, Ys)) = '+'(length(Xs), length(Ys))). -cnf(a, axiom, nest('0', X) = X). -cnf(a, axiom, '<>'(X, text('[]')) = X). -cnf(a, axiom, nest('+'(I, J), X) = nest(I, nest(J, X))). -cnf(a, axiom, '$$'(X, '$$'(Y, Z)) = '$$'('$$'(X, Y), Z)). -cnf(a, axiom, '<>'(X, nest(I, Y)) = '<>'(X, Y)). -cnf(a, axiom, '<>'(nest(I, X), Y) = nest(I, '<>'(X, Y))). -cnf(a, axiom, '<>'('$$'(X, Y), Z) = '$$'(X, '<>'(Y, Z))). -cnf(a, axiom, '<>'('<>'(X, Y), Z) = '<>'(X, '<>'(Y, Z))). -cnf(a, axiom, '<>'(text(X), text(Y)) = text('++'(X, Y))). -cnf(a, axiom, '$$'(nest(I, X), nest(I, Y)) = nest(I, '$$'(X, Y))). -cnf(a, axiom, '<>'(text(Xs), '$$'('<>'(text('[]'), X), Y)) = '$$'('<>'(text(Xs), X), nest(length(Xs), Y))). diff --git a/tests/ring.p b/tests/ring.p --- a/tests/ring.p +++ b/tests/ring.p @@ -1,10 +1,9 @@ -cnf(a, axiom, '+'(X, Y) = '+'(Y, X)). -cnf(a, axiom, '+'(X, '+'(Y, Z)) = '+'('+'(X, Y), Z)). -cnf(a, axiom, '+'('0', X) = X). -cnf(a, axiom, '+'(X, '-'(X)) = '0'). -%'*'(X, '1') = X -cnf(a, axiom, '*'(X, '*'(Y, Z)) = '*'('*'(X, Y), Z)). -cnf(a, axiom, '*'(X, '+'(Y, Z)) = '+'('*'(X, Y), '*'(X, Z))). -cnf(a, axiom, '*'('+'(X, Y), Z) = '+'('*'(X, Z), '*'(Y, Z))). -cnf(a, axiom, X = '*'(X, '*'(X, X))). -cnf(a, axiom, '*'(a, b) != '*'(b, a)). +cnf(plus_comm, axiom, '+'(X, Y) = '+'(Y, X)). +cnf(plus_assoc, axiom, '+'(X, '+'(Y, Z)) = '+'('+'(X, Y), Z)). +cnf(plus_zero, axiom, '+'('0', X) = X). +cnf(plus_inv, axiom, '+'(X, '-'(X)) = '0'). +cnf(times_assoc, axiom, '*'(X, '*'(Y, Z)) = '*'('*'(X, Y), Z)). +cnf(distrib, axiom, '*'(X, '+'(Y, Z)) = '+'('*'(X, Y), '*'(X, Z))). +cnf(distrib, axiom, '*'('+'(X, Y), Z) = '+'('*'(X, Z), '*'(Y, Z))). +cnf(cube, axiom, X = '*'(X, '*'(X, X))). +cnf(conjecture, negated_conjecture, '*'(a, b) != '*'(b, a)). diff --git a/tests/ring2.p b/tests/ring2.p --- a/tests/ring2.p +++ b/tests/ring2.p @@ -1,9 +1,9 @@ -cnf(a, axiom, '+'(X, Y) = '+'(Y, X)). -cnf(a, axiom, '+'(X, '+'(Y, Z)) = '+'('+'(X, Y), Z)). -cnf(a, axiom, '+'('0', X) = X). -cnf(a, axiom, '+'(X, '-'(X)) = '0'). -cnf(a, axiom, '*'(X, '*'(Y, Z)) = '*'('*'(X, Y), Z)). -cnf(a, axiom, '*'(X, '+'(Y, Z)) = '+'('*'(X, Y), '*'(X, Z))). -cnf(a, axiom, '*'('+'(X, Y), Z) = '+'('*'(X, Z), '*'(Y, Z))). -cnf(a, axiom, X = '*'(X, '*'(X, '*'(X, '*'(X, '*'(X, X)))))). -cnf(a, axiom, '*'(a, b) != '*'(b, a)). +cnf(plus_comm, axiom, '+'(X, Y) = '+'(Y, X)). +cnf(plus_assoc, axiom, '+'(X, '+'(Y, Z)) = '+'('+'(X, Y), Z)). +cnf(plus_zero, axiom, '+'('0', X) = X). +cnf(plus_inv, axiom, '+'(X, '-'(X)) = '0'). +cnf(times_assoc, axiom, '*'(X, '*'(Y, Z)) = '*'('*'(X, Y), Z)). +cnf(distrib, axiom, '*'(X, '+'(Y, Z)) = '+'('*'(X, Y), '*'(X, Z))). +cnf(distrib, axiom, '*'('+'(X, Y), Z) = '+'('*'(X, Z), '*'(Y, Z))). +cnf(power_six, axiom, X = '*'(X, '*'(X, '*'(X, '*'(X, '*'(X, X)))))). +cnf(conjecture, negated_conjecture, '*'(a, b) != '*'(b, a)). diff --git a/tests/ring3.p b/tests/ring3.p --- a/tests/ring3.p +++ b/tests/ring3.p @@ -1,10 +1,9 @@ -cnf(a, axiom, '+'(X, Y) = '+'(Y, X)). -cnf(a, axiom, '+'(X, '+'(Y, Z)) = '+'('+'(X, Y), Z)). -cnf(a, axiom, '+'('0', X) = X). -cnf(a, axiom, '+'(X, '-'(X)) = '0'). -%'*'(X, '1') = X -cnf(a, axiom, '*'(X, '*'(Y, Z)) = '*'('*'(X, Y), Z)). -cnf(a, axiom, '*'(X, '+'(Y, Z)) = '+'('*'(X, Y), '*'(X, Z))). -cnf(a, axiom, '*'('+'(X, Y), Z) = '+'('*'(X, Z), '*'(Y, Z))). -cnf(a, axiom, X = '*'(X, '*'(X, '*'(X, X)))). -cnf(a, axiom, '*'(a, b) != '*'(b, a)). +cnf(plus_comm, axiom, '+'(X, Y) = '+'(Y, X)). +cnf(plus_assoc, axiom, '+'(X, '+'(Y, Z)) = '+'('+'(X, Y), Z)). +cnf(plus_zero, axiom, '+'('0', X) = X). +cnf(plus_neg, axiom, '+'(X, '-'(X)) = '0'). +cnf(times_assoc, axiom, '*'(X, '*'(Y, Z)) = '*'('*'(X, Y), Z)). +cnf(distrib, axiom, '*'(X, '+'(Y, Z)) = '+'('*'(X, Y), '*'(X, Z))). +cnf(distrib, axiom, '*'('+'(X, Y), Z) = '+'('*'(X, Z), '*'(Y, Z))). +cnf(power_four, axiom, X = '*'(X, '*'(X, '*'(X, X)))). +cnf(conjecture, negated_conjecture, '*'(a, b) != '*'(b, a)). diff --git a/tests/ring4.p b/tests/ring4.p --- a/tests/ring4.p +++ b/tests/ring4.p @@ -1,10 +1,9 @@ -cnf(a, axiom, '+'(X, Y) = '+'(Y, X)). -cnf(a, axiom, '+'(X, '+'(Y, Z)) = '+'('+'(X, Y), Z)). -cnf(a, axiom, '+'('0', X) = X). -cnf(a, axiom, '+'(X, '-'(X)) = '0'). -%'*'(X, '1') = X -cnf(a, axiom, '*'(X, '*'(Y, Z)) = '*'('*'(X, Y), Z)). -cnf(a, axiom, '*'(X, '+'(Y, Z)) = '+'('*'(X, Y), '*'(X, Z))). -cnf(a, axiom, '*'('+'(X, Y), Z) = '+'('*'(X, Z), '*'(Y, Z))). -cnf(a, axiom, X = '*'(X, '*'(X, '*'(X, '*'(X, X))))). -cnf(a, axiom, '*'(a, b) != '*'(b, a)). +cnf(plus_comm, axiom, '+'(X, Y) = '+'(Y, X)). +cnf(plus_assoc, axiom, '+'(X, '+'(Y, Z)) = '+'('+'(X, Y), Z)). +cnf(plus_zero, axiom, '+'('0', X) = X). +cnf(plus_inv, axiom, '+'(X, '-'(X)) = '0'). +cnf(times_ssoc, axiom, '*'(X, '*'(Y, Z)) = '*'('*'(X, Y), Z)). +cnf(distrib, axiom, '*'(X, '+'(Y, Z)) = '+'('*'(X, Y), '*'(X, Z))). +cnf(distrib, axiom, '*'('+'(X, Y), Z) = '+'('*'(X, Z), '*'(Y, Z))). +cnf(power_five, axiom, X = '*'(X, '*'(X, '*'(X, '*'(X, X))))). +cnf(conjecture, negated_conjecture, '*'(a, b) != '*'(b, a)). diff --git a/tests/robbins-easy.p b/tests/robbins-easy.p --- a/tests/robbins-easy.p +++ b/tests/robbins-easy.p @@ -1,4 +1,4 @@ -cnf(a, axiom, '+'(X, Y) = '+'(Y, X)). -cnf(a, axiom, '+'(X, '+'(Y, Z)) = '+'('+'(X, Y), Z)). -cnf(a, axiom, '+'('-'('+'('-'(X), Y)), '-'('+'('-'(X), '-'(Y)))) = X). -cnf(a, axiom, '-'('+'('-'('+'(a, b)), '-'('+'(a, '-'(b))))) != a). +cnf(comm, axiom, '+'(X, Y) = '+'(Y, X)). +cnf(assoc, axiom, '+'(X, '+'(Y, Z)) = '+'('+'(X, Y), Z)). +cnf(funny, axiom, '+'('-'('+'('-'(X), Y)), '-'('+'('-'(X), '-'(Y)))) = X). +cnf(conjecture, negated_conjecture, '-'('+'('-'('+'(a, b)), '-'('+'(a, '-'(b))))) != a). diff --git a/tests/robbins-hard.p b/tests/robbins-hard.p deleted file mode 100644 --- a/tests/robbins-hard.p +++ /dev/null @@ -1,5 +0,0 @@ -cnf(a, axiom, '-+'(X, Y) = '-'('+'(X, Y))). -cnf(a, axiom, '+'(X, Y) = '+'(Y, X)). -cnf(a, axiom, '+'(X, '+'(Y, Z)) = '+'('+'(X, Y), Z)). -cnf(a, axiom, '-'('+'('-'('+'(X, Y)), '-'('+'(X, '-'(Y))))) = X). -cnf(a, axiom, '+'('-'('+'('-'(a), b)), '-'('+'('-'(a), '-'(b)))) != a). diff --git a/tests/robbins-quite-hard.p b/tests/robbins-quite-hard.p deleted file mode 100644 --- a/tests/robbins-quite-hard.p +++ /dev/null @@ -1,4 +0,0 @@ -cnf(a, axiom, '+'(X, Y) = '+'(Y, X)). -cnf(a, axiom, '+'(X, '+'(Y, Z)) = '+'('+'(X, Y), Z)). -cnf(a, axiom, '-'('+'('-'('+'(X, Y)), '-'('+'(X, '-'(Y))))) = X). -cnf(a, axiom, '+'(X, X) != X). diff --git a/tests/robbins.p b/tests/robbins.p new file mode 100644 --- /dev/null +++ b/tests/robbins.p @@ -0,0 +1,4 @@ +cnf(comm, axiom, '+'(X, Y) = '+'(Y, X)). +cnf(assoc, axiom, '+'(X, '+'(Y, Z)) = '+'('+'(X, Y), Z)). +cnf(funny, axiom, '-'('+'('-'('+'(X, Y)), '-'('+'(X, '-'(Y))))) = X). +cnf(conjecture, negated_conjecture, '-'('-'(a)) != a). diff --git a/tests/robbins2.p b/tests/robbins2.p deleted file mode 100644 --- a/tests/robbins2.p +++ /dev/null @@ -1,4 +0,0 @@ -cnf(a, axiom, '+'(X, Y) = '+'(Y, X)). -cnf(a, axiom, '+'(X, '+'(Y, Z)) = '+'('+'(X, Y), Z)). -cnf(a, axiom, '-'('+'('-'('+'(X, Y)), '-'('+'(X, '-'(Y))))) = X). -cnf(a, axiom, '-'('-'(a)) != a). diff --git a/tests/semigroup.p b/tests/semigroup.p --- a/tests/semigroup.p +++ b/tests/semigroup.p @@ -1,4 +1,4 @@ -cnf(a, axiom, '*'(X, '*'(Y, Z)) = '*'('*'(X, Y), Z)). -cnf(a, axiom, '*'(X, X) = '*'(X, '*'(X, X))). -cnf(a, axiom, '*'('*'(X, X), Y) = '*'(Y, '*'(X, X))). -cnf(a, axiom, '*'('*'(a, b), '*'(a, b)) != '*'('*'(a, a), '*'(b, b))). +cnf(assoc, axiom, '*'(X, '*'(Y, Z)) = '*'('*'(X, Y), Z)). +cnf(two_three, axiom, '*'(X, X) = '*'(X, '*'(X, X))). +cnf(twiddle, axiom, '*'('*'(X, X), Y) = '*'(Y, '*'(X, X))). +cnf(conjecture, negated_conjecture, '*'('*'(a, b), '*'(a, b)) != '*'('*'(a, a), '*'(b, b))). diff --git a/tests/semigroup2.p b/tests/semigroup2.p --- a/tests/semigroup2.p +++ b/tests/semigroup2.p @@ -1,26 +1,26 @@ -% File : GRP'1'96'-''1' : TPTP v6.'1'.'0'. Released v2.2.'0'. +% File : GRP196-1 : TPTP v6.1.0. Released v2.2.0. % Domain : Group Theory (Semigroups) -% Problem : In semigroups, xyyy=yyyx '->' (uy)'^'9 = u'^'9v'^'9. +% Problem : In semigroups, xyyy=yyyx -> (uy)^9 = u^9v^9. % Version : [MP96] (equality) axioms. % English : -% Refs : [McC98] McCune ('1'998), Email to G. Sutcliffe -% : [MP96] McCune & Padmanabhan ('1'996), Automated Deduction in Eq -% : [McC95] McCune ('1'995), Four Challenge Problems in Equational L +% Refs : [McC98] McCune (1998), Email to G. Sutcliffe +% : [MP96] McCune & Padmanabhan (1996), Automated Deduction in Eq +% : [McC95] McCune (1995), Four Challenge Problems in Equational L % Source : [McC98] -% Names : CS'-'3 [MP96] +% Names : CS-3 [MP96] % : Problem B [McC95] % Status : Unsatisfiable -% Rating : '1'.'0''0' v4.'0'.'1', '0'.93 v4.'0'.'0', '0'.92 v3.7.'0', '0'.89 v3.4.'0', '1'.'0''0' v3.3.'0', '0'.93 v3.'1'.'0', '1'.'0''0' v2.2.'1' -% Syntax : Number of clauses : 3 ( '0' non'-'Horn; 3 unit; '1' RR) +% Rating : 1.00 v4.0.1, 0.93 v4.0.0, 0.92 v3.7.0, 0.89 v3.4.0, 1.00 v3.3.0, 0.93 v3.1.0, 1.00 v2.2.1 +% Syntax : Number of clauses : 3 ( 0 non-Horn; 3 unit; 1 RR) % Number of atoms : 3 ( 3 equality) -% Maximal clause size : '1' ( '1' average) -% Number of predicates : '1' ( '0' propositional; 2'-'2 arity) -% Number of functors : 3 ( 2 constant; '0''-'2 arity) -% Number of variables : 5 ( '0' singleton) -% Maximal term depth : '1'8 ( 8 average) +% Maximal clause size : 1 ( 1 average) +% Number of predicates : 1 ( 0 propositional; 2-2 arity) +% Number of functors : 3 ( 2 constant; 0-2 arity) +% Number of variables : 5 ( 0 singleton) +% Maximal term depth : 18 ( 8 average) % SPC : CNF_UNS_RFO_PEQ_UEQ % Comments : The problem was originally posed for cancellative semigroups, % Otter does this with a nonstandard representation [MP96]. -cnf(a, axiom, '*'('*'(A,B),C)='*'(A,'*'(B,C))). -cnf(a, axiom, '*'(A,'*'(B,'*'(B,B)))='*'(B,'*'(B,'*'(B,A)))). -cnf(a, axiom, '*'(a,'*'(b,'*'(a,'*'(b,'*'(a,'*'(b,'*'(a,'*'(b,'*'(a,'*'(b,'*'(a,'*'(b,'*'(a,'*'(b,'*'(a,'*'(b,'*'(a,b))))))))))))))))) != '*'(a,'*'(a,'*'(a,'*'(a,'*'(a,'*'(a,'*'(a,'*'(a,'*'(a,'*'(b,'*'(b,'*'(b,'*'(b,'*'(b,'*'(b,'*'(b,'*'(b,b)))))))))))))))))). +cnf(assoc, axiom, '*'('*'(A,B),C)='*'(A,'*'(B,C))). +cnf(twiddle, axiom, '*'(A,'*'(B,'*'(B,B)))='*'(B,'*'(B,'*'(B,A)))). +cnf(conjecture, negated_conjecture, '*'(a,'*'(b,'*'(a,'*'(b,'*'(a,'*'(b,'*'(a,'*'(b,'*'(a,'*'(b,'*'(a,'*'(b,'*'(a,'*'(b,'*'(a,'*'(b,'*'(a,b))))))))))))))))) != '*'(a,'*'(a,'*'(a,'*'(a,'*'(a,'*'(a,'*'(a,'*'(a,'*'(a,'*'(b,'*'(b,'*'(b,'*'(b,'*'(b,'*'(b,'*'(b,'*'(b,b)))))))))))))))))). diff --git a/tests/winkler-easy.p b/tests/winkler-easy.p --- a/tests/winkler-easy.p +++ b/tests/winkler-easy.p @@ -1,6 +1,6 @@ % Needs case split on X < c. -cnf(a, axiom, '+'(X, Y) = '+'(Y, X)). -cnf(a, axiom, '+'(X, '+'(Y, Z)) = '+'('+'(X, Y), Z)). -cnf(a, axiom, '+'(X, X) = X). -cnf(a, axiom, '-'('+'('-'('+'(X, Y)), '-'('+'(X, '-'(Y))))) = X). -cnf(a, axiom, '+'('-'('+'('-'(a), b)), '-'('+'('-'(a), '-'(b)))) != a). +cnf(comm, axiom, '+'(X, Y) = '+'(Y, X)). +cnf(assoc, axiom, '+'(X, '+'(Y, Z)) = '+'('+'(X, Y), Z)). +cnf(idem, axiom, '+'(X, X) = X). +cnf(funny, axiom, '-'('+'('-'('+'(X, Y)), '-'('+'(X, '-'(Y))))) = X). +cnf(conjecture, negated_conjecture, '+'('-'('+'('-'(a), b)), '-'('+'('-'(a), '-'(b)))) != a). diff --git a/tests/winkler.p b/tests/winkler.p --- a/tests/winkler.p +++ b/tests/winkler.p @@ -1,6 +1,6 @@ % Needs case split on X < c. -cnf(a, axiom, '+'(X, Y) = '+'(Y, X)). -cnf(a, axiom, '+'(X, '+'(Y, Z)) = '+'('+'(X, Y), Z)). -cnf(a, axiom, '+'(c, c) = c). -cnf(a, axiom, '-'('+'('-'('+'(X, Y)), '-'('+'(X, '-'(Y))))) = X). -cnf(a, axiom, '+'('-'('+'('-'(a), b)), '-'('+'('-'(a), '-'(b)))) != a). +cnf(comm, axiom, '+'(X, Y) = '+'(Y, X)). +cnf(assoc, axiom, '+'(X, '+'(Y, Z)) = '+'('+'(X, Y), Z)). +cnf(idem_c, axiom, '+'(c, c) = c). +cnf(funny, axiom, '-'('+'('-'('+'(X, Y)), '-'('+'(X, '-'(Y))))) = X). +cnf(conjecture, negated_conjecture, '+'('-'('+'('-'(a), b)), '-'('+'('-'(a), '-'(b)))) != a). diff --git a/tests/winkler2.p b/tests/winkler2.p --- a/tests/winkler2.p +++ b/tests/winkler2.p @@ -1,6 +1,6 @@ % Needs case split on X < c. -cnf(a, axiom, '+'(X, Y) = '+'(Y, X)). -cnf(a, axiom, '+'(X, '+'(Y, Z)) = '+'('+'(X, Y), Z)). -cnf(a, axiom, '+'(c, d) = c). -cnf(a, axiom, '-'('+'('-'('+'(X, Y)), '-'('+'(X, '-'(Y))))) = X). -cnf(a, axiom, '+'('-'('+'('-'(a), b)), '-'('+'('-'(a), '-'(b)))) != a). +cnf(comm, axiom, '+'(X, Y) = '+'(Y, X)). +cnf(assoc, axiom, '+'(X, '+'(Y, Z)) = '+'('+'(X, Y), Z)). +cnf(plus_c_d, axiom, '+'(c, d) = c). +cnf(funny, axiom, '-'('+'('-'('+'(X, Y)), '-'('+'(X, '-'(Y))))) = X). +cnf(conjecture, negated_conjecture, '+'('-'('+'('-'(a), b)), '-'('+'('-'(a), '-'(b)))) != a). diff --git a/tests/y-easier.p b/tests/y-easier.p deleted file mode 100644 --- a/tests/y-easier.p +++ /dev/null @@ -1,5 +0,0 @@ -cnf(a, axiom, app(app(k, X), Y) = X). -cnf(a, axiom, app(app(app(s, X), Y), Z) = app(app(X, Z), app(Y, Z))). -cnf(a, axiom, app(app(app(b, X), Y), Z) = app(X, app(Y, Z))). -cnf(a, axiom, app(m, X) = app(X, X)). -cnf(a, axiom, app(X, a(X)) != app(a(X), app(X, a(X)))). diff --git a/tests/y-hard.p b/tests/y-hard.p deleted file mode 100644 --- a/tests/y-hard.p +++ /dev/null @@ -1,3 +0,0 @@ -cnf(a, axiom, '@'('@'(k, X), Y) = X). -cnf(a, axiom, '@'('@'('@'(s, X), Y), Z) = '@'('@'(X, Z), '@'(Y, Z))). -cnf(a, axiom, '@'(X, a) != '@'(a, '@'(X, a))). diff --git a/tests/y-inconsistent.p b/tests/y-inconsistent.p deleted file mode 100644 --- a/tests/y-inconsistent.p +++ /dev/null @@ -1,13 +0,0 @@ -% Obviously inconsistent because w X Y = X X Y = X. -% Interesting thing is the final rules: -% w '@' X'0' '->' X'0' '@' X'0' (unoriented) -% X'0' '@' X'0' '->' w '@' X'0' (unoriented) -% X'0' '@' X'1' '->' X'0' '@' ? (weak on [X'1']) -% X'0' '@' X'1' '->' w '@' X'0' (unoriented) -% We should maybe use X'0' '@' X'1' '->' X'0' '@' ? to simplify the -% other rules (many of which would still be oriented the same) -cnf(a, axiom, '@'('@'('@'(c, X), Y), Z) = '@'(X, '@'(Y, Z))). -cnf(a, axiom, '@'('@'('@'(f, X), Y), Z) = '@'('@'(X, Z), Y)). -cnf(a, axiom, '@'(w, X) = '@'(X, X)). -cnf(a, axiom, '@'('@'(w, X), Y) = X). -cnf(a, axiom, '@'(X, a) != '@'(a, '@'(X, a))). diff --git a/tests/y-really-hard.p b/tests/y-really-hard.p deleted file mode 100644 --- a/tests/y-really-hard.p +++ /dev/null @@ -1,3 +0,0 @@ -cnf(a, axiom, '@'('@'(k, X), Y) = X). -cnf(a, axiom, '@'('@'('@'(s, X), Y), Z) = '@'('@'(X, Z), '@'(Y, Z))). -cnf(a, axiom, '@'(X, a(X)) != '@'(a(X), '@'(X, a(X)))). diff --git a/tests/y.p b/tests/y.p --- a/tests/y.p +++ b/tests/y.p @@ -1,4 +1,3 @@ -cnf(a, axiom, '@'('@'('@'(c, X), Y), Z) = '@'(X, '@'(Y, Z))). -cnf(a, axiom, '@'('@'('@'(f, X), Y), Z) = '@'('@'(X, Z), Y)). -cnf(a, axiom, '@'(w, X) = '@'(X, X)). -cnf(a, axiom, '@'(X, a) != '@'(a, '@'(X, a))). +fof(k_def, axiom, ![X, Y]: '@'('@'(k, X), Y) = X). +fof(s_def, axiom, ![X, Y, Z]: '@'('@'('@'(s, X), Y), Z) = '@'('@'(X, Z), '@'(Y, Z))). +fof(conjecture, conjecture, ?[Y]: ![F]: '@'(Y, F) = '@'(F, '@'(Y, F))). diff --git a/twee.cabal b/twee.cabal --- a/twee.cabal +++ b/twee.cabal @@ -1,5 +1,5 @@ name: twee -version: 0.1 +version: 2.0 synopsis: An equational theorem prover homepage: http://github.com/nick8325/twee license: BSD3 @@ -9,7 +9,7 @@ category: Theorem Provers build-type: Simple cabal-version: >=1.10 -extra-source-files: README src/errors.h tests/*.p +extra-source-files: README tests/*.p description: Twee is an experimental equational theorem prover based on Knuth-Bendix completion. @@ -28,49 +28,82 @@ location: git://github.com/nick8325/twee.git branch: master +flag static + description: Build a static binary. + default: False + +flag static-cxx + description: Build a binary which statically links against libstdc++. + default: False + +flag llvm + description: Build using LLVM backend for faster code. + default: False + +flag bounds-checks + description: Use bounds checks for all array operations. + default: False + library exposed-modules: Twee Twee.Array Twee.Base - Twee.Pretty + Twee.ChurchList Twee.Constraints + Twee.CP + Twee.Equation + Twee.Heap Twee.Index - Twee.Indexes - Twee.Queue + Twee.Index.Lookup + Twee.Join + Twee.KBO + Twee.Label + Twee.Pretty + Twee.Proof Twee.Rule + Twee.Rule.Index Twee.Term Twee.Term.Core + Twee.Task Twee.Utils - Twee.KBO - Twee.LPO - Twee.Label build-depends: base >= 4 && < 5, containers, transformers, dlist, pretty, - heaps, ghc-prim, - primitive, - reflection, - array + primitive >= 0.6.2.0 hs-source-dirs: src - include-dirs: src - ghc-options: -W -fno-warn-incomplete-patterns -fno-full-laziness + ghc-options: -W -fno-warn-incomplete-patterns -O2 -fmax-worker-args=100 default-language: Haskell2010 + if flag(llvm) + ghc-options: -fllvm + if flag(bounds-checks) + cpp-options: -DBOUNDS_CHECKS + exposed-modules: + Data.Primitive.SmallArray.Checked + Data.Primitive.ByteArray.Checked + Data.Primitive.Checked + executable twee main-is: executable/Main.hs default-language: Haskell2010 build-depends: base, twee, containers, - transformers, pretty, - array, - reflection, split, - jukebox >= 0.2 - ghc-options: -W -fno-warn-incomplete-patterns -fno-full-laziness + jukebox >= 0.3 + ghc-options: -W -fno-warn-incomplete-patterns -O2 -fmax-worker-args=100 + + if flag(llvm) + ghc-options: -fllvm + + if flag(static) + ghc-options: -optl -static + + if flag(static-cxx) + ghc-options: -pgml misc/static-libstdc++