La lettre de Caml, numéro 7

Les sources des programmes Caml

interface de la bibliothèque PATRICIA; implémentation de la bibliothèque PATRICIA ;

interface de la bibliothèque sur les séries formelles ; implémentation de la bibliothèque sur les séries formelles

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

L'interface de la bibliothèque sur les arbres compactés de recherche :

type arbre_de_recherche =
    {
        chercher : string -> bool ;
        insérer : string -> unit ;
        supprimer : string -> unit
    } ;;
    
value nouvel_arbre : unit -> arbre_de_recherche ;;

L'implémentation de la bibliothèque sur les arbres compactés de recherche :

let rec intervalle i j =
    if i <= j then i :: (intervalle (i+1) j)
    else [] ;;

let bits_of_char c =
    let c' = int_of_char c
    in
    it_list (fun l i -> (c' lsr i) land 1 :: l)
        [] (intervalle 0 7) ;;

let bits_of_string s =
    list_it
        (fun i l -> bits_of_char s.[i] @ l)
        (intervalle 0 (string_length s - 1))
        [0;0;0;0;0;0;0;0] ;;

type arbre = Feuille of string | Nud of int * arbre * arbre ;;

let rec skip k l =
    if k = 0 then l
    else skip (k - 1) (tl l) ;;

let recherche a s =
    let rec aux l = function
        | Feuille s' -> s = s'
        | Nud(k,g,d)
            ->  try
                    let t :: q = skip k l
                    in
                    aux q (if t = 0 then g else d)
                with _ -> false
    in
    aux (bits_of_string s) a ;;

let rec suppression a s =
    let rec aux l = function
        | Feuille s' when s <> s' -> Feuille s'
        | Feuille _ -> failwith "Arbre vide !"
        | Nud(k,Feuille s',d) when s' = s
            ->  (   match d with
                        | Feuille _ -> d
                        | Nud(k',g',d') -> Nud(k + k' + 1,g',d')  )
        | Nud(k,g,Feuille s') when s' = s
            ->  (   match g with
                        | Feuille _ -> g
                        | Nud(k',g',d') -> Nud(k + k' + 1,g',d')  )
        | Nud(k,g,d)
            -> try
                    match skip k l with
                        t :: q ->   if t = 0 then Nud(k,(aux q g),d)
                                    else Nud(k,g,(aux q d))
                with _ -> Nud(k,g,d)
    in
    aux (bits_of_string s) a ;;

let trouve_place s a =
    let rec descend = function
        | Feuille s' -> s'
        | Nud(_,g,_) -> descend g
    in
    let rec aux l = function
        | Feuille s' -> s'
        | Nud(k,g,d)
            ->  try
                    match skip k l with
                        t :: q -> aux q (if t = 0 then g else d)
                with _ -> descend g
    in
    aux (bits_of_string s) a ;;

let rec discrimine l1 l2 i =
    match l1,l2 with
        t1 :: q1,t2 :: q2
            ->  if t1 <> t2 then i,t1,t2
                else discrimine q1 q2 (i + 1) ;;

let insertion a s =
    let s' = trouve_place s a
    in
    if s = s' then a
    else
    let l,l' = (bits_of_string s),(bits_of_string s')
    in
    let i,c,_ = discrimine l l' 0
    in
    let rec aux j l = function
        | Feuille s' as a
            ->  if c = 0 then Nud(j,Feuille s,a)
                else Nud(j,a,Feuille s)
        | Nud(k,g,d) as a
            ->  if j > k then
                    let t :: q = skip k l
                    in
                    if t = 0 then Nud(k,(aux (j - k - 1) q g),d)
                    else Nud(k,g,(aux (j - k - 1) q d))
                else if j < k then
                    if c = 0 then Nud(j,Feuille s,Nud(k-j-1,g,d))
                    else Nud(j,Nud(k-j-1,g,d),Feuille s)
                else (* j = k *)
                    failwith "Erreur irrécupérable" 
    in
    aux i l a ;;

(*******************************************
 ce type est défini dans le fichier .mli,
 sa définition ne doit pas être répétée !

type arbre_de_recherche =
    { chercher : string -> bool ; insérer : string -> unit ; supprimer : string -> unit } ;;
    
*********************************************)

let nouvel_arbre () =
    let a = ref (Feuille "")
    in
    {
        chercher = (function s -> recherche !a s) ;
        insérer = (function s -> a := insertion !a s) ;
        supprimer = (function s -> a := suppression !a s)
    } ;;

L'interface de la bibliothèque sur les séries formelles :

#open "num" ;;

type série_formelle ;;

value   prefix +@ : série_formelle -> série_formelle -> série_formelle
and     prefix -@ : série_formelle -> série_formelle -> série_formelle
and     prefix *@ : série_formelle -> série_formelle -> série_formelle
and     prefix /@ : série_formelle -> série_formelle -> série_formelle
and     prefix @@ : série_formelle -> série_formelle -> série_formelle
and     prefix ^@ : série_formelle -> num -> série_formelle
and     prefix !@ : num list -> série_formelle
and     prefix %@ : num -> série_formelle -> série_formelle

and
    zéro    : num
and un      : num
and deux    : num
and trois   : num
and quatre  : num
and cinq    : num
and six     : num
and sept    : num
and huit    : num
and neuf    : num
and dix     : num
and un_demi : num
and 
    moins_un        : num
and moins_deux      : num
and moins_trois     : num
and moins_quatre    : num
and moins_cinq      : num
and moins_six       : num
and moins_sept      : num
and moins_huit      : num
and moins_neuf      : num
and moins_dix       : num
and moins_un_demi   : num
and
    print_SF            : série_formelle -> int -> unit
and print_par_défaut    : série_formelle -> unit
and installe_impression : unit -> unit
and
    crée_SF_de      : (num -> num) -> série_formelle
and crée_SF_expo_de : (num -> num) -> série_formelle
and intégration_SF  : série_formelle -> num -> série_formelle
and dérivation_SF   : série_formelle -> série_formelle
and
    sinus           : série_formelle
and cosinus         : série_formelle
and sinus_h         : série_formelle
and cosinus_h       : série_formelle
and tangente        : série_formelle
and tangente_h      : série_formelle
and arctangente     : série_formelle
and arctangente_h   : série_formelle
and exponentielle   : série_formelle
and ln_un_plus_z    : série_formelle
and arcsinus        : série_formelle
and arcsinus_h      : série_formelle
and catalan         : série_formelle ;;

L'implémentation de la bibliothèque sur les séries formelles :

#open "num" ;;

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

type série_formelle = { Constante : num ; mutable Reste : série_formelle glaçon } ;;

let moins_un = num_of_int (-1) and moins_deux = num_of_int (-2) ;;
let [zéro;un;deux;trois;quatre;cinq;six;sept;huit;neuf;dix] = map num_of_int [0;1;2;3;4;5;6;7;8;9;10] ;;
let [moins_un;moins_deux;moins_trois;moins_quatre;moins_cinq;moins_six;moins_sept;moins_huit;moins_neuf;moins_dix]
= map num_of_int [-1;-2;-3;-4;-5;-6;-7;-8;-9;-10] ;;
let un_demi = un // deux and moins_un_demi = moins_un // deux ;;

let reste_SF s = match s.Reste with
    | Gelé r -> let a = r() in s.Reste <- Connu a ; a
    | Connu a -> a ;;


let crée_SF_de f =
    let rec crée n =
        {   Constante = f n ;
            Reste = Gelé (function () -> crée (n +/ un))
        }
    in
    crée zéro ;;

let SF_de_poly l =
    let rec crée = function
        | [] -> { Constante = zéro ; Reste = Gelé (function () -> crée []) }
        | a :: q -> { Constante = a ; Reste = Gelé (function () -> crée q) }
    in
    crée l ;;

let crée_SF_expo_de f =
    let rec crée n nn =
        {   Constante = (f n) // nn ;
            Reste = Gelé (function () -> crée (n +/ un) (nn */ (n +/ un)))
        }
    in
    crée zéro un ;;

let rec liste_des_coefficients s = function
    | 0 -> []
    | n -> s.Constante :: (liste_des_coefficients (reste_SF s) (n-1)) ;;

let rec zéro_SF () = { Constante = zéro ; Reste = Gelé zéro_SF } ;;

let rec zn_SF = function
    | 0 -> { Constante = un ; Reste = Gelé zéro_SF }
    | n -> { Constante = zéro ; Reste = Gelé (function () -> zn_SF (n-1)) } ;;

let rec addition_SF s t =
    {   Constante = s.Constante +/ t.Constante ;
        Reste = Gelé (function () -> addition_SF (reste_SF s) (reste_SF t)) } ;;

let rec soustraction_SF s t =
    {   Constante = s.Constante -/ t.Constante ;
        Reste = Gelé (function () -> soustraction_SF (reste_SF s) (reste_SF t)) } ;;

let rec multiplication_SF_num s n =
    {   Constante = s.Constante */ n ;
        Reste = Gelé (function () -> multiplication_SF_num (reste_SF s) n)
    } ;;

let opposé_SF s = multiplication_SF_num s moins_un ;;

let rec intégration_SF s k0 =
    {   Constante = k0 ;
        Reste = Gelé (function() -> intègre_SF_depuis_un_certain_rang s un)
    }
and intègre_SF_depuis_un_certain_rang s n =
    {   Constante = s.Constante // n ;
        Reste = Gelé (function () -> intègre_SF_depuis_un_certain_rang (reste_SF s) (n +/ un))
    } ;;

let dérivation_SF s =
    let rec dérivation_aux s n =
        {   Constante = s.Constante */ n ;
            Reste = Gelé (function () -> dérivation_aux (reste_SF s) (n +/ un))
        }
    in
    dérivation_aux (reste_SF s) un ;;

let multiplication_SF s t =
    let produit_de_Cauchy a b =
        let b' = rev b
        in
        it_list2 (fun t x y -> t +/ x */ y) zéro a b'
    in
    let rec multiplie_aux s t sl tl =
        let sl' = s.Constante :: sl
        and tl' = t.Constante :: tl
        in
        {   Constante = produit_de_Cauchy sl' tl' ;
            Reste = Gelé (function () -> multiplie_aux (reste_SF s) (reste_SF t) sl' tl')
        }
    in
    multiplie_aux s t [] [] ;;

let composition_SF s t =
    let rec intervalle i j =
        if i > j then []
        else i :: (intervalle (i + 1) j)
    in
    let rec k_somme k s =   (* k_somme 3 6 renvoie [[4; 1; 1]; [3; 2; 1]; [3; 1; 2]; ... *)
        if s = 0 then []
        else if k = 1 then [ [ s ] ]
        else it_list
                (fun ll i -> (map (function l -> i :: l) (k_somme (k - 1) (s - i))) @ ll)
                [] (intervalle 1 s)
    in
    let coeff av bv =
        let n = vect_length av - 1
        in
        let sbk l = it_list (fun x i -> x */ bv.(n - i)) un l
        in
        it_list
            (fun s k -> s +/ av.(n-k) */ (it_list
                                            (fun x l -> x +/ (sbk l))
                                            zéro
                                            (k_somme k n)))
            zéro
            (intervalle 1 n)
    in
    let rec aux al bl s t =
        let al' = s.Constante :: al
        and bl' = t.Constante :: bl
        in
        {   Constante = coeff (vect_of_list al') (vect_of_list bl') ;
            Reste = Gelé(function () -> aux al' bl' (reste_SF s) (reste_SF t))
        }
    in
    if t.Constante <>/ zéro then failwith "La composée a(b(z)) n'existe que si v(b) > 1" ;
    {   Constante = s.Constante ;
        Reste = Gelé(function () -> aux [ s.Constante ] [ t.Constante ]
                                        (reste_SF s) (reste_SF t))
    } ;;

let un_plus_z_puissance_a_SF a =
    let rec aux coef k =
        let k' = k +/ un
        in
        {   Constante = coef ;
            Reste = Gelé (function () -> aux (coef */ (a -/ k) // k') k')
        }
    in
    {   Constante = un ;
        Reste = Gelé (function () -> aux a un)
    } ;;

let un_sur_a_plus_z_SF a =
    if a =/ zéro then failwith "1/z n'a pas de développement en série formelle" ;
    let a' = zéro -/ a
    in
    let rec aux coeff =
        {   Constante = coeff ;
            Reste = Gelé (function () -> aux (coeff // a'))
        }
    in
    aux (un // a) ;; 

let rec division_SF s t =
    let rec Cauchy_inverse a b t0 sn =
        let b' = tl (rev b)
        in
        (sn -/ (it_list2 (fun s x y -> s +/ x */ y) zéro a b')) // t0
    in
    let rec divise_aux s t ul tl t0 =
        let tl' = t.Constante :: tl
        in
        let u_n = Cauchy_inverse ul tl' t0 s.Constante
        in
        {
            Constante = u_n ;
            Reste = Gelé (function ()
                            -> divise_aux
                                    (reste_SF s) (reste_SF t)
                                    (u_n :: ul) tl' t0)
        }
    in
    if t.Constante =/ zéro then
        if s.Constante =/ zéro then division_SF (reste_SF s) (reste_SF t)
        else failwith "Division impossible : valuation du numérateur inférieure à celle du dénominateur"
    else
        divise_aux s t [] [] t.Constante ;;

let puissance_SF_num s n =
    let a = s.Constante
    in
    try
    multiplication_SF_num
        (composition_SF
            (un_plus_z_puissance_a_SF n)
            {
                Constante = zéro ;
                Reste = Gelé(function () -> reste_SF (multiplication_SF_num s (un // a)))
            })
        (if a =/ un then un else a **/ n)
    with _ -> failwith "Exponentiation impossible" ;;

let rec évalue_SF s x n =
    if n = 0 then s.Constante
    else s.Constante +/ x */ (évalue_SF (reste_SF s) x (n-1)) ;;

let prefix +@ = addition_SF
and prefix -@ = soustraction_SF
and prefix *@ = multiplication_SF
and prefix /@ = division_SF
and prefix @@ = composition_SF
and prefix ^@ = puissance_SF_num
and prefix !@ = SF_de_poly
and prefix %@ n s = multiplication_SF_num s n ;;

#open "format" ;;

let print_num n = print_string (string_of_num n) ;;

let print_variable = function
    | 0 -> false
    | 1 -> print_string " z" ; true
    | n -> print_string " z^" ; print_int n ; true ;;

let print_term 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 rec print_SF s until =
    open_hovbox 1;
    let c = s.Constante
    in
    if until == 0 then print_num c else
    let rest = ref s
    in
    let nul = ref true
    in
    if not (c =/ zéro) then (print_num c ; print_space() ; nul := false) ;
    for i = 1 to until do
        rest := reste_SF !rest;
        let delim = if !nul then "" else "+ "
        in
        if print_term delim i !rest then ( nul := false ; print_space())
    done ;
    if not !nul then print_string "+ " ;
    print_string "O(z^"; print_int (succ until) ;
    print_string ")" ;
    close_box() ;;

let print_par_défaut s = print_SF s 11 ;;

let installe_impression () = install_printer "print_par_défaut" ;;

let rec sinus = {   Constante = zéro ;
                    Reste = Gelé (function () -> intègre_SF_depuis_un_certain_rang cosinus un) }
and cosinus = { Constante = un ;
                Reste = Gelé (function () -> intègre_SF_depuis_un_certain_rang (opposé_SF sinus) un) } ;;


let rec sinus_h = { Constante = zéro ;
                    Reste = Gelé (function () -> intègre_SF_depuis_un_certain_rang cosinus_h un) }
and cosinus_h = {   Constante = un ;
                    Reste = Gelé (function () -> intègre_SF_depuis_un_certain_rang sinus_h un) } ;;

let tangente = sinus /@ cosinus ;;
let tangente_h = sinus_h /@ cosinus_h ;;
let arctangente   = intégration_SF ((!@ [un]) /@ (!@ [un;zéro;deux])) zéro ;;
let arctangente_h = intégration_SF ((!@ [un]) /@ (!@ [un;zéro;moins_deux])) zéro ;; 
let exponentielle = crée_SF_expo_de (function _ -> un) ;;
let ln_un_plus_z = intégration_SF (un_plus_z_puissance_a_SF moins_un) zéro ;;
let arcsinus = intégration_SF ((!@ [un;zéro;moins_deux]) ^@ moins_un_demi) zéro ;;
let arcsinus_h = intégration_SF ((!@ [un;zéro;deux]) ^@ moins_un_demi) zéro ;;

let catalan = ((!@ [un]) -@ ((!@ [un;moins_quatre]) ^@ un_demi))
                /@ (!@ [zéro;deux]) ;;

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