-- Casui 1.0b : an equation manipulator -- Copyright (C) 2008 Etienne Laurin -- -- This program is not free software; you can redistribute it and/or -- modify it only under the terms of the ATN Universal Public License -- as published by the Etienne Laurin; either the first version of -- the License, or (at your option) any later version. -- -- This program is distributed in the hope that it will be useful, -- but WITHOUT ANY WARRANTY; without even the implied warranty of -- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -- ATN Universal Public License for more details. -- -- You should have received a copy of the ATN Universal Public License along -- with this program; if not, write to Etienne Laurin . {-# LANGUAGE FlexibleContexts #-} module Casui.CAS where import Control.Arrow import Control.Applicative ((<*>)) import Data.List import Data.Maybe import Data.Function import Data.Ord import System.IO import Control.Monad import Data.Either import Text.ParserCombinators.Parsec import Text.Parsec.Prim import Casui.Utils import Casui.Debug newtype Fix a = Fix (a (Fix a)) data Expression e = VarE Variable | ConstE Constant | OpE Operator [e] newtype SimpleExpression = SimpleExpression (Expression SimpleExpression) deriving Show type Priority = Int data Operator = UserO { opName :: String } | Op { opName :: String, opPrioroty' :: Priority, opAssoc' :: Bool, opMaxArg' :: Maybe Int } deriving (Eq, Show) data Constant = IntC Int | FloatC Double | NamedC String deriving Eq data Relative = ChildR Int | ParentR deriving (Show, Eq) data ERef e = ERef { refExp :: e, refList :: [(Relative, e)] } data Variable = Var { nameV :: String } class ExpressionLike a where expressionOf :: a -> Expression a class Expressionable a where buildExpression :: Expression a -> a rebuildExpression :: a -> Expression a -> a instance ExpressionLike SimpleExpression where expressionOf (SimpleExpression e) = e instance Expressionable SimpleExpression where buildExpression = SimpleExpression rebuildExpression _ = SimpleExpression instance ExpressionLike e => Show (Expression e) where showsPrec _ (OpE o l) = showParen True $ (opName o ++) . foldl (\a b -> a . (" " ++) . shows (expressionOf b)) id l showsPrec _ (VarE (Var v)) = showString $ if null v then "_" else v showsPrec _ (ConstE c) = shows c instance ExpressionLike e => Eq (Expression e) where (OpE o l) == (OpE p k) = o == p && on (==) (map expressionOf) l k (VarE (Var v)) == (VarE (Var w)) = v == w (ConstE c) == (ConstE d) = c == d instance Show Constant where showsPrec _ (IntC i) = shows i showsPrec _ (FloatC d) = shows d showsPrec _ (NamedC n) = showString n expressionChildren (OpE _ l) = l expressionChildren _ = [] convertExpression :: (a -> b) -> Expression a -> Expression b convertExpression f (OpE o l) = OpE o $ map f l convertExpression f (VarE (Var n)) = VarE $ Var n convertExpression _ (ConstE c) = ConstE c convertExpressionIndex :: (a -> Int -> e) -> Expression a -> Expression e convertExpressionIndex f (OpE o l) = OpE o $ zipWith f l [0..] convertExpressionIndex f (VarE (Var n)) = VarE $ Var n convertExpressionIndex _ (ConstE c) = ConstE c convertReference f (ERef e l) = ERef (f e) $ map (second f) l refNew e = ERef e [] refGo (ERef e ((_,p):l)) ParentR = Just $ ERef p l refGo (ERef e l) r@(ChildR n) = case maybeNth (expressionChildren (expressionOf e)) n of Just c -> Just $ ERef c ((r,e):l) Nothing -> Nothing refGo _ _ = Nothing refGoList r (d:l) = case refGo r d of Nothing -> (r,d:l); Just r' -> refGoList r' l refGoList r [] = (r, []) updateRef (ERef _ l) t = foldr ((\a -> (flip refGo a =<<)) . fst) (Just $ ERef t []) l maxPriority, minPriority :: Int maxPriority = 1200 minPriority = 0 addO = Op "+" 500 True Nothing mulO = Op "*" 400 True Nothing divO = Op "/" 400 False $ Just 2 eqO = Op "=" 800 False $ Just 2 invO = Op "inv" 200 False $ Just 1 negO = Op "neg" 700 False $ Just 1 eqnlistO = Op "eqnlist" 1200 True Nothing rootO = Op "root" 0 False $ Just 1 powO = Op "pow" 800 False $ Just 2 logO = Op "log" 0 False $ Just 2 defaultOps = [addO, mulO, divO, eqO, invO, negO, eqnlistO, rootO, logO, powO] mkOp ops name = fromMaybe (UserO name) $ find ((== name) . opName) ops opPriority (Op _ p _ _) = p opPriority _ = maxPriority opAssoc (Op _ _ a _) = a opAssoc _ = False opMaxArg (Op _ _ _ m) = m opMaxArg _ = Nothing expressionPriority (OpE o _) = opPriority o expressionPriority _ = maxPriority expressionName (OpE op _) = opName op expressionName (VarE v) = nameV v expressionName (ConstE c) = show c maybeRead :: Read a => String -> Maybe a maybeRead = fmap fst . listToMaybe . filter (null . snd) . reads removeAt _ [] = [] removeAt 0 (_:l) = l removeAt n (x:l) = x : removeAt (n-1) l findChild f e l = foldr g Nothing $ zip [0..] $ expressionChildren $ expressionOf e where g (n,c) mr = if f c then Just $ ERef c ((ChildR n, e):l) else mr expressionOp e = f (expressionOf e) where f (OpE o _) = Just o f _ = Nothing orElse Nothing a = a orElse a _ = a fastConvertRef f (ERef e l) = ERef (f e) $ map (second f) l replaceRef :: (ExpressionLike e, Expressionable e) => ERef e -> e -> Bool -> Maybe e replaceRef r@(ERef e l) e' keepChildren = foldl f (Just e'') l where e'' = if not keepChildren then e' else case expressionOf e' of OpE o _ -> rebuildExpression e' $ OpE o $ expressionChildren $ expressionOf e _ -> e' f (Just child) (ChildR n, parent) = Just $ rebuildExpression parent (convertExpressionIndex replaceChild $ expressionOf parent) where replaceChild e n' | n == n' = child | True = e f _ _ = Nothing -- l2 isn't ref so arguments don't get swapped accidently. Corrupt -- ERefs are never deadly, but might yeild weird behaviour. appendRef (ERef e1 l1) l2 = ERef e1 (l1 ++ l2) mergeRefs (ERef le ll) (ERef re rl) = merge [] (reverse ll) (reverse rl) where merge m ((l,e):ll) ((r,_):rr) | l == r = merge ((r,e):m) ll rr merge m ll rr = let e = if null ll then le else case rr of [] -> re; ((_,e):_) -> e in (ERef e m, ERef le (reverse ll), ERef re (reverse rr)) modifyList a b = modifyList' 0 a $ sortBy (comparing fst) b modifyList' _ [] _ = [] modifyList' a (_:xs) ((b,Nothing):l) | a == b = modifyList' (a+1) xs l modifyList' a (_:xs) ((b, Just x):l) | a == b = x : modifyList' (a+1) xs l modifyList' a (x:xs) l = x : modifyList' (a+1) xs l modifyChildren e l d = case expressionOf e of OpE o c -> case c' of [e] | d -> e; _ -> rebuildExpression e $ OpE o c' where c' = modifyList c l _ -> e data Rule = Rule { pattern, replacement :: Expression SimpleExpression } deriving Show -- second try. still temporary. manipulate :: (ExpressionLike e, Expressionable e) => ERef e -> ERef e -> [Rule] -> Maybe e manipulate from to rules = let (trunk, from', to') = mergeRefs from to rfr = reverse $ map fst $ refList from' rtr = reverse $ map fst $ refList to' in trace (show $ length $ refList trunk) flip (replaceRef trunk) False =<< uncurry createExpression =<< maybeHead (catMaybes $ zipWith (\a b -> fmap (flip (,) b) a) (map (matchTop rfr rtr (expressionOf $ refExp trunk) . pattern) rules) (map replacement rules)) createExpression :: (Expressionable e, ExpressionLike e) => (Maybe (Operator, [e], [e]), (Bool, Bool, [(String, Either (Expression e) [e])])) -> Expression SimpleExpression -> Maybe e createExpression (t, (True, True, e)) r = buildExpression `fmap` reTop t (build e r) where reTop Nothing me = me reTop (Just (o, [], [])) me = me reTop (Just (o, l, r)) me = do e <- me; case e of (OpE p c) | p == o -> return (OpE o (l ++ c ++ r)) _ -> return (OpE o (l ++ [buildExpression e] ++ r)) createExpression _ _ = Nothing build :: (Expressionable e, ExpressionLike e) => [(String, Either (Expression e) [e])] -> Expression SimpleExpression -> Maybe (Expression e) build e (OpE o c) = case map expressionOf c of [VarE (Var v)] -> maybe n (Just . OpE o) $ maybeRight =<< lookup v e [OpE p d] -> case map expressionOf d of [VarE (Var a), VarE (Var b)] -> -- todo: distribute arbitrary constants maybe n (Just . f o p) $ do x <- lookup a e; y <- lookup b e; maybeLeftRight x y _ -> n _ -> n where n = OpE o `fmap` mapM (fmap buildExpression . build e . expressionOf) c f :: (Expressionable e, ExpressionLike e) => Operator -> Operator -> (Expression e, [e], Bool) -> Expression e f o p (a,l,r) = OpE o $ map (\x -> buildExpression $ OpE p $ if r then [a',x] else [x,a']) l where a' = buildExpression a build e (ConstE c) = Just $ ConstE c build e (VarE (Var v)) = maybe (Just (VarE (Var v))) maybeLeft $ lookup v e maybeLeft (Left a) = Just a maybeLeft _ = Nothing maybeRight (Right a) = Just a maybeRight _ = Nothing maybeLeftRight (Left a) (Right b) = Just (a,b,True) maybeLeftRight (Right b) (Left a) = Just (a,b,False) maybeLeftRight _ _ = Nothing matchTop' f t e p = trace ("MT" ++ show (f,t,e,p)) (matchTop f t e p) matchTop :: ExpressionLike e => [Relative] -> [Relative] -> Expression e -> Expression SimpleExpression -> Maybe (Maybe (Operator, [e], [e]), (Bool, Bool, [(String, Either (Expression e) [e])])) matchTop (ChildR n : f) (ChildR m : t) (OpE eo ec) p@(OpE po pc) | eo == po && opAssoc eo = let mef = maybeNth ec n met = maybeNth ec m l = removeAt n (take m ec) r = removeAt (n-m-1) (drop (m+1) ec) n' = if m < n then 1 else 0 m' = 1 - n' in case (mef,met) of (Just ef, Just et) -> fmap ((,) (Just (eo, l, r))) -- todo: do both et/ef and ef/et ? (match (Just (ChildR n' : f)) (Just (ChildR m' : t)) (OpE eo $ if n' == 0 then [ef,et] else [et,ef]) p) _ -> Nothing matchTop f t e p = fmap ((,) Nothing) $ match (Just f) (Just t) e p match' f t e p = trace ("M" ++ show (f,t,e,p) ++ if isJust r then " T" else " F") r where r = match f t e p -- todo: score matches and chose best; check if all instances of a var are equal match :: ExpressionLike e => Maybe [Relative] -> Maybe [Relative] -> Expression e -> Expression SimpleExpression -> Maybe (Bool, Bool, [(String, Either (Expression e) [e])]) match (Just []) Nothing e (VarE (Var "$")) = Just (True, False, [("$", Left e)]) match Nothing (Just []) e (VarE (Var "#")) = Just (False, True, [("#", Left e)]) match Nothing (Just [_]) e@(OpE eo ec) (OpE po [pc]) | (case expressionOf pc of (VarE (Var "#")) -> True; _->otherwise) && opAssoc eo && eo == po = Just (False, True, [("#",Right ec)]) match _ _ e (VarE (Var v)) | v `notElem` ["$","#"] = Just (False, False, [(v,Left e)]) -- todo: if comm and assoc then try all combinations match t f (OpE eo ec) (OpE po pc) | eo == po && sameLength ec pc = mergeMatches $ zipWith3 (matchChild t f) [0..] ec pc | True = Nothing match _ _ (VarE (Var ev)) (VarE (Var pv)) | ev == pv = Just (False,False,[]) match _ _ (ConstE ec) (ConstE pc) | ec == pc = Just (False,False,[]) match _ _ _ _ = Nothing mergeMatches = foldl mergeMatch $ Just (False, False, []) mergeMatch (Just (f1,t1,l1)) (Just (f2,t2,l2)) | f1 `nand` f2 && t1 `nand` t2 = Just (f1||f2, t1||t2, l1++l2) mergeMatch _ _ = Nothing nand a b = not (a && b) matchChild t f c e p = match (a =<< t) (a =<< f) (expressionOf e) (expressionOf p) where a (ChildR x:l) | x == c = Just l a _ = Nothing sameLength [] [] = True sameLength (_:a) (_:b) = sameLength a b sameLength _ _ = False {- -- first try. final pattern matching will be intuitive, short and scriptable defM :: (ExpressionLike e, Expressionable e) => ERef e -> ERef e -> Maybe e defM (ERef x [(ChildR a, t)]) (ERef y [(ChildR b,_t)]) | expressionOp t == Just mulO && expressionOp y == Just addO = Just $ distribute t a x b y mulO defM (ERef x [(ChildR a, t)]) (ERef _ [(ChildR b,_t),(ChildR _, y)]) | expressionOp t == Just mulO && expressionOp y == Just addO = Just $ distribute t a x b y mulO defM _ _ = Nothing {- defM a b = trace (show s) Nothing where s = (map (second expressionOp) $ refList a, map (second expressionOp) $ refList b) -} distribute :: (ExpressionLike e, Expressionable e) => e -> Int -> e -> Int -> e -> Operator -> e distribute t a x b y o = modifyChildren t [(a,Nothing),(b,Just r)] True where r = rebuildExpression y $ convertExpression f $ expressionOf y f e = buildExpression $ OpE o [x,e] -} -- todo: don't use show hPutExpr h e = hPutStr h $ "(expr " ++ show (expressionOf e) ++ ")\n" readExprsFromFile file = do contents <- readFile file return $ parse exprsP file contents exprsP :: Expressionable e => Parser [Expression e] opP, varP, constP :: Expressionable e => Parser (Expression e) exprsP = many $ do e <- opP <|> constP <|> varP; many $ oneOf spaceChars; return e opP = do char '(' op <- symbolP ch <- exprsP char ')' return $ OpE (mkOp defaultOps op) $ map buildExpression ch -- todo: safe read, nicer code constP = do neg <- (char '-' >> return (negate,negate)) <|> ((char '+' <|> return '+') >> return (id,id)) i <- many1 $ oneOf "0123456789" flip (<|>) (return $ ConstE $ IntC $ fst neg $ read i) $ do char '.' d <- many1 $ oneOf "0123456789" return $ ConstE $ FloatC $ snd neg $ read $ i ++"."++ d varP = return . VarE . Var . (\x -> if x == "_" then "" else x) =<< symbolP symbolP = do x <- many1 $ noneOf (spaceChars ++ "()"); many (oneOf spaceChars); return x skipSpaces :: Stream s m Char => ParsecT s u m [Char] skipSpaces = many $ oneOf spaceChars spaceChars = " \t\r\n" e x = f $ parse exprsP "*" x where f (Left e) = error $ show e; f (Right [e]) = e se x = e x :: Expression SimpleExpression be = buildExpression test = build [("a", Right [be $ se "1", be $ se "3"]),("b", Left $ se "2")] (se "(* (+ a b))") == Just (se "(* (+ 2 1) (+ 2 3))")