Bugfixing, more patterns!

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