gestion de fichiers d'image ; nth linéaire ; parseur arithmétique ; automates
Retour à la page générale de La lettre de Caml.
(************************************************************************
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 ;;
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 *)
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) ;;
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.