#lang racket ;;; chap17.rkt - Les sources du chapitre 17 (La Prise en Main du Contrôle) ;;; Livre PCPS : "Premiers Cours de Programmation avec Scheme" ;;; Langage determine par le source (require "show.rkt") "Du style direct a CPS" (define (somme L) ; page 377 (if (null? L) 0 (+ (car L) (somme (cdr L))))) (show (somme '(2 8 5 1))) (define (k-somme L f) ; calcule (f (somme L)) sans utiliser somme, ligne 5 (if (null? L) (f 0) (k-somme (cdr L) (lambda (r) (f (+ (car L) r)))))) (show (k-somme '(2 8 5 1) zero?)) "Abandon et capture de continuation" (define (k-valeur expr f) ; style CPS, ligne 11 (if (number? expr) (f expr) (k-valeur (cadr expr) ; valeur a du premier argument (lambda (a) (k-valeur (caddr expr) ; valeur b du second argument (lambda (b) (k-valeur-op (car expr) ; puis... (lambda (proc) (f (proc a b)))))))))) (define (k-valeur-op op f) (f (case op ((add) +) ((sub) -) ((mul) *) ((quo) /)))) (define id (lambda (x) x)) ; la fonction identite (show (k-valeur '(add (mul 2 (add 3 4)) (sub 5 1)) id)) ; ligne 35 (define (k-valeur-ret expr f-init) ; ligne 46 (define (iter e f) (cond ((number? e) (f e)) ((equal? (car e) 'return) (iter (cadr e) f-init)) (else (iter (cadr e) (lambda (r1) (iter (caddr e) (lambda (r2) (k-valeur-op (car e) (lambda (proc) (f (proc r1 r2))))))))))) (iter expr f-init)) (show (k-valeur-ret '(add (mul 2 (return (add 3 4))) (sub 5 1)) add1)) (define PHOTO '?) ; ligne 59 (define (k-valeur-photo expr f) (cond ((number? expr) (f expr)) ((equal? (car expr) 'photo) (set! PHOTO f) (k-valeur-photo (cadr expr) f)) (else (k-valeur-photo (cadr expr) (lambda (r1) (k-valeur-photo (caddr expr) (lambda (r2) (k-valeur-op (car expr) (lambda (proc) (f (proc r1 r2))))))))))) (show (k-valeur-photo '(add (mul 2 (photo (add 3 4))) (sub 5 1)) add1)) (show (PHOTO 5)) "Les continuations CPS a plusieurs variables" (define (k-fib2 n f) ; calcule (f (fib n) (fib (+ n 1))) sans utiliser fib (if (= n 0) (f 0 1) (k-fib2 (- n 1) (lambda (a b) (f b (+ a b)))))) (show (time (k-fib2 500 (lambda (x y) x)))) "Mise en attente d'un calcul sans pile" ; je la nomme produit0 car il y a une autre fonction produit plus loin... (define (produit0 L) ; aucun calcul si L contient 0 (define (iter L f) ; boucle locale en CPS (cond ((null? L) (f 1)) ((= (car L) 0) 0) ; abandon de la continuation f (else (iter (cdr L) (lambda (r) (f (* (car L) r))))))) (iter L id)) (show (produit0 '(5 1 2 0 3 4))) "Generateurs et calculs pas a pas" (define (solution pred L) ; gel (cond ((null? L) '*echec*) ((pred (car L)) (cons (car L) (lambda () (solution pred (cdr L))))) (else (solution pred (cdr L))))) (define (suivante sol) ; degel (if (equal? sol '*echec*) '*echec* ((cdr sol)))) (define (courante sol) (if (equal? sol '*echec*) '*echec* (car sol))) (do ((sol (solution number? '(1 et 2 font 3)) (suivante sol))) ((equal? sol '*echec*) (printf "Fini\n")) (printf "Solution : ~a (je continue)\n" (courante sol))) "Application au retour-arriere : les N dames" (define (legal? n p L) ; exo 17.5.4 '...) (define (queens N k L i backtrack) (cond ((= k N) L) ; fini ((> i N) (backtrack)) ; impasse, retour arrière ! ((legal? (+ k 1) i L) ; une nouvelle dame en (k+1,i) (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)))) ; (show (queens 3 0 '() 1 (lambda () 'Fini))) ; (show (queens 8 0 '() 1 (lambda () 'Fini))) "Les continuations de 1ere classe avec call/cc" ; La remarque au bas de la page 385 semble obsolete, Racket ayant pris soin de delimiter la continuation ! (show (+ 3 (call/cc (lambda (k) (* 3 4))) 5)) (show (+ 3 (call/cc (lambda (k) (* (/ 5 (k 8)) 4))) 5)) (define the-cont '?) (show (+ 3 (call/cc (lambda (k) (set! the-cont k) 4)) 5)) (show (the-cont 1)) "S'echapper d'un calcul recursif" (define (produit L) ; version avec call/cc} (define (mul a b) ; pour compter (set! cpt (+ cpt 1)) ; les multiplications (* a b)) (call/cc (lambda (k) (define (aux L) (cond ((null? L) 1) ((zero? (car L)) (k 0)) ; abandon ! (else (mul (car L) (aux (cdr L)))))) (aux L)))) (define cpt 0) (printf "Resultat=~a avec cpt=~a\n" (produit '(2 3 4 5)) cpt) ; 4 multiplications (set! cpt 0) (printf "Resultat=~a avec cpt=~a\n" (produit '(2 3 0 4 5)) cpt) ; aucune multiplication ! "Capturer la continuation du toplevel" (define abort '?) (show (call/cc (lambda (k) (set! abort k)))) (show (+ (* 2 3) (abort (+ 4 5)) 6)) "Capturer une continuation pour simuler un GOTO" (define (fac n) ; imperative avec GOBACK (call/cc (lambda (return) (let ((GOBACK '?) (res 1)) (call/cc (lambda (k) (set! GOBACK k))) ; capture ; etiquette (if (zero? n) (return res) (begin (set! res (* res n)) (set! n (- n 1)) (GOBACK 'etiquette))))))) (show (fac 5)) (printf "Le coup du (loop loop) :\n") (define p 0) (let ((loop (call/cc (lambda (k) k)))) (printf "~a " p) (set! p (+ p 1)) (when (< p 10) (loop loop))) (printf "\n") ; implementation du GOBACK (define (GOBACK k) (k k)) (define-syntax label ; Une macro 'label' pour declarer une etiquette (syntax-rules () ((label etiq) (set! etiq (call/cc (lambda (k) k)))))) (define (fac-avec-goback n) (let ((res 1) (loop '?)) (label loop) (if (= n 1) res (begin (set! res (* res n)) (set! n (- n 1)) (GOBACK loop))))) (show (fac-avec-goback 5)) ; utilisation de let/ec (show (let/ec abort (* 2 (abort (* 3 4)) 5))) ; implementation du GOTO ; j'utilise des majuscules car label est deja defini plus haut... et puis c'est kitch. (define-syntax LABEL (syntax-rules () ((LABEL etiq expr ...) (let/cc etiq-suiv (let/cc k (set! etiq k) (etiq-suiv '?)) expr ...)))) (define-syntax GOTO (syntax-rules () ((GOTO etiq) (etiq '?)))) (define (prog-avec-GOTO) (let ([e10 '?] [e20 '?] [N 0]) (let/cc END (LABEL e10 ; declaration de e10 (set! N (+ N 1)) (when (< N 5) (GOTO e20)) (printf "\n") (END)) (LABEL e20 ; declaration de e20 (printf "~a " N) (GOTO e10)) (GOTO e10)))) ; entree dans le programme (prog-avec-GOTO) "17.3 La Programmation Non-Deterministe" ; La ligne ci-dessous provoque uniquement la premiere fois le telechargement et l'installation du package amb.plt sur: ; http://planet.plt-scheme.org/display.ss?package=amb.plt&owner=murphy (require (planet murphy/amb:1:1/amb)) ; le site PLaneT devrait changer de nom sous peu, peut-être simplement RACKET ? (show (amb-find (let ((x (amb 1 2 3 4 5)) (y (amb 6 7 8 9))) (amb-assert (> (+ x y) 10)) (list x y)))) (show (with-handlers ((exn:fail:amb? (lambda (e) #f))) (amb-find (let ((x (amb 1 2 3 4 5)) (y (amb 6 7 8 9))) (amb-assert (> (+ x y) 1000)) ; impossible ! (list x y))))) (show (amb-find (let ((x (amb 1 2 3 4 5)) (y (amb 6 7 8 9))) (if (> (+ x y) 10) (list x y) (amb))))) (show (amb-collect (let ((x (amb 1 2 3 4 5)) (y (amb 6 7 8 9))) (amb-assert (> (+ x y) 10)) (list x y)))) "Un chercheur de nombres premiers" (define (un-entier-de a b) (if (> a b) (amb) ; impasse, donc backtrack ! (amb a (un-entier-de (+ a 1) b)))) (define (premier? n) ; n pas trop grand (define (ppdiv n) ; le plus petit diviseur de n dans[2,n] (local [(define (iter d) ; d impair, aucun diviseur dans [2,d[ (cond ((> (sqr d) n) n) ; il est premier ! ((zero? (modulo n d)) d) ; on le tient ! (else (iter (+ d 2)))))] (if (even? n) 2 (iter 3)))) (and (>= n 2) (= n (ppdiv n)))) (show (amb-collect (let ((n (un-entier-de 2 80))) (amb-assert (premier? n)) n))) "Un puzzle logique" (define (tous-distincts? L) (or (null? L) (and (not (member (car L) (cdr L))) (tous-distincts? (cdr L))))) (define (solve-puzzle) (amb-find (let ((Bob (amb 1 2 3 4)) (Alice (amb 2 3 4 5)) (Max (amb 2 3 4)) (Emile (amb 2 3 4 5)) (Vanessa (amb 1 2 3 4 5))) (let ((L (list Max Bob Vanessa Emile Alice))) (amb-assert (and (tous-distincts? L) (> Emile Alice) (not (= 1 (abs (- Vanessa Max)))) (not (= 1 (abs (- Alice Max)))))) `((Bob ,Bob) (Max ,Max) (Alice ,Alice) (Vanessa ,Vanessa) (Emile ,Emile)))))) (show (solve-puzzle)) "Une implementation de amb" ;;; Voir le fichier amb.rkt "17.4 La Programmation Paresseuse" "Le langage HASKELL" ; Voir le fichier haskell.hs "Lazy Racket" ; Voir le fichier lazy-racket.rkt "Rendre MISS paresseux" ; Voir le fichier lazy-miss.rkt, regardez la fonction %install-software qui definit FIBS par ex. ; Exemple de session : ; > (%lazy-miss) ; Miss Is (almost) a Susbset of lazy Scheme ! ; [lazy]? FIBS ; --> # ; [lazy]? ($print-list ($take 10 FIBS)) ; < 0 1 1 2 3 5 8 13 21 34 > ; --> # ; [lazy]? ($define fac ($lambda (n) ($if ($= n 0) 1 ($* n (fac ($- n 1)))))) ; --> # ; [lazy]? (fac 5) ; --> 120 ; [lazy]? (define f (lambda (x y) x)) ; Miss error : Variable MISS inconnue : define ; [lazy]? ($define f ($lambda (x y) x)) ; --> # ; [lazy]? (f 4 (fac 100000000000)) ; --> 4 "Une implementation des flots en Scheme strict" ; Voir le fichier streams.rkt