From b9aee774da921e163b9dfccb0f17444297eb2319 Mon Sep 17 00:00:00 2001
From: hasufell <hasufell@hasufell.de>
Date: Wed, 1 Oct 2014 02:55:32 +0200
Subject: [PATCH] Polish the gui

More buttons and a file chooser.
---
 Main.hs | 108 +++++++++++++++++++++++++++++++++++++++++++++++---------
 1 file changed, 92 insertions(+), 16 deletions(-)

diff --git a/Main.hs b/Main.hs
index 647067d..0018b1a 100644
--- a/Main.hs
+++ b/Main.hs
@@ -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"
-  window <- windowNew
-  da <- drawingAreaNew
+
+  -- 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