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 ! |
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))) |
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).
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) |
F = (a0 a1 a2 a3 a4 ...)
{a0=0, a0=a1, a2=1, a1=a3, a4=2, a5=a2,...}
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 |
