La lettre de Caml, numéro 1

Les sources des programmes Caml

gestion de fichiers d'image ; nth linéaire ; parseur arithmétique ; automates

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


Gestion de fichiers d'image :

(************************************************************************
Syntaxe : bmp2clg "nom_fichier"
     ou : bmp2clg "nom_fichier.bmp"
crée un fichier nommé "nom_fichier.clg" 
************************************************************************)

let nom_sans_extension nom ext =
    let n = string_length nom
    and n' = string_length ext
    in
    if n > n' && eq_string ("." ^ ext) (sub_string nom (n-n'-1) (n'+1))
        then sub_string nom 0 (n-n'-1)
    else nom ;;

let bmp2clg fichier_bmp =
    let nom = nom_sans_extension fichier_bmp "bmp"
    in
    let canal_in = open_in  (nom ^ ".bmp")
    and canal_out = open_out (nom ^ ".clg")
    in
    let lit_deux_octets décalage =
    begin
        seek_in canal_in décalage ;
        let poids_faible = input_byte canal_in
        in
        let poids_fort = input_byte canal_in
        in
        poids_faible + 256 * poids_fort
    end
    in
    let largeur = 4 * ((lit_deux_octets(18) + 3)/4)
    in
    output_binary_int canal_out largeur ;
    let hauteur = lit_deux_octets(22)
    in
    output_binary_int canal_out hauteur ;
    print_string "largeur = " ; print_int largeur ;
    print_string " , hauteur = " ; print_int hauteur ;
    print_newline () ;
    let palette=make_vect 256 0 
    in
    let lit_couleur () =
        let b = input_byte canal_in
        in
        let g = input_byte canal_in
        in
        let r = input_byte canal_in
        in
        let _ = input_byte canal_in
        in
        rgb r g b
    in
    seek_in canal_in 54 ;
    for i = 0 to 255 do palette.(i) <- lit_couleur() done ;
    for i = 1 to hauteur do
        seek_in canal_in (1078 + largeur * (hauteur-i)) ;
        for j=1 to largeur do
            output_binary_int canal_out palette.(input_byte canal_in)
        done
    done ;
    close_out canal_out ; 
    close_in canal_in ;;

(************************************************************************
Syntaxe: charge_clg "nom_fichier"
     ou: charge_clg "nom_fichier.clg"
************************************************************************)
              
let charge_clg fichier_clg =
    let nom = (nom_sans_extension fichier_clg "clg") ^ ".clg" in
    let canal_in = open_in nom in
    let largeur = input_binary_int canal_in in
    let hauteur = input_binary_int canal_in in
    let image = make_matrix hauteur largeur 0
    in
    for i=0 to hauteur-1 do
        for j=0 to largeur -1 do
            image.(i).(j) <- input_binary_int canal_in
        done
    done ;
    image ;;

Recherche linéaire du i-ème plus petit élément :

let rec tri_insertion l = 
    let rec insertion x = function
          [] -> [x]
        | a::q -> if x<a then x :: a :: q else a :: (insertion x q)
    in
    match l with
      [] -> []
    | a::q -> insertion a (tri_insertion q) ;;


let découpe liste pivot =
    let rec découpe_rec l1 n1 l2 n2 = function
              [] -> l1,n1,l2,n2
            | a :: q -> if a < pivot
                    then découpe_rec (a::l1) (n1+1) l2 n2 q
                    else découpe_rec l1 n1 (a::l2) (n2+1) q
    in découpe_rec [] 0 [] 0 liste ;;
    
(* par exemple :                    *)
(*      découpe [1;3;2;5;4] 3 ;;    *)
(*      s'évalue en                 *)
(*      [2; 1], 2, [4; 5; 3], 3     *)

let rec quintuplifie = function
      [] -> []
    | a::b::c::d::e::q -> [a;b;c;d;e] :: (quintuplifie q)
    | l -> [l] ;;
    
let rec milieux = function
      [] -> []
    | [a;b;c;d;e] :: q -> c :: (milieux q)
    | (a::_)::q -> a :: (milieux q) ;;
    
let rec nth n l = if n=0 then hd l else nth (n-1) (tl l) ;;

let rec nth_linéaire n l =  
        (* renvoie le n-ième élément de la liste l, *)
        (* dans l'ordre, nth 0 l est donc le min    *)
    let choisit_pivot l n =
        let médians = milieux (map tri_insertion (quintuplifie l))
        in
        nth_linéaire (((n+4)/5)/2) médians
    in
    match l with
      [] -> failwith "Liste vide"
    | l ->  let nl = (list_length l)
            in
            if nl <= 5 then nth n (tri_insertion l)
            else
            let l1,n1,l2,n2 = découpe l (choisit_pivot l nl)
            in
            if n < n1 
            then nth_linéaire n l1
            else nth_linéaire (n-n1) l2 ;;

(* par exemple :                            *)
(*      nth_linéaire 6 [1;4;2;7;3;0;5;6]    *)
(*      s'évalue en 6                       *)

Lexeur, parseur et évaluateur arithmétiques :

type lexème = Entier of int | Plus | Moins | Multiplie | Divise 
                | Puissance | ParenthèseGauche | ParenthèseDroite ;;
                
let int_of_digit c = (int_of_char c) - (int_of_char `0`) ;;
                
let rec MangeEntier flot accu = match flot with
    | [< '(`0`..`9` as c) >] -> MangeEntier flot (10*accu+(int_of_digit c))
    | [< >] -> Entier(accu) ;;
                
let rec lexeur flot = match flot with
    | [< '(` ` | `\r` | `\t` | `\n`) >] -> lexeur flot
    | [< '`+` >] -> [< 'Plus ; (lexeur flot) >]
    | [< '`-` >] -> [< 'Moins ; (lexeur flot) >]
    | [< '`*` >] -> [< 'Multiplie ; (lexeur flot) >]
    | [< '`/` >] -> [< 'Divise ; (lexeur flot) >]
    | [< '`^` >] -> [< 'Puissance ; (lexeur flot) >]
    | [< '`(` >] -> [< 'ParenthèseGauche ; (lexeur flot) >]
    | [< '`)` >] -> [< 'ParenthèseDroite ; (lexeur flot) >]
    | [< '(`0`..`9` as c) >] 
            -> [< '(MangeEntier flot (int_of_digit c)) ; (lexeur flot) >]
    | [< >] -> [< >] ;;

type expression = N of int
        | Opposé of expression
        | Somme of expression*expression
        | Différence of expression*expression
        | Produit of expression*expression
        | Quotient of expression*expression
        | Élévation of expression*expression ;;
        
exception Syntax_error ;;

let rec parseur_E flot = match flot with
    | [< parseur_F f ; parseur_E' e' >] 
            -> match e' with
                | [< 'Somme(_,e) >] -> Somme(f,e)
                | [< 'Différence(_,e) >] -> Différence(f,e)
                | [< >] -> f
    | [< >] -> raise Syntax_error
and parseur_E' flot = match flot with
    | [< 'Plus ; parseur_E e >] -> [< 'Somme(N(0),e) >]
    | [< 'Moins ; parseur_E e >] -> [< 'Différence(N(0),e) >]
    | [< >] -> [< >]
and parseur_F flot = match flot with
    | [< parseur_G g ; parseur_F' f' >] 
            -> match f' with
                | [< 'Produit(_,e) >] -> Produit(g,e)
                | [< 'Quotient(_,e) >] -> Quotient(g,e)
                | [< >] -> g
    | [< >] -> raise Syntax_error
and parseur_F' flot = match flot with
    | [< 'Multiplie ; parseur_F f >] -> [< 'Produit(N(0),f) >]
    | [< 'Divise ; parseur_F f >] -> [< 'Quotient(N(0),f) >]
    | [< >] -> [< >]
and parseur_G flot = match flot with
    | [< parseur_H h ; parseur_G' g' >] 
            -> match g' with
                | [< 'Élévation(_,e) >] -> Élévation(h,e)
                | [< >] -> h
    | [< >] -> raise Syntax_error
and parseur_G' flot = match flot with
    | [< 'Puissance ; parseur_G g >] -> [< 'Élévation(N(0),g) >]
    | [< >] -> [< >]
and parseur_H flot = match flot with
    | [< 'Moins ; parseur_I i >] -> Opposé(i)
    | [< parseur_I i >] -> i
    | [< >] -> raise Syntax_error
and parseur_I flot = match flot with
    | [< 'ParenthèseGauche ; parseur_E e ; 'ParenthèseDroite >] -> e
    | [< 'Entier(n) >] -> N(n)
    | [< >] -> raise Syntax_error ;;
    
let parseur s = parseur_E (lexeur (stream_of_string s)) ;;

exception Power_error of string ;;

let carré n = n*n ;;
let impair n = (n mod 2) <> 0 ;;
        
let rec puissance a b =
    if b < 0 then raise (Power_error "exposants négatifs interdits")
    else if a = 0 then  
            if b = 0 then raise (Power_error "O^O n'existe pas")
            else 0
    else if b = 0 then 1
    else if impair b then a * carré(puissance a (b/2))
    else carré(puissance a (b/2)) ;;
        
let rec évaluation = function
    | N(n) -> n
    | Opposé(e) -> - (évaluation e)
    | Somme(e,f) -> (évaluation e) + (évaluation f)
    | Différence(e,f) -> (évaluation e) - (évaluation f)
    | Produit(e,f) -> (évaluation e) * (évaluation f)
    | Quotient(e,f) -> (évaluation e) / (évaluation f)
    | Élévation(e,f) -> puissance (évaluation e) (évaluation f) ;;

let évalue s = évaluation (parseur s) ;;

Automates :

exception Pas_de_transition ;;

type genre      = Non_final | Final ;

type automateD  = { mutable état_initialD : étatD ; 
                    mutable les_étatsD : étatD list }
and étatD       = { mutable espèceD : genre ; 
                    mutable déclencheursD : char list ; 
                    mutable transitionD : char -> étatD } ;;

type automateND = { mutable état_initialND : étatND ;
                    mutable les_étatsND : étatND list }
and étatND      = { mutable espèceND : genre ;
                    mutable déclencheursND : char list ;
                    mutable transitionND : char -> étatND list ;
                    mutable epsilon_transitionND : étatND list } ;;

let reconnaissanceD automate chaîne =
    let n = string_length chaîne
    in
    let rec reconnaît_rec état i =
        if i = n then état.espèceD = Final
        else try reconnaît_rec (état.transitionD chaîne.[i]) (i+1)
             with Pas_de_transition -> false
    in
    reconnaît_rec automate.état_initialD 0 ;;

let pt_fixe f l0 =
    let rec pt_fixe_rec défi prod épuisés =
         match prod with
              [] -> défi
            | a :: q -> if mem a épuisés then pt_fixe_rec défi q épuisés
                        else let l = f(a)
                             in
                             pt_fixe_rec (union l défi)
                                         (union l prod)
                                         (a :: épuisés)
    in
    pt_fixe_rec l0 l0 [] ;;
    
let epsilon_clôture liste_états = 
        pt_fixe (function état -> état.epsilon_transitionND) liste_états ;;
    
let flat_union_map f l = flat_union_map_rec l where rec
          flat_union_map_rec = function
                | [] -> []
                | a :: q -> union (f a) (flat_union_map_rec q) ;;

let reconnaissanceND automate chaîne =
    let n = string_length chaîne
    in
    let rec reconnaîtND_rec liste_états i =
        if i = n then 
            exists (function état -> état.espèceND = Final) liste_états
        else    let c = chaîne.[i]
                in
                reconnaîtND_rec
                    (flat_union_map 
                        ( function état ->  try état.transitionND c
                                            with Pas_de_transition -> [] )
                        (epsilon_clôture liste_états) )
                    (i+1)
    in
    reconnaîtND_rec [ automate.état_initialND ] 0 ;;

let filtre prédicat = filtre_rec where rec
    filtre_rec = function
        | [] -> []
        | a :: q -> if prédicat a then a :: (filtre_rec q)
                    else filtre_rec q ;;

let états_finaux automate =
    filtre (function état -> état.espèceND = Final) automate.les_étatsND ;;

let automate_d'alternative a1 a2 =
    let finaux1,finaux2 = (états_finaux a1),(états_finaux a2)
    in
    let nouvel_initial = 
        { espèceND = Non_final ; déclencheursND = [] ;
          epsilon_transitionND = [ a1.état_initialND ; a2.état_initialND ] ;
          transitionND = (function _ -> raise Pas_de_transition)  }
    and nouveau_final =
        { espèceND = Final ; déclencheursND = [] ;
          epsilon_transitionND = [] ;
          transitionND = (function _ -> raise Pas_de_transition ) }
    in
    let foo état =
        begin
            état.espèceND <- Non_final ;
            état.epsilon_transitionND <- 
                nouveau_final :: état.epsilon_transitionND
        end
    in
    do_list foo finaux1 ; do_list foo finaux2 ;
    
    { état_initialND = nouvel_initial ;
      les_étatsND = nouvel_initial :: nouveau_final
          :: (a1.les_étatsND @ a2.les_étatsND) } ;;

let automate_d'étoilée a1 =
    let finaux1 = états_finaux a1
    in
    let nouveau_final =
        {   espèceND = Final ; déclencheursND = [] ;
            epsilon_transitionND = [] ;
            transitionND = (function _ -> raise Pas_de_transition ) }
    in
    let nouvel_initial = 
        {   espèceND = Non_final ; déclencheursND = [] ;
            epsilon_transitionND = [ a1.état_initialND ; nouveau_final ] ;
            transitionND = (function _ -> raise Pas_de_transition)  }
    in
    let foo état =
        begin
            état.espèceND <- Non_final ;
            état.epsilon_transitionND <- 
                a1.état_initialND :: nouveau_final
                    :: état.epsilon_transitionND
        end
    in
    do_list foo finaux1 ;
    
    { état_initialND = nouvel_initial ;
      les_étatsND = nouvel_initial :: nouveau_final :: a1.les_étatsND } ;;

let automate_de_séquence a1 a2 =
    let finaux1 = états_finaux a1
    in
    let foo état =
        begin
            état.espèceND <- Non_final ;
            état.epsilon_transitionND <- 
                a2.état_initialND :: état.epsilon_transitionND
        end
    in
    do_list foo finaux1 ;
    { état_initialND = a1.état_initialND ;
      les_étatsND = a1.les_étatsND @ a2.les_étatsND } ;;

let automate_de_chaîne s =
    let final =
        {   espèceND = Final ; déclencheursND = [] ;
            epsilon_transitionND = [] ;
            transitionND = (function _ -> raise Pas_de_transition ) }
    in
    let rec ajoute_caractère i liste_des_états état_courant =
        if i >= 0 then
            let nouvel_état =
                { espèceND = Non_final ; déclencheursND = [ s.[i] ] ;
                  epsilon_transitionND = [] ;
                  transitionND = 
                    (function c -> if c = s.[i] then [ état_courant ]
                                   else raise Pas_de_transition )     }
            in ajoute_caractère (i-1)
                                (nouvel_état::liste_des_états) 
                                nouvel_état
        else 
            { état_initialND = état_courant ;
              les_étatsND = liste_des_états } 
    in
    ajoute_caractère ((string_length s) - 1) [ final ] final ;;

let rec auto_de_regexp = function
      Chaîne s -> automate_de_chaîne s
    | Séquence(e1,e2) -> automate_de_séquence (auto_de_regexp e1) (auto_de_regexp e2)
    | Étoilée e -> automate_d'étoilée (auto_de_regexp e)
    | Alternative(e1,e2) -> automate_d'alternative (auto_de_regexp e1) (auto_de_regexp e2)
    | _ -> failwith "êtes-vous sûr d'avoir appelé le bon parseur ?" ;;


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