Refactor GUI API
This commit is contained in:
parent
1fb87d8e1e
commit
d33683cb82
165
Gtk.hs
165
Gtk.hs
@ -13,9 +13,46 @@ import System.Directory
|
||||
import Util
|
||||
|
||||
|
||||
data MyGUI = MkMyGUI {
|
||||
win :: Window,
|
||||
dB :: Button,
|
||||
sB :: Button,
|
||||
qB :: Button,
|
||||
fB :: FileChooserButton,
|
||||
da :: DrawingArea,
|
||||
hs :: HScale,
|
||||
xl :: Entry,
|
||||
xu :: Entry,
|
||||
yl :: Entry,
|
||||
yu :: Entry
|
||||
}
|
||||
|
||||
|
||||
gladeFile :: FilePath
|
||||
gladeFile = "gtk2.glade"
|
||||
|
||||
|
||||
-- |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"
|
||||
|
||||
return $ MkMyGUI win' dB' sB' qB' fB' da' hs' xl' xu' yl' yu'
|
||||
|
||||
|
||||
-- |Handle the whole GTK gui.
|
||||
makeGUI :: FilePath -> IO ()
|
||||
makeGUI startFile = do
|
||||
@ -24,90 +61,66 @@ makeGUI startFile = do
|
||||
-- init gui
|
||||
_ <- initGUI
|
||||
|
||||
-- load glade file
|
||||
Just xml <- xmlNew gladeFile
|
||||
window <- xmlGetWidget xml castToWindow "window1"
|
||||
drawButton <- xmlGetWidget xml castToButton "drawButton"
|
||||
saveButton <- xmlGetWidget xml castToButton "saveButton"
|
||||
quitButton <- xmlGetWidget xml castToButton "quitButton"
|
||||
fileButton <- xmlGetWidget xml castToFileChooserButton
|
||||
"filechooserButton"
|
||||
da <- xmlGetWidget xml castToDrawingArea "drawingarea"
|
||||
hscale <- xmlGetWidget xml castToHScale "hscale"
|
||||
xlDE <- xmlGetWidget xml castToEntry "xlD"
|
||||
xlUE <- xmlGetWidget xml castToEntry "xlU"
|
||||
ylDE <- xmlGetWidget xml castToEntry "ylD"
|
||||
ylUE <- xmlGetWidget xml castToEntry "ylU"
|
||||
-- get GUI object
|
||||
mygui <- makeMyGladeGUI
|
||||
|
||||
-- adjust properties
|
||||
if startFile == ""
|
||||
then do
|
||||
_ <- fileChooserSetCurrentFolder fileButton homedir
|
||||
_ <- fileChooserSetCurrentFolder (fB mygui) homedir
|
||||
return ()
|
||||
else do
|
||||
_ <- fileChooserSetFilename fileButton startFile
|
||||
_ <- fileChooserSetFilename (fB mygui) startFile
|
||||
return ()
|
||||
|
||||
-- callbacks
|
||||
_ <- onDestroy window mainQuit
|
||||
_ <- onClicked drawButton $ onClickedDrawButton fileButton
|
||||
da hscale (xlDE, xlUE) (ylDE, ylUE)
|
||||
_ <- onClicked saveButton $ onClickedSaveButton fileButton
|
||||
hscale (xlDE, xlUE) (ylDE, ylUE)
|
||||
_ <- onClicked quitButton mainQuit
|
||||
_ <- onDestroy (win mygui) mainQuit
|
||||
_ <- onClicked (dB mygui) $ onClickedDrawButton mygui
|
||||
_ <- onClicked (sB mygui) $ onClickedSaveButton mygui
|
||||
_ <- onClicked (qB mygui) mainQuit
|
||||
|
||||
-- hotkeys
|
||||
_ <- window `on` keyPressEvent $ tryEvent $ do
|
||||
_ <- win mygui `on` keyPressEvent $ tryEvent $ do
|
||||
[Control] <- eventModifier
|
||||
"q" <- eventKeyName
|
||||
liftIO mainQuit
|
||||
_ <- window `on` keyPressEvent $ tryEvent $ do
|
||||
_ <- win mygui `on` keyPressEvent $ tryEvent $ do
|
||||
[Control] <- eventModifier
|
||||
"s" <- eventKeyName
|
||||
liftIO $ onClickedSaveButton fileButton
|
||||
hscale (xlDE, xlUE) (ylDE, ylUE)
|
||||
_ <- window `on` keyPressEvent $ tryEvent $ do
|
||||
liftIO $ onClickedSaveButton mygui
|
||||
_ <- win mygui `on` keyPressEvent $ tryEvent $ do
|
||||
[Control] <- eventModifier
|
||||
"d" <- eventKeyName
|
||||
liftIO $ onClickedDrawButton fileButton da hscale
|
||||
(xlDE, xlUE) (ylDE, ylUE)
|
||||
liftIO $ onClickedDrawButton mygui
|
||||
|
||||
-- draw widgets and start main loop
|
||||
widgetShowAll window
|
||||
widgetShowAll (win mygui)
|
||||
mainGUI
|
||||
|
||||
|
||||
-- |Callback when the "Draw" Button is clicked.
|
||||
onClickedDrawButton :: (WidgetClass widget, RangeClass scale)
|
||||
=> FileChooserButton
|
||||
-> widget
|
||||
-> scale
|
||||
-> (Entry, Entry)
|
||||
-> (Entry, Entry)
|
||||
onClickedDrawButton :: MyGUI
|
||||
-> IO ()
|
||||
onClickedDrawButton fcb da scale' dXE dYE = do
|
||||
onClickedDrawButton mygui = do
|
||||
let fcb = fB mygui
|
||||
filename <- fileChooserGetFilename fcb
|
||||
case filename of
|
||||
Just x -> do
|
||||
cId <- onExpose da (\_ -> drawDiag' x da scale' dXE dYE)
|
||||
cId <- onExpose (da mygui) (\_ -> drawDiag' x mygui)
|
||||
_ <- on fcb fileActivated (signalDisconnect cId)
|
||||
ret <- drawDiag' x da scale' dXE dYE
|
||||
ret <- drawDiag' x mygui
|
||||
unless ret $ showErrorDialog "No valid Mesh file!"
|
||||
Nothing -> showErrorDialog "No valid Mesh file!"
|
||||
|
||||
|
||||
-- |Callback when the "Save" Button is clicked.
|
||||
onClickedSaveButton :: RangeClass scale
|
||||
=> FileChooserButton
|
||||
-> scale
|
||||
-> (Entry, Entry)
|
||||
-> (Entry, Entry)
|
||||
onClickedSaveButton :: MyGUI
|
||||
-> IO ()
|
||||
onClickedSaveButton fcb scale' dXE dYE = do
|
||||
filename <- fileChooserGetFilename fcb
|
||||
onClickedSaveButton mygui = do
|
||||
filename <- fileChooserGetFilename (fB mygui)
|
||||
case filename of
|
||||
Just x -> do
|
||||
ret <- saveDiag' x scale' dXE dYE
|
||||
ret <- saveDiag' x mygui
|
||||
unless ret $ showErrorDialog "No valid Mesh file!"
|
||||
Nothing -> showErrorDialog "No valid Mesh file!"
|
||||
|
||||
@ -126,30 +139,26 @@ showErrorDialog str = do
|
||||
|
||||
-- |Draws a Diagram which is built from a given file to
|
||||
-- the gtk DrawingArea.
|
||||
drawDiag' :: (WidgetClass widget, RangeClass scale)
|
||||
=> FilePath
|
||||
-> widget
|
||||
-> scale
|
||||
-> (Entry, Entry)
|
||||
-> (Entry, Entry)
|
||||
drawDiag' :: FilePath
|
||||
-> MyGUI
|
||||
-> IO Bool
|
||||
drawDiag' fp da scale' dXE dYE =
|
||||
drawDiag' fp mygui =
|
||||
if cmpExt "obj" fp
|
||||
then do
|
||||
mesh <- readFile fp
|
||||
dw <- widgetGetDrawWindow da
|
||||
adjustment <- rangeGetAdjustment scale'
|
||||
dw <- widgetGetDrawWindow (da mygui)
|
||||
adjustment <- rangeGetAdjustment (hs mygui)
|
||||
scaleVal <- adjustmentGetValue adjustment
|
||||
xlD <- entryGetText $ fst dXE
|
||||
xlU <- entryGetText $ snd dXE
|
||||
ylD <- entryGetText $ fst dYE
|
||||
ylU <- entryGetText $ snd dYE
|
||||
xlD <- entryGetText (xl mygui)
|
||||
xuD <- entryGetText (xu mygui)
|
||||
ylD <- entryGetText (yl mygui)
|
||||
yuD <- entryGetText (yu mygui)
|
||||
|
||||
-- clear drawing area
|
||||
clearDiag da
|
||||
clearDiag mygui
|
||||
|
||||
let xD = (read xlD, read xlU) :: (Double, Double)
|
||||
yD = (read ylD, read ylU) :: (Double, Double)
|
||||
let xD = (read xlD, read xuD) :: (Double, Double)
|
||||
yD = (read ylD, read yuD) :: (Double, Double)
|
||||
(_, r) = renderDia Cairo
|
||||
(CairoOptions "" (Width 600) SVG False)
|
||||
(diagFromString (def{t = scaleVal,
|
||||
@ -162,25 +171,22 @@ drawDiag' fp da scale' dXE dYE =
|
||||
|
||||
|
||||
-- |Saves a Diagram which is built from a given file as an SVG.
|
||||
saveDiag' :: RangeClass scale
|
||||
=> FilePath
|
||||
-> scale
|
||||
-> (Entry, Entry)
|
||||
-> (Entry, Entry)
|
||||
saveDiag' :: FilePath
|
||||
-> MyGUI
|
||||
-> IO Bool
|
||||
saveDiag' fp scale' dXE dYE =
|
||||
saveDiag' fp mygui =
|
||||
if cmpExt "obj" fp
|
||||
then do
|
||||
mesh <- readFile fp
|
||||
adjustment <- rangeGetAdjustment scale'
|
||||
adjustment <- rangeGetAdjustment (hs mygui)
|
||||
scaleVal <- adjustmentGetValue adjustment
|
||||
xlD <- entryGetText $ fst dXE
|
||||
xlU <- entryGetText $ snd dXE
|
||||
ylD <- entryGetText $ fst dYE
|
||||
ylU <- entryGetText $ snd dYE
|
||||
xlD <- entryGetText (xl mygui)
|
||||
xuD <- entryGetText (xu mygui)
|
||||
ylD <- entryGetText (yl mygui)
|
||||
yuD <- entryGetText (yu mygui)
|
||||
|
||||
let xD = (read xlD, read xlU) :: (Double, Double)
|
||||
yD = (read ylD, read ylU) :: (Double, Double)
|
||||
let xD = (read xlD, read xuD) :: (Double, Double)
|
||||
yD = (read ylD, read yuD) :: (Double, Double)
|
||||
renderCairo "out.svg" (Width 600)
|
||||
(diagFromString (def{t = scaleVal,
|
||||
dX = xD,
|
||||
@ -191,11 +197,10 @@ saveDiag' fp scale' dXE dYE =
|
||||
|
||||
|
||||
-- |Clears the drawing area by painting a white rectangle.
|
||||
clearDiag :: WidgetClass widget
|
||||
=> widget
|
||||
clearDiag :: MyGUI
|
||||
-> IO ()
|
||||
clearDiag da = do
|
||||
dw <- widgetGetDrawWindow da
|
||||
clearDiag mygui = do
|
||||
dw <- widgetGetDrawWindow (da mygui)
|
||||
|
||||
let (_, r) = renderDia Cairo
|
||||
(CairoOptions "" (Width 600) SVG False)
|
||||
|
||||
@ -153,7 +153,7 @@
|
||||
</packing>
|
||||
</child>
|
||||
<child>
|
||||
<widget class="GtkEntry" id="xlU">
|
||||
<widget class="GtkEntry" id="xuD">
|
||||
<property name="width_request">5</property>
|
||||
<property name="visible">True</property>
|
||||
<property name="can_focus">True</property>
|
||||
@ -248,7 +248,7 @@
|
||||
</packing>
|
||||
</child>
|
||||
<child>
|
||||
<widget class="GtkEntry" id="ylU">
|
||||
<widget class="GtkEntry" id="yuD">
|
||||
<property name="width_request">5</property>
|
||||
<property name="visible">True</property>
|
||||
<property name="can_focus">True</property>
|
||||
|
||||
Loading…
Reference in New Issue
Block a user