(**************************************)
(* Déclarations des types de l'énoncé *)
(**************************************)

type color = White | Black

type tree =
  | Leaf of color
  | Node of tree * tree * tree * tree

type image = color array array

(* Ouvrir la fenêtre graphique *)

let () = Graphics.open_graph " 512x512"

(**************)
(* Question 1 *)
(**************)

let rec count_leaves = function
  | Leaf _ ->
      1
  | Node (c1, c2, c3, c4) ->
      count_leaves c1 +
      count_leaves c2 +
      count_leaves c3 +
      count_leaves c4

let a =
  Node (Node (Leaf White,
              Leaf White,
              Leaf Black,
              Leaf White),
        Leaf Black,
        Leaf Black,
        Leaf Black)

let () = assert (count_leaves a = 7)

(**************)
(* Question 2 *)
(**************)

let rec do_draw i j k = function
  | Leaf Black ->
      Graphics.fill_rect i j k k
  | Leaf White ->
      ()
  | Node (c1, c2, c3, c4) ->
      let k2 = k/2 in
      do_draw i (j+k2) k2 c1;
      do_draw (i+k2) (j+k2) k2 c2;
      do_draw i j k2 c3;
      do_draw (i+k2) j k2 c4

let draw_tree k a = do_draw 0 0 k a

(* Test de draw_tree *)
let rec q2 a =
  Graphics.clear_graph ();
  draw_tree 512 a;
  let rec do_rec () =
    let c = Graphics.read_key () in
    if c = 'q' then ()
    else do_rec ()
  in
  do_rec ()

let () = q2 a

let rec do_to_tree img x y k =
  if k <= 1 then
    Leaf img.(x).(y)
  else
    let k = k / 2 in
    let c1 = do_to_tree img x       (y + k) k
    and c2 = do_to_tree img (x + k) (y + k) k
    and c3 = do_to_tree img x       y       k
    and c4 = do_to_tree img (x + k) y       k in
    match c1, c2, c3, c4 with
    | Leaf n1, Leaf n2, Leaf n3, Leaf n4
      when n1 = n2 && n2 = n3 && n3 = n4 -> c1
    | _ -> Node (c1, c2, c3, c4)

let image_to_tree k img = do_to_tree img 0 0 k


(* Test de image_to_tree *)
let img =
[|
  [| Black; Black; Black; Black; Black; Black; Black; Black;
     Black; Black; Black; Black; White; White; White; White;  |];
  [| Black; Black; Black; Black; Black; Black; Black; Black;
     Black; Black; Black; Black; White; White; White; White;  |];
  [| Black; Black; Black; Black; Black; Black; Black; Black;
     Black; Black; Black; Black; White; White; White; White;  |];
  [| Black; Black; Black; Black; Black; Black; Black; Black;
     Black; Black; Black; Black;White; White; White; White;  |];
  [| Black; Black; Black; Black; Black; Black; Black; Black;
     White; White; White; White; White; White; White; White;  |];
  [| Black; Black; Black; Black; Black; Black; Black; Black;
     White; White; White; White; White; White; White; White;  |];
  [| Black; Black; Black; Black; Black; Black; Black; Black;
     White; White; White; White; White; White; White; White;  |];
  [| Black; Black; Black; Black; Black; Black; Black; Black;
     White; White; White; White; White; White; White; White;  |];
  [| Black; Black; Black; Black; Black; Black; Black; Black;
     Black; Black; Black; Black; Black; Black; Black; Black;  |];
  [| Black; Black; Black; Black; Black; Black; Black; Black;
     Black; Black; Black; Black; Black; Black; Black; Black;  |];
  [| Black; Black; Black; Black; Black; Black; Black; Black;
     Black; Black; Black; Black; Black; Black; Black; Black;  |];
  [| Black; Black; Black; Black; Black; Black; Black; Black;
     Black; Black; Black; Black; Black; Black; Black; Black;  |];
  [| Black; Black; Black; Black; Black; Black; Black; Black;
     Black; Black; Black; Black; Black; Black; Black; Black;  |];
  [| Black; Black; Black; Black; Black; Black; Black; Black;
     Black; Black; Black; Black; Black; Black; Black; Black;  |];
  [| Black; Black; Black; Black; Black; Black; Black; Black;
     Black; Black; Black; Black; Black; Black; Black; Black;  |];
  [| Black; Black; Black; Black; Black; Black; Black; Black;
     Black; Black; Black; Black; Black; Black; Black; Black;  |];
  |]
[@@ocamlformat "disable"]

let () = assert (image_to_tree (Array.length img) img = a)

(**************)
(* Question 3 *)
(**************)

let rec inverse = function
  | Leaf White ->
      Leaf Black
  | Leaf Black ->
      Leaf White
  | Node (c1, c2, c3, c4) ->
      Node (inverse c1, inverse c2, inverse c3, inverse c4)

(* 3 -> 4 -> 2 -> 1 *)
let rec rotate = function
  | Leaf _ as a ->
      a
  | Node (c1, c2, c3, c4) ->
      Node (rotate c2, rotate c4, rotate c1, rotate c3)

(* 1 -> 2 -> 4 -> 3 *)
let rec antirotate = function
  | Leaf _ as a ->
      a
  | Node (c1, c2, c3, c4) ->
      Node (antirotate c3, antirotate c1, antirotate c4, antirotate c2)


(* Test des rotations *)
let rec q3 a =
  Graphics.clear_graph ();
  draw_tree 512 a;
  let rec do_rec () =
    let c = Graphics.read_key () in
    if c = 'n' then q3 (rotate a)
    else if c = 'p' then q3 (antirotate a)
    else if c = 'i' then q3 (inverse a)
    else if c = 'q' then ()
    else do_rec ()
  in
  do_rec ()

let () = q3 a

(**************)
(* Question 4 *)
(**************)

let rec fractal n =
  if n <= 0 then
    Leaf Black
  else
    let c = fractal (n-1) in
    let c1 = Node (c, c, c, Leaf White) in
    let c3 = rotate c1 in
    let c4 = rotate c3 in
    let c2 = rotate c4 in
    Node (c1, c2, c3, c4)

let rec q4 i =
  draw_tree 512 (fractal i);
  let rec do_rec () =
    let c = Graphics.read_key () in
    if c = 'n' && i < 5 then begin
      Graphics.clear_graph ();
      q4 (i+1)
    end else if c = 'p' && i > 0 then begin
      Graphics.clear_graph ();
      q4 (i-1)
    end else if c = 'q' then
      ()
    else
      do_rec () in
  do_rec ()

let () = q4 0

(**************)
(* Question 5 *)
(**************)

type bit = Zero | One

let rec do_tree_to_list a k = match a with
  | Leaf White ->
      Zero :: Zero :: k
  | Leaf Black  ->
      Zero :: One :: k
  | Node (a1, a2, a3, a4) ->
      One :: do_tree_to_list a1
        (do_tree_to_list a2
           (do_tree_to_list a3
              (do_tree_to_list a4 k)))

let tree_to_list a = do_tree_to_list a []

let rec do_parse = function
  | Zero :: Zero :: rem ->
      Leaf White, rem
  | Zero :: One :: rem ->
      Leaf Black, rem
  | One :: rem ->
      let a1, rem = do_parse rem in
      let a2, rem = do_parse rem in
      let a3, rem = do_parse rem in
      let a4, rem = do_parse rem in
      Node (a1, a2, a3, a4), rem
  | _ ->
      assert false

let list_to_tree l =
  let a,_ = do_parse l in a
  (* /!\ on ignore d'éventuels bits en trop, ce qui sera le cas ci-dessous
         avec les bits de remplissage du dernier octet du fichier *)

let a = fractal 4

let () = assert (a = list_to_tree (tree_to_list a))


(* Sauvegarde et lecture, octet par octet des listes de bits.

   On fait ici le choix d'être petit-boutiste, c'est-à-dire de commencer
   par les bits de poids faible. *)

let bit_to_int = function
  | Zero -> 0
  | One   -> 1

let get_one_bit = function
  | []       -> Zero, []
  | b :: rem -> b, rem

let rec get_n_bits n l =
  if n <= 0 then
    0, l
  else
    let b, rem = get_one_bit l in
    let r, rem = get_n_bits (n - 1) rem in
    2 * r + bit_to_int b, rem

let rec output_list f = function
  | [] ->
      ()
  | l ->
      let byte,rem = get_n_bits 8 l in
      output_char f (Char.chr byte);
      output_list f rem

let write_tree name a =
  let f = open_out_bin name in
  output_list f (tree_to_list a);
  close_out f

let read_byte f =
  try
    let c = input_char f in
    Some (Char.code c)
  with End_of_file ->
    None

let rec get_n_bits digits n =
  if digits <= 0 then
    []
  else
    let b = match n mod 2 with 0 -> Zero | 1 -> One | _ -> assert false in
    b :: get_n_bits (digits - 1) (n / 2)

let rec input_list f = match read_byte f with
  | None   -> []
  | Some n -> get_n_bits 8 n @ input_list f

let read_tree name =
  let f = open_in_bin name in
  let a = list_to_tree (input_list f) in
  close_in f;
  a

let q5 a =
  write_tree "f4.quad" a;
  let aa = read_tree "f4.quad" in
  assert (a = aa)

let () = q5 (fractal 4)

let () =
  Graphics.clear_graph ();
  let a = read_tree "a.quad" in
  draw_tree 512 a;
  ignore (Graphics.read_key ())

This document was generated using caml2html