From af425841a63ee73603cc09510d95a36e646ddafd Mon Sep 17 00:00:00 2001
From: Tom Smeding <tom.smeding@gmail.com>
Date: Thu, 19 Apr 2018 11:45:46 +0200
Subject: Build with stack

---
 Simplify.hs | 125 ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
 1 file changed, 125 insertions(+)
 create mode 100644 Simplify.hs

(limited to 'Simplify.hs')

diff --git a/Simplify.hs b/Simplify.hs
new file mode 100644
index 0000000..9ae29f1
--- /dev/null
+++ b/Simplify.hs
@@ -0,0 +1,125 @@
+module Simplify (simplify) where
+
+import Data.List
+import qualified Data.Map.Strict as Map
+
+import AST
+import Utility
+
+import Debug
+import PrettyPrint
+
+tracex :: (Show a) => String -> a -> a
+tracex s x = trace (s ++ ": " ++ show x) x
+
+tracexp :: (PrettyPrint a) => String -> a -> a
+tracexp s x = trace (s ++ ": " ++ prettyPrint x) x
+
+
+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
+flattenSums node = case node of
+    (Negative n) -> Negative $ flattenSums n
+    (Reciprocal n) -> Reciprocal $ flattenSums n
+    (Apply name args) -> Apply name $ map flattenSums args
+    (Sum args) -> case length args of
+        0 -> Number 0
+        1 -> flattenSums $ args !! 0
+        otherwise -> Sum $ concat $ map (listify . flattenSums) args
+        where
+            listify (Sum args) = args
+            listify node = [node]
+    (Product args) -> case length args of
+        0 -> Number 1
+        1 -> flattenSums $ args !! 0
+        otherwise -> Product $ concat $ map (listify . flattenSums) args
+        where
+            listify (Product args) = args
+            listify node = [node]
+    _ -> node
+
+foldNumbers :: AST -> AST
+foldNumbers node = case node of
+    (Negative n) -> let fn = foldNumbers n in case fn of
+        (Number x) -> Number (-x)
+        (Negative n2) -> n2
+        (Product args) -> Product $ Number (-1) : args
+        _ -> Negative $ fn
+    (Reciprocal n) -> let fn = foldNumbers n in case fn of
+        (Number x) -> Number (1/x)
+        (Negative n) -> Negative $ Reciprocal fn
+        (Reciprocal n2) -> n2
+        _ -> Reciprocal $ fn
+    (Apply name args) -> let fargs = 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
+    where
+        dofoldnums func args zerovalue =
+            let foldedArgs = map foldNumbers args
+                (nums,notnums) = partition astIsNumber foldedArgs
+                foldvalue = func $ map (\(Number n) -> n) nums
+            in case length nums of
+                x | x >= 1 -> if foldvalue == zerovalue then notnums else Number foldvalue : notnums
+                otherwise -> foldedArgs
+        dofoldnegsToProd args =
+            let foldedArgs = map foldNumbers args
+                (negs,notnegs) = partition isneg foldedArgs
+                isneg (Negative _) = True
+                isneg (Number n) = n < 0
+                isneg _ = False
+                unneg (Negative n) = n
+                unneg (Number n) = Number $ abs n
+                unneg n = n
+                unnegged = map unneg negs ++ notnegs
+            in case length negs of
+                x | x < 2 -> Product args
+                  | even x -> Product unnegged
+                  | odd x -> Product $ Number (-1) : unnegged
+
+canonicaliseOrder :: AST -> AST
+canonicaliseOrder node = case node of
+    (Number _) -> node
+    (Variable _) -> node
+    (Sum args) -> Sum $ sort args
+    (Product args) -> Product $ sort args
+    (Negative n) -> Negative $ canonicaliseOrder n
+    (Reciprocal n) -> Reciprocal $ canonicaliseOrder n
+    (Apply name args) -> Apply name $ map canonicaliseOrder args
+    (Capture _) -> node
+    (CaptureTerm _) -> node
+    (CaptureConstr _ _) -> node
+
+
+astChildMap :: AST -> (AST -> AST) -> AST
+astChildMap node f = case node of
+    (Number _) -> node
+    (Variable _) -> node
+    (Sum args) -> Sum $ map f args
+    (Product args) -> Product $ map f args
+    (Negative n) -> Negative $ f n
+    (Reciprocal n) -> Reciprocal $ f n
+    (Apply name args) -> Apply name $ map f args
+    (Capture _) -> node
+    (CaptureTerm _) -> node
+    (CaptureConstr _ _) -> node
+
+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 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