summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
-rw-r--r--ast.hs26
-rw-r--r--simplify.hs46
2 files changed, 58 insertions, 14 deletions
diff --git a/ast.hs b/ast.hs
index 1e267c1..4862a92 100644
--- a/ast.hs
+++ b/ast.hs
@@ -72,16 +72,16 @@ instance NFData AST where
rnf (CaptureConstr !_ !_) = () -- explicitly not deepseq'ing the ast node
instance Ord AST where
- compare (Number _) (Number _) = EQ
- compare (Variable _) (Variable _) = EQ
- compare (Sum _) (Sum _) = EQ
- compare (Product _) (Product _) = EQ
- compare (Negative _) (Negative _) = EQ
- compare (Reciprocal _) (Reciprocal _) = EQ
- compare (Apply _ _) (Apply _ _) = EQ
- compare (Capture _) (Capture _) = EQ
- compare (CaptureTerm _) (CaptureTerm _) = EQ
- compare (CaptureConstr _ _) (CaptureConstr _ _) = EQ
+ compare (Number a) (Number b) = compare a b
+ compare (Variable a) (Variable b) = compare a b
+ compare (Sum a) (Sum b) = compare a b
+ compare (Product a) (Product b) = compare a b
+ compare (Negative a) (Negative b) = compare a b
+ compare (Reciprocal a) (Reciprocal b) = compare a b
+ compare (Apply n1 a) (Apply n2 b) = let r = compare n1 n2 in if r == EQ then compare a b else r
+ compare (Capture a) (Capture b) = compare a b
+ compare (CaptureTerm a) (CaptureTerm b) = compare a b
+ compare (CaptureConstr n1 node1) (CaptureConstr n2 node2) = let r = compare n1 n2 in if r == EQ then compare node1 node2 else r
compare (Capture _) _ = LT -- Unbounded captures first for efficient
compare _ (Capture _) = GT -- extraction with span isCapture
@@ -114,6 +114,10 @@ astIsCapture (Capture _) = True
astIsCapture _ = False
+astFromNumber :: AST -> Double
+astFromNumber (Number n) = n
+
+
astMatchSimple :: AST -> AST -> Bool
astMatchSimple pat sub = let res = {-(\x -> trace (" !! RESULT: " ++ show x ++ " !! ") x) $-} astMatch pat sub
in if null res
@@ -159,7 +163,7 @@ astMatch pat sub = assertS "No captures in astMatch subject" (not $ hasCaptures
_ -> []
Apply name l -> case sub of
- Apply name l2 -> matchOrderedList l l2
+ Apply name2 l2 | name == name2 -> matchOrderedList l l2
_ -> []
Capture name -> [Map.singleton name sub]
diff --git a/simplify.hs b/simplify.hs
index cb3e5af..f2eaa28 100644
--- a/simplify.hs
+++ b/simplify.hs
@@ -61,7 +61,12 @@ foldNumbers node = case node of
(Negative n) -> Negative $ Reciprocal fn
(Reciprocal n2) -> n2
_ -> Reciprocal $ fn
- (Apply name args) -> Apply name $ map foldNumbers args
+ (Apply name args) -> let fargs = map foldNumbers args -- Apply name $ map foldNumbers args
+ in case name of
+ "pow" -> if all astIsNumber fargs
+ then Number $ astFromNumber (fargs!!0) ** astFromNumber (fargs!!1)
+ else Apply "pow" fargs
+ _ -> Apply name fargs
(Sum args) -> Sum $ dofoldnums sum args 0
(Product args) -> dofoldnegsToProd $ dofoldnums product args 1
_ -> node
@@ -148,7 +153,42 @@ patterndb = [
Sum [Product [Sum [Capture "n1",Capture "n2"],
Capture "x"],
- Capture "rest"])
+ 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"),
+
+
+ (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"]])
]
astChildMap :: AST -> (AST -> AST) -> AST
@@ -169,4 +209,4 @@ applyPatterns node = let matches = filter (not . null . fst) $ map (\(pat,repl)
in if null matches
then astChildMap node applyPatterns
else let ((capdict:_),repl) = head matches -- TODO: don't take the first option of the first match, but use them all
- in replaceCaptures capdict repl
+ in {-applyPatterns $-} replaceCaptures capdict repl