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 :: FilePath -> IO () startGUI startFile = 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 _ <- fileChooserSetFilename fileButton startFile -- 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 drawDiag' x da Nothing -> do showErrorDialog "No valid Mesh file!" onClickedSaveButton :: FileChooserButton -> IO () onClickedSaveButton fcb = do filename <- fileChooserGetFilename fcb case filename of Just x -> do saveDiag' x Nothing -> do showErrorDialog "No valid Mesh file!" showErrorDialog :: String -> IO () showErrorDialog str = do errorDialog <- messageDialogNew Nothing [DialogDestroyWithParent] MessageError ButtonsClose str _ <- dialogRun errorDialog widgetDestroy errorDialog drawDiag' :: WidgetClass widget => FilePath -> widget -> IO () drawDiag' fp da = do mesh <- readFile fp dw <- widgetGetDrawWindow da let (_, r) = renderDia Cairo (CairoOptions "" (Width 600) SVG False) (diagFromString mesh) renderWithDrawable dw r saveDiag' :: FilePath -> IO () saveDiag' fp = do mesh <- readFile fp renderCairo "out.svg" (Width 600) (diagFromString mesh)