76 lines
2.7 KiB
Haskell
76 lines
2.7 KiB
Haskell
{-# OPTIONS_HADDOCK ignore-exports #-}
|
|
|
|
module Algorithms.ConvexHull.GrahamScan where
|
|
|
|
import Algebra.Vector
|
|
import Algebra.VectorTypes
|
|
import Diagrams.TwoD.Types
|
|
import MyPrelude
|
|
|
|
|
|
-- |Get all points on a convex hull by using the graham scan
|
|
-- algorithm.
|
|
grahamGetCH :: [PT] -> [PT]
|
|
grahamGetCH vs =
|
|
-- merge upper hull with lower hull while discarding
|
|
-- the duplicated points from the lower hull
|
|
scan uH uHRest ++ tailInit (scan lH lHRest)
|
|
where
|
|
-- sort lexicographically by x values (ties are resolved by y values)
|
|
sortedXY = fmap p2 . sortLex . fmap unp2 $ vs
|
|
-- lists for lower hull
|
|
(lH, lHRest) = first reverse . splitAt 2 $ sortedXY
|
|
-- lists for upper hull
|
|
(uH, uHRest) = first reverse . splitAt 2 . reverse $ sortedXY
|
|
-- This is the actual algorithm.
|
|
-- If we have a list say:
|
|
-- [(100, 100), (200, 450), (250, 250), (300, 400), (400, 200)]
|
|
--
|
|
-- then this will start with:
|
|
-- [(200, 450), (100, 100)] and [(250, 250), (300, 400), (400, 200)]
|
|
--
|
|
-- The first list is reversed since we only care about the last
|
|
-- 3 elements and want to stay efficient.
|
|
scan :: [PT] -- ^ the starting convex hull points
|
|
-> [PT] -- ^ the rest of the points
|
|
-> [PT] -- ^ all convex hull points
|
|
scan (y:z:xs) (x:ys)
|
|
-- last 3 elements are ccw, but there are elements left to check
|
|
| ccw z y x = scan (x:y:z:xs) ys
|
|
-- not ccw, pop one out
|
|
| otherwise = scan (x:z:xs) ys
|
|
scan (x:y:z:xs) []
|
|
-- nothing left and last 3 elements are ccw, so return
|
|
| ccw z y x = x:y:z:xs
|
|
-- not ccw, pop one out
|
|
| otherwise = scan (x:z:xs) []
|
|
scan xs _ = xs
|
|
|
|
|
|
-- |Compute all steps of the graham scan algorithm to allow
|
|
-- visualizing it.
|
|
grahamGetCHSteps :: [PT] -> [[PT]]
|
|
grahamGetCHSteps vs =
|
|
(++) (reverse . g (length vs) lH $ lHRest) .
|
|
fmap (\x -> (last . reverse . g (length vs) lH $ lHRest)
|
|
++ x) $
|
|
(init . reverse . g (length vs) uH $ uHRest)
|
|
where
|
|
sortedXY = fmap p2 . sortLex . fmap unp2 $ vs
|
|
(lH, lHRest) = first reverse . splitAt 2 $ sortedXY
|
|
(uH, uHRest) = first reverse . splitAt 2 . reverse $ sortedXY
|
|
g c xs' ys'
|
|
| c >= 0 = scan 0 xs' ys' : g (c - 1) xs' ys'
|
|
| otherwise = []
|
|
where
|
|
scan c' (y:z:xs) (x:ys)
|
|
| c' >= c = reverse (y:z:xs)
|
|
| ccw z y x = scan (c' + 1) (x:y:z:xs) ys
|
|
| otherwise = scan (c' + 1) (x:z:xs) ys
|
|
scan _ [x,y] [] = [y,x]
|
|
scan c' (x:y:z:xs) []
|
|
| c' >= c = reverse (x:y:z:xs)
|
|
| ccw z y x = x:y:z:xs
|
|
| otherwise = scan (c' + 1) (x:z:xs) []
|
|
scan _ xs _ = reverse xs
|