From a65c127558fc96b13ea515194ac28f8b09e065c6 Mon Sep 17 00:00:00 2001 From: tomsmeding Date: Mon, 20 Jun 2016 22:07:41 +0200 Subject: Strongly improved, dynamic rule system --- simplify.hs | 112 ++++++------------------------------------------------------ 1 file changed, 10 insertions(+), 102 deletions(-) (limited to 'simplify.hs') 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 -- cgit v1.2.3-54-g00ecf