let print = Printf.printf;;
Sys.command "ocaml -version";;

print_endline

(* file de priorité version non-mutable *)
type 'a priopqueue = (int * 'a) list;;

(* file vide *)
let vide : 'a priopqueue = [ ];;

(* [inserer x clef q] insere l'element [x] dans la file [q]
   avec le clef [x], et renvoie la nouvelle file ainsi créée.
   Termine avec une exception si la file contient déjà [x]  *)
let inserer (x:'a) (clef:int) (q:'a priopqueue) : 'a priopqueue =
    if List.exists (fun (_, v) -> x = v) q
    then failwith "l'element est déjà dans la file"
    else (clef,x) :: q
;;

(* [est_vide q] teste si la file [q] est vide *)
let est_vide (q:'a priopqueue) : bool = (q = [ ]);;

(* [trouve_min_aux min_val min_clef q] renvoie un couple de clef minimale
     dans (min_val,min_clef)::q *)
let rec trouve_min_aux (min_val:'a) (min_clef:int) (q:'a priopqueue) : int * 'a =
    match q with
    | [ ] -> (min_clef, min_val)
    | (clef, _) :: q when clef > min_clef -> trouve_min_aux min_val min_clef q
    | (clef, v) :: q -> trouve_min_aux v clef q
;;

(* [trouve_min q] renvoie un élément de clef minimale la file [q].
   Lance une exception si la liste est vide *)
let trouve_min (q:'a priopqueue) : 'a =
    match q with
    | [ ] -> failwith "trouve_min: la file est vide"
    | (clef, v) :: q -> snd (trouve_min_aux v clef q)
;;

let _ = trouve_min (inserer '1' 1 (inserer '2' 2 (inserer '3' 3 vide)));;
let _ = trouve_min (inserer '1' 4 (inserer '2' 2 (inserer '3' 3 vide)));;

(* [supprime v q] renvoie une file contenant les éléments de [q], sauf [x].
   [x] doit apparaitre une et une seule fois dans la file. *)
let rec supprime (x:'a) (q:'a priopqueue) : 'a priopqueue =
    match q with
    | [ ] -> [ ]
    | (_, v) :: q when v=x -> q
    | (clef, v) :: q -> (clef, v) :: (supprime x q)
;;

(* [extraire_min q] renvoie un élément de q, de clef minimal,
   ainsi que la nouvelle file obtenue en supprimant cet
   élément; termine avec une exception si la file est vide  *)
let extraire_min (q:'a priopqueue) : 'a * 'a priopqueue =
    if q = [ ] then
        failwith "extraire_min: file vide"
    else
        let min = trouve_min q in
        (min, supprime min q)
;;

let _ = extraire_min (inserer '1' 1 (inserer '2' 2 (inserer '3' 3 vide)));;
let _ = extraire_min (inserer '1' 4 (inserer '2' 2 (inserer '3' 3 vide)));;

(* [diminuer_clef q clef x] modifie la clef de l'élément [x]
   dans la file q en lui associant la nouvelle clef [clef], qui
   doit être inferieur à la clef actuelle de [x].
   Termine avec une exception si la file ne contient pas [x]  *)
let rec diminuer_clef (x:'a) (clef:int) (q:'a priopqueue) : 'a priopqueue =
    match q with
    | [ ] -> failwith "diminuer_clef : l'élément n'est pas présent"
    | (_, v) :: q when v=x -> (clef, x) :: q
    | (c, v) :: q -> (c, v) :: diminuer_clef x clef q
;;

let f =  inserer '1' 1 (inserer '2' 2 (inserer '3' 3 vide));;
let _ = diminuer_clef '3' 0 f;;
let _ = diminuer_clef '2' 0 f;;

type sommet = int;;
type graph = {
    taille: int; (* les sommets sont des entiers entre 0 et taille-1 *)
    adj: (int * sommet) list array;
    entree: sommet
};;

let print = Printf.fprintf;;

let dot outname (g:graph) (bold:(int*int) list) : unit =
    let f = open_out (outname ^ ".dot") in
    print f "digraph G {\n";
    for i=0 to g.taille-1 do
        print f "  som%d [label=\"%d\"];\n" i i
    done;
    for i=0 to g.taille-1 do
        List.iter (fun (c,j) ->
            let option = if List.mem (i,j) bold then ",style=bold" else "" in
            print f "  som%d -> som%d [label=\"%d\"%s];\n" i j c option
        ) g.adj.(i);
    done;
    print f "}\n";
    close_out f
;;

let dot2svg outname =
    Sys.command (Printf.sprintf "dot -Tsvg %s.dot > %s.svg" outname outname);

let s = 0
and a = 1
and b = 2
and c = 3
and d = 4;;
let g1 = {
    taille = 5;
    entree = s;
    adj = [|
        [(2,a); (4,b); (2,c)]; (* adj(s) *)
        [(1,d)]; (* adj(A) *)
        [(4,d)]; (* adj(B) *)
        [(1,b)]; (* adj(C) *)
        [ ]; (* adj(D) *)
    |]
};;

let _ = dot "TP7__g1" g1 [ ];;
dot2svg "TP7__g1";;

Sys.command "cat TP7__g1.dot";;

let _ = dot "TP7__g2" g1 [(0,3);(3,2);(2,4)];;

Sys.command "cat TP7__g2.dot";;
dot2svg "TP7__g2";;

let dijkstra g =
    let q = ref vide in
    let dist = Array.init g.taille (fun i ->
        if i=g.entree then 0 else max_int
    ) in
    for i=0 to g.taille - 1 do (* initialisation de la file *)
        q := inserer i dist.(i) !q
    done;
    while not (est_vide !q) do
        let (x, q') = extraire_min !q in
        q := q';  (* ne pas oublier de mettre à jour la file *)
        (* on regarde les adjacents de x *)
        List.iter (fun (c,y) ->
            if dist.(y) > dist.(x) + c
            then begin
                dist.(y) <- dist.(x) + c;
                q := diminuer_clef y dist.(y) !q
            end
        ) g.adj.(x)
    done;
    dist
;;

let _ = dijkstra g1

let s = 0
and a = 1
and b = 2
and c = 3
and d = 4
and e = 5
and f = 6;;
let g2 = {
    taille = 7;
    entree = s;
    adj = [|
        [(2,a); (4,b); (2,c)]; (* adj(s) *)
        [(1,d)]; (* adj(A) *)
        [(4,d)]; (* adj(B) *)
        [(1,b)]; (* adj(C) *)
        [ ]; (* adj(D) *)
        [(5,f)]; (* adj(E) *)
        [ ]; (* adj(F) *)
    |]
};;

let _ = dijkstra g2;;

let s = 0
and a = 1
and b = 2
and c = 3
and d = 4;;
let g3 = {
    taille = 5;
    entree = s;
    adj = [|
        [(2,a); (-4,b); (2,c)]; (* adj(s) *)
        [(1,d)]; (* adj(A) *)
        [(-4,d)]; (* adj(B) *)
        [(1,b)]; (* adj(C) *)
        [(2,b)]; (* adj(D) *)
    |]
};;

let _ = dijkstra g3;;

(* file de priorité version non-mutable *)
type 'a priopqueue = (int * 'a) list ref;;

(* file vide *)
let vide () : 'a priopqueue = ref [ ];;

(* [inserer x clef q] insere l'element [x] dans la file [q]
   avec le clef [x].
   Termine avec une exception si la file contient déjà [x]  *)
let inserer (x:'a) (clef:int) (q:'a priopqueue) : unit =
    if List.exists (fun (_, v) -> x=v) !q
    then failwith "l'element est déjà dans la file"
    else q := (clef,x) :: !q
;;

(* [est_vide q] teste si la file [q] est vide *)
let est_vide (q:'a priopqueue) : bool = (!q = [ ]);;

(* [trouve_min_aux min_val min_clef q] renvoie un couple de clef minimale
     dans (min_val,min_clef)::q *)
let rec trouve_min_aux (min_val:'a) (min_clef:int) (q:(int*'a) list) : int * 'a =
    match q with
    | [ ] -> (min_clef, min_val)
    | (clef, _) :: q when clef > min_clef -> trouve_min_aux min_val min_clef q
    | (clef, v) :: q -> trouve_min_aux v clef q
;;

(* [trouve_min q] renvoie un élément de clef minimale la file [q].
   Lance une exception si la liste est vide *)
let trouve_min (q:(int*'a) list) : 'a =
    match q with
    | [ ] -> failwith "trouve_min: la file est vide"
    | (clef, v) :: q -> snd (trouve_min_aux v clef q)
;;

(* [supprime v q] renvoie une file contenant les éléments de [q], sauf [x].
   [x] doit apparaitre une et une seule fois dans la file. *)
let rec supprime (x:'a) (q:(int*'a) list) : (int*'a) list =
    match q with
    | [ ] -> [ ]
    | (_, v) :: q when v=x -> q
    | (clef, v) :: q -> (clef,v) :: (supprime x q)
;;

(* [extraire_min q] renvoie un élément de q, de clef minimal,
   et met à jour la file; termine avec une exception si la file est vide  *)
let extraire_min (q:'a priopqueue) : 'a =
    if !q = [ ] then failwith "extraire_min: file vide"
    else
        let min = trouve_min !q in
        q :=  supprime min !q;
        min
;;

(* [diminuer_clef q clef x] modifie la clef de l'élément [x]
   dans la file q en lui associant la nouvelle clef [clef], qui
   doit être inferieur à la clef actuelle de [x].
   Termine avec une exception si la file ne contient pas [x]  *)
let diminuer_clef (x:'a) (clef:int) (q:'a priopqueue) : unit =
    let rec diminuer_aux (l:(int*'a) list) : (int*'a) list =
        match l with
        | [ ] -> failwith "diminuer_clef : l'élément n'est pas présent"
        | (_, v) :: q when v=x -> (clef, x) :: q
        | (c, v) :: q -> (c, v) :: diminuer_aux q in
    q := diminuer_aux !q
;;

let dijkstra g =
    let q = vide () in
    let dist = Array.init g.taille (fun i ->
        if i=g.entree then 0 else max_int
    ) in
    let pere = Array.init g.taille (fun i -> i) in
    for i=0 to g.taille - 1 do (* initialisation de la file *)
        inserer i dist.(i) q;
    done;
    while not (est_vide q) do
        let x = extraire_min q in
        (* on regarde les adjacents de x *)
        List.iter (fun (c,y) ->
            if dist.(y) > dist.(x) + c
            then begin
                pere.(y) <- x;
                dist.(y) <- dist.(x) + c;
                diminuer_clef y dist.(y) q
        end) g.adj.(x)
    done;
    dist, pere
;;

let _ = dijkstra g1;;

let _ = dijkstra g2;;

let _ = dijkstra g3;;

let prim g =
    let q = vide () in
    let poids = Array.init g.taille (fun i ->
        if i=g.entree then 0 else max_int
    ) in
    let pere = Array.init g.taille (fun i -> i) in
    for i=0 to g.taille-1 do (* initialisation de la file *)
        inserer i poids.(i) q;
    done;
    while not (est_vide q) do
        let x = extraire_min q in
        (* on regarde les adjacents de x *)
        List.iter (fun (c,y) ->
            if poids.(y) > c
            then begin
                pere.(y) <- x;
                poids.(y) <- c;
                diminuer_clef y poids.(y) q
        end)
        g.adj.(x)
    done;
    Array.iteri (fun i p ->
        if i != p then Printf.printf " (%d, %d)\n" i p
    ) pere;
    poids, pere;
;;

let _ = prim g1

(** {2 Leftist heaps, by Jean-Christophe Filliâtre} *)

(**************************************************************************)
(*                                                                        *)
(*  Copyright (C) Jean-Christophe Filliâtre                               *)
(*                                                                        *)
(*  This software is free software; you can redistribute it and/or        *)
(*  modify it under the terms of the GNU Library General Public           *)
(*  License version 2.1, with the special exception on linking            *)
(*  described in file LICENSE.                                            *)
(*                                                                        *)
(*  This software is distributed in the hope that it will be useful,      *)
(*  but WITHOUT ANY WARRANTY; without even the implied warranty of        *)
(*  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.                  *)
(*                                                                        *)
(**************************************************************************)

(* Leftist heaps.

   See for instance Chris Okasaki's "Purely Functional Data Structures" *)

module type Ordered = sig
  type t
  val le: t -> t -> bool
end

exception Empty

module Make(X : Ordered) :
sig
  type t
  val empty : t
  val is_empty : t -> bool
  val insert : X.t -> t -> t
  val min : t -> X.t
  val extract_min : t -> X.t * t
  val merge : t -> t -> t
  val length : t -> int
end
=
struct

  type t = E | T of int * X.t * t * t

  let rank = function E -> 0 | T (r,_,_,_) -> r

  let rec length = function E -> 0 | T (_,_,t1,t2) -> 1 + (length t1) + (length t2)

  let make x a b =
    let ra = rank a and rb = rank b in
    if ra >= rb then T (rb + 1, x, a, b) else T (ra + 1, x, b, a)

  let empty = E

  let is_empty = function E -> true | T _ -> false

  let rec merge h1 h2 = match h1,h2 with
    | E, h | h, E ->
        h
    | T (_,x,a1,b1), T (_,y,a2,b2) ->
        if X.le x y then make x a1 (merge b1 h2) else make y a2 (merge h1 b2)

  let insert x h = merge (T (1, x, E, E)) h

  let min = function E -> raise Empty | T (_,x,_,_) -> x

  let extract_min = function
    | E -> raise Empty
    | T (_,x,a,b) -> x, merge a b

end

(** Calcule l'alphabet du texte [text] ainsi que son tableau de fréquence.
    Linéaire en temps et espace dans la taille du texte. *)
let frequencies text =
    let n = String.length text in
    let f = Hashtbl.create 128 in
    for i = 0 to n-1 do
        if Hashtbl.mem f text.[i] then
            Hashtbl.replace f text.[i] (1 + Hashtbl.find f text.[i])
        else Hashtbl.add f text.[i] 1;
    done;
    f
;;

(** Renvoie juste l'alphabet qui compose le texte [text]. *)
let alphabet text =
    let f = frequencies text in
    let alp = ref [ ] in
    Hashtbl.iter (fun carct _ -> alp := carct :: !alp) f;
    !alp
;;

(** Un exemple. https://www.un.org/fr/universal-declaration-human-rights/index.html *)
let text1 = "https://www.un.org/fr/universal-declaration-human-rights/index.html : Article premier\n\nTous les etres humains naissent libres et egaux en dignite et en droits. Ils sont doues de raison et de conscience et doivent agir les uns envers les autres dans un esprit de fraternite.\nArticle 2\n\n1. Chacun peut se prevaloir de tous les droits et de toutes les libertes proclames dans la presente Declaration, sans distinction aucune, notamment de race, de couleur, de sexe, de langue, de religion, d'opinion politique ou de toute autre opinion, d'origine nationale ou sociale, de fortune, de naissance ou de toute autre situation.\n2. De plus, il ne sera fait aucune distinction fondee sur le statut politique, juridique ou international du pays ou du territoire dont une personne est ressortissante, que ce pays ou territoire soit independant, sous tutelle, non autonome ou soumis a une limitation quelconque de souverainete.";;
let _ = alphabet text1;;

(** Pour affiche facilement. *)
let print = Format.printf;;

(** Pour visualiser un tableau des fréquences ainsi calculée. *)
let print_frequencies f =
  flush_all();
  print "\n\nTable des fréquences f :\n";
  flush_all();
  Hashtbl.iter (fun carct freq -> print "%C: %i, " carct freq) f;
  flush_all();
;;

print_frequencies (frequencies text1);;

(* #use "Heap.ml";; *)
(* open Heap;; *)

type codage =
    | F of char * int | N of (int * codage * codage);;

let freq = function F (_, i) -> i | N (i,_ , _) -> i;;

module CodageFreq = struct
    type t = codage
    let le c1 c2 = (freq c1) <= (freq c2)
end;;

module MinHeap = Make(CodageFreq);;

let rec check_freq = function
    | F(_,i) -> assert( (i >= 0) )
    | N(i, c1, c2) -> assert( (i >= 0) && (i = (freq c1) + (freq c2)) ); check_freq c1; check_freq c2;
;;

let sigma_fromlist l =
    let h = Hashtbl.create (List.length l) in
    List.iter (fun (c, f) -> Hashtbl.add h c f) l;
    h
;;

let sigma1 = sigma_fromlist [('f', 5); ('e', 9); ('c', 12); ('b', 13); ('d', 16); ('a', 45) ];;

let codage1 = N(100,
    F('a', 45),
    N(55,
    N(25,
        F('c',12),
        F('b',13)
    ),
    N(30,
        N(14,
        F('f',5),
        F('e',9)
        ),
        F('d',16)
    )
)
);;

let _ = check_freq codage1;;

(** Calcul du nombre de bits nécessaires pour stocker le fichier. *)
let rec coutx prof = function
  | F(c, f) -> begin
    print "\nFeuille %C de profondeur %i et de fréquence %i." c prof f;
    (f * prof);
  end
  | N(_, c1, c2) -> (coutx (prof+1) c1) + (coutx (prof+1) c2)
;;

(** Il faudrait rajouter la taille du codage lui-même. *)
let cout = coutx 1;;

let _ = cout codage1;;

let huffmanx sigma =
    let n = Hashtbl.length sigma in
    let q = ref (MinHeap.empty) in
    Hashtbl.iter (fun c f -> q := (MinHeap.insert (F(c,f)) !q) ) sigma;
    for i = 1 to n-1 do
        flush_all();
        print "\n\nHuffmanx : %i-ième étape. La file q est de taille %i." i (MinHeap.length !q);
        let x, q2 = MinHeap.extract_min (!q) in
        flush_all();
        print "\nOn retire à q le noeud x de fréquence minimale (= %i)." (freq x);
        let y, q3 = MinHeap.extract_min q2 in
        flush_all();
        print "\nOn retire à q second noeud y de fréquence minimale (= %i)." (freq y);
        q := q3;
        let z = N( (freq x) + (freq y), x, y) in
        flush_all();
        print "\nOn les fusionne en z un nouveau noeud de fréquence %i, de fils gauche = x et droit = y." ( freq z );
        q := MinHeap.insert z !q;
        flush_all();
        print "\nOn ajoute ce noeud z a la file de priorité min q.";
    done;
    MinHeap.min !q
;;

(* Vérification sur l'exemple. *)
assert(codage1 = (huffmanx sigma1));;

(** Pour un texte entier, on calcule directement le codage. *)
let huffman text =
    let freq = frequencies text in
    huffmanx freq
;;

let sigma2 = sigma_fromlist [ ('a',1); ('b',1); ('c',2); ('d',3); ('e',5); ('f',8); ('g',13); ('h',21) ];;
let _ = huffmanx sigma2;;

let _ = huffman text1;;

type sommet = int ;;
type graphe = (sommet list) array;;

let nb_sommet (g : graphe) = Array.length g;;

type couleur = int;;
type coloriage = couleur array;; (* c.(i) est la couleur du sommet i... *)

let verifie_coloriage (g : graphe) (c : coloriage) =
    let res = ref true in
    let n = nb_sommet g in
    for i = 0 to n-1 do
        if c.(i) < 0 || c.(i) >= n then res := false;
        List.iter (fun j ->
            if c.(i) == c.(j) then res := false;
        ) g.(i)
    done;
    !res
;;

let g1 : graphe = [|
    [1; 2; 3]; (* voisins de 0 *)
    [0; 4]; (* voisins de 1 *)
    [0; 3; 4]; (* voisins de 2 *)
    [0; 2]; (* voisins de 3 *)
    [1; 2]  (* voisins de 4 *)
|];;

let coloriage1 = [|0; 1; 1; 1; 0|];;
let _ = verifie_coloriage g1 coloriage1;; (* 3 -> 2 mais ont la même couleur *)

let coloriage2 = [|0; 1; 2; 1; 0|];;
let _ = verifie_coloriage g1 coloriage2;;

let coloriage_naif (g : graphe) : coloriage =
    let n = nb_sommet g in
    Array.init n (fun i -> i);
;;

let coloriage3 = coloriage_naif g1;;
let _ = verifie_coloriage g1 coloriage3;;

let degres (g : graphe) : int array =
    Array.map List.length g
;;

let _ = degres g1;;

type permutation = int array;;

let trie_par_degres (g : graphe) : permutation =
    let n = nb_sommet g in
    let indices = Array.init n (fun i -> i) in
    let d = degres g in
    let cmp_deg i j = Pervasives.compare d.(j) d.(i) in
    Array.stable_sort cmp_deg indices;
    indices
;;

let _ = trie_par_degres g1;;

let plus_petite_couleur_libre (n : int) (cs : couleur list) : couleur =
    let rep = ref 0 in
    while List.mem !rep cs do
        incr rep
    done;
    assert (!rep < n);
    !rep
;;

let coloriage_glouton (g : graphe) : coloriage =
    let n = nb_sommet g in
    let c = Array.make n (-1) in
    let perm = trie_par_degres g in
    for i = 0 to n-1 do
        (* on regarde le sommet perm.(i) *)
        let couleurs_voisins = List.map (fun j -> c.(j)) g.(perm.(i)) in
        c.(perm.(i)) <- plus_petite_couleur_libre n couleurs_voisins;
    done;
    c
;;

let coloriage_glouton_pas_trie (g : graphe) : coloriage =
    let n = nb_sommet g in
    let c = Array.make n (-1) in
    for i = 0 to n-1 do
        (* on regarde le sommet i *)
        let couleurs_voisins = List.map (fun j -> c.(j)) g.(i) in
        c.(i) <- plus_petite_couleur_libre n couleurs_voisins;
    done;
    c
;;

let coloriage4 = coloriage_glouton g1;;
let _ = verifie_coloriage g1 coloriage4;;

let coloriage5 = coloriage_glouton_pas_trie g1;;
let _ = verifie_coloriage g1 coloriage5;;

let g2 : graphe = [|
    [1; 2; 3; 4; 5]; (* voisins de 0 *)
    [0; 2; 3; 4; 5]; (* voisins de 1 *)
    [0; 1; 3; 4]; (* voisins de 2 *)
    [0; 1; 2; 5]; (* voisins de 3 *)
    [0; 1; 2];  (* voisins de 4 *)
    [0; 1; 3]  (* voisins de 5 *)
|];;

let coloriage6 = coloriage_glouton g2;;
let _ = verifie_coloriage g2 coloriage6;;

let coloriage6 = coloriage_glouton_pas_trie g2;;
let _ = verifie_coloriage g2 coloriage6;;

let g3 : graphe = [|
    [5; 4; 2];  (* voisins de 0 *)
    [5; 4; 3];  (* voisins de 1 *)
    [5; 4; 3; 0]; (* voisins de 2 *)
    [5; 4; 2; 1]; (* voisins de 3 *)
    [5; 3; 2; 1; 0]; (* voisins de 4 *)
    [4; 3; 2; 1; 0] (* voisins de 5 *)
|];;

let coloriage6 = coloriage_glouton g3;;
let _ = verifie_coloriage g3 coloriage6;;

let coloriage6 = coloriage_glouton_pas_trie g3;;
let _ = verifie_coloriage g3 coloriage6;;