This commit is contained in:
hasufell 2014-10-05 03:12:58 +02:00
parent c95e003228
commit c7c0fdd500
No known key found for this signature in database
GPG Key ID: 220CD1C5BDEED020
2 changed files with 24 additions and 29 deletions

41
Gtk.hs
View File

@ -1,6 +1,7 @@
module Gtk where module Gtk where
import Control.Monad.IO.Class import Control.Monad.IO.Class
import Control.Monad
import Diagram import Diagram
import Diagrams.Prelude import Diagrams.Prelude
import Diagrams.Backend.Cairo import Diagrams.Backend.Cairo
@ -35,11 +36,11 @@ makeGUI startFile = do
hscale <- xmlGetWidget xml castToHScale "hscale" hscale <- xmlGetWidget xml castToHScale "hscale"
-- adjust properties -- adjust properties
case startFile == "" of if startFile == ""
True -> do then do
_ <- fileChooserSetCurrentFolder fileButton homedir _ <- fileChooserSetCurrentFolder fileButton homedir
return () return ()
False -> do else do
_ <- fileChooserSetFilename fileButton startFile _ <- fileChooserSetFilename fileButton startFile
return () return ()
@ -54,7 +55,7 @@ makeGUI startFile = do
_ <- window `on` keyPressEvent $ tryEvent $ do _ <- window `on` keyPressEvent $ tryEvent $ do
[Control] <- eventModifier [Control] <- eventModifier
"q" <- eventKeyName "q" <- eventKeyName
liftIO $ mainQuit liftIO mainQuit
_ <- window `on` keyPressEvent $ tryEvent $ do _ <- window `on` keyPressEvent $ tryEvent $ do
[Control] <- eventModifier [Control] <- eventModifier
"s" <- eventKeyName "s" <- eventKeyName
@ -79,14 +80,11 @@ onClickedDrawButton fcb da scale' = do
filename <- fileChooserGetFilename fcb filename <- fileChooserGetFilename fcb
case filename of case filename of
Just x -> do Just x -> do
cId <- onExpose da (\x' -> drawDiag' x da scale') cId <- onExpose da (\_ -> drawDiag' x da scale')
_ <- on fcb fileActivated (signalDisconnect cId) _ <- on fcb fileActivated (signalDisconnect cId)
ret <- drawDiag' x da scale' ret <- drawDiag' x da scale'
case ret of unless ret $ showErrorDialog "No valid Mesh file!"
True -> return () Nothing -> showErrorDialog "No valid Mesh file!"
False -> showErrorDialog "No valid Mesh file!"
Nothing -> do
showErrorDialog "No valid Mesh file!"
-- |Callback when the "Save" Button is clicked. -- |Callback when the "Save" Button is clicked.
@ -97,11 +95,8 @@ onClickedSaveButton fcb = do
case filename of case filename of
Just x -> do Just x -> do
ret <- saveDiag' x ret <- saveDiag' x
case ret of unless ret $ showErrorDialog "No valid Mesh file!"
True -> return () Nothing -> showErrorDialog "No valid Mesh file!"
False -> showErrorDialog "No valid Mesh file!"
Nothing -> do
showErrorDialog "No valid Mesh file!"
-- |Pops up an error Dialog with the given String. -- |Pops up an error Dialog with the given String.
@ -122,10 +117,10 @@ drawDiag' :: (WidgetClass widget, RangeClass scale)
=> FilePath => FilePath
-> widget -> widget
-> scale -> scale
-> IO (Bool) -> IO Bool
drawDiag' fp da scale' = drawDiag' fp da scale' =
case cmpExt "obj" fp of if cmpExt "obj" fp
True -> do then do
mesh <- readFile fp mesh <- readFile fp
dw <- widgetGetDrawWindow da dw <- widgetGetDrawWindow da
adjustment <- rangeGetAdjustment scale' adjustment <- rangeGetAdjustment scale'
@ -135,15 +130,15 @@ drawDiag' fp da scale' =
(diagFromString (MkProp scaleVal) mesh) (diagFromString (MkProp scaleVal) mesh)
renderWithDrawable dw r renderWithDrawable dw r
return True return True
False -> return False else return False
-- |Saves a Diagram which is built from a given file as an SVG. -- |Saves a Diagram which is built from a given file as an SVG.
saveDiag' :: FilePath -> IO (Bool) saveDiag' :: FilePath -> IO Bool
saveDiag' fp = saveDiag' fp =
case cmpExt "obj" fp of if cmpExt "obj" fp
True -> do then do
mesh <- readFile fp mesh <- readFile fp
renderCairo "out.svg" (Width 600) (diagFromString (MkProp 2) mesh) renderCairo "out.svg" (Width 600) (diagFromString (MkProp 2) mesh)
return True return True
False -> return False else return False

View File

@ -18,6 +18,6 @@ meshToArr xs = fmap (\(Just (x, _)) -> x) .
-- | Creates a Parser that accepts a single vertice, such as 'v 1.0 2.0'. -- | Creates a Parser that accepts a single vertice, such as 'v 1.0 2.0'.
parseVertice :: Parser (Double, Double) parseVertice :: Parser (Double, Double)
parseVertice = liftA2 (,) parseVertice = (,) <$>
(char 'v' *> spaces *> posDouble) (char 'v' *> spaces *> posDouble) <*>
(spaces *> posDouble) (spaces *> posDouble)