Page code source, mettez vos sources ici !

[gorgonite]

Vous avez des codes sources dans les langages fonctionnels ?
Vous pensez que ces codes sources peuvent aider d'autres personnes ?
Vous souhaitez partager vos codes avec des internautes ?

Dans ce cas, participez à l'enrichissement des pages de codes sources de developpez.com et postez à la suite

Pour chaque proposition, merci d'expliquer en quelques mots ce que fait le code, s'il nécessite des bibliothèques ou des options particulières.

[Strab]

Voici quelques fonctions de traitement des graphes que j'avais fait il y a quelques années pour un exercice scolaire. Cela offre une alternative intéressante je trouve à l'implémentation des graphes utilisée dans le tutoriel de millie (cf forum cours et tutoriels). Je ne sais pas si elle est meilleure ou quoi, je n'ai jamais cherché à savoir, je l'avais juste trouvée jolie à ce moment là

Je donne tout le source tel quel. Il y a quelques fonctions inutiles, c'est sûrement parce qu'on avait pas le droit à grand chose dans le cadre de l'exercice. Chaque fonction est précédée d'un cartouche expliquant précisément ce qu'elle fait. C'est du Caml Light

Code :

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
type ’a graphe = { sommets : ’a list ; succ : ’a −> ’a list };;

(* Interface appartient
type : ’a −> ’a list −> bool
arg : a = élément à rechercher
        l = liste de recherche
post : true si a appartient à l, false sinon *)
let rec appartient a l = match l with
   |[] −> false
   |t::q −> if a=t then true else appartient a q
;;


(* Interface miroir
type : ’a list −> ’a list
arg : l = liste à inverser
post : liste éléments de l dans l’odre inverse de celui de l *)
let miroir l =
   let rec aux l acc = match l with
     |[] −> acc
     |t::q −> aux q (t::acc)
   in aux l []
;;


(* Interface parcours
type : ’a graphe −> ’a −> ’a list
arg : graphe = graphe à parcourir
        x = sommet de départ
pre : x est un sommet de graphe
post : liste des sommets de g rencontrés lors de son parcours en profondeur à partir de son premier
 sommet. elle est dans l’odre où les sommets sont rencontrés *)
let parcours graphe x =
   (* aux fait le travail de parcours en s’aidant de deux paramètres supplémentaires : *)
   (* les successeurs de x et les sommets déjà parcourus *)
   (* les sommets sont ajoutés dès leur rencontre : résultat à l’envers *)
   let rec aux graphe x succ_x result_temp = match succ_x with
     |[] −> result_temp
     |t::q −> if appartient t result_temp (* t a−t−il été déjà visité ? *)
       then    (* on passe à la suite *)
         aux graphe x q result_temp
       else    (* on parcours les successeurs de t avant de continuer avec ceux de x *)
         aux graphe x q (aux graphe t (graphe.succ t) (t::result_temp))
   in miroir (aux graphe x (graphe.succ x) [x])
;;


(* Interface recherche
type : ’a graphe −> ’a −> ’a −> ’a list −> ’a list −> ’a list −> bool * ’a list * ’a list
arg : graphe
        a = sommet où commence la recherche
        b = sommet recherché
        succ_a = successeurs de a
        visites = sommets déjà visités au moment de cet appel
        temp = miroir du chemin parcouru pour rechercher arrivee
pre : a et les éléments de succ_a sont des sommets de graphe
post : triplet contenant :
         * un booléen vrai si il existe un chemin de graphe entre a et b
         * le miroir de ce chemin si il existe, celui du dernier essayé sinon
         * la liste des sommets visités *)
let rec recherche graphe a b succ_a temp visites = match succ_a with
     |[] −> false,temp,visites
     |t::q −> if t=b then true,t::temp,visites    (* on est arrivé *)
       else if appartient t visites (* sommes−nous déjà passés ici ? *)
       then      (* on passe à la suite *)
         recherche graphe a b q temp visites
       else      (* on essaye en passant par t... *)
         let trouve,temp’,visites’ = recherche graphe t b (graphe.succ t) (t::temp) (t::visites) in
         if trouve
         then trouve,temp’,visites’ (* ... et ça a marché *)
         else recherche graphe a b q temp visites’ (* ... en vain : on passe à la suite *)
;;


(* Interface circuit
type : ’a graphe −> ’a −> ’a list
arg : graphe = graphe où est recherché le circuit
        x = sommet que doit contenir le circuit recherché
pre : x est un sommet de graphe
post : un circuit (donc orienté) de graphe passant par x si il existe, la liste vide sinon *)
let circuit graphe x =
   let (trouve,chemin,_) = recherche graphe x x (graphe.succ x) [x] [x] in
     if trouve then miroir chemin else []
;;


(* Interface pred
type : ’a graphe −> ’a −> ’a list
arg : graphe
        x = sommet dont on veut les prédécesseurs
        sommets susceptibles d’être des prédécesseurs de x
pre : les éléments de sommets et x sont des sommets de graphe
post : liste des prédécesseurs de x *)
let rec pred graphe x sommets = match sommets with
   |[] −> []
   |t::q −> if t=x then pred graphe x q
             else if appartient x (graphe.succ t) then t::(pred graphe x q)
             else pred graphe x q
;;


(* Interface desoriente
type : ’a graphe −> ’a graphe
arg : graphe
post : renvoie graphe modifié de manière à ne plus tenir compte de l’orientation des arcs *)
let desoriente graphe =
   (* aux calcule la fonction succ associée au graphe désorienté *)
   let rec aux graphe sommets = match sommets with
     |[] −> (function x −> failwith "sommet inconnu")
     |t::q −> function
         |x when (x=t) −> (graphe.succ t)@(pred graphe t graphe.sommets)
         |x −> (aux graphe q) x
   in let succ’ = aux graphe graphe.sommets
   in { sommets = graphe.sommets ; succ = succ’ }
;;


type ’a precedent = Rien | P of ’a;;


(* Interface cycle
type : ’a graphe −> ’a −> ’a list
arg : graphe = graphe où est recherché le cycle
        x = sommet que doit contenir le cycle recherché
pre : x est un sommet de graphe
post : un cycle de graphe passant par x si il existe, la liste vide sinon *)
let cycle graphe x =
   let back t prec l = match prec with
     |Rien −> true
     |P(x) −> (t <> x) || appartient t l
   in let rec recherche2 graphe a b succ_a prec temp visites = match succ_a with
     |[] −> false,temp,visites
     |t::q −> if (t=b) && (back t prec q) (* On de doit pas revenir en arrière *)
       then true,t::temp,visites    (* on est arrivé *)
       else if appartient t visites (* sommes−nous déjà passés ici ? *)
       then      (* on passe à la suite *)
         recherche2 graphe a b q prec temp visites
       else      (* on essaye en passant par t... *)
         let trouve,temp’,visites’ = recherche2 graphe t b (graphe.succ t) (P a) (t::temp) (t::visites)
in
         if trouve
         then trouve,temp’,visites’ (* ... et ça a marché *)
         else recherche2 graphe a b q prec temp visites’ (* ... en vain : on passe à la suite *)
   in let graphe’ = desoriente graphe in
   let (trouve,chemin,_) = recherche2 graphe’ x x (graphe’.succ x) Rien [x] [x] in
     if trouve then miroir chemin else []
;;


(* Interface chemin
type : ’a graphe −> ’a −> ’a −> ’a list
arg : graphe = graphe où le chemin est recherché
        a = extremité initiale du chemin recherché
        b = extrémité finale du chemin recherché
pre : a est un sommet de graphe
post : un chemin de graphe entre a et b si il existe, la liste vide sinon *)
let chemin graphe a b =
   let (trouve,reponse,_) = recherche graphe a b (graphe.succ a) [a] [a] in
     if trouve then miroir reponse else []
;;


type ’a graphevalue = { sommets : ’a list ; succ : ’a −> (’a * int) list };;


(* Interface retire
type : ’a −> ’a list −> ’a list
arg : a = élément à retirer
        l = liste à modifier
post : l privée de la première occurence de a si elle existe (l sinon) *)
let rec retire a l = match l with
   | [] −> []
   |t::q−> if a=t then q else t::(retire a q)
;;


(* Interface inf
type : int −> int −> bool
arg : a b
post : true si a < b, false sinon, en considérant que −1 = l’infini *)
let inf a b = (a <> −1) && ( (b = −1) || (a < b) );;


(* Interface distmin
type : ’a list −> (’a * int) list −> ’a * int
arg : sbar = liste de sommets
        distances = liste de couples (sommet, distance)
pre : sbar et distances sont non vides
post : plus petit couple de distances (en ordonnant les couples par rapport à leur second élément) dont
 le premier élément appartient à sbar
raises : si sbar ou distances est vide *)
let rec distmin sbar distances =
   (* aux garde le plus petit couple trouvé en paramètre *)
   let rec aux sbar distances mintmp = match distances with
     | [] −> mintmp
     |(i,pi_i)::q −> let (j,pi_j) = mintmp in
          if (inf pi_i pi_j) && (appartient i sbar)
          then aux sbar q (i,pi_i) (* on a trouvé plus petit : on garde *)
          else aux sbar q mintmp
   in match distances with (* on cherche un premier mintmp avant d’appeler aux *)
     | [] −> failwith "distmin : l’un des arguments est vide"
     |(i,pi_i)::q −> if appartient i sbar
       then aux sbar q (i,pi_i)
       else distmin sbar q
;;


(* Interface longueur_arc
type : (’a * int) list −> ’a −> ’a −> int
arg : succ_i = successeurs de i
        i = extrêmité initiale de l’arc recherché
        j = son extrêmité finale
post : valeur de l’arc (i,j) si il existe, −1 sinon (représente l’infini) *)
let rec longueur_arc succ_i i j = if i=j then 0 else
   match succ_i with
     | []       −> −1
     |(t,d)::q −> if j=t then d else longueur_arc q i j
;;


(* Interface min2
type : int −> int −> int
arg : a b
pre : a est positif ou infini (égal à −1), b est positif
post : retourne le minimum des deux entiers en tenant compte de la possible infinitude de a *)
let min2 a b =
   if a < 0 then b else min a b
;;


(* Interface update
type : ’a graphevalue −> ’a list −> ’a −> int −> (’a * int) list −> (’a * int) list
arg : graphe
        sbar = liste de sommets
        j = sommet dont on veut mettre à jour les successeurs
        pi_j = distance de x0 à j (valeur définitive)
        distances = liste des couples (sommet, distance de sommet à x0)
pre : j est un sommet de graphe, pi_j non infini (différent de −1), distances contient les couples de
tous les sommets de graphe
post : pour chaque sommet i de sbar successeur de j, met à jour le couple correspondant si le chemin
 passant par j est plus court que l’actuel, ne modifie rien pour les autres *)
let rec update graphe sbar j pi_j distances = match distances with
   |[] −> []
   |(i,pi_i)::q −> let lji = longueur_arc (graphe.succ j) j i in
      if (lji > 0) && (appartient i sbar)             (* successeur de j dans sbar ? *)
      then (i,min2 pi_i (pi_j + lji))::(update graphe sbar j pi_j q)
      else (i,pi_i)::(update graphe sbar j pi_j q)    (* on ne modifie pas à i *)
;;


(* Interface init_dist
type : ’a −> ’a list −> (’a * int) list −> (’a * int) list
arg : x = sommet initial des chemins calculés
        sommets (du graphe)
        succ_x = successeurs de x
post : liste des couples (s, valeur de l’arc (x0,s)), cette valeur étant infinie si l’arc n’existe pas *)
let rec init_dist x sommets succ_x = match sommets with
   | [] −> []
   |t::q −> (t, longueur_arc succ_x x t)::(init_dist x q succ_x)
;;


(* Interface pluscourtschemins
type : ’a graphevalue −> ’a −> (’a * int) list
arg : graphe (valué)
        x = sommet de départ
pre : x est un sommet de graphe
post : liste des couples (s,l) où l est la plus petite des longueurs des chemins de x au sommet s.
        Utilise l’algorithme de Dijkstra *)
let pluscourtschemins graphe x =
   let rec aux graphe sbar distances =     (* on n’a pas besoin de x pour continuer *)
     let (j,pi_j) = distmin sbar distances in
       if (pi_j < 0) then distances (* si l’infini est la valeur minimum, on a fini *)
       else
         let sbar’ = retire j sbar in match sbar’ with
            | [] −> distances
            | _ −> aux graphe sbar’ (update graphe sbar’ j pi_j distances)
   in aux graphe (retire x (graphe.sommets)) (init_dist x graphe.sommets (graphe.succ x))
;;

[remya]

Bonjour à tous,
Voici mon premier code en Camllight concernant le traitement d'images numériques. Ce programme calcul le produit de convolution d'une matrice u (image) et d'une matrice h (noyau) la matrice u étant de taille quelconque et la matrice h étant de taille impaire x impaire
Il ne nécéssite ni bibliothèque ni options particulieres.

Il se décompose en trois sous fonctions.

la premiere est la suivante; elle permet de calculer u*h (produit de convolution) au point (x y)

Code :

1
2
3
4
5
6
7
8
9
10
let convol_simpl_imp_imp h u x y = 
  let m = vect_length h and n = vect_length h.(0) in
    let a= ref 0 in     
      for i = -((m-1)/2) to ((m-1)/2) do
        for j = -((n-1)/2) to ((n-1)/2) do
          a := (  !a+  (  (  h.(i + ((m-1)/2)).(j + ((n-1)/2))   )*(u.(x+i).(y+j)) ) )
          done;
            done; 
(!a)
;;

on récupère la taille de h :

Code :

let m = vect_length h and n = vect_length h.(0) in

puis on applique la formule de convolution sur un espace discret (dans le cas simple ou la fonction représenté par u est à support borné.)

Code :

1
2
3
      for i = -((m-1)/2) to ((m-1)/2) do
        for j = -((n-1)/2) to ((n-1)/2) do
          a := (  !a+  (  (  h.(i + ((m-1)/2)).(j + ((n-1)/2))   )*(u.(x+i).(y+j)) ) )

On doit désormait appliquer cette fonction en chaque point de la matrice u; ainsi pour ne pas "déborder" on doit "grossir" la matrice u avant de lui appliquer h.
C'est à cela que sert la fonction suivante:

Code :

1
2
3
4
5
6
7
8
9
10
11
12
13
14
let grossir_imp_imp u h  =

let k = vect_length u and l = vect_length u.(0) in 
let m = vect_length h and n = vect_length h.(0) in 
  let u_sec = make_vect (k+m-1) [|0;0|] in
    for i = 0 to (k+ m -2) do
      u_sec.(i)<-( make_vect (l+n-1) 0) done; 

for i = (m/2) to ((m/2)+k-1) do
  for j = (n/2) to ((n/2)+l-1) do 
    u_sec.(i).(j)<-(u.(i-(m/2)).(j-(n/2)))
  done; 
done;
u_sec ;;

la méthode est la suivante: on récupère la taille de u et celle de h :

Code :

1
2
let k = vect_length u and l = vect_length u.(0) in 
let m = vect_length h and n = vect_length h.(0) in

On crée la matrice de taille suffisante pour que h s'applique en tout points de u :

Code :

1
2
3
  let u_sec = make_vect (k+m-1) [|0;0|] in
    for i = 0 to (k+ m -2) do
      u_sec.(i)<-( make_vect (l+n-1) 0) done;

à se stade u_sec est une matrice pleine de 0 de la taille souhaitée. on place u en son centre.

Code :

1
2
3
4
5
for i = (m/2) to ((m/2)+k-1) do
  for j = (n/2) to ((n/2)+l-1) do 
    u_sec.(i).(j)<-(u.(i-(m/2)).(j-(n/2)))
  done; 
done;

On peut désormais appliquer h en tout points de u :

Code :

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
let convol_imp_imp h u = 
  let k = vect_length u and l = vect_length u.(0) in 
  let m = vect_length h and n = vect_length h.(0) in 

let u_sec = make_vect (k+m-1) [|0;0|] in
    for i = 0 to (k+ m -2) do
      u_sec.(i)<-( make_vect (l+n-1) 0) done; 

  let u_tres = ( grossir_imp_imp u h ) in
    
for i = (m/2) to ((m/2)+k-1) do
  for j = (n/2) to ((n/2)+l-1) do 
        u_sec.(i).(j)<-(convol_simpl_imp_imp h  u_tres i j ) 
      done;
    done;
u_sec ;;

à ce stade :
pour u = [|[|1;1;1|];[|2;2;2|]|] et h = [|[|0;-1;1|]|]
losrqu'on exécute grossir_imp_imp u h on obtient [|[|0; 1; 1; 1; 0|]; [|0; 2; 2; 2; 0|]|]
lorsqu'on exécute convol_imp_imp h u on obtient [|[|0; 0; 0; -1; 0|]; [|0; 0; 0; -2; 0|]|]

On peut cependant faire la même fonction qui rend le même résultat sans ajouter les zeros sur les contours:

Code :

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
let convol_nodark_imp_imp h u = 
 let k = vect_length u and l = vect_length u.(0) in 
  let m = vect_length h and n = vect_length h.(0) in

    let u_sec = make_vect k [|0;0|] in
      for i = 0 to (k-1) do
        u_sec.(i)<-(make_vect (l) 0) done;

    let u_tres = convol_imp_imp h u in 

      for i = (m/2) to ((m/2)+k-1) do
      for j = (n/2) to ((n/2)+l-1) do 
        u_sec.(i-(m/2)).(j-(n/2))<-u_tres.(i).(j) 
      done;
      done; 
u_sec ;;

il suffit en effet de recopier le résultat "utile" (ie le centre) de "convol_imp_imp h u " dans une matrice de la taille de u ... (il faut seulement décaler les indices dans le for.)


Voilà peut-être que ça servira à quelqu'un un jour ^^
Rémy.

[InOCamlWeTrust]

Indente le code s'il te plaît et pense à la balise .

[SpiceGuid]

Mes codes sources sont tous en Objective Caml 3.08 ou plus.

Je commence par quelques fonctions utilitaires pour les listes:


make génère une liste de n éléments à partir de l'élément a et en appliquant n-1 fois la fonction u:

Code :

1
2
3
let rec make u a n =
  if n=1 then a
  else let b=make u a (n-1) in u n b::b;;

exemple, générer les 10 premiers entiers:

Code :

make (fun _ l -> List.hd l + 1) [0] 10;;

autre exemple qui génére les 10 premiers nombres de fibonacci:

Code :

make (fun _ l -> List.nth l 0 + List.nth l 1) [1;0] 10;;

un dernier exemple qui génére les 10 premiers factoriels:

Code :

make (fun n l -> n * List.hd l) [1;0] 10;;

La fonction pair_list génère toutes les paires possibles formées à partir d'une liste l:

Code :

1
2
3
4
let rec pair_list l =
  match l with
  | []  -> []
  | a::l -> (List.map (fun b -> a,b) l) @ pair_list l;;

Enfin la fonction exists_commutative teste l'existence de deux éléments de la liste l qui vérifient le prédicat 2-aire commutatif cond:

Code :

1
2
3
4
5
6
let exists_commutative cond l =
  let rec loop l = 
    match l with
    | []   -> false
    | a::l -> (List.exists (cond a) l) or loop l   
  in loop l;;

[SpiceGuid]

Je continue avec un algorithme rapide de calcul de PI en goutte-à-goutte, toujours en Objective-Caml.

Code :

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
let add  = Big_int.add_big_int
and sub  = Big_int.sub_big_int
and succ = Big_int.succ_big_int
and pred = Big_int.pred_big_int
and mult = Big_int.mult_big_int
and div  = Big_int.div_big_int
and add_int  = Big_int.add_int_big_int
and mult_int = Big_int.mult_int_big_int
and big_int  = Big_int.big_int_of_int
and int_of   = Big_int.int_of_big_int
;;

let pi () =
  let rec g q r t i =
    let i3 = mult_int 3 i in
    let u = mult_int 3 (mult (succ i3) (add_int 2 i3))
    and y = int_of (div (add (mult q (add_int (-12) (mult_int 27 i))) (mult_int 5 r)) (mult_int 5 t)) 
    in begin
      print_int y;
      flush stdout;
      g
      (mult_int 10 (mult q (mult i (pred (add i i)))))
      (mult_int 10 (mult u (sub (add (mult q (add_int (-2) (mult_int 5 i))) r) (mult_int y t))))
      (mult t u)
      (succ i);
      ()
    end
  in g (big_int 1) (big_int 180) (big_int 60) (big_int 2);; 

pi ();;

À compiler avec:

Code :

ocamlopt -unsafe -o pi.exe nums.cmxa pi.ml

Sinon dans l'interpréteur il vous faudra d'abord entrer cette commande:

Code :

#load "nums.cma";;

Les plus connaisseurs pourront encore accélérer l'algorithme à l'aide de la bibliothèque numerix de Michel Quercia.

[SpiceGuid]

Et mainenant des routines pour les inventaires.

Le type inventaire:

Code :

1
2
type 'a inventory = ('a * int) list;;
type 'a t = 'a inventory;;

Un inventaire est une liste énumérative qui dit par exemple "j'ai 3 livres et deux tasses à café".

Code :

([("livre",3);("tasse",2)] : string inventory);;

Le test de validité d'un inventaire, en particulier un inventaire ne peut pas contenir un négatif ou nul, un inventaire valide est également trié par ordre croissant:

Code :

1
2
3
4
5
6
7
8
let valid (a: 'a inventory) =
  let rec helper prev l =
    match l with
    | [] -> true
    | (p,n)::t -> if (n > 0) && (p > prev) then helper p t else false
  in match a with
  | [] -> true
  | (p,n)::t ->  if n > 0 then helper p t else false;;

Le constructeur d'inventaire à partir d'un liste l:

Code :

1
2
3
4
let make l =
  let sorted = List.sort (fun (p1,_) (p2,_) -> compare p1 p2) l in
  if valid sorted then (sorted : 'a inventory)
  else failwith "Inventory.make";;

La liste retounée est garantie valide.

Maintenant les opérations élémentaires.

L'union et l'intersection de deux inventaires:

Code :

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
let union (a: 'a inventory) (b: 'a inventory) =
  let rec helper a b u =
    match a,b with
    | [],_ -> List.rev_append u b
    | _,[] -> List.rev_append u a
    | (pa,qa as ha)::ta,(pb,qb as hb)::tb ->
        if pa < pb then helper ta b (ha::u)
        else if pa > pb then helper a tb (hb::u)
        else helper ta tb ((pa,qa+qb)::u)
  in (helper a b []: 'a inventory);;

let intersection (a: 'a inventory) (b: 'a inventory) =
  let rec helper a b c =
    match a,b with
    | [],_ -> List.rev c
    | _,[] -> List.rev c
    | (pa,qa)::ta,(pb,qb)::tb ->
        if pa < pb then helper ta b c
        else if pa > pb then helper a tb c
        else helper ta tb ((pa,min qa qb)::c)
  in (helper a b []: 'a inventory);;

La différence de deux inventaires, qui renvoie à la fois a-b et b-a, et la soustraction qui elle renvoie seulement a-b:

Code :

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
let difference (a: 'a inventory) (b: 'a inventory) =
  let rec helper a b r x =
    match a,b with
    | [],_ -> List.rev r,List.rev_append x b
    | _,[] -> List.rev_append r a,List.rev x
    | (pa,qa as ha)::ta,(pb,qb as hb)::tb ->
        if pa < pb then
          helper ta b (ha::r) x
        else if pa > pb then
          helper a tb r (hb::x)
        else if qa < qb then
          helper ta tb r ((pa,qb-qa)::x)
        else if qa > qb then
          helper ta tb ((pa,qa-qb)::r) x
        else
          helper ta tb r x
  in (helper a b [] []: 'a inventory * 'a inventory);;

let minus (a: 'a inventory) (b: 'a inventory) =
  let rec helper a b r =
    match a,b with
    | [],_ -> List.rev r
    | _,[] -> List.rev_append r a
    | (pa,qa as ha)::ta,(pb,qb as hb)::tb ->
        if pa < pb then
          helper ta b (ha::r)
        else if pa > pb then
          helper a tb r
        else if qa < qb then
          helper ta tb r
        else if qa > qb then
          helper ta tb ((pa,qa-qb)::r)
        else
          helper ta tb r
  in (helper a b []: 'a inventory);;

Le test d'inclusion et le test d'intersection pour deux inventaires:

Code :

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
let rec includes (a: 'a inventory) (b: 'a inventory) =
  match a,b with
  | [],_ -> b=[]
  | _,[] -> true
  | (pa,qa)::ta,(pb,qb)::tb ->
      if pa < pb then
        includes ta b
      else if pa > pb then
        false
      else if qa >= qb then
        includes ta tb
      else
        false;;

let rec intersects (a: 'a inventory) (b: 'a inventory) =
  match a,b with
  | [],_ -> false
  | _,[] -> false
  | (pa,qa)::ta,(pb,qb)::tb ->
      if pa < pb then
        intersects ta b
      else if pa > pb then
        intersects a tb
      else
        true;;

[SpiceGuid]

La suite des fonctions sur les inventaires.
Ces fonctions paraissent beaucoup moins naturelles car ce sont des utilitaires pour la "grosse" fonction collect tout à la fin.

Multiplier un inventaire par un entier n:

Code :

1
2
3
let scale n (a: 'a inventory) =
  assert(n > 0);
  (List.map (fun (p,q) -> (p,n*q)) a : 'a inventory);;

Diviser un inventaire par un autre inventaire, renvoie le nombre n de fois que a inclut b ainsi que l'inventaire restant après avoir retranché n x b:

Code :

1
2
3
4
5
6
7
let reduce (a: 'a inventory) (b: 'a inventory) =
  let rec helper n a =
    if includes a b then
      helper (n+1) (minus a b)
    else
      n,a
  in helper 0 a;;

Le nombre total d'articles dans un inventaire:

Code :

1
2
3
4
5
6
let length (a: 'a inventory) =
  let rec helper a n =
    match a with
    | [] -> n
    | (_,q)::t -> helper t (n+q)
  in helper a 0;;

Une fonction qui évalue l'écart entre deux inventaires:

Code :

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
let distance (a: 'a inventory) (b: 'a inventory) =
  let rec helper a b c x =
    match a,b with
    | _,[] -> c,x
    | [],_ -> c,x + length b
    | (pa,qa)::ta,(pb,qb)::tb ->
        if pa < pb then
          helper ta b c x
        else if pa > pb then
          helper a tb c (x+qb)
        else if qa <= qb then
          helper ta tb (c+qa) (x+qb-qa)
        else
          helper ta tb (c+qb) (x+qa-qb)
    in helper a b 0 0;;

Une fonction qui dit lequel de a ou de b est plus proche de l'inventaire wanted:

Code :

1
2
3
4
5
6
7
8
let discriminate (wanted: 'a inventory) a b =
  let ca,xa = distance wanted a in
  let cb,xb = distance wanted b in
  let cb_xa = cb * xa in
  let ca_xb = ca * xb in
  if cb_xa < ca_xb then 1
  else if cb_xa > ca_xb then -1
  else 0;;

Deux types supplémentaires, un catalog est une liste d'inventaires, un order est le bon de commande d'un inventaire:

Code :

1
2
type ('a,'b) catalog = ('a * 'b inventory) list;;
type ('a,'b) order = {items: 'a inventory; missing: 'b inventory; extras: 'b inventory};;

Comme un inventaire, un catalog a son test de validité:

Code :

1
2
let valid_catalog (cat: ('a,'b) catalog) =
  List.for_all (fun (_,inv) -> valid inv) cat;;

La fonction supercede n'est qu'un utilitaire pour la fonction collect qui suit

Code :

1
2
3
4
5
6
7
8
let rec supercede k_max inv_max (wanted: 'b inventory) (cat: ('a,'b) catalog) =
  match cat with
  | [] -> k_max,inv_max
  | (k,inv)::l ->
    if discriminate wanted inv inv_max > 0 then
      supercede k inv wanted l
    else
      supercede k_max inv_max wanted l;;

La voilà cette fonction collect, elle vise à s'approcher de l'inventaire wanted à l'aide du catalog cat, c'est-à-dire qu'elle renvoie l'order le mieux susceptible de satisfaire l'inventaire wanted voulu:

Code :

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
let collect (wanted: 'b inventory) (cat: ('a,'b) catalog) margin =
  assert(valid_catalog cat);
  assert(valid wanted);
  assert(0 <= margin && margin < length wanted);
  let rec helper wanted cat keys extras =
    if length wanted <= margin then
      {items=keys;missing=wanted;extras=extras}
    else
    let passed =
      List.filter (fun (_,inv) -> intersects wanted inv) cat
    in match passed with
       | [] -> failwith "Inventory.collect"
       | (k,inv)::l ->
         let k_max,inv_max = supercede k inv wanted l in
         let rest,more = difference wanted inv_max in
         helper rest passed (union keys [k_max,1]) (union more extras)
  in helper wanted cat [] [];;

Exemple pratique: à l'aide d'une base de données fonctionnelle (le catalog de toutes les boîtes lego référencées) la fonction collect renvoie les 8 à 10 boîtes lego qui typiquement fourniraient 70% à 80% des éléments nécessaires pour construire un modèle original de 1000 briques.

[SpiceGuid]

Voici quelques fonctions de manipulation de motifs.

Le type motif et son afficheur:

Code :

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
type pattern_val =
   | Pattern of string * pattern_val list
   | Var of string
   | Int of int
;;

let rec print_pattern pat =
  match pat with
  | Pattern(op,sons) ->
      if sons=[] then
        print_string op
      else begin
        print_string op; print_char '(';
        print_pattern (List.hd sons);
        List.iter (fun x -> print_string ", "; print_pattern x) (List.tl sons);
        print_char ')'
      end
  | Var s -> print_string s
  | Int n -> print_int n
;;

La fonction construct réalise l'instanciation de motif, les variables du motif pat sont remplacées par leur valeur associée dans l'environnement env:

Code :

1
2
3
4
5
6
7
let rec construct env pat =
  let rec loop pat = 
  match pat with
  | Pattern(name,sons) -> Pattern(name, List.map loop sons)
  | Var s -> (try List.assoc s env with Not_found -> Var s)
  | _ -> pat
  in loop pat;;

La fonction extend augmente l'environnement env par l'association de la variable var à la valeur pat:

Code :

1
2
3
4
5
6
7
let extend env (var,pat) =
  try
    let pat1=List.assoc var env in
    if pat=pat1 then env else failwith "extend" 
  with
  | Not_found -> (var,pat)::env
;;

La fonction occurs réalise le test d'occurrence de la variable var dans le motif pat:

Code :

1
2
3
4
5
6
7
let occurs var pat =
  let rec loop pat =
  match pat with
  | Pattern(_,sons) -> List.exists loop sons
  | Var s -> s = var
  | _ -> false
  in loop pat;;

La fonction unify réalise l'unification de deux motifs pat1 et pat2:

Code :

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
let compose env2 env1 =
  (List.map (fun (var,pat) -> (var,construct env2 pat)) env1) @ env2
;;

let rec unify pat1 pat2 =
  match pat1,pat2 with
  | pat1, pat2 when pat1 = pat2 -> []
  | Var s,v2   ->  if occurs s v2 then failwith "unify"
                   else [s,v2]
  | v1,Var s   ->  if occurs s v1 then failwith "unify"
                   else [s,v1]
  | Pattern(op1,sons1),Pattern(op2,sons2) ->
      if op1 = op2 then
        try
          let compose_unify env t1 t2 =
              compose (unify (construct env t1) (construct env t2)) env
          in List.fold_left2 compose_unify [] sons1 sons2
        with
        | Invalid_argument "fold_left2" -> failwith "unify"
      else failwith "unify"
  | pat1, pat2 -> failwith "unify"
;;

La fonction exists_commutative a déjà été décrite plus haut, elle teste l'existence de deux éléments de la liste l qui vérifient le prédicat 2-aire commutatif cond:

Code :

1
2
3
4
5
6
let exists_commutative cond l =
  let rec loop l = 
    match l with
    | []   -> false
    | a::l -> (List.exists (cond a) l) or loop l   
  in loop l;;

Un filtrage est une liste de motifs.
La fonction is_determinist réalise un test de déterminisme sur un filtrage, un filtrage est dit déterministe si aucuns de ses motifs ne sont unifiables deux-à-deux, dans un filtrage déterministe il n'y a toujours que zéro (le filtrage n'est pas forcément complet) ou un seul choix possible, jamais plusieurs:

Code :

1
2
3
4
5
6
7
8
let can_unify (pat1,_) (pat2,_) =
  try
    let _ = unify pat1 pat2 in true
  with
  | Failure "unify" -> false;;

let is_determinist pattern_list =
  not (exists_commutative can_unify pattern_list);;

[SpiceGuid]

Ma bibliothèque ocaml pour l'arithmétique des grands nombres.
L'implémentation utilise des tableaux d'entiers et supporte la base 10000 en 32 bits.
J'ai massivement utilisé les assertions pour débugger plus vite.

Le type big_int et son constructeur big_of_int:

Code :

1
2
3
4
5
6
7
8
9
10
11
12
type big_int = int array;;

let base = 10;;

let zero_big = ([|0|]: big_int);;

let unit_big = ([|1|]: big_int);;

let big_of_int n =
  assert (0 <= n & n < base * base);
  if n < base then ([|n|]: big_int)
  else ([|n / base;n mod base|]: big_int);;

La function add_big réalise l'addition destructive des grands entiers a et b (a est écrasé):

Code :

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
let add_big (a: big_int) (b: big_int) =
  assert (Array.length a >= Array.length b);
  let result = ref a
  and carry  = ref 0
  and i = ref (Array.length a - 1)
  and j = ref (Array.length b - 1)
  in begin
    while !j >= 0 do
      let d = a.(!i) + b.(!j) + !carry
      in if d < base then begin
        carry := 0; a.(!i) <- d 
      end else begin
        carry := 1; a.(!i) <- d - base
      end;
      decr i; decr j; 
    done;
    while !carry > 0 do
      if !i >= 0 then begin
        let d = a.(!i) + !carry
        in if d < base then begin
          carry := 0; a.(!i) <- d 
        end else begin
          a.(!i) <- d - base
        end;
        decr i;
      end else begin
        result := Array.make (Array.length a + 1) 0;
        Array.blit a 0 !result 1 (Array.length a);
        !result.(0) <- 1; carry := 0;
      end;
    done;
    !result
  end;;

La function sum_big réalise l'addition non destructive des grands entiers a et b:

Code :

1
2
3
4
5
let sum_big (a: big_int) (b: big_int) =
  if Array.length a >= Array.length b then
    add_big (Array.copy a) b
  else 
    add_big (Array.copy b) a;;

La function compare_big compare deux grands entiers a et b:

Code :

1
2
3
4
5
6
7
8
9
10
11
12
13
let compare_big (a: big_int) (b: big_int) =
  if Array.length a < Array.length b then -1
  else if Array.length a > Array.length b then 1
  else
    let i = ref 0 in
    begin
      while !i < Array.length a & a.(!i) = b.(!i) do
        incr i;
      done;
      if !i = Array.length a then 0
      else if a.(!i) > b.(!i) then 1
      else -1
    end;;

Les functions min_big et max_big renvoient le minimum et le maximum de a et b:

Code :

1
2
3
4
5
let min_big (a: big_int) (b: big_int) =
  if compare_big a b < 0 then a else b;;

let max_big (a: big_int) (b: big_int) =
  if compare_big a b > 0 then a else b;;

La function sub_big réalise la soustraction destructive des grands entiers a et b (a est écrasé):

Code :

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
let sub_big (a: big_int) (b: big_int) =
  assert (compare_big a b >= 0);
  let result = ref a
  and carry  = ref 0
  and i = ref (Array.length a - 1)
  and j = ref (Array.length b - 1)
  in begin
    while !j >= 0 do
      let d = a.(!i) - b.(!j) - !carry
      in if d >= 0 then begin
        carry := 0; a.(!i) <- d 
      end else begin
        carry := 1; a.(!i) <- d + base
      end;
      decr i; decr j; 
    done;
    while !carry > 0 do
      let d = a.(!i) - !carry
      in if d >= 0 then begin
        carry := 0; a.(!i) <- d 
      end else begin
        a.(!i) <- d + base
      end;
      decr i;
    done;
    if !i < 0 then begin
      i := 0; j := Array.length a - 1;
      while a.(!i) = 0 & !i < !j  do incr i; done;
      if !i >= 0 then result := Array.sub a !i (Array.length a - !i);
    end;  
    !result
  end;;

La function sub_big réalise la soustraction non destructive des grands entiers a et b:

Code :

1
2
3
let diff_big (a: big_int) (b: big_int) =
  assert (compare_big a b >= 0);
  sub_big (Array.copy a) b;;

La function shift_big réalise un décalage à gauche:

Code :

1
2
3
4
5
6
7
8
9
let shift_big (a: big_int) n =
  assert (n >= 0);
  if a = zero_big then zero_big
  else
    let result: big_int = Array.make (Array.length a + n) 0
    in begin
      Array.blit a 0 result 0 (Array.length a);
      result
    end;;

La function scale_up_big réalise le produit par un nombre n < base :

Code :

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
let scale_up_big (a: big_int) n =
  assert (0 <= n & n < base);
  if n = 0 then zero_big
  else 
    let accu = ref 0 
    and carry = ref 0
    and result: big_int = Array.make (Array.length a + 1) 0
    in begin
      for i = (Array.length a) downto 1 do
        accu := a.(i-1) * n + !carry; 
        result.(i) <- !accu mod base; carry := !accu/base
      done;
      result.(0) <- !carry;
      if !carry = 0 then
        (Array.sub result 1 (Array.length a): big_int)
      else
        result  
    end;;

La multiplication ordinaire:

Code :

1
2
3
4
5
6
7
8
9
10
11
let long_mult_big (a: big_int) (b: big_int) =
  let i = ref 0
  and j = ref (Array.length b-1) in
  let result = ref (shift_big (scale_up_big a b.(!i)) !j) 
  in begin
    while !j > 0 do
      incr i; decr j;
      result := add_big !result (shift_big (scale_up_big a b.(!i)) !j)
    done;  
    !result
  end;;

La multiplication rapide à la Karatsuba:

Code :

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
let array_sub (a: big_int) start len = 
  let i = ref start and n = ref len in
  while a.(!i)=0 && !n > 1 do
    incr i; decr n;
  done;
  (Array.sub a !i !n : big_int);;  

let karatsuba_threshold = 20;;

let rec mult_big (a: big_int) (b: big_int) =
  if Array.length a < Array.length b then
    mult_big b a
  else if Array.length b < karatsuba_threshold then
    long_mult_big a b
  else 
    karatsuba_big a b
and karatsuba_big (p: big_int) (q: big_int) =
  assert (Array.length p >= Array.length q);
  let len_p = Array.length p  in
  let len_q = Array.length q  in
  let     n = len_p / 2       in
  let     a = array_sub p 0 (len_p - n)  in
  let     b = array_sub p (len_p - n) n  in
  if len_q > n then  
    let      c = array_sub q 0 (len_q - n)  in
    let      d = array_sub q (len_q - n) n  in
    let     ac = mult_big a c  in
    let     bd = mult_big b d  in
    let  ad_bc = sub_big (sub_big (mult_big (sum_big a b) (sum_big c d)) ac) bd
    in
    add_big (add_big (shift_big ac (2*n)) (shift_big ad_bc n)) bd
  else  
    let     aq = mult_big a q in
    let     bq = mult_big b q in
    add_big (shift_big aq n) bq
;;

Le carré et la puissance:

Code :

1
2
3
4
5
6
7
8
9
10
11
let square_big (a: big_int) = mult_big a a;; 

let rec power_big (a: big_int) n =
  assert (n >= 0);
  if n=0 then unit_big
  else if n=1 then a
  else
    let b = power_big a (n/2) in
    if (n mod 2 = 0) then mult_big b b 
    else mult_big (mult_big b b) a
;;

La function scale_down_big réalise la division par un nombre n < base² :

Code :

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
let scale_down_big (a: big_int) n =
  assert (0 < n & n < base * base);
  let accu = ref 0 
  and carry = ref 0
  and result: big_int = Array.copy a
  in begin
    for i = 0 to (Array.length a - 1) do
      accu := a.(i) + !carry * base; 
      result.(i) <- !accu/n; carry := !accu mod n
    done;
    if (result.(0) = 0) && (Array.length a > 1) then
      (Array.sub result 1 (Array.length a - 1): big_int),!carry
    else
      result,!carry  
  end;;

La division rapide à la Burnikel-Ziegler:

Code :

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
let rec burnikel_ziegler_big (a: big_int) (b: big_int) =
  if  Array.length b <= 2 then
    let b2 = if Array.length b < 2 then b.(0) else b.(0)*base + b.(1) in 
    let q,r = scale_down_big a b2
    in  q,big_of_int r
  else    
    let   len_a = Array.length a               in
    let   len_b = Array.length b               in
    let       n = (len_b - 1) / 2              in
    let      a0 = array_sub a (len_a - n) n    in
    let      a1 = array_sub a 0 (len_a - n)    in
    if compare_big a1 b >= 0 then
      let q1,r1 = burnikel_ziegler_big a1 b    in
      let q0,r0 = burnikel_ziegler_big (add_big (shift_big r1 n) a0) b
      in  add_big (shift_big q1 n) q0,r0
    else
      let    b0 = array_sub b (len_b - n) n    in
      let    b1 = array_sub b 0 (len_b - n)    in
      let q1,r1 = burnikel_ziegler_big a1 b1   in
      let a0_r1 = add_big (shift_big r1 n) a0  in
      let b0_q1 = mult_big b0 q1               in
      if compare_big a0_r1 b0_q1 >= 0 then
        let plus_x = sub_big a0_r1 b0_q1
        in  q1,plus_x
      else
        let minus_x = sub_big b0_q1 a0_r1 in
        sub_big q1 unit_big, sub_big b minus_x;;


let quomod_big (a: big_int) (b: big_int) =
  if b = zero_big then raise Division_by_zero
  else if compare_big a b < 0 then zero_big,a
  else burnikel_ziegler_big a b;;

Le nombre de permutations de p éléments parmi n:

Code :

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
let rec permutation_big n p =
  assert(0 <= p & p <= n);
  let rec helper a b =
    if a = b then
      big_of_int a
    else if a + 1 = b then
      big_of_int (a * b)
    else 
      let ab2 = (a + b) / 2 in
      mult_big (helper a ab2) (helper (ab2+1) b)
  in if p = 0 then unit_big else helper (n - p + 1) n;;   

let factorial_big n =
  assert(n >= 0);
  permutation_big n n;;

Les coefficients du binôme:

Code :

1
2
3
let binomial_big n p =
  assert(0 <= p & p <= n);
  div_big (permutation_big n p) (factorial_big p);;

[millie]

En tout cas. Je te remercie pour toutes les sources que tu nous proposes

[SpiceGuid]

Erratum:

Je ne suis plus très certain de ma division rapide Burnikel-Ziegler, elle fait parfois planter l'interpréteur OCamlWin sans que je sache pourquoi, les fonctions qui l'utilisent peuvent donc également être affectées (quomod_big et binomial_big).

[SpiceGuid]

Un petit dérivateur formel qui simplifie raisonnablement son résultat.

Le type fonction d'une variable:

Code :

1
2
3
4
5
6
7
8
9
10
11
type function_x = X
     | R of float
     | Sin of function_x
     | Cos of function_x
     | Tan of function_x
     | Log of function_x
     | Exp of function_x
     | Power of function_x * float
     | Add of function_x * function_x
     | Mul of function_x * function_x
;;

Dans ce type vous remarquerez notamment l'absence de la soustraction et de la division, cela s'explique par le fait que:

• la soustraction est redondante avec la multiplication par -1.
• la division est redondante avec la puissance -1.

Le fait d'éliminer ces redondances facilite grandement le travail de simplification d'écriture, il n'y a plus qu'à s'occuper de la factorisation (élémentaire), c'est ce que font les lignes suivantes:

Code :

1
2
3
4
5
6
7
8
9
10
11
12
13
let multiply p = match p with
  | R(1.),u -> u
  | u,v -> Mul(u,v)
;;
  
let product p = match p with
  | R(a),Mul(R(b),u) -> multiply(R(a*.b),u)
  | Mul(R(a),u),R(b) -> multiply(R(a*.b),u)
  | Mul(R(a),u),Mul(R(b),v) -> multiply(R(a*.b),Mul(u,v))
  | u,Mul(R(k),v) -> Mul(R(k),Mul(u,v))
  | Mul(R(k),u),v -> Mul(R(k),Mul(u,v))
  | u,v -> multiply(u,v)
;;

Le dérivateur lui-même:

Code :

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
let rec deriv f =
  match f with
  | X -> R(1.)
  | R(k) -> R(0.)
  | Add(u,R(k)) -> deriv(u)
  | Add(u,v)    -> Add(deriv(u),deriv(v))
  | Mul(R(k),X) -> R(k)
  | Mul(R(k),u) -> product(R(k),deriv(u))
  | Mul(u,v)    -> Add(product(deriv(u),v),product(u,deriv(v)))
  | Sin(u) -> product(deriv(u),Cos(u))
  | Cos(u) -> product(R(-1.),product(deriv(u),Sin(u)))
  | Tan(u) -> product(deriv(u),Power(Cos(u),-2.))
  | Log(u) -> product(deriv(u),Power(u,-1.))
  | Exp(u) -> product(deriv(u),Exp(u))
  | Power(u,2.) -> product(R(2.),product(deriv(u),u))
  | Power(u,b)  -> product(R(b),product(deriv(u),Power(u,b-.1.)))
;;

[SpiceGuid]

Une petite fonctionnelle pour fusionner les listes triées:

Code :

1
2
3
4
5
6
7
8
9
10
11
let map_merge cmp f a b =
  let rec loop a b u =
    match a,b with 
    | [],_ -> List.rev_append u b
    | _,[] -> List.rev_append u a
    | ha::ta,hb::tb ->
        let c = cmp ha hb in
        if c < 0 then loop ta b (ha::u)
        else if c > 0 then loop a tb (hb::u)
        else loop ta tb (f ha hb::u)
  in loop a b [];;

Fusionner deux int list triées:

Code :

1
2
let merge_int_list = map_merge (-) (fun a b -> b);;
merge_int_list [1;3;5] [2;4;6];;

Fusionner deux (string * int) list triées:

Code :

1
2
3
4
5
6
7
let merge_inventory =
  map_merge
    (fun (pa,_) (pb,_) -> String.compare pa pb)
    (fun (pa,qa) (pb,qb) -> pa,qa+qb);;
merge_inventory
  ["book",5;"chair",2;"paper",20]
  ["book",2;"paper",50;"pen",1];;

Les résultats respectifs:

Code :

1
2
[1; 2; 3; 4; 5; 6]
[("book", 7); ("chair", 2); ("paper", 70); ("pen", 1)]

[SpiceGuid]

Voici la version corrigée de scale_down_big, c'était cette fonction qui était responsable de l'erreur dans la division Burnikel-Ziegler:

Code :

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
let scale_down_big (a: big_int) n =
  assert (0 < n & n < base * base);
  let lastr = Array.length a - 1 in
  let accu  = ref 0 
  and carry = ref 0
  and result: big_int = Array.copy a
  in begin
    for i = 0 to lastr do
      accu := a.(i) + !carry * base; 
      result.(i) <- !accu/n; carry := !accu mod n
    done;
    if (result.(0) = 0) && (lastr > 0) then
      (array_sub result 1 lastr: big_int),!carry
    else
      result,!carry
  end;;

Dans la version erronée j'avais mis Array.sub au lieu de array_sub.

[gasche]

Voici une ré-écriture du code de dérivation en utilisant des facilités syntaxiques. Je n'ai (théoriquement) absolument rien changé au comportement du code.

Code :

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
let (+) a b = Add(a,b)
and ( ^ ) a b = Power(a,b)
and ( * ) a b =  
  let ( * ) a b = Mul(a,b) in
  let ( *! ) a b = if a = R(1.) then b else a * b in
  match a, b with
  | R(a), Mul(R(b),u) | Mul(R(a),u), R(b) -> R(a*.b) *! u
  | Mul(R(a),u), Mul(R(b),v) -> R(a*.b) *! (u * v)
  | u, Mul(R(k),v) | Mul(R(k),u),v -> R(k) * (u * v)
  | u, v -> u *! v

let rec deriv f =
  match f with
  | X -> R(1.)
  | R(k) -> R(0.)
  | Add(u,R(k)) -> !u
  | Add(u,v)    -> !u + !v
  | Mul(R(k),X) -> R(k)
  | Mul(R(k),u) -> R(k) * !u
  | Mul(u,v)    -> !u * v + u * !v
  | Sin(u) -> !u * Cos(u)
  | Cos(u) -> R(-1.) * (!u * Sin(u))
  | Tan(u) -> !u * (Cos(u) ^ -2.)
  | Log(u) -> !u * (u ^ -1.)
  | Exp(u) -> !u * Exp(u)
  | Power(u,2.) -> R(2.) * (!u * u)
  | Power(u,b)  -> R(b) * (!u * (u ^ (b -. 1.)))
and ( ! ) f = deriv f

Après, je ne sais pas si vous trouvez ça plus lisible (redéfinir les opérateurs courant peut aussi provoquer une certaine confusion), c'est un peu une question de goût.

Les parenthèsages du style a * (b * c) pourraient être évités, mais il changerait le comportement actuel du code qui donne une priorité à droite à la multiplication, et je ne suis pas sûr de son interaction avec le simplicateur.

On pourrait améliorer les patterns en utilisant la syntaxe révisée, qui utilise une jolie syntaxe curryfiée pour les constructeurs et les types, et je pensque que l'on pourrait même utiliser des pseudos-macros de pattern avec un support camlp4 plus lourd (si LLB passe par ici, il va faire de la propagande ).

[SpiceGuid]

Camlp4 c'est carnaval.

Avec SpiceGuid les constructeurs ils ont le poil qui brille, et le premier qui commence à paresser ou à curryfier au lieu de construire il se prend un coup de fouet entre les homoplates, nourris à l'ancienne, rien qu'avec des tuples, miam miam les tuples c'est bon mangez en et vous aurez de belles dents.

[SpiceGuid]

Il manquait à ce fil de discussion une vraie fonctionnelle, qui renvoie une fonction utile et néanmoins plus tordue que son argument. Voilà qui est réparé avec lexicographical, un catamorphisme de la fonction compare:

Code :

1
2
3
4
5
6
7
8
9
10
11
12
13
# let lexicographical cmp =
  let rec loop l1 l2 =
    match l1,l2 with
    | [],[] -> 0
    | [],_ -> -1
    | _,[] ->  1
    | a::t1,b::t2 ->
        let r = cmp a b in
        if r = 0 then loop t1 t2
        else r
  in loop;;
val lexicographical : ('a -> 'b -> int) -> 'a list -> 'b list -> int = <fun>

Dans ma tête le type était:

Code :

('a -> 'a -> int) -> ('a list -> 'a list -> int)

Mais OCaml n'infère pas toujours exactement le type qu'on a en tête (parce qu'on a une intention que le code ne capture pas), en particulier il n'est vraiment pas doué pour placer des parenthèses à droite des flèches.

Explication:

Code :

1
2
3
4
5
6
7
8
9
10
11
12
13
# let lexicographical cmp l1 l2 =
  let rec loop l1 l2 =
    match l1,l2 with
    | [],[] -> 0
    | [],_ -> -1
    | _,[] ->  1
    | a::t1,b::t2 ->
        let r = cmp a b in
        if r = 0 then loop t1 t2
        else r
  in loop l1 l2;;
val lexicographical : ('a -> 'b -> int) -> 'a list -> 'b list -> int = <fun>

Pure spéculation: à mon avis à une certaine étape il effectue cette éta-expansion et c'est là que mes parenthèses se perdent.

[Jedai]

Envoyé par SpiceGuid

Dans ma tête le type était:

Code :

('a -> 'a -> int) -> ('a list -> 'a list -> int)

Mais OCaml n'infère pas toujours exactement le type qu'on a en tête (parce qu'on a une intention que le code ne capture pas), en particulier il n'est vraiment pas doué pour placer des parenthèses à droite des flèches.

Pourquoi il serait "doué" pour ça ? Il n'y a aucune raison qu'il en place, vu que la flèche est associative à droite, les parenthèses sont donc purement esthétiques.

--
Jedaï

[SpiceGuid]

Cela serait sympathique si on pouvait contrôler cette esthétique, exemples:

La version qui explicite totalement l'associativité à droite de la flèche (en explicitant l'associativité à gauche de l'application):

Code :

1
2
3
4
5
# let lexicographical (cmp: 'a -> 'a -> int ) l1 l2 =
  ...
  in ((loop l1) l2);;
val lexicographical : ('a -> 'a -> int) -> ('a list -> ('a list -> int)) = <fun>

La version que je voudrais:

Code :

1
2
3
4
5
# let lexicographical (cmp: 'a -> 'a -> int ) =
  ...
  in (loop);;
val lexicographical : ('a -> 'a -> int) -> ('a list -> 'a list -> int) = <fun>