L'approche qualité avec OCaml

Damien Guichard

Dans ce tutoriel nous allons aborder les concepts du paradigme fonctionnel et les situer dans le cadre plus large d'une démarche méthodologique qui vise à atteindre la qualité totale au plus tôt. Dans son but cette démarche s'oppose à la tendance naturelle qui repousse les difficultés à plus tard, au mieux lors du débogage, au pire lors du test qualité, ou pire encore, lors de l'utilisation. Nous illustrons par de nombreux exemples comment le paradigme fonctionnel et l'approche qualité coopèrent à améliorer la confiance du programmeur.

- Titre : L'approche qualité avec OCaml

- Auteur : Damien Guichard

- Parution : 5 mars 2008

- Mise à jour : 11 janvier 2013

- Licence : Les sources présentées sur cette page sont libres de droits et vous pouvez les utiliser à votre convenance. Par contre, la page de présentation constitue une œuvre intellectuelle protégée par les droits d'auteur. Copyright ® 2013 Damien Guichard. Aucune reproduction, même partielle, ne peut être faite de ce site et de l'ensemble de son contenu : textes, documents, images, etc. sans l'autorisation expresse de l'auteur. Sinon vous encourez selon la loi jusqu'à trois ans de prison et jusqu'à 300 000 € de dommages et intérêts.

Sommaire

- I. OCaml

- II. Partie I

- II-A. 1. L'approche qualité

- II-B. 2. Programmation et composants

- II-C. 3. Programmation et langage

- II-D. 4. Installation d'Objective Caml

- III. Partie II

- III-A. La programmation fonctionnelle

- III-A-1. 5. Expressions immédiates

- III-A-2. 6. Fonctions et application

- III-A-3. 7. Déclarations de variables

- III-A-4. 8. Déclarations et récursion

- III-A-5. 9. Déclarations de fonctions

- III-A-6. 10. Récursion et accumulation

- III-A-7. 11. Déclarations locales

- III-A-8. 12. Fonctions et assertions

- III-A-9. 13. Les types énumérés

- III-A-10. 14. Le filtrage

- III-A-11. 15. Les listes

- III-A-12. 16. Les fonctions sur les listes

- III-A-13. 17. Le polymorphisme paramétrique

- III-A-14. 18. Les couples

- III-A-15. 19. Les huit reines

- III-A-16. 20. Le tri fusion

- III-A-17. 21. Les modules

- III-A-18. 22. Le traitement des erreurs

- III-A-19. 23. Les enregistrements

- III-A-20. 24. Les performances

- IV. Partie III

- IV-A. Application à la gestion d'inventaires

- IV-A-1. 25. Domaine des inventaires

- IV-A-2. 26. Opérations élémentaires sur les inventaires

- IV-A-3. 27. Opérations avancées sur les inventaires

- IV-A-4. 28. Cas d'usage du module Inventory

- V. Partie IV

- V-A. Application à la théorie des jeux

- V-A-1. 29. Le jeu des tétrominos

- V-A-2. 30. Le tableau de jeu

- V-A-3. 31. La génération des coups

- V-A-4. 32. Le calcul de la valeur d'un tableau

- VI. Partie V

- VI-A. La programmation impérative

- VI-A-1. 33. Les champs mutables

- VI-A-2. 34. Les références

- VI-A-3. 35. Les boucles

- VI-A-4. 36. Les tableaux

- VI-A-5. 37. Les entrées-sorties

- VII. Partie VI

- VII-A. Application aux grands nombres

- VII-A-1. 39. Domaine des entiers naturels

- VII-A-2. 40. Opérations sur les tableaux

- VII-A-3. 41. L'addition

- VII-A-4. 42. La comparaison

- VII-A-5. 43. La soustraction

- VII-A-6. 44. La multiplication longue

- VII-A-7. 45. La multiplication Knuth-Karatsuba

- VII-A-8. 46. La division Burnikel-Ziegler

- VII-A-9. 47. Calcul de &pi au goutte-à-goutte

- VIII. Partie VII

- VIII-A. Application à l'analyse syntaxique

- VIII-A-1. 48. Techniques d'analyse syntaxique

- VIII-A-2. 49. Les requêtes syntaxiques

- VIII-A-3. 50. Un analyseur pour pascal

- VIII-A-4. 51. Les erreurs de syntaxe

- VIII-A-5. 52. Implémentation de Lex.lex_parser

- IX. Partie VIII

- IX-A. Les types algébriques

- IX-A-1. 53. Ordre lexicographique

- IX-A-2. 54. Les types produit

- IX-A-3. 55. Les types somme

- IX-A-4. 56. Les types inductifs

- IX-A-5. 57. Le typage des fonctions partielles

- IX-A-6. 58. Les catamorphismes

- IX-A-7. 59. Les paramorphismes

- X. Partie IX

- X-A. Application aux tableaux extensibles

- X-A-1. 60. Arbres de Braun

- X-A-2. 61. L'interface

- X-A-3. 62. L'implémentation

- X-A-4. 63. La performance et la persistance

- X-A-5. 64. Les itérateurs

- XI. Partie X

- XI-A. Application à la génération de code machine

- XI-A-1. 65. Les familles de processeurs

- XI-A-2. 66. Architecture processeur et performance

- XI-A-3. 67. Le langage machine

- XI-A-4. 68. Le langage source

- XI-A-5. 69. Quelques compléments sur le langage OCaml

- XI-A-6. 70. La traduction en code machine

- XI-A-7. 71. Le traducteur en action

- XI-A-8. Pour aller plus loin

- XII. Remerciements

I - OCaml

Pour accéder à la documentation officielle du langage OCaml cliquez ici.

Pour toute interrogation suscitée par L'approche qualité avec OCaml veuillez exposer ce qui vous fait obstacle dans le fil de discussion réservé à cet effet Commentez .

II - Partie I

1. L'approche qualité

2. Programmation et composants

3. Programmation et langage

4. Installation d'Objective Caml

II-A - 1. L'approche qualité

Le génie logiciel (ou software engineering) est la discipline qui consiste à dégager un certain nombre de principes de conception et d'implémentation dont l'application systématique vise à réduire les efforts (coût humain), les risques de sûreté (coût en insécurité), les risques de fiabilité (coût des indisponibilités) et les risques économiques (coûts financiers) liés au cycle de vie du produit logiciel, depuis son développement, puis sa validation, puis son déploiement, sa mise en service, sa maintenance, sa mise à jour, jusqu'à sa disparition ou son remplacement.

Le génie logiciel est donc par définition essentiellement préventif, il met tout en oeuvre pour minimiser toutes les marges possibles dans les surcoûts liés aux imprévus qui accompagnent les projets logiciels de façon aussi récurrente que pour d'autres réalisations humaines complexes telles que les grands travaux de génie civil. Le génie logiciel ne s'occupe pas des questions humaines et d'organisation sociale, il ne se préoccupe que de la qualité du produit logiciel. Il n'en demeure pas moins que l'application rigoureusement des principes du génie logiciel contribue à atténuer grandement le stress lié à la conception et à la programmation (par l'augmentation de la lisibilité, de la fiabilité et même de l'esthétique du code), augmente la satisfaction et la confiance des utilisateurs (par la robustesse du produit) et plus généralement participe au progrès informatique en rendant possible les logiciels qui doivent exploiter les ressources toujours plus grandes des nouveaux matériels informatiques, sans cesse plus performants, ainsi que satisfaire les nouveaux usages sans cesse plus paramétrables, plus flexibles, plus mobiles et plus communicants.

Enfin, une présentation du génie logiciel ne serait pas complète sans la formulation de sa règle d'or, que le développeur devra toujours garder à l'esprit, et ce d'autant plus si le produit logiciel n'est encore qu'au début de son cycle de développement :

- les gains en qualité ne peuvent jamais attendre ;

- les gains en fonctionnalités peuvent toujours attendre.

Cette règle de développement est connue sous le nom de quality first ou encore release early, release often.
Elle dit que la qualité du code doit être maximale dès le début du développement et ne jamais baisser, quitte à différer l'implémentation de fonctionnalités supplémentaires, quelle que soit leur désirabilité.
Elle dit qu'au final la tortue court plus vite que le lièvre.

II-B - 2. Programmation et composants

Au fur et à mesure qu'ils résolvent des problèmes de plus en plus complexes, les programmes informatiques deviennent eux-mêmes de plus en plus complexes. Cette croissance de la complexité doit rester maîtrisée : un programme ne doit pas devenir plus complexe que le problème qu'il résout. Une solution consiste à diviser pour régner, la conception d'un logiciel se réduit alors à un problème de découpage en composants (components) plus élémentaires. Chaque composant offre une fonctionnalité partielle et leur assemblage fournit la totalité de la fonctionnalité recherchée. Il s'ensuit que la première qualité d'un composant est sa composabilité, c'est-à-dire la facilité avec laquelle on peut l'assembler avec ses semblables pour produire un nouveau composant.

Toute la discipline du génie logiciel consiste alors à débattre des mérites comparatifs des différents candidats opérande/opérateur susceptibles de réaliser le couple composant/assembleur.
Dans le cadre de ce cours on a choisi :

- la fonction (function) comme composant ;

- l' imbrication comme moyen de composition.

Ce choix est motivé par les facilités suivantes :

- l'application de fonction permet le raisonnement équationnel, comme en mathématiques (d'où une bonne lisibilité et une excellente prouvabilité) ;

- l'imbrication est le moyen de composition qui assure le maximum de découplage entre les composants, c'est-à-dire que les composants, tout en étant assemblables, restent totalement lisibles et compréhensibles indépendamment les uns des autres.

Ces deux qualités seront des atouts précieux pour écrire le plus rapidement possible des programmes qu'on espère de la plus grande qualité possible.

II-C - 3. Programmation et langage

Le langage d'implémentation sera Objective Caml (ou en abrégé: OCaml).

Le choix de OCaml est motivé par les avantages suivants :

- OCaml est déjà utilisé dans les universités, l'enseignement supérieur et les concours aux grandes écoles, ainsi que dans de nombreux domaines scientifiques et industriels (conception de circuits intégrés, traitement de signal, biologie moléculaire, séquençage ADN, interpréteurs, compilateurs, cryptologie, ERP, XML, OpenGL). Microsoft, Dassault-Aviation, Intel, XenSource sont membres du consortium OCaml ;

- OCaml peut être soit un interpréteur (interactif) soit un compilateur (efficace) ;

- OCaml est portable et disponible sur de nombreux systèmes ;

- OCaml pratique l'inférence de type (ou typage automatique).

Ce dernier point est décisif, l'inférence de type est une aide précieuse au développement, elle élimine une grande partie des erreurs de conception au plus tôt, dès la saisie du code. Les erreurs de typage rapportées par OCaml sont moins lisibles qu'avec d'autres langages, mais en contrepartie les phases de test et de débogage sont souvent beaucoup plus restreintes. Il n'est pas rare qu'un code qui compile donne le résultat attendu dès le premier essai. En pratique le gain de productivité est considérable. À chaque nouvelle construction introduite, nous introduirons la règle d'inférence de type qui l'accompagne.

II-D - 4. Installation d'Objective Caml

Pour Microsoft Windows 98 et supérieur (versions 32 bits uniquement)

Installez la dernière version de Objective Caml pour Windows.

Le chemin de l'interpréteur pour l'interface OCamlWinPlus est "C:\Program Files\Objective Caml\bin".
Ensuite, suivez ce tutoriel pour installer l'éditeur Crimson et MinGW :

- http://www.france-ioi.org/cours_caml/win_ide.php;

- http://www.france-ioi.org/cours_caml/win_ide_avance.php.

L'éditeur Crimson offre une édition plus confortable avec :

- la numérotation des lignes ;

- la coloration syntaxique personnalisable ;

- la compilation et l'exécution dans l'éditeur, sans ligne de commande ;

- le décalage gauche/droite des blocs de code ;

- des macros définissables par l'utilisateur.

L'environnement MinGW permet la compilation des sources OCaml en code natif sous Windows, ainsi on profite des avantages de l'inférence de types, de l'interpréteur interactif et du ramasse-miettes sans payer le coût en mémoire et en performance qui pénalise les plateformes à compilation juste-à-temps (Just-In-Time).

Soyez conscient que l'interface OCamlWinPlus est assez capricieuse et que d'une façon générale la plateforme Windows, tout en étant largement utilisable, n'est pas forcément la plus confortable pour le développement OCaml.

Les versions pour Windows 64bits sont pour l'instant disponibles sous forme de code source uniquement.

Pour Linux x86, Mac OSX (x86 et PPC)

Voyez la page des distributions binaires précompilés officielles.

Ces plateformes sont les seules à bénéficier d'environnements de développement dédiés à OCaml.

Pour les autres Unix

Voyez la page de la distribution source officielle.

Il vous faudra lancer le script d'installation qui compilera les sources.

Pour BeOS

Il s'agit d'un portage officieux (recompilation à partir du code source).
Un projet d'interfaçage complet avec l'API de BeOS est en cours.
Les binaires de la version 3.08.4 sont à la page http://www.bebits.com/app/3746.

Pour Syllable OS

Il s'agit d'un autre portage officieux (recompilation du code source).
Les binaires de la version 3.10.2 sont à la page OCaml pour Syllable.

III - Partie II

5. Expressions immédiates
6. Fonctions et application
7. Déclarations de variables
8. Déclarations et récursion
9. Déclarations de fonctions
10. Récursion et accumulation
11. Déclarations locales
12. Fonctions et assertions
13. Les types énumérés
14. Le filtrage
15. Les listes
16. Les fonctions sur les listes
17. Le polymorphisme paramétrique
18. Les couples
19. Les huit reines
20. Le tri fusion
21. Les modules
22. Le traitement des erreurs
23. Les enregistrements
24. Les performances

III-A - La programmation fonctionnelle

III-A-1 - 5. Expressions immédiates

La programmation en OCaml consiste essentiellement à évaluer des expressions. Lorsqu'une expression valide suivie de ;; est entrée :

1. OCaml synthétise son type ;

2. Si la synthèse de type échoue, un message d'erreur de type est affiché ;

3. Sinon OCaml affiche son type et sa valeur.

Exemple :

# 1 + 3;;
- : int = 4

Ce qui signifie : l'expression était entière et valait 4.
Pour tirer le meilleur parti de OCaml il est de la plus grande importance de saisir la stratégie utilisée pour la synthèse de type.
Le type des opérandes doit toujours être conforme au type attendu par les opérateurs.
Ainsi l'expression suivante est mal typée et ne peut pas être évaluée :

# 1.0 + 3;;
Characters 0-3:
1.0 + 3;;
^^^
This expression has type float but is here used with type int

Parce que + est l'addition entière et attend deux arguments entiers.
Dans ce cas il faut utiliser +. qui est l'addition réelle :

# 1. +. 3.;;
- : float = 4.

Remarque : contrairement à d'autres langages OCaml infère le type des opérandes à l'aide du type des opérateurs.

OCaml distingue les minuscules et les majuscules.
Les commentaires sont ouverts par (* et sont fermés par *) et ils peuvent être imbriqués.

Les types atomiques sont les nombres entiers (int), les booléens (bool), les chaînes de caractères (string), les caractères (char) et les nombres réels à virgule flottante (float). Voici la liste de ces types accompagnés de leurs opérateurs les plus courants. Ce tableau est suivi de quelques exemples d'utilisation :

Type:

int

Instances:

1 4 -3 0

Préfixés:

min max abs - lnot float_of_int char_of_int string_of_int

Infixés:

+ - * / mod land lor lsl lsr = <> < <= >= >

Type:

bool

Instances:

true false

Préfixés:

not

Infixés:

&& || or = <>

Type:

string

Instances:

"Hello World!"

Préfixés:

String.length print_string int_of_string

Infixés:

^ .[i] = <> < <= >= >

Type:

char

Instances:

'a'

Préfixés:

int_of_char

Infixés:

= <> < <= >= >

Type:

float

Instances:

3.14 .5 0.

Préfixés:

min max sqrt sin cos tan log exp asin acos atan int_of_float

Infixés:

+. -. *. /. ** = <> < <= >= >

Exemples:

Résultat:

# 1+1;;

- : int = 2

# 2*3 = 13 mod 7;;

- : bool = true

# abs (-3);;

- : int = 3

# min 34 (-67);;

- : int = -67

# not (1<2);;

- : bool = false

# not (true && false);;

- : bool = true

# "good" ^ "bye!";;

- : string = "goodbye!"

# "beef".[3];;

- : char = 'f'

# 2.0**3.0;;

- : float = 8.

# sqrt 4.;;

- : float = 2.

# exp 1.;;

- : float = 2.7182818284590451

# cos 0.;;

- : float = 1.

(* La priorité des opérateurs est respectée *)
# 2+3*4;;
- : int = 14

(* Les parenthèses permettent d'utiliser un opérateur infixe en position préfixe *)
# (+) 2 2;;
- : int = 4

(* L'opérateur * en position préfixe doit être entouré d'espaces *)
(* sinon il est interprété comme l'ouverture d'un commentaire *)
# ( * ) 2 2;;
- : int = 4

Le typage remonte l'arbre d'expression, il s'applique d'abord aux constantes, puis à l'échelle des expressions élémentaires et enfin il se propage à travers toutes les expressions englobantes.

Règles de typage (expressions simples)

La règle de typage d'une expression abs n, -n, lnot n, float_of_int n, char_of_int n, ou string_of_int n distingue deux cas possibles :

- ou bien le type de n est int alors l'expression est de type (respectivement) int, int, int, float, char, string ;

- ou bien l'expression est mal typée.

La règle de typage d'une expression a + b, a - b, a * b, a mod b, a land b, a lor b, a lsl b, a lsr b, distingue deux cas possibles :

- ou bien le type de a est int et le type de b est int alors l'expression est de type int ;

- ou bien l'expression est mal typée.

La règle de typage d'une expression a = b, a <> b, a < b et a <= b, a >= b, ou a > b distingue deux cas possibles :

- ou bien a et b ont un même type E alors l'expression est de type bool ;

- ou bien l'expression est mal typée.

La règle de typage d'une expression min a b ou max a b distingue deux cas possibles :

- ou bien a et b ont un même type E alors l'expression est de type E ;

- ou bien l'expression est mal typée.

La règle de typage d'une expression a && b, a || b ou a or b distingue deux cas possibles :

- ou bien le type de a est bool et le type de b est bool alors l'expression est de type bool ;

- ou bien l'expression est mal typée.

La règle de typage d'une expression sqrt x, sin x, cos x, tan x, log x, exp x, asin x, acos x ou atan x distingue deux cas possibles :

- ou bien le type de x est float alors l'expression est de type float ;

- ou bien l'expression est mal typée.

III-A-2 - 6. Fonctions et application

En OCaml les notions d'expression et de valeur ont un sens assez large puisqu'elles englobent aussi les fonctions qui sont des valeurs à part entière.
Une fonction d'une seule variable se déclare à l'aide du mot-clé fun et d'une flèche, par exemple la fonction de n qui renvoie n + 1 se déclare comme ceci :

# fun n -> n + 1;;
- : int -> int = <fun>

L'interpréteur a bien évalué cette expression comme une valeur et lui a attribué le type int → int, c'est-à-dire une fonction d'un entier qui renvoie un entier.
Cette attribution de type se fait grâce au soutien des règles de typage, au niveau le plus élevé, celui de la fonction, le système de typage a réuni suffisamment d'informations de typage pour en déduire le type complet d'une fonction.
La flèche est un constructeur infixe pour les types fonctionnels, elle prend à gauche le type d'un argument et à droite le type d'une application à un argument. Un type fonctionnel est le correspondant OCaml d'une signature dans d'autres langages. Dans ces autres langages, une signature n'est pas un type parce que les fonctions ne sont pas des valeurs à part entière.

L'application de fonction est une opération tellement élémentaire qu'en OCaml on l'écrit par simple juxtaposition, par exemple le successeur de l'entier 2 est l'entier 3 :

# (fun n -> n + 1) 2;;
- : int = 3

Une fonction à plusieurs arguments se construit en imbriquant plusieurs fonctions à un seul argument, par exemple cette fonction réalise l'addition de deux entiers a et b :

fun a -> (fun b -> a + b);;

Son type est int → (int → int), car la flèche est associative à droite, si on lui passe en entier comme argument alors le résultat est de type int → int. Comme la flèche est associative à droite et que l'application de fonction est associative à gauche, pour additionner 1 et 2 on pourra écrire :

(fun a -> fun b -> a + b) 1 2;;

La valeur 1 est alors associée à la variable a puis la valeur 2 est associée à la variable b dans l'expression 1 + b ce qui donne 1 + 2 = 3.
On peut écrire en plus condensé :

(fun a b -> a + b) 1 2;;

Cette abréviation n'altère en rien le mécanisme d'évaluation qui reste exactement le même, en particulier, comme le suggérait le type int → (int → int), on peut construire une fonction d'incrémentation en appliquant 1 à cette fonction :

(fun a b -> a + b) 1;;

Règle de typage (construction d'une fonction)
La règle de typage d'une expression fun v → expr distingue trois cas possibles :

- ou bien toutes les occurrences de v dans expr ont un même type T alors l'expression est de type T → E où E est le type de expr ;

- ou bien il n'y a aucune occurrence de v dans expr alors l'expression est de type 'a → E où E est le type de expr, ce cas ne nous intéresse pas pour l'instant, nous définirons le type 'a au moment opportun ;

- ou bien l'expression est mal typée.

Règle de typage (application d'une fonction)
La règle de typage d'une application f x distingue deux cas possibles :

- ou bien l'expression f est du type X → Y et l'expression x est du type X alors l'application f x est de type Y ;

- ou bien l'application f x est mal typée.

III-A-3 - 7. Déclarations de variables

Les déclarations se font avec le mot-clé let qui associe une valeur à une variable, la constante pi pourra être définie ainsi :

let pi = 3.1415926535898;;

L'addition entière pourra être définie ainsi :

let add = fun a b -> a + b;;

Attention: les variables ainsi définies sont liées, elles ne sont pas modifiables, leur valeur est fixée, elles ne peuvent pas en changer en utilisant une assignation.

Les mots-clés if ... then ... else ... permettent un choix parmi deux expressions possibles selon la valeur d'une condition :

let abs = fun z -> if z >= 0 then z else -z;;
let minimum = fun a b -> if a < b then a else b;;
let maximum = fun a b -> if a > b then a else b;;

Le if ... then ... else ... n'est pas une instruction, mais une expression qui peut prendre deux valeurs possibles.

Règle de typage (expression conditionnelle)
La règle de typage d'une expression if cond then expr1 else expr2 distingue deux cas possibles :

- ou bien le type de cond est bool et les expressions expr1 et expr2 ont un même type E alors l'expression est de type E ;

- ou bien l'expression est mal typée.

III-A-4 - 8. Déclarations et récursion

Le mot-clé rec permet la récursion c'est-à-dire l'utilisation d'une variable pendant sa définition avec let :

let rec factorial =
fun n -> if n=0 then 1 else n * factorial (n - 1);;

let rec power =
fun x n -> if n=0 then 1. else x *. power x (n-1);;

let rec binomial =
fun n p -> if (p=0) or (p=n) then 1 else binomial (n-1) p + binomial (n-1) (p-1);;

let rec fibonacci =
fun n -> if n < 2 then 1 else fibonacci (n - 1) + fibonacci (n - 2);;

Remarque : pour donner une idée intuitive de cette dernière fonction fibonacci disons que si une grenouille pouvait sauter au maximum deux marches d'escalier alors fibonacci n serait le nombre de façons différentes pour cette grenouille de monter n marches à l'aide d'une combinaison de sauts d'une ou deux marches.

III-A-5 - 9. Déclarations de fonctions

Les déclarations suivantes sont, par abus de langage, appelées déclarations de fonctions :

let rec factorial n = if n=0 then 1 else n * factorial (n - 1);;

let rec power x n = if n=0 then 1. else x *. power x (n-1);;

let rec binomial n p = if (p=0) or (p=n)  then 1 else binomial (n-1) p + binomial (n-1) (p-1);;

let rec fibonacci n = if n < 2 then 1 else fibonacci (n - 1) + fibonacci (n - 2);;

Leur sémantique est exactement la même que leurs précédentes versions respectives. factorial, power, binomial et fibonacci restent des variables liées à des valeurs fonctionnelles.

III-A-6 - 10. Récursion et accumulation

Il existe une façon alternative de définir des fonctions récursives: au lieu d'effectuer le calcul au plus tard on l'effectue au plus tôt, pour cela on rajoute un paramètre dit accumulateur qui enregistre le résultat partiel du calcul en cours :

let rec factorial acc n =
if n=0 then acc else factorial (acc*n) (n-1);;

L'expression factorial 1 correspond alors à la fonction factorielle recherchée.

Remarque : on a bien renversé le sens du calcul, cette version itérative calcule n×(n-1)×(n-2)×…×2 alors que la version sans accumulation calculait 2×…×(n-2)×(n-1)×n, bien sûr cela n'a pas d'intérêt ici, car la multiplication est commutative, mais cet effet peut se révéler très utile lors d'applications plus concrètes comme nous aurons l'occasion d'en donner des exemples.

Nombre de fonctions récursives (mais pas toutes) peuvent être réécrites à l'aide d'un ou plusieurs accumulateurs :

let rec power acc x n =
if n=0 then acc else power (acc *. x) x (n-1);;

L'expression power 1.0 correspond à la fonction puissance ordinaire.

Pour la fonction fibonacci on aura besoin de deux accumulateurs :

let rec fibonacci acc0 acc1 n =
if n < 2 then acc1 else fibonacci acc1 (acc0 + acc1) (n - 1);;

L'expression fibonacci 1 1 correspond à la fonction fibonacci ordinaire.

Cette définition de fibonacci est beaucoup plus efficace que la version purement récursive. Pour faire une comparaison imaginons qu'avec la version à accumulateurs la grenouille se contente de monter n marches, alors avec la version récursive la grenouille expérimenterait toutes les façons possibles de monter ces mêmes n marches.

Dans toutes ces implémentations avec accumulateurs la branche then renvoie le résultat final tandis que la branche else n'est qu'une réapplication de la fonction avec de nouveaux arguments. Comme nous le verrons plus loin, cette propriété dite de récursion terminale a aussi son importance dans les performances des calculs intensifs.

III-A-7 - 11. Déclarations locales

Avouons-le, les versions à accumulateur(s) sont moins confortables à l'usage, à cause de leur(s) paramètre(s) supplémentaire(s). Il serait plus commode de camoufler les paramètres-accumulateurs pour n'utiliser que les paramètres significatifs. Pour ce faire nous allons utiliser les mots-clés let v = expr1 in expr2. Cette construction autorise une définition locale, elle agit comme un let ordinaire sauf que la variable v n'est définie que dans expr2 où elle vaudra expr1. La variable v n'est pas définie dans le reste du programme. La construction let rec v = expr1 in expr2 autorise la récursion sur une définition locale de la variable v, c'est-à-dire que v pourra être présente dans expr1.

Nous avons besoin d'un let pour créer le raccourci ainsi que d'un let rec qui définira la fonction récursive locale à accumulateur :

let factorial n =
let rec loop acc n =
if n=0 then acc else loop (acc*n) (n-1)
in loop 1 n;;

let power x n =
let rec loop acc n =
if n=0 then acc else loop (acc *. x) (n-1)
in loop 1. n;;

let fibonacci n =
let rec loop acc0 acc1 n =
if n < 2 then acc1 else loop acc1 (acc0 + acc1) (n - 1)
in loop 1 1 n;;

Il existe une autre raison, plus profonde que celle de la commodité, pour laquelle un changement dans l'expression d'une fonction ne doit pas modifier la façon d'appliquer cette fonction. Cette raison tient à l'approche de componentisation systématique sur laquelle nous nous sommes engagés dès notre présentation de la notion de complexité dans les programmes. Les fonctions sont un de nos meilleurs atouts, si nous voulons préserver leur composabilité il nous faut préserver leur type, car il est le connecteur qui permet de les emboîter les unes avec les autres.

Règle de typage (déclaration locale)
La règle de typage d'une expression let v = expr1 in expr2 distingue trois cas possibles :

- ou bien toutes les occurrences de v dans expr2 ont le même type que expr1 alors l'expression est de type E où E est le type de expr2 ;

- ou bien il n'y a aucune occurrence de v dans expr2 alors l'expression est de type E où E est le type de expr2 ;

- ou bien l'expression est mal typée.

III-A-8 - 12. Fonctions et assertions

Parfois le domaine de définition d'une fonction est strictement inclus dans son type, on utilisera alors le mot-clé assert pour garantir qu'une fonction n'est toujours appliquée que sur son domaine de définition :

let factorial n =
assert(n >= 0);
let rec loop acc n =
if n=0 then acc else loop (acc*n) (n-1)
in loop 1 n;;

let power x n =
assert(n >= 0);
let rec loop acc n =
if n=0 then acc else loop (acc *. x) (n-1)
in loop 1. n;;

let fibonacci n =
assert(n >= 0);
let rec loop acc0 acc1 n =
if n < 2 then acc1 else loop acc1 (acc0 + acc1) (n - 1)
in loop 1 1 n;;

let rec binomial n p =
assert(0 <= p && p <= n);
if (p=0) or (p=n)  then 1 else binomial (n-1) p + binomial (n-1) (p-1);;

Lorsqu'une fonction sera appliquée hors de son domaine de définition OCaml terminera l'évaluation par une erreur Assert_failure telle que celle-ci :

# factorial (-1);;
Exception: Assert_failure ("", 5, 1).

Une assertion ne fait que rendre explicite une indication d'usage que vous auriez autrement mis en commentaire. Expliciter ce qui autrefois était implicite c'est un thème récurrent du principe quality first.

Le respect du principe quality first prescrit d'écrire systématiquement les assertions nécessaires, avant même d'écrire le corps de la fonction. Vous vous remercierez de l'avoir fait pendant le débogage. Anticiper les phases suivantes du développement c'est un autre thème récurrent du principe quality first. N'effacez jamais une assertion, au pire mettez-la en commentaire.

Les assertions font également partie de notre panoplie d'outils pour préserver la composabilité, elles doivent être considérées comme des types, la contrainte qu'elles ajoutent a du sens, elle capture une restriction de domaine que notre système de type n'est pas assez expressif pour imposer à la compilation.

Règle de typage (assertion)
La règle de typage d'une expression assert (cond) distingue deux cas possibles :

- ou bien le type de cond est bool alors l'expression est de type unit (nous reparlerons de ce type unit au moment opportun) ;

- ou bien l'expression est mal typée.

III-A-9 - 13. Les types énumérés

Un type énuméré est un ensemble fini qui correspond au domaine de définition d'une fonction. De cette façon on n'aura pas à ajouter d'assertion, car le type de la fonction correspondra à son domaine de définition.

type day =
| Monday
| Tuesday
| Wednesday
| Thursday
| Friday
| Saturday
| Sunday
;;

Chaque jour ainsi énuméré devient un constructeur pour le type day.

Remarque : le nom de chacun des membres (on dit variants) d'un type énuméré doit commencer par une majuscule, c'est une obligation, au contraire les autres identificateurs habituels (les types, fonctions, variables et étiquettes) doivent toujours commencer par une lettre minuscule.

Règle de typage (constructeur)
La règle de typage d'une expression Constructeur ne contient qu'un seul cas possible :

- le type d'un Constructeur est le type dans lequel il a été énuméré.

III-A-10 - 14. Le filtrage

Le filtrage (pattern matching) permet une analyse de cas en distinguant chacun des motifs (patterns) possibles. Une variable dans un motif prend la valeur à laquelle elle est associée dans ce motif. Les motifs sont ordonnés, ils sont confrontés tour à tour à la valeur filtrée, le premier motif filtrant cette valeur sélectionne la valeur renvoyée par l'expression filtrante. Les variables dans les motifs filtrent toutes les valeurs.

let rec fibonacci n =
assert(n >= 0);
match n with
| 0 -> 1
| 1 -> 1
| m -> fibonacci(m-1) + fibonacci(m-2) ;;

La sémantique de l'expression filtrante match dans cette fonction est la suivante :

- si n = 0 alors l'expression vaut 1 ;

- si n = 1 alors l'expression vaut 1 ;

- sinon l'expression vaut let m = n in fibonacci(m-1) + fibonacci(m-2).

Comme les motifs sont ordonnés, un motif plus général pourra cacher un motif plus spécifique, dans ce cas OCaml délivrera un avertissement à prendre au sérieux comme dans l'exemple suivant où les motifs ont été clairement mal ordonnés :

# let rec factorial n =
match n with
| m -> m * factorial (m - 1)
| 0 -> 1;;
Characters 80-81:
Warning U: this match case is unused.
| 0 -> 1;;
^
val factorial : int -> int = <fun>

De même qu'il existe des fonctions anonymes (introduites par le mot-clé fun) il existe également des variables anonymes.
La variable anonyme est notée "_", la fonction fibonacci peut donc être réécrite :

let rec fibonacci n =
assert(n >= 0);
match n with
| 0 -> 1
| 1 -> 1
| _ -> fibonacci(n-1) + fibonacci(n-2) ;;

Le filtrage multiple, c'est-à-dire sur plusieurs valeurs, est possible à l'aide de la virgule :

let rec binomial n p =
assert(0 <= p && p <= n);
match n,p with
| _,0 -> 1
| _,_ -> if p = n then 1
else binomial (n-1) p + binomial (n-1) (p-1) ;;

Les schémas autorisés dans un motif sont :

- une nouvelle variable ;

- un constructeur ;

- une constante immédiate ;

- une nouvelle variable anonyme.

Les expressions et les applications de fonction ne sont pas autorisées dans les motifs, car un motif n'est pas une valeur, mais un schéma de valeurs.
OCaml vérifie l'exhaustivité du filtrage, si un cas n'est pas filtré, un message d'alerte vous invite à intégrer ce cas ou à reconsidérer votre fonction :

# let string_of_day d =
match d with
| 1 -> "Monday"
| 2 -> "Tuesday"
| 3 -> "Wednesday"
| 4 -> "Thursday"
| 5 -> "Friday"
| 6 -> "Saturday"
| 7 -> "Sunday";;
Characters 23-97:
Warning: this pattern-matching is not exhaustive.
Here is an example of a value that is not matched:
0

Vous devez prendre cet avertissement au sérieux, dans le cas ci-dessus le filtrage a peu de sens, car il y a une infinité d'entiers pour seulement 7 jours de la semaine. L'avertissement concernant la fonction string_of_day est le symptôme d'une erreur sur le domaine de définition, dans notre cas un type énuméré ferait davantage l'affaire :

let string_of_day d =
match d with
| Monday    -> "Monday"
| Tuesday   -> "Tuesday"
| Wednesday -> "Wednesday"
| Thursday  -> "Thursday"
| Friday    -> "Friday"
| Saturday  -> "Saturday"
| Sunday    -> "Sunday";;

let tomorrow d =
match d with
| Monday    -> Tuesday
| Tuesday   -> Wednesday
| Wednesday -> Thursday
| Thursday  -> Friday
| Friday    -> Saturday
| Saturday  -> Sunday
| Sunday    -> Monday;;

Remarque : OCaml rejette la définition multiple d'une même variable dans un même motif.

# let equal a b =
match a,b with
| x,x -> true
| _,_ -> false;;
Characters 43-44:
| x,x -> true
^
This variable is bound several times in this matching

Ici, ce qui semble une contrainte d'égalité est en fait une tentative de définir la même variable avec deux valeurs différentes.

Règle de typage (filtrage)
La règle de typage d'une expression match expr with pat1 → expr1 | ... | patn → exprn comportant n clauses distingue deux cas possibles :

- ou bien l'expression expr et les motifs pat1 à patn ont un même type T et les expressions expr1 à exprn ont un même type E alors l'expression est de type E ;

- ou bien l'expression est mal typée.

III-A-11 - 15. Les listes

La liste chaînée est le type conteneur-extensible le plus simple, tellement simple qu'en OCaml ce type est prédéfini.
Il existe deux façons distinctes d'exprimer une liste chaînée :

- ou bien par énumération, en encadrant les éléments par des crochets, séparés par des points-virgules

# [2;3;4];;
- : int list = [2; 3; 4]

- ou bien par construction à l'aide du constructeur infixe ::

# 2::3::4::[];;
- : int list = [2; 3; 4]

Dans le cas du constructeur :: l'argument à gauche est appelé la tête (head) et celui à droite la queue (tail) de la liste.

Les fonctions qui manipulent des listes utilisent abondamment le filtrage :

- une liste énumérée pour le (ou les) cas de base ;

- une liste construite pour les cas composites.

Par exemple, la fonction sum_list renvoie la somme des entiers d'une liste, la somme des éléments d'une liste vide étant nulle, et la somme des éléments d'une liste non vide étant égale à sa tête n plus la somme des éléments de sa queue t :

let rec sum_list l =
match l with
| []   -> 0
| n::t -> n + sum_list t;;

Il s'agit là d'un raisonnement par cas qui sera souvent utilisé sur les listes :

- ou bien on est dans le cas trivial de la liste vide ;

- ou bien on déconstruit la liste et on applique le traitement adéquat sur sa tête et sa queue, souvent on aura une récursion sur la queue.

Plus rarement il faudra traiter le cas de la liste à un seul élément ou alors il faudra considérer les deux premiers éléments en tête de la liste. Nous aurons bien assez tôt l'occasion de voir maints exemples de fonctions sur les listes.

Règle de typage (liste)
La règle de typage d'une expression a::l ne contient qu'un seul cas possible :

- le type de l'expression a est T ;

- le type de l'expression l est T list ;

- le type de l'expression a::l est T list.

III-A-12 - 16. Les fonctions sur les listes

On se propose de donner deux exemples plus avancés avec les listes.
En premier on déterminera toutes les vues sur un tétromino.
En second on donnera la liste des coordonnées des sommets du cube unité en dimensions quelconques.

Un polyomino est une congruence orthogonale de n carrés. Le jeu Tetris tire son nom du fait qu'il se joue avec les congruences orthogonales de quatre carrés, ce sont les cinq tétrominos surnommées I.L.O.S.T. :

On représentera un polyomino par une edge list, une liste des arêtes (edge) orientées dans le sens des aiguilles d'une montre où le type edge est défini par :

type edge =
| Up
| Down
| Left
| Right
;;

Voici les cinq tétrominos I.L.O.S.T. :

let tetro_I = [Up;Up;Up;Up;Right;Down;Down;Down;Down;Left];;
let tetro_L = [Up;Up;Up;Right;Down;Down;Right;Down;Left;Left];;
let tetro_O = [Up;Up;Right;Right;Down;Down;Left;Left];;
let tetro_S = [Up;Right;Up;Right;Right;Down;Left;Down;Left;Left];;
let tetro_T = [Up;Left;Up;Right;Right;Right;Down;Left;Down;Left];;

On voudra pouvoir les tourner (d'un quart de tour dans le sens horaire) :

let rec rotate p =
match p with
| [] -> []
| Up::t    -> Right::rotate t
| Down::t  -> Left::rotate t
| Left::t  -> Up::rotate t
| Right::t -> Down::rotate t
;;

On voudra également pouvoir les miroiter (échange gauche-droite) :

let mirror p =
let rec loop l a =
match l with
| [] -> a
| Up::t    -> loop t (Down::a)
| Down::t  -> loop t (Up::a)
| Left::t  -> loop t (Left::a)
| Right::t -> loop t (Right::a)
in loop p [];;

Remarque : pour pouvoir retourner la liste, on a utilisé une fonction avec un accumulateur.

Nous allons maintenant représenter le vecteur unité par la liste [[0];[1]] :

# [[0];[1]];;
- : int list list = [[0]; [1]]

Et le carré unité par la liste [[0;0]; [0;1]; [1;0]; [1;1]]. Pour généraliser en dimension n on s'aidera de la fonction mult_unit qui multiplie un cube c par l'intervalle unité lui ajoutant ainsi une dimension. Il suffit alors d'utiliser cette multiplication pour calculer la puissance nième de l'intervalle unité, c'est ce que fait la fonction power_cube :

let rec power_cube n =
assert(n >= 1);
let rec mult_unit c =
match c with
| []   -> []
| h::t -> (0::h)::(1::h)::mult_unit t
in
if n=1 then [[0];[1]]
else mult_unit (power_cube (n-1));;

III-A-13 - 17. Le polymorphisme paramétrique

Nous avons déjà vu qu'une fonction n'a qu'un seul paramètre (sur son domaine) et ne renvoie qu'un résultat (sur son codomaine).

Une conséquence logique c'est qu'une fonction n'a que deux schémas de type possibles :

- ou bien le codomaine est identique au domaine, alors le type de la fonction est de la forme α → α ;

- ou bien le codomaine est différent du domaine, alors le type de la fonction est de la forme α → β.

Ou encore, dit autrement, l'opérateur infixe → est le constructeur du type fonctionnel α → β.

En OCaml les schémas de type α et β sont notés respectivement 'a et 'b :

# let f x = x in f;;
- : 'a -> 'a = <fun>

# let rec f x = f x in f;;
- : 'a -> 'b = <fun>

Un type paramétré par un schéma de type est dit polymorphe.
Un tel type n'est pas une curiosité, nous en avons déjà rencontré un :

# [];;
- : 'a list = []

Le type list est un type paramétré, une liste est homogène, tous ses éléments sont forcément du même type 'a. Ce paramètre de type 'a peut être fixé librement d'où le nom de polymorphisme paramétrique donné à cette capacité.
Ce polymorphisme paramétrique s'applique aussi bien aux types qu'aux fonctions :

- un type polymorphe permet de séparer le type conteneur du type contenu ;

- une fonction polymorphe permet de séparer le type de la fonction du type de ses paramètres.

Les deux vont de pair, la définition d'un type polymorphe s'accompagnant des fonctions polymorphes qui agissent sur lui.
Par exemple des fonctions sur une liste qui ne présagent pas du contenu de cette liste si bien qu'elles sont utiles sur tous les types de liste possibles.
C'est en premier lieu le cas du constructeur de liste, qui n'est pas une fonction puisqu'on ne peut pas l'appliquer, mais dont on va faire apparaître le type de la façon suivante :

# fun h t -> h::t;;
- : 'a -> 'a list -> 'a list = <fun>

La distinction entre fonctions et constructeurs se justifie par le filtrage, une fonction est faite pour être appliquée, un constructeur est fait pour être instancié et filtré.

L'opérateur infixe @ de concaténation de liste est également polymorphe :

# (@);;
- : 'a list -> 'a list -> 'a list = <fun>

Il est temps maintenant de profiter de la pleine fonctionnalité. Nous allons encore écrire des fonctions jouets, mais dorénavant elles seront plus amusantes que jamais. Alors, écrivons sept fonctions polymorphes sur les listes.

La première s'appelle filter, elle est du type :

('a -> bool) -> 'a list -> 'a list

Son 1er paramètre est donc un prédicat (une fonction qui teste un élément), son 2d paramètre est une liste et la fonction renvoie également une liste. Et le type nous dit encore plus que ceci. En effet regardons les paramètres de type, ils nous disent que le prédicat peut tester tous les éléments de la liste donnée en paramètre et que si on appliquait un prédicat à filter, c'est-à-dire si on ne lui fournissait que le premier de ses deux arguments (on appelle ceci une application partielle), alors filter serait un endomorphisme (une fonction de type α → α), elle aurait donc le même type que la fonction identité.

À partir de là, sur la seule foi de son type, il est possible d'imaginer ce que fait la fonction filter: elle renvoie la liste donnée en paramètre à laquelle ont été ôtés tous les éléments qui ne satisfont pas le prédicat ('a -> bool). Nous allons maintenant l'implémenter, voilà comment nous procédons, en raisonnant par cas :

- ou bien la liste est vide alors, la liste filtrée est vide ;

- ou bien la liste a une tête et une queue alors on filtre la queue et on lui ajoute la tête (si elle satisfait le prédicat) ou pas (si elle ne satisfait pas le prédicat).

Ce qui nous donne :

let rec filter p l =
match l with
| [] -> []
| h::t -> if p h then h::filter p t
else filter p t;;

Passons à notre deuxième fonction polymorphe, elle s'appelle exists et elle est du type :

('a -> bool) -> 'a list -> bool

Raisonnons sur son type, c'est encore une fonction qui attend un prédicat et une liste, encore une fois le prédicat teste les éléments de cette liste (puisque lui et la liste ont le même paramètre de type 'a), mais cette fois-ci la fonction exists est elle-même un prédicat (sur la liste donnée en argument), car si on lui applique un prédicat (par application partielle) alors son type devient α → bool. La fonction exists fait l'union logique de l'application du prédicat sur tous les éléments de la liste. Avec ce type elle pourrait faire la conjonction au lieu de l'union (c'est d'ailleurs le rôle de la fonction for_all que nous verrons plus tard). Le type d'une fonction ne la caractérise donc pas totalement, mais il en dit déjà assez long et il serait désavantageux d'ignorer cette information.

Raisonnons par cas :

- ou bien la liste est vide, elle ne contient alors aucun élément qui puisse satisfaire le prédicat, nous renvoyons false ;

- ou bien la liste a une tête et une queue alors nous renvoyons la conjonction logique du prédicat sur la tête et de la récursion sur la queue.

Ce qui nous donne :

let rec exists p l =
match l with
| [] -> false
| h::t -> p h or exists p t;;

Passons à notre troisième fonction polymorphe, elle s'appelle mapi et elle est du type :

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

Imaginons que les int soient absents de ce type alors le type serait celui-ci :

('a -> 'b) -> 'a list -> 'b list

Et c'est tout de suite plus clair : nous comprenons que la fonction mapi applique la fonction ('a → 'b) sur tous les éléments de la liste ('a list) et renvoie une liste ('b list). Alors que viennent faire les int ? C'est simple, il s'agit d'un argument supplémentaire qui croit avec la position de l'élément 'a dans la liste ('a list).

Raisonnons à nouveau par cas :

- ou bien la liste est vide alors la fonction f ne s'applique jamais et la liste renvoyée est vide ;

- ou bien la liste a une tête et une queue alors nous appliquons (f n h) et nous ajoutons le résultat à la transformation de la queue.

Ce qui nous donne :

let rec mapi f n l =
match l with
| [] -> []
| h::t -> f n h::mapi f (n+1) t;;

Notre quatrième fonction polymorphe utilisera notre fonction exists, elle s'appelle exists_commutative et elle est du type :

('a -> 'a -> bool) -> 'a list -> bool

Ce type ressemble beaucoup à celui de exists sauf que cette fois-ci le prédicat teste deux éléments de la liste donnée en paramètre. Cette fonction nous dira donc s'il existe deux éléments dans la liste qui vérifient le prédicat donné en paramètre.

Raisonnons par cas :

- ou bien la liste est vide alors elle ne contient pas deux éléments, nous renvoyons false ;

- ou bien la liste a une tête et une queue alors, nous renvoyons la conjonction logique du prédicat (duquel on a fixé le premier argument avec la tête) appliqué à toute la queue et de la récursion sur la queue.

let rec exists_commutative p l =
match l with
| []   -> false
| h::t -> (exists (p h) t) or exists_commutative p t;;

Notez que le prédicat doit être commutatif, car pour chaque couple d'éléments il n'est appliqué qu'une seule fois, si le prédicat était non commutatif il faudrait également l'appliquer en échangeant l'ordre des deux éléments.

Notre cinquième fonction polymorphe est la fonction flatten qui renvoie la concaténation de plusieurs listes :

let rec flatten l =
match l with
| [] -> []
| h::t -> h @ flatten t;;

Notre sixième fonction polymorphe est distribute qui utilise mapi pour renvoyer la liste des listes l dans lesquelles on a inséré l'élément a à toutes les positions possibles :

let rec distribute a l =
match l with
| []   -> [[a]]
| h::t -> (a::l) :: (mapi (fun _ x -> h::x) 0 (distribute a t));;

Enfin notre septième et dernière fonction est permute qui utilise flatten, mapi et distribute pour renvoyer la liste de toutes les permutations d'une liste :

let rec permute l =
match l with
| []   -> [[]]
| h::t -> flatten (mapi (fun _ -> distribute h) 0 (permute t));;

Remarque :

Les opérations sur les listes sont toujours non destructives, la structure des listes passées en arguments est toujours préservée, les listes retournées en résultat sont fraîchement allouées dans le tas (la mémoire globale) par le constructeur (::), on dit que la liste est une structure de données immutable. D'une façon générale, la programmation fonctionnelle privilégie plutôt les données immutables alors que la programmation impérative privilégie plutôt les données mutables. Les données immutables bénéficient de la propriété dite de substituabilité qui facilite un raisonnement équationnel assez similaire à celui utilisé en mathématiques. Cette facilité de raisonner sur le texte du programme et non sur son exécution améliore grandement la lisibilité du code. De plus la rigueur du raisonnement par récurrence fait que le texte du programme se rapproche naturellement du raisonnement qui établit la preuve de sa correction.

Remarques :

- toute fonction de type 'a → 'a est isomorphe à la fonction identité ;

- toute fonction de type 'a → 'b → 'a est un opérateur associatif à gauche ;

- toute fonction de type 'a → 'b → 'b est un opérateur associatif à droite.

Règle de typage (liaison d'une variable de type)
Cette règle explicite l'instanciation d'un type polymorphe par un autre type monomorphe ou polymorphe :

- la variable 'a peut être liée à n'importe quel type T ne contenant pas d'occurrence libre de la variable 'a ;

- la variable 'a peut être liée à deux types T1 et T2 si et seulement si le type T1 est identique au type T2.

III-A-14 - 18. Les couples

Les couples (pairs) correspondent à un produit cartésien de valeurs, ils combinent deux valeurs de types quelconques sous la forme d'une seule paire. Les deux éléments d'un couple sont séparés par une virgule. Les couples sont utilisés notamment :

- comme des containers ;

- pour retourner deux valeurs ;

- pour le filtrage multiple (nous avons déjà parlé du filtrage sur plusieurs valeurs).

La virgule est un constructeur, mais nous allons exposer son type comme nous l'avons fait pour le constructeur de listes :

# fun a b -> (a,b);;
- : 'a -> 'b -> 'a * 'b = <fun>

Deux remarques :

- le résultat contient deux paramètres de type 'a et 'b, un couple peut donc être hétérogène ;

- les parenthèses ne sont pas indispensables, mais elles sont souvent utiles surtout si on ne connaît pas bien la priorité des opérateurs OCaml.

On retiendra que l'opérateur infixe * est le constructeur du type produit α * β .

Le let, le let rec et les déclarations de fonctions peuvent filtrer les couples.

En tant que conteneurs, les couples peuvent représenter les nombres complexes :

let add_z (a1,b1) (a2,b2) = (a1+.a2,b1+.b2);;
let mul_z (a1,b1) (a2,b2) = (a1*.a2-.b1*.b2,a1*.b2+.a2*.b1);;

Un couple peut également être utilisé pour retourner deux valeurs, c'est par exemple le cas de la fonction predefinie modf qui renvoie un couple de float :

# modf;;
- : float -> float * float = <fun>

Les deux composantes du couple renvoyé peuvent être récupérées par un let-filtrant, par exemple cette expression extrait la partie décimale de pi :

# let pi = 3.14159 in
let (d,i) = modf pi in d;;
- : float = 0.14158999999999988

Parfois un couple cumule les deux utilités, une fonction renvoie deux valeurs, mais ces valeurs peuvent être interprétées comme une seule valeur composite, par exemple ces valeurs peuvent être les deux bornes d'un intervalle à une dimension.

Règle de typage (construction d'un couple)
La règle de typage d'une expression a,b ne contient qu'un seul cas possible :

- le type d'un couple a,b est A * B où A est le type de l'expression a et B est le type de l'expression b

Pour finir, tout ce qui a été dit sur les couples est généralisable aux triplets ainsi qu'aux n-uplets (tuples) quelconques.

# (1,2,3);;
- : int * int * int = (1, 2, 3)

III-A-15 - 19. Les huit reines

Le problème des 8 reines est un problème classique, l'exercice consiste à générer toutes les façons de positionner 8 reines sur un échiquier sans qu'aucune ne puisse en prendre une autre. Nous allons résoudre ce problème plus facilement qu'il n'y paraît.

Supposons qu'une reine soit sur la case (xa,ya) et une autre sur la case (xb,yb), alors le prédicat check_queens nous dit si ces deux reines sont en position de prise :

let check_queens (xa,ya) (xb,yb) =
(xa = xb) or (ya = yb) or
(xa - xb) = (ya - yb)  or
(ya - yb) = (xb - xa);;

Cela résout-il notre problème, apparemment non. Mais réfléchissez un instant aux fonctions polymorphes que nous venons de développer, elles ont le pouvoir d'étendre la sémantique d'une fonction aussi loin qu'il est nécessaire pour la résolution de notre problème.

En effet, considérez que :

- il n'y a forcément qu'une reine par colonne ;

- il n'y a forcément qu'une reine par ligne ;

- nous appelons reine n la reine placée sur la nième ligne, alors permute [1;2;3;4;5;6;7;8] place les reines 1 à 8 sur toutes les permutations de colonnes possibles ;

- nous pouvons alors utiliser mapi pour créer les couples de coordonnées (colonne,ligne) ;

- pour détecter une liste de reines qui ne serait pas une solution, nous pouvons appliquer le test exists_commutative check_queens car le prédicat check_queens est commutatif ;

- nous pouvons utiliser filter pour ne garder que les listes de reines qui sont des solutions du problème.

Ce qui nous donne :

let safe_boards queens =
filter
(fun l -> exists_commutative check_queens l = false)
(mapi
(fun _ l -> mapi (fun a b -> a,b) 1 l)
1
(permute queens)
);;

safe_boards [1;2;3;4;5;6;7;8];;

Et comme la permutation nous garantit que chaque reine est sur un couple (colonne,ligne) unique nous pouvons simplifier le prédicat check_queens comme ceci :

let check_queens (xa,ya) (xb,yb) =
(xa - xb) = (ya - yb) or
(ya - yb) = (xb - xa) ;;

Remarque : les opérateurs logiques or et && sont semi-stricts, si la valeur de leur premier argument suffit à établir le résultat alors ils n'évaluent pas leur second argument. De ce fait la fonction check_queens ci-dessus est aussi efficace que la fonction check_queens ci-dessous.

let check_queens (xa,ya) (xb,yb) =
if (xa - xb) = (ya - yb) then true
else (ya - yb) = (xb - xa) ;;

III-A-16 - 20. Le tri fusion

Encore un exemple, pour illustrer la récursion et la démarche diviser pour régner, et encore une fonction polymorphe sur les listes. Celle-ci trie une liste par ordre croissant. Elle tire son polymorphisme de celui de la fonction (>) :

# (>);;
- : 'a -> 'a -> bool = <fun>

En OCaml toutes les fonctions de comparaison sont des prédicats polymorphes, en effet, si 'a est int ou float alors la comparaison a son sens mathématique habituel, avec les types char et string les données sont comparées suivant l'ordre alphabétique, sinon les données sont comparées selon une méthode structurelle (voir la documentation en ligne du module Pervasives pour plus de détails).

Le tri-fusion polymorphe nécessite trois fonctions auxiliaires.
La fonction merge_list fusionne deux listes a et b déja triées et renvoie leur union, c'est-à-dire une liste triée qui contient à la fois les éléments de a et ceux de b :

let rec merge_list a b =
match a,b with
| [],_ -> b
| _,[] -> a
| ha::ta,hb::tb ->
if ha < hb then ha::(merge_list ta b)
else hb::(merge_list a tb);;

Le premier élément d'une liste est l'élément de rang zéro.
La fonction odd_list renvoie la liste des éléments de rang impair de la liste l :

let rec odd_list l =
match l with
| []  -> []
| [a] -> []
| a::b::l -> b::odd_list l;;

La fonction even_list renvoie la liste des éléments de rang pair de la liste l :

let rec even_list l =
match l with
| []   -> []
| a::l -> a::odd_list l;;

Enfin, la fonction merge_sort est la fonction du tri-fusion d'une liste l.
Elle procède en trois étapes :

- elle scinde la liste l en deux listes ;

- elle trie ces deux listes ;

- elle fusionne les deux listes triées en une seule.

Cette décomposition récursive du processus de tri s'arrête nécessairement puisque l'on sait trier une liste vide et une liste qui contient un seul élément. Sinon la liste contient au moins deux éléments et alors on applique le procédé décrit ci-dessus. Voici le code de cette fonction :

let rec merge_sort l =
match l with
| [] -> []
| [a] -> [a]
| _ ->
let p = even_list l in
let q = odd_list  l in
merge_list (merge_sort p) (merge_sort q);;

Remarque : on aurait pu effectuer la scission d'une liste en une seule étape, à l'aide de couples, comme ceci

let rec split_list l =
match l with
| [] -> [],[]
| [a] -> [a],[]
| a::b::l -> let p,q = split_list l in (a::p,b::q);;

let rec merge_sort l =
match l with
| [] -> []
| [a] -> [a]
| _ ->
let p,q = split_list l
in merge_list (merge_sort p) (merge_sort q);;

Remarque : il existe également un prédicat compare a b, qui effectue une comparaison plus complète que (<), qui est lui aussi polymorphe, et qui renvoie un entier dont le signe dépend de a < b et a > b

# compare;;
- : 'a -> 'a -> int = <fun>

Ce prédicat pourrait être implémenté ainsi pour les entiers :

# let compare_int a b = a - b;;
val compare_int : int -> int -> int = <fun>

Bien sûr cette version est monomorphe, elle n'accepte que les entiers, mais elle donne une bonne idée du comportement du compare polymorphe.

III-A-17 - 21. Les modules

Bien entendu OCaml permet de gérer les gros projets et les projets en équipe, pour cela il fournit un mécanisme de modularité qui offre un espace de nommage (et même beaucoup plus, mais cela n'est pas le sujet de ce paragraphe). Ce mécanisme de modularité est d'autant plus indispensable que certaines fonctions sont "trop" polymorphes. Par exemple la fonction compare (celle du module Pervasives) est définie d'une façon trop générique, pour des types composites elle ne renverra pas forcément le résultat escompté, il faudra alors définir une fonction compare plus spécialisée qui renvoie le résultat attendu pour ce nouveau type. Il devient alors logique, pour ne pas écraser le compare habituel, de réunir la définition du nouveau type composite et la définition de sa fonction compare dans un même module.

Le mot-clé module permet de limiter la portée du let. Ainsi, en introduisant un module List on pourra limiter la portée des fonctions filter, exists, flatten sur les listes, ceci permettrait par exemple de réutiliser ces noms dans un hypothétique module Tree. Choisir des noms identiques pour des fonctionnalités identiques est une bonne pratique qui participe à augmenter la lisibilité des programmes.

La bonne nouvelle c'est que ce module List existe déjà, c'est le fichier Objective Caml/libs/list.ml, et il contient les fonctions List.filter, List.exists, et List.flatten telles que nous les avons défines, avec des implémentations récursives terminales quand cela est possible. Pour une spécification plus complète du module List veuillez consulter sa documentation en ligne.

Parfois la récursion terminale n'est pas directement possible, c'est le cas de la fonction List.append qui est la version préfixe de l'opérateur de concaténation de listes (@) que nous avons déjà utilisé. Il est possible d'écrire une version récursive terminale de la concaténation, en ajoutant un accumulateur, mais comme nous l'avons vu ceci peut avoir pour effet de renvoyer un résultat qui est le miroir du résultat voulu, dans le cas de la concaténation de liste ceci nous donne la fonction List.rev_append :

# List.rev_append;;
- : 'a list -> 'a list -> 'a list = <fun>

Cette fonction a le même type que List.append, elle est récursive terminale et elle concatène bien ses deux arguments, mais son résultat est renversé, nous verrons néanmoins que cette fonction n'est pas inutile, car nous n'aurons pas forcément besoin de renverser son résultat à l'aide de List.rev.

Vous l'avez deviné, List.rev l est la fonction qui renverse la liste l, elle est récursive terminale :

let rev l = rev_append l [];;

Voilà bien un premier exemple qui montre que List.rev_append n'est pas l'aberration qu'on pourrait croire.

Le module List contient également les fonctions List.map, List.for_all et List.sort.

La fonction List.map ressemble à notre fonction mapi à la différence près que List.map ne tient pas compte de la position des éléments dans la liste :

# List.map;;
- : ('a -> 'b) -> 'a list -> 'b list = <fun>

La fonction List.map applique la fonction ('a → 'b) sur tous les éléments de la liste ('a list) et renvoie une liste ('b list).
Cette fonction n'est pas récursive terminale, sa version récursive terminale (mais renversée) est List.rev_map.

La fonction List.for_all ressemble fort à la fonction List.exists et d'ailleurs on pourrait l'implémenter ainsi :

let for_all p l = List.exists (fun x -> p x = false) l = false;;

Elle dit simplement si les éléments d'une liste l vérifient tous le prédicat p.

Enfin la fonction List.sort ressemble fort à notre fonction merge_sort à la différence qu'en plus elle attend pour premier argument une fonction similaire à compare et c'est cette fonction qui lui sert de critère pour le tri :

# List.sort;;
- : ('a -> 'a -> int) -> 'a list -> 'a list = <fun>

Il reste le cas de nos fonctions mapi, exists_commutative et permute, et comme elles ont déjà prouvé leur utilité nous les conserverons dans un nouveau module que l'on nommera ListXP :

module ListXP = struct
let rec mapi f n l = ...
let rec exists_commutative p l = ...
let rec permute l = ...
end;;

La portée de leurs déclarations est alors délimitée par les mots-clés struct et end.
Nous en profitons pour améliorer leurs implémentations en fournissant une version récursive terminale rev_mapi et en utilisant les fonctions du module List :

module ListXP = struct

let rec mapi f n l =
match l with
| []   -> []
| h::t -> f n h::mapi f (n+1) t;;

let rev_mapi f n l =
let rec loop l n acc =
match l with
| []   -> acc
| h::t -> loop t (n+1) (f n h::acc)
in loop l n [];;

let rec exists_commutative p l =
match l with
| []   -> false
| h::t -> (List.exists (p h) t) or exists_commutative p t;;

let rec distribute a l =
match l with
| []   -> [[a]]
| h::t -> (a::l) :: (List.map (fun x -> h::x) (distribute a t));;

let rec permute l =
match l with
| []   -> [[]]
| h::t -> List.flatten (List.map (distribute h) (permute t));;

end;;

Notons qu'un module est une expression et a donc un type (qu'on appelle aussi signature), voici la signature de notre module ListXP telle que l'interpréteur OCaml l'a inférée :

module ListXP :
sig
val mapi : (int -> 'a -> 'b) -> int -> 'a list -> 'b list
val rev_mapi : (int -> 'a -> 'b) -> int -> 'a list -> 'b list
val exists_commutative : ('a -> 'a -> bool) -> 'a list -> bool
val distribute : 'a -> 'a list -> 'a list list
val permute : 'a list -> 'a list list
end

Remarque : le nom d'un module doit obligatoirement commencer par une majuscule.

III-A-18 - 22. Le traitement des erreurs

Parfois une fonction ne peut pas renvoyer de résultat parce que ses arguments sont incompatibles avec le calcul à effectuer.
Il existe trois façons simples de régler ces cas, par ordre de préférence :

- la fonction assert, déjà vue ;

- la fonction invalid_arg appliquée à une chaîne de message d'erreur ;

- la fonction failwith appliquée à une chaîne de message d'erreur.

Voici un cas où l'on privilégiera la fonction assert parce qu'il n'y pas de filtrage :

# abs min_int;;
- : int = -1073741824
# let safe_abs n =
assert(n > min_int);
abs n;;
val safe_abs : int -> int = <fun>

Voici un cas où l'on privilégiera au contraire la fonction invalid_arg parce que le cas à éliminer est déjà pris en compte par un filtrage exhaustif :

# let maximum l =
let rec loop a l =
match l with
| []   -> a
| b::t -> if a > b then loop a t else loop b t
in match l with
| []   -> invalid_arg "maximum"
| a::t -> loop a t;;
val maximum : 'a list -> 'a = <fun>

On réservera l'usage de la fonction failwith aux cas où les arguments sont bien dans le domaine de définition.

Remarque : les fonctions failwith et invalid_arg sont de type string → 'a, un type à l'évidence totalement dépourvu de sémantique, avec pour seul avantage qu'il trouve sa place n'importe où.
La bonne nouvelle c'est qu'un déclenchement d'erreur pourra se substituer à n'importe quelle expression.
La mauvaise nouvelle c'est que n'importe quelle expression suffisamment obscure pourra cacher un déclenchement d'erreur.

III-A-19 - 23. Les enregistrements

Les enregistrements (records) correspondent eux aussi à un produit cartésien de valeurs et ont la même utilité que les couples ou n-uplets. La principale différence c'est qu'avec un n-uplet un élément est identifié par sa position alors qu'avec un enregistrement un élément est identifié par son étiquette (label).

Une autre différence c'est le typage, OCaml doit pouvoir typer la totalité d'un couple alors que pour un enregistrement il lui suffit de typer chacune de ses composantes. Nous étudierons plus tard en quoi le typage limite parfois les couples et avantage les enregistrements.

Typiquement la déconstruction d'un couple se fait plutôt par filtrage alors que la déconstruction d'un enregistrement se fait plutôt par ses accesseurs. Le filtrage est plus naturel pour le calcul symbolique, les accesseurs sont plus naturels pour les calculs numériques.

En voici un exemple, nous déclarons d'abord les types vector et point, en trois dimensions :

type vector = {x: float; y: float; z: float};;
type point  = vector;;

Le type point n'est qu'un alias (un synonyme) pour le type vector, parce qu'un point peut être désigné par le vecteur qui le sépare de l'origine. Nous pouvons maintenant implémenter les opérations vectorielles classiques, l'addition, la soustraction, le produit scalaire et le carré scalaire :

let add a b =
{x = a.x +. b.x; y = a.y +. b.y; z = a.z +. b.z;};;

let sub a b =
{x = a.x -. b.x; y = a.y -. b.y; z = a.z -. b.z;};;

let scalar_dot a b =
a.x *. b.x +.
a.y *. b.y +.
a.z *. b.z;;

let scalar_sqr v =
v.x *. v.x +.
v.y *. v.y +.
v.z *. v.z;;

Nous ajoutons également un constructeur qui fabrique un vecteur à partir de deux points :

let make (a: point) (b: point) =
{x = b.x -. a.x; y = b.y -. a.y; z = b.z -. a.z;};;

On remarquera la notation (expr: type) qui demande explicitement au compilateur d'essayer d'inférer le type mentionné. Ceci n'a rien à voir avec le transtypage dans les langages pourvus d'un typage moins fort que celui d'OCaml, si le compilateur ne parvient pas à inférer le type demandé alors une erreur de typage sera reportée. Ici on demande au compilateur d'inférer le type point plutôt que le type vector. Cette façon d'orienter le typage s'appelle une annotation de type.

Nous voilà prêts pour affronter la problématique de base du lancé de rayons. Un rayon est une demi-droite paramétrée s + tv , elle a pour source le point s et pour direction le vecteur v.
Une sphère a pour centre un point c et pour rayon un réel r. L'intersection d'un rayon avec une sphère est soit vide, soit un intervalle (t1,t2) de paramètres du rayon s + tv.

# let ray_sphere (s: point) v (c: point) r =
(* Carré du rayon de la sphère: *)
let r2 = r *. r   in
(* Vecteur de la source au centre de la sphère: *)
let sc = make s c in
(* Carré de la distance de la source au centre de la sphère: *)
let sc2 = scalar_sqr sc   in
let v2  = scalar_sqr v    in
let p   = scalar_dot sc v in
let p2  = p *. p    in
(* Carré de la distance du rayon au centre de la sphère: *)
let d2 = sc2 -. p2 /. v2 in
let delta = r2 -. d2 in
if delta <= 0. then
failwith "empty"
else
let sq = sqrt (delta /. v2) in
let t1 = p /. v2 -. sq in
let t2 = p /. v2 +. sq in
if t2 < 0. then
failwith "empty"
else
(max 0. t1, t2);;
val ray_sphere : point -> vector -> point -> float -> float * float = <fun>

Règle de typage (synonymie de type)
Cette règle précise le sens de la condition "même type" en présence d'aliasing de type :

- un type est le même type qu'un type qui est son alias.

Règle de typage (typage explicite)
La règle de typage d'une expression explicitement typée (expr: E) distingue deux cas possibles :

- ou bien le type de expr est le même type que E alors l'expression est de type E ;

- ou bien l'expression est mal typée.

III-A-20 - 24. Les performances

Bien que les langages fonctionnels soient plus proches de la spécification que les langages impératifs ils n'en sont pas moins exempts des considérations de performances. Il y trois types de ressources à économiser :

- la pile est une ressource mémoire locale et limitée ;

- le tas désigne la mémoire globale ;

- les processeurs désignent les ressources d'exécution.

Du fait de leur système de typage bien plus avancé, les langages fonctionnels peuvent mieux capitaliser sur la modularité pour réutiliser les meilleurs algorithmes et les meilleures structures de données les plus adaptés aux spécificités du domaine. Du coup le programmeur fonctionnel est généralement moins sous pression quant aux gains de performances liés à l'économie des ressources d'exécution.

Il faudra tout de même prendre garde à partager les calculs autant que possible, par exemple

let square f x = f x *. f x;;

devra s'écrire :

let square f x = let y = f x in y *. y;;

Sinon le calcul, potentiellement long, de f x se fera deux fois au lieu d'une seule.

La contrepartie d'une meilleure maîtrise des ressources d'exécution c'est que le programmeur fonctionnel doit faire davantage attention à économiser les ressources mémoire, les langages fonctionnels sont des langages de haut niveau, ils ont une tendance naturelle à consommer plus de pile et de tas que les langages de bas niveau.

L'astuce principale pour économiser la pile consiste à privilégier la récursion terminale, par exemple si l'on veut concaténer deux listes et que seuls comptent les éléments (pas leur ordonnancement) alors on utilisera List.rev_append plutôt que List.append parce que List.rev_append est récursive terminale et pas List.append. Il en va de même pour List.rev_map comparée à List.map.

Dans d'autres cas, il faudra utiliser l'accumulation si cela est nécessaire, notamment si l'on envisage de traiter des chaînes de longueur potentiellement élevée. Souvent il sera plus aisé de faire l'implémentation en deux étapes, d'abord écrire une version récursive, la tester, puis ensuite écrire une nouvelle version avec accumulation.

Une astuce de nature similaire s'applique au tas, elle consiste à remplacer les listes normales par des listes paresseuses, ces listes sont détruites au fur et à mesure qu'elles sont construites de sorte que seule leur tête est présente dans le tas au lieu de toute leur longueur. Nous n'aborderons pas les listes paresseuses dans ce chapitre.

Une autre astuce appréciable pour économiser le tas consiste à éviter la duplication des listes et des couples quand elle n'est pas strictement indispensable.

Pour les listes cela peut se faire en cumulant deux fonctionnalités en une seule, par exemple si on effectue des grandes quantités de ce traitement :

List.rev_map f (List.filter p l);;

Alors on pourra avantageusement le remplacer par :

let rev_map_filter p f l =
let rec loop l acc =
match l with
| [] -> acc
| h::t ->
if p h then loop t (f h::acc)
else loop t acc
in loop l [];;

Ce qui permet d'économiser la production de listes par filter qui seraient aussitôt consommées par rev_map.

Une situation similaire concerne les couples, dans les cas où soit on veut pouvoir à la fois les détruire et les conserver.
Supposons que nous voulions ordonner tous les couples d'une liste, que le second élément du couple soit toujours supérieur au premier, voici une façon de faire :

let ordered_pair (a,b) = if a < b then (a,b) else (b,a);;
let list_ordered_pairs l = List.map ordered_pair l;;

Le cas dérangeant c'est le cas a < b, car alors nous détruisons le couple pour en construire un autre en tous points identique, en conséquence le tas est davantage sollicité qu'il ne le devrait. Afin d'éviter ces cas il existe le mot-clé as qui permet d'apparier une variable (ici p) à la totalité d'un motif (ici a,b) :

let ordered_pair (a,b as p) = if a < b then p else (b,a);;

Avec cette version, seuls les "nouveaux" couples sont alloués, les anciens sont réutilisés.

IV - Partie III

1. Domaine des inventaires

2. Opérations élémentaires sur les inventaires

3. Opérations avancées sur les inventaires

4. Cas d'usage du module Inventory

IV-A - Application à la gestion d'inventaires

Pour conclure ce tour d'horizon des techniques de programmation élémentaires, des listes polymorphes, de la modularité et du traitement des erreurs, nous allons étudier un projet complet et réaliste qui fait usage de toutes ces connaissances.

IV-A-1 - 25. Domaine des inventaires

Notre projet a pour but de fournir des primitives sophistiquées pour l'écriture de programmes de gestion automatique des inventaires de pièces détachées. Toutes ces facilités seront disponibles dans le module Inventory :

module Inventory = struct
...
end;;

Un inventaire est une liste d'associations qui à chaque clé 'a associe un entier, ce que nous formalisons ainsi :

type 'a inventory = ('a * int) list;;

Pour la commodité des utilisateurs du module nous définissons également l'alias suivant de sorte que le type inventaire soit disponible sous le nom Inventory.t :

type 'a t = 'a inventory;;

Et pour donner une idée intuitive de ce qu'est un inventaire rien de tel qu'un exemple :

# (["bottle",1;"glass",2] : string inventory);;
- : string inventory = [("bottle", 1); ("glass", 2)]

Cette expression signifie simplement "1 bouteille et 2 verres", l'interpréteur confirme qu'il a bien inféré un inventaire comme il lui a été demandé par l'annotation de type.

Nous venons de définir le type d'un inventaire, il nous faut maintenant définir son domaine.
Par exemple il est évident que la quantité d'un article dans un inventaire ne saurait être négative. Nous choisissons également d'imposer une représentation unique pour chaque inventaire possible, pour cela nous ajoutons les deux contraintes suivantes :

- la quantité d'un article dans un inventaire ne peut pas être nulle (elle doit être strictement positive) ;

- un même article ne peut pas avoir deux quantités dans le même inventaire.

Afin de garantir cette deuxième et dernière contrainte, le plus simple est de trier les articles selon leur clé.
Le prédicat valid nous assurera qu'un inventaire est bien dans le domaine de définition :

let valid (a: 'a inventory) =
let rec loop prev l =
match l with
| [] -> true
| (p,n)::t -> (p > prev) && (n > 0) && (loop p t)
in match a with
| [] -> true
| (p,n)::t -> (n > 0) && (loop p t);;

Et le constructeur make nous construira un inventaire valide à partir d'une liste quand cela est possible :

let make l =
let sorted = List.sort (fun (p1,_) (p2,_) -> compare p1 p2) l in
assert(valid sorted);
(sorted : 'a inventory);;

Nous pouvons maintenant aborder sereinement les opérations élémentaires sur les inventaires.

IV-A-2 - 26. Opérations élémentaires sur les inventaires

L'union de deux inventaires qui renvoie a + b, et l'intersection de deux inventaires qui renvoie a && b :

(* a + b *)
let union (a: 'a inventory) (b: 'a inventory) =
assert(valid a); assert(valid b);
let rec loop 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 loop ta b (ha::u)
else if pa > pb then loop a tb (hb::u)
else loop ta tb ((pa,qa+qb)::u)
in (loop a b []: 'a inventory);;

(* a && b *)
let intersection (a: 'a inventory) (b: 'a inventory) =
assert(valid a); assert(valid b);
let rec loop a b c =
match a,b with
| [],_ -> List.rev c
| _,[] -> List.rev c
| (pa,qa)::ta,(pb,qb)::tb ->
if pa < pb then loop ta b c
else if pa > pb then loop a tb c
else loop ta tb ((pa,min qa qb)::c)
in (loop 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 :

(* a-b, b-a *)
let difference (a: 'a inventory) (b: 'a inventory) =
assert(valid a); assert(valid b);
let rec loop 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
loop ta b (ha::r) x
else if pa > pb then
loop a tb r (hb::x)
else if qa < qb then
loop ta tb r ((pa,qb-qa)::x)
else if qa > qb then
loop ta tb ((pa,qa-qb)::r) x
else
loop ta tb r x
in (loop a b [] []: 'a inventory * 'a inventory);;

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

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

let rec includes (a: 'a inventory) (b: 'a inventory) =
assert(valid a); assert(valid b);
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) =
assert(valid a); assert(valid b);
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;;

La multiplication d'un inventaire a par un entier n :

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

La division d'un inventaire a par un inventaire b, renvoie le nombre n de fois que a inclut b ainsi que l'inventaire restant après avoir retranché n × b :

let reduce (a: 'a inventory) (b: 'a inventory) =
assert(valid a); assert(valid b);
let rec loop n a =
if includes a b then
loop (n+1) (minus a b)
else
n,a
in loop 0 a;;

Le nombre total d'articles dans un inventaire a :

let size (a: 'a inventory) =
assert(valid a);
let rec loop a n =
match a with
| [] -> n
| (_,q)::t -> loop t (n+q)
in loop a 0;;

IV-A-3 - 27. Opérations avancées sur les inventaires

La fonction gap calcule l'écart d'un inventaire b par rapport à un inventaire a, cet écart est le couple formé par la taille (size) de a && b et la taille de b - a :

let gap (a: 'a inventory) (b: 'a inventory) =
assert(valid a); assert(valid b);
let rec loop a b c x =
match a,b with
| _,[] -> c,x
| [],_ -> c,x + size b
| (pa,qa)::ta,(pb,qb)::tb ->
if pa < pb then
loop ta b c x
else if pa > pb then
loop a tb c (x+qb)
else if qa <= qb then
loop ta tb (c+qa) (x+qb-qa)
else
loop ta tb (c+qb) (x+qa-qb)
in loop a b 0 0;;

Supposons que l'on cherche à obtenir l'inventaire a, soit let c,x = gap a b alors on peut estimer que le rapport c / x est une bonne approximation de la désirabilité de l'inventaire b. C'est ce rapport que nous allons utiliser pour comparer deux inventaires a et b par rapport à wanted qui désignera l'inventaire recherché.

let compare (wanted: 'a inventory) a b =
assert(valid a); assert(valid b); assert(valid wanted);
let ca,xa = gap wanted a in
let cb,xb = gap 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;;

L'application partielle (compare wanted) nous donne le type suivant :

'a inventory -> 'a inventory -> int

Comme attendu, ce type est un sous-type de la fonction Pervasives.compare, notre fonction compare correspond bien à notre intuition, en particulier elle nous permet d'écrire une fonction fold_max qui renvoie le meilleur inventaire parmi une liste d'inventaires candidats (un catalog).

Un catalog est une liste d'associations qui à chaque clé 'a, associe un 'b inventory, un catalog est valide si tous ses 'b inventory sont valides :

type ('a,'b) catalog = ('a * 'b inventory) list;;

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

Comme il a été dit, la fonction fold_max trouve, dans un catalog, le couple (clé, inventaire) qui se rapproche le mieux de l'inventaire wanted recherché :

let rec fold_max key_init inv_init (wanted: 'b inventory) (cat: ('a,'b) catalog) =
match cat with
| [] -> key_init,inv_init
| (key,inv)::l ->
if compare wanted inv inv_init > 0 then
fold_max key inv wanted l
else
fold_max key_init inv_init wanted l;;

Cette fonction à l'apparence assez obscure n'est en réalité pas bien différente d'une fonction list_max qui renverrait le plus grand élément d'une liste l qui soit supérieur à init :

# let rec list_max init l =
match l with
| [] -> init
| a::l ->
if a > init then
list_max a l
else
list_max init l;;
val list_max : 'a -> 'a list -> 'a = <fun>

C'est un des avantages de la programmation fonctionnelle que, lorsque l'on sait programmer une fonction sur un type élémentaire, alors on a peu d'efforts à fournir pour adapter sa sémantique à un type de données beaucoup plus structuré.

Maintenant que nous connaissons les inventaires et les catalogues, nous en arrivons au problème crucial qui justifie tous ces développements : soit wanted un inventaire recherché, quelle liste d'inventaires faut-il commander (order) dans un catalog pour s'approcher autant que possible de l'inventaire voulu ?

Bien sûr pour répondre à cette question il faut d'abord définir précisément la notion de commande, une commande (order) contient :

- un inventaire des articles (items) commandés dans un catalogue ;

- un inventaire des pièces encore manquantes (missing) après cette commande ;

- un inventaire des pièces en trop (extras) après cette commande.

type ('a,'b) order = {items: 'a inventory; missing: 'b inventory; extras: 'b inventory};;

Ces deux dernières informations tiennent au fait que l'on autorise une marge d'erreur (margin), c'est-à-dire un nombre de pièces indisponibles tel que size missing <= margin.

La fonction collect ci-dessous fournit la fonctionnalité voulue, à partir d'un inventaire et d'un catalogue elle génère une commande (order) qui fournira un inventaire dont le nombre de pièces manquantes sera inférieur à margin :

# let collect (wanted: 'b inventory) (cat: ('a,'b) catalog) margin =
assert(valid_catalog cat);
assert(valid wanted);
assert(0 <= margin && margin < size wanted);
let rec loop wanted cat keys extras =
if size 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"
| (key,inv)::l ->
let key_max,inv_max = fold_max key inv wanted l in
let rest,more = difference wanted inv_max in
loop rest passed (union keys [key_max,1]) (union more extras)
in loop wanted cat [] [];;
val collect : 'a inventory -> ('b, 'a) catalog -> int -> ('b, 'a) order = <fun>

Le type de la fonction semble correspondre, toutefois rien ne vaut un test sur un cas réel et c'est ce que nous allons faire dans le paragraphe suivant.

IV-A-4 - 28. Cas d'usage du module Inventory

Voici quelques photographies d'une création originale en briques legos, un vaisseau de transport nommé "Frégate C.H.O.A.M." :

Dans un premier temps cette construction a été réalisée virtuellement sur ordinateur à l'aide du logiciel gratuit MLCad, un des meilleurs logiciels de modélisation en legos, le résultat de cette modélisation a été sauvegardé au format LDRAW dans le fichier choam_frigate.ldr.

Pour réellement construire cette création avec de vraies briques, on a procédé en deux temps :

- le prix des briques au détail étant assez élevé, on a d'abord acheté 12 boîtes de legos qui fournissent la plus grosse partie de l'inventaire ;

- les dernières briques manquantes ont été achetées au détail sur BrickLink, un site de vente en ligne de briques legos.

Le problème consiste alors à choisir au mieux les boîtes à acheter pour maximiser l'inventaire utile à notre construction tout en minimisant l'inventaire en surplus. Trop de surplus pourrait faire disparaître l'avantage économique de l'achat en gros sur l'achat au détail.

Pour commencer, il va nous falloir spécialiser nos routines d'inventaires, c'est le rôle du module LegoBricks :

module LegoBricks = struct
...
end;;

Les briques legos ont une couleur (color) :

type color =
| Black | Blue | Clear | Green
| OldBrown | OldDkGray | OldGray | Red
| TrBlue | TrGreen | TrRed | TrYellow
| White | Yellow;;

Et aussi un numéro de moulage composé d'un mélange de chiffres et de lettres, nous mettrons ce numéro dans un string et voilà comment nous définissons un inventaire de briques legos :

type brick = string * color;;
type inventory = brick Inventory.t;;

Quelques raccourcis utiles, avant de nous attaquer aux catalogues de modèles legos :

let make l = (Inventory.make l: inventory);;
let size a = Inventory.size a;;

Un modèle lego a un en-tête dans lequel on fera figurer son nom (name), son thème, son année de création (year), une adresse URL où l'on pourra trouver plus d'informations (home), son nombre de pièces et son nombre de mini-figurines (minifigs) :

type header =
{name:string;
theme:string;
year:int;
home:string;
pieces:int;
minifigs:int;
};;

Maintenant nous pouvons définir un modèle lego, un catalogue de modèles legos, et enfin une commande de modèles legos :

type model   = header * inventory;;
type catalog = (header,brick) Inventory.catalog;;
type order   = (header,brick) Inventory.order;;

Bien entendu toutes ces définitions sont accompagnées de quelques mesures élémentaires de vérification, il serait imprudent de manipuler autant de données sans prendre quelques menues précautions :

let valid_header h =
assert(h.year >= 1978);
assert(h.pieces > 0);
assert(h.minifigs >= 0);
true;;
let valid_model (h,p: model) =
assert(valid_header h);
assert(h.pieces = size p);
true;;
let valid_catalog (cat: catalog) =
List.for_all valid_model cat;;

Nous en arrivons enfin à la solution à notre problème, une fonction collect spécialisée dans les modèles en legos :

let collect (wanted: inventory) (cat: catalog) margin =
assert(valid_catalog cat);
(Inventory.collect wanted cat margin: order);;

Il reste à extraire l'inventaire du fichier choam_frigate.ldr, ceci se fait à l'aide de fonctions d'analyse syntaxique que nous verrons dans un chapitre ultérieur, le résultat étant la source du module ChoamFrigate qui rend accessibles le modèle (ChoamFrigate.model), son en-tête (ChoamFrigate.header) et son inventaire (ChoamFrigate.parts) :

module ChoamFrigate = struct

open LegoBricks;;

let parts = make
[
("3900",Black), 1;
("4479",Black), 1;
("3841",Black), 1;
("3962a",Black), 1;
("3957",Black), 8;
("3957",TrRed), 12;
("4873",Black), 2;
("4732",Blue), 4;
("3062b",Blue), 4;
("3062b",TrRed), 12;
("4070",Blue), 16;
("4070",White), 4;
("3004",Blue), 4;
("3004p06",Blue), 4;
("4595",Blue), 2;
("3622",Blue), 4;
("3009",Blue), 8;
("3963",Black), 16;
("3003",Blue), 4;
("3941",Blue), 8;
("3941",White), 4;
("3941",TrYellow), 6;
("3002",Blue), 12;
("3001",Blue), 15;
("3007",Blue), 4;
("3006",Blue), 2;
("3829",Blue), 4;
("4589",TrRed), 4;
("4346",Blue), 4;
("4345a",Blue), 4;
("4740",TrRed), 4;
("4285a",Blue), 4;
("3633",Blue), 4;
("3185",Blue), 2;
("4448",Blue), 4;
("4448",TrYellow), 6;
("3937",Blue), 4;
("3938",Blue), 4;
("4593",Black), 4;
("298",Black), 4;
("4315",Blue), 4;
("4349",Black), 4;
("3876",TrRed), 2;
("3837",Black), 1;
("774",Black), 1;
("4522",Black), 1;
("4006",Black), 1;
("3959",Blue), 4;
("3959",OldGray), 12;
("4215a",TrYellow), 4;
("30116",OldGray), 4;
("2345",White), 8;
("3024",TrGreen), 5;
("3024",TrRed), 21;
("4073",TrGreen), 6;
("4073",TrRed), 18;
("4085b",Blue), 4;
("4085b",White), 14;
("4085a",Blue), 8;
("4085a",White), 2;
("3023",Blue), 24;
("3023",White), 6;
("3794",Blue), 4;
("3839b",White), 4;
("4175",Blue), 4;
("3623",Blue), 12;
("3710",Black), 4;
("3710",Blue), 4;
("4590",Black), 10;
("4590",Blue), 8;
("4590",White), 4;
("4477",White), 2;
("3022",Black), 4;
("3022",Blue), 2;
("3022",OldGray), 4;
("4032",Black), 16;
("4229",Black), 8;
("3021",Blue), 4;
("3021",White), 12;
("3020",Blue), 16;
("3020",White), 4;
("3795",Blue), 12;
("3795",White), 3;
("3034",Blue), 7;
("3034",OldGray), 4;
("3034",White), 12;
("3832",Blue), 12;
("3832",White), 2;
("3032",Blue), 4;
("3032",White), 2;
("3035",Blue), 2;
("3030",Blue), 2;
("3030",White), 2;
("3029",Blue), 2;
("3029",White), 1;
("3958",TrYellow), 2;
("3036",White), 2;
("3033",Blue), 2;
("3028",Blue), 2;
("4151",OldGray), 1;
("6063",Black), 1;
("30363",Blue), 4;
("4286",Blue), 4;
("4287",Blue), 8;
("3747",Blue), 2;
("3747",White), 4;
("3040b",Blue), 4;
("3665",Blue), 8;
("3039",Blue), 8;
("3660",Blue), 10;
("3676",Blue), 4;
("3039p32",Blue), 2;
("3039p32",OldGray), 4;
("3039p05",Blue), 2;
("3039p34",Blue), 2;
("2342",Blue), 4;
("3940",Black), 4;
("4741",Blue), 6;
("4737",Blue), 8;
("4596",Blue), 6;
("4476",Blue), 10;
("4476",White), 4;
("2340",White), 4;
("4746",Black), 4;
("69c01",Blue), 4;
("3703",Blue), 2;
("3070b",Blue), 4;
("3070b",TrRed), 8;
("2412b",OldGray), 8;
("3069bp25",Blue), 2;
("3069b",Blue), 8;
("3069bp06",Blue), 4;
("3068bp07",White), 1;
("3068b",Blue), 4;
("3068b",White), 2;
("3068bp08",White), 2;
("4033",Blue), 4;
("4474",Blue), 2;
("4474",TrYellow), 2;
("3936",Blue), 2;
("3935",Blue), 2;
("3933",Blue), 6;
("3934",Blue), 6;
("3680c01",Blue), 2;
("73590a",Black), 8;
("73590a",White), 2;
("x467",Black), 4;
];;

let header =
{name="CHOAM Frigate";
theme="MOC/SpiceGuid/SYSTEM/Space/Classic";
year=2000;
home="http://pagesperso-orange.fr/tuttisoft";
pieces=size parts;
minifigs=0};;

let model = (header,parts: model);;

end;;

Voilà qui nous donne une première information, le nombre de pièces dans notre modèle :

# ChoamFrigate.header.pieces;;
- : int = 777

A priori pour faciliter notre construction il nous faudrait plutôt des boîtes legos de la famille 'espace', nous utilisons donc nos facilités d'analyse syntaxique pour générer un module LegoSpace qui rend notamment accessible LegoSpace.catalog, le catalogue de toutes les boîtes de lego de l'espace, le résultat est une base de données de plus de 5000 lignes :

module LegoSpace = struct

open LegoBricks;;

let spy_bot =
let spy_bot_parts = make
[
("4070",OldGray), 6;
("4595",Black), 1;
("3941",Black), 2;
("4589",Black), 4;
("3937",Black), 2;
("3938",Black), 2;
("4593",Black), 2;
("298",Black), 2;
("4275",OldGray), 2;
("2429",OldGray), 2;
("2430",OldGray), 2;
("4531",OldGray), 2;
("3959",Black), 1;
("4006",Black), 1;
("4073",TrGreen), 2;
("4085b",Black), 3;
("4085b",OldGray), 2;
("3023",OldGray), 2;
("4623",Black), 1;
("3839b",OldGray), 1;
("3623",Black), 2;
("4590",OldGray), 1;
("3022",OldGray), 2;
("4032",OldGray), 1;
("3021",OldGray), 1;
("3020",OldGray), 1;
("3040b",OldGray), 6;
("3039p34",OldGray), 1;
("3039p23",OldGray), 1;
("3749",OldGray), 2;
("3700",OldGray), 2;
("3069bp25",OldGray), 3;
("3680c01",Black), 1;
]
in let spy_bot_info =
{name="Spy-Bot";
theme="LEGO/SYSTEM/Space/Classic";
year=1987;
home="http://guide.lugnet.com/set/1498_1";
pieces=size spy_bot_parts;
minifigs=0}
in (spy_bot_info,spy_bot_parts: model);;
let set_1498_1= spy_bot;;

let twin_starfire =
let twin_starfire_parts = make
[
("3957",TrRed), 2;
("2436",White), 2;
("4588",TrRed), 2;
("3829",White), 2;
("4597",Blue), 2;
("4589",TrRed), 1;
("2335",White), 2;
("3937",White), 2;
("4593",Black), 2;
("298",White), 2;
("3838",Yellow), 2;
("193b",Yellow), 2;
("3959",Black), 2;
("3626ap01",Yellow), 2;
("970c00",Yellow), 2;
("4349",Blue), 2;
("973p90",Yellow), 2;
("3024",Blue), 4;
("4073",TrGreen), 2;
("4081a",White), 4;
("4085b",White), 2;
("3023",White), 2;
("3623",White), 2;
("3710",White), 8;
("4590",White), 1;
("3666",White), 6;
("3460",White), 2;
("3022",White), 1;
("3020",White), 2;
("3034",Blue), 1;
("3832",Blue), 1;
("2419",White), 2;
("3031",White), 1;
("4871",White), 1;
("4854",White), 1;
("3479",Blue), 1;
("4746",Blue), 1;
("3070b",TrRed), 2;
("3069bp05",White), 3;
("3069bp25",White), 1;
("2432",Blue), 2;
("3069bp06",White), 2;
("4858p90",White), 1;
("2418a",TrBlue), 2;
]
in let twin_starfire_info =
{name="Twin Starfire";
theme="LEGO/SYSTEM/Space/Classic";
year=1987;
home="http://guide.lugnet.com/set/1499_1";
pieces=size twin_starfire_parts;
minifigs=2}
in (twin_starfire_info,twin_starfire_parts: model);;
let set_1499_1 = twin_starfire;;

let space_scooter_1557 =
let space_scooter_parts = make
[
("4598",White), 1;
("4588",Black), 1;
("4595",OldGray), 2;
("4589",TrRed), 2;
("3942b",OldGray), 1;
("3937",OldGray), 1;
("3938",OldGray), 1;
("4593",OldGray), 2;
("298",Blue), 2;
("3838",Red), 1;
("193b",Red), 1;
("3626ap01",Yellow), 1;
("970c00",Red), 1;
("4349",Black), 2;
("973p90",Red), 1;
("3024",Blue), 2;
("3022",OldGray), 1;
("4032",OldGray), 2;
("3020",Blue), 1;
("3936",Blue), 1;
("3935",Blue), 1;
]
in let space_scooter_info =
{name="Space Scooter";
theme="LEGO/SYSTEM/Space/Classic";
year=1986;
home="http://guide.lugnet.com/set/1557_1";
pieces=size space_scooter_parts;
minifigs=1}
in (space_scooter_info,space_scooter_parts: model);;
let set_1557_1 = space_scooter_1557;;

let mobile_command_trailer =
let mobile_command_trailer_parts = make
[
("4589",Blue), 2;
("4589",TrRed), 2;
("4589",TrYellow), 2;
("4593",Black), 4;
("298",OldGray), 4;
("3640",Blue), 1;
("3639",Blue), 1;
("3838",Black), 1;
("3838",Yellow), 1;
("193b",Black), 1;
("193b",Yellow), 1;
("3962a",Black), 1;
("3626ap01",Yellow), 2;
("970c00",Black), 1;
("970c00",Yellow), 1;
("4736",OldGray), 2;
("4006",Black), 1;
("973p90",Black), 1;
("973p90",Yellow), 1;
("3024",TrYellow), 2;
("4073",TrYellow), 2;
("3023",Blue), 4;
("3710",Blue), 4;
("4590",Blue), 2;
("3022",Blue), 4;
("122c01",OldGray), 3;
("3795",Blue), 1;
("3031",Blue), 1;
("4740",TrYellow), 1;
("3040b",Blue), 2;
("2342",OldGray), 4;
("2336p35",Blue), 1;
("4735",OldGray), 2;
("4596",Blue), 1;
("3069bp25",Blue), 1;
("4288",Black), 6;
("4859",Blue), 1;
]
in let mobile_command_trailer_info =
{name="Mobile Command Trailer";
theme="LEGO/SYSTEM/Space/Classic";
year=1986;
home="http://guide.lugnet.com/set/1558_1";
pieces=size mobile_command_trailer_parts;
minifigs=2}
in (mobile_command_trailer_info,mobile_command_trailer_parts: model);;
let set_1558_1 = mobile_command_trailer;;

let lunar_scout =
let lunar_scout_parts = make
[
("4070",OldGray), 2;
("4595",Black), 2;
("4730",OldGray), 1;
("3002",OldGray), 1;
("3001",OldGray), 1;
("4346",OldGray), 2;
("4345a",OldGray), 2;
("4593",Black), 2;
("298",OldGray), 2;
("4315",OldGray), 1;
("73590a",OldGray), 2;
("3838",Blue), 1;
("193b",Blue), 1;
("3959",Black), 1;
("981",Blue), 1;
("982",Blue), 1;
("983",Blue), 2;
("3626ap01",Yellow), 1;
("970c00",Blue), 1;
("4349",Black), 1;
("4479",Black), 1;
("973p90",Blue), 1;
("3024",TrRed), 2;
("4073",TrRed), 2;
("4085a",OldGray), 4;
("3023",OldGray), 5;
("3022",OldGray), 2;
("3020",OldGray), 1;
("4740",TrRed), 2;
("3297p90",OldGray), 1;
("3039",OldGray), 1;
("3660",OldGray), 1;
("3039p32",OldGray), 1;
("2342",Black), 1;
("4735",Black), 1;
("3706",Black), 3;
("3700",OldGray), 1;
("3702",OldGray), 2;
("3713",OldGray), 6;
("3069bp25",OldGray), 1;
("3069b",OldGray), 2;
("4288",Black), 6;
("4474",TrGreen), 1;
]
in let lunar_scout_info =
{name="Lunar Scout";
theme="LEGO/SYSTEM/Space/Classic";
year=1986;
home="http://guide.lugnet.com/set/1580_1";
pieces=size lunar_scout_parts;
minifigs=1}
in (lunar_scout_info,lunar_scout_parts: model);;
let set_1580_1 = lunar_scout;;

let unnamed_1593 =
let unnamed_1593_parts = make
[
("3957",Black), 3;
("3957",OldGray), 3;
("792c02",OldGray), 2;
("3612",OldGray), 8;
("3613",OldGray), 1;
("3956",OldGray), 1;
("3956",White), 4;
("3005",OldGray), 2;
("3005",White), 4;
("3062b",TrGreen), 3;
("3062b",TrRed), 5;
("4070",OldGray), 4;
("3004",OldGray), 2;
("3004",White), 1;
("3004p90",White), 3;
("3622",White), 4;
("3010",White), 4;
("3010p04",White), 4;
("3963",Black), 2;
("3941",OldGray), 3;
("3941",White), 2;
("3829",Black), 1;
("3829",OldGray), 2;
("3942a",Black), 2;
("3942a",OldGray), 3;
("3942a",White), 2;
("3943",Black), 2;
("4221",OldGray), 2;
("4220",OldGray), 1;
("3937",OldGray), 1;
("3937",White), 2;
("3938",OldGray), 1;
("3938",White), 2;
("3831",OldGray), 2;
("3831",White), 2;
("3830",OldGray), 2;
("3830",White), 2;
("3838",Red), 1;
("3838",Yellow), 1;
("4360",Black), 1;
("193a",Red), 1;
("193a",Yellow), 1;
("3962a",Black), 1;
("3959",Black), 2;
("3959",OldGray), 2;
("3626ap01",Yellow), 2;
("970c00",Red), 1;
("970c00",Yellow), 1;
("3900",Black), 1;
("4006",Black), 1;
("973p90",Red), 1;
("973p90",Yellow), 1;
("3024",OldGray), 2;
("3024",Yellow), 2;
("3024",TrRed), 14;
("4081a",OldGray), 4;
("4081a",White), 4;
("4085a",White), 2;
("3023",OldGray), 4;
("3023",White), 4;
("3839b",Black), 3;
("3839b",OldGray), 3;
("4175",Black), 2;
("4175",OldGray), 4;
("3623",OldGray), 6;
("3623",Yellow), 2;
("3710",OldGray), 11;
("3710",White), 6;
("3666",OldGray), 6;
("3666",White), 2;
("3460",OldGray), 6;
("3460",White), 1;
("3022",OldGray), 7;
("3022",White), 1;
("4032",Black), 3;
("4229",OldGray), 2;
("3021",OldGray), 4;
("3020",OldGray), 7;
("3795",OldGray), 1;
("3795",White), 1;
("3034",OldGray), 3;
("3034",White), 1;
("3832",OldGray), 1;
("3032",OldGray), 1;
("3032",White), 4;
("3032",TrBlue), 1;
("3029",OldGray), 2;
("3958",OldGray), 1;
("3960",OldGray), 2;
("4285a",OldGray), 1;
("3298",White), 2;
("3747",OldGray), 4;
("4089",OldGray), 1;
("3298p90",OldGray), 1;
("3298p90",White), 1;
("3939",TrBlue), 1;
("3665",OldGray), 2;
("3039",OldGray), 1;
("3039p34",OldGray), 1;
("3039p34",White), 2;
("3039p23",OldGray), 1;
("3940",Black), 7;
("3479",White), 7;
("3707",Black), 3;
("3702",OldGray), 2;
("3713",OldGray), 6;
("3069b",White), 4;
("3680c01",OldGray), 1;
("4288",Black), 6;
("3856",White), 4;
("3853",White), 2;
("3936",OldGray), 4;
("3935",OldGray), 4;
("3933",OldGray), 1;
("3934",OldGray), 1;
]
in let unnamed_1593_info =
{name="Unnamed #1593";
theme="LEGO/SYSTEM/Space/Classic";
year=1983;
home="http://guide.lugnet.com/set/1593_1";
pieces=size unnamed_1593_parts;
minifigs=2}
in (unnamed_1593_info,unnamed_1593_parts: model);;
let set_1593_1 = unnamed_1593;;

let unnamed_1968 =
let unnamed_1968_parts = make
[
("3957",TrRed), 4;
("3956",Black), 1;
("4598",White), 1;
("4732",Black), 1;
("3062b",TrRed), 2;
("4070",Blue), 2;
("4070",OldGray), 6;
("3004",OldGray), 4;
("3004",White), 2;
("3004p06",OldGray), 2;
("3010",OldGray), 5;
("3010p04",OldGray), 2;
("3009",OldGray), 1;
("3003",OldGray), 2;
("3941",Black), 2;
("3941",White), 1;
("4730",White), 1;
("3006",Black), 1;
("4589",TrRed), 2;
("3937",Blue), 1;
("3938",Blue), 1;
("4213",TrYellow), 2;
("4593",Black), 2;
("298",Black), 2;
("4315",Black), 3;
("73590a",TrYellow), 6;
("3838",Red), 1;
("193b",Red), 1;
("3626ap01",Yellow), 1;
("970c00",Red), 1;
("4349",Black), 2;
("973p90",Red), 1;
("3024",OldGray), 2;
("3024",TrRed), 2;
("4073",TrBlue), 1;
("4073",TrRed), 1;
("3023",Black), 2;
("3023",Blue), 1;
("3023",OldGray), 2;
("3794",Blue), 1;
("3475b",Black), 2;
("3710",Black), 3;
("3710",OldGray), 9;
("4590",Black), 1;
("3460",OldGray), 2;
("3022",OldGray), 7;
("4032",Black), 3;
("4229",Black), 9;
("4600",OldGray), 2;
("3020",OldGray), 3;
("3795",OldGray), 2;
("3832",OldGray), 1;
("3031",OldGray), 1;
("3033",OldGray), 1;
("4740",TrBlue), 1;
("4740",TrGreen), 2;
("4740",TrRed), 2;
("4286",OldGray), 6;
("4287",OldGray), 2;
("3747",Black), 1;
("3747",OldGray), 2;
("3040b",OldGray), 10;
("3039p34",White), 1;
("3039p23",White), 1;
("3037",OldGray), 1;
("4735",Black), 2;
("4735",Blue), 2;
("3940",Black), 3;
("4737",Black), 2;
("3700",Black), 1;
("3069bp25",OldGray), 1;
("3068bp08",OldGray), 2;
("3641",Black), 4;
("4624",OldGray), 4;
("4474",TrGreen), 1;
("3936",OldGray), 2;
("3935",OldGray), 2;
("3933",OldGray), 2;
("3934",OldGray), 2;
]
in let unnamed_1968_info =
{name="Unnamed #1968";
theme="LEGO/SYSTEM/Space/Classic";
year=1985;
home="http://guide.lugnet.com/set/1968_1";
pieces=size unnamed_1968_parts;
minifigs=1}
in (unnamed_1968_info,unnamed_1968_parts: model);;
let set_1968_1 = unnamed_1968;;

let space_shuttle =
let space_shuttle_parts = make
[
("3957",OldGray), 1;
("3062a",TrGreen), 1;
("3963",OldGray), 2;
("3829",OldGray), 2;
("3838",White), 1;
("193a",White), 1;
("3959",OldGray), 1;
("3626ap01",Yellow), 1;
("970c00",White), 1;
("973p90",White), 1;
("3024",OldGray), 2;
("3024",TrRed), 2;
("3023",OldGray), 2;
("3794",OldGray), 1;
("3839a",OldGray), 1;
("3475b",OldGray), 2;
("3623",OldGray), 2;
("3460",OldGray), 1;
("3021",OldGray), 1;
("3020",OldGray), 2;
("3795",OldGray), 3;
("3035",OldGray), 1;
("3298p90",OldGray), 1;
("3039p34",OldGray), 1;
("3479",OldGray), 1;
("3936",OldGray), 2;
("3935",OldGray), 2;
]
in let space_shuttle_info =
{name="Space Shuttle";
theme="LEGO/SYSTEM/Space/Classic";
year=1979;
home="http://guide.lugnet.com/set/442_1";
pieces=size space_shuttle_parts;
minifigs=1}
in (space_shuttle_info,space_shuttle_parts: model);;
let set_442_1 = space_shuttle;;
let set_891_1 = space_shuttle;;

let mobile_tracking_station =
let mobile_tracking_station_parts = make
[
("3957",OldGray), 1;
("3005",OldGray), 2;
("3062a",OldGray), 2;
("3062a",TrGreen), 1;
("3004",OldGray), 4;
("3004p90",OldGray), 2;
("3065",TrYellow), 3;
("3622",OldGray), 2;
("3001",OldGray), 1;
("3788",OldGray), 2;
("3787",OldGray), 2;
("3829",OldGray), 1;
("3937",OldGray), 1;
("3938",OldGray), 1;
("3831",OldGray), 2;
("3830",OldGray), 2;
("3838",OldGray), 1;
("3838",White), 1;
("193a",White), 1;
("3876",Clear), 2;
("3959",OldGray), 1;
("3626ap01",Yellow), 1;
("970c00",White), 1;
("973p90",White), 1;
("3024",TrRed), 1;
("3023",OldGray), 2;
("3794",OldGray), 2;
("3839a",OldGray), 1;
("3710",OldGray), 2;
("3022",OldGray), 2;
("3731",OldGray), 1;
("3730",OldGray), 1;
("122c01",OldGray), 4;
("3021",OldGray), 4;
("3020",OldGray), 2;
("3034",OldGray), 1;
("3960",OldGray), 1;
("3039p23",OldGray), 1;
("3651",OldGray), 1;
("3070b",OldGray), 2;
("3069b",OldGray), 3;
("3680c01",OldGray), 1;
("3641",Black), 8;
]
in let mobile_tracking_station_info =
{name="Mobile Tracking Station";
theme="LEGO/SYSTEM/Space/Classic";
year=1979;
home="http://guide.lugnet.com/set/452_1";
pieces=size mobile_tracking_station_parts;
minifigs=1}
in (mobile_tracking_station_info,mobile_tracking_station_parts: model);;
let set_452_1 = mobile_tracking_station;;
let set_894_1 = mobile_tracking_station;;

let rocket_launcher =
let rocket_launcher_parts = make
[
("3957",OldGray), 1;
("3956",OldGray), 2;
("3062a",TrGreen), 1;
("3963",OldGray), 1;
("3941",Black), 2;
("3941",White), 6;
("3787",OldGray), 5;
("3829",OldGray), 1;
("3942a",Black), 1;
("3942a",White), 1;
("3937",OldGray), 1;
("3938",OldGray), 1;
("3324c01",OldGray), 1;
("3838",Red), 1;
("3838",OldGray), 1;
("3838",White), 1;
("193a",Red), 1;
("193a",White), 1;
("3962a",Black), 1;
("3626ap01",Yellow), 2;
("970c00",Red), 1;
("970c00",White), 1;
("973p90",Red), 1;
("973p90",White), 1;
("3024",OldGray), 2;
("3024",TrRed), 1;
("3023",OldGray), 3;
("3794",Red), 2;
("3794",OldGray), 2;
("3022",OldGray), 1;
("3731",OldGray), 1;
("3730",OldGray), 1;
("122c01",OldGray), 5;
("3020",OldGray), 3;
("3795",OldGray), 3;
("3034",OldGray), 1;
("3960",OldGray), 1;
("3039p23",OldGray), 1;
("3479",OldGray), 2;
("3680c01",OldGray), 1;
("3641",Black), 10;
]
in let rocket_launcher_info =
{name="Rocket Launcher";
theme="LEGO/SYSTEM/Space/Classic";
year=1978;
home="http://guide.lugnet.com/set/462_1";
pieces=size rocket_launcher_parts;
minifigs=2}
in (rocket_launcher_info,rocket_launcher_parts: model);;
let set_462_1 = rocket_launcher;;
let set_897_1 = rocket_launcher;;

let alpha1_rocket_base =
let alpha1_rocket_base_parts = make
[
("3957",OldGray), 3;
("3947",OldGray), 1;
("3956",Blue), 4;
("3956",OldGray), 3;
("3005",Blue), 7;
("3062a",OldGray), 2;
("3062a",TrGreen), 2;
("3062a",TrRed), 3;
("3004",Blue), 7;
("3622",Blue), 1;
("3010",Blue), 2;
("3066",TrYellow), 9;
("3009",Blue), 4;
("3008",Blue), 1;
("3003",Blue), 1;
("3941",Black), 2;
("3941",Blue), 6;
("3941",OldGray), 11;
("3941",White), 8;
("3002",Blue), 1;
("3788",OldGray), 2;
("3787",OldGray), 2;
("3829",Blue), 2;
("3829",OldGray), 2;
("3942a",Black), 1;
("3942a",White), 1;
("3937",OldGray), 1;
("3938",OldGray), 1;
("3149c01",Blue), 1;
("x467",Black), 3;
("3838",Red), 1;
("3838",OldGray), 1;
("3838",White), 2;
("193a",Red), 1;
("193a",White), 2;
("3962a",Black), 2;
("3626ap01",Yellow), 3;
("970c00",Red), 1;
("970c00",White), 2;
("4006",Black), 1;
("973p90",Red), 1;
("973p90",White), 2;
("3024",Blue), 1;
("3024",TrGreen), 4;
("3024",TrRed), 2;
("3023",OldGray), 2;
("3023",Yellow), 2;
("3794",OldGray), 3;
("3839a",OldGray), 8;
("3710",Blue), 2;
("3710",OldGray), 1;
("3710",Yellow), 2;
("3666",Blue), 2;
("3022",OldGray), 1;
("3731",OldGray), 1;
("3730",OldGray), 1;
("122c01",OldGray), 4;
("3020",Blue), 1;
("3020",OldGray), 4;
("3795",OldGray), 1;
("3034",Blue), 1;
("3832",Blue), 2;
("3029",Blue), 1;
("3036",Blue), 1;
("3036",TrYellow), 1;
("3960",OldGray), 1;
("3660p01",Blue), 3;
("3039p34",Blue), 2;
("3039p34",OldGray), 1;
("3039p23",Blue), 1;
("3479",Blue), 4;
("69c01",Blue), 4;
("3680c01",OldGray), 1;
("3641",Black), 8;
]
in let alpha1_rocket_base_info =
{name="Alpha-1 Rocket Base";
theme="LEGO/SYSTEM/Space/Classic";
year=1979;
home="http://guide.lugnet.com/set/483_1";
pieces=size alpha1_rocket_base_parts;
minifigs=3}
in (alpha1_rocket_base_info,alpha1_rocket_base_parts: model);;
let set_483_1 = alpha1_rocket_base;;
let set_920_2 = alpha1_rocket_base;;

let space_cruiser =
let space_cruiser_parts = make
[
("3957",OldGray), 1;
("3956",Blue), 2;
("3062a",TrGreen), 1;
("3004",Blue), 5;
("3004",White), 1;
("3004p90",Blue), 2;
("3004p20",Blue), 2;
("3065",TrYellow), 4;
("3622",Blue), 2;
("3010",Blue), 3;
("3010p924",Blue), 2;
("3066",TrYellow), 2;
("3009",Blue), 1;
("3008",Blue), 2;
("3963",OldGray), 2;
("3003",Blue), 2;
("3941",OldGray), 2;
("3829",OldGray), 2;
("3943a",OldGray), 2;
("3822",White), 1;
("3821",White), 1;
("3430c00",OldGray), 1;
("3937",Blue), 2;
("3938",Blue), 2;
("3831",Blue), 2;
("3830",Blue), 2;
("3838",Red), 1;
("3838",White), 1;
("193a",Red), 1;
("193a",White), 1;
("3959",OldGray), 1;
("3626ap01",Yellow), 2;
("970c00",Red), 1;
("970c00",White), 1;
("4006",Black), 1;
("973p90",Red), 1;
("973p90",White), 1;
("3024",TrGreen), 2;
("3024",TrRed), 2;
("3023",Blue), 8;
("3023",White), 2;
("3839a",OldGray), 1;
("3623",Black), 2;
("3623",Blue), 2;
("3623",OldGray), 2;
("3623",Yellow), 2;
("3710",Blue), 7;
("3666",Blue), 1;
("3666",OldGray), 2;
("3460",Blue), 2;
("3460",OldGray), 2;
("3022",Blue), 2;
("122c01",OldGray), 2;
("3021",Blue), 2;
("3021",OldGray), 4;
("3020",Blue), 6;
("3020",OldGray), 4;
("3020",White), 2;
("3795",OldGray), 1;
("3032",OldGray), 1;
("3030",OldGray), 3;
("3030",TrYellow), 1;
("3958",OldGray), 2;
("3027",OldGray), 1;
("3939",TrYellow), 2;
("3939p91",Blue), 1;
("3665",Blue), 2;
("3660",Blue), 2;
("3039p34",OldGray), 1;
("3039p23",OldGray), 1;
("3940",OldGray), 4;
("3479",Blue), 2;
("3479",OldGray), 4;
("3069b",Blue), 8;
("3068b",Blue), 4;
("3641",Black), 4;
("3933",OldGray), 3;
("3934",OldGray), 3;
]
in let space_cruiser_info =
{name="Space Cruiser";
theme="LEGO/SYSTEM/Space/Classic";
year=1978;
home="http://guide.lugnet.com/set/487_1";
pieces=size space_cruiser_parts;
minifigs=2}
in (space_cruiser_info,space_cruiser_parts: model);;
let set_487_1 = space_cruiser;;
let set_924_1 = space_cruiser;;

let space_command_center =
let space_command_center_parts = make
[
("3957",OldGray), 2;
("3144",OldGray), 2;
("3811",OldGray), 1;
("3947",OldGray), 1;
("3956",OldGray), 1;
("3062a",TrGreen), 1;
("3062a",TrRed), 2;
("3004",Blue), 19;
("3004p90",Blue), 2;
("3004p20",Blue), 1;
("3010",Blue), 1;
("3066",TrYellow), 3;
("3009",Blue), 4;
("3067",TrYellow), 3;
("3754p01",Blue), 1;
("3008",Blue), 5;
("3003",Blue), 3;
("3063",OldGray), 8;
("3941",Blue), 1;
("3941",OldGray), 2;
("3002",Blue), 8;
("3787",OldGray), 2;
("3829",OldGray), 2;
("3937",OldGray), 2;
("3938",OldGray), 2;
("3838",Red), 2;
("3838",OldGray), 2;
("3838",White), 2;
("193a",Red), 2;
("193a",White), 2;
("3962a",Black), 2;
("3959",OldGray), 1;
("3626ap01",Yellow), 4;
("970c00",Red), 2;
("970c00",White), 2;
("973p90",Red), 2;
("973p90",White), 2;
("3023",Blue), 2;
("3023",OldGray), 1;
("3794",OldGray), 5;
("3839a",OldGray), 3;
("3460",Blue), 4;
("3481",Blue), 1;
("122c01",OldGray), 4;
("3021",Blue), 1;
("3021",OldGray), 2;
("3020",OldGray), 4;
("3795",OldGray), 2;
("3036",TrYellow), 2;
("3456",Blue), 1;
("3027",Blue), 1;
("3960",OldGray), 1;
("3961",OldGray), 1;
("3665",Blue), 4;
("3040a",Blue), 6;
("3040a",OldGray), 4;
("3039",OldGray), 5;
("3660",Blue), 4;
("3660p01",Blue), 3;
("3039p34",Blue), 1;
("3039p23",Blue), 3;
("3678",Clear), 2;
("3940",OldGray), 1;
("3479",Blue), 5;
("3703",Blue), 1;
("3680c01",Blue), 1;
("3680c01",OldGray), 3;
("3641",Black), 8;
]
in let space_command_center_info =
{name="Space Command Center";
theme="LEGO/SYSTEM/Space/Classic";
year=1978;
home="http://guide.lugnet.com/set/493_1";
pieces=size space_command_center_parts;
minifigs=4}
in (space_command_center_info,space_command_center_parts: model);;
let set_493_1 = space_command_center;;
let set_926_1 = space_command_center;;

let galaxy_explorer =
let galaxy_explorer_parts = make
[
("3957",OldGray), 2;
("3144",OldGray), 1;
("6099px2",OldGray), 1;
("3947",OldGray), 1;
("3956",Blue), 2;
("3956",OldGray), 3;
("3005",Blue), 6;
("3062a",TrGreen), 1;
("3062a",TrRed), 15;
("3004",Blue), 4;
("3004p90",Blue), 4;
("3004p20",Blue), 2;
("3622",Blue), 10;
("3010",Blue), 10;
("3010p04",Blue), 3;
("3010p928",Blue), 2;
("3066",TrYellow), 7;
("3009",Blue), 1;
("3067",TrYellow), 2;
("3008",Blue), 7;
("3963",OldGray), 2;
("3941",OldGray), 4;
("3001",Blue), 3;
("3829",OldGray), 2;
("3942a",OldGray), 2;
("3943a",OldGray), 7;
("3822",OldGray), 1;
("3821",OldGray), 1;
("3937",Blue), 2;
("3938",Blue), 2;
("3831",Blue), 4;
("3830",Blue), 4;
("3149c01",OldGray), 1;
("3838",Red), 2;
("3838",OldGray), 1;
("3838",White), 2;
("193a",Red), 2;
("193a",White), 2;
("3962a",Black), 2;
("3959",OldGray), 1;
("3626ap01",Yellow), 4;
("970c00",Red), 2;
("970c00",White), 2;
("4006",Black), 1;
("973p90",Red), 2;
("973p90",White), 2;
("3024",Blue), 2;
("3024",TrGreen), 2;
("3024",TrRed), 2;
("3023",Blue), 2;
("3023",OldGray), 2;
("3794",OldGray), 1;
("3839a",OldGray), 4;
("3623",Black), 4;
("3623",Blue), 4;
("3623",Yellow), 8;
("3710",Blue), 6;
("3710",OldGray), 5;
("3666",Blue), 3;
("3666",OldGray), 7;
("3460",Blue), 4;
("3460",OldGray), 6;
("3022",Blue), 2;
("3022",OldGray), 6;
("122c01",OldGray), 2;
("3021",Blue), 2;
("3021",OldGray), 5;
("3020",Blue), 1;
("3020",OldGray), 4;
("3795",Blue), 2;
("3795",OldGray), 5;
("3034",OldGray), 10;
("3832",OldGray), 3;
("3031",OldGray), 2;
("3032",Blue), 4;
("3032",OldGray), 1;
("3035",Blue), 1;
("3035",OldGray), 2;
("3030",OldGray), 3;
("3030",TrYellow), 1;
("3029",OldGray), 2;
("3958",OldGray), 3;
("3028",OldGray), 2;
("3961",OldGray), 1;
("3298",OldGray), 2;
("3297",OldGray), 2;
("3939",TrYellow), 3;
("3939p91",Blue), 1;
("3040b",Blue), 4;
("3665",Blue), 2;
("3039",OldGray), 1;
("3660",Blue), 9;
("3039p34",Blue), 1;
("3039p34",OldGray), 1;
("3039p23",Blue), 1;
("3039p23",OldGray), 1;
("3940",OldGray), 5;
("3479",Blue), 8;
("3479",OldGray), 6;
("3070b",Blue), 2;
("3069b",Blue), 7;
("3641",Black), 4;
("3936",OldGray), 2;
("3935",OldGray), 2;
("3933",OldGray), 4;
("3934",OldGray), 4;
]
in let galaxy_explorer_info =
{name="Galaxy Explorer";
theme="LEGO/SYSTEM/Space/Classic";
year=1979;
home="http://guide.lugnet.com/set/497_1";
pieces=size galaxy_explorer_parts;
minifigs=4}
in (galaxy_explorer_info,galaxy_explorer_parts: model);;
let set_497_1 = galaxy_explorer;;
let set_928_1 = galaxy_explorer;;

let light_sound_sonic_robot =
let light_sound_sonic_robot_parts = make
[
("3957",TrRed), 2;
("792c02",White), 2;
("3612",White), 8;
("3613",White), 2;
("3956",White), 4;
("4598",White), 2;
("4588",TrRed), 2;
("3004p06",White), 1;
("3963",White), 2;
("4589",TrRed), 2;
("4760c01",White), 1;
("4767",White), 1;
("4774c01",White), 1;
("4773",TrGreen), 1;
("4773",TrRed), 1;
("4221",Black), 4;
("4220",White), 2;
("4593",Black), 4;
("298",Black), 4;
("73590a",TrYellow), 2;
("3838",Blue), 1;
("3838",Red), 1;
("193b",Blue), 1;
("193b",Red), 1;
("3626ap01",Yellow), 2;
("970c00",Blue), 1;
("970c00",Red), 1;
("4349",White), 4;
("973p90",Blue), 1;
("973p90",Red), 1;
("3024",TrGreen), 3;
("3024",TrRed), 2;
("4085b",Black), 2;
("3023",White), 5;
("3794",White), 3;
("3623",White), 2;
("4032",Black), 2;
("4229",Black), 4;
("3021",White), 4;
("3795",White), 1;
("3958",Black), 1;
("4286",White), 2;
("4089",Black), 2;
("3040b",White), 2;
("3660p01",White), 1;
("4735",Black), 2;
("3069b",White), 2;
("3069bp06",White), 2;
("3068bp08",White), 2;
("3680c01",Black), 1;
]
in let light_sound_sonic_robot_info =
{name="Light & Sound Sonic Robot";
theme="LEGO/SYSTEM/Space/Classic";
year=1987;
home="http://guide.lugnet.com/set/6750_1";
pieces=size light_sound_sonic_robot_parts;
minifigs=2}
in (light_sound_sonic_robot_info,light_sound_sonic_robot_parts: model);;
let set_6750_1 = light_sound_sonic_robot;;

let light_sound_xt_starship =
let light_sound_xt_starship_parts = make
[
("3957",TrRed), 6;
("3956",White), 4;
("4732",Black), 2;
("3005",White), 2;
("4588",TrRed), 2;
("3004p06",White), 2;
("3004p01",White), 2;
("3622",White), 2;
("3010",White), 2;
("3010p04",White), 2;
("3009",White), 1;
("3008",White), 1;
("3963",Black), 6;
("3003",White), 3;
("4730",White), 1;
("4591",White), 1;
("3002",White), 3;
("3006",White), 1;
("4589",Black), 2;
("4589",White), 1;
("4589",TrRed), 4;
("4760c01",White), 1;
("4767",White), 2;
("4771",White), 1;
("4774c01",White), 1;
("4773",TrGreen), 2;
("4773",TrRed), 2;
("4773",TrYellow), 2;
("4757",White), 1;
("4758",White), 1;
("3937",White), 1;
("3938",White), 1;
("4593",Black), 4;
("298",Black), 4;
("4315",White), 1;
("73590a",Black), 2;
("73590a",TrYellow), 2;
("3838",Yellow), 1;
("193b",Yellow), 1;
("3626ap01",Yellow), 1;
("970c00",Yellow), 1;
("973p90",Yellow), 1;
("4865",White), 4;
("3024",White), 2;
("3024",TrGreen), 2;
("3024",TrRed), 4;
("4081a",White), 4;
("4085b",White), 4;
("3023",Black), 8;
("3023",White), 9;
("3839b",White), 2;
("3022",Black), 1;
("3022",White), 7;
("4032",White), 3;
("4229",Black), 10;
("3021",Black), 1;
("3020",Black), 1;
("3020",White), 5;
("3795",White), 1;
("3031",White), 1;
("4740",TrGreen), 2;
("4740",TrRed), 3;
("3747",White), 6;
("3298p90",White), 1;
("3040b",White), 2;
("3665",White), 6;
("3660",White), 2;
("3039p34",White), 2;
("4735",Black), 2;
("4596",White), 1;
("4476",White), 6;
("4746",Black), 3;
("3700",White), 3;
("3673",OldGray), 1;
("3069bp25",OldGray), 1;
("3069b",White), 1;
("3069bp06",White), 2;
("3068b",White), 2;
("3068bp08",White), 2;
("4474",TrBlue), 1;
("3936",White), 1;
("3935",White), 1;
("4475",White), 1;
]
in let light_sound_xt_starship_info =
{name="Light & Sound XT - Starship";
theme="LEGO/SYSTEM/Space/Classic";
year=1987;
home="http://guide.lugnet.com/set/6780_1";
pieces=size light_sound_xt_starship_parts;
minifigs=1}
in (light_sound_xt_starship_info,light_sound_xt_starship_parts: model);;
let set_6780_1 = light_sound_xt_starship;;

let sonar_transmitting_cruiser =
let sonar_transmitting_cruiser_parts = make
[
("3957",TrRed), 2;
("3956",White), 1;
("4732",Black), 2;
("3005",White), 12;
("4588",TrRed), 2;
("4070",Blue), 2;
("4070",White), 4;
("3004",Blue), 1;
("3004",White), 10;
("4595",Black), 4;
("3622",White), 2;
("3010",White), 3;
("3010p04",White), 2;
("3009",White), 3;
("3963",Black), 1;
("3003",White), 8;
("3941",Black), 2;
("3941",Blue), 1;
("4730",White), 7;
("3002",Black), 2;
("3002",White), 3;
("4589",Black), 4;
("4589",TrRed), 3;
("3943",Black), 1;
("4760c01",White), 1;
("4767",White), 2;
("4771",White), 1;
("4774c01",White), 1;
("4773",TrGreen), 2;
("4773",TrRed), 2;
("4757",White), 2;
("4758",White), 3;
("3633",White), 2;
("3937",White), 1;
("3938",White), 1;
("4213",TrBlue), 2;
("4593",Black), 6;
("298",Black), 6;
("4315",Black), 4;
("4315",White), 1;
("3149c01",White), 1;
("4625",White), 2;
("73590a",Black), 6;
("3838",Red), 1;
("3838",Yellow), 1;
("193b",Red), 1;
("193b",Yellow), 1;
("3962a",Black), 1;
("3959",Black), 1;
("3626ap01",Yellow), 2;
("970c00",Red), 1;
("970c00",Yellow), 1;
("4006",Black), 1;
("973p90",Red), 1;
("973p90",Yellow), 1;
("2345",White), 8;
("4868",White), 2;
("3024",White), 8;
("3024",TrGreen), 4;
("3024",TrRed), 5;
("3024",TrYellow), 2;
("4085b",White), 10;
("3023",Black), 8;
("3023",White), 14;
("3794",White), 3;
("3839b",Black), 1;
("3623",White), 2;
("3710",White), 4;
("4590",Black), 8;
("3666",Black), 2;
("3666",White), 4;
("3460",White), 3;
("3022",White), 15;
("4032",Black), 4;
("122c01",Black), 2;
("3021",White), 17;
("3020",Black), 3;
("3020",White), 5;
("3795",White), 8;
("3034",White), 1;
("3832",White), 1;
("3031",Black), 1;
("3036",Black), 2;
("4740",TrRed), 1;
("4285a",Black), 2;
("3747",Black), 2;
("3040b",White), 3;
("3040px5",White), 2; (* Unofficial part *)
("3660",White), 2;
("3039p32",White), 1;
("3039p05",White), 1;
("3039p23",White), 2;
("2342",Black), 3;
("2342",White), 1;
("4735",Black), 1;
("4735",Blue), 2;
("4476",White), 2;
("2340",Black), 2;
("3700",White), 7;
("3069bp05",White), 4;
("3069b",White), 1;
("3069bp06",White), 6;
("3068b",White), 2;
("3068bp07",White), 2;
("3068bp08",White), 2;
("4288",Black), 4;
("4859",Black), 1;
("4859",White), 1;
("4858p90",White), 1;
("4856",White), 1;
("4474",Black), 2;
("4474",TrBlue), 3;
("3936",White), 1;
("3935",White), 1;
]
in let sonar_transmitting_cruiser_info =
{name="Sonar Transmitting Cruiser";
theme="LEGO/SYSTEM/Space/Classic";
year=1988;
home="http://guide.lugnet.com/set/6783_1";
pieces=size sonar_transmitting_cruiser_parts;
minifigs=2}
in (sonar_transmitting_cruiser_info,sonar_transmitting_cruiser_parts: model);;
let set_6783_1 = sonar_transmitting_cruiser;;

let rocket_sled =
let rocket_sled_parts = make
[
("3957",OldGray), 1;
("3963",Black), 2;
("3829",OldGray), 1;
("3838",White), 1;
("193a",White), 1;
("3962a",Black), 1;
("3959",Black), 1;
("3626ap01",Yellow), 1;
("970c00",White), 1;
("973p90",White), 1;
("4085a",OldGray), 3;
("3023",OldGray), 1;
("3839a",Black), 3;
("3022",OldGray), 1;
("3795",OldGray), 1;
("3960",OldGray), 1;
("3039p34",OldGray), 1;
("3709b",OldGray), 1;
]
in let rocket_sled_info =
{name="Rocket Sled";
theme="LEGO/SYSTEM/Space/Classic";
year=1981;
home="http://guide.lugnet.com/set/6801_1";
pieces=size rocket_sled_parts;
minifigs=1}
in (rocket_sled_info,rocket_sled_parts: model);;
let set_6801_1 = rocket_sled;;

let space_probe =
let space_probe_parts = make
[
("4588",Black), 1;
("4588",White), 1;
("3062b",Black), 1;
("4733",Black), 1;
("4589",White), 1;
("3937",OldGray), 1;
("3938",OldGray), 1;
("4593",Black), 2;
("298",Black), 2;
("3838",Yellow), 1;
("193b",Yellow), 1;
("3626ap01",Yellow), 1;
("970c00",Yellow), 1;
("973p90",Yellow), 1;
("122c01",OldGray), 2;
("3795",OldGray), 1;
("2342",OldGray), 1;
("4735",Black), 2;
("3704",Black), 1;
("3700",OldGray), 1;
("3641",Black), 4;
]
in let space_probe_info =
{name="Space Probe";
theme="LEGO/SYSTEM/Space/Classic";
year=1986;
home="http://guide.lugnet.com/set/6802_1";
pieces=size space_probe_parts;
minifigs=1}
in (space_probe_info,space_probe_parts: model);;
let set_6802_1 = space_probe;;

let space_patrol =
let space_patrol_parts = make
[
("3957",Blue), 1;
("3062b",TrRed), 2;
("3963",Blue), 2;
("3829",Blue), 1;
("3838",White), 1;
("4360",Black), 1;
("193a",White), 1;
("3626ap01",Yellow), 1;
("970c00",White), 1;
("973p90",White), 1;
("3024",Blue), 2;
("4073",TrYellow), 2;
("4081a",Blue), 2;
("3023",Blue), 1;
("3839b",OldGray), 1;
("3034",OldGray), 1;
("4286",Blue), 2;
("3933",OldGray), 1;
("3934",OldGray), 1;
]
in let space_patrol_info =
{name="Space Patrol";
theme="LEGO/SYSTEM/Space/Classic";
year=1983;
home="http://guide.lugnet.com/set/6803_1";
pieces=size space_patrol_parts;
minifigs=1}
in (space_patrol_info,space_patrol_parts: model);;
let set_6803_1 = space_patrol;;

let surface_rover =
let surface_rover_parts = make
[
("4598",Blue), 1;
("4588",OldGray), 1;
("3829",Blue), 1;
("3838",White), 1;
("193b",White), 1;
("3962a",Black), 1;
("3626ap01",Yellow), 1;
("970c00",White), 1;
("4349",OldGray), 2;
("973p90",White), 1;
("4073",TrRed), 2;
("122c01",OldGray), 2;
("3020",Blue), 1;
("4596",Blue), 1;
("3641",Black), 4;
]
in let surface_rover_info =
{name="Surface Rover";
theme="LEGO/SYSTEM/Space/Classic";
year=1984;
home="http://guide.lugnet.com/set/6804_1";
pieces=size surface_rover_parts;
minifigs=1}
in (surface_rover_info,surface_rover_parts: model);;
let set_6804_1 = surface_rover;;

let astro_dasher =
let astro_dasher_parts = make
[
("4598",OldGray), 1;
("3941",Black), 1;
("4589",TrRed), 3;
("4593",Black), 2;
("298",Black), 2;
("3838",Blue), 1;
("4360",Black), 1;
("193b",Blue), 1;
("3626ap01",Yellow), 1;
("970c00",Blue), 1;
("973p90",Blue), 1;
("4073",TrGreen), 2;
("4081a",OldGray), 2;
("4623",OldGray), 1;
("4590",OldGray), 1;
("4032",Black), 2;
("3020",OldGray), 1;
("4740",TrRed), 1;
("4735",Black), 1;
("4596",OldGray), 5;
]
in let astro_dasher_info =
{name="Astro Dasher";
theme="LEGO/SYSTEM/Space/Classic";
year=1985;
home="http://guide.lugnet.com/set/6805_1";
pieces=size astro_dasher_parts;
minifigs=1}
in (astro_dasher_info,astro_dasher_parts: model);;
let set_6805_1 = astro_dasher;;

let surface_hopper =
let surface_hopper_parts = make
[
("4598",OldGray), 1;
("4588",OldGray), 4;
("4588",TrRed), 2;
("4593",Black), 2;
("298",OldGray), 2;
("73590a",TrYellow), 2;
("3838",Red), 1;
("193b",Red), 1;
("3626ap01",Yellow), 1;
("970c00",Red), 1;
("973p90",Red), 1;
("4590",Black), 4;
("4740",TrGreen), 2;
("4735",Black), 1;
]
in let surface_hopper_info =
{name="Surface Hopper";
theme="LEGO/SYSTEM/Space/Classic";
year=1985;
home="http://guide.lugnet.com/set/6806_1";
pieces=size surface_hopper_parts;
minifigs=1}
in (surface_hopper_info,surface_hopper_parts: model);;
let set_6806_1 = surface_hopper;;

let unnamed_6807 =
let unnamed_6807_parts = make
[
("4598",OldGray), 1;
("4588",Black), 3;
("4733",Black), 1;
("4589",TrRed), 1;
("4593",Black), 3;
("298",Black), 1;
("298",OldGray), 2;
("3838",Yellow), 1;
("193b",Yellow), 1;
("3626ap01",Yellow), 1;
("970c00",Yellow), 1;
("4349",OldGray), 2;
("973p90",Yellow), 1;
("3839b",OldGray), 1;
("4229",Black), 2;
("3020",OldGray), 1;
("4740",TrRed), 2;
("4735",Black), 2;
]
in let unnamed_6807_info =
{name="Unnamed #6807";
theme="LEGO/SYSTEM/Space/Classic";
year=1985;
home="http://guide.lugnet.com/set/6807_1";
pieces=size unnamed_6807_parts;
minifigs=1}
in (unnamed_6807_info,unnamed_6807_parts: model);;
let set_6807_1 = unnamed_6807;;

let galaxy_trekkor =
let galaxy_trekkor_parts = make
[
("4598",White), 1;
("4070",White), 2;
("4589",Black), 2;
("4589",TrRed), 1;
("2429",White), 2;
("2430",White), 2;
("73590a",Black), 2;
("3838",Blue), 1;
("193b",Blue), 1;
("3626ap01",Yellow), 1;
("970c00",Blue), 1;
("4349",Black), 1;
("973p90",Blue), 1;
("3023",White), 1;
("3022",White), 1;
("4032",Black), 2;
("3020",White), 2;
("4740",TrRed), 2;
("3039p05",White), 1;
("4596",White), 1;
("3069bp25",White), 1;
("3936",White), 1;
("3935",White), 1;
]
in let galaxy_trekkor_info =
{name="Galaxy Trekkor";
theme="LEGO/SYSTEM/Space/Classic";
year=1987;
home="http://guide.lugnet.com/set/6808_1";
pieces=size galaxy_trekkor_parts;
minifigs=1}
in (galaxy_trekkor_info,galaxy_trekkor_parts: model);;
let set_6808_1 = galaxy_trekkor;;

let xt5_and_droid =
let xt5_and_droid_parts = make
[
("4598",OldGray), 1;
("3062b",Black), 2;
("4070",Black), 2;
("4589",TrRed), 2;
("2433",Black), 2;
("4593",Black), 2;
("298",Black), 2;
("4276",OldGray), 2;
("3838",Blue), 1;
("193b",Blue), 1;
("3962a",Black), 1;
("3626ap01",Yellow), 1;
("970c00",Blue), 1;
("973p90",Blue), 1;
("4073",OldGray), 2;
("4073",TrGreen), 2;
("3023",Black), 2;
("3023",OldGray), 1;
("4590",Black), 1;
("4590",OldGray), 1;
("3022",OldGray), 1;
("4032",Black), 1;
("3021",OldGray), 1;
("3039p05",OldGray), 1;
("4871",OldGray), 2;
("4735",Black), 2;
("3069bp25",OldGray), 1;
]
in let xt5_and_droid_info =
{name="XT-5 And Droid";
theme="LEGO/SYSTEM/Space/Classic";
year=1988;
home="http://guide.lugnet.com/set/6809_1";
pieces=size xt5_and_droid_parts;
minifigs=1}
in (xt5_and_droid_info,xt5_and_droid_parts: model);;
let set_6809_1 = xt5_and_droid;;

let starfire1 =
let starfire1_parts = make
[
("4873",Black), 2;
("4598",White), 1;
("4595",Black), 2;
("4589",TrRed), 2;
("3942b",White), 1;
("4593",Black), 3;
("298",Black), 3;
("3838",Blue), 1;
("4360",Black), 1;
("193b",Blue), 1;
("3626ap01",Yellow), 1;
("970c00",Blue), 1;
("973p90",Blue), 1;
("3024",TrRed), 2;
("3023",White), 2;
("3839b",Black), 1;
("3666",Black), 2;
("3460",White), 1;
("3022",Black), 1;
("3022",White), 3;
("3795",White), 1;
("2342",White), 1;
("2336p36",White), 1;
("3936",White), 1;
("3935",White), 1;
]
in let starfire1_info =
{name="Starfire I";
theme="LEGO/SYSTEM/Space/Classic";
year=1986;
home="http://guide.lugnet.com/set/6820_1";
pieces=size starfire1_parts;
minifigs=1}
in (starfire1_info,starfire1_parts: model);;
let set_6820_1 = starfire1;;

let shovel_buggy =
let shovel_buggy_parts = make
[
("3957",OldGray), 1;
("792c01",OldGray), 1;
("3612",OldGray), 2;
("3613",OldGray), 1;
("3004",OldGray), 1;
("3963",OldGray), 2;
("3829",OldGray), 1;
("3838",White), 1;
("193a",White), 1;
("3962a",Black), 1;
("3626ap01",Yellow), 1;
("970c00",White), 1;
("973p90",White), 1;
("3024",Yellow), 2;
("4085a",OldGray), 1;
("122c01",OldGray), 2;
("3795",OldGray), 1;
("3747",OldGray), 1;
("4089",OldGray), 1;
("3039p34",OldGray), 1;
("3641",Black), 4;
]
in let shovel_buggy_info =
{name="Shovel Buggy";
theme="LEGO/SYSTEM/Space/Classic";
year=1980;
home="http://guide.lugnet.com/set/6821_1";
pieces=size shovel_buggy_parts;
minifigs=1}
in (shovel_buggy_info,shovel_buggy_parts: model);;
let set_6821_1 = shovel_buggy;;

let space_shuttle =
let space_shuttle_parts = make
[
("3957",OldGray), 1;
("792c02",OldGray), 1;
("3612",OldGray), 3;
("3963",Black), 2;
("3829",OldGray), 1;
("4221",OldGray), 2;
("4220",OldGray), 1;
("3838",Red), 1;
("193a",Red), 1;
("3962a",Black), 1;
("3626ap01",Yellow), 1;
("970c00",Red), 1;
("973p90",Red), 1;
("3024",OldGray), 2;
("3024",TrRed), 4;
("4081a",OldGray), 2;
("3794",Black), 2;
("3710",OldGray), 1;
("4229",OldGray), 4;
("3795",OldGray), 1;
]
in let space_shuttle_info =
{name="Space Shuttle";
theme="LEGO/SYSTEM/Space/Classic";
year=1981;
home="http://guide.lugnet.com/set/6822_1";
pieces=size space_shuttle_parts;
minifigs=1}
in (space_shuttle_info,space_shuttle_parts: model);;
let set_6822_1 = space_shuttle;;

let surface_transport =
let surface_transport_parts = make
[
("3957",Black), 1;
("3062b",TrRed), 1;
("4070",OldGray), 2;
("3004",OldGray), 1;
("3829",OldGray), 1;
("4346",OldGray), 1;
("4345a",OldGray), 1;
("3640",OldGray), 1;
("3639",OldGray), 1;
("3838",Yellow), 1;
("193a",Yellow), 1;
("3626ap01",Yellow), 1;
("970c00",Yellow), 1;
("4479",Black), 1;
("973p90",Yellow), 1;
("4085a",OldGray), 2;
("4175",OldGray), 2;
("122c01",OldGray), 2;
("3021",OldGray), 1;
("4288",Black), 4;
]
in let surface_transport_info =
{name="Surface Transport";
theme="LEGO/SYSTEM/Space/Classic";
year=1983;
home="http://guide.lugnet.com/set/6823_1";
pieces=size surface_transport_parts;
minifigs=1}
in (surface_transport_info,surface_transport_parts: model);;
let set_6823_1 = surface_transport;;

let space_dart1 =
let space_dart1_parts = make
[
("3957",OldGray), 2;
("3957",TrRed), 1;
("4598",OldGray), 1;
("4588",Black), 2;
("3062b",TrRed), 1;
("4070",OldGray), 2;
("3941",Black), 1;
("3941",OldGray), 1;
("4591",Black), 1;
("3829",OldGray), 1;
("3942a",OldGray), 1;
("3838",Blue), 1;
("193b",Blue), 1;
("3962a",Black), 1;
("3626ap01",Yellow), 1;
("970c00",Blue), 1;
("4349",Black), 4;
("973p90",Blue), 1;
("3024",TrGreen), 2;
("4073",TrRed), 4;
("4073",TrYellow), 2;
("4085a",OldGray), 2;
("4590",OldGray), 4;
("4032",Black), 2;
("3020",OldGray), 1;
("3795",OldGray), 1;
("4596",OldGray), 4;
("3749",OldGray), 1;
("3700",OldGray), 1;
]
in let space_dart1_info =
{name="Space Dart-I";
theme="LEGO/SYSTEM/Space/Classic";
year=1984;
home="http://guide.lugnet.com/set/6824_1";
pieces=size space_dart1_parts;
minifigs=1}
in (space_dart1_info,space_dart1_parts: model);;
let set_6824_1 = space_dart1;;

let cosmic_comet =
let cosmic_comet_parts = make
[
("3957",TrRed), 1;
("4598",Blue), 1;
("4595",OldGray), 2;
("3941",OldGray), 2;
("4589",TrRed), 4;
("4593",Black), 2;
("298",OldGray), 2;
("73590a",TrYellow), 2;
("3838",White), 1;
("4360",OldGray), 1;
("193b",White), 1;
("3626ap01",Yellow), 1;
("970c00",White), 1;
("973p90",White), 1;
("3024",TrRed), 2;
("4073",TrYellow), 2;
("4623",Blue), 1;
("4590",Blue), 2;
("4590",OldGray), 1;
("4032",OldGray), 1;
("3020",Blue), 1;
("4740",TrRed), 3;
("4735",OldGray), 2;
("4596",Blue), 3;
("3933",Blue), 1;
("3934",Blue), 1;
]
in let cosmic_comet_info =
{name="Cosmic Comet";
theme="LEGO/SYSTEM/Space/Classic";
year=1985;
home="http://guide.lugnet.com/set/6825_1";
pieces=size cosmic_comet_parts;
minifigs=1}
in (cosmic_comet_info,cosmic_comet_parts: model);;
let set_6825_1 = cosmic_comet;;

let crater_crawler =
let crater_crawler_parts = make
[
("3957",OldGray), 1;
("4598",OldGray), 1;
("4732",OldGray), 1;
("4588",TrRed), 1;
("4070",OldGray), 2;
("4595",Black), 1;
("4589",Black), 2;
("4593",Black), 2;
("298",Black), 2;
("3838",Yellow), 1;
("193b",Yellow), 1;
("3626ap01",Yellow), 1;
("970c00",Yellow), 1;
("973p90",Yellow), 1;
("3794",Black), 1;
("3794",OldGray), 2;
("4590",OldGray), 2;
("122c01",OldGray), 2;
("3021",Black), 1;
("4740",TrRed), 2;
("4596",OldGray), 1;
("3069b",Black), 1;
("4288",Black), 4;
]
in let crater_crawler_info =
{name="Crater Crawler";
theme="LEGO/SYSTEM/Space/Classic";
year=1985;
home="http://guide.lugnet.com/set/6826_1";
pieces=size crater_crawler_parts;
minifigs=1}
in (crater_crawler_info,crater_crawler_parts: model);;
let set_6826_1 = crater_crawler;;

let strata_scooter =
let strata_scooter_parts = make
[
("4598",White), 1;
("3001",White), 1;
("4589",TrRed), 1;
("2433",White), 2;
("4593",Black), 2;
("298",Black), 2;
("4276",White), 2;
("2429",White), 2;
("2430",White), 2;
("3838",Blue), 1;
("193b",Blue), 1;
("3626ap01",Yellow), 1;
("970c00",Blue), 1;
("973p90",Blue), 1;
("4073",TrRed), 2;
("3023",Black), 1;
("3023",White), 1;
("4032",Black), 1;
("122c02",Black), 2;
("3020",White), 1;
("4740",TrGreen), 2;
("3747",White), 1;
("2336p90",White), 1;
("4596",White), 2;
("2432",White), 1;
("4084",Black), 4;
]
in let strata_scooter_info =
{name="Strata Scooter";
theme="LEGO/SYSTEM/Space/Classic";
year=1987;
home="http://guide.lugnet.com/set/6827_1";
pieces=size strata_scooter_parts;
minifigs=1}
in (strata_scooter_info,strata_scooter_parts: model);;
let set_6827_1 = strata_scooter;;

let mineral_detector =
let mineral_detector_parts = make
[
("3957",OldGray), 1;
("4083",OldGray), 1;
("3963",OldGray), 2;
("3788",OldGray), 3;
("3829",OldGray), 1;
("3831",OldGray), 2;
("3830",OldGray), 2;
("3838",Red), 1;
("193a",Red), 1;
("3962a",Black), 1;
("3626ap01",Yellow), 1;
("970c00",Red), 1;
("973p90",Red), 1;
("3024",TrGreen), 2;
("3024",TrRed), 4;
("4085a",OldGray), 1;
("3666",OldGray), 2;
("122c01",OldGray), 3;
("3020",OldGray), 2;
("3034",OldGray), 1;
("3960",OldGray), 2;
("3040b",OldGray), 2;
("3039p34",OldGray), 1;
("3641",Black), 6;
]
in let mineral_detector_info =
{name="Mineral Detector";
theme="LEGO/SYSTEM/Space/Classic";
year=1980;
home="http://guide.lugnet.com/set/6841_1";
pieces=size mineral_detector_parts;
minifigs=1}
in (mineral_detector_info,mineral_detector_parts: model);;
let set_6841_1 = mineral_detector;;

let shuttle_craft =
let shuttle_craft_parts = make
[
("3957",Black), 3;
("3956",White), 1;
("3004",White), 3;
("3963",Black), 2;
("3829",White), 1;
("3943a",Black), 1;
("3838",Red), 1;
("193a",Red), 1;
("3626ap01",Yellow), 1;
("970c00",Red), 1;
("973p90",Red), 1;
("3024",OldGray), 2;
("3024",TrRed), 2;
("4081a",White), 2;
("3023",OldGray), 2;
("3023",White), 2;
("3839a",Black), 1;
("4175",Black), 2;
("3710",OldGray), 1;
("4229",OldGray), 4;
("3020",White), 1;
("3034",White), 1;
("3832",OldGray), 1;
("3298",White), 2;
("3298p90",White), 1;
("3040b",White), 2;
("3936",OldGray), 1;
("3935",OldGray), 1;
("3933",OldGray), 1;
("3934",OldGray), 1;
]
in let shuttle_craft_info =
{name="Shuttle Craft";
theme="LEGO/SYSTEM/Space/Classic";
year=1981;
home="http://guide.lugnet.com/set/6842_1";
pieces=size shuttle_craft_parts;
minifigs=1}
in (shuttle_craft_info,shuttle_craft_parts: model);;
let set_6842_1 = shuttle_craft;;

let seismologic_vehicle =
let seismologic_vehicle_parts = make
[
("3957",OldGray), 1;
("3062b",OldGray), 2;
("3062b",TrRed), 2;
("3004",Blue), 2;
("3829",OldGray), 1;
("3829",White), 1;
("4346",Blue), 2;
("4345a",Blue), 2;
("4275",Blue), 1;
("4276",Blue), 1;
(* ("x1125",Blue), 1; Unofficial part *)
(* ("x1126",Blue), 1; Unofficial part *)
("3640",OldGray), 1;
("3639",OldGray), 1;
("193a",White), 1;
("3626ap01",Yellow), 1;
("970c00",White), 1;
("4479",OldGray), 2;
("973p90",White), 1;
("3024",Blue), 1;
("4085a",OldGray), 2;
("3023",OldGray), 2;
("3794",Blue), 5;
("3839b",OldGray), 1;
("3710",Blue), 1;
("3022",Blue), 1;
("122c01",OldGray), 2;
("3795",Blue), 1;
("4285a",OldGray), 1;
("3747",Blue), 1;
("4476",Blue), 1;
("4288",Black), 4;
]
in let seismologic_vehicle_info =
{name="Seismologic Vehicle";
theme="LEGO/SYSTEM/Space/Classic";
year=1983;
home="http://guide.lugnet.com/set/6844_1";
pieces=size seismologic_vehicle_parts;
minifigs=1}
in (seismologic_vehicle_info,seismologic_vehicle_parts: model);;
let set_6844_1 = seismologic_vehicle;;

let cosmic_charger =
let cosmic_charger_parts = make
[
("3957",TrRed), 2;
("4598",Blue), 1;
("4588",Black), 2;
("4595",Black), 2;
("3963",Black), 2;
("4589",TrRed), 3;
("3937",Blue), 3;
("3938",Blue), 3;
("4593",OldGray), 2;
("298",Blue), 2;
("3838",White), 1;
("193b",White), 1;
("3626ap01",Yellow), 1;
("970c00",White), 1;
("973p90",White), 1;
("4073",TrRed), 2;
("3023",White), 4;
("3623",Blue), 2;
("4590",Blue), 1;
("3666",White), 2;
("3022",Blue), 1;
("3022",White), 1;
("3021",Blue), 1;
("3795",White), 2;
("4854",White), 1;
("2342",Blue), 1;
("4596",Blue), 1;
("2340",Blue), 2;
("3069bp06",Blue), 2;
("4855",White), 1;
("4447",White), 1;
("4475",Blue), 1;
]
in let cosmic_charger_info =
{name="Cosmic Charger";
theme="LEGO/SYSTEM/Space/Classic";
year=1986;
home="http://guide.lugnet.com/set/6845_1";
pieces=size cosmic_charger_parts;
minifigs=1}
in (cosmic_charger_info,cosmic_charger_parts: model);;
let set_6845_1 = cosmic_charger;;

let tri_star_voyager =
let tri_star_voyager_parts = make
[
("3957",Blue), 2;
("3957",TrRed), 2;
("4588",White), 3;
("3062b",Blue), 4;
("4070",Blue), 2;
("3829",Blue), 1;
("3937",White), 2;
("3938",White), 2;
("3838",Red), 1;
("193b",Red), 1;
("3959",Blue), 2;
("3626ap01",Yellow), 1;
("970c00",Red), 1;
("4349",White), 2;
("973p90",Red), 1;
("3024",TrRed), 2;
("4073",TrRed), 2;
("4081a",Blue), 2;
("4081a",White), 2;
("4085a",Blue), 2;
("4085a",White), 2;
("3023",Blue), 1;
("3794",Blue), 1;
("3839b",Blue), 1;
("3839b",White), 2;
("3710",Blue), 2;
("3710",White), 2;
("4590",Blue), 1;
("3666",Blue), 2;
("4032",White), 2;
("3020",Blue), 1;
("3020",White), 1;
("3795",Blue), 1;
("3034",Blue), 1;
("4286",White), 2;
("4596",Blue), 5;
("4596",White), 2;
("4162",Blue), 2;
("4475",Blue), 1;
]
in let tri_star_voyager_info =
{name="Tri-Star Voyager";
theme="LEGO/SYSTEM/Space/Classic";
year=1984;
home="http://guide.lugnet.com/set/6846_1";
pieces=size tri_star_voyager_parts;
minifigs=1}
in (tri_star_voyager_info,tri_star_voyager_parts: model);;
let set_6846_1 = tri_star_voyager;;

let space_dozer =
let space_dozer_parts = make
[
("4598",OldGray), 1;
("4588",TrRed), 2;
("4589",TrRed), 2;
("4315",OldGray), 1;
("73590a",Black), 2;
("3838",Yellow), 1;
("4360",Black), 1;
("193b",Yellow), 1;
("3962a",Black), 1;
("3626ap01",Yellow), 1;
("970c00",Yellow), 1;
("3841",Black), 1;
("973p90",Yellow), 1;
("3024",Yellow), 4;
("4081a",OldGray), 2;
("4085a",OldGray), 2;
("3794",OldGray), 1;
("3710",OldGray), 2;
("4590",OldGray), 1;
("3021",OldGray), 1;
("3032",OldGray), 1;
("4740",TrGreen), 1;
("3039p32",OldGray), 1;
("3039p34",OldGray), 1;
("4735",Black), 1;
("4596",OldGray), 1;
("3706",Black), 1;
("3749",OldGray), 4;
("3894",OldGray), 2;
("3713",OldGray), 2;
("4288",Black), 4;
("4474",OldGray), 1;
]
in let space_dozer_info =
{name="Space Dozer";
theme="LEGO/SYSTEM/Space/Classic";
year=1985;
home="http://guide.lugnet.com/set/6847_1";
pieces=size space_dozer_parts;
minifigs=1}
in (space_dozer_info,space_dozer_parts: model);;
let set_6847_1 = space_dozer;;

let interplanetary_shuttle =
let interplanetary_shuttle_parts = make
[
("3957",TrRed), 1;
("4598",OldGray), 1;
("4588",Black), 2;
("3829",OldGray), 1;
("4589",TrRed), 1;
("4346",OldGray), 2;
("4345a",OldGray), 2;
("3838",Red), 1;
("193b",Red), 1;
("3626ap01",Yellow), 1;
("970c00",Red), 1;
("4349",OldGray), 2;
("4479",Black), 1;
("4522",Black), 1;
("973p90",Red), 1;
("4073",TrGreen), 2;
("4073",TrRed), 2;
("4085a",OldGray), 2;
("3023",OldGray), 1;
("4175",Black), 2;
("4590",Black), 4;
("3666",OldGray), 1;
("3022",OldGray), 2;
("4032",Black), 2;
("3021",OldGray), 1;
("3020",OldGray), 1;
("3034",OldGray), 1;
("3832",OldGray), 1;
("4740",TrGreen), 2;
("4285a",OldGray), 1;
("3660",OldGray), 1;
("3039p32",OldGray), 2;
("4460",OldGray), 2;
("4596",OldGray), 3;
("3933",OldGray), 1;
("3934",OldGray), 1;
]
in let interplanetary_shuttle_info =
{name="Interplanetary Shuttle";
theme="LEGO/SYSTEM/Space/Classic";
year=1985;
home="http://guide.lugnet.com/set/6848_2";
pieces=size interplanetary_shuttle_parts;
minifigs=1}
in (interplanetary_shuttle_info,interplanetary_shuttle_parts: model);;
let set_6848_2 = interplanetary_shuttle;;

let satellite_patroller =
let satellite_patroller_parts = make
[
("3957",TrRed), 2;
("4598",White), 1;
("4070",Black), 2;
("3001",White), 1;
("3829",White), 1;
("4589",TrRed), 1;
("4593",Black), 1;
("298",Black), 1;
("2429",Black), 2;
("2430",Black), 2;
("3640",Black), 1;
("3639",Black), 1;
("3838",Yellow), 1;
("193b",Yellow), 1;
("3626ap01",Yellow), 1;
("970c00",Yellow), 1;
("973p90",Yellow), 1;
("4865",White), 1;
("4073",TrGreen), 2;
("4073",TrRed), 2;
("3794",Black), 2;
("4590",Black), 1;
("3022",White), 1;
("122c02",Black), 2;
("3021",Black), 1;
("2419",White), 2;
("4740",White), 2;
("4740",TrGreen), 2;
("3039p32",White), 1;
("3039p34",White), 1;
("2336p90",White), 1;
("4596",White), 2;
("4746",White), 1;
("3068bp08",White), 1;
("4084",Black), 4;
]
in let satellite_patroller_info =
{name="Satellite Patroller";
theme="LEGO/SYSTEM/Space/Classic";
year=1987;
home="http://guide.lugnet.com/set/6849_1";
pieces=size satellite_patroller_parts;
minifigs=1}
in (satellite_patroller_info,satellite_patroller_parts: model);;
let set_6849_1 = satellite_patroller;;

let x1_patrol_craft =
let x1_patrol_craft_parts = make
[
("3957",OldGray), 2;
("3956",OldGray), 4;
("3062b",TrRed), 2;
("3004",OldGray), 2;
("3065",TrGreen), 1;
("3963",OldGray), 2;
("3941",OldGray), 8;
("3829",OldGray), 1;
("3942a",OldGray), 2;
("3943a",OldGray), 2;
("3838",Red), 1;
("193a",Red), 1;
("3959",OldGray), 2;
("3626ap01",Yellow), 1;
("970c00",Red), 1;
("973p90",Red), 1;
("3024",OldGray), 2;
("3024",TrRed), 2;
("3839a",OldGray), 1;
("3021",OldGray), 1;
("3034",OldGray), 2;
("3832",OldGray), 1;
("3032",OldGray), 1;
("3036",OldGray), 1;
("3298p90",OldGray), 1;
("3039",OldGray), 1;
("3940",OldGray), 4;
("3479",OldGray), 1;
("3933",OldGray), 2;
("3934",OldGray), 2;
]
in let x1_patrol_craft_info =
{name="X-1 Patrol Craft";
theme="LEGO/SYSTEM/Space/Classic";
year=1980;
home="http://guide.lugnet.com/set/6861_1";
pieces=size x1_patrol_craft_parts;
minifigs=1}
in (x1_patrol_craft_info,x1_patrol_craft_parts: model);;
let set_6861_1 = x1_patrol_craft;;

let space_probe_launcher =
let space_probe_launcher_parts = make
[
("3957",Black), 2;
("3957",OldGray), 2;
("3956",OldGray), 1;
("3622",White), 2;
("3963",Black), 2;
("3963",OldGray), 2;
("3829",OldGray), 1;
("3829",White), 1;
("3640",OldGray), 1;
("3639",OldGray), 1;
("3324c01",OldGray), 1;
("3838",Red), 1;
("193a",Red), 1;
("3626ap01",Yellow), 1;
("970c00",Red), 1;
("973p90",Red), 1;
("3024",TrGreen), 2;
("3024",TrRed), 2;
("4081a",OldGray), 2;
("4081a",White), 4;
("3023",OldGray), 2;
("4175",OldGray), 1;
("122c01",OldGray), 3;
("3020",OldGray), 3;
("3034",OldGray), 1;
("3034",White), 1;
("3031",OldGray), 1;
("3298p90",White), 1;
("3040b",White), 2;
("3665",White), 2;
("3068b",OldGray), 4;
("4084",Black), 6;
("3933",White), 1;
("3934",White), 1;
]
in let space_probe_launcher_info =
{name="Space Probe Launcher";
theme="LEGO/SYSTEM/Space/Classic";
year=1981;
home="http://guide.lugnet.com/set/6870_1";
pieces=size space_probe_launcher_parts;
minifigs=1}
in (space_probe_launcher_info,space_probe_launcher_parts: model);;
let set_6870_1 = space_probe_launcher;;

let star_patrol_launcher =
let star_patrol_launcher_parts = make
[
("4598",Blue), 1;
("4588",OldGray), 2;
("3004",OldGray), 1;
("3941",OldGray), 2;
("3829",Blue), 1;
("3829",OldGray), 1;
("3937",OldGray), 1;
("3938",OldGray), 1;
("3838",Red), 1;
("3838",White), 1;
("4360",Black), 1;
("193b",Red), 1;
("193b",White), 1;
("3626ap01",Yellow), 2;
("970c00",Red), 1;
("970c00",White), 1;
("4349",Black), 2;
("4349",OldGray), 2;
("973p90",Red), 1;
("973p90",White), 1;
("4073",TrGreen), 2;
("4073",TrRed), 2;
("4073",TrYellow), 4;
("3023",OldGray), 1;
("3794",Blue), 1;
("3794",OldGray), 1;
("3710",Blue), 1;
("4590",OldGray), 2;
("3022",OldGray), 3;
("122c01",OldGray), 3;
("3020",OldGray), 1;
("3795",OldGray), 1;
("3034",OldGray), 1;
("3747",Blue), 1;
("3665",Blue), 2;
("3039p23",OldGray), 1;
("4596",Blue), 1;
("4596",OldGray), 1;
("3749",Black), 2;
("3701",Blue), 1;
("3701",OldGray), 1;
("3069b",OldGray), 1;
("3068b",OldGray), 2;
("3680c01",OldGray), 1;
("4288",Black), 6;
("3936",Blue), 1;
("3935",Blue), 1;
]
in let star_patrol_launcher_info =
{name="Star Patrol Launcher";
theme="LEGO/SYSTEM/Space/Classic";
year=1984;
home="http://guide.lugnet.com/set/6871_1";
pieces=size star_patrol_launcher_parts;
minifigs=2}
in (star_patrol_launcher_info,star_patrol_launcher_parts: model);;
let set_6871_1 = star_patrol_launcher;;

let lunar_patrol_craft =
let lunar_patrol_craft_parts = make
[
("3957",TrRed), 2;
("3957",TrYellow), 2;
("4732",OldGray), 1;
("4070",OldGray), 2;
("4733",OldGray), 1;
("3004",OldGray), 2;
("3010",OldGray), 2;
("3963",OldGray), 2;
("4591",Black), 1;
("4589",TrYellow), 4;
("3189",Blue), 1;
("3188",Blue), 1;
("3937",OldGray), 1;
("3938",Black), 1;
("4593",Black), 2;
("298",Black), 2;
("4276a",Blue), 2;
("4275a",Blue), 2;
("4315",OldGray), 1;
("73590a",Black), 2;
("3838",Yellow), 1;
("193b",Yellow), 1;
("3626ap01",Yellow), 1;
("970c00",Yellow), 1;
("973p90",Yellow), 1;
("3024",OldGray), 2;
("4081a",Blue), 4;
("4085a",OldGray), 2;
("3023",Blue), 1;
("3023",OldGray), 3;
("3794",Black), 1;
("4590",OldGray), 1;
("3666",Blue), 2;
("3021",Blue), 1;
("3020",Blue), 3;
("3795",OldGray), 1;
("4740",TrRed), 2;
("3747",OldGray), 3;
("4735",Black), 4;
("4746",OldGray), 1;
("3069bp25",Blue), 1;
("3069bp06",Blue), 2;
("3068b",OldGray), 1;
("4474",TrYellow), 1;
("3933",Blue), 1;
("3934",Blue), 1;
("4475",Blue), 1;
]
in let lunar_patrol_craft_info =
{name="Lunar Patrol Craft";
theme="LEGO/SYSTEM/Space/Classic";
year=1986;
home="http://guide.lugnet.com/set/6872_1";
pieces=size lunar_patrol_craft_parts;
minifigs=1}
in (lunar_patrol_craft_info,lunar_patrol_craft_parts: model);;
let set_6872_1 = lunar_patrol_craft;;

let moonrover =
let moonrover_parts = make
[
("4598",Blue), 1;
("4598",White), 1;
("4588",Black), 1;
("4595",White), 2;
("3003",Blue), 2;
("3829",Blue), 1;
("4589",Blue), 2;
("4589",TrRed), 2;
("3185",Blue), 2;
("4593",Black), 2;
("298",Black), 2;
("3640",Blue), 1;
("3639",Blue), 1;
("73590a",White), 1;
("3838",Red), 1;
("3838",Yellow), 1;
("193b",Red), 1;
("193b",Yellow), 1;
("3959",White), 2;
("3626ap01",Yellow), 2;
("970c00",Red), 1;
("970c00",Yellow), 1;
("4349",White), 2;
("973p90",Red), 1;
("973p90",Yellow), 1;
("3023",White), 1;
("3839b",White), 3;
("4590",White), 4;
("3022",Blue), 1;
("4032",Black), 2;
("122c01",OldGray), 2;
("3020",Blue), 1;
("3795",White), 1;
("4740",TrRed), 2;
("4740",TrYellow), 2;
("3298",Blue), 4;
("3039",Blue), 2;
("2342",White), 1;
("2336p35",Blue), 1;
("3940",White), 1;
("4288",Black), 4;
("4859",White), 1;
]
in let moonrover_info =
{name="Moonrover";
theme="LEGO/SYSTEM/Space/Classic";
year=1986;
home="http://guide.lugnet.com/set/6874_1";
pieces=size moonrover_parts;
minifigs=2}
in (moonrover_info,moonrover_parts: model);;
let set_6874_1 = moonrover;;

let surface_explorer =
let surface_explorer_parts = make
[
("3957",Black), 1;
("3957",OldGray), 2;
("792c02",OldGray), 2;
("3612",OldGray), 8;
("3613",OldGray), 1;
("3956",OldGray), 1;
("3062b",TrRed), 2;
("3829",OldGray), 2;
("4221",OldGray), 2;
("4220",OldGray), 1;
("3838",Yellow), 1;
("4360",Black), 1;
("193a",Yellow), 1;
("3959",Black), 1;
("3626ap01",Yellow), 1;
("970c00",Yellow), 1;
("4006",Black), 1;
("973p90",Yellow), 1;
("3024",Yellow), 2;
("4081a",OldGray), 4;
("3839a",Black), 2;
("3839a",OldGray), 2;
("4175",OldGray), 4;
("3020",OldGray), 2;
("3832",OldGray), 2;
("3032",OldGray), 1;
("4285a",OldGray), 1;
("4089",OldGray), 1;
("3298p90",OldGray), 1;
("3039",OldGray), 1;
("3039p34",OldGray), 1;
("3039p23",OldGray), 1;
("3940",Black), 3;
("3707",Black), 3;
("3702",OldGray), 2;
("3713",OldGray), 6;
("3680c01",OldGray), 1;
("4288",Black), 12;
]
in let surface_explorer_info =
{name="Surface Explorer";
theme="LEGO/SYSTEM/Space/Classic";
year=1982;
home="http://guide.lugnet.com/set/6880_1";
pieces=size surface_explorer_parts;
minifigs=1}
in (surface_explorer_info,surface_explorer_parts: model);;
let set_6880_1 = surface_explorer;;

let lunar_rocket_launcher =
let lunar_rocket_launcher_parts = make
[
("4588",OldGray), 1;
("3062b",Black), 4;
("4070",Blue), 2;
("3004p06",Blue), 2;
("3010",Blue), 2;
("3941",Black), 4;
("3941",White), 3;
("4591",White), 2;
("3829",Blue), 1;
("3942a",White), 1;
("4276a",Black), 2;
("4275a",Black), 2;
("3640",Blue), 1;
("3639",Blue), 1;
("3324c01",Blue), 1;
("x467",Black), 2;
("3838",White), 1;
("4360",Black), 1;
("193b",White), 1;
("3962a",Black), 1;
("3876",TrRed), 1;
("3959",OldGray), 3;
("3626ap01",Yellow), 1;
("970c00",White), 1;
("973p90",White), 1;
("4073",TrRed), 2;
("4073",TrYellow), 4;
("4081a",Blue), 4;
("4085a",Blue), 4;
("3023",Black), 1;
("3023",Blue), 3;
("3839b",OldGray), 1;
("3710",Blue), 2;
("4590",Blue), 3;
("3666",Blue), 1;
("122c01",OldGray), 4;
("3020",Blue), 2;
("3795",Blue), 2;
("3034",Blue), 1;
("4286",Blue), 2;
("4287",Blue), 4;
("3039p34",Blue), 1;
("4596",White), 2;
("3737",Black), 1;
("3070b",TrRed), 2;
("4162",Blue), 2;
("4288",Black), 8;
]
in let lunar_rocket_launcher_info =
{name="Lunar Rocket Launcher";
theme="LEGO/SYSTEM/Space/Classic";
year=1984;
home="http://guide.lugnet.com/set/6881_1";
pieces=size lunar_rocket_launcher_parts;
minifigs=1}
in (lunar_rocket_launcher_info,lunar_rocket_launcher_parts: model);;
let set_6881_1 = lunar_rocket_launcher;;

let walking_astro_grappler =
let walking_astro_grappler_parts = make
[
("792c02",OldGray), 1;
("3612",OldGray), 7;
("4598",Blue), 1;
("4732",Blue), 2;
("3062b",Blue), 4;
("3622",Blue), 2;
("3829",Blue), 1;
("4589",TrRed), 4;
("4346",Blue), 2;
("4345a",Blue), 2;
("4221",Black), 2;
("4220",Black), 1;
("4593",Black), 2;
("298",Black), 2;
("4625",Blue), 2;
("73590a",TrYellow), 2;
("3838",Black), 1;
("193b",Black), 1;
("3626ap01",Yellow), 1;
("970c00",Black), 1;
("973p90",Black), 1;
("3024",Blue), 2;
("3710",Blue), 1;
("4590",Blue), 2;
("3460",Blue), 1;
("3022",Blue), 4;
("3020",Blue), 1;
("3034",Blue), 5;
("3034",OldGray), 3;
("4740",OldGray), 2;
("3040b",Blue), 2;
("4735",OldGray), 2;
("4476",OldGray), 4;
("3894",Blue), 2;
("4274",OldGray), 2;
("3069b",Blue), 5;
("4162",OldGray), 2;
("3680c01",Blue), 10;
("4474",Blue), 1;
("4474",TrYellow), 1;
]
in let walking_astro_grappler_info =
{name="Walking Astro Grappler";
theme="LEGO/SYSTEM/Space/Classic";
year=1985;
home="http://guide.lugnet.com/set/6882_1";
pieces=size walking_astro_grappler_parts;
minifigs=1}
in (walking_astro_grappler_info,walking_astro_grappler_parts: model);;
let set_6882_1 = walking_astro_grappler;;

let terrestrial_rover =
let terrestrial_rover_parts = make
[
("3957",TrRed), 4;
("4588",TrRed), 1;
("3062b",Black), 2;
("3062b",Blue), 1;
("3062b",White), 1;
("3004",Black), 2;
("3004",Blue), 2;
("3004",White), 1;
("4595",Black), 4;
("4595",Blue), 1;
("3963",White), 2;
("3941",White), 1;
("2433",Black), 2;
("4593",Black), 2;
("298",Black), 2;
("4276",Blue), 2;
("2429",Blue), 4;
("2430",Blue), 4;
("3640",Blue), 1;
("3639",Blue), 1;
("3838",White), 1;
("193b",White), 1;
("3962a",Black), 1;
("3626ap01",Yellow), 1;
("970c00",White), 1;
("4006",Black), 1;
("973p90",White), 1;
("3024",TrRed), 2;
("3024",TrYellow), 4;
("4085b",Black), 2;
("3023",Black), 2;
("3023",Blue), 5;
("3023",White), 2;
("3794",White), 5;
("3839b",White), 2;
("3710",Blue), 5;
("4590",Blue), 3;
("2420",Blue), 4;
("122c02",Black), 4;
("3021",Blue), 1;
("3795",Blue), 1;
("4282",Blue), 1;
("2419",Blue), 2;
("4740",White), 4;
("4740",TrRed), 2;
("3960",White), 2;
("3040b",Blue), 2;
("4476",Blue), 2;
("2340p90",Blue), 1;
("3068b",Black), 1;
("4084",Black), 8;
("2399",Blue), 1;
]
in let terrestrial_rover_info =
{name="Terrestrial Rover";
theme="LEGO/SYSTEM/Space/Classic";
year=1987;
home="http://guide.lugnet.com/set/6883_1";
pieces=size terrestrial_rover_parts;
minifigs=1}
in (terrestrial_rover_info,terrestrial_rover_parts: model);;
let set_6883_1 = terrestrial_rover;;

let cosmic_cruiser =
let cosmic_cruiser_parts = make
[
("3957",Black), 2;
("3957",OldGray), 2;
("3956",Black), 1;
("3062b",TrGreen), 2;
("3004",Blue), 2;
("3004",White), 1;
("3004p06",OldGray), 1;
("3065",TrBlue), 2;
("3622",White), 2;
("3010p04",Blue), 2;
("3963",OldGray), 2;
("3941",Black), 2;
("4212",White), 1;
("3829",White), 1;
("3943",Black), 1;
("3937",Blue), 1;
("3938",OldGray), 1;
("4213",TrBlue), 1;
("4315",Blue), 1;
("3838",Red), 1;
("193a",Red), 1;
("3626ap01",Yellow), 1;
("970c00",Red), 1;
("973p90",Red), 1;
("3024",White), 4;
("3024",TrRed), 4;
("4073",TrRed), 2;
("4081a",White), 4;
("4085a",OldGray), 2;
("3023",Blue), 4;
("3023",OldGray), 1;
("3023",White), 7;
("3839a",Black), 1;
("3839a",White), 1;
("4175",OldGray), 2;
("3623",White), 4;
("3710",Blue), 1;
("3710",White), 4;
("3666",Blue), 1;
("3460",Blue), 1;
("3460",White), 2;
("3022",White), 4;
("4229",Black), 3;
("3021",OldGray), 1;
("3021",White), 2;
("3795",Blue), 1;
("3795",White), 1;
("3832",White), 1;
("4286",Blue), 4;
("4287",Blue), 2;
("4287",White), 2;
("3298",White), 1;
("3298p90",White), 1;
("3939",TrBlue), 1;
("3939p90",Blue), 1;
("3039",White), 2;
("3940",Black), 2;
("3069b",White), 2;
("3933",White), 3;
("3934",White), 3;
]
in let cosmic_cruiser_info =
{name="Cosmic Cruiser";
theme="LEGO/SYSTEM/Space/Classic";
year=1982;
home="http://guide.lugnet.com/set/6890_1";
pieces=size cosmic_cruiser_parts;
minifigs=1}
in (cosmic_cruiser_info,cosmic_cruiser_parts: model);;
let set_6890_1 = cosmic_cruiser;;

let gamma_v_laser_craft =
let gamma_v_laser_craft_parts = make
[
("3957",TrYellow), 1;
("4732",Black), 2;
("4588",Black), 1;
("4070",OldGray), 4;
("4733",Blue), 1;
("3004",OldGray), 2;
("3004p01",OldGray), 2;
("4595",Black), 1;
("4595",Blue), 1;
("3622",OldGray), 2;
("3010",OldGray), 1;
("3963",Black), 2;
("3003",OldGray), 1;
("4591",OldGray), 1;
("3002",OldGray), 1;
("3001",OldGray), 1;
("3829",OldGray), 1;
("4589",Black), 1;
("4589",TrRed), 3;
("3189",Black), 1;
("3188",Black), 1;
("4213",Black), 2;
("4593",Black), 2;
("298",Black), 2;
("4315",OldGray), 3;
("73590a",Black), 2;
("3838",Black), 1;
("193b",Black), 1;
("3959",Black), 1;
("3626ap01",Yellow), 1;
("970c00",Black), 1;
("973p90",Black), 1;
("3024",OldGray), 2;
("3024",TrGreen), 2;
("3024",TrRed), 2;
("4073",TrRed), 2;
("4085a",OldGray), 2;
("3023",OldGray), 14;
("3794",OldGray), 2;
("3623",Black), 2;
("3710",OldGray), 1;
("4590",OldGray), 1;
("3666",OldGray), 1;
("3022",OldGray), 3;
("4229",Black), 2;
("4229",OldGray), 2;
("3021",OldGray), 4;
("3020",Black), 6;
("3020",OldGray), 4;
("3795",OldGray), 1;
("3832",OldGray), 1;
("3031",OldGray), 1;
("4740",Blue), 1;
("4740",TrRed), 1;
("3747",OldGray), 5;
("3040b",OldGray), 2;
("3039p32",OldGray), 1;
("4735",Black), 1;
("4735",Blue), 2;
("4737",Black), 2;
("4596",OldGray), 1;
("3479",OldGray), 2;
("4746",Black), 1;
("3700",OldGray), 2;
("3673",OldGray), 1;
("3070b",TrRed), 2;
("3069bp06",OldGray), 2;
("3068b",OldGray), 1;
("3068bp08",OldGray), 1;
("4474",TrGreen), 1;
("3936",OldGray), 1;
("3935",OldGray), 1;
("4475",OldGray), 3;
]
in let gamma_v_laser_craft_info =
{name="Gamma-V Laser Craft";
theme="LEGO/SYSTEM/Space/Classic";
year=1985;
home="http://guide.lugnet.com/set/6891_1";
pieces=size gamma_v_laser_craft_parts;
minifigs=1}
in (gamma_v_laser_craft_info,gamma_v_laser_craft_parts: model);;
let set_6891_1 = gamma_v_laser_craft;;

let modular_space_transport =
let modular_space_transport_parts = make
[
("3957",TrRed), 4;
("4873",White), 1;
("3956",White), 1;
("4732",Blue), 1;
("4070",Black), 2;
("3004",Blue), 5;
("3010",Blue), 2;
("3009",Blue), 4;
("3008",Blue), 1;
("3003",White), 1;
("3137c01",Black), 3;
("3006",Blue), 1;
("4589",TrRed), 2;
("3633",Blue), 2;
("3937",Blue), 1;
("3938",Blue), 1;
("4315",Blue), 1;
("3838",Yellow), 2;
("193b",Yellow), 2;
("3626ap01",Yellow), 2;
("970c00",Yellow), 2;
("973p90",Yellow), 2;
("3024",TrRed), 2;
("3023",Blue), 6;
("3794",Blue), 2;
("3710",White), 6;
("4590",Blue), 1;
("3666",Blue), 2;
("3022",Blue), 5;
("4032",Black), 1;
("3021",Blue), 2;
("3021",White), 1;
("3020",Black), 1;
("3020",Blue), 4;
("3795",Blue), 2;
("3034",Blue), 1;
("3832",Blue), 2;
("3035",White), 1;
("4740",TrRed), 2;
("4286",Blue), 4;
("4286",White), 2;
("4287",Blue), 2;
("3747",Blue), 2;
("3040b",Blue), 16;
("3665",Blue), 6;
("3660",Blue), 4;
("3037",Blue), 1;
("2342",Black), 1;
("4741",Blue), 2;
("3700",Blue), 1;
("3701",Blue), 1;
("3703",Blue), 2;
("3673",OldGray), 1;
("3069bp25",Blue), 1;
("3069b",White), 4;
("3069bp06",White), 2;
("4162",White), 2;
("3068bp08",White), 1;
("3641",Black), 6;
("4474",TrYellow), 1;
("3936",White), 1;
("3935",White), 1;
("3933",White), 1;
("3934",White), 1;
]
in let modular_space_transport_info =
{name="Modular Space Transport";
theme="LEGO/SYSTEM/Space/Classic";
year=1986;
home="http://guide.lugnet.com/set/6892_1";
pieces=size modular_space_transport_parts;
minifigs=2}
in (modular_space_transport_info,modular_space_transport_parts: model);;
let set_6892_1 = modular_space_transport;;

let mobile_lab =
let mobile_lab_parts = make
[
("3957",OldGray), 1;
("792c02",OldGray), 1;
("3612",OldGray), 5;
("3613",OldGray), 1;
("3005",OldGray), 2;
("3062b",OldGray), 1;
("3062b",TrGreen), 2;
("3062b",TrRed), 2;
("4070",OldGray), 2;
("3004",OldGray), 5;
("3004p90",OldGray), 2;
("3065",TrGreen), 4;
("3010",OldGray), 3;
("3066",TrGreen), 2;
("3829",OldGray), 1;
("3831",OldGray), 4;
("3830",OldGray), 4;
("3838",Red), 1;
("3838",White), 1;
("193a",Red), 1;
("193a",White), 1;
("3962a",Black), 1;
("3959",OldGray), 3;
("970c00",Red), 1;
("970c00",White), 1;
("4006",Black), 1;
("973p90",Red), 1;
("973p90",White), 1;
("3024",TrGreen), 2;
("3024",TrRed), 6;
("3614",OldGray), 1;
("4085a",OldGray), 2;
("3023",OldGray), 5;
("3794",OldGray), 2;
("3839a",OldGray), 2;
("3710",OldGray), 6;
("3666",OldGray), 4;
("3022",OldGray), 3;
("122c01",OldGray), 6;
("3021",OldGray), 1;
("3034",OldGray), 2;
("3036",OldGray), 1;
("3028",OldGray), 1;
("3960",OldGray), 1;
("4089",OldGray), 1;
("3298p90",OldGray), 2;
("3939",TrGreen), 1;
("3940",OldGray), 6;
("3070b",OldGray), 4;
("3069b",OldGray), 11;
("3641",Black), 12;
]
in let mobile_lab_info =
{name="Mobile Lab";
theme="LEGO/SYSTEM/Space/Classic";
year=1980;
home="http://guide.lugnet.com/set/6901_1";
pieces=size mobile_lab_parts;
minifigs=2}
in (mobile_lab_info,mobile_lab_parts: model);;
let set_6901_1 = mobile_lab;;

let mobile_recovery_vehicle =
let mobile_recovery_vehicle_parts = make
[
("3957",TrRed), 2;
("4598",OldGray), 2;
("4732",Blue), 1;
("3005",Blue), 4;
("3062b",Yellow), 2;
("3062b",TrRed), 2;
("4070",Blue), 2;
("3004",Blue), 1;
("3010",Blue), 1;
("3963",Black), 2;
("3003",Blue), 1;
("3941",Black), 2;
("3941",Blue), 1;
("3941",OldGray), 2;
("4730",Blue), 1;
("4730",OldGray), 1;
("3002",Blue), 1;
("3007",Blue), 1;
("4589",TrRed), 2;
("3633",Blue), 2;
("4448",TrYellow), 2;
("4315",Blue), 1;
("3838",Yellow), 2;
("2343",OldGray), 2;
("193b",Yellow), 2;
("3962a",Black), 1;
("3626ap01",Yellow), 2;
("970c00",Yellow), 2;
("4006",Black), 1;
("973p90",Yellow), 2;
("3024",Blue), 4;
("4081a",OldGray), 2;
("4085a",Blue), 2;
("3023",Blue), 3;
("4175",OldGray), 1;
("3710",Blue), 5;
("4590",Blue), 1;
("3666",Blue), 1;
("3022",Blue), 2;
("4032",Black), 7;
("3021",Blue), 2;
("3795",Blue), 1;
("3034",Blue), 2;
("3035",Blue), 1;
("4740",TrRed), 2;
("4286",Blue), 2;
("4287",Blue), 4;
("3747",Blue), 2;
("3040b",Blue), 8;
("3665",Blue), 2;
("3039",Blue), 1;
("3660",Blue), 2;
("3037",Blue), 1;
("2342",OldGray), 1;
("4741",Blue), 2;
("4596",OldGray), 2;
("2340",Blue), 2;
("3749",OldGray), 4;
("3701",Blue), 1;
("3894",Blue), 2;
("3702",Blue), 1;
("3895",Blue), 2;
("3069bp25",Blue), 1;
("3069b",Blue), 5;
("3068b",Blue), 1;
("3068bp08",Blue), 2;
("3634",Black), 4;
("4859",Blue), 1;
("3482",OldGray), 4;
("4474",TrYellow), 1;
("3936",Blue), 2;
("3935",Blue), 2;
("3933",Blue), 1;
("3934",Blue), 1;
]
in let mobile_recovery_vehicle_info =
{name="Mobile Recovery Vehicle";
theme="LEGO/SYSTEM/Space/Classic";
year=1986;
home="http://guide.lugnet.com/set/6926_1";
pieces=size mobile_recovery_vehicle_parts;
minifigs=2}
in (mobile_recovery_vehicle_info,mobile_recovery_vehicle_parts: model);;
let set_6926_1 = mobile_recovery_vehicle;;

let all_terrain_vehicle =
let all_terrain_vehicle_parts = make
[
("3957",Black), 2;
("3956",White), 2;
("3005",Blue), 3;
("3062b",TrGreen), 2;
("4070",OldGray), 4;
("3004",Blue), 4;
("3004p90",Blue), 2;
("3004p20",Blue), 2;
("3622",White), 4;
("3010",Blue), 1;
("3010",White), 2;
("3010p04",White), 2;
("3066",TrBlue), 2;
("3009",Blue), 3;
("3009",White), 1;
("3829",White), 1;
("3943a",Black), 2;
("3855",TrYellow), 3;
("3937",Blue), 4;
("3938",Blue), 4;
("3831",White), 2;
("3830",White), 2;
("3838",Red), 1;
("3838",White), 1;
("193a",Red), 1;
("193a",White), 1;
("3962a",Black), 1;
("4079",Yellow), 1;
("3626ap01",Yellow), 2;
("970c00",Red), 1;
("970c00",White), 1;
("4006",Black), 1;
("973p90",Red), 1;
("973p90",White), 1;
("3024",Blue), 3;
("3024",White), 2;
("3024",TrRed), 2;
("4073",TrRed), 2;
("4081a",White), 2;
("4085a",White), 4;
("3023",Blue), 1;
("3023",White), 12;
("4175",Black), 4;
("3623",White), 4;
("3710",OldGray), 2;
("3710",White), 2;
("3666",Blue), 1;
("3666",OldGray), 1;
("3666",White), 5;
("3034",White), 1;
("3035",Black), 1;
("3036",Blue), 1;
("3036",TrYellow), 1;
("3960",OldGray), 2;
("3939",TrBlue), 2;
("4228",TrBlue), 1;
("3040b",White), 2;
("3665",Black), 2;
("3665",White), 2;
("3039",White), 2;
("3046",White), 2;
("3660",Blue), 2;
("3039p34",Blue), 2;
("3039p23",Blue), 2;
("3940",Black), 4;
("3749",OldGray), 6;
("3895",Black), 2;
("3069b",Blue), 4;
("4162",Blue), 1;
("4033",Blue), 3;
("3680c01",Yellow), 1;
("3483",Black), 6;
("3482",OldGray), 6;
]
in let all_terrain_vehicle_info =
{name="All-Terrain Vehicle";
theme="LEGO/SYSTEM/Space/Classic";
year=1981;
home="http://guide.lugnet.com/set/6927_1";
pieces=size all_terrain_vehicle_parts;
minifigs=2}
in (all_terrain_vehicle_info,all_terrain_vehicle_parts: model);;
let set_6927_1 = all_terrain_vehicle;;

let uranium_search_vehicle =
let uranium_search_vehicle_parts = make
[
("3957",OldGray), 2;
("3957",TrRed), 1;
("3005",Blue), 2;
("4588",OldGray), 2;
("4070",Blue), 4;
("3004",Blue), 3;
("3004p06",Blue), 2;
("3004p90",Blue), 2;
("3065",TrYellow), 4;
("3622",Blue), 2;
("3010",Blue), 2;
("3066",TrYellow), 2;
("3003",Blue), 3;
("3001",Blue), 1;
("3829",Blue), 1;
("4597",Blue), 2;
("3831",Blue), 2;
("3830",Blue), 2;
("4213",TrYellow), 1;
("4276a",OldGray), 2;
("4275a",Blue), 2;
("4315",Blue), 2;
("3640",Blue), 1;
("3639",Blue), 1;
("3838",Black), 1;
("3838",White), 1;
("193b",Black), 1;
("193b",White), 1;
("3962a",Black), 1;
("3876",TrRed), 2;
("3959",Black), 1;
("3959",OldGray), 2;
("3626ap01",Yellow), 2;
("970c00",Black), 1;
("970c00",White), 1;
("4349",OldGray), 2;
("4479",OldGray), 2;
("4522",Black), 1;
("4006",Black), 1;
("973p90",Black), 1;
("973p90",White), 1;
("3024",Blue), 4;
("3024",TrRed), 2;
("4073",TrRed), 4;
("4081a",Blue), 2;
("4085a",Blue), 6;
("3023",Blue), 10;
("3794",Blue), 1;
("4175",OldGray), 3;
("3623",Blue), 8;
("3710",Blue), 7;
("4590",Blue), 2;
("3022",Blue), 4;
("3020",Blue), 2;
("3960",OldGray), 4;
("4286",Blue), 4;
("3747",Blue), 6;
("3039",Blue), 1;
("3039p23",Blue), 1;
("4596",Blue), 6;
("4596",OldGray), 2;
("3737",Black), 4;
("3700",Blue), 4;
("3894",Blue), 4;
("3713",OldGray), 8;
("3673",OldGray), 4;
("3069b",Blue), 11;
("4288",Black), 16;
("4474",TrYellow), 1;
]
in let uranium_search_vehicle_info =
{name="Uranium Search Vehicle";
theme="LEGO/SYSTEM/Space/Classic";
year=1984;
home="http://guide.lugnet.com/set/6928_1";
pieces=size uranium_search_vehicle_parts;
minifigs=2}
in (uranium_search_vehicle_info,uranium_search_vehicle_parts: model);;
let set_6928_1 = uranium_search_vehicle;;

let starfleet_voyager =
let starfleet_voyager_parts = make
[
("3957",Black), 2;
("3957",OldGray), 1;
("3956",White), 4;
("3005",OldGray), 2;
("3005",White), 6;
("3062b",TrGreen), 3;
("3062b",TrRed), 3;
("4070",OldGray), 4;
("3004",OldGray), 2;
("3004",White), 1;
("3004p90",White), 4;
("3622",White), 4;
("3010",White), 4;
("3010p04",White), 4;
("3963",Black), 2;
("3941",OldGray), 3;
("3941",White), 2;
("3829",White), 1;
("3942a",Black), 2;
("3942a",OldGray), 3;
("3942a",White), 2;
("3943a",Black), 2;
("3937",OldGray), 1;
("3937",White), 2;
("3938",OldGray), 1;
("3938",White), 2;
("3831",OldGray), 2;
("3831",White), 2;
("3830",OldGray), 2;
("3830",White), 2;
("3838",Red), 1;
("193a",Red), 1;
("3962a",Black), 1;
("3959",Black), 1;
("3959",OldGray), 2;
("3626ap01",Yellow), 1;
("970c00",Red), 1;
("3837",OldDkGray), 1;
("3900",Black), 1;
("774",OldGray), 1;
("4006",Black), 1;
("973p90",Red), 1;
("3024",OldGray), 2;
("3024",TrRed), 14;
("4081a",White), 4;
("4085a",White), 2;
("3023",OldGray), 4;
("3023",White), 4;
("3839a",Black), 1;
("3839a",OldGray), 1;
("4175",Black), 2;
("3623",OldGray), 6;
("3623",Yellow), 2;
("3710",OldGray), 11;
("3710",White), 6;
("3666",OldGray), 6;
("3666",White), 2;
("3460",OldGray), 6;
("3460",White), 1;
("3022",OldGray), 7;
("3022",White), 1;
("4032",Black), 3;
("4229",OldGray), 2;
("3021",OldGray), 4;
("3020",OldGray), 5;
("3795",OldGray), 1;
("3795",White), 1;
("3034",OldGray), 3;
("3034",White), 1;
("3032",White), 4;
("3032",TrBlue), 1;
("3029",OldGray), 2;
("3958",OldGray), 1;
("3960",OldGray), 2;
("3298",White), 2;
("3747",OldGray), 4;
("3298p90",White), 1;
("3939",TrBlue), 1;
("4228",OldGray), 1;
("4228",TrBlue), 1;
("3665",OldGray), 2;
("3039p34",White), 2;
("3940",Black), 4;
("3479",White), 8;
("3069b",White), 5;
("3856",White), 4;
("3853",White), 2;
("3936",OldGray), 4;
("3935",OldGray), 4;
("3933",OldGray), 1;
("3934",OldGray), 1;
]
in let starfleet_voyager_info =
{name="Starfleet Voyager";
theme="LEGO/SYSTEM/Space/Classic";
year=1981;
home="http://guide.lugnet.com/set/6929_1";
pieces=size starfleet_voyager_parts;
minifigs=1}
in (starfleet_voyager_info,starfleet_voyager_parts: model);;
let set_6929_1 = starfleet_voyager;;

let space_supply_station =
let space_supply_station_parts = make
[
("3957",Blue), 4;
("3957",OldGray), 2;
("3947",OldGray), 1;
("3956",White), 2;
("3062b",Blue), 2;
("3062b",OldGray), 1;
("3062b",TrGreen), 6;
("3062b",TrRed), 4;
("3004",White), 2;
("3004p06",White), 2;
("3004p90",White), 1;
("3004p20",Blue), 2;
("3622",White), 2;
("3009",White), 2;
("3008",White), 3;
("3963",OldGray), 2;
("3003",White), 2;
("3941",Blue), 16;
("3829",OldGray), 4;
("4346",Blue), 2;
("4346",OldGray), 1;
("4345a",Blue), 2;
("4345a",OldGray), 1;
("4315",White), 2;
("3640",OldGray), 1;
("3639",OldGray), 1;
("3838",Red), 2;
("3838",Yellow), 2;
("4360",Black), 1;
("193a",Red), 2;
("193a",Yellow), 2;
("3962a",Black), 2;
("4079",Blue), 2;
("3959",Black), 3;
("3959",OldGray), 2;
("3626ap01",Yellow), 4;
("970c00",Red), 2;
("970c00",Yellow), 2;
("4349",Black), 1;
("4479",Black), 1;
("774",Black), 1;
("973p90",Red), 2;
("973p90",Yellow), 2;
("4073",TrRed), 2;
("4081a",OldGray), 4;
("4081a",White), 4;
("4085a",OldGray), 6;
("4085a",White), 2;
("3023",OldGray), 2;
("3794",OldGray), 5;
("3839b",OldGray), 2;
("4175",Blue), 2;
("4175",OldGray), 1;
("3460",Blue), 4;
("3460",White), 2;
("4477",White), 5;
("3022",OldGray), 2;
("4032",Black), 2;
("122c01",OldGray), 4;
("3020",OldGray), 2;
("3795",Blue), 2;
("3795",OldGray), 1;
("3795",White), 2;
("3034",OldGray), 2;
("3028",White), 1;
("3960",OldGray), 2;
("4285a",OldGray), 4;
("4286",White), 8;
("4089",OldGray), 2;
("3039",Blue), 6;
("3039p34",White), 1;
("3039p23",White), 1;
("4476",Blue), 8;
("3702",White), 1;
("4162",White), 1;
("4288",Black), 8;
("4474",TrBlue), 2;
]
in let space_supply_station_info =
{name="Space Supply Station";
theme="LEGO/SYSTEM/Space/Classic";
year=1983;
home="http://guide.lugnet.com/set/6930_1";
pieces=size space_supply_station_parts;
minifigs=4}
in (space_supply_station_info,space_supply_station_parts: model);;
let set_6930_1 = space_supply_station;;

let fx_star_patroller =
let fx_star_patroller_parts = make
[
("3957",TrRed), 2;
("4732",Black), 1;
("3005",Blue), 10;
("3005",TrYellow), 2;
("4588",TrRed), 2;
("4070",Black), 2;
("4070",Blue), 2;
("4733",Black), 1;
("3004",OldGray), 1;
("3004p01",OldGray), 2;
("4595",OldGray), 4;
("3622",Blue), 4;
("3010",Blue), 1;
("3010",OldGray), 2;
("3010p42",Blue), 2;
("3009",Blue), 4;
("3008",Blue), 2;
("3963",Black), 2;
("3003",OldGray), 1;
("4591",Black), 2;
("3001",OldGray), 1;
("3006",Blue), 1;
("4589",Black), 4;
("4589",Blue), 2;
("4589",TrRed), 4;
("4589",TrYellow), 2;
("3937",Black), 1;
("3938",Black), 1;
("4213",Blue), 1;
("4213",OldGray), 2;
("4593",Black), 4;
("4593",OldGray), 1;
("298",Black), 4;
("298",Blue), 1;
("4315",Blue), 3;
("4315",OldGray), 1;
("73590a",Black), 4;
("3838",Yellow), 1;
("193b",Yellow), 1;
("3626ap01",Yellow), 1;
("970c00",Yellow), 1;
("4736",Blue), 1;
("973p90",Yellow), 1;
("4215a",TrBlue), 1;
("3024",Blue), 2;
("4073",TrYellow), 2;
("3023",Black), 2;
("3023",OldGray), 10;
("3023",Yellow), 1;
("3794",Black), 1;
("3794",Blue), 2;
("3839b",OldGray), 2;
("3475b",OldGray), 2;
("3710",Blue), 6;
("3710",OldGray), 5;
("3666",OldGray), 2;
("3022",OldGray), 2;
("4032",Black), 2;
("4229",Black), 4;
("4600",OldGray), 3;
("3021",Black), 1;
("3021",OldGray), 7;
("3020",Blue), 1;
("3020",OldGray), 2;
("3795",OldGray), 1;
("3832",Blue), 2;
("3032",Blue), 1;
("3032",OldGray), 1;
("3036",OldGray), 1;
("4740",OldGray), 2;
("4740",TrBlue), 2;
("4740",TrRed), 2;
("4286",Blue), 2;
("3298",Blue), 1;
("3747",Blue), 1;
("3747",OldGray), 2;
("3665",Blue), 2;
("3040px5",Blue), 2; (* Unofficial part *)
("3039",Blue), 1;
("3660",Blue), 2;
("3039p32",OldGray), 3;
("3039p05",Blue), 2;
("4735",Black), 2;
("4735",OldGray), 4;
("4476",Blue), 1;
("4746",OldGray), 2;
("3700",Blue), 1;
("3700",OldGray), 1;
("3673",OldGray), 1;
("3069bp25",OldGray), 1;
("3069b",Black), 1;
("3069b",Blue), 3;
("3069b",OldGray), 2;
("3069bp06",Blue), 2;
("3069bp06",OldGray), 4;
("3068b",Black), 1;
("3068bp08",Blue), 2;
("3068bp08",OldGray), 2;
("3641",Black), 6;
("4624",OldGray), 6;
("4474",TrBlue), 1;
("3936",OldGray), 1;
("3935",OldGray), 1;
("3933",OldGray), 1;
("3934",OldGray), 1;
("4475",OldGray), 3;
]
in let fx_star_patroller_info =
{name="FX-Star Patroller";
theme="LEGO/SYSTEM/Space/Classic";
year=1985;
home="http://guide.lugnet.com/set/6931_1";
pieces=size fx_star_patroller_parts;
minifigs=1}
in (fx_star_patroller_info,fx_star_patroller_parts: model);;
let set_6931_1 = fx_star_patroller;;

let alien_moon_stalker =
let alien_moon_stalker_parts = make
[
("3957",TrRed), 2;
("792c01",OldGray), 1;
("3612",OldGray), 5;
("4070",OldGray), 8;
("3004",OldGray), 5;
("4595",Black), 4;
("3010",OldGray), 9;
("3963",Black), 2;
("3003",OldGray), 8;
("3063",OldGray), 8;
("3941",Black), 2;
("3941",White), 6;
("4730",OldGray), 2;
("3001",OldGray), 2;
("4589",Black), 2;
("4589",White), 2;
("4589",TrRed), 2;
("3942b",Black), 2;
("3942b",White), 2;
("4346",OldGray), 2;
("4345a",OldGray), 2;
("4448",Black), 4;
("4448",TrGreen), 4;
("4221",Black), 2;
("4220",OldGray), 1;
("4593",Black), 4;
("4593",White), 2;
("298",OldGray), 4;
("298",White), 2;
("4315",OldGray), 1;
("3640",OldGray), 2;
("3639",OldGray), 2;
("73590a",OldGray), 2;
("3838",Blue), 1;
("3838",Red), 1;
("2343",Black), 2;
("193b",Blue), 1;
("193b",Red), 1;
("3626ap01",Yellow), 2;
("970c00",Blue), 1;
("970c00",Red), 1;
("973p90",Blue), 1;
("973p90",Red), 1;
("4865",OldGray), 4;
("3024",TrGreen), 6;
("3024",TrRed), 10;
("4085a",OldGray), 4;
("3023",Black), 2;
("3023",OldGray), 7;
("4623",OldGray), 2;
("3475b",Black), 2;
("3623",OldGray), 8;
("3710",OldGray), 4;
("3022",OldGray), 7;
("3021",OldGray), 4;
("3020",OldGray), 3;
("3795",OldGray), 5;
("3034",OldGray), 2;
("3832",OldGray), 1;
("3031",OldGray), 1;
("3035",OldGray), 1;
("3029",OldGray), 1;
("4740",Black), 2;
("4740",TrRed), 2;
("3747",OldGray), 6;
("3298p90",OldGray), 1;
("3040b",OldGray), 12;
("3039",OldGray), 3;
("3039p05",OldGray), 4;
("3039p34",OldGray), 1;
("3037",OldGray), 2;
("2342",Black), 1;
("2342",OldGray), 2;
("4741",OldGray), 4;
("3706",Black), 2;
("3700",OldGray), 4;
("3070b",TrGreen), 4;
("3070b",TrRed), 4;
("3069bp25",OldGray), 1;
("3068b",Black), 2;
("3068b",OldGray), 4;
("3680c01",OldGray), 6;
("4859",OldGray), 2;
("4474",TrGreen), 1;
("3936",OldGray), 2;
("3935",OldGray), 2;
]
in let alien_moon_stalker_info =
{name="Alien Moon Stalker";
theme="LEGO/SYSTEM/Space/Classic";
year=1986;
home="http://guide.lugnet.com/set/6940_1";
pieces=size alien_moon_stalker_parts;
minifigs=2}
in (alien_moon_stalker_info,alien_moon_stalker_parts: model);;
let set_6940_1 = alien_moon_stalker;;

let mobile_rocket_transport =
let mobile_rocket_transport_parts = make
[
("3957",Black), 3;
("4083",OldGray), 4;
("3956",OldGray), 2;
("3956",White), 4;
("3005",OldGray), 2;
("3062b",TrRed), 3;
("4070",OldGray), 2;
("3004",Blue), 4;
("3010p04",OldGray), 3;
("3009",Blue), 2;
("3067",TrYellow), 2;
("3963",OldGray), 2;
("3003",Blue), 1;
("3941",Black), 6;
("3941",White), 4;
("3001",Blue), 2;
("3829",OldGray), 5;
("3942a",White), 1;
("3943",Black), 2;
("3943",OldGray), 1;
("3943",White), 1;
("3937",OldGray), 4;
("3938",OldGray), 4;
("4275",Yellow), 2;
("4276",Yellow), 2;
(* ("x1125",Yellow), 2; Unofficial part *)
(* ("x1126",Yellow), 2; Unofficial part *)
("3324c01",OldGray), 2;
("3838",Yellow), 2;
("4360",Black), 2;
("193a",Yellow), 2;
("3962a",Black), 1;
("3959",Black), 2;
("3626ap01",Yellow), 2;
("970c00",Yellow), 2;
("973p90",Yellow), 2;
("3024",TrGreen), 2;
("4073",TrRed), 4;
("4081a",OldGray), 2;
("4085a",OldGray), 2;
("3023",White), 2;
("3839a",OldGray), 2;
("4175",Black), 2;
("4175",OldGray), 2;
("3623",OldGray), 2;
("3710",OldGray), 4;
("3666",OldGray), 1;
("3022",Blue), 3;
("4032",Black), 7;
("4229",Black), 4;
("3021",Blue), 3;
("3020",Blue), 4;
("3020",OldGray), 1;
("3795",OldGray), 5;
("3832",Blue), 1;
("3032",OldGray), 1;
("3456",Blue), 1;
("4285a",OldGray), 1;
("4286",OldGray), 4;
("3747",Blue), 2;
("3939",TrYellow), 1;
("4228",TrYellow), 1;
("3660",Blue), 7;
("3039p34",OldGray), 1;
("3039p23",OldGray), 1;
("3705",Black), 1;
("3737",Black), 1;
("3749",Black), 8;
("3700",Blue), 4;
("3702",Blue), 4;
("3713",OldGray), 1;
("3673",OldGray), 4;
("3069b",OldGray), 1;
("3068b",OldGray), 6;
("3403c01",Black), 1;
("3634",Black), 8;
("3482",Black), 8;
("3933",OldGray), 2;
("3934",OldGray), 2;
]
in let mobile_rocket_transport_info =
{name="Mobile Rocket Transport";
theme="LEGO/SYSTEM/Space/Classic";
year=1982;
home="http://guide.lugnet.com/set/6950_1";
pieces=size mobile_rocket_transport_parts;
minifigs=2}
in (mobile_rocket_transport_info,mobile_rocket_transport_parts: model);;
let set_6950_1 = mobile_rocket_transport;;

let robot_command_center =
let robot_command_center_parts = make
[
("3957",TrRed), 2;
("792c02",Blue), 2;
("3612",Blue), 10;
("3956",Blue), 3;
("3956",White), 1;
("3005",Blue), 10;
("3062b",TrRed), 3;
("3062b",TrYellow), 2;
("3004",Blue), 6;
("3004p06",OldGray), 2;
("3004p90",Blue), 2;
("3004p20",Blue), 2;
("3010",Blue), 2;
("3009",Blue), 4;
("3003",Blue), 5;
("3941",OldGray), 2;
("3941",White), 3;
("4591",Black), 1;
("4591",Blue), 2;
("3002",Blue), 4;
("3001",Blue), 8;
("3829",Blue), 2;
("3829",OldGray), 2;
("4597",Blue), 2;
("3942a",Black), 1;
("4346",Blue), 4;
("4345a",Blue), 4;
("4448",TrYellow), 2;
("4221",OldGray), 4;
("4220",OldGray), 2;
("3937",OldGray), 5;
("3938",OldGray), 5;
("3831",Blue), 4;
("3830",Blue), 4;
("4213",Blue), 1;
("4213",TrYellow), 2;
("4315",Blue), 5;
("4625",Blue), 2;
("3838",Black), 1;
("3838",Red), 1;
("3838",Yellow), 1;
("193b",Black), 1;
("193b",Red), 1;
("193b",Yellow), 1;
("3962a",Black), 1;
("3876",TrRed), 2;
("3959",Black), 2;
("3959",White), 1;
("3626ap01",Yellow), 3;
("970c00",Black), 1;
("970c00",Red), 1;
("970c00",Yellow), 1;
("4349",Black), 2;
("4349",OldGray), 6;
("973p90",Black), 1;
("973p90",Red), 1;
("973p90",Yellow), 1;
("3024",Blue), 2;
("3024",TrGreen), 2;
("4073",TrGreen), 2;
("4073",TrRed), 9;
("4073",TrYellow), 6;
("4081a",Blue), 4;
("4081a",OldGray), 2;
("4085a",Blue), 4;
("3023",Blue), 10;
("3023",OldGray), 3;
("3794",OldGray), 4;
("4175",OldGray), 2;
("3710",Blue), 2;
("3710",OldGray), 1;
("4590",Blue), 2;
("4590",OldGray), 2;
("3666",Blue), 4;
("4477",Blue), 1;
("3022",Blue), 3;
("4229",OldGray), 4;
("122c01",OldGray), 2;
("3021",OldGray), 1;
("3020",OldGray), 2;
("3795",Blue), 1;
("3795",OldGray), 5;
("3832",Blue), 1;
("3960",OldGray), 2;
("4285a",OldGray), 1;
("3747",Blue), 4;
("3040b",Blue), 2;
("3039",Blue), 2;
("3039",OldGray), 1;
("3660p01",Blue), 2;
("3039p05",Blue), 3;
("3039p34",Blue), 2;
("3039p23",Blue), 2;
("4596",Blue), 4;
("4596",OldGray), 1;
("4596",White), 2;
("3749",OldGray), 3;
("3700",OldGray), 1;
("3700",White), 2;
("3701",OldGray), 1;
("3702",Blue), 3;
("3673",OldGray), 1;
("3068b",Blue), 2;
("4033",Blue), 4;
("3680c01",Blue), 1;
("3641",Black), 4;
("4447",Blue), 2;
("4474",Blue), 4;
("3936",OldGray), 1;
("3935",OldGray), 1;
]
in let robot_command_center_info =
{name="Robot Command Center";
theme="LEGO/SYSTEM/Space/Classic";
year=1984;
home="http://guide.lugnet.com/set/6951_1";
pieces=size robot_command_center_parts;
minifigs=3}
in (robot_command_center_info,robot_command_center_parts: model);;
let set_6951_1 = robot_command_center;;

let solar_power_transporter =
let solar_power_transporter_parts = make
[
("3957",TrRed), 8;
("4070",Blue), 2;
("4070",OldGray), 4;
("4733",Blue), 1;
("3004",OldGray), 6;
("4595",Black), 4;
("3622",OldGray), 4;
("3010p42",OldGray), 4;
("3963",Black), 4;
("3003",OldGray), 4;
("3001",OldGray), 2;
("3829",OldGray), 2;
("4589",TrRed), 14;
("3937",Black), 2;
("3937",Blue), 1;
("3938",OldGray), 3;
("4593",Black), 6;
("4593",OldGray), 2;
("298",Black), 6;
("298",Blue), 2;
("4315",OldGray), 2;
("3640",OldGray), 2;
("3639",OldGray), 2;
("73590a",Black), 2;
("193b",Black), 1;
("193b",Red), 1;
("193b",Yellow), 1;
("193b",White), 1;
("3626ap01",Yellow), 4;
("970c00",Black), 1;
("970c00",Red), 1;
("970c00",Yellow), 1;
("970c00",White), 1;
("4736",Blue), 1;
("973p90",Black), 1;
("973p90",Red), 1;
("973p90",Yellow), 1;
("973p90",White), 1;
("3024",TrGreen), 4;
("3024",TrRed), 4;
("4073",TrYellow), 2;
("4081a",OldGray), 4;
("4085a",OldGray), 4;
("3023",Black), 4;
("3023",OldGray), 24;
("3794",OldGray), 5;
("3475b",Black), 4;
("4175",Black), 2;
("3710",OldGray), 2;
("4590",OldGray), 2;
("3460",OldGray), 6;
("3022",OldGray), 10;
("3021",OldGray), 2;
("3020",OldGray), 7;
("3795",OldGray), 8;
("3034",OldGray), 2;
("3832",OldGray), 1;
("3032",OldGray), 1;
("3030",OldGray), 1;
("3958",OldGray), 2;
("3033",OldGray), 1;
("4740",TrRed), 5;
("3298",OldGray), 2;
("4228",OldGray), 2;
("3660",OldGray), 2;
("3039p32",OldGray), 2;
("3037",OldGray), 4;
("4735",Blue), 3;
("4737",OldGray), 4;
("4476",OldGray), 2;
("3749",OldGray), 6;
("3700",OldGray), 14;
("3701",OldGray), 6;
("3673",OldGray), 6;
("3709b",OldGray), 4;
("3069bp25",OldGray), 2;
("3069b",OldGray), 2;
("3069bp06",OldGray), 4;
("3068b",OldGray), 6;
("3068bp08",OldGray), 4;
("3634",Black), 6;
("3482",Black), 6;
("4474",TrGreen), 2;
("3936",OldGray), 4;
("3935",OldGray), 4;
]
in let solar_power_transporter_info =
{name="Solar Power Transporter";
theme="LEGO/SYSTEM/Space/Classic";
year=1985;
home="http://guide.lugnet.com/set/6952_1";
pieces=size solar_power_transporter_parts;
minifigs=4}
in (solar_power_transporter_info,solar_power_transporter_parts: model);;
let set_6952_1 = solar_power_transporter;;

let beta1_command_base =
let beta1_command_base_parts = make
[
("3957",Black), 2;
("3957",OldGray), 6;
("3144",OldGray), 1;
("4083",OldGray), 2;
("3947",OldGray), 2;
("3956",Black), 4;
("3956",Blue), 1;
("3956",OldGray), 3;
("3005",Blue), 9;
("3062b",TrGreen), 5;
("3062b",TrRed), 4;
("3004",Blue), 23;
("3004",Yellow), 2;
("3004p90",Blue), 1;
("3004p20",Blue), 2;
("3622",Blue), 5;
("3010",Blue), 3;
("3066",TrYellow), 1;
("3009",Blue), 8;
("3754px7",Blue), 1;
("3008",Blue), 3;
("3008",OldGray), 4;
("3963",Black), 2;
("3003",Blue), 5;
("3941",Black), 2;
("3941",White), 4;
("3001",Blue), 6;
("3006",Blue), 2;
("3829",OldGray), 2;
("3942a",White), 2;
("3943a",White), 2;
("3596c90",White), 1;
("3855a",TrYellow), 2;
("3762",TrYellow), 1;
("3937",OldGray), 1;
("3938",OldGray), 1;
("3149c01",Blue), 1;
("3838",Red), 2;
("3838",OldGray), 1;
("3838",White), 3;
("193a",Red), 2;
("193a",White), 2;
("3962a",Black), 3;
("4079",OldGray), 2;
("4079",Yellow), 2;
("3959",Black), 1;
("3959",OldGray), 2;
("3899",Clear), 1;
("3626ap01",Yellow), 4;
("970c00",Red), 2;
("970c00",White), 2;
("4006",Black), 2;
("973p90",Red), 2;
("973p90",White), 2;
("3024",Blue), 8;
("3024",TrRed), 2;
("4085a",OldGray), 5;
("3023",Blue), 2;
("3023",OldGray), 2;
("3023",Yellow), 4;
("3794",OldGray), 3;
("3839a",OldGray), 1;
("3460",OldGray), 2;
("3022",OldGray), 2;
("122c01",OldGray), 2;
("3020",OldGray), 1;
("3020",Yellow), 1;
("3795",OldGray), 1;
("3795",Yellow), 2;
("3034",Blue), 1;
("3034",OldGray), 1;
("3035",OldGray), 3;
("3029",Blue), 5;
("3036",Blue), 1;
("3036",TrYellow), 2;
("3960",OldGray), 2;
("3961",OldGray), 1;
("3747",OldGray), 1;
("3297p90",OldGray), 1;
("3040b",Blue), 2;
("3665",Blue), 2;
("3039",OldGray), 1;
("3039",Yellow), 2;
("3660",Blue), 1;
("3039p34",Blue), 2;
("3940",Black), 2;
("3940",OldGray), 10;
("3895",Blue), 6;
("3673",OldGray), 2;
("3068b",Blue), 3;
("3228b",OldGray), 3;
("3680c01",OldGray), 1;
("3680c01",Yellow), 2;
("3641",Black), 4;
("3853",Blue), 2;
("3761",Blue), 1;
("3936",OldGray), 1;
("3935",OldGray), 1;
("3933",OldGray), 2;
("3934",OldGray), 2;
]
in let beta1_command_base_info =
{name="Beta-1 Command Base";
theme="LEGO/SYSTEM/Space/Classic";
year=1980;
home="http://guide.lugnet.com/set/6970_1";
pieces=size beta1_command_base_parts;
minifigs=4}
in (beta1_command_base_info,beta1_command_base_parts: model);;
let set_6970_1 = beta1_command_base;;

let intergalactic_command_base =
let intergalactic_command_base_parts = make
[
("3957",OldGray), 4;
("3957",TrRed), 2;
("3947",OldGray), 2;
("4598",White), 2;
("3005",Blue), 10;
("4588",Black), 2;
("3062b",TrGreen), 3;
("3062b",TrRed), 8;
("4070",White), 2;
("3004",Blue), 5;
("3004p06",White), 2;
("3065",TrYellow), 1;
("3622",Blue), 2;
("3008",Blue), 6;
("3963",OldGray), 4;
("3963",White), 2;
("3003",Blue), 1;
("3941",Blue), 3;
("3941",White), 3;
("4591",Black), 2;
("4591",White), 2;
("3829",Blue), 2;
("3829",White), 2;
("4597",OldGray), 1;
("3942b",White), 1;
("3185",Blue), 3;
("3762",TrYellow), 2;
("3937",OldGray), 4;
("3938",OldGray), 4;
("4276a",Black), 2;
("4275a",Black), 2;
("3149c01",Blue), 1;
("x467",Black), 2;
("3838",Black), 1;
("3838",Blue), 1;
("3838",Yellow), 1;
("4360",OldGray), 1;
("193b",Black), 1;
("193b",Blue), 1;
("193b",Yellow), 1;
("3962a",Black), 1;
("3876",TrRed), 4;
("3959",Black), 1;
("3959",Blue), 4;
("3959",OldGray), 6;
("3959",White), 2;
("3626ap01",Yellow), 3;
("970c00",Black), 1;
("970c00",Blue), 1;
("970c00",Yellow), 1;
("4479",OldGray), 2;
("4522",Black), 1;
("4006",Black), 1;
("973p90",Black), 1;
("973p90",Blue), 1;
("973p90",Yellow), 1;
("3024",Blue), 6;
("4073",TrGreen), 8;
("4073",TrRed), 12;
("4073",TrYellow), 2;
("4081a",White), 4;
("4085a",Blue), 2;
("4085a",White), 2;
("3023",Black), 9;
("3023",Blue), 11;
("3023",White), 4;
("3794",Blue), 7;
("3710",OldGray), 2;
("4590",Blue), 4;
("4590",OldGray), 2;
("4590",White), 4;
("3666",Blue), 1;
("3460",Blue), 2;
("3460",White), 1;
("4477",Blue), 3;
("3022",OldGray), 2;
("4032",Black), 2;
("4229",White), 3;
("3021",Blue), 1;
("3795",White), 2;
("3034",OldGray), 1;
("3034",White), 1;
("3832",Blue), 4;
("4282",Blue), 1;
("3030",TrYellow), 1;
("3958",TrYellow), 2;
("3033",Blue), 2;
("3960",White), 4;
("4285a",OldGray), 2;
("4286",Blue), 4;
("4287",Black), 6;
("4287",Blue), 4;
("3298p90",White), 1;
("4228",Blue), 2;
("3040b",Blue), 2;
("3039p34",White), 2;
("3039p23",White), 1;
("4596",Blue), 6;
("4596",White), 2;
("4476",Blue), 10;
("4476",OldGray), 2;
("3705",Black), 1;
("3706",Black), 1;
("3749",OldGray), 1;
("3703",Blue), 1;
("3709b",OldGray), 1;
("3070b",TrRed), 2;
("3069b",Blue), 8;
("4162",Blue), 9;
("4033",Blue), 4;
("3680c01",OldGray), 1;
("3761",Blue), 2;
("4447",Blue), 8;
("4475",White), 1;
]
in let intergalactic_command_base_info =
{name="Intergalactic Command Base";
theme="LEGO/SYSTEM/Space/Classic";
year=1984;
home="http://guide.lugnet.com/set/6971_1";
pieces=size intergalactic_command_base_parts;
minifigs=3}
in (intergalactic_command_base_info,intergalactic_command_base_parts: model);;
let set_6971_1 = intergalactic_command_base;;

let polaris1_space_lab =
let polaris1_space_lab_parts = make
[
("3957",TrRed), 3;
("3947",OldGray), 1;
("3956",Black), 2;
("4598",White), 2;
("3005",Black), 2;
("3005",White), 15;
("3005",TrBlue), 2;
("4588",TrRed), 2;
("3062b",Black), 4;
("4070",White), 14;
("3004",White), 40;
("3065",TrBlue), 2;
("4595",Black), 4;
("4595",White), 2;
("3622",White), 17;
("3003",Black), 2;
("3003",White), 2;
("2357",White), 1;
("3063",White), 4;
("3941",Black), 3;
("3001",Black), 2;
("4589",Black), 4;
("3943",Black), 1;
("4448",TrBlue), 4;
("3937",White), 6;
("3938",White), 5;
("4593",Black), 8;
("298",Black), 8;
("4276",White), 8;
("4275",White), 8;
("3149c01",Black), 2;
("73590a",Black), 2;
("3838",Blue), 3;
("193b",Blue), 3;
("3626ap01",Yellow), 3;
("970c00",Blue), 3;
("973p90",Blue), 3;
("4215a",White), 1;
("2345",White), 3;
("3024",Black), 2;
("3024",White), 8;
("3024",TrRed), 6;
("4085b",White), 2;
("3023",Black), 2;
("3023",White), 13;
("3794",Black), 2;
("4175",White), 2;
("3623",White), 6;
("3710",Black), 2;
("3710",White), 8;
("4590",Black), 2;
("3666",White), 3;
("3460",Black), 2;
("4477",White), 4;
("3022",Black), 6;
("3022",White), 2;
("2420",White), 1;
("4032",Black), 2;
("4032",White), 2;
("4229",Black), 2;
("3021",Black), 2;
("3021",White), 2;
("3020",Black), 2;
("3020",White), 6;
("3795",Black), 2;
("3795",White), 2;
("3034",White), 2;
("3832",White), 2;
("4282",Black), 2;
("2419",Black), 4;
("2419",TrRed), 4;
("3031",Black), 1;
("3035",Black), 2;
("3028",Black), 2;
("4740",TrRed), 4;
("4285a",White), 2;
("3747",White), 1;
("3298p90",White), 1;
("3040b",White), 4;
("3040p32",White), 2;
("3660",White), 2;
("3039p32",White), 2;
("3038",White), 2;
("3037",White), 2;
("4871",White), 2;
("4460",White), 6;
("2342",White), 2;
("3940",Black), 2;
("4737",Black), 1;
("4476",White), 6;
("3706",Black), 1;
("3700",Black), 2;
("3895",White), 2;
("4265a",OldGray), 1;
("3069bp05",White), 2;
("3069b",White), 4;
("2431",White), 2;
("4162",White), 8;
("3068b",Black), 6;
("3068b",White), 2;
("3068bp08",White), 2;
("4035",White), 4;
("4447",White), 4;
("2418a",White), 1;
]
in let polaris1_space_lab_info =
{name="Polaris-I Space Lab";
theme="LEGO/SYSTEM/Space/Classic";
year=1987;
home="http://guide.lugnet.com/set/6972_1";
pieces=size polaris1_space_lab_parts;
minifigs=3}
in (polaris1_space_lab_info,polaris1_space_lab_parts: model);;
let set_6972_1 = polaris1_space_lab;;

let galaxy_commander =
let galaxy_commander_parts = make
[
("3957",Blue), 5;
("3957",OldGray), 1;
("3957",White), 8;
("6099p03",OldGray), 1;
("3956",Blue), 3;
("3956",White), 2;
("3005",Blue), 4;
("3062b",TrGreen), 4;
("3062b",TrRed), 14;
("3062b",TrYellow), 4;
("3004",Blue), 4;
("3004",White), 6;
("3004p06",Blue), 2;
("3004p06",White), 5;
("3010",Blue), 2;
("3010",White), 3;
("3066",TrBlue), 8;
("3009",White), 4;
("3008",Blue), 4;
("3963",Blue), 2;
("3963",White), 4;
("3003",Blue), 2;
("3003",White), 2;
("3941",White), 2;
("3002",Blue), 2;
("3001",Blue), 3;
("3829",Blue), 4;
("3943",Blue), 1;
("3943",White), 4;
("4346",Blue), 2;
("4345a",Blue), 2;
("3937",White), 3;
("3938",White), 3;
("3831",Blue), 4;
("3830",Blue), 4;
("4213",Blue), 1;
("4315",Blue), 3;
("x467",Black), 1;
("3838",Red), 1;
("3838",Yellow), 2;
("3838",White), 2;
("4360",White), 4;
("193a",Red), 1;
("193a",Yellow), 2;
("193a",White), 2;
("3962a",Black), 2;
("4079",Blue), 1;
("3959",OldGray), 1;
("3959",White), 2;
("3626ap01",Yellow), 5;
("970c00",Red), 1;
("970c00",Yellow), 2;
("970c00",White), 2;
("4349",Black), 1;
("4479",Black), 1;
("973p90",Red), 1;
("973p90",Yellow), 2;
("973p90",White), 2;
("3024",Blue), 6;
("3024",White), 7;
("3024",TrRed), 8;
("4073",TrGreen), 6;
("4073",TrRed), 7;
("4081a",Blue), 20;
("4081a",White), 10;
("4085a",OldGray), 2;
("4085a",White), 4;
("3023",Blue), 10;
("3023",White), 11;
("3839b",Blue), 1;
("3839b",White), 4;
("4175",Blue), 2;
("4175",OldGray), 1;
("3623",Blue), 4;
("3623",White), 5;
("3710",Blue), 6;
("3710",White), 5;
("3666",Blue), 4;
("3666",White), 2;
("3460",White), 5;
("4477",White), 4;
("3022",Blue), 4;
("3022",White), 3;
("4032",Black), 7;
("4229",Black), 6;
("122c01",OldGray), 4;
("3021",Blue), 4;
("3021",White), 1;
("3020",Blue), 3;
("3020",White), 5;
("3795",Blue), 5;
("3795",White), 4;
("3034",OldGray), 1;
("3034",White), 1;
("3832",Blue), 2;
("3832",White), 2;
("3035",TrBlue), 1;
("3029",White), 1;
("3033",White), 1;
("3028",White), 1;
("4285a",Blue), 1;
("4286",Blue), 2;
("4287",Blue), 2;
("3298",Blue), 4;
("3298p90",Blue), 1;
("4228",White), 2;
("4228",TrBlue), 2;
("3040b",White), 4;
("3039",Blue), 4;
("3660",White), 2;
("3039p34",White), 1;
("3039p23",Blue), 1;
("3039p23",White), 1;
("3940",Black), 3;
("4476",Blue), 4;
("3479",White), 3;
("3895",Blue), 2;
("3070b",White), 2;
("3069b",Blue), 7;
("3069b",White), 7;
("4162",White), 3;
("3068b",Blue), 3;
("4288",Black), 8;
("4474",TrBlue), 2;
("3933",Blue), 2;
("3933",White), 3;
("3934",Blue), 2;
("3934",White), 3;
("4475",White), 2;
]
in let galaxy_commander_info =
{name="Galaxy Commander";
theme="LEGO/SYSTEM/Space/Classic";
year=1983;
home="http://guide.lugnet.com/set/6980_1";
pieces=size galaxy_commander_parts;
minifigs=5}
in (galaxy_commander_info,galaxy_commander_parts: model);;
let set_6980_1 = galaxy_commander;;

let cosmic_fleet_voyager =
let cosmic_fleet_voyager_parts = make
[
("3957",TrRed), 2;
("3956",White), 1;
("4732",White), 2;
("4588",White), 2;
("3062b",TrRed), 4;
("4070",Blue), 14;
("3004",Blue), 20;
("3004p90",Blue), 2;
("3004p01",Blue), 2;
("4595",Blue), 4;
("3622",Blue), 14;
("3010",Blue), 5;
("3010p04",Blue), 2;
("3066",TrYellow), 2;
("3009",Blue), 2;
("3008",Blue), 2;
("3941",TrYellow), 6;
("4730",Blue), 3;
("4730",OldGray), 2;
("3002",Blue), 2;
("3001",Blue), 1;
("4589",White), 2;
("4589",TrRed), 4;
("3943",White), 2;
("4448",Blue), 6;
("4448",TrYellow), 6;
("3937",Blue), 2;
("3938",Blue), 2;
("4213",Blue), 5;
("4315",Blue), 6;
("4625",Blue), 1;
("73590a",White), 2;
("3838",Black), 1;
("3838",Red), 1;
("3838",Yellow), 1;
("3838",White), 1;
("4360",White), 1;
("193b",Black), 1;
("193b",Red), 1;
("193b",Yellow), 1;
("193b",White), 1;
("3962a",Black), 1;
("3626ap01",Yellow), 4;
("970c00",Black), 1;
("970c00",Red), 1;
("970c00",Yellow), 1;
("970c00",White), 1;
("4479",Black), 1;
("3837",Black), 1;
("3900",Black), 1;
("3841",Black), 1;
("973p90",Black), 1;
("973p90",Red), 1;
("973p90",Yellow), 1;
("973p90",White), 1;
("4215a",TrYellow), 6;
("3024",Blue), 2;
("3024",OldGray), 2;
("3024",TrRed), 4;
("4085a",OldGray), 6;
("3023",Blue), 16;
("3023",White), 6;
("3475b",Black), 4;
("3623",Blue), 14;
("3710",Blue), 3;
("3666",Blue), 4;
("3460",Blue), 4;
("3022",Blue), 3;
("3022",OldGray), 2;
("3022",White), 1;
("4600",OldGray), 2;
("3021",Blue), 2;
("3021",OldGray), 3;
("3020",Blue), 2;
("3020",White), 2;
("3795",Blue), 1;
("3795",White), 2;
("3034",Blue), 1;
("3034",OldGray), 1;
("3034",White), 1;
("3832",Blue), 3;
("3832",White), 2;
("3032",Blue), 2;
("3030",White), 1;
("3030",TrYellow), 2;
("3029",White), 2;
("3958",White), 1;
("3036",Blue), 1;
("3036",White), 1;
("3028",White), 1;
("4740",TrRed), 3;
("4285a",Blue), 1;
("4286",Blue), 2;
("4287",Blue), 2;
("3298",Blue), 3;
("3747",Blue), 1;
("3939",TrYellow), 1;
("3040b",Blue), 16;
("3665",Blue), 20;
("3039",Blue), 4;
("3660",Blue), 4;
("3676",Blue), 4;
("3039p32",Blue), 1;
("3039p34",Blue), 1;
("3039p23",Blue), 1;
("4460",Blue), 2;
("3684",Blue), 2;
("2342",OldGray), 1;
("2342",White), 1;
("2336p35",Blue), 1;
("3940",Black), 6;
("4741",Blue), 6;
("4737",Blue), 6;
("2340",White), 4;
("4746",Blue), 2;
("3706",Black), 2;
("3700",Blue), 5;
("3700",OldGray), 2;
("3895",Blue), 2;
("3703",Blue), 2;
("3070b",TrRed), 2;
("3069bp25",Blue), 2;
("3069b",Blue), 8;
("3069b",OldGray), 2;
("3069bp06",Blue), 2;
("3068b",Blue), 2;
("3641",Black), 4;
("4624",OldGray), 4;
("4474",Blue), 1;
("4474",TrYellow), 1;
("3936",White), 3;
("3935",White), 3;
("3933",White), 1;
("3934",White), 1;
]
in let cosmic_fleet_voyager_info =
{name="Cosmic Fleet Voyager";
theme="LEGO/SYSTEM/Space/Classic";
year=1986;
home="http://guide.lugnet.com/set/6985_1";
pieces=size cosmic_fleet_voyager_parts;
minifigs=4}
in (cosmic_fleet_voyager_info,cosmic_fleet_voyager_parts: model);;
let set_6985_1 = cosmic_fleet_voyager;;

let space_scooter_885 =
let space_scooter_parts = make
[
("3957",OldGray), 1;
("3062a",TrBlue), 2;
("3829",OldGray), 1;
("3633",OldGray), 1;
("3838",Red), 1;
("193a",Red), 1;
("3626ap01",Yellow), 1;
("970c00",Red), 1;
("973p90",Red), 1;
("3024",TrRed), 2;
("3839a",OldGray), 1;
("3460",OldGray), 1;
("3022",OldGray), 2;
("3034",OldGray), 1;
("3298p90",OldGray), 1;
("3933",OldGray), 1;
("3934",OldGray), 1;
]
in let space_scooter_info =
{name="Space Scooter";
theme="LEGO/SYSTEM/Space/Classic";
year=1978;
home="http://guide.lugnet.com/set/885_1";
pieces=size space_scooter_parts;
minifigs=1}
in (space_scooter_info,space_scooter_parts: model);;
let set_885_1 = space_scooter_885;;

let space_buggy =
let space_buggy_parts = make
[
("3957",OldGray), 1;
("3062a",TrGreen), 1;
("3829",OldGray), 1;
("3838",OldGray), 1;
("3838",White), 1;
("193a",White), 1;
("3959",OldGray), 1;
("3626ap01",Yellow), 1;
("970c00",White), 1;
("973p90",White), 1;
("3794",OldGray), 1;
("122c01",OldGray), 2;
("3020",OldGray), 1;
("3795",OldGray), 1;
("3039",OldGray), 1;
("3641",Black), 4;
]
in let space_buggy_info =
{name="Space Buggy";
theme="LEGO/SYSTEM/Space/Classic";
year=1979;
home="http://guide.lugnet.com/set/886_1";
pieces=size space_buggy_parts;
minifigs=1}
in (space_buggy_info,space_buggy_parts: model);;
let set_886_1 = space_buggy;;

let radar_truck =
let radar_truck_parts = make
[
("3956",OldGray), 1;
("3787",OldGray), 2;
("3829",OldGray), 1;
("3937",OldGray), 1;
("3938",OldGray), 1;
("3838",Red), 1;
("3838",OldGray), 1;
("193a",Red), 1;
("3959",OldGray), 1;
("3626ap01",Yellow), 1;
("970c00",Red), 1;
("973p90",Red), 1;
("3024",OldGray), 1;
("3023",OldGray), 2;
("3794",OldGray), 1;
("3022",OldGray), 1;
("122c01",OldGray), 2;
("3021",OldGray), 2;
("3020",OldGray), 1;
("3795",OldGray), 1;
("3960",OldGray), 1;
("3641",Black), 4;
]
in let radar_truck_info =
{name="Radar Truck";
theme="LEGO/SYSTEM/Space/Classic";
year=1979;
home="http://guide.lugnet.com/set/889_1";
pieces=size radar_truck_parts;
minifigs=1}
in (radar_truck_info,radar_truck_parts: model);;
let set_889_1 = radar_truck;;

let space_transport =
let space_transport_parts = make
[
("3957",OldGray), 1;
("3956",Blue), 1;
("3005",Blue), 2;
("3004",Blue), 2;
("3622",Blue), 2;
("3010",Blue), 3;
("3010p41",OldGray), 1;
("3010p918",Blue), 2;
("3963",OldGray), 2;
("3941",OldGray), 1;
("3829",OldGray), 1;
("3943a",OldGray), 1;
("3822",OldGray), 1;
("3821",OldGray), 1;
("3937",Blue), 2;
("3938",Blue), 2;
("3838",Red), 1;
("193a",Red), 1;
("3626ap01",Yellow), 1;
("970c00",Red), 1;
("973p90",Red), 1;
("3024",OldGray), 2;
("3024",TrGreen), 2;
("3024",TrRed), 2;
("3023",OldGray), 4;
("3839a",OldGray), 1;
("3710",Blue), 2;
("3666",OldGray), 2;
("3022",OldGray), 1;
("3021",OldGray), 2;
("3020",Blue), 1;
("3020",OldGray), 2;
("3795",Blue), 1;
("3795",OldGray), 1;
("3034",OldGray), 3;
("3832",OldGray), 1;
("3031",Blue), 1;
("3032",TrYellow), 1;
("3035",OldGray), 1;
("3939",TrYellow), 1;
("3939p91",Blue), 1;
("3660",Blue), 2;
("3660",OldGray), 10;
("3940",OldGray), 3;
("3479",OldGray), 1;
("3069b",Blue), 2;
("3933",OldGray), 3;
("3934",OldGray), 3;
]
in let space_transport_info =
{name="Space Transport";
theme="LEGO/SYSTEM/Space/Classic";
year=1978;
home="http://guide.lugnet.com/set/918_1";
pieces=size space_transport_parts;
minifigs=1}
in (space_transport_info,space_transport_parts: model);;
let set_918_1 = space_transport;;

let catalog = ([
(* 1498-1 *) spy_bot;
(* 1499-1 *) twin_starfire;
(* 1526-1 *)
(* 1557-1 *) space_scooter_1557;
(* 1558-1 *) mobile_command_trailer;
(* 1580-1 *) lunar_scout;
(* 1593-1 *) unnamed_1593;
(* 1968-1 *) unnamed_1968;
(*  442-1 *) space_shuttle;            (* 891-1 *)
(*  452-1 *) mobile_tracking_station;  (* 894-1 *)
(*  462-1 *) rocket_launcher;          (* 897-1 *)
(*  483-1 *) alpha1_rocket_base;       (* 920-2 *)
(*  487-1 *) space_cruiser;            (* 924-1 *)
(*  493-1 *) space_command_center;     (* 926-1 *)
(*  497-1 *) galaxy_explorer;          (* 928-1 *)
(* 6750-1 *) light_sound_sonic_robot;
(* 6780-1 *) light_sound_xt_starship;
(* 6783-1 *) sonar_transmitting_cruiser;
(* 6801-1 *) rocket_sled;
(* 6802-1 *) space_probe;
(* 6803-1 *) space_patrol;
(* 6804-1 *) surface_rover;
(* 6805-1 *) astro_dasher;
(* 6806-1 *) surface_hopper;
(* 6807-1 *) unnamed_6807;
(* 6808-1 *) galaxy_trekkor;
(* 6809-1 *) xt5_and_droid;
(* 6820-1 *) starfire1;
(* 6821-1 *) shovel_buggy;
(* 6822-1 *) space_shuttle;
(* 6823-1 *) surface_transport;
(* 6824-1 *) space_dart1;
(* 6825-1 *) cosmic_comet;
(* 6826-1 *) crater_crawler;
(* 6827-1 *) strata_scooter;
(* 6841-1 *) mineral_detector;
(* 6842-1 *) shuttle_craft;
(* 6844-1 *) seismologic_vehicle;
(* 6845-1 *) cosmic_charger;
(* 6846-1 *) tri_star_voyager;
(* 6847-1 *) space_dozer;
(* 6848-2 *) interplanetary_shuttle;
(* 6849-1 *) satellite_patroller;
(* 6861-1 *) x1_patrol_craft;
(* 6870-1 *) space_probe_launcher;
(* 6871-1 *) star_patrol_launcher;
(* 6872-1 *) lunar_patrol_craft;
(* 6874-1 *) moonrover;
(* 6880-1 *) surface_explorer;
(* 6881-1 *) lunar_rocket_launcher;
(* 6882-1 *) walking_astro_grappler;
(* 6883-1 *) terrestrial_rover;
(* 6890-1 *) cosmic_cruiser;
(* 6891-1 *) gamma_v_laser_craft;
(* 6892-1 *) modular_space_transport;
(* 6901-1 *) mobile_lab;
(* 6926-1 *) mobile_recovery_vehicle;
(* 6927-1 *) all_terrain_vehicle;
(* 6928-1 *) uranium_search_vehicle;
(* 6929-1 *) starfleet_voyager;
(* 6930-1 *) space_supply_station;
(* 6931-1 *) fx_star_patroller;
(* 6940-1 *) alien_moon_stalker;
(* 6950-1 *) mobile_rocket_transport;
(* 6951-1 *) robot_command_center;
(* 6952-1 *) solar_power_transporter;
(* 6970-1 *) beta1_command_base;
(* 6971-1 *) intergalactic_command_base;
(* 6972-1 *) polaris1_space_lab;
(* 6980-1 *) galaxy_commander;
(* 6985-1 *) cosmic_fleet_voyager;
(*  885-1 *) space_scooter_885;
(*  886-1 *) space_buggy;
(*  889-1 *) radar_truck;
(*  918-1 *) space_transport;
]:catalog);;

end;;

Enfin, dernière opération, nous allons connaître la liste des boîtes à acheter et grâce auxquelles il nous manquera moins de 180 briques sur les 777 nécessaires :

# open LegoBricks;;
# let my_order = collect ChoamFrigate.parts LegoSpace.catalog 180;;
val my_order : LegoBricks.order =
{Inventory.items =
[({name = "Cosmic Charger"; theme = "LEGO/SYSTEM/Space/Classic";
year = 1986; home = "http://guide.lugnet.com/set/6845_1"; pieces = 53;
minifigs = 1},
1);
({name = "Cosmic Fleet Voyager"; theme = "LEGO/SYSTEM/Space/Classic";
year = 1986; home = "http://guide.lugnet.com/set/6985_1";
pieces = 412; minifigs = 4},
1);
({name = "Intergalactic Command Base";
theme = "LEGO/SYSTEM/Space/Classic"; year = 1984;
home = "http://guide.lugnet.com/set/6971_1"; pieces = 328;
minifigs = 3},
1);
({name = "Light & Sound XT - Starship";
theme = "LEGO/SYSTEM/Space/Classic"; year = 1987;
home = "http://guide.lugnet.com/set/6780_1"; pieces = 204;
minifigs = 1},
1);
({name = "Lunar Rocket Launcher"; theme = "LEGO/SYSTEM/Space/Classic";
year = 1984; home = "http://guide.lugnet.com/set/6881_1"; pieces = 98;
minifigs = 1},
1);
({name = "Mobile Recovery Vehicle"; theme = "LEGO/SYSTEM/Space/Classic";
year = 1986; home = "http://guide.lugnet.com/set/6926_1";
pieces = 150; minifigs = 2},
1);
({name = "Modular Space Transport"; theme = "LEGO/SYSTEM/Space/Classic";
year = 1986; home = "http://guide.lugnet.com/set/6892_1";
pieces = 150; minifigs = 2},
1);
({name = "Sonar Transmitting Cruiser";
theme = "LEGO/SYSTEM/Space/Classic"; year = 1988;
home = "http://guide.lugnet.com/set/6783_1"; pieces = 354;
minifigs = 2},
1);
({name = "Space Dart-I"; theme = "LEGO/SYSTEM/Space/Classic";
year = 1984; home = "http://guide.lugnet.com/set/6824_1"; pieces = 48;
minifigs = 1},
1);
({name = "Space Shuttle"; theme = "LEGO/SYSTEM/Space/Classic";
year = 1981; home = "http://guide.lugnet.com/set/6822_1"; pieces = 33;
minifigs = 1},
2);
({name = "Walking Astro Grappler"; theme = "LEGO/SYSTEM/Space/Classic";
year = 1985; home = "http://guide.lugnet.com/set/6882_1"; pieces = 94;
minifigs = 1},
1)];
Inventory.missing =
[(("2342", Blue), 3); (("2412b", OldGray), 8); (("3001", Blue), 14);
(("3002", Blue), 9); (("3003", Blue), 2); (("3004p06", Blue), 2);
(("3006", Blue), 1); (("3007", Blue), 3); (("3009", Blue), 2);
(("30116", OldGray), 4); (("3020", Blue), 7); (("3022", Black), 3);
(("3028", Blue), 2); (("3029", Blue), 2); (("3030", Blue), 2);
(("3030", White), 1); (("3032", Blue), 2); (("3032", White), 2);
(("3034", White), 9); (("3035", Blue), 1); (("3036", White), 1);
(("30363", Blue), 4); (("3039", Blue), 3); (("3039p05", Blue), 2);
(("3039p32", Blue), 1); (("3039p32", OldGray), 4); (("3068b", Blue), 1);
(("3070b", Blue), 4); (("3070b", TrRed), 2); (("3710", Black), 4);
(("3795", Blue), 6); (("3832", Blue), 3); ((...), ...); ...];
Inventory.extras = ...}

La réponse désigne 11 boîtes (cliquez sur les liens soulignés pour voir ces boîtes), la boîte 6822: Space Shuttle étant présente en double exemplaire cela nous fait un total de 12 boîtes.

Combien de briques nous manquera-t-il avec ces 12 boîtes ?

# size my_order.Inventory.missing;;
- : int = 172

C'est effectivement un peu mieux que 180 briques.
Et combien de briques "en trop" ?

# size my_order.Inventory.extras;;
- : int = 1352

Ce nombre peut paraître élevé, mais pour qui connaît les legos il est en fait très raisonnable, car le prix des briques au détail est bien supérieur au double du prix des briques en boîte. Et puis ce nombre inclut les pièces des minifigurines qui peupleront notre vaisseau de frêt et les pièces qui serviront à fabriquer les véhicules qu'il transportera d'une planète à une autre, on n'a jamais trop de legos…

V - Partie IV

1. Le jeu des tétrominos

2. Le tableau de jeu

3. La génération des coups

4. Le calcul de la valeur d'un tableau

V-A - Application à la théorie des jeux

V-A-1 - 29. Le jeu des tétrominos

Vous connaissez déjà les pièces, voici maintenant le jeu.

On énonce en six points la règle du jeu de tétrominos (à deux joueurs) :

- chaque joueur dispose de cinq tétrominos ;

- chaque joueur dépose tour à tour une de ses cinq pièces sur une grille rectangulaire de 5 x 8 cases ;

- avant la pose une pièce peut être librement orientée et retournée ;

- après la pose une pièce est inamovible et conserve sa position jusqu'à la fin de la partie

- le premier joueur qui ne peut plus poser une de ses pièces a perdu ;

- si la grille est totalement couverte par les dix pièces des deux joueurs alors la partie est déclarée nulle.

On appelle valeur théorique du jeu celle qui est vraie parmi ces trois valeurs possibles :

- first wins : il existe une stratégie gagnante pour le premier joueur ;

- second wins : il existe une stratégie gagnante pour le deuxième joueur ;

- tie game : deux joueurs « parfaits » font toujours une partie nulle.

On se propose, avec nos connaissances en OCaml, de calculer cette valeur théorique en trois étapes.

Mais d'abord, faisons plusieurs observations qui découlent directement de la règle du jeu :

- le plateau de jeu contient 40 cases ;

- la durée d'une partie est d'au maximum cinq coups par joueur ;

- la valeur théorique du jeu dépend uniquement de trois paramètres qui sont : la main de chaque joueur, de l'occupation du plateau de jeu et, bien sûr (puisque c'est là toute la question de la valeur théorique) de qui a la main ;

- en particulier la valeur théorique du jeu ne dépend pas de la couleur des cases occupées.

Précisons notre vocabulaire :

- avoir la main signifie avoir l'initiative de jouer ;

- la main d'un joueur est l'ensemble des pièces que ce joueur n'a pas encore posées sur le plateau de jeu ;

- l'occupation d'une case ne peut prendre que deux valeurs : libre ou occupée ;

- la couleur d'une case occupée ne peut prendre que deux valeurs : bleue ou rouge ;

- le premier joueur (first) désigne celui qui a la main, le second joueur (second) désigne celui qui n'a pas la main ;

- chaque joueur est alternativement first/second.

V-A-2 - 30. Le tableau de jeu

D'une part nous appellerons tableau de jeu la structure de donnée choisie pour représenter les trois paramètres dont dépend la valeur théorique du jeu.

D'autre part il faut savoir qu'un entier OCaml (du type int) contient au minimum 31 bits. Il nous faudra donc deux entiers pour représenter le plateau de jeu si un bit à 0 désigne une case vide et un bit à 1 désigne une case occupée.

Nous choisissons de couper le plateau de jeu en deux parties, horizontalement, de sorte que 20 bits représenteront les 20 cases supérieures du plateau et 20 autres bits représenteront les 20 cases inférieures du plateau.

Du coup, dans chacun des deux entiers, il reste encore 11 bits à notre disposition. Or il nous suffit de cinq bits pour représenter une main si un bit à 0 désigne une pièce déjà posée et un bit à 1 désigne une pièce dans la main. Assez opportunément le tableau de jeu (ou bitboard) sera donc constitué de deux entiers, le premier contiendra la main du premier joueur et la partie supérieure du plateau, le second contiendra la main du second joueur et la partie inférieure du plateau. La notation 0bBBBBB désigne un nombre de cinq bits en numérotation binaire. Les informations de main sont placées à partir du 20e bit pour laisser assez de place pour le masque d'occupation du plateau.

type hand = int;;

let hand_i = 0b00001 lsl 20
and hand_l = 0b00010 lsl 20
and hand_o = 0b00100 lsl 20
and hand_s = 0b01000 lsl 20
and hand_t = 0b10000 lsl 20
;;

let hand_mask  = 0x1F00000
and board_mask = 0x00FFFFF
;;

type bitboard = {first: int; second: int};;
type piece    = {upper: int; lower:  int};;

Le type piece désigne les cases occupées par une certaine pièce posée à une certaine position, il est identique au type bitboard excepté qu'il ne contient pas d'information de main.

Au début du jeu les joueurs possèdent toutes les pièces et aucune case n'est occupée, le tableau de jeu initial est donc :

{first = hand_mask; second = hand_mask};;

Pour chacun des tétrominos I.L.O.S.T. nous avons besoin de la liste de toutes ses positions possibles sur le plateau de jeu.

D'abord, étant donné une pièce p, la fonction unfold_piece p a b c génère la liste de toutes les positions possibles de cette pièce sur le plateau, avec a une liste de décalages pour lesquels p reste dans la partie supérieure du plateau, b une liste de décalages pour lesquels p est à cheval sur la partie supérieure et la partie inférieure, et enfin c une liste de décalages pour lesquels p reste dans la partie inférieure du plateau :

let unfold_piece p a b c =
let lower_part n =
if n >= 20 then p lsr (n - 20)
else (p lsl (20 - n)) land board_mask
in List.flatten [
List.map (fun n -> {upper = p lsr n; lower = 0}) a;
List.map (fun n -> {upper = p lsr n; lower = lower_part n}) b;
List.map (fun n -> {upper = 0; lower = p lsr (n - 20)}) c;
];;

Ensuite, en fournissant les listes a b c adéquates, on spécialise unfold_piece pour des pièces de largeur 3 et de hauteur 2, des pièces de largeur 2 et de hauteur 3, la pièce de largeur 1 et de hauteur 4, la pièce de largeur 4 et de hauteur 1, et enfin de la pièce carrée de côté 2 :

let unfold_piece_3x2 p =
unfold_piece p
[0;1;2; 5;6;7; 10;11;12] [15;16;17] [20;21;22; 25;26;27; 30;31;32]
and unfold_piece_2x3 p =
unfold_piece p
[0;1;2;3; 5;6;7;8] [10;11;12;13; 15;16;17;18] [20;21;22;23; 25;26;27;28]
and unfold_piece_1x4 p =
unfold_piece p
[0;1;2;3;4] [5;6;7;8;9; 10;11;12;13;14; 15;16;17;18;19] [20;21;22;23;24]
and unfold_piece_4x1 p =
unfold_piece p
[0;1; 5;6; 10;11; 15;16] [] [20;21; 25;26; 30;31; 35;36]
and unfold_piece_2x2 p =
unfold_piece p
[0;1;2;3; 5;6;7;8; 10;11;12;13] [15;16;17;18] [20;21;22;23; 25;26;27;28; 30;31;32;33]
;;

On appelle alors:

- j la pièce qui miroite la pièce l ;

- z la pièce qui miroite la pièce s ;

- 0 la rotation d'angle nul ;

- 1 la rotation d'un quart de tour dans le sens horaire ;

- 2 la rotation de deux quarts de tour dans le sens horaire ;

- 3 la rotation de trois quarts de tour dans le sens horaire.

On obtient la liste de toutes les positions possibles des 19 tétrominos orientés à l'aide de ces 19 déclarations :

let tetro_i0 = unfold_piece_1x4 0b10000100001000010000
and tetro_i1 = unfold_piece_4x1 0b11110000000000000000
and tetro_l0 = unfold_piece_2x3 0b10000100001100000000
and tetro_l1 = unfold_piece_3x2 0b11100100000000000000
and tetro_l2 = unfold_piece_2x3 0b11000010000100000000
and tetro_l3 = unfold_piece_3x2 0b00100111000000000000
and tetro_j0 = unfold_piece_2x3 0b01000010001100000000
and tetro_j1 = unfold_piece_3x2 0b10000111000000000000
and tetro_j2 = unfold_piece_2x3 0b11000100001000000000
and tetro_j3 = unfold_piece_3x2 0b11100001000000000000
and tetro_oo = unfold_piece_2x2 0b11000110000000000000
and tetro_s0 = unfold_piece_3x2 0b01100110000000000000
and tetro_s1 = unfold_piece_2x3 0b10000110000100000000
and tetro_z0 = unfold_piece_3x2 0b11000011000000000000
and tetro_z1 = unfold_piece_2x3 0b01000110001000000000
and tetro_t0 = unfold_piece_3x2 0b11100010000000000000
and tetro_t1 = unfold_piece_2x3 0b01000110000100000000
and tetro_t2 = unfold_piece_3x2 0b01000111000000000000
and tetro_t3 = unfold_piece_2x3 0b10000110001000000000
;;

Déclarations dans lesquelles 0bBBBBBBBBBBBBBBBBBBBB est un nombre en binaire, sur 20 bits distribués en quatre morceaux de cinq bits, chaque morceau de cinq bits représentant l'occupation de la pièce orientée sur une rangée horizontale de la partie supérieure du plateau, la position initiale de la pièce orientée étant toujours dans le coin supérieur gauche. La fonction unfold_pieceWxH applique à la pièce les décalages appropriés qui lui font prendre toutes les autres positions envisageables.

Enfin on obtient la liste de toutes les positions possibles des cinq tétrominos non orientés à l'aide de ces cinq déclarations :

let tetro_i = List.flatten [tetro_i0;tetro_i1]
and tetro_l = List.flatten [tetro_l0;tetro_l1;tetro_l2;tetro_l3;tetro_j0;tetro_j1;tetro_j2;tetro_j3]
and tetro_o = List.flatten [tetro_oo]
and tetro_s = List.flatten [tetro_s0;tetro_s1;tetro_z0;tetro_z1]
and tetro_t = List.flatten [tetro_t0;tetro_t1;tetro_t2;tetro_t3]
;;

V-A-3 - 31. La génération des coups

Souvenez-vous de la fonction rev_map_filter :

let rev_map_filter p f l =
let rec loop l acc =
match l with
| [] -> acc
| h::t ->
if p h then loop t (f h::acc)
else loop t acc
in loop l [];;

Au lieu de lui donner la liste vide [] comme valeur initiale de l'accumulateur acc nous pourrions très bien lui donner une liste quelconque, de ce fait on réaliserait un append en plus de map et filter, ce qui nous donne une nouvelle version, rev_append_map_filter :

let rev_append_map_filter p f l1 l2 =
let rec loop l acc =
match l with
| [] -> acc
| h::t ->
if p h then loop t (f h::acc)
else loop t acc
in loop l1 l2;;

C'est cette version que nous mettrons dans notre module ListXP.

Pour générer les coups légalement jouables, il nous faut définir une fonction du type :

bitboard -> bitboard list

Nous l'appellerons play_moves, elle démarre avec une liste vide [] et pour chacun des tétrominos I.L.O.S.T. elle augmente cette liste avec les nouveaux tableaux de jeux générés par la possession de ce tétromino en utilisant rev_append_map_filter :

let play_moves (b: bitboard ) =
let hand1  = b.first  land hand_mask
and hand2  = b.second land hand_mask
and board1 = b.first  land board_mask
and board2 = b.second land board_mask
in
let can_move p =
(p.upper land board1) lor
(p.lower land board2) = 0
and play_move h p =
{first  = p.upper + board1 + hand2;
second = p.lower + board2 + hand1 - h}
in let legal_moves h t acc =
if (hand1 land h) = 0 then acc
else ListXP.rev_append_map_filter can_move (play_move h) t acc
in begin
if (b.first land hand_mask) = 0 then
[]
else
let i = legal_moves hand_i tetro_i [] in
let l = legal_moves hand_l tetro_l  i in
let o = legal_moves hand_o tetro_o  l in
let s = legal_moves hand_s tetro_s  o in
let t = legal_moves hand_t tetro_t  s in
t
end;;

V-A-4 - 32. Le calcul de la valeur d'un tableau

Voici simplement le type game qui prend les trois valeurs théoriques possibles pour un jeu de stratégie à information complète pour deux joueurs :

type game = First | Second | Tie;;

Nous définissons ainsi la valeur théorique d'un tableau de jeu :

- si cinq coups par joueur ont été joués alors le résultat est Tie ;

- sinon ce tableau peut générer une liste de tableaux par la fonction play_moves ;

- si cette liste est vide alors le résultat est First ;

- sinon si cette liste contient au moins un tableau dont la valeur est First alors le résultat est Second ;

- sinon si cette liste contient au moins un tableau dont la valeur est Tie alors le résultat est Tie ;

- sinon le résultat est First.

Nous écrivons maintenant la fonction eval qui donne la valeur théorique d'un tableau de jeu au nième coup suivant cette définition :

let rec eval (b: bitboard ) n =
if n = 10 then Tie
else eval_list (play_moves b) (succ n)
and eval_list l n =
let rec loop l acc =
if acc = Second then acc
else match l with
| [] -> acc
| h::t ->
( match eval h n with
| First  -> Second
| Second -> loop t acc
| Tie    -> loop t Tie )
in loop l First;;

Ainsi que le code principal qui affiche la valeur théorique du jeu (la valeur théorique du tableau de jeu initial) :

print_string
( match eval {first = hand_mask; second = hand_mask} 0 with
| First  ->  "First wins\n"
| Second ->  "Second wins\n"
| Tie    ->  "Tie game\n" );;

VI - Partie V

1. Les champs mutables

2. Les références

3. Les boucles

4. Les tableaux

5. Les entrées-sorties

6. (réservé)

VI-A - La programmation impérative

VI-A-1 - 33. Les champs mutables

Jusqu'à présent nous avons manipulé beaucoup de listes et nous avons laissé de côté les structures plus générales comme les arbres et les graphes. Rattrapons cet oubli.

Commençons par les arbres.

Un programmeur habitué à des langages à typage dynamique pourrait imaginer que la structure list suffira à représenter les arbres n-aires (n-ary trees) par exemple de la façon suivante :

# [[1];[[2;3];[4;5]]];;
Characters 6-11:
[[1];[[2;3];[4;5]]];;
^^^^^
This expression has type 'a list but is here used with type int

Et pourtant cette tentative est immédiatement rejetée par OCaml, pourquoi ?
Parce que le type 'a list est obligatoirement homogène, or ici le 1er élément de notre liste est de type int list alors que le 2d élément est de type int list list. Notre liste est donc hétérogène, elle est mal typée.

Pensons plutôt notre arbre récursivement. Nous aimerions que chaque noeud puisse contenir un élément de type 'a et une liste de sous-arbres du même type que lui-même. Nous avons donc besoin de deux composantes, ce qui nous laisse le choix de l'implémentation, soit un couple, soit un enregistrement. Nous pouvons alors choisir entre l'une de ces deux déclarations de types.

Ou bien à l'aide d'un enregistrement :

# type 'a tree = {item: 'a; sub: 'a tree list};;
type 'a tree = { item : 'a; sub : 'a tree list; }

Ou bien à l'aide d'un couple :

# type 'a tree = 'a * ('a tree list);;
Characters 4-34:
type 'a tree = 'a * ('a tree list);;
^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
The type abbreviation tree is cyclic

En fait non, nous ne pouvons pas utiliser les couples. La raison peut paraître obscure pourtant elle devient limpide si nous évaluons ces deux expressions :

# 1,[];;
- : int * 'a list = (1, [])
# 1,[2,[];3,[]];;
- : int * (int * 'a list) list = (1, [(2, []); (3, [])])

Le type que nous voudrions définir dépend de la structure de données. Il croît avec elle, nous n'avons pas de moyen de définir le domaine d'une façon générale. Au contraire, avec le type enregistrement, 'a tree est le domaine. Il est déjà défini et donc le type 'a tree list est disponible pour le champ sub. On dit que le type enregistrement est un type récursif, au contraire le type n-uplet n'est pas un type récursif.

Les fonctions sur les arbres rev_tree, map_tree, exists_tree, flatten_tree, suivent de façon assez immédiate leurs correspondantes sur les listes :

let rec rev_tree t =
{item = t.item; sub = List.rev_map rev_tree t.sub};;

let rec map_tree f t =
{item = f t.item; sub = List.map (map_tree f) t.sub};;

let rec exists_tree p t =
(p t.item) or List.exists (exists_tree p) t.sub;;

let rec flatten_tree t =
t.item::List.flatten (List.map flatten_tree t.sub);;

Passons maintenant aux graphes dirigés avec racine.

Un graphe dirigé avec racine (rooted directed graph) est très semblable à un arbre n-aire avec la possibilité supplémentaire de partager des noeuds, de surcroît des cycles peuvent exister, de ce fait les algorithmes de parcours valables sur un arbre ne sont plus valables sur un graphe dirigé, car un cycle pourrait piéger le parcours dans une boucle infinie.

Afin d'éviter les boucles infinies, on doit arrêter la récursion quand on rencontre un sommet déjà visité. Il nous faut donc trouver un moyen de marquer les sommets déjà visités pendant la traversée. Il nous faut également nettoyer toutes les marques après la traversée. Voici comment on procède : on déclare un graphe dirigé avec racine de la même façon qu'un arbre n-aire tout en lui ajoutant un champ time qui est déclaré mutable :

type 'a rooted_digraph =
{point: 'a; arrows: 'a rooted_digraph list; mutable time: int};;

Essentiellement il s'agit de relier des sommets (point) par des flèches (arrows) et d'enregistrer l'horaire (time) de la dernière visite.

mutable signifie que la valeur du champ time pourra changer. Nous verrons qu'heureusement ce changement fait l'objet de règles de bonne conduite. Mais d'abord nous allons déclarer l'horloge qui fournira notre temps de référence :

let clock = {point = 1; arrows = []; time = 0};;

Désormais l'heure sera la valeur du champ clock.time.

Notons que, puisque clock est le sommet d'un rooted_digraph, il est logique que chaque sommet d'un rooted_digraph puisse être considéré comme une horloge, chacune de ces horloges pourra soit être à l'heure soit être en retard par rapport à clock notre horloge de référence.

Nous définissons maintenant trois fonctions horaires :

- clock_tick t fait progresser l'horloge de référence de t unités ;

- clock_slow h nous dit si l'horloge h a pris du retard ;

- clock_sync h remet l'horloge h à l'heure de référence.

let clock_tick t =
assert(t > 0);
clock.time <- clock.time + t;;

let clock_slow h =
h.time < clock.time;;

let clock_sync h =
h.time <- clock.time;;

Les deux fonctions clock_tick et clock_sync garantissent :

- que toute horloge est strictement croissante ;

- que toute horloge est synchronisable avec l'heure de référence ;

- que l'heure de référence est également une heure maximale, aucune horloge ne pourra la dépasser.

Ces deux fonctions sont précisément celles qui justifient la mutabilité du champ time, le qualificatif mutable signifie qu'on peut assigner ce champ à l'aide de l'opérateur ←, cette opération d'assignation renvoie un élément du type unit. En fait le type unit ne contient qu'un seul élément, à savoir (), par conséquent l'opérateur d'assignation renvoie toujours la valeur (). Plus généralement, toute expression de type unit, c'est-à-dire de valeur () est considérée comme une instruction valide. En particulier l'opérateur infixe de séquencement des instructions est le point-virgule, il est associatif à droite et de type unit → 'a → 'a, de sorte que la valeur d'une séquence d'instruction est la valeur de l'expression qui la suit immédiatement.

Preuve :

- la flèche → est associative à droite, par conséquent le point-virgule est de type unit → ('a → 'a) ;

- 'a → 'a est forcément le type de l'identité.

La fonction d'un rooted_digraph la plus élémentaire est length_graph qui donne le nombre de sommets présents dans le graphe :

let length_graph g =
let rec loop acc g =
if clock_slow g then begin
clock_sync g;
List.fold_left loop (acc + 1) g.arrows
end else
acc
in begin
clock_tick 1;
loop 0 g
end;;

Les mots-clés begin ... end encadrent une séquence d'instructions séparées par un point-virgule.
Une instruction est une expression du type unit, sauf pour la dernière d'entre elles qui est d'un type quelconque, c'est le type de cette dernière instruction qui devient le type de toute la séquence, car les séquences sont typées elles aussi. La valeur () est la seule et unique valeur de type unit. En fait l'expression begin instr1;...;instrn end a exactement la même sémantique que l'expression let () = instr1 and ... and () = instrn-1 in instrn.

Remarque : nous ne décrirons pas la fonction List.fold_left, pour plus d'information sur cette fonction veuillez vous reporter à la documentation en ligne du module List.

Les fonctions exists_graph et flatten_graph sont bâties sur le même modèle que length_graph :

let exists_graph p g =
let rec loop g =
if clock_slow g then begin
clock_sync g;
(p g.point) or List.exists loop g.arrows
end else
false
in begin
clock_tick 1;
loop g
end;;

let flatten_graph g =
let rec loop acc g =
if clock_slow g then begin
clock_sync g;
List.fold_left loop (g.point::acc) g.arrows
end else
acc
in begin
clock_tick 1;
List.rev (loop [] g)
end;;

Dans le cas courant d'un graphe dirigé acyclique, la fonction flatten_graph effectue ce que l'on appelle un tri topologique.

Mais au fait, comment construit-on un rooted_digraph ?
On construit un graphe à l'aide de let rec ... and ... and ... in root où root désigne le sommet racine du graphe.

Exemple avec un automate qui reconnaît les mots anglais race, rat, ray, rice, ride, role, rome, rope, rose, row, rude, rule :

La fonction r_graph construit le graphe de cet automate et place les lettres sur les sommets correspondants :

let r_graph () =
let
rec a = {point= 'a'; arrows= [t;y;c];     time=0}
and c = {point= 'c'; arrows= [e];         time=0}
and d = {point= 'd'; arrows= [e];         time=0}
and e = {point= 'e'; arrows= [];          time=0}
and i = {point= 'i'; arrows= [c;d];       time=0}
and l = {point= 'l'; arrows= [e];         time=0}
and m = {point= 'm'; arrows= [e];         time=0}
and o = {point= 'o'; arrows= [l;m;p;s;w]; time=0}
and p = {point= 'p'; arrows= [e];         time=0}
and r = {point= 'r'; arrows= [a;i;o;u];   time=0}
and s = {point= 's'; arrows= [e];         time=0}
and t = {point= 't'; arrows= [];          time=0}
and u = {point= 'u'; arrows= [d;l];       time=0}
and w = {point= 'w'; arrows= [];          time=0}
and y = {point= 'y'; arrows= [];          time=0}
in  r;;

La mauvaise nouvelle c'est que l'interpréteur OCaml est bien maladroit quand il s'agit d'afficher un tel graphe, il parcourt la structure comme un arbre en affichant plusieurs fois les sommets partagés. Pire, si notre graphe contenait une seule boucle elle serait affichée comme une structure infinie, jusqu'à épuisement de la capacité de la console.
C'est pourquoi nous n'avons pas défini le graphe comme une valeur, mais comme une fonction qui attend un élément unit avant de renvoyer le graphe, de cette façon nous coupons court à toute tentative d'affichage tout en définissant un raccourci bien commode pour tester nos fonctions sur ce graphe :

# length_graph (r_graph ());;
- : int = 15
# exists_graph ((=) 'n') (r_graph ());;
- : bool = false
# exists_graph ((=) 'o') (r_graph ());;
- : bool = true
# flatten_graph (r_graph ());;
- : char list =
['r'; 'a'; 't'; 'y'; 'c'; 'e'; 'i'; 'd'; 'o'; 'l'; 'm'; 'p'; 's'; 'w'; 'u']

La bonne nouvelle c'est qu'il n'est pas bien difficile d'écrire une procédure de décision pour les automates :

# let rec recognized l auto =
match l with
| [] -> false
| c::[] -> auto.point=c && auto.arrows=[]
| c::l  -> auto.point=c && List.exists (recognized l) auto.arrows
;;
val recognized : 'a list -> 'a rooted_digraph -> bool = <fun>
# recognized ['r';'o';'p';'e'] (r_graph ());;
- : bool = true
# recognized ['r';'a';'t';'e'] (r_graph ());;
- : bool = false

VI-A-2 - 34. Les références

Comme nous l'avons mentionné au paragraphe déclarations de variables, il n'est pas possible en OCaml de modifier la valeur d'une variable. D'autre part nous venons de voir qu'il est possible de modifier un champ mutable d'un enregistrement. On peut dès lors imaginer un type conteneur pour un champ mutable. C'est précisément ce qu'est le type prédéfini 'a ref, un type enregistrement polymorphe contenant un seul champ mutable nommé contents :

# type 'a ref = {
mutable contents : 'a;
};;
type 'a ref = { mutable contents : 'a; }

Ce type possède un constructeur prédéfini :

# let ref v = {contents = v};;
val ref : 'a -> 'a ref = <fun>

Évidemment la fonction duale est un accesseur, également prédéfini, en position préfixe :

# let (!) r = r.contents;;
val ( ! ) : 'a ref -> 'a = <fun>

Mais la nouveauté réside bien entendu dans les méthodes, également prédéfinies, l'assignation (en position infixe) et ses deux variantes plus spécialisées, l'incrémentation et la décrémentation :

# let (:=) r v = r.contents <- v;;
val ( := ) : 'a ref -> 'a -> unit = <fun>

# let incr r = r.contents <- succ r.contents;;
val incr : int ref -> unit = <fun>

# let decr r = r.contents <- pred r.contents;;
val decr : int ref -> unit = <fun>

Avec ces outils il n'est toujours pas possible de modifier la valeur d'une variable, mais il devient possible de modifier le contenu de la valeur d'une variable, par exemple on pourra déclarer une variable r1 de type int ref :

# let r1 = ref 1;;
val r1 : int ref = {contents = 1}

Ce qui permettra, à valeur constante, de modifier son contenu, par exemple comme ceci :

# let () = (r1 := 4) in !r1;;
- : int = 4

Comme let () = expr1 in expr2 est équivalent à expr1; expr2 on peut écrire plus simplement :

# r1 := 4; !r1;;
- : int = 4

Après cette opération la variable r1 désigne toujours le même enregistrement, cependant le champ contents de cet enregistrement a été modifié :

# r1;;
- : int ref = {contents = 4}

Pour illustrer les possibilités des références nous allons implémenter une fonction prédécesseur pour l'appel de fonction, en conséquence notre fonction pred_call appliquera la fonction f non pas à son argument courant, mais à son argument au précédent appel, nous devons donc fournir une fonction f de type 'a → 'b et un argument initial init de type 'a, le résultat sera une nouvelle fonction de type 'a → 'b :

# let pred_call f init =
let memo = ref (f init) in
fun n -> let result = !memo
in  memo := f n; result;;
val pred_call : ('a -> 'b) -> 'a -> 'a -> 'b = <fun>

Ainsi une fonction successeur pour le moins étrange pourrait renvoyer le succ de son argument au précédent appel :

# let pred_succ = pred_call succ 0;;
val pred_succ : int -> int = <fun>

Voici un exemple de session :

# pred_succ 34;;
- : int = 1
# pred_succ 17;;
- : int = 35
# pred_succ 22;;
- : int = 18

Après cette courte présentation de l'utilité des champs mutable et des références dans un style qui reste somme toute assez fonctionnel, nous allons entrer de plain-pied dans le monde de la programmation impérative.

VI-A-3 - 35. Les boucles

Il n'existe que deux boucles prédéfinies en OCaml, la boucle while et la boucle for.

La boucle while expression do instruction done répète l'instruction tant que l'expression est égale à true.

Ainsi on se convaincra aisément que le code ci-dessous implémente la même fonction factorial que celle du paragraphe II.12 :

let factorial n =
assert(n >= 0);
let i = ref n and result = ref 1 in
while !i > 1 do
result := !result * !i;
decr i
done;
!result;;

Règle d'inférence de type
La règle d'inférence d'une expression while expression do instruction done distingue trois cas possibles :

- ou bien expression n'est pas de type bool alors l'expression est mal typée ;

- ou bien instruction n'est pas de type unit alors l'expression est mal typée ;

- ou bien l'expression est de type unit.

Dans les cas où l'on connaît par avance le nombre de répétitions on peut économiser un let en utilisant une boucle for au lieu de la boucle while, on a alors deux sortes de boucle for à notre disposition, ou bien la boucle ascendante for ... to ... do ... done qui incrémente le compteur de boucle :

let factorial n =
assert(n >= 0);
let result = ref 1 in
for i = 1 to n do
result := !result * i
done;
!result;;

Ou bien la boucle descendante for ... downto ... do ... done qui décrémente le compteur de boucle :

let factorial n =
assert(n >= 0);
let result = ref 1 in
for i = n downto 1 do
result := !result * i
done;
!result;;

Ici, nous ne donnerons pas davantage d'exemples de boucles, car ceci fera l'objet du chapitre VI.

Règle d'inférence de type
La règle d'inférence d'une expression for var = start (to|downto) limit do instruction done distingue trois cas possibles :

- ou bien start n'est pas de type int ou encore limit n'est pas de type int alors l'expression est mal typée ;

- ou bien instruction n'est pas de type unit alors l'expression est mal typée ;

- ou bien l'expression est de type unit.

Remarque : l'expression limit est évaluée une fois et une seule pour toute la durée de la boucle for.

VI-A-4 - 36. Les tableaux

Les tableaux (array) permettent l'accès à leur nième élément en temps constant. En outre les éléments d'un tableau sont toujours assignables. Les fonctions sur les tableaux sont réunies dans le module Array, et en particulier :

- Array.length a renvoie le nombre d'éléments dans le tableau a, les indices dans un tableau a seront toujours compris entre 0 et Array.length a - 1 ;

- Array.make n x crée un nouveau tableau de longueur n et dont tous les éléments valent x ;

- Array.get a n renvoie le nième élément du tableau a, cette fonction possède une forme infixe a.(n) ;

- Array.set a n x assigne la valeur x au nième élément du tableau a, cette instruction possède une forme infixe a.(n) ← x.

Ces quelques fonctions sont amplement suffisantes pour implémenter l'équivalent du tri-fusion sur les tableaux.
Pour une spécification plus complète du module Array veuillez consulter sa documentation en ligne.

Écrivons d'abord une fonction qui échange deux éléments d'un tableau a :

let swap a i j =
let tmp = a.(i) in
a.(i) <- a.(j);
a.(j) <- tmp;;

L'algorithme QiSort est une sorte d'équivalent du tri-fusion pour un tableau, il est bien décrit sur cette page et son implémentation en OCaml est assez immédiate :

let array_sort a =
let rec qi_sort lower upper =
let left = ref lower and right = ref upper in
while !left < !right do
while !left < !right && a.(!left) < a.(!right) do decr right done;
if !left < !right then begin
swap a !left !right;
incr left;
while !left < !right && a.(!left) < a.(!right) do incr left done;
if !left < !right then begin
swap a !left !right;
decr right;
end;
end;
done;
decr left;
incr right;
if lower  < !left then qi_sort lower  !left;
if !right < upper then qi_sort !right upper;
in qi_sort 0 (Array.length a - 1);;

La notation OCaml pour les tableaux en extension est comparable à celle des listes en extension, à la différence de la barre verticale qui suit le crochet ouvrant et qui précède le crochet fermant :

# let a=[|4;2;5;8;6;9;3;7;0;1|] in array_sort a; a;;
- : int array = [|0; 1; 2; 3; 4; 5; 6; 7; 8; 9|]

Dans la partie VI on développera un module complet qui mettra en œuvre toutes nos nouvelles connaissances sur les références, les tableaux et les boucles, tout cela sans rien mettre de côté de l'approche qualité qui a fait ses preuves jusqu'ici.

À signaler : du fait de la proximité conceptuelle des chaînes de caractères (string) avec les tableaux de char, le module String fournit une interface assez comparable à celle du module Array.
C'est ainsi que les quatre fonctions pour les tableaux ont leurs équivalents exacts pour les chaînes :

- String.length s renvoie le nombre de caractères dans la chaîne s, les indices dans une chaîne s seront toujours compris entre 0 et String.length s - 1 ;

- String.make n c crée une nouvelle chaîne de longueur n et dont tous les caractères valent c ;

- String.get s n renvoie le nième caractère de la chaîne s, cette fonction possède une forme infixe s.[n] ;

- String.set s n c assigne la valeur c au nième caractère de la chaîne s, cette instruction possède une forme infixe s.[n] ← c.

VI-A-5 - 37. Les entrées-sorties

Le module Pervasives exporte des fonctions pour l'affichage des valeurs élémentaires :

# print_int;;
- : int -> unit = <fun>
# print_float;;
- : float -> unit = <fun>
# print_char;;
- : char -> unit = <fun>
# print_string;;
- : string -> unit = <fun>
# print_newline;;
- : unit -> unit = <fun>

Parmi ces fonctions seule print_newline force l'affichage, les autres ne font que remplir un cache d'affichage qui sera vidé lors d'un appel print_newline (). On peut aussi vider explicitement le cache, et ainsi forcer l'affichage sans passage à la ligne, à l'aide de flush stdout.

Le module Pervasives exporte aussi le type in_channel qui désigne un fichier accessible en lecture ainsi que plusieurs fonctions d'accès parmi lesquelles on pourra retenir au moins les trois suivantes :

- open_in : string -> in_channel qui ouvre en lecture le fichier texte situé au chemin d'accès spécifié ;

- input_line : in_channel -> string qui lit une ligne de texte dans un fichier ouvert en lecture ;

- close_in : in_channel -> unit qui ferme un fichier texte ouvert à l'aide de open_in.

Le module Printf quant à lui exporte des fonctions pour l'affichage de chaînes formatées.
Par exemple la fonction Printf.printf accepte des paramètres similaires à son homologue en C :

# Printf.printf "Delay: %04d\n" 89;;
Delay: 0089
- : unit = ()

VII - Partie VI

VII-A - Application aux grands nombres

L'objectif est d'implémenter Big_nat, un module raisonnablement performant pour l'arithmétique sur les entiers naturels.
Pour situer le niveau de performance, nous nous fixons comme objectif de fournir une multiplication et une division de complexité inférieure à celle d'une implémentation naïve. C'est-à-dire d'une complexité inférieure à la complexité quadratique.

1. Domaine des entiers naturels

2. Opérations sur les tableaux

3. L'addition

4. La comparaison

5. La soustraction

6. La multiplication longue

7. La multiplication Knuth-Karatsuba

8. La division Burnikel-Ziegler

9. Calcul de &pi au goutte-à-goutte

VII-A-1 - 39. Domaine des entiers naturels

Notre module Big_nat n'implémentera que les opérations sur les grands entiers positifs ou nuls.

module Big_nat = struct
...
end;;

Pour ce qui est de la base du système de numération, elle dépendra de la longueur du mot machine :

let base =
match Sys.word_size with
| 32 -> 10000
| 64 -> 1000000000
| _  -> 10;;

Pour ce qui est de la représentation des nombres, nous avons deux choix possibles :

- ou bien le type int list ;

- ou bien le type int array.

L'inconvénient majeur du type int list c'est qu'on ne peut le parcourir que dans un sens, or :

- l'addition de deux entiers nous impose de progresser des digits de poids faible vers les digits de poids fort ;

- l'inégalité de deux entiers nous impose de progresser des digits de poids fort vers les digits de poids faible.

C'est ainsi que notre objectif d'une implémentation efficace nous pousse vers le type int array, avec toutes les vicissitudes du style impératif que cela implique. Nous choisissons néanmoins cette option et nous définissons le type Big_nat.big_nat ainsi que son abréviation Big_nat.t :

type big_nat = int array;;
type t = big_nat;;

Dans la foulée nous introduisons deux constantes pas forcément inutiles :

let zero_big = ([|0|]: big_nat)
and unit_big = ([|1|]: big_nat)
;;

Il reste une dernière chose à régler : pour simplifier nos fonctions, nous devons assurer l'unicité de la représentation de chaque entier. Pour cela nous décidons que le digit de poids fort sera toujours strictement supérieur à zéro. La seule et unique exception à cette règle sera le nombre zero_big défini ci-dessus.

À ce stade nous pouvons implémenter un constructeur élémentaire pour notre type big_nat :

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

Essai sur une plateforme 32 bits :

# base;;
- : int = 10000
# big_of_int 1500123;;
- : big_nat = [|150; 123|]

Comme vous pouvez le constater, un zéro significatif a disparu à l'affichage.

VII-A-2 - 40. Opérations sur les tableaux

Afin d'assurer la manipulation efficace des importantes quantités d'int que pourront contenir nos grands entiers, nous aurons besoin du support de trois fonctions supplémentaires du module Array :

- Array.copy a renvoie une nouvelle copie du tableau a ;

- Array.sub a start len renvoie un nouveau tableau de longueur len, qui contient len éléments du tableau a, de l'indice start à l'indice start + len - 1, en cas de dépassement des bornes l'erreur invalid_arg "Array.sub" est déclenchée ;

- Array.blit a1 i1 a2 i2 len copie len éléments du tableau a1 vers le tableau a2, la lecture commence à l'indice i1 du tableau a1, l'écriture commence à l'indice i2 du tableau a2, en cas de dépassement des bornes l'erreur invalid_arg "Array.blit" est déclenchée, Array.blit autorise la copie à l'intérieur d'un même tableau, même dans les cas où il y a recouvrement de l'intervalle source et de l'intervalle destination.

Quant à l'affichage d'un big_nat, il ne nécessitera qu'une seule nouvelle fonction du module Array :

- Array.iteri f a applique f i a.(i) pour tous les éléments d'indice i de 0 à Array.length a - 1

let print_big (a: big_nat) =
let print i n =
if i=0 then print_int n
else if base=10 then print_int n
else if base=10000 then Printf.printf "%04d" n
else Printf.printf "%09d" n
in Array.iteri print a;;

Essai sur une plateforme 32 bits :

# base;;
- : int = 10000
# print_big [|150;123|];;
1500123- : unit = ()

Comme vous pouvez le constater, un zéro significatif a été révélé à l'affichage.

VII-A-3 - 41. L'addition

Pour implémenter l'addition nous allons utiliser une fonction auxiliaire add_big.
Si a contient au moins autant de digits que b alors la fonction add_big a b effectue l'assignation a := a + b.

Pour ce faire :

- il faut additionner tous les digits de b aux digits de poids faible de a ;

- une fois les digits de b épuisés il faut éventuellement propager une retenue dans les digits de poids fort restants dans a ;

- une fois les digits de a épuisés, une retenue éventuelle provoque un débordement qui oblige à réallouer une copie du tableau a ;

- finalement le tableau a initial (ou bien sa copie) est retourné en résultat.

Les deux premiers points font l'objet des deux boucles while qui constituent l'essentiel de la fonction add_big.
Le troisième point fait l'objet de la dernière branche else begin ... end.
Enfin le quatrième et dernier point est réalisé par l'expression finale !result.

let add_big (a: big_nat) (b: big_nat) =
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 fonction add_big sert de support pour la fonction sum_big qui effectue l'addition générale.
Pour cela il suffit de copier le tableau a après avoir éventuellement inversé les arguments a et b, afin que a contienne toujours plus de digits que b :

let sum_big (a: big_nat) (b: big_nat) =
if Array.length a >= Array.length b then
add_big (Array.copy a) b
else
add_big (Array.copy b) a
;;

VII-A-4 - 42. La comparaison

Pour effectuer la comparaison de a et b il y a trois cas à traiter :

- ou bien a comporte moins de digits que b alors a est plus petit que b ;

- ou bien a comporte plus de digits que b alors a est plus grand que b ;

- ou bien a et b comportent le même nombre de digits.

Dans le troisième cas, le résultat est déterminé par la première paire de digits non égaux, en progressant des digits de poids fort vers les digits de poids faible. La transcription en code OCaml ne pose pas de difficulté particulière :

let compare_big (a: big_nat) (b: big_nat) =
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;;

Au passage, on ne se prive pas d'implémenter le minimum et le maximum :

let min_big (a: big_nat) (b: big_nat) =
if compare_big a b < 0 then a else b;;

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

VII-A-5 - 43. La soustraction

La soustraction présente beaucoup de points communs avec l'addition, on reconnaîtra notamment :

- une même fonction auxiliaire, ici sub_big a b ;

- les deux mêmes boucles while qui constituent l'essentiel de la fonction sub_big a b ;

- une même copie éventuelle du tableau a, destinée ici à éliminer les zéros en tête ;

- la même expression finale !result qui renvoie a ou bien sa copie ;

- la même opération généralisée, ici diff_big a b.

Là où la soustraction est un peu plus exigente que l'addition, c'est dans sa précondition. Cette fois il ne suffira plus que a ait au moins autant de digits que b, pour ne pas sortir du domaine des entiers naturels il faudra impérativement que a soit supérieur ou égal à b.

let sub_big (a: big_nat) (b: big_nat) =
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;;

let diff_big (a: big_nat) (b: big_nat) =
assert (compare_big a b >= 0);
sub_big (Array.copy a) b;;

VII-A-6 - 44. La multiplication longue

Pour la multiplication nous décomposons l'opération en trois étapes :

- d'abord la multiplication d'un big_nat par un int strictement inférieur à base ;

- ensuite le décalage à gauche d'un big_nat ;

- enfin la multiplication d'un big_nat par un big_nat selon la méthode enseignée à l'école primaire.

Première étape.
Multiplier un big_nat par un int strictement inférieur à base.
Il s'agit essentiellement d'une boucle for qui propage la retenue des digits de poids faible vers les digits de poids fort.
Le if final est destiné à éliminer un éventuel zéro en tête.

let scale_up_big (a: big_nat) n =
assert (0 <= n && n < base);
if n = 0 then zero_big
else
let accu  = ref 0
and carry = ref 0
and result: big_nat = 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_nat)
else
result
end;;

Deuxième étape.
Décaler un big_nat de n digits à gauche.
On fait une copie calée au début d'un nouveau tableau contenant n digits supplémentaires initialisés à zéro.

let shift_big (a: big_nat) n =
assert (n >= 0);
if a = zero_big then zero_big
else
let result: big_nat = Array.make (Array.length a + n) 0
in begin
Array.blit a 0 result 0 (Array.length a);
result
end;;

Troisième étape.
Comme à l'école primaire, les digits de b, du poids faible au poids fort, servent de facteur pour scale_up_big a, à chaque digit on décale le résultat d'un digit de plus, puis on somme le tout.

let long_mult_big (a: big_nat) (b: big_nat) =
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;;

VII-A-7 - 45. La multiplication Knuth-Karatsuba

Nous allons maintenant réaliser un produit raisonnablement efficace de deux entiers naturels p et q.

Supposons que p et q aient chacun 2n digits.
On peut alors décomposer p et q en les divisant par basen, comme ceci :

p = a.basen + b ;
q = c.basen + d.

Ce qui nous donne la valeur du produit pq :

pq = ac.base2n + (ad + bc).basen + bd.

C'est-à-dire que quand la taille des nombres double (passe de n à 2n) il faut faire 4 fois plus de multiplications, plus précisément il faut faire les 4 produits ac, ad, bc et bd. C'est exactement ce qui explique la lenteur de la multiplication, le doublement de la taille des opérandes entraîne un quadruplement du temps de calcul.
L'idée ingénieuse de Karatsuba (reprise et popularisée par Knuth) consiste à remarquer l'égalité suivante :

ad + bc = (a + b)(c + d) - ac - bd.

Du coup, en remplaçant ad + bc, la valeur du produit pq devient :

pq = ac.base2n + [(a + b)(c + d) - ac - bd].basen + bd.

Algorithmiquement, cette nouvelle égalité est bien plus intéressante que la précédente, car elle nous dit qu'un doublement de la taille des opérandes n'entraîne qu'un triplement du temps de calcul.
En effet, énumérons les produits à effectuer :

- il y a toujours le produit ac ;

- il y a toujours le produit bd ;

- inconvénient : il y a un nouveau produit (a + b)(c + d) ;

- avantage : il n'y a plus les deux produits ad et bc.

Évidemment, l'avantage vaut le double de l'inconvénient, car il ne reste plus que 3 produits à effectuer au lieu de 4 !

Le code qui effectue cette nouvelle multiplication se compose de deux fonctions.
La première est array_sub qui extrait une portion des digits d'un big_nat en retirant les éventuels zéros en tête :

let array_sub (a: big_nat) 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_nat);;

La deuxième est mult_big qui implémente la multiplication Karatsuba, avec trois améliorations notables :

- la généralisation à un nombre quelconque de digits, pas seulement les puissances de 2 ;

- le recours à long_mult_big lorsqu'elle est plus efficace (empiriquement, en dessous de 20 à 30 digits) ;

- une formule simplifiée dans le cas où q est au moins 2 fois plus court que p.

let karatsuba_threshold = 20;;

let rec mult_big (a: big_nat) (b: big_nat) =
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_nat) (q: big_nat) =
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
;;

La multiplication apporte avec elle son lot de nouvelles opérations.
Grâce à la complexité sub-quadradrique de la multiplication Karatsuba, ces opérations sont plus efficaces qu'avec une implémentation naïve.

Le carré :

let square_big (a: big_nat) = mult_big a a;;

La puissance entière, implémentée de façon dichotomique :

let rec power_big (a: big_nat) 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 permutation de p éléments parmi n, elle aussi implémentée de façon dichotomique :

let permutation_big n p =
assert(0 <= p && p <= n);
let rec product 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 (product a ab2) (product (ab2+1) b)
in
if p = 0 then unit_big else product (n - p + 1) n;;

Enfin, la factorielle qui n'est que la permutation de n éléments parmi n :

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

VII-A-8 - 46. La division Burnikel-Ziegler

Pour la division nous décomposons l'opération en deux étapes :

- d'abord la division d'un big_nat par un int strictement inférieur à base² ;

- ensuite la division d'un big_nat par un big_nat selon l'algorithme de Burnikel et Ziegler, que nous présenterons sans le justifier.

Première étape.

Diviser un big_nat par un int inférieur à base².
Il s'agit essentiellement d'une boucle for qui propage la retenue des digits de poids fort vers les digits de poids faible.
Comme à l'habitude, le if final est l'étape d'élimination de l'éventuel zéro en tête.

let scale_down_big (a: big_nat) n =
assert (0 < n && n < base * base);
let last  = Array.length a - 1 in
let accu  = ref 0
and carry = ref 0
and result: big_nat = Array.copy a
in begin
for i = 0 to last do
accu := a.(i) + !carry * base;
result.(i) <- !accu/n; carry := !accu mod n
done;
if (result.(0) = 0) && (last > 0) then
(array_sub result 1 last: big_nat),!carry
else
result,!carry
end;;

Deuxième étape.

Remarquons qu'un entier inférieur à base² c'est exactement le nombre que peut stocker un big_nat de deux digits.

Une fois acquise la division par un nombre de deux digits, l'algorithme publié en 2000 par Michel Quercia et Paul Zimmermann, et qui est une amélioration d'une idée originale de Burnikel et Ziegler, permet le passage à une division quelconque. Il utilise une méthode dichotomique qui apporte à la division l'équivalent de ce que la méthode Karatsuba apporte à la multiplication.
La description de l'algorithme est suivie d'un petit commentaire sur le respect du domaine de définition, puis l'implémentation s'ensuit naturellement, la notation restant assez proche de la spécification mathématique tout en réutilisant nombre de fonctions auxiliaires introduites pour la mutiplication.

Soit n = (le nombre de digits de b - 1) / 2
Ou bien n = 0 :

diviser a par b à l'aide de la fonction scale_down_big ;

Ou bien n > 0 :

décomposer a selon le binôme a = a1.basen + a0
si a1 >= b :

- diviser récursivement a1 par b selon l'égalité a1 = b.q1 + r1

- diviser récursivement r1.basen + a0 par b selon l'égalité r1.basen + a0 = b.q0 + r0

- alors r = r0 et q = q1.basen + q0 ;

si a1 < b :

- décomposer b selon le binôme b = b1.basen + b0 ,

- diviser récursivement a1 par b1 selon l'égalité a1 = b1.q1 + r1,

- soit x = a0 + r1.basen - b0.q1,

- si x >= 0 alors r = x et q = q1 sinon r = b + x et q = q1 - 1.

Dans le cas où a1 < b, avec nos entiers positifs on ne pourra pas directement calculer x, il faudra comparer a0 + r1.basen avec b0.q1, et le reste vaudra, suivant le signe de x, ou bien x ou bien b -(-x).

let rec burnikel_ziegler_big (a: big_nat) (b: big_nat) =
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 (sum_big (shift_big r1 n) a0) b
in  sum_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 = sum_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 = diff_big a0_r1 b0_q1
in  q1,plus_x
else
let minus_x = diff_big b0_q1 a0_r1 in
diff_big q1 unit_big, diff_big b minus_x;;

La dernière touche c'est la fonction quomod_big qui enveloppe burnikel_ziegler_big dans une interface plus commune, en traitant notamment le cas particulier de la division par zéro :

let quomod_big (a: big_nat) (b: big_nat) =
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;;

Et pour finir, voici un calcul efficace des coefficients binomiaux :

VII-A-9 - 47. Calcul de &pi au goutte-à-goutte

La formule ci-dessus, due à William Gosper, possède le double avantage :

- de ne faire intervenir que les quatre opérations élémentaires ;

- d'admettre une implémentation en goutte-à-goutte, l'affichage démarre immédiatement, les décimales s'affichent une à une, de plus nous n'avons pas à sélectionner une précision maximale par avance.

Comme souvent dans les formules un peu complexes, mieux vaut commencer par définir quelques abréviations afin d'alléger la notation :

let add a b  =
if Array.length a >= Array.length b then Big_nat.add_big a b
else Big_nat.add_big b a
and sub      = Big_nat.sub_big
and mult     = Big_nat.mult_big
and div a b  = let q,r = Big_nat.quomod_big a b in q
and add_int  n a = Big_nat.sum_big a [|n|]
and sub_int  n a = Big_nat.sub_big a [|n|]
and mult_int n a = Big_nat.scale_up_big a n
and big_int  = Big_nat.big_of_int
and int_of n = match n with [|n|] -> n | _ -> assert false
;;

L'implémentation en goutte-à-goutte est due à Jeremy Gibbons, il s'agit d'une simple boucle, chaque itération affichant une décimale supplémentaire :

let pi () =
let rec g q r t i =
let i3 = mult_int 3 i in
let u = mult_int 3 (mult (add_int 1 i3) (add_int 2 i3))
and y = int_of (div (add (mult q (sub_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 (sub_int 1 (mult_int 2 i)))))
(mult_int 10 (mult u (sub (add (mult q (sub_int 2 (mult_int 5 i))) r) (mult_int y t))))
(mult t u)
(add_int 1 i);
()
end
in g (big_int 1) (big_int 180) (big_int 60) (big_int 2);;

Comme on ne fait aucun passage à la ligne, on est obligé de forcer l'affichage à l'aide de flush stdout.

Prêt ? Partez :

pi ();;

Pour interrompre le calcul dans OCamlWinPlus il faut invoquer le menu Workspace/Interrupt.
Pour interrompre le calcul dans une console de commandes il faut envoyer un signal d'interruption (le plus souvent en appuyant sur Ctrl+C).

VIII - Partie VII

1. Techniques d'analyse syntaxique

2. Les requêtes syntaxiques

3. Un analyseur pour pascal

4. Les erreurs de syntaxe

5. Implémentation de Lex.lex_parser

VIII-A - Application à l'analyse syntaxique

VIII-A-1 - 48. Techniques d'analyse syntaxique

On peut distinguer trois familles méthodologiques quand il s'agit de faire l'analyse d'un document texte structuré :

- les outils spécialisés (Lex/Yacc/Bison) utilisent un métalangage pour spécifier la structure du texte, à partir de cette spécification ils génèrent une source qui réalise l'analyse du texte selon cette structure ;

- les parser combinators offrent une collection d'opérations élémentaires d'analyse ainsi que des opérateurs qui permettent de les combiner pour produire des analyseurs plus complexes ;

- la méthode traditionnelle, telle qu'enseignée par Niklaus Wirth, consiste à tout écrire à la main, sans dépendance ni à un outil ni à une bibliothèque.

Le module que nous allons réaliser dans cette partie est une modernisation de la méthode traditionnelle.
Cette méthode suppose d'écrire à la main un analyseur syntaxique de type descendant.
Ce cours ne vous apprendra pas à écrire un analyseur descendant, si vous ne savez pas le faire veuillez vous référer à la littérature classique sur le sujet, par exemple le très classique Compiler Construction de Niklaus Wirth ou bien le cours de Sébastien Doeraene.

VIII-A-2 - 49. Les requêtes syntaxiques

Le type le plus important exporté par le module Lex est sans aucun doute le type Lex.lex_parser.
Hormis quelques considérations sur l'analyse syntaxique descendante en général, nous allons surtout nous attacher aux spécificités particulières à l'utilisation d'un objet Lex.lex_parser.
Comme vous allez le voir, il s'agit d'une révision de l'analyse syntaxique descendante à la Niklaus Wirth, dont le mérite principal est que la syntaxe y apparaît plus clairement grâce à une formulation plus ramassée.

Pour commencer il n'y a pas d'analyseur lexical au sens habituel.
Par exemple il n'y a pas de mots réservés, mais seulement des mots-clés contextuels.
On ne peut pas définir ses propres unités lexicales, elles sont toutes prédéfinies.

Un élément lexical appartient à l'une de ces sept catégories :

- un word est un mot-clé introduit par le langage, par exemple begin ;

- un name est un identificateur introduit par le programmeur, par exemple push ;

- un mono est un caractère simple, par exemple + ;

- un poly est un caractère multiple, par exemple >= ;

- un string est une valeur chaîne de charactères immédiate, par exemple "hello!" ;

- un char est une valeur caractère immédiate, par exemple 'a' ;

- un int est une valeur entière décimale immédiate non-signée, par exemple 31415.

Après les spécificités lexicales passons maintenant aux spécificités syntaxiques.

Classiquement, en plus de construire un arbre de syntaxe abstraite, un analyseur syntaxique descendant est responsable de trois autres sortes d'opérations élémentaires :

- reconnaître une unité lexicale (souvent à l'aide d'une égalité) ;

- avancer d'une unité lexicale ;

- signaler une erreur syntaxique.

Avec ces quatre tâches différentes, il n'est pas étonnant que le code d'un analyseur descendant apparaisse souvent comme surchargé.
Ce malheureux cumul des mandats est contraire à l'injonction dite de separation of concerns et encourage le recours à des outils spécialisés.
Au contraire de ces outils spécialisés, avec leur notation métalinguistique, le module Lex vous maintient dans le confort du langage OCaml que vous connaissez déjà.

La conception du module Lex est basée sur deux critiques de la méthode traditionnelle :

- les opérations comme reconnaître une unité lexicale ou bien avancer d'une unité lexicale n'ont rien à faire dans un analyseur syntaxique, elles auraient mieux leur place dans un analyseur lexical ;

- les opérations reconnaître-avancer-erreur sont de trop bas niveaux, il faudrait pouvoir les fusionner dans des opérations de plus haut niveau.

Pour remédier à ces deux déficiences, le module Lex propose :

- de redescendre certaines opérations (comme l'égalité) au niveau de l'analyse lexicale ;

- la notion de requête qui combine reconnaître-avancer-erreur en une opération unique.

Désormais, pour effectuer une analyse syntaxique descendante, il vous faudra penser en termes de requêtes demand, granted ou promised qui sont liées aux opérations classiques par l'explication suivante :

- si une requête demand reconnaît alors elle avance sinon elle signale une erreur ;

- si une requête granted reconnaît alors elle avance sinon elle n'avance pas, mais ne signale pas d'erreur ;

- une requête promised reconnaît (ou pas); n'avance jamais; ne signale jamais d'erreur.

Cette explication ne se justifie que par l'expérience de l'analyse descendante, elle n'est pas très intuitive en elle-même.
C'est pourquoi, de façon similaire aux diagrammes syntaxiques, ce formalisme pour les grammaires LL(1) possède sa propre représentation graphique, les ordigrammes syntaxiques, qui va je l'espère vous aider à l'appréhender et à l'utiliser dans vos propres projets.

Les ordigrammes syntaxiques complètent harmonieusement les diagrammes syntaxiques :

- les diagrammes syntaxiques disent à quoi ressemble une phrase, leur sémantique est "déclarative" ;

- les ordigrammes syntaxiques disent comment reconnaître une phrase, leur sémantique est "impérative".

Pour les lire il suffira de savoir que :

- les ordigrammes syntaxiques sont composés d'écluses (ou portes) reliées par des canaux dans lesquels le flux lexical peut s'écouler ;

- le flux lexical entre dans une porte par la gauche ;

- si le flux lexical charrie le motif inscrit sur la porte alors il ressort par la droite, si ce faisant il traverse une puce noire alors l'élément inscrit sur la porte est retiré du flux lexical (la lecture dans le flux lexical avance d'une unité) ;

- sinon le flux lexical est interdit de passage et il poursuit sa course en bas à gauche de la porte ;

- sur une porte les unités lexicales sont marquées en gras tandis que les règles syntaxiques sont marquées en italique ;

- une porte avec deux sorties, une 1re à droite et la 2de à gauche, ne peut pas être gardée par une règle, elle ne peut être gardée que par une unité lexicale

Il en résulte que la grammaire utilise la première unité du flux lexical comme le discriminant d'une phrase, on dit aussi que la grammaire est sous la forme LL(1).

Les requêtes du module Lex sont reliées aux ordigrammes syntaxiques par une correspondance bi-univoque, chaque schéma possédant son équivalent textuel et vice versa :

Par exemple l'ordigramme syntaxique d'une séquence :

Se traduit textuellement en Caml par la fonction sequence :

let sequence () =
lex.demand_word "begin";
instruction ();
while lex.granted_mono ';' do
instruction ()
done;
lex.demand_word "end"

VIII-A-3 - 50. Un analyseur pour pascal

Dans ce chapitre, afin de se donner une idée plus concrète des facilités et des limites du module Lex, on se propose d'implémenter un analyseur syntaxique descendant pour un langage Turbo Pascal modulaire à peine simplifié (sans extension POO cependant, nous sommes là pour apprendre l'analyse syntaxique, pas pour programmer en Object Pascal).

Pour le besoin du cours cette source TP5.ml est présentée ici en plusieurs morceaux entrecoupés de commentaires. Afin de faciliter vos expérimentations les sources Lex.ml et TP5.ml complètes ainsi que l'exécutable pour Linux et Win32 ont été réunis dans cette archive.

Pour commencer :

- on ouvre le module Lex à l'aide de open Lex ;

- on créer un analyseur lex de type Lex.lex_parser qui lit le flux stdin, pour lire un fichier il suffira de rediriger l'entrée ;

- on créer simple_name (), un analyseur élémentaire qui se contente d'oublier l'identificateur que l'on vient de demander à l'aide de lex.demand_name ().

open Lex;;

let lex = Lex.make stdin in

let rec simple_name () =
ignore(lex.demand_not reserved)

Après ce let rec initial les définitions suivantes seront simplement introduites par and. Elles sont donc mutuellement récursives ce qui nous permettra d'utiliser par anticipation des règles de syntaxe pas encore introduites.

Un simple_name est un nom simple, c'est-à-dire non qualifié, comme dans unit test.
Un simple_name est un identificateur, il ne peut pas être un mot réservé.
Nous avons exprimé cette contrainte à l'aide de la requête syntaxique demand_not reserved.

reserved est le nom de notre prédicat qui dit si un mot est réservé ou non.
On peut réserver la liste complète des mots-clés du pascal en les plaçant dans un tableau soumis à un test d'occurrence.
Le module Lex exporte justement une fonction sorted_array_mem, cette fonction réalise un test d'occurrence sur un tableau, nous n'avons pas à chercher plus loin.

and reserved =
Lex.sorted_array_mem
[|
"and";"array";"asm";
"begin";"case";"const";
"div";"do";"downto";"else";"end";
"file";"for";"function";"goto";
"if";"implementation";"in";"interface";
"label";"mod";"nil";"not";"of";"or";"out";
"packed";"procedure";"program";
"record";"repeat";
"set";"shl";"shr";"string";
"then";"to";"type";
"unit";"until";"uses";
"var";"while";"with";"xor";
|]

Précisons tout de même que sorted_array_mem fait une recherche dichotomique : elle est efficace, mais elle n'est correcte que sur un tableau trié.
Si par misère notre tableau de mots-clés n'était pas déjà trié, nous pourrions le trier à l'aide de Array.sort.

Bien entendu nous pourrions coder une reconnaissance encore plus efficace des mots réservés, par exemple à l'aide d'un arbre Patricia.
Cette méthode n'aurait rien à envier aux meilleures technologies à base d'automates, toutefois pour avancer plus vite nous laissons ce raffinement à titre d'exercice à la discrétion du lecteur. Et nous progressons promptement dans l'épanchement de notre soif de syntaxe.

Un nom qualifié est un nom suivi par un suffixe comme table dans table^[i].key ou dans table.at(i).
Remarquez que key est un nom et pourrait à son tour être qualifié.

Nous en savons assez pour pouvoir qualifier un nom :

and qualify_name () =
ignore(lex.granted_mono '^');
match lex with
| l when lex.granted_mono '.' ->
simple_name (); qualify_name ()
| l when lex.granted_mono '[' ->
expression ();
lex.demand_mono ']';
qualify_name ()
| l -> arguments ()

Il nous reste alors à traiter le dernier cas, où un nom est qualifié par une liste d'arguments réels, comme insert dans insert(key,item).

and arguments () =
if lex.granted_mono '(' then begin
expression ();
while lex.granted_mono ',' do
expression ()
done;
lex.demand_mono ')'; qualify_name ()
end

Voilà qui nous amène aux expressions, cela peut paraître intimidant.
Cependant en y regardant de plus près nous avons déjà bien entamé la définition d'une expression.
Plus précisément il ne nous manque que les cas suivants :

- l'expression est une constante entière ou réelle (partie entière plus partie décimale) ;

- l'expression est une constante caractère ;

- l'expression est une constante chaîne de caractères ;

- l'expression est parenthésée ;

- l'expression est préfixée par un opérateur unaire (ou bien - ou bien not) ;

- l'expression est un nom éventuellement qualifié (c'est le cas déjà traité) ;

- l'expression est une opération (ou l'opérateur figure parmi + - * <= >= <> < > = and or xor div mod).

Il n'y a plus qu'à traduire :

and expression () =
( match lex with
| l when lex.promised_int ()    ->
ignore (lex.demand_int ());
if lex.granted_mono '.' then ignore (lex.demand_int ())
| l when lex.promised_mono '\"' -> ignore (lex.demand_char ())
| l when lex.promised_mono '\'' -> ignore (lex.demand_string ())
| l when lex.granted_mono  '('  -> expression (); lex.demand_mono ')'
| l when lex.granted_mono  '-'  -> expression ()
| l when lex.granted_word "not" -> expression ()
| l -> simple_name (); qualify_name ()
) ;
( match lex with
| l when lex.granted_mono '+'   -> expression ()
| l when lex.granted_mono '-'   -> expression ()
| l when lex.granted_mono '*'   -> expression ()
| l when lex.granted_poly "<="  -> expression ()
| l when lex.granted_poly ">="  -> expression ()
| l when lex.granted_poly "<>"  -> expression ()
| l when lex.granted_mono '<'   -> expression ()
| l when lex.granted_mono '>'   -> expression ()
| l when lex.granted_mono '='   -> expression ()
| l when lex.granted_word "and" -> expression ()
| l when lex.granted_word "or"  -> expression ()
| l when lex.granted_word "xor" -> expression ()
| l when lex.granted_word "div" -> expression ()
| l when lex.granted_word "mod" -> expression ()
| l -> ()
)

Nous en avons terminé avec les expressions, nous passons aux instructions.

La séquence permet de regrouper une série d'instructions séparées par un point-virgule :

and sequence () =
lex.demand_word "begin";
instruction ();
while lex.granted_mono ';' do
instruction ()
done;
lex.demand_word "end"

Finalement une instruction est :

- ou bien une séquence ;

- ou bien une instruction structurée (à choisir parmi if while repeat for with) ;

- ou bien un appel de procédure ;

- ou bien une assignation.

Il n'y a plus qu'à traduire :

and instruction () =
match lex with
| l when lex.promised_word "begin" ->
sequence ();
| l when lex.granted_word "if" ->
expression ();
lex.demand_word "then";
instruction ();
if lex.granted_word "else" then instruction ()
| l when lex.granted_word "while" ->
expression ();
lex.demand_word "do";
instruction ();
| l when lex.granted_word "repeat" ->
instruction ();
while lex.granted_mono ';' do
instruction ()
done;
lex.demand_word "until"; expression ()
| l when lex.granted_word "for" ->
simple_name (); qualify_name ();
lex.demand_poly ":=";
expression ();
if lex.granted_word "to" then ()
else lex.demand_word "downto";
expression ();
lex.demand_word "do";
instruction ();
| l when lex.granted_word "with" ->
simple_name (); qualify_name ();
lex.demand_word "do";
instruction ();
| l ->
simple_name (); qualify_name ();
if lex.granted_poly ":=" then expression ()
else arguments()

Comme vous voyez, ça avance très vite, nous en avons terminé avec les instructions.
Nous passons maintenant aux déclarations de types.

Une caractéristique de pascal, plutôt à l'abandon dans les langages modernes, ce sont ces types anonymes.
Bien sûr il y a les types prédéfinis comme Integer, Longint, Real, Byte, Word, Char, Boolean, Pointer.
Un programmeur pascal peut également définir un nouvel alias de type.
Mais en plus, sans avoir à le nommer, le programmeur pascal peut spécifier :

- un nouveau type chaîne string[max] ;

- un nouveau type fichier file of data_type ;

- un nouveau type tableau array [min..max] of data_type ;

- un nouveau type enregistrement record components end ;

- un nouveau type procedure ou function ;

- un nouveau type pointeur (à l'aide du caractère ^) ;

- un nouveau type énuméré comme (North, East, South, West).

Il n'y a plus qu'à traduire :

and data_type () =
match lex with
| l when lex.granted_word "Integer" -> ()
| l when lex.granted_word "Longint" -> ()
| l when lex.granted_word "Real" -> ()
| l when lex.granted_word "Byte" -> ()
| l when lex.granted_word "Word" -> ()
| l when lex.granted_word "Char" -> ()
| l when lex.granted_word "Boolean" -> ()
| l when lex.granted_word "Pointer" -> ()
| l when lex.granted_word "string" ->
if lex.granted_mono '[' then begin
constant_value ();
lex.demand_mono ']'
end
| l when lex.granted_word "file" ->
lex.demand_word "of";
data_type ()
| l when lex.granted_word "array" ->
lex.demand_mono '[';
constant_value ();
lex.demand_poly "..";
constant_value ();
lex.demand_mono ']';
lex.demand_word "of";
data_type ()
| l when lex.granted_word "record" ->
components ();
lex.demand_word "end"
| l when lex.granted_word "procedure" ->
procedure_type ()
| l when lex.granted_word "function" ->
procedure_type (); lex.demand_mono ':'; data_type ()
| l when lex.granted_mono '^' ->
data_type ()
| l when lex.granted_mono '(' ->
simple_name ();
while lex.granted_mono ',' do
simple_name ()
done;
lex.demand_mono ')'
| l -> simple_name ()

Sachant que constant_value(), components () et procedure_type () restent encore à définir.

Une valeur constante est soit un nom (défini à l'aide de const) soit une constante entière :

and constant_value () =
if lex.promised_name () then simple_name ()
else ignore (lex.demand_int ())

L'ensemble des composantes d'un enregistrement est une série de déclarations noms:type séparées par des virgules et points-virgules :

and components () =
simple_name ();
while lex.granted_mono ',' do
simple_name ()
done;
lex.demand_mono ':';
data_type ();
if lex.granted_mono ';' then components ()

Un type procedure se résume à une (éventuelle) liste d'arguments formels noms:type séparés par des virgules et points-virgules. Ces arguments pourront être annotés const, var, in, out selon la façon dont on peut ou non les modifier.

and procedure_type () =
if lex.granted_mono '(' then
let rec loop () =
( match lex with
| l when lex.granted_word "const" -> ()
| l when lex.granted_word "var" -> ()
| l when lex.granted_word "in" -> ()
| l when lex.granted_word "out" -> ()
| l -> ()
) ;
simple_name ();
while lex.granted_mono ',' do
simple_name ()
done;
lex.demand_mono ':';
data_type ();
if lex.granted_mono ';' then loop ()
in loop (); lex.demand_mono ')'

C'est fini pour les types.

Nous avons les expressions, nous avons les instructions, nous avons les types, il nous manque les deux derniers niveaux hiérarchiques supérieurs, à savoir :

- les déclarations (de constantes, de types, de variables globales, de procédures, de fonctions) ;

- les unités et les programmes.

Une simple boucle nous donnera une vue d'ensemble des définitions :

- ou bien une déclaration débute par l'un des mots-clés const type var procedure function ;

- ou bien on quitte la boucle des déclarations.

and declare () =
comments ();
match lex with
| l when lex.granted_word "const" ->
comments (); constant (); declare ()
| l when lex.granted_word "type" ->
comments (); definition (); declare ()
| l when lex.granted_word "var" ->
comments (); components (); declare ()
| l when lex.granted_word "procedure" ->
comments (); procedure (); declare ()
| l when lex.granted_word "function" ->
comments (); typed_procedure (); declare ()
| l -> ()

Les déclarations sont souvent un endroit privilégié pour placer des commentaires.
Le module Lex ne gère pas tout seul les commentaires, les commentaires font donc partie de la grammaire.
Nous utiliserons les commentaires d'une ligne tels que Delphi les recommande :

and comments () =
while lex.granted_poly "//" do
lex.demand_line ()
done

La déclaration de constantes réutilise constant_value :

and constant () =
comments ();
simple_name ();
lex.demand_mono '=';
constant_value ();
if lex.granted_mono ';' then constant ()

La déclaration de types réutilise data_type :

and definition () =
comments ();
simple_name ();
lex.demand_mono '=';
data_type ();
if lex.granted_mono ';' then definition ()

La déclaration de procédures réutilise procedure_type :

and procedure () =
simple_name (); procedure_type ();
lex.demand_mono ';';
procedure_body ()

Une fonction est une typed_procedure :

and typed_procedure () =
simple_name (); procedure_type ();
lex.demand_mono ':'; data_type (); lex.demand_mono ';';
procedure_body ()

Le corps d'une procédure est :

- ou bien une déclaration avancée forward ;

- ou bien une séquence begin...end éventuellement précédée d'une déclaration locale var (les components d'une procédure).

and procedure_body () =
if not (lex.granted_word "forward") then begin
if lex.granted_word "var" then components ();
sequence ();
end;
lex.demand_mono ';'

Un programme débute par program puis un certain nombre de déclarations précèdent une séquence begin...end.

and program () =
lex.demand_word "program";
simple_name ();
lex.demand_mono ';';
comments ();
declare ();
sequence ()

Une unité débute par unit.
Puis suivent les sections interface et implementation.
Une unité est éventuellement clôturée par une séquence begin...end.

and modular () =
lex.demand_word "unit";
simple_name ();
lex.demand_mono ';';
comments ();
lex.demand_word "interface";
imports ();
comments ();
declare ();
lex.demand_word "implementation";
imports ();
declare ();
if lex.promised_word "begin" then sequence ()
else lex.demand_word "end"

Enfin, une clause d'importation est un mot-clé uses suivi d'une liste de noms d'unités séparés par une virgule :

and imports () =
comments ();
while lex.granted_word "uses" do
comments ();
simple_name ();
while lex.granted_mono ',' do
simple_name ()
done;
lex.demand_mono ';'
done;

VIII-A-4 - 51. Les erreurs de syntaxe

Nous en arrivons au programme principal où il n'est plus question que de :

- discriminer entre unit et program ;

- demander le caractère '.' qui termine tout programme ou unité ;

- traiter les erreurs de syntaxe.

and turbo_pascal_5 () =
try
comments ();
if lex.promised_word "unit" then modular ()
else program ();
if lex.promised_mono '.' then ()
else lex.demand_mono '.'
with
| Lex.Demand_denied(position,demand) ->
Lex.print_position position;
Lex.print_denied   demand;
| Lex.Word_reserved(position) ->
Lex.print_position position;
Lex.print_reserved ();
| End_of_file ->
print_endline "unexpected end of text"

in turbo_pascal_5 ()

On voit qu'en fait il n'y a que trois erreurs possibles, chacune générant une exception :

- une requête lex.demand_... n'a pas pu être satisfaite et une exception Lex.Demand_denied est levée ;

- une requête lex.demand_not reserved n'a pas pu être satisfaite et une exception Lex.Word_reserved est levée ;

- le texte se termine prématurément et une exception End_of_file est levée.

Lex.print_position, Lex.print_denied et Lex.print_reserved génèrent un rapport d'erreur qui permet à l'utilisateur de localiser l'unité lexicale fautive et de la situer dans son contexte en affichant :

- l'unité lexicale qui était attendue ;

- le numéro de la ligne fautive ;

- le texte de la ligne fautive (le passage incriminé est souligné).

Le traitement spécifique au point qui suit le end final mérite un petit commentaire.
Pour imposer la présence d'un point, il suffit habituellement de la requête :

lex.demand_mono '.';

Le problème c'est que si cette requête réussit alors elle va lire une unité lexicale supplémentaire.
Et comme c'est normalement la fin du texte une exception End_of_file va être générée.
Pour éviter ce désagrément, l'idée est de tester la présence du point avec lex.promised et de ne faire appel à lex.demand qu'en cas d'erreur :

if lex.promised_mono '.' then ()
else lex.demand_mono '.'

C'est plus alambiqué qu'à l'habitude, mais on obtient le comportement adéquat.

VIII-A-5 - 52. Implémentation de Lex.lex_parser

L'implémentation du module Lex est très représentative de la flexibilité de l'approche fonctionnelle.

À première vue, avec notre utilisation abondante de la notation pointée, on pourrait penser à quelque classe équipée d'un constructeur make dans le style classique de la programmation orientée objet.
Or il n'en est rien, nous n'avons utilisé que des constructions Caml déjà connues.

La notation pointée n'est due qu'à un type enregistrement dont les composantes sont de type fonctionnel :

type lex_parser =
{
(* demands *)
demand_line   : unit   -> unit;
demand_word   : string -> unit;
demand_mono   : char   -> unit;
demand_poly   : string -> unit;
demand_name   : unit   -> string;
demand_not    : (string -> bool) -> string;
demand_string : unit   -> string;
demand_char   : unit   -> char;
demand_int    : unit   -> int;
(* promises *)
promised_word : string -> bool;
promised_mono : char   -> bool;
promised_name : unit   -> bool;
promised_int  : unit   -> bool;
(* grants *)
granted_word  : string -> bool;
granted_mono  : char   -> bool;
granted_poly  : string -> bool;
}

Le constructeur make à son tour n'est qu'une fonction ordinaire qui :

- définit des variables locales ;

- définit des fonctions locales manipulant l'état local ;

- utilise ces fonctions locales pour construire un objet de type Lex.lex_parser.

Le squelette de make ressemble à ceci (les passages omis ont été remplacés par ...) :

let make file =

let
(* local variables *)
...
in

(* demands *)
let demand_line () = ...
and demand_word s = ...
and demand_mono c = ...
and demand_poly s = ...
and demand_name () = ...
and demand_not reserved = ...
and demand_string () = ...
and demand_char () = ...
and demand_int  () = ...
(* promises *)
and promised_word s = ...
and promised_mono c = ...
and promised_name () = ...
and promised_int  () = ...
(* grants *)
and granted_word s = ...
and granted_mono c = ...
and granted_poly s = ...
in

demand_line ();

(* build a lex_parser object *)
{
(* demands *)
demand_line   = demand_line;
demand_word   = demand_word;
demand_mono   = demand_mono;
demand_poly   = demand_poly;
demand_name   = demand_name;
demand_not    = demand_not;
demand_string = demand_string;
demand_char   = demand_char;
demand_int    = demand_int;
(* promises *)
promised_word = promised_word;
promised_mono = promised_mono;
promised_name = promised_name;
promised_int  = promised_int;
(* grants *)
granted_word  = granted_word;
granted_mono  = granted_mono;
granted_poly  = granted_poly;
}

IX - Partie VIII

1. Ordre lexicographique

2. Les types produit

3. Les types somme

4. Les types inductifs

5. Le typage des fonctions partielles

6. Les catamorphismes

7. Les paramorphismes

IX-A - Les types algébriques

On appelle type algébrique un type qui réalise la somme de produits de types.
Ce vocabulaire sera défini en deux chapitres :

- le chapitre 54 a pour objet de définir la nature d'un type produit ;

- le chapitre 55 a pour objet de définir la nature d'un type somme.

La connaissance des types somme et des types produit entraîne la connaissance des types algébriques.
Les types inductifs sont des types algébriques récursifs et feront l'objet du chapitre 56.
Enfin, les schémas de récursion les plus courants seront présentés dans les chapitres 58 et 59.

IX-A-1 - 53. Ordre lexicographique

Implémenter un ordre total sur un type revient à implémenter une fonction similaire à la fonction Pervasives.compare.
Parfois on a une implémentation d'un ordre total sur un type et on veut l'étendre à une structure de donnée.
Par exemple on peut vouloir étendre cet ordre vers un ordre sur les listes ou sur les n-uplets.
Il existe une façon générale de réaliser cette extension, cette façon se nomme ordre lexicographique et fonctionne de façon similaire à l'ordre alphabétique.

Prenons exemple sur les caractères.
On peut bien sûr comparer deux caractères de type char :

# 'a' < 'o';;
- : bool = true

Et on peut aussi comparer deux chaînes de caractères de type string :

# "baba" < "bobo";;
- : bool = true

Cette façon d'étendre la comparaison du type char vers le type string c'est l'ordre alphabétique. On compare d'abord le 1er caractère, en cas d'égalité on compare le 2d, puis éventuellement le 3e, et ainsi de suite jusqu'à éventuellement atteindre la fin de la chaîne. C'est justement cette méthode qu'utilise la fonction Pervasives.compare. Illustration avec les listes :

# ['b';'a';'b';'a'] < ['b';'o';'b';'o'];;
- : bool = true

Puis avec les n-uplets :

# ('b','a','b','a') < ('b','o','b','o');;
- : bool = true

Remarque : dans le cas où l'on implémente une fonction compare spécifique (nous l'avons déjà fait par exemple pour les inventaires) la fonction qui suit nous renvoie l'extension lexicographique de cet ordre sur les listes.

# let lexicographical (cmp:'a -> 'a -> int) =
let rec loop l1 l2 =
match l1,l2 with
| [],[] -> 0
| [],_ -> -1
| _,[] ->  1
| h1::t1,h2::t2 ->
let c = cmp h1 h2 in
if c = 0 then loop t1 t2
else c
in loop;;
val lexicographical : ('a -> 'a -> int) -> 'a list -> 'a list -> int = <fun>

IX-A-2 - 54. Les types produit

On appelle type produit un type qui réalise le produit cartésien de deux ou plusieurs types.

En OCaml il s'agit essentiellement :

- des n-uplets dont on a parlé dans le chapitre 18. Les couples, le constructeur pour ces types est le caractère étoile, le constructeur pour ces valeurs est le caractère virgule ;

- des enregistrements dont on a parlé dans le chapitre 23. Les enregistrements, les constructeurs pour ces types sont les noms d'un type enregistrement, le constructeur pour ces valeurs est la paire d'accolades.

IX-A-3 - 55. Les types somme

On appelle type somme un type qui réalise l'union disjointe de plusieurs types.
Il s'agit des types énumérés dont on a parlé au chapitre 13. Les types énumérés, le constructeur pour ces types est le caractère barre verticale, le constructeur pour ces valeurs est un variant.

À voix haute la barre verticale se lit "ou bien".

Les variants ne sont pas limités aux types énumérés et nous allons progressivement exposer toute leur généralité.
Nous allons commencer par un simple problème de jeu de cartes qui suffira amplement à se convaincre de leur étonnante expressivité. Le problème que nous avons choisi est celui de la main gagnante au poker, après l'abattage (showdown) : laquelle parmi deux mains l'emporte sur l'autre ?

Le néophyte pourra rapidement s'initier au poker, il retiendra en particulier qu'une main au poker est constituée de cinq cartes et que le jeu consiste à produire la meilleure combinaison possible :

- avoir en main une carte haute (HighCard) c'est passable ;

- avoir en main une paire (OnePair) c'est un peu mieux ;

- avoir en main deux paires (TwoPair) c'est déjà pas mal ;

- avoir en main un brelan (ThreeOfAKind) c'est meilleur ;

- avoir en main une quinte (Straight) c'est déjà confortable ;

- avoir en main une couleur (Flush) c'est encore plus confortable ;

- avoir en main une main pleine (FullHouse) c'est bien plus avantageux ;

- avoir en main un carré (FourOfAKind) c'est encore plus avantageux ;

- avoir en main une quinte-flush (StraightFlush) c'est l'idéal.

On résume ainsi la relation d'ordre total pour une combinaison :

- HighCard < OnePair < TwoPair < ThreeOfAKind < Straight < Flush < FullHouse < FourOfAKind < StraightFlush

Ainsi bien sûr que la relation d'ordre total pour une carte seule :

- 2 < 3 < 4 < 5 < 6 < 7 < 8 < 9 < 10 < jack < queen < king < ace.

Pour implémenter l'ordre total sur une seule carte, il suffit de désigner les cartes numériques par leur valeur entière et les figures par cette définition multiple (à l'aide de l'appariement de motif sur un quadruplet) :

# let ace,king,queen,jack = 50,40,30,20;;
val ace : int = 50
val king : int = 40
val queen : int = 30
val jack : int = 20

La tentation est grande d'appliquer la même technique (appariement de motif sur un n-uplet) pour implémenter l'ordre total sur une combinaison :

let
highcard,onepair,twopair,threeofakind,straight,
flush,fullhouse,fourofakind,straightflush
=
1,2,3,4,5,6,7,8,9
;;

Et cela nous permet bien la comparaison de deux combinaisons. Cependant l'exemple des jours de la semaine dans le déjà lointain chapitre 14. Le filtrage et la discussion qui en découlait nous incitent à penser qu'un type énuméré ferait mieux l'affaire. Nous préfèrerons donc déclarer le type poker_hand :

type poker_hand =
| HighCard
| OnePair
| TwoPair
| ThreeOfAKind
| Straight
| Flush
| FullHouse
| FourOfAKind
| StraightFlush
;;

D'un côté, en éliminant les valeurs numériques arbitraires, nous gagnons en clarté, de plus le type poker_hand est désormais candidat au filtrage, une facilité si essentielle que l'habitude et le confort nous l'ont déjà rendue indispensable. De l'autre côté, nous ne perdons absolument rien, car, les fonctions standards de comparaisons étant polymorphes, les types énumérés sont aussi bien ordonnés que les int. Pour l'exemple :

# ThreeOfAKind < FullHouse;;
- : bool = true
# compare Straight StraightFlush;;
- : int = -1

Toutefois il subsiste encore deux questions sans réponse :

- que décider en cas de combinaisons de force égale, par exemple comment comparer un brelan de dames avec un brelan de rois ? ;

- comment comparer deux mains opposant la même combinaison, par exemple une paire de dames contre une paire de dames ?

À ces deux problèmes OCaml apporte une seule et même solution :

- ou bien un variant n'attend aucun paramètre ;

- ou bien un variant attend exactement un paramètre.

Le paramètre d'un variant peut être de n'importe quel type et en particulier un type produit.
Un type énuméré est un type somme dégénéré, aucun de ses variants n'admet un paramètre.

Pour spécifier le paramètre d'un variant on utilise le mot-clé of suivi du type du paramètre.
Par exemple il est tout à fait judicieux de déclarer notre type poker_hand comme ceci :

type poker_hand =
| HighCard of int * int * int * int * int
| OnePair of int * int * int * int
| TwoPair of int * int * int
| ThreeOfAKind of int
| Straight of int
| Flush of int * int * int * int * int
| FullHouse of int * int
| FourOfAKind of int
| StraightFlush of int
;;

Le type poker_hand réalise l'union disjointe de n-uplets, c'est donc un type somme de produits ou type algébrique (non récursif).

À variant égal la comparaison de deux valeurs de type poker_hand se fait selon l'ordre lexicographique sur les n-uplets.
Par exemple cet extrait de session compare dans l'ordre, deux cartes hautes, deux paires de dames, deux mains pleines, et pour fournir une quinte-flush au 8 face à une quinte-flush au 6 :

HighCard(king,queen,jack,10,7) > HighCard(king,queen,jack,10,5);;
- : bool = true
OnePair(queen,king,jack,10) > OnePair(queen,king,jack,7);;
- : bool = true
FullHouse(queen,jack) > FullHouse(queen,10);;
- : bool = true
StraightFlush(8) > StraightFlush(6);;
- : bool = true

IX-A-4 - 56. Les types inductifs

On appelle type inductif un type algébrique récursif.

La récursivité permet la création de types composites, avec un type inductif on peut créer des composants, c'est-à-dire des valeur-objets enfichables qui sont toujours du même type et qui sont traités de façon uniforme quelle que soit leur complexité.

Premier exemple :

Une liste de type 'a list est :

- ou bien la liste vide Nil ;

- ou bien une paire Cons formée d'une tête de type 'a et d'une queue de type 'a list.

Le type 'a list est donc un type inductif que l'on pourrait déclarer ainsi :

# type 'a list =
| Nil
| Cons of 'a * ('a list)
;;
type 'a list = Nil | Cons of 'a * 'a list

La liste 1::2::3::[] s'écrirait alors Cons(1,Cons(2,Cons(3,Nil))) et l'opérateur de concaténation s'implémenterait ainsi :

# let rec append l1 l2 =
match l1 with
| Nil -> l2
| Cons(h,t) -> Cons(h,append t l2)
;;
val append : 'a list -> 'a list -> 'a list = <fun>

Même si le type 'a list n'était pas prédéfini en OCaml nous pourrions encore l'implémenter simplement grâce à un type inductif.

Remarque : la définition du type list ci-dessus a écrasé la définition du type list prédéfini, celui-ci n'est plus disponible pour l'utilisateur, il vous faut redémarrer l'interpréteur pour avoir à nouveau accès au type list prédéfini que bien sûr nous allons continuer d'utiliser dans la suite de ce cours.

Autre exemple :

Au chapitre 33 nous n'avons pas réussi à implémenter les arbres n-aires à l'aide d'un couple (c'est-à-dire à l'aide d'un simple type produit), nous allons voir que ce qui faisait obstacle c'étaient la notion de type inductif qui nous manquait encore à ce moment.

Un arbre n-aire est :

- un nœud (node) contenant un élément et une liste de sous-arbres n-aires (récursivement).

La déclaration de ce type suit immédiatement :

# type 'a tree =
Node of 'a * ('a tree list);;
type 'a tree = Node of 'a * 'a tree list

Pas de surprise, nos fonctions sur ces arbres n-aires sont tout à fait analogues à leurs cousines du chapitre 33 qui utilisaient un type enregistrement :

let rec rev_tree (Node(a,l)) =
Node(a,List.rev_map rev_tree l);;

let rec map_tree f (Node(a,l)) =
Node(f a,List.map (map_tree f) l);;

let rec exists_tree p (Node(a,l)) =
p a or List.exists (exists_tree p) l;;

Une dernière utilisation des types inductifs est d'une importance particulière, ce sont les arbres de syntaxe abstraite qui modélisent les expressions, par exemple les expressions arithmétiques, ici avec les quatre opérateurs :

type arithmetic =
| Int of int
| Neg of arithmetic
| Add of arithmetic * arithmetic
| Sub of arithmetic * arithmetic
| Mul of arithmetic * arithmetic
| Div of arithmetic * arithmetic
;;

Ces types inductifs sont généralement accompagnés d'une fonction d'évaluation, soit eval pour notre exemple :

# let rec eval expr =
match expr with
| Int n -> n
| Neg a -> - eval a
| Add(a,b) -> eval a + eval b
| Sub(a,b) -> eval a - eval b
| Mul(a,b) -> eval a * eval b
| Div(a,b) -> eval a / eval b
;;
val eval : arithmetic -> int = <fun>

IX-A-5 - 57. Le typage des fonctions partielles

On appelle fonction partielle une fonction dont le domaine de définition est strictement inclus dans son type.

Jusqu'ici nous avons contourné cette question du domaine de définition à l'aide :

- soit d'une assertion ;

- soit d'une exception.

Typiquement nous avions ce genre de comportement :

# eval (Div(Int 1, Int 0));;
Exception: Division_by_zero.

Non seulement l'interpréteur ne nous affiche pas de valeur, mais en plus il n'est même pas capable de nous afficher un type.
Une exception, au même titre qu'une assertion, est toujours un recours dynamique face à un constat d'échec du typage statique.
Ne peut-on pas typer eval statiquement, de manière totale, sûre et définitive ?

C'est possible, et la solution vient des types sommes.
Ce qu'il nous faut c'est transcrire le fait que le résultat de eval est :

- ou bien un entier ;

- ou bien l'échec d'une opération de division.

Une fois cette alternative intégrée dans le type de eval la fonction redeviendra forcément totale.

Le type result nous permet de généraliser cette alternative, un résultat result sera ou bien Ok ou bien une Error :

type ('a,'b) result =
| Ok of 'a
| Error of 'b
;;

Nous pouvons à présent écrire une version exception-less de notre évaluateur arithmétique :

# let rec eval expr =
match expr with
| Int n ->
Ok n
| Neg a ->
( match eval a with
| Ok a -> Ok (-a)
| _ -> Error "Division by 0")
| Add(a,b) ->
( match eval a,eval b with
| Ok a,Ok b -> Ok (a+b)
| _,_ -> Error "Division by 0")
| Sub(a,b) ->
( match eval a,eval b with
| Ok a,Ok b -> Ok (a-b)
| _,_ -> Error "Division by 0")
| Mul(a,b) ->
( match eval a,eval b with
| Ok a,Ok b -> Ok (a*b)
| _,_ -> Error "Division by 0")
| Div(a,b) ->
( match eval a,eval b with
| Ok a,Ok b when b<>0 -> Ok (a/b)
| _,_ -> Error "Division by 0")
;;
val eval : arithmetic -> (int, string) result = <fun>

Ce code contient trop de redites, certes nous n'avons plus d'exception, mais le calcul du résultat est comme obscurci par la gestion de la propagation de l'erreur. Nous allons remédier à cela.

À l'aide de ces trois petites fonctions utilitaires :

let ok1 v f =
match v with
| Ok x -> Ok (f x)
| Error _ -> v
;;

let ok2 v1 v2 f =
match v1,v2 with
| Ok x1,Ok x2 -> Ok (f x1 x2)
| Error _, _ -> v1
| _, Error _ -> v2
;;

let result2 v1 v2 f =
match v1,v2 with
| Ok x1,Ok x2 -> f x1 x2
| Error _, _ -> v1
| _, Error _ -> v2
;;

Nous pouvons refactoriser la fonction eval comme ceci :

# let rec eval expr =
match expr with
| Int n ->
Ok n
| Neg a ->
ok1 (eval a) (~-)
| Add(a,b) ->
ok2 (eval a) (eval b) (+)
| Sub(a,b) ->
ok2 (eval a) (eval b) (-)
| Mul(a,b) ->
ok2 (eval a) (eval b) ( * )
| Div(a,b) ->
result2
(eval a) (eval b)
(fun a b -> if b=0 then Error "Division by 0" else Ok (a/b))
;;
val eval : arithmetic -> (int, string) result = <fun>

C'est nettement plus clair !

Le bon point ici est que nos fonctions utilitaires sont universelles au sens où nous n'aurons pas à les réécrire, elles constituent une solution réutilisable au problème des fonctions partielles sur les types inductifs.

Nous allons l'illustrer sur un second exemple.
Il s'agit cette fois de dimensionner correctement une expression matricielle.
Le type grid nous servira de dimension matricielle :

type grid =
{rows: int; columns: int};;

Tandis que le type mat_expr représentera une expression matricielle :

type mat_expr =
| Mat of grid
| MatNeg of mat_expr
| MatTrans of mat_expr
| MatPower of mat_expr * int
| MatSum of mat_expr * mat_expr
| MatProduct of mat_expr * mat_expr
;;

Avec pour opérations :

- la négation ;

- la transposée ;

- la puissance par un entier ;

- la somme ;

- le produit matriciel.

Le code de la fonction mat_size, qui dimensionne une expression matricielle, montre comment une solution exception-less passe à nouveau par les fonctions utilitaires ok1, ok2 et result2.

# let rec mat_size mat_expr =
match mat_expr with
| Mat g ->
Ok g
| MatNeg m ->
mat_size m
| MatPower(m,n) ->
mat_size m
| MatTrans m ->
ok1
(mat_size m)
(fun g -> {rows=g.columns;columns=g.rows})
| MatSum(m1,m2) ->
result2
(mat_size m1)
(mat_size m2)
(fun g1 g2 ->
if g1 = g2 then Ok g1
else Error "Addition of different sized matrices")
| MatProduct(m1,m2) ->
ok2
(mat_size m1)
(mat_size m2)
(fun g1 g2 -> {rows=g1.rows;columns=g2.columns})
;;
val mat_size : mat_expr -> (grid, string) result = <fun>

IX-A-6 - 58. Les catamorphismes

On appelle catamorphisme une fonction qui réalise un parcours canonique sur un type inductif.

Le type inductif le plus élémentaire est le type list, le module List fournit deux sortes de parcours sur les listes :

- la fonction fold_right effectue un parcours récursif, on pourrait l'implémenter comme ceci :

let rec fold_right f l init =
match l with
| [] -> init
| h::t -> f h (fold_right f t init)
;;

- la fonction fold_left effectue un parcours récursif terminal, on pourrait l'implémenter comme ceci :

let rec fold_left f init l =
match l with
| [] -> init
| h::t -> fold_left f (f init h) t
;;

Plutôt que ces implémentations un peu ardues, essayons de donner une définition d'un catamorphisme de liste :

- l'image de [] par un catamorphisme est la valeur initiale init ;

- la fonction f attend deux arguments ;

- soit $$ un opérateur infixe égal à la fonction f et que l'on pourrait déclarer ainsi :

let ($$) = f;;

- alors l'image d'une liste a0::a1:: ... ::an::[] par un catamorphisme est la valeur a0$$a1$$ ... $$an$$init.

En résumé :

- le constructeur inital [] est remplacé par la valeur initiale init ;

- chaque constructeur :: est remplacé par l'opérateur $$.

Le module Seq qui suit illustre la généralité des catamorphismes fold_left et fold_right, cette implémentation d'une partie de la signature du module List est surprenante de concision :

module Seq = struct
let rec fold_left f init l =
match l with
| [] -> init
| h::t -> fold_left f (f init h) t
let rec fold_right f l init =
match l with
| [] -> init
| h::t -> f h (fold_right f t init)
let length l = fold_left (fun a b -> a+1) 0 l
let rev l = fold_left (fun a b -> b::a) [] l
let append l1 l2 = fold_right (fun a b -> a::b) l1 l2
let rev_append l1 l2 = fold_left (fun a b -> b::a) l2 l1
let iter f l = fold_left (fun a b -> f b) () l
let map f l = fold_right (fun a b -> f a::b) l []
let rev_map f l = fold_left (fun a b -> f b::a) [] l
let flatten l = fold_right append l []
let for_all f l = fold_left (fun a b -> f b && a) true l
let exists f l = fold_left (fun a b -> f b or a) false l
let mem x l = fold_left (fun a b -> x=b or a) false l
let filter f l = fold_right (fun a b -> if f a then a::b else b) l []
let partition f l = fold_right (fun a (p,q) -> if f a then (a::p,q) else (p,a::q)) l ([],[])
let split l = fold_right (fun (a,b) (p,q) -> (a::p,b::q)) l ([],[])
end;;

Le cas des arbres binaires est également intéressant.

Un arbre binaire est :

- ou bien une feuille (leaf) sans élément ;

- ou bien un noeud (node) contenant un élément et deux sous-arbres binaires (récursivement).

Le module BinaryTree qui suit introduit un type tree et son catamorphisme fold, ensuite il utilise fold pour implémenter la taille (size), la profondeur (depth), le nombre de Strahler (strahler), puis d'autres fonctions de parcours de même sémantique que leurs homonymes sur les listes :

module BinaryTree = struct
type 'a tree =
| Leaf
| Node of ('a tree) * 'a * ('a tree)
let fold f init t =
let rec loop t =
match t with
| Leaf -> init
| Node(l,a,r) -> f (loop l) a (loop r)
in loop t
let size t  = fold (fun l a r -> l + r + 1) 0 t
let depth t = fold (fun l a r -> max l r + 1) 0 t
let strahler t = fold (fun l a r -> if l=r then l+1 else max l r) 1 t
let rev t = fold (fun l a r -> Node(r,a,l)) Leaf t
let iter f t = fold (fun l a r -> f a) () t
let map  f t = fold (fun l a r -> Node(l,f a,r)) Leaf t
let flatten t = fold (fun l a r -> l @ a::r) [] t
let for_all f t = fold (fun l a r -> l && r && f a) true t
let exists  f t = fold (fun l a r -> l or r or f a) false t
let mem x t = fold (fun l a r -> l or r or x=a) false t
let split t = fold (fun (m,q) (a,b) (p,r) -> Node(m,a,p),Node(q,b,r)) (Leaf,Leaf) t
end;;

Nous vous renvoyons à la thèse de Nicolas Janey pour une définition des nombres de Horton-Strahler (lire les paragraphes 3.2.1 à 3.2.3) et pour leur application en botanique, en hydrogéologie et en topologie.

Le module BinaryTree se prête volontiers à une généralisation aux arbres n-aires tels que nous les avons définis au chapitre 57.
Ce sera le module NaryTree qui, après la définition du type tree et l'introduction des ses deux catamorphismes fold_left et fold_right, implémente les opérations sur les arbres n-aires, toujours avec une extrême concision :

module NaryTree = struct
type 'a tree =
Node of 'a * ('a tree list)
let fold_left g f init t =
let rec helper (Node(a,l)) =
let loop = List.fold_left (fun a b -> f (helper b) a) init l
in  g a loop
in helper t
let fold_right g f init t =
let rec helper (Node(a,l)) =
let loop = List.fold_right (fun a b -> f (helper a) b) l init
in  g a loop
in helper t
let cons a b = a::b
let size t = fold_left (fun a l -> l + 1) (+)  t
let depth t = fold_left (fun a l -> l + 1) max 1 t
let rev t = fold_left (fun a l -> Node(a,l)) cons [] t
let iter f t = fold_left (fun a l -> f a) (fun a b -> ()) () t
let map f t = fold_right (fun a l -> Node(f a,l)) cons [] t
let rev_map f t = fold_left (fun a l -> Node(f a,l)) cons [] t
let flatten t = fold_left cons (@) [] t
let for_all f t = fold_left (fun a l -> l && f a) (&&) true t
let exists  f t = fold_left (fun a l -> l or f a) (||) false t
let mem x t = fold_left (fun a l -> l or x=a) (||) false t
end;;

À ce stade on peut se demander à quoi servent les catamorphismes.
Après tout on a déjà le filtrage qui est une facilité très puissante.
Et les modules exportent d'autres facilitées plus immédiates comme rev, map ou filter.
Alors on peut penser que les catamorphismes c'est concis, le concept est élégant, mais en pratique ce qui compte c'est l'inferface d'un module et non la concision de son implémentation.

Sans vouloir minimiser le bien-fondé de ces deux remarques, il faut tout de même dire que le programmeur fonctionnel expérimenté ne peut pas complètement faire l'économie des catamorphismes.

Pour deux raisons principales :

- en tant qu'utilisateur d'un module le programmeur fonctionnel peut être confronté à une situation où son besoin n'est pas couvert par l'interface du module (les fonctions classiques rev, map ou filter...). Dans ce cas il ne peut pas non plus coder son propre parcours à l'aide du filtrage, car l'implémentation du type à parcourir est cachée par le module, on ne connaît pas son schéma, on ne peut pas filtrer ses valeurs. Il ne reste alors plus qu'une option disponible: paramétrer le fold dont le bon implémenteur de module aura eu soin d'équiper son interface ;

- en tant qu'implémenteur de composants certifés ou critiques, paramétrer un fold est une option plus sûre, car on ne peut pas faire une récursion mal fondée. Un catamorphisme est structurellement bien fondé, l'utiliser c'est déjà une preuve de terminaison, mais surtout c'est une base pour le raisonnement inductif et un premier pas important vers la preuve de programme.

Comme nous avons déjà vu beaucoup d'exemples de modules, jusqu'à la fin de ce chapitre nous allons nous placer dans le cadre plus confidentiel de la preuve de programme. Aussi, si vous n'êtes pas intéressé par la preuve de programme, vous pouvez sans conséquence aucune faire l'impasse sur cette fin de partie VIII.

Sinon vous allez voir comment remplacer la récursion par l'utilisation systématique de schémas de récursion afin de faciliter le raisonnement inductif.
Pour l'exemple nous allons nous concentrer sur les arbres binaires et le type :

type 'a tree =
| Leaf
| Node of ('a tree) * 'a * ('a tree)

Avec l'intention de lui adjoindre des opérations classiques comme member, insert et remove, autant dire que ce que nous voulons spécifier ce n'est plus un simple arbre binaire, mais bien un arbre binaire de recherche (binary search tree).

Un arbre binaire de recherche est un arbre binaire qui vérifie les deux propriétés suivantes :

- l'élément porté par un fils gauche est toujours strictement plus petit que l'élément porté par son parent ;

- l'élément porté par un fils droit est toujours strictement plus grand que l'élément porté par son parent.

Comme nous l'avons déjà mentionné à maintes reprises, le système de types d'OCaml n'est que structurel, il n'est pas capable de distinguer un arbre binaire ordonné (par la propritété ci-dessus) d'un simple arbre binaire quelconque. Si bien que nous allons recourir au pis aller habituel : un prédicat ordered nous dit si un arbre binaire est ordonné et ce prédicat nous sert de précondition pour les fonctions member, insert et remove.

let fold init f t =
let rec loop t =
match t with
| Leaf -> init
| Node(l,a,r) -> f (loop l) a (loop r)
in loop t

Ce fold devrait faire l'affaire, il devrait suffire de le paramétrer pour obtenir le prédicat ordered que nous voulons.
Malheureusement ce que l'on cherche c'est à encadrer chaque arbre par un minorant et un majorant, or Leaf ne porte aucune valeur, dans ces conditions il n'est pas facile de l'encadrer, et pas facile non plus d'encadrer son parent.

Le prédicat ordered serait plus évident à implémenter si nous avions toujours accès à au moins une valeur initiale, il serait plus confortable que chaque feuille contienne au moins un élément.
Après tout OCaml exige bien une valeur initiale pour créer une référence ou pour créer un tableau alors pourquoi pas pour quelque chose de plus compliqué comme un arbre binaire de recherche ?
Sans plus d'états d'âme, nous interdisons carrément qu'un arbre binaire soit vide :

type 'a tree =
| One  of 'a
| Pair of 'a * 'a
| Node of ('a tree) * 'a * ('a tree)

Puis nous équipons cet arbre binaire de son catamorphisme canonique :

let cata_rec one pair node t =
let rec loop t =
match t with
| One a -> one a
| Pair(a,b) -> pair a b
| Node(l,a,r) -> node (loop l) a (loop r)
in loop t

Est-ce qu'au moins cela nous facilite l'implémentation du prédicat ordered ? Oui, car il est désormais facile d'encadrer n'importe quel arbre par un intervalle (minorant, majorant) :

let ordered t =
let a,b =
cata_rec
(fun a -> a,a)
(fun a b -> a,b)
(fun (l1,l2) a (r1,r2) ->
if l1>l2 then l1,l2
else if l2>a then l2,a
else if a>r1 then a,r1
else if r1>r2 then r1,r2
else l1,r2
)
t
in a<=b

Muni de ce prédicat et de notre catamorphisme canonique rien n'est plus simple que d'implémenter member c'est-à-dire une fonction de recherche d'un élément x dans t (un arbre binaire ordonné) :

let member x t =
assert(ordered t);
cata_rec
(fun a -> x=a)
(fun a b -> x=a or x=b)
(fun l a r -> l or x=a or r)
t

Mais attendez voir... c'est exactement la même fonction que mem, la recherche dans un arbre binaire quelconque! Où est l'intérêt d'un arbre binaire de recherche s'il n'accélère pas la recherche ?
Nous voudrions pouvoir rechercher un élément dans un temps proportionnel à la profondeur de l'arbre, et pas dans un temps proportionnel à sa taille.

Comment empêcher notre catamorphisme de parcourir l'arbre en totalité ?
Ce qu'il nous faudrait c'est un parcours moins avide, un parcours qui se laisse diriger. Ce parcours plus lazy nous l'appellerons caty_rec, il est le frère de cata_rec, le même en plus paresseux :

let caty_rec one pair node t =
let rec loop t () =
match t with
| One a -> one a
| Pair(a,b) -> pair a b
| Node(l,a,r) -> node (loop l) a (loop r)
in loop t ()

Et il nous permet d'effectuer notre recherche en temps logarithmique :

let member x t =
assert(ordered t);
caty_rec
(fun a -> x=a)
(fun a b -> x=a or x=b)
(fun l a r ->
if x < a then l()
else if x > a then r()
else true)
t

IX-A-7 - 59. Les paramorphismes

Autant le dire tout de suite : le plus difficile est encore devant nous, car il reste les opérations d'insertion (insert) et de suppression (remove).

Comment aborder l'insertion ?
Avec les mêmes exigences que pour l'appartenance : nous ne voulons pas reconstruire tout l'arbre, mais seulement le chemin qui mène à la nouvelle feuille.
Or, pour ne reconstruire que ce chemin, nous avons besoin de ses effluents, c'est-à-dire des anciennes composantes de chaque nœud que nous voulons remplacer.
Comme diraient les anglophones nous voulons 'eat our cake and have it too', et cela un catamorphisme ne nous le permet pas.

En résumé nous voulons à la fois :

- manger un nœud ;

- l'avoir encore sous les yeux et dans la main ;

- rester paresseux (ne pas parcourir tout l'arbre).

C'est ce petit miracle (ou plutôt ce schéma de récursion) que nous appellerons paramorphisme.
Pour un arbre binaire il prendra cette forme :

let para_rec one pair node t =
let rec loop t () =
match t with
| One a -> one a
| Pair(a,b) -> pair a b
| Node(l,a,r) -> node (l,loop l) a (r,loop r)
in loop t ()

Avec cette baguette magique, l'insertion d'un élément x ne pose plus vraiment problème :

let insert x t =
assert(not(member x t));
para_rec
(fun a -> if x > a then Pair(a,x) else Pair(x,a))
(fun a b ->
if x > b then Node(One a,b,One x)
else if x < a then Node(One x,a,One b)
else Node(One a,x,One b)
)
(fun (l1,l2) a (r1,r2) ->
if x < a then Node(l2(),a,r1)
else Node(l1,a,r2())
)
t

D'ailleurs notre baguette est tellement magique, utilisons-la vite avant qu'on nous la confisque !
Vite, nous enlevons le minorant d'un arbre binaire de recherche :

let remove_min t =
assert(ordered t);
para_rec
(fun a -> One a,a)
(fun a b -> One b,a)
(fun (l1,l2) a (r1,r2) ->
match l1 with
| One b -> r1,b
| _ -> let b,c = l2() in Node(b,a,r1),c
)
t

Grâce à quoi nous pouvons finalement retirer un élément x quelconque :

let remove x t =
assert(member x t);
para_rec
(fun a -> One a)
(fun a b -> if x > a then One a else One b)
(fun (l1,l2) a (r1,r2) ->
if x < a then Node(l2(),a,r1)
else if x > a then Node(l1,a,r2())
else
match l1,r1 with
| One b,One c -> Pair(b,c)
| One _,Node(_,_,_) -> r1
| Node(_,_,_),One _ -> l1
| Pair(b,c),One d | One b,Pair(c,d) ->
Node(One b,c,One d)
| _,_ ->
let b,c = remove_min r1 in Node(l1,c,b)
)
t

Et voilà !
Nous avons implémenté un Type Abstrait de Données récursif sans utiliser directement aucune récursion.

Si vous souhaitez approfondir le sujet et faire connaissance avec de nouveaux schémas de récursion (anamorphismes, hylomorphismes, apomorphismes) je ne peux que vous recommander la lecture de Functional Programming with Bananas, Lenses, Envelopes and Barbed Wire par Fokkinga.

X - Partie IX

1. Les arbres de Braun

2. L'interface

3. L'implémentation

4. La performance et la persistance

5. Les itérateurs

X-A - Application aux tableaux extensibles

Dans cette partie nous allons illustrer les techniques liées aux types inductifs en implémentant, dans un module, un TAD (Type Abstrait de Données) qui n'est pas natif en OCaml.

Ce faisant nous allons mettre en lumière trois facettes de notre module, trois qualités typiques d'une implémentation d'un TAD dans un langage fonctionnel :

- le module exporte des routines typiques du TAD concerné ;

- le module implémente une interface, on pourrait substituer une autre implémentation de cette même interface, le code du client resterait inchangé malgré cette substitution, l'implémentation se fait à l'aide d'un type inductif, privé, qui reste caché au client du module ;

- en utilisant les itérateurs exportés, le client du module peut en plus définir ses propres opérations avancées, sans connaître l'implémentation concrète du TAD.

Pour un type inductif, le TAD qui retiendra notre attention vous paraîtra sans doute étrangement linéaire puisque nous avons choisi d'implémenter un tableau extensible.
Il s'agit d'un dictionnaire dont les clés sont des entiers, mais celui-ci comporte quelques flexibilités supplémentaires qui le distinguent du type array ordinaire :

- le tableau n'est limité par aucune borne ;

- les éléments sont d'indices entiers, pas forcément positifs et (surtout) pas forcément consécutifs.

Pas forcément consécutifs, voilà une contrainte qui met à mal notre intuition de linéarité.
Bien sûr, la flexibilité de notre TAD aura un certain coût en termes de performance.
C'est ce que nous allons voir dans le chapitre qui suit.

X-A-1 - 60. Arbres de Braun

À la lumière de ses spécifications on peut écarter l'idée d'implémenter notre tableau extensible à l'aide d'un classique array, quelle que soit la manière de contourner l'absence de bornes elle nous conduirait à une perte d'espace insupportable dans le cas général. Le type array n'est définitivement adapté qu'à des indices raisonnablement consécutifs.

L'arbre AVL (Adelson-Velskii-Landis) représente une alternative plus crédible :

- il n'impose aucune borne sur la clé ;

- il est optimum en espace, une cellule pour un élément ;

- les opérations élémentaires sont exécutées en temps logarithmique.

Malheureusement l'arbre AVL est délicat à coder, c'est un TAD qui n'impose qu'une relation d'ordre total sur les clés, il est en quelque sorte trop général pour ce que nous voulons faire. Au lieu d'un AVL nous allons utiliser un autre arbre binaire, moins sophistiqué, plus spécifique aux clés entières et au moins aussi performant.

L'idée essentielle de notre TAD c'est une bijection entre ℕ et les chemins dans un arbre binaire :

- un entier en base 2 est une liste de digits (0 ou 1) ;

- un chemin dans un arbre binaire est une liste de directions (gauche ou droite).

Or, dans un arbre binaire, partant de la racine, il y a bijection entre les chemins et les nœuds.
Il y a donc une bijection entre ℕ et les nœuds, ou autrement dit, puisqu'un dictionnaire n'est rien d'autre qu'une bijection entre les clés et les articles, nous avons trouvé la structure qui sied à nos besoins.

un arbre de Braun, les nœuds sont numérotés en base 2un bit à 0 pour un fils à gauche, un bit à 1 pour un fils à droite

Nous obtiendrons une extension à ℤ par simple dédoublement :

- un premier arbre de Braun contiendra les clés positives ou nulles ;

- un second arbre de Braun contiendra les clés strictement négatives.

X-A-2 - 61. L'interface

Quelle interface souhaitons-nous ?

Hé bien le client d'un tel module est en droit d'attendre :

- un constructeur make ;

- les traditionnels accesseurs set et get ;

- les itérateurs classiques iter, exists, for_all et filter ;

- un itérateur plus général fold ;

- les variantes avec indice, à savoir iteri, foldi et mapi ;

- le foncteur map ;

- to_list, la fonction de conversion en une liste ;

- to_alist, la fonction de conversion en une liste d'association.

Afin de cacher les détails d'implémentation au client d'un module, on peut mettre l'interface du module dans un fichier séparé *.mli, voici par exemple à quoi ressemblerait notre fichier Vector.mli :

module Vector :
sig
type 'a t
val make : 'a -> 'a t
val get : 'a t -> int -> 'a
val set : 'a t -> int -> 'a -> unit
val iter : ('a -> unit) -> 'a t -> unit
val exists : ('a -> bool) -> 'a t -> bool
val for_all : ('a -> bool) -> 'a t -> bool
val filter : ('a t -> bool) -> 'a t -> 'a list
val map : ('a -> 'b) -> 'a t -> 'b t
val fold : ('a -> 'b -> 'b) -> 'b -> 'a t -> 'b
val iteri : (int -> 'a -> unit) -> 'a t -> unit
val foldi : (int -> 'a -> 'b -> 'b) -> 'b -> 'a t -> 'b
val mapi : (int -> 'a -> 'b) -> 'a t -> 'b t
val to_list : 'a t -> 'a list
val to_alist : 'a t -> (int * 'a) list
end

Tant que le fichier *.mli est présent il ne sera pas possible au client de savoir, par exemple, comment est implémenté le type 'a Vector.t

Le bémol c'est que, contrairement à notre habitude, il nous faut donner le type de toutes les fonctions, ou plus exactement de toutes celles qui sont exportées. Alors on n'y perd aucune sécurité puisque l'implémentation sera systématiquement comparée à l'interface déclarée, mais n'y perd-on pas un peu de notre confort ?
Hé bien pas vraiment, car il faut bien l'avouer on procède souvent à rebours, n'oublions pas que la signature est le type d'un module. Il suffit donc de coller la source du module dans l'interpréteur et celui-ci nous affiche sa signature, il ne reste plus qu'à effacer les informations 'compromettantes' pour obtenir une interface respectable.
Bien sûr, on prendra soin de rester soupçonneux et de vérifier avec attention que le type inféré correspond bien à l'idée intuitive que l'on se fait de chaque opération.

X-A-3 - 62. L'implémentation

Notre arbre de Braun est mutable, nous aurions pu choisir une implémentation persistante, mais ça ne faisait pas partie de nos exigences de départ. Persistant ou pas les algorithmes sont tout à fait comparables et notre implémentation suffira bien à illustrer le parcours sur une structure de données non triviale.

type 'a vector =
| Leaf
| Node of 'a node
and 'a node =
{mutable left: 'a vector; mutable item: 'a; mutable right: 'a vector}

Nous avons besoin de deux arbres de Braun (un pour les indices positifs, un pour les indices négatifs) ainsi que d'un article par défaut :

type 'a t =
{mutable plus: 'a vector; mutable minus: 'a vector; default: 'a}

Tout indice qui n'aura subi aucun set depuis la création renverra l'article par défaut.

Cette valeur par défaut nous est fournie par le constructeur make :

let make x =
{plus = Leaf; minus = Leaf; default = x}

Pour accéder à un article à partir de son indice :

- on distingue les indices positifs ou nuls des indices strictement négatifs ;

- selon le cas on choisit la racine plus ou la racine minus ;

- lorsqu'on a atteint une feuille, cela signifie que l'indice n'a jamais fait l'objet d'un set, on renvoie l'article par défaut ;

- sinon on a affaire à un nœud ;

- si l'indice vaut 1 on renvoie l'article contenu dans ce nœud ;

- on poursuit dans l'arbre à gauche (respectivement à droite) si l'indice est pair (respectivement impair) ;

- on divise l'indice par 2.

let get v i =
let rec loop i node =
match node with
| Leaf ->
v.default
| Node n ->
if i = 1 then n.item else
loop (i asr 1) (if i land 1 = 0 then n.left else n.right)
in if i >= 0 then loop (succ i) v.plus else loop (-i) v.minus

Pour modifier l'article situé à un certain indice :

- on distingue les indices positifs ou nuls des indices strictement négatifs ;

- selon le cas on choisit la racine plus ou la racine minus ;

- on parcourt l'arbre jusqu'à trouver le nœud d'indice recherché, on modifie son item ;

- si on atteint une feuille alors, l'indice n'est pas présent, dans ce cas il va falloir faire bourgeonner cette feuille en une nouvelle branche jusqu'à atteindre l'indice recherché pour y déposer l'article voulu.

let set v i x =
let rec grow i =
Node
(
if i = 1 then
{left = Leaf; item = x; right = Leaf}
else if i land 1 = 0 then
{left = grow (i asr 1); item = v.default; right = Leaf}
else
{left = Leaf; item = v.default; right = grow (i asr 1)}
)
and tree i node =
match node with
| Leaf ->
grow i
| Node n ->
if i = 1 then
n.item <- x
else if i land 1 = 0 then
n.left <- tree (i asr 1) n.left
else
n.right <- tree (i asr 1) n.right;
node
in
if i >= 0 then
v.plus <- tree (succ i) v.plus
else
v.minus <- tree (-i) v.minus

X-A-4 - 63. La performance et la persistance

L'arbre de Braun est simple à implémenter, beaucoup plus facile que l'arbre AVL, il n'y a pas de rotations et les nœuds sont très légers, ils ne stockent pas de clé et ils ne contiennent aucune information sur l'équilibre/déséquilibre des deux sous-arbres.
De plus le temps d'accès est directement proportionnel à la longueur de la clé tandis que, dans le cas général, la performance d'un arbre AVL sera affectée à la fois par la longueur de la clé et par le nombre d'éléments déjà présents.

Nous verrons toutefois au chapitre suivant que cette performance a un prix.

En attendant, nous pouvons implémenter une optimisation assez élémentaire.
Telle que la fonction set est codée, l'assignation de l'article par défaut ne provoque jamais la libération d'aucun nœud.
La modification de la fonction set, de façon à permettre la décroissance de l'arbre de Braun lorsque l'article par défaut est assigné à une feuille, ne nécessite que l'insertion de deux lignes supplémentaires (que l'on a coloriées en vert) :

let set v i x =
let rec grow i =
Node
(
if i = 1 then
{left = Leaf; item = x; right = Leaf}
else if i land 1 = 0 then
{left = grow (i asr 1); item = v.default; right = Leaf}
else
{left = Leaf; item = v.default; right = grow (i asr 1)}
)
and tree i node =
match node with
| Leaf ->
grow i
| Node n ->
if i = 1 then
n.item <- x
else if i land 1 = 0 then
n.left <- tree (i asr 1) n.left
else
n.right <- tree (i asr 1) n.right;
if x = v.default && n.left = Leaf && n.right = Leaf then Leaf
else node
in
if i >= 0 then
v.plus <- tree (succ i) v.plus
else
v.minus <- tree (-i) v.minus

Pour ceux qui préféreraient une version immutable de ce TAD, il suffit d'opter pour une fonction d'ajout appropriée, qui opère une copie de la partie de l'arbre altérée par l'opération d'insertion :

let add v i x =
let rec grow i =
Node
(
if i = 1 then
{left = Leaf; item = x; right = Leaf}
else if i land 1 = 0 then
{left = grow (i asr 1); item = v.default; right = Leaf}
else
{left = Leaf; item = v.default; right = grow (i asr 1)}
)
and tree i node =
match node with
| Leaf ->
grow i
| Node n ->
Node
(
if i = 1 then
{n with item = x}
else if i land 1 = 0 then
{n with left = tree (i asr 1) n.left}
else
{n with right = tree (i asr 1) n.right}
)
in
if i >= 0 then
{v with plus = tree (succ i) v.plus}
else
{v with minus = tree (-i) v.minus; plus = v.plus}

On ne peut s'empêcher de remarquer la grande similitude entre la version mutable et la version immutable.
C'est parce que l'algorithme est le même, seul le moyen change, l'affectation r.a <- b est remplacée par l'expression {r with a = b} :

- l'assignation r.a <- b modifie sur place le champ a en lui affectant la valeur b ;

- l'opération {r with a = b} renvoie une copie de l'enregistrement r dans laquelle le champ a a pour valeur b.

Cependant, add ne suffit pas à rendre le TAD définitivement immutable, pour cela il faudrait carrément retirer les mots-clés mutable dans le type 'a node.

Mais c'est tout de même un compromis acceptable entre deux écueils possibles :

- un TAD immutable qui sollicite trop le ramasse-miettes parce que dans l'usage qu'on en fait toutes les modifications pourraient se faire sur place ;

- un TAD mutable que l'on utilise comme un TAD fonctionnel, si bien qu'il n'est impur que par péché.

Afin de faciliter vos expérimentations, la source complète du module Vector a été archivée ici.

X-A-5 - 64. Les itérateurs

La figure ci-dessous représente les indices des nœuds dans un arbre de Braun, en notation décimale cette fois-ci.

Il ne sera pas facile de parcourir l'arbre de telle façon de que nous traversions les indices dans l'ordre, qu'il soit croissant ou décroissant.
De plus la relation entre l'indice et la position dans l'arbre n'est pas la même pour la moitié positive et pour la moitié négative.
Et nous avons plus d'un itérateur à coder.

Tout cela ne nous facilite pas la tâche et pourrait impliquer plus de travail que nous l'envisagions au départ.

Une astuce pour minimiser l'effort consiste à maximiser la réutilisation interne en codant les fonctions courantes à partir des fonctions les plus générales :

let map f v =
mapi (fun i -> f) v

let iter f v =
fold (fun h t -> f h) () v

let exists p v =
fold (fun h t -> p h or t) false v

let for_all p v =
fold (fun h t -> p h && t) true v

let filter p v =
fold (fun h t -> if p v then h::t else t) [] v

let to_list v =
fold (fun h t -> h::t) [] v

let iteri f v =
foldi (fun i h t -> f i h) () v

let to_alist v =
foldi (fun i h t -> (i,h)::t) [] v

De cette façon il ne nous reste plus qu'à coder fold, foldi et mapi.

Mais avant il nous faut choisir une façon de relier l'indice et l'ordre d'application dans fold.
Nous choisissons de ne pas les relier.
Le choix contraire nous aurait fait regretter l'arbre AVL qui aurait été plus avantageux quant à la traversée selon les indices.

Commençons par le fold. Pour une feuille on retourne l'accumulateur, pour un nœud :

1. on parcourt l'arbre gauche ;

2. on applique f avec l'article de ce nœud et (1) pour arguments ;

3. on parcourt l'arbre droit, avec (2) pour valeur initiale.

let fold f init v =
let rec loop node acc =
match node with
| Leaf ->
acc
| Node n ->
if n.item = v.default then loop n.right (loop n.left acc)
else loop n.right (f n.item (loop n.left acc))
in loop v.plus (loop v.minus init)

La figure ci-dessous montre comment calculer les indices, de façon incrémentale à partir de la racine.

Ce qu'il faut en retenir c'est que :

- pour un fils à droite il faut ajouter le nombre de nœuds que peut contenir le niveau actuel ;

- pour un fils à gauche il faut ajouter le nombre de nœuds que peut contenir le niveau supérieur.

Cela nous fournit l'indication qui nous manquait pour le calcul des indices dans foldi.

let foldi f init v =
let rec plus node i d acc =
match node with
| Leaf ->
acc
| Node n ->
let middle = plus n.left (i+d) (d+d) acc in
plus n.right (i+d+d) (d+d)
(if n.item = v.default then middle else (f (i-1) n.item middle))
and minus node i d acc =
match node with
| Leaf ->
acc
| Node n ->
let middle = minus n.right (i+d+d) (d+d) acc in
minus n.left (i+d) (d+d)
(if n.item = v.default then middle else (f (-i) n.item middle))
in plus v.plus 1 1 (minus v.minus 1 1 init)

Comme nous l'avions anticipé, il faut dédoubler la routine de parcours, car le calcul n'est pas le même pour les indices positifs et pour les indices négatifs.

Ce dédoublement affecte tout autant la fonction mapi, que nous ne pouvons pas coder à l'aide de foldi puisque nous devons reproduire la structure (l'arbre de Braun) alors que notre fold se contente d'en énumérer chaque élément.

let mapi f v =
let rec plus node i d =
match node with
| Leaf ->
Leaf
| Node n ->
Node
{
left  = plus n.left (i+d) (d+d);
item  = f (i-1) n.item;
right = plus n.right (i+d+d) (d+d);
}
and minus node i d =
match node with
| Leaf ->
Leaf
| Node n ->
Node
{
left  = minus n.left (i+d) (d+d);
item  = f (-i) n.item;
right = minus n.right (i+d+d) (d+d);
}
in {plus = plus v.plus 1 1; minus = minus v.minus 1 1; default = f v.default}

XI - Partie X

65. Les familles de processeurs
66. Architecture processeur et performance
67. Le langage machine
68. Le langage source
69. Quelques compléments sur le langage OCaml
70. La traduction en code machine
71. Le traducteur en action
Pour aller plus loin

XI-A - Application à la génération de code machine

XI-A-1 - 65. Les familles de processeurs

Comme tout composant matériel ou logiciel un microprocesseur comporte une interface et une implémentation :

- l'implémentation est un interpréteur machine pour le jeu d'instructions, son détail diffère d'un modèle à l'autre et n'intéresse pas l'auteur de compilateurs ;

- l'interface est un jeu d'instructions, plus ou moins riche d'un modèle à l'autre il reste néanmoins globalement identique tant qu'on s'en tient à une même famille de microprocesseurs.

On distingue trois grandes architectures de jeu d'instructions :

- les processeurs CISC (Complex Instruction Set Computing) caractérisés par une instruction MOVE, un petit nombre de registres (disons 8 ou 16) et des instructions du genre ADD op,reg où reg est un registre et op un opérande, elle-même étant un registre ou une case mémoire dont l'adresse peut être calculée de façon plus ou moins sophistiquée ;

- les processeurs RISC (Reduced Instruction Set Computing) caractérisés par une paire d'instructions LOAD et STORE, un grand nombre de registres (disons au moins 32), des instructions de longueur fixe et des mnémoniques simples du genre ADD reg1,reg2,reg3 ;

- les processeurs VLIW (Very Long Instruction Word) ou EPIC (Explicitly Parallel Instruction Computing) sont identiques aux RISC, mais caractérisés par des instructions riches capables d'effectuer un plus grand nombre de traitements parallèles, conditionnels ou spéculatifs par cycle d'horloge.

Dans la plupart des architectures, le nombre total d'instructions disponibles est élevé et dépasse souvent la centaine.

Ce nombre n'a en fait que peu d'influence, car bon nombre de ces instructions sont en fait dédiées à des opérations sur des données spécialisées (opérations sur les flottants, les chaînes de bits, les vecteurs), à des manipulations des registres spéciaux et des caches, ainsi qu'à des opérations système (du code en mode superviseur) qui ne concernent pas le code en mode utilisateur.
La richesse du jeu d'instruction n'influe donc pas tellement sur la complexité générale du compilateur.

XI-A-2 - 66. Architecture processeur et performance

Dans un monde idéal la performance serait uniquement le souci du fondeur et il n'y aurait pas à s'en soucier.

Dans la pratique le jeu d'instructions limite le nombre de variables temporaires (registres) sur lesquelles ont lieu les opérations.
Il incombe donc au compilateur de masquer cette limitation de ressources autant qu'il le peut :

- en effectuant une transformation (register allocation) qui donne l'illusion d'un nombre illimité de variables alors que le nombre de registres est limité ;

- cette transformation va générer des instructions MOVE ou LOAD / STORE qui ne participent à aucun calcul, mais qui agissent comme un cache pour les variables situées en mémoire ;

- avec une transformation naïve, on génère un grand nombre de MOVE ou LOAD / STORE qui peuvent représenter 30 % ou même plus de surcharge en temps d'exécution ;

- une meilleure méthode consiste à modéliser le flot d'exécution pour calculer la durée de vie de chacune des variables (par exemple à l'aide d'une mise sous forme dite SSA pour Single-Static-Assignment) afin de leur assigner un registre pour toute leur durée de vie (au lieu d'une seule opération dans le cas de la transformation naïve) ;

- ce genre d'optimisation est très efficace puisqu'il supprime une grande quantité de MOVE / LOAD / STORE.

Contrairement à ce que l'on pourrait penser la documentation du constructeur de CPU n'est pas l'élément vital dans la génération d'un code performant :

- comme le temps d'exécution d'une instruction sur un processeur moderne dépend du modèle considéré, ainsi que d'un ensemble de conditions dynamiques très difficiles à maîtriser (état du pipeline de décodage, disponibilité du code et des données dans les différents caches, hyper-threading) l'auteur de compilateurs s'intéresse moins à la performance quantitative d'une instruction qu'à sa complexité relative par rapport à une instruction qui lui serait équivalente ;

- il est fondamentalement plus simple de lire un registre que de lire une case mémoire, de faire un décalage à droite que de faire une division par 2, donc dans tous les cas où c'est possible on cherchera à substituer une opération par une autre fondamentalement plus simple ;

- la plupart de ces optimisations sont locales et par conséquent, relativement faciles à implanter ;

- l'optimisation difficile c'est l'optimisation globale, celle dont la portée excède celle d'une expression/instruction dans le langage source ;

- l'optimisation globale la plus payante est celle de register allocation ;

- la bonne nouvelle c'est que cette optimisation est relativement bien portable d'une architecture de CPU à une autre ;

- la mauvaise nouvelle c'est que cette optimisation est relativement difficile à implanter et coûteuse en temps d'exécution par rapport à l'approche naïve.

XI-A-3 - 67. Le langage machine

Choisir un jeu d'instructions pour un tutoriel de compilation est relativement délicat :

- trop abstrait : le lecteur n'apprendra rien d'immédiatement applicable ;

- trop réaliste : le lecteur n'apprendra rien de général.

Pour ce tutoriel on a fait le choix pragmatique d'une architecture CISC populaire, mais sans rentrer dans le détail de l'encodage des instructions Intel x86, ceci afin de garder une notation de haut niveau tout en restant proche de la machine réelle.
Toujours dans le même but de ne pas surcharger inutilement un code qui se veut essentiellement éducatif, on s'est limité à une seule taille d'opérande à savoir le mot machine soit 32 bits pour ia32 ou 64 bits pour ia64.
En particulier toutes les tailles et tous les déplacements (offset) sont exprimés en nombre de mots machine.

Finalement, pour rester très concret, on donnera une traduction de notre jeu d'instruction abstrait vers deux architectures CISC populaires.

Parmi tous nos registres, nous en réservons trois pour des usages spécifiques :

- un premier servira de pointeur de cadre de pile ;

- un second servira de pointeur d'environnement global ;

- un troisième registre est sans doute déjà réservé comme pointeur de pile.

Les opérandes couvrent l'ensemble des modes d'adressage qui nous seront directement utiles :

- Imm n désigne la valeur constante entière n ;

- Reg n désigne le nième registre ;

- Main n désigne une variable globale située à n mots machines dans l'environnement global ;

- Stack n désigne une variable locale située à n mots machines dans le cadre de pile ;

- Offset(reg,offset) désigne le mot situé à l'adresse reg + offset ;

- ScaleL(reg0,reg1) désigne le mot situé à l'adresse reg0 + reg1 ;

- ScaleD(reg0,reg1) désigne le mot situé à l'adresse reg0 + reg1 * 2.

type asm_op =
| Imm of int          (* immediate *)
| Reg of int          (* register *)
| Main of int         (* global variables *)
| Stack of int        (* local variables *)
| Offset of int * int (* record field *)
| ScaleL of int * int (* access to word array  *)
| ScaleD of int * int (* access to dword array *)

Les étiquettes serviront lors des sauts :

type asm_lab =
{mutable label: int option}

Ces conditions serviront lors des sauts conditionnels :

type cond_op =
| Equal | Less | More
| NotEqual | NotLess | NotMore

Les opérateurs binaires, on pourrait en ajouter d'autres cela ne changerait pas notre schéma de traduction :

type bin_op =
| Add | Sub | Mul | Div | Mod | Xor | And | Or

Finalement nos mnémoniques utilisent les opérandes et autres éléments précédemment définis :

type asm_instr =
| MoveTo of asm_op * int
| MoveFrom of asm_op * int
| Apply of bin_op * int * asm_op  (* binary operation *)
| Addr of int * asm_op  (* effective address *)
| Label of asm_lab      (* declare label *)
| Branch of asm_lab
| BranchIf of cond_op * asm_lab
| Push of asm_op
| Call of asm_lab
| CallTo of asm_op
| Frame of int          (* build stack frame *)
| ReturnPop of int      (* return and pop arguments *)
| PushRegs of int
| PopRegs of int

Où :

- reg étant un numéro de registre ;

- op étant un opérande ;

- lab étant une étiquette ;

- MoveTo(op,reg) copie le contenu de l'opérande op dans reg ;

- MoveFrom(op,reg) copie reg dans l'opérande op ;

- Apply(⊕,reg,op) applique l'opération reg ⊕ op et place le résultat dans reg ;

- Addr(reg,op) calcule addresse effective op et place le résultat dans reg ;

- Label lab declare l'étiquette lab ;

- Branch lab effectue un saut inconditionnel à l'étiquette lab ;

- BranchIf(cond,asm_lab) effectue un saut conditionnel à l'étiquette lab;S

- Push op empile le contenu de l'opérande op ;

- Call lab effectue un appel de sous-routine à l'étiquette lab ;

- CallTo op effectue un appel de sous-routine à l'addresse effective op ;

- Frame n créer un cadre de pile d'une taille de n mots machine ;

- ReturnPop n retourne à l'appelant et dépile les n paramètres réels ;

- PushRegs n empile tous les registres de 0 à n ;

- PopRegs n dépile tous les registres de n à 0.

Tout en restant abstrait notre assembleur simule assez bien les processeurs CISC réels comme le montre le tableau suivant qui fait le rapprochement avec deux CPU CISC très populaires.

assembleur abstrait

assembleur Intel 80486

assembleur Motorola 68020

Imm 0

0

#0

Reg 0

EAX

D0

Main -2

[ESI-8]

(-8,A6)

Stack -2

[EBP-8]

(-8,A5)

Offset(0,2)

[EAX+8]

(8,A0)

ScaleL(0,1)

[EAX+EBX]

(A0,D1.L*4)

ScaleD(0,1)

[EAX+EBX*2]

(A0,D1.L*8)

MoveTo(op,reg)

MOV reg,op

MOVE.L op,reg

MoveFrom(op,reg)

MOV op,reg

MOVE.L reg,op

Apply(Add,reg,op)

ADD op,reg

ADD.L op,reg

Addr(reg,op)

LEA reg,op

LEA op,reg

Branch lab

JMP lab

BRA lab

BranchIf(NotEqual,lab)

JNE lab

BNE lab

Push op

PUSH op

MOVE.L op,-(A7)

Call lab

CALL lab

BSR lab

CallTo op

CALL op

JSR op

Frame 2

PUSH EBP
MOV ESP,EBP
SUB ESP,8

LINK A5,#8

ReturnPop 1

MOV EBP,ESP
POP EBP
RET 4

UNLK A5
RTD #4

PushRegs 2

PUSH EAX
PUSH EBX
PUSH ECX

MOVEM.L D0-D2,-(A7)

PopRegs 2

POP ECX
POP EBX
POP EAX

MOVEM.L (A7)+,D0-D2

Le fait que notre assembleur abstrait comporte aussi peu d'instructions confirme que les compilateurs, en général, n'utilisent qu'une petite fraction du jeu total d'instruction, ceci pour les raisons déjà évoquées plus haut.
Bien sûr un langage réaliste possède plus de types de données que notre langage jouet qui n'a même pas les nombres flottants. Il y a aussi des opportunités d'exploiter quelques spécificités de l'architecture réelle. Ce ne sont là que quelques extensions et optimisations qui ne changeraient pas le cœur de la traduction qui s'occupe avant tout des expressions simples et des structures de contrôle élémentaires.

XI-A-4 - 68. Le langage source

On a choisi un langage de programmation impérative structurée de type C/Pascal avec une extension POO.
On en donne ici que l'arbre de syntaxe abstraite issu du front-end et dont on n'a retenu que les informations strictement nécessaires à la traduction dans notre langage machine.

Les variables sont soit simples soit rangées dans un tableau :

type ast_var =
| Var of int            (* offset *)
| Array of int * int    (* offset, size of item *)

À l'aide de ces variables, on peut construire des expressions plus complexes :

- Unit est l'expression vide ;

- Integer n est l'entier constant n ;

- Local n est une variable locale située à n mots dans le cadre de pile ;

- Glocal n est une variable globale située à n mots dans l'environnement global ;

- Member(e,c) est le champ c dans l'enregistrement e ;

- Compare(p,a,b) compare a et b selon le prédicat p ;

- BinaryOp(⊕,a,b) calcule a ⊕ b ;

- ItemAt(a,i) est l'élément d'indice i dans le tableau a ;

- ProcCall(p,a) appelle la procédure p avec la liste d'arguments a ;

- MethodCall(m,o,a) appelle la méthode m de l'objet o avec la liste d'arguments a.

type ast_expr =
| Unit
| Integer of int
| Local of ast_var
| Global of ast_var
| Member of ast_expr * ast_var
| Compare of cond_op * ast_expr * ast_expr
| BinaryOp of bin_op * ast_expr * ast_expr
| ItemAt of ast_expr * ast_expr * int
| ProcCall of ast_proc * ast_expr list
| MethodCall of ast_expr * ast_var * ast_expr list

Les instructions sont déclarées d'une façon assez parlante :

and ast_instr =
| Nop
| Block of ast_instr list
| AssignTo of ast_expr * ast_expr
| IfThenElse of ast_expr * ast_instr * ast_instr
| WhileDo of ast_expr * ast_instr
| Loop of ast_instr * asm_lab
| Break of ast_instr
| Return of ast_proc * ast_expr
| Ignore of ast_expr

Précisons tout de même que :

- un Break n'est possible que dans une instruction Loop ;

- Ignore sert avant tout à convertir un appel de procédure/méthode en une instruction.

Enfin, une procédure est un quadruplet formé :

- d'une étiquette (adresse de début du code) ;

- d'une arité (nombre d'arguments) ;

- d'une taille de cadre local (nombre de mots à allouer sur la pile) ;

- d'un corps (liste d'instructions).

and ast_proc =
asm_lab * int * int * ast_instr

Une méthode ne sera qu'une variable-procédure c'est-à-dire une procédure située à un certain déplacement.

XI-A-5 - 69. Quelques compléments sur le langage OCaml

Le code de notre traduction utilise quelques notions nouvelles qui n'ont pas été présentées dans les parties précédentes de ce cours OCaml.
Ce paragraphe ne prétend pas présenter ces notions en profondeur, il se contente de survoler la syntaxe des notions utilisées afin que le code ne fasse pas obstacle à la compréhension.

Tout d'abord :

function pat1 -> val1 | pat2 -> val2 | ... | patn -> valn

Permet d'abstraire un filtrage, comme avec :

fun x -> match x with pat1 -> val1 | pat2 -> val2 | ... | patn -> valn

Mais sans déclarer la variable x, elle reste anonyme.

Ensuite, comme son nom le laisse supposer, OCaml possède une extension POO.
Cette extension orientée objet mériterait à elle seule un cours complet dont les aspects abordés ici ne seraient qu'un maigre aperçu.

Syntaxiquement, une nouvelle classe dotted peut être déclarée ainsi :

class dotted arg1 arg2 =
object
val plus = arg1 + arg2
val mutable minus = arg1 - arg2
method compute = function n -> plus - minus + n
initializer
print_endline "new object created"
end

Où :

- arg1 et arg2 sont les arguments du constructeur ;

- le mot-clé val déclare une nouvelle valeur privée locale à l'objet ;

- le mot-clé mutable rend possible l'assignation d'une valeur locale ;

- le mot-clé method déclare une nouvelle valeur publique visible de l'extérieur de l'objet ;

- la section initializer contient du code d'initialisation exécuté uniquement lors de la création de l'objet.

En fait la déclaration d'une classe est une double déclaration :

- elle déclare un nouveau type dotted qui est un type d'objet, c'est-à-dire un type enregistrement ouvert (on dit aussi extensible)

type dotted = <compute: int -> int>

- elle déclare une nouvelle fonction new dotted qui renvoie un objet de type dotted

# new dotted;;
- : int -> int -> dotted = <fun>

L'envoi de message se fait à l'aide de l'opérateur #.

L'extension POO de OCaml est compatible avec l'inférence de types et respecte la sémantique fonctionnelle du langage.
En particulier lorsqu'un envoi de message demande la méthode d'un certain objet il obtient en résultat une fonction ordinaire.

# (new dotted 1 2)#compute;;
new object created
- : int -> int = <fun>

Le constructeur d'une classe est également une fonction ordinaire.

# new dotted;;
- : int -> int -> dotted = <fun>

Au même titre que n'importe quelle autre fonction, méthodes et constructeurs peuvent être passés en argument ou être renvoyés comme résultat.

La compatibilité entre deux objets découle de la relation d'inclusion de leurs types d'objet respectifs.
La relation d'inclusion entre types d'objet généralise l'héritage tel qu'il existe dans la plupart des langages POO.
La compatibilité entre types d'objet introduit une nouvelle forme de polymorphisme appelé polymorphisme ad hoc par opposition au polymorphisme paramétrique.
Nous n'en dirons toutefois pas davantage sur cet aspect, car nous n'en aurons pas besoin ici.

Enfin, il existe un constructeur de motif que nous n'avions pas rencontré jusqu'à présent.
Le motif noté pat1 | pat2 est appelé un motif union et filtre toute valeur filtrable par le motif pat1 ou le motif pat2.
Bien sûr pat1 | pat2 doivent être de même type. Ils doivent aussi déclarer le même ensemble de variables.
La fonction offset utilise un motif union pour extraire l'offset d'une variable :

let offset (Var x | Array(x,_)) = x

XI-A-6 - 70. La traduction en code machine

Dans un premier temps il nous faut mettre en place une stratégie d'allocation des registres.
Nous allons utiliser un schéma simple et typique dans les compilateurs CISC :

- un opérateur unaire place le résultat dans le même registre que son argument ;

- un opérateur binaire calcule son argument gauche dans le registre n, son argument droit dans le registre n + 1, puis place le résultat de l'opération dans le registre n.

La figure ci-dessous illustre l'annotation d'un arbre d'expression selon ce schéma d'allocation. Les opérandes (dans les feuilles) et les opérateurs (dans les nœuds) n'y sont pas mentionnés pour mieux faire ressortir les numéros de registre.

Le nombre de registres strictement nécessaires à l'évaluation d'une expression sans utiliser la pile est égal au nombre de Strahler de l'arbre d'expression à évaluer.
Ce nombre est relativement petit puisqu'il n'augmente que lorsqu'on ajoute un niveau à un arbre complet. C'est ce qui explique que le jeu d'instruction CISC avec son nombre de registres relativement réduit résiste encore face aux nouvelles architectures à plusieurs centaines de registres.

Certaines opérations et, en premier lieu l'appel de fonction sont susceptibles d'écraser un ou plusieurs registres.
Afin que des résultats intermédiaires ne soient pas perdus, ces opérations doivent éventuellement sauver temporairement des registres sur la pile pour ensuite les restaurer en fin de calcul.

Le squelette de notre traducteur est une classe ast_to_asm dont le constructeur attend une liste de procédures qu'il va traduire en code machine. Ces procédures pourront être récursives ou mutuellement récursives, car notre traducteur effectue la mise à jour automatique des sauts en avant.
La classe ast_to_asm commence par quelques formalités pour :

- créer la liste d'instructions dans le champ code ;

- définir label, le numéro de la prochaine déclaration d'étiquette ;

- déclarer deux routines d'émission de code pour les fonctions et méthodes.

Le code qui nous intéresse vraiment prendra place à l'endroit en pointillés.

class ast_to_asm proc_list =
object
val mutable code : asm_instr list = []
val mutable label = 0
method asm_code = List.rev code
initializer
let emit asm = code <- asm::code in
let offset (Var x | Array(x,_)) = x
and emit_call (l,a,f,b) =
emit (Call l)
and emit_callto proc =
match proc with
| Var offset ->
emit (Push (Reg 0));
emit (MoveTo (Offset(0,0),0));
emit (MoveTo (Offset(0,offset),0));
emit (CallTo (Offset(0,0)))
| _ -> assert false
in
...
end

Le cœur de notre évaluateur est une fonction eval_val reg expr qui place la valeur de expr dans le registre reg.

Cependant ça n'est pas la totalité de notre évaluateur, en effet, si on plaçait toutes les expressions dans un registre ça ne serait plus du CISC, ça serait du RISC !
Il nous faut en plus un évaluateur auxiliaire capable de placer des expressions dans un opérande au lieu d'un registre.
Il nous faut également un évaluateur auxiliaire capable de calculer l'adresse d'une expression plutôt que sa valeur.

En tout nous avons besoin de pas moins de quatre fonctions auxiliaires :

- eval_arg reg expr place la valeur de expr dans un opérande ;

- eval_addr reg expr place l'adresse de la valeur expr dans reg ;

- eval_scale reg disp place le déplacement disp dans un opérande ;

- eval_push expr place la valeur de expr sur la pile.

let rec eval_arg reg = function
| Integer n -> Imm n
| Local v -> Stack (offset v)
| Global v -> Main (offset v)
| expr -> eval_val reg expr; (Reg reg)
and eval_push expr =
emit (Push (eval_arg 0 expr))
and eval_scale reg = function
| 1 -> ScaleL(reg,reg+1)
| 2 -> ScaleD(reg,reg+1)
| size ->
emit (Apply(Mul,reg+1,Imm size));
ScaleL(reg,reg+1)
and eval_addr reg = function
| Member(record,var) ->
eval_addr reg record;
emit (Addr(reg,Offset(reg,offset var)))
| ItemAt(vector,index,size) ->
eval_addr reg vector;
eval_val (reg+1) index;
emit (Addr(reg,eval_scale reg size))
| expr ->
eval_val reg expr
and eval_val reg = function
...

La fonction eval_val applique notre schéma d'allocation de registres sur chacun des noeuds de l'arbre d'expression et émet les instructions appropriées à chacun des cas.
Il n'y a rien de particulier à signaler hormis peut-être l'utilisation du couple d'instructions PushRegs / PopRegs pour conserver les résultats intermédiaires lors des appels de fonctions ou méthodes.

and eval_val reg = function
| Unit ->
()
| Integer n ->
emit (MoveTo(Imm n,reg))
| Local v ->
emit (MoveTo(Stack (offset v),reg))
| Global v ->
emit (MoveTo(Main (offset v),reg))
| Member(record,var) ->
eval_addr reg record;
emit (MoveTo(Offset(reg,offset var),reg))
| Compare(Equal,left,Integer 0) ->
eval_val reg left
| Compare(cond,left,right) ->
eval_val reg left;
let arg = eval_arg (reg+1) right
in emit (Apply(Sub,reg,arg))
| ItemAt(vector,index,size) ->
eval_addr reg vector;
eval_val (reg+1) index;
emit (MoveTo(eval_scale reg size,reg))
| BinaryOp(op,left,right) ->
eval_val reg left;
let arg = eval_arg (reg+1) right;
in  emit (Apply(op,reg,arg))
| ProcCall(proc,args) ->
if reg > 0 then emit (PushRegs (reg-1));
List.iter eval_push args;
emit_call proc;
if reg > 0 then begin
emit (MoveTo(Reg 0,reg));
emit (PopRegs (reg-1))
end
| MethodCall(target,proc,args) ->
if reg > 0 then emit (PushRegs (reg-1));
List.iter eval_push args;
eval_val 0 target;
emit_callto proc;
if reg > 0 then begin
emit (MoveTo(Reg 0,reg));
emit (PopRegs (reg-1))
end
in
...

À l'aide de cette traduction des expressions, nous sommes maintenant prêts à traduire les instructions.

Encore quelques fonctions utilitaires pour gérer les sauts et mettre à jour les étiquettes :

let forward () =
{label=None}
and emit_label () =
let l = {label=Some label} in
emit (Label l);
label <- label + 1; l
and assign_label l =
let here = Some label in
emit (Label {label=here}); l.label <- here;
label <- label + 1
and branch_to_here from =
emit (Label {label=Some label});
from.label <- Some label;
label <- label + 1
and emit_break = function
| Loop(cmd,ended) -> emit (Branch ended)
| _ -> assert false
and negate = function
| Equal    -> NotEqual
| Less     -> NotLess
| More     -> NotMore
| NotEqual -> Equal
| NotLess  -> Less
| NotMore  -> More
in
...

Évaluer une condition et placer la cible d'une assignation dans un opérande :

let eval_test expr =
eval_val 0 expr;
let l = forward () in
match expr with
| Compare(cond,left,right) ->
emit (BranchIf(negate cond,l)); l
| _ ->
emit (BranchIf(NotEqual,l)); l
and eval_dest reg = function
| Local v -> Stack (offset v)
| Global v -> Main (offset v)
| expr -> eval_addr reg expr; Offset(reg,0)
in
...

Et nous pouvons maintenant générer le code pour les instructions :

let rec eval_instr = function
| Nop ->
()
| Block cmds ->
List.iter eval_instr cmds
| AssignTo(source,target) ->
eval_val 0 source;
let dest = eval_dest 1 target in
emit (MoveFrom(dest,0))
| IfThenElse(cond,cmd_t,Nop) ->
let test = eval_test cond in
eval_instr cmd_t;
branch_to_here test
| IfThenElse(cond,cmd_t,cmd_f) ->
let test = eval_test cond in
eval_instr cmd_t;
let done_t = forward () in
emit (Branch done_t);
branch_to_here test;
eval_instr cmd_f;
branch_to_here done_t
| WhileDo(cond,cmd) ->
let start = emit_label () in
let test = eval_test cond in
eval_instr cmd;
emit (Branch start);
branch_to_here test
| Loop(cmd,ended) ->
let start = emit_label () in
eval_instr cmd;
emit (Branch start);
assign_label ended
| Break loop ->
emit_break loop
| Return((l,a,f,b),v) ->
eval_val 0 v;
emit (ReturnPop a)
| Ignore call ->
eval_val 0 call
in
...

La génération du code pour les procédures ne consiste plus qu'à déclarer leur étiquette, créer le cadre de pile et traduire leur corps d'instructions :

let eval_proc (l,a,f,b : ast_proc) =
assign_label l; emit (Frame f); eval_instr b
in  List.iter eval_proc proc_list

XI-A-7 - 71. Le traducteur en action

Supposons qu'à l'entrée du front-end on ait ce bout de code dans un langage source fictif proche de Pascal/MODULA :

RECORD binary_tree
left:  PTR TO binary_tree
right: PTR TO binary_tree
ENDRECORD

PROC height(t:PTR TO binary_tree)
LOCAL l:LONG,r:LONG
IF t = NIL THEN RETURN 0
l := height(t.left)
r := height(t.right)
IF l > r THEN RETURN l+1
RETURN r+1
ENDPROC

À l'entrée du back-end on aurait alors cet arbre de syntaxe abstraite :

let rec height : ast_proc =
let left = Var 0
and right = Var 1
and zero = Integer 0
and one = Integer 1
and t = Local (Var 2)
and l = Local (Var (-1))
and r = Local (Var (-2))
in
{label=None},
1,
2,
Block
[
IfThenElse(Compare(Equal,t,zero),Return(height,zero),Nop);
AssignTo(ProcCall(height,[Member(t,left)]),l);
AssignTo(ProcCall(height,[Member(t,right)]),r);
IfThenElse
(
Compare(More,l,r),
Block[Return(height,BinaryOp(Add,l,one))],
Nop
);
Return(height,BinaryOp(Add,r,one))
]

Il suffit alors d'invoquer notre traducteur :

(new ast_to_asm [height])#asm_code;;

Pour obtenir ce code machine :

[Label {label = Some 0}; Frame 2; MoveTo (Stack 2, 0);
BranchIf (NotEqual, {label = Some 1}); MoveTo (Imm 0, 0); ReturnPop 1;
Label {label = Some 1}; MoveTo (Stack 2, 0); MoveTo (Offset (0, 0), 0);
Push (Reg 0); Call {label = Some 0}; MoveFrom (Stack (-1), 0);
MoveTo (Stack 2, 0); MoveTo (Offset (0, 1), 0); Push (Reg 0);
Call {label = Some 0}; MoveFrom (Stack (-2), 0); MoveTo (Stack (-1), 0);
Apply (Sub, 0, Stack (-2)); BranchIf (NotMore, {label = Some 2});
MoveTo (Stack (-1), 0); Apply (Add, 0, Imm 1); ReturnPop 1;
Label {label = Some 2}; MoveTo (Stack (-2), 0); Apply (Add, 0, Imm 1);
ReturnPop 1]

Qu'on pourra reformater ainsi pour une meilleure visibilité :

Label 0
Frame 2
MoveTo    Stack 2, R0
BranchIf  NotEqual, 1
MoveTo    Imm 0, R0
ReturnPop 1
Label 1
MoveTo    Stack 2, R0
MoveTo    [R0], R0
Push      R0
Call 0
MoveFrom  Stack -1, R0
MoveTo    Stack 2, R0
MoveTo    [R0 + 1], R0
Push      R0
Call 0
MoveFrom  Stack -2, R0
MoveTo    Stack -1, R0
Apply     Sub, R0, Stack -2
BranchIf  NotMore, 2
MoveTo    Stack -1, R0
Apply     Add, R0, Imm 1
ReturnPop 1
Label 2
MoveTo    Stack -2, R0
Apply     Add, R0, Imm 1
ReturnPop 1

À titre de comparaison voici le même programme écrit cette fois manuellement en assembleur 68020 :

STRUCTURE Tree,0
APTR  tree_left
APTR  tree_right
LABEL tree_sizeof

height_enter:
MOVE.L   (4,SP),D0
BEQ.S    height_exit0
MOVE.L   D0,A0
MOVE.L   (tree_left,A0),-(SP)
BSR.S    height_enter
MOVE.L   (4,SP),A0
MOVE.L   D0,-(SP)
MOVE.L   (tree_right,A0),-(SP)
BSR.S    height_enter
MOVE.L   (SP)+,D1
CMP.L    D1,D0
BGT.S    height_exit1
EXG.L    D1,D0
height_exit1:
ADDQ.L   #1,D0
height_exit0:
RTD      #4

La version manuelle est évidemment meilleure :

- elle ne procède pas à la création/destruction d'un cadre de pile ;

- elle n'est pas calquée sur les constructions de la programmation structurée ;

- elle ne contient que 7 instructions MOVE au lieu de 11, car elle alloue les registres beaucoup plus intelligemment.

Le point positif c'est que, malgré sa simplicité, notre générateur ne fait rien de réellement stupide. En particulier on n'a pas besoin d'une passe supplémentaire dans un pipeline qui éliminerait du code inutile. Si on veut améliorer la qualité du code, on peut toujours ajouter des cas au filtrage. Le faire sur l'arbre de syntaxe abstraite est bien plus confortable que de le faire sur une séquence de code.

Par exemple au lieu de l'instruction :

MoveTo    Imm 0, R0

On peut préférer l'instruction :

Apply     Sub, R0, R0

Dont l'avantage est de ne pas stocker la constante zéro et donc d'économiser de la place (un mot machine sur CPU Intel).
Pour ça il suffira d'ajouter un cas au filtrage :

and eval_val reg = function
| Integer 0 -> emit (Apply(Sub,reg,(Reg reg)))

Évidemment ce serait encore mieux de pouvoir économiser des instructions complètes et on retombe là encore sur le point noir de notre schéma : il génère beaucoup de MOVE.

XI-A-8 - Pour aller plus loin

Le code que nous avons présenté est assez efficace quant à minimiser le nombre d'instructions PUSH.
Les optimisations que notre traducteur simpliste n'effectue pas se rangent en trois catégories principales :

- minimiser le nombre d'instructions BRANCH à l'aide d'une analyse du CFG (Control Flow Graph) ;

- minimiser le nombre d'instructions MOVE en augmentant la granularité de l'allocation de registre de la taille de l'expression jusqu'à la taille de la fonction, du module ou du programme ;

- retirer le code mort à l'aide d'une analyse du flot de données. C'est particulièrement important dans le cadre du développement modulaire ou POO où l'on thésaurise du code dont seule une petite fraction participe effectivement au programme client.

Des articles Wikipédia donnent des définitions de base pour ces trois domaines :

- Control Flow Graph ;

- Register allocation et Static Single Assignment Form ;

- Dead code elimination.

Dans sa forme la plus simpliste, l'allocation globale de registre se contente de registériser les quelques variables les plus utilisées dans les boucles. C'est une approche simple et utilisée par de nombreux outils populaires gratuits comme LCC.
Pour faire un peu mieux il faut procéder à une mise sous forme de CFG et utiliser une heuristique d'allocation comme linear scan.
Pour une allocation encore plus efficace cumulée avec le retrait du code mort, il faut passer par une représentation intermédiaire dite SSA (Static Single Assignment Form).

Tout cela ce sont des heuristiques, car le problème de l'allocation optimale de registre est NP-complet et même indécidable en présence de boucles.

Ces quelques ressources devraient vous aider à approfondir ces sujets :

- Cours de compilation avancée à l'ENSTA ;

- Cours de compilation à Polytechnique ;

- Linear Scan Register Allocation ;

- Static Single Assignment Form ;

- La représentation SSA: sémantique, analyses et implémentation ;

- Tailoring Graph-coloring Register Allocation For Runtime Compilation.

XII - Remerciements

- à millie et à gorgonite pour leur soutien ;

- à InOCamlWeTrust pour ses suggestions ;

- à Florent Aspic et jacques_jean pour leur promptitude et leur attention dans la correction orthographique ;

- enfin, remerciement spécial à Nicolas Le Griel pour sa lecture méticuleuse et ses remarques appréciables.