diff --git a/Algorithms/ConvexHull/GrahamScan.hs b/Algorithms/ConvexHull/GrahamScan.hs index 38978a5..23c5fca 100644 --- a/Algorithms/ConvexHull/GrahamScan.hs +++ b/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]] -grahamGetCHSteps vs = - (++) (rmdups . reverse . g ((* 2) . length $ vs) lH $ lHRest) - (rmdups . init . reverse . g ((* 2) . length $ vs) uH $ uHRest) +-- Whether the upper or lower hull is computed depends on the input. +grahamGetCHSteps :: Int -> [PT] -> [PT] -> [[PT]] +grahamGetCHSteps c xs' ys' + | c >= 0 = scanH 0 xs' ys' : grahamGetCHSteps (c - 1) xs' ys' + | otherwise = [] where - sortedXY = fmap p2 . sortLex . fmap unp2 $ vs - (lH, lHRest) = first reverse . splitAt 3 $ sortedXY + scanH c' hs@(x:y:z:xs) (r':rs') + | 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 = [] - where - scanH c' hs@(x:y:z:xs) (r':rs') - | c' >= c = hs - | notcw z y x = scanH (c' + 1) (r':hs) rs' - | otherwise = scanH (c' + 1) (x:z:xs) (r':rs') - scanH _ [x,y] [] = [y,x] - 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 + + +grahamGetLowerHullSteps :: [PT] -> [[PT]] +grahamGetLowerHullSteps vs = + (++) [take 2 sortedXY] . rmdups . reverse . grahamGetCHSteps ((* 2) . length $ vs) lH $ lHRest + where + sortedXY = fmap p2 . sortLex . fmap unp2 $ vs + (lH, lHRest) = first reverse . splitAt 3 $ sortedXY + +{- - (++) (rmdups . reverse . g ((* 2) . length $ vs) lH $ lHRest) -} +{- - (rmdups . init . reverse . g ((* 2) . length $ vs) uH $ uHRest) -} diff --git a/Graphics/Diagram/Gif.hs b/Graphics/Diagram/Gif.hs index 6e6342a..f7f4108 100644 --- a/Graphics/Diagram/Gif.hs +++ b/Graphics/Diagram/Gif.hs @@ -18,11 +18,16 @@ gifDiag p xs = fmap (\x -> x <> nonChDiag) . flip (++) [mkDiag (convexHullPointsText `mappend` - convexHullLines `mappend` convexHullPoints) - p xs] $ - (convexHullLinesInterval p xs) + p xs <> lastUpperHull <> lastLowerHull] $ + (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 . diff --git a/Graphics/Diagram/Plotter.hs b/Graphics/Diagram/Plotter.hs index 7c977e7..0660daa 100644 --- a/Graphics/Diagram/Plotter.hs +++ b/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 --- of diagrams with each step of the algorithm. --- Unfortunately this is very difficult to implement as a Diag (TODO). -convexHullLinesInterval :: DiagProp -> [PT] -> [Diagram Cairo R2] -convexHullLinesInterval p xs = - fmap mkChDiag (grahamGetCHSteps xs) +convexHullLinesIntervalLower :: DiagProp -> [PT] -> [Diagram Cairo R2] +convexHullLinesIntervalLower p xs = + fmap mkChDiag (grahamGetLowerHullSteps 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