diff options
| -rw-r--r-- | ast.hs | 26 | ||||
| -rw-r--r-- | simplify.hs | 46 |
2 files changed, 58 insertions, 14 deletions
@@ -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 |