cga/Diagram.hs

171 lines
4.3 KiB
Haskell
Raw Normal View History

{-# OPTIONS_HADDOCK ignore-exports #-}
2014-10-06 20:15:10 +00:00
module Diagram (t,
dX,
dY,
alg,
defaultProp,
diag,
diagS,
whiteRect) where
2014-09-30 22:05:29 +00:00
import Algorithms.ConvexHull
2014-10-07 17:18:16 +00:00
import Class.Defaults
2014-09-30 22:05:29 +00:00
import Diagrams.Prelude
import Diagrams.Backend.Cairo
2014-10-07 17:12:07 +00:00
import LinearAlgebra.Vector
import Parser.Meshparser
2014-09-30 22:05:29 +00:00
2014-10-06 21:31:13 +00:00
-- |Represents a Cairo Diagram. This allows us to create multiple
-- diagrams with different algorithms but based on the same
-- coordinates and common properties.
data Diag = Diag {
mkDiag :: DiagProp
-> [PT]
-> Diagram Cairo R2
}
2014-10-01 21:02:43 +00:00
-- |Holds the properties for a Diagram, like thickness of 2d points etc.
data DiagProp = MkProp {
2014-10-05 16:09:24 +00:00
-- |The thickness of the dots.
t :: Double,
-- |The dimensions of the x-axis.
dX :: Coord,
2014-10-05 16:09:24 +00:00
-- |The dimensions of the y-axis.
dY :: Coord,
-- |Algorithm to use.
alg :: Int
}
instance Def DiagProp where
def = defaultProp
instance Monoid Diag where
mempty = Diag (\_ _ -> rect 0 0)
mappend d1 d2 = Diag g
where
g p vt = mkDiag d1 p vt <> mkDiag d2 p vt
mconcat = foldr mappend mempty
-- |The default properties of the Diagram.
defaultProp :: DiagProp
defaultProp = MkProp 2 (0,500) (0,500) 0
-- |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
-- via DiagProp.
showCoordinates :: Diag
showCoordinates = Diag f
where
f p vt
= position (zip (filter (inRange (dX p) (dY p)) $ vt)
(repeat dot))
where
-- a dot itself is a diagram
dot = (circle $ t p :: Diagram Cairo R2) # fc black
-- |Create a diagram which shows the points of the convex hull.
showConvexHullPoints :: Diag
showConvexHullPoints = Diag f
where
f p vt
= position (zip (filter (inRange (dX p) (dY p)) $ vtch)
(repeat dot))
where
-- a dot itself is a diagram
dot = (circle $ t p :: Diagram Cairo R2) # fc red # lc red
vtch = grahamGetCH vt
2014-10-08 17:31:55 +00:00
showConvexHullLines :: Diag
showConvexHullLines = Diag f
where
f _ vt
= (strokeTrail .
fromVertices .
flip (++) [head $ grahamGetCH vt] .
grahamGetCH $
vt
) # moveTo (head $ grahamGetCH vt) # lc red
-- |Creates a Diagram that shows an XAxis which is bound
-- by the dimensions given in xD from DiagProp.
showXAxis :: Diag
showXAxis = Diag f
where
f p _ = (strokeTrail . fromVertices $ [p2 (xlD p,0), p2 (xuD p, 0)]) # moveTo (p2 (xlD p,0))
-- |Creates a Diagram that shows an YAxis which is bound
-- by the dimensions given in yD from DiagProp.
showYAxis :: Diag
showYAxis = Diag f
where
2014-10-08 17:29:51 +00:00
f p _ = (strokeTrail . fromVertices $ [p2 (0, ylD p), p2 (0, yuD p)]) # moveTo (p2 (0, ylD p))
-- |Creates a Diagram that shows a white rectangle which is a little
-- bit bigger as both X and Y axis dimensions from DiagProp.
showWhiteRectB :: Diag
showWhiteRectB = Diag f
where
f p _ = whiteRect (w' + 50) (h' + 50) # moveTo (p2 (w' / 2, h' / 2))
where
w' = xuD p - xlD p
h' = yuD p - ylD p
2014-10-08 17:23:40 +00:00
-- |Create the Diagram from the points.
diag :: DiagProp -> [PT] -> Diagram Cairo R2
diag p = case alg p of
0 -> mkDiag
(mconcat [showCoordinates, showXAxis, showYAxis, showWhiteRectB])
p
1 -> mkDiag
2014-10-08 17:31:55 +00:00
(mconcat [showConvexHullPoints, showConvexHullLines,
showCoordinates, showXAxis, showYAxis, showWhiteRectB])
p
_ -> 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.
diagS :: DiagProp -> String -> Diagram Cairo R2
diagS p mesh
= (diag p .
meshToArr $
mesh) # bg white
-- |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