Difference between revisions of "Graham Scan Implementation"

Revision as of 22:44, 11 September 2020

Descriptions of this problem can be found in Real World Haskell, Chapter 3

import Data.Function (on, (&))
import Data.List (sortOn, tails)
import Data.Tuple (swap)

data Direction = TurnLeft | TurnRight | GoStraight
  deriving (Show, Eq)

type Point2D = (Double, Double)

turning :: Point2D -> Point2D -> Point2D -> Direction
turning (x1, y1) (x2, y2) (x3, y3) = case compare area 0 of
  LT -> TurnRight
  EQ -> GoStraight
  GT -> TurnLeft
  where
    area = (x2 - x1) * (y3 - y1) - (y2 - y1) * (x3 - x1)

bottomLeft :: [Point2D] -> Point2D
bottomLeft = swap . foldr1 min . map swap

sortOnPolar :: [Point2D] -> [Point2D]
sortOnPolar [] = []
sortOnPolar ps = origin : sortOn polar rest
  where
    polar (x, y) = atan2 (y - y0) (x - x0)
    origin@(x0, y0) = bottomLeft ps
    rest = filter (/= origin) ps

grahamScan :: [Point2D] -> [Point2D]
grahamScan [] = []
grahamScan (p : ps) = grahamScan' [p] ps
  where
    grahamScan' xs [] = xs
    grahamScan' xs [y] = y : xs
    grahamScan' xs'@(x : xs) (y : z : ys)
      | turning x y z == TurnLeft = grahamScan' (y : xs') (z : ys)
      | otherwise = grahamScan' xs (x : z : ys)

convex :: [Point2D] -> [Point2D]
convex = grahamScan . sortOnPolar

Test

import Control.Monad
import Convex (convex)
import Data.Function ((&))
import Data.List (sort)
import Test.QuickCheck

convexIsStable n =
  forAll
    (replicateM n arbitrary)
    (\xs -> (xs & convex & sort) == (xs & convex & convex & sort))

main :: IO ()
main = do
  putStrLn "Running tests..."
  mapM checkN [0, 1, 2, 3, 4, 5, 10, 100, 1000]
  putStrLn "done."
  where
    checkN :: Int -> IO ()
    checkN n = do
      putStrLn $ "size: " ++ show n
      quickCheck (convexIsStable n)

The results are:

Running tests...
size: 0
+++ OK, passed 100 tests.
size: 1
+++ OK, passed 100 tests.
size: 2
+++ OK, passed 100 tests.
size: 3
+++ OK, passed 100 tests.
size: 4
+++ OK, passed 100 tests.
size: 5
+++ OK, passed 100 tests.
size: 10
+++ OK, passed 100 tests.
size: 100
+++ OK, passed 100 tests.
size: 1000
+++ OK, passed 100 tests.
done.

@@ Line 2: / Line 2: @@
 <haskell>
-import Data.List (sortBy)
+import Data.Function (on, (&))
-import Data.Function (on)
+import Data.List (sortOn, tails)
+import Data.Tuple (swap)
-data Direction = LEFT | RIGHT | STRAIGHT
+data Direction = TurnLeft | TurnRight | GoStraight
-               deriving (Show, Eq)
+  deriving (Show, Eq)
-data Pt = Pt (Double, Double)
+type Point2D = (Double, Double)
-isTurned :: Pt -> Pt -> Pt -> Direction
+turning :: Point2D -> Point2D -> Point2D -> Direction
-isTurned (Pt (ax, ay)) (Pt (bx, by)) (Pt (cx, cy)) = case sign of
+turning (x1, y1) (x2, y2) (x3, y3) = case compare area 0 of
-    EQ -> STRAIGHT
+  LT -> TurnRight
-    LT -> RIGHT
+  EQ -> GoStraight
-    GT -> LEFT
+  GT -> TurnLeft
+  where
-    where sign = compare ((bx - ax) * (cy - ay)) ((cx - ax) * (by - ay))
+    area = (x2 - x1) * (y3 - y1) - (y2 - y1) * (x3 - x1)
-gScan :: [Pt] -> [Pt]
+bottomLeft :: [Point2D] -> Point2D
+bottomLeft = swap . foldr1 min . map swap
-gScan pts
-    | length pts >= 3 = scan [pt0] rests
-    | otherwise       = pts
-    where
-        -- Find the most bottom-left point pt0
-        pt0 = foldr bottomLeft (Pt (1/0, 1/0)) pts where
-            bottomLeft pa pb = case ord of
-                               LT -> pa
-                               GT -> pb
-                               EQ -> pa
-                       where ord = (compare `on` (\ (Pt (x, y)) -> (y, x))) pa pb
+sortOnPolar :: [Point2D] -> [Point2D]
-        -- Sort other points based on angle
+sortOnPolar [] = []
-        rests = tail (sortBy (compare `on` compkey pt0) pts) where
+sortOnPolar ps = origin : sortOn polar rest
-            compkey (Pt (x0, y0)) (Pt (x, y)) = (atan2 (y - y0) (x - x0),
+  where
-                                       abs (x - x0))
+    polar (x, y) = atan2 (y - y0) (x - x0)
+    origin@(x0, y0) = bottomLeft ps
+    rest = filter (/= origin) ps
+grahamScan :: [Point2D] -> [Point2D]
-        -- Scan the points to find out convex
+grahamScan [] = []
-        -- -- handle the case that all points are collinear
-        scan [p0] (p1:ps)
+grahamScan (p : ps) = grahamScan' [p] ps
+  where
-            | isTurned pz p0 p1 == STRAIGHT = [pz, p0]
-            where pz = last ps
+    grahamScan' xs [] = xs
+    grahamScan' xs [y] = y : xs
+    grahamScan' xs'@(x : xs) (y : z : ys)
+      | turning x y z == TurnLeft = grahamScan' (y : xs') (z : ys)
+      | otherwise = grahamScan' xs (x : z : ys)
+convex :: [Point2D] -> [Point2D]
-        scan (x:xs) (y:z:rsts) = case isTurned x y z of
+convex = grahamScan . sortOnPolar
-            RIGHT    -> scan xs (x:z:rsts)
-            STRAIGHT -> scan (x:xs) (z:rsts) -- skip collinear points
-            LEFT     -> scan (y:x:xs) (z:rsts)
-        scan xs [z] = z : xs
 </haskell>
@@ Line 52: / Line 47: @@
 == Test ==
 <haskell>
+import Control.Monad
+import Convex (convex)
+import Data.Function ((&))
+import Data.List (sort)
 import Test.QuickCheck
-import Control.Monad
-import Data.List
+convexIsStable n =
+  forAll
+    (replicateM n arbitrary)
+    (\xs -> (xs & convex & sort) == (xs & convex & convex & sort))
+main :: IO ()
-convex' = map (\(Pt x) -> x) . convex . map Pt
+main = do
+  putStrLn "Running tests..."
-prop_convex n = forAll (replicateM n arbitrary) (\xs -> sort (convex' xs) == sort (convex' (convex' xs)))
+  mapM checkN [0, 1, 2, 3, 4, 5, 10, 100, 1000]
+  putStrLn "done."
+  where
+    checkN :: Int -> IO ()
+    checkN n = do
+      putStrLn $ "size: " ++ show n
+      quickCheck (convexIsStable n)
 </haskell>
@@ Line 66: / Line 73: @@
 <haskell>
+Running tests...
-> quickCheck (prop_convex 0)
+size: 0
-+++ OK, passed 100 tests.
-> quickCheck (prop_convex 1)
 +++ OK, passed 100 tests.
+size: 1
-> quickCheck (prop_convex 2)
 +++ OK, passed 100 tests.
+size: 2
-> quickCheck (prop_convex 3)
 +++ OK, passed 100 tests.
+size: 3
-> quickCheck (prop_convex 4)
 +++ OK, passed 100 tests.
+size: 4
-> quickCheck (prop_convex 5)
 +++ OK, passed 100 tests.
+size: 5
-> quickCheck (prop_convex 10)
 +++ OK, passed 100 tests.
+size: 10
-> quickCheck (prop_convex 100)
 +++ OK, passed 100 tests.
+size: 100
-> quickCheck (prop_convex 1000)
 +++ OK, passed 100 tests.
+size: 1000
-> quickCheck (prop_convex 10000)
 +++ OK, passed 100 tests.
+done.
 </haskell>

Difference between revisions of "Graham Scan Implementation"

Revision as of 22:44, 11 September 2020

Test

Navigation menu

Search