-- Sutherland-Hodgman (1974) re-entrant polygon clipping

#load "libthread"
#load "libsessiontype"

open SessionType

--
-- We first build a tiny 3-D geometry library
--

-- Points and planes in R^3.
type point = { x, y, z : float }
type plane = [ `Plane of float * float * float * float ]

-- We use the plane `Plane(a, b, c, d) to represent the open half-space
-- { Point(x, y, z) | ax + by + cz + d > 0 }

let string_of_point p =
    "(" ^ string_of p.x ^ ", " ^ string_of p.y ^ ", " ^ string_of p.z ^ ")"

let string_of_plane (`Plane(a, b, c, d): plane) =
    string_of a ^ "x + " ^ string_of b ^ "y + " ^
    string_of c ^ "z + " ^ string_of d ^ " > 0"

(* Some of this should be in the library! *)
let splitWhile : ('a -> bool) -> 'a list -> 'a list * 'a list
  = fun pred ->
      let rec loop (acc: 'a list) (xs: 'a list) : 'a list * 'a list =
                match xs with
                | []         -> (rev acc, [])
                | (x ∷ xs') -> if pred x
                                   then loop (x ∷ acc) xs'
                                   else (rev acc, xs)
       in loop []

let not (b: bool) = if b then false else true

let notp (pred: 'a -> bool): 'a -> bool =
  fun a -> not (pred a)

let isSpace (c: char): bool =
  match c with
  | ' '  -> true
  | '\t' -> true
  | '\n' -> true
  | '\r' -> true
  | _    -> false

let dropSpace (cs : char list) : char list =
  let (_, result) = splitWhile isSpace cs in result

let parsePoint (s : string) : point =
  let foil (x: char list) = float_of_string (implode x) in
    let cs = explode s in
    let ('(' ∷ cs) = dropSpace cs in
    let (x, (_ ∷ cs)) = splitWhile (notp ((==) ',')) (dropSpace cs) in
    let (y, (_ ∷ cs)) = splitWhile (notp ((==) ',')) (dropSpace cs) in
    let (z, (_ ∷ cs)) = splitWhile (notp ((==) ')')) (dropSpace cs) in
      { x = foil x, y = foil y, z = foil z }

let parsePlane (s: string) : plane =
  let foil (x: char list) = float_of_string (implode x) in
    let cs = explode s in
    let (a, (_ ∷ cs)) = splitWhile (notp ((==) 'x')) (dropSpace cs) in
    let ('+' ∷ cs)    = dropSpace cs in
    let (b, (_ ∷ cs)) = splitWhile (notp ((==) 'y')) (dropSpace cs) in
    let ('+' ∷ cs)    = dropSpace cs in
    let (c, (_ ∷ cs)) = splitWhile (notp ((==) 'z')) (dropSpace cs) in
    let ('+' ∷ cs)    = dropSpace cs in
    let (d, (_ ∷ cs)) = splitWhile (notp ((==) '>')) (dropSpace cs) in
    let ('0' ∷ cs)    = dropSpace cs in
      `Plane (foil a, foil b, foil c, foil d)

-- Is the point above the plane?  (i.e., in the semi-space)
let isPointAbovePlane { x, y, z } (`Plane(a, b, c, d)) =
  a *. x +. b *. y +. c *. z +. d >. 0.0

-- Does the line segment between the two points intersect the plane,
-- and if so, where?
let intersect p1 p2 (`Plane(a, b, c, d) as plane) =
 if isPointAbovePlane p1 plane == isPointAbovePlane p2 plane
   then None
   else let t = (a *. p1.x +. b *. p1.y +. c *. p1.z +. d) /.
                (a *. (p1.x -. p2.x) +.
                 b *. (p1.y -. p2.y) +.
                 c *. (p1.z -. p2.z)) in
        let x = p1.x +. (p2.x -. p1.x) *. t in
        let y = p1.y +. (p2.y -. p1.y) *. t in
        let z = p1.z +. (p2.z -. p1.z) *. t in
          Some { x, y, z }

--
-- In sublanguage A, our protocol is to send an unbounded
-- sequence of points:
--

type 'a stream = mu 'x. 1 |&| ?'a; 'x

--
-- Each transducer takes a plane to clip by, and two rendezvous objects,
-- the first on which it expects to receive points, and the second on
-- which it will send points.
--

let clipper (plane: plane)
               (ic: point stream channel)
               (oc: point stream dual channel): unit =
       let finish (oc: point stream dual channel) =
             sel1 oc; () in
       let put (oc: point stream dual channel) (pt: point) =
             send (sel2 oc) pt in
       let putCross (oc: point stream dual channel)
                    (p1: point) (p2: point) =
             match intersect p1 p2 plane with
             | Some pt -> put oc pt
             | None    -> oc in
       let putVisible (oc: point stream dual channel)
                      (pt: point) =
             if isPointAbovePlane pt plane
               then put oc pt
               else oc in
         match follow ic with
         | Left _   -> finish oc
         | Right ic ->
             let (pt0, ic) = recv ic in
             let rec loop (ic: point stream channel)
                          (oc: point stream dual channel)
                          (pt: point) : unit =
                       let oc = putVisible oc pt in
                         match follow ic with
                         | Left _   -> let oc = putCross oc pt pt0 in
                                         finish oc
                         | Right ic -> let (pt', ic) = recv ic in
                                       let oc = putCross oc pt pt' in
                                         loop ic oc pt'
               in loop ic oc pt0

let printer : point stream channel -> unit =
  let rec loop (ic: point stream channel): unit =
            match follow ic with
            | Left _   -> ()
            | Right ic -> let (pt, ic) = recv ic in
                            putStrLn (string_of_point pt);
                            loop ic
   in loop

-- The main protocol for the program, which lets us split our parser
-- from our main loop.
type main_prot = mu 'x. point stream |&| ?plane; 'x

let parser : main_prot dual channel -> unit =
  let rec plane_loop (oc: main_prot dual channel): unit =
            match getLine () with
            | "" -> point_loop (sel1 oc)
            | s  -> let plane = parsePlane s in
                    let oc    = send (sel2 oc) plane in
                      plane_loop oc
      and point_loop (oc: point stream dual channel): unit =
            match getLine () with
            | "" -> sel1 oc; ()
            | s  -> let point = parsePoint s in
                    let oc    = send (sel2 oc) point in
                      point_loop oc
   in plane_loop

let main : unit -> unit =
  let rec get_planes (acc: plane list) (ic: main_prot channel)
                     : plane list * point stream channel =
            match follow ic with
            | Left ic  -> (rev acc, ic)
            | Right ic -> let (plane, ic) = recv ic in
                            get_planes (plane ∷ acc) ic in
  let rec connect (planes: plane list)
                  (ic: point stream channel)
                  : point stream channel =
            match planes with
            | []              -> ic
            | plane ∷ rest ->
                let outrv : point stream rendezvous = newRendezvous () in
                  AThread.fork (fun () ->
                    clipper plane ic (accept outrv));
                  connect rest (request outrv) in
  fun () ->
    let rv           = newRendezvous () : main_prot rendezvous in
    let _            = AThread.fork (fun () -> parser (accept rv)) in
    let (planes, ic) = get_planes [] (request rv) in
    let ic           = connect planes ic in
      printer ic

in
  main ()