Make Gif animation more nice, TODO: IMPROVE CODE

Algorithms/ConvexHull/GrahamScan.hs

@@ -102,28 +102,41 @@ grahamGetCH vs =
 
 -- |Compute all steps of the graham scan algorithm to allow
 -- visualizing it.
-grahamGetCHSteps :: [PT] -> [[PT]]
+-- Whether the upper or lower hull is computed depends on the input.
-grahamGetCHSteps vs =
+grahamGetCHSteps :: Int -> [PT] -> [PT] -> [[PT]]
-  (++) (rmdups . reverse . g ((* 2) . length $ vs) lH $ lHRest)
+grahamGetCHSteps c xs' ys'
-       (rmdups . init . reverse . g ((* 2) . length $ vs) uH $ uHRest)
+  | c >= 0    = scanH 0 xs' ys' : grahamGetCHSteps (c - 1) xs' ys'
+  | otherwise = []
   where
-    sortedXY = fmap p2 . sortLex . fmap unp2 $ vs
+    scanH c' hs@(x:y:z:xs) (r':rs')
-    (lH, lHRest) = first reverse . splitAt 3 $ sortedXY
+      | c' >= c      = hs
+      |	notcw z y x  = scanH (c' + 1) (r':hs) rs'
+      | otherwise    = scanH (c' + 1) (x:z:xs) (r':rs')
+    scanH c' hs@(x:y:z:xs) []
+      | c' >= c      = hs
+      |	notcw z y x  = hs
+      | otherwise    = scanH (c' + 1) (x:z:xs) []
+    scanH c' hs (r':rs')
+      | c' >= c      = hs
+      | otherwise    = scanH (c' + 1) (r':hs) rs'
+    scanH _ xs _     = xs
+
+
+grahamGetUpperHullSteps :: [PT] -> [[PT]]
+grahamGetUpperHullSteps vs =
+  (++) [getLastX 2 sortedXY] . rmdups . init . reverse . grahamGetCHSteps ((* 2) . length $ vs) uH $
+    uHRest
+  where
+    sortedXY     = fmap p2 . sortLex . fmap unp2 $ vs
     (uH, uHRest) = first reverse . splitAt 3 . reverse $ sortedXY
-    g c xs' ys'
+
-      | c >= 0    = scanH 0 xs' ys' : g (c - 1) xs' ys'
+
-      | otherwise = []
+grahamGetLowerHullSteps :: [PT] -> [[PT]]
-      where
+grahamGetLowerHullSteps vs =
-        scanH c' hs@(x:y:z:xs) (r':rs')
+  (++) [take 2 sortedXY] . rmdups . reverse . grahamGetCHSteps ((* 2) . length $ vs) lH $ lHRest
-          | c' >= c      = hs
+  where
-          |	notcw z y x  = scanH (c' + 1) (r':hs) rs'
+    sortedXY     = fmap p2 . sortLex . fmap unp2 $ vs
-          | otherwise    = scanH (c' + 1) (x:z:xs) (r':rs')
+    (lH, lHRest) = first reverse . splitAt 3 $ sortedXY
-        scanH _ [x,y] [] = [y,x]
+
-        scanH c' hs@(x:y:z:xs) []
+{- -  (++) (rmdups . reverse . g ((* 2) . length $ vs) lH $ lHRest) -}
-          | c' >= c      = hs
+{- -       (rmdups . init . reverse . g ((* 2) . length $ vs) uH $ uHRest) -}
-          |	notcw z y x  = hs
-          | otherwise    = scanH (c' + 1) (x:z:xs) []
-        scanH c' hs (r':rs')
-          | c' >= c      = hs
-          | otherwise    = scanH (c' + 1) (r':hs) rs'
-        scanH _ xs _     = xs

Graphics/Diagram/Gif.hs

@@ -18,11 +18,16 @@ gifDiag p xs =
     fmap (\x -> x <> nonChDiag)              .
     flip (++)
       [mkDiag (convexHullPointsText `mappend`
-                convexHullLines     `mappend`
                 convexHullPoints)
-              p xs]                $
+              p xs <> lastUpperHull <> lastLowerHull] $
-    (convexHullLinesInterval p xs)
+    (lowerHullList ++
+      ((<> lastLowerHull) <$>
+      upperHullList))
   where
+    upperHullList = convexHullLinesIntervalUpper p xs
+    lastUpperHull = last upperHullList
+    lowerHullList = convexHullLinesIntervalLower p xs
+    lastLowerHull = last lowerHullList
     -- add the x-axis and the other default stuff
     nonChDiag =
       mconcat                      .

Graphics/Diagram/Plotter.hs

@@ -85,19 +85,30 @@ convexHullLines = Diag chl
         vtf = filter (inRange (dX p) (dY p)) vt
 
 
--- |Same as showConvexHullLines, except that it returns an array
+convexHullLinesIntervalLower :: DiagProp -> [PT] -> [Diagram Cairo R2]
--- of diagrams with each step of the algorithm.
+convexHullLinesIntervalLower p xs =
--- Unfortunately this is very difficult to implement as a Diag (TODO).
+  fmap mkChDiag (grahamGetLowerHullSteps xs)
-convexHullLinesInterval :: DiagProp -> [PT] -> [Diagram Cairo R2]
-convexHullLinesInterval p xs =
-  fmap mkChDiag (grahamGetCHSteps xs)
   where
     mkChDiag vt =
       (strokeTrail         .
           fromVertices     $
           vtf)            #
         moveTo (head vtf) #
-        lc red
+        lc orange
+      where
+        vtf = filter (inRange (dX p) (dY p)) vt
+
+
+convexHullLinesIntervalUpper :: DiagProp -> [PT] -> [Diagram Cairo R2]
+convexHullLinesIntervalUpper p xs =
+  fmap mkChDiag (grahamGetUpperHullSteps xs)
+  where
+    mkChDiag vt =
+      (strokeTrail         .
+          fromVertices     $
+          vtf)            #
+        moveTo (head vtf) #
+        lc purple
       where
         vtf = filter (inRange (dX p) (dY p)) vt