casui-0.3: Casui/CAS.hs
-- 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 <etienne@atnnn.com>.
{-# 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))")