289 lines
9.2 KiB
Haskell
289 lines
9.2 KiB
Haskell
{-# OPTIONS_HADDOCK ignore-exports #-}
|
|
|
|
module GUI.Gtk (makeGUI) where
|
|
|
|
import Control.Applicative
|
|
import Control.Monad(unless)
|
|
import Control.Monad.IO.Class
|
|
import Diagrams.Prelude
|
|
import Diagrams.Backend.Cairo
|
|
import Diagrams.Backend.Cairo.Internal
|
|
import Graphics.Diagram.Gtk
|
|
import Graphics.Diagram.Types
|
|
import Graphics.UI.Gtk
|
|
import Graphics.UI.Gtk.Glade
|
|
import MyPrelude
|
|
import System.Directory
|
|
import System.FilePath.Posix
|
|
import Text.Read
|
|
|
|
|
|
-- |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.
|
|
data MyGUI = MkMyGUI {
|
|
-- |main Window
|
|
rootWin :: Window,
|
|
-- |Tree Window
|
|
treeWin :: Window,
|
|
-- |delete Button
|
|
delButton :: Button,
|
|
-- |save Button
|
|
saveButton :: Button,
|
|
-- |quit Button
|
|
quitButton :: Button,
|
|
-- |file chooser button
|
|
fileButton :: FileChooserButton,
|
|
-- |drawing area
|
|
mainDraw :: DrawingArea,
|
|
-- |drawing area for the tree
|
|
treeDraw :: DrawingArea,
|
|
-- |scaler for point thickness
|
|
ptScale :: HScale,
|
|
-- |entry widget for lower x bound
|
|
xminEntry :: Entry,
|
|
-- |entry widget for upper x bound
|
|
xmaxEntry :: Entry,
|
|
-- |entry widget for lower y bound
|
|
yminEntry :: Entry,
|
|
-- |entry widget for upper y bound
|
|
ymaxEntry :: Entry,
|
|
-- |about dialog
|
|
aboutDialog :: AboutDialog,
|
|
-- |combo box for choosing the algorithm
|
|
algoBox :: ComboBox,
|
|
-- |grid check button
|
|
gridCheckBox :: CheckButton,
|
|
-- |coord check button
|
|
coordCheckBox :: CheckButton,
|
|
-- |Path entry widget for the quad tree.
|
|
quadPathEntry :: Entry,
|
|
-- |Horizontal box containing the path entry widget.
|
|
vbox7 :: Box
|
|
}
|
|
|
|
|
|
-- |The glade file to load the UI from.
|
|
gladeFile :: FilePath
|
|
gladeFile = "GUI/gtk2.glade"
|
|
|
|
|
|
-- |Loads the glade file and creates the MyGUI object.
|
|
makeMyGladeGUI :: IO MyGUI
|
|
makeMyGladeGUI = do
|
|
-- load glade file
|
|
Just xml <- xmlNew gladeFile
|
|
|
|
MkMyGUI
|
|
<$> xmlGetWidget xml castToWindow "window1"
|
|
<*> xmlGetWidget xml castToWindow "window2"
|
|
<*> xmlGetWidget xml castToButton "drawButton"
|
|
<*> xmlGetWidget xml castToButton "saveButton"
|
|
<*> xmlGetWidget xml castToButton "quitButton"
|
|
<*> xmlGetWidget xml castToFileChooserButton
|
|
"filechooserButton"
|
|
<*> xmlGetWidget xml castToDrawingArea "drawingarea"
|
|
<*> xmlGetWidget xml castToDrawingArea "treedrawingarea"
|
|
<*> 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"
|
|
|
|
|
|
-- |Main entry point for the GTK GUI routines.
|
|
makeGUI :: FilePath -> IO ()
|
|
makeGUI startFile = do
|
|
homedir <- getHomeDirectory
|
|
|
|
-- init gui
|
|
_ <- initGUI
|
|
|
|
-- get GUI object
|
|
mygui <- makeMyGladeGUI
|
|
|
|
-- adjust properties
|
|
if startFile == ""
|
|
then do
|
|
_ <- fileChooserSetCurrentFolder (fileButton mygui) homedir
|
|
return ()
|
|
else do
|
|
_ <- fileChooserSetFilename (fileButton mygui) startFile
|
|
return ()
|
|
comboBoxSetActive (algoBox mygui) 0
|
|
|
|
-- callbacks
|
|
_ <- 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 >>=
|
|
(\_ -> return True))
|
|
_ <- onExpose (treeDraw mygui) (\_ -> drawDiag mygui >>=
|
|
(\_ -> 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)
|
|
|
|
-- hotkeys
|
|
_ <- rootWin mygui `on` keyPressEvent $ tryEvent $ do
|
|
[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
|
|
[Control] <- eventModifier
|
|
"s" <- eventKeyName
|
|
liftIO $ saveDiag mygui
|
|
_ <- rootWin mygui `on` keyPressEvent $ tryEvent $ do
|
|
[Control] <- eventModifier
|
|
"d" <- eventKeyName
|
|
liftIO $ drawDiag mygui
|
|
_ <- rootWin mygui `on` keyPressEvent $ tryEvent $ do
|
|
[Control] <- eventModifier
|
|
"a" <- eventKeyName
|
|
liftIO $ widgetShowAll (aboutDialog mygui)
|
|
|
|
-- draw widgets and start main loop
|
|
widgetShowAll (rootWin mygui)
|
|
widgetShowAll (treeWin mygui)
|
|
widgetHide (vbox7 mygui)
|
|
widgetHide (treeWin mygui)
|
|
mainGUI
|
|
|
|
|
|
-- |Pops up an error Dialog with the given String.
|
|
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
|
|
widgetShow (vbox7 mygui)
|
|
widgetShow (treeWin mygui)
|
|
else do
|
|
widgetHide (vbox7 mygui)
|
|
widgetHide (treeWin mygui)
|
|
return ()
|
|
|
|
|
|
-- |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 ()
|
|
|
|
|
|
-- |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 ()
|
|
|
|
|
|
-- |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
|
|
then do
|
|
mesh <- 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)
|
|
|
|
let
|
|
xDim = (,) <$>
|
|
readMaybe xminEntryText <*>
|
|
readMaybe xmaxEntryText :: Maybe (Double, Double)
|
|
yDim = (,) <$>
|
|
readMaybe yminEntryText <*>
|
|
readMaybe ymaxEntryText :: Maybe (Double, Double)
|
|
renderDiag winWidth winHeight buildDiag xDim' yDim' =
|
|
renderDia Cairo
|
|
(CairoOptions fps
|
|
(Dims (fromIntegral winWidth) (fromIntegral winHeight))
|
|
SVG False)
|
|
(buildDiag (def{
|
|
dotSize = scaleVal,
|
|
xDimension = xDim',
|
|
yDimension = yDim',
|
|
algo = algoActive,
|
|
haveGrid = gridActive,
|
|
showCoordText = coordTextActive,
|
|
quadPath = quadPathEntry'})
|
|
mesh)
|
|
|
|
case (xDim, yDim) of
|
|
(Just xDim', Just yDim') -> do
|
|
let (s, r) = renderDiag daW daH diagS xDim' yDim'
|
|
let (_, r') = renderDiag daTW daTH diagTreeS xDim' yDim'
|
|
|
|
renderWithDrawable mainDrawWindow r
|
|
renderWithDrawable treeDrawWindow r'
|
|
|
|
unless (null fps) s
|
|
return 0
|
|
_ -> return 1
|
|
|
|
else return 2
|