diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -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. diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/craftwerk-gtk.cabal b/craftwerk-gtk.cabal new file mode 100644 --- /dev/null +++ b/craftwerk-gtk.cabal @@ -0,0 +1,63 @@ +Name: craftwerk-gtk +Version: 0.1 +License: MIT +License-file: LICENSE +Author: Malte Harder +Maintainer: Malte Harder +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: . + . + 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 + diff --git a/examples/Example1.hs b/examples/Example1.hs new file mode 100644 --- /dev/null +++ b/examples/Example1.hs @@ -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 + ] + diff --git a/src/Graphics/Craftwerk/UI.hs b/src/Graphics/Craftwerk/UI.hs new file mode 100644 --- /dev/null +++ b/src/Graphics/Craftwerk/UI.hs @@ -0,0 +1,14 @@ +-- | +-- Module : Graphics.Craftwerk.Core.Style +-- Copyright : (c) Malte Harder 2011 +-- License : MIT +-- Maintainer : Malte Harder +-- + +module Graphics.Craftwerk.UI + ( + module Graphics.Craftwerk.UI.Gtk + ) where + +import Graphics.Craftwerk.UI.Gtk + diff --git a/src/Graphics/Craftwerk/UI/Gtk.hs b/src/Graphics/Craftwerk/UI/Gtk.hs new file mode 100644 --- /dev/null +++ b/src/Graphics/Craftwerk/UI/Gtk.hs @@ -0,0 +1,487 @@ +-- | +-- 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 = "\ +\ \ +\ \ +\ \ +\ \ +\ \ +\ \ +\ \ +\ \ +\ \ +\ \ +\ \ +\ \ +\ \ +\ \ +\ \ +\ \ +\ \ +\ \ +\ \ +\ \ +\ \ +\ \ +\ \ +\ \ +\ " +