Difference between revisions of "Graham Scan Implementation"

From HaskellWiki
Jump to: navigation, search
m (fixup Pt definition)
(concise implementation)
 
Line 2: Line 2:
   
 
<haskell>
 
<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)
deriving (Show, Eq, Ord)
 
   
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 sign = compare ((bx - ax) * (cy - ay)) ((cx - ax) * (by - ay))
+
where
  +
area = (x2 - x1) * (y3 - y1) - (y2 - y1) * (x3 - x1)
   
gScan :: [Pt] -> [Pt]
+
bottomLeft :: [Point2D] -> Point2D
gScan pts
+
bottomLeft = swap . foldr1 min . map swap
| 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
 
   
-- Sort other points based on angle
 
  +
sortOnPolar :: [Point2D] -> [Point2D]
rests = tail (sortBy (compare `on` compkey pt0) pts) where
 
  +
sortOnPolar [] = []
compkey (Pt (x0, y0)) (Pt (x, y)) = (atan2 (y - y0) (x - x0),
 
  +
sortOnPolar ps = origin : sortOn polar rest
abs (x - x0))
 
  +
where
  +
polar (x, y) = atan2 (y - y0) (x - x0)
  +
origin@(x0, y0) = bottomLeft ps
  +
rest = filter (/= origin) ps
   
-- Scan the points to find out convex
 
  +
grahamScan :: [Point2D] -> [Point2D]
-- -- handle the case that all points are collinear
 
  +
grahamScan [] = []
scan [p0] (p1:ps)
 
  +
grahamScan (p : ps) = grahamScan' [p] ps
| isTurned pz p0 p1 == STRAIGHT = [pz, p0]
 
  +
where
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)
   
scan (x:xs) (y:z:rsts) = case isTurned x y z of
 
  +
convex :: [Point2D] -> [Point2D]
RIGHT -> scan xs (x:z:rsts)
 
  +
convex = grahamScan . sortOnPolar
STRAIGHT -> scan (x:xs) (z:rsts) -- skip collinear points
 
LEFT -> scan (y:x:xs) (z:rsts)
 
 
scan xs [z] = z : xs
 
 
</haskell>
 
</haskell>
   
Line 42: Line 45:
 
== Test ==
 
== Test ==
 
<haskell>
 
<haskell>
  +
import Control.Monad
  +
import Convex (convex)
  +
import Data.Function ((&))
  +
import Data.List (sort)
 
import Test.QuickCheck
 
import Test.QuickCheck
import Control.Monad
 
import Data.List
 
   
  +
convexIsStable n =
  +
forAll
  +
(replicateM n arbitrary)
  +
(\xs -> (xs & convex & sort) == (xs & convex & convex & sort))
   
convex' = map (\(Pt x) -> x) . convex . map Pt
 
  +
main :: IO ()
 
  +
main = do
prop_convex n = forAll (replicateM n arbitrary) (\xs -> sort (convex' xs) == sort (convex' (convex' xs)))
 
  +
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)
 
</haskell>
 
</haskell>
   
Line 56: Line 71:
   
 
<haskell>
 
<haskell>
> quickCheck (prop_convex 0)
 
  +
Running tests...
+++ OK, passed 100 tests.
 
  +
size: 0
> quickCheck (prop_convex 1)
 
 
+++ OK, passed 100 tests.
 
+++ OK, passed 100 tests.
> quickCheck (prop_convex 2)
 
  +
size: 1
 
+++ OK, passed 100 tests.
 
+++ OK, passed 100 tests.
> quickCheck (prop_convex 3)
 
  +
size: 2
 
+++ OK, passed 100 tests.
 
+++ OK, passed 100 tests.
> quickCheck (prop_convex 4)
 
  +
size: 3
 
+++ OK, passed 100 tests.
 
+++ OK, passed 100 tests.
> quickCheck (prop_convex 5)
 
  +
size: 4
 
+++ OK, passed 100 tests.
 
+++ OK, passed 100 tests.
> quickCheck (prop_convex 10)
 
  +
size: 5
 
+++ OK, passed 100 tests.
 
+++ OK, passed 100 tests.
> quickCheck (prop_convex 100)
 
  +
size: 10
 
+++ OK, passed 100 tests.
 
+++ OK, passed 100 tests.
> quickCheck (prop_convex 1000)
 
  +
size: 100
 
+++ OK, passed 100 tests.
 
+++ OK, passed 100 tests.
> quickCheck (prop_convex 10000)
 
  +
size: 1000
 
+++ OK, passed 100 tests.
 
+++ OK, passed 100 tests.
  +
done.
 
</haskell>
 
</haskell>

Latest 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.