cga/GUI/Gtk.hs

325 lines
11 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
2014-10-17 12:04:37 +00:00
import Control.Applicative
import Control.Monad(unless)
2014-10-01 18:26:57 +00:00
import Control.Monad.IO.Class
import qualified Data.ByteString.Char8 as B
import Data.Maybe
2014-10-01 18:26:57 +00:00
import Diagrams.Prelude
import Diagrams.Backend.Cairo
import Diagrams.Backend.Cairo.Internal
import Graphics.Diagram.Core (DiagProp(..))
2014-10-10 15:40:08 +00:00
import Graphics.Diagram.Gtk
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
import System.FilePath.Posix
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
rootWin :: Window,
-- |Tree Window
treeWin :: Window,
2014-10-05 19:47:00 +00:00
-- |delete Button
2014-11-16 15:45:51 +00:00
delButton :: Button,
2014-10-05 19:47:00 +00:00
-- |save Button
2014-11-16 15:45:51 +00:00
saveButton :: Button,
2014-10-05 19:47:00 +00:00
-- |quit Button
2014-11-16 15:45:51 +00:00
quitButton :: Button,
2014-10-05 19:47:00 +00:00
-- |file chooser button
2014-11-16 15:45:51 +00:00
fileButton :: FileChooserButton,
2014-10-05 19:47:00 +00:00
-- |drawing area
2014-11-16 15:45:51 +00:00
mainDraw :: DrawingArea,
-- |drawing area for the tree
treeDraw :: DrawingArea,
2014-10-05 19:47:00 +00:00
-- |scaler for point thickness
2014-11-16 15:45:51 +00:00
ptScale :: HScale,
2014-10-05 19:47:00 +00:00
-- |entry widget for lower x bound
2014-11-16 15:45:51 +00:00
xminEntry :: Entry,
2014-10-05 19:47:00 +00:00
-- |entry widget for upper x bound
2014-11-16 15:45:51 +00:00
xmaxEntry :: Entry,
2014-10-05 19:47:00 +00:00
-- |entry widget for lower y bound
2014-11-16 15:45:51 +00:00
yminEntry :: Entry,
2014-10-05 19:47:00 +00:00
-- |entry widget for upper y bound
2014-11-16 15:45:51 +00:00
ymaxEntry :: Entry,
2014-10-05 19:47:00 +00:00
-- |about dialog
2014-11-16 15:45:51 +00:00
aboutDialog :: AboutDialog,
2014-10-05 19:47:00 +00:00
-- |combo box for choosing the algorithm
2014-11-16 15:45:51 +00:00
algoBox :: ComboBox,
2014-10-09 16:45:37 +00:00
-- |grid check button
2014-11-16 15:45:51 +00:00
gridCheckBox :: CheckButton,
-- |coord check button
2014-11-16 15:45:51 +00:00
coordCheckBox :: CheckButton,
-- |Path entry widget for the quad tree.
2014-11-16 15:45:51 +00:00
quadPathEntry :: Entry,
-- |Horizontal box containing the path entry widget.
vbox7 :: Box,
-- |Horizontal box containing the Rang search entry widgets.
vbox10 :: Box,
-- |Range entry widget for lower x bound
rangeXminEntry :: Entry,
-- |Range entry widget for upper x bound
rangeXmaxEntry :: Entry,
-- |Range entry widget for lower y bound
rangeYminEntry :: Entry,
-- |Range entry widget for upper y bound
rangeYmaxEntry :: Entry
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
2014-10-17 12:04:37 +00:00
MkMyGUI
<$> xmlGetWidget xml castToWindow "window1"
<*> xmlGetWidget xml castToWindow "window2"
2014-10-17 12:04:37 +00:00
<*> xmlGetWidget xml castToButton "drawButton"
<*> xmlGetWidget xml castToButton "saveButton"
<*> xmlGetWidget xml castToButton "quitButton"
2014-11-16 15:45:51 +00:00
<*> xmlGetWidget xml castToFileChooserButton "filechooserButton"
2014-10-17 12:04:37 +00:00
<*> xmlGetWidget xml castToDrawingArea "drawingarea"
<*> xmlGetWidget xml castToDrawingArea "treedrawingarea"
2014-10-17 12:04:37 +00:00
<*> xmlGetWidget xml castToHScale "hscale"
<*> xmlGetWidget xml castToEntry "xlD"
<*> xmlGetWidget xml castToEntry "xuD"
<*> xmlGetWidget xml castToEntry "ylD"
<*> xmlGetWidget xml castToEntry "yuD"
<*> xmlGetWidget xml castToAboutDialog "aboutdialog"
<*> xmlGetWidget xml castToComboBox "comboalgo"
<*> xmlGetWidget xml castToCheckButton "gridcheckbutton"
<*> xmlGetWidget xml castToCheckButton "coordcheckbutton"
<*> xmlGetWidget xml castToEntry "path"
<*> xmlGetWidget xml castToBox "vbox7"
<*> xmlGetWidget xml castToBox "vbox10"
<*> xmlGetWidget xml castToEntry "rxMin"
<*> xmlGetWidget xml castToEntry "rxMax"
<*> xmlGetWidget xml castToEntry "ryMin"
<*> xmlGetWidget xml castToEntry "ryMax"
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
_ <- fileChooserSetCurrentFolder (fileButton mygui) homedir
2014-10-05 01:12:58 +00:00
return ()
else do
_ <- fileChooserSetFilename (fileButton mygui) startFile
2014-10-05 01:12:58 +00:00
return ()
comboBoxSetActive (algoBox mygui) 0
2014-10-01 18:26:57 +00:00
-- callbacks
2014-11-16 15:45:51 +00:00
_ <- onDestroy (rootWin mygui) mainQuit
_ <- onClicked (delButton mygui) $ drawDiag mygui
_ <- onClicked (saveButton mygui) $ saveDiag mygui
_ <- onClicked (quitButton mygui) mainQuit
_ <- onResponse (aboutDialog mygui)
(\x -> case x of
ResponseCancel -> widgetHideAll (aboutDialog mygui)
_ -> return ())
-- have to redraw for window overlapping and resizing on expose
_ <- onExpose (mainDraw mygui) (\_ -> drawDiag mygui >>=
2014-11-16 15:45:51 +00:00
(\_ -> return True))
_ <- onExpose (treeDraw mygui) (\_ -> drawDiag mygui >>=
2014-11-16 15:45:51 +00:00
(\_ -> return True))
_ <- on (algoBox mygui) changed (drawDiag mygui)
_ <- on (algoBox mygui) changed (onAlgoBoxChange mygui)
_ <- on (gridCheckBox mygui) toggled (drawDiag mygui)
_ <- on (coordCheckBox mygui) toggled (drawDiag mygui)
2014-10-01 18:26:57 +00:00
-- hotkeys
_ <- rootWin mygui `on` keyPressEvent $ tryEvent $ do
2014-10-09 22:19:05 +00:00
[Control] <- eventModifier
"q" <- eventKeyName
liftIO mainQuit
_ <- treeWin mygui `on` keyPressEvent $ tryEvent $ do
[Control] <- eventModifier
"q" <- eventKeyName
liftIO (widgetHide $ treeWin mygui)
_ <- rootWin mygui `on` keyPressEvent $ tryEvent $ do
2014-10-09 22:19:05 +00:00
[Control] <- eventModifier
"s" <- eventKeyName
liftIO $ saveDiag mygui
_ <- rootWin mygui `on` keyPressEvent $ tryEvent $ do
2014-10-09 22:19:05 +00:00
[Control] <- eventModifier
"d" <- eventKeyName
liftIO $ drawDiag mygui
_ <- rootWin mygui `on` keyPressEvent $ tryEvent $ do
2014-10-09 22:19:05 +00:00
[Control] <- eventModifier
"a" <- eventKeyName
liftIO $ widgetShowAll (aboutDialog mygui)
2014-10-01 18:26:57 +00:00
-- draw widgets and start main loop
widgetShowAll (rootWin mygui)
widgetShowAll (treeWin mygui)
widgetHide (vbox7 mygui)
widgetHide (vbox10 mygui)
widgetHide (treeWin 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
-- |May hide or show the widget that holds the quad tree path entry,
-- depending on the context and may also pop up the tree window.
onAlgoBoxChange :: MyGUI
-> IO ()
onAlgoBoxChange mygui = do
item <- comboBoxGetActive (algoBox mygui)
if item == 4
then do
2014-11-29 23:19:57 +00:00
widgetHide (vbox10 mygui)
widgetShow (vbox7 mygui)
widgetShow (treeWin mygui)
else
if item == 5
then do
2014-11-29 23:19:57 +00:00
widgetHide (vbox7 mygui)
widgetShow (vbox10 mygui)
widgetShow (treeWin mygui)
else do
2014-11-29 23:19:57 +00:00
widgetHide (vbox10 mygui)
widgetHide (vbox7 mygui)
widgetHide (treeWin mygui)
return ()
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 (fileButton 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 -> return ()
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 (fileButton 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 -> return ()
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 =
if (==) ".obj" . takeExtension $ fp
2014-10-05 01:12:58 +00:00
then do
mesh <- B.readFile fp
mainDrawWindow <- widgetGetDrawWindow (mainDraw mygui)
treeDrawWindow <- widgetGetDrawWindow (treeDraw mygui)
adjustment <- rangeGetAdjustment (ptScale mygui)
scaleVal <- adjustmentGetValue adjustment
xminEntryText <- entryGetText (xminEntry mygui)
xmaxEntryText <- entryGetText (xmaxEntry mygui)
yminEntryText <- entryGetText (yminEntry mygui)
ymaxEntryText <- entryGetText (ymaxEntry mygui)
algoActive <- comboBoxGetActive (algoBox mygui)
(daW, daH) <- widgetGetSize (mainDraw mygui)
(daTW, daTH) <- widgetGetSize (treeDraw mygui)
gridActive <- toggleButtonGetActive (gridCheckBox mygui)
coordTextActive <- toggleButtonGetActive (coordCheckBox mygui)
quadPathEntry' <- entryGetText (quadPathEntry mygui)
rxminEntryText <- entryGetText (rangeXminEntry mygui)
rxmaxEntryText <- entryGetText (rangeXmaxEntry mygui)
ryminEntryText <- entryGetText (rangeYminEntry mygui)
rymaxEntryText <- entryGetText (rangeYmaxEntry mygui)
2014-10-09 22:19:05 +00:00
let
xDim = (,) <$>
readMaybe xminEntryText <*>
readMaybe xmaxEntryText :: Maybe (Double, Double)
yDim = (,) <$>
readMaybe yminEntryText <*>
readMaybe ymaxEntryText :: Maybe (Double, Double)
rxDim = (,) <$>
readMaybe rxminEntryText <*>
readMaybe rxmaxEntryText :: Maybe (Double, Double)
ryDim = (,) <$>
readMaybe ryminEntryText <*>
readMaybe rymaxEntryText :: Maybe (Double, Double)
renderDiag winWidth winHeight buildDiag =
renderDia Cairo
(CairoOptions fps
(Dims (fromIntegral winWidth) (fromIntegral winHeight))
SVG False)
(buildDiag (def{
dotSize = scaleVal,
xDimension = fromMaybe (0, 500) xDim,
yDimension = fromMaybe (0, 500) yDim,
algo = algoActive,
haveGrid = gridActive,
showCoordText = coordTextActive,
quadPath = quadPathEntry',
rangeSquare = (fromMaybe (0, 500) rxDim,
fromMaybe (0, 500) ryDim)
})
mesh)
(s, r) = renderDiag daW daH diagS
(_, r') = renderDiag daTW daTH diagTreeS
2014-10-09 22:19:05 +00:00
renderWithDrawable mainDrawWindow r
renderWithDrawable treeDrawWindow r'
unless (null fps) s
return 0
2014-10-05 18:08:58 +00:00
else return 2