casui-0.3: Casui/Gui.hs
-- 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