-- | -- Module : Graphics.Craftwerk.UI.Gtk -- Copyright : (c) Malte Harder 2011 -- License : MIT -- Maintainer : Malte Harder -- -- The UI functions of Craftwerk allow quick display of figures. They also -- support the creation of a simple user interface to control parameters of -- the figures that are displayed. module Graphics.Craftwerk.UI.Gtk ( -- * Data types Option(..) , RenderContext(..) -- * Display figures , renderFigure , displayRender , displayMultiple , renderWindow -- * Option values , value , choice , choices , isSet ) where import Graphics.UI.Gtk import qualified Graphics.Rendering.Cairo as Cairo import Graphics.Craftwerk.Core.Driver.Cairo import Graphics.Craftwerk.Core.Driver.Tikz import Graphics.Craftwerk.Core.Figure import Data.IORef import qualified Data.Map as Map import Data.List import Control.Monad import Control.Monad.Trans import Text.Printf data State = State { zoomFactor :: Double , currentContext :: String , curOptions :: Map.Map String Option } -- | Describing options for a user interface. data Option = NumberOption Double -- | A range: min, max, step and initial value. | RangeOption Double Double Double Double | BoolOption Bool -- | An option of choices with a default selection. | ChoiceOption [String] Int value (NumberOption v) = v value (RangeOption _ _ _ v) = v value _ = 0.0 choice (ChoiceOption _ i) = i choice _ = 0 choices (ChoiceOption s _) = s choices _ = [] isSet (BoolOption b) = b isSet _ = False -- | Combined cairo and tikz rendering functions depending on the options. data RenderContext = RenderContext { cairo :: Map.Map String Option -> Double -> Double -> IO (Cairo.Render()) , tikz :: Map.Map String Option -> IO String} -- | Renders an 'IO Figure' into a render context with the given dimensions. renderFigure :: Double -- ^ Width of the coordinate system of the GTK widget -> Double -- ^ Height of the coordinate system of the GTK widget -> (Map.Map String Option -> IO Figure) -- ^ The render function -> RenderContext renderFigure w h f = RenderContext r (liftM figureToTikzPicture . f) where r op wx hx = liftM (s wx hx) (f op) s wx hx = figureToRenderContext . scale (wx/w, -hx/h) . translate (0,-h) -- | Display a render context in a Gtk window, starts the Gtk main loop. -- The first argument contains a list of named options whose UI values -- are passed to the render context. displayRender :: [(String, Option)] -> RenderContext -> IO () displayRender opt r = do initGUI window <- renderWindow opt [("Render",r)] widgetShowAll window onDestroy window mainQuit mainGUI -- | Display multiple render contexts in a Gtk window, starts the Gtk main loop. -- The first argument contains a list of named options whose UI values -- are passed to the render context. displayMultiple :: [(String, Option)] -> [(String, RenderContext)] -> IO () displayMultiple opt rcs = do initGUI window <- renderWindow opt rcs widgetShowAll window onDestroy window mainQuit mainGUI -- | Same as 'displayMultiple' except that the Gtk main loop is not started or -- initialized. The window is not visible upon return. renderWindow :: [(String, Option)] -> [(String, RenderContext)] -> IO Window renderWindow opt ctxs = do let rcs = Map.fromList ctxs window <- windowNew set window [windowTitle := "Render View", windowDefaultWidth := 420, windowDefaultHeight := 450] let firstContext = fst $ head ctxs -- Initialize the state stateRef <- newIORef State { zoomFactor = 1.0 , currentContext = firstContext , curOptions = Map.fromList opt } -- The box layout box <- vBoxNew False 0 containerAdd window box -- Init menubar and toolbar fma <- actionNew "FMA" "File" Nothing Nothing hma <- actionNew "HMA" "Help" Nothing Nothing expp <- actionNew "EXPP" "Export as PDF..." (Just "Export as PDF") (Just stockConvert) expt <- actionNew "EXPT" "Export as TikZ..." (Just "Export as TikZ") (Just stockDnd) exia <- actionNew "EXIA" "Close" (Just "Close") (Just stockQuit) zooi <- actionNew "ZOOI" "Zoom in" (Just "Zoom in") (Just stockZoomIn) zooo <- actionNew "ZOOO" "Zoom out" (Just "Zoom out") (Just stockZoomOut) zoof <- actionNew "ZOOF" "Zoom to fit" (Just "Zoom to fit") (Just stockZoomFit) next <- actionNew "NEXT" "Next" (Just "Next") (Just stockMediaNext) prev <- actionNew "PREV" "Previous" (Just "Previous") (Just stockMediaPrevious) hlpa <- actionNew "HLPA" "Help" (Just "Help") (Just stockHelp) agr <- actionGroupNew "AGR" np <- actionGroupNew "NP" mapM_ (actionGroupAddAction agr) [fma, hma] mapM_ (\ act -> actionGroupAddActionWithAccel agr act Nothing) [expp,expt,zooi,zooo,zoof,hlpa] actionGroupAddActionWithAccel agr exia (Just "e") actionGroupAddActionWithAccel np next Nothing actionGroupAddActionWithAccel np prev Nothing when (length ctxs <= 1) (actionGroupSetSensitive np False) ui <- uiManagerNew uiManagerAddUiFromString ui uiStd uiManagerInsertActionGroup ui agr 0 uiManagerInsertActionGroup ui np 0 maybeMenubar <- uiManagerGetWidget ui "/ui/menubar" let menubar = case maybeMenubar of (Just x) -> x Nothing -> error "Cannot get menubar from string." boxPackStart box menubar PackNatural 0 maybeToolbar <- uiManagerGetWidget ui "/ui/toolbar" let toolbar = case maybeToolbar of (Just x) -> x Nothing -> error "Cannot get toolbar from string." boxPackStart box toolbar PackNatural 0 -- Create the drawing area, options need to update it canvas <- drawingAreaNew -- Create a hbox for options and drawing hpane <- hPanedNew --hbox <- hBoxNew False 0 boxPackStart box hpane PackGrow 0 sidebox <- vBoxNew False 0 --boxPackStart hbox sidebox PackNatural 0 containerAdd hpane sidebox -- Create the label and option widgets opt <- optionToUI canvas opt stateRef label <- labelNew (Just firstContext) boxPackStart sidebox label PackNatural 10 boxPackStart sidebox opt PackGrow 10 -- The display widgets scrwin <- scrolledWindowNew Nothing Nothing scrolledWindowSetPolicy scrwin PolicyAutomatic PolicyAutomatic -- boxPackStart hbox scrwin PackGrow 0 containerAdd hpane scrwin oframe <- aspectFrameNew 0.5 0.5 (Just 1) frameSetShadowType oframe ShadowNone fixed <- fixedNew frame <- aspectFrameNew 0.5 0.5 (Just 1) fixedPut fixed frame (0,0) containerAdd oframe fixed scrolledWindowAddWithViewport scrwin oframe containerAdd frame canvas widgetSetSizeRequest canvas 400 400 -- Show the window widgetShowAll window -- Draw actions onExpose canvas (\x -> do (w,h) <- widgetGetSize canvas drawin <- widgetGetDrawWindow canvas state <- readIORef stateRef let f = cairo (rcs Map.! currentContext state) fig <- f (curOptions state) (fromIntegral w) (fromIntegral h) renderWithDrawable drawin (do Cairo.setSourceRGB 1.0 1.0 1.0 let dw = (fromIntegral w) dh = (fromIntegral h) Cairo.moveTo 0 0 Cairo.lineTo 0 dw Cairo.lineTo dw dh Cairo.lineTo dh 0 Cairo.closePath Cairo.fill fig) return True) -- Menu event actions onActionActivate exia (widgetDestroy window) onActionActivate zooi (do state <- readIORef stateRef let zf = 2 * zoomFactor state writeIORef stateRef (state { zoomFactor = zf}) resizeFrame canvas stateRef) onActionActivate zooo (do state <- readIORef stateRef let zf = 0.5 * zoomFactor state writeIORef stateRef (state { zoomFactor = zf}) resizeFrame canvas stateRef) onActionActivate zoof (do state <- readIORef stateRef let zf = 1 writeIORef stateRef (state { zoomFactor = zf}) resizeFrame canvas stateRef) onActionActivate expp (do fchdal <- fileChooserDialogNew (Just "Export As PDF...") Nothing FileChooserActionSave [("Cancel", ResponseCancel), ("Export", ResponseAccept)] fileChooserSetDoOverwriteConfirmation fchdal True widgetShow fchdal response <- dialogRun fchdal case response of ResponseCancel -> return () ResponseAccept -> do nwf <- fileChooserGetFilename fchdal case nwf of Nothing -> return () Just path -> do state <- readIORef stateRef let f = cairo (rcs Map.! currentContext state) fig <- f (curOptions state) 500 500 (Cairo.withPDFSurface path (realToFrac 500) (realToFrac 500) (`Cairo.renderWith` fig)) ResponseDeleteEvent -> return () widgetDestroy fchdal) onActionActivate expt (do fchdal <- fileChooserDialogNew (Just "Export As TikZ...") Nothing FileChooserActionSave [("Cancel", ResponseCancel), ("Export", ResponseAccept)] fileChooserSetDoOverwriteConfirmation fchdal True widgetShow fchdal response <- dialogRun fchdal case response of ResponseCancel -> return () ResponseAccept -> do nwf <- fileChooserGetFilename fchdal case nwf of Nothing -> return () Just path -> do state <- readIORef stateRef let t = tikz (rcs Map.! currentContext state) fig <- (t (curOptions state)) writeFile path fig ResponseDeleteEvent -> return () widgetDestroy fchdal) onActionActivate next (do state <- readIORef stateRef let cur = currentContext state let maybeidx = findIndex (\(a,b) -> a == cur) ctxs writeIORef stateRef (state { currentContext = case maybeidx of Nothing -> fst $ head ctxs Just idx -> if (idx+1) >= length ctxs then cur else fst $ ctxs !! (idx + 1) }) nstate <- readIORef stateRef labelSetText label (currentContext nstate) widgetQueueDraw canvas) onActionActivate prev (do state <- readIORef stateRef let cur = currentContext state let maybeidx = findIndex (\(a,b) -> a == cur) ctxs writeIORef stateRef (state { currentContext = case maybeidx of Nothing -> fst $ head ctxs Just idx -> if (idx-1) < 0 then cur else fst $ ctxs !! (idx - 1) }) nstate <- readIORef stateRef labelSetText label (currentContext nstate) widgetQueueDraw canvas) return window where resizeFrame canvas stateRef = do state <- readIORef stateRef let zf = (zoomFactor state) widgetSetSizeRequest canvas (ceiling $ 400*zf) (ceiling $ 400*zf) optionToUI :: DrawingArea -> [(String,Option)] -> IORef State -> IO VBox optionToUI canvas opt stateRef = do box <- vBoxNew False 0 sep <- hSeparatorNew boxPackStart box sep PackNatural 8 label1 <- labelNew (Just "Options:") boxPackStart box label1 PackNatural 5 sep2 <- hSeparatorNew boxPackStart box sep2 PackNatural 0 mapM_ (createOption canvas stateRef box) opt return box createOption :: DrawingArea -> IORef State -> VBox -> (String,Option) -> IO () createOption canvas stateRef box (lbl, opt) = do hbox <- hBoxNew False 0 case opt of ChoiceOption _ _ -> boxPackStart box hbox PackGrow 5 _ -> do boxPackStart box hbox PackNatural 5 label <- labelNew (Just lbl) boxPackStart hbox label PackNatural 10 case opt of NumberOption def -> do field <- entryNew entrySetText field $ printf "%f" def boxPackStart hbox field PackGrow 10 onEntryActivate field ( do state <- readIORef stateRef txt <- entryGetText field writeIORef stateRef (state { curOptions = Map.update (const $ Just $ NumberOption (read txt)) lbl (curOptions state) }) widgetQueueDraw canvas return ()) return () RangeOption min max step def -> do adj <- adjustmentNew def min max step (step*10) 0.0 scl <- spinButtonNew adj 0.5 4 boxPackStart hbox scl PackGrow 10 onValueChanged adj ( do state <- readIORef stateRef val <- adjustmentGetValue adj writeIORef stateRef (state { curOptions = Map.update (const $ Just $ NumberOption val) lbl (curOptions state) }) widgetQueueDraw canvas return ()) return () BoolOption def -> do btn <- checkButtonNew toggleButtonSetActive btn def boxPackStart hbox btn PackNatural 10 onToggled btn ( do state <- readIORef stateRef val <- toggleButtonGetActive btn writeIORef stateRef (state { curOptions = Map.update (const $ Just $ BoolOption val) lbl (curOptions state) }) widgetQueueDraw canvas return ()) return () ChoiceOption choices def -> do list <- listStoreNew choices treeview <- treeViewNewWithModel list tvc <- treeViewColumnNew treeViewColumnSetTitle tvc lbl renderer <- cellRendererTextNew cellLayoutPackStart tvc renderer False cellLayoutSetAttributes tvc renderer list (\ind -> [cellText := ind]) treeViewAppendColumn treeview tvc tree <- treeViewGetSelection treeview treeSelectionSetMode tree SelectionSingle treeSelectionSelectPath tree [0] scrwin <- scrolledWindowNew Nothing Nothing scrolledWindowSetPolicy scrwin PolicyNever PolicyAutomatic containerAdd scrwin treeview frame <- frameNew containerAdd frame scrwin boxPackStart hbox frame PackGrow 10 onSelectionChanged tree ( do sel <- treeSelectionGetSelectedRows tree state <- readIORef stateRef let val = head $ head sel let c = [] --choices $ (curOptions state) Map.! lbl writeIORef stateRef (state { curOptions = Map.update (const $ Just $ ChoiceOption c val) lbl (curOptions state) }) widgetQueueDraw canvas return () ) return () sep <- hSeparatorNew boxPackStart box sep PackNatural 0 uiStd = "\ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ "