module Graphics.Craftwerk.UI.Gtk (
Option(..)
, RenderContext(..)
, renderFigure
, displayRender
, displayMultiple
, renderWindow
, 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
}
data Option = NumberOption Double
| RangeOption Double Double Double Double
| BoolOption Bool
| 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
data RenderContext =
RenderContext { cairo :: Map.Map String Option -> Double -> Double -> IO (Cairo.Render())
, tikz :: Map.Map String Option -> IO String}
renderFigure :: Double
-> Double
-> (Map.Map String Option -> IO Figure)
-> 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)
displayRender :: [(String, Option)] -> RenderContext -> IO ()
displayRender opt r = do
initGUI
window <- renderWindow opt [("Render",r)]
widgetShowAll window
onDestroy window mainQuit
mainGUI
displayMultiple :: [(String, Option)] -> [(String, RenderContext)] -> IO ()
displayMultiple opt rcs = do
initGUI
window <- renderWindow opt rcs
widgetShowAll window
onDestroy window mainQuit
mainGUI
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
stateRef <- newIORef State { zoomFactor = 1.0
, currentContext = firstContext
, curOptions = Map.fromList opt }
box <- vBoxNew False 0
containerAdd window box
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
canvas <- drawingAreaNew
hpane <- hPanedNew
boxPackStart box hpane PackGrow 0
sidebox <- vBoxNew False 0
containerAdd hpane sidebox
opt <- optionToUI canvas opt stateRef
label <- labelNew (Just firstContext)
boxPackStart sidebox label PackNatural 10
boxPackStart sidebox opt PackGrow 10
scrwin <- scrolledWindowNew Nothing Nothing
scrolledWindowSetPolicy scrwin PolicyAutomatic PolicyAutomatic
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
widgetShowAll window
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)
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 (idx1) < 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 = []
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>"