Source code in the ocaml programming language

let is_inside (x,y) ((ax,ay), (bx,by)) =
  (bx -. ax) *. (y -. ay) > (by -. ay) *. (x -. ax)

let intersection (sx,sy) (ex,ey) ((ax,ay), (bx,by)) =
  let dc_x, dc_y = (ax -. bx, ay -. by) in
  let dp_x, dp_y = (sx -. ex, sy -. ey) in
  let n1 = ax *. by -. ay *. bx in
  let n2 = sx *. ey -. sy *. ex in
  let n3 = 1.0 /. (dc_x *. dp_y -. dc_y *. dp_x) in
  ((n1 *. dp_x -. n2 *. dc_x) *. n3,
   (n1 *. dp_y -. n2 *. dc_y) *. n3)

let last lst = List.hd (List.rev lst)

let polygon_iter_edges poly f init =
  if poly = [] then init else
    let p0 = List.hd poly in
    let rec aux acc = function
      | p1 :: p2 :: tl -> aux (f (p1, p2) acc) (p2 :: tl)
      | p :: [] -> f (p, p0) acc
      | [] -> acc
    in
    aux init poly

let poly_clip subject_polygon clip_polygon =
  polygon_iter_edges clip_polygon (fun clip_edge input_list ->
    fst (
      List.fold_left (fun (out, s) e ->

        match (is_inside e clip_edge), (is_inside s clip_edge) with
        | true, false -> (e :: (intersection s e clip_edge) :: out), e
        | true, true -> (e :: out), e
        | false, true -> ((intersection s e clip_edge) :: out), e
        | false, false -> (out, e)

      ) ([], last input_list) input_list)

  ) subject_polygon

let () =
  let subject_polygon =
    [ ( 50.0, 150.0); (200.0,  50.0); (350.0, 150.0);
      (350.0, 300.0); (250.0, 300.0); (200.0, 250.0);
      (150.0, 350.0); (100.0, 250.0); (100.0, 200.0); ] in

  let clip_polygon =
    [ (100.0, 100.0); (300.0, 100.0); (300.0, 300.0); (100.0, 300.0) ] in

  List.iter (fun (x,y) ->
      Printf.printf " (%g, %g)\n" x y;
    ) (poly_clip subject_polygon clip_polygon)


let subject_polygon =
  [ ( 50.0, 150.0); (200.0,  50.0); (350.0, 150.0);
    (350.0, 300.0); (250.0, 300.0); (200.0, 250.0);
    (150.0, 350.0); (100.0, 250.0); (100.0, 200.0); ]

let clip_polygon =
  [ (100.0, 100.0); (300.0, 100.0); (300.0, 300.0); (100.0, 300.0) ]

let () =
  Graphics.open_graph " 400x400";
  let to_grid poly =
    let round x = int_of_float (floor (x +. 0.5)) in
    Array.map
      (fun (x, y) -> (round x, round y))
      (Array.of_list poly)
  in
  let draw_poly fill stroke poly =
    let p = to_grid poly in
    Graphics.set_color fill;
    Graphics.fill_poly p;
    Graphics.set_color stroke;
    Graphics.draw_poly p;
  in
  draw_poly Graphics.red Graphics.blue subject_polygon;
  draw_poly Graphics.cyan Graphics.blue clip_polygon;
  draw_poly Graphics.magenta Graphics.blue (poly_clip subject_polygon clip_polygon);
  let _ = Graphics.wait_next_event [Graphics.Button_down; Graphics.Key_pressed] in
  Graphics.close_graph ()