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

---
 .gitignore     |   8 +-
 AST.hs         | 295 +++++++++++++++++++++++++++++++++++++++++++++++++++++++++
 Debug.hs       |  23 +++++
 Main.hs        | 145 ++++++++++++++++++++++++++++
 Makefile       |  16 ----
 Parser.hs      | 240 ++++++++++++++++++++++++++++++++++++++++++++++
 PrettyPrint.hs |  11 +++
 Simplify.hs    | 125 ++++++++++++++++++++++++
 Utility.hs     |  28 ++++++
 ast.hs         | 295 ---------------------------------------------------------
 debug.hs       |  23 -----
 main.hs        | 145 ----------------------------
 math.cabal     |  16 ++++
 parser.hs      | 240 ----------------------------------------------
 prettyprint.hs |  11 ---
 simplify.hs    | 125 ------------------------
 stack.yaml     |   6 ++
 utility.hs     |  28 ------
 18 files changed, 895 insertions(+), 885 deletions(-)
 create mode 100644 AST.hs
 create mode 100644 Debug.hs
 create mode 100644 Main.hs
 delete mode 100644 Makefile
 create mode 100644 Parser.hs
 create mode 100644 PrettyPrint.hs
 create mode 100644 Simplify.hs
 create mode 100644 Utility.hs
 delete mode 100644 ast.hs
 delete mode 100644 debug.hs
 delete mode 100644 main.hs
 create mode 100644 math.cabal
 delete mode 100644 parser.hs
 delete mode 100644 prettyprint.hs
 delete mode 100644 simplify.hs
 create mode 100644 stack.yaml
 delete mode 100644 utility.hs

diff --git a/.gitignore b/.gitignore
index 2c67b73..babd9e2 100644
--- a/.gitignore
+++ b/.gitignore
@@ -1,4 +1,8 @@
+main
 *.o
 *.hi
-*.hs[0-9]
-main
+.stack-work/
+.cabal-sandbox
+cabal.sandbox.config
+.DS_Store
+*.swp
diff --git a/AST.hs b/AST.hs
new file mode 100644
index 0000000..d4c669b
--- /dev/null
+++ b/AST.hs
@@ -0,0 +1,295 @@
+{-# LANGUAGE TupleSections, BangPatterns, DeriveDataTypeable #-}
+
+module AST where
+
+import qualified Data.Map.Strict as Map
+import Data.List
+import Data.Data
+import Data.Typeable
+import Control.DeepSeq
+
+import PrettyPrint
+import Debug
+
+
+data AST = Number Double
+         | Variable String
+         | Sum [AST]
+         | Product [AST]
+         | Negative AST
+         | Reciprocal AST
+         | Apply String [AST]
+         -- The following only in patterns:
+         | Capture String
+         | CaptureTerm String
+         | CaptureConstr String AST  -- AST argument only for constructor; only WHNF
+         deriving (Show,Read,Eq,Typeable,Data)
+
+instance PrettyPrint AST where
+    prettyPrint (Number n) = show n
+
+    prettyPrint (Variable n) = n
+
+    prettyPrint (Sum []) = "(+)"
+    prettyPrint (Sum args) = intercalate " + " $ map prettyPrint args
+
+    prettyPrint (Product []) = "(*)"
+    prettyPrint (Product args) = intercalate "*" $ map gopp args
+        where gopp s@(Sum _) = '(' : prettyPrint s ++ ")"
+              gopp n = prettyPrint n
+
+    prettyPrint (Negative n) = '-' : case n of
+        s@(Sum _) -> '(' : prettyPrint s ++ ")"
+        n -> prettyPrint n
+
+    prettyPrint (Reciprocal n) = "1/" ++ case n of
+        s@(Sum _) -> '(' : prettyPrint s ++ ")"
+        s@(Product _) -> '(' : prettyPrint s ++ ")"
+        s@(Reciprocal _) -> '(' : prettyPrint s ++ ")"
+        n -> prettyPrint n
+
+    prettyPrint (Apply name args) = name ++ "(" ++ intercalate "," (map prettyPrint args) ++ ")"
+
+    prettyPrint (Capture name) = '[' : name ++ "]"
+
+    prettyPrint (CaptureTerm name) = '[' : '[' : name ++ "]]"
+
+    prettyPrint (CaptureConstr name c) = '[' : name ++ ":" ++ showConstr (toConstr c) ++ "]"
+
+instance NFData AST where
+    rnf (Number !_) = ()
+    rnf (Variable !_) = ()
+    rnf (Sum l) = seq (length $ map rnf l) ()
+    rnf (Product l) = seq (length $ map rnf l) ()
+    rnf (Negative n) = rnf n
+    rnf (Reciprocal n) = rnf n
+    rnf (Apply !_ l) = seq (length $ map rnf l) ()
+    rnf (Capture !_) = ()
+    rnf (CaptureTerm !_) = ()
+    rnf (CaptureConstr !_ !_) = ()  -- explicitly not deepseq'ing the ast node
+
+instance Ord AST where
+    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
+    compare (Number _) _ = LT
+    compare _ (Number _) = GT
+    compare (Variable _) _ = LT
+    compare _ (Variable _) = GT
+    compare (Sum _) _ = LT
+    compare _ (Sum _) = GT
+    compare (Product _) _ = LT
+    compare _ (Product _) = GT
+    compare (Negative _) _ = LT
+    compare _ (Negative _) = GT
+    compare (Reciprocal _) _ = LT
+    compare _ (Reciprocal _) = GT
+    compare (Apply _ _) _ = LT
+    compare _ (Apply _ _) = GT
+    compare (CaptureTerm _) _ = LT
+    compare _ (CaptureTerm _) = GT
+    -- compare (CaptureConstr _ _) _ = LT
+    -- compare _ (CaptureConstr _ _) = GT
+
+
+astIsNumber :: AST -> Bool
+astIsNumber (Number _) = True
+astIsNumber _ = False
+
+astIsCapture :: AST -> Bool
+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
+        then False
+        else any Map.null res
+
+
+astMatch :: AST                   -- pattern
+         -> AST                   -- subject
+         -> [Map.Map String AST]  -- list of possible capture assignments
+astMatch pat sub = assertS "No captures in astMatch subject" (not $ hasCaptures sub) $
+    case pat of
+        Number x -> case sub of
+            Number y | x == y -> [Map.empty]
+            _ -> []
+
+        Variable name -> case sub of
+            Variable name2 | name == name2 -> [Map.empty]
+            _ -> []
+
+        Sum [term] -> case sub of
+            Sum l2 -> matchList Sum [term] l2
+            s -> astMatch term s
+
+        Sum l -> case sub of
+            Sum l2 -> matchList Sum l l2
+            _ -> []
+
+        Product [term] -> case sub of
+            Product l2 -> matchList Product [term] l2
+            s -> astMatch term s
+
+        Product l -> case sub of
+            Product l2 -> matchList Product l l2
+            _ -> []
+
+        Negative n -> case sub of
+            Negative n2 -> astMatch n n2
+            _ -> []
+
+        Reciprocal n -> case sub of
+            Reciprocal n2 -> astMatch n n2
+            _ -> []
+
+        Apply name l -> case sub of
+            Apply name2 l2 | name == name2 -> matchOrderedList l l2
+            _ -> []
+
+        Capture name -> [Map.singleton name sub]
+
+        CaptureTerm name -> [Map.singleton name sub]
+
+        CaptureConstr name constr ->
+            if toConstr sub == toConstr constr
+                then [Map.singleton name sub]
+                else []
+
+
+matchList :: ([AST] -> AST)        -- AST constructor for this list (for insertion in capture)
+          -> [AST]                 -- unordered patterns
+          -> [AST]                 -- unordered subjects
+          -> [Map.Map String AST]  -- list of possible capture assignments
+matchList constr pats subs =
+    let ordered = sort pats
+        (captures,nocaps) = span astIsCapture ordered
+    in assertS "At most one capture in sum/product" (length captures <= 1) $ case captures of
+        [] -> matchListDBG Nothing nocaps subs
+        [c] -> matchListDBG (Just c) nocaps subs
+    where matchList' :: Maybe AST -> [AST] -> [AST] -> [Map.Map String AST]
+          matchList' Nothing [] [] = [Map.empty]
+          matchList' Nothing [] _ = []
+          matchList' (Just (Capture name)) [] subs = [Map.singleton name $ constr subs]
+          matchList' (Just node) [] subs = astMatch node (constr subs)
+          matchList' mcap (pat:pats) subs =
+              let firstmatches = concat $ mapDel (\s other -> map (,other) $ astMatch pat s) subs
+                  processed = concat
+                              $ map (\(ass,rest) ->
+                                         let replpats = map (replaceCaptures ass) pats
+                                             replmcap = fmap (replaceCaptures ass) mcap
+                                         in map (Map.union ass) $ matchListDBG replmcap replpats rest)
+                                    firstmatches
+              in {-trace ("firstmatches = "++show firstmatches) $ trace ("processed = "++show processed) $-} processed
+
+          matchListDBG :: Maybe AST -> [AST] -> [AST] -> [Map.Map String AST]
+          matchListDBG mcap pats subs = {-force $ trace ("\n<< "++show (mcap,pats,subs)++" >>\n")
+                                        $-} matchList' mcap pats subs
+
+
+matchOrderedList :: [AST]                 -- ordered patterns
+                 -> [AST]                 -- ordered subjects
+                 -> [Map.Map String AST]  -- list of possible capture assignments
+matchOrderedList [] [] = [Map.empty]
+matchOrderedList [] _ = []
+matchOrderedList _ [] = []
+matchOrderedList (pat:pats) (sub:subs) =
+    let opts = astMatch pat sub
+        newpatsopts = [(map (replaceCaptures opt) pats,opt) | opt <- opts]
+            -- ^ list of possible refined versions of the (rest of the) pattern list
+    in {-trace (show (pat:pats) ++ " -- " ++ show (sub:subs)) $ traceShow opts $-}
+       concat $ map (\(newpats,opt) -> map (Map.union opt)
+              $ 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 -> 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
+    Capture name -> maybe n id $ Map.lookup name mp
+    CaptureTerm name -> maybe n id $ Map.lookup name mp
+    CaptureConstr name c -> maybe n id $ Map.lookup name mp
+
+
+hasCaptures :: AST -> Bool
+hasCaptures n = case n of
+    Number _ -> False
+    Variable _ -> False
+    Sum l -> any id [hasCaptures m | m <- l]
+    Product l -> any id [hasCaptures m | m <- l]
+    Negative m -> hasCaptures m
+    Reciprocal m -> hasCaptures m
+    Apply _ l -> any id [hasCaptures m | m <- l]
+    Capture _ -> True
+    CaptureTerm _ -> True
+    CaptureConstr _ _ -> True
+
+
+assert :: Bool -> a -> a
+assert = assertS "(no reason)"
+
+assertS :: String -> Bool -> a -> a
+assertS _ True = id
+assertS s False = error $ "Condition not satisfied in assert: " ++ s
+
+
+mapDel :: (a -> [a] -> b) -> [a] -> [b]
+mapDel _ [] = []
+mapDel f l =
+    let splits = zip l
+                 $ map (\(a,b:bs) -> a++bs)
+                 $ iterate (\(a,b:bs) -> (a++[b],bs)) ([],l)
+    in map (uncurry f) splits
+
+
+-- some testing things
+--pat = Sum [Number 1,Capture "x",Negative $ Capture "x"]
+--sub = Sum [Number 4,Variable "a",Number 1,Negative $ Sum [Variable "a",Number 4]]
+
+--pat = Sum [Negative $ Capture "x"]
+--sub = Sum [Negative $ Sum [Variable "a",Number 4]]
+
+--pat = Sum [Capture "x",Negative (Capture "x"),CaptureTerm "y",CaptureTerm "z"]
+--sub = let x = Reciprocal (Number 7) in Sum [x,Negative x,Number 7,Number 8]
+
+--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]]
+
+--main = do
+--    let res = astMatch pat sub
+--    deepseq res $ putStrLn $ "\x1B[32m"++show res++"\x1B[0m"
diff --git a/Debug.hs b/Debug.hs
new file mode 100644
index 0000000..437f91a
--- /dev/null
+++ b/Debug.hs
@@ -0,0 +1,23 @@
+{-# LANGUAGE CPP #-}
+
+module Debug where
+
+#if 0
+
+import qualified Debug.Trace as Trace
+
+trace :: String -> a -> a
+trace = Trace.trace
+
+traceShow :: (Show a) => a -> b -> b
+traceShow = Trace.traceShow
+
+#else
+
+trace :: String -> a -> a
+trace = flip const
+
+traceShow :: a -> b -> b
+traceShow = flip const
+
+#endif
diff --git a/Main.hs b/Main.hs
new file mode 100644
index 0000000..b908807
--- /dev/null
+++ b/Main.hs
@@ -0,0 +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
+
+
+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 db
+        Just line -> do
+            addHistory line
+            let eexpr = parseExpression line
+            either (putStrLn . ("Error: "++)) handleExpression eexpr
+            repl db
+    where
+        generaldb = fromJust $ Map.lookup "general" db
+        sanitisedb = fromJust $ Map.lookup "sanitise" db
+        displaydb = fromJust $ Map.lookup "display" db
+        handleExpression expr = do
+            putStrLn $ prettyPrint expr
+            let sim = foldl (flip simplify) expr [generaldb,sanitisedb,displaydb]
+            putStrLn $ prettyPrint sim
+
+
+main :: IO ()
+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/Makefile b/Makefile
deleted file mode 100644
index 6d4ca8f..0000000
--- a/Makefile
+++ /dev/null
@@ -1,16 +0,0 @@
-BIN = main
-
-hs_files = $(wildcard *.hs)
-
-.PHONY: all clean remake
-
-all: $(BIN)
-
-clean:
-	rm -f *.hi *.o $(BIN)
-
-remake: clean all
-
-
-$(BIN): $(hs_files)
-	ghc -O3 -o $(BIN) $^
diff --git a/Parser.hs b/Parser.hs
new file mode 100644
index 0000000..636c04f
--- /dev/null
+++ b/Parser.hs
@@ -0,0 +1,240 @@
+module Parser (parseExpression) where
+
+import Control.Applicative
+import Control.Monad
+import Data.Char
+import Data.Maybe
+
+import AST
+import Utility
+
+
+parseExpression :: String -> Either String AST
+parseExpression s = case parse pexpression s of
+    ((node,rest):_) -> case rest of
+        "" -> Right node
+        s -> Left $ "Cannot parse from '" ++ take 10 rest ++ "'"
+    _ -> Left "No valid parse"
+
+
+newtype Parser a = Parser (String -> [(a,String)])
+
+parse :: Parser a -> String -> [(a,String)]
+parse (Parser p) = p
+
+instance Functor Parser where
+    fmap f p = Parser (\cs -> map (\(a,s) -> (f a,s)) $ parse p cs)
+
+instance Applicative Parser where
+    pure x = Parser (\cs -> [(x,cs)])
+    (<*>) f p = Parser (\cs -> concat $
+        map (\(a,s) -> parse (fmap a p) s) $ parse f cs)
+
+instance Monad Parser where
+    p >>= f = Parser (\cs -> concat $
+        map (\(a,s) -> parse (f a) s) $ parse p cs)
+
+instance Alternative Parser where
+    empty = Parser (\_ -> [])
+    (<|>) p q = Parser (\cs -> parse p cs ++ parse q cs)
+
+instance MonadPlus Parser
+
+
+--The deterministic choice operator: choose the first possibile parse (if
+--available at all) from the results given by the two parsers.
+--mplus is the non-deterministic choice operator; it would give all results.
+mplus1 :: Parser a -> Parser a -> Parser a
+mplus1 p q = Parser $ \cs -> case parse (mplus p q) cs of
+    [] -> []
+    (x:_) -> [x]
+
+--(++) = mplus
+(+++) = mplus1
+
+
+pitem :: Parser Char
+pitem = Parser $ \s -> case s of
+    "" -> []
+    (c:cs) -> [(c,cs)]
+
+psat :: (Char -> Bool) -> Parser Char
+psat f = do
+    c <- pitem
+    if f c then return c else mzero
+
+--checks that the next char satisfies the predicate; does NOT consume characters
+passert :: (Char -> Bool) -> Parser ()
+passert p = Parser $ \s -> case s of
+    "" -> []
+    (c:_) -> if p c then [((),s)] else []
+
+pchar :: Char -> Parser Char
+pchar c = psat (==c)
+
+pstring :: String -> Parser String
+pstring "" = return ""
+pstring (c:cs) = do
+    pchar c
+    pstring cs
+    return (c:cs)
+
+pmany :: Parser a -> Parser [a]
+pmany p = pmany1 p +++ return []
+
+pmany1 :: Parser a -> Parser [a]
+pmany1 p = do
+    a <- p
+    as <- pmany p
+    return (a:as)
+
+pinteger :: Parser Int
+pinteger = do
+    s <- pmany $ psat isDigit
+    return $ read s
+
+pdouble :: Parser Double
+pdouble = Parser reads
+
+pquotstring :: Parser String
+pquotstring = Parser reads
+
+poptws :: Parser String
+poptws = Parser $ pure . span isSpace
+
+pws :: Parser String
+pws = Parser $ \s -> case span isSpace s of
+    ("",_) -> []
+    tup@(_,_) -> [tup]
+
+pword :: Parser String
+pword = do
+    c <- psat $ options [isAlpha,(=='_')]
+    cs <- pmany $ psat $ options [isAlpha,isDigit,(=='_')]
+    return (c:cs)
+
+
+pnumber :: Parser AST
+pnumber = liftM Number pdouble
+
+pvariable :: Parser AST
+pvariable = liftM Variable $ pstring "PI" +++ (liftM pure (psat isAlpha))
+
+pinfixoperator :: (Char,Char)  -- +/- symbols
+               -> Parser AST  -- term parser
+               -> ([AST] -> AST)  -- Sum constructor
+               -> (AST -> AST)  -- Negative constructor
+               -> Bool  -- whether the plus sign is optional
+               -> Bool  -- whether a negative sign cannot follow after a term
+               -> Parser AST  -- Resulting parser
+pinfixoperator (plus,minus) pterm sumconstr negconstr plusopt noneg = do
+    term <- pterm
+    pmoreterms term +++ return (sumconstr [term])
+    where
+        pmoreterms term = if plusopt
+            then pmoretermsplus term +++ pmoretermsminus term +++ pmoretermsnothing term
+            else pmoretermsplus term +++ pmoretermsminus term
+
+        pmoretermsplus term = do
+            poptws
+            pchar plus
+            poptws
+            nextterm <- pterm
+            let thissum = sumconstr [term,nextterm]
+            pmoreterms thissum +++ return thissum
+        pmoretermsminus term = do
+            poptws
+            pchar minus
+            poptws
+            nextterm <- pterm
+            let thissum = sumconstr [term,negconstr nextterm]
+            pmoreterms thissum +++ return thissum
+        pmoretermsnothing term = do
+            poptws
+            if noneg then passert (/='-') else return ()
+            nextterm <- pterm
+            let thissum = sumconstr [term,nextterm]
+            pmoreterms thissum +++ return thissum
+
+psum :: Parser AST
+psum = do
+    poptws
+    res <- pinfixoperator ('+','-') pproduct Sum Negative False False
+    poptws
+    return res
+
+pproduct :: Parser AST
+pproduct = pinfixoperator ('*','/') pfactor Product Reciprocal True True
+
+pfactor :: Parser AST
+pfactor = pnegative +++ pfactornoneg +++ pcapture +++ pcaptureterm
+
+pnegative :: Parser AST
+pnegative = do {pchar '-'; poptws; f <- pfactor; return $ Negative f} +++ pfactornoneg
+
+pfactornoneg :: Parser AST
+pfactornoneg = do
+    fact <- pnumber +++ pparenthetical +++ pfunctioncall +++ pvariable
+    ppower fact +++ pfactorial fact +++ return fact
+    where
+        ppower fact = do
+            poptws
+            pchar '^'
+            poptws
+            fact2 <- pfactornoneg
+            return $ Apply "pow" [fact,fact2]
+        pfactorial fact = do
+            poptws
+            pchar '!'
+            return $ Apply "fact" [fact]
+
+
+pparenthetical :: Parser AST
+pparenthetical = do
+    pchar '('
+    poptws
+    sum <- psum
+    poptws
+    pchar ')'
+    return sum
+
+pfunctioncall :: Parser AST
+pfunctioncall = do
+    name <- pword
+    poptws
+    pchar '('
+    poptws
+    args <- parglist
+    poptws
+    pchar ')'
+    return $ Apply name args
+    where
+        parglist = do
+            arg <- parg
+            poptws
+            pmoreargs arg +++ return [arg]
+        pmoreargs arg = do
+            pchar ','
+            poptws
+            args <- parglist
+            return (arg:args)
+        parg = pexpression
+
+pcapture :: Parser AST
+pcapture = do
+    pchar '['
+    name <- pmany1 $ psat (/=']')
+    pchar ']'
+    return $ Capture name
+
+pcaptureterm :: Parser AST
+pcaptureterm = do
+    pchar '['
+    pchar '['
+    name <- pmany1 $ psat (/=']')
+    pchar ']'
+    pchar ']'
+    return $ CaptureTerm name
+
+pexpression :: Parser AST
+pexpression = psum
diff --git a/PrettyPrint.hs b/PrettyPrint.hs
new file mode 100644
index 0000000..45ca6ac
--- /dev/null
+++ b/PrettyPrint.hs
@@ -0,0 +1,11 @@
+{-# LANGUAGE FlexibleInstances #-}
+
+module PrettyPrint where
+
+class PrettyPrint a where
+    prettyPrint :: a -> String
+    -- a = a
+
+instance PrettyPrint String where prettyPrint = id
+instance PrettyPrint Double where prettyPrint = show
+instance PrettyPrint Int where prettyPrint = show
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
diff --git a/Utility.hs b/Utility.hs
new file mode 100644
index 0000000..a160cb7
--- /dev/null
+++ b/Utility.hs
@@ -0,0 +1,28 @@
+module Utility where
+
+import Data.List
+
+--if any of the predicates returns true, options returns true
+options :: [a -> Bool] -> a -> Bool
+options l x = any id [f x | f <- l]
+
+fixpoint :: (Eq a) => (a -> a) -> a -> a
+fixpoint f x = let fx = f x in if fx == x then x else fixpoint f fx
+
+setcompareBy :: (a -> a -> Bool) -> [a] -> [a] -> Bool
+setcompareBy _ [] [] = True
+setcompareBy _ [] _ = False
+setcompareBy _ _ [] = False
+setcompareBy p a@(x:xs) b = length a == length b && setcompareBy p xs (deleteBy p x b)
+
+deleteIndex :: Int -> [a] -> [a]
+deleteIndex 0 (_:xs) = xs
+deleteIndex i (x:xs) | i > 0 = x : deleteIndex (i-1) xs
+
+fromLeft :: Either a b -> a
+fromLeft (Left a) = a
+fromLeft (Right _) = undefined
+
+fromRight :: Either a b -> b
+fromRight (Left _) = undefined
+fromRight (Right b) = b
diff --git a/ast.hs b/ast.hs
deleted file mode 100644
index d4c669b..0000000
--- a/ast.hs
+++ /dev/null
@@ -1,295 +0,0 @@
-{-# LANGUAGE TupleSections, BangPatterns, DeriveDataTypeable #-}
-
-module AST where
-
-import qualified Data.Map.Strict as Map
-import Data.List
-import Data.Data
-import Data.Typeable
-import Control.DeepSeq
-
-import PrettyPrint
-import Debug
-
-
-data AST = Number Double
-         | Variable String
-         | Sum [AST]
-         | Product [AST]
-         | Negative AST
-         | Reciprocal AST
-         | Apply String [AST]
-         -- The following only in patterns:
-         | Capture String
-         | CaptureTerm String
-         | CaptureConstr String AST  -- AST argument only for constructor; only WHNF
-         deriving (Show,Read,Eq,Typeable,Data)
-
-instance PrettyPrint AST where
-    prettyPrint (Number n) = show n
-
-    prettyPrint (Variable n) = n
-
-    prettyPrint (Sum []) = "(+)"
-    prettyPrint (Sum args) = intercalate " + " $ map prettyPrint args
-
-    prettyPrint (Product []) = "(*)"
-    prettyPrint (Product args) = intercalate "*" $ map gopp args
-        where gopp s@(Sum _) = '(' : prettyPrint s ++ ")"
-              gopp n = prettyPrint n
-
-    prettyPrint (Negative n) = '-' : case n of
-        s@(Sum _) -> '(' : prettyPrint s ++ ")"
-        n -> prettyPrint n
-
-    prettyPrint (Reciprocal n) = "1/" ++ case n of
-        s@(Sum _) -> '(' : prettyPrint s ++ ")"
-        s@(Product _) -> '(' : prettyPrint s ++ ")"
-        s@(Reciprocal _) -> '(' : prettyPrint s ++ ")"
-        n -> prettyPrint n
-
-    prettyPrint (Apply name args) = name ++ "(" ++ intercalate "," (map prettyPrint args) ++ ")"
-
-    prettyPrint (Capture name) = '[' : name ++ "]"
-
-    prettyPrint (CaptureTerm name) = '[' : '[' : name ++ "]]"
-
-    prettyPrint (CaptureConstr name c) = '[' : name ++ ":" ++ showConstr (toConstr c) ++ "]"
-
-instance NFData AST where
-    rnf (Number !_) = ()
-    rnf (Variable !_) = ()
-    rnf (Sum l) = seq (length $ map rnf l) ()
-    rnf (Product l) = seq (length $ map rnf l) ()
-    rnf (Negative n) = rnf n
-    rnf (Reciprocal n) = rnf n
-    rnf (Apply !_ l) = seq (length $ map rnf l) ()
-    rnf (Capture !_) = ()
-    rnf (CaptureTerm !_) = ()
-    rnf (CaptureConstr !_ !_) = ()  -- explicitly not deepseq'ing the ast node
-
-instance Ord AST where
-    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
-    compare (Number _) _ = LT
-    compare _ (Number _) = GT
-    compare (Variable _) _ = LT
-    compare _ (Variable _) = GT
-    compare (Sum _) _ = LT
-    compare _ (Sum _) = GT
-    compare (Product _) _ = LT
-    compare _ (Product _) = GT
-    compare (Negative _) _ = LT
-    compare _ (Negative _) = GT
-    compare (Reciprocal _) _ = LT
-    compare _ (Reciprocal _) = GT
-    compare (Apply _ _) _ = LT
-    compare _ (Apply _ _) = GT
-    compare (CaptureTerm _) _ = LT
-    compare _ (CaptureTerm _) = GT
-    -- compare (CaptureConstr _ _) _ = LT
-    -- compare _ (CaptureConstr _ _) = GT
-
-
-astIsNumber :: AST -> Bool
-astIsNumber (Number _) = True
-astIsNumber _ = False
-
-astIsCapture :: AST -> Bool
-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
-        then False
-        else any Map.null res
-
-
-astMatch :: AST                   -- pattern
-         -> AST                   -- subject
-         -> [Map.Map String AST]  -- list of possible capture assignments
-astMatch pat sub = assertS "No captures in astMatch subject" (not $ hasCaptures sub) $
-    case pat of
-        Number x -> case sub of
-            Number y | x == y -> [Map.empty]
-            _ -> []
-
-        Variable name -> case sub of
-            Variable name2 | name == name2 -> [Map.empty]
-            _ -> []
-
-        Sum [term] -> case sub of
-            Sum l2 -> matchList Sum [term] l2
-            s -> astMatch term s
-
-        Sum l -> case sub of
-            Sum l2 -> matchList Sum l l2
-            _ -> []
-
-        Product [term] -> case sub of
-            Product l2 -> matchList Product [term] l2
-            s -> astMatch term s
-
-        Product l -> case sub of
-            Product l2 -> matchList Product l l2
-            _ -> []
-
-        Negative n -> case sub of
-            Negative n2 -> astMatch n n2
-            _ -> []
-
-        Reciprocal n -> case sub of
-            Reciprocal n2 -> astMatch n n2
-            _ -> []
-
-        Apply name l -> case sub of
-            Apply name2 l2 | name == name2 -> matchOrderedList l l2
-            _ -> []
-
-        Capture name -> [Map.singleton name sub]
-
-        CaptureTerm name -> [Map.singleton name sub]
-
-        CaptureConstr name constr ->
-            if toConstr sub == toConstr constr
-                then [Map.singleton name sub]
-                else []
-
-
-matchList :: ([AST] -> AST)        -- AST constructor for this list (for insertion in capture)
-          -> [AST]                 -- unordered patterns
-          -> [AST]                 -- unordered subjects
-          -> [Map.Map String AST]  -- list of possible capture assignments
-matchList constr pats subs =
-    let ordered = sort pats
-        (captures,nocaps) = span astIsCapture ordered
-    in assertS "At most one capture in sum/product" (length captures <= 1) $ case captures of
-        [] -> matchListDBG Nothing nocaps subs
-        [c] -> matchListDBG (Just c) nocaps subs
-    where matchList' :: Maybe AST -> [AST] -> [AST] -> [Map.Map String AST]
-          matchList' Nothing [] [] = [Map.empty]
-          matchList' Nothing [] _ = []
-          matchList' (Just (Capture name)) [] subs = [Map.singleton name $ constr subs]
-          matchList' (Just node) [] subs = astMatch node (constr subs)
-          matchList' mcap (pat:pats) subs =
-              let firstmatches = concat $ mapDel (\s other -> map (,other) $ astMatch pat s) subs
-                  processed = concat
-                              $ map (\(ass,rest) ->
-                                         let replpats = map (replaceCaptures ass) pats
-                                             replmcap = fmap (replaceCaptures ass) mcap
-                                         in map (Map.union ass) $ matchListDBG replmcap replpats rest)
-                                    firstmatches
-              in {-trace ("firstmatches = "++show firstmatches) $ trace ("processed = "++show processed) $-} processed
-
-          matchListDBG :: Maybe AST -> [AST] -> [AST] -> [Map.Map String AST]
-          matchListDBG mcap pats subs = {-force $ trace ("\n<< "++show (mcap,pats,subs)++" >>\n")
-                                        $-} matchList' mcap pats subs
-
-
-matchOrderedList :: [AST]                 -- ordered patterns
-                 -> [AST]                 -- ordered subjects
-                 -> [Map.Map String AST]  -- list of possible capture assignments
-matchOrderedList [] [] = [Map.empty]
-matchOrderedList [] _ = []
-matchOrderedList _ [] = []
-matchOrderedList (pat:pats) (sub:subs) =
-    let opts = astMatch pat sub
-        newpatsopts = [(map (replaceCaptures opt) pats,opt) | opt <- opts]
-            -- ^ list of possible refined versions of the (rest of the) pattern list
-    in {-trace (show (pat:pats) ++ " -- " ++ show (sub:subs)) $ traceShow opts $-}
-       concat $ map (\(newpats,opt) -> map (Map.union opt)
-              $ 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 -> 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
-    Capture name -> maybe n id $ Map.lookup name mp
-    CaptureTerm name -> maybe n id $ Map.lookup name mp
-    CaptureConstr name c -> maybe n id $ Map.lookup name mp
-
-
-hasCaptures :: AST -> Bool
-hasCaptures n = case n of
-    Number _ -> False
-    Variable _ -> False
-    Sum l -> any id [hasCaptures m | m <- l]
-    Product l -> any id [hasCaptures m | m <- l]
-    Negative m -> hasCaptures m
-    Reciprocal m -> hasCaptures m
-    Apply _ l -> any id [hasCaptures m | m <- l]
-    Capture _ -> True
-    CaptureTerm _ -> True
-    CaptureConstr _ _ -> True
-
-
-assert :: Bool -> a -> a
-assert = assertS "(no reason)"
-
-assertS :: String -> Bool -> a -> a
-assertS _ True = id
-assertS s False = error $ "Condition not satisfied in assert: " ++ s
-
-
-mapDel :: (a -> [a] -> b) -> [a] -> [b]
-mapDel _ [] = []
-mapDel f l =
-    let splits = zip l
-                 $ map (\(a,b:bs) -> a++bs)
-                 $ iterate (\(a,b:bs) -> (a++[b],bs)) ([],l)
-    in map (uncurry f) splits
-
-
--- some testing things
---pat = Sum [Number 1,Capture "x",Negative $ Capture "x"]
---sub = Sum [Number 4,Variable "a",Number 1,Negative $ Sum [Variable "a",Number 4]]
-
---pat = Sum [Negative $ Capture "x"]
---sub = Sum [Negative $ Sum [Variable "a",Number 4]]
-
---pat = Sum [Capture "x",Negative (Capture "x"),CaptureTerm "y",CaptureTerm "z"]
---sub = let x = Reciprocal (Number 7) in Sum [x,Negative x,Number 7,Number 8]
-
---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]]
-
---main = do
---    let res = astMatch pat sub
---    deepseq res $ putStrLn $ "\x1B[32m"++show res++"\x1B[0m"
diff --git a/debug.hs b/debug.hs
deleted file mode 100644
index 437f91a..0000000
--- a/debug.hs
+++ /dev/null
@@ -1,23 +0,0 @@
-{-# LANGUAGE CPP #-}
-
-module Debug where
-
-#if 0
-
-import qualified Debug.Trace as Trace
-
-trace :: String -> a -> a
-trace = Trace.trace
-
-traceShow :: (Show a) => a -> b -> b
-traceShow = Trace.traceShow
-
-#else
-
-trace :: String -> a -> a
-trace = flip const
-
-traceShow :: a -> b -> b
-traceShow = flip const
-
-#endif
diff --git a/main.hs b/main.hs
deleted file mode 100644
index b908807..0000000
--- a/main.hs
+++ /dev/null
@@ -1,145 +0,0 @@
-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
-
-
-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 db
-        Just line -> do
-            addHistory line
-            let eexpr = parseExpression line
-            either (putStrLn . ("Error: "++)) handleExpression eexpr
-            repl db
-    where
-        generaldb = fromJust $ Map.lookup "general" db
-        sanitisedb = fromJust $ Map.lookup "sanitise" db
-        displaydb = fromJust $ Map.lookup "display" db
-        handleExpression expr = do
-            putStrLn $ prettyPrint expr
-            let sim = foldl (flip simplify) expr [generaldb,sanitisedb,displaydb]
-            putStrLn $ prettyPrint sim
-
-
-main :: IO ()
-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/math.cabal b/math.cabal
new file mode 100644
index 0000000..9cf7d1a
--- /dev/null
+++ b/math.cabal
@@ -0,0 +1,16 @@
+name:          math
+version:       0.1.0
+cabal-version: >= 1.10
+build-type:    Simple
+license:       MIT
+author:        Tom Smeding
+maintainer:    tom.smeding@gmail.com
+
+executable            math
+    hs-source-dirs:   .
+    main-is:          Main.hs
+    default-language: Haskell2010
+    ghc-options:      -Wall -O2
+    build-depends:    base >= 4 && < 5,
+                      containers, readline, deepseq
+    other-modules:    AST, Debug, Parser, PrettyPrint, Simplify, Utility
diff --git a/parser.hs b/parser.hs
deleted file mode 100644
index 636c04f..0000000
--- a/parser.hs
+++ /dev/null
@@ -1,240 +0,0 @@
-module Parser (parseExpression) where
-
-import Control.Applicative
-import Control.Monad
-import Data.Char
-import Data.Maybe
-
-import AST
-import Utility
-
-
-parseExpression :: String -> Either String AST
-parseExpression s = case parse pexpression s of
-    ((node,rest):_) -> case rest of
-        "" -> Right node
-        s -> Left $ "Cannot parse from '" ++ take 10 rest ++ "'"
-    _ -> Left "No valid parse"
-
-
-newtype Parser a = Parser (String -> [(a,String)])
-
-parse :: Parser a -> String -> [(a,String)]
-parse (Parser p) = p
-
-instance Functor Parser where
-    fmap f p = Parser (\cs -> map (\(a,s) -> (f a,s)) $ parse p cs)
-
-instance Applicative Parser where
-    pure x = Parser (\cs -> [(x,cs)])
-    (<*>) f p = Parser (\cs -> concat $
-        map (\(a,s) -> parse (fmap a p) s) $ parse f cs)
-
-instance Monad Parser where
-    p >>= f = Parser (\cs -> concat $
-        map (\(a,s) -> parse (f a) s) $ parse p cs)
-
-instance Alternative Parser where
-    empty = Parser (\_ -> [])
-    (<|>) p q = Parser (\cs -> parse p cs ++ parse q cs)
-
-instance MonadPlus Parser
-
-
---The deterministic choice operator: choose the first possibile parse (if
---available at all) from the results given by the two parsers.
---mplus is the non-deterministic choice operator; it would give all results.
-mplus1 :: Parser a -> Parser a -> Parser a
-mplus1 p q = Parser $ \cs -> case parse (mplus p q) cs of
-    [] -> []
-    (x:_) -> [x]
-
---(++) = mplus
-(+++) = mplus1
-
-
-pitem :: Parser Char
-pitem = Parser $ \s -> case s of
-    "" -> []
-    (c:cs) -> [(c,cs)]
-
-psat :: (Char -> Bool) -> Parser Char
-psat f = do
-    c <- pitem
-    if f c then return c else mzero
-
---checks that the next char satisfies the predicate; does NOT consume characters
-passert :: (Char -> Bool) -> Parser ()
-passert p = Parser $ \s -> case s of
-    "" -> []
-    (c:_) -> if p c then [((),s)] else []
-
-pchar :: Char -> Parser Char
-pchar c = psat (==c)
-
-pstring :: String -> Parser String
-pstring "" = return ""
-pstring (c:cs) = do
-    pchar c
-    pstring cs
-    return (c:cs)
-
-pmany :: Parser a -> Parser [a]
-pmany p = pmany1 p +++ return []
-
-pmany1 :: Parser a -> Parser [a]
-pmany1 p = do
-    a <- p
-    as <- pmany p
-    return (a:as)
-
-pinteger :: Parser Int
-pinteger = do
-    s <- pmany $ psat isDigit
-    return $ read s
-
-pdouble :: Parser Double
-pdouble = Parser reads
-
-pquotstring :: Parser String
-pquotstring = Parser reads
-
-poptws :: Parser String
-poptws = Parser $ pure . span isSpace
-
-pws :: Parser String
-pws = Parser $ \s -> case span isSpace s of
-    ("",_) -> []
-    tup@(_,_) -> [tup]
-
-pword :: Parser String
-pword = do
-    c <- psat $ options [isAlpha,(=='_')]
-    cs <- pmany $ psat $ options [isAlpha,isDigit,(=='_')]
-    return (c:cs)
-
-
-pnumber :: Parser AST
-pnumber = liftM Number pdouble
-
-pvariable :: Parser AST
-pvariable = liftM Variable $ pstring "PI" +++ (liftM pure (psat isAlpha))
-
-pinfixoperator :: (Char,Char)  -- +/- symbols
-               -> Parser AST  -- term parser
-               -> ([AST] -> AST)  -- Sum constructor
-               -> (AST -> AST)  -- Negative constructor
-               -> Bool  -- whether the plus sign is optional
-               -> Bool  -- whether a negative sign cannot follow after a term
-               -> Parser AST  -- Resulting parser
-pinfixoperator (plus,minus) pterm sumconstr negconstr plusopt noneg = do
-    term <- pterm
-    pmoreterms term +++ return (sumconstr [term])
-    where
-        pmoreterms term = if plusopt
-            then pmoretermsplus term +++ pmoretermsminus term +++ pmoretermsnothing term
-            else pmoretermsplus term +++ pmoretermsminus term
-
-        pmoretermsplus term = do
-            poptws
-            pchar plus
-            poptws
-            nextterm <- pterm
-            let thissum = sumconstr [term,nextterm]
-            pmoreterms thissum +++ return thissum
-        pmoretermsminus term = do
-            poptws
-            pchar minus
-            poptws
-            nextterm <- pterm
-            let thissum = sumconstr [term,negconstr nextterm]
-            pmoreterms thissum +++ return thissum
-        pmoretermsnothing term = do
-            poptws
-            if noneg then passert (/='-') else return ()
-            nextterm <- pterm
-            let thissum = sumconstr [term,nextterm]
-            pmoreterms thissum +++ return thissum
-
-psum :: Parser AST
-psum = do
-    poptws
-    res <- pinfixoperator ('+','-') pproduct Sum Negative False False
-    poptws
-    return res
-
-pproduct :: Parser AST
-pproduct = pinfixoperator ('*','/') pfactor Product Reciprocal True True
-
-pfactor :: Parser AST
-pfactor = pnegative +++ pfactornoneg +++ pcapture +++ pcaptureterm
-
-pnegative :: Parser AST
-pnegative = do {pchar '-'; poptws; f <- pfactor; return $ Negative f} +++ pfactornoneg
-
-pfactornoneg :: Parser AST
-pfactornoneg = do
-    fact <- pnumber +++ pparenthetical +++ pfunctioncall +++ pvariable
-    ppower fact +++ pfactorial fact +++ return fact
-    where
-        ppower fact = do
-            poptws
-            pchar '^'
-            poptws
-            fact2 <- pfactornoneg
-            return $ Apply "pow" [fact,fact2]
-        pfactorial fact = do
-            poptws
-            pchar '!'
-            return $ Apply "fact" [fact]
-
-
-pparenthetical :: Parser AST
-pparenthetical = do
-    pchar '('
-    poptws
-    sum <- psum
-    poptws
-    pchar ')'
-    return sum
-
-pfunctioncall :: Parser AST
-pfunctioncall = do
-    name <- pword
-    poptws
-    pchar '('
-    poptws
-    args <- parglist
-    poptws
-    pchar ')'
-    return $ Apply name args
-    where
-        parglist = do
-            arg <- parg
-            poptws
-            pmoreargs arg +++ return [arg]
-        pmoreargs arg = do
-            pchar ','
-            poptws
-            args <- parglist
-            return (arg:args)
-        parg = pexpression
-
-pcapture :: Parser AST
-pcapture = do
-    pchar '['
-    name <- pmany1 $ psat (/=']')
-    pchar ']'
-    return $ Capture name
-
-pcaptureterm :: Parser AST
-pcaptureterm = do
-    pchar '['
-    pchar '['
-    name <- pmany1 $ psat (/=']')
-    pchar ']'
-    pchar ']'
-    return $ CaptureTerm name
-
-pexpression :: Parser AST
-pexpression = psum
diff --git a/prettyprint.hs b/prettyprint.hs
deleted file mode 100644
index 45ca6ac..0000000
--- a/prettyprint.hs
+++ /dev/null
@@ -1,11 +0,0 @@
-{-# LANGUAGE FlexibleInstances #-}
-
-module PrettyPrint where
-
-class PrettyPrint a where
-    prettyPrint :: a -> String
-    -- a = a
-
-instance PrettyPrint String where prettyPrint = id
-instance PrettyPrint Double where prettyPrint = show
-instance PrettyPrint Int where prettyPrint = show
diff --git a/simplify.hs b/simplify.hs
deleted file mode 100644
index 9ae29f1..0000000
--- a/simplify.hs
+++ /dev/null
@@ -1,125 +0,0 @@
-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
diff --git a/stack.yaml b/stack.yaml
new file mode 100644
index 0000000..261384c
--- /dev/null
+++ b/stack.yaml
@@ -0,0 +1,6 @@
+flags: {}
+packages:
+- .
+extra-deps:
+- readline-1.0.3.0
+resolver: lts-11.2
diff --git a/utility.hs b/utility.hs
deleted file mode 100644
index a160cb7..0000000
--- a/utility.hs
+++ /dev/null
@@ -1,28 +0,0 @@
-module Utility where
-
-import Data.List
-
---if any of the predicates returns true, options returns true
-options :: [a -> Bool] -> a -> Bool
-options l x = any id [f x | f <- l]
-
-fixpoint :: (Eq a) => (a -> a) -> a -> a
-fixpoint f x = let fx = f x in if fx == x then x else fixpoint f fx
-
-setcompareBy :: (a -> a -> Bool) -> [a] -> [a] -> Bool
-setcompareBy _ [] [] = True
-setcompareBy _ [] _ = False
-setcompareBy _ _ [] = False
-setcompareBy p a@(x:xs) b = length a == length b && setcompareBy p xs (deleteBy p x b)
-
-deleteIndex :: Int -> [a] -> [a]
-deleteIndex 0 (_:xs) = xs
-deleteIndex i (x:xs) | i > 0 = x : deleteIndex (i-1) xs
-
-fromLeft :: Either a b -> a
-fromLeft (Left a) = a
-fromLeft (Right _) = undefined
-
-fromRight :: Either a b -> b
-fromRight (Left _) = undefined
-fromRight (Right b) = b
-- 
cgit v1.2.3-70-g09d2