casui (empty) → 0.3
raw patch · 17 files changed
+2433/−0 lines, 17 filesdep +basedep +gtkdep +haskell98setup-changed
Dependencies added: base, gtk, haskell98, mtl, parsec
Files
- Casui/CAS.hs +389/−0
- Casui/Casui.hs +45/−0
- Casui/Compile.hs +37/−0
- Casui/Debug.hs +46/−0
- Casui/Draw.hs +301/−0
- Casui/Gui.hs +866/−0
- Casui/Menu.hs +50/−0
- Casui/Module.hs +34/−0
- Casui/Name.hs +66/−0
- Casui/Parse.hs +147/−0
- Casui/Utils.hs +101/−0
- Casui/Value.hs +72/−0
- LICENSE +19/−0
- Setup.lhs +3/−0
- casui.cabal +27/−0
- data/modules.cui +216/−0
- data/rules.cui +14/−0
+ Casui/CAS.hs view
@@ -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 <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))")
+ Casui/Casui.hs view
@@ -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+
+ Casui/Compile.hs view
@@ -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
+ Casui/Debug.hs view
@@ -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"
+ Casui/Draw.hs view
@@ -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 = "<Glyph>"++-- 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)))
+ Casui/Gui.hs view
@@ -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 <etienne@atnnn.com>.++{-# 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<x+w, b<y+h]++redraw gl st ev = do+ dw <- widgetGetDrawWindow $ canvas gl+ gc <- gcNewWithValues dw $ newGCValues {foreground = Color 0 0 0}+ gcGrey <- gcNewWithValues dw $ newGCValues {foreground = Color 32768 32768 32768}+ (x,y) <- readIORef $ xy st+ (ww, wh) <- widgetGetSize $ canvas gl+ drawWindowBeginPaintRect dw $ Rectangle 0 0 ww wh+ ex <- readIORef $ expr st+ --trm ("redrawing " ++ show ex)+ let (w,h) = deSize ex+ msel <- readIORef $ hover st+ mcur <- readIORef $ cur st+ mnex <- readIORef $ next st+ mdrag <- readIORef $ drag st+ case mnex of+ Nothing ->+ 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 = "<view>"++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
+ Casui/Menu.hs view
@@ -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] ()
+ Casui/Module.hs view
@@ -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
+ Casui/Name.hs view
@@ -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+
+ Casui/Parse.hs view
@@ -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+
+ Casui/Utils.hs view
@@ -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
+ Casui/Value.hs view
@@ -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) ++ ")"
+ LICENSE view
@@ -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.
+ Setup.lhs view
@@ -0,0 +1,3 @@+#!/usr/bin/env runhaskell+> import Distribution.Simple+> main = defaultMain
+ casui.cabal view
@@ -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 <etienne@atnnn.com>+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/
+ data/modules.cui view
@@ -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 <name> [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 <name> <type>)+;; 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 <alias> <name>)+;; creates an alias for the other name++;; (script:type <name>)+;; create a user-defined type++;; (script:context <name> <lookup-order>)+;; define a custom context for expressions++;; (script:constant <name> <value>)+;; (script:variable <name> [value])+;; (script:subroutine <name> ([arguments*]) <code>)+;; these three allow to define variables, constants and subs++;; (script:op <name>)+;; define an operator++;; (match:canonical <pattern> <replacement>)+;; equivalent expression used when pattern matching++;; (math:simplify <pattern> <replacement>)++;; (ui:input-alias <string> <op>)+;; (ui:input-alias <string> (<op> [arguments*]))+;; input alias++;; (script:use [none | [<module> | (<module> <names>)]* ])+;; modules to include+;; default use is (script ui math view expression equations)+;; priority is left to right++;; (script:define <name> [<property> | (property [arguments*])])*+;; shorthand for defining multiple properties++;;;; Properties++;; (ui:view <op> <view>)+;; the view of an instance, an object or a type, +;; eg. (view math:add view:binop)++;; (view:operator <operator> ) -- string - the character for unop or binop+++;; (ui:handler (<event> [arguments*]) <code>)+;; trigger code when event happens+;; arguments are deep pattern matching++;; (ui:priority <op> <int>)+;; 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
+ data/rules.cui view
@@ -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 (* # $)))