Allow specifying the diagram dimensions in the GUI
This commit is contained in:
parent
6c677d55b8
commit
522ad2b452
@ -34,8 +34,7 @@ diagFromVTable prop vt
|
|||||||
(repeat dot)) # moveTo (p2(xOffset, yOffset))
|
(repeat dot)) # moveTo (p2(xOffset, yOffset))
|
||||||
`atop` hrule (xuD - xlD) # centerX # moveTo (p2(0, yOffset))
|
`atop` hrule (xuD - xlD) # centerX # moveTo (p2(0, yOffset))
|
||||||
`atop` vrule (yuD - ylD) # centerY # moveTo (p2(xOffset, 0))
|
`atop` vrule (yuD - ylD) # centerY # moveTo (p2(xOffset, 0))
|
||||||
`atop` rect (xuD - xlD + 50)
|
`atop` emptyRect (xuD - xlD + 50) (yuD - ylD + 50)
|
||||||
(yuD - ylD + 50) # lwG 0.00 # bg white
|
|
||||||
where dot = (circle $
|
where dot = (circle $
|
||||||
t prop :: Diagram Cairo R2) # fc black
|
t prop :: Diagram Cairo R2) # fc black
|
||||||
mkPoint (x,y) = p2 (x,y)
|
mkPoint (x,y) = p2 (x,y)
|
||||||
@ -57,3 +56,8 @@ diagFromString prop mesh
|
|||||||
= diagFromVTable prop .
|
= diagFromVTable prop .
|
||||||
meshToArr $
|
meshToArr $
|
||||||
mesh
|
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
|
||||||
|
|||||||
85
Gtk.hs
85
Gtk.hs
@ -34,6 +34,10 @@ makeGUI startFile = do
|
|||||||
"filechooserButton"
|
"filechooserButton"
|
||||||
da <- xmlGetWidget xml castToDrawingArea "drawingarea"
|
da <- xmlGetWidget xml castToDrawingArea "drawingarea"
|
||||||
hscale <- xmlGetWidget xml castToHScale "hscale"
|
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
|
-- adjust properties
|
||||||
if startFile == ""
|
if startFile == ""
|
||||||
@ -47,8 +51,9 @@ makeGUI startFile = do
|
|||||||
-- callbacks
|
-- callbacks
|
||||||
_ <- onDestroy window mainQuit
|
_ <- onDestroy window mainQuit
|
||||||
_ <- onClicked drawButton $ onClickedDrawButton fileButton
|
_ <- onClicked drawButton $ onClickedDrawButton fileButton
|
||||||
da hscale
|
da hscale (xlDE, xlUE) (ylDE, ylUE)
|
||||||
_ <- onClicked saveButton $ onClickedSaveButton fileButton
|
_ <- onClicked saveButton $ onClickedSaveButton fileButton
|
||||||
|
hscale (xlDE, xlUE) (ylDE, ylUE)
|
||||||
_ <- onClicked quitButton mainQuit
|
_ <- onClicked quitButton mainQuit
|
||||||
|
|
||||||
-- hotkeys
|
-- hotkeys
|
||||||
@ -60,10 +65,12 @@ makeGUI startFile = do
|
|||||||
[Control] <- eventModifier
|
[Control] <- eventModifier
|
||||||
"s" <- eventKeyName
|
"s" <- eventKeyName
|
||||||
liftIO $ onClickedSaveButton fileButton
|
liftIO $ onClickedSaveButton fileButton
|
||||||
|
hscale (xlDE, xlUE) (ylDE, ylUE)
|
||||||
_ <- window `on` keyPressEvent $ tryEvent $ do
|
_ <- window `on` keyPressEvent $ tryEvent $ do
|
||||||
[Control] <- eventModifier
|
[Control] <- eventModifier
|
||||||
"d" <- eventKeyName
|
"d" <- eventKeyName
|
||||||
liftIO $ onClickedDrawButton fileButton da hscale
|
liftIO $ onClickedDrawButton fileButton da hscale
|
||||||
|
(xlDE, xlUE) (ylDE, ylUE)
|
||||||
|
|
||||||
-- draw widgets and start main loop
|
-- draw widgets and start main loop
|
||||||
widgetShowAll window
|
widgetShowAll window
|
||||||
@ -75,26 +82,32 @@ onClickedDrawButton :: (WidgetClass widget, RangeClass scale)
|
|||||||
=> FileChooserButton
|
=> FileChooserButton
|
||||||
-> widget
|
-> widget
|
||||||
-> scale
|
-> scale
|
||||||
|
-> (Entry, Entry)
|
||||||
|
-> (Entry, Entry)
|
||||||
-> IO ()
|
-> IO ()
|
||||||
onClickedDrawButton fcb da scale' = do
|
onClickedDrawButton fcb da scale' dXE dYE = do
|
||||||
filename <- fileChooserGetFilename fcb
|
filename <- fileChooserGetFilename fcb
|
||||||
case filename of
|
case filename of
|
||||||
Just x -> do
|
Just x -> do
|
||||||
cId <- onExpose da (\_ -> drawDiag' x da scale')
|
cId <- onExpose da (\_ -> drawDiag' x da scale' dXE dYE)
|
||||||
_ <- on fcb fileActivated (signalDisconnect cId)
|
_ <- on fcb fileActivated (signalDisconnect cId)
|
||||||
ret <- drawDiag' x da scale'
|
ret <- drawDiag' x da scale' dXE dYE
|
||||||
unless ret $ showErrorDialog "No valid Mesh file!"
|
unless ret $ showErrorDialog "No valid Mesh file!"
|
||||||
Nothing -> showErrorDialog "No valid Mesh file!"
|
Nothing -> showErrorDialog "No valid Mesh file!"
|
||||||
|
|
||||||
|
|
||||||
-- |Callback when the "Save" Button is clicked.
|
-- |Callback when the "Save" Button is clicked.
|
||||||
onClickedSaveButton :: FileChooserButton
|
onClickedSaveButton :: RangeClass scale
|
||||||
|
=> FileChooserButton
|
||||||
|
-> scale
|
||||||
|
-> (Entry, Entry)
|
||||||
|
-> (Entry, Entry)
|
||||||
-> IO ()
|
-> IO ()
|
||||||
onClickedSaveButton fcb = do
|
onClickedSaveButton fcb scale' dXE dYE = do
|
||||||
filename <- fileChooserGetFilename fcb
|
filename <- fileChooserGetFilename fcb
|
||||||
case filename of
|
case filename of
|
||||||
Just x -> do
|
Just x -> do
|
||||||
ret <- saveDiag' x
|
ret <- saveDiag' x scale' dXE dYE
|
||||||
unless ret $ showErrorDialog "No valid Mesh file!"
|
unless ret $ showErrorDialog "No valid Mesh file!"
|
||||||
Nothing -> showErrorDialog "No valid Mesh file!"
|
Nothing -> showErrorDialog "No valid Mesh file!"
|
||||||
|
|
||||||
@ -117,28 +130,74 @@ drawDiag' :: (WidgetClass widget, RangeClass scale)
|
|||||||
=> FilePath
|
=> FilePath
|
||||||
-> widget
|
-> widget
|
||||||
-> scale
|
-> scale
|
||||||
|
-> (Entry, Entry)
|
||||||
|
-> (Entry, Entry)
|
||||||
-> IO Bool
|
-> IO Bool
|
||||||
drawDiag' fp da scale' =
|
drawDiag' fp da scale' dXE dYE =
|
||||||
if cmpExt "obj" fp
|
if cmpExt "obj" fp
|
||||||
then do
|
then do
|
||||||
mesh <- readFile fp
|
mesh <- readFile fp
|
||||||
dw <- widgetGetDrawWindow da
|
dw <- widgetGetDrawWindow da
|
||||||
adjustment <- rangeGetAdjustment scale'
|
adjustment <- rangeGetAdjustment scale'
|
||||||
scaleVal <- adjustmentGetValue adjustment
|
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)
|
(CairoOptions "" (Width 600) SVG False)
|
||||||
(diagFromString (def{t = scaleVal}) mesh)
|
(diagFromString (def{t = scaleVal,
|
||||||
|
dX = xD,
|
||||||
|
dY = yD})
|
||||||
|
mesh)
|
||||||
renderWithDrawable dw r
|
renderWithDrawable dw r
|
||||||
return True
|
return True
|
||||||
else 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' :: RangeClass scale
|
||||||
saveDiag' fp =
|
=> FilePath
|
||||||
|
-> scale
|
||||||
|
-> (Entry, Entry)
|
||||||
|
-> (Entry, Entry)
|
||||||
|
-> IO Bool
|
||||||
|
saveDiag' fp scale' dXE dYE =
|
||||||
if cmpExt "obj" fp
|
if cmpExt "obj" fp
|
||||||
then do
|
then do
|
||||||
mesh <- readFile fp
|
mesh <- readFile fp
|
||||||
renderCairo "out.svg" (Width 600) (diagFromString def mesh)
|
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
|
return True
|
||||||
else return False
|
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
|
||||||
|
|||||||
223
gtk2.glade
223
gtk2.glade
@ -11,6 +11,18 @@
|
|||||||
<widget class="GtkVBox" id="vbox1">
|
<widget class="GtkVBox" id="vbox1">
|
||||||
<property name="visible">True</property>
|
<property name="visible">True</property>
|
||||||
<property name="can_focus">False</property>
|
<property name="can_focus">False</property>
|
||||||
|
<child>
|
||||||
|
<widget class="GtkFileChooserButton" id="filechooserButton">
|
||||||
|
<property name="visible">True</property>
|
||||||
|
<property name="can_focus">False</property>
|
||||||
|
<property name="create_folders">False</property>
|
||||||
|
</widget>
|
||||||
|
<packing>
|
||||||
|
<property name="expand">True</property>
|
||||||
|
<property name="fill">True</property>
|
||||||
|
<property name="position">0</property>
|
||||||
|
</packing>
|
||||||
|
</child>
|
||||||
<child>
|
<child>
|
||||||
<widget class="GtkDrawingArea" id="drawingarea">
|
<widget class="GtkDrawingArea" id="drawingarea">
|
||||||
<property name="width_request">600</property>
|
<property name="width_request">600</property>
|
||||||
@ -21,7 +33,7 @@
|
|||||||
<packing>
|
<packing>
|
||||||
<property name="expand">True</property>
|
<property name="expand">True</property>
|
||||||
<property name="fill">True</property>
|
<property name="fill">True</property>
|
||||||
<property name="position">0</property>
|
<property name="position">1</property>
|
||||||
</packing>
|
</packing>
|
||||||
</child>
|
</child>
|
||||||
<child>
|
<child>
|
||||||
@ -71,7 +83,7 @@
|
|||||||
<packing>
|
<packing>
|
||||||
<property name="expand">False</property>
|
<property name="expand">False</property>
|
||||||
<property name="fill">False</property>
|
<property name="fill">False</property>
|
||||||
<property name="position">1</property>
|
<property name="position">2</property>
|
||||||
</packing>
|
</packing>
|
||||||
</child>
|
</child>
|
||||||
<child>
|
<child>
|
||||||
@ -79,10 +91,204 @@
|
|||||||
<property name="visible">True</property>
|
<property name="visible">True</property>
|
||||||
<property name="can_focus">False</property>
|
<property name="can_focus">False</property>
|
||||||
<child>
|
<child>
|
||||||
<widget class="GtkFileChooserButton" id="filechooserButton">
|
<widget class="GtkHBox" id="hbox3">
|
||||||
<property name="visible">True</property>
|
<property name="visible">True</property>
|
||||||
<property name="can_focus">False</property>
|
<property name="can_focus">False</property>
|
||||||
<property name="create_folders">False</property>
|
<child>
|
||||||
|
<widget class="GtkVBox" id="vbox2">
|
||||||
|
<property name="visible">True</property>
|
||||||
|
<property name="can_focus">False</property>
|
||||||
|
<child>
|
||||||
|
<widget class="GtkLabel" id="label1">
|
||||||
|
<property name="visible">True</property>
|
||||||
|
<property name="can_focus">False</property>
|
||||||
|
<property name="label" translatable="yes">X min</property>
|
||||||
|
</widget>
|
||||||
|
<packing>
|
||||||
|
<property name="expand">True</property>
|
||||||
|
<property name="fill">True</property>
|
||||||
|
<property name="position">0</property>
|
||||||
|
</packing>
|
||||||
|
</child>
|
||||||
|
<child>
|
||||||
|
<widget class="GtkEntry" id="xlD">
|
||||||
|
<property name="width_request">5</property>
|
||||||
|
<property name="visible">True</property>
|
||||||
|
<property name="can_focus">True</property>
|
||||||
|
<property name="invisible_char">●</property>
|
||||||
|
<property name="text" translatable="yes">0</property>
|
||||||
|
<property name="invisible_char_set">True</property>
|
||||||
|
<property name="primary_icon_activatable">False</property>
|
||||||
|
<property name="secondary_icon_activatable">False</property>
|
||||||
|
<property name="primary_icon_sensitive">True</property>
|
||||||
|
<property name="secondary_icon_sensitive">True</property>
|
||||||
|
</widget>
|
||||||
|
<packing>
|
||||||
|
<property name="expand">True</property>
|
||||||
|
<property name="fill">True</property>
|
||||||
|
<property name="position">1</property>
|
||||||
|
</packing>
|
||||||
|
</child>
|
||||||
|
</widget>
|
||||||
|
<packing>
|
||||||
|
<property name="expand">True</property>
|
||||||
|
<property name="fill">True</property>
|
||||||
|
<property name="position">0</property>
|
||||||
|
</packing>
|
||||||
|
</child>
|
||||||
|
<child>
|
||||||
|
<widget class="GtkVBox" id="vbox3">
|
||||||
|
<property name="visible">True</property>
|
||||||
|
<property name="can_focus">False</property>
|
||||||
|
<child>
|
||||||
|
<widget class="GtkLabel" id="label2">
|
||||||
|
<property name="visible">True</property>
|
||||||
|
<property name="can_focus">False</property>
|
||||||
|
<property name="label" translatable="yes">X max</property>
|
||||||
|
</widget>
|
||||||
|
<packing>
|
||||||
|
<property name="expand">True</property>
|
||||||
|
<property name="fill">True</property>
|
||||||
|
<property name="position">0</property>
|
||||||
|
</packing>
|
||||||
|
</child>
|
||||||
|
<child>
|
||||||
|
<widget class="GtkEntry" id="xlU">
|
||||||
|
<property name="width_request">5</property>
|
||||||
|
<property name="visible">True</property>
|
||||||
|
<property name="can_focus">True</property>
|
||||||
|
<property name="invisible_char">●</property>
|
||||||
|
<property name="text" translatable="yes">500</property>
|
||||||
|
<property name="invisible_char_set">True</property>
|
||||||
|
<property name="primary_icon_activatable">False</property>
|
||||||
|
<property name="secondary_icon_activatable">False</property>
|
||||||
|
<property name="primary_icon_sensitive">True</property>
|
||||||
|
<property name="secondary_icon_sensitive">True</property>
|
||||||
|
</widget>
|
||||||
|
<packing>
|
||||||
|
<property name="expand">True</property>
|
||||||
|
<property name="fill">True</property>
|
||||||
|
<property name="position">1</property>
|
||||||
|
</packing>
|
||||||
|
</child>
|
||||||
|
</widget>
|
||||||
|
<packing>
|
||||||
|
<property name="expand">True</property>
|
||||||
|
<property name="fill">True</property>
|
||||||
|
<property name="position">1</property>
|
||||||
|
</packing>
|
||||||
|
</child>
|
||||||
|
</widget>
|
||||||
|
<packing>
|
||||||
|
<property name="expand">True</property>
|
||||||
|
<property name="fill">True</property>
|
||||||
|
<property name="position">0</property>
|
||||||
|
</packing>
|
||||||
|
</child>
|
||||||
|
<child>
|
||||||
|
<widget class="GtkHBox" id="hbox4">
|
||||||
|
<property name="visible">True</property>
|
||||||
|
<property name="can_focus">False</property>
|
||||||
|
<child>
|
||||||
|
<widget class="GtkVBox" id="vbox4">
|
||||||
|
<property name="visible">True</property>
|
||||||
|
<property name="can_focus">False</property>
|
||||||
|
<child>
|
||||||
|
<widget class="GtkLabel" id="label3">
|
||||||
|
<property name="visible">True</property>
|
||||||
|
<property name="can_focus">False</property>
|
||||||
|
<property name="label" translatable="yes">Y min</property>
|
||||||
|
</widget>
|
||||||
|
<packing>
|
||||||
|
<property name="expand">True</property>
|
||||||
|
<property name="fill">True</property>
|
||||||
|
<property name="position">0</property>
|
||||||
|
</packing>
|
||||||
|
</child>
|
||||||
|
<child>
|
||||||
|
<widget class="GtkEntry" id="ylD">
|
||||||
|
<property name="width_request">5</property>
|
||||||
|
<property name="visible">True</property>
|
||||||
|
<property name="can_focus">True</property>
|
||||||
|
<property name="invisible_char">●</property>
|
||||||
|
<property name="text" translatable="yes">0</property>
|
||||||
|
<property name="invisible_char_set">True</property>
|
||||||
|
<property name="primary_icon_activatable">False</property>
|
||||||
|
<property name="secondary_icon_activatable">False</property>
|
||||||
|
<property name="primary_icon_sensitive">True</property>
|
||||||
|
<property name="secondary_icon_sensitive">True</property>
|
||||||
|
</widget>
|
||||||
|
<packing>
|
||||||
|
<property name="expand">True</property>
|
||||||
|
<property name="fill">True</property>
|
||||||
|
<property name="position">1</property>
|
||||||
|
</packing>
|
||||||
|
</child>
|
||||||
|
</widget>
|
||||||
|
<packing>
|
||||||
|
<property name="expand">True</property>
|
||||||
|
<property name="fill">True</property>
|
||||||
|
<property name="position">0</property>
|
||||||
|
</packing>
|
||||||
|
</child>
|
||||||
|
<child>
|
||||||
|
<widget class="GtkVBox" id="vbox5">
|
||||||
|
<property name="visible">True</property>
|
||||||
|
<property name="can_focus">False</property>
|
||||||
|
<child>
|
||||||
|
<widget class="GtkLabel" id="label4">
|
||||||
|
<property name="visible">True</property>
|
||||||
|
<property name="can_focus">False</property>
|
||||||
|
<property name="label" translatable="yes">Y max</property>
|
||||||
|
</widget>
|
||||||
|
<packing>
|
||||||
|
<property name="expand">True</property>
|
||||||
|
<property name="fill">True</property>
|
||||||
|
<property name="position">0</property>
|
||||||
|
</packing>
|
||||||
|
</child>
|
||||||
|
<child>
|
||||||
|
<widget class="GtkEntry" id="ylU">
|
||||||
|
<property name="width_request">5</property>
|
||||||
|
<property name="visible">True</property>
|
||||||
|
<property name="can_focus">True</property>
|
||||||
|
<property name="invisible_char">●</property>
|
||||||
|
<property name="text" translatable="yes">500</property>
|
||||||
|
<property name="invisible_char_set">True</property>
|
||||||
|
<property name="primary_icon_activatable">False</property>
|
||||||
|
<property name="secondary_icon_activatable">False</property>
|
||||||
|
<property name="primary_icon_sensitive">True</property>
|
||||||
|
<property name="secondary_icon_sensitive">True</property>
|
||||||
|
</widget>
|
||||||
|
<packing>
|
||||||
|
<property name="expand">True</property>
|
||||||
|
<property name="fill">True</property>
|
||||||
|
<property name="position">1</property>
|
||||||
|
</packing>
|
||||||
|
</child>
|
||||||
|
</widget>
|
||||||
|
<packing>
|
||||||
|
<property name="expand">True</property>
|
||||||
|
<property name="fill">True</property>
|
||||||
|
<property name="position">1</property>
|
||||||
|
</packing>
|
||||||
|
</child>
|
||||||
|
</widget>
|
||||||
|
<packing>
|
||||||
|
<property name="expand">True</property>
|
||||||
|
<property name="fill">True</property>
|
||||||
|
<property name="position">1</property>
|
||||||
|
</packing>
|
||||||
|
</child>
|
||||||
|
<child>
|
||||||
|
<widget class="GtkVBox" id="vbox6">
|
||||||
|
<property name="visible">True</property>
|
||||||
|
<property name="can_focus">False</property>
|
||||||
|
<child>
|
||||||
|
<widget class="GtkLabel" id="label5">
|
||||||
|
<property name="visible">True</property>
|
||||||
|
<property name="can_focus">False</property>
|
||||||
|
<property name="label" translatable="yes">point thickness</property>
|
||||||
</widget>
|
</widget>
|
||||||
<packing>
|
<packing>
|
||||||
<property name="expand">True</property>
|
<property name="expand">True</property>
|
||||||
@ -105,10 +311,17 @@
|
|||||||
</packing>
|
</packing>
|
||||||
</child>
|
</child>
|
||||||
</widget>
|
</widget>
|
||||||
|
<packing>
|
||||||
|
<property name="expand">True</property>
|
||||||
|
<property name="fill">True</property>
|
||||||
|
<property name="position">2</property>
|
||||||
|
</packing>
|
||||||
|
</child>
|
||||||
|
</widget>
|
||||||
<packing>
|
<packing>
|
||||||
<property name="expand">False</property>
|
<property name="expand">False</property>
|
||||||
<property name="fill">False</property>
|
<property name="fill">False</property>
|
||||||
<property name="position">2</property>
|
<property name="position">3</property>
|
||||||
</packing>
|
</packing>
|
||||||
</child>
|
</child>
|
||||||
</widget>
|
</widget>
|
||||||
|
|||||||
Loading…
Reference in New Issue
Block a user