├── .gitignore ├── Changelog ├── LICENSE ├── README.md ├── Setup.lhs ├── src └── Data │ └── Rewriting │ ├── Context.hs │ ├── Context │ ├── Ops.hs │ └── Type.hs │ ├── CriticalPair.hs │ ├── CriticalPair │ ├── Ops.hs │ └── Type.hs │ ├── Pos.hs │ ├── Problem.hs │ ├── Problem │ ├── Parse.hs │ ├── Pretty.hs │ └── Type.hs │ ├── Rule.hs │ ├── Rule │ ├── Ops.hs │ ├── Pretty.hs │ └── Type.hs │ ├── Rules.hs │ ├── Rules │ ├── Ops.hs │ └── Rewrite.hs │ ├── Signature.hs │ ├── Substitution.hs │ ├── Substitution │ ├── Match.hs │ ├── Ops.hs │ ├── Parse.hs │ ├── Pretty.hs │ ├── Type.hs │ └── Unify.hs │ ├── Term.hs │ ├── Term │ ├── Ops.hs │ ├── Parse.hs │ ├── Pretty.hs │ └── Type.hs │ ├── Utils.hs │ └── Utils │ └── Parse.hs ├── term-rewriting.cabal └── test ├── Arbitrary.hs ├── CriticalPair.hs ├── Main.hs ├── Pos.hs ├── README ├── Rule.hs ├── Samples.hs ├── Substitution.hs └── Term.hs /.gitignore: -------------------------------------------------------------------------------- 1 | *~ 2 | /dist/ 3 | *.swp 4 | .dist-scion 5 | .cabal-sandbox/ 6 | cabal.config 7 | cabal.sandbox.config 8 | -------------------------------------------------------------------------------- /Changelog: -------------------------------------------------------------------------------- 1 | version 0.4.0.2 2 | - compatibility with ghc-8.8.1 (bump quickcheck version) 3 | 4 | version 0.4.0.1 5 | - Changelog 6 | 7 | version 0.4 8 | - nicer pretty printing of Problems 9 | - support simple signatures ("(SIG ...)") in problems 10 | 11 | version 0.3.0.1 12 | - compatibility with ghc-8.6.1 13 | 14 | version 0.3 15 | - drop Control.Monad.Error import in Data.Rewriting.Term.Parse 16 | - fix testsuite 17 | * include all modules in source distribution 18 | * build fix for recent QuickCheck 19 | 20 | version 0.2.1.1 21 | - Changelog 22 | 23 | version 0.2.1 24 | - add Term.mapSides, Rule.map, Rules.map, Problem.map 25 | - fix build with ghc-8.0.2 (and remove overlapping instance) 26 | 27 | version 0.2 28 | - fix argument order of Data.Rewriting.Rule.isVariantOf 29 | 30 | version 0.1.2.2 31 | - fix build with ghc-7.10.1 32 | 33 | version 0.1.2.1 34 | - fix Data.Rewriting.CriticalPair.cpsIn and cpsOut 35 | 36 | version 0.1.2 37 | - update to parsec >= 3.1.6 API (thanks alpako!) 38 | 39 | version 0.1.1 40 | - no changelog (yet?) 41 | -------------------------------------------------------------------------------- /LICENSE: -------------------------------------------------------------------------------- 1 | term-rewriting library -- basic first order term rewriting. 2 | 3 | Copyright (c) 2011-2019 by Martin Avanzini, Bertram Felgenhauer and 4 | Christian Sternagel. 5 | 6 | Permission is hereby granted, free of charge, to any person obtaining a 7 | copy of this software and associated documentation files (the "Software"), 8 | to deal in the Software without restriction, including without limitation 9 | the rights to use, copy, modify, merge, publish, distribute, sublicense, 10 | and/or sell copies of the Software, and to permit persons to whom the 11 | Software is furnished to do so, subject to the following conditions: 12 | 13 | The above copyright notice and this permission notice shall be included in 14 | all copies or substantial portions of the Software. 15 | 16 | THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR 17 | IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, 18 | FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE 19 | AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER 20 | LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING 21 | FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER 22 | DEALINGS IN THE SOFTWARE. 23 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | ## term-rewriting library 2 | 3 | This library provides basic data types and functionality for first order 4 | term rewriting. 5 | 6 | It is also available from hackage (including some documentation): 7 | 8 | http://hackage.haskell.org/package/term-rewriting 9 | -------------------------------------------------------------------------------- /Setup.lhs: -------------------------------------------------------------------------------- 1 | #! /usr/bin/env runghc 2 | > import Distribution.Simple (defaultMain) 3 | > main = defaultMain 4 | -------------------------------------------------------------------------------- /src/Data/Rewriting/Context.hs: -------------------------------------------------------------------------------- 1 | -- This file is part of the 'term-rewriting' library. It is licensed 2 | -- under an MIT license. See the accompanying 'LICENSE' file for details. 3 | -- 4 | -- Author: Bertram Felgenhauer 5 | 6 | module Data.Rewriting.Context ( 7 | Ctxt, 8 | -- * Important operations 9 | ofTerm, 10 | apply, 11 | -- * Reexported modules 12 | module Data.Rewriting.Context.Type, 13 | module Data.Rewriting.Context.Ops, 14 | ) where 15 | 16 | import Data.Rewriting.Context.Type 17 | import Data.Rewriting.Context.Ops 18 | -------------------------------------------------------------------------------- /src/Data/Rewriting/Context/Ops.hs: -------------------------------------------------------------------------------- 1 | -- This file is part of the 'term-rewriting' library. It is licensed 2 | -- under an MIT license. See the accompanying 'LICENSE' file for details. 3 | -- 4 | -- Authors: Christian Sternagel 5 | 6 | module Data.Rewriting.Context.Ops ( 7 | apply, 8 | compose, 9 | ofTerm, 10 | ) where 11 | 12 | import Control.Monad 13 | import Data.Rewriting.Pos 14 | import Data.Rewriting.Term.Type 15 | import Data.Rewriting.Context.Type 16 | 17 | -- | Apply a context to a term (i.e., replace the hole in the context by the 18 | -- term). 19 | apply :: Ctxt f v -> Term f v -> Term f v 20 | apply Hole t = t 21 | apply (Ctxt f ts1 ctxt ts2) t = Fun f (ts1 ++ apply ctxt t : ts2) 22 | 23 | -- | Compose two contexts (i.e., replace the hole in the left context by the 24 | -- right context). 25 | compose :: Ctxt f v -> Ctxt f v -> Ctxt f v 26 | compose Hole c2 = c2 27 | compose (Ctxt f ts1 c1 ts2) c2 = Ctxt f ts1 (c1 `compose` c2) ts2 28 | 29 | -- | Create a context from a term by placing the hole at a specific position. 30 | ofTerm :: Term f v -> Pos -> Maybe (Ctxt f v) 31 | ofTerm _ [] = Just Hole 32 | ofTerm (Fun f ts) (i:p) = do 33 | guard (i >= 0 && i < length ts) 34 | let (ts1, t:ts2) = splitAt i ts 35 | ctxt <- ofTerm t p 36 | return (Ctxt f ts1 ctxt ts2) 37 | ofTerm _ _ = Nothing 38 | -------------------------------------------------------------------------------- /src/Data/Rewriting/Context/Type.hs: -------------------------------------------------------------------------------- 1 | -- This file is part of the 'term-rewriting' library. It is licensed 2 | -- under an MIT license. See the accompanying 'LICENSE' file for details. 3 | -- 4 | -- Authors: Christian Sternagel 5 | 6 | module Data.Rewriting.Context.Type ( 7 | Ctxt (..), 8 | ) where 9 | 10 | import Data.Rewriting.Term (Term(..)) 11 | 12 | data Ctxt f v 13 | = Hole -- ^ Hole 14 | | Ctxt f [Term f v] (Ctxt f v) [Term f v] -- ^ Non-empty context 15 | 16 | -- CS: would it make sense to reverse the left term list? 17 | deriving (Show, Eq, Ord) 18 | -------------------------------------------------------------------------------- /src/Data/Rewriting/CriticalPair.hs: -------------------------------------------------------------------------------- 1 | -- This file is part of the 'term-rewriting' library. It is licensed 2 | -- under an MIT license. See the accompanying 'LICENSE' file for details. 3 | -- 4 | -- Authors: Bertram Felgenhauer 5 | 6 | module Data.Rewriting.CriticalPair ( 7 | CP, 8 | -- * Important operations 9 | cps', 10 | cps, 11 | -- * Reexported modules 12 | module Data.Rewriting.CriticalPair.Type, 13 | module Data.Rewriting.CriticalPair.Ops, 14 | ) where 15 | 16 | import Data.Rewriting.CriticalPair.Type 17 | import Data.Rewriting.CriticalPair.Ops 18 | -------------------------------------------------------------------------------- /src/Data/Rewriting/CriticalPair/Ops.hs: -------------------------------------------------------------------------------- 1 | -- This file is part of the 'term-rewriting' library. It is licensed 2 | -- under an MIT license. See the accompanying 'LICENSE' file for details. 3 | -- 4 | -- Authors: Bertram Felgenhauer 5 | 6 | module Data.Rewriting.CriticalPair.Ops ( 7 | -- * pairs of rewrite systems 8 | cps, 9 | cpsIn, 10 | cpsOut, 11 | -- * single rewrite systems 12 | cps', 13 | cpsIn', 14 | cpsOut', 15 | ) where 16 | 17 | import Data.Rewriting.CriticalPair.Type 18 | import Data.Rewriting.Substitution 19 | import Data.Rewriting.Rule.Type 20 | import qualified Data.Rewriting.Term as Term 21 | import Data.Rewriting.Pos 22 | import Data.Rewriting.Rules.Rewrite (listContexts) 23 | 24 | import Data.Maybe 25 | import Control.Monad 26 | import Data.List 27 | 28 | -- cpW does all the hard work: 29 | -- Given a function that returns contexts to consider for rewriting, 30 | -- unify the contexts of the right rule's lhs with the left rule's lhs, 31 | -- and return the resulting critical pairs. 32 | cpW :: (Ord v, Ord v', Eq f) 33 | => (Term f (Either v v') 34 | -> [(Pos, Context f (Either v v'), Term f (Either v v'))]) 35 | -> Rule f v -> Rule f v' -> [(CP f v v')] 36 | cpW f rl rr = do 37 | let rl' = Term.map id Left (lhs rl) 38 | rr' = Term.map id Right (lhs rr) 39 | (pos, ctx, rr'') <- f rr' 40 | guard $ not (Term.isVar rr'') 41 | subst <- maybeToList $ unify rl' rr'' 42 | return CP{ 43 | left = apply subst (ctx (Term.map id Left (rhs rl))), 44 | top = apply subst rr', 45 | right = apply subst (Term.map id Right (rhs rr)), 46 | leftRule = rl, 47 | leftPos = pos, 48 | rightRule = rr, 49 | subst = subst 50 | } 51 | 52 | 53 | -- TODO: find a better place for this kind of contexts. 54 | type Context f v = Term f v -> Term f v 55 | 56 | -- Calculate contexts of a term, in pre-order. 57 | -- In particular, the root context is returned first. 58 | contexts :: Term f v -> [(Pos, Context f v, Term f v)] 59 | contexts t@(Var _) = [([], id, t)] 60 | contexts t@(Fun f ts) = ([], id, t) : do 61 | (i, ctxL, t) <- listContexts ts 62 | (pos, ctxT, t') <- contexts t 63 | return (i : pos, Fun f . ctxL . ctxT, t') 64 | 65 | -- Determine critical pairs for a pair of rules. 66 | cp :: (Ord v, Ord v', Eq f) 67 | => Rule f v -> Rule f v' -> [(CP f v v')] 68 | cp = cpW contexts 69 | 70 | -- Determine outer critical pairs for a pair of rules. 71 | cpOut :: (Ord v, Ord v', Eq f) 72 | => Rule f v -> Rule f v' -> [(CP f v v')] 73 | cpOut = cpW (take 1 . contexts) 74 | 75 | -- Determine inner critical pairs for a pair of rules. 76 | cpIn :: (Ord v, Ord v', Eq f) 77 | => Rule f v -> Rule f v' -> [(CP f v v')] 78 | cpIn = cpW (tail . contexts) 79 | 80 | 81 | -- | Determine all critical pairs for a pair of TRSs. 82 | cps :: (Ord v, Ord v', Eq f) => [Rule f v] -> [Rule f v'] 83 | -> [(CP f v v')] 84 | cps trs1 trs2 = do 85 | rl <- trs1 86 | rr <- trs2 87 | cp rl rr 88 | 89 | -- | Determine all inner critical pairs for a pair of TRSs. 90 | -- 91 | -- A critical pair is /inner/ if the left rewrite step is not a root step. 92 | cpsIn :: (Ord v, Ord v', Eq f) => [Rule f v] -> [Rule f v'] 93 | -> [(CP f v v')] 94 | cpsIn trs1 trs2 = do 95 | rl <- trs1 96 | rr <- trs2 97 | cpIn rl rr 98 | 99 | -- | Determine outer critical pairs for a pair of TRSs. 100 | -- 101 | -- A critical pair is /outer/ if the left rewrite step is a root step. 102 | cpsOut :: (Ord v, Ord v', Eq f) => [Rule f v] -> [Rule f v'] 103 | -> [(CP f v v')] 104 | cpsOut trs1 trs2 = do 105 | rl <- trs1 106 | rr <- trs2 107 | cpOut rl rr 108 | 109 | 110 | -- | Determine all critical pairs of a single TRS with itself. 111 | -- 112 | -- Unlike @cps@, @cps'@ takes symmetries into account. See 'cpsIn'' and 113 | -- 'cpsOut'' for details. 114 | cps' :: (Ord v, Eq f) => [Rule f v] -> [(CP f v v)] 115 | cps' trs = cpsIn' trs ++ cpsOut' trs 116 | 117 | -- | Determine all inner critical pairs of a single TRS with itself. 118 | -- 119 | -- The result of @cpsIn' trs@ differs from @cpsIn trs trs@ in that overlaps 120 | -- of a rule with itself are returned once, not twice. 121 | cpsIn' :: (Ord v, Eq f) => [Rule f v] -> [(CP f v v)] 122 | cpsIn' trs = do 123 | r1 : trs' <- tails trs 124 | cpIn r1 r1 ++ do 125 | r2 <- trs' 126 | cpIn r1 r2 ++ cpIn r2 r1 127 | 128 | -- | Determine all outer critical pairs of a single TRS with itself. 129 | -- 130 | -- The result of @cpsOut' trs@ differs from @cpsOut trs trs@ in two aspects: 131 | -- 132 | -- * The trivial overlaps of rules with themselves are omitted. 133 | -- 134 | -- * Symmetry is taken into account: Overlaps between distinct rules are 135 | -- returned once instead of twice. 136 | cpsOut' :: (Ord v, Eq f) => [Rule f v] -> [(CP f v v)] 137 | cpsOut' trs = do 138 | rl : trs' <- tails trs 139 | rr <- trs' 140 | cpOut rl rr 141 | -------------------------------------------------------------------------------- /src/Data/Rewriting/CriticalPair/Type.hs: -------------------------------------------------------------------------------- 1 | -- This file is part of the 'term-rewriting' library. It is licensed 2 | -- under an MIT license. See the accompanying 'LICENSE' file for details. 3 | -- 4 | -- Authors: Bertram Felgenhauer 5 | 6 | module Data.Rewriting.CriticalPair.Type ( 7 | CP (..), 8 | ) where 9 | 10 | import Data.Rewriting.Substitution 11 | import Data.Rewriting.Rule.Type 12 | import Data.Rewriting.Pos 13 | 14 | -- | A critical pair. Critical pairs (should) have the following properties: 15 | -- 16 | -- @ 17 | -- top == Context.ofTerm top pos (Term.map Left id (Rule.lhs leftRule)) 18 | -- left == Context.ofTerm top pos (Term.map Left id (Rule.rhs leftRule)) 19 | -- top == Substitution.apply subst (Term.map Right id (Rule.lhs rightRule)) 20 | -- right == Substitution.apply subst (Term.map Right id (Rule.rhs rightRule)) 21 | -- @ 22 | -- 23 | -- Furthermore, @pos@ is a non-variable position of @(lhs rightRule)@ and 24 | -- @subst@ is a most general substitution with these properties. 25 | data CP f v v' = CP { 26 | left :: Term f (Either v v'), -- ^ left reduct 27 | top :: Term f (Either v v'), -- ^ source 28 | right :: Term f (Either v v'), -- ^ right reduct 29 | leftRule :: Rule f v, -- ^ rule applied on left side 30 | leftPos :: Pos, -- ^ position of left rule application 31 | rightRule :: Rule f v', -- ^ rule applied on right side 32 | subst :: Subst f (Either v v') -- ^ common substitution of the rewrite steps 33 | } 34 | -------------------------------------------------------------------------------- /src/Data/Rewriting/Pos.hs: -------------------------------------------------------------------------------- 1 | -- This file is part of the 'term-rewriting' library. It is licensed 2 | -- under an MIT license. See the accompanying 'LICENSE' file for details. 3 | -- 4 | -- Authors: Christian Sternagel, Bertram Felgenhauer, Martin Avanzini 5 | 6 | module Data.Rewriting.Pos ( 7 | Pos, 8 | -- * Comparing Positions 9 | -- | Note that positions are not totally ordered. Nevertheless there are 10 | -- some commonly useful comparisons between positions. 11 | above, 12 | below, 13 | parallelTo, 14 | leftOf, 15 | rightOf, 16 | ) where 17 | 18 | import Data.Rewriting.Utils 19 | import Data.List 20 | 21 | -- | A position in a term. Arguments are counted from 0. 22 | -- 23 | -- A position describes a path in the tree representation of a term. The empty 24 | -- position @[]@ denotes the root of the term. A position @[0,1]@ denotes the 25 | -- 2nd child of the 1st child of the root (counting children from left to 26 | -- right). 27 | type Pos = [Int] 28 | 29 | -- | @p \`above\` q@ checks whether @p@ is above @q@ (in the tree representation of 30 | -- a term). A position @p@ is above a position @q@, whenever @p@ is a prefix of 31 | -- @q@. 32 | above :: Pos -> Pos -> Bool 33 | above = isPrefixOf 34 | 35 | -- | @p \`below\` q@ checks whether @p@ is below @q@, that is to say that @q@ is 36 | -- above @p@. 37 | below :: Pos -> Pos -> Bool 38 | below = flip above 39 | 40 | -- | @p \`parallelTo\` q@ checks whether @p@ is parallel to @q@, that is to say 41 | -- that @p@ and @q@ do not lie on the same path. 42 | parallelTo :: Pos -> Pos -> Bool 43 | parallelTo p q = not (null p') && not (null q') where 44 | (p', q') = dropCommonPrefix p q 45 | 46 | -- | @p \`leftOf\` q@ checks whether @p@ is left of @q@. This is only possible if 47 | -- @p@ and @q@ do not lie on the same path (i.e., are parallel to each other). 48 | leftOf :: Pos -> Pos -> Bool 49 | leftOf p q = not (null p') && not (null q') && head p' < head q' where 50 | (p', q') = dropCommonPrefix p q 51 | 52 | -- | @p \`rightOf\` q@ checks whether @p@ is right of @q@. 53 | rightOf :: Pos -> Pos -> Bool 54 | rightOf p q = not (null p') && not (null q') && head p' > head q' where 55 | (p', q') = dropCommonPrefix p q 56 | 57 | -- reference implementations 58 | parallelToRef :: Pos -> Pos -> Bool 59 | parallelToRef p q = not (p `above` q) && not (p `below` q) 60 | -------------------------------------------------------------------------------- /src/Data/Rewriting/Problem.hs: -------------------------------------------------------------------------------- 1 | -- This file is part of the 'term-rewriting' library. It is licensed 2 | -- under an MIT license. See the accompanying 'LICENSE' file for details. 3 | -- 4 | -- Authors: Martin Avanzini 5 | 6 | -- | Termination problem type, based on WST format. 7 | module Data.Rewriting.Problem ( 8 | Problem, 9 | -- * Reexported modules 10 | module Data.Rewriting.Problem.Type, 11 | module Data.Rewriting.Problem.Parse, 12 | module Data.Rewriting.Problem.Pretty, 13 | ) where 14 | 15 | import Data.Rewriting.Problem.Type 16 | import Data.Rewriting.Problem.Parse 17 | import Data.Rewriting.Problem.Pretty 18 | -------------------------------------------------------------------------------- /src/Data/Rewriting/Problem/Parse.hs: -------------------------------------------------------------------------------- 1 | -- This file is part of the 'term-rewriting' library. It is licensed 2 | -- under an MIT license. See the accompanying 'LICENSE' file for details. 3 | -- 4 | -- Authors: Martin Avanzini, Christian Sternagel 5 | 6 | {-# LANGUAGE FlexibleContexts #-} 7 | {-# LANGUAGE GeneralizedNewtypeDeriving #-} 8 | module Data.Rewriting.Problem.Parse ( 9 | parseIO, 10 | parseFileIO, 11 | fromString, 12 | fromFile, 13 | fromCharStream, 14 | ProblemParseError (..) 15 | ) where 16 | 17 | import Data.Rewriting.Utils.Parse (lex, par, ident) 18 | import qualified Data.Rewriting.Problem.Type as Prob 19 | import Data.Rewriting.Problem.Type (Problem) 20 | import Data.Rewriting.Rule (Rule (..)) 21 | import qualified Data.Rewriting.Term as Term 22 | import qualified Data.Rewriting.Rules as Rules 23 | 24 | import Data.List (partition, union) 25 | import Data.Maybe (isJust) 26 | import Prelude hiding (lex, catch) 27 | import Control.Exception (catch) 28 | import Control.Monad.Error 29 | import Control.Monad (liftM, liftM3) 30 | import Text.Parsec hiding (parse) 31 | import System.IO (readFile) 32 | 33 | data ProblemParseError = UnknownParseError String 34 | | UnsupportedStrategy String 35 | | FileReadError IOError 36 | | UnsupportedDeclaration String 37 | | SomeParseError ParseError deriving (Show) 38 | 39 | instance Error ProblemParseError where strMsg = UnknownParseError 40 | 41 | parseFileIO :: FilePath -> IO (Problem String String) 42 | parseFileIO file = do r <- fromFile file 43 | case r of 44 | Left err -> do { putStrLn "following error occured:"; print err; mzero } 45 | Right t -> return t 46 | 47 | parseIO :: String -> IO (Problem String String) 48 | parseIO string = case fromString string of 49 | Left err -> do { putStrLn "following error occured:"; print err; mzero } 50 | Right t -> return t 51 | 52 | fromFile :: FilePath -> IO (Either ProblemParseError (Problem String String)) 53 | fromFile file = fromFile' `catch` (return . Left . FileReadError) where 54 | fromFile' = fromCharStream sn `liftM` readFile file 55 | sn = "" 56 | 57 | fromString :: String -> Either ProblemParseError (Problem String String) 58 | fromString = fromCharStream "supplied string" 59 | 60 | fromCharStream :: (Stream s (Either ProblemParseError) Char) 61 | => SourceName -> s -> Either ProblemParseError (Problem String String) 62 | fromCharStream sourcename input = 63 | case runParserT parse initialState sourcename input of 64 | Right (Left e) -> Left $ SomeParseError e 65 | Right (Right p) -> Right p 66 | Left e -> Left e 67 | where initialState = Prob.Problem { Prob.startTerms = Prob.AllTerms , 68 | Prob.strategy = Prob.Full , 69 | Prob.theory = Nothing , 70 | Prob.rules = Prob.RulesPair { Prob.strictRules = [], 71 | Prob.weakRules = [] } , 72 | Prob.variables = [] , 73 | Prob.symbols = [] , 74 | Prob.signature = Nothing, 75 | Prob.comment = Nothing } 76 | 77 | 78 | type ParserState = Problem String String 79 | 80 | type WSTParser s a = ParsecT s ParserState (Either ProblemParseError) a 81 | 82 | modifyProblem :: (Problem String String -> Problem String String) -> WSTParser s () 83 | modifyProblem = modifyState 84 | 85 | parsedVariables :: WSTParser s [String] 86 | parsedVariables = Prob.variables `liftM` getState 87 | 88 | parse :: (Stream s (Either ProblemParseError) Char) => WSTParser s (Problem String String) 89 | parse = spaces >> parseDecls >> eof >> getState where 90 | parseDecls = many1 parseDecl 91 | parseDecl = decl "VAR" vars (\ e p -> p {Prob.variables = e `union` Prob.variables p}) 92 | <|> decl "THEORY" theory (\ e p -> p {Prob.theory = maybeAppend Prob.theory e p}) 93 | <|> decl "SIG" signature (\ e p -> p {Prob.signature = maybeAppend Prob.signature e p}) 94 | <|> decl "RULES" rules (\ e p -> p {Prob.rules = e, --FIXME multiple RULES blocks? 95 | Prob.symbols = Rules.funsDL (Prob.allRules e) [] }) 96 | <|> decl "STRATEGY" strategy (\ e p -> p {Prob.strategy = e}) 97 | <|> decl "STARTTERM" startterms (\ e p -> p {Prob.startTerms = e}) 98 | <|> (decl "COMMENT" comment (\ e p -> p {Prob.comment = maybeAppend Prob.comment e p}) "comment") 99 | <|> (par comment >>= modifyProblem . (\ e p -> p {Prob.comment = maybeAppend Prob.comment e p}) "comment") 100 | decl name p f = try (par $ do 101 | lex $ string name 102 | r <- p 103 | modifyProblem $ f r) (name ++ " block") 104 | maybeAppend fld e p = Just $ maybe [] id (fld p) ++ e 105 | 106 | vars :: (Stream s (Either ProblemParseError) Char) => WSTParser s [String] 107 | vars = do vs <- many (lex $ ident "()," []) 108 | return vs 109 | 110 | signature :: (Stream s (Either ProblemParseError) Char) => WSTParser s [(String,Int)] 111 | signature = many fundecl 112 | where 113 | fundecl = par (do 114 | f <- lex $ ident "()," [] 115 | ar <- lex (read <$> many1 digit) 116 | return $ (f,ar)) 117 | 118 | theory :: (Stream s (Either ProblemParseError) Char) => WSTParser s [Prob.Theory String String] 119 | theory = many thdecl where 120 | thdecl = par ((equations >>= return . Prob.Equations) 121 | <|> (idlist >>= \ (x:xs) -> return $ Prob.SymbolProperty x xs)) 122 | equations = try (do 123 | vs <- parsedVariables 124 | lex $ string "EQUATIONS" 125 | many $ equation vs) "EQUATIONS block" 126 | equation vs = do 127 | l <- Term.parseWST vs 128 | lex $ string "==" 129 | r <- Term.parseWST vs 130 | return $ Rule l r 131 | idlist = many1 $ (lex $ ident "()," []) 132 | 133 | rules :: (Stream s (Either ProblemParseError) Char) => WSTParser s (Prob.RulesPair String String) 134 | rules = do vs <- parsedVariables 135 | rs <- many $ rule vs 136 | let (s,w) = partition fst rs 137 | return Prob.RulesPair { Prob.strictRules = map snd s , 138 | Prob.weakRules = map snd w } 139 | where rule vs = do l <- Term.parseWST vs 140 | sep <- lex $ (try $ string "->=") <|> string "->" 141 | r <- Term.parseWST vs 142 | return (sep == "->", Rule {lhs = l, rhs = r}) 143 | 144 | strategy :: (Stream s (Either ProblemParseError) Char) => WSTParser s Prob.Strategy 145 | strategy = innermost <|> outermost where 146 | innermost = string "INNERMOST" >> return Prob.Innermost 147 | outermost = string "OUTERMOST" >> return Prob.Outermost 148 | 149 | startterms :: (Stream s (Either ProblemParseError) Char) => WSTParser s Prob.StartTerms 150 | startterms = basic <|> terms where 151 | basic = string "CONSTRUCTOR-BASED" >> return Prob.BasicTerms 152 | terms = string "FULL" >> return Prob.AllTerms 153 | 154 | comment :: (Stream s (Either ProblemParseError) Char) => WSTParser s String 155 | comment = withpars <|> liftM2 (++) idents comment <|> return "" 156 | where idents = many1 (noneOf "()") 157 | withpars = do _ <- char '(' 158 | pre <- comment 159 | _ <- char ')' 160 | suf <- comment 161 | return $ "(" ++ pre ++ ")" ++ suf 162 | -------------------------------------------------------------------------------- /src/Data/Rewriting/Problem/Pretty.hs: -------------------------------------------------------------------------------- 1 | -- This file is part of the 'term-rewriting' library. It is licensed 2 | -- under an MIT license. See the accompanying 'LICENSE' file for details. 3 | -- 4 | -- Authors: Martin Avanzini 5 | 6 | module Data.Rewriting.Problem.Pretty ( 7 | prettyProblem, 8 | prettyWST, 9 | prettyWST', 10 | ) where 11 | 12 | import Data.Maybe (isJust, fromJust) 13 | import Data.List (nub) 14 | import Data.Rewriting.Problem.Type 15 | import Data.Rewriting.Rule (prettyRule) 16 | import Text.PrettyPrint.ANSI.Leijen 17 | 18 | printWhen :: Bool -> Doc -> Doc 19 | printWhen False _ = empty 20 | printWhen True p = p 21 | 22 | 23 | prettyWST' :: (Pretty f, Pretty v) => Problem f v -> Doc 24 | prettyWST' = prettyWST pretty pretty 25 | 26 | prettyWST :: (f -> Doc) -> (v -> Doc) -> Problem f v -> Doc 27 | prettyWST fun var prob = 28 | printWhen (sterms /= AllTerms) (block "STARTTERM" $ text "CONSTRUCTOR-BASED") 29 | <> printWhen (strat /= Full) (block "STRATEGY" $ ppStrat strat) 30 | <> maybeblock "THEORY" theory ppTheories 31 | <> block "VAR" (ppVars $ variables prob) 32 | <> maybeblock "SIG" signature ppSignature 33 | <> block "RULES" (ppRules $ rules prob) 34 | <> maybeblock "COMMENT" comment text 35 | 36 | where block n pp = (parens $ (hang 3 $ text n <$$> pp) <> linebreak) <> linebreak 37 | maybeblock n f fpp = case f prob of 38 | Just e -> block n (fpp e) 39 | Nothing -> empty 40 | 41 | ppStrat Innermost = text "INNERMOST" 42 | ppStrat Outermost = text "OUTERMOST" 43 | 44 | ppVars vs = align $ fillSep [ var v | v <- vs] 45 | 46 | ppTheories thys = align $ vcat [ppThy thy | thy <- thys] 47 | where ppThy (SymbolProperty p fs) = block p (align $ fillSep [ fun f | f <- fs ]) 48 | ppThy (Equations rs) = block "EQUATIONS" $ vcat [ppRule "==" r | r <- rs] 49 | 50 | ppSignature sigs = align $ fillSep [ppSig sig | sig <- sigs] 51 | where ppSig (f,i) = parens $ fun f <+> int i 52 | 53 | ppRules rp = align $ vcat ([ppRule "->" r | r <- strictRules rp] 54 | ++ [ppRule "->=" r | r <- weakRules rp]) 55 | 56 | ppRule sep = prettyRule (text sep) fun var 57 | 58 | sterms = startTerms prob 59 | strat = strategy prob 60 | thry = theory prob 61 | 62 | 63 | prettyProblem :: (Eq f, Eq v) => (f -> Doc) -> (v -> Doc) -> Problem f v -> Doc 64 | prettyProblem fun var prob = block "Start-Terms" (ppST `on` startTerms) 65 | <$$> block "Strategy" (ppStrat `on` strategy) 66 | <$$> block "Variables" (ppVars `on` variables) 67 | <$$> block "Function Symbols" (ppSyms `on` symbols) 68 | <$$> maybeblock "Theory" ppTheories theory 69 | <$$> block "Rules" (ppRules `on` rules) 70 | <$$> maybeblock "Comment" ppComment comment where 71 | pp `on` fld = pp $ fld prob 72 | block n pp = hang 3 $ (underline $ text $ n ++ ":") <+> pp 73 | maybeblock n pp f = printWhen (isJust `on` f) (block n (pp `on` (fromJust . f))) 74 | commalist = fillSep . punctuate (text ",") 75 | 76 | ppST AllTerms = text "all" 77 | ppST BasicTerms = text "basic terms" 78 | ppStrat Innermost = text "innermost" 79 | ppStrat Outermost = text "outermost" 80 | ppStrat Full = text "full rewriting" 81 | ppVars vars = commalist $ [var v | v <- nub vars] 82 | ppSyms syms = commalist $ [fun v | v <- nub syms] 83 | ppComment c = text c 84 | ppTheories ths = align $ vcat [ ppTheory th | th <- ths ] where 85 | ppTheory (SymbolProperty p fs) = text (p++":") <+> align (commalist [ fun f | f <- fs]) 86 | ppTheory (Equations rs) = align $ vcat [ppRule "==" r | r <- rs] 87 | ppRules rp = align $ vcat $ 88 | [ppRule "->" r | r <- strictRules rp] 89 | ++ [ppRule "->=" r | r <- weakRules rp] 90 | ppRule sep = prettyRule (text sep) fun var 91 | 92 | instance (Eq f, Eq v, Pretty f, Pretty v) => Pretty (Problem f v) where 93 | pretty = prettyProblem pretty pretty 94 | -------------------------------------------------------------------------------- /src/Data/Rewriting/Problem/Type.hs: -------------------------------------------------------------------------------- 1 | -- This file is part of the 'term-rewriting' library. It is licensed 2 | -- under an MIT license. See the accompanying 'LICENSE' file for details. 3 | -- 4 | -- Authors: Martin Avanzini, Christial Sternagel 5 | 6 | module Data.Rewriting.Problem.Type ( 7 | StartTerms (..), 8 | Strategy (..), 9 | RulesPair (..), 10 | Problem (..), 11 | Theory (..), 12 | allRules, 13 | map 14 | ) where 15 | 16 | import Prelude hiding (map) 17 | import qualified Prelude as P 18 | 19 | import Data.Rewriting.Rule (Rule (..)) 20 | import qualified Data.Rewriting.Rule as Rule 21 | 22 | data StartTerms = AllTerms 23 | | BasicTerms deriving (Eq, Show) 24 | 25 | data Strategy = Innermost 26 | | Full 27 | | Outermost deriving (Eq, Show) 28 | 29 | data RulesPair f v = RulesPair { strictRules :: [Rule f v] 30 | , weakRules :: [Rule f v] } deriving (Eq, Show) 31 | 32 | 33 | data Theory f v = SymbolProperty String [f] 34 | | Equations [Rule f v] deriving (Eq, Show) 35 | 36 | data Problem f v = Problem { startTerms :: StartTerms 37 | , strategy :: Strategy 38 | , theory :: Maybe [Theory f v] 39 | , rules :: RulesPair f v 40 | , variables :: [v] 41 | , symbols :: [f] 42 | , signature :: Maybe [(f, Int)] 43 | , comment :: Maybe String} deriving (Show) 44 | 45 | allRules :: RulesPair f v -> [Rule f v] 46 | allRules rp = strictRules rp ++ weakRules rp 47 | 48 | map :: (f -> f') -> (v -> v') -> Problem f v -> Problem f' v' 49 | map ffun fvar prob = 50 | Problem { startTerms = startTerms prob 51 | , strategy = strategy prob 52 | , theory = P.map (mapTheory ffun fvar) <$> theory prob 53 | , rules = mapRulesPair ffun fvar (rules prob) 54 | , variables = P.map fvar (variables prob) 55 | , symbols = P.map ffun (symbols prob) 56 | , signature = fmap (P.map (\(f, a) -> (ffun f, a))) (signature prob) 57 | , comment = comment prob} 58 | 59 | mapTheory :: (f -> f') -> (v -> v') -> Theory f v -> Theory f' v' 60 | mapTheory ffun _ (SymbolProperty p fs) = SymbolProperty p (P.map ffun fs) 61 | mapTheory ffun fvar (Equations rs) = Equations (P.map (Rule.map ffun fvar) rs) 62 | 63 | mapRulesPair :: (f -> f') -> (v -> v') -> RulesPair f v -> RulesPair f' v' 64 | mapRulesPair ffun fvar rp = 65 | RulesPair { strictRules = modify (strictRules rp) 66 | , weakRules = modify (weakRules rp)} 67 | where modify = P.map (Rule.map ffun fvar) 68 | -------------------------------------------------------------------------------- /src/Data/Rewriting/Rule.hs: -------------------------------------------------------------------------------- 1 | -- This file is part of the 'term-rewriting' library. It is licensed 2 | -- under an MIT license. See the accompanying 'LICENSE' file for details. 3 | -- 4 | -- Authors: Bertram Felgenhauer, Martin Avanzini 5 | 6 | module Data.Rewriting.Rule ( 7 | Rule (..), 8 | -- * Reexported modules 9 | module Data.Rewriting.Rule.Type, 10 | module Data.Rewriting.Rule.Ops, 11 | module Data.Rewriting.Rule.Pretty, 12 | ) where 13 | 14 | import Data.Rewriting.Rule.Type 15 | import Data.Rewriting.Rule.Ops 16 | import Data.Rewriting.Rule.Pretty 17 | -------------------------------------------------------------------------------- /src/Data/Rewriting/Rule/Ops.hs: -------------------------------------------------------------------------------- 1 | -- This file is part of the 'term-rewriting' library. It is licensed 2 | -- under an MIT license. See the accompanying 'LICENSE' file for details. 3 | -- 4 | -- Authors: Bertram Felgenhauer, Martin Avanzini 5 | 6 | module Data.Rewriting.Rule.Ops ( 7 | -- * Operations on Rules 8 | funs, 9 | funsDL, 10 | vars, 11 | varsDL, 12 | left, 13 | right, 14 | rename, 15 | -- * Predicates on Rules 16 | both, 17 | isLinear, isLeftLinear, isRightLinear, 18 | isGround, isLeftGround, isRightGround, 19 | isErasing, 20 | isCreating, 21 | isDuplicating, 22 | isCollapsing, 23 | isExpanding, 24 | isValid, 25 | isInstanceOf, 26 | isVariantOf, 27 | ) where 28 | 29 | import Data.Rewriting.Rule.Type 30 | import Data.Rewriting.Substitution (match, merge) 31 | import qualified Data.Rewriting.Term as Term 32 | 33 | import qualified Data.Set as S 34 | import qualified Data.MultiSet as MS 35 | import Data.Maybe 36 | 37 | -- | Test whether the given predicate is true for both sides of a rule. 38 | both :: (Term f v -> Bool) -> Rule f v -> Bool 39 | both p r = p (lhs r) && p (rhs r) 40 | 41 | -- | Apply a function to the lhs of a rule. 42 | left :: (Term f v -> a) -> Rule f v -> a 43 | left f = f . lhs 44 | 45 | -- | Apply a function to the rhs of a rule. 46 | right :: (Term f v -> a) -> Rule f v -> a 47 | right f = f . rhs 48 | 49 | 50 | -- | Lifting of 'Term.rename' to 'Rule': renames left- and right-hand sides. 51 | -- 52 | -- >>> rename (+ 1) $ Rule {lhs = (Fun 'f' [Var 1, Fun 'g' [Var 2]]), rhs = Fun 'g' [Var 1]} 53 | -- Rule {lhs = Fun 'f' [Var 2, Fun 'g' [Var 3]], rhs = Fun 'g' [Var 2]} 54 | rename :: (v -> v') -> Rule f v -> Rule f v' 55 | rename f rl = Rule (left (Term.rename f) rl) (right (Term.rename f) rl) 56 | 57 | 58 | -- | Lifting of 'Term.funs' to 'Rule': returns the list of function symbols 59 | -- in left- and right-hand sides. 60 | -- 61 | -- >>> funs $ Rule {lhs = Fun 'f' [Var 3, Fun 'g' [Fun 'f' []]], rhs = Fun 'h' [Fun 'f' []]} 62 | -- "fgfhf" 63 | funs :: Rule f v -> [f] 64 | funs = flip funsDL [] 65 | 66 | -- | Difference List version of 'funs'. 67 | -- We have @funsDL r vs = funs r ++ vs@. 68 | funsDL :: Rule f v -> [f] -> [f] 69 | funsDL r = Term.funsDL (lhs r) . Term.funsDL (rhs r) 70 | 71 | -- | Lifting of 'Term.vars' to 'Rule': returns the list of variables in 72 | -- left- and right-hand sides. 73 | -- 74 | -- >>> vars $ Rule {lhs = Fun 'g' [Var 3, Fun 'f' [Var 1, Var 2, Var 3]], rhs = Fun 'g' [Var 4, Var 3]} 75 | -- [3,1,2,3,4,3] 76 | vars :: Rule f v -> [v] 77 | vars = flip varsDL [] 78 | 79 | -- | Difference List version of 'vars'. 80 | -- We have @varsDL r vs = vars r ++ vs@. 81 | varsDL :: Rule f v -> [v] -> [v] 82 | varsDL r = Term.varsDL (lhs r) . Term.varsDL (rhs r) 83 | 84 | -- | Check whether both sides of the given rule are linear. 85 | isLinear :: Ord v => Rule f v -> Bool 86 | isLinear = both Term.isLinear 87 | 88 | -- | Check whether the left hand side of the given rule is linear. 89 | isLeftLinear :: Ord v => Rule f v -> Bool 90 | isLeftLinear = left Term.isLinear 91 | 92 | -- | Check whether the right hand side of the given rule is linear. 93 | isRightLinear :: Ord v => Rule f v -> Bool 94 | isRightLinear = right Term.isLinear 95 | 96 | -- | Check whether both sides of the given rule is are ground terms. 97 | isGround :: Rule f v -> Bool 98 | isGround = both Term.isGround 99 | 100 | -- | Check whether the left hand side of the given rule is a ground term. 101 | isLeftGround :: Rule f v -> Bool 102 | isLeftGround = left Term.isGround 103 | 104 | -- | Check whether the right hand side of the given rule is a ground term. 105 | isRightGround :: Rule f v -> Bool 106 | isRightGround = right Term.isGround 107 | 108 | -- auxiliary: return variables of term as Set 109 | varsS :: Ord v => Term f v -> S.Set v 110 | varsS = S.fromList . Term.vars 111 | 112 | -- | Check whether the given rule is erasing, i.e., if some variable 113 | -- occurs in the left hand side but not in the right hand side. 114 | isErasing :: Ord v => Rule f v -> Bool 115 | isErasing r = not $ varsS (lhs r) `S.isSubsetOf` varsS (rhs r) 116 | 117 | -- | Check whether the given rule is creating, i.e., if some variable 118 | -- occurs in its right hand side that does not occur in its left hand side. 119 | -- 120 | -- This is the dual of 'isErasing'. The term /creating/ is non-standard. 121 | -- Creating rules are usually forbidden. See also 'isValid'. 122 | isCreating :: Ord v => Rule f v -> Bool 123 | isCreating r = not $ varsS (rhs r) `S.isSubsetOf` varsS (lhs r) 124 | 125 | -- auxiliary: return variables of term as MultiSet 126 | varsMS :: Ord v => Term f v -> MS.MultiSet v 127 | varsMS = MS.fromList . Term.vars 128 | 129 | -- | Check whether the given rule is duplicating, i.e., if some variable 130 | -- occurs more often in its right hand side than in its left hand side. 131 | isDuplicating :: Ord v => Rule f v -> Bool 132 | isDuplicating r = not $ varsMS (rhs r) `MS.isSubsetOf` varsMS (lhs r) 133 | 134 | -- | Check whether the given rule is collapsing, i.e., if its right 135 | -- hand side is a variable. 136 | isCollapsing :: Rule f v -> Bool 137 | isCollapsing = Term.isVar . rhs 138 | 139 | -- | Check whether the given rule is expanding, i.e., if its left hand 140 | -- sides is a variable. 141 | -- 142 | -- This is the dual of 'isCollapsing'. The term /expanding/ is non-standard. 143 | -- Expanding rules are usually forbidden. See also 'isValid'. 144 | isExpanding :: Rule f v -> Bool 145 | isExpanding = Term.isVar . lhs 146 | 147 | -- | Check whether the given rule is non-creating and non-expanding. 148 | -- See also 'isCreating' and 'isExpanding' 149 | isValid :: Ord v => Rule f v -> Bool 150 | isValid r = not (isCreating r) && not (isExpanding r) 151 | 152 | -- | Check whether the first rule is an instance of the second rule. 153 | isInstanceOf :: (Eq f, Ord v, Ord v') => Rule f v -> Rule f v' -> Bool 154 | isInstanceOf r r' = case (match (lhs r') (lhs r), match (rhs r') (rhs r)) of 155 | (Just s, Just s') -> isJust (merge s s') 156 | _ -> False 157 | 158 | -- | Check whether two rules are variants of each other. 159 | isVariantOf :: (Eq f, Ord v, Ord v') => Rule f v -> Rule f v' -> Bool 160 | isVariantOf t u = isInstanceOf t u && isInstanceOf u t 161 | -------------------------------------------------------------------------------- /src/Data/Rewriting/Rule/Pretty.hs: -------------------------------------------------------------------------------- 1 | -- This file is part of the 'term-rewriting' library. It is licensed 2 | -- under an MIT license. See the accompanying 'LICENSE' file for details. 3 | -- 4 | -- Authors: Martin Avanzini 5 | 6 | module Data.Rewriting.Rule.Pretty ( 7 | prettyRule 8 | ) where 9 | 10 | import Data.Rewriting.Rule.Type 11 | import Data.Rewriting.Term (prettyTerm) 12 | 13 | import Text.PrettyPrint.ANSI.Leijen 14 | 15 | prettyRule :: Doc -> (f -> Doc) -> (v -> Doc) -> Rule f v -> Doc 16 | prettyRule arr fun var (Rule l r) = hang 2 $ term l <+> arr term r where 17 | term = prettyTerm fun var 18 | 19 | instance (Pretty f, Pretty v) => Pretty (Rule f v) where 20 | pretty = prettyRule (text "->") pretty pretty 21 | 22 | -------------------------------------------------------------------------------- /src/Data/Rewriting/Rule/Type.hs: -------------------------------------------------------------------------------- 1 | -- This file is part of the 'term-rewriting' library. It is licensed 2 | -- under an MIT license. See the accompanying 'LICENSE' file for details. 3 | -- 4 | -- Authors: Bertram Felgenhauer 5 | 6 | module Data.Rewriting.Rule.Type ( 7 | module Data.Rewriting.Term.Type, 8 | Rule (..), 9 | map, 10 | mapSides 11 | ) where 12 | 13 | import Prelude hiding (map) 14 | import Data.Rewriting.Term.Type hiding (map, fold) 15 | import qualified Data.Rewriting.Term.Type as T 16 | 17 | -- | Rewrite rule with left-hand side and right-hand side. 18 | data Rule f v = Rule { lhs :: Term f v, rhs :: Term f v } 19 | deriving (Ord, Eq, Show) 20 | 21 | 22 | mapSides :: (Term f v -> Term f' v') -> Rule f v -> Rule f' v' 23 | mapSides f r = Rule{ lhs = f (lhs r), rhs = f (rhs r) } 24 | 25 | map :: (f -> f') -> (v -> v') -> Rule f v -> Rule f' v' 26 | map f v = mapSides (T.map f v) 27 | 28 | -------------------------------------------------------------------------------- /src/Data/Rewriting/Rules.hs: -------------------------------------------------------------------------------- 1 | -- This file is part of the 'term-rewriting' library. It is licensed 2 | -- under an MIT license. See the accompanying 'LICENSE' file for details. 3 | -- 4 | -- Authors: Bertram Felgenhauer, Martin Avanzini 5 | 6 | -- | Operations on lists of rules. 7 | -- 8 | -- See also "Data.Rewriting.CriticalPair" 9 | module Data.Rewriting.Rules ( 10 | -- * Important operations 11 | fullRewrite, 12 | -- * Reexported modules 13 | module Data.Rewriting.Rules.Rewrite, 14 | module Data.Rewriting.Rules.Ops, 15 | ) where 16 | 17 | import Data.Rewriting.Rules.Ops 18 | import Data.Rewriting.Rules.Rewrite hiding (nested, listContexts) 19 | 20 | 21 | 22 | 23 | -------------------------------------------------------------------------------- /src/Data/Rewriting/Rules/Ops.hs: -------------------------------------------------------------------------------- 1 | -- This file is part of the 'term-rewriting' library. It is licensed 2 | -- under an MIT license. See the accompanying 'LICENSE' file for details. 3 | -- 4 | -- Authors: Martin Avanzini, Bertram Felgenhauer 5 | 6 | module Data.Rewriting.Rules.Ops ( 7 | -- * Operations on Rules 8 | funs, 9 | funsDL, 10 | vars, 11 | varsDL, 12 | lhss, 13 | rhss, 14 | map, 15 | restrictFuns, 16 | -- * Predicates on Rules 17 | isLinear, isLeftLinear, isRightLinear, 18 | isGround, isLeftGround, isRightGround, 19 | isErasing, 20 | isCreating, 21 | isExpanding, 22 | isDuplicating, 23 | isCollapsing, 24 | isValid, 25 | ) where 26 | 27 | import Prelude hiding (map) 28 | import qualified Prelude as P 29 | import Data.Rewriting.Rule (Rule) 30 | import Data.Rewriting.Term (Term) 31 | import qualified Data.Rewriting.Term as Term 32 | import qualified Data.Rewriting.Rule as Rule 33 | 34 | 35 | -- | @lhss rs@ returns the list of left-hand sides of @rs@ 36 | lhss :: [Rule f v] -> [Term f v] 37 | lhss = P.map Rule.lhs 38 | 39 | -- | @lhss rs@ returns the list of right-hand sides of @rs@ 40 | rhss :: [Rule f v] -> [Term f v] 41 | rhss = P.map Rule.rhs 42 | 43 | -- | Lifting of Term.'Term.funs' to list of rules. 44 | funs :: [Rule f v] -> [f] 45 | funs = flip funsDL [] 46 | 47 | -- | Difference List version of 'funs'. 48 | -- We have @funsDL r vs = funs r ++ vs@. 49 | funsDL :: [Rule f v] -> [f] -> [f] 50 | funsDL rs fs = foldr Rule.funsDL fs rs 51 | 52 | -- | Lifting of Term.'Term.vars' to list of rules. 53 | vars :: [Rule f v] -> [v] 54 | vars = flip varsDL [] 55 | 56 | -- | Lifting of Rule.'Rule.map' to list of rules. 57 | map :: (f -> f') -> (v -> v') -> [Rule f v] -> [Rule f' v'] 58 | map f v = P.map (Rule.map f v) 59 | 60 | -- | Difference List version of 'vars'. 61 | -- We have @varsDL r vs = vars r ++ vs@. 62 | varsDL :: [Rule f v] -> [v] -> [v] 63 | varsDL rs fs = foldr Rule.varsDL fs rs 64 | 65 | -- | Returns 'True' iff all given rules satisfy 'Rule.isLinear' 66 | isLinear :: Ord v => [Rule f v] -> Bool 67 | isLinear = all Rule.isLinear 68 | 69 | -- | Returns 'True' iff all given rules satisfy 'Rule.isLeftLinear' 70 | isLeftLinear :: Ord v => [Rule f v] -> Bool 71 | isLeftLinear = all Rule.isLeftLinear 72 | 73 | -- | Returns 'True' iff all given rules satisfy 'Rule.isRightLinear' 74 | isRightLinear :: Ord v => [Rule f v] -> Bool 75 | isRightLinear = all Rule.isRightLinear 76 | 77 | -- | Returns 'True' iff all given rules satisfy 'Rule.isGroundLinear' 78 | isGround :: [Rule f v] -> Bool 79 | isGround = all Rule.isGround 80 | 81 | -- | Returns 'True' iff all given rules satisfy 'Rule.isLeftGround' 82 | isLeftGround :: [Rule f v] -> Bool 83 | isLeftGround = all Rule.isLeftGround 84 | 85 | -- | Returns 'True' iff all given rules satisfy 'Rule.isRightGround' 86 | isRightGround :: [Rule f v] -> Bool 87 | isRightGround = all Rule.isRightGround 88 | 89 | -- | Returns 'True' iff any of the given rules satisfy 'Rule.isErasing' 90 | isErasing :: Ord v => [Rule f v] -> Bool 91 | isErasing = any Rule.isErasing 92 | 93 | -- | Returns 'True' iff any of the given rules satisfy 'Rule.isCreating' 94 | isCreating :: Ord v => [Rule f v] -> Bool 95 | isCreating = any Rule.isCreating 96 | 97 | -- | Returns 'True' iff any of the given rules satisfy 'Rule.isDuplicating' 98 | isDuplicating :: Ord v => [Rule f v] -> Bool 99 | isDuplicating = any Rule.isDuplicating 100 | 101 | -- | Returns 'True' iff any of the given rules satisfy 'Rule.isCollapsing' 102 | isCollapsing :: [Rule f v] -> Bool 103 | isCollapsing = any Rule.isCollapsing 104 | 105 | -- | Returns 'True' iff any of the given rules satisfy 'Rule.isExpanding' 106 | isExpanding :: [Rule f v] -> Bool 107 | isExpanding = any Rule.isExpanding 108 | 109 | -- | Returns 'True' iff all rules satisfy 'Rule.isValid' 110 | isValid :: Ord v => [Rule f v] -> Bool 111 | isValid = all Rule.isValid 112 | 113 | -- | Restrict the rules to those only using function symbols satisfying 114 | -- the given predicate. 115 | restrictFuns :: (f -> Bool) -> [Rule f v] -> [Rule f v] 116 | restrictFuns funp = filter (all funp . Rule.funs) 117 | -------------------------------------------------------------------------------- /src/Data/Rewriting/Rules/Rewrite.hs: -------------------------------------------------------------------------------- 1 | -- This file is part of the 'term-rewriting' library. It is licensed 2 | -- under an MIT license. See the accompanying 'LICENSE' file for details. 3 | -- 4 | -- Authors: Bertram Felgenhauer 5 | 6 | {-# LANGUAGE BangPatterns #-} 7 | -- | 8 | -- Simple rewriting. 9 | -- 10 | -- Note: The rules are assumed to be non-creating, i.e., variables on the 11 | -- rhs should also occur on the lhs. Rules violating this constraint 12 | -- will have no effect. 13 | module Data.Rewriting.Rules.Rewrite ( 14 | Reduct (..), 15 | Strategy, 16 | fullRewrite, 17 | outerRewrite, 18 | innerRewrite, 19 | rootRewrite, 20 | -- * utilities not reexported from "Data.Rewriting.Rules" 21 | nested, 22 | listContexts, 23 | ) where 24 | 25 | import Data.Rewriting.Substitution 26 | import Data.Rewriting.Pos 27 | import Data.Rewriting.Rule 28 | 29 | import Data.Maybe 30 | 31 | -- | A reduct. It contains the resulting term, the position that the term 32 | -- was rewritten at, and the applied rule. 33 | data Reduct f v v' = Reduct { 34 | result :: Term f v, 35 | pos :: Pos, 36 | rule :: Rule f v', 37 | subst :: GSubst v' f v 38 | } 39 | 40 | -- | A rewrite strategy. 41 | type Strategy f v v' = Term f v -> [Reduct f v v'] 42 | 43 | -- | Full rewriting: Apply rules anywhere in the term. 44 | -- 45 | -- Reducts are returned in pre-order: the first is a leftmost, outermost redex. 46 | fullRewrite :: (Ord v', Eq v, Eq f) 47 | => [Rule f v'] -> Strategy f v v' 48 | fullRewrite trs t = rootRewrite trs t ++ nested (fullRewrite trs) t 49 | 50 | -- | Outer rewriting: Apply rules at outermost redexes. 51 | -- 52 | -- Reducts are returned in left to right order. 53 | outerRewrite :: (Ord v', Eq v, Eq f) 54 | => [Rule f v'] -> Strategy f v v' 55 | outerRewrite trs t = case rootRewrite trs t of 56 | [] -> nested (outerRewrite trs) t 57 | rs -> rs 58 | 59 | -- | Inner rewriting: Apply rules at innermost redexes. 60 | -- 61 | -- Reducts are returned in left to right order. 62 | innerRewrite :: (Ord v', Eq v, Eq f) 63 | => [Rule f v'] -> Strategy f v v' 64 | innerRewrite trs t = case nested (innerRewrite trs) t of 65 | [] -> rootRewrite trs t 66 | rs -> rs 67 | 68 | -- | Root rewriting: Apply rules only at the root of the term. 69 | -- 70 | -- This is mainly useful as a building block for various rewriting strategies. 71 | rootRewrite :: (Ord v', Eq v, Eq f) 72 | => [Rule f v'] -> Strategy f v v' 73 | rootRewrite trs t = do 74 | r <- trs 75 | s <- maybeToList $ match (lhs r) t 76 | t' <- maybeToList $ gApply s (rhs r) 77 | return Reduct{ result = t', pos = [], rule = r, subst = s } 78 | 79 | -- | Nested rewriting: Apply a rewriting strategy to all arguments of a 80 | -- function symbol, left to right. For variables, the result will be empty. 81 | -- 82 | -- This is another building block for rewriting strategies. 83 | nested :: Strategy f v v' -> Strategy f v v' 84 | nested _ (Var _) = [] 85 | nested s (Fun f ts) = do 86 | (n, cl, t) <- listContexts ts 87 | (\r -> r{ result = Fun f (cl (result r)), pos = n : pos r }) `fmap` s t 88 | 89 | -- | Return a list of contexts of a list. Each returned element is an element 90 | -- index (starting from 0), a function that replaces the list element by a 91 | -- new one, and the original element. 92 | listContexts :: [a] -> [(Int, a -> [a], a)] 93 | listContexts = go 0 id where 94 | go !n f [] = [] 95 | go !n f (x:xs) = (n, f . (: xs), x) : go (n+1) (f . (x:)) xs 96 | -------------------------------------------------------------------------------- /src/Data/Rewriting/Signature.hs: -------------------------------------------------------------------------------- 1 | -- This file is part of the 'term-rewriting' library. It is licensed 2 | -- under an MIT license. See the accompanying 'LICENSE' file for details. 3 | -- 4 | -- Authors: Bertram Felgenhauer 5 | 6 | -- Here be dragons. (What are signatures exactly?) 7 | 8 | -- fix some signature type. but which? 9 | 10 | type Signature f = Map f Int -- or Set f? 11 | data TRS f v = TRS { rules :: [Rule f v], sig :: Signature f } 12 | 13 | restrict :: Signature f -> [Rules f v] -> [Rules f v] 14 | restrict = undefined 15 | 16 | -- or define some extensible signature mechanism (overengineering alert) 17 | 18 | class HasIsFunction sig f where 19 | isFunction :: sig -> f -> Bool 20 | 21 | class HasIsFunction sig f => HasArity sig f where 22 | arity :: sig -> f -> Int 23 | 24 | restrict :: HasIsFunction sig f => sig -> [Rules f v] -> [Rules f v] 25 | restrict = undefined 26 | 27 | -- or use type families 28 | 29 | type family Signature f 30 | 31 | -- ...and now? type classes? 32 | 33 | -- or ... 34 | -------------------------------------------------------------------------------- /src/Data/Rewriting/Substitution.hs: -------------------------------------------------------------------------------- 1 | -- This file is part of the 'term-rewriting' library. It is licensed 2 | -- under an MIT license. See the accompanying 'LICENSE' file for details. 3 | -- 4 | -- Authors: Bertram Felgenhauer, Martin Avanzini 5 | 6 | module Data.Rewriting.Substitution ( 7 | GSubst, 8 | Subst, 9 | -- * Important operations 10 | gApply, 11 | apply, 12 | compose, 13 | -- * Reexported modules 14 | module Data.Rewriting.Substitution.Type, 15 | module Data.Rewriting.Substitution.Ops, 16 | module Data.Rewriting.Substitution.Match, 17 | module Data.Rewriting.Substitution.Unify, 18 | module Data.Rewriting.Substitution.Pretty, 19 | module Data.Rewriting.Substitution.Parse, 20 | ) where 21 | 22 | import Data.Rewriting.Substitution.Type hiding (fromMap, toMap) 23 | import Data.Rewriting.Substitution.Ops 24 | import Data.Rewriting.Substitution.Match 25 | import Data.Rewriting.Substitution.Unify 26 | import Data.Rewriting.Substitution.Pretty 27 | import Data.Rewriting.Substitution.Parse 28 | -------------------------------------------------------------------------------- /src/Data/Rewriting/Substitution/Match.hs: -------------------------------------------------------------------------------- 1 | -- This file is part of the 'term-rewriting' library. It is licensed 2 | -- under an MIT license. See the accompanying 'LICENSE' file for details. 3 | -- 4 | -- Authors: Bertram Felgenhauer 5 | 6 | module Data.Rewriting.Substitution.Match ( 7 | match, 8 | ) where 9 | 10 | import Data.Rewriting.Substitution.Type 11 | import qualified Data.Rewriting.Term.Type as Term 12 | import Data.Rewriting.Term.Type (Term (..)) 13 | 14 | import qualified Data.Map as M 15 | import Control.Monad 16 | import Control.Applicative 17 | 18 | -- | Match two terms. If matching succeeds, return the resulting subtitution. 19 | -- We have the following property: 20 | -- 21 | -- > match t u == Just s ==> apply s t == gapply s t == u 22 | match :: (Eq f, Ord v, Eq v') => Term f v -> Term f v' -> Maybe (GSubst v f v') 23 | match t u = fromMap <$> go t u (M.empty) where 24 | go (Var v) t subst = case M.lookup v subst of 25 | Nothing -> Just (M.insert v t subst) 26 | Just t' | t == t' -> Just subst 27 | _ -> Nothing 28 | go (Fun f ts) (Fun f' ts') subst 29 | | f /= f' || length ts /= length ts' = Nothing 30 | | otherwise = composeM (zipWith go ts ts') subst 31 | go _ _ _ = Nothing 32 | 33 | -- TODO: move to Utils module 34 | composeM :: Monad m => [a -> m a] -> a -> m a 35 | composeM = foldr (>=>) return 36 | -------------------------------------------------------------------------------- /src/Data/Rewriting/Substitution/Ops.hs: -------------------------------------------------------------------------------- 1 | -- This file is part of the 'term-rewriting' library. It is licensed 2 | -- under an MIT license. See the accompanying 'LICENSE' file for details. 3 | -- 4 | -- Authors: Bertram Felgenhauer, Christian Sternagel 5 | 6 | module Data.Rewriting.Substitution.Ops ( 7 | apply, 8 | applyRule, 9 | applyCtxt, 10 | gApply, 11 | compose, 12 | merge, 13 | ) where 14 | 15 | import Data.Rewriting.Substitution.Type 16 | import qualified Data.Rewriting.Term.Type as Term 17 | import Data.Rewriting.Term.Type (Term (..)) 18 | import Data.Rewriting.Rule.Type (Rule (..)) 19 | import Data.Rewriting.Context.Type (Ctxt (..)) 20 | import qualified Data.Map as M 21 | import Control.Monad 22 | import Control.Applicative 23 | 24 | -- | Apply a substitution, assuming that it's the identity on variables not 25 | -- mentionend in the substitution. 26 | apply :: (Ord v) => Subst f v -> Term f v -> Term f v 27 | apply subst = Term.fold var fun where 28 | var v = M.findWithDefault (Var v) v (toMap subst) 29 | fun = Fun 30 | 31 | -- | Liftting of 'apply' to rules: applies the given substitution to left- and right-hand side. 32 | applyRule :: (Ord v) => Subst f v -> Rule f v -> Rule f v 33 | applyRule subst rl = Rule (apply subst (lhs rl)) (apply subst (rhs rl)) 34 | 35 | -- | Liftting of 'apply' to contexts. 36 | applyCtxt :: Ord v => Subst f v -> Ctxt f v -> Ctxt f v 37 | applyCtxt _ Hole = Hole 38 | applyCtxt subst (Ctxt f ts1 ctxt ts2) = 39 | Ctxt f (map (apply subst) ts1) (applyCtxt subst ctxt) (map (apply subst) ts2) 40 | 41 | 42 | -- | Apply a substitution, assuming that it's total. If the term contains 43 | -- a variable not defined by the substitution, return 'Nothing'. 44 | gApply :: (Ord v) => GSubst v f v' -> Term f v -> Maybe (Term f v') 45 | gApply subst = Term.fold var fun where 46 | var v = M.lookup v (toMap subst) 47 | fun f ts = Fun f <$> sequence ts 48 | 49 | -- | Compose substitutions. We have 50 | -- 51 | -- > (s1 `compose` s2) `apply` t = s1 `apply` (s2 `apply` t). 52 | compose :: (Ord v) => Subst f v -> Subst f v -> Subst f v 53 | compose subst subst' = 54 | fromMap (M.unionWith const (apply subst <$> toMap subst') (toMap subst)) 55 | 56 | -- | Merge two substitutions. The operation fails if some variable is 57 | -- different terms by the substitutions. 58 | merge :: (Ord v, Eq f, Eq v') 59 | => GSubst v f v' -> GSubst v f v' -> Maybe (GSubst v f v') 60 | merge subst subst' = do 61 | guard $ and (M.elems (M.intersectionWith (==) (toMap subst) (toMap subst'))) 62 | return $ fromMap $ M.union (toMap subst) (toMap subst') 63 | -------------------------------------------------------------------------------- /src/Data/Rewriting/Substitution/Parse.hs: -------------------------------------------------------------------------------- 1 | -- This file is part of the 'term-rewriting' library. It is licensed 2 | -- under an MIT license. See the accompanying 'LICENSE' file for details. 3 | -- 4 | -- Authors: Christian Sternagel 5 | 6 | {-# LANGUAGE FlexibleContexts#-} 7 | module Data.Rewriting.Substitution.Parse ( 8 | fromString, 9 | parse, 10 | parseIO 11 | ) where 12 | 13 | import Data.Rewriting.Utils.Parse (ident, lex, par) 14 | import Prelude hiding (lex) 15 | import qualified Data.Map as Map 16 | import Data.Rewriting.Term.Type 17 | import Data.Rewriting.Substitution.Type 18 | import qualified Data.Rewriting.Term.Parse as Term 19 | import Control.Monad 20 | import Text.Parsec hiding (parse) 21 | import Text.Parsec.Prim (runP) 22 | 23 | 24 | parse :: (Ord v) => 25 | Parsec String u f -> Parsec String u v -> Parsec String u (Subst f v) 26 | parse fun var = par $ liftM (fromMap . Map.fromList) bindings where 27 | bindings = binding fun var `sepBy` lex (char ',') 28 | 29 | 30 | binding :: Parsec String u f -> Parsec String u v -> Parsec String u (v, Term f v) 31 | binding fun var = liftM2 (,) var (slash >> term) "binding" where 32 | slash = lex $ char '/' 33 | term = Term.parse fun var 34 | 35 | 36 | fromString :: [String] -> String -> Either ParseError (Subst String String) 37 | fromString xs = runP (parse fun (var xs)) () "" where 38 | var = Term.parseVar $ ident "(),{}/" [] 39 | fun = Term.parseFun $ ident "(),{}" [] 40 | 41 | 42 | parseIO :: [String] -> String -> IO (Subst String String) 43 | parseIO xs input = case fromString xs input of 44 | Left err -> do { putStr "parse error at "; print err; mzero } 45 | Right t -> return t 46 | -------------------------------------------------------------------------------- /src/Data/Rewriting/Substitution/Pretty.hs: -------------------------------------------------------------------------------- 1 | -- This file is part of the 'term-rewriting' library. It is licensed 2 | -- under an MIT license. See the accompanying 'LICENSE' file for details. 3 | -- 4 | -- Authors: Martin Avanzini 5 | 6 | {-# LANGUAGE TypeSynonymInstances, FlexibleInstances #-} 7 | module Data.Rewriting.Substitution.Pretty ( 8 | prettySubst 9 | ) where 10 | 11 | import Data.Rewriting.Substitution.Type 12 | import Data.Rewriting.Term (prettyTerm) 13 | import qualified Data.Map as M 14 | 15 | import Text.PrettyPrint.ANSI.Leijen 16 | 17 | prettyGSubst :: (v -> Doc) -> (f -> Doc) -> (v' -> Doc) -> GSubst v f v' -> Doc 18 | prettyGSubst var fun var' subst = 19 | encloseSep lbrace rbrace comma [ppBinding v t | (v,t) <- M.toList $ toMap subst] 20 | where ppBinding v t = var v <> text "/" <> prettyTerm fun var' t 21 | 22 | prettySubst :: (f -> Doc) -> (v -> Doc) -> Subst f v -> Doc 23 | prettySubst fun var = prettyGSubst var fun var 24 | 25 | instance (Pretty v, Pretty f, Pretty v') => Pretty (GSubst v f v') where 26 | pretty = prettyGSubst pretty pretty pretty 27 | -------------------------------------------------------------------------------- /src/Data/Rewriting/Substitution/Type.hs: -------------------------------------------------------------------------------- 1 | -- This file is part of the 'term-rewriting' library. It is licensed 2 | -- under an MIT license. See the accompanying 'LICENSE' file for details. 3 | -- 4 | -- Authors: Bertram Felgenhauer 5 | 6 | module Data.Rewriting.Substitution.Type ( 7 | Subst, 8 | GSubst, 9 | -- * utilities not reexported from 'Data.Rewriting.Substitution' 10 | fromMap, 11 | toMap, 12 | ) where 13 | 14 | import Data.Rewriting.Term.Type 15 | import qualified Data.Map as M 16 | 17 | 18 | -- | A substitution, mapping variables to terms. Substitutions are 19 | -- equal to the identity almost everywhere. 20 | type Subst f v = GSubst v f v 21 | 22 | -- | A generalised? substitution: a finite, partial map from variables 23 | -- to terms with a different variable type. 24 | newtype GSubst v f v' = GS { unGS :: M.Map v (Term f v') } 25 | deriving Show 26 | 27 | -- Do not derive Eq: Depending on the interpretation, v / Var v 28 | -- will have to be ignored or not. 29 | 30 | fromMap :: M.Map v (Term f v') -> GSubst v f v' 31 | fromMap = GS 32 | 33 | toMap :: GSubst v f v' -> M.Map v (Term f v') 34 | toMap = unGS 35 | -------------------------------------------------------------------------------- /src/Data/Rewriting/Substitution/Unify.hs: -------------------------------------------------------------------------------- 1 | -- This file is part of the 'term-rewriting' library. It is licensed 2 | -- under an MIT license. See the accompanying 'LICENSE' file for details. 3 | -- 4 | -- Authors: Bertram Felgenhauer 5 | 6 | {-# LANGUAGE FlexibleContexts #-} 7 | 8 | module Data.Rewriting.Substitution.Unify ( 9 | unify, 10 | unifyRef, 11 | ) where 12 | 13 | import Data.Rewriting.Substitution.Type 14 | import Data.Rewriting.Substitution.Ops (apply) 15 | import qualified Data.Rewriting.Term.Ops as Term 16 | import qualified Data.Rewriting.Term.Type as Term 17 | import Data.Rewriting.Term.Type (Term (..)) 18 | 19 | import qualified Data.Map as M 20 | import qualified Control.Monad.Union as UM 21 | import qualified Data.Union as U 22 | import Control.Monad.State 23 | import Control.Monad.ST 24 | import Control.Applicative 25 | import Control.Arrow 26 | import Data.Array.ST 27 | import Data.Array 28 | import Data.Maybe 29 | import Data.Word 30 | 31 | -- The setup is as follows: 32 | -- 33 | -- We have a disjoint set forest, in which every node represents some 34 | -- subterm of our unification problem. Each node is annotated by a 35 | -- description of the term which may refer to other nodes. So we actually 36 | -- have a graph, and an efficient implementation for joining nodes in 37 | -- the graph, curtesy of the union find data structure. We also maintain 38 | -- a map of variables encountered so far to their allocated node. 39 | 40 | type UnifyM f v a = StateT (M.Map v U.Node) (UM.UnionM (Annot f v)) a 41 | 42 | -- Each node can either represent 43 | -- - a variable (in which case this is the only node representing that variable) 44 | -- - an *expanded* function application with arguments represented by nodes, 45 | -- - or a *pending* function application with normal terms as arguments, 46 | -- not yet represented in the disjoint set forest. 47 | 48 | data Annot f v = VarA v | FunA f [U.Node] | FunP f [Term f v] 49 | 50 | -- Extract function symbol and arity from (non-variable) annotation. 51 | funari :: Annot f v -> (f, Int) 52 | funari (FunA f ns) = (f, length ns) 53 | funari (FunP f ts) = (f, length ts) 54 | 55 | -- Solve a system of equations between terms that are represented by nodes. 56 | solve :: (Eq f, Ord v) => [(U.Node, U.Node)] -> UnifyM f v Bool 57 | solve [] = return True 58 | solve ((t, u) : xs) = do 59 | (t, t') <- UM.lookup t 60 | (u, u') <- UM.lookup u 61 | -- if t == u then the nodes are already equivalent. 62 | if t == u then solve xs else case (t', u') of 63 | (VarA _, _) -> do 64 | -- assign term to variable 65 | UM.merge (\_ _ -> (u', ())) t u 66 | solve xs 67 | (_, VarA _) -> do 68 | -- assign term to variable 69 | UM.merge (\_ _ -> (t', ())) t u 70 | solve xs 71 | _ | funari t' == funari u' -> 72 | -- matching function applications: expand ... 73 | -- note: avoid `do` notation because `FunA _ ts` is a "failable" 74 | -- pattern and `UnionM` doesn't have a `MonadFail` instance; 75 | -- cf. https://wiki.haskell.org/MonadFail_Proposal 76 | expand t t' >>= \(FunA _ ts) -> 77 | expand u u' >>= \(FunA _ us) -> 78 | UM.merge (\t _ -> (t, ())) t u >> 79 | -- ... and equate the argument lists. 80 | solve (zip ts us ++ xs) 81 | _ -> do 82 | -- mismatch, fail. 83 | return False 84 | 85 | -- Expand a node: If the node is currently a pending function application, 86 | -- turn it into an expanded one. 87 | -- The second argument must equal the current annotation of the node. 88 | expand :: (Ord v) => U.Node -> Annot f v -> UnifyM f v (Annot f v) 89 | expand n (FunP f ts) = do 90 | ann <- FunA f <$> mapM mkNode ts 91 | UM.annotate n ann 92 | return ann 93 | expand n ann = return ann 94 | 95 | -- Create a new node representing a given term. 96 | -- Variable nodes are shared whenever possible. 97 | -- Function applications will be pending initially. 98 | mkNode :: (Ord v) => Term f v -> UnifyM f v U.Node 99 | mkNode (Var v) = do 100 | n <- gets (M.lookup v) 101 | case n of 102 | Just n -> return n 103 | Nothing -> do 104 | n <- UM.new (VarA v) 105 | modify (M.insert v n) 106 | return n 107 | mkNode (Fun f ts) = UM.new (FunP f ts) 108 | 109 | -- | Unify two terms. If unification succeeds, return a most general unifier 110 | -- of the given terms. We have the following property: 111 | -- 112 | -- > unify t u == Just s ==> apply s t == apply s u 113 | -- 114 | -- /O(n log(n))/, where /n/ is the apparent size of the arguments. Note that 115 | -- the apparent size of the result may be exponential due to shared subterms. 116 | unify :: (Eq f, Ord v) => Term f v -> Term f v -> Maybe (Subst f v) 117 | unify t u = do 118 | let -- solve unification problem 119 | act = do 120 | t' <- mkNode t 121 | u' <- mkNode u 122 | success <- solve [(t', u')] 123 | return (t', success) 124 | (union, ((root, success), vmap)) = UM.run' $ runStateT act M.empty 125 | -- find the successors in the resulting graph 126 | succs n = case snd (U.lookup union n) of 127 | VarA v -> [] 128 | FunA f ns -> ns 129 | FunP f ts -> do v <- Term.vars =<< ts; maybeToList (M.lookup v vmap) 130 | guard $ success && acyclic (U.size union) succs root 131 | let -- build resulting substitution 132 | subst = fromMap $ fmap lookupNode vmap 133 | -- 'terms' maps representatives to their reconstructed terms 134 | terms = fmap mkTerm (UM.label union) 135 | -- look up a node in 'terms' 136 | lookupNode = (terms !) . U.fromNode . fst . U.lookup union 137 | -- translate annotation back to term 138 | mkTerm (VarA v) = Var v 139 | mkTerm (FunA f ns) = Fun f (fmap lookupNode ns) 140 | mkTerm (FunP f ts) = subst `apply` Fun f ts 141 | return subst 142 | 143 | -- Check whether the subgraph reachable from the given root is acyclic. 144 | -- This is done by a depth first search, where nodes are initially colored 145 | -- white (0), then grey (1) while their children are being visited and 146 | -- finally black (2) after the children have been processed completely. 147 | -- 148 | -- The subgraph is cyclic iff we encounter a grey node at some point. 149 | -- 150 | -- O(n) plus the cost of 'succs'; 'succs' is called at most once per node. 151 | acyclic :: Int -> (U.Node -> [U.Node]) -> U.Node -> Bool 152 | acyclic size succs root = runST $ do 153 | let t :: ST s (STUArray s Int Word8) 154 | t = undefined 155 | color <- newArray (0, size-1) 0 `asTypeOf` t 156 | let dfs n = do 157 | c <- readArray color (U.fromNode n) 158 | case c of 159 | 0 -> do 160 | writeArray color (U.fromNode n) 1 161 | flip (foldr andM) (map dfs (succs n)) $ do 162 | writeArray color (U.fromNode n) 2 163 | return True 164 | 1 -> return False 165 | 2 -> return True 166 | dfs root 167 | 168 | -- monadic, logical and with short-cut evaluation 169 | andM :: Monad m => m Bool -> m Bool -> m Bool 170 | andM a b = do 171 | a' <- a 172 | if a' then b else return False 173 | 174 | ------------------------------------------------------------------------------ 175 | -- Reference implementation 176 | 177 | -- | Unify two terms. This is a simple implementation for testing purposes, 178 | -- and may be removed in future versions of this library. 179 | unifyRef :: (Eq f, Ord v) => Term f v -> Term f v -> Maybe (Subst f v) 180 | unifyRef t u = fromMap <$> go [(t, u)] M.empty where 181 | go [] subst = Just subst 182 | go ((t, u) : xs) subst = case (t, u) of 183 | (Var v, t) -> add v t xs subst 184 | (t, Var v) -> add v t xs subst 185 | (Fun f ts, Fun f' ts') 186 | | f /= f' || length ts /= length ts' -> Nothing 187 | | otherwise -> go (zip ts ts' ++ xs) subst 188 | add v t xs subst 189 | | Var v == t = go xs subst 190 | | occurs v t = Nothing 191 | | otherwise = 192 | let app = apply (fromMap (M.singleton v t)) 193 | in go (fmap (app *** app) xs) (M.insert v t (fmap app subst)) 194 | occurs v t = v `elem` Term.vars t 195 | -------------------------------------------------------------------------------- /src/Data/Rewriting/Term.hs: -------------------------------------------------------------------------------- 1 | -- This file is part of the 'term-rewriting' library. It is licensed 2 | -- under an MIT license. See the accompanying 'LICENSE' file for details. 3 | -- 4 | -- Authors: Bertram Felgenhauer, Martin Avanzini 5 | 6 | module Data.Rewriting.Term ( 7 | Term (..), 8 | -- * Important operations 9 | fold, map, vars, funs, 10 | -- * Reexported modules 11 | module Data.Rewriting.Term.Type, 12 | module Data.Rewriting.Term.Ops, 13 | module Data.Rewriting.Term.Pretty, 14 | module Data.Rewriting.Term.Parse 15 | ) where 16 | 17 | import Prelude () 18 | import Data.Rewriting.Term.Type 19 | import Data.Rewriting.Term.Ops 20 | import Data.Rewriting.Term.Pretty 21 | import Data.Rewriting.Term.Parse 22 | -------------------------------------------------------------------------------- /src/Data/Rewriting/Term/Ops.hs: -------------------------------------------------------------------------------- 1 | -- This file is part of the 'term-rewriting' library. It is licensed 2 | -- under an MIT license. See the accompanying 'LICENSE' file for details. 3 | -- 4 | -- Authors: Martin Avanzini, Bertram Felgenhauer 5 | 6 | module Data.Rewriting.Term.Ops ( 7 | -- * Operations on Terms 8 | funs, 9 | funsDL, 10 | vars, 11 | varsDL, 12 | root, 13 | withArity, 14 | subtermAt, 15 | properSubterms, 16 | subterms, 17 | replaceAt, 18 | rename, 19 | -- * Predicates on Terms 20 | isVar, 21 | isFun, 22 | isGround, 23 | isLinear, 24 | isInstanceOf, 25 | isVariantOf, 26 | ) where 27 | 28 | import Data.Rewriting.Pos 29 | import Data.Rewriting.Term.Type as Term 30 | import Data.Rewriting.Substitution.Match 31 | import Data.Maybe 32 | import qualified Data.MultiSet as MS 33 | 34 | import Control.Monad (guard) 35 | 36 | -- | Annotate each occurrence of a function symbol with its actual arity, 37 | -- i.e., its number of arguments. 38 | -- 39 | -- >>> withArity (Fun 'f' [Var 1, Fun 'f' []]) 40 | -- Fun ('f',2) [Var 1,Fun ('f',0) []] 41 | withArity :: Term f v -> Term (f, Int) v 42 | withArity = Term.fold Var (\f ts -> Fun (f, length ts) ts) 43 | 44 | -- | Return the subterm at a given position. 45 | subtermAt :: Term f v -> Pos -> Maybe (Term f v) 46 | subtermAt t [] = Just t 47 | subtermAt (Fun _ ts) (p:ps) | p >= 0 && p < length ts = subtermAt (ts !! p) ps 48 | subtermAt _ _ = Nothing 49 | 50 | -- | Return the list of all proper subterms. 51 | -- 52 | -- >>> properSubterms (Fun 'g' [Fun 'f' [Var 1], Fun 'f' [Var 1]]) 53 | -- [Fun 'f' [Var 1],Var 1,Fun 'f' [Var 1],Var 1] 54 | properSubterms :: Term f v -> [Term f v] 55 | properSubterms (Var _) = [] 56 | properSubterms (Fun _ ts) = concatMap subterms ts 57 | 58 | -- | Return the list of all subterms. 59 | -- 60 | -- prop> subterms t = t : properSubterms t 61 | subterms :: Term f v -> [Term f v] 62 | subterms t = t : properSubterms t 63 | 64 | -- NOTE: replaceAt and Context.ofTerm have the same recusion structure; is 65 | -- there a nice higher-order function to abstract from it? 66 | 67 | -- | replace a subterm at a given position. 68 | replaceAt :: Term f v -> Pos -> Term f v -> Maybe (Term f v) 69 | replaceAt _ [] t' = Just t' 70 | replaceAt (Fun f ts) (i:p) t' = do 71 | guard (i >= 0 && i < length ts) 72 | let (ts1, t:ts2) = splitAt i ts 73 | t <- replaceAt t p t' 74 | return $ Fun f (ts1 ++ t : ts2) 75 | replaceAt _ _ _ = Nothing 76 | 77 | -- | Return the list of all variables in the term, from left to right. 78 | -- 79 | -- >>> vars (Fun 'g' [Var 3, Fun 'f' [Var 1, Var 2, Var 3]]) 80 | -- [3,1,2,3] 81 | vars :: Term f v -> [v] 82 | vars = flip varsDL [] 83 | 84 | -- | Difference List version of 'vars'. 85 | -- We have @varsDL t vs = vars t ++ vs@. 86 | 87 | varsDL :: Term f v -> [v] -> [v] 88 | varsDL = Term.fold (:) (const $ foldr (.) id) 89 | 90 | 91 | -- | Return the root symbol of the given term. 92 | -- 93 | -- >>> root (Fun 'f' [Var 1, Fun 'g' []]) 94 | -- Right 'f' 95 | -- 96 | -- >>> root (Var 1) 97 | -- Left 1 98 | root :: Term f v -> Either v f 99 | root (Fun f _) = Right f 100 | root (Var v) = Left v 101 | 102 | -- | Return the list of all function symbols in the term, from left to right. 103 | -- 104 | -- >>> funs (Fun 'f' [Var 3, Fun 'g' [Fun 'f' []]]) 105 | -- "fgf" 106 | funs :: Term f v -> [f] 107 | funs = flip funsDL [] 108 | 109 | -- | Difference List version of 'funs'. 110 | -- We have @funsDL t vs = funs t ++ vs@. 111 | funsDL :: Term f v -> [f] -> [f] 112 | funsDL = Term.fold (const id) (\f xs -> (f:) . foldr (.) id xs) 113 | 114 | -- | Return 'True' if the term is a variable, 'False' otherwise. 115 | isVar :: Term f v -> Bool 116 | isVar Var{} = True 117 | isVar Fun{} = False 118 | 119 | -- | Return 'True' if the term is a function application, 'False' otherwise. 120 | isFun :: Term f v -> Bool 121 | isFun Var{} = False 122 | isFun Fun{} = True 123 | 124 | -- | Check whether the term is a ground term, i.e., contains no variables. 125 | isGround :: Term f v -> Bool 126 | isGround = null . vars 127 | 128 | -- | Check whether the term is linear, i.e., contains each variable at most 129 | -- once. 130 | isLinear :: Ord v => Term f v -> Bool 131 | isLinear = all (\(_, c) -> c == 1) . MS.toOccurList . MS.fromList . vars 132 | 133 | -- | Check whether the first term is an instance of the second term. 134 | isInstanceOf :: (Eq f, Ord v, Ord v') => Term f v -> Term f v' -> Bool 135 | isInstanceOf t u = isJust (match u t) 136 | 137 | -- | Check whether two terms are variants of each other. 138 | isVariantOf :: (Eq f, Ord v, Ord v') => Term f v -> Term f v' -> Bool 139 | isVariantOf t u = isInstanceOf t u && isInstanceOf u t 140 | 141 | -- | Rename the variables in a term. 142 | -- 143 | -- >>> rename (+ 1) (Fun 'f' [Var 1, Fun 'g' [Var 2]]) 144 | -- (Fun 'f' [Var 2, Fun 'g' [Var 3]]) 145 | rename :: (v -> v') -> Term f v -> Term f v' 146 | rename = Term.map id 147 | -------------------------------------------------------------------------------- /src/Data/Rewriting/Term/Parse.hs: -------------------------------------------------------------------------------- 1 | -- This file is part of the 'term-rewriting' library. It is licensed 2 | -- under an MIT license. See the accompanying 'LICENSE' file for details. 3 | -- 4 | -- Authors: Christian Sternagel 5 | 6 | {-# LANGUAGE FlexibleContexts#-} 7 | module Data.Rewriting.Term.Parse ( 8 | fromString, 9 | parse, 10 | parseIO, 11 | parseFun, 12 | parseVar, 13 | parseWST, 14 | ) where 15 | 16 | import Data.Rewriting.Utils.Parse (lex, par, ident) 17 | import Prelude hiding (lex) 18 | import Control.Monad 19 | import Data.Rewriting.Term.Type 20 | import Text.Parsec hiding (parse) 21 | import Text.Parsec.Prim (runP) 22 | 23 | -- | Like 'fromString', but the result is wrapped in the IO monad, making this 24 | -- function useful for interactive testing. 25 | -- 26 | -- >>> parseIO ["x","y"] "f(x,c)" 27 | -- Fun "f" [Var "x",Fun "c" []] 28 | parseIO :: [String] -> String -> IO (Term String String) 29 | parseIO xs input = case fromString xs input of 30 | Left err -> do { putStr "parse error at "; print err; mzero } 31 | Right t -> return t 32 | 33 | -- | @fromString xs s@ parsers a term from the string @s@, where elements of @xs@ 34 | -- are considered as variables. 35 | fromString :: [String] -> String -> Either ParseError (Term String String) 36 | fromString xs = runP (parseWST xs) () "" 37 | 38 | 39 | -- | @parse fun var@ is a parser for terms, where @fun@ and @var@ are 40 | -- parsers for function symbols and variables, respectively. The @var@ parser 41 | -- has a higher priority than the @fun@ parser. Hence, whenever @var@ 42 | -- succeeds, the token is treated as a variable. 43 | -- 44 | -- Note that the user has to take care of handling trailing white space in 45 | -- @fun@ and @var@. 46 | parse :: Stream s m Char => ParsecT s u m f -> ParsecT s u m v 47 | -> ParsecT s u m (Term f v) 48 | parse fun var = term "term" where 49 | term = try (liftM Var var) <|> liftM2 Fun fun args 50 | args = par (sepBy term (lex $ char ',')) <|> return [] 51 | 52 | 53 | -- | @parseWST xs@ is a parser for terms following the conventions of the 54 | -- ancient ASCII input format of the termination competition: every @Char@ that 55 | -- is neither a white space (according to 'Data.Char.isSpace') nor one of '@(@', 56 | -- '@)@', or '@,@', is considered a letter. An identifier is a non-empty 57 | -- sequence of letters and it is treated as variable iff it is contained in 58 | -- @xs@. 59 | 60 | -- change name? 61 | parseWST :: Stream s m Char => [String] -> ParsecT s u m (Term String String) 62 | parseWST xs = parse (parseFun identWST) (parseVar identWST xs) 63 | 64 | -- | @parseFun ident@ parses function symbols defined by @ident@. 65 | parseFun :: Stream s m Char => ParsecT s u m String -> ParsecT s u m String 66 | parseFun id = lex id "function symbol" 67 | 68 | -- | @parseVar ident vars@ parses variables as defined by @ident@ and with the 69 | -- additional requirement that the result is a member of @vars@. 70 | parseVar :: Stream s m Char => 71 | ParsecT s u m String -> [String] -> ParsecT s u m String 72 | parseVar id xs = do { x <- lex id; guard (x `elem` xs); return x } 73 | "variable" 74 | 75 | identWST :: Stream s m Char => ParsecT s u m String 76 | -- COMMENT: according to http://www.lri.fr/~marche/tpdb/format.html '"' and some 77 | -- reserved strings are also not allowed, but I don't see the point 78 | identWST = ident "()," [] 79 | -------------------------------------------------------------------------------- /src/Data/Rewriting/Term/Pretty.hs: -------------------------------------------------------------------------------- 1 | -- This file is part of the 'term-rewriting' library. It is licensed 2 | -- under an MIT license. See the accompanying 'LICENSE' file for details. 3 | -- 4 | -- Auhtors: Martin Avanzini, Christian Sternagel 5 | 6 | module Data.Rewriting.Term.Pretty ( 7 | prettyTerm, 8 | ) where 9 | 10 | import Data.Rewriting.Term.Type 11 | import Text.PrettyPrint.ANSI.Leijen 12 | 13 | -- | Given a pretty printer @f@ for function symbols and pretty printer @v@ for variables 14 | -- @prettyTerm f v@ produces a pretty printer for terms 15 | 16 | prettyTerm :: (f -> Doc) -> (v -> Doc) -> Term f v -> Doc 17 | prettyTerm _ var (Var x) = var x 18 | prettyTerm fun var (Fun f ts) = fun f <> args where 19 | args = encloseSep lparen rparen comma [prettyTerm fun var ti | ti <- ts] 20 | 21 | instance (Pretty f, Pretty v) => Pretty (Term f v) where 22 | pretty = prettyTerm pretty pretty 23 | -------------------------------------------------------------------------------- /src/Data/Rewriting/Term/Type.hs: -------------------------------------------------------------------------------- 1 | -- This file is part of the 'term-rewriting' library. It is licensed 2 | -- under an MIT license. See the accompanying 'LICENSE' file for details. 3 | -- 4 | -- Authors: Bertram Felgenhauer 5 | 6 | module Data.Rewriting.Term.Type ( 7 | Term (..), 8 | fold, 9 | map, 10 | ) where 11 | 12 | import Prelude hiding (map) 13 | 14 | data Term f v 15 | = Var v -- ^ Variable 16 | | Fun f [Term f v] -- ^ Function application 17 | deriving (Show, Eq, Ord) 18 | 19 | -- | Folding terms. 20 | -- 21 | -- >>> fold (\v -> 1) (\f xs -> 1 + sum xs) (Fun 'f' [Var 1, Fun 'g' []]) 22 | -- 3 -- size of the given term 23 | fold :: (v -> a) -> (f -> [a] -> a) -> Term f v -> a 24 | fold var fun (Var v) = var v 25 | fold var fun (Fun f ts) = fun f (fmap (fold var fun) ts) 26 | 27 | -- | Mapping terms: Rename function symbols and variables. 28 | -- 29 | -- >>> map succ pred (Fun 'f' [Var 2, Fun 'g' []]) 30 | -- Fun 'e' [Var 3,Fun 'f' []] 31 | map :: (f -> f') -> (v -> v') -> Term f v -> Term f' v' 32 | map fun var = fold (Var . var) (Fun . fun) 33 | -------------------------------------------------------------------------------- /src/Data/Rewriting/Utils.hs: -------------------------------------------------------------------------------- 1 | -- This file is part of the 'term-rewriting' library. It is licensed 2 | -- under an MIT license. See the accompanying 'LICENSE' file for details. 3 | -- 4 | -- Authors: Christian Sternagel 5 | 6 | module Data.Rewriting.Utils ( 7 | dropCommonPrefix, 8 | ) where 9 | 10 | -- | @dropCommonPrefix xs ys@ removes the common prefix of @xs@ and @ys@ and 11 | -- returns the remaining lists as a pair. 12 | -- 13 | -- >>>dropCommonPrefix [1,2,3] [1,2,4,1] 14 | -- ([3], [4,1]) 15 | dropCommonPrefix :: Ord a => [a] -> [a] -> ([a], [a]) 16 | dropCommonPrefix (x:xs) (y:ys) | x == y = dropCommonPrefix xs ys 17 | dropCommonPrefix xs ys = (xs, ys) 18 | -------------------------------------------------------------------------------- /src/Data/Rewriting/Utils/Parse.hs: -------------------------------------------------------------------------------- 1 | -- This file is part of the 'term-rewriting' library. It is licensed 2 | -- under an MIT license. See the accompanying 'LICENSE' file for details. 3 | -- 4 | -- Authors: Christian Sternagel 5 | 6 | {-# LANGUAGE FlexibleContexts#-} 7 | module Data.Rewriting.Utils.Parse ( 8 | lex, 9 | par, 10 | ident 11 | ) where 12 | 13 | import Control.Monad 14 | import Prelude hiding (lex) 15 | import Text.Parsec 16 | import Data.Char (isSpace) 17 | 18 | -- | @lex p@ is similar to @p@ but also consumes trailing white space. 19 | lex :: Stream s m Char => ParsecT s u m a -> ParsecT s u m a 20 | lex p = do { x <- p; spaces; return x } 21 | 22 | -- | @par p@ accpets @p@ enclosed in parentheses ('@(@' and '@)@'). 23 | par :: Stream s m Char => ParsecT s u m a -> ParsecT s u m a 24 | par = between (lex$char '(') (lex$char ')') 25 | 26 | -- | @ident taboo@ parses a non-empty sequence of non-space characters not 27 | -- containing elements of @taboo@. 28 | ident :: Stream s m Char => String -> [String] -> ParsecT s u m String 29 | ident tabooChars tabooWords = try $ do 30 | s <- many1 (satisfy (\c -> not (isSpace c) && c `notElem` tabooChars)) 31 | guard (s `notElem` tabooWords) 32 | return s 33 | -------------------------------------------------------------------------------- /term-rewriting.cabal: -------------------------------------------------------------------------------- 1 | name: term-rewriting 2 | version: 0.4.0.2 3 | stability: experimental 4 | author: Martin Avanzini, 5 | Bertram Felgenhauer, 6 | Christian Sternagel, 7 | Ilya Epifanov 8 | homepage: http://cl-informatik.uibk.ac.at/software/haskell-rewriting/ 9 | maintainer: haskell-rewriting@informatik.uibk.ac.at 10 | license: MIT 11 | license-file: LICENSE 12 | category: Logic 13 | synopsis: Term Rewriting Library 14 | description: 15 | Yet Another Term Rewriting Library. 16 | . 17 | This library provides basic data types and functionality for first order 18 | term rewriting. 19 | build-type: Simple 20 | cabal-version: >= 1.8 21 | 22 | extra-source-files: 23 | Changelog 24 | 25 | source-repository head 26 | type: git 27 | location: git://github.com/haskell-rewriting/term-rewriting 28 | 29 | library 30 | hs-source-dirs: 31 | src 32 | exposed-modules: 33 | Data.Rewriting.Term 34 | Data.Rewriting.Term.Type 35 | Data.Rewriting.Term.Ops 36 | Data.Rewriting.Term.Parse 37 | Data.Rewriting.Term.Pretty 38 | Data.Rewriting.Pos 39 | Data.Rewriting.Problem 40 | Data.Rewriting.Problem.Type 41 | Data.Rewriting.Problem.Parse 42 | Data.Rewriting.Problem.Pretty 43 | Data.Rewriting.Rule 44 | Data.Rewriting.Rule.Type 45 | Data.Rewriting.Rule.Pretty 46 | Data.Rewriting.Rule.Ops 47 | Data.Rewriting.Substitution 48 | Data.Rewriting.Substitution.Type 49 | Data.Rewriting.Substitution.Parse 50 | Data.Rewriting.Substitution.Ops 51 | Data.Rewriting.Substitution.Pretty 52 | Data.Rewriting.Substitution.Match 53 | Data.Rewriting.Substitution.Unify 54 | Data.Rewriting.Rules 55 | Data.Rewriting.Rules.Rewrite 56 | Data.Rewriting.Rules.Ops 57 | Data.Rewriting.Context 58 | Data.Rewriting.Context.Type 59 | Data.Rewriting.Context.Ops 60 | Data.Rewriting.CriticalPair 61 | Data.Rewriting.CriticalPair.Type 62 | Data.Rewriting.CriticalPair.Ops 63 | other-modules: 64 | Data.Rewriting.Utils 65 | Data.Rewriting.Utils.Parse 66 | build-depends: 67 | containers >= 0.3 && < 0.7, 68 | multiset >= 0.2 && < 0.4, 69 | parsec >= 3.1.6 && < 3.2, 70 | union-find-array >= 0.1 && < 0.2, 71 | array >= 0.3 && < 0.6, 72 | ansi-wl-pprint >= 0.6 && < 0.7, 73 | mtl >= 1.1 && < 2.3, 74 | base >= 4 && < 5 75 | extensions: 76 | TypeSynonymInstances 77 | BangPatterns 78 | 79 | test-suite test 80 | type: exitcode-stdio-1.0 81 | hs-source-dirs: test 82 | main-is: Main.hs 83 | other-modules: 84 | Arbitrary 85 | CriticalPair 86 | Pos 87 | Rule 88 | Samples 89 | Substitution 90 | Term 91 | build-depends: 92 | base >= 4 && < 5, 93 | term-rewriting, 94 | containers >= 0.3 && < 0.7, 95 | HUnit >= 1.2 && < 1.7, 96 | QuickCheck >= 2.6 && < 2.14 97 | -------------------------------------------------------------------------------- /test/Arbitrary.hs: -------------------------------------------------------------------------------- 1 | -- This file is part of the 'term-rewriting' library. It is licensed 2 | -- under an MIT license. See the accompanying 'LICENSE' file for details. 3 | -- 4 | -- Authors: Bertram Felgenhauer 5 | 6 | {-# LANGUAGE TypeSynonymInstances, FlexibleInstances #-} 7 | 8 | -- Types and Arbitrary instances for tests. 9 | 10 | module Arbitrary ( 11 | Var', 12 | Fun', 13 | Term', 14 | Rule', 15 | Subst', 16 | ) where 17 | 18 | import Data.Rewriting.Term (Term (..)) 19 | import Data.Rewriting.Rule (Rule (..)) 20 | import qualified Data.Rewriting.Rule as Rule 21 | import Data.Rewriting.Substitution (Subst, GSubst) 22 | import qualified Data.Rewriting.Substitution.Type as Subst 23 | 24 | import Test.QuickCheck (Arbitrary (..), CoArbitrary (..), (><)) 25 | import Test.QuickCheck.Gen 26 | import Control.Applicative 27 | import Control.Monad 28 | import qualified Data.Map as M 29 | 30 | newtype Var' = Var' Char 31 | deriving (Eq, Ord) 32 | 33 | newtype Fun' = Fun' Char 34 | deriving (Eq, Ord) 35 | 36 | type Term' = Term Fun' Var' 37 | 38 | type Rule' = Rule Fun' Var' 39 | 40 | type Subst' = Subst Fun' Var' 41 | 42 | instance Show Var' where 43 | showsPrec p (Var' c) = showsPrec p c 44 | 45 | instance Show Fun' where 46 | showsPrec p (Fun' c) = showsPrec p c 47 | 48 | instance Arbitrary Var' where 49 | arbitrary = Var' <$> growingElements "xyzuvw" 50 | 51 | instance CoArbitrary Var' where 52 | coarbitrary (Var' c) = coarbitrary c 53 | 54 | instance Arbitrary Fun' where 55 | arbitrary = Fun' <$> growingElements "fghijk" 56 | 57 | instance CoArbitrary Fun' where 58 | coarbitrary (Fun' c) = coarbitrary c 59 | 60 | constant :: Gen Fun' 61 | constant = Fun' <$> growingElements "abcd" 62 | 63 | instance Arbitrary Term' where 64 | arbitrary = oneof [ 65 | Var <$> arbitrary, 66 | Fun <$> constant <*> pure [], 67 | Fun <$> arbitrary <*> args] 68 | where 69 | args = sized $ \n -> do 70 | k <- choose (1, 1 `max` n) 71 | let n' = if k == 1 then n else 2*n `div` k 72 | replicateM k (resize n' arbitrary) 73 | 74 | instance CoArbitrary Term' where 75 | coarbitrary (Var x) = variant 0 . coarbitrary x 76 | coarbitrary (Fun f ts) = variant (-1) . (coarbitrary f >< coarbitrary ts) 77 | 78 | instance Arbitrary Rule' where 79 | arbitrary = (Rule <$> arbitrary <*> arbitrary) `suchThat` Rule.isValid 80 | 81 | instance CoArbitrary Rule' where 82 | coarbitrary (Rule l r) = coarbitrary l >< coarbitrary r 83 | 84 | instance Arbitrary Subst' where 85 | arbitrary = Subst.fromMap . M.fromList <$> arbitrary 86 | 87 | instance CoArbitrary Subst' where 88 | coarbitrary = coarbitrary . M.toList . Subst.toMap 89 | -------------------------------------------------------------------------------- /test/CriticalPair.hs: -------------------------------------------------------------------------------- 1 | -- This file is part of the 'term-rewriting' library. It is licensed 2 | -- under an MIT license. See the accompanying 'LICENSE' file for details. 3 | -- 4 | -- Authors: Bertram Felgenhauer 5 | 6 | -- Tests for Data.Rewriting.CriticalPair 7 | 8 | module CriticalPair where 9 | 10 | import Arbitrary 11 | import Samples 12 | 13 | import Data.Rewriting.Term (Term (..)) 14 | import qualified Data.Rewriting.Term as Term 15 | import Data.Rewriting.Rule (Rule (..)) 16 | import Data.Rewriting.Pos (Pos) 17 | import qualified Data.Rewriting.Substitution as Subst 18 | import qualified Data.Rewriting.Rules as Rules 19 | import qualified Data.Rewriting.Context as Ctxt 20 | import Data.Rewriting.CriticalPair 21 | 22 | import qualified Data.Set as S 23 | import Test.HUnit 24 | 25 | type CP' = CP Fun' Var' Var' 26 | 27 | maxSize = 4 28 | 29 | propValidCPs' :: [Rule'] -> Bool 30 | propValidCPs' = all validCP . cps' . take maxSize 31 | 32 | -- propValidCPs :: [Rule'] -> [Rule'] -> Bool 33 | -- propValidCPs rs rs' = all validCP (cps (take maxSize rs) (take maxSize rs')) 34 | 35 | propOuterCPs' :: [Rule'] -> Bool 36 | propOuterCPs' = all (null . leftPos) . cpsOut' . take maxSize 37 | 38 | propInnerCPs' :: [Rule'] -> Bool 39 | propInnerCPs' = all (not . null . leftPos) . cpsIn' . take maxSize 40 | 41 | tests :: Test 42 | tests = TestLabel "Critical Pair Tests" $ TestList [ 43 | TestCase $ assertEqual "CPs of fixed TRS" 44 | (cpSet cps1) (cpSet $ cps' trs1) 45 | ] 46 | 47 | cpSet :: (Ord f, Ord v) => [CP f v v] -> S.Set (Term f (Either v v), Term f (Either v v), Term f (Either v v), Rule f v, Rule f v, Pos) 48 | cpSet = S.fromList . map (\cp -> (top cp, left cp, right cp, leftRule cp, rightRule cp, leftPos cp)) 49 | 50 | validCP :: (Ord v, Eq f) => CP f v v -> Bool 51 | validCP CP{ left = left, top = top, right = right, leftPos = pos, 52 | leftRule = lRule, rightRule = rRule, subst = subst } = 53 | subst `Subst.apply` Term.map id Right (lhs rRule) == top && 54 | subst `Subst.apply` Term.map id Right (rhs rRule) == right && 55 | subst `Subst.apply` Term.map id Left (lhs lRule) == top !!! pos && 56 | subst `Subst.apply` Term.map id Left (rhs lRule) == left !!! pos && 57 | Ctxt.ofTerm top pos == Ctxt.ofTerm left pos 58 | -------------------------------------------------------------------------------- /test/Main.hs: -------------------------------------------------------------------------------- 1 | -- This file is part of the 'term-rewriting' library. It is licensed 2 | -- under an MIT license. See the accompanying 'LICENSE' file for details. 3 | -- 4 | -- Authors: Bertram Felgenhauer 5 | 6 | -- Main test driver. 7 | 8 | module Main (main) where 9 | 10 | import qualified Pos 11 | import qualified Term 12 | import qualified Rule 13 | import qualified CriticalPair 14 | import qualified Substitution 15 | 16 | import Test.QuickCheck 17 | import Test.HUnit 18 | import Control.Monad 19 | import System.IO 20 | 21 | properties :: [(String, Property)] 22 | properties = [ 23 | ("Pos.propParallelTo", property Pos.propParallelTo), 24 | ("Term.propReplaceAt1", property Term.propReplaceAt1), 25 | ("Term.propReplaceAt2", property Term.propReplaceAt2), 26 | ("Rule.propLeftRightLinearDual", property Rule.propLeftRightLinearDual), 27 | ("Rule.propCollapsingExpandingDual", property Rule.propCollapsingExpandingDual), 28 | ("Rule.propErasingCreatingDual", property Rule.propErasingCreatingDual), 29 | ("Rule.propLinear", property Rule.propLinear), 30 | ("Rule.propValid", property Rule.propValid), 31 | ("Substitution.propCompose", property Substitution.propCompose), 32 | ("Substitution.propUnify1", property Substitution.propUnify1), 33 | ("Substitution.propUnify2", property Substitution.propUnify2), 34 | ("CriticalPair.propValidCPs'", property CriticalPair.propValidCPs'), 35 | ("CriticalPair.propOuterCPs'", property CriticalPair.propOuterCPs'), 36 | ("CriticalPair.propInnerCPs'", property CriticalPair.propInnerCPs') 37 | ] 38 | 39 | tests :: Test 40 | tests = TestList [ 41 | CriticalPair.tests, 42 | Rule.tests, 43 | TestList []] 44 | 45 | main :: IO () 46 | main = do 47 | forM_ properties $ \(name, prop) -> do 48 | putStrLn $ "- " ++ name 49 | quickCheck prop 50 | putStrLn $ "- HUnit tests" 51 | runTestTT tests 52 | return () 53 | -------------------------------------------------------------------------------- /test/Pos.hs: -------------------------------------------------------------------------------- 1 | -- This file is part of the 'term-rewriting' library. It is licensed 2 | -- under an MIT license. See the accompanying 'LICENSE' file for details. 3 | -- 4 | -- Authors: Bertram Felgenhauer 5 | 6 | -- Tests for Data.Rewriting.Pos 7 | 8 | module Pos where 9 | 10 | import Data.Rewriting.Pos 11 | 12 | import Test.QuickCheck 13 | 14 | propParallelTo :: Pos -> Pos -> Bool 15 | propParallelTo = \p q -> parallelTo p q == parallelToRef p q 16 | 17 | -- reference implementation 18 | parallelToRef :: Pos -> Pos -> Bool 19 | parallelToRef p q = not (p `above` q) && not (p `below` q) 20 | -------------------------------------------------------------------------------- /test/README: -------------------------------------------------------------------------------- 1 | To run tests, install the library and then 'runhaskell Main.hs' in this 2 | directory. 3 | 4 | TODO: 5 | - look into the new Cabal testsuite support. 6 | - automate the extraction of prop* from the various test modules 7 | 8 | -------------------------------------------------------------------------------- /test/Rule.hs: -------------------------------------------------------------------------------- 1 | -- This file is part of the 'term-rewriting' library. It is licensed 2 | -- under an MIT license. See the accompanying 'LICENSE' file for details. 3 | -- 4 | -- Authors: Bertram Felgenhauer 5 | 6 | -- Tests for Data.Rewriting.Rules 7 | 8 | module Rule where 9 | 10 | import Samples 11 | import Arbitrary 12 | 13 | import Data.Rewriting.Rule 14 | 15 | import Test.HUnit 16 | 17 | tests :: Test 18 | tests = TestLabel "Rules Tests" $ TestList [ 19 | TestCase $ assertEqual "isLeftLinear" 20 | True (isLeftLinear $ x --> f[x, x]), 21 | TestCase $ assertEqual "~isLeftLinear" 22 | False (isLeftLinear $ f[x,g[a,b,x],y] --> z), 23 | TestCase $ assertEqual "isCollapsing" 24 | True (isCollapsing $ g[a, b] --> x), 25 | TestCase $ assertEqual "~isCollapsing" 26 | False (isCollapsing $ z --> g[x,h[x]]), 27 | TestList []] 28 | 29 | propLeftRightLinearDual :: Term' -> Term' -> Bool 30 | propLeftRightLinearDual = dual isLeftLinear isRightLinear 31 | 32 | propCollapsingExpandingDual :: Term' -> Term' -> Bool 33 | propCollapsingExpandingDual = dual isCollapsing isExpanding 34 | 35 | propErasingCreatingDual :: Term' -> Term' -> Bool 36 | propErasingCreatingDual = dual isErasing isCreating 37 | 38 | propLinear :: Term' -> Term' -> Bool 39 | propLinear l r = isLinear (Rule l r) == 40 | (isLeftLinear (Rule l r) && isRightLinear (Rule l r)) 41 | 42 | propValid :: Term' -> Term' -> Bool 43 | propValid l r = isValid (Rule l r) == 44 | not (isCreating (Rule l r) || isExpanding (Rule l r)) 45 | 46 | dual :: (Rule' -> Bool) -> (Rule' -> Bool) -> Term' -> Term' -> Bool 47 | dual p q a b = p (Rule a b) == q (Rule b a) 48 | -------------------------------------------------------------------------------- /test/Samples.hs: -------------------------------------------------------------------------------- 1 | -- This file is part of the 'term-rewriting' library. It is licensed 2 | -- under an MIT license. See the accompanying 'LICENSE' file for details. 3 | -- 4 | -- Authors: Bertram Felgenhauer 5 | 6 | {-# LANGUAGE StandaloneDeriving #-} 7 | 8 | -- selected samples for tests 9 | 10 | module Samples where 11 | 12 | import Data.Rewriting.Term (Term (..)) 13 | import qualified Data.Rewriting.Term as Term 14 | import Data.Rewriting.Rule (Rule (..)) 15 | import Data.Rewriting.Pos (Pos) 16 | import Data.Rewriting.CriticalPair (CP (..)) 17 | import Data.Rewriting.Substitution (GSubst (..)) 18 | import qualified Data.Rewriting.Substitution as Subst 19 | import qualified Data.Rewriting.Context as Ctxt 20 | 21 | a = Fun 'a' [] 22 | b = Fun 'b' [] 23 | c = Fun 'c' [] 24 | 25 | f = Fun 'f' 26 | g = Fun 'g' 27 | h = Fun 'h' 28 | 29 | x = Var 'x' 30 | y = Var 'y' 31 | z = Var 'z' 32 | 33 | (-->) = Rule 34 | 35 | trs1 = [f[x, x] --> g[a, x], f[a, y] --> h[a], a --> b] 36 | cps1 = [mkCP r1 r2 [], mkCP r3 r2 [0]] 37 | where [r1, r2, r3] = trs1 38 | 39 | mkCP :: (Eq f, Ord v) => Rule f v -> Rule f v -> Pos -> CP f v v 40 | mkCP lRule rRule pos = let 41 | (llhs, lrhs) = (Term.map id Left (lhs lRule), Term.map id Left (rhs lRule)) 42 | (rlhs, rrhs) = (Term.map id Right (lhs rRule), Term.map id Right (rhs rRule)) 43 | Just subst = Subst.unify llhs (rlhs !!! pos) 44 | Just rlhs' = Ctxt.ofTerm rlhs pos 45 | in 46 | CP{ top = subst `Subst.apply` rlhs, right = subst `Subst.apply` rrhs, 47 | left = rlhs' `Ctxt.apply` (subst `Subst.apply` lrhs), 48 | leftRule = lRule, rightRule = rRule, leftPos = pos, subst = subst } 49 | 50 | deriving instance (Show f, Show v, Show v') => Show (CP f v v') 51 | 52 | (!!!) :: Term f v -> Pos -> Term f v 53 | t !!! [] = t 54 | Fun _ ts !!! (p:ps) = (ts !! p) !!! ps 55 | -------------------------------------------------------------------------------- /test/Substitution.hs: -------------------------------------------------------------------------------- 1 | -- This file is part of the 'term-rewriting' library. It is licensed 2 | -- under an MIT license. See the accompanying 'LICENSE' file for details. 3 | -- 4 | -- Authors: Bertram Felgenhauer 5 | 6 | -- Tests for Data.Rewriting.Substitution 7 | 8 | module Substitution where 9 | 10 | import Arbitrary 11 | 12 | import Data.Rewriting.Term (Term (..)) 13 | import Data.Rewriting.Substitution 14 | import Data.Rewriting.Substitution.Type 15 | 16 | import Control.Applicative 17 | import Control.Monad 18 | import Data.Maybe 19 | import Data.Function 20 | import qualified Data.Map as M 21 | 22 | propCompose :: Subst' -> Subst' -> Term' -> Bool 23 | propCompose s1 s2 t = (s1 `compose` s2) `apply` t == s1 `apply` (s2 `apply` t) 24 | 25 | propUnify1 :: Term' -> Term' -> Bool 26 | propUnify1 s t = Just False /= do 27 | (\u -> u `apply` s == u `apply` t) <$> unify s t 28 | 29 | propUnify2 :: Term' -> Term' -> Bool 30 | propUnify2 s t = Just False /= do 31 | equalSubst <$> unify s t <*> unifyRef s t 32 | 33 | equalSubst :: (Ord v, Eq f) => Subst f v -> Subst f v -> Bool 34 | equalSubst s1 s2 = ((==) `on` toMap) (id' `compose` s1) (id' `compose` s2) 35 | where 36 | id' = fromMap . M.fromList $ 37 | [(v, Var v) | v <- M.keys (toMap s1) ++ M.keys (toMap s2)] 38 | -------------------------------------------------------------------------------- /test/Term.hs: -------------------------------------------------------------------------------- 1 | -- This file is part of the 'term-rewriting' library. It is licensed 2 | -- under an MIT license. See the accompanying 'LICENSE' file for details. 3 | -- 4 | -- Authors: Bertram Felgenhauer 5 | 6 | -- Tests for Data.Rewriting.Term 7 | 8 | module Term where 9 | 10 | import Arbitrary 11 | 12 | import Data.Rewriting.Pos 13 | import Data.Rewriting.Term 14 | 15 | import Control.Monad (liftM2) 16 | import Data.Maybe (fromMaybe) 17 | 18 | propReplaceAt1 :: Pos -> Term' -> Term' -> Bool 19 | propReplaceAt1 p t t' = fromMaybe True $ do 20 | u <- replaceAt t p t' 21 | v <- u `subtermAt` p 22 | return $ t' == v 23 | 24 | propReplaceAt2 :: Pos -> Term' -> Term' -> Term' -> Bool 25 | propReplaceAt2 p t t1 t2 = fromMaybe True $ do 26 | u1 <- replaceAt t p t1 27 | u2 <- replaceAt t p t2 28 | return $ (u1 == u2) == (t1 == t2) 29 | --------------------------------------------------------------------------------