Allow showing the coordinate points as text
This commit is contained in:
parent
4137af7a7f
commit
01e2dd7802
43
Diagram.hs
43
Diagram.hs
@ -5,6 +5,7 @@ module Diagram (t,
|
||||
dY,
|
||||
alg,
|
||||
gd,
|
||||
ct,
|
||||
defaultProp,
|
||||
diag,
|
||||
diagS,
|
||||
@ -47,6 +48,8 @@ data DiagProp = MkProp {
|
||||
alg :: Int,
|
||||
-- |If we want to show the grid.
|
||||
gd :: Bool,
|
||||
-- |If we want to show the coordinates as text.
|
||||
ct :: Bool,
|
||||
-- |Square size used to show the grid and x/y-axis.
|
||||
sqS :: Double
|
||||
}
|
||||
@ -66,7 +69,7 @@ instance Monoid Diag where
|
||||
|
||||
-- |The default properties of the Diagram.
|
||||
defaultProp :: DiagProp
|
||||
defaultProp = MkProp 2 (0,500) (0,500) 0 False 50
|
||||
defaultProp = MkProp 2 (0,500) (0,500) 0 False False 50
|
||||
|
||||
|
||||
-- |Extract the lower bound of the x-axis dimension.
|
||||
@ -102,6 +105,19 @@ coordPoints = Diag cp
|
||||
dot = (circle $ t p :: Diagram Cairo R2) # fc black
|
||||
|
||||
|
||||
coordPointsText :: Diag
|
||||
coordPointsText = Diag cpt
|
||||
where
|
||||
cpt _ vt =
|
||||
position $
|
||||
zip vt
|
||||
((\(x, y) -> (flip (<>) (square 1 # lw none) .
|
||||
text $ ("(" ++ show x ++ ", " ++ show y ++ ")")) #
|
||||
scale 10 # translate (r2 (0, 10))) <$>
|
||||
unp2 <$>
|
||||
vt)
|
||||
|
||||
|
||||
-- |Create a diagram which shows the points of the convex hull.
|
||||
convexHullPoints :: Diag
|
||||
convexHullPoints = Diag chp
|
||||
@ -114,6 +130,22 @@ convexHullPoints = Diag chp
|
||||
vtch = grahamGetCH vt
|
||||
|
||||
|
||||
-- |Create a diagram which shows the points of the convex hull.
|
||||
convexHullPointsText :: Diag
|
||||
convexHullPointsText = Diag chpt
|
||||
where
|
||||
chpt _ vt =
|
||||
position $
|
||||
zip vtch
|
||||
((\(x, y) -> (flip (<>) (square 1 # lw none) .
|
||||
text $ ("(" ++ show x ++ ", " ++ show y ++ ")")) #
|
||||
scale 10 # translate (r2 (0, 10))) <$>
|
||||
unp2 <$>
|
||||
vtch)
|
||||
where
|
||||
vtch = grahamGetCH vt
|
||||
|
||||
|
||||
-- |Create a diagram which shows the lines along the convex hull
|
||||
-- points.
|
||||
convexHullLines :: Diag
|
||||
@ -220,14 +252,17 @@ diag :: DiagProp -> [PT] -> Diagram Cairo R2
|
||||
diag p = case alg p of
|
||||
0 ->
|
||||
mkDiag
|
||||
(mconcat [coordPoints, xAxis, yAxis,
|
||||
(mconcat [if ct p then coordPointsText else mempty,
|
||||
coordPoints, xAxis, yAxis,
|
||||
(if gd p then grid else mempty),whiteRectB])
|
||||
p
|
||||
1 ->
|
||||
mkDiag
|
||||
(mconcat
|
||||
[convexHullPoints, convexHullLines, coordPoints,
|
||||
xAxis, yAxis, (if gd p then grid else mempty), whiteRectB])
|
||||
[if ct p then convexHullPointsText else mempty,
|
||||
convexHullPoints, convexHullLines,
|
||||
coordPoints, xAxis, yAxis,
|
||||
(if gd p then grid else mempty), whiteRectB])
|
||||
p
|
||||
_ -> mempty
|
||||
|
||||
|
||||
18
Gtk.hs
18
Gtk.hs
@ -15,6 +15,7 @@ import System.Directory
|
||||
import Text.Read
|
||||
import OS.FileExt
|
||||
|
||||
|
||||
-- |Monolithic object passed to various GUI functions in order
|
||||
-- to keep the API stable and not alter the parameters too much.
|
||||
-- This only holds GUI widgets that are needed to be read during
|
||||
@ -47,7 +48,9 @@ data MyGUI = MkMyGUI {
|
||||
-- |combo box for choosing the algorithm
|
||||
cB :: ComboBox,
|
||||
-- |grid check button
|
||||
gC :: CheckButton
|
||||
gC :: CheckButton,
|
||||
-- |coord check button
|
||||
cC :: CheckButton
|
||||
}
|
||||
|
||||
|
||||
@ -76,13 +79,14 @@ makeMyGladeGUI = do
|
||||
aD' <- xmlGetWidget xml castToAboutDialog "aboutdialog"
|
||||
cB' <- xmlGetWidget xml castToComboBox "comboalgo"
|
||||
gC' <- xmlGetWidget xml castToCheckButton "gridcheckbutton"
|
||||
cC' <- xmlGetWidget xml castToCheckButton "coordcheckbutton"
|
||||
|
||||
return $ MkMyGUI win' dB' sB' qB' fB' da' hs'
|
||||
xl' xu' yl' yu' aD' cB' gC'
|
||||
xl' xu' yl' yu' aD' cB' gC' cC'
|
||||
|
||||
|
||||
gifCLI :: FilePath -> IO ()
|
||||
gifCLI startFile = do
|
||||
gifCLI _ = do
|
||||
mesh <- readFile "UB1_sonderfaelle.obj"
|
||||
gifMain (gifDiagS def mesh)
|
||||
|
||||
@ -206,6 +210,7 @@ drawDiag' fp mygui =
|
||||
alg' <- comboBoxGetActive (cB mygui)
|
||||
(daW, daH) <- widgetGetSize (da mygui)
|
||||
gd' <- toggleButtonGetActive (gC mygui)
|
||||
ct' <- toggleButtonGetActive (cC mygui)
|
||||
|
||||
let
|
||||
xD = (,) <$>
|
||||
@ -226,7 +231,8 @@ drawDiag' fp mygui =
|
||||
dX = xD',
|
||||
dY = yD',
|
||||
alg = alg',
|
||||
gd = gd'})
|
||||
gd = gd',
|
||||
ct = ct'})
|
||||
mesh)
|
||||
renderWithDrawable dw r
|
||||
return 0
|
||||
@ -252,6 +258,7 @@ saveDiag' fp mygui =
|
||||
alg' <- comboBoxGetActive (cB mygui)
|
||||
(daW, daH) <- widgetGetSize (da mygui)
|
||||
gd' <- toggleButtonGetActive (gC mygui)
|
||||
ct' <- toggleButtonGetActive (cC mygui)
|
||||
|
||||
let
|
||||
xD = (,) <$>
|
||||
@ -269,7 +276,8 @@ saveDiag' fp mygui =
|
||||
dX = xD',
|
||||
dY = yD',
|
||||
alg = alg',
|
||||
gd = gd'})
|
||||
gd = gd',
|
||||
ct = ct'})
|
||||
mesh)
|
||||
return 0
|
||||
_ -> return 1
|
||||
|
||||
30
gtk2.glade
30
gtk2.glade
@ -692,8 +692,7 @@ Malte Flender <malte.flender@fh-bielefeld.de></property>
|
||||
</packing>
|
||||
</child>
|
||||
<child>
|
||||
<widget class="GtkVBox" id="vbox7">
|
||||
<property name="width_request">100</property>
|
||||
<widget class="GtkVBox" id="vbox8">
|
||||
<property name="visible">True</property>
|
||||
<property name="can_focus">False</property>
|
||||
<child>
|
||||
@ -708,6 +707,10 @@ Malte Flender <malte.flender@fh-bielefeld.de></property>
|
||||
<property name="position">0</property>
|
||||
</packing>
|
||||
</child>
|
||||
<child>
|
||||
<widget class="GtkHBox" id="hbox6">
|
||||
<property name="visible">True</property>
|
||||
<property name="can_focus">False</property>
|
||||
<child>
|
||||
<widget class="GtkCheckButton" id="gridcheckbutton">
|
||||
<property name="label" translatable="yes">grid</property>
|
||||
@ -719,13 +722,34 @@ Malte Flender <malte.flender@fh-bielefeld.de></property>
|
||||
<packing>
|
||||
<property name="expand">False</property>
|
||||
<property name="fill">False</property>
|
||||
<property name="position">0</property>
|
||||
</packing>
|
||||
</child>
|
||||
<child>
|
||||
<widget class="GtkCheckButton" id="coordcheckbutton">
|
||||
<property name="label" translatable="yes">coord</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">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">False</property>
|
||||
<property name="fill">True</property>
|
||||
<property name="fill">False</property>
|
||||
<property name="position">3</property>
|
||||
</packing>
|
||||
</child>
|
||||
|
||||
Loading…
Reference in New Issue
Block a user