Skip to content

Instantly share code, notes, and snippets.

@dminuoso dminuoso/graham.hs
Created Dec 19, 2017

Embed
What would you like to do?
module Graham where
import Data.List (sortBy)
import Data.Ord (comparing)
import Data.Monoid
data Direction = Left'
| Right'
| Straight'
deriving (Show)
data Point a = Point { getX :: a
, getY :: a
}
instance (Num a, Show a) => Show (Point a) where
showsPrec d (Point a b) = showParen (d > 9) $ showString "Point " . shows a . showString " " . shows b
-- |Vector subtraction
sub :: (Num a) => Point a -> Point a -> Point a
sub (Point x1 y1) (Point x2 y2) = Point (x1 - x2) (y1 - y2)
-- |Inner vector product
dot :: (Num a) => Point a -> Point a -> a
dot (Point x y) (Point x' y') = x * x' + y * y'
-- |Length of a vector
len :: (Floating a) => Point a -> a
len (Point x y) = sqrt (x ^ 2 + y ^ 2)
-- |Determinant of the matrix given by two R2 vectors
det :: (Floating a) => Point a -> Point a -> a
det (Point x y) (Point x' y') = x * y' - y * x'
-- |Unoriented angle between two vectors
angle :: (Floating a) => Point a -> Point a -> a
angle p1 p2 = acos (p1 `dot` p2 / (len p1 * len p2))
toDeg :: (Floating a) => a -> a
toDeg x = x * (180 / pi)
-- |Oriented angle between two vectors
orientedAngle :: (Floating a) => Point a -> Point a -> a
orientedAngle p1 p2 = signum (det p1 p2) * p1 `angle` p2
uncurry3 :: (a -> b -> c -> d) -> (a,b,c) -> d
uncurry3 f (a,b,c) = f a b c
starting :: (Ord a) => Point a -> Point a -> Ordering
starting (Point x1 y1) (Point x2 y2) = compare x1 x2 <> compare y1 y2
grahamScan :: (Ord a, Num a, Floating a) => [Point a] -> [Point a]
grahamScan l = grahamScan' [pt, p] pts where
(p:ps) = sortBy starting l
(pt:pts) = sortBy (comparing $ orientedAngle p) ps
grahamScan' :: (Eq a, Floating a) => [Point a] -> [Point a] -> [Point a]
grahamScan' stack@[pt1, pt2] (y:ys) = grahamScan' (y:stack) ys
grahamScan' stack [] = stack
grahamScan' stack@(pt1:pt2:pts) r@(y:ys) = case dirChange pt2 pt1 y of
Right' -> grahamScan' (pt2:pts) r
_ -> grahamScan' (y:stack) ys
-- |Given three points, calculate the direction change
dirChange :: (Eq a, Floating a) => Point a -> Point a -> Point a -> Direction
dirChange p1 p2 p3 = case signum $ det (p2 `sub` p1) (p3 `sub` p2) of
0 -> Straight'
1 -> Left'
(-1) -> Right'
-- |Create a sliding window of size 3 in a list
windows3 :: [a] -> [(a,a,a)]
windows3 l = zip3 l (drop 1 l) (drop 2 l)
-- | Given a list of points, calculate the consecutive direction changes
directions :: (Eq a, Floating a) => [Point a] -> [Direction]
directions = fmap (uncurry3 dirChange) . windows3
Sign up for free to join this conversation on GitHub. Already have an account? Sign in to comment
You can’t perform that action at this time.