-- 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