17. La Prise en Main du Contrôle
1 Exercice 17.5.1
2 Exercice 17.5.2
3 Exercice 17.5.3
4 Exercice 17.5.4
5 Exercice 17.5.5
6 Exercice 17.5.6
7 Exercice 17.5.7
8 Exercice 17.5.8
9 Exercice 17.5.9
10 Exercice 17.5.10
11 Exercice 17.5.11
12 Exercice 17.5.12
13 Exercice 17.5.13
14 Exercice 17.5.14
6.0.1.11

17. La Prise en Main du Contrôle

1 Exercice 17.5.1

Dérécursiver une récurrence enveloppée est un processus automatique. Il suffit de prendre en main l’ordre des calculs et à chaque fois dire comment on continue le calcul courant... Pour calculer xy, je calcule r=xy-1 et je continue en multipliant r par x, puis en prenant l’image du résultat par f.

(define (k-expt x y f)    ; y entier naturel, calcule (f (expt x y)) en CPS

  (if (= y 0)

      (f 1)

      (k-expt x (- y 1) (lambda (r) (f (* r x))))))   ; itératif !

> (k-expt 2 10 add1)

1025

La fonction $gcd étant déjà itérative [appel récursif terminal], la continuation sera laissée invariante !

(define (k-gcd x y f)    ; x et y entiers naturels, calcule (f (gcd x y)) en CPS

  (if (= y 0)

      (f x)

      (k-gcd y (modulo x y) (lambda (r) (f r)))))   ; et (lambda (r) (f r)) == f

2 Exercice 17.5.2

Si u et v sont des coefficients de Bezout pour a et n, le PGCD g vérifie g=au+nv. En réduisant modulo n, on voit que si a et n sont premiers entre eux, il vient 1=au, donc u est l’inverse de a. Il suffit alors de le réduire modulo n.

(define (invmod a n)   ; l'inverse de a modulo n

  (bezout a n (lambda (g u v)

                (if (= g 1)   ; a est-il bien inversible modulo n ?

                    (modulo u n)

                    #f))))

3 Exercice 17.5.3

(define (produit L)          ; sans aucun calcul s'il y a un 0 dans la liste L

  (define cpt 0)             ; le compteur de multiplications

  (define (iter L f)         ; boucle en CPS

    (cond ((null? L) (f 1))

          ((= (car L) 0) 0)  ; abandon de continuation !

          (else (iter (cdr L)

                      (lambda (r) (set! cpt (add1 cpt)) (f (* (car L) r)))))))

  (list (iter L id) cpt))    ; je rends le couple (résultat cpt)

> (produit '(1 2 3 4))              ; 24 avec 4 multiplications

(24 4)

> (produit '(1 2 3 4 5 6 0 7 8 9))  ; 0 avec 0 multiplication !

(0 0)

Voilà ce que ça donnerait avec call/cc :

(define (produit L)

  (call/cc (lambda (return)

              (define (aux L)

                (cond ((null? L) 1)                  ; surtout pas (return 1) !

                      ((= (car L) 0) (return 0))     ; abandon de continuation !

                      (else (set! cpt (add1 cpt)) (* (car L) (aux (cdr L))))))

              (aux L))))

4 Exercice 17.5.4

(define (legal? col lig L)

  (andmap (lambda (pos)

            (let ((col1 (car pos)) (lig1 (cadr pos)))

              (not (or (= col col1)

                   (= lig lig1)

                   (= (abs (- col col1)) (abs (- lig lig1)))))))

          L))

Pour que le résultat soit le nombre de solutions, il suffit d’introduire un compteur :

(define cpt 0)

 

(define (queens N k L i backtrack)

  (cond ((= k N) (set! cpt (add1 cpt)) (backtrack))     ; <-----

        ((> i N) (backtrack))

        ((legal? (+ k 1) i L) (queens N

                                      (+ k 1)

                                      (cons (list (+ k 1) i) L) 1

                                      (lambda () (queens N k L (+ i 1) backtrack))))

        (else (queens N k L (+ i 1) backtrack))))

> (queens 8 0 '() 1 (lambda () cpt))   ; combien de solutions pour 8 dames ?

92

5 Exercice 17.5.5

> (visiter '(+ (* 2 (/ 3 x)) (/ z -5))        ; la liste des feuilles

           (lambda (noeud cont) (cont))

           (lambda (feuille cont) (cons feuille (cont)))

           (lambda () '()))

(2 3 x z -5)

> (visiter '(+ (* 2 (/ 3 x)) (/ z -5))        ; le premier noeud de racine /

           (lambda (noeud cont) (if (equal? (racine noeud) '/) noeud (cont)))

           (lambda (feuille cont) (cont))

           (lambda () #f))

(/ 3 x)

Pour trouver la dernière feuille, c’est un peu comme si l’on est au bord du ravin. Une fois tombé dedans, on sait qu’il y avait un ravin :-)

> (visiter '(+ (* 2 (/ 3 x)) (/ z -5))

            (lambda (noeud cont) (cont))       ; la derniere feuille

            (lambda (feuille cont) (let ((essai (cont)))

                                     (if (not essai) feuille try)))

            (lambda () #f))

-5

6 Exercice 17.5.6

Si j’entre au toplevel (call/cc (lambda (k) ...)), la variable k représentera la continuation du toplevel.

> (call/cc (lambda (k) (printf "Résultat = ~a\n" (k 10))))

10

7 Exercice 17.5.7

Regardez à nouveau la fin de la solution de l’exercice 17.5.3...

(define (équilibré? m)

  (call/cc (lambda (return)

             (if (feuille? m)

                 (list #t m)

                 (local [(define m1 (fg m)) (define res1 (équilibré_5? m1))]

                   (if (first res1)

                       (local [(define m2 (fd m)) (define res2 (équilibré_5? m2))]

                         (if (first res2)

                             (if (= (second res1) (second res2))

                                 (list #t (+ (racine m) (second res1) (second res2)))

                                 (return (list #f '?)))   ; abandon !

                             (return (list #f '?))))      ; abandon !

                       (return (list #f '?))))))))        ; abandon !


Mobiles de Calder

8 Exercice 17.5.8

Le PGCD avec GOTO s’écrit en pseudo-langage hyper-impératif :

Fonction PGCD(x,y)

   etiq:  if (y = 0) return x

          (x,y) = (y,x mod y)

          goto etiq

Idem en Scheme en définissant localement GOTO :

(define (pgcd-avec-goto x y)

  (call/cc (lambda (return)

             (let ((etiq '?) (GOTO '?) (tmp '?))

               ; etiq

               (call/cc (lambda (k) (set! GOTO k)))    ; capture

               (when (= y 0) (return x))

               (set! tmp x)

               (set! x y)

               (set! y (modulo tmp y))

               (GOTO 'etiq))))

Code qui n’a parfaitement aucun autre intérêt que d’apprendre le maniement de call/cc, mais qui peut s’avérer utile lors d’une production automatique de code par un compilateur par exemple...

Dans la solution suivante, j’utilise let/cc à la place de call/cc. Un let/ec [un peu plus efficace] aurait aussi bien fait l’affaire :

(define (fortran-fac10)   ; livre page 14

  (let ((a: '?) (b: '?) (N '?) (F '?))

    (set! N 10)

    (set! F 1)

    (let/cc end

      (label a:

             (when (= N 0) (goto b:))

             (set! F (* F N))

             (set! N (- N 1))

             (goto a:))

      (label b:

             (printf "Fac(10) = ~a\n" F)

             (end))

      (goto a:))))

> (fortran-fac10)

Fac(10) = 3628800

(define (prog-sans-goto)    ; les étiquettes deviennent des fonctions co-récursives

  (let ((N 0))

    (define (e10)

      (set! N (+ N 1))

      (if (< N 5) (e20) (printf "\n")))

    (define (e20)

      (printf "~a " N)

      (e10))

    (e10)))

GOTO

9 Exercice 17.5.9

Référence : Applications of Continuations, par Dan Friedman.

(define (cycle f)

  (call/cc (lambda (k)

             (letrec ([loop (lambda () (f k) (loop))])

               (loop)))))

(define (fac n)

  (let ((res 1))

    (cycle (lambda (exit-with)

             (if (zero? n)

                 (exit-with res)

                 (begin (set! res (* res n))

                        (set! n (- n 1))))))))

 

> (fac 10)

3628800

Tiens, au passage, une définition de while avec cycle :

(define-syntax while

  (syntax-rules ()

    ((while test e ...) (cycle (lambda (end)

                                 (if test

                                     (begin e ...)

                                     (end)))))))

10 Exercice 17.5.10

Commençons par définir les macros push! et pop! sur les piles implémentées par des listes :

(define-syntax push!

  (syntax-rules ()

    ((push! x pile) (set! pile (cons x pile)))))

(define-syntax pop!

  (syntax-rules ()

    ((pop! pile) (if (null? pile)

                     (error "Empty pile")

                     (let ((x (car pile)))

                       (set! pile (cdr pile))

                       x)))))

L’instruction (entrer proc) va consister à empiler la continuation courante puis lancer la procédure unaire proc, tandis que sortir va à la fois la dépiler mais aussi l’exécuter pour se retrouver dans le contexte... Bien entendu il faudra gérer une pile *cont* pour stocker toutes ces continuations !

(define *cont* '())

(define-syntax entrer

  (syntax-rules ()

    ((entrer proc) (call/cc (lambda (k) (push! k *cont*) (proc))))))

(define (sortir)

  ((pop! *cont*)))

Testons l’exemple du livre page 413 :

(define (foo)

  (printf "1")

  (entrer bar)

  (printf "5"))

(define (bar)

  (printf "2")

  (entrer gee)

  (printf "4")

  (sortir)

  (printf "Bug"))

(define (gee)

  (printf "3")

  (sortir)

  (printf "Bug"))

> (foo)

12345

La généralisation de cet exercice se nomme : coroutines.

11 Exercice 17.5.11

L’opérateur ambigü amb est dû à John McCarthy dans son papier A basis for a Mathematical Theory of Computation (1963).

McCarthy

Je charge le module amb.rkt et j’exprime les contraintes du puzzle :

#lang racket

(require "amb.rkt")

 

(define (tous-distincts? L)

  (cond ((null? L) #t)

        ((member (car L) (cdr L)) #f)

        (else (tous-distincts? (cdr L)))))

 

(define (solve-puzzle)

  (let ((A (amb 1 2 3 4 5 6 7 8 9))

        (B (amb 0 1 2 3 4 5 6 7 8 9))

        (C (amb 1 2 3 4 5 6 7 8 9))

        (D (amb 0 1 2 3 4 5 6 7 8 9))

        (r (amb 0 1)))       ; B + D = C et je retiens r...

     (assert (and (tous-distincts? (list A B C D))

                  (= (+ D B) (+ (* 10 r) C))

                  (= (+ r A C) D)))

     (printf "Solution : ~a~a + ~a~a = ~a~a\n" A B C D D C)     ; la solution courante

     (amb))    ; backtrack pour les autres solutions...

> (solve-puzzle)

Solution : 18 + 24 = 42

Solution : 18 + 35 = 53

Solution : 18 + 46 = 64

Solution : 18 + 57 = 75

Solution : 18 + 79 = 97

Solution : 27 + 14 = 41

Solution : 27 + 36 = 63

Solution : 27 + 58 = 85

Solution : 27 + 69 = 96

Solution : 36 + 15 = 51

Solution : 36 + 48 = 84

Solution : 36 + 59 = 95

Solution : 45 + 16 = 61

Solution : 45 + 27 = 72

Solution : 45 + 38 = 83

Solution : 54 + 17 = 71

Solution : 54 + 28 = 82

Solution : 54 + 39 = 93

Solution : 63 + 18 = 81

Solution : 63 + 29 = 92

Solution : 72 + 19 = 91

amb : no more solution !

Le lecteur versé dans le langage Prolog sera en pays de connaissance. Le schemeur pourra s’intéresser à la librairie datalog de Racket, sorte de Prolog pur sans le cut, servant à poser des requêtes logiques dans des bases de données.

12 Exercice 17.5.12

Garder présent à l’esprit que Lazy Racket, maintenu par Eli Barzilay, est un langage expérimental en cours de gestation...

#lang lazy

 

(define-syntax show   ; mieux que la ligne 352 car begin retourne maintenant une promesse !

  (syntax-rules ()

    ((show expr) (printf "> ~s\n~s\n" 'expr (!! expr)))))

 

(define (ints-from n)

  (cons n (ints-from (+ n 1))))

 

(show (take 10 (ints-from 5)))

   ; --> (5 6 7 8 9 10 11 12 13 14)

 

(define NAT (ints-from 0))

(define UN (cons 1 UN))

(define NNAT (cons 0 (map + NNAT UN)))

(define PAIR (filter even? NAT))

(define FACT (cons 1 (map * FACT (cdr NAT))))

 

(show (take 10 FACT))

   ; --> (1 1 2 6 24 120 720 5040 40320 362880)

 

(define (melanger s1 s2)     ; s1 et s2 flots infinis strictement croissants

  (cond ((< (car s1) (car s2)) (cons (car s1) (melanger (cdr s1) s2)))

        ((> (car s1) (car s2)) (cons (car s2) (melanger s1 (cdr s2))))

        (else (cons (car s1) (melanger (cdr s1) (cdr s2))))))

 

(define (zoom x s)

  (cons (* (car s) x) (zoom x (cdr s))))

 

(define PPAIR (zoom 2 NAT))

 

(show (take 10 (melanger (zoom 2 NAT) (zoom 3 NAT))))

   ; --> (0 2 3 4 6 8 9 10 12 14)

 

(define (flot-de-hamming)

  (define h (cons 1 (melanger (zoom 2 h) (melanger (zoom 3 h) (zoom 5 h)))))

  h)

 

(define H (flot-de-hamming))    ; seuls facteurs premiers 2, 3, 5

 

(show (take 30 H))

   ; --> (1 2 3 4 5 6 8 9 10 12 15 16 18 20 24 25 27 30 32 36 40 45 48 50 54 60 64 72 75 80)

(show (list-ref H 49999))     ; le 50000ème élément du flot H

   ; --> 2379126835648701693226200858624

13 Exercice 17.5.13

(define (entrelacer s1 s2)

  (cons (car s1) (entrelacer s2 (cdr s1))))

 

(take 10 (entrelacer NAT PAIR))

   ; --> (0 0 1 2 2 4 3 6 4 8)

 

(define F (entrelacer NAT F))

 

(show (take 10 F))

   ; --> (0 0 1 0 2 1 3 0 4 2)

Comment prévoir à la main le résultat précédent ? Ecrivons F avec des inconnues :

F = (a0 a1 a2 a3 a4 ...)

L’équation (entrelacer NAT F) = F produit un système infini d’équations que l’on peut résoudre (heureusement !) en cascade :

{a0=0, a0=a1, a2=1, a1=a3, a4=2, a5=a2,...}

d’où F = (0 0 1 0 2 1 ...).

14 Exercice 17.5.14

En Lazy Racket, stream-ref n’est autre que list-ref. Concentrons-nous sur l’implémentation des flots en Scheme strict du § 17.4.4, voir le fichier streams.rkt.

#lang racket

(require "streams.rkt")

 

(define SIN (stream-cons 0 (int-serie COS)))

(define COS (stream-cons 1 (stream-map - (int-serie SIN))))   ; intellectuel non ?...

 

(printf "Flot de la serie SIN :\n")

(stream-print SIN)

  ; -_> <0, 1, 0, -1/6, 0, 1/120, 0, -1/5040, 0, 1/362880, 0, -1/39916800, 0, 1/6227020800, 0, ...>

 

(printf "Flot de la serie COS :\n")

(stream-print COS)

  ; --> <1, 0, -1/2, 0, 1/24, 0, -1/720, 0, 1/40320, 0, -1/3628800, 0, 1/479001600, 0, -1/87178291200, ...>

 

(define (serie+ S1 S2)

  (stream-map + S1 S2))

 

(define (serie* S1 S2)

  (stream-cons (* (stream-car S1) (stream-car S2))

               (serie+ (stream-map (lambda (t) (* t (stream-car S1))) (stream-cdr S2))

                       (serie* (stream-cdr S1) S2))))

 

(stream-print (serie+ (serie* COS COS) (serie* SIN SIN)))

  ; --> <1, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, ...>

 

(define (inv-serie S)    ; S de premier terme 1

  (stream-cons 1 (stream-map - (serie* (stream-cdr S) (inv-serie S)))))

 

(define 1/1-X (inv-serie (poly->serie '(1 -1))))   ; série de 1/(1-X)

(stream-print 1/1-X)

  ; --> <1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, ...>

 

(stream-print (int-serie 1/1-X))                   ; série de ln(1-X)

  ; --> <1, 1/2, 1/3, 1/4, 1/5, 1/6, 1/7, 1/8, 1/9, 1/10, 1/11, 1/12, 1/13, 1/14, 1/15, ...>

 

(define TAN (serie* SIN (inv-serie COS)))

> (stream-ref TAN 15)       ; coeff. de x^15 dans la série de tan(x)

929569/638512875

je vous tire mon chapeau !