DIAGRAM: small refactor

Enhanced the Diag type and used it for poly functions as well.

Graphics/Diagram/Gtk.hs

@@ -2,7 +2,6 @@
 
 module Graphics.Diagram.Gtk where
 
-import Algebra.VectorTypes
 import Diagrams.Backend.Cairo
 import Diagrams.Prelude
 import Graphics.Diagram.Plotter
@@ -11,63 +10,47 @@ import Parser.Meshparser
 
 
 -- |Create the Diagram from the points.
-diag :: DiagProp -> [[PT]] -> Diagram Cairo R2
+diag :: DiagProp -> Object -> Diagram Cairo R2
-diag p pts = case alg p of
+diag p obj@(Object _)
-  0 ->
+  | alg p == 0 =
       mkDiag
         (mconcat [maybeDiag (ct p) coordPointsText,
-        coordPoints, xAxis, yAxis,
+          coordPoints, plotterBG])
-        maybeDiag (gd p) grid, whiteRectB])
+        p obj
-      p (head pts)
+  | alg p == 1 =
-  1 ->
       mkDiag
         (mconcat
           [maybeDiag (ct p) convexHPText,
           convexHP, convexHLs,
-        coordPoints, xAxis, yAxis,
+          coordPoints, plotterBG])
-        maybeDiag (gd p) grid, whiteRectB])
+        p obj
-      p (head pts)
+  | otherwise = mempty
-  2 -> polys
+diag p objs@(Objects _)
-  3 ->
+  | alg p == 2 =
-      polyIntText
+      mkDiag (mconcat [polyLines, maybeDiag (ct p) coordPointsText, coordPoints,
-      `atop`
+                      plotterBG])
-      polyIntersection (head pts) (pts !! 1) p
+        p objs
-      `atop`
+  | alg p == 3 =
-      polys
+      mkDiag (mconcat [maybeDiag (ct p) polyIntersectionText,
-  _ -> mempty
+                      polyIntersection, maybeDiag (ct p) coordPointsText,
-  where
+                      coordPoints, polyLines,
-    polys =
+                      plotterBG])
-      mkDiag
+        p objs
-        (mconcat [maybeDiag (ct p) coordPointsText, coordPoints, polyLines])
+  | otherwise = mempty
-        p (head pts)
-      `atop`
-      mkDiag
-        (mconcat
-          [maybeDiag (ct p) coordPointsText,
-          polyLines, coordPoints, xAxis, yAxis,
-          maybeDiag (gd p) grid, whiteRectB])
-        p (pts !! 1)
-    polyIntText = if ct p
-                    then polyIntersectionText (head pts) (pts !! 1) p
-                    else mempty
-
 
 
 -- |Create the Diagram from a String which is supposed to be the contents
 -- of an obj file.
 diagS :: DiagProp -> MeshString -> Diagram Cairo R2
-diagS p mesh = case alg p of
+diagS p mesh
-  2 ->
+  | alg p == 2 || alg p == 3 =
       diag p.
+        Objects    .
         facesToArr $
         mesh
-  3 ->
+  | otherwise =
-    diag p.
-      facesToArr $
-      mesh
-  _ ->
       (diag p       .
-        (:[])     .
+          Object    .
           meshToArr $
           mesh) #
         bg white

Graphics/Diagram/Plotter.hs

@@ -18,7 +18,10 @@ import Graphics.Diagram.Types
 coordPoints :: Diag
 coordPoints = Diag cp
   where
-    cp p vt =
+    cp p (Object vt) = drawP vt p
+    cp p (Objects vts) = drawP (concat vts) p
+    drawP [] _ = mempty
+    drawP vt p =
       position (zip (filter (inRange (dX p) (dY p)) vt)
         (repeat dot))
       where
@@ -38,9 +41,14 @@ pointToTextCoord pt =
 coordPointsText :: Diag
 coordPointsText = Diag cpt
   where
-    cpt p vt =
+    cpt p (Object vt)   = drawT vt p
+    cpt p (Objects vts) = drawT (concat vts) p
+    drawT [] _ = mempty
+    drawT vt p
+      | ct p =
           position $
             zip vtf (pointToTextCoord <$> vtf) # translate (r2 (0, 10))
+      | otherwise = mempty
       where
         vtf = filter (inRange (dX p) (dY p)) vt
 
@@ -49,72 +57,80 @@ coordPointsText = Diag cpt
 polyLines :: Diag
 polyLines = Diag pp
   where
-    pp _ []  = mempty
+    pp _ (Objects []) = mempty
-    pp p vt =
+    pp p (Objects (x:y:_)) =
+      strokePoly x <> strokePoly y
+      where
+        strokePoly x' =
           (strokeTrail        .
             fromVertices      $
-          vtf ++ [head vtf])   #
+            vtf x' ++ [head . vtf $ x'])   #
-        moveTo (head vt)       #
+          moveTo (head x')                 #
           lc black
-      where
+        vtf = filter (inRange (dX p) (dY p))
-        vtf = filter (inRange (dX p) (dY p)) vt
+    pp _ _  = mempty
 
 
 -- |Show the intersection points of two polygons as red dots.
-polyIntersection :: [PT]
+polyIntersection :: Diag
-                 -> [PT]
+polyIntersection = Diag pi'
-                 -> DiagProp
-                 -> Diagram Cairo R2
-polyIntersection pA pB p =
-  position (zip vtpi (repeat dot))
   where
-    paF  = filter (inRange (dX p) (dY p)) pA
+    pi' p (Objects (x:y:_)) = position (zip vtpi (repeat dot))
-    pbF  = filter (inRange (dX p) (dY p)) pB
+      where
+        paF  = filter (inRange (dX p) (dY p)) x
+        pbF  = filter (inRange (dX p) (dY p)) y
         dot  = (circle $ t p :: Diagram Cairo R2) # fc red # lc red
         vtpi = intersectionPoints
                 . sortLexPolys
                 $ (sortLexPoly paF, sortLexPoly pbF)
+    pi' _ _ = mempty
 
 
 -- |Show the intersection points of two polygons as red dots.
-polyIntersectionText :: [PT]
+polyIntersectionText :: Diag
-                     -> [PT]
+polyIntersectionText = Diag pit'
-                     -> DiagProp
+  where
-                     -> Diagram Cairo R2
+    pit' p (Objects (x:y:_))
-polyIntersectionText pA pB p =
+      | ct p =
           position $
             zip vtpi
                 (pointToTextCoord # fc red <$> vtpi) # translate (r2 (0, 10))
+      | otherwise = mempty
       where
-    paF  = filter (inRange (dX p) (dY p)) pA
+        paF  = filter (inRange (dX p) (dY p)) x
-    pbF  = filter (inRange (dX p) (dY p)) pB
+        pbF  = filter (inRange (dX p) (dY p)) y
         vtpi = intersectionPoints
                 . sortLexPolys
                 $ (sortLexPoly paF, sortLexPoly pbF)
+    pit' _ _ = mempty
 
 
 -- |Create a diagram which shows the points of the convex hull.
 convexHP :: Diag
 convexHP = Diag chp
   where
-    chp p vt =
+    chp p (Object vt) =
       position (zip vtch
         (repeat dot))
       where
         dot = (circle $ t p :: Diagram Cairo R2) # fc red # lc red
         vtch = grahamCH $ filter (inRange (dX p) (dY p)) vt
+    chp _ _ = mempty
 
 
 -- |Show coordinates as text above the convex hull points.
 convexHPText :: Diag
 convexHPText = Diag chpt
   where
-    chpt p vt =
+    chpt p (Object vt)
+      | ct p =
           position $
             zip vtchf
                 (pointToTextCoord <$> vtchf) # translate (r2 (0, 10))
+      | otherwise = mempty
       where
         vtchf = grahamCH . filter (inRange (dX p) (dY p)) $ vt
+    chpt _ _ = mempty
 
 
 -- |Create a diagram which shows the lines along the convex hull
@@ -122,8 +138,8 @@ convexHPText = Diag chpt
 convexHLs :: Diag
 convexHLs = Diag chl
   where
-    chl _ [] = mempty
+    chl _ (Object []) = mempty
-    chl p vt =
+    chl p (Object vt) =
       (strokeTrail                           .
           fromVertices                       .
           flip (++) [head $ grahamCH vtf]    .
@@ -133,6 +149,7 @@ convexHLs = Diag chl
         lc red
       where
         vtf = filter (inRange (dX p) (dY p)) vt
+    chl _ _ = mempty
 
 
 -- |Create list of diagrama which describe the lines along points of a half
@@ -245,17 +262,24 @@ whiteRect x y = rect x y # lwG 0.00 # bg white
 grid :: Diag
 grid = Diag xGrid <> Diag yGrid
   where
-    yGrid p _ =
+    yGrid p _
+      | gd p =
           hcat' (with & sep .~ sqS p)
                 (replicate (floor . (/) (w' p) $ sqS p)
                            (vrule $ h' p))  #
           moveTo (p2 (xmin p, hOff p))      #
           lw ultraThin
-    xGrid p _ =
+      | otherwise = mempty
+    xGrid p _
+      | gd p =
           vcat' (with & sep .~ sqS p)
                 (replicate (floor . (/) (h' p) $ sqS p)
                            (hrule $ w' p))  #
           alignB                            #
           moveTo (p2 (wOff p, ymin p))      #
           lw ultraThin
-      where
+      | otherwise = mempty
+
+
+plotterBG :: Diag
+plotterBG = mconcat [xAxis, yAxis, grid, whiteRectB]

Graphics/Diagram/Types.hs

@@ -16,11 +16,15 @@ type MeshString = String
 -- coordinates and common properties.
 data Diag = Diag {
   mkDiag :: DiagProp
-         -> [PT]
+         -> Object
          -> Diagram Cairo R2
 }
 
 
+data Object = Object [PT]
+            | Objects [[PT]]
+
+
 -- |Holds the properties for a Diagram, like thickness of 2d points etc.
 -- This can also be seen as a context when merging multiple diagrams.
 data DiagProp = MkProp {