hasufell
f3cabab280
This window creation still sucks a bit, we should realize it without actually showing it.
289 lines
8.6 KiB
Haskell
289 lines
8.6 KiB
Haskell
{-# OPTIONS_HADDOCK ignore-exports #-}
|
|
|
|
module GUI.Gtk (makeGUI) where
|
|
|
|
import Control.Applicative
|
|
import Control.Monad
|
|
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.FileSystem.FileExt
|
|
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
|
|
win :: Window,
|
|
-- |Tree Window
|
|
winT :: Window,
|
|
-- |delete Button
|
|
dB :: Button,
|
|
-- |save Button
|
|
sB :: Button,
|
|
-- |quit Button
|
|
qB :: Button,
|
|
-- |file chooser button
|
|
fB :: FileChooserButton,
|
|
-- |drawing area
|
|
da :: DrawingArea,
|
|
-- |drawing area for the tree
|
|
daT :: DrawingArea,
|
|
-- |scaler for point thickness
|
|
hs :: HScale,
|
|
-- |entry widget for lower x bound
|
|
xl :: Entry,
|
|
-- |entry widget for upper x bound
|
|
xu :: Entry,
|
|
-- |entry widget for lower y bound
|
|
yl :: Entry,
|
|
-- |entry widget for upper y bound
|
|
yu :: Entry,
|
|
-- |about dialog
|
|
aD :: AboutDialog,
|
|
-- |combo box for choosing the algorithm
|
|
cB :: ComboBox,
|
|
-- |grid check button
|
|
gC :: CheckButton,
|
|
-- |coord check button
|
|
cC :: CheckButton,
|
|
-- |Path entry widget for the quad tree.
|
|
pE :: 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 (fB mygui) homedir
|
|
return ()
|
|
else do
|
|
_ <- fileChooserSetFilename (fB mygui) startFile
|
|
return ()
|
|
comboBoxSetActive (cB mygui) 0
|
|
|
|
-- callbacks
|
|
_ <- onDestroy (win mygui) mainQuit
|
|
_ <- onClicked (dB mygui) $ drawDiag mygui
|
|
_ <- onClicked (sB mygui) $ saveDiag mygui
|
|
_ <- 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))
|
|
_ <- onExpose (daT mygui) (\_ -> drawDiag mygui >>=
|
|
(\_ -> return True))
|
|
_ <- on (cB mygui) changed (drawDiag mygui)
|
|
_ <- on (cB mygui) changed (onPathWidgetChange mygui)
|
|
_ <- on (gC mygui) toggled (drawDiag mygui)
|
|
_ <- on (cC mygui) toggled (drawDiag mygui)
|
|
|
|
-- hotkeys
|
|
_ <- win mygui `on` keyPressEvent $ tryEvent $ do
|
|
[Control] <- eventModifier
|
|
"q" <- eventKeyName
|
|
liftIO mainQuit
|
|
_ <- winT mygui `on` keyPressEvent $ tryEvent $ do
|
|
[Control] <- eventModifier
|
|
"q" <- eventKeyName
|
|
liftIO (widgetHide $ winT mygui)
|
|
_ <- win mygui `on` keyPressEvent $ tryEvent $ do
|
|
[Control] <- eventModifier
|
|
"s" <- eventKeyName
|
|
liftIO $ saveDiag mygui
|
|
_ <- win mygui `on` keyPressEvent $ tryEvent $ do
|
|
[Control] <- eventModifier
|
|
"d" <- eventKeyName
|
|
liftIO $ drawDiag mygui
|
|
_ <- win mygui `on` keyPressEvent $ tryEvent $ do
|
|
[Control] <- eventModifier
|
|
"a" <- eventKeyName
|
|
liftIO $ widgetShowAll (aD mygui)
|
|
|
|
-- draw widgets and start main loop
|
|
widgetShowAll (win mygui)
|
|
widgetShowAll (winT mygui)
|
|
widgetHide (vbox7 mygui)
|
|
widgetHide (winT 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.
|
|
onPathWidgetChange :: MyGUI
|
|
-> IO ()
|
|
onPathWidgetChange mygui = do
|
|
item <- comboBoxGetActive (cB mygui)
|
|
if item == 4
|
|
then do
|
|
widgetShow (vbox7 mygui)
|
|
widgetShow (winT mygui)
|
|
else widgetHide (vbox7 mygui)
|
|
return ()
|
|
|
|
|
|
-- |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 -> return ()
|
|
|
|
|
|
-- |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 -> 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 cmpExt "obj" fp
|
|
then do
|
|
mesh <- readFile fp
|
|
dw <- widgetGetDrawWindow (da mygui)
|
|
dwT <- widgetGetDrawWindow (daT 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)
|
|
(daTW, daTH) <- widgetGetSize (daT mygui)
|
|
gd' <- toggleButtonGetActive (gC mygui)
|
|
ct' <- toggleButtonGetActive (cC mygui)
|
|
pE' <- entryGetText (pE mygui)
|
|
|
|
let
|
|
xD = (,) <$>
|
|
readMaybe xlD' <*>
|
|
readMaybe xuD' :: Maybe (Double, Double)
|
|
yD = (,) <$>
|
|
readMaybe ylD' <*>
|
|
readMaybe yuD' :: Maybe (Double, Double)
|
|
renderDiag winWidth winHeight buildDiag xD' yD' =
|
|
renderDia Cairo
|
|
(CairoOptions fps
|
|
(Dims (fromIntegral winWidth) (fromIntegral winHeight))
|
|
SVG False)
|
|
(buildDiag (def{
|
|
t = scaleVal,
|
|
dX = xD',
|
|
dY = yD',
|
|
alg = alg',
|
|
gd = gd',
|
|
ct = ct',
|
|
pQt = pE'})
|
|
mesh)
|
|
|
|
case (xD, yD) of
|
|
(Just xD', Just yD') -> do
|
|
let (s, r) = renderDiag daW daH diagS xD' yD'
|
|
let (_, r') = renderDiag daTW daTH diagTreeS xD' yD'
|
|
|
|
renderWithDrawable dw r
|
|
renderWithDrawable dwT r'
|
|
|
|
if null fps
|
|
then return ()
|
|
else s
|
|
return 0
|
|
_ -> return 1
|
|
|
|
else return 2
|