summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authortomsmeding <tom.smeding@gmail.com>2016-06-20 22:07:41 +0200
committertomsmeding <tom.smeding@gmail.com>2016-06-21 22:43:48 +0200
commita65c127558fc96b13ea515194ac28f8b09e065c6 (patch)
tree9d06353148ec20077e77833e31a5e4cc41854d4d
parentdfe39f59f9ad203a8231f85efb54a6030305ca56 (diff)
Strongly improved, dynamic rule system
-rw-r--r--ast.hs25
-rw-r--r--debug.hs2
-rw-r--r--main.hs130
-rw-r--r--rules.txt96
-rw-r--r--simplify.hs112
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