summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authortomsmeding <tom.smeding@gmail.com>2016-06-20 22:06:58 +0200
committertomsmeding <tom.smeding@gmail.com>2016-06-20 22:06:58 +0200
commit7957dc36354a803ba96231c5bf8397a154f0ca59 (patch)
tree3d3a156d8cbc145a37e4886eeeb2d3abdfa74e1e
parent712dfe8a117207f1d70e0e14f9d6e7ee62c8eadd (diff)
Cleanup + from(Left|Right)
-rw-r--r--ast.hs5
-rw-r--r--simplify.hs33
-rw-r--r--utility.hs8
3 files changed, 11 insertions, 35 deletions
diff --git a/ast.hs b/ast.hs
index 4862a92..11aeb9b 100644
--- a/ast.hs
+++ b/ast.hs
@@ -23,7 +23,7 @@ data AST = Number Double
| Capture String
| CaptureTerm String
| CaptureConstr String AST -- AST argument only for constructor; only WHNF
- deriving (Eq,Typeable,Data)
+ deriving (Show,Read,Eq,Typeable,Data)
instance PrettyPrint AST where
prettyPrint (Number n) = show n
@@ -56,9 +56,6 @@ instance PrettyPrint AST where
prettyPrint (CaptureConstr name c) = '[' : name ++ ":" ++ showConstr (toConstr c) ++ "]"
-instance Show AST where
- show = prettyPrint
-
instance NFData AST where
rnf (Number !_) = ()
rnf (Variable !_) = ()
diff --git a/simplify.hs b/simplify.hs
index f0fcd6e..c62ff4b 100644
--- a/simplify.hs
+++ b/simplify.hs
@@ -21,9 +21,8 @@ tracexp s x = trace (s ++ ": " ++ prettyPrint x) x
simplify :: AST -> AST
simplify = tracex "last canonicaliseOrder" . canonicaliseOrder
. (fixpoint $ tracex "applyPatterns " . applyPatterns
- . tracex "flattenSums " . flattenSums
- -- . tracex "collectLikeTerms " . collectLikeTerms
. tracex "canonicaliseOrder" . canonicaliseOrder
+ . tracex "flattenSums " . flattenSums
. tracex "foldNumbers " . foldNumbers)
. tracex "first flattenSums" . flattenSums
@@ -61,7 +60,7 @@ foldNumbers node = case node of
(Negative n) -> Negative $ Reciprocal fn
(Reciprocal n2) -> n2
_ -> Reciprocal $ fn
- (Apply name args) -> let fargs = map foldNumbers args -- Apply name $ map foldNumbers args
+ (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)
@@ -93,34 +92,6 @@ foldNumbers node = case node of
| even x -> Product unnegged
| odd x -> Product $ Number (-1) : unnegged
--- collectLikeTerms :: AST -> AST
--- collectLikeTerms node = case node of
--- (Reciprocal n) -> Apply "pow" [n,Number $ -1]
--- (Product args) ->
--- let ispow (Apply "pow" _) = True
--- ispow _ = False
--- (pows,nopows) = partition ispow $ map collectLikeTerms args
--- groups = groupBy (\(Apply _ [x,_]) (Apply _ [y,_]) -> x == y) pows
--- baseof (Apply _ [x,_]) = x
--- expof (Apply _ [_,x]) = x
--- collectGroup l = Apply "pow" [baseof (l!!0),Sum $ map expof l]
--- in Product $ map collectGroup groups ++ nopows
--- (Sum args) ->
--- let isnumterm (Product (Number _:_)) = True
--- isnumterm _ = False
--- (numterms,nonumterms) = partition isnumterm $ map collectLikeTerms args
--- groups = groupBy (\(Product (Number _:xs)) (Product (Number _:ys))
--- -> astMatchSimple (Product xs) (Product ys))
--- numterms
--- numof (Product (n:_)) = n
--- restof (Product (_:rest)) = rest
--- collectGroup l =
--- if length l == 1
--- then l!!0
--- else Product $ Sum (map numof l) : restof (l!!0)
--- in Sum $ map collectGroup groups ++ nonumterms
--- _ -> node
-
canonicaliseOrder :: AST -> AST
canonicaliseOrder node = case node of
(Number _) -> node
diff --git a/utility.hs b/utility.hs
index c442f80..a160cb7 100644
--- a/utility.hs
+++ b/utility.hs
@@ -18,3 +18,11 @@ setcompareBy p a@(x:xs) b = length a == length b && setcompareBy p xs (deleteBy
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