(* Les codes suivants sont des versions naïves destinées à illustrer un cours. *)
(* De nombreuses améliorations sont possibles.                                 *)


(*************************************************************************)
(* ARBRES BINAIRES DE RECHERCHE *)
(*************************************************************************)

type abr = Em | No of (abr * int * abr)
;;

(* addabr e a retourne un arbre binaire de recherche représentant un ensemble  *)
(* comportant en plus de tous les éléments d'un arbre binaire de recherche a   *)
(* un élément e.                                                               *)
let rec addabr e a = match a with
  | Em -> No (Em,e,Em)
  | No(ls,x,rs) -> 
    let c = compare e x in
    if c = 0 then a 
    else if c < 0 then No ( addabr e ls, x, rs)
    else No (ls, x, addabr e rs)
;;

(* memabr e a retourne true s'il y a un élément e dans a,                      *)
(*         retourne false sinon.                                               *)
let rec memabr e a = match a with
  | Em -> false
  | No(ls,x,rs) ->  
    let c = compare e x in
    (c=0) or (if c < 0 then memabr e ls else memabr e rs)
;;

(* minabr a retourne le plus petit élément de a pour la relation d'ordre de    *)
(*          construction, s'il en existe un.                                   *)
(* RAISES exception Not_found       (prédéfinie)                               *)
let rec minabr = function
  | Em -> raise Not_found
  | No (Em, x, _) -> x
  | No(ls,_,_) -> minabr ls
;; 

(* remminabr a retourne un ABR comportant tous les éléments de a sauf son      *)
(*           minimum s'il existe.                                              *)
let rec remminabr = function
  | Em -> Em
  | No(Em,x,rs) -> rs
  | No(ls,x,rs) -> No(remminabr ls,x,rs)
;;

(* removeabr e a retourne un ABR comportant tous les éléments de a sauf e.     *)
let rec removeabr e a = match a with
  | Em -> Em 
  | No(ls, x, rs) -> 
    let c = compare e x in
    if c = 0 then 
      match rs with 
	| Em -> ls 
	| _ -> No(ls,minabr rs,remminabr rs) 
    else if c < 0 then No ( removeabr e ls, x, rs)
    else No (ls, x, removeabr e rs)
;;


(*************************************************************************)
(* ARBRES AVL *)
(*************************************************************************)


(* Maintenant AVL *)
type 'a avl = E | N of ('a avl * 'a * 'a avl * int)
;;

(* empty_avl est la fonction constante avl vide.                               *)
let empty_avl = E
;;

(* height_avl t retourne la hauteur de l'avl t.                                *)
let height_avl t = match t with 
  | E -> 0 
  | N(_,_,_,h) -> h
;;

(* node_avl l v r retourne un avl de sommet v, fils gauche l, fils droit r et  *)
(*                dont la hauteur est déjà calculée.                           *)
let node_avl l v r = N(l,v,r,1+ max (height_avl l) (height_avl r))
;;

(* mem_avl e a retourne true s'il y a un élément e dans a,                     *)
(*             retourne false sinon.                                           *)
let rec mem_avl e a = match a with
    E -> false
  | N(ls,x,rs,_) ->  let c = compare e x in
		   (c=0) or (if c < 0 then mem_avl e ls else mem_avl e rs)
;;

(* min_avl a retourne le plus petit élément de a pour la relation d'ordre de   *)
(*           construction, s'il en existe un.                                  *)
(* RAISES exception Not_found       (prédéfinie)                               *)
let rec min_avl = function
  | E -> raise Not_found
  | N (E, x, _, _) -> x
  | N(ls,_,_,_) -> min_avl ls
;; 


(* bal l v r     retourne un avl de sommet v, fils gauche l, fils droit r     *)
(*               avec calcul de la hauteur et équilibrage de 1                *)
exception Les_maths_sont_inconsistantes
;;
let bal l v r = 
  let hl = height_avl l and hr = height_avl r in
  if hl > hr + 1 then (match l with
    | N(ll,lv,lr,_) -> 
      if (height_avl ll >= height_avl lr) then node_avl ll lv (node_avl lr v r) 
      else (match lr with 
        | N(lrl,lrv,lrr,_) -> node_avl (node_avl ll lv lrl) lrv (node_avl lrr v r)
        | _ -> raise Les_maths_sont_inconsistantes)
    | _ -> raise Les_maths_sont_inconsistantes)
  else if hr > hl + 1 then (match r with
    | N(rl,rv,rr,_) -> 
      if (height_avl rr >= height_avl rl) then node_avl (node_avl l v rl) rv rr
      else (match rl with
	| N(rll,rlv,rlr,_) -> node_avl (node_avl l v rll) rlv (node_avl rlr rv rr)
        | _ -> raise Les_maths_sont_inconsistantes)
    | _ -> raise Les_maths_sont_inconsistantes)
  else node_avl l v r 
;;

(* add_avl e a retourne un arbre AVL représentant un ensemble  comportant en   *)
(*             plus de tous les éléments d'un arbre AVL a un élément e.        *)
let rec add_avl e a = match a with
    E -> N (E,e,E,1)
  | N(ls,x,rs,_) -> let c = compare e x in
      if c = 0 then a 
      else if c < 0 then bal (add_avl e ls)  x  rs
      else bal ls x (add_avl e rs)
;;

let rec remmin_avl = function
  | E -> E
  | N(E,_,rs,_) -> rs
  | N(ls,x,rs,_) -> bal (remmin_avl ls) x rs
;;

let rec remove_avl e a = match a with
  | E -> E
  | N (ls, x, rs,_) -> 
    let c = compare e x in
    if c = 0 then match rs with 
      | E -> ls 
      | _ -> bal ls (min_avl rs) (remmin_avl rs) 
    else if c < 0 then bal (remove_avl e ls) x rs
    else bal ls x (remove_avl e rs)
;;



(*************************************************************************)
(* ASSOCIATIONS *)
(*************************************************************************)


(* Associations polymorphes, à base d' arbres AVL       *)
type ('a,'b) pmap = 
  | EM 
  | NM of (('a,'b) pmap 
	   * 'a 
	   * 'b 
	   * ('a,'b) pmap 
	   * int)
;;

(* Comparaison des clefs...                             *)
let comp x y = compare x y
;;

(* Fonction constante : association vide                *)
let empty_map = EM
;;

(* height_map m retourne la hauteur d'une association m *)
(*              comstruite comme un arbre AVL           *)
let height_map = function 
  | EM -> 0
  | NM (_,_,_,_,h) -> h
;;

(* smart constructor pour AVL based maps                *)
let node_map l k e r = NM (l,k,e,r,1+ max (height_map l) (height_map r))
;;

(* smarter constructor pour AVL based maps              *) 
exception Impossible
;;
let balance l k e r = 
  let hl = height_map l and hr = height_map r in
  if hl > hr + 1 then (match l with
    | NM (ll, lk, le, lr, _) -> 
      if (height_map ll >= height_map lr) then 
	node_map ll lk le (node_map lr k e r) 
      else (match lr with 
        | NM (lrl, lrk, lre, lrr, _) -> 
	    node_map (node_map ll lk le lrl) lrk lre (node_map lrr k e r)
        | _ -> raise Impossible)
    | _ -> raise Impossible)
  else if hr > hl + 1 then (match r with
    | NM (rl, rk, re, rr, _) -> 
      if (height_map rr >= height_map rl) then 
	node_map (node_map l k e rl) rk re rr
      else (match rl with
	| NM (rll, rlk, rle, rlr, _) -> 
	  node_map (node_map l k e rll) rlk rle (node_map rlr rk re rr)
        | _ -> raise Impossible)
    | _ -> raise Impossible)
  else node_map l k e r 
;;

(* add_map k e a retourne une association contenant en plus de tous les  *)
(*               liens dans a ne concernant pas la clef k, le lien k e.  *) 
let rec add_map k e a = match a with
    EM -> NM (empty_map, k, e, empty_map, 1)
  | NM (ls, x, e_x, rs, h) -> let c = compare k x in
      if c = 0 then NM ( ls, k, e, rs, h) 
      else if c < 0 then balance (add_map k e ls)  x e_x rs
      else balance ls x e_x (add_map k e rs)
;;


let rec min_map = function
  | EM -> raise Not_found
  | NM (EM,mk,me,_,_) -> (mk,me)
  | NM (ls,_,_,_,_) -> min_map ls
;;

let rec remmin_map = function
  | EM -> EM
  | NM(EM,_,_,rs,_) -> rs
  | NM(ls,x,e_x,rs,_) -> balance (remmin_map ls) x e_x rs
;;

(* remove_map k a retourne une association contenant tous les liens
                  dans a sauf, le cas échéant celui de la clef k et
                  d'un élément associé.  *)
let rec remove_map e a = match a with
  | EM -> EM
  | NM (ls, x,e_x, rs,_) -> let c = compare e x in
			    if c = 0 then match rs with 
			      | EM -> ls 
			      | _ -> let (mk,me) = min_map rs in
				     balance ls mk me (remmin_map rs) 
			    else if c < 0 then balance (remove_map e ls) x e_x rs
			    else balance ls x e_x (remove_map e rs);;


(* mem k a retourne true s'il existe un lien de clef k dans a, *)
(*         retourne false sinon.                               *)
let rec mem_map e m = match m with
  | EM -> false
  | NM (l, k, _, r, _) ->  
    let c = comp e k in
    (c=0) or (if c < 0 then mem_map e l else mem_map e r)
;;


(* find k a retourne l'élément lié à la clef k dans a s'il existe, *)
(*          RAISES Not_found sinon.                                *)
let rec find x m = match m with
  | EM -> raise Not_found
  | NM (l, k, e_k, r, _) ->  let c = comp x k in
			   if c = 0 then e_k
			   else if c < 0 then find x l 
			   else find x r
;;


(* un fold sur les maps *)
let rec fold_map f m acc = match m with
  | EM -> acc
  | NM (l, k, e_k, r, _) -> fold_map f l (f k e_k (fold_map f r acc))
;;

(* Commentaires en anglais à partir d'ici, désolé, c'est mal je change ça rapidement. *)

(*************************************************************************)
(* GRAPHS *)
(*************************************************************************)


(* graphs with vertices of type 'a *)
type 'a graph = ('a, 'a avl) pmap
;;

(* WE SHALL USE FUNCTIONS OVER AVL TREES AND PMAP, WITHOUT KNOWLEDGE ON
   THEIR STRUCTURE (TYPE CONSTRUCTORS) OR ON HOW THEY ARE IMPLEMENTED  *)


(* add_vertex v g returns a graph containing vertex v and all vertices *)
(*                in graph g, with the same arcs as g,                 *)
(*                returns a graph isomorphic to g if v is already in g *) 
let add_vertex v g = add_map v empty_avl g
;;

(* with pretty printing of types *)
let add_vertex (v : 'a)  (g : 'a graph) = 
  (add_map v empty_avl g : 'a graph)
;;

(* add_arc v1 v2 g returns a graph containing all vertices in g, and  *)
(*                 all arcs in g in addition to arc (v1,v2),          *)
(*                 result is isomorphic to g if (v1,v2)  already in g *) 
(* -- RAISES Not_found if v1 not in g                                 *)
(* -- PRECONDITION v2 in g                                            *)
let add_arc (v1 : 'a) (v2 : 'a) (g : 'a graph) = 
  (add_map v1 (add_avl v2 (find v1 g)) g : 'a graph)
;;

(* is_path vl g returns true if vertex list vl describes a path in   *)
(*              graph g, and false otherwise.                        *)
(*              Returns false if a vertex in vl does not belong to g *)
let rec is_path_aux (vl: 'a list) (g:'a graph) = match vl with
  | [] -> true
  | e::[] -> mem_map e g
  | e1::(e2::r as rem) -> mem_avl e2 (find e1 g) && is_path_aux rem g 
;;

let is_path vl g = try is_path_aux vl g with Not_found -> false
;;

(* exists_path v1 v2 g returns true if there is a path from v1 to v2 *)
(*              in graph g, and false otherwise.                     *)
(*              Returns false if v1 or if v2 does not belong to g    *)
exception Success;;
let rec path2 seen vset v2 (g : 'a graph) = match vset with
  | E -> (seen) 
  | N(l,vi,r,_) -> let deep =
		     if (mem_avl vi seen) then (seen) 
		     else let succ_vi = find vi g in
			  if mem_avl v2 succ_vi then raise Success 
			  else path2 (add_avl vi seen) succ_vi v2 g in
		   let deep_left = path2 deep l v2 g in
		   path2 deep_left r v2 g (* deep, left and right*)
;;

let exists_path v1 v2 g = 
  try let _ = path2 empty_avl (add_avl v1 E) v2 g in false 
  with Success -> true
;;


"Exo : retourner le chemin solution";;
(* CHERCHEZ-LE ! *)


(******************************************************
Retour aux commentaires en français...
*******************************************************)


(*************************************************************************)
(* ARBRES DE PRÉFIXES *)
(*************************************************************************)


(* Arbres de préfixes. Les n uds valident un mot, les *)
(* arrêtes sont étiquetées par les lettres.           *)
type 'a trie = T of (bool * (('a, 'a trie) pmap))
;;
 
(* ON N'UTILISERA DONC QUE LES FONCTIONS CARACTÉRISANT LES PMAP, SANS
   AVOIR BESOIN DE CONNAÎTRE LEUR IMPLANTATION.       *)

(* Fonction constante : arbre de préfixes vide.       *)
let empty = T (false, empty_map)
;;

(* mem x a retourne true si le mot x est contenu dans *)
(*     l'arbre de préfixes a.                         *)
let rec mem x (T (b,m)) = match x with
  | [] -> b
  | a::r ->    try mem r (find a m) with Not_found -> false
;;

(* add x a retourne un arbre de préfixes contenant    *)
(*     tous les mots de a auxquels le mot x est ajouté*)
let rec add x (T (b,m)) = match x with
  | [] -> (T (true, m))
  | a::r -> let t = try find a m with Not_found -> empty in
	   T (b, add_map a (add r t) m)
;;

(* remove x a retourne un arbre de préfixes contenant *)
(*     tous les mots de a auxquels le mot x est retiré*)
let rec remove x ((T (b,m) as t0)) = match x with
  | [] -> (T (false,m))
  | a::r -> 
    try 
      let s = remove r (find a m) in
      let new_m = 
	if s = empty then remove_map a m
	else add_map a s m in
      T(b,new_m)	  
    with Not_found -> t0
;;

(* inter a b retourne un arbre de préfixe contenant les*)
(*      mots contenus à la fois dans a et b.           *)
let rec inter (T (b1,mt1)) (T (b2,mt2)) =
  (T (b1 && b2, inter_branches mt1 mt2))
and inter_branches m1 m2 = 
  fold_map
    (fun k t_k acc ->
      try 
	let t = inter t_k (find k m2) in
	  if t = empty then acc
	  else add_map k t acc 
      with Not_found -> acc)
    m1
    empty_map
;;