cga/Gtk.hs

137 lines
4.1 KiB
Haskell
Raw Normal View History

2014-10-01 18:26:57 +00:00
module Gtk where
import Control.Monad.IO.Class
import Diagram
import Diagrams.Prelude
import Diagrams.Backend.Cairo
import Diagrams.Backend.Cairo.Internal
import Graphics.UI.Gtk
2014-10-02 12:29:56 +00:00
import Graphics.UI.Gtk.Glade
2014-10-01 18:26:57 +00:00
import Graphics.UI.Gtk.Windows.MessageDialog
import System.Directory
import Util
2014-10-01 18:26:57 +00:00
2014-10-02 12:29:56 +00:00
gladeFile :: FilePath
gladeFile = "gtk2.glade"
2014-10-01 21:02:43 +00:00
-- |Handle the whole GTK gui.
2014-10-02 11:14:16 +00:00
makeGUI :: FilePath -> IO ()
makeGUI startFile = do
2014-10-01 18:26:57 +00:00
homedir <- getHomeDirectory
-- init gui
_ <- initGUI
2014-10-02 12:29:56 +00:00
-- load glade file
Just xml <- xmlNew gladeFile
window <- xmlGetWidget xml castToWindow "window1"
drawButton <- xmlGetWidget xml castToButton "drawButton"
saveButton <- xmlGetWidget xml castToButton "saveButton"
quitButton <- xmlGetWidget xml castToButton "quitButton"
fileButton <- xmlGetWidget xml castToFileChooserButton
"filechooserButton"
da <- xmlGetWidget xml castToDrawingArea "drawingarea"
hscale <- xmlGetWidget xml castToHScale "hscale"
2014-10-01 18:26:57 +00:00
-- adjust properties
_ <- fileChooserSetCurrentFolder fileButton homedir
2014-10-01 19:47:54 +00:00
_ <- fileChooserSetFilename fileButton startFile
2014-10-01 18:26:57 +00:00
-- callbacks
_ <- onDestroy window mainQuit
_ <- onClicked drawButton $ onClickedDrawButton fileButton
2014-10-02 12:30:08 +00:00
da hscale
2014-10-01 18:26:57 +00:00
_ <- onClicked saveButton $ onClickedSaveButton fileButton
_ <- onClicked quitButton mainQuit
-- hotkeys
_ <- window `on` keyPressEvent $ tryEvent $ do
[Control] <- eventModifier
"q" <- eventKeyName
liftIO $ mainQuit
_ <- window `on` keyPressEvent $ tryEvent $ do
[Control] <- eventModifier
"s" <- eventKeyName
liftIO $ onClickedSaveButton fileButton
_ <- window `on` keyPressEvent $ tryEvent $ do
[Control] <- eventModifier
"d" <- eventKeyName
liftIO $ onClickedDrawButton fileButton da hscale
2014-10-01 18:26:57 +00:00
-- draw widgets and start main loop
widgetShowAll window
mainGUI
2014-10-01 21:02:43 +00:00
-- |Callback when the "Draw" Button is clicked.
onClickedDrawButton :: (WidgetClass widget, RangeClass scale)
2014-10-01 18:26:57 +00:00
=> FileChooserButton
-> widget
-> scale
2014-10-01 18:26:57 +00:00
-> IO ()
onClickedDrawButton fcb da scale' = do
2014-10-01 18:26:57 +00:00
filename <- fileChooserGetFilename fcb
case filename of
Just x -> do
drawDiag' x da scale'
2014-10-01 18:26:57 +00:00
Nothing -> do
showErrorDialog "No valid Mesh file!"
2014-10-01 21:02:43 +00:00
-- |Callback when the "Save" Button is clicked.
2014-10-01 18:26:57 +00:00
onClickedSaveButton :: FileChooserButton
-> IO ()
onClickedSaveButton fcb = do
filename <- fileChooserGetFilename fcb
case filename of
Just x -> do
saveDiag' x
2014-10-01 18:26:57 +00:00
Nothing -> do
showErrorDialog "No valid Mesh file!"
2014-10-01 21:02:43 +00:00
-- |Pops up an error Dialog with the given String.
2014-10-01 18:26:57 +00:00
showErrorDialog :: String -> IO ()
showErrorDialog str = do
errorDialog <- messageDialogNew Nothing
[DialogDestroyWithParent]
MessageError
ButtonsClose
str
_ <- dialogRun errorDialog
widgetDestroy errorDialog
2014-10-01 21:02:43 +00:00
-- |Draws a Diagram which is built from a given file to
-- the gtk DrawingArea.
-- Prints an error dialog if no valid mesh file is found.
drawDiag' :: (WidgetClass widget, RangeClass scale)
=> FilePath
-> widget
-> scale
-> IO ()
drawDiag' fp da scale' =
case cmpExt "obj" fp of
True -> do
mesh <- readFile fp
dw <- widgetGetDrawWindow da
adjustment <- rangeGetAdjustment scale'
scaleVal <- adjustmentGetValue adjustment
let (_, r) = renderDia Cairo
(CairoOptions "" (Width 600) SVG False)
(diagFromString (MkProp scaleVal) mesh)
renderWithDrawable dw r
False -> showErrorDialog "No valid Mesh file!"
2014-10-01 21:02:43 +00:00
-- |Saves a Diagram which is built from a given file as an SVG.
-- Prints an error dialog if no valid mesh file is found.
saveDiag' :: FilePath -> IO ()
saveDiag' fp =
case cmpExt "obj" fp of
True -> do
mesh <- readFile fp
renderCairo "out.svg" (Width 600) (diagFromString (MkProp 2) mesh)
False -> showErrorDialog "No valid Mesh file!"