La lettre de Caml, numéro 2

Les sources des programmes Caml

évaluation paresseuse ; mots de Lukasiewicz ; mots de Lyndon ; permutations

Retour à la page générale de La lettre de Caml.

Évaluation paresseuse :

type 'a glaçon =
| Gelé of unit -> 'a
| Connu of 'a;;

type 'a lazy_list =
| Nil
| Cons of 'a cellule

and 'a cellule = { hd : 'a; mutable tl : 'a lazy_list glaçon};;

let force cellule =
  let glaçon = cellule.tl in
  match glaçon with
  | Connu val -> val
  | Gelé g ->
     let val = g () in
     cellule.tl <- Connu val;
     val;;

let rec lazy_map f = function
| Nil -> Nil
| Cons ({hd = x; _} as cellule) ->
   Cons {hd = f x; tl = Gelé (function () -> lazy_map f (force cellule))};;

let rec nat = Cons {hd = 0; tl = Gelé (fun () -> lazy_map succ nat)};;

let rec lazy_do_list f n = function
| Nil -> ()
| Cons ({hd = x; _} as cellule) ->
   if n > 0 then begin f x; lazy_do_list f (n - 1) (force cellule) end;;

(* Utilitaires sur les grands nombres *)
#open "num";;

(* Impression *)
#open "format";;
let print_num n = print_string (string_of_num n);;

install_printer "print_num";;

let prefix + = prefix +/
and prefix - = prefix -/
and prefix * = prefix */
and prefix / = prefix //
and prefix >= = prefix >=/
and prefix = = prefix =/;;

(* Quelques constantes *)
let un = num_of_int 1;;
let zéro = num_of_int 0;;
let moins_un = zéro - un;;

type 'a glaçon =
| Gelé of unit -> 'a
| Connu of 'a;;
type série = {Constante : num; mutable Reste : série glaçon};;

let reste_de_série s =
  match s.Reste with
  | Connu rest -> rest
  | Gelé r -> let rest = r () in s.Reste <- Connu rest; rest;;

let rec add_série s1 s2 =
 {Constante = s1.Constante + s2.Constante;
  Reste =
   Gelé
    (function () -> add_série (reste_de_série s1) (reste_de_série s2))};;

let rec mult_série_par_constante c s =
 {Constante = c * s.Constante;
  Reste = Gelé
          (function () -> mult_série_par_constante c (reste_de_série s))};;

let rec mult_série s1 s2 =
 {Constante = s1.Constante * s2.Constante;
  Reste =
   Gelé
   (function () ->
     add_série (mult_série_par_constante s1.Constante (reste_de_série s2))
               (mult_série (reste_de_série s1) s2))};;

let opposée_de_série s = mult_série_par_constante moins_un s;;

let rec integre_série c0 s =
 {Constante = c0;
  Reste = Gelé (function () -> integre_depuis un s)}

and integre_depuis n s =
 {Constante = s.Constante / n;
  Reste = Gelé (function () -> integre_depuis (n + un) (reste_de_série s))};;

let print_variable = function
    0 -> false
  | 1 -> print_string "z"; true
  | n -> print_string "z^"; print_int n; true;;
let print_terme plus degré s =
  let c = s.Constante in
  if c = zéro then false else
  if c = un then begin print_string plus; print_variable degré end else
  if c = moins_un
   then begin print_string "- "; print_variable degré end
   else
    begin
     if c >= zéro then print_string plus else print_string "- ";
     print_num (abs_num c);
     print_variable degré
    end;;
let print_first_terme s =
  let c = s.Constante in
  if c = zéro then false else begin print_num c; true end;;

let rec print_série until s =
 open_hovbox 1;
 let c = s.Constante in
 if until == 0 then print_num c else
 let rest = ref s in
 let zéro = not (print_first_terme !rest) in
 if not zéro then print_space();
 for i = 1 to until do
  rest := reste_de_série !rest;
  let delim = if i == 1 & zéro then "" else "+ " in
  if print_terme delim i !rest then print_space()
 done;
 print_string "+ O(z^"; print_int (succ until);
 print_string ")";
 close_box();;

let rec sinus =
 {Constante = zéro;
  Reste = Gelé (function () -> integre_depuis un cosinus)}
and cosinus =
 {Constante = un;
  Reste = Gelé (function () -> integre_depuis un (opposée_de_série sinus))};;
let s = add_série (mult_série sinus sinus) (mult_série cosinus cosinus);;

print_série 10 s;;

Mots de Lukasiewicz :

#open "graphics" ;;

open_graph "" ;;

exception Not_Lukasiewicz ;;

let rec somme m k =
    if k = 0 then 0
    else (hd m) + somme (tl m) (k - 1) ;;
    
let rec rho = function
    | 1 :: -1 :: -1 :: reste -> true, -1 :: reste
    | x :: reste -> let flag, m' = rho reste in flag, x::m'
    | m -> false, m ;;
    
let rec rho_étoile m =
    match rho m with
        | false, m' -> m'
        | true,  m' -> rho_étoile m' ;;
        
let est_Lukasiewicz m =
    match rho_étoile m with
        | [-1] -> true
        | _ -> false ;;
        
let rec décompose suffixe =
    let rec décomp_rec m s =
        match m with
            | n :: m' ->    if n + s = -1 then [n] , m'
                            else    let g,d = décomp_rec m' (n + s)
                                    in
                                    n :: g , d
            | _ -> raise Not_Lukasiewicz
    in
    décomp_rec suffixe 0 ;;
    
type arbre = Feuille | Nud of arbre * arbre ;;

let rec Lukasiewicz_of_arbre = function
    | Feuille -> [-1]
    | Nud(g,d) -> 1 :: (Lukasiewicz_of_arbre g) @ (Lukasiewicz_of_arbre d) ;;
    
let rec arbre_of_Lukasiewicz = function
    | [-1] -> Feuille
    | 1 :: reste -> let gauche,droit = décompose reste
                    in
                    Nud((arbre_of_Lukasiewicz gauche),(arbre_of_Lukasiewicz droit))
    | _ -> raise Not_Lukasiewicz ;;
    
let rec profondeur_arbre = function
    | Feuille -> -1
    | Nud(g,d) -> 1 + max (profondeur_arbre g) (profondeur_arbre d) ;;

let profondeur_Lukasiewicz m = profondeur_arbre (arbre_of_Lukasiewicz m) ;;

let rotation (x,y) = (y-x+240,276-x-y) ;;

let point x y = let x',y' = rotation(x,y) in fill_circle x' y' 2 ;;
let va_à x y = let x',y' = rotation(x,y) in moveto x' y' ;;
let tracer x y = let x',y' = rotation(x,y) in lineto x' y' ;;

let rec deux_puissance = function
    | 0 -> 1
    | n -> let x = deux_puissance (n/2) in if n mod 2 = 0 then x * x else 2 * x * x ;;

let dessine mot =
    let rec dessin_rec a x0 y0 =
        point x0 y0 ;
        match a with
            | Feuille -> ()
            | Nud(g,d) ->  let delta = 3 * (deux_puissance (profondeur_arbre a))
                            in
                            begin
                                dessin_rec g (x0 + delta) y0 ;
                                dessin_rec d x0 (y0 + delta) ;
                                va_à (x0 + delta) y0 ;
                                tracer x0 y0 ;
                                tracer x0 (y0 + delta)
                            end
    in
    dessin_rec (arbre_of_Lukasiewicz mot) 0 0 ;;

Mots de Lyndon :

exception Not_Lyndon ;;

type comparaison = Inférieur | Égal | Supérieur ;;

let rec ordre u v = match u,v with
    | [],[] -> Égal
    | [],_ -> Inférieur
    | _,[] -> Supérieur
    | u0 :: u' , v0 :: v'
        -> if u0 = v0 then ordre u' v'
           else if u0 < v0 then Inférieur else Supérieur ;;
           
let rec est_préfixe a mot = match a with
    | [] -> true
    | a0 :: a' -> match mot with
                    | m0 :: m' when a0 = m0 -> est_préfixe a' m'
                    | _ -> false ;;

let est_suffixe a mot =
    let rec shift l = function
        | 0 -> l
        | n -> shift (tl l) (n - 1)
    in
    let la,lm = (list_length a),(list_length mot)
    in
    if la > lm then false
    else a = (shift mot (lm - la)) ;;

let rotation mot = (tl mot) @ [ hd mot ] ;;

let est_Lyndon_def mot =
    let n = list_length mot
    and m = ref mot
    in
    try
        for i = 1 to n  do
            m := rotation !m ;
            if (ordre mot !m) = Supérieur then raise Not_Lyndon
        done ;
        true
    with Not_Lyndon -> false ;;
    
let est_Lyndon mot =
    let rec test = function
        | [] -> true
        | (a :: q) as m' -> (Inférieur = ordre mot m') && (test q)
    in
    test (tl mot) ;;

let factorisation_de_Lyndon mot =
    let rec réduit = function
        | (a :: b :: q) as ll
            ->  ( if (ordre a b) = Inférieur then
                        let m,_ = réduit ((a @ b) :: q) in m,true
                  else
                        match réduit (b :: q) with
                            | m,true -> réduit (a :: m)
                            | m,false -> ll,false                       )
        | ll -> ll,false
    in
    match réduit (map (function x -> [x]) mot) with ll,_ -> ll ;;

let Lyndon =
    let rec insertion x = function
        | [] -> [x]
        | y :: q -> match ordre x y with
                        | Inférieur -> x :: y :: q
                        | Égal -> y :: q
                        | Supérieur -> y :: (insertion x q)
    in
    let rec map_accu f accu = function
        | [] -> accu
        | x :: q -> match f(x) with
                        | [] -> map_accu f accu q
                        | y -> map_accu f (insertion y accu) q
    in
    let compose_un x1 l2 accu =
        map_accu (function x2 -> if Inférieur = ordre x1 x2 then x1 @ x2 else [])
                 accu l2
    in
    let rec compose l1 l2 accu =
        match l1 with
            | [] -> accu
            | x1 :: q -> compose q l2 (compose_un x1 l2 accu)
    in
    let rec compose_tout f n k accu =
        if k < n then compose_tout f n (k+1) (compose (f k) (f (n-k)) accu)
        else accu
    in
    let mémoire = ref [ (0,[]) ; (1,[ [0] ; [1] ]) ]
    in
    let rec f n =
        try assoc n !mémoire
        with Not_found -> let res = compose_tout f n 1 []
                          in
                          mémoire := (n,res) :: !mémoire ;
                          res
    in
    f ;;

Permutations :

let image v k = v.(k - 1)
and affecte v k x = v.(k-1) <- x ;;
    
let identité n =
    let v = make_vect n 1
    in
    for i = 1 to n do affecte v i i done ;
    v ;;

let compose v v' =
    let n,n' = (vect_length v),(vect_length v')
    in
    if n = n' then
        let w = make_vect n 1
        in
        for i = 1 to n do affecte w i (image v (image v' i)) done ;
        w
    else
        failwith "Composition de deux permutations de tailles différentes" ;;
        
let rec intervalle_d'entiers i j =
    if i > j then []
    else i :: (intervalle_d'entiers (i+1) j) ;;

let est_permutation v =
    let n = vect_length v
    in
    let un_a_n = intervalle_d'entiers 1 n
    in
    let rec est_ok = function
        | [] -> true
        | a :: q -> (not (mem a q)) && (mem a un_a_n) && (est_ok q)
    in
    est_ok (list_of_vect v) ;;

let orbite v k =
    let rec augmente_orbite k liste =
        if mem (image v k) liste then liste
        else augmente_orbite (image v k) ((image v k) :: liste)
    in
    augmente_orbite k [ k ] ;;

let rec select f = function
    | [] -> []
    | a :: q -> if (f a) then a :: (select f q) else select f q ;;
    
let points_fixes v =
    let n = vect_length v
    in
    select (function x -> x = (image v x)) (intervalle_d'entiers 1 n) ;;

let réciproque v =
    let n = vect_length v
    in
    let w = make_vect n 1
    in
    for i = 1 to n do affecte w (image v i) i done ;
    w ;;

let rec ôte x = function
    | [] -> []
    | a :: q when a = x -> q
    | a :: q -> a :: (ôte x q) ;;

let cycles v =
    let rec un_cycle x0 x candidats =
        if (image v x) = x0 then [ x0 ] , (ôte x candidats)
        else
            let queue,c' = un_cycle x0 (image v x) (ôte x candidats)
            in
            x :: queue,c'
    in
    let rec épuise = function
        | [] -> []
        | a :: _ as liste ->    let cycle,candidats = un_cycle a a liste
                                in
                                cycle :: (épuise candidats)
    in
    épuise (list_of_vect v) ;;

let échange v i j =
    let x = v.(i)
    in
    v.(i) <- v.(j) ; 
    v.(j) <- x ;;

let applique_aux_permutations f n =
    let v = vect_of_list (intervalle_d'entiers 1 n)
    in
    let rec perm_rec i =
        if i = n - 1 then f v
        else
            for j = i to n - 1 do
                échange v i j ;
                perm_rec (i+1) ;
                échange v i j
            done
    in
    perm_rec 0 ;;
    
let print_permutation v =
    for i = 0 to (vect_length v) - 1 do
        print_int v.(i) ;
        print_char ` `
    done ;
    print_newline () ;;
    
let toutes_les_permutations = applique_aux_permutations print_permutation ;;

exception No_more_permutation ;;

let permutation_suivante v =
    let n = vect_length v
    in
    let rec début_suffixe i =
        if i <= 0 then raise No_more_permutation
        else
        if v.(i) < v.(i-1) then début_suffixe (i-1)
        else i-1
    and retourne_suffixe a b =
        if a < b then
        begin
            échange v a b ;
            retourne_suffixe (a + 1) (b - 1) 
        end
    and place k j =
        if v.(j) > v.(k) then échange v j k
        else place k (j + 1)
    and modifie_suffixe k =
            retourne_suffixe (k + 1) (n - 1) ;
            place k (k + 1)
    in
    modifie_suffixe ( début_suffixe (n - 1) ) ;;

Retour à la page générale de La lettre de Caml.