summaryrefslogtreecommitdiff
path: root/simplify.hs
diff options
context:
space:
mode:
Diffstat (limited to 'simplify.hs')
-rw-r--r--simplify.hs112
1 files changed, 10 insertions, 102 deletions
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