hasufell/cga
1
1
Fork 0
Code Issues Pull Requests Releases Wiki Activity

Refactor some function names for readability

Browse Source
This commit is contained in:
hasufell 2014-11-16 00:10:57 +01:00
parent bf596a5842
commit 3f3467cc44
No known key found for this signature in database
GPG Key ID: 220CD1C5BDEED020
4 changed files with 166 additions and 168 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

176
GUI/Gtk.hs
View File

@ -3,7 +3,7 @@
module GUI.Gtk (makeGUI) where module GUI.Gtk (makeGUI) where
import Control.Applicative import Control.Applicative
import Control.Monad import Control.Monad(unless)
import Control.Monad.IO.Class import Control.Monad.IO.Class
import Diagrams.Prelude import Diagrams.Prelude
import Diagrams.Backend.Cairo import Diagrams.Backend.Cairo
@ -24,41 +24,41 @@ import Text.Read
-- runtime. -- runtime.
data MyGUI = MkMyGUI { data MyGUI = MkMyGUI {
-- |main Window -- |main Window
win :: Window, rootWin :: Window,
-- |Tree Window -- |Tree Window
winT :: Window, treeWin :: Window,
-- |delete Button -- |delete Button
dB :: Button, delButton :: Button,
-- |save Button -- |save Button
sB :: Button, saveButton :: Button,
-- |quit Button -- |quit Button
qB :: Button, quitButton :: Button,
-- |file chooser button -- |file chooser button
fB :: FileChooserButton, fileButton :: FileChooserButton,
-- |drawing area -- |drawing area
da :: DrawingArea, mainDraw :: DrawingArea,
-- |drawing area for the tree -- |drawing area for the tree
daT :: DrawingArea, treeDraw :: DrawingArea,
-- |scaler for point thickness -- |scaler for point thickness
hs :: HScale, ptScale :: HScale,
-- |entry widget for lower x bound -- |entry widget for lower x bound
xl :: Entry, xminEntry :: Entry,
-- |entry widget for upper x bound -- |entry widget for upper x bound
xu :: Entry, xmaxEntry :: Entry,
-- |entry widget for lower y bound -- |entry widget for lower y bound
yl :: Entry, yminEntry :: Entry,
-- |entry widget for upper y bound -- |entry widget for upper y bound
yu :: Entry, ymaxEntry :: Entry,
-- |about dialog -- |about dialog
aD :: AboutDialog, aboutDialog :: AboutDialog,
-- |combo box for choosing the algorithm -- |combo box for choosing the algorithm
cB :: ComboBox, algoBox :: ComboBox,
-- |grid check button -- |grid check button
gC :: CheckButton, gridCheckBox :: CheckButton,
-- |coord check button -- |coord check button
cC :: CheckButton, coordCheckBox :: CheckButton,
-- |Path entry widget for the quad tree. -- |Path entry widget for the quad tree.
pE :: Entry, quadPathEntry :: Entry,
-- |Horizontal box containing the path entry widget. -- |Horizontal box containing the path entry widget.
vbox7 :: Box vbox7 :: Box
} }
@ -112,58 +112,58 @@ makeGUI startFile = do
-- adjust properties -- adjust properties
if startFile == "" if startFile == ""
then do then do
_ <- fileChooserSetCurrentFolder (fB mygui) homedir _ <- fileChooserSetCurrentFolder (fileButton mygui) homedir
return () return ()
else do else do
_ <- fileChooserSetFilename (fB mygui) startFile _ <- fileChooserSetFilename (fileButton mygui) startFile
return () return ()
comboBoxSetActive (cB mygui) 0 comboBoxSetActive (algoBox mygui) 0
-- callbacks -- callbacks
_ <- onDestroy (win mygui) mainQuit _ <- onDestroy (rootWin mygui) mainQuit
_ <- onClicked (dB mygui) $ drawDiag mygui _ <- onClicked (delButton mygui) $ drawDiag mygui
_ <- onClicked (sB mygui) $ saveDiag mygui _ <- onClicked (saveButton mygui) $ saveDiag mygui
_ <- onClicked (qB mygui) mainQuit _ <- onClicked (quitButton mygui) mainQuit
_ <- onResponse (aD mygui) (\x -> case x of _ <- onResponse (aboutDialog mygui) (\x -> case x of
ResponseCancel -> widgetHideAll (aD mygui) ResponseCancel -> widgetHideAll (aboutDialog mygui)
_ -> return ()) _ -> return ())
-- have to redraw for window overlapping and resizing on expose -- have to redraw for window overlapping and resizing on expose
_ <- onExpose (da mygui) (\_ -> drawDiag mygui >>= _ <- onExpose (mainDraw mygui) (\_ -> drawDiag mygui >>=
(\_ -> return True)) (\_ -> return True))
_ <- onExpose (daT mygui) (\_ -> drawDiag mygui >>= _ <- onExpose (treeDraw mygui) (\_ -> drawDiag mygui >>=
(\_ -> return True)) (\_ -> return True))
_ <- on (cB mygui) changed (drawDiag mygui) _ <- on (algoBox mygui) changed (drawDiag mygui)
_ <- on (cB mygui) changed (onPathWidgetChange mygui) _ <- on (algoBox mygui) changed (onAlgoBoxChange mygui)
_ <- on (gC mygui) toggled (drawDiag mygui) _ <- on (gridCheckBox mygui) toggled (drawDiag mygui)
_ <- on (cC mygui) toggled (drawDiag mygui) _ <- on (coordCheckBox mygui) toggled (drawDiag mygui)
-- hotkeys -- hotkeys
_ <- win mygui `on` keyPressEvent $ tryEvent $ do _ <- rootWin mygui `on` keyPressEvent $ tryEvent $ do
[Control] <- eventModifier [Control] <- eventModifier
"q" <- eventKeyName "q" <- eventKeyName
liftIO mainQuit liftIO mainQuit
_ <- winT mygui `on` keyPressEvent $ tryEvent $ do _ <- treeWin mygui `on` keyPressEvent $ tryEvent $ do
[Control] <- eventModifier [Control] <- eventModifier
"q" <- eventKeyName "q" <- eventKeyName
liftIO (widgetHide $ winT mygui) liftIO (widgetHide $ treeWin mygui)
_ <- win mygui `on` keyPressEvent $ tryEvent $ do _ <- rootWin mygui `on` keyPressEvent $ tryEvent $ do
[Control] <- eventModifier [Control] <- eventModifier
"s" <- eventKeyName "s" <- eventKeyName
liftIO $ saveDiag mygui liftIO $ saveDiag mygui
_ <- win mygui `on` keyPressEvent $ tryEvent $ do _ <- rootWin mygui `on` keyPressEvent $ tryEvent $ do
[Control] <- eventModifier [Control] <- eventModifier
"d" <- eventKeyName "d" <- eventKeyName
liftIO $ drawDiag mygui liftIO $ drawDiag mygui
_ <- win mygui `on` keyPressEvent $ tryEvent $ do _ <- rootWin mygui `on` keyPressEvent $ tryEvent $ do
[Control] <- eventModifier [Control] <- eventModifier
"a" <- eventKeyName "a" <- eventKeyName
liftIO $ widgetShowAll (aD mygui) liftIO $ widgetShowAll (aboutDialog mygui)
-- draw widgets and start main loop -- draw widgets and start main loop
widgetShowAll (win mygui) widgetShowAll (rootWin mygui)
widgetShowAll (winT mygui) widgetShowAll (treeWin mygui)
widgetHide (vbox7 mygui) widgetHide (vbox7 mygui)
widgetHide (winT mygui) widgetHide (treeWin mygui)
mainGUI mainGUI
@ -181,14 +181,14 @@ showErrorDialog str = do
-- |May hide or show the widget that holds the quad tree path entry, -- |May hide or show the widget that holds the quad tree path entry,
-- depending on the context and may also pop up the tree window. -- depending on the context and may also pop up the tree window.
onPathWidgetChange :: MyGUI onAlgoBoxChange :: MyGUI
-> IO () -> IO ()
onPathWidgetChange mygui = do onAlgoBoxChange mygui = do
item <- comboBoxGetActive (cB mygui) item <- comboBoxGetActive (algoBox mygui)
if item == 4 if item == 4
then do then do
widgetShow (vbox7 mygui) widgetShow (vbox7 mygui)
widgetShow (winT mygui) widgetShow (treeWin mygui)
else widgetHide (vbox7 mygui) else widgetHide (vbox7 mygui)
return () return ()
@ -198,7 +198,7 @@ onPathWidgetChange mygui = do
drawDiag :: MyGUI drawDiag :: MyGUI
-> IO () -> IO ()
drawDiag mygui = do drawDiag mygui = do
fp <- fileChooserGetFilename (fB mygui) fp <- fileChooserGetFilename (fileButton mygui)
case fp of case fp of
Just x -> do Just x -> do
ret <- saveAndDrawDiag x "" mygui ret <- saveAndDrawDiag x "" mygui
@ -213,7 +213,7 @@ drawDiag mygui = do
saveDiag :: MyGUI saveDiag :: MyGUI
-> IO () -> IO ()
saveDiag mygui = do saveDiag mygui = do
fp <- fileChooserGetFilename (fB mygui) fp <- fileChooserGetFilename (fileButton mygui)
case fp of case fp of
Just x -> do Just x -> do
ret <- saveAndDrawDiag x "out.svg" mygui ret <- saveAndDrawDiag x "out.svg" mygui
@ -233,55 +233,53 @@ saveAndDrawDiag :: FilePath -- ^ obj file to parse
saveAndDrawDiag fp fps mygui = saveAndDrawDiag fp fps mygui =
if cmpExt "obj" fp if cmpExt "obj" fp
then do then do
mesh <- readFile fp mesh <- readFile fp
dw <- widgetGetDrawWindow (da mygui) mainDrawWindow <- widgetGetDrawWindow (mainDraw mygui)
dwT <- widgetGetDrawWindow (daT mygui) treeDrawWindow <- widgetGetDrawWindow (treeDraw mygui)
adjustment <- rangeGetAdjustment (hs mygui) adjustment <- rangeGetAdjustment (ptScale mygui)
scaleVal <- adjustmentGetValue adjustment scaleVal <- adjustmentGetValue adjustment
xlD' <- entryGetText (xl mygui) xminEntryText <- entryGetText (xminEntry mygui)
xuD' <- entryGetText (xu mygui) xmaxEntryText <- entryGetText (xmaxEntry mygui)
ylD' <- entryGetText (yl mygui) yminEntryText <- entryGetText (yminEntry mygui)
yuD' <- entryGetText (yu mygui) ymaxEntryText <- entryGetText (ymaxEntry mygui)
alg' <- comboBoxGetActive (cB mygui) algoActive <- comboBoxGetActive (algoBox mygui)
(daW, daH) <- widgetGetSize (da mygui) (daW, daH) <- widgetGetSize (mainDraw mygui)
(daTW, daTH) <- widgetGetSize (daT mygui) (daTW, daTH) <- widgetGetSize (treeDraw mygui)
gd' <- toggleButtonGetActive (gC mygui) gridActive <- toggleButtonGetActive (gridCheckBox mygui)
ct' <- toggleButtonGetActive (cC mygui) coordTextActive <- toggleButtonGetActive (coordCheckBox mygui)
pE' <- entryGetText (pE mygui) quadPathEntry' <- entryGetText (quadPathEntry mygui)
let let
xD = (,) <$> xDim = (,) <$>
readMaybe xlD' <*> readMaybe xminEntryText <*>
readMaybe xuD' :: Maybe (Double, Double) readMaybe xmaxEntryText :: Maybe (Double, Double)
yD = (,) <$> yDim = (,) <$>
readMaybe ylD' <*> readMaybe yminEntryText <*>
readMaybe yuD' :: Maybe (Double, Double) readMaybe ymaxEntryText :: Maybe (Double, Double)
renderDiag winWidth winHeight buildDiag xD' yD' = renderDiag winWidth winHeight buildDiag xDim' yDim' =
renderDia Cairo renderDia Cairo
(CairoOptions fps (CairoOptions fps
(Dims (fromIntegral winWidth) (fromIntegral winHeight)) (Dims (fromIntegral winWidth) (fromIntegral winHeight))
SVG False) SVG False)
(buildDiag (def{ (buildDiag (def{
t = scaleVal, dotSize = scaleVal,
dX = xD', xDimension = xDim',
dY = yD', yDimension = yDim',
alg = alg', algo = algoActive,
gd = gd', haveGrid = gridActive,
ct = ct', showCoordText = coordTextActive,
pQt = pE'}) quadPath = quadPathEntry'})
mesh) mesh)
case (xD, yD) of case (xDim, yDim) of
(Just xD', Just yD') -> do (Just xDim', Just yDim') -> do
let (s, r) = renderDiag daW daH diagS xD' yD' let (s, r) = renderDiag daW daH diagS xDim' yDim'
let (_, r') = renderDiag daTW daTH diagTreeS xD' yD' let (_, r') = renderDiag daTW daTH diagTreeS xDim' yDim'
renderWithDrawable dw r renderWithDrawable mainDrawWindow r
renderWithDrawable dwT r' renderWithDrawable treeDrawWindow r'
if null fps unless (null fps) s
then return ()
else s
return 0 return 0
_ -> return 1 _ -> return 1

14
Graphics/Diagram/Gtk.hs
View File

@ -12,22 +12,22 @@ import Parser.Meshparser
-- |Create the Diagram from the points. -- |Create the Diagram from the points.
diag :: DiagProp -> Object -> Diagram Cairo R2 diag :: DiagProp -> Object -> Diagram Cairo R2
diag p obj@(Object _) diag p obj@(Object _)
| alg p == 0 = | algo p == 0 =
mkDiag (mconcat [coordPointsText, coordPoints, plotterBG]) mkDiag (mconcat [coordPointsText, coordPoints, plotterBG])
p obj p obj
| alg p == 1 = | algo p == 1 =
mkDiag (mconcat [convexHPText, convexHP, convexHLs, coordPoints, plotterBG]) mkDiag (mconcat [convexHPText, convexHP, convexHLs, coordPoints, plotterBG])
p obj p obj
| alg p == 4 = | algo p == 4 =
mkDiag (mconcat [quadPathSquare, squares, coordPointsText, mkDiag (mconcat [quadPathSquare, squares, coordPointsText,
coordPoints, polyLines, plotterBG]) coordPoints, polyLines, plotterBG])
p obj p obj
| otherwise = mempty | otherwise = mempty
diag p objs@(Objects _) diag p objs@(Objects _)
| alg p == 2 = | algo p == 2 =
mkDiag (mconcat [polyLines, coordPointsText, coordPoints, plotterBG]) mkDiag (mconcat [polyLines, coordPointsText, coordPoints, plotterBG])
p objs p objs
| alg p == 3 = | algo p == 3 =
mkDiag (mconcat [polyIntersectionText, polyIntersection, mkDiag (mconcat [polyIntersectionText, polyIntersection,
coordPoints, polyLines, plotterBG]) coordPoints, polyLines, plotterBG])
p objs p objs
@ -38,7 +38,7 @@ diag p objs@(Objects _)
-- of an obj file. -- of an obj file.
diagS :: DiagProp -> MeshString -> Diagram Cairo R2 diagS :: DiagProp -> MeshString -> Diagram Cairo R2
diagS p mesh diagS p mesh
| alg p == 2 || alg p == 3 = diag p. Objects . facesToArr $ mesh | algo p == 2 || algo p == 3 = diag p. Objects . facesToArr $ mesh
| otherwise = (diag p . Object . meshToArr $ mesh) # bg white | otherwise = (diag p . Object . meshToArr $ mesh) # bg white
@ -46,5 +46,5 @@ diagS p mesh
-- of an obj file. -- of an obj file.
diagTreeS :: DiagProp -> MeshString -> Diagram Cairo R2 diagTreeS :: DiagProp -> MeshString -> Diagram Cairo R2
diagTreeS p mesh diagTreeS p mesh
| alg p == 4 = mkDiag treePretty p (Object . meshToArr $mesh) | algo p == 4 = mkDiag treePretty p (Object . meshToArr $mesh)
| otherwise = mempty | otherwise = mempty

88
Graphics/Diagram/Plotter.hs
View File

@ -29,7 +29,7 @@ coordPoints = Diag cp
position (zip (filterValidPT p vt) position (zip (filterValidPT p vt)
(repeat dot)) (repeat dot))
where where
dot = (circle $ t p :: Diagram Cairo R2) # fc black dot = (circle $ dotSize p :: Diagram Cairo R2) # fc black
-- |Creates a Diagram from a point that shows the coordinates -- |Creates a Diagram from a point that shows the coordinates
@ -52,7 +52,7 @@ coordPointsText = Diag cpt
cpt p (Objects vts) = drawT (concat vts) p cpt p (Objects vts) = drawT (concat vts) p
drawT [] _ = mempty drawT [] _ = mempty
drawT vt p drawT vt p
| ct p = | showCoordText p =
position $ position $
zip vtf (pointToTextCoord <$> vtf) # translate (r2 (0, 10)) zip vtf (pointToTextCoord <$> vtf) # translate (r2 (0, 10))
| otherwise = mempty | otherwise = mempty
@ -86,7 +86,7 @@ polyIntersection = Diag pi'
where where
paF = filterValidPT p x paF = filterValidPT p x
pbF = filterValidPT p y pbF = filterValidPT p y
dot = (circle $ t p :: Diagram Cairo R2) # fc red # lc red dot = (circle $ dotSize p :: Diagram Cairo R2) # fc red # lc red
vtpi = intersectionPoints vtpi = intersectionPoints
. sortLexPolys . sortLexPolys
$ (sortLexPoly paF, sortLexPoly pbF) $ (sortLexPoly paF, sortLexPoly pbF)
@ -98,7 +98,7 @@ polyIntersectionText :: Diag
polyIntersectionText = Diag pit' polyIntersectionText = Diag pit'
where where
pit' p (Objects (x:y:_)) pit' p (Objects (x:y:_))
| ct p = | showCoordText p =
position $ position $
zip vtpi zip vtpi
(pointToTextCoord # fc red <$> vtpi) # translate (r2 (0, 10)) (pointToTextCoord # fc red <$> vtpi) # translate (r2 (0, 10))
@ -120,7 +120,7 @@ convexHP = Diag chp
position (zip vtch position (zip vtch
(repeat dot)) (repeat dot))
where where
dot = (circle $ t p :: Diagram Cairo R2) # fc red # lc red dot = (circle $ dotSize p :: Diagram Cairo R2) # fc red # lc red
vtch = grahamCH $ filterValidPT p vt vtch = grahamCH $ filterValidPT p vt
chp _ _ = mempty chp _ _ = mempty
@ -130,7 +130,7 @@ convexHPText :: Diag
convexHPText = Diag chpt convexHPText = Diag chpt
where where
chpt p (Object vt) chpt p (Object vt)
| ct p = | showCoordText p =
position $ position $
zip vtchf zip vtchf
(pointToTextCoord <$> vtchf) # translate (r2 (0, 10)) (pointToTextCoord <$> vtchf) # translate (r2 (0, 10))
@ -182,7 +182,7 @@ squares = Diag f
mconcat mconcat
$ (\((xmin', xmax'), (ymin', ymax')) -> rect (xmax' - xmin') (ymax' - ymin') $ (\((xmin', xmax'), (ymin', ymax')) -> rect (xmax' - xmin') (ymax' - ymin')
# moveTo (p2 ((xmax' + xmin') / 2, (ymax' + ymin') / 2)) # lw ultraThin) # moveTo (p2 ((xmax' + xmin') / 2, (ymax' + ymin') / 2)) # lw ultraThin)
<$> (quadTreeSquares (dX p, dY p) . quadTree vtf $ (dX p, dY p)) <$> (quadTreeSquares (xDimension p, yDimension p) . quadTree vtf $ (xDimension p, yDimension p))
where where
vtf = filterValidPT p vt vtf = filterValidPT p vt
f _ _ = mempty f _ _ = mempty
@ -191,11 +191,11 @@ squares = Diag f
-- |Get the quad tree corresponding to the given points and diagram properties. -- |Get the quad tree corresponding to the given points and diagram properties.
qt :: [PT] -> DiagProp -> QuadTree PT qt :: [PT] -> DiagProp -> QuadTree PT
qt vt p = quadTree (filterValidPT p vt) (dX p, dY p) qt vt p = quadTree (filterValidPT p vt) (xDimension p, yDimension p)
-- |Create a diagram that shows a single square of the RangeSearch algorithm -- |Create a diagram that shows a single square of the RangeSearch algorithm
-- from the quad tree in red, according to the given path in pQt. -- from the quad tree in red, according to the given path in quadPath.
quadPathSquare :: Diag quadPathSquare :: Diag
quadPathSquare = Diag f quadPathSquare = Diag f
where where
@ -203,10 +203,10 @@ quadPathSquare = Diag f
f p (Object vt) = f p (Object vt) =
(\((xmin', xmax'), (ymin', ymax')) -> rect (xmax' - xmin') (ymax' - ymin') (\((xmin', xmax'), (ymin', ymax')) -> rect (xmax' - xmin') (ymax' - ymin')
# moveTo (p2 ((xmax' + xmin') / 2,(ymax' + ymin') / 2)) # lw thin # lc red) # moveTo (p2 ((xmax' + xmin') / 2,(ymax' + ymin') / 2)) # lw thin # lc red)
(getSquare (stringToQuads (pQt p)) (qt vt p, [])) (getSquare (stringToQuads (quadPath p)) (qt vt p, []))
where where
getSquare :: [Either Quad Orient] -> Zipper PT -> Square getSquare :: [Either Quad Orient] -> Zipper PT -> Square
getSquare [] z = getSquareByZipper (dX p, dY p) z getSquare [] z = getSquareByZipper (xDimension p, yDimension p) z
getSquare (q:qs) z = case q of getSquare (q:qs) z = case q of
Right x -> getSquare qs (fromMaybe z (findNeighbor x z)) Right x -> getSquare qs (fromMaybe z (findNeighbor x z))
Left x -> getSquare qs (fromMaybe z (goQuad x z)) Left x -> getSquare qs (fromMaybe z (goQuad x z))
@ -221,14 +221,14 @@ gifQuadPath = GifDiag f
f p col _ vt = f p col _ vt =
(\((xmin', xmax'), (ymin', ymax')) -> rect (xmax' - xmin') (ymax' - ymin') (\((xmin', xmax'), (ymin', ymax')) -> rect (xmax' - xmin') (ymax' - ymin')
# moveTo (p2 ((xmax' + xmin') / 2,(ymax' + ymin') / 2)) # lw thick # lc col) # moveTo (p2 ((xmax' + xmin') / 2,(ymax' + ymin') / 2)) # lw thick # lc col)
<$> getSquares (stringToQuads (pQt p)) (qt vt p, []) <$> getSquares (stringToQuads (quadPath p)) (qt vt p, [])
where where
getSquares :: [Either Quad Orient] -> Zipper PT -> [Square] getSquares :: [Either Quad Orient] -> Zipper PT -> [Square]
getSquares [] z = [getSquareByZipper (dX p, dY p) z] getSquares [] z = [getSquareByZipper (xDimension p, yDimension p) z]
getSquares (q:qs) z = case q of getSquares (q:qs) z = case q of
Right x -> getSquareByZipper (dX p, dY p) z : Right x -> getSquareByZipper (xDimension p, yDimension p) z :
getSquares qs (fromMaybe z (findNeighbor x z)) getSquares qs (fromMaybe z (findNeighbor x z))
Left x -> getSquareByZipper (dX p, dY p) z : Left x -> getSquareByZipper (xDimension p, yDimension p) z :
getSquares qs (fromMaybe z (goQuad x z)) getSquares qs (fromMaybe z (goQuad x z))
@ -238,7 +238,7 @@ treePretty = Diag f
where where
f _ (Object []) = mempty f _ (Object []) = mempty
f p (Object vt) = f p (Object vt) =
prettyRoseTree (quadTreeToRoseTree . flip getCurQT (qt vt p, []) . stringToQuads . pQt $ p) prettyRoseTree (quadTreeToRoseTree . flip getCurQT (qt vt p, []) . stringToQuads . quadPath $ p)
where where
getCurQT :: [Either Quad Orient] -> Zipper PT -> Zipper PT getCurQT :: [Either Quad Orient] -> Zipper PT -> Zipper PT
getCurQT [] z = z getCurQT [] z = z
@ -269,23 +269,23 @@ xAxis =
Diag labels Diag labels
where where
hRule p _ = hRule p _ =
arrowAt (p2 (xmin p, if ymin p <= 0 then 0 else ymin p)) arrowAt (p2 (diagXmin p, if diagYmin p <= 0 then 0 else diagYmin p))
(r2 (w' p, 0)) (r2 (diagWidth p, 0))
segments p _ = segments p _ =
hcat' (with & sep .~ sqS p) hcat' (with & sep .~ squareSize p)
(replicate (floor . (/) (w' p) $ sqS p) (replicate (floor . (/) (diagWidth p) $ squareSize p)
(vrule 10)) # (vrule 10)) #
moveTo (p2 (xmin p, if ymin p <= 0 then 0 else ymin p)) moveTo (p2 (diagXmin p, if diagYmin p <= 0 then 0 else diagYmin p))
labels p _ = labels p _ =
position $ position $
zip (mkPoint <$> xs) zip (mkPoint <$> xs)
((\x -> (text . show $ x) # scale 10) <$> xs) ((\x -> (text . show $ x) # scale 10) <$> xs)
where where
xs :: [Int] xs :: [Int]
xs = take (floor . (/) (w' p) $ sqS p) xs = take (floor . (/) (diagWidth p) $ squareSize p)
(iterate (+(floor . sqS $ p)) (floor . xmin $ p)) (iterate (+(floor . squareSize $ p)) (floor . diagXmin $ p))
mkPoint x = p2 (fromIntegral x, mkPoint x = p2 (fromIntegral x,
-15 + (if ymin p <= 0 then 0 else ymin p)) -15 + (if diagYmin p <= 0 then 0 else diagYmin p))
-- |Creates a Diagram that shows an YAxis which is bound -- |Creates a Diagram that shows an YAxis which is bound
@ -297,23 +297,23 @@ yAxis =
Diag labels Diag labels
where where
vRule p _ = vRule p _ =
arrowAt (p2 (if xmin p <= 0 then 0 else xmin p, ymin p)) arrowAt (p2 (if diagXmin p <= 0 then 0 else diagXmin p, diagYmin p))
(r2 (0, h' p)) (r2 (0, diagHeight p))
segments p _ = segments p _ =
vcat' (with & sep .~ sqS p) vcat' (with & sep .~ squareSize p)
(replicate (floor . (/) (h' p) $ sqS p) (replicate (floor . (/) (diagHeight p) $ squareSize p)
(hrule 10)) # (hrule 10)) #
alignB # alignB #
moveTo (p2 (if xmin p <= 0 then 0 else xmin p, ymin p)) moveTo (p2 (if diagXmin p <= 0 then 0 else diagXmin p, diagYmin p))
labels p _ = labels p _ =
position $ position $
zip (mkPoint <$> ys) zip (mkPoint <$> ys)
((\x -> (text . show $ x) # scale 10) <$> ys) ((\x -> (text . show $ x) # scale 10) <$> ys)
where where
ys :: [Int] ys :: [Int]
ys = take (floor . (/) (h' p) $ sqS p) ys = take (floor . (/) (diagHeight p) $ squareSize p)
(iterate (+(floor . sqS $ p)) (floor . ymin $ p)) (iterate (+(floor . squareSize $ p)) (floor . diagYmin $ p))
mkPoint y = p2 (-15 + (if xmin p <= 0 then 0 else xmin p), mkPoint y = p2 (-15 + (if diagXmin p <= 0 then 0 else diagXmin p),
fromIntegral y) fromIntegral y)
@ -323,8 +323,8 @@ whiteRectB :: Diag
whiteRectB = Diag rect' whiteRectB = Diag rect'
where where
rect' p _ = rect' p _ =
whiteRect (w' p + (w' p / 10)) (h' p + (h' p / 10)) # whiteRect (diagWidth p + (diagWidth p / 10)) (diagHeight p + (diagHeight p / 10)) #
moveTo (p2 (wOff p, hOff p)) moveTo (p2 (diagWidthOffset p, diagHeightOffset p))
where where
@ -339,20 +339,20 @@ grid :: Diag
grid = Diag xGrid <> Diag yGrid grid = Diag xGrid <> Diag yGrid
where where
yGrid p _ yGrid p _
| gd p = | haveGrid p =
hcat' (with & sep .~ sqS p) hcat' (with & sep .~ squareSize p)
(replicate (floor . (/) (w' p) $ sqS p) (replicate (floor . (/) (diagWidth p) $ squareSize p)
(vrule $ h' p)) # (vrule $ diagHeight p)) #
moveTo (p2 (xmin p, hOff p)) # moveTo (p2 (diagXmin p, diagHeightOffset p)) #
lw ultraThin lw ultraThin
| otherwise = mempty | otherwise = mempty
xGrid p _ xGrid p _
| gd p = | haveGrid p =
vcat' (with & sep .~ sqS p) vcat' (with & sep .~ squareSize p)
(replicate (floor . (/) (h' p) $ sqS p) (replicate (floor . (/) (diagHeight p) $ squareSize p)
(hrule $ w' p)) # (hrule $ diagWidth p)) #
alignB # alignB #
moveTo (p2 (wOff p, ymin p)) # moveTo (p2 (diagWidthOffset p, diagYmin p)) #
lw ultraThin lw ultraThin
| otherwise = mempty | otherwise = mempty

56
Graphics/Diagram/Types.hs
View File

@ -41,26 +41,26 @@ data Object = Object [PT]
-- This can also be seen as a context when merging multiple diagrams. -- This can also be seen as a context when merging multiple diagrams.
data DiagProp = MkProp { data DiagProp = MkProp {
-- |The thickness of the dots. -- |The thickness of the dots.
t :: Double, dotSize :: Double,
-- |The dimensions of the x-axis. -- |The dimensions of the x-axis.
dX :: Coord, xDimension :: Coord,
-- |The dimensions of the y-axis. -- |The dimensions of the y-axis.
dY :: Coord, yDimension :: Coord,
-- |Algorithm to use. -- |Algorithm to use.
alg :: Int, algo :: Int,
-- |If we want to show the grid. -- |If we want to show the grid.
gd :: Bool, haveGrid :: Bool,
-- |If we want to show the coordinates as text. -- |If we want to show the coordinates as text.
ct :: Bool, showCoordText :: Bool,
-- |Square size used to show the grid and x/y-axis. -- |Square size used to show the grid and x/y-axis.
sqS :: Double, squareSize :: Double,
-- |The path to a quad in the quad tree. -- |The path to a quad in the quad tree.
pQt :: String quadPath :: String
} }
instance Def DiagProp where instance Def DiagProp where
def = defaultProp def = diagDefaultProp
instance Monoid Diag where instance Monoid Diag where
@ -84,50 +84,50 @@ instance Monoid Diag where
-- |The default properties of the Diagram. -- |The default properties of the Diagram.
defaultProp :: DiagProp diagDefaultProp :: DiagProp
defaultProp = MkProp 2 (0,500) (0,500) 0 False False 50 "" diagDefaultProp = MkProp 2 (0,500) (0,500) 0 False False 50 ""
-- |Extract the lower bound of the x-axis dimension. -- |Extract the lower bound of the x-axis dimension.
xmin :: DiagProp -> Double diagXmin :: DiagProp -> Double
xmin = fst . dX diagXmin = fst . xDimension
-- |Extract the upper bound of the x-axis dimension. -- |Extract the upper bound of the x-axis dimension.
xmax :: DiagProp -> Double diagXmax :: DiagProp -> Double
xmax = snd . dX diagXmax = snd . xDimension
-- |Extract the lower bound of the y-axis dimension. -- |Extract the lower bound of the y-axis dimension.
ymin :: DiagProp -> Double diagYmin :: DiagProp -> Double
ymin = fst . dY diagYmin = fst . yDimension
-- |Extract the upper bound of the y-axis dimension. -- |Extract the upper bound of the y-axis dimension.
ymax :: DiagProp -> Double diagYmax :: DiagProp -> Double
ymax = snd . dY diagYmax = snd . yDimension
-- |The full width of the x dimension. -- |The full width of the x dimension.
w' :: DiagProp -> Double diagWidth :: DiagProp -> Double
w' p = xmax p - xmin p diagWidth p = diagXmax p - diagXmin p
-- |The full height of the y dimension. -- |The full height of the y dimension.
h' :: DiagProp -> Double diagHeight :: DiagProp -> Double
h' p = ymax p - ymin p diagHeight p = diagYmax p - diagYmin p
-- |The offset on the x-axis to move the grid and the white rectangle -- |The offset on the x-axis to move the grid and the white rectangle
-- to the right place. -- to the right place.
wOff :: DiagProp -> Double diagWidthOffset :: DiagProp -> Double
wOff p = xmin p + (w' p / 2) diagWidthOffset p = diagXmin p + (diagWidth p / 2)
-- |The offset on the y-axis to move the grid and the white rectangle -- |The offset on the y-axis to move the grid and the white rectangle
-- to the right place. -- to the right place.
hOff :: DiagProp -> Double diagHeightOffset :: DiagProp -> Double
hOff p = ymin p + (h' p / 2) diagHeightOffset p = diagYmin p + (diagWidth p / 2)
-- |Returns the specified diagram if True is passed, -- |Returns the specified diagram if True is passed,
@ -140,4 +140,4 @@ maybeDiag b d
filterValidPT :: DiagProp -> [PT] -> [PT] filterValidPT :: DiagProp -> [PT] -> [PT]
filterValidPT p = filter (inRange (dX p, dY p)) filterValidPT p = filter (inRange (xDimension p, yDimension p))