diff --git a/Casui/CAS.hs b/Casui/CAS.hs new file mode 100644 --- /dev/null +++ b/Casui/CAS.hs @@ -0,0 +1,389 @@ +-- 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))") diff --git a/Casui/Casui.hs b/Casui/Casui.hs new file mode 100644 --- /dev/null +++ b/Casui/Casui.hs @@ -0,0 +1,45 @@ +module Casui.Casui where + +import Casui.Module +import Casui.Value +import Casui.Name + +data Env = Env { + envModuleLibrary :: ModuleLibrary + -- TODO + } + +data Context = Context { + ctxLocal :: [(Symbol, Expression)], + ctxModules :: ModuleList Expression + } + +data Casui s a = Casui (s -> Context -> Env -> IO (a, Env)) + +instance Monad (Casui l) where + (Casui f) >>= g = Casui $ \s c e -> do + (a, e) <- f s c e + let Casui h = g a + h s c e + return a = Casui $ \s c e -> return (a, e) + +instance Functor (Casui s) where + fmap g (Casui f) = Casui $ \s c e -> do + (a, e) <- f s c e + return (g a, e) + +env :: Casui s Env +env = Casui $ \s c e -> return $ (,) e e + +withContext :: Context -> Casui s a -> Casui s a +withContext c (Casui f) = Casui $ \s _ e -> f s c e + +listBuiltinModules :: Casui s [CompiledModule] +listBuiltinModules = do + fmap (filter isBuiltIn . mlList . envModuleLibrary) env + +getModules :: Name -> Casui l [Module FullName Expression] +getModules name = fmap (findModules name . envModuleLibrary) env + +type CompiledModule = Module FullName Expression + diff --git a/Casui/Compile.hs b/Casui/Compile.hs new file mode 100644 --- /dev/null +++ b/Casui/Compile.hs @@ -0,0 +1,37 @@ +{-# LANGUAGE ScopedTypeVariables #-} + +module Casui.Extend where + +import Casui.Name +import Casui.Utils +import Casui.Value +import Casui.Module +import Casui.Parse +import Casui.Casui + +import Data.Either +import Control.Monad + +type CompileModuleResult = Either (TagError [(ParsedName, [FullName])]) + + +compileModule :: Module ParsedName ParsedValue -> Casui s (CompileModuleResult CompiledModule) +compileModule mod = do + elist <- listModuleImports mod + flip (either (return . Left)) elist $ \mlist -> do + ctx <- return . Context [] . ModuleList . (mlist ++) =<< listBuiltinModules + withContext ctx $ do + + return undefined + +listModuleImports :: ParsedModule -> Casui s (CompileModuleResult [CompiledModule]) +listModuleImports mod = do + (imps :: [Either (ParsedName, [FullName]) CompiledModule]) + <- forM (mImports mod) $ \pn@(ParsedName loc name) -> do + ms <- getModules name + return $ case ms of + [m] -> Right $ m + l -> Left $ (pn, map mFullName l) + case imps of + (lefts -> l@(_:_)) -> return $ Left $ err "Error finding imports" l + (rights -> l) -> return $ Right $ l diff --git a/Casui/Debug.hs b/Casui/Debug.hs new file mode 100644 --- /dev/null +++ b/Casui/Debug.hs @@ -0,0 +1,46 @@ +module Casui.Debug where + +{- +import Debug.Trace + +tr :: Show a => a -> a +tr a = trace (show a) a + +trf :: Show b => (a -> b) -> a -> a +trf f a = trace (show $ f a) a + +traceCall :: String -> a -> a +traceCall = trace + +trn :: Show a => String -> a -> a +trn s a = trace (s ++ show a) a + +trm :: Monad m => String -> m () +trm s = trace s $ return () +-} + +--{- +trace = flip const + +tr :: Show a => a -> a +tr a = a + +trf :: Show b => (a -> b) -> a -> a +trf f a = a + +traceCall :: String -> a -> a +traceCall = flip const + +trn :: Show a => String -> a -> a +trn s a = a + +trm :: Monad m => String -> m () +trm s = return () +--} + +{-# WARNING todo, Todo, something "Unfinished code (TODO)" #-} +todo = error "todo: not implemented" + +data Todo + +something = error "something is wrong" diff --git a/Casui/Draw.hs b/Casui/Draw.hs new file mode 100644 --- /dev/null +++ b/Casui/Draw.hs @@ -0,0 +1,301 @@ +module Casui.Draw where + +{-# OPTIONS_GHC -XPackageImports #-} + +import Graphics.UI.Gtk hiding (Arrow) +import Graphics.UI.Gtk.Gdk.GC +import Numeric +import Data.Bits +import Control.Monad.Trans +import Control.Applicative +import Casui.Utils +import Control.Arrow +import Data.List +import Control.Monad +import Data.Maybe + +import Casui.Debug + +-- deriving instance Show Rectangle + +data Drawing t = LineD Point Point + | GlyphD GlyphItem Double (Int, Int) + | GroupD [DrawAttrib] [(Point, DrawInfo t)] + | TagD t (Drawing t) + deriving Show + +data DrawAttrib = ColorA Color deriving Show + +data DrawInfo t = DrawInfo { + diBox :: Rectangle, + diDrawing :: Drawing t + -- ... + } deriving Show + +{-instance Show Color where + showsPrec _ (Color r g b) = shows $ "#" ++ hexcolor r ++ hexcolor g ++ hexcolor b + where hexcolor = pad . flip showHex "" . flip shiftR 8 + pad [x] = ['0',x] + pad xs = xs-} + +instance Show GlyphItem where + show l = "" + +-- todo: returned (c, scale) defines order on children, the [DrawInfo] +-- should use same order and be purged as it is used +newtype Draw t a = Draw { + drawF :: Double + -> PangoContext + -> (DrawInfo t -> DrawInfo t -> DrawInfo t) + -> IO (Maybe (DrawInfo t), a) + } + +instance Monad (Draw t) where + return a = Draw $ \_ _ _ -> return (Nothing, a) + d >>= f = Draw $ \s c m -> do (d, a) <- drawF d s c m + (e, a') <- drawF (f a) s c m + return (case (d, e) of + (Just x, Just y) -> Just $ m x y + (Just x, _) -> Just x + (_, Just y) -> Just y + _ -> Nothing + , a') + +instance MonadIO (Draw t) where + liftIO a = Draw $ \_ _ _ -> (,) Nothing <$> a + +instance Functor (Draw t) where + fmap f = (>>= return . f) + +runDraw :: Draw t a -> Double -> PangoContext -> IO a +runDraw d s c = snd <$> drawF d s c squashed + +emptyDI :: DrawInfo t +emptyDI = DrawInfo (Rectangle 0 0 0 0) (GroupD [] []) + +emptyp :: DrawInfo t -> Bool +emptyp (DrawInfo _ (GroupD _ [])) = True +emptyp _ = False + +squashed :: DrawInfo t -> DrawInfo t -> DrawInfo t +squashed = groupDIs 0 0 + +groupDIs :: (Int, Int) -> (Int, Int) -> DrawInfo t -> DrawInfo t -> DrawInfo t +groupDIs dxy0@(px0,py0) dxy1@(px1,py1) + d0@(DrawInfo r0@(Rectangle x0 y0 w0 h0) _) + d1@(DrawInfo r1@(Rectangle x1 y1 w1 h1) _) = + let rx0 = x0 + px0 + rx1 = x1 + px1 + ry0 = y0 + py0 + ry1 = y1 + py1 + --dxy0 = 0 + --dxy1 = (rx1 - rx0, ry1 - ry0) + lx = min px0 px1 --rx0 rx1 + by = min py0 py1 --ry0 ry1 + rx = max (px0 + w0) (px1 + w1) -- (rx0 + w0) (rx1 + w1) + ty = max (py0 + h0) (py1 + h1) -- (ry0 + h0) (ry1 + h1) + tw = rx - lx + th = ty - by + --splat p (DrawInfo _ (GroupD [] l)) = map (first (+p)) l -- don't ignore diBox + splat p d = [(p, d)] in + trace (show (dxy0, r0, dxy1, r1, tw, th)) $ + DrawInfo (Rectangle 0 0 tw th) -- (Rectangle rx0 ry0 tw th) + (GroupD [] $ splat dxy0 d0 ++ splat dxy1 d1) + +getScale :: Draw t Double +getScale = Draw $ \s _ _ -> return (Nothing, s) + +getPangoContext :: Draw t PangoContext +getPangoContext = Draw $ \_ c _ -> return (Nothing, c) + +putDI :: DrawInfo t -> Draw t () +putDI d = Draw $ \_ _ _ -> return (Just d, ()) + +removeDI :: Draw t a -> Draw t (Maybe (DrawInfo t), a) +removeDI d = Draw $ \s c m -> + do (e, a) <- drawF d s c m + return (Nothing, (e,a)) + +removeDI_ d = fst <$> removeDI d + +getDI :: Draw t a -> Draw t (Maybe (DrawInfo t), a) +getDI d = do + (e, a) <- removeDI d + maybe (return ()) putDI e + return (e, a) + +scaleBy :: Double -> Draw t a -> Draw t a +scaleBy sc d = Draw $ \s -> drawF d (s * sc) + +withScale :: Double -> Draw t a -> Draw t a +withScale sc d = Draw $ \s -> drawF d sc + +diPos :: DrawInfo t -> (Int, Int) +diPos (DrawInfo (Rectangle x y _ _) _) = (x, y) + +diSize :: DrawInfo t -> (Int, Int) +diSize (DrawInfo (Rectangle _ _ w h) _) = (w, h) + +displaying :: (DrawInfo t -> DrawInfo t -> DrawInfo t) -> Draw t a -> Draw t a +displaying m d = Draw $ \s c _ -> drawF d s c m + +tag :: t -> Draw t d -> Draw t d +tag t d = Draw $ \s c m -> + first (Just . tagDI t . fromMaybe emptyDI) <$> drawF d s c m + +tagDI :: t -> DrawInfo t -> DrawInfo t +tagDI t di@(DrawInfo { diDrawing = d }) = di { diDrawing = TagD t d } + + +draw :: (DrawableClass d, Show t) => d -> GC -> (Int, Int) -> DrawInfo t -> IO () +draw dw gc p = draw' dw gc p . diDrawing + +draw' :: (DrawableClass d, Show t) => d -> GC -> (Int, Int) -> Drawing t -> IO () +draw' dw gc (x,y) (LineD (x1,y1) (x2,y2)) = drawLine dw gc (x1+x, y1+y) (x2+x, y2+y) +draw' dw gc (x,y) (GlyphD t a (ox, oy)) = drawGlyphs dw gc (x-ox) (y-oy) t +draw' dw gc (x,y) (GroupD [] l) = mapM_ f l + where f ((sx,sy),d) = draw dw gc (x+sx, y+sy) d +draw' dw gc (x,y) (GroupD a l) = do save <- modifyGC gc a; mapM_ f l; gcSetValues gc save + where f ((sx,sy),d) = draw dw gc (x+sx, y+sy) d +draw' dw gc p (TagD _ d) = draw' dw gc p d + +modifyGC :: GC -> [DrawAttrib] -> IO GCValues +modifyGC gc l = do s <- gcGetValues gc; gcSetValues gc $ foldl f s l; return s + where f a (ColorA c') = a {foreground = c'} + +layoutSetFontSize :: PangoLayout -> Double -> IO () +layoutSetFontSize layout size = do + text <- layoutGetText layout + layoutSetAttributes layout [AttrSize 0 (length text) size] + +glyphItemSize :: GlyphItem -> IO (Int, Int) +glyphItemSize g = do + (_, Rectangle _ _ w h) <- glyphItemPixelExtents g + return (w,h) + +glyphItemOffset :: GlyphItem -> IO (Int, Int) +glyphItemOffset = glyphItemOffset' True + +glyphItemOffset' t g = do + (Rectangle a b _ _, Rectangle x y _ _) <- glyphItemPixelExtents g + return $ if t then (x,y) else (a,b) + +glyphItemPixelExtents :: GlyphItem -> IO (Rectangle, Rectangle) +glyphItemPixelExtents g = do + (PangoRectangle a b c d, PangoRectangle e f g h) <- glyphItemExtents g + return (Rectangle (round a) (round b) (round c) (round d), + Rectangle (round e) (round f) (round g) (round h)) + +glyphItemBBox :: GlyphItem -> IO Rectangle +glyphItemBBox g = snd <$> glyphItemPixelExtents g + +glyphItemBBox' inkOrLogical g = (if inkOrLogical then snd else fst) <$> glyphItemPixelExtents g + +-- todo: dynamic +normalFontSize :: Double +normalFontSize = 32 + +minFontSize :: Double +minFontSize = 6 + +scaleMultiplier :: Double +scaleMultiplier = 0.7 + +-- |Horizontal box combiner +nextTo :: DrawInfo t -> DrawInfo t -> DrawInfo t +nextTo d@(DrawInfo (Rectangle _ _ w _) _) = + groupDIs 0 (w, 0) d + +superscript :: DrawInfo t -> DrawInfo t -> DrawInfo t +superscript + d1@(DrawInfo (Rectangle _ _ w1 h1) _) + d2@(DrawInfo (Rectangle _ _ w2 h2) _) = + groupDIs (0, h2 `div` 2) + (w1, 0) + d1 d2 + +leftSuperscript :: DrawInfo t -> DrawInfo t -> DrawInfo t +leftSuperscript + d1@(DrawInfo (Rectangle _ _ w1 h1) _) + d2@(DrawInfo (Rectangle _ _ w2 h2) _) = + groupDIs 0 + (w1, h1`div`2) + d1 d2 + +centeredNextTo :: DrawInfo t -> DrawInfo t -> DrawInfo t +centeredNextTo d@(DrawInfo (Rectangle x0 y0 w0 h0) _) + e@(DrawInfo (Rectangle x1 y1 w1 h1) _) = + let th = max h0 h1 + in groupDIs + (0, (th - h0) `div` 2) + (w0, (th - h1) `div` 2) + d e + + +-- |Centered vertical box combiner +centeredUnder :: DrawInfo t -> DrawInfo t -> DrawInfo t +centeredUnder d@(DrawInfo (Rectangle x0 y0 w0 h0) _) + e@(DrawInfo (Rectangle x1 y1 w1 h1) _) = + let tw = max w0 w1 + in groupDIs + ((tw - w0) `div` 2, 0) --(div (tw-w0) 2 - x0, 0) + ((tw - w1) `div` 2, h0) --(div (tw-w1) 2 - x1, h0 - y0 + y1) + d e + + +getFontSize :: Draw t Double +getFontSize = max minFontSize . (normalFontSize *) <$> getScale + +text :: String -> Draw t () +text str = advancedText True str + +advancedText inkOrLogical str = do + size <- getFontSize + context <- getPangoContext + dis <- liftIO $ do + pangois <- pangoItemize context str [AttrSize 0 (length str) size] + ascents <- map ascent <$> mapM pangoItemGetFontMetrics pangois + glyphs <- mapM pangoShape pangois + offsets <- mapM (glyphItemOffset' inkOrLogical) glyphs + boxes <- mapM (glyphItemBBox' inkOrLogical) glyphs + return $ zipWith DrawInfo boxes $ zipWith3 GlyphD glyphs ascents offsets + displaying nextTo $ mapM_ putDI dis + +parenLeft = "(⎛⎜⎝" +parenRight = ")⎞⎟⎠" + +vstretch :: String -> Int -> Draw t () +vstretch [small,top,middle,bottom] heighti = + let height = trn "height: " $ realToFrac heighti in + if height < 2 * normalFontSize + then {- withScale (height / normalFontSize) $-} text [small] + else displaying centeredUnder $ do + advancedText True [top] + advancedText True [middle] + advancedText True [bottom] + +addParens :: Draw t a -> Draw t a +addParens d = displaying nextTo $ do + (mdi, b) <- removeDI d + case mdi of + Nothing -> text "()" >> return b + Just di -> displaying centeredNextTo $ do + let height = rectHeight $ diBox di + vstretch parenLeft height + putDI di + vstretch parenRight height + return b + +getTagsPos :: Point -> Drawing t -> [(Point, t)] +getTagsPos p (TagD t di) = [(p, t)] +getTagsPos p (GroupD _ l) = concatMap (uncurry getTagsPos . ((+p) *** diDrawing)) l +getTagsPos _ _ = [] + +rectWidth :: Rectangle -> Int +rectWidth (Rectangle _ _ w _) = w + +rectHeight :: Rectangle -> Int +rectHeight (Rectangle _ _ _ h) = h + +line :: Int -> Int -> Int -> Int -> Draw t () +line x0 y0 x1 y1 = putDI (DrawInfo (Rectangle x0 y0 (x1-x0) (y1-y0)) (LineD (x0,y0) (x1,y1))) diff --git a/Casui/Gui.hs b/Casui/Gui.hs new file mode 100644 --- /dev/null +++ b/Casui/Gui.hs @@ -0,0 +1,866 @@ +-- Casui 0.3 : an equation manipulator +-- Copyright (C) 2008-2011 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 PatternGuards #-} + +module Main where + +import Data.IORef +import Graphics.UI.Gtk hiding (on, eventKeyName, Priority) +import Graphics.UI.Gtk.Gdk.Events +import Graphics.UI.Gtk.Gdk.GC +import Data.Maybe +import Data.Function +import Control.Monad +import Control.Arrow +import Control.Applicative +import Data.List +import Data.Char +import Data.Ord +import Control.Monad.Fix +import System.IO +import Time +import System.IO.Error + +import Casui.CAS +import Casui.Draw +import Casui.Utils +import Casui.Menu +import Casui.Debug + +import Paths_casui + +main :: IO () +main = do + initGUI + (window, global, state) <- casuiNew + widgetShowAll window + trace "Entering mainGUI" mainGUI + widgetDestroy window + +-- |Initialise the environment +casuiNew :: IO (Window, Global, IORef State) +casuiNew = do + -- Main window + window <- windowNew + windowSetTitle window programFullName + onDelete window $ const (mainClose >> return False) + vbox <- vBoxNew False 0 + containerAdd window vbox + + -- Menubar + menubar <- menuBarNew + boxPackStart vbox menubar PackNatural 0 + + -- Canvas + canvas <- drawingAreaNew + widgetSetCanFocus canvas True + widgetSetRedrawOnAllocate canvas False + widgetSetDoubleBuffered canvas False + boxPackStart vbox canvas PackGrow 0 + + -- Status bar + status <- statusbarNew + context <- statusbarGetContextId status "main" + statusbarPush status context $ "Casui " ++ programVersion + boxPackEnd vbox status PackNatural 0 + let statusShow m = statusbarPop status context >> statusbarPush status context m >> return () + + -- Initialise local and global state + state <- newIORef =<< mkState =<< mkDE canvas initialVE + global <- mkGlobal canvas statusShow + + -- Populate Menu + populateMenu menubar $ mainMenu state global + + -- Event handlers + let ws f e = readIORef state >>= \s -> f global s e + onMotionNotify canvas True (ws mouseMotion) + onExpose canvas (ws redraw) + onKeyPress canvas (ws keyPress) + onButtonPress canvas (ws buttonPress) + onButtonRelease canvas (ws buttonRelease) + + -- Initial window size + windowResize window 400 300 + + -- load default rules + defaultRulesFile <- getDataFileName "rules.cui" + st <- readIORef state + loadRulesFromFile global st defaultRulesFile + + return (window, global, state) + +-- |Create the main menu given a 'State' and 'Global' +mainMenu :: IORef State -> Global -> [SimpleMenu] +mainMenu state global = genMenuItems $ do + submenu "File" $ do + leaf "New Expression" $ newState state (canvas global) + leaf "Save Expression as .." $ saveStateAsk state global + leaf "Load Expression .." $ loadStateAsk state global + leaf "Load Rules .." $ loadRulesAsk global =<< readIORef state + seperator + leaf "Exit" mainClose + submenu "Edit" $ do + leaf "Undo" $ popExpression global =<< readIORef state + seperator + leaf "Copy" $ copyCur global =<< readIORef state + leaf "Paste" $ pasteCur global =<< readIORef state + submenu "Help" $ do + dynamicMenu "Time" $ getClockTime >>= \t -> return $ leaf (show t) (return ()) >> return True + leaf "About .." $ showAboutDialog >> return () + +showAboutDialog :: IO () +showAboutDialog = do + d <- aboutDialogNew + aboutDialogSetName d programFullName + aboutDialogSetCopyright d "(C) 2008-2011 Etienne Laurin" + aboutDialogSetComments d "Computer Algebra System User Interface: an equation manipulator" + aboutDialogSetWebsite d "http://code.atnnn.com/projects/casui" + --aboutDialogSetLicense d . justRight =<< try (readFile "../LICENSE") + dialogRun d + widgetDestroy d + +-- |Initialise a new local state for a 'DisplayExpression' +mkState :: DE -> IO State +mkState pexpr = do + expr <- newIORef pexpr -- Current expression + xy <- newIORef (0,0) -- Position of the expression + prev <- newIORef [] -- Undo stack + hover <- newIORef Nothing -- Sub-expression under pointer + cur <- newIORef Nothing -- Selected sub-expression + typed <- newIORef "" -- Input buffer + drag <- newIORef Nothing -- When dragging, the source sub-expression + next <- newIORef Nothing -- Not yet committed result of current action (eg, drag) + rules <- newIORef [] -- Rules + return $ State expr xy prev hover cur typed drag next rules + +-- |Initialise a new global state +mkGlobal :: DrawingArea -> (String -> IO ()) -> IO Global +mkGlobal canvas message = do + clip <- newIORef Nothing -- Cliboard + return $ Global clip message canvas + +-- |Convert a 'ViewExpression' to a 'DisplayExpression' +mkDE :: (WidgetClass self) => self -> ViewExpression -> IO DisplayExpression +mkDE canvas ve = traceCall "mkDE" $ do + pc <- widgetCreatePangoContext canvas + displayVE defaultViews pc 1 ve + +-- Type Alises +type DE = DisplayExpression +type VE = ViewExpression +type DERef = ERef DE +type VERef = ERef VE +type DESel = Maybe (Point, DERef) +type Size = Point + +-- |The state of the editor for an expression +data State = State + { expr :: IORef DE -- ^Current expression + , xy :: IORef Point -- ^Position of the expression + , prev :: IORef [(DESel, DE)] -- ^Undo stack + , hover :: IORef DESel -- ^Sub-expression under pointer + , cur :: IORef DESel -- ^Selected sub-expression + , typed :: IORef String -- ^Input buffer + , drag :: IORef (Maybe Point) -- ^When dragging, the source sub-expression + , next :: IORef (Maybe DE) -- ^Not yet committed result of current action (eg, drag) + , rules :: IORef [Rule] -- ^Rules + } + +-- |The global state of the application, common to all 'State's +data Global = Global + { clipboard :: IORef (Maybe DE) -- ^A copied expression + , message :: String -> IO () -- ^Display a message in the status bar + , canvas :: DrawingArea -- ^The canvas + } + +-- |Quit Casui when the main window is closed +mainClose :: IO () +mainClose = mainQuit + +programName = "Casui" +programVersion = "0.3" +programFullName = programName ++ " " ++ programVersion + +-- |An empty 'State' +newState :: (WidgetClass self) => IORef State -> self -> IO () +newState state global = writeIORef state =<< mkState =<< mkDE global initialVE + +-- |A filter for the file chooser dialog for *.cui files +casuiFilter :: IO FileFilter +casuiFilter = do + filter <- fileFilterNew + fileFilterSetName filter "Casui file (*.cui)" + fileFilterAddPattern filter "*.cui" + return filter + +showFileChooserAction FileChooserActionSave = "Save" +showFileChooserAction FileChooserActionOpen = "Open" +showFileChooserAction FileChooserActionSelectFolder = "Select Folder" +showFileChooserAction FileChooserActionCreateFolder = "Create Folder" + +-- |Helper for the fileChooser dialog +askForFile :: FileChooserAction -> IO (Maybe FilePath) +askForFile action = do + dialog <- fileChooserDialogNew Nothing Nothing action + [(showFileChooserAction action,ResponseOk),("Cancel",ResponseCancel)] + filter <- casuiFilter + fileChooserAddFilter dialog filter + fileChooserSetFilter dialog filter + fileChooserSetDoOverwriteConfirmation dialog True +-- Just file | '.' `elem` file -> fileChooserSetFilename dialog (file ++ ".cui") >> return () + dialogSetDefaultResponse dialog ResponseOk + response <- dialogRun dialog + file <- if response == ResponseOk then + fileChooserGetFilename dialog + else return Nothing + widgetDestroy dialog + return file + +-- |Load rules from a file specified by the user +loadRulesAsk :: Global -> State -> IO () +loadRulesAsk gl st = do + mfile <- askForFile FileChooserActionOpen + ifJust mfile $ loadRulesFromFile gl st + +loadRulesFromFile :: Global -> State -> FilePath -> IO () +loadRulesFromFile gl st file = (>> return ()) . try $ do + exprs <- readExprsFromFile file + case exprs of + Right l -> writeIORef (rules st) $ exprsRules l + Left err -> message gl $ show err + +-- |Parse the content of the rules file +exprsRules :: [Expression SimpleExpression] -> [Rule] +exprsRules l = mapMaybe f l + where f (OpE (UserO "rule") [p,r]) = Just $ Rule (expressionOf p) (expressionOf r) + f _ = Nothing + +-- |Save the expression being edited +saveStateAsk :: IORef State -> Global -> IO () +saveStateAsk state global = do + mfile <- askForFile FileChooserActionSave + ifJust mfile $ \file -> do + st <- readIORef state + h <- openFile file WriteMode + hPutExpr h =<< readIORef (expr st) + hClose h + message global $ "Saved to " ++ file + return () + +-- |Load a saved expression +loadStateAsk :: IORef State -> Global -> IO () +loadStateAsk state global = do + mfile <- askForFile FileChooserActionOpen + ifJust mfile $ \file -> do + exprs <- readExprsFromFile file + case exprs of + Right [OpE (UserO "expr") [e]] -> + writeIORef state =<< mkState =<< mkDE (canvas global) e + Left err -> message global $ show err + _ -> message global $ "Invalid file " ++ file + +-- |Undo +popExpression :: Global -> State -> IO () +popExpression gl st = do + prevs <- readIORef (prev st) + case prevs of + [] -> message gl "Nothing to undo" + ((c,e):l) -> do + writeIORef (cur st) c + writeIORef (expr st) e + writeIORef (prev st) l + +-- |Copy +copyCur :: Global -> State -> IO () +copyCur global st = do + mr <- readIORef (cur st) + maybe (return ()) (writeIORef (clipboard global) . Just . refExp . snd) mr + +-- |Paste +pasteCur gl st = do + mc <- readIORef (clipboard gl) + mr <- readIORef (cur st) + case (mr, mc) of + (Just (_, ref), Just new) -> + modifyExpression gl st (replaceRef (fastConvertRef DisplayExpressionV ref) + (DisplayExpressionV new) False, Just []) + _ -> return False + return () + +-- |The currently selected sub-expression +currentSelection :: State -> IO DERef +currentSelection st = join $ do + mcur <- readIORef $ cur st + return $ case mcur of + Just (_, ref) -> return ref + Nothing -> do ref <- fmap (flip ERef []) $ readIORef $ expr st + writeIORef (cur st) $ Just (0, ref) + return ref + +-- |Called when a key is pressed. Calls 'deleteSomething' or +-- 'insertOperator' to edit the equation and 'modifyExpression' to +-- apply the modifications. +keyPress :: Global -> State -> Event -> IO Bool +keyPress gl st ev = traceCall "KeyPress" $ do + chars <- readIORef $ typed st + writeIORef (typed st) "" + ref <- currentSelection st + let vref = fastConvertRef DisplayExpressionV ref + let dir "Left" = Just distLeft; dir "Right" = Just distRight + dir "Up" = Just distUp; dir "Down" = Just distDown; dir _ = Nothing + case trn "key: " $ eventKeyName ev of + "Delete" -> modifyExpression gl st $ deleteSomething vref + "Return" -> return False -- add arg to top eqnlist + n | Just d <- dir n -> modifyExpression gl st . (,) Nothing . navigateExpression ref 0 Nothing $ d + _ -> case eventKeyChar ev of + Just '(' -> + case expressionOf $ refExp ref of + (VarE (Var n)) -> modifyExpression gl st + (replaceRef vref (buildExpression $ OpE (mkOp defaultOps n) + [buildExpression $ VarE (Var "")]) + False, Just [ChildR 0]) + _ -> return False + Just ',' -> let mp = refGo vref ParentR in + case (expressionOf <$> refExp <$> mp, mp) of + (Just (OpE o _), Just r) -> modifyExpression gl st $ + insertArgument r o Nothing [ParentR] + _ -> return False + Just c -> case operatorChar c of + Just o -> modifyExpression gl st $ insertOperator o vref + _ -> let (mods,chars') = insertCharacter c vref chars in + writeIORef (typed st) chars' + >> modifyExpression gl st mods + _ -> return False + + +distLeft (a,b) (c,d) = a-c -- + signum (b-d) +distRight p q = distLeft q p +distUp (b,a) (d,c) = distLeft (a,b) (c,d) +distDown (d,c) (b,a) = distLeft (a,b) (c,d) + +-- |Navigate an expression +navigateExpression + :: DERef -- ^ The current position in the expression + -> Point -- ^ The top left corner of the starting point + -> Maybe Int -- ^ Nothing if we are at the starting point. + -- Just n on a recursive call from the nth child + -> (Point -> Point -> Int) -- ^ The direction we are moving towards + -- ('distLeft', 'distRight', 'distUp' or 'distDown) + -> Maybe [Relative] -- ^ A possible list of directions +navigateExpression ref pos mchild dist = + let children = deChildrenPos $ refExp ref + pos' = maybe pos (+pos) $ join . maybeNth children =<< mchild + dests = catMaybes $ zipWith (fmap . (,)) (map (return . ChildR) [0..]) children + possibilities = filter ((>0) . snd) . map (second $ dist pos') $ dests + in if not $ null possibilities + then Just . fst . minimumBy (comparing snd) $ possibilities + else case refList ref of + ((ChildR n, p):l) -> mplus + ((ParentR:) <$> navigateExpression (ERef p l) pos' (Just n) dist) + (const [ParentR] <$> mchild) + _ -> maybe Nothing (const $ Just []) mchild + +-- |Updates the expression, hover and selection +modifyExpression :: Global -> State -> (Maybe ViewExpression, Maybe [Relative]) -> IO Bool +modifyExpression gl st (mve, mds) = traceCall "modifyExpression" $ + case mve of Nothing -> do + trace "adjustCurrent" $ adjustCurrent (cur st) mds =<< readIORef (expr st) + trace "widgetQueueDraw" $ widgetQueueDraw $ canvas gl + return False + Just ve -> do + writeIORef (hover st) Nothing + pc <- widgetCreatePangoContext $ canvas gl + new <- trace "me,displayVE" $ displayVE defaultViews pc 1 ve + trace "me,pushExpression" $ pushExpression st new + trace "me,adjustCurrent" $ adjustCurrent (cur st) mds new + widgetQueueDraw $ canvas gl + return True + +-- |Modifies the current selection. +adjustCurrent :: IORef (Maybe (Point, DERef)) -> Maybe [Relative] -> DE -> IO () +adjustCurrent cur Nothing e = writeIORef cur Nothing +adjustCurrent cur (Just l) e = modifyIORef cur f + where f :: Maybe (Point, DERef) -> Maybe (Point , DERef) + f x = do (ref, l') <- fmap (flip refGoList l . snd) x + refOffset . fst . flip refGoList l' =<< updateRef ref e + +-- |Create a restore point for a future undo +pushExpression :: State -> DE -> IO () +pushExpression st new = do + e <- readIORef $ expr st + writeIORef (expr st) new + c <- readIORef $ cur st + modifyIORef (prev st) ((c,e):) + +-- |An empty 'ViewExpression' +initialVE = ViewExpression (VarE $ Var "") Nothing + +insertOperator :: Operator -> ERef ViewExpression -> (Maybe ViewExpression, Maybe [Relative]) +insertOperator o r@(ERef de l) = traceCall "insertOperator" $ + case expressionOf de of + OpE (UserO "") _ -> (replaceRef r (ViewExpression (OpE o []) Nothing) True, Just []) + OpE op _ -> if op /= o || not (canAdd o de) then def else insertArgument r o Nothing [] + e -> case l of + ((ChildR n, p):tl) -> if expressionOp p == Just o && canAdd o p + then insertArgument (ERef p tl) o (Just $ n+1) [ParentR] + else def + _ -> def + where def = (replaceRef r (ViewExpression (OpE o (de : + [ViewExpression (VarE $ Var "") Nothing + | opMaxArg o `gt` 1] + )) Nothing) False, + Just [ChildR 1 | opMaxArg o `gt` 1]) + canAdd o e = opMaxArg o `gt` length (expressionChildren $ expressionOf e) + gt (Just a) b = a > b + gt _ _ = True + +insertArgument :: ERef ViewExpression -> Operator -> Maybe Int -> [Relative] + -> (Maybe ViewExpression, Maybe [Relative]) +insertArgument r@(ERef de l) o mp rs = + let c = expressionChildren $ expressionOf de + pos = fromMaybe (length c) mp in + (replaceRef r (rebuildExpression de (OpE o $ insertAt (ViewExpression (VarE $ Var "") Nothing) pos c)) False, + Just $ rs ++ [ChildR pos]) + +-- todo: replace with custom key bindings +operatorChar '+' = Just addO +operatorChar '*' = Just mulO +operatorChar '/' = Just divO +operatorChar '=' = Just eqO +operatorChar '-' = Just negO +operatorChar '^' = Just powO +--operatorChar '\n' = Just eqnlistO +operatorChar _ = Nothing + +-- todo: automatic multiplication "2a" -> (* 2 a) +insertCharacter :: Char -> VERef -> String -> ((Maybe ViewExpression, Maybe [Relative]), String) +insertCharacter c r@(ERef e l) prev = traceCall ("insertCharacter(" ++ show c ++ ")") $ + case (expressionOf e, null prev) of + (VarE (Var ""), _) -> ((replaceRef r (ViewExpression newE Nothing) False, Just []), [c]) + (VarE (Var _), False) -> ((replaceRef r (ViewExpression (VarE $ Var str) Nothing) False, Just []), str) + (OpE op _, _) -> + if null prev && not (null $ opName op) then deflt else + ((replaceRef r (ViewExpression (OpE (op {opName = str}) []) Nothing) True, Just []), str) + (ConstE (IntC _), False) -> + case maybeRead str of + Nothing -> + case maybeRead strdbl of + Nothing -> ignore + Just f -> ((replaceRef r (ViewExpression (ConstE $ FloatC f) Nothing) False, Just []), str) + Just i -> ((replaceRef r (ViewExpression (ConstE $ IntC i) Nothing) False, Just []), str) + (ConstE (FloatC _), False) -> + case maybeRead str of + Nothing -> ignore + Just i -> ((replaceRef r (ViewExpression (ConstE $ FloatC i) Nothing) False, Just []), str) + _ -> deflt + where newE = if not $ isDigit c then VarE (Var [c]) else ConstE (IntC $ read [c]) + str = prev ++ [c] + strdbl = if c == '.' then prev else str + ignore = ((Nothing, Just []), "") + rego = ((ParentR :) . (:[])) <$> fst <$> maybeHead (refList r) + deflt = traceCall "insertCharacter:dflt" $ ((replaceRef r (ViewExpression (OpE (trn "adding op: " $ mkOp defaultOps str) [refExp r]) (Just viewFunction)) False, rego), str) + +deleteSomething :: ERef ViewExpression -> (Maybe ViewExpression, Maybe [Relative]) +deleteSomething r@(ERef e l) = + case expressionOf e of + OpE (UserO "") _ -> + let new = maybe (ViewExpression (VarE $ Var "") Nothing) refExp + (findChild (\e -> expressionName (expressionOf e) /= "") e l) in + (replaceRef r new False, Just []) + OpE _ _ -> (replaceRef r (ViewExpression (OpE (UserO "") []) Nothing) True, Just []) + VarE (Var "") -> + case l of + [] -> (Nothing, Nothing) + ((ChildR n, p@ve):tl) -> + case expressionOf ve of + (OpE o c) -> + let v = veView ve in + (replaceRef (ERef p tl) + (ViewExpression (OpE o $ removeAt n c) v) False, + Just [ParentR]) + _ -> (Nothing, Nothing) + _ -> (replaceRef r (ViewExpression (VarE $ Var "") Nothing) False, Just []) + +veView :: ViewExpression -> Maybe View +veView (ViewExpression _ v) = v +veView (DisplayExpressionV (DisplayExpression _ v _ _ _)) = Just v + +refOffset :: ERef DisplayExpression -> Maybe (Point, ERef DisplayExpression) +refOffset r@(ERef e l) = flip (,) r <$> foldl f (Just 0) l + where f mp (ChildR n, e) = liftM2 (+) mp $ join $ maybeNth (deChildrenPos e) n + f _ (ParentR, _) = Nothing + +buttonRelease :: Global -> State -> t -> IO Bool +buttonRelease gl st ev = do + writeIORef (drag st) Nothing + mnex <- readIORef $ next st + case mnex of + Nothing -> return () + Just ex -> do + pushExpression st ex + writeIORef (next st) Nothing + writeIORef (hover st) Nothing + writeIORef (cur st) Nothing + widgetQueueDraw $ canvas gl + return False + +buttonPress :: Global -> State -> t -> IO Bool +buttonPress gl st ev = do + msel <- readIORef $ hover st + writeIORef (cur st) msel + case msel of Just (_, ERef e _) -> message gl $ show $ expressionOf e; _ -> return () + widgetQueueDraw $ canvas gl + writeIORef (typed st) "" + writeIORef (drag st) . Just =<< readIORef (xy st) + return False + +mouseMotion gl st ev = do + dw <- widgetGetDrawWindow $ canvas gl + drawWindowGetPointer dw + (ww, wh) <- widgetGetSize $ canvas gl + msel <- readIORef $ hover st + ex <- readIORef $ expr st + mdrag <- readIORef $ drag st + mnex <- readIORef $ next st + mcur <- readIORef $ cur st + rulz <- readIORef $ rules st + + let (w,h) = deSize ex + let (tx,ty) = (div (ww-w) 2, div (wh-h) 2) + let (x,y) = (round (eventX ev) - tx, round (eventY ev) - ty) + + writeIORef (xy st) (x,y) + + let select = (x,y) `inside` rect 0 (w,h) + let redraw = drawWindowInvalidateRect dw (Rectangle 0 0 ww wh) True + let (mpr, new) = if not select + then (Nothing, isJust msel) + else let (sp, ref) = fromMaybe (0, ERef ex []) msel in + case cursorDirections ex sp (x,y) ref of + Nothing -> if isNothing msel then (Just (sp, ref), True) + else (Just (sp, ref), False) + msel' -> (msel', True) + + case (new, mdrag >> mcur) of + (True, Nothing) -> writeIORef (hover st) mpr >> redraw + (False, Just _) -> redraw + (False, Nothing) -> return () + (True, Just (_, old)) -> do + writeIORef (hover st) mpr + case mpr of + Nothing -> writeIORef (next st) Nothing + Just (_, dst) -> do + pc <- widgetCreatePangoContext $ canvas gl + (writeIORef (next st) =<<) $ maybe (return Nothing) + (fmap Just . displayVE defaultViews pc 1) $ + case expressionOf $ refExp dst of + VarE (Var "") -> replaceRef (fastConvertRef DisplayExpressionV dst) + (DisplayExpressionV $ refExp old) False + _ -> case manipulate (fastConvertRef DisplayExpressionV old) + (fastConvertRef DisplayExpressionV dst) + rulz of + Nothing -> Nothing + Just ve -> Just ve + redraw + return False + +deChildrenPosAssoc = catMaybes . zipWith (fmap . (,)) [0..] . deChildrenPos + +climbOnce :: Point -> Point -> DERef -> Maybe (DE, Int, Point) +climbOnce p c (ERef e l) = foldr (f . second (+p)) Nothing (deChildrenPosAssoc e) + where f (n, p) r = let mchild = maybeNth (expressionChildren (deExpression e)) n in + case mchild of Nothing -> Nothing + Just child -> if c `inside` rect p (deSize child) + then Just (child, n, p) else r + +cursorDirections parent pos cursor ref = + if cursor `inside` rect pos (deSize $ refExp ref) + then case climbToCursor pos cursor $ ERef (refExp ref) [] of + (p, ERef _ []) -> Nothing + (p, ref') -> Just (p, appendRef ref' $ refList ref) + else Just $ climbToCursor 0 cursor (ERef parent []) + +climbToCursor pos cursor ref@(ERef e l) = + maybe (pos, ref) (\(child, index, pos') -> + climbToCursor pos' cursor $ ERef child ((ChildR index, e) : l)) + (climbOnce pos cursor ref) + +rect (x,y) (w,h) = Rectangle x y w h + +inside (a,b) (Rectangle x y w h) = and [a>=x, b>=y, a + do let (tx,ty) = (div (ww-w) 2, div (wh-h) 2) + case msel of + Nothing -> return () + Just ((sx, sy), ref@(ERef e l)) -> + let (w,h) = deSize e in + drawRectangle dw gcGrey False (sx+tx) (sy+ty) (w-1) (h-1) + case mcur of + Nothing -> return () + Just ((x, y), ERef e _) -> + let (w,h) = deSize e in + drawRectangle dw gc False (x+tx) (y+ty) (w-1) (h-1) + case (mdrag, mcur) of + (Just p, Just (o, r)) | p /= (x,y) -> + let offset = divPoint ((2*x, 2*y) - p - divPoint (deSize $ refExp r) 2 - o) 2 in + draw dw gc (tx, ty) $ offsetChild r offset $ deDraw ex + _ -> draw dw gc (tx,ty) $ deDraw ex + Just e -> + let (w,h) = deSize e + (tx,ty) = (div (ww-w) 2, div (wh-h) 2) in + draw dw gc (tx,ty) $ deDraw e + --statusShow $ show ((x,y), (sx, sy), (tx,ty)) + drawWindowEndPaint dw + return False + +offsetChild :: ERef a -> Point -> DrawInfo Tag -> DrawInfo Tag +offsetChild (ERef _ list) offset di = maybe di (alter di) mchildIndexes + where mchildIndexes :: Maybe [Int] + mchildIndexes = reverse <$> sequence (map (cn . fst) list) + cn :: Relative -> Maybe Int + cn (ChildR n) = Just n + cn _ = Nothing + alter :: DrawInfo Tag -> [Int] -> DrawInfo Tag + alter di [] = DrawInfo (diBox di) $ GroupD [] [(offset, di)] + alter (DrawInfo box (TagD (n, tag) d)) (c:cs) | n == c = + DrawInfo box (TagD (n, tag) $ diDrawing $ alter (DrawInfo box d) cs) + alter (DrawInfo box (GroupD p l)) cs = + DrawInfo box (GroupD p (map (second (\d -> alter d cs)) l)) + alter di _ = di + +data DisplayExpression = DisplayExpression { + deExpression :: Expression DisplayExpression, + deView :: View, + deScale :: Double, + deDraw :: DrawInfo Tag, + deChildrenPos :: [Maybe Point] + } deriving Show + +data ViewExpression = ViewExpression (Expression ViewExpression) (Maybe View) + | DisplayExpressionV DisplayExpression + +instance ExpressionLike ViewExpression where + expressionOf (ViewExpression e _) = e + expressionOf (DisplayExpressionV d) = convertExpression DisplayExpressionV $ deExpression d + +instance Expressionable ViewExpression where + buildExpression e = ViewExpression e Nothing + rebuildExpression (ViewExpression _ v) e = ViewExpression e v + rebuildExpression (DisplayExpressionV de) e = ViewExpression e $ Just $ deView de + +instance ExpressionLike DisplayExpression where + expressionOf (DisplayExpression e _ _ _ _) = e + +type Drawer = Draw Tag () + +type Tag = (Int, Either DisplayExpression (Expression ViewExpression, View, Double)) + +type EVE = Expression ViewExpression + +data ChildInfo = ChildInfo { + expressionCI :: EVE, + drawerCI :: Drawer, + showParensCI :: Priority -> Bool +} + +data View = View { + displayV :: EVE -> [ChildInfo] -> Drawer, + showParensV :: Int -> Bool + } + +instance Show View where + show v = "" + +deSize de = diSize $ deDraw de + + +-- | Takes VE, its renedring context and its DrawInfo and returns a DE +-- By extracting information about the children +buildDE :: VE -> Double -> PangoContext -> DrawInfo Tag -> View -> IO DE +buildDE ve sc pc di vi = traceCall ("buildDE(" ++ show (expressionOf ve) ++ ")") $ do + cs <- children + return $ DisplayExpression (ex cs ve) vi sc di (cpos cs) + where ex cs = trace "buildDE:ex" $ convertExpressionIndex (f cs) . expressionOf + f cs _ = trace "buildDE:f" $ child cs + child cs n = trace "buildDE:child" $ fromMaybe errorDE . fmap snd . lookup n $ cs + children :: IO [(Int, (Point, DE))] + children = trace "buildDE:children" $ + sequence $ map (\(pos, (idx, e)) -> (,) idx <$> (,) pos <$> gc idx e) $ + getTagsPos 0 $ trn "getTagPos of " $ diDrawing di + gc _ (Left de) = trace "buildDE:gc (Left)" $ return de + gc n (Right (ex, vi, sc)) = trace "buildDE:gc (Right)" $ do + dinfo <- eve2di n ex vi sc pc + buildDE (ViewExpression ex Nothing) sc pc dinfo vi + cpos cs = trace "buildDE:cpos" $ + map (fmap fst . flip lookup cs) + [0..(foldl max (negate 1) $ map fst cs)] + errorDE :: DisplayExpression + errorDE = DisplayExpression (ConstE $ NamedC "?internal-error?") (constantV defaultViews) sc (DrawInfo (Rectangle 0 0 0 0) (LineD (0,0) (0,0))) [] + +-- | Renders an EVE into a DrawInfo +eve2di :: Int -> EVE -> View -> Double -> PangoContext -> IO (DrawInfo Tag) +eve2di n eve view sc pc = traceCall "eve2di" $ do + fromMaybe emptyDI <$> fst <$> + drawF (putVE ({-Just n-} Nothing) defaultViews (ViewExpression eve $ Just view)) sc pc squashed + +-- | Entry point to the expression rendering process +displayVE :: Views -> PangoContext -> Double -> ViewExpression -> IO DisplayExpression +displayVE vs pc sc ve = traceCall "displayVE" $ do + ret <- uncurry (buildDE ve sc pc) =<< first (fromMaybe emptyDI) + <$> (trace "dve,drawF" $ drawF (putVE Nothing vs ve) sc pc squashed) + return $ flip traceCall ret $ "displayVE(" ++ show (expressionOf ve) ++ ") = " ++ show (deDraw ret) + +-- | Build a Draw from a VE and its View +putVE :: Maybe Int -> Views -> ViewExpression -> Draw Tag View +putVE mindex views (DisplayExpressionV + de@(DisplayExpression + { deScale = scale, deExpression = expression, deView = view, deDraw = di })) = + traceCall "putVE.D" $ do + sc <- getScale + if sc == scale + then do maybe id (\index -> tag (index, Left de)) mindex $ putDI di; return view -- XXX + else putVE mindex views nve + where nve = ViewExpression (convertExpression DisplayExpressionV expression) (Just view) +putVE mindex views ve@(ViewExpression expression mv) = traceCall "putVE.V" $ do + s <- getScale + di <- (fromMaybe emptyDI . fst) <$> + removeDI (trace "putVE,displayV" $ + displayV view expression (dc $ expressionChildren expression)) + (maybe id (\index -> tag (index, Right (expression, view, s))) mindex) $ putDI di + return view + where view = trn "putVE.V:view = " $ fromMaybe (findView views expression) mv + dc = trace "pve:dc" $ zipWith (\i e -> ChildInfo (expressionOf e) (putVE (Just i) views e >> return ()) (showParensV view)) [0..] + +data Views = Views { + variableV, constantV :: View, + operatorV :: Operator -> View -- Map? + } + +findView (Views v c f) (VarE _) = v +findView (Views v c f) (ConstE _) = c +findView (Views v c f) (OpE o _) = f o + +defaultShowParens op p2 = opPriority op < p2 + +defaultPriorities p = [p,p..] + +defaultViews = Views defaultViewVarOrConst defaultViewVarOrConst defaultViewOp + +defaultViewVarOrConst = View viewNameOrValue (const False) + +viewNameOrValue ex _ = + let str = expressionName ex in + text (if null str then "_" else str) + +defaultViewOp :: Operator -> View +defaultViewOp op | op == addO = viewBinOp "+" op +defaultViewOp op | op == mulO = viewBinOp [chr 0x00b7] op +defaultViewOp op | op == eqO = viewBinOp "=" op +defaultViewOp op | op == negO = viewUnaryOp "-" op +defaultViewOp op | op == divO = viewDiv +defaultViewOp op | op == powO = viewPow op +defaultViewOp op | op == eqnlistO = viewList +defaultViewOp _ = trace "defaultViewOp.other" $ viewFunction + +-- todo: show paren only when ambiguous (eg: (-1)^2, (1/2)^3 ) +viewPow op = View displayPow $ defaultShowParens op + +viewBinOp :: String -> Operator -> View +viewBinOp o op = View (displayBinOp o $ opPriority op) $ defaultShowParens op + +viewUnaryOp o op = View (displayUnaryOp o $ opPriority op) $ defaultShowParens op + +viewDiv = View displayDiv (const False) + +viewList = View displayList (const False) + +type DV = EVE -> [ChildInfo] -> Drawer + +displayBinOp :: String -> Priority -> DV +displayBinOp str prio expression ci@(_:_:_) = + displaying centeredNextTo $ sequence_ $ intersperse (text str) $ map (parensCI prio) ci +displayBinOp _ _ expression children = displayFunction expression children + +displayUnaryOp :: String -> Priority -> DV +displayUnaryOp str prio expression [c] = + displaying centeredNextTo $ text str >> parensCI prio c +displayUnaryOp _ _ expression children = displayFunction expression children + + +displayDiv :: DV +displayDiv expression l@[a,b] = do + adi <- fmap (fromMaybe emptyDI) $ removeDI_ $ drawerCI a + bdi <- fmap (fromMaybe emptyDI) $ removeDI_ $ drawerCI b + let w = max (rectWidth $ diBox adi) (rectWidth $ diBox bdi) + 2 + displaying centeredUnder $ do + putDI adi + line 0 0 w 0 + putDI bdi +displayDiv expression children = displayFunction expression children + +-- todo: align =, number +displayList :: DV +displayList expression children = + displaying centeredUnder $ sequence_ $ childrenDs minPriority children + +viewFunction = View displayFunction (const False) + +displayFunction :: DV +displayFunction expression children = trace "displayFunction" $ do + let name = expressionName expression + str = if null name then [chr 0xfffd] else name + trm "M" + displaying centeredNextTo $ do + trm ("N:" ++ str) + text str + trm "P" + addParens $ + sequence_ $ intersperse (text ",") $ childrenDs minPriority children + trm "Q" + +displayPow expression l@[a,b] = do + adi <- fmap (fromMaybe emptyDI) $ removeDI_ $ parensCI 801 a -- TODO: depepnding on expression, always show parenthises + bdi <- fmap (fromMaybe emptyDI) $ removeDI_ $ scaleBy 0.7 $ parensCI 800 b + let ha = rectHeight $ diBox adi + let hb = rectHeight $ diBox bdi + displaying superscript $ do + putDI adi + putDI bdi +displayPow e c = displayFunction e c + +childrenDs :: Priority -> [ChildInfo] -> [Drawer] +childrenDs p = map $ parensCI p + +parensCI p c = if showParensCI c p then addParens d else d + where d = drawerCI c diff --git a/Casui/Menu.hs b/Casui/Menu.hs new file mode 100644 --- /dev/null +++ b/Casui/Menu.hs @@ -0,0 +1,50 @@ +module Casui.Menu where + +import Graphics.UI.Gtk +import Control.Monad + +populateMenu :: MenuShellClass a => a -> [SimpleMenu] -> IO () +populateMenu shell = mapM_ ((menuShellAppend shell =<<) . buildMenu) + +buildMenu (LeafM name action) = do + item <- menuItemNewWithLabel name + onActivateLeaf item action + return item +buildMenu SeperatorM = fmap castToMenuItem separatorMenuItemNew +buildMenu (MenuM name children) = do + item <- menuItemNewWithLabel name + menu <- menuNew + menuItemSetSubmenu item menu + populateMenu menu children + return item +buildMenu (DynM name mchildren) = do + item <- menuItemNewWithLabel name + menu <- menuNew + menuItemSetSubmenu item menu + onSelect item $ do + children <- mchildren + when (genMenuValue children) $ + do mapM_ (containerRemove menu) =<< containerGetChildren menu + populateMenu menu $ genMenuItems children + widgetShowAll menu + return item + + +data SimpleMenu = LeafM String (IO ()) + | SeperatorM + | MenuM String [SimpleMenu] + | DynM String (IO (GenMenu Bool)) + +data GenMenu a = GenMenu { genMenuItems :: [SimpleMenu], genMenuValue :: a } + +instance Monad GenMenu where + return = GenMenu [] + GenMenu l a >>= f = case f a of GenMenu k b -> GenMenu (l++k) b + +seperator = GenMenu [SeperatorM] () + +leaf a b = GenMenu [LeafM a b] () + +submenu a s = GenMenu [MenuM a $ genMenuItems s] () + +dynamicMenu a s = GenMenu [DynM a s] () diff --git a/Casui/Module.hs b/Casui/Module.hs new file mode 100644 --- /dev/null +++ b/Casui/Module.hs @@ -0,0 +1,34 @@ +module Casui.Module where + +import Casui.Name +import Casui.Value +import Casui.Utils + +import Control.Monad + +data ModuleList val = ModuleList { mlList :: [Module FullName val] } + +data Module name val = Module { + mFullName :: FullName, + mImports :: [name], + mDefines :: [(Symbol, Maybe val)], + mProperties :: [(name, Property name val)] + } + + +type ModuleLibrary = ModuleList Expression + +isBuiltIn :: Module FullName v -> Bool +isBuiltIn (mFullName -> FullName Builtin _) = True +isBuiltIn _ = False + + +findModules :: Name -> ModuleLibrary -> [Module FullName Expression] +findModules n (ModuleList l) = filter (matchName n . mFullName) l + +resolveName :: Name -> ModuleList Expression -> Maybe FullName +resolveName (Name (reverse -> (name:(reverse -> path)))) modlist = + foldl mplus Nothing $ + map (lookup name) $ + map (\m -> map (flip (,) (mFullName m) . fst) (mDefines m)) $ + findModules (Name path) modlist diff --git a/Casui/Name.hs b/Casui/Name.hs new file mode 100644 --- /dev/null +++ b/Casui/Name.hs @@ -0,0 +1,66 @@ +module Casui.Name where + +import Casui.Utils + +import Data.Unique +import Data.List + +type Symbol = String + + +class HasName t where + nameOf :: t -> Name + +instance HasName Name where + nameOf = id + +instance HasName FullName where + nameOf (FullName Builtin l) = Name $ "builtin" : l + nameOf (FullName _ l) = Name $ l + +matchName :: Name -> FullName -> Bool +matchName (Name n) (FullName i fn) = + case dropSame (reverse n) (reverse fn) of + ([], _) -> True + (["builtin"],[]) -> i == Builtin + _otherwise -> False + +data Name = Name [Symbol] + deriving Eq + +data FullName = FullName FileId [Symbol] + deriving Eq + +data FileId = Builtin | Lexical | FileId Unique + deriving Eq + +instance Show Name where + show (Name l) = (concat $ intersperse ":" l) + +instance Show FullName where + show (FullName i l) = concat $ intersperse ":" $ if show i == "" then l else show i : l + +instance Show FileId where + show Builtin = "builtin" + show Lexical = "lexical" + show (FileId i) = "#e" ++ show (hashUnique i) + +instance FName Name where + fullName e s = Name $ show e : splitChar ':' s + +instance FName FullName where + fullName i s = FullName i $ splitChar ':' s + +builtin :: FName n => String -> n +builtin s = fullName Builtin s + +class (Eq n, Show n) => FName n where + fullName :: FileId -> String -> n + +mkName :: String -> Name +mkName = Name . splitChar ':' + + +catNames :: Name -> Name -> Name +catNames (Name a) (Name b) = Name $ a ++ b + diff --git a/Casui/Parse.hs b/Casui/Parse.hs new file mode 100644 --- /dev/null +++ b/Casui/Parse.hs @@ -0,0 +1,147 @@ +{-# LANGUAGE ScopedTypeVariables #-} + +module Casui.Parse where + +import Casui.Name +import Casui.Utils +import Casui.Value +import Casui.Module + +import Data.Ratio +import Data.List +import Control.Monad +import Control.Monad.Error +import Control.Applicative hiding ((<|>), many) +import Control.Arrow +import Text.ParserCombinators.Parsec + + +nonSymbolChars :: [Char] +nonSymbolChars = " \r\n\t()\"#',`" + +parseValue :: Parser ParsedValue +parseValue = pSpacesOrComment >> ( + pQQU + <|> pList + <|> pString + <|> pNumber + <|> pSymbol + ) <* pSpacesOrComment + +pSpacesOrComment :: Parser () +pSpacesOrComment = spaces >> ((try $ char ';' >> skipMany (noneOf "\n")) <|> return ()) + +pQQU :: Parser ParsedValue +pQQU = do c <- oneOf "'`," + let n = case c of '\'' -> "quote"; ',' -> "unquote"; '`' -> "quasiquote"; _ -> unreachable + spaces + v <- parseValue + ParsedValue <$> getPosition <*> return (VStruct (builtin $ "script:" ++ n) [v]) + +pList :: Parser ParsedValue +pList = ParsedValue <$> getPosition <*> (VList <$> (pParens $ many (parseValue <* spaces))) + +pParens :: Parser a -> Parser a +pParens p = char '(' >> p <* char ')' + +pString :: Parser ParsedValue +pString = ParsedValue <$> getPosition <*> fmap VString ( + char '"' + >> (many $ pStringEscape <|> noneOf ['"']) + <* char '"' ) + +pStringEscape :: Parser Char +pStringEscape = char '\\' >> do + c <- anyChar + case lookup c [('n','\n'),('\\','\\'),('\r','\r'),('\t','\t')] of + Just v -> return v + _ -> unexpected "unvalid use of backslash in string" + +pNumber :: Parser ParsedValue +pNumber = lookAhead (digit <|> char '.') >> do + (i :: Integer) <- maybe 0 read <$> optionMaybe (many1 digit) + f <- maybe 0 fpart <$> optionMaybe (char '.' >> many1 digit) + ParsedValue <$> getPosition <*> (return . VExact . toRational $ toRational i + f) + where fpart = liftM2 (%) read $ (10^) . length + +pSymbol :: Parser ParsedValue +pSymbol = ParsedValue <$> getPosition <*> (VName <$> pName) + +pName :: Parser Name +pName = mkName <$> many1 (noneOf nonSymbolChars) + + +instance Show ParsedValue where + show (ParsedValue _ v) = show v + +uvModule :: FileId -> Name -> ParsedValue -> + Either (TagError SourcePos) (Module ParsedName ParsedValue) +uvModule extid (Name parent) + (val -> VList ((val -> VName (Name ["module"])) : (val -> VName (Name [nam])) : content)) = + let ([imps, defs], props) = groupVL [mkName "import", mkName "define"] $ content in do + imports <- fmap (if null parent then id else (ParsedName Nothing (Name parent):)) . + fmap concat . mapM listImports $ map snd imps + (defines, dprops) <- second concat . unzip <$> mapM (uncurry listDefines) defs + properties <- map mkProp . (dprops ++) <$> mapM getProp props + return $ Module (FullName extid $ parent ++ [nam]) + imports defines properties + where + listImports :: [ParsedValue] -> Either (TagError SourcePos) [ParsedName] + listImports syms = mapM getName syms + listDefines _def (sym:pprops) = do + n <- getName sym + s <- case n of ParsedName _ (Name [s]) -> return s + _otherwise -> Left $ err "compound name in define" $ pvSourcePos sym + (mv, pprops') <- extractValue pprops + ps <- mapM getPProp pprops' + return ((s, mv), map (\(a,b) -> (a, n, b)) ps) + listDefines def _ = Left $ err "empty define" $ pvSourcePos def + extractValue ps = case partition notList ps of + ([a], l) -> return (Just a, l) + ([], l) -> return (Nothing, l) + ((_:v:_), _) -> Left $ err "too many values in define" $ pvSourcePos v + notList (val -> VList _) = True + notList _ = False + getPProp :: ParsedValue -> Either (TagError SourcePos) (ParsedName, [ParsedValue]) + getPProp (val -> VList (prop:arg)) = liftM2 (,) (getName prop) (return arg) + getPProp v = Left $ err "expecting a partial property" $ pvSourcePos v + getProp :: ParsedValue -> Either (TagError SourcePos) (ParsedName, ParsedName, [ParsedValue]) + getProp (val -> VList (prop:name:arg)) = liftM3 (,,) (getName prop) (getName name) (return arg) + getProp v = Left $ err "expecting a property" $ pvSourcePos v + getName :: ParsedValue -> Either (TagError SourcePos) ParsedName + getName v@(val -> VName n) = return $ ParsedName (Just $ pvSourcePos v) (n) + getName v = Left $ err "expecting a symbol" $ pvSourcePos v + mkProp :: (ParsedName, ParsedName, [ParsedValue]) -> + (ParsedName, Property ParsedName ParsedValue) + mkProp (prop,obj,arg) = (obj, E prop arg) + +uvModule _ _ (ParsedValue sp _) = Left $ err "expecting a module declaration" sp + +groupVL :: Val v => [Name] -> [v] -> ([[(v, [v])]], [v]) +groupVL [] vl = ([], vl) +groupVL (name:names) vl = first (match:) $ groupVL names others + where (match, others) = extractVL name vl + +extractVL :: Val v => Name -> [v] -> ([(v, [v])], [v]) +extractVL _ [] = ([],[]) +extractVL name (v:vs) = put $ extractVL name vs + where put = case val v of VList ((val -> VName head):tail) + | head == name -> first ((v, tail):) + _otherwise -> second (v:) + + +type ParsedModule = Module ParsedName ParsedValue + +data ParsedName = ParsedName (Maybe SourcePos) Name + +instance HasName ParsedName where + nameOf (ParsedName _ name) = name + +data ParsedValue = ParsedValue { + pvSourcePos :: SourcePos, + pvValue :: Value ParsedValue + } + +instance Val ParsedValue where + val (ParsedValue _ v) = v + diff --git a/Casui/Utils.hs b/Casui/Utils.hs new file mode 100644 --- /dev/null +++ b/Casui/Utils.hs @@ -0,0 +1,101 @@ +{-# LANGUAGE EmptyDataDecls, PatternGuards #-} + +module Casui.Utils + ( unreachable + , justRight + , ifJust + , insertAt + , divPoint + , maxSize + , convertInt + , fst3 + , snd3 + , first3 + , second3 + , maybeNth + , third3 + , thrd + , maybeHead + , dropSame + , splitChar + , TagError + , errorData + , errorMessage + , err + ) where + +import Control.Monad.Error + +unreachable :: a +unreachable = error "unreachable" + +justRight :: Either a b -> Maybe b +justRight (Left _) = Nothing +justRight (Right a) = Just a + +ifJust :: (Monad m) => Maybe a -> (a -> m ()) -> m () +ifJust a f = maybe (return ()) f a + +insertAt :: a -> Int -> [a] -> [a] +insertAt a _ [] = [a] +insertAt a 0 l = a:l +insertAt a n (x:l) = x : insertAt a (n-1) l + +type Point = (Int, Int) + +divPoint :: Point -> Int -> Point +divPoint (a,b) x = (div a x, div b x) + +maxSize :: Point -> Point -> Point +maxSize (a,b) (c,d) = (max a c, max b d) + +instance (Num a, Num b) => Num (a, b) where + (a,b) + (c,d) = (a+c, b+d) + (a,b) - (c,d) = (a-c, b-d) + (a,b) * (c,d) = (a*c, b*d) + abs (a,b) = (abs a, abs b) + signum (a,b) = (signum a, signum b) + fromInteger a = (fromInteger a,0) + +convertInt :: (Integral a, Integral b) => a -> b +convertInt = fromInteger . toInteger + +fst3 (a,_,_) = a + +first3 f (a,b,c) = (f a,b,c) + +second3 f (a,b,c) = (a,f b,c) + +third3 f (a,b,c) = (a,b,f c) + +maybeNth [] _ = Nothing +maybeNth (x:_) 0 = Just x +maybeNth (_:xs) n = maybeNth xs (n-1) + +snd3 (_,a,_) = a + +thrd (_, _, a) = a +maybeHead :: [a] -> Maybe a +maybeHead (x:_) = Just x +maybeHead _ = Nothing + +dropSame :: Eq a => [a] -> [a] -> ([a], [a]) +dropSame (a:as) (b:bs) | a == b = dropSame as bs +dropSame as bs = (,) as bs + +splitChar :: Char -> String -> [String] +splitChar c l | (a,(_:b)) <- break (==c) l = a : splitChar c b + | otherwise = [l] + + +data TagError a = TagError { + errorMessage :: String, + errorData :: Maybe a + } + +instance Error (TagError a) where + noMsg = TagError "" Nothing + strMsg e = TagError e Nothing + +err :: String -> a -> TagError a +err e d = TagError e $ Just d diff --git a/Casui/Value.hs b/Casui/Value.hs new file mode 100644 --- /dev/null +++ b/Casui/Value.hs @@ -0,0 +1,72 @@ +module Casui.Value where + +import Casui.Name + +import Data.Ratio +import Data.List + +data Value val = VName Name + | VExact Rational + | VString String + | VList [val] + | VStruct FullName [val] + | VFun ([val] -> val) + -- | VProc ([val] -> Casui val) + +data Property name val = E name [val] + +data Expression = Expression { + eProperties :: Property FullName Expression, + eValue :: Value Expression + } + +type Type = FullName + +class Val v where + val :: v -> Value v + +class ToValue a where + value :: a -> Value v + +class FromValue a where + unvalue :: Value v -> Maybe a + +instance ToValue Bool where + value True = VName $ fullName Builtin "bool:true" + value False = VName $ fullName Builtin "bool:false" + +instance FromValue Bool where + unvalue (VName n) | n == builtin "bool:true" = Just True + | n == builtin "bool:false" = Just False + unvalue _ = Nothing + +instance ToValue Int where + value = VExact . toRational + +instance FromValue Int where + unvalue (VExact r) = if denominator r == 1 then Just . fromInteger $ numerator r else Nothing + unvalue _ = Nothing + +baseType :: Value v -> Type +baseType (VName _) = builtin "type:symbol" +baseType (VExact _) = builtin "type:rational" +baseType (VString _) = builtin "type:string" +baseType (VList _) = builtin "type:list" +baseType (VFun _) = builtin "type:fun" +baseType (VStruct t _) = t + + +isPrimitiveType :: FName n => n -> Bool +isPrimitiveType (show -> s) = elem s . map ("builtin:type:"++) $ ["symbol", "rational", "string"] + + +instance Show v => Show (Value v) where + show (VName n) = show n + show (VExact r) = if denominator r == 1 then show $ numerator r else show $ (fromRational r :: Double) + show (VString s) = show s + show (VList l) = "(" ++ (concat . intersperse " ") (map show l) ++ ")" + show (VFun _) = "#fun" + show (VStruct n [a]) | show n == "builtin:script:quote" = "'" ++ show a + show (VStruct n [a]) | show n == "builtin:script:unquote" = "," ++ show a + show (VStruct n [a]) | show n == "builtin:script:quasiquote" = "`" ++ show a + show (VStruct n l) = "(" ++ (concat . intersperse " ") (show n : map show l) ++ ")" diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,19 @@ +Copyright (c) 2011 Etienne Laurin + +Permission is hereby granted, free of charge, to any person obtaining a copy +of this software and associated documentation files (the "Software"), to deal +in the Software without restriction, including without limitation the rights +to use, copy, modify, merge, publish, distribute, sublicense, and/or sell +copies of the Software, and to permit persons to whom the Software is +furnished to do so, subject to the following conditions: + +The above copyright notice and this permission notice shall be included in +all copies or substantial portions of the Software. + +THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR +IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, +FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE +AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER +LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, +OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN +THE SOFTWARE. diff --git a/Setup.lhs b/Setup.lhs new file mode 100644 --- /dev/null +++ b/Setup.lhs @@ -0,0 +1,3 @@ +#!/usr/bin/env runhaskell +> import Distribution.Simple +> main = defaultMain diff --git a/casui.cabal b/casui.cabal new file mode 100644 --- /dev/null +++ b/casui.cabal @@ -0,0 +1,27 @@ +name: casui +version: 0.3 +stability: experimental +synopsis: Equation Manipulator +description: Interactive user interface for computer algebra systems +category: Math +license: MIT +license-file: LICENSE +author: Etienne Laurin +maintainer: Etienne Laurin +homepage: http://code.atnnn.com/projects/casui +bug-reports: http://code.atnnn.com/projects/casui/issues/new +cabal-version: >= 1.6 +build-type: Simple +data-dir: data/ +data-files: *.cui +tested-with: GHC ==7.0.3 +extra-source-files: Casui/*.hs + +executable casui + main-is: Casui/Gui.hs + build-depends: base > 3, base < 5, parsec >= 3, gtk, haskell98, mtl + --ghc-options: -Wall + +source-repository head + type: darcs + location: http://code.atnnn.com/darcs/casui/ diff --git a/data/modules.cui b/data/modules.cui new file mode 100644 --- /dev/null +++ b/data/modules.cui @@ -0,0 +1,216 @@ +;;;; extending Casui + +;; all module prefixes can be omitted, name lookup depends on the context +;; all types of extensions have the same namespace + +;;;; basic extension types + +;; (module [extensions ...]) +;; define extensions in a named module +;; the enclosed extensions automatically get the name: prefix +;; the extensions can include another module, eg foo:bar:baz + +;; (script:property ) +;; define a type of property +;; the property can then be used as an extension, to define a tuple +;; eg. (name a) (name a b) (name a b c) + +;; (script:alias ) +;; creates an alias for the other name + +;; (script:type ) +;; create a user-defined type + +;; (script:context ) +;; define a custom context for expressions + +;; (script:constant ) +;; (script:variable [value]) +;; (script:subroutine ([arguments*]) ) +;; these three allow to define variables, constants and subs + +;; (script:op ) +;; define an operator + +;; (match:canonical ) +;; equivalent expression used when pattern matching + +;; (math:simplify ) + +;; (ui:input-alias ) +;; (ui:input-alias ( [arguments*])) +;; input alias + +;; (script:use [none | [ | ( )]* ]) +;; modules to include +;; default use is (script ui math view expression equations) +;; priority is left to right + +;; (script:define [ | (property [arguments*])])* +;; shorthand for defining multiple properties + +;;;; Properties + +;; (ui:view ) +;; the view of an instance, an object or a type, +;; eg. (view math:add view:binop) + +;; (view:operator ) -- string - the character for unop or binop + + +;; (ui:handler ( [arguments*]) ) +;; trigger code when event happens +;; arguments are deep pattern matching + +;; (ui:priority ) +;; operator prority, currently 0 to 1200 based on prolog + +;;;; ops + +;; math:add +;; math:mult +;; math:div +;; math:pow +;; math:neg +;; math:equals +;; data:list +;; script:rule +;; math:inv + +;;;; Views + +;; view:function +;; view:binop +;; view:unop +;; view:frac +;; view:sqrt +;; view:div +;; view:pow +;; view:name +;; view:bool + +;;;; Types + +;; symbol, exact, inxact, string, list + +;;;; Contexts + +;; View resolution: instance -> object -> type -> context -> loaded modules in order + +;; equations:context +;; default context for equations in the ui + +;; script:context +;; default context for script files + +;;;; subroutines + +;; the language is a kind of lisp +;; with somevariables dynamically bound + +;; builtin:handle-key-press + +;;;; Handlers + +;; the most specific handler pattern match is chosen + +;; (expression:keypress any (handle-key-press)) +;; enter a number +;; add operator +;; move with arrows + +;;;; Modules + +(module elementary-algebra ; http://en.wikipedia.org/wiki/Elementary_algebra + + ;; todo: + ;; monotone (increasing/decreasing/by variable) + + ; operations defined in this module + (define add op + (inverse subtract) + (zero 0) + commutative + associative + (sub list (apply + list)) + (operator "+")) + (define subtract op + (zero 0) + (inverse add) + (sub (a b) (- a b)) + (operator "-")) + (define negate op + (operator "-") + (sub (a) (- a))) + (define multiply op + (zero 1) + commutative + associative + (distributes add) + (sub list (apply * list)) + (operator "*")) + (define divide op + (zero 1) + (inverse mul (not-equal b 0)) + (sub (a b) (/ a b)) + (condition (not-equal b 0)) + (operator "/")) + (define inverse op + (sub (a) (divide 1 a)) + (condition (not-equal a 0))) + (define log op + (sub (a b) (log a b)) + (sub (a) (log a default-log-base))) + (define pow op) + (define nth-root op) + (define not-equal op + inequality) + (define equal op + equality + inequality) + (define less-than op + inequality) + (define greater-than op + inequality) + (define less-than-or-equal op + inequality) + (define greater-than-or-equal op + inequality) + + (canonical (subtract a b) (add a (negate b))) + + (move source dest + ('op source dest) ; match enginge knows about commutativity and associativity + (prop (commutative op)) + (rebuild empty (add source (mark dest)))) ;and rebuilds expression like it was + + + (move source dest + ('op1 source dest) ; match enginge knows about commutativity and associativity + (prop (distributive (op1 (op dest)))) + (rebuild empty ; match:empty, a special value + (mark ; change selection to here, match:mark + (apply (op dest) + (map (lambda (child) + (op1 source child)) ; todo: correct order (right/left distributivity) + (children dest)))))) + (move source dest + (divide dest (either source (* source))) + true + (rebuild empty (multiply dest (inverse (mark source))))) + + (move source dest + (multiply source (dest (root a b))) + true + (rebuild empty (root (multiply (pow (mark source) b) a) b))) + + (move source dest + (op (either (add source)) dest) + (prop (inequality op)) + (rebuild empty (add dest (negate source)))) + + (move source dest + (pow (dest (pow a b)) source) + true + (pow a (multiply b (mark source)))) +) ; end module elementary-algebra diff --git a/data/rules.cui b/data/rules.cui new file mode 100644 --- /dev/null +++ b/data/rules.cui @@ -0,0 +1,14 @@ +(rule (* $ (+ #)) (+ (* $ #))) +(rule (* (+ #) $) (+ (* # $))) +(rule (/ (+ #) $) (+ (/ # $))) +(rule (* $ #) (* # $)) +(rule (* # $) (* $ #)) +(rule (+ $ #) (+ # $)) +(rule (+ # $) (+ $ #)) +(rule (/ # $) (* # (inv $))) +(rule (/ $ #) (/ 1 (* # (inv $)))) +(rule (pow (* #) $) (* (pow # $))) +(rule (* $ (nthroot a #)) (nthroot a (* (pow $ a) #))) +(rule (= $ #) (= 0 (+ # (- $)))) +(rule (= # $) (= (+ # (- $)) 0)) +(rule (pow (pow a #) $) (pow a (* # $)))