Haskell – Convex Hull – Graham Scan
===================================
December 16, 2017
Playing with Convex Hulls (via Graham Scan) and SVG Export in Haskell:
This is an embedded SVG generated by the Haskell programm below:
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ {.haskell .numberLines}
---------------------------------------------------------------------------------------------
--
-- GRAHAM SCAN IMPLEMENTATION
--
-- This little haskell programm calulates the Convex Hull for a set of 2D points.
-- It ships wit a main function that feeds the Graham Scan algorithm with some
-- random points and generates a simple SVG of the input points and resulting envelope.
-- A simple SVG encoder is included.
--
-- Alogrithm used: https://en.wikipedia.org/wiki/Graham_scan
--
-- CREDITS --
--
-- Michal Idziorek
-- 16 December 2017
--
---------------------------------------------------------------------------------------------
import Data.List
import System.Random
---------------------------------------------------------------------------------------------
-- GRAHAM SCAN --
-- Three points are clockwise if ccw < 0.
ccw (p1x,p1y) (p2x,p2y) (p3x,p3y) = (p2x - p1x)*(p3y - p1y) - (p2y - p1y)*(p3x - p1x)
-- Calculate the slope defined by 2 points. (return Infinity, if points are identical).
slope (ax,ay) (bx,by) | (ax,ay ) == (bx,by) = 1/0 -- Infinity
| otherwise = (bx-ax)/(by-ay)
-- Comparison function to sort points counterclockwise (given a reference point).
slope_cmp a b c = compare (slope a c) (slope a b)
-- Comparison function using the y and x coordinates for ordering.
graham_cmp (ax,ay) (bx,by) | ay /= by = compare ay by
| otherwise = compare ax bx
-- Graham scan on prepared data. this will calculate the convex hull.
graham_calc [] hs = hs
graham_calc (x1:xs) hh | length(hh) < 2 = graham_calc xs (x1:hh)
graham_calc xx@(x1:xs) hh@(h1:h2:hs) | ccw x1 h1 h2 < 0 = graham_calc xs (x1:hh)
| otherwise = graham_calc xx (h2:hs)
-- Find the starting point, sort all points counterclockwise and perform the graham scan.
graham xs = graham_calc sortedPoints []
where minPoint = minimumBy graham_cmp xs
sortedPoints = sortBy (slope_cmp minPoint) xs
---------------------------------------------------------------------------------------------
-- XML ENCODING--
xml_attr (x:xs) = x++"=\""++(head xs)++"\" "
xml_enc tag attrs body = "<"++tag++" "++xml_attrs++">"++body++""
where xml_attrs = unlines $ map xml_attr attrs
-- SVG ENCODING --
-- hardcoded scaling and panning function
svg_transf x = x*30+5
line_to_svg ((x1,y1),(x2,y2)) = xml_enc "line" [["x1",show lx1],["y1",show ly1],
["x2",show lx2],["y2",show ly2],
["style", "stroke:rgb(255,0,0);stroke-width:2"]] ""
where lx1=svg_transf x1
lx2=svg_transf x2
ly1=svg_transf y1
ly2=svg_transf y2
point_to_svg (x,y) = xml_enc "circle" [["cx",show cx],["cy",show cy],["r","5"],
["fill","rgb(30,150,"++(show (floor dist))++")"]] ""
where cx=svg_transf x
cy=svg_transf y
dist= (sqrt ((x-5)*(x-5) + (y-5)*(y-5)))*255/8
-- draws SVG points and lines (in hardcoded sizes and colors)
svg_draw p l = xml_enc "svg" [style,["width","330"],["height","330"]] body
where style = ["style",
"background-color:black;border:3px solid green;margin:2px;"]
body = (unlines (map point_to_svg p )) ++
(unlines (map line_to_svg l ))
-- calculate convex hull and generate svg
svg_graham xs = svg_draw xs (zip hull hull_open)
where hull_open = graham xs
hull = (last hull_open) : hull_open
-- RANDOMIZING --
randomPoints g cnt = take cnt (zip r10a r10b)
where r5 = randomRs (0,5) g :: [Double]
r10a =zipWith (+) r5 (drop cnt r5)
r10b =zipWith (+) (drop (2*cnt) r5) (drop (3*cnt) r5)
---------------------------------------------------------------------------------------------
-- MAIN --
-- Note that this is the only place of impurity in this source-file.
-- Is is subject to side effects due to I/O (we are writng to stdout)
-- and the random number generator.
main = do
g <- newStdGen
putStr (svg_graham (randomPoints g 25))
putStr (svg_graham (randomPoints g 50))
putStr (svg_graham (randomPoints g 100))
putStr (svg_graham (randomPoints g 250))
putStr (svg_graham (randomPoints g 500))
putStr (svg_graham (randomPoints g 1500))
---------------------------------------------------------------------------------------------
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~