(* CCP 2000 *)
                      
  type arbre = | Vide
               | Noeud of int * arbre * arbre ;;
                                        

  let rec taille a = match a with
              |         Vide -> 0
              | Noeud(_,g,d) -> 1 + taille g + taille d ;;
              
   let occurrence n =
        let rec aux k accu =
             if k= 1 then accu
             else if k mod 2 = 0 then aux (k/2) (0::accu)
                                 else aux (k/2) (1::accu)
        in aux n [] ;;    
        
               
   let rec consulter c a = match a with
            |         Vide -> failwith "Erreur"
            | Noeud(r,g,d) -> if c = [] then r
                              else if hd(c) =0 then consulter (tl c)  g
                                               else consulter (tl c ) d ;;
                                              
   let rec inserer v c a = match a with
            |         Vide -> Noeud(v,Vide,Vide)
            | Noeud(r,g,d) -> if hd(c) = 0 
                              then Noeud(r, inserer v (tl c) g, d)
                              else Noeud(r, g, inserer v (tl c) d) ;;
                              
 
                                                
   let rec inserer_tas v c a = match a with
      |         Vide -> Noeud(v,Vide,Vide)
      | Noeud(r,g,d) -> if hd(c) = 0 
      
         then if r <= v then Noeud(r, inserer_tas v (tl c) g, d)
                        else Noeud(v, inserer_tas r (tl c) g, d)
         else if r <= v then Noeud(r, g, inserer_tas v (tl c) d) 
                        else Noeud(v, g, inserer_tas r (tl c) d) ;;
                                                

   let rec construire l = match l with
           |  []  -> Vide 
           | t::q -> let a = construire q in
                     inserer_tas t (occurrence (taille a + 1)) a ;;

 
   let extraire c a = Vide ;;      (* non implémentée *)


   let rec aplatir a = 
       if a = Vide then []
       else let c = occurrence (taille a) 
            in (consulter [] a)::(aplatir (extraire c a));;
       
   let  trier l = aplatir(construire l);;
  
  
(* -------------------------------------------------------------------------*)  

        (* IMPLEMENTATION EFFECTIVE de la suppression de la racine *)

 
        (* La fonction suivante fait descendre l'étiquette de la 
           racine pour obtenir un tas sachant que l'arbre gauche 
           et l'arbre droit sont eux-mêmes des tas                 *)

    let rec reorganise a = match a with
           |               Vide -> Vide
           | Noeud(_,Vide,Vide) -> a
           | Noeud(r,Noeud(s,g,d),Vide) -> if r<=s then a
                                           else Noeud(s,Noeud(r,g,d),Vide)      
           | Noeud(r,Vide,Noeud(s,g,d)) -> if r<=s then a
                                           else Noeud(s,Vide,Noeud(r,g,d))
           | Noeud(r,Noeud(r1,g1,d1),Noeud(r2,g2,d2)) ->
               let m=min r1 r2 in
               if r <= m then a else
               if r1=m 
               then  Noeud(m,reorganise (Noeud(r,g1,d1)),Noeud(r2,g2,d2)) 
               else  Noeud(m,Noeud(r1,g1,d1),reorganise (Noeud(r,g2,d2))) ;;

         (* La fonction suivante reçoit un tas et renvoie un tas
            déduit du précédent en supprimant la racine           *)
     
 
   let supprime_racine a = 
        let n = taille a in
        let l = occurrence n in
        let nr = consulter l a in
        let c = rev(l) in
        let rec parcours b chemin = match b with
            |         Vide -> Vide
            | Noeud(r,g,d) -> if chemin = c then Vide
                              else Noeud(r, 
                                         parcours g (0::chemin),
                                         parcours d (1::chemin))         
        in let aa = parcours a [] 
        in match aa with 
           |           Vide -> Vide
           | Noeud(_,ag,ad) -> reorganise (Noeud(nr,ag,ad)) ;;   
           
              
  let rec aplatir a = 
       if a = Vide then []
       else (consulter [] a)::(aplatir (supprime_racine a));;
       
  let  trier l = aplatir(construire l);;
  
  
                                (** FIN **)