Difference between revisions of "Graham Scan Implementation"

Latest revision as of 03:42, 14 August 2021

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.Ord (comparing)
+import Data.Function (on, (&))
-import Data.List (sortBy)
+import Data.List (sortOn, tails)
+import Data.Tuple (swap)
---Graham Scan exercise
+data Direction = TurnLeft | TurnRight | GoStraight
---Direction type
+  deriving (Show, Eq)
-data Direction = LeftTurn
-               | RightTurn
-               | Straight
-                deriving (Show, Eq)
+type Point2D = (Double, Double)
---Point type
-data Point = Point (Double, Double)
-             deriving (Show)
+turning :: Point2D -> Point2D -> Point2D -> Direction
---some points
+turning (x1, y1) (x2, y2) (x3, y3) = case compare area 0 of
-p0 = Point (2.1,2.0)
+  LT -> TurnRight
-p1 = Point (4.2,2.0)
+  EQ -> GoStraight
-p2 = Point (0.5,2.5)
+  GT -> TurnLeft
-p3 = Point (3.2,3.5)
+  where
-p4 = Point (1.2,4.0)
+    area = (x2 - x1) * (y3 - y1) - (y2 - y1) * (x3 - x1)
-p5 = Point (0.7,4.7)
-p6 = Point (1.0,1.0)
-p7 = Point (3.0,5.2)
-p8 = Point (4.0,4.0)
-p9 = Point (3.5,1.5)
-pA = Point (0.5,1.0)
-points = [p0,p1,p2,p3,p4,p5,p6,p7,p8,p9,pA]
+bottomLeft :: [Point2D] -> Point2D
--- Actually, I'd leave it as EQ, GT, LT.  Then, actually,
+bottomLeft = swap . foldr1 min . map swap
--- if you wanted to sort points rotationally around a single point,
--- sortBy (dir x) would actually work. --wasserman.louis@gmail.com
---Get direction of single set of line segments
-dir :: Point -> Point -> Point -> Direction
-dir (Point (ax, ay)) (Point (bx, by)) (Point (cx, cy)) = case sign of
-                                  EQ -> Straight
-                                  GT -> LeftTurn
-                                  LT -> RightTurn
-                                  where sign = compare ((bx - ax) * (cy - ay))  ((by - ay) * (cx - ax))
+sortOnPolar :: [Point2D] -> [Point2D]
---Get a list of Directions from a list of Points
-dirlist :: [Point] -> [Direction]
+sortOnPolar [] = []
+sortOnPolar ps = origin : sortOn polar rest
-dirlist (x:y:z:xs) = dir x y z : dirlist (y:z:xs)
+  where
-dirlist _ = []
+    polar (x, y) = atan2 (y - y0) (x - x0)
+    origin@(x0, y0) = bottomLeft ps
+    rest = filter (/= origin) ps
+grahamScan :: [Point2D] -> [Point2D]
---Compare Y axes
-sortByY :: [Point] -> [Point]
+grahamScan [] = []
+grahamScan (p : ps) = grahamScan' [p] ps
-sortByY xs = sortBy lowestY xs
+  where
-             where lowestY (Point(x1,y1)) (Point (x2,y2)) = compare (y1,x1) (y2,x2)
+    grahamScan' xs [] = xs
---get COT of line defined by two points and the x-axis
+    grahamScan' xs [y] = y : xs
-pointAngle :: Point -> Point -> Double
+    grahamScan' xs'@(x : xs) (y : z : ys)
-pointAngle (Point (x1, y1)) (Point (x2, y2)) = (x2 - x1) / (y2 - y1)
+      | turning x y z == TurnLeft = grahamScan' (y : xs') (z : ys)
+      | otherwise = grahamScan' xs (x : z : ys)
+convex :: [Point2D] -> [Point2D]
---compare based on point angle
+convex = grahamScan . sortOnPolar
-pointOrdering :: Point -> Point -> Ordering
+</haskell>
-pointOrdering a b = compare (pointAngle a b) 0.0
---Sort by angle
-sortByAngle :: [Point] -> [Point]
-sortByAngle ps = bottomLeft : sortBy (compareAngles bottomLeft) (tail (sortedPs))
-                where sortedPs = sortByY ps
-                      bottomLeft = head (sortedPs)
+== Test ==
+<haskell>
+import Control.Monad
+import Convex (convex)
+import Data.Function ((&))
+import Data.List (sort)
+import Test.QuickCheck
+convexIsStable n =
---Compare angles
+  forAll
-compareAngles :: Point -> Point -> Point -> Ordering
+    (replicateM n arbitrary)
-compareAngles = comparing . pointAngle
+    (\xs -> (xs & convex & sort) == (xs & convex & convex & sort))
+main :: IO ()
---Graham Scan
+main = do
-gscan :: [Point] -> [Point]
+  putStrLn "Running tests..."
-gscan ps = scan (sortByAngle ps)
+  mapM checkN [0, 1, 2, 3, 4, 5, 10, 100, 1000]
-          where scan (x:y:z:xs) = if dir x y z == RightTurn
+  putStrLn "done."
-                                  then x: scan (z:xs)
+  where
-                                  else x: scan (y:z:xs)
+    checkN :: Int -> IO ()
-                scan [x,y] = [x,y] -- there's no shame in a pattern match
+    checkN n = do
-                                   -- of this type!
-                scan _ = []
+      putStrLn $ "size: " ++ show n
+      quickCheck (convexIsStable n)
 </haskell>
+The results are:
+<haskell>
+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.
+</haskell>
+[[Category:Code]]

Difference between revisions of "Graham Scan Implementation"

Latest revision as of 03:42, 14 August 2021

Test

Navigation menu

Search