sierpinski.ml

open Graphics

let (|+) (x1, y1) (x2, y2) =
  x1 +. x2, y1 +. y2

let (|-) (x1, y1) (x2, y2) =
  x1 -. x2, y1 -. y2

let (|*) s (x, y) =
  s *. x, s *. y

let int = int_of_float

type frame = {
  origin : float * float;
  edge1 : float * float;
  edge2 : float * float;
}

let top_frame () =
  let shift = (10.0, 10.0) in
  let wx, wy = (float_of_int (size_x ()),
				float_of_int (size_y ()))
			 |- (2.0 |* shift)
  in
	{ origin = shift;
	  edge1 = (wx, 0.);
	  edge2 = (0., wy) }

let map_coord fr =
  fun (vx, vy) ->
	fr.origin
  |+ (vx |* fr.edge1)
  |+ (vy |* fr.edge2)

let segment_painter slist =
  fun fr ->
	let cmap = map_coord fr in
	let draw_segment (_start, _end) =
	  let (x0, y0), (x1, y1) =
		cmap _start, cmap _end
	  in
		moveto (int x0) (int y0);
		lineto (int x1) (int y1)
	in
	  List.iter draw_segment slist

let transform painter origin corner1 corner2 =
  fun fr ->
	let cmap = map_coord fr in
	let new_orig = cmap origin in
	let new_frame = { origin = new_orig;
					  edge1 = (cmap corner1) |- new_orig;
					  edge2 = (cmap corner2) |- new_orig }
	in
	  painter new_frame

let beside p1 p2 =
  let left =
	transform p1 (0.0, 0.0) (0.5, 0.0) (0.0, 1.0)
  and right =
	transform p2 (0.5, 0.0) (1.0, 0.0) (0.5, 1.0)
  in
	fun fr -> (left fr); (right fr)

let below p1 p2 =
  let top =
	transform p1 (0.0, 0.5) (1.0, 0.5) (0.0, 1.0)
  and bottom =
	transform p2 (0.0, 0.0) (1.0, 0.0) (0.0, 0.5)
  in
	fun fr -> (top fr); (bottom fr)

let flip_vert painter =
  transform painter
	(0.0, 1.0) (1.0, 1.0) (0.0, 0.0)

let flip_horiz painter =
  transform painter
	(1.0, 0.0) (0.0, 0.0) (1.0, 1.0)

let half_in_center painter =
  transform painter
	(0.25, 0.0) (0.75, 0.0) (0.25, 1.0)

let rec right_split painter = function
	0 -> painter
  | n ->
	  let smaller = right_split painter (n-1) in
		(beside painter (below smaller smaller))

let rec bottom_split painter = function
	0 -> painter
  | n ->
	  let smaller = bottom_split painter (n-1) in
		(below painter (beside smaller smaller))

let triangle =
  segment_painter [
	(0.0, 0.0), (0.5, 1.0);
	(0.5, 1.0), (1.0, 0.0);
	(1.0, 0.0), (0.0, 0.0)
  ]

let rec sierpinski = function
	0 -> triangle
  | n->
	  let painter = sierpinski (n-1) in
		below (half_in_center painter)
		  (beside painter painter)

let _ =
  open_graph "";
  (sierpinski 7) (top_frame ())