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))
|
||||
`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
|
||||
|
||||
89
Gtk.hs
89
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
|
||||
|
||||
233
gtk2.glade
233
gtk2.glade
@ -11,6 +11,18 @@
|
||||
<widget class="GtkVBox" id="vbox1">
|
||||
<property name="visible">True</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>
|
||||
<widget class="GtkDrawingArea" id="drawingarea">
|
||||
<property name="width_request">600</property>
|
||||
@ -21,7 +33,7 @@
|
||||
<packing>
|
||||
<property name="expand">True</property>
|
||||
<property name="fill">True</property>
|
||||
<property name="position">0</property>
|
||||
<property name="position">1</property>
|
||||
</packing>
|
||||
</child>
|
||||
<child>
|
||||
@ -71,7 +83,7 @@
|
||||
<packing>
|
||||
<property name="expand">False</property>
|
||||
<property name="fill">False</property>
|
||||
<property name="position">1</property>
|
||||
<property name="position">2</property>
|
||||
</packing>
|
||||
</child>
|
||||
<child>
|
||||
@ -79,10 +91,93 @@
|
||||
<property name="visible">True</property>
|
||||
<property name="can_focus">False</property>
|
||||
<child>
|
||||
<widget class="GtkFileChooserButton" id="filechooserButton">
|
||||
<widget class="GtkHBox" id="hbox3">
|
||||
<property name="visible">True</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>
|
||||
@ -91,12 +186,93 @@
|
||||
</packing>
|
||||
</child>
|
||||
<child>
|
||||
<widget class="GtkHScale" id="hscale">
|
||||
<widget class="GtkHBox" id="hbox4">
|
||||
<property name="visible">True</property>
|
||||
<property name="can_focus">True</property>
|
||||
<property name="adjustment">1 0.10000000000000001 10 0.5 0.5 0</property>
|
||||
<property name="round_digits">1</property>
|
||||
<property name="value_pos">left</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>
|
||||
@ -104,11 +280,48 @@
|
||||
<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>
|
||||
<packing>
|
||||
<property name="expand">True</property>
|
||||
<property name="fill">True</property>
|
||||
<property name="position">0</property>
|
||||
</packing>
|
||||
</child>
|
||||
<child>
|
||||
<widget class="GtkHScale" id="hscale">
|
||||
<property name="visible">True</property>
|
||||
<property name="can_focus">True</property>
|
||||
<property name="adjustment">1 0.10000000000000001 10 0.5 0.5 0</property>
|
||||
<property name="round_digits">1</property>
|
||||
<property name="value_pos">left</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">2</property>
|
||||
</packing>
|
||||
</child>
|
||||
</widget>
|
||||
<packing>
|
||||
<property name="expand">False</property>
|
||||
<property name="fill">False</property>
|
||||
<property name="position">2</property>
|
||||
<property name="position">3</property>
|
||||
</packing>
|
||||
</child>
|
||||
</widget>
|
||||
|
||||
Loading…
Reference in New Issue
Block a user