Allow showing a grid
This commit is contained in:
parent
4195404694
commit
de5aba792e
29
Diagram.hs
29
Diagram.hs
@ -4,6 +4,7 @@ module Diagram (t,
|
||||
dX,
|
||||
dY,
|
||||
alg,
|
||||
gd,
|
||||
defaultProp,
|
||||
diag,
|
||||
diagS,
|
||||
@ -39,7 +40,9 @@ data DiagProp = MkProp {
|
||||
-- |The dimensions of the y-axis.
|
||||
dY :: Coord,
|
||||
-- |Algorithm to use.
|
||||
alg :: Int
|
||||
alg :: Int,
|
||||
-- |If we want to show the grid.
|
||||
gd :: Bool
|
||||
}
|
||||
|
||||
|
||||
@ -57,7 +60,7 @@ instance Monoid Diag where
|
||||
|
||||
-- |The default properties of the Diagram.
|
||||
defaultProp :: DiagProp
|
||||
defaultProp = MkProp 2 (0,500) (0,500) 0
|
||||
defaultProp = MkProp 2 (0,500) (0,500) 0 False
|
||||
|
||||
|
||||
-- |Extract the lower bound of the x-axis dimension.
|
||||
@ -177,12 +180,13 @@ whiteRectB = Diag f
|
||||
diag :: DiagProp -> [PT] -> Diagram Cairo R2
|
||||
diag p = case alg p of
|
||||
0 -> mkDiag
|
||||
(mconcat [coordPoints, xAxis, yAxis, whiteRectB])
|
||||
(mconcat [coordPoints, xAxis, yAxis,
|
||||
(if gd p then grid else mempty), whiteRectB])
|
||||
p
|
||||
1 -> mkDiag
|
||||
(mconcat $
|
||||
[convexHullPoints, convexHullLines, coordPoints,
|
||||
xAxis, yAxis, whiteRectB])
|
||||
xAxis, yAxis, (if gd p then grid else mempty), whiteRectB])
|
||||
p
|
||||
_ -> mempty
|
||||
|
||||
@ -223,3 +227,20 @@ gifDiagS p = gifDiag p .
|
||||
-- |Create a white rectangle with the given width and height.
|
||||
whiteRect :: Double -> Double -> Diagram Cairo R2
|
||||
whiteRect x y = rect x y # lwG 0.00 # bg white
|
||||
|
||||
|
||||
-- |Create a grid across the whole diagram with 50*50 squares.
|
||||
grid :: Diag
|
||||
grid = Diag f `mappend` Diag g
|
||||
where
|
||||
f p _ = hcat' (with & sep .~ 50)
|
||||
(take (floor . (/) (xuD p - xlD p) $ 50) .
|
||||
repeat $ (vrule $ xuD p - xlD p)) #
|
||||
moveTo (p2 (xlD p, (yuD p - ylD p) / 2)) #
|
||||
lw ultraThin
|
||||
g p _ = vcat' (with & sep .~ 50)
|
||||
(take (floor . (/) (yuD p - ylD p) $ 50) .
|
||||
repeat $ (hrule $ yuD p - ylD p)) #
|
||||
alignB #
|
||||
moveTo (p2 ((xuD p - xlD p) / 2, ylD p)) #
|
||||
lw ultraThin
|
||||
|
||||
15
Gtk.hs
15
Gtk.hs
@ -45,7 +45,9 @@ data MyGUI = MkMyGUI {
|
||||
-- |about dialog
|
||||
aD :: AboutDialog,
|
||||
-- |combo box for choosing the algorithm
|
||||
cB :: ComboBox
|
||||
cB :: ComboBox,
|
||||
-- |grid check button
|
||||
gC :: CheckButton
|
||||
}
|
||||
|
||||
|
||||
@ -73,8 +75,9 @@ makeMyGladeGUI = do
|
||||
yu' <- xmlGetWidget xml castToEntry "yuD"
|
||||
aD' <- xmlGetWidget xml castToAboutDialog "aboutdialog"
|
||||
cB' <- xmlGetWidget xml castToComboBox "comboalgo"
|
||||
gC' <- xmlGetWidget xml castToCheckButton "gridcheckbutton"
|
||||
|
||||
return $ MkMyGUI win' dB' sB' qB' fB' da' hs' xl' xu' yl' yu' aD' cB'
|
||||
return $ MkMyGUI win' dB' sB' qB' fB' da' hs' xl' xu' yl' yu' aD' cB' gC'
|
||||
|
||||
|
||||
gifCLI :: FilePath -> IO ()
|
||||
@ -201,6 +204,7 @@ drawDiag' fp mygui =
|
||||
yuD' <- entryGetText (yu mygui)
|
||||
alg' <- comboBoxGetActive (cB mygui)
|
||||
(daW, daH) <- widgetGetSize (da mygui)
|
||||
gd' <- toggleButtonGetActive (gC mygui)
|
||||
|
||||
let xD = (,) <$> readMaybe xlD' <*> readMaybe xuD' :: Maybe (Double,
|
||||
Double)
|
||||
@ -215,7 +219,8 @@ drawDiag' fp mygui =
|
||||
(diagS (def{t = scaleVal,
|
||||
dX = xD',
|
||||
dY = yD',
|
||||
alg = alg'})
|
||||
alg = alg',
|
||||
gd = gd'})
|
||||
mesh)
|
||||
renderWithDrawable dw r
|
||||
return 0
|
||||
@ -240,6 +245,7 @@ saveDiag' fp mygui =
|
||||
yuD' <- entryGetText (yu mygui)
|
||||
alg' <- comboBoxGetActive (cB mygui)
|
||||
(daW, daH) <- widgetGetSize (da mygui)
|
||||
gd' <- toggleButtonGetActive (gC mygui)
|
||||
|
||||
let xD = (,) <$> readMaybe xlD' <*> readMaybe xuD' :: Maybe (Double,
|
||||
Double)
|
||||
@ -252,7 +258,8 @@ saveDiag' fp mygui =
|
||||
(diagS (def{t = scaleVal,
|
||||
dX = xD',
|
||||
dY = yD',
|
||||
alg = alg'})
|
||||
alg = alg',
|
||||
gd = gd'})
|
||||
mesh)
|
||||
return 0
|
||||
_ -> return 1
|
||||
|
||||
40
gtk2.glade
40
gtk2.glade
@ -674,7 +674,7 @@ Malte Flender <malte.flender@fh-bielefeld.de></property>
|
||||
<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="adjustment">2 0.10000000000000001 10 0.5 0.5 0</property>
|
||||
<property name="round_digits">1</property>
|
||||
<property name="value_pos">left</property>
|
||||
</widget>
|
||||
@ -691,6 +691,44 @@ Malte Flender <malte.flender@fh-bielefeld.de></property>
|
||||
<property name="position">2</property>
|
||||
</packing>
|
||||
</child>
|
||||
<child>
|
||||
<widget class="GtkVBox" id="vbox7">
|
||||
<property name="width_request">100</property>
|
||||
<property name="visible">True</property>
|
||||
<property name="can_focus">False</property>
|
||||
<child>
|
||||
<widget class="GtkLabel" id="label6">
|
||||
<property name="visible">True</property>
|
||||
<property name="can_focus">False</property>
|
||||
<property name="label" translatable="yes">options</property>
|
||||
</widget>
|
||||
<packing>
|
||||
<property name="expand">True</property>
|
||||
<property name="fill">True</property>
|
||||
<property name="position">0</property>
|
||||
</packing>
|
||||
</child>
|
||||
<child>
|
||||
<widget class="GtkCheckButton" id="gridcheckbutton">
|
||||
<property name="label" translatable="yes">grid</property>
|
||||
<property name="visible">True</property>
|
||||
<property name="can_focus">True</property>
|
||||
<property name="receives_default">False</property>
|
||||
<property name="draw_indicator">True</property>
|
||||
</widget>
|
||||
<packing>
|
||||
<property name="expand">False</property>
|
||||
<property name="fill">False</property>
|
||||
<property name="position">1</property>
|
||||
</packing>
|
||||
</child>
|
||||
</widget>
|
||||
<packing>
|
||||
<property name="expand">False</property>
|
||||
<property name="fill">True</property>
|
||||
<property name="position">3</property>
|
||||
</packing>
|
||||
</child>
|
||||
</widget>
|
||||
<packing>
|
||||
<property name="expand">False</property>
|
||||
|
||||
Loading…
Reference in New Issue
Block a user