(* TP4 *)

(*Exercice 1*)

module type Ordered =
    sig
      type t
	     
      val compare: t -> t -> int
    end;;

module Clef:Ordered =
  struct
    type t = int 

    let compare a b = a - b
  end;;
          
module type Assoc =
  functor(X: Ordered) ->
  sig

    type 'a assoc
	    
    val empty : 'a assoc

    val is_empty : 'a assoc -> bool

    val add : X.t -> 'a -> 'a assoc -> 'a assoc

    val mem : X.t -> 'a assoc -> bool

    val modify : X.t -> 'a -> 'a assoc -> 'a assoc

    val remove X.t -> 'a assoc -> 'a assoc

    val cardinal 'a assoc -> int

    val union 'a assoc -> 'a assoc -> 'a assoc

    val inclus 'a assoc -> 'a assoc -> bool

    val inter 'a assoc -> 'a assoc -> 'a assoc

    val extract 'a assoc

    val foldassoc : ('a -> 'b -> 'b) -> 'a assoc -> 'b -> 'b

    exception Unbound of X.t

  end;;

module Assolist(Clef:Ordered):Assoc(X) =
  struct
    
  type 'a avl = Empty | Node of ('a avl *(X.t * 'a) * 'a avl * int)
      
  type 'a assoc = 'a avl
		   
  let empty = Empty

  let is_empty a = match a with
    |Empty -> true
    |_     -> false;;

  let avl_height a = match a with
    |Empty         -> 0
    |Node(g,r,d,l) -> l

  let node g r d = Node(g,r,d,1 + max (avl_height g) (avl_height d))

  exception Impossible
	      
  let balance g r d = let hg = avl_height g and hd = avl_height d in
  if abs(hg - hd) <= 1
		|Node(fdg,rdg,fdd,_) -> node (node fg rg fdg) rdg (node fdd r d)
  else match d with
       |Empty            -> raise Impossible
       |Node(fg,rd,fd,_) ->
	        let hgd = avl_height fg and hdd = avl_height fd in
	        if hgd < hdd
		then node (node g r fg) rd fd
		else match fg with
		|Empty               -> raise Impossible
		|Node(fgg,rgd,fgd,_) -> node (node g r fgg) rgd (node fgd rd fd) d (c,e))

  let rec modify c e a = if not (mem a (c,e)) then add a (c,e)
			 else match a with
			 |Empty -> Empty
			 |Node(g,r,d,_) -> if (compare r (c,e)) = 0 then node g (c,e) d
				      else if (compare r (c,e)) < 0 then modify c e g
				      else modify c e d

  let rec minelt a = match a with
    |Empty             -> raise Impossible
    |Node(Empty,r,d,_) -> r
    |Node(g,r,d,_)     -> minelt g

  let rec remminelt a = match a with
    |Empty             -> raise Impossible
    |Node(Empty,r,d,_) -> d
    |Node(g,r,d,_)     -> balance (remminelt g) r d
    
  let fusion a b = match a,b with
    |Empty,b -> b
    |a,Empty -> a
    |a,b     -> balance a (minelt b) (remminelt b)
    
  let rec remove a c e = if not (mem a c e) then a else match a with
    |Empty         -> Empty
    |Node(g,r,d,_) -> if compare (c,e) r = 0 then fusion g d
	              else if compare (c,e) r < 0 then balance (remove g c e) r d
		      else balance g r (remove d c e)
    
  let rec cardinal a = match a with
    |Empty         -> 0
    |Node(g,r,d,l) -> 1 + (cardinal g) + (cardinal d)
    
  let rec union a b = match a,b with
    |Empty,_           -> b
    |a,Empty           -> a
    |a,Node(bg,r,bd,l) -> union (add a r) (remove b r)

  let rec inclus a b = match a,b with
    |Empty,_            -> false
    |a,Empty            -> true
    |a,Node(bg,br,bd,l) -> (inclus a bg) && (mem (fst br) (snd br) a) && (inclus a bd)

  let rec inter a b = match a,b with
    |Empty,_            -> Empty
    |a,Empty            -> Empty
    |a,Node(bg,br,bd,l) -> let u = union (inter a bg) (inter a bd) in
		  	   if (mem a br) then (add u br)
                 	                 else u

  let extract a v = (v,remove v a)

  let rec avltolist a = match a with
    |Empty         -> []
    |Node(g,r,d,_) -> (avltolist g)@(r::(avltolist d))
    
  let foldassoc a f e = List.fold_left f e (avltolist a)
  end