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,
-        maybeDiag (gd p) grid, whiteRectB])
-      p (head pts)
-  1 ->
-    mkDiag
-      (mconcat
-        [maybeDiag (ct p) convexHPText,
-        convexHP, convexHLs,
-        coordPoints, xAxis, yAxis,
-        maybeDiag (gd p) grid, whiteRectB])
-      p (head pts)
-  2 -> polys
-  3 ->
-      polyIntText
-      `atop`
-      polyIntersection (head pts) (pts !! 1) p
-      `atop`
-      polys
-  _ -> mempty
-  where
-    polys =
       mkDiag
-        (mconcat [maybeDiag (ct p) coordPointsText, coordPoints, polyLines])
+        (mconcat [maybeDiag (ct p) coordPointsText,
-        p (head pts)
+          coordPoints, plotterBG])
-      `atop`
+        p obj
+  | alg p == 1 =
       mkDiag
         (mconcat
-          [maybeDiag (ct p) coordPointsText,
+          [maybeDiag (ct p) convexHPText,
-          polyLines, coordPoints, xAxis, yAxis,
+          convexHP, convexHLs,
-          maybeDiag (gd p) grid, whiteRectB])
+          coordPoints, plotterBG])
-        p (pts !! 1)
+        p obj
-    polyIntText = if ct p
+  | otherwise = mempty
-                    then polyIntersectionText (head pts) (pts !! 1) p
+diag p objs@(Objects _)
-                    else mempty
+  | alg p == 2 =
-
+      mkDiag (mconcat [polyLines, maybeDiag (ct p) coordPointsText, coordPoints,
+                      plotterBG])
+        p objs
+  | alg p == 3 =
+      mkDiag (mconcat [maybeDiag (ct p) polyIntersectionText,
+                      polyIntersection, maybeDiag (ct p) coordPointsText,
+                      coordPoints, polyLines,
+                      plotterBG])
+        p objs
+  | otherwise = 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.
+      diag p.
-      facesToArr $
+        Objects    .
-      mesh
+        facesToArr $
-  3 ->
+        mesh
-    diag p.
+  | otherwise =
-      facesToArr $
+      (diag p       .
-      mesh
+          Object    .
-  _ ->
+          meshToArr $
-    (diag p       .
+          mesh) #
-        (:[])     .
+        bg white
-        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
-      position $
+    cpt p (Objects vts) = drawT (concat vts) p
-        zip vtf (pointToTextCoord <$> vtf) # translate (r2 (0, 10))
+    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:_)) =
-        (strokeTrail        .
+      strokePoly x <> strokePoly y
-          fromVertices      $
-          vtf ++ [head vtf])   #
-        moveTo (head vt)       #
-        lc black
       where
-        vtf = filter (inRange (dX p) (dY p)) vt
+        strokePoly x' =
+          (strokeTrail        .
+            fromVertices      $
+            vtf x' ++ [head . vtf $ x'])   #
+          moveTo (head x')                 #
+          lc black
+        vtf = filter (inRange (dX p) (dY p))
+    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
-    dot  = (circle $ t p :: Diagram Cairo R2) # fc red # lc red
+        paF  = filter (inRange (dX p) (dY p)) x
-    vtpi = intersectionPoints
+        pbF  = filter (inRange (dX p) (dY p)) y
-            . sortLexPolys
+        dot  = (circle $ t p :: Diagram Cairo R2) # fc red # lc red
-            $ (sortLexPoly paF, sortLexPoly pbF)
+        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
-                     -> Diagram Cairo R2
-polyIntersectionText pA pB p =
-  position $
-    zip vtpi
-        (pointToTextCoord # fc red <$> vtpi) # translate (r2 (0, 10))
   where
-    paF  = filter (inRange (dX p) (dY p)) pA
+    pit' p (Objects (x:y:_))
-    pbF  = filter (inRange (dX p) (dY p)) pB
+      | ct p =
-    vtpi = intersectionPoints
+          position $
-            . sortLexPolys
+            zip vtpi
-            $ (sortLexPoly paF, sortLexPoly pbF)
+                (pointToTextCoord # fc red <$> vtpi) # translate (r2 (0, 10))
+      | otherwise = mempty
+      where
+        paF  = filter (inRange (dX p) (dY p)) x
+        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)
-      position $
+      | ct p =
-        zip vtchf
+          position $
-            (pointToTextCoord <$> vtchf) # translate (r2 (0, 10))
+            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 _
-      hcat' (with & sep .~ sqS p)
+      | gd p =
-            (replicate (floor . (/) (w' p) $ sqS p)
+          hcat' (with & sep .~ sqS p)
-                       (vrule $ h' p))  #
+                (replicate (floor . (/) (w' p) $ sqS p)
-      moveTo (p2 (xmin p, hOff p))      #
+                           (vrule $ h' p))  #
-      lw ultraThin
+          moveTo (p2 (xmin p, hOff p))      #
-    xGrid p _ =
+          lw ultraThin
-      vcat' (with & sep .~ sqS p)
+      | otherwise = mempty
-            (replicate (floor . (/) (h' p) $ sqS p)
+    xGrid p _
-                       (hrule $ w' p))  #
+      | gd p =
-      alignB                            #
+          vcat' (with & sep .~ sqS p)
-      moveTo (p2 (wOff p, ymin p))      #
+                (replicate (floor . (/) (h' p) $ sqS p)
-      lw ultraThin
+                           (hrule $ w' p))  #
-      where
+          alignB                            #
+          moveTo (p2 (wOff p, ymin p))      #
+          lw ultraThin
+      | 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 {