From 522ad2b4523946564258ab9f9ffa52b7a113e1f6 Mon Sep 17 00:00:00 2001 From: hasufell Date: Sun, 5 Oct 2014 18:41:41 +0200 Subject: [PATCH] Allow specifying the diagram dimensions in the GUI --- Diagram.hs | 8 +- Gtk.hs | 89 ++++++++++++++++---- gtk2.glade | 233 ++++++++++++++++++++++++++++++++++++++++++++++++++--- 3 files changed, 303 insertions(+), 27 deletions(-) diff --git a/Diagram.hs b/Diagram.hs index f46f85a..720cb1a 100644 --- a/Diagram.hs +++ b/Diagram.hs @@ -34,8 +34,7 @@ diagFromVTable prop vt (repeat dot)) # moveTo (p2(xOffset, yOffset)) `atop` hrule (xuD - xlD) # centerX # moveTo (p2(0, yOffset)) `atop` vrule (yuD - ylD) # centerY # moveTo (p2(xOffset, 0)) - `atop` rect (xuD - xlD + 50) - (yuD - ylD + 50) # lwG 0.00 # bg white + `atop` emptyRect (xuD - xlD + 50) (yuD - ylD + 50) where dot = (circle $ t prop :: Diagram Cairo R2) # fc black mkPoint (x,y) = p2 (x,y) @@ -57,3 +56,8 @@ diagFromString prop mesh = diagFromVTable prop . meshToArr $ mesh + + +-- |Create a white rectangle with the given width and height. +emptyRect :: Double -> Double -> Diagram Cairo R2 +emptyRect x y = rect x y # lwG 0.00 # bg white diff --git a/Gtk.hs b/Gtk.hs index 83f2fbc..4e48e08 100644 --- a/Gtk.hs +++ b/Gtk.hs @@ -34,6 +34,10 @@ makeGUI startFile = do "filechooserButton" da <- xmlGetWidget xml castToDrawingArea "drawingarea" hscale <- xmlGetWidget xml castToHScale "hscale" + xlDE <- xmlGetWidget xml castToEntry "xlD" + xlUE <- xmlGetWidget xml castToEntry "xlU" + ylDE <- xmlGetWidget xml castToEntry "ylD" + ylUE <- xmlGetWidget xml castToEntry "ylU" -- adjust properties if startFile == "" @@ -47,8 +51,9 @@ makeGUI startFile = do -- callbacks _ <- onDestroy window mainQuit _ <- onClicked drawButton $ onClickedDrawButton fileButton - da hscale + da hscale (xlDE, xlUE) (ylDE, ylUE) _ <- onClicked saveButton $ onClickedSaveButton fileButton + hscale (xlDE, xlUE) (ylDE, ylUE) _ <- onClicked quitButton mainQuit -- hotkeys @@ -60,10 +65,12 @@ makeGUI startFile = do [Control] <- eventModifier "s" <- eventKeyName liftIO $ onClickedSaveButton fileButton + hscale (xlDE, xlUE) (ylDE, ylUE) _ <- window `on` keyPressEvent $ tryEvent $ do [Control] <- eventModifier "d" <- eventKeyName liftIO $ onClickedDrawButton fileButton da hscale + (xlDE, xlUE) (ylDE, ylUE) -- draw widgets and start main loop widgetShowAll window @@ -75,26 +82,32 @@ onClickedDrawButton :: (WidgetClass widget, RangeClass scale) => FileChooserButton -> widget -> scale + -> (Entry, Entry) + -> (Entry, Entry) -> IO () -onClickedDrawButton fcb da scale' = do +onClickedDrawButton fcb da scale' dXE dYE = do filename <- fileChooserGetFilename fcb case filename of Just x -> do - cId <- onExpose da (\_ -> drawDiag' x da scale') - _ <- on fcb fileActivated (signalDisconnect cId) - ret <- drawDiag' x da scale' + cId <- onExpose da (\_ -> drawDiag' x da scale' dXE dYE) + _ <- on fcb fileActivated (signalDisconnect cId) + ret <- drawDiag' x da scale' dXE dYE unless ret $ showErrorDialog "No valid Mesh file!" Nothing -> showErrorDialog "No valid Mesh file!" -- |Callback when the "Save" Button is clicked. -onClickedSaveButton :: FileChooserButton +onClickedSaveButton :: RangeClass scale + => FileChooserButton + -> scale + -> (Entry, Entry) + -> (Entry, Entry) -> IO () -onClickedSaveButton fcb = do +onClickedSaveButton fcb scale' dXE dYE = do filename <- fileChooserGetFilename fcb case filename of Just x -> do - ret <- saveDiag' x + ret <- saveDiag' x scale' dXE dYE unless ret $ showErrorDialog "No valid Mesh file!" Nothing -> showErrorDialog "No valid Mesh file!" @@ -117,28 +130,74 @@ drawDiag' :: (WidgetClass widget, RangeClass scale) => FilePath -> widget -> scale + -> (Entry, Entry) + -> (Entry, Entry) -> IO Bool -drawDiag' fp da scale' = +drawDiag' fp da scale' dXE dYE = if cmpExt "obj" fp then do mesh <- readFile fp dw <- widgetGetDrawWindow da adjustment <- rangeGetAdjustment scale' scaleVal <- adjustmentGetValue adjustment - let (_, r) = renderDia Cairo + xlD <- entryGetText $ fst dXE + xlU <- entryGetText $ snd dXE + ylD <- entryGetText $ fst dYE + ylU <- entryGetText $ snd dYE + + -- clear drawing area + clearDiag da + + let xD = (read xlD, read xlU) :: (Double, Double) + yD = (read ylD, read ylU) :: (Double, Double) + (_, r) = renderDia Cairo (CairoOptions "" (Width 600) SVG False) - (diagFromString (def{t = scaleVal}) mesh) + (diagFromString (def{t = scaleVal, + dX = xD, + dY = yD}) + mesh) renderWithDrawable dw r return True else return False -- |Saves a Diagram which is built from a given file as an SVG. -saveDiag' :: FilePath -> IO Bool -saveDiag' fp = +saveDiag' :: RangeClass scale + => FilePath + -> scale + -> (Entry, Entry) + -> (Entry, Entry) + -> IO Bool +saveDiag' fp scale' dXE dYE = if cmpExt "obj" fp then do - mesh <- readFile fp - renderCairo "out.svg" (Width 600) (diagFromString def mesh) + mesh <- readFile fp + adjustment <- rangeGetAdjustment scale' + scaleVal <- adjustmentGetValue adjustment + xlD <- entryGetText $ fst dXE + xlU <- entryGetText $ snd dXE + ylD <- entryGetText $ fst dYE + ylU <- entryGetText $ snd dYE + + let xD = (read xlD, read xlU) :: (Double, Double) + yD = (read ylD, read ylU) :: (Double, Double) + renderCairo "out.svg" (Width 600) + (diagFromString (def{t = scaleVal, + dX = xD, + dY = yD}) + mesh) return True else return False + + +-- |Clears the drawing area by painting a white rectangle. +clearDiag :: WidgetClass widget + => widget + -> IO () +clearDiag da = do + dw <- widgetGetDrawWindow da + + let (_, r) = renderDia Cairo + (CairoOptions "" (Width 600) SVG False) + (emptyRect 600 600) + renderWithDrawable dw r diff --git a/gtk2.glade b/gtk2.glade index 30b09ff..e84434c 100644 --- a/gtk2.glade +++ b/gtk2.glade @@ -11,6 +11,18 @@ True False + + + True + False + False + + + True + True + 0 + + 600 @@ -21,7 +33,7 @@ True True - 0 + 1 @@ -71,7 +83,7 @@ False False - 1 + 2 @@ -79,10 +91,93 @@ True False - + True False - False + + + True + False + + + True + False + X min + + + True + True + 0 + + + + + 5 + True + True + ● + 0 + True + False + False + True + True + + + True + True + 1 + + + + + True + True + 0 + + + + + True + False + + + True + False + X max + + + True + True + 0 + + + + + 5 + True + True + ● + 500 + True + False + False + True + True + + + True + True + 1 + + + + + True + True + 1 + + True @@ -91,12 +186,93 @@ - + True - True - 1 0.10000000000000001 10 0.5 0.5 0 - 1 - left + False + + + True + False + + + True + False + Y min + + + True + True + 0 + + + + + 5 + True + True + ● + 0 + True + False + False + True + True + + + True + True + 1 + + + + + True + True + 0 + + + + + True + False + + + True + False + Y max + + + True + True + 0 + + + + + 5 + True + True + ● + 500 + True + False + False + True + True + + + True + True + 1 + + + + + True + True + 1 + + True @@ -104,11 +280,48 @@ 1 + + + True + False + + + True + False + point thickness + + + True + True + 0 + + + + + True + True + 1 0.10000000000000001 10 0.5 0.5 0 + 1 + left + + + True + True + 1 + + + + + True + True + 2 + + False False - 2 + 3