(* Ouvrir la fenêtre graphique *)

let () = Graphics.open_graph " 512x512"

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

type couleur = Blanc | Noir

type arbre =
  | Feuille of couleur
  | Noeud   of arbre * arbre * arbre * arbre

type image = couleur array array

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

let rec compte_feuilles = function
  | Feuille _ ->
      1
  | Noeud (c1, c2, c3, c4) ->
      compte_feuilles c1 +
      compte_feuilles c2 +
      compte_feuilles c3 +
      compte_feuilles c4

let a =
  Noeud (Noeud (Feuille Blanc,
                Feuille Blanc,
                Feuille Noir,
                Feuille Blanc),
         Feuille Noir,
         Feuille Noir,
         Feuille Noir)

let () = assert (compte_feuilles a = 7)

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

let rec do_dessine i j k = function
  | Feuille Noir ->
      Graphics.fill_rect i j k k
  | Feuille Blanc ->
      ()
  | Noeud (c1, c2, c3, c4) ->
      let k2 = k/2 in
      do_dessine i (j+k2) k2 c1;
      do_dessine (i+k2) (j+k2) k2 c2;
      do_dessine i j k2 c3;
      do_dessine (i+k2) j k2 c4

let dessine_arbre k a = do_dessine 0 0 k a


let rec do_vers_arbre img i j k =
  if k <= 1 then
    Feuille img.(i).(j)
  else
    let k2 = k/2 in
    let c1 = do_vers_arbre img i (j+k2) k2
    and c2 = do_vers_arbre img (i+k2) (j+k2) k2
    and c3 = do_vers_arbre img i j k2
    and c4 = do_vers_arbre img (i+k2) j k2 in
    match c1, c2, c3, c4 with
      | Feuille n1, Feuille n2, Feuille n3, Feuille n4
        when n1 = n2 && n2 = n3 && n3 = n4 -> c1
      | _ -> Noeud (c1, c2, c3, c4)

let image_vers_arbre k img = do_vers_arbre img 0 0 k

(* Test de dessine_arbre *)
let rec q2 a =
  Graphics.clear_graph ();
  dessine_arbre 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

(* Test de image_vers_arbre *)
let img =
[|
  [| Noir; Noir; Noir; Noir; Noir; Noir; Noir; Noir;
     Noir; Noir; Noir; Noir; Blanc; Blanc; Blanc; Blanc;  |];
  [| Noir; Noir; Noir; Noir; Noir; Noir; Noir; Noir;
     Noir; Noir; Noir; Noir; Blanc; Blanc; Blanc; Blanc;  |];
  [| Noir; Noir; Noir; Noir; Noir; Noir; Noir; Noir;
     Noir; Noir; Noir; Noir; Blanc; Blanc; Blanc; Blanc;  |];
  [| Noir; Noir; Noir; Noir; Noir; Noir; Noir; Noir;
     Noir; Noir; Noir; Noir;Blanc; Blanc; Blanc; Blanc;  |];
  [| Noir; Noir; Noir; Noir; Noir; Noir; Noir; Noir;
     Blanc; Blanc; Blanc; Blanc; Blanc; Blanc; Blanc; Blanc;  |];
  [| Noir; Noir; Noir; Noir; Noir; Noir; Noir; Noir;
     Blanc; Blanc; Blanc; Blanc; Blanc; Blanc; Blanc; Blanc;  |];
  [| Noir; Noir; Noir; Noir; Noir; Noir; Noir; Noir;
     Blanc; Blanc; Blanc; Blanc; Blanc; Blanc; Blanc; Blanc;  |];
  [| Noir; Noir; Noir; Noir; Noir; Noir; Noir; Noir;
     Blanc; Blanc; Blanc; Blanc; Blanc; Blanc; Blanc; Blanc;  |];
  [| Noir; Noir; Noir; Noir; Noir; Noir; Noir; Noir;
     Noir; Noir; Noir; Noir; Noir; Noir; Noir; Noir;  |];
  [| Noir; Noir; Noir; Noir; Noir; Noir; Noir; Noir;
     Noir; Noir; Noir; Noir; Noir; Noir; Noir; Noir;  |];
  [| Noir; Noir; Noir; Noir; Noir; Noir; Noir; Noir;
     Noir; Noir; Noir; Noir; Noir; Noir; Noir; Noir;  |];
  [| Noir; Noir; Noir; Noir; Noir; Noir; Noir; Noir;
     Noir; Noir; Noir; Noir; Noir; Noir; Noir; Noir;  |];
  [| Noir; Noir; Noir; Noir; Noir; Noir; Noir; Noir;
     Noir; Noir; Noir; Noir; Noir; Noir; Noir; Noir;  |];
  [| Noir; Noir; Noir; Noir; Noir; Noir; Noir; Noir;
     Noir; Noir; Noir; Noir; Noir; Noir; Noir; Noir;  |];
  [| Noir; Noir; Noir; Noir; Noir; Noir; Noir; Noir;
     Noir; Noir; Noir; Noir; Noir; Noir; Noir; Noir;  |];
  [| Noir; Noir; Noir; Noir; Noir; Noir; Noir; Noir;
     Noir; Noir; Noir; Noir; Noir; Noir; Noir; Noir;  |];
  |]

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

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

let rec inverse = function
  | Feuille Blanc ->
      Feuille Noir
  | Feuille Noir ->
      Feuille Blanc
  | Noeud (c1, c2, c3, c4) ->
      Noeud (inverse c1, inverse c2, inverse c3, inverse c4)

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

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


(* Test des rotations *)
let rec q3 a =
  Graphics.clear_graph ();
  dessine_arbre 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 fractale n =
  if n <= 0 then
    Feuille Noir
  else
    let c = fractale (n-1) in
    let c1 = Noeud (c, c, c, Feuille Blanc) in
    let c3 = rotate c1 in
    let c4 = rotate c3 in
    let c2 = rotate c4 in
    Noeud (c1, c2, c3, c4)

let rec q4 i =
  dessine_arbre 512 (fractale 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 | Un

let rec do_arbre_vers_liste a k = match a with
  | Feuille Blanc ->
      Zero :: Zero :: k
  | Feuille Noir  ->
      Zero :: Un :: k
  | Noeud (a1, a2, a3, a4) ->
      Un :: do_arbre_vers_liste a1
        (do_arbre_vers_liste a2
           (do_arbre_vers_liste a3
              (do_arbre_vers_liste a4 k)))

let arbre_vers_liste a = do_arbre_vers_liste a []

let rec do_parse = function
  | Zero :: Zero :: rem ->
      Feuille Blanc, rem
  | Zero :: Un :: rem ->
      Feuille Noir, rem
  | Un :: 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
      Noeud (a1, a2, a3, a4), rem
  | _ ->
      assert false

let liste_vers_arbre l = let a,_ = do_parse l in a

let a = fractale 4

let () = assert (a = liste_vers_arbre (arbre_vers_liste a))


(* sauvegarde et lecture, octet par octet des listes de bits *)

let bit_to_int = function
  | Zero -> 0
  | Un   -> 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 ecrire_arbre name a =
  let f = open_out_bin name in
  output_list f (arbre_vers_liste 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 -> Un | _ -> 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 lire_arbre name =
  let f = open_in_bin name in
  let a = liste_vers_arbre (input_list f) in
  close_in f;
  a

let q5 a =
  ecrire_arbre "f4.quad" a;
  let aa = lire_arbre "f4.quad" in
  assert (a = aa)

let () = q5 (fractale 4)

This document was generated using caml2html