diff --git a/Gtk.hs b/Gtk.hs new file mode 100644 index 0000000..90d57b0 --- /dev/null +++ b/Gtk.hs @@ -0,0 +1,125 @@ +module Gtk where + +import Control.Monad.IO.Class +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 + + +startGUI :: IO () +startGUI = do + homedir <- getHomeDirectory + + -- init gui + _ <- initGUI + + -- 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 := 600, windowDefaultHeight := 700, + 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 + + -- hotkeys + _ <- window `on` keyPressEvent $ tryEvent $ do + [Control] <- eventModifier + "q" <- eventKeyName + liftIO $ mainQuit + _ <- window `on` keyPressEvent $ tryEvent $ do + [Control] <- eventModifier + "s" <- eventKeyName + liftIO $ onClickedSaveButton fileButton + _ <- window `on` keyPressEvent $ tryEvent $ do + [Control] <- eventModifier + "d" <- eventKeyName + liftIO $ onClickedDrawButton fileButton da + + -- 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 + diff --git a/Main.hs b/Main.hs index 0284a13..afbd2aa 100644 --- a/Main.hs +++ b/Main.hs @@ -1,122 +1,4 @@ -import Control.Monad.IO.Class -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 - +import Gtk main :: IO () -main = do - homedir <- getHomeDirectory - - -- init gui - _ <- initGUI - - -- 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 := 600, windowDefaultHeight := 700, - 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 - - -- hotkeys - _ <- window `on` keyPressEvent $ tryEvent $ do - [Control] <- eventModifier - "q" <- eventKeyName - liftIO $ mainQuit - _ <- window `on` keyPressEvent $ tryEvent $ do - [Control] <- eventModifier - "s" <- eventKeyName - liftIO $ onClickedSaveButton fileButton - _ <- window `on` keyPressEvent $ tryEvent $ do - [Control] <- eventModifier - "d" <- eventKeyName - liftIO $ onClickedDrawButton fileButton da - - -- 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 +main = startGUI