Polish the gui

More buttons and a file chooser.
This commit is contained in:
hasufell 2014-10-01 02:55:32 +02:00
parent a676cbdbab
commit b9aee774da
No known key found for this signature in database
GPG Key ID: 220CD1C5BDEED020

104
Main.hs
View File

@ -1,30 +1,106 @@
import Control.Monad (void)
import Control.Monad.IO.Class (liftIO)
import Diagram
import Diagrams.Prelude
import Diagrams.Backend.Cairo
import Diagrams.Backend.Cairo.Internal
import Graphics.UI.Gtk
import Graphics.UI.Gtk.Windows.MessageDialog
import System.Directory
main :: IO ()
main = do
homedir <- getHomeDirectory
-- init gui
_ <- initGUI
mesh <- readFile "test.obj"
-- create window and widgets
window <- windowNew
da <- drawingAreaNew
fileButton <- fileChooserButtonNew "Select mesh"
FileChooserActionOpen
drawButton <- buttonNew
saveButton <- buttonNew
quitButton <- buttonNew
box1 <- vBoxNew False 0
box2 <- hButtonBoxNew
box3 <- hButtonBoxNew
drawButtonLabel <- labelNew $ Just "Draw"
saveButtonLabel <- labelNew $ Just "Save"
quitButtonLabel <- labelNew $ Just "Quit"
-- containers and boxing
containerAdd drawButton drawButtonLabel
containerAdd saveButton saveButtonLabel
containerAdd quitButton quitButtonLabel
containerAdd window box1
boxPackStart box1 da PackGrow 0
boxPackStart box1 box2 PackNatural 0
boxPackStart box1 box3 PackNatural 0
boxPackStart box2 drawButton PackNatural 0
boxPackStart box2 saveButton PackNatural 0
boxPackStart box2 quitButton PackNatural 0
boxPackStart box3 fileButton PackNatural 0
-- adjust properties
set window [windowDefaultWidth := 700, windowDefaultHeight := 700,
windowTitle := "Computergrafik", containerBorderWidth := 10,
containerChild := da]
_ <- onDestroy window mainQuit
void $ da `on` exposeEvent $ liftIO $ do
dw <- widgetGetDrawWindow da
let (png, r) = renderDia Cairo
(CairoOptions "jo.svg" (Width 600) SVG False)
(diagFromString mesh)
png
renderWithDrawable dw r
return True
windowTitle := "Computergrafik"]
set box2 [buttonBoxLayoutStyle := ButtonboxCenter]
set box3 [buttonBoxLayoutStyle := ButtonboxCenter]
_ <- windowSetTypeHint window WindowTypeHintDialog
containerSetBorderWidth box2 10
_ <- fileChooserSetCurrentFolder fileButton homedir
-- callbacks
_ <- onDestroy window mainQuit
_ <- onClicked drawButton $ onClickedDrawButton fileButton
da
_ <- onClicked saveButton $ onClickedSaveButton fileButton
_ <- onClicked quitButton mainQuit
-- draw widgets and start main loop
widgetShowAll window
mainGUI
onClickedDrawButton :: WidgetClass widget
=> FileChooserButton
-> widget
-> IO ()
onClickedDrawButton fcb da = do
filename <- fileChooserGetFilename fcb
case filename of
Just x -> do
mesh <- readFile x
dw <- widgetGetDrawWindow da
let (_, r) = renderDia Cairo
(CairoOptions "" (Width 600) SVG False)
(diagFromString mesh)
renderWithDrawable dw r
Nothing -> do
showErrorDialog "No valid Mesh file!"
onClickedSaveButton :: FileChooserButton
-> IO ()
onClickedSaveButton fcb = do
filename <- fileChooserGetFilename fcb
case filename of
Just x -> do
mesh <- readFile x
let (png, _) = renderDia Cairo
(CairoOptions "out.svg" (Width 600) SVG False)
(diagFromString mesh)
png
Nothing -> do
showErrorDialog "No valid Mesh file!"
showErrorDialog :: String -> IO ()
showErrorDialog str = do
errorDialog <- messageDialogNew Nothing [DialogDestroyWithParent]
MessageError
ButtonsClose
str
_ <- dialogRun errorDialog
widgetDestroy errorDialog