2014-10-06 21:14:23 +00:00
|
|
|
{-# OPTIONS_HADDOCK ignore-exports #-}
|
|
|
|
|
2014-10-06 20:15:10 +00:00
|
|
|
module Diagram (t,
|
|
|
|
dX,
|
|
|
|
dY,
|
|
|
|
alg,
|
2014-10-09 16:45:37 +00:00
|
|
|
gd,
|
2014-10-06 20:15:10 +00:00
|
|
|
defaultProp,
|
|
|
|
diag,
|
|
|
|
diagS,
|
2014-10-09 01:10:21 +00:00
|
|
|
gifDiag,
|
|
|
|
gifDiagS,
|
2014-10-06 20:15:10 +00:00
|
|
|
whiteRect) where
|
2014-09-30 22:05:29 +00:00
|
|
|
|
2014-10-08 14:39:46 +00:00
|
|
|
import Algorithms.ConvexHull
|
2014-10-09 01:10:21 +00:00
|
|
|
import Codec.Picture.Gif
|
2014-10-07 17:18:16 +00:00
|
|
|
import Class.Defaults
|
2014-09-30 22:05:29 +00:00
|
|
|
import Diagrams.Backend.Cairo
|
2014-10-09 01:10:21 +00:00
|
|
|
import Diagrams.Prelude
|
2014-10-07 17:12:07 +00:00
|
|
|
import LinearAlgebra.Vector
|
|
|
|
import Parser.Meshparser
|
2014-09-30 22:05:29 +00:00
|
|
|
|
|
|
|
|
2014-10-09 22:23:58 +00:00
|
|
|
type MeshString = String
|
|
|
|
|
|
|
|
|
2014-10-06 21:31:13 +00:00
|
|
|
-- |Represents a Cairo Diagram. This allows us to create multiple
|
2014-10-06 19:11:28 +00:00
|
|
|
-- diagrams with different algorithms but based on the same
|
|
|
|
-- coordinates and common properties.
|
|
|
|
data Diag = Diag {
|
2014-10-06 21:02:09 +00:00
|
|
|
mkDiag :: DiagProp
|
2014-10-08 14:31:57 +00:00
|
|
|
-> [PT]
|
2014-10-06 21:02:09 +00:00
|
|
|
-> Diagram Cairo R2
|
2014-10-06 19:11:28 +00:00
|
|
|
}
|
2014-10-05 13:50:42 +00:00
|
|
|
|
|
|
|
|
2014-10-01 21:02:43 +00:00
|
|
|
-- |Holds the properties for a Diagram, like thickness of 2d points etc.
|
2014-10-09 19:37:58 +00:00
|
|
|
-- This can also be seen as a context when merging multiple diagrams.
|
2014-10-01 19:48:31 +00:00
|
|
|
data DiagProp = MkProp {
|
2014-10-05 16:09:24 +00:00
|
|
|
-- |The thickness of the dots.
|
|
|
|
t :: Double,
|
|
|
|
-- |The dimensions of the x-axis.
|
2014-10-08 14:31:57 +00:00
|
|
|
dX :: Coord,
|
2014-10-05 16:09:24 +00:00
|
|
|
-- |The dimensions of the y-axis.
|
2014-10-08 14:31:57 +00:00
|
|
|
dY :: Coord,
|
2014-10-06 19:11:28 +00:00
|
|
|
-- |Algorithm to use.
|
2014-10-09 16:45:37 +00:00
|
|
|
alg :: Int,
|
|
|
|
-- |If we want to show the grid.
|
2014-10-09 22:30:56 +00:00
|
|
|
gd :: Bool,
|
|
|
|
-- |Square size used to show the grid and x/y-axis.
|
|
|
|
sqS :: Double
|
2014-10-01 19:48:31 +00:00
|
|
|
}
|
|
|
|
|
|
|
|
|
2014-10-06 19:11:28 +00:00
|
|
|
instance Def DiagProp where
|
2014-10-09 22:19:05 +00:00
|
|
|
def = defaultProp
|
2014-10-06 19:11:28 +00:00
|
|
|
|
|
|
|
|
|
|
|
instance Monoid Diag where
|
2014-10-08 22:59:18 +00:00
|
|
|
mempty = Diag (\_ _ -> mempty)
|
2014-10-06 19:11:28 +00:00
|
|
|
mappend d1 d2 = Diag g
|
|
|
|
where
|
2014-10-08 17:21:47 +00:00
|
|
|
g p vt = mkDiag d1 p vt <> mkDiag d2 p vt
|
2014-10-06 19:11:28 +00:00
|
|
|
mconcat = foldr mappend mempty
|
|
|
|
|
|
|
|
|
2014-10-05 13:50:42 +00:00
|
|
|
-- |The default properties of the Diagram.
|
|
|
|
defaultProp :: DiagProp
|
2014-10-09 22:30:56 +00:00
|
|
|
defaultProp = MkProp 2 (0,500) (0,500) 0 False 50
|
2014-10-05 13:50:42 +00:00
|
|
|
|
|
|
|
|
2014-10-06 19:11:28 +00:00
|
|
|
-- |Extract the lower bound of the x-axis dimension.
|
|
|
|
xlD :: DiagProp -> Double
|
|
|
|
xlD = fst . dX
|
|
|
|
|
|
|
|
|
|
|
|
-- |Extract the upper bound of the x-axis dimension.
|
|
|
|
xuD :: DiagProp -> Double
|
|
|
|
xuD = snd . dX
|
|
|
|
|
|
|
|
|
|
|
|
-- |Extract the lower bound of the y-axis dimension.
|
|
|
|
ylD :: DiagProp -> Double
|
|
|
|
ylD = fst . dY
|
|
|
|
|
|
|
|
|
|
|
|
-- |Extract the upper bound of the y-axis dimension.
|
|
|
|
yuD :: DiagProp -> Double
|
|
|
|
yuD = snd . dY
|
|
|
|
|
|
|
|
|
2014-10-08 17:23:40 +00:00
|
|
|
-- |Creates a Diagram that shows the coordinates from the points
|
|
|
|
-- as dots. The points and thickness of the dots can be controlled
|
2014-10-06 19:11:28 +00:00
|
|
|
-- via DiagProp.
|
2014-10-09 15:19:58 +00:00
|
|
|
coordPoints :: Diag
|
2014-10-09 22:42:15 +00:00
|
|
|
coordPoints = Diag cp
|
2014-10-06 19:11:28 +00:00
|
|
|
where
|
2014-10-09 22:42:15 +00:00
|
|
|
cp p vt =
|
2014-10-09 22:19:05 +00:00
|
|
|
position (zip (filter (inRange (dX p) (dY p)) $ vt)
|
|
|
|
(repeat dot))
|
|
|
|
where
|
|
|
|
dot = (circle $ t p :: Diagram Cairo R2) # fc black
|
2014-10-06 19:11:28 +00:00
|
|
|
|
|
|
|
|
2014-10-08 14:39:46 +00:00
|
|
|
-- |Create a diagram which shows the points of the convex hull.
|
2014-10-09 15:19:58 +00:00
|
|
|
convexHullPoints :: Diag
|
2014-10-09 22:42:15 +00:00
|
|
|
convexHullPoints = Diag chp
|
2014-10-08 14:39:46 +00:00
|
|
|
where
|
2014-10-09 22:42:15 +00:00
|
|
|
chp p vt =
|
2014-10-09 22:19:05 +00:00
|
|
|
position (zip (filter (inRange (dX p) (dY p)) $ vtch)
|
|
|
|
(repeat dot))
|
|
|
|
where
|
|
|
|
dot = (circle $ t p :: Diagram Cairo R2) # fc red # lc red
|
|
|
|
vtch = grahamGetCH vt
|
2014-10-08 14:39:46 +00:00
|
|
|
|
|
|
|
|
2014-10-09 01:10:21 +00:00
|
|
|
-- |Create a diagram which shows the lines along the convex hull
|
|
|
|
-- points.
|
2014-10-09 15:19:58 +00:00
|
|
|
convexHullLines :: Diag
|
2014-10-09 22:42:15 +00:00
|
|
|
convexHullLines = Diag chl
|
2014-10-08 17:31:55 +00:00
|
|
|
where
|
2014-10-09 22:42:15 +00:00
|
|
|
chl _ [] = mempty
|
|
|
|
chl p vt =
|
2014-10-09 22:19:05 +00:00
|
|
|
(strokeTrail .
|
|
|
|
fromVertices .
|
|
|
|
flip (++) [head $ grahamGetCH vtf] .
|
|
|
|
grahamGetCH $
|
|
|
|
vtf) #
|
|
|
|
moveTo (head $ grahamGetCH vtf) #
|
|
|
|
lc red
|
2014-10-09 16:51:32 +00:00
|
|
|
where
|
|
|
|
vtf = filter (inRange (dX p) (dY p)) vt
|
2014-10-08 17:31:55 +00:00
|
|
|
|
|
|
|
|
2014-10-09 01:10:21 +00:00
|
|
|
-- |Same as showConvexHullLines, except that it returns an array
|
|
|
|
-- of diagrams with each step of the algorithm.
|
2014-10-09 15:20:14 +00:00
|
|
|
-- Unfortunately this is very difficult to implement as a Diag (TODO).
|
2014-10-09 15:19:58 +00:00
|
|
|
convexHullLinesInterval :: DiagProp -> [PT] -> [Diagram Cairo R2]
|
2014-10-09 16:51:32 +00:00
|
|
|
convexHullLinesInterval p xs =
|
2014-10-09 22:42:15 +00:00
|
|
|
fmap mkChDiag (grahamGetCHSteps xs)
|
2014-10-09 22:19:05 +00:00
|
|
|
where
|
2014-10-09 22:42:15 +00:00
|
|
|
mkChDiag vt =
|
2014-10-09 22:19:05 +00:00
|
|
|
(strokeTrail .
|
|
|
|
fromVertices $
|
|
|
|
vtf) #
|
|
|
|
moveTo (head vtf) #
|
|
|
|
lc red
|
|
|
|
where
|
|
|
|
vtf = filter (inRange (dX p) (dY p)) vt
|
2014-10-09 01:10:21 +00:00
|
|
|
|
|
|
|
|
2014-10-06 19:11:28 +00:00
|
|
|
-- |Creates a Diagram that shows an XAxis which is bound
|
|
|
|
-- by the dimensions given in xD from DiagProp.
|
2014-10-09 15:19:58 +00:00
|
|
|
xAxis :: Diag
|
2014-10-09 22:19:05 +00:00
|
|
|
xAxis =
|
|
|
|
(Diag hRule) `mappend`
|
|
|
|
(Diag segments) `mappend`
|
|
|
|
(Diag labels)
|
2014-10-06 19:11:28 +00:00
|
|
|
where
|
2014-10-09 22:19:05 +00:00
|
|
|
hRule p _ =
|
|
|
|
arrowAt (p2 (xlD p,0)) (r2 (xuD p, 0)) # moveTo (p2 (xlD p,0))
|
|
|
|
segments p _ =
|
2014-10-09 22:30:56 +00:00
|
|
|
hcat' (with & sep .~ (sqS p))
|
|
|
|
(take (floor . (/) (xuD p - xlD p) $ (sqS p)) .
|
|
|
|
repeat $ (vrule 10)) #
|
2014-10-09 22:19:05 +00:00
|
|
|
moveTo (p2 (xlD p,0))
|
2014-10-09 19:37:45 +00:00
|
|
|
labels p _ =
|
2014-10-09 22:19:05 +00:00
|
|
|
position $
|
|
|
|
zip (mkPoint <$> xs)
|
|
|
|
((\x -> (flip (<>) (square 1 # lw none) .
|
|
|
|
text . show $ x) # scale 10) <$> xs)
|
|
|
|
where
|
|
|
|
xs :: [Int]
|
2014-10-09 22:30:56 +00:00
|
|
|
xs = take (floor . (/) (xuD p - xlD p) $ (sqS p))
|
|
|
|
(iterate (+(floor . sqS $ p)) 0)
|
2014-10-09 22:19:05 +00:00
|
|
|
mkPoint x = p2 (fromIntegral x, -15)
|
2014-10-06 19:11:28 +00:00
|
|
|
|
|
|
|
|
|
|
|
-- |Creates a Diagram that shows an YAxis which is bound
|
|
|
|
-- by the dimensions given in yD from DiagProp.
|
2014-10-09 15:19:58 +00:00
|
|
|
yAxis :: Diag
|
2014-10-09 22:19:05 +00:00
|
|
|
yAxis =
|
|
|
|
(Diag vRule) `mappend`
|
|
|
|
(Diag segments) `mappend`
|
|
|
|
(Diag labels)
|
2014-10-06 19:11:28 +00:00
|
|
|
where
|
2014-10-09 22:19:05 +00:00
|
|
|
vRule p _ =
|
|
|
|
arrowAt (p2 (0, ylD p)) (r2 (0, yuD p)) # moveTo (p2 (0, ylD p))
|
|
|
|
segments p _ =
|
2014-10-09 22:30:56 +00:00
|
|
|
vcat' (with & sep .~ (sqS p))
|
|
|
|
(take (floor . (/) (yuD p - ylD p) $ (sqS p)) .
|
2014-10-09 22:19:05 +00:00
|
|
|
repeat $ (hrule 10)) #
|
|
|
|
alignB #
|
|
|
|
moveTo (p2 (0, (ylD p)))
|
2014-10-09 19:37:45 +00:00
|
|
|
labels p _ =
|
2014-10-09 22:19:05 +00:00
|
|
|
position $
|
|
|
|
zip (mkPoint <$> ys)
|
|
|
|
((\x -> (flip (<>) (square 1 # lw none) .
|
|
|
|
text . show $ x) # scale 10) <$> ys)
|
2014-10-09 19:37:45 +00:00
|
|
|
where
|
|
|
|
ys :: [Int]
|
2014-10-09 22:30:56 +00:00
|
|
|
ys = take (floor . (/) (yuD p - ylD p) $ (sqS p))
|
|
|
|
(iterate (+(floor . sqS $ p)) 0)
|
2014-10-09 19:37:45 +00:00
|
|
|
mkPoint y = p2 (-15, fromIntegral y)
|
2014-10-06 19:11:28 +00:00
|
|
|
|
|
|
|
|
|
|
|
-- |Creates a Diagram that shows a white rectangle which is a little
|
|
|
|
-- bit bigger as both X and Y axis dimensions from DiagProp.
|
2014-10-09 15:19:58 +00:00
|
|
|
whiteRectB :: Diag
|
2014-10-09 22:42:15 +00:00
|
|
|
whiteRectB = Diag rect'
|
2014-10-06 19:11:28 +00:00
|
|
|
where
|
2014-10-09 22:42:15 +00:00
|
|
|
rect' p _ = whiteRect (w' + 50) (h' + 50) # moveTo (p2 (w' / 2, h' / 2))
|
2014-10-08 17:23:15 +00:00
|
|
|
where
|
|
|
|
w' = xuD p - xlD p
|
|
|
|
h' = yuD p - ylD p
|
2014-10-06 19:11:28 +00:00
|
|
|
|
|
|
|
|
2014-10-08 17:23:40 +00:00
|
|
|
-- |Create the Diagram from the points.
|
2014-10-08 14:31:57 +00:00
|
|
|
diag :: DiagProp -> [PT] -> Diagram Cairo R2
|
2014-10-06 19:11:28 +00:00
|
|
|
diag p = case alg p of
|
2014-10-09 22:19:05 +00:00
|
|
|
0 ->
|
|
|
|
mkDiag
|
|
|
|
(mconcat [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])
|
|
|
|
p
|
2014-10-06 19:11:28 +00:00
|
|
|
_ -> mempty
|
2014-09-30 22:05:29 +00:00
|
|
|
|
2014-10-05 13:50:52 +00:00
|
|
|
|
2014-10-05 13:57:31 +00:00
|
|
|
-- |Create the Diagram from a String which is supposed to be the contents
|
|
|
|
-- of an obj file.
|
2014-10-09 22:23:58 +00:00
|
|
|
diagS :: DiagProp -> MeshString -> Diagram Cairo R2
|
2014-10-09 22:19:05 +00:00
|
|
|
diagS p mesh =
|
|
|
|
(diag p .
|
2014-10-06 19:11:28 +00:00
|
|
|
meshToArr $
|
2014-10-09 22:19:05 +00:00
|
|
|
mesh) #
|
|
|
|
bg white
|
2014-10-05 16:41:41 +00:00
|
|
|
|
|
|
|
|
2014-10-09 01:10:21 +00:00
|
|
|
-- |Return a list of tuples used by 'gifMain' to generate an animated gif.
|
|
|
|
gifDiag :: DiagProp -> [PT] -> [(Diagram Cairo R2, GifDelay)]
|
2014-10-09 22:19:05 +00:00
|
|
|
gifDiag p xs =
|
|
|
|
fmap (\x -> (x, 100)) .
|
2014-10-09 22:42:15 +00:00
|
|
|
fmap (\x -> x <> nonChDiag) .
|
2014-10-09 22:19:05 +00:00
|
|
|
flip (++)
|
|
|
|
[mkDiag (convexHullLines `mappend`
|
|
|
|
convexHullPoints) p xs] $
|
|
|
|
(convexHullLinesInterval p xs)
|
|
|
|
where
|
2014-10-09 22:42:15 +00:00
|
|
|
-- add the x-axis and the other default stuff
|
|
|
|
nonChDiag =
|
2014-10-09 22:19:05 +00:00
|
|
|
mconcat .
|
|
|
|
fmap (\x -> mkDiag x p xs) $
|
|
|
|
[coordPoints,
|
|
|
|
xAxis,
|
|
|
|
yAxis,
|
|
|
|
whiteRectB]
|
2014-10-09 01:10:21 +00:00
|
|
|
|
|
|
|
|
|
|
|
-- |Same as gifDiag, except that it takes a string containing the
|
|
|
|
-- mesh file content instead of the the points.
|
2014-10-09 22:23:58 +00:00
|
|
|
gifDiagS :: DiagProp -> MeshString -> [(Diagram Cairo R2, GifDelay)]
|
2014-10-09 22:19:05 +00:00
|
|
|
gifDiagS p = gifDiag p . meshToArr
|
2014-10-09 01:10:21 +00:00
|
|
|
|
|
|
|
|
2014-10-05 16:41:41 +00:00
|
|
|
-- |Create a white rectangle with the given width and height.
|
2014-10-06 19:22:32 +00:00
|
|
|
whiteRect :: Double -> Double -> Diagram Cairo R2
|
|
|
|
whiteRect x y = rect x y # lwG 0.00 # bg white
|
2014-10-09 16:45:37 +00:00
|
|
|
|
|
|
|
|
2014-10-09 23:08:53 +00:00
|
|
|
-- |Create a grid across the whole diagram with squares of the
|
|
|
|
-- given size in DiagProp.
|
2014-10-09 16:45:37 +00:00
|
|
|
grid :: Diag
|
2014-10-09 22:42:15 +00:00
|
|
|
grid = Diag xGrid `mappend` Diag yGrid
|
2014-10-09 16:45:37 +00:00
|
|
|
where
|
2014-10-09 22:42:15 +00:00
|
|
|
yGrid p _ =
|
2014-10-09 22:30:56 +00:00
|
|
|
hcat' (with & sep .~ (sqS p))
|
|
|
|
(take (floor . (/) (xuD p - xlD p) $ (sqS p)) .
|
2014-10-09 22:19:05 +00:00
|
|
|
repeat $ (vrule $ xuD p - xlD p)) #
|
|
|
|
moveTo (p2 (xlD p, (yuD p - ylD p) / 2)) #
|
|
|
|
lw ultraThin
|
2014-10-09 22:42:15 +00:00
|
|
|
xGrid p _ =
|
2014-10-09 22:30:56 +00:00
|
|
|
vcat' (with & sep .~ (sqS p))
|
|
|
|
(take (floor . (/) (yuD p - ylD p) $ (sqS p)) .
|
2014-10-09 22:19:05 +00:00
|
|
|
repeat $ (hrule $ yuD p - ylD p)) #
|
|
|
|
alignB #
|
|
|
|
moveTo (p2 ((xuD p - xlD p) / 2, ylD p)) #
|
|
|
|
lw ultraThin
|