cga/Gtk.hs

253 lines
7.9 KiB
Haskell
Raw Normal View History

{-# OPTIONS_HADDOCK ignore-exports #-}
2014-10-06 20:51:54 +00:00
module Gtk (makeGUI) where
2014-10-01 18:26:57 +00:00
import Control.Monad.IO.Class
2014-10-07 17:18:16 +00:00
import Class.Defaults
2014-10-01 18:26:57 +00:00
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 System.Directory
2014-10-05 18:08:58 +00:00
import Text.Read
2014-10-07 17:12:07 +00:00
import OS.FileExt
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
cB :: ComboBox
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
gladeFile = "gtk2.glade"
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-05 17:32:36 +00:00
return $ MkMyGUI win' dB' sB' qB' fB' da' hs' xl' xu' yl' yu' aD' cB'
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) $ onClickedDrawButton mygui
_ <- onClicked (sB mygui) $ onClickedSaveButton mygui
_ <- onClicked (qB mygui) mainQuit
_ <- onResponse (aD mygui) (\x -> case x of
ResponseCancel -> widgetHideAll (aD mygui)
_ -> return ())
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-01 18:26:57 +00:00
[Control] <- eventModifier
"q" <- eventKeyName
2014-10-05 01:12:58 +00:00
liftIO mainQuit
2014-10-05 17:32:36 +00:00
_ <- win mygui `on` keyPressEvent $ tryEvent $ do
2014-10-01 18:26:57 +00:00
[Control] <- eventModifier
"s" <- eventKeyName
2014-10-05 17:32:36 +00:00
liftIO $ onClickedSaveButton mygui
_ <- win mygui `on` keyPressEvent $ tryEvent $ do
2014-10-01 18:26:57 +00:00
[Control] <- eventModifier
"d" <- eventKeyName
2014-10-05 17:32:36 +00:00
liftIO $ onClickedDrawButton mygui
2014-10-05 18:54:42 +00:00
_ <- win mygui `on` keyPressEvent $ tryEvent $ do
[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
-- |Callback when the "Draw" Button is clicked.
2014-10-05 17:32:36 +00:00
onClickedDrawButton :: MyGUI
2014-10-01 18:26:57 +00:00
-> IO ()
2014-10-05 17:32:36 +00:00
onClickedDrawButton mygui = do
let fcb = fB mygui
2014-10-01 18:26:57 +00:00
filename <- fileChooserGetFilename fcb
case filename of
Just x -> do
2014-10-05 18:08:58 +00:00
cId <- onExpose (da mygui) (\_ -> drawDiag' x mygui >>=
(\_ -> return True))
_ <- on fcb fileActivated (signalDisconnect cId)
2014-10-05 17:32:36 +00:00
ret <- drawDiag' x mygui
2014-10-05 18:08:58 +00:00
case ret of
1 -> showErrorDialog "No valid x/y dimensions!"
2 -> showErrorDialog "No valid Mesh file!"
_ -> return ()
2014-10-05 01:12:58 +00:00
Nothing -> showErrorDialog "No valid Mesh file!"
2014-10-01 18:26:57 +00:00
2014-10-01 21:02:43 +00:00
-- |Callback when the "Save" Button is clicked.
2014-10-05 17:32:36 +00:00
onClickedSaveButton :: MyGUI
2014-10-01 18:26:57 +00:00
-> IO ()
2014-10-05 17:32:36 +00:00
onClickedSaveButton mygui = do
filename <- fileChooserGetFilename (fB mygui)
2014-10-01 18:26:57 +00:00
case filename of
Just x -> do
2014-10-05 17:32:36 +00:00
ret <- saveDiag' x mygui
2014-10-05 18:08:58 +00:00
case ret of
1 -> showErrorDialog "No valid x/y dimensions!"
2 -> showErrorDialog "No valid Mesh file!"
_ -> return ()
2014-10-05 01:12:58 +00:00
Nothing -> showErrorDialog "No valid Mesh file!"
2014-10-01 18:26:57 +00:00
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.
2014-10-05 17:32:36 +00:00
drawDiag' :: FilePath
-> MyGUI
2014-10-05 18:08:58 +00:00
-> IO Int
2014-10-05 17:32:36 +00:00
drawDiag' fp 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-06 19:12:18 +00:00
let xD = (,) <$> readMaybe xlD' <*> readMaybe xuD' :: Maybe (Double,
2014-10-05 18:08:58 +00:00
Double)
2014-10-06 19:12:18 +00:00
yD = (,) <$> readMaybe ylD' <*> readMaybe yuD' :: Maybe (Double,
2014-10-05 18:08:58 +00:00
Double)
case (xD, yD) of
(Just xD', Just yD') -> do
let (_, r) = renderDia Cairo
(CairoOptions ""
(Dims (fromIntegral daW) (fromIntegral daH))
SVG False)
2014-10-06 19:12:18 +00:00
(diagS (def{t = scaleVal,
dX = xD',
dY = yD',
alg = alg'})
mesh)
2014-10-05 18:08:58 +00:00
renderWithDrawable dw r
return 0
_ -> return 1
else return 2
2014-10-01 21:02:43 +00:00
-- |Saves a Diagram which is built from a given file as an SVG.
2014-10-05 17:32:36 +00:00
saveDiag' :: FilePath
-> MyGUI
2014-10-05 18:08:58 +00:00
-> IO Int
2014-10-05 17:32:36 +00:00
saveDiag' fp 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
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-06 19:12:18 +00:00
let xD = (,) <$> readMaybe xlD' <*> readMaybe xuD' :: Maybe (Double,
2014-10-05 18:08:58 +00:00
Double)
2014-10-06 19:12:18 +00:00
yD = (,) <$> readMaybe ylD' <*> readMaybe yuD' :: Maybe (Double,
2014-10-05 18:08:58 +00:00
Double)
case (xD, yD) of
(Just xD', Just yD') -> do
renderCairo "out.svg"
(Dims (fromIntegral daW) (fromIntegral daH))
2014-10-06 19:12:18 +00:00
(diagS (def{t = scaleVal,
dX = xD',
dY = yD',
alg = alg'})
mesh)
2014-10-05 18:08:58 +00:00
return 0
_ -> return 1
else return 2