2D Catmull Clark Subdivision in Elm

CatmullClarkSubdivision2D.elm

import Graphics.Collage (move, filled, circle, Form, collage)
import Graphics.Element (Element)
import List (map, map2, (::), head, tail)
import Color (rgb)

--- GLOBALS YOU CAN MESS WITH

pointSize  = 3             -- THE SIZE OF THE POINTS
pointColor = rgb 255 100 0 -- THE COLOR OF THE POINTS
iterations = 5             -- NUMBER OF ITERATIONS OF CATMULL-CLARK SUBDIVISION

-- 2D POINT TYPE

type alias Point = {
  x : Float,
  y : Float
}


origin = Point 0 0

-- CALCULATES THE MIDPOINT BETWEEN TWO POINTS
midpoint : Point -> Point -> Point
midpoint p q = 
  Point ((p.x + q.x) / 2) ((p.y + q.y) / 2)

-- INTERLEAVE THE ELEMENTS OF A LIST WITHIN ANOTHER LIST
interleave : List a -> List a -> List a
interleave list1 list2 = 
  case list1 of
    []      -> list2
    x :: xs -> 
      case list2 of
        []      -> list1
        y :: ys -> y :: x :: interleave xs ys


-- A SQUARE  
square : Point -> Float -> List Point
square {x, y} size = 
  let halfSize = size / 2
  in
    [Point (x + halfSize) (y + halfSize),
     Point (x - halfSize) (y + halfSize),
     Point (x - halfSize) (y - halfSize),
     Point (x + halfSize) (y - halfSize)]
     
-- A RHOMBUS FROM 30 60 90 TRIANGLES
rhombus {x, y} size = 
  let shortHalf = size / 2
      longHalf  = (sqrt 3) * shortHalf
  in
    [Point 0 (y + shortHalf),
     Point (x - longHalf) 0,
     Point 0 (y - shortHalf),
     Point (x + longHalf) 0]
     
-- AN EQUILATERAL TRIANGLE
triangle {x, y} size = 
  let halfSize = size / 2
  in 
    [Point (x + halfSize * cos 0) (y + halfSize * sin 0),
     Point (x + halfSize * cos (degrees 120)) (y + halfSize * sin (degrees 120)),
     Point (x + halfSize * cos (degrees 240)) (y + halfSize * sin (degrees 240))]
     
-- CATMULL CLARK SUBDIVISION: SPLIT THEN REAVERAGE REPEAT

split : List Point -> (List Point, List Point)
split points = 
  let averages = map2 midpoint points (tail points ++ [head points])
  in (points, averages)
  
reAverage : (List Point, List Point) -> (List Point, List Point)
reAverage (points, averages) =
  let newAverages = map2 midpoint averages (tail points ++ [head points])
  in (newAverages, averages)

join : (List Point, List Point) -> List Point
join (points, averages) = 
  interleave points averages
  
subDivide : List Point -> List Point
subDivide = split >> reAverage >> join  


catmullClarkSubdivision : Int -> List Point -> List Point
catmullClarkSubdivision iterations = 
  if iterations <= 0
  then identity
  else subDivide >> catmullClarkSubdivision (iterations - 1)

--

-- DRAW A POINT   
drawPoint : Point -> Form
drawPoint {x, y} = 
  move (x,y) <| filled pointColor (circle pointSize)
  
-- DRAW A LIST OF POINTS
render : List Point -> Element
render = collage 400 400 << map drawPoint

-- THE MAIN FUNCTION
--main = render <| catmullClarkSubdivision iterations <| square origin 200
--main = render <| catmullClarkSubdivision iterations <| rhombus origin 200
main = render <| catmullClarkSubdivision iterations <| triangle origin 200