Strongly improved, dynamic rule system

5 files changed, 247 insertions, 118 deletions

diff --git a/ast.hs b/ast.hs
index 11aeb9b..d4c669b 100644
--- a/ast.hs
+++ b/ast.hs
@@ -218,12 +218,23 @@ matchOrderedList (pat:pats) (sub:subs) =
               $ matchOrderedList newpats subs) newpatsopts
 
 
+flattenSingle :: AST -> AST
+flattenSingle (Sum args) =
+    let listify (Sum a) = a
+        listify node = [node]
+    in Sum $ concat $ map listify args
+flattenSingle (Product args) =
+    let listify (Product a) = a
+        listify node = [node]
+    in Product $ concat $ map listify args
+flattenSingle node = node
+
 replaceCaptures :: Map.Map String AST -> AST -> AST
 replaceCaptures mp n = case n of
     Number _ -> n
     Variable _ -> n
-    Sum l -> Sum $ map (replaceCaptures mp) l
-    Product l -> Product $ map (replaceCaptures mp) l
+    Sum l -> flattenSingle $ Sum $ map (replaceCaptures mp) l
+    Product l -> flattenSingle $ Product $ map (replaceCaptures mp) l
     Negative n2 -> Negative $ replaceCaptures mp n2
     Reciprocal n2 -> Reciprocal $ replaceCaptures mp n2
     Apply name n2 -> Apply name $ map (replaceCaptures mp) n2
@@ -276,9 +287,9 @@ mapDel f l =
 --pat = Sum [CaptureTerm "x",CaptureTerm "y",Capture "rest",Negative $ Capture "rest"]
 --sub = Sum [Number 1,Number 2,Negative $ Number 1,Variable "kaas",Negative $ Sum [Negative $ Number 1,Variable "kaas"]]
 
-pat = Sum [Product [Capture "x"],Product [Capture "x"]]
-sub = Sum [Product [Number 1],Product [Number 1]]
+--pat = Sum [Product [Capture "x"],Product [Capture "x"]]
+--sub = Sum [Product [Number 1],Product [Number 1]]
 
-main = do
-    let res = astMatch pat sub
-    deepseq res $ putStrLn $ "\x1B[32m"++show res++"\x1B[0m"
+--main = do
+--    let res = astMatch pat sub
+--    deepseq res $ putStrLn $ "\x1B[32m"++show res++"\x1B[0m"
diff --git a/debug.hs b/debug.hs
index 33ca1b0..437f91a 100644
--- a/debug.hs
+++ b/debug.hs
@@ -2,7 +2,7 @@
 
 module Debug where
 
-#if 1
+#if 0
 
 import qualified Debug.Trace as Trace
 
diff --git a/main.hs b/main.hs
index 5beb0e4..b908807 100644
--- a/main.hs
+++ b/main.hs
@@ -1,31 +1,145 @@
 module Main where
 
 import Control.Monad
+import Data.Char
+import Data.List
 import Data.Either
 import Data.Maybe
 import System.Console.Readline
+import System.Exit
+import System.IO
+import qualified Data.Map.Strict as Map
 
+import AST hiding (main)
 import Simplify
 import Parser
 import PrettyPrint
+import Utility
+import Debug
 
 
-repl :: IO ()
-repl = do
+trimlr :: String -> String
+trimlr = reverse . dropWhile isSpace . reverse . dropWhile isSpace
+
+findstr :: String -> String -> Maybe Int
+findstr pat sub = go sub 0
+    where len = length pat
+          go :: String -> Int -> Maybe Int
+          go "" _ = Nothing
+          go sub i = if take len sub == pat then Just i else go (tail sub) (i+1)
+
+mayberead :: Read a => String -> Maybe a
+mayberead s =
+    let r = reads s
+        ok = if null r then False else null $ snd $ head r
+        v = fst $ head r
+    in if ok then Just v else Nothing
+
+readrule :: String -> IO (AST,AST)
+readrule line = do
+    let (patstr',(repstr')) = break (=='|') line
+        patstr = desugar $ trimlr patstr'
+        repstr = desugar $ trimlr $ tail repstr'
+    if null repstr'
+    then die $ "No pipe separator found: " ++ line
+    else do
+        let mpat = mayberead patstr :: Maybe AST
+            mrep = mayberead repstr :: Maybe AST
+        when (isNothing mpat) $ die $ "Could not parse pattern! (from '" ++ patstr ++ "')"
+        when (isNothing mrep) $ die $ "Could not parse replacement! (from '" ++ repstr ++ "')"
+        return (fromJust mpat,fromJust mrep)
+
+desugar :: String -> String
+desugar "" = ""
+desugar ('{':cs) =
+    let midx = findIndex (=='}') cs
+        idx = fromJust midx
+        termcap = head cs == '{' && length cs > idx+1 && cs !! (idx+1) == '}'
+        endidx = if termcap then idx+1 else idx
+        after = drop (endidx+1) cs
+        name' = if termcap then tail $ take (endidx-1) cs else take endidx cs
+        name = map (\c -> if c == '\\' || c == '"' then '_' else c) name'
+    in if isNothing midx
+       then '{':desugar cs
+       else if termcap
+            then let mcolonidx = findIndex (==':') name
+                     colonidx = fromJust mcolonidx
+                     precolon = take colonidx name
+                     postcolon = drop (colonidx+1) name
+                     stub = case postcolon of
+                         "Number" -> "Number 42"
+                         "Variable" -> "Variable \"\""
+                         _ -> trace postcolon undefined
+                 in if isNothing mcolonidx
+                    then "(CaptureTerm \"" ++ name ++ "\")" ++ desugar after
+                    else "(CaptureConstr \"" ++ precolon ++ "\" (" ++ stub ++ "))" ++ desugar after
+            else "(Capture \"" ++ name ++ "\")" ++ desugar after
+desugar (':':cs) =
+    let midx = findIndex (==':') cs
+        endidx = fromJust midx
+        after = drop (endidx+1) cs
+        name = map (\c -> if c == '\\' || c == '"' then '_' else c) $ take endidx cs
+    in if isNothing midx
+       then ':':desugar cs
+       else "Apply \"" ++ name ++ "\" " ++ desugar after
+desugar (c:cs) = c : desugar cs
+
+readrules :: Handle -> IO (Map.Map String [(AST,AST)])
+readrules handle = liftM (uncurry fixincludes) $ go "general" Map.empty Map.empty
+  where
+    go :: String  -- current section
+       -> Map.Map String [String]  -- sections still to be included (#+)
+       -> Map.Map String [(AST,AST)]  -- current rules db
+       -> IO (Map.Map String [(AST,AST)],Map.Map String [String])  -- (rules db,includes)
+    go sect includes db = hIsEOF handle >>= \eof -> if eof then return (db,includes) else do
+        line <- hGetLine handle
+        case take 3 line of
+            "" -> go sect includes db
+            "-- " -> go sect includes db
+            "## " -> go (trimlr $ drop 3 line) includes db
+            "#+ " -> go sect (Map.insertWith (++) sect [trimlr $ drop 3 line] includes) db
+            _ -> readrule (trimlr line) >>= \rule -> go sect includes (Map.insertWith (flip (++)) sect [rule] db)
+
+    fixincludes :: Map.Map String [(AST,AST)]  -- rules db
+                -> Map.Map String [String]  -- to be included sections
+                -> Map.Map String [(AST,AST)]  -- resulting rules db
+    fixincludes db includes = Map.foldlWithKey insertincludes db includes
+      where
+        insertincludes :: Map.Map String [(AST,AST)]  -- db
+                      -> String  -- section
+                      -> [String]  -- sections to be included
+                      -> Map.Map String [(AST,AST)]  -- resulting db
+        insertincludes db sect incls = foldl (\db incl -> insertinclude db sect incl) db incls
+            where insertinclude db sect incl = Map.insertWith (++) sect (fromJust $ Map.lookup incl db) db
+
+
+printrules :: [(AST,AST)] -> IO ()
+printrules db = sequence_ $ foldl (\l (pat,sub) -> l ++ [print pat,putStr " -> ",print sub]) [] db
+
+
+repl :: Map.Map String [(AST,AST)] -> IO ()
+repl db = do
     mline <- readline "> "
     case mline of
         Nothing -> return ()  -- EOF
-        Just "" -> repl
+        Just "" -> repl db
         Just line -> do
             addHistory line
             let eexpr = parseExpression line
             either (putStrLn . ("Error: "++)) handleExpression eexpr
-            repl
+            repl db
     where
+        generaldb = fromJust $ Map.lookup "general" db
+        sanitisedb = fromJust $ Map.lookup "sanitise" db
+        displaydb = fromJust $ Map.lookup "display" db
         handleExpression expr = do
-            print expr
-            let sim = simplify expr
-            print sim
+            putStrLn $ prettyPrint expr
+            let sim = foldl (flip simplify) expr [generaldb,sanitisedb,displaydb]
+            putStrLn $ prettyPrint sim
+
 
 main :: IO ()
-main = repl
+main = do
+    rulesdb <- withFile "rules.txt" ReadMode readrules
+    --sequence_ $ Map.foldlWithKey (\l sect rules -> putStrLn ("## "++sect) : printrules rules : putStrLn "" : l) [] rulesdb
+    repl rulesdb
diff --git a/rules.txt b/rules.txt
new file mode 100644
index 0000000..aa1f44d
--- /dev/null
+++ b/rules.txt
@@ -0,0 +1,96 @@
+## general
+#+ to_internal
+#+ fraction_identities
+#+ identities
+#+ uncollect_sums
+#+ differentiation
+#+ sanitise_epowers
+
+
+## display
+#+ to_display
+#+ fraction_identities
+#+ collect
+#+ identities
+
+
+## general_display
+#+ general
+#+ display
+
+
+## sanitise
+#+ sanitise_epowers
+#+ collect_numbers
+
+
+## collect
+Sum [{{x}},{{x}},{rest}] | Sum [Product [Number 2,{x}],{rest}]
+Sum [{{x}},Product [{{n:Number}},{x}],{rest}] | Sum [Product [Sum [Number 1,{n}],{x}],{rest}]
+Sum [Product [{{n1:Number}},{x}],Product [{{n2:Number}},{x}],{rest}] | Sum [Product [Sum [{n1},{n2}],{x}],{rest}]
+
+Product [{{x}},{{x}},{rest}] | Product [:pow:[{x},Number 2],{rest}]
+Product [{{x}},:pow:[{{x}},{{n}}],{rest}] | Product [:pow:[{x},Sum [{n},Number 1]],{rest}]
+Product [:pow:[{x},{a}],:pow:[{x},{b}],{rest}] | Product [:pow:[{x},Sum [{a},{b}]],{rest}]
+
+
+## uncollect_sums
+Product [Sum [{{a}},{rest}],{prod}] | Sum [Product [{a},{prod}],Product [{rest},{prod}]]
+
+
+## identities
+:pow:[:pow:[{{x}},{{n}}],{{m}}] | :pow:[{x},Product [{n},{m}]]
+:pow:[{{x}},Number 1] | {x}
+
+-- Guarding necessary for x != 0
+:pow:[{x},Number 0] | Number 1
+
+Product [Number 0,{rest}] | Number 0
+Product [Number 1,{rest}] | {rest}
+
+
+## fraction_identities
+Reciprocal (Product [Reciprocal {{x}},{rest}]) | Product [{x},Reciprocal {rest}]
+Product [{{x}},Reciprocal {{x}},{rest}] | {rest}
+Product [{{x}},Reciprocal (Product [{{x}},{rrest}]),{rest}] | Product [{rest},Reciprocal {rrest}]
+
+
+## to_internal
+Reciprocal {a} | :pow:[{a},Number (-1)]
+Negative {a} | Product [Number (-1),{a}]
+:pow:[Product [{{a}},{b}],{exp}] | Product [:pow:[{a},{exp}],:pow:[{b},{exp}]]
+:tan:[{x}] | Product [:sin:[{x}],Reciprocal (:cos:[{x}])]
+
+
+## differentiation
+:d:[{{n:Number}},{x}] | Number 0
+:d:[{{x:Variable}},{{x}}] | Number 1
+:d:[Sum [{{a}},{b}],{{x}}] | Sum [:d:[{a},{x}],:d:[{b},{x}]]
+:d:[Product [{{n:Number}},{a}],{x}] | Product [{n},:d:[{a},{x}]]
+:d:[Product [{{a}},{b}],{x}] | Sum [Product [:d:[{a},{x}],{b}],Product [{a},:d:[{b},{x}]]]
+:d:[:pow:[Variable "E",{ex}],{x}] | Product [:pow:[Variable "E",{ex}],:d:[{ex},{x}]]
+
+-- Guarding probably necessary for a != E
+-- Cannot be generally applied, because {a} may be negative; for differentiation, however, that doesn't matter
+-- :d:[:pow:[{a},{b}],{x}] | :d:[:pow:[Variable "E",Product [{b},:ln:[{a}]]],{x}]
+:d:[:pow:[{a},{b}],{x}] | Product [:pow:[{a},{b}],:d:[Product[{b},:ln:[{a}]],{x}]]
+
+:d:[:ln:[{args}],{x}] | Product [Reciprocal {args},:d:[{args},{x}]]
+:d:[:sin:[{a}],{x}] | Product [:cos:[{a}],:d:[{a},{x}]]
+:d:[:cos:[{a}],{x}] | Product [Number (-1),:sin:[{a}],:d:[{a},{x}]]
+
+
+## sanitise_epowers
+:pow:[Variable "E",:ln:[{arg}]] | {arg}
+:pow:[Variable "E",Product [:ln:[{arg}],{rest}]] | :pow:[{arg},{rest}]
+
+
+## collect_numbers
+Sum [Product [{{n1:Number}},{x}],Product [{{n2:Number}},{x}],{rest}] | Sum [Product [Sum [{n1},{n2}],{x}],{rest}]
+
+
+## to_display
+:pow:[Variable "E",:ln:[{arg}]] | {arg}
+:pow:[Variable "E",Product [:ln:[{arg}],{rest}]] | :pow:[{arg},{rest}]
+:pow:[{x},Number (-1)] | Reciprocal {x}
+Product [:sin:[{x}],Reciprocal (:cos:[{x}]),{rest}] | Product [:tan:[{x}],{rest}]
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