diff options
| -rw-r--r-- | ast.hs | 5 | ||||
| -rw-r--r-- | simplify.hs | 33 | ||||
| -rw-r--r-- | utility.hs | 8 |
3 files changed, 11 insertions, 35 deletions
@@ -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 @@ -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 |