cga/GUI/Gtk.hs

243 lines
7.2 KiB
Haskell
Raw Normal View History

{-# OPTIONS_HADDOCK ignore-exports #-}
2014-10-10 15:40:08 +00:00
module GUI.Gtk (makeGUI) where
2014-10-01 18:26:57 +00:00
import Control.Monad.IO.Class
import Diagrams.Prelude
import Diagrams.Backend.Cairo
import Diagrams.Backend.Cairo.Internal
2014-10-10 15:40:08 +00:00
import Graphics.Diagram.Gtk
import Graphics.Diagram.Types
2014-10-01 18:26:57 +00:00
import Graphics.UI.Gtk
2014-10-02 12:29:56 +00:00
import Graphics.UI.Gtk.Glade
2014-10-10 15:40:08 +00:00
import MyPrelude
2014-10-01 18:26:57 +00:00
import System.Directory
2014-10-10 15:40:08 +00:00
import System.FileSystem.FileExt
2014-10-05 18:08:58 +00:00
import Text.Read
2014-10-01 18:26:57 +00:00
2014-10-05 19:47:00 +00:00
-- |Monolithic object passed to various GUI functions in order
-- to keep the API stable and not alter the parameters too much.
-- This only holds GUI widgets that are needed to be read during
-- runtime.
2014-10-05 17:32:36 +00:00
data MyGUI = MkMyGUI {
2014-10-05 19:47:00 +00:00
-- |main Window
2014-10-05 17:32:36 +00:00
win :: Window,
2014-10-05 19:47:00 +00:00
-- |delete Button
2014-10-05 17:32:36 +00:00
dB :: Button,
2014-10-05 19:47:00 +00:00
-- |save Button
2014-10-05 17:32:36 +00:00
sB :: Button,
2014-10-05 19:47:00 +00:00
-- |quit Button
2014-10-05 17:32:36 +00:00
qB :: Button,
2014-10-05 19:47:00 +00:00
-- |file chooser button
2014-10-05 17:32:36 +00:00
fB :: FileChooserButton,
2014-10-05 19:47:00 +00:00
-- |drawing area
2014-10-05 17:32:36 +00:00
da :: DrawingArea,
2014-10-05 19:47:00 +00:00
-- |scaler for point thickness
2014-10-05 17:32:36 +00:00
hs :: HScale,
2014-10-05 19:47:00 +00:00
-- |entry widget for lower x bound
2014-10-05 17:32:36 +00:00
xl :: Entry,
2014-10-05 19:47:00 +00:00
-- |entry widget for upper x bound
2014-10-05 17:32:36 +00:00
xu :: Entry,
2014-10-05 19:47:00 +00:00
-- |entry widget for lower y bound
2014-10-05 17:32:36 +00:00
yl :: Entry,
2014-10-05 19:47:00 +00:00
-- |entry widget for upper y bound
2014-10-05 18:54:42 +00:00
yu :: Entry,
2014-10-05 19:47:00 +00:00
-- |about dialog
aD :: AboutDialog,
2014-10-05 19:47:00 +00:00
-- |combo box for choosing the algorithm
2014-10-09 16:45:37 +00:00
cB :: ComboBox,
-- |grid check button
gC :: CheckButton,
-- |coord check button
cC :: CheckButton
2014-10-05 17:32:36 +00:00
}
2014-10-05 19:47:00 +00:00
-- |The glade file to load the UI from.
2014-10-02 12:29:56 +00:00
gladeFile :: FilePath
2014-10-10 15:40:08 +00:00
gladeFile = "GUI/gtk2.glade"
2014-10-02 12:29:56 +00:00
2014-10-05 17:32:36 +00:00
-- |Loads the glade file and creates the MyGUI object.
makeMyGladeGUI :: IO MyGUI
makeMyGladeGUI = do
-- load glade file
Just xml <- xmlNew gladeFile
win' <- xmlGetWidget xml castToWindow "window1"
dB' <- xmlGetWidget xml castToButton "drawButton"
sB' <- xmlGetWidget xml castToButton "saveButton"
qB' <- xmlGetWidget xml castToButton "quitButton"
fB' <- xmlGetWidget xml castToFileChooserButton
"filechooserButton"
da' <- xmlGetWidget xml castToDrawingArea "drawingarea"
hs' <- xmlGetWidget xml castToHScale "hscale"
xl' <- xmlGetWidget xml castToEntry "xlD"
xu' <- xmlGetWidget xml castToEntry "xuD"
yl' <- xmlGetWidget xml castToEntry "ylD"
yu' <- xmlGetWidget xml castToEntry "yuD"
2014-10-05 18:54:42 +00:00
aD' <- xmlGetWidget xml castToAboutDialog "aboutdialog"
cB' <- xmlGetWidget xml castToComboBox "comboalgo"
2014-10-09 16:45:37 +00:00
gC' <- xmlGetWidget xml castToCheckButton "gridcheckbutton"
cC' <- xmlGetWidget xml castToCheckButton "coordcheckbutton"
2014-10-05 17:32:36 +00:00
2014-10-09 22:19:05 +00:00
return $ MkMyGUI win' dB' sB' qB' fB' da' hs'
xl' xu' yl' yu' aD' cB' gC' cC'
2014-10-05 17:32:36 +00:00
2014-10-05 19:47:00 +00:00
-- |Main entry point for the GTK GUI routines.
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-05 17:32:36 +00:00
-- get GUI object
mygui <- makeMyGladeGUI
2014-10-01 18:26:57 +00:00
-- adjust properties
2014-10-05 01:12:58 +00:00
if startFile == ""
then do
2014-10-05 17:32:36 +00:00
_ <- fileChooserSetCurrentFolder (fB mygui) homedir
2014-10-05 01:12:58 +00:00
return ()
else do
2014-10-05 17:32:36 +00:00
_ <- fileChooserSetFilename (fB mygui) startFile
2014-10-05 01:12:58 +00:00
return ()
comboBoxSetActive (cB mygui) 0
2014-10-01 18:26:57 +00:00
-- callbacks
2014-10-05 18:54:42 +00:00
_ <- onDestroy (win mygui) mainQuit
_ <- onClicked (dB mygui) $ drawDiag mygui
_ <- onClicked (sB mygui) $ saveDiag mygui
2014-10-05 18:54:42 +00:00
_ <- onClicked (qB mygui) mainQuit
_ <- onResponse (aD mygui) (\x -> case x of
ResponseCancel -> widgetHideAll (aD mygui)
_ -> return ())
-- have to redraw for window overlapping and resizing on expose
_ <- onExpose (da mygui) (\_ -> drawDiag mygui >>=
(\_ -> return True))
_ <- on (cB mygui) changed (drawDiag mygui)
_ <- on (gC mygui) toggled (drawDiag mygui)
_ <- on (cC mygui) toggled (drawDiag mygui)
_ <- on (hs mygui) valueChanged (drawDiag mygui)
2014-10-01 18:26:57 +00:00
-- hotkeys
2014-10-05 17:32:36 +00:00
_ <- win mygui `on` keyPressEvent $ tryEvent $ do
2014-10-09 22:19:05 +00:00
[Control] <- eventModifier
"q" <- eventKeyName
liftIO mainQuit
2014-10-05 17:32:36 +00:00
_ <- win mygui `on` keyPressEvent $ tryEvent $ do
2014-10-09 22:19:05 +00:00
[Control] <- eventModifier
"s" <- eventKeyName
liftIO $ saveDiag mygui
2014-10-05 17:32:36 +00:00
_ <- win mygui `on` keyPressEvent $ tryEvent $ do
2014-10-09 22:19:05 +00:00
[Control] <- eventModifier
"d" <- eventKeyName
liftIO $ drawDiag mygui
2014-10-05 18:54:42 +00:00
_ <- win mygui `on` keyPressEvent $ tryEvent $ do
2014-10-09 22:19:05 +00:00
[Control] <- eventModifier
"a" <- eventKeyName
liftIO $ widgetShowAll (aD mygui)
2014-10-01 18:26:57 +00:00
-- draw widgets and start main loop
2014-10-05 17:32:36 +00:00
widgetShowAll (win mygui)
2014-10-01 18:26:57 +00:00
mainGUI
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.
drawDiag :: MyGUI
-> IO ()
drawDiag mygui = do
fp <- fileChooserGetFilename (fB mygui)
case fp of
Just x -> do
ret <- saveAndDrawDiag x "" mygui
case ret of
1 -> showErrorDialog "No valid x/y dimensions!"
2 -> showErrorDialog "No valid Mesh file!"
_ -> return ()
Nothing -> showErrorDialog "No valid Mesh file!"
2014-10-10 22:16:18 +00:00
-- |Saves a Diagram which is built from a given file as an SVG.
saveDiag :: MyGUI
-> IO ()
saveDiag mygui = do
fp <- fileChooserGetFilename (fB mygui)
case fp of
Just x -> do
ret <- saveAndDrawDiag x "out.svg" mygui
case ret of
1 -> showErrorDialog "No valid x/y dimensions!"
2 -> showErrorDialog "No valid Mesh file!"
_ -> return ()
Nothing -> showErrorDialog "No valid Mesh file!"
2014-10-10 22:16:18 +00:00
-- |Draws and saves a Diagram which is built from a given file.
-- If the file to save is left empty, then nothing is saved.
saveAndDrawDiag :: FilePath -- ^ obj file to parse
-> FilePath -- ^ if/where to save the result
-> MyGUI
-> IO Int
saveAndDrawDiag fp fps mygui =
2014-10-05 01:12:58 +00:00
if cmpExt "obj" fp
then do
mesh <- readFile fp
2014-10-05 17:32:36 +00:00
dw <- widgetGetDrawWindow (da mygui)
adjustment <- rangeGetAdjustment (hs mygui)
scaleVal <- adjustmentGetValue adjustment
xlD' <- entryGetText (xl mygui)
xuD' <- entryGetText (xu mygui)
ylD' <- entryGetText (yl mygui)
yuD' <- entryGetText (yu mygui)
alg' <- comboBoxGetActive (cB mygui)
(daW, daH) <- widgetGetSize (da mygui)
2014-10-09 16:45:37 +00:00
gd' <- toggleButtonGetActive (gC mygui)
ct' <- toggleButtonGetActive (cC mygui)
2014-10-09 22:19:05 +00:00
let
xD = (,) <$>
readMaybe xlD' <*>
readMaybe xuD' :: Maybe (Double, Double)
yD = (,) <$>
readMaybe ylD' <*>
readMaybe yuD' :: Maybe (Double, Double)
2014-10-05 18:08:58 +00:00
case (xD, yD) of
(Just xD', Just yD') -> do
2014-10-10 22:16:18 +00:00
let (s, r) = renderDia Cairo
(CairoOptions fps
2014-10-09 22:19:05 +00:00
(Dims (fromIntegral daW) (fromIntegral daH))
SVG False)
(diagS (def{
t = scaleVal,
dX = xD',
dY = yD',
alg = alg',
gd = gd',
ct = ct'})
2014-10-09 22:19:05 +00:00
mesh)
2014-10-05 18:08:58 +00:00
renderWithDrawable dw r
2014-10-10 22:16:18 +00:00
if null fps
then return ()
else s
2014-10-05 18:08:58 +00:00
return 0
_ -> return 1
else return 2