Graham Scan in Haskell

The last exercise in chapter 3 of Real World Haskell is quite more difficult than the previous ones, so it deserves a post with code. I have not used any function not yet seen at that point in the book, so the code is not very pretty, and I have followed quite closely the algorithm for Graham Scan as explained in Introduction to Algorithms, which can also be seen here.

When I learn a bit more about Haskell syntax I will try to pretify it, but for the moment here it goes in all its uglyness:


data Direction = LeftTurn
    | RightTurn
    | Straight
      deriving (Eq, Show)

turn (x1,y1) (x2,y2) (x3,y3)
     | cross_product == 0 = Straight
     | cross_product > 0 = LeftTurn
     | cross_product < 0 = RightTurn
     where
       cross_product = (x2 - x1)*(y3 - y1) - (y2 - y1)*(x3 - x1)

miny [x] = x
miny ((x1,y1):(x2,y2):xs)
     | y1 < y2 = miny ((x1,y1):xs)
     | y2 < y1 = miny ((x2,y2):xs)
     | x1 < x2 = miny ((x1,y1):xs)
     | x2 < x1 = miny ((x2,y2):xs)
     | otherwise = error "repeated points"

removepoint _ [] = []
removepoint (x,y) ((x1,y1):xs)
    | x == x1 && y == y1 = xs
    | otherwise = (x1,y1):removepoint (x,y) xs

sort_merge_polar origin [] = []
sort_merge_polar origin [x] = [x]
sort_merge_polar (x1,y1) lista =
    merge (sort_merge_polar (x1,y1) (take midpoint lista)) (sort_merge_polar (x1,y1) (drop midpoint lista))
        where
          midpoint = div (length lista) 2
          merge [] [] = []
          merge [] lisb = lisb
          merge lisa [] = lisa
          merge ((x2,y2):xs) ((x3,y3):ys)
              | turn (x1,y1) (x2,y2) (x3,y3) == LeftTurn = (x2,y2) : merge xs ((x3,y3):ys)
              | turn (x1,y1) (x2,y2) (x3,y3) == RightTurn = (x3,y3) : merge ((x2,y2):xs) ys
              | turn (x1,y1) (x2,y2) (x3,y3) == Straight = further_point : merge xs ys
              where further_point
                        | abs(x2 - x1) > abs(x3 - x1) = (x2,y2)
                        | abs(x2 - x1) < abs(x3 - x1) = (x3,y3)
                        | abs(y2 - y1) > abs(y3 - y1) = (x2,y2)
                        | abs(y2 - y1) < abs(y3 - y1) = (x3,y3)
                        | otherwise = error "repeated points.."

graham_scan (pa:pb:pc:ps) = result
    where
      p0 = miny (pa:pb:pc:ps)
      sorted_list = sort_merge_polar p0 (removepoint p0 (pa:pb:pc:ps))
      p1 = head sorted_list
      p2 = head (tail sorted_list)
      result = iterate_graham [p2,p1,p0] (tail (tail sorted_list))
      iterate_graham convex_hull [] = reverse(convex_hull)
      iterate_graham (top:ntop:xs) (pi:ps)
          | turn ntop top pi == RightTurn = iterate_graham (ntop:xs) (pi:ps)
          | turn ntop top pi == LeftTurn = iterate_graham (pi:top:ntop:xs) ps
          | turn ntop top pi == Straight = error "didn't I get rid of straight points relative to p0??"

graham_scan _ = error "we need at least three points"


As a basic test, if we compute the Convex Hull of the following points, we get the correct result. Other online solutions seem to choke on inputs like this, probably due to an incorrect implementation of the Graham Scan algorithm.

*Main> graham_scan [(10,0), (10,1),(-10,1),(-10,0),(-7,0),(-10,2),(-10,3),(-4,1),(-2,2),(-12,1)]
[(-10,0),(10,0),(10,1),(-10,3),(-12,1)]
*Main>