type quad = White | Black | Node of quad * quad * quad * quad

let rec checker_board n =
  if n = 0 then Black
  else if n = 1 then Node (White, Black, White, Black)
  else let q = checker_board (n - 1) in
    Node (q, q, q, q)

let rec draw x y w = function
  | White -> ()
  | Black -> Graphics.fill_rect x y w w
  | Node (q1, q2, q3, q4) ->
    let w = w / 2 in
    draw x y w q1;
    draw (x + w) y w q2;
    draw (x + w) (y + w) w q3;
    draw x (y + w) w q4

let node = function
  | White, White, White, White -> White
  | Black, Black, Black, Black -> Black
  | q1, q2, q3, q4 -> Node (q1, q2, q3, q4)

let rec rotate = function
  | White -> White
  | Black -> Black
  | Node (q1, q2, q3, q4) ->
    node (rotate q4, rotate q1, rotate q2, rotate q3)

let rec mirror = function
  | White -> White
  | Black -> Black
  | Node (q1, q2, q3, q4) ->
    node (mirror q2, mirror q1, mirror q4, mirror q3)

type bit = Zero | One

let rec unparse = function
  | White -> [Zero]
  | Black -> [One]
  | Node (q1, q2, q3, q4) ->
    unparse q1 @
    unparse q2 @
    unparse q3 @
    unparse q4

let char_of_bit = function
  | Zero -> '0'
  | One -> '1'

let unparse l =
  unparse l |> List.map char_of_bit |> List.to_seq |> String.of_seq

let split l =
  let rec split_aux n l =
    match n, l with
    | 0, _ -> ([], l)
    | n, x :: r ->
      let l1, l2 = split_aux (n-1) r in
      (x :: l1, l2)
    | _ ->
      assert false in
  split_aux (List.length l / 2) l

let parse s =
  let bit_of_char = function
    | '1' -> One
    | '0' -> Zero
    | _ -> assert false in
  let color_of_bit = function
    | One -> Black
    | Zero -> White in
  let rec quad_of_bit = function
    | [q] -> color_of_bit q
    | l -> let ql, qu = split l in
      let q1, q2 = split ql
      and q3, q4 = split qu in
      let q1 = quad_of_bit q1 in
      let q2 = quad_of_bit q2 in
      let q3 = quad_of_bit q3 in
      let q4 = quad_of_bit q4 in
      Node (q1, q2, q3, q4) in
  let s = String.fold_left (fun a e -> bit_of_char e :: a) [] s in
  let s = List.rev s in
  quad_of_bit s

let _pp_bit =
  let pp = function
    | Zero -> Format.printf "0"
    | One -> Format.printf "1" in
  List.iter pp

let () =
  let board = checker_board 3 in
  Format.eprintf "%s@." (unparse board)

let () =
  Graphics.open_graph " 3x3";
  let board = checker_board 3 in
  draw 0 0 256 board;
  ignore (Graphics.read_key ());
  Graphics.clear_graph ();
  let m_board = mirror board in
  draw 0 0 256 (m_board);
  ignore (Graphics.read_key ());
  Graphics.clear_graph ();
  draw 0 0 256 (rotate m_board);
  ignore (Graphics.read_key ());
  Graphics.clear_graph ()

let frac4 = Node (Black, White, Black, Black)
let frac3 = Node (White, Black, Black, Black)
let frac2 = Node (Black, Black, Black, White)
let frac1 = Node (Black, Black, White, Black)

let frac = Node (frac1, frac2, frac3, frac4)

let () =
  Graphics.open_graph " 3x3";
  draw 0 0 256 frac;
  ignore (Graphics.read_key ())

let () =
  let s = "0101" in
  let q = parse s in
  Graphics.open_graph " 3x3";
  draw 0 0 256 q;
  ignore (Graphics.read_key ())

let () =
  let s =
    "0101010101010101010101010101010101010101010101010101010101010101"
  in
  let q = parse s in
  let s' = unparse q in
  assert (s = s');
  Graphics.open_graph " 3x3";
  draw 0 0 256 q;
  ignore (Graphics.read_key ())

This document was generated using caml2html