graham.hs

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