Improve function names
This commit is contained in:
parent
dfb25a7a1d
commit
207360b4a5
33
Diagram.hs
33
Diagram.hs
@ -93,9 +93,9 @@ yuD = snd . dY
|
|||||||
-- as dots. The points and thickness of the dots can be controlled
|
-- as dots. The points and thickness of the dots can be controlled
|
||||||
-- via DiagProp.
|
-- via DiagProp.
|
||||||
coordPoints :: Diag
|
coordPoints :: Diag
|
||||||
coordPoints = Diag f
|
coordPoints = Diag cp
|
||||||
where
|
where
|
||||||
f p vt =
|
cp p vt =
|
||||||
position (zip (filter (inRange (dX p) (dY p)) $ vt)
|
position (zip (filter (inRange (dX p) (dY p)) $ vt)
|
||||||
(repeat dot))
|
(repeat dot))
|
||||||
where
|
where
|
||||||
@ -104,9 +104,9 @@ coordPoints = Diag f
|
|||||||
|
|
||||||
-- |Create a diagram which shows the points of the convex hull.
|
-- |Create a diagram which shows the points of the convex hull.
|
||||||
convexHullPoints :: Diag
|
convexHullPoints :: Diag
|
||||||
convexHullPoints = Diag f
|
convexHullPoints = Diag chp
|
||||||
where
|
where
|
||||||
f p vt =
|
chp p vt =
|
||||||
position (zip (filter (inRange (dX p) (dY p)) $ vtch)
|
position (zip (filter (inRange (dX p) (dY p)) $ vtch)
|
||||||
(repeat dot))
|
(repeat dot))
|
||||||
where
|
where
|
||||||
@ -117,10 +117,10 @@ convexHullPoints = Diag f
|
|||||||
-- |Create a diagram which shows the lines along the convex hull
|
-- |Create a diagram which shows the lines along the convex hull
|
||||||
-- points.
|
-- points.
|
||||||
convexHullLines :: Diag
|
convexHullLines :: Diag
|
||||||
convexHullLines = Diag f
|
convexHullLines = Diag chl
|
||||||
where
|
where
|
||||||
f _ [] = mempty
|
chl _ [] = mempty
|
||||||
f p vt =
|
chl p vt =
|
||||||
(strokeTrail .
|
(strokeTrail .
|
||||||
fromVertices .
|
fromVertices .
|
||||||
flip (++) [head $ grahamGetCH vtf] .
|
flip (++) [head $ grahamGetCH vtf] .
|
||||||
@ -137,9 +137,9 @@ convexHullLines = Diag f
|
|||||||
-- Unfortunately this is very difficult to implement as a Diag (TODO).
|
-- Unfortunately this is very difficult to implement as a Diag (TODO).
|
||||||
convexHullLinesInterval :: DiagProp -> [PT] -> [Diagram Cairo R2]
|
convexHullLinesInterval :: DiagProp -> [PT] -> [Diagram Cairo R2]
|
||||||
convexHullLinesInterval p xs =
|
convexHullLinesInterval p xs =
|
||||||
fmap g (grahamGetCHSteps xs)
|
fmap mkChDiag (grahamGetCHSteps xs)
|
||||||
where
|
where
|
||||||
g vt =
|
mkChDiag vt =
|
||||||
(strokeTrail .
|
(strokeTrail .
|
||||||
fromVertices $
|
fromVertices $
|
||||||
vtf) #
|
vtf) #
|
||||||
@ -207,9 +207,9 @@ yAxis =
|
|||||||
-- |Creates a Diagram that shows a white rectangle which is a little
|
-- |Creates a Diagram that shows a white rectangle which is a little
|
||||||
-- bit bigger as both X and Y axis dimensions from DiagProp.
|
-- bit bigger as both X and Y axis dimensions from DiagProp.
|
||||||
whiteRectB :: Diag
|
whiteRectB :: Diag
|
||||||
whiteRectB = Diag f
|
whiteRectB = Diag rect'
|
||||||
where
|
where
|
||||||
f p _ = whiteRect (w' + 50) (h' + 50) # moveTo (p2 (w' / 2, h' / 2))
|
rect' p _ = whiteRect (w' + 50) (h' + 50) # moveTo (p2 (w' / 2, h' / 2))
|
||||||
where
|
where
|
||||||
w' = xuD p - xlD p
|
w' = xuD p - xlD p
|
||||||
h' = yuD p - ylD p
|
h' = yuD p - ylD p
|
||||||
@ -246,13 +246,14 @@ diagS p mesh =
|
|||||||
gifDiag :: DiagProp -> [PT] -> [(Diagram Cairo R2, GifDelay)]
|
gifDiag :: DiagProp -> [PT] -> [(Diagram Cairo R2, GifDelay)]
|
||||||
gifDiag p xs =
|
gifDiag p xs =
|
||||||
fmap (\x -> (x, 100)) .
|
fmap (\x -> (x, 100)) .
|
||||||
fmap (\x -> x <> g) .
|
fmap (\x -> x <> nonChDiag) .
|
||||||
flip (++)
|
flip (++)
|
||||||
[mkDiag (convexHullLines `mappend`
|
[mkDiag (convexHullLines `mappend`
|
||||||
convexHullPoints) p xs] $
|
convexHullPoints) p xs] $
|
||||||
(convexHullLinesInterval p xs)
|
(convexHullLinesInterval p xs)
|
||||||
where
|
where
|
||||||
g =
|
-- add the x-axis and the other default stuff
|
||||||
|
nonChDiag =
|
||||||
mconcat .
|
mconcat .
|
||||||
fmap (\x -> mkDiag x p xs) $
|
fmap (\x -> mkDiag x p xs) $
|
||||||
[coordPoints,
|
[coordPoints,
|
||||||
@ -274,15 +275,15 @@ whiteRect x y = rect x y # lwG 0.00 # bg white
|
|||||||
|
|
||||||
-- |Create a grid across the whole diagram with 50*50 squares.
|
-- |Create a grid across the whole diagram with 50*50 squares.
|
||||||
grid :: Diag
|
grid :: Diag
|
||||||
grid = Diag f `mappend` Diag g
|
grid = Diag xGrid `mappend` Diag yGrid
|
||||||
where
|
where
|
||||||
f p _ =
|
yGrid p _ =
|
||||||
hcat' (with & sep .~ (sqS p))
|
hcat' (with & sep .~ (sqS p))
|
||||||
(take (floor . (/) (xuD p - xlD p) $ (sqS p)) .
|
(take (floor . (/) (xuD p - xlD p) $ (sqS p)) .
|
||||||
repeat $ (vrule $ xuD p - xlD p)) #
|
repeat $ (vrule $ xuD p - xlD p)) #
|
||||||
moveTo (p2 (xlD p, (yuD p - ylD p) / 2)) #
|
moveTo (p2 (xlD p, (yuD p - ylD p) / 2)) #
|
||||||
lw ultraThin
|
lw ultraThin
|
||||||
g p _ =
|
xGrid p _ =
|
||||||
vcat' (with & sep .~ (sqS p))
|
vcat' (with & sep .~ (sqS p))
|
||||||
(take (floor . (/) (yuD p - ylD p) $ (sqS p)) .
|
(take (floor . (/) (yuD p - ylD p) $ (sqS p)) .
|
||||||
repeat $ (hrule $ yuD p - ylD p)) #
|
repeat $ (hrule $ yuD p - ylD p)) #
|
||||||
|
Loading…
Reference in New Issue
Block a user