DIAGRAM: small refactor

Update Diag type to play more nicely with GifDiags.

Graphics/Diagram/Gif.hs

@@ -3,6 +3,7 @@
 module Graphics.Diagram.Gif where
 
 import Algebra.VectorTypes
+import Algorithms.ConvexHull.GrahamScan
 import Codec.Picture.Gif
 import Data.Monoid
 import Diagrams.Backend.Cairo
@@ -15,26 +16,19 @@ import Parser.Meshparser
 -- |Return a list of tuples used by 'gifMain' to generate an animated gif.
 gifDiag :: DiagProp -> [PT] -> [(Diagram Cairo R2, GifDelay)]
 gifDiag p xs =
-  fmap ((\x -> (x, 100)) . (<> nonChDiag))      .
+  fmap ((\x -> (x, 50)) . (<> nonChDiag))
-    flip (++)
+   (upperHullList
-      [mkDiag (convexHPText <>
+     <> fmap (<> last upperHullList) lowerHullList
-        convexHP)
+     <> [mkDiag (mconcat [convexHPText, convexHP, convexHLs])
-        p xs <> lastUpperHull <> lastLowerHull] $
+         p{ ct = True } (Object xs)])
-    (lowerHullList ++ ((<> lastLowerHull) <$> upperHullList))
   where
-    upperHullList = convexUHStepsLs p xs
+    upperHullList = mkGifDiag convexHStepsLs p purple grahamUHSteps xs
-    lastUpperHull = last upperHullList
+    lowerHullList = mkGifDiag convexHStepsLs p orange grahamLHSteps xs
-    lowerHullList = convexLHStepsLs p xs
-    lastLowerHull = last lowerHullList
     -- add the x-axis and the other default stuff
     nonChDiag =
       mconcat                               .
-        fmap (\x -> mkDiag x p xs) $
+        fmap (\x -> mkDiag x p (Object xs)) $
-        [coordPoints,
+        [coordPoints, plotterBG]
-        xAxis,
-        yAxis,
-        grid,
-        whiteRectB]
 
 
 -- |Same as gifDiag, except that it takes a string containing the

Graphics/Diagram/Plotter.hs

@@ -2,7 +2,6 @@
 
 module Graphics.Diagram.Plotter where
 
-import Algebra.Vector
 import Algebra.VectorTypes
 import Algorithms.ConvexHull.GrahamScan
 import Algorithms.PolygonIntersection.Core
@@ -22,7 +21,7 @@ coordPoints = Diag cp
     cp p (Objects vts) = drawP (concat vts) p
     drawP [] _ = mempty
     drawP vt p =
-      position (zip (filter (inRange (dX p) (dY p)) vt)
+      position (zip (filterValidPT p vt)
         (repeat dot))
       where
         dot = (circle $ t p :: Diagram Cairo R2) # fc black
@@ -50,7 +49,7 @@ coordPointsText = Diag cpt
             zip vtf (pointToTextCoord <$> vtf) # translate (r2 (0, 10))
       | otherwise = mempty
       where
-        vtf = filter (inRange (dX p) (dY p)) vt
+        vtf = filterValidPT p vt
 
 
 -- |Draw the lines of the polygon.
@@ -67,7 +66,7 @@ polyLines = Diag pp
             vtf x' ++ [head . vtf $ x'])   #
           moveTo (head x')                 #
           lc black
-        vtf = filter (inRange (dX p) (dY p))
+        vtf = filterValidPT p
     pp _ _  = mempty
 
 
@@ -77,8 +76,8 @@ polyIntersection = Diag pi'
   where
     pi' p (Objects (x:y:_)) = position (zip vtpi (repeat dot))
       where
-        paF  = filter (inRange (dX p) (dY p)) x
+        paF  = filterValidPT p x
-        pbF  = filter (inRange (dX p) (dY p)) y
+        pbF  = filterValidPT p y
         dot  = (circle $ t p :: Diagram Cairo R2) # fc red # lc red
         vtpi = intersectionPoints
                 . sortLexPolys
@@ -97,8 +96,8 @@ polyIntersectionText = Diag pit'
                 (pointToTextCoord # fc red <$> vtpi) # translate (r2 (0, 10))
       | otherwise = mempty
       where
-        paF  = filter (inRange (dX p) (dY p)) x
+        paF  = filterValidPT p x
-        pbF  = filter (inRange (dX p) (dY p)) y
+        pbF  = filterValidPT p y
         vtpi = intersectionPoints
                 . sortLexPolys
                 $ (sortLexPoly paF, sortLexPoly pbF)
@@ -114,7 +113,7 @@ convexHP = Diag chp
         (repeat dot))
       where
         dot = (circle $ t p :: Diagram Cairo R2) # fc red # lc red
-        vtch = grahamCH $ filter (inRange (dX p) (dY p)) vt
+        vtch = grahamCH $ filterValidPT p vt
     chp _ _ = mempty
 
 
@@ -129,7 +128,7 @@ convexHPText = Diag chpt
                 (pointToTextCoord <$> vtchf) # translate (r2 (0, 10))
       | otherwise = mempty
       where
-        vtchf = grahamCH . filter (inRange (dX p) (dY p)) $ vt
+        vtchf = grahamCH . filterValidPT p $ vt
     chpt _ _ = mempty
 
 
@@ -148,40 +147,21 @@ convexHLs = Diag chl
         moveTo (head $ grahamCH vtf) #
         lc red
       where
-        vtf = filter (inRange (dX p) (dY p)) vt
+        vtf = filterValidPT p vt
     chl _ _ = mempty
 
 
 -- |Create list of diagrama which describe the lines along points of a half
 -- convex hull, for each iteration of the algorithm. Which half is chosen
 -- depends on the input.
-convexHStepsLs :: Colour Double
+convexHStepsLs :: Diag
-               -> ([PT] -> [[PT]])
+convexHStepsLs = GifDiag chs
-               -> DiagProp
-               -> [PT]
-               -> [Diagram Cairo R2]
-convexHStepsLs col f p xs =
-  fmap mkChDiag (f xs')
   where
-    xs' = filter (inRange (dX p) (dY p)) xs
+    chs p col f vt =
-    mkChDiag vt =
+      fmap mkChDiag (f . filterValidPT p $ vt)
-      (strokeTrail         .
+      where
-          fromVertices     $
+        mkChDiag vt' =
-          vt)            #
+          (strokeTrail . fromVertices $ vt') # moveTo (head vt') # lc col
-        moveTo (head vt) #
-        lc col
-
-
--- |Create list of diagrama which describe the lines along the lower
--- convex hull points, for each iteration of the algorithm.
-convexLHStepsLs :: DiagProp -> [PT] -> [Diagram Cairo R2]
-convexLHStepsLs = convexHStepsLs orange grahamLHSteps
-
-
--- |Create list of diagrama which describe the lines along the upper
--- convex hull points, for each iteration of the algorithm.
-convexUHStepsLs :: DiagProp -> [PT] -> [Diagram Cairo R2]
-convexUHStepsLs = convexHStepsLs purple grahamUHSteps
 
 
 -- |Creates a Diagram that shows an XAxis which is bound

Graphics/Diagram/Types.hs

@@ -2,6 +2,7 @@
 
 module Graphics.Diagram.Types where
 
+import Algebra.Vector
 import Algebra.VectorTypes
 import Diagrams.Backend.Cairo
 import Diagrams.Prelude
@@ -14,11 +15,22 @@ type MeshString = String
 -- |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 {
+data Diag =
+  Diag
+  {
     mkDiag :: DiagProp
            -> Object
            -> Diagram Cairo R2
-}
+  }
+  | GifDiag
+  {
+    mkGifDiag :: DiagProp
+              -> Colour Double
+              -> ([PT] -> [[PT]])
+              -> [PT]
+              -> [Diagram Cairo R2]
+  }
+  | EmptyDiag (Diagram Cairo R2)
 
 
 data Object = Object [PT]
@@ -50,10 +62,22 @@ instance Def DiagProp where
 
 
 instance Monoid Diag where
-  mempty = Diag (\_ _ -> mempty)
+  mempty = EmptyDiag mempty
-  mappend d1 d2 = Diag g
+  mappend d1@(Diag {}) d2@(Diag {}) = Diag g
     where
-      g p vt = mkDiag d1 p vt <> mkDiag d2 p vt
+      g p obj = mkDiag d1 p obj <> mkDiag d2 p obj
+  mappend d1@(GifDiag {}) d2@(Diag {}) = GifDiag g
+    where
+      g p col f vt = mkGifDiag d1 p col f vt ++ [mkDiag d2 p (Object vt)]
+  mappend d1@(Diag {}) d2@(GifDiag {}) = GifDiag g
+    where
+      g p col f vt = mkDiag d2 p (Object vt) : mkGifDiag d1 p col f vt
+  mappend d1@(GifDiag {}) d2@(GifDiag {}) = GifDiag g
+    where
+      g p col f vt = mkGifDiag d1 p col f vt ++ mkGifDiag d2 p col f vt
+  mappend (EmptyDiag _) g = g
+  mappend g (EmptyDiag _) = g
+
   mconcat = foldr mappend mempty
 
 
@@ -111,3 +135,7 @@ maybeDiag :: Bool -> Diag -> Diag
 maybeDiag b d
   | b         = d
   | otherwise = mempty
+
+
+filterValidPT :: DiagProp -> [PT] -> [PT]
+filterValidPT p = filter (inRange (dX p) (dY p))