diff options
| -rw-r--r-- | ast.hs | 25 | ||||
| -rw-r--r-- | debug.hs | 2 | ||||
| -rw-r--r-- | main.hs | 130 | ||||
| -rw-r--r-- | rules.txt | 96 | ||||
| -rw-r--r-- | simplify.hs | 112 |
5 files changed, 247 insertions, 118 deletions
@@ -218,12 +218,23 @@ matchOrderedList (pat:pats) (sub:subs) = $ matchOrderedList newpats subs) newpatsopts +flattenSingle :: AST -> AST +flattenSingle (Sum args) = + let listify (Sum a) = a + listify node = [node] + in Sum $ concat $ map listify args +flattenSingle (Product args) = + let listify (Product a) = a + listify node = [node] + in Product $ concat $ map listify args +flattenSingle node = node + replaceCaptures :: Map.Map String AST -> AST -> AST replaceCaptures mp n = case n of Number _ -> n Variable _ -> n - Sum l -> Sum $ map (replaceCaptures mp) l - Product l -> Product $ map (replaceCaptures mp) l + Sum l -> flattenSingle $ Sum $ map (replaceCaptures mp) l + Product l -> flattenSingle $ Product $ map (replaceCaptures mp) l Negative n2 -> Negative $ replaceCaptures mp n2 Reciprocal n2 -> Reciprocal $ replaceCaptures mp n2 Apply name n2 -> Apply name $ map (replaceCaptures mp) n2 @@ -276,9 +287,9 @@ mapDel f l = --pat = Sum [CaptureTerm "x",CaptureTerm "y",Capture "rest",Negative $ Capture "rest"] --sub = Sum [Number 1,Number 2,Negative $ Number 1,Variable "kaas",Negative $ Sum [Negative $ Number 1,Variable "kaas"]] -pat = Sum [Product [Capture "x"],Product [Capture "x"]] -sub = Sum [Product [Number 1],Product [Number 1]] +--pat = Sum [Product [Capture "x"],Product [Capture "x"]] +--sub = Sum [Product [Number 1],Product [Number 1]] -main = do - let res = astMatch pat sub - deepseq res $ putStrLn $ "\x1B[32m"++show res++"\x1B[0m" +--main = do +-- let res = astMatch pat sub +-- deepseq res $ putStrLn $ "\x1B[32m"++show res++"\x1B[0m" @@ -2,7 +2,7 @@ module Debug where -#if 1 +#if 0 import qualified Debug.Trace as Trace @@ -1,31 +1,145 @@ module Main where import Control.Monad +import Data.Char +import Data.List import Data.Either import Data.Maybe import System.Console.Readline +import System.Exit +import System.IO +import qualified Data.Map.Strict as Map +import AST hiding (main) import Simplify import Parser import PrettyPrint +import Utility +import Debug -repl :: IO () -repl = do +trimlr :: String -> String +trimlr = reverse . dropWhile isSpace . reverse . dropWhile isSpace + +findstr :: String -> String -> Maybe Int +findstr pat sub = go sub 0 + where len = length pat + go :: String -> Int -> Maybe Int + go "" _ = Nothing + go sub i = if take len sub == pat then Just i else go (tail sub) (i+1) + +mayberead :: Read a => String -> Maybe a +mayberead s = + let r = reads s + ok = if null r then False else null $ snd $ head r + v = fst $ head r + in if ok then Just v else Nothing + +readrule :: String -> IO (AST,AST) +readrule line = do + let (patstr',(repstr')) = break (=='|') line + patstr = desugar $ trimlr patstr' + repstr = desugar $ trimlr $ tail repstr' + if null repstr' + then die $ "No pipe separator found: " ++ line + else do + let mpat = mayberead patstr :: Maybe AST + mrep = mayberead repstr :: Maybe AST + when (isNothing mpat) $ die $ "Could not parse pattern! (from '" ++ patstr ++ "')" + when (isNothing mrep) $ die $ "Could not parse replacement! (from '" ++ repstr ++ "')" + return (fromJust mpat,fromJust mrep) + +desugar :: String -> String +desugar "" = "" +desugar ('{':cs) = + let midx = findIndex (=='}') cs + idx = fromJust midx + termcap = head cs == '{' && length cs > idx+1 && cs !! (idx+1) == '}' + endidx = if termcap then idx+1 else idx + after = drop (endidx+1) cs + name' = if termcap then tail $ take (endidx-1) cs else take endidx cs + name = map (\c -> if c == '\\' || c == '"' then '_' else c) name' + in if isNothing midx + then '{':desugar cs + else if termcap + then let mcolonidx = findIndex (==':') name + colonidx = fromJust mcolonidx + precolon = take colonidx name + postcolon = drop (colonidx+1) name + stub = case postcolon of + "Number" -> "Number 42" + "Variable" -> "Variable \"\"" + _ -> trace postcolon undefined + in if isNothing mcolonidx + then "(CaptureTerm \"" ++ name ++ "\")" ++ desugar after + else "(CaptureConstr \"" ++ precolon ++ "\" (" ++ stub ++ "))" ++ desugar after + else "(Capture \"" ++ name ++ "\")" ++ desugar after +desugar (':':cs) = + let midx = findIndex (==':') cs + endidx = fromJust midx + after = drop (endidx+1) cs + name = map (\c -> if c == '\\' || c == '"' then '_' else c) $ take endidx cs + in if isNothing midx + then ':':desugar cs + else "Apply \"" ++ name ++ "\" " ++ desugar after +desugar (c:cs) = c : desugar cs + +readrules :: Handle -> IO (Map.Map String [(AST,AST)]) +readrules handle = liftM (uncurry fixincludes) $ go "general" Map.empty Map.empty + where + go :: String -- current section + -> Map.Map String [String] -- sections still to be included (#+) + -> Map.Map String [(AST,AST)] -- current rules db + -> IO (Map.Map String [(AST,AST)],Map.Map String [String]) -- (rules db,includes) + go sect includes db = hIsEOF handle >>= \eof -> if eof then return (db,includes) else do + line <- hGetLine handle + case take 3 line of + "" -> go sect includes db + "-- " -> go sect includes db + "## " -> go (trimlr $ drop 3 line) includes db + "#+ " -> go sect (Map.insertWith (++) sect [trimlr $ drop 3 line] includes) db + _ -> readrule (trimlr line) >>= \rule -> go sect includes (Map.insertWith (flip (++)) sect [rule] db) + + fixincludes :: Map.Map String [(AST,AST)] -- rules db + -> Map.Map String [String] -- to be included sections + -> Map.Map String [(AST,AST)] -- resulting rules db + fixincludes db includes = Map.foldlWithKey insertincludes db includes + where + insertincludes :: Map.Map String [(AST,AST)] -- db + -> String -- section + -> [String] -- sections to be included + -> Map.Map String [(AST,AST)] -- resulting db + insertincludes db sect incls = foldl (\db incl -> insertinclude db sect incl) db incls + where insertinclude db sect incl = Map.insertWith (++) sect (fromJust $ Map.lookup incl db) db + + +printrules :: [(AST,AST)] -> IO () +printrules db = sequence_ $ foldl (\l (pat,sub) -> l ++ [print pat,putStr " -> ",print sub]) [] db + + +repl :: Map.Map String [(AST,AST)] -> IO () +repl db = do mline <- readline "> " case mline of Nothing -> return () -- EOF - Just "" -> repl + Just "" -> repl db Just line -> do addHistory line let eexpr = parseExpression line either (putStrLn . ("Error: "++)) handleExpression eexpr - repl + repl db where + generaldb = fromJust $ Map.lookup "general" db + sanitisedb = fromJust $ Map.lookup "sanitise" db + displaydb = fromJust $ Map.lookup "display" db handleExpression expr = do - print expr - let sim = simplify expr - print sim + putStrLn $ prettyPrint expr + let sim = foldl (flip simplify) expr [generaldb,sanitisedb,displaydb] + putStrLn $ prettyPrint sim + main :: IO () -main = repl +main = do + rulesdb <- withFile "rules.txt" ReadMode readrules + --sequence_ $ Map.foldlWithKey (\l sect rules -> putStrLn ("## "++sect) : printrules rules : putStrLn "" : l) [] rulesdb + repl rulesdb diff --git a/rules.txt b/rules.txt new file mode 100644 index 0000000..aa1f44d --- /dev/null +++ b/rules.txt @@ -0,0 +1,96 @@ +## general +#+ to_internal +#+ fraction_identities +#+ identities +#+ uncollect_sums +#+ differentiation +#+ sanitise_epowers + + +## display +#+ to_display +#+ fraction_identities +#+ collect +#+ identities + + +## general_display +#+ general +#+ display + + +## sanitise +#+ sanitise_epowers +#+ collect_numbers + + +## collect +Sum [{{x}},{{x}},{rest}] | Sum [Product [Number 2,{x}],{rest}] +Sum [{{x}},Product [{{n:Number}},{x}],{rest}] | Sum [Product [Sum [Number 1,{n}],{x}],{rest}] +Sum [Product [{{n1:Number}},{x}],Product [{{n2:Number}},{x}],{rest}] | Sum [Product [Sum [{n1},{n2}],{x}],{rest}] + +Product [{{x}},{{x}},{rest}] | Product [:pow:[{x},Number 2],{rest}] +Product [{{x}},:pow:[{{x}},{{n}}],{rest}] | Product [:pow:[{x},Sum [{n},Number 1]],{rest}] +Product [:pow:[{x},{a}],:pow:[{x},{b}],{rest}] | Product [:pow:[{x},Sum [{a},{b}]],{rest}] + + +## uncollect_sums +Product [Sum [{{a}},{rest}],{prod}] | Sum [Product [{a},{prod}],Product [{rest},{prod}]] + + +## identities +:pow:[:pow:[{{x}},{{n}}],{{m}}] | :pow:[{x},Product [{n},{m}]] +:pow:[{{x}},Number 1] | {x} + +-- Guarding necessary for x != 0 +:pow:[{x},Number 0] | Number 1 + +Product [Number 0,{rest}] | Number 0 +Product [Number 1,{rest}] | {rest} + + +## fraction_identities +Reciprocal (Product [Reciprocal {{x}},{rest}]) | Product [{x},Reciprocal {rest}] +Product [{{x}},Reciprocal {{x}},{rest}] | {rest} +Product [{{x}},Reciprocal (Product [{{x}},{rrest}]),{rest}] | Product [{rest},Reciprocal {rrest}] + + +## to_internal +Reciprocal {a} | :pow:[{a},Number (-1)] +Negative {a} | Product [Number (-1),{a}] +:pow:[Product [{{a}},{b}],{exp}] | Product [:pow:[{a},{exp}],:pow:[{b},{exp}]] +:tan:[{x}] | Product [:sin:[{x}],Reciprocal (:cos:[{x}])] + + +## differentiation +:d:[{{n:Number}},{x}] | Number 0 +:d:[{{x:Variable}},{{x}}] | Number 1 +:d:[Sum [{{a}},{b}],{{x}}] | Sum [:d:[{a},{x}],:d:[{b},{x}]] +:d:[Product [{{n:Number}},{a}],{x}] | Product [{n},:d:[{a},{x}]] +:d:[Product [{{a}},{b}],{x}] | Sum [Product [:d:[{a},{x}],{b}],Product [{a},:d:[{b},{x}]]] +:d:[:pow:[Variable "E",{ex}],{x}] | Product [:pow:[Variable "E",{ex}],:d:[{ex},{x}]] + +-- Guarding probably necessary for a != E +-- Cannot be generally applied, because {a} may be negative; for differentiation, however, that doesn't matter +-- :d:[:pow:[{a},{b}],{x}] | :d:[:pow:[Variable "E",Product [{b},:ln:[{a}]]],{x}] +:d:[:pow:[{a},{b}],{x}] | Product [:pow:[{a},{b}],:d:[Product[{b},:ln:[{a}]],{x}]] + +:d:[:ln:[{args}],{x}] | Product [Reciprocal {args},:d:[{args},{x}]] +:d:[:sin:[{a}],{x}] | Product [:cos:[{a}],:d:[{a},{x}]] +:d:[:cos:[{a}],{x}] | Product [Number (-1),:sin:[{a}],:d:[{a},{x}]] + + +## sanitise_epowers +:pow:[Variable "E",:ln:[{arg}]] | {arg} +:pow:[Variable "E",Product [:ln:[{arg}],{rest}]] | :pow:[{arg},{rest}] + + +## collect_numbers +Sum [Product [{{n1:Number}},{x}],Product [{{n2:Number}},{x}],{rest}] | Sum [Product [Sum [{n1},{n2}],{x}],{rest}] + + +## to_display +:pow:[Variable "E",:ln:[{arg}]] | {arg} +:pow:[Variable "E",Product [:ln:[{arg}],{rest}]] | :pow:[{arg},{rest}] +:pow:[{x},Number (-1)] | Reciprocal {x} +Product [:sin:[{x}],Reciprocal (:cos:[{x}]),{rest}] | Product [:tan:[{x}],{rest}] diff --git a/simplify.hs b/simplify.hs index c62ff4b..9ae29f1 100644 --- a/simplify.hs +++ b/simplify.hs @@ -1,5 +1,3 @@ -{-# LANGUAGE CPP #-} - module Simplify (simplify) where import Data.List @@ -18,13 +16,13 @@ tracexp :: (PrettyPrint a) => String -> a -> a tracexp s x = trace (s ++ ": " ++ prettyPrint x) x -simplify :: AST -> AST -simplify = tracex "last canonicaliseOrder" . canonicaliseOrder - . (fixpoint $ tracex "applyPatterns " . applyPatterns - . tracex "canonicaliseOrder" . canonicaliseOrder - . tracex "flattenSums " . flattenSums - . tracex "foldNumbers " . foldNumbers) - . tracex "first flattenSums" . flattenSums +simplify :: [(AST,AST)] -> AST -> AST +simplify db = tracex "last canonicaliseOrder" . canonicaliseOrder + . (fixpoint $ tracex "applyPatterns " . applyPatterns db + . tracex "canonicaliseOrder" . canonicaliseOrder + . tracex "flattenSums " . flattenSums + . tracex "foldNumbers " . foldNumbers) + . tracex "first flattenSums" . flattenSums flattenSums :: AST -> AST @@ -106,96 +104,6 @@ canonicaliseOrder node = case node of (CaptureConstr _ _) -> node -patterndb :: [(AST,AST)] -patterndb = [ - (Reciprocal $ Product [Reciprocal (CaptureTerm "x"),Capture "rest"], -- 1/(1/x * [rest]) -> x * 1/[rest] - Product [Capture "x",Reciprocal $ Capture "rest"]), - - (Product [CaptureTerm "x",Reciprocal (CaptureTerm "x"),Capture "rest"], -- x * 1/x * [rest] -> [rest] - Capture "rest"), - - (Product [CaptureTerm "x", -- x * 1/(x*[rrest]) * [rest] -> [rest] * 1/[rrest] - Reciprocal (Product [CaptureTerm "x",Capture "rrest"]), - Capture "rest"], - Product [Capture "rest",Reciprocal (Capture "rrest")]), - - (Sum [CaptureTerm "x",CaptureTerm "x",Capture "rest"], -- x + x + [rest] -> 2*x + [rest] - Sum [Product [Number 2,Capture "x"],Capture "rest"]), - - (Sum [CaptureTerm "x", -- x + n*x + [rest] -> (1+n)*x + [rest] - Product [CaptureConstr "n" (Number undefined),Capture "x"], - Capture "rest"], - Sum [Product [Sum [Number 1,Capture "n"], - Capture "x"], - Capture "rest"]), - - (Sum [Product [CaptureConstr "n1" (Number undefined),Capture "x"], -- n1*x + n2*x + [rest] -> (n1+n2)*x + [rest] - Product [CaptureConstr "n2" (Number undefined),Capture "x"], - Capture "rest"], - - Sum [Product [Sum [Capture "n1",Capture "n2"], - Capture "x"], - Capture "rest"]), - - (Product [CaptureTerm "x", -- x*x*[rest] -> x^2*[rest] - CaptureTerm "x", - Capture "rest"], - Product [Apply "pow" [Capture "x",Number 2], - Capture "rest"]), - - (Product [CaptureTerm "x", -- x*x^n*[rest] -> x^(n+1)*[rest] - Apply "pow" [CaptureTerm "x",CaptureTerm "n"], - Capture "rest"], - Product [Apply "pow" [Capture "x",Sum [Capture "n",Number 1]], - Capture "rest"]), - - (Product [Apply "pow" [CaptureTerm "x",CaptureTerm "a"], -- x^a*x^b*[rest] -> x^(a+b)*[rest] - Apply "pow" [CaptureTerm "x",CaptureTerm "b"], - Capture "rest"], - Product [Apply "pow" [Capture "x",Sum [Capture "a",Capture "b"]], - Capture "rest"]), - - (Apply "pow" [Apply "pow" [CaptureTerm "x",CaptureTerm "n"],CaptureTerm "m"], -- (x^n)^m -> x^(n*m) - Apply "pow" [Capture "x",Product [Capture "n",Capture "m"]]), - - (Apply "pow" [CaptureTerm "x",Number 1], -- x^1 -> x - Capture "x"), - - (Product [Number 0,Capture "rest"], -- 0*[rest] -> 0 - Number 0), - - (Product [Number 1,Capture "rest"], -- 1*[rest] -> [rest] - Capture "rest"), - - - (Apply "d" [CaptureConstr "n" (Number undefined),Capture "x"], -- d(n,x) -> 0 - Number 0), - - (Apply "d" [CaptureConstr "x" (Variable undefined),CaptureTerm "x"], -- d(x,x) -> 1 - Number 1), - - (Apply "d" [Apply "pow" [CaptureConstr "x" (Variable undefined),CaptureTerm "n"], -- d(x^n,x) -> n*x^(n-1) - CaptureTerm "x"], - Product [Capture "n",Apply "pow" [Capture "x",Sum [Capture "n",Number (-1)]]]), - - (Apply "d" [Sum [CaptureTerm "a",Capture "b"],CaptureTerm "x"], -- d(a+[b],x) -> d(a,x) + d([b],x) - Sum [Apply "d" [Capture "a",Capture "x"],Apply "d" [Capture "b",Capture "x"]]), - - (Apply "d" [Product [CaptureTerm "a",Capture "b"],Capture "x"], -- d(ab,x) -> d(a,x)*b + a*d(b,x) - Sum [Product [Apply "d" [Capture "a",Capture "x"],Capture "b"], - Product [Capture "a",Apply "d" [Capture "b",Capture "x"]]]), - - (Apply "d" [Apply "pow" [CaptureConstr "a" (Variable undefined), -- d(a^expr,x) -> a^expr * ln(a) * d(expr,x) - Capture "expr"], - Capture "x"], - Product [Apply "pow" [Capture "a",Capture "expr"], - Apply "ln" [Capture "a"], - Apply "d" [Capture "expr",Capture "x"]]), - - (Apply "d" [Apply "ln" [Capture "args"],Capture "x"], -- d(ln([args]),x) -> 1/[args]*d([args],x) - Product [Reciprocal (Capture "args"),Apply "d" [Capture "args",Capture "x"]]) - ] - astChildMap :: AST -> (AST -> AST) -> AST astChildMap node f = case node of (Number _) -> node @@ -209,9 +117,9 @@ astChildMap node f = case node of (CaptureTerm _) -> node (CaptureConstr _ _) -> node -applyPatterns :: AST -> AST -applyPatterns node = let matches = filter (not . null . fst) $ map (\(pat,repl) -> (astMatch pat node,repl)) patterndb +applyPatterns :: [(AST,AST)] -> AST -> AST +applyPatterns db node = let matches = filter (not . null . fst) $ map (\(pat,repl) -> (astMatch pat node,repl)) db in if null matches - then astChildMap node applyPatterns + then astChildMap node (applyPatterns db) else let ((capdict:_),repl) = head matches -- TODO: don't take the first option of the first match, but use them all in {-applyPatterns $-} replaceCaptures capdict repl |