Difference between revisions of "Graham Scan Implementation"

From HaskellWiki
Jump to navigation Jump to search
m
 
(11 intermediate revisions by 5 users not shown)
Line 2: Line 2:
   
 
<haskell>
  
<haskell>
  +
import Data.Function (on, (&))
−
--Graham Scan exercise
  
  +
import Data.List (sortOn, tails)
  +
import Data.Tuple (swap)
   
  +
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
−
--Get direction of single set of line segments
  
  +
bottomLeft = swap . foldr1 min . map swap
−
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)) 0
  
   
  +
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)) = if y1 == y2
 
  +
grahamScan' xs [] = xs
−
then compare x1 x2
  
  +
grahamScan' xs [y] = y : xs
−
else compare y1 y2
  
  +
grahamScan' xs'@(x : xs) (y : z : ys)
−
--get COT of line defined by two points and the x-axis
  
  +
| turning x y z == TurnLeft = grahamScan' (y : xs') (z : ys)
−
pointAngle :: Point -> Point -> Double
  
  +
| otherwise = grahamScan' xs (x : z : ys)
−
pointAngle (Point (x1, y1)) (Point (x2, y2)) = (x2 - x1) / (y2 - y1)
  
   
  +
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 base a b = compare (pointAngle base b) (pointAngle base a)
  
  +
(\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:[])
 
−
scan _ = []
 +
checkN n = do
  +
putStrLn $ "size: " ++ show n
  +
quickCheck (convexIsStable n)
 
</haskell>
  
</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]]

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.
Retrieved from "https://wiki.haskell.org/index.php?title=Graham_Scan_Implementation&oldid=64702"