12. La Mutation
1 Exercice 12.15.1
2 Exercice 12.15.2
3 Exercice 12.15.3
4 Exercice 12.15.4
5 Exercice 12.15.5
6 Exercice 12.15.6
7 Exercice 12.15.7
8 Exercice 12.15.8
9 Exercice 12.15.9
10 Exercice 12.15.10
11 Exercice 12.15.11
12 Exercice 12.15.12
13 Exercice 12.15.13
14 Exercice 12.15.14
15 Exercice 12.15.15
16 Exercice 12.15.16
17 Exercice 12.15.17
18 Exercice 12.15.18
6.0.1.11

12. La Mutation

Danger : mutation !

1 Exercice 12.15.1

(empiler! x L) ne peut pas être une fonction car une fonction ne peut pas modifier la valeur de son argument d’entrée (appel par valeur) ! Idem pour depiler!.

(define-syntax empiler!

  (syntax-rules ()

    ((empiler! x L) (set! L (cons x L)))))   ; sans resultat

Dans (depiler! L), on suppose que l’argument L est une variable dont la valeur est une liste.

(define-syntax depiler!

  (syntax-rules ()

    ((depiler! L) (let ((x (car L)))

                    (set! L (cdr L))

                    x))))

2 Exercice 12.15.2

(define-syntax while

  (syntax-rules ()

    ((while test e1 e2 ...) (let ()

                               (define (iter)        ; ou bien avec un letrec

                                 (if (not test)

                                     (void)

                                     (begin e1 e2 ... (iter))))

                               (iter)))))

> (let ((n 100) (s 0))

    (while (> n 0)

      (set! s (+ s n))

      (set! n (- n 1)))

    s)

5050

Idem pour for...

3 Exercice 12.15.3

(define-syntax $letrec

  (syntax-rules ()

    (($letrec ((x e) ...) expr ...) (let ((x '?) ...) (set! x e) ... expr ...))))

> ($letrec (($odd? (lambda (x) (if (= x 0) #f ($even? (- x 1)))))

            ($even? (lambda (x) (if (= x 0) #t ($odd? (- x 1))))))

    ($odd? 5))

#t

4 Exercice 12.15.4

Difficile, à sauter en première lecture... Détails dans Macros in Scheme de William Clinger, il s’agit de sa macro set*! aux pages 4-5.

(define-syntax mset!     ; d'apres William Clinger (forum comp.lang.scheme)

  (syntax-rules ()

    ((mset! x1 e1 reste ...) (mset-aux () x1 e1 reste ...))))

 

(define-syntax mset-aux

  (syntax-rules ()

    ((mset-aux ((x1 e1 t1) ...)) (let ((t1 e1) ...)         ; (***)

                                    (set! x1 t1) ...))

    ((mset-aux ((x1 e1 t1) ...) x2 e2 reste ...) (mset-aux ((x1 e1 t1) ... (x2 e2 newtemp)) reste ...))))

Pour visualiser l’expansion, mettez une quote devant le let à la ligne (***)... Vous noterez que toutes les nouvelles variables locales sont peut-être nommées newtemp, mais le caractère hygiénique des macros define-syntax garantit qu’elles sont bien renommées en internes, ce sont donc bien des variables différentes !!!

5 Exercice 12.15.5

Un grand classique, quel que soit le langage de programmation... Toutes les opérations sont en O(1). J’utilise un style acteur (page 253) avec envois de messages :

File d'attente

(require racket/mpair)      ; pour les doublets mutables

 

(define (make-file-attente)

  (let ((F (mcons '() '())))

    (define (this selecteur . Largs)

      (case selecteur

        ((vide?) (null? (mcar F)))   ; peu importe le (cdr F) si le car est vide !

        ((init!) (set-mcar! F '()))

        ((enfiler!) (let ((d (mlist (car Largs))))

                      (if (null? (mcar F))

                          (set-mcar! F d)

                          (set-mcdr! (mcdr F) d))

                      (set-mcdr! F d)))

       ((premier)  (if (this 'vide?)

                       (error "File vide !")

                       (mcar (mcar F))))

       ((defiler!) (if (this 'vide?)

                       (error "File vide !")

                       (let ((prem (this 'premier)))

                         (set-mcar! F (mcdr (mcar F)))

                         prem)))

       ((liste) (mcar F))       ; file->list

       (else (error "Methode inconnue" selecteur))))

    this))

> (define F (make-file-attente))

> (F 'enfiler! 'a)

> (F 'enfiler! 'b)

> (F 'enfiler! 'c)

> (F 'vide?)

#f

> (F 'premier)

a

> (F 'liste)     ; juste pour le debug...

{a b c}

> (F 'defiler!)

a

> (F 'liste)

{b c}

6 Exercice 12.15.6

(define (make-gen-pairs)

  (let ((n -1))     ; la mémoire privée du générateur

    (lambda ()

      (set! n (+ n 1))

      n)))

(define (make-gen-fib)

  (let ((f_n-1 0) (f_n 1) (tmp '?))  ; deux fibonacci consecutifs, et un neurone de sauvegarde

    (lambda ()

      (set! tmp f_n-1)

      (set! f_n-1 f_n)

      (set! f_n (+ tmp f_n))

      tmp)))

> (let ((fibo (make-gen-fib)))

    (do ((i 0 (+ i 1)))

      ((= i 20) (void))

      (printf "~a " (fibo))))

0 1 1 2 3 5 8 13 21 34 55 89 144 233 377 610 987 1597 2584 4181

7 Exercice 12.15.7

Le générateur des feuilles d’un arbre binaire d’expression jusqu’à épuisement utile une pile, pour sauter brutalement d’une feuille jusqu’au dernier fils droit empilé :

(require "adt-arbre23.rkt" "adt-pile.rkt")

(define (make-gen-feuilles A)

  (let ((pile (pile-vide)) (finished? #f))

    (define (next)

      (cond (finished? '*echec*)

            ((feuille? A) (if (pile-vide? pile)

                              (begin (set! finished? #t) A)

                              (let ((x A))

                                (set! A (sommet pile))

                                (set! pile (depiler pile))

                                x)))

           (else (set! pile (empiler (fd A) pile))

                 (set! A (fg A))

                 (next))))

    next))

> (define G (make-gen-feuilles '(+ (* x (- y 1)) (/ z 3))))

> (do ((i 0 (+ i 1)))

    ((= i 10) (void))

    (printf "~a " (LEAF)))

x y 1 z 3 *echec* *echec* *echec* *echec* *echec*

8 Exercice 12.15.8

a) Elle passe son temps à faire et refaire les mêmes calculs. Par exemple, (binomial 8 3) demande le calcul de (binomial 7 3) et (binomial 7 2). Mais (binomial 7 3) demande lui-même le calcul de (binomial 7 2), et ainsi de suite, une véritable catastrophe, que même la sardine qui bouchait le port de Marseille ce n’était rien à côté, ma pauvre dame !...

b) On ne change pas l’algorithme, donc on n’utilise pas de factorielles ! On rédige une mémo-fonction. Les spécialistes parlent de programmation dynamique... Il y a une infinité de 1 sur les bords du triangle de Pascal, on peut pas les placer dans la mémoire initiale (une A-liste) qui est donc vide :

(define binomial

  (let ((AL '()))                       ; la memoire cache

    (define (calc n p)

      (if (or (= n p) (= p 0))

          1

          (let ((essai (assoc (list n p) AL)))    ; deja en memoire ?

            (if essai

                (cadr essai)

                (let ((res (+ (calc (- n 1) p) (calc (- n 1) (- p 1)))))

                  (set! AL (cons (list (list n p) res) AL))  ; on le stocke

                  res)))))

    calc))

> (time (binomial 1000 20))    ; jouable mais un peu lent...

cpu time: 24 s

339482811302457603895512614793686020778700

> (time (binomial 700 15))     ; déjà calculé au passage !!

cpu time: 0 s

3121564406842366095116973960080

Une autre version avec la mémoire sous forme de table de hash-code, bien plus rapide qu’une A-liste :

(define H-binomial

  (let ((H (make-hash)))

    (define (calc n p)

      (if (or (= n p) (= p 0))

          1

          (let ((essai (hash-ref H (list n p) (lambda () #f))))

            (if essai

                essai

                (let ((res (+ (calc (- n 1) p) (calc (- n 1) (- p 1)))))

                  (hash-set! H (list n p) res)

                  res)))))

    calc))

> (time (H-binomial 1000 20))    ; rapide !

cpu time: 0.7 s

339482811302457603895512614793686020778700

> (time (H-binomial 700 15))     ; déjà calculé au passage !!

cpu time: 0 real time: 0 gc time: 0

3121564406842366095116973960080

9 Exercice 12.15.9

(define (new-couple x y)

  ; aucune mémoire privée, elle est déjà constituée de x et y

  (define (this sel)            ; aucun argument au message

    (case sel

      ((first) x)

      ((second) y)

      (else (error "couple : message inconnu ~a" sel))))

  this)                         ; un acteur est une fonction qui analyse un message

(define (new-couple x0 y0 passwd)

  (let ((x x0) (y y0))          ; les valeurs courantes

    (define (this sel . Largs)

      (case sel

        ((first) x)

        ((second) y)

        ((set-first!) (if (equal? (cadr Largs) passwd)

                          (set! x (car Largs))

                          (error "set-first! : accès refusé, mauvais mot de passe !")))

        ((set-second!) (if (equal? (cadr Largs) passwd)

                           (set! y (car Largs))

                           (error "set-second! : accès refusé, mauvais mot de passe !")))

        ((reset) (if (equal? (car Largs) passwd)

                     (begin (set! x x0) (set! y y0))

                     (error "reset : accès refusé, mauvais mot de passe !")))

        (else (error "couple : méthode inconnue : ~a" sel))))

    this))

10 Exercice 12.15.10

J’utilise la version avec table de hash de l’exercice 12.15.8 :

(define (new-binomial)

  (let ((H (make-hash)))

    (define (calc n p)

      (if (or (= n p) (= p 0))

          1

          (let ((essai (hash-ref H (list n p) (lambda () #f))))

            (if essai

                essai

                (let ((res (+ (calc (- n 1) p) (calc (- n 1) (- p 1)))))

                  (hash-set! H (list n p) res)

                  res)))))

   (define (this sel . Largs)

     (case sel

       ((table-length) (hash-count H))   ; combien de valeurs en mémoire ?

       ((calc) (apply calc Largs))

       ((reset) (set! H (make-hash)))

       (else (error "binomial : methode inconnue : ~a" sel))))

   this))

11 Exercice 12.15.11

Je vous le laisse, c’est très ludique...

12 Exercice 12.15.12

N.B. On entend souvent comme critique de Lisp/Scheme que la notation sucrée t[i] pour un tableau est plus pratique que (vector-ref t i). D’abord rien ne vous empêche de définir vref comme un synonyme de vector-ref si vos petits doigts ressentent une arthrose précoce. Plus sérieusement, l’homogénéité et la cohérence du langage Scheme n’ont pas été choisis au hasard. Notre notation est strictement plus puissante au sens où elle permet d’utiliser des fonctions d’ordre supérieur, pour écrire des choses du style :

(map vector-ref ...)

Ceci dit, le sucre syntaxique, c’est bien, mais ça caramélise ! En C, la notation t[i] n’est elle-même qu’un caramel engluant la construction *(t+i)...

Ce qui ne m’empêche pas d’utiliser le sucre syntaxique for que j’ai en librairie dans le fichier while-for.rkt :

(require "while-for.rkt")

(define (drapeau-aleatoire n)   ; de longueur n

  (let ((v (make-vector n)))

    (for i from 0 to (- n 1)

      (vector-set! v i (case (random 3)

                         ((0) 'bleu)

                         ((1) 'blanc)

                         (else 'rouge))))

    v))

J’aurais du mettre aussi en librairie la fonction permettant d’échanger deux composantes d’un vecteur (ligne 454 page 266). Oui, il faut s’habituer à déposer ses petits utilitaires dans des fichiers à requérir si besoin...

(define (echanger! v i j)      ; ligne 454 page 266

  (let ((temp (vector-ref v i)))

    (vector-set! v i (vector-ref v j))

    (vector-set! v j temp)))

et je programme à vue la solution de la page 267 :

(define (drapeau v)            ; v est un drapeau ne contenant que 'bleu, 'blanc et 'rouge

  (let ((n (vector-length v)))

    (define (iter i j k)  ; v[0..i]=bleu, v[i+1..j]=blanc,v[j+1..k]=?,v[k+1..n-1]=rouge

      (if (> (+ j 1) k)

          v

          (case (vector-ref v (+ j 1))

            ((bleu)  (echanger! v (+ i 1) (+ j 1)) (iter (+ i 1) (+ j 1) k))

            ((blanc) (iter i (+ j 1) k))

            (else    (echanger! v (+ j 1) k) (iter i j (- k 1))))))

    (iter -1 -1 (- n 1))))

La remarque qui suit cet exercice explique comment trier sur place un vecteur avec la fonction vector-sort! de la librairie rnrs/sorting-6. Tapez vector-sort! dans l’aide en ligne...

(require rnrs/sorting-6)

(define v (vector 7 2 4 5 1))

(vector-sort! < v)    ; v --> #(1 2 4 5 7)

La même librairie fournie list-sort pour obtenir une copie triée d’une liste mutable. Si la liste n’est pas mutable (ce qui est le cas par défaut de Racket), inutile d’utiliser la librairie rnrs/sorting-6 : utilisez sort disponible dans le langage racket...

13 Exercice 12.15.13

Il s’agit d’un exercice d’approfondissement pouvant faire l’objet d’un projet, et qui mérite une solution personnelle...

14 Exercice 12.15.14

Il faut vérifier que les formats des deux matrices (rectangulaires !) sont compatibles :

(define (matrix+ M1 M2)

(let ((F1 (matrix-format M1)) (F2 (matrix-format M2)))

  (let ((l1 (first F1)) (c1 (second F1)) (l2 (first F2)) (c2 (second F2)))

    (when (not (and (= l1 l2) (= c1 c2))) (error 'matrix+ "Mauvais formats de matrices !"))

    (build-matrix l1 c1 (lambda (i j) (+ (matrix-ref M1 i j) (matrix-ref M2 i j)))))))

Pour la multiplication, j’utilise notre boucle for (page 247) située dans le module while-for.rkt :

(define (matrix* M1 M2)

  (let ((F1 (matrix-format M1)) (F2 (matrix-format M2)))

    (let ((l1 (first F1)) (c1 (second F1)) (l2 (first F2)) (c2 (second F2)))

      (when (not (= c1 l2)) (error 'matrix* "Mauvais formats de matrices !"))

      (build-matrix l1 c2 (lambda (i j)

                            (let ((s 0))

                              (for k from 0 to (- c1 1)

                                (set! s (+ s (* (matrix-ref M1 i k) (matrix-ref M2 k j)))))

                              s))))))

> (matrix* #(#(1 2 1) #(3 -1 0))

            #(#(1 -1) #(2 3) #(0 -1)))

#(#(5 4) #(1 -6))

15 Exercice 12.15.15

Cet exercice suppose que les listes sont mutables. Je me suis inspiré de la fonction list-length de Common-Lisp, décrite dans CLtL :

(require racket/mpair)

(define (circulaire? L)

  (define (iter slow fast)

    (cond ((eq? slow fast) #t)

          ((null? fast) #f)

          ((null? (mcdr fast)) #f)

          (else (iter (mcdr slow) (mcdr (mcdr fast))))))

  (and (not (null? L)) (iter L (mcdr L))))

> (circulaire? (mlist 'a 'b 'c 'd 'e 'f))

#f

> (define L

    (let ((L (mlist 'a 'b 'c 'd 'e 'f)))

      (do ((ptr L (mcdr ptr)))

        ((null? (mcdr ptr)) (set-mcdr! ptr (mcdr (mcdr L)))))   ; page 275

      L))

> (circulaire? L)

#t

> L

{a b . #0={c d e f . #0#}}

16 Exercice 12.15.16

ERRATUM : il manque une croix dans le cdr du car de d1... Ceci dit :

(define d1

  (let ((d (list 2)))   ; (list 2) <==> (cons 2 '())

    (cons d (list d)))) ; occupation mémoire = 3 doublets

> d1

((2) (2))

Par contre d2 est une structure circulaire, donc il me faut des listes mutables ! Je commence par construire une approximation sans circularités :

(define d2

  (let ((d (list 1 2)))

    (list d d)))         ; d2 --> {{1 2} {1 2}}

et ensuite je pratique une petite chirurgie sur les pointeurs pour introduire des circularités :

> (set-mcdr! (mcdr d2) d2)

> d2

#0={#1={1 2} #1# . #0#}

> (set-mcdr! (mcdr (mcar d2)) (mcdr d2))

> d2

#0={#1={1 2 . {#1# . #0#}} . {#1# . #0#}}

Cette dernière notation de d2 ne me satisfait qu’à moitié, j’aurais bien vu un #3# supplémentaire au lieu de deux fois le {#1# . #0#}. Mais après un mail aux développeurs Racket le 14.09.2010, it’s now fixed for the next version ! Dont acte...

17 Exercice 12.15.17

Déjà résolu en 12.15.8, impossible d’attendre :-)

18 Exercice 12.15.18

La méthode forward est à rajouter parmi les méthodes de la tortue, après init par exemple. Il faut faire attention aux angles et au quadrant dans lequel on travaille... Pour la poursuite, je rajoute une fonction (distance t1 t2) qui retourne la distance entre deux tortues. Je ne prends pas la distance euclidienne usuelle qui utilise des multiplications, mais celle plus simple |x1 - x2| + |y1 - y2| pour laquelle les cercles deviennent des losanges, mais qui est plus rapide et possède toutes les propriétés d’une distance :

(define (distance t1 t2)

  (apply + (map (compose abs -) (t1 'pos) (t2 'pos))))

La fonction poursuite va dessiner la courbe du chien :

(define (poursuite)

  (let ((lapin (new-tortue)) (chien (new-tortue)))

    (lapin 'init '(-200 190) 90)    ; en haut à gauche

    (chien 'lc)

    (chien 'fpos 198 -200)

    (chien 'bc)

    (do ()

      ((< (distance lapin chien) 4) 'Miam!)

      (lapin 'av 1)

      (chien 'toward (lapin 'pos))

      (chien 'av 2))))    ; 2 fois plus vite !

Vous trouverez ce code dans le fichier tortue-toward.rkt.

:-)