craftwerk-gtk-0.1: src/Graphics/Craftwerk/UI/Gtk.hs
-- |
-- Module : Graphics.Craftwerk.UI.Gtk
-- Copyright : (c) Malte Harder 2011
-- License : MIT
-- Maintainer : Malte Harder <malte.harder@gmail.com>
--
-- 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 "<Control>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 = "<ui>\
\ <menubar>\
\ <menu action=\"FMA\">\
\ <menuitem action=\"EXPP\" />\
\ <menuitem action=\"EXPT\" />\
\ <separator />\
\ <menuitem action=\"EXIA\" />\
\ </menu>\
\ <menu action=\"HMA\">\
\ <menuitem action=\"HLPA\" />\
\ </menu>\
\ </menubar>\
\ <toolbar>\
\ <toolitem action=\"ZOOI\" />\
\ <toolitem action=\"ZOOO\" />\
\ <toolitem action=\"ZOOF\" />\
\ <separator />\
\ <toolitem action=\"PREV\" />\
\ <toolitem action=\"NEXT\" />\
\ <separator />\
\ <toolitem action=\"EXPP\" />\
\ <toolitem action=\"EXPT\" />\
\ <separator />\
\ <toolitem action=\"HLPA\" />\
\ </toolbar>\
\ </ui>"