craftwerk-gtk (empty) → 0.1
raw patch · 6 files changed
+623/−0 lines, 6 filesdep +basedep +cairodep +containerssetup-changed
Dependencies added: base, cairo, containers, craftwerk, craftwerk-cairo, craftwerk-gtk, gtk, mtl
Files
- LICENSE +19/−0
- Setup.hs +2/−0
- craftwerk-gtk.cabal +63/−0
- examples/Example1.hs +38/−0
- src/Graphics/Craftwerk/UI.hs +14/−0
- src/Graphics/Craftwerk/UI/Gtk.hs +487/−0
+ LICENSE view
@@ -0,0 +1,19 @@+Copyright (c) 2011 Malte Harder++Permission is hereby granted, free of charge, to any person obtaining a copy+of this software and associated documentation files (the "Software"), to deal+in the Software without restriction, including without limitation the rights+to use, copy, modify, merge, publish, distribute, sublicense, and/or sell+copies of the Software, and to permit persons to whom the Software is+furnished to do so, subject to the following conditions:++The above copyright notice and this permission notice shall be included in+all copies or substantial portions of the Software.++THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR+IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,+FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE+AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER+LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,+OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN+THE SOFTWARE.
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ craftwerk-gtk.cabal view
@@ -0,0 +1,63 @@+Name: craftwerk-gtk+Version: 0.1+License: MIT+License-file: LICENSE+Author: Malte Harder <malte.harder@gmail.com>+Maintainer: Malte Harder <malte.harder@gmail.com>+Category: Graphics+Homepage: http://mahrz.github.com/craftwerk.html+Synopsis: Gtk UI for Craftwerk.+Description: Gtk UI functions for Craftwerk, a high-level and easy to use graphics library+ with integrated TikZ output.+ .+ Craftwerk is a high-level 2D vector graphics library for output of+ TikZ pictures that can be typeset using (pdf)LaTeX. The TikZ library+ and documentation can be found at: <http://sourceforge.net/projects/pgf>.+ .+ Craftwerk tries to encapsulate the graphics backend such that figures+ can also be rendered with a Cairo backend and quickly displayed in a+ Gtk window. The aim is to support TikZ and Cairo seamlessly as+ possible, meaning that graphics produced with either backend should+ look as similar as possible. Other backends are easily written and the+ aim is to provide generic fallback functions for features that are not+ natively supported by some backend.++Stability: unstable+Build-Type: Simple+Cabal-Version: >=1.8++Extra-Source-Files: LICENSE,+ examples/Example1.hs++Flag examples+ Description: Build the examples+ Default: False++Library+ Hs-Source-Dirs: src+ Build-Depends: base >= 3 && < 5,+ cairo >= 0.11.1 && < 0.13,+ gtk >= 0.11.1 && < 0.13,+ containers >= 0.3 && < 0.5,+ craftwerk-cairo >= 0.1 && < 0.2,+ craftwerk >= 0.1 && < 0.2,+ mtl+ Exposed-Modules: Graphics.Craftwerk.UI,+ Graphics.Craftwerk.UI.Gtk++Executable example1+ Hs-Source-Dirs: examples+ if flag(examples)+ Build-Depends: base >= 3 && < 5,+ craftwerk,+ craftwerk-cairo,+ craftwerk-gtk,+ containers+ Main-Is: Example1.hs+ if !flag(examples)+ Buildable: False++source-repository head+ type: git+ location: git://github.com/mahrz/Craftwerk.git+
+ examples/Example1.hs view
@@ -0,0 +1,38 @@+module Main where++import Graphics.Craftwerk.Core+import Graphics.Craftwerk.UI+import Graphics.Craftwerk.Core.Driver.Cairo++import qualified Data.Map as Map++main = do displayMultiple ([ ("Iteration",+ RangeOption 1 6 1 1)+ , ("Color", ChoiceOption ["red"+ ,"green"+ ,"blue"] 0)])+ $+ [ ("Iterator", renderFigure 1 1+ (\opt -> return $+ style newStyle { closePath = yes+ , fillColor =+ Just $ [red,green,blue] !!+ choice (opt Map.! "Color")+ , stroke = no+ , fill = yes} $+ iterations+ (round $ value (opt Map.! "Iteration"))+ (line [(0,0),(0,1),(1,0)])+ ))]++iterations :: Int -> Figure -> Figure+iterations 0 f = f+iterations i f =+ let nf = iterations (i-1) f+ in scale (0.5,0.5) $ composition+ [+ translate (0,1) $ nf+ , translate (0,0) $ nf+ , translate (1,0) $ nf+ ]+
+ src/Graphics/Craftwerk/UI.hs view
@@ -0,0 +1,14 @@+-- |+-- Module : Graphics.Craftwerk.Core.Style+-- Copyright : (c) Malte Harder 2011+-- License : MIT+-- Maintainer : Malte Harder <malte.harder@gmail.com>+--++module Graphics.Craftwerk.UI+ (+ module Graphics.Craftwerk.UI.Gtk+ ) where++import Graphics.Craftwerk.UI.Gtk+
+ src/Graphics/Craftwerk/UI/Gtk.hs view
@@ -0,0 +1,487 @@+-- |+-- 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>"+