purely_functional_matrix.ml

module Data = struct
  type color = I | J | L | O | S | T | Z
  type cell = NoCell | Garbage | CI | CJ | CL | CO | CS | CT | CZ
  let cell_of_color (co: color): cell = Obj.magic (2 + Obj.magic co)
  let char_of_cell (cl: cell): char = ".GIJLOSTZ".[Obj.magic cl]
  let char_of_color co = char_of_cell (cell_of_color co)
end

module type Matrix_S = sig
  type t
  val empty: t
  val test: (int * int) list -> t -> bool
  val printl: out_channel -> t -> unit

  type color
  val blit: (int * int * color) list -> t -> t
end

module Matrix: Matrix_S
       with type color := Data.color = struct
  module Row = struct
    type t =
      {mutable sealed: bool;
       mutable count: int;
       cells: Data.cell array}

    let empty = {sealed = true; count = 0; cells = Array.make 10 Data.NoCell}
    let count r = r.count
    let get x r = r.cells.(x)
    let copy r = {sealed = false; count = r.count; cells = Array.copy r.cells}
    let seal r = r.sealed <- true
    let cow r = if r.sealed then copy r else r

    let set x c r =
      let r = cow r in
      if r.cells.(x) = NoCell then r.count <- r.count + 1; 
      r.cells.(x) <- Data.cell_of_color c;
      r

    let to_string r =
      String.init 10 (fun x -> Data.char_of_cell r.cells.(x))
  end

  type t =
    {height: int;
     rows: Row.t list}

  let empty = {height = 0; rows = []}
  let of_rows rows = let height = List.length rows in {height; rows}

  let printl oc m =
    let rec iter i = function
      | r::rs -> Printf.fprintf oc "%2d |%s|\n" i (Row.to_string r);
                 iter (i - 1) rs
      | []    -> ()
    in
    iter (m.height - 1) (List.rev m.rows);
    Printf.fprintf oc "    0123456789 \n"

  let test locs m =
    let rec search y rows locs =
      match rows, locs with
      | _, [] -> false
      | [], _ -> false
      | r::rows', (lx, ly)::locs' ->
         assert (ly >= y);
         if ly = y
         then Row.get lx r <> NoCell ||
                search y rows locs'
         else search (y+1) rows' locs
    in
    let rec filter acc = function
      | [] ->
         let locs = List.sort (fun (_, y1) (_, y2) -> y1 - y2) acc in
         search 0 m.rows locs
      | (lx, ly)::ls ->
         if lx < 0 || ly < 0 || lx >= 10 
         then true
         else if ly >= m.height
         then false
         else filter ((lx, ly)::acc) ls
    in
    filter [] locs

  let blit cells m =
    let rec build y front back cells =
      match cells with
      | (cx, cy, cc)::next ->
         let r, rs = match front with
           | r::rs -> r, rs
           | []    -> Row.empty, [] in
         assert (cy >= y);
         if cy = y
         then let r = Row.set cx cc r in
              build y     (r::rs) back      next
         else build (y+1) rs      (r::back) cells
      | [] ->
         match back with
         | r::rs -> Row.seal r; build y (r::front) rs []
         | []    -> of_rows front
    in
    build 0 m.rows [] @@
      List.stable_sort (fun (_, y1, _) (_, y2, _) -> y1 - y2) cells
end