La lettre de Caml, numéro 3

Les sources des programmes Caml

formes normales ; lecture des formes normales ; écriture des formes normales ; inverse fonctionnel d'une permutation ; algorithme de Johnson ; parseur arithmétique

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

Formes normales :

let rec point_fixe tr x0 =
    let rec aux x xx = if x = xx then x else aux xx (tr xx)
    in
    aux x0 (tr x0) ;;

let set_of_list =
    let rec aux accu = function
        | [] -> accu
        | h :: t -> if mem h accu then aux accu t else aux (h :: accu) t
    in
    aux [] ;;

let remove_p prédicat =
    let rec aux accu = function
        | [] -> accu
        | h :: t -> if prédicat h then (aux accu t) else aux (h :: accu) t
    in aux [] ;;

type proposition = Var of int
                 | Non of proposition
                 | Implique of proposition * proposition
                 | Equivalent of proposition * proposition
                 | Ou of proposition * proposition
                 | Et of proposition * proposition ;;

let éliminer_implique =
    let rec étape = function
        | Var(n)            -> Var(n)
        | Non(t)            -> Non(étape t)
        | Implique(t1,t2)   -> Ou(Non(étape t1),étape t2)
        | Equivalent(t1,t2) -> Et( Ou(Non(étape t1),étape t2) ,
                                   Ou(Non(étape t2),étape t1) )
        | Ou(t1,t2)         -> Ou(étape t1,étape t2)
        | Et(t1,t2)         -> Et(étape t1,étape t2)
    in point_fixe étape ;;

let intérioriser_négation =
    let rec étape = function
        | Non(Et(t1,t2)) -> Ou(Non(étape t1),Non(étape t2))
        | Non(Ou(t1,t2)) -> Et(Non(étape t1),Non(étape t2))
        | Var(n) -> Var(n)
        | Non(t) -> Non(étape t)
        | Ou(t1,t2) -> Ou(étape t1,étape t2)
        | Et(t1,t2) -> Et(étape t1,étape t2)
    in point_fixe étape ;;
    
let exterioriser_conjonction =
    let rec étape = function
        | Ou(f,Et(g,h)) -> Et(Ou(étape f,étape g),Ou(étape f,étape h))
        | Ou(Et(g,h),f) -> Et(Ou(étape g,étape f),Ou(étape h,étape f))
        | Var(n) -> Var(n)
        | Non(t) -> Non(étape t)
        | Ou(t1,t2) -> Ou(étape t1,étape t2)
        | Et(t1,t2) -> Et(étape t1,étape t2)
    in point_fixe étape ;;

let exterioriser_disjonction =
    let rec étape = function
        | Et(f,Ou(g,h)) -> Ou(Et(étape f,étape g),Et(étape f,étape h))
        | Et(Ou(g,h),f) -> Ou(Et(étape g,étape f),Et(étape h,étape f))
        | Var(n) -> Var(n)
        | Non(t) -> Non(étape t)
        | Ou(t1,t2) -> Ou(étape t1,étape t2)
        | Et(t1,t2) -> Et(étape t1,étape t2)
    in point_fixe étape ;;

let fnc_vers_ll p =
    let aplatir_et =
        let rec aux l = function
            | Et(a,b) -> (aux l a) @ (aux l b)
            | a -> a :: l
        in aux []
    and aplatir_ou =
        let rec aux l = function
            | Ou(a,b) -> (aux l a) @ (aux l b)
            | a -> a :: l
        in aux []
    in map aplatir_ou (aplatir_et p) ;;

let fnd_vers_ll p =
    let aplatir_et =
        let rec aux l = function
            | Et(a,b) -> (aux l a) @ (aux l b)
            | a -> a :: l
        in aux []
    and aplatir_ou =
        let rec aux l = function
            | Ou(a,b) -> (aux l a) @ (aux l b)
            | a -> a :: l
        in aux []
    in map aplatir_et (aplatir_ou p) ;;

let éliminer_double_négation =
    let élim =
        let rec étape = function
            | Var(n) -> Var(n)
            | Non(Non(a)) -> (étape a)
            | Non(a) -> Non(étape a)
        in point_fixe étape
    in map (map élim) ;;

let éliminer_a_non_a =
    let inutile liste =
        let négation = function
            | Var(n) -> exists (function x -> x = Non(Var(n))) liste
            | Non(Var(n)) -> exists (function x -> x = Var(n)) liste
        in exists négation liste
    in map (function x -> if (inutile x) then [] else x) ;;

let éliminer_variable_inutile = map set_of_list ;;

let éliminer_vide = remove_p (function [] -> true | _ -> false) ;;

let formeC t =
     (éliminer_vide
        (éliminer_a_non_a
            (éliminer_variable_inutile
                (éliminer_double_négation
                    (fnc_vers_ll
                        (fnc t)))))) ;;

let formeD t =
     (éliminer_vide
        (éliminer_a_non_a
            (éliminer_variable_inutile
                (éliminer_double_négation
                    (fnd_vers_ll
                        (fnd t)))))) ;;

type forme_normale = FNC of proposition list list 
                   | FND of proposition list list ;;

let forme_normale_conjonctive s = FNC(formeC (parseur s))
and forme_normale_disjonctive s = FND(formeD (parseur s)) ;;

Lecture des formes normales :

type lexème = Entier of int | Conjonction | Disjonction | Implication | Équivalence 
                | Négation | 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
    | [< '`^` >] -> [< 'Conjonction ; (lexeur flot) >]
    | [< '`|` >] -> [< 'Disjonction ; (lexeur flot) >]
    | [< '`=`;'`>` >] -> [< 'Implication ; (lexeur flot) >]
    | [< '`<`;'`=`;'`>` >] -> [< 'Équivalence ; (lexeur flot) >]
    | [< '`-` >] -> [< 'Négation ; (lexeur flot) >]
    | [< '`(` >] -> [< 'ParenthèseGauche ; (lexeur flot) >]
    | [< '`)` >] -> [< 'ParenthèseDroite ; (lexeur flot) >]
    | [< '(`0`..`9` as c) >] 
            -> [< '(MangeEntier flot (int_of_digit c)) ; (lexeur flot) >]
    | [< >] -> [< >] ;;

exception Syntax_error ;;

let rec parseur_E flot = match flot with
    | [< parseur_F f ; parseur_E' e' >] 
            -> match e' with
                | [< 'Ou(_,e) >] -> Ou(f,e)
                | [< >] -> f
    | [< >] -> raise Syntax_error
and parseur_E' flot = match flot with
    | [< 'Disjonction ; parseur_E e >] -> [< 'Ou(Var(0),e) >]
    | [< >] -> [< >]
and parseur_F flot = match flot with
    | [< parseur_G g ; parseur_F' f' >] 
            -> match f' with
                | [< 'Et(_,e) >] -> Et(g,e)
                | [< >] -> g
    | [< >] -> raise Syntax_error
and parseur_F' flot = match flot with
    | [< 'Conjonction ; parseur_F f >] -> [< 'Et(Var(0),f) >]
    | [< >] -> [< >]
and parseur_G flot = match flot with
    | [< parseur_H h ; parseur_G' g' >] 
            -> match g' with
                | [< 'Implique(_,e) >] -> Implique(h,e)
                | [< 'Equivalent(_,e) >] -> Equivalent(h,e)
                | [< >] -> h
    | [< >] -> raise Syntax_error
and parseur_G' flot = match flot with
    | [< 'Implication ; parseur_G g >] -> [< 'Implique(Var(0),g) >]
    | [< 'Équivalence ; parseur_G g >] -> [< 'Equivalent(Var(0),g) >]
    | [< >] -> [< >]
and parseur_H flot = match flot with
    | [< 'Négation ; parseur_I i >] -> Non(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) >] -> Var(n)
    | [< >] -> raise Syntax_error ;;
    
let parseur s = parseur_E (lexeur (stream_of_string s)) ;;

Écriture des formes normales :

#open "format" ;;

let print_variable = function
    | Var(n)       -> open_hbox () ; 
                      print_char (char_of_int (n-1+(int_of_char `a`))) ;
                      close_box ()
    | Non(Var (n)) -> open_hbox () ; 
                      print_char `-` ;
                      print_char (char_of_int (n-1+(int_of_char `a`))) ;
                      close_box () ;;

let print_disjonction l = 
    let rec aux = function
        | [] -> ()
        | tête :: queue -> print_space () ;
                           print_char `|` ;
                           print_space () ;
                           print_variable tête ;
                           aux queue
    in
    open_hovbox 3 ;
    match l with
        | [] -> ()
        | [x] -> print_variable x
        | tête :: queue ->              
                print_char `(` ;
                print_variable tête ; aux queue ;
                print_char `)` ;
    close_box () ;;

let print_conjonction l = 
    let rec aux = function
        | [] -> ()
        | tête :: queue -> print_space () ;
                           print_char `^` ;
                           print_space () ;
                           print_variable tête ;
                           aux queue
    in
    open_hovbox 3 ;
    match l with
        | [] -> ()
        | [x] -> print_variable x
        | tête :: queue -> 
                print_char `(` ;
                print_variable tête ; aux queue ;
                print_char `)` ;
    close_box () ;;

let print_fnc ll =
    let rec aux = function
        | [] -> ()
        | tête :: queue -> print_space () ;
                           print_char `^` ;
                           print_space () ;
                           print_disjonction tête ;
                           aux queue
    in
    open_hvbox 2 ;
    match ll with
        | [] -> ()
        | [ l ] -> print_conjonction l
        | tête :: queue -> print_break(2,0) ;
                           print_disjonction tête ;
                           aux queue ;
    close_box () ;;

let print_fnd ll =
    let rec aux = function
        | [] -> ()
        | tête :: queue -> print_space () ;
                           print_char `|` ;
                           print_space () ;
                           print_conjonction tête ;
                           aux queue
    in
    open_hvbox 2 ;
    match ll with
        | [] -> ()
        | [ l ] -> print_conjonction l
        | tête :: queue -> print_break(2,0) ;
                           print_conjonction tête ;
                           aux queue ;
    close_box () ;;

let print_forme_normale = function
    | FNC ll -> print_fnc ll
    | FND ll -> print_fnd ll ;;
    
install_printer "print_forme_normale" ;;

Inverse fonctionnel d'une permutation :

(* deux définitions utiles *)
let id = function x -> x;;
let compose f g = function x-> f(g x);;

(* la transposition de p et q *)
let tau p q x = if x = p then q else if x = q then p else x ;;

(* la composition à gauche par icelle *)
let by_tau p q h = compose (tau p q) h ;;

(* tout est prêt, allons-y ! *)
let inverse f n =
   let rec inv_rec f g n =
     if n = 0 then g else
     if n = f(n) then inv_rec f g (n-1) 
                 else inv_rec (by_tau n (f n) f) (by_tau n (f n) g) (n-1)
   in
   inv_rec f id n ;;

(* on fait un essai pour voir *)
let f = function 1 -> 3 | 2 -> 5 | 3 -> 4 | 4 -> 1 | 5 -> 2 | 6 -> 6 | x -> x ;;

for k=1 to 6 do print_int(f(inverse f 6 k)) done ;;

Algorithme de Johnson :

exception Fin ;;

type sens = Gauche | Droite ;;

let valeur_de (_,n) = n
and sens_de (s,_) = s ;;

let voit table i =
	match sens_de table.(i) with
		| Gauche -> i-1
		| Droite -> i+1 ;;
		
let est_mobile table i =
	try valeur_de table.(voit table i) < valeur_de table.(i)
	with Invalid_argument(_) -> false ;;
	
let inverse table i =
	match table.(i) with
		| Gauche,p -> table.(i) <- Droite,p
		| Droite,p -> table.(i) <- Gauche,p ;;
		
let initialise n =
	let v = make_vect n (Gauche,0)
	in
	for i = 0 to n-1 do v.(i) <- (Gauche,i+1) done ;
	v ;;
	
let avance table n =
	let rec cherche_max_mobile i indice_du_max =
		if i = n then 
			if indice_du_max = (-1) then raise Fin else indice_du_max
		else 
			if est_mobile table i && 
				(indice_du_max = (-1) || valeur_de table.(i) > (valeur_de table.(indice_du_max)))
			then cherche_max_mobile (i+1) i
			else cherche_max_mobile (i+1) indice_du_max
	in
	let indice_du_max = cherche_max_mobile 0 (-1)
	in
	let le_max = table.(indice_du_max)
	and indice_vu = voit table indice_du_max
	in
	let vu = table.(indice_vu)
	in
	table.(indice_du_max) <- vu ; table.(indice_vu) <- le_max ;
	for i = 0 to n-1 do
		if (valeur_de table.(i)) > (valeur_de le_max) then inverse table i
	done ;;
	
let affiche_permutation table n =
	for i = 0 to n-1 do print_int (valeur_de table.(i)) ; print_char ` ` done ;
	print_newline () ;;

let affiche_les_permutations n =
	let table = initialise n
	in
	try
		while true do
			affiche_permutation table n ;
			avance table n
		done
	with Fin -> () ;;

(*************************************************)
let impair n = n mod 2 = 1 ;;

let permutation n k =
	let table = make_vect n 0
	in
	let rec installe d p saut =
		if table.(d) = 0 then
			if saut = 0 then table.(d) <- p
			else installe (d+1) p (saut-1)
		else installe (d+1) p saut
	in
	let rec place p k =
		let bloc = 1 + (k-1)/p
		and ligne = 1 + (k-1) mod p
		in
		installe 0 p (if impair bloc then p-ligne else ligne-1) ;
		if p>1 then place (p-1) bloc
	in
	place n k ;
	table ;;

Parseur arithmétique :

exception Syntax_error ;;

let rec parseur_E pile flot = 
    let e = parseur_F [] flot
    in
    match flot with
        | [< 'Plus >] -> parseur_E ((e,Plus) :: pile) flot
        | [< 'Moins >] -> parseur_E ((e,Moins) :: pile) flot
        | [< >] -> construit_E pile e
and construit_E pile e = match pile with
    | [] -> e
    | (f,op) :: queue -> match op with
                            | Plus -> Somme(construit_E queue f,e)
                            | Moins -> Différence(construit_E queue f,e)
and parseur_F pile flot =
    let e = parseur_G flot
    in
    match flot with
        | [< 'Multiplie >] -> parseur_F ((e,Multiplie) :: pile) flot
        | [< 'Divise >] -> parseur_F ((e,Divise) :: pile) flot
        | [< >] -> construit_F pile e
and construit_F pile e = match pile with
    | [] -> e
    | (f,op) :: queue -> match op with
                            | Multiplie -> Produit(construit_F queue f,e)
                            | Divise -> Quotient(construit_F queue f,e)
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)) ;;

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