add examples from J-P Roy's textbook to check before a release

collects/tests/jpr/README.TXT

@@ -0,0 +1,6 @@
+Some files to be checked for compatibility with new releases
+of PLT-Scheme, from 4.2.5.1
+
+Book : "Premiers Cours de Programmation avec (PLT) Scheme"
+Jean-Paul Roy, Sept. 2010, 410 pages, to be published.
+

collects/tests/jpr/balle-grav-frot.ss

@@ -0,0 +1,48 @@
+;; The first three lines of this file were inserted by DrScheme. They record metadata
+;; about the language level of this file in a form that our tools can easily process.
+#reader(lib "htdp-advanced-reader.ss" "lang")((modname balle-grav-frot) (read-case-sensitive #t) (teachpacks ()) (htdp-settings #(#t write mixed-fraction #t #t none #f ())))
+;;; Language : advanced student
+
+(require "valrose.ss")
+
+(define (balle-avec-gravitation-et-frottement x0 y0 dx0 dy0)
+  (local [(define BALLE (bitmap "ballon.png"))
+          (define R (/ (image-width BALLE) 2))
+          (define SIZE 400)
+          (define FOND (place-image (text "Mouse or Space !" 18 "Blue") 200 80 (rectangle SIZE SIZE 'solid "yellow")))
+          (define-struct monde (x y dx dy))
+          (define INIT (make-monde x0 y0 dx0 dy0))
+          (define G #i1)
+          (define F #i0.95)
+          (define (suivant m)
+            (local [(define x (monde-x m))
+                    (define y (monde-y m))
+                    (define dx (monde-dx m))
+                    (define dy (monde-dy m))
+                    (define xs (+ x dx))
+                    (define ys (+ y dy))]
+              (cond ((> ys (- SIZE R)) (make-monde xs (- SIZE R) (* F dx) (+ (* F (- dy)) G)))
+                    ((< xs R) (make-monde R ys (* F (- dx)) (* F (+ dy G))))
+                    ((> (+ xs R) SIZE) (make-monde (- SIZE R) ys (* F (- dx)) (* F (+ dy G))))
+                    ((< ys R) (make-monde xs R dx (+ (* F (- dy)) G)))
+                    (else (make-monde xs ys dx (+ dy G))))))
+          (define (souris m x y evt)
+            (if (mouse=? evt "button-down")
+                (make-monde x y (monde-dx m) (monde-dy m))
+                m))
+          (define (clavier m key)
+            (if (key=? key " ")
+                (make-monde (+ R (random (- SIZE (* 2 R)))) (+ R (random (- SIZE (* 2 R)))) (monde-dx m) (monde-dy m))
+                m))
+          (define (dessiner m)
+            (place-image BALLE (monde-x m) (monde-y m) FOND))
+          (define (final? m)
+            (and (< (abs (- SIZE (monde-y m) R)) 1) (< (abs (monde-dx m)) 1) (< (abs (monde-dy m)) 1)))]
+    (big-bang INIT
+              (on-tick suivant)
+              (on-draw dessiner SIZE SIZE)
+              (on-mouse souris)
+              (on-key clavier)
+              (stop-when final?))))
+
+(balle-avec-gravitation-et-frottement 200 200 5 15)

collects/tests/jpr/dessine-arbre.ss

@@ -0,0 +1,34 @@
+;; The first three lines of this file were inserted by DrScheme. They record metadata
+;; about the language level of this file in a form that our tools can easily process.
+#reader(lib "htdp-advanced-reader.ss" "lang")((modname dessine-arbre) (read-case-sensitive #t) (teachpacks ()) (htdp-settings #(#t write mixed-fraction #t #t none #f ())))
+;;; dessine-arbre.ss
+
+(require "valrose.ss")
+
+(define (objet->image x)    ; x est un operateur ou une feuille
+  (text (if (number? x) (number->string x) (symbol->string x))
+        18 "black"))
+
+(define (vert h) (rectangle 1 h 'solid "white"))
+(define (horiz w) (rectangle w 1 'solid "white"))
+
+(define (arbre->image A)    ; Arbre --> Image au niveau n
+  (if (feuille? A)
+      (objet->image A)
+      (local [(define ig (arbre->image (fg A)))
+              (define wg/2 (/ (image-width ig) 2))
+              (define id (arbre->image (fd A)))
+              (define wd/2 (/ (image-width id) 2))
+              (define igd (beside/align 'top ig (horiz 20) id))
+              (define wgd/2 (/ (image-width igd) 2))]
+        (above (objet->image (racine A))
+               (beside (horiz wg/2) 
+                       (line (- wg/2 wgd/2) 20 "black") 
+                       (line (- wgd/2 wd/2) 20 "black")
+                       (horiz wd/2))
+               (vert 5)
+               igd))))
+
+(arbre->image '(+ (* (+ (* x (- x y)) 2) (* (- a b) longueur)) (/ (* x 2) y)))
+
+

collects/tests/jpr/foo.ss

@@ -0,0 +1,18 @@
+#lang scheme
+(read-accept-reader #t) 
+
+(define (chercher-definition fonc f)    
+  (define (good-def? expr)
+    (and (pair? expr)
+         (equal? (car expr) 'define)
+         (or (equal? (cadr expr) fonc)                                ; (define fonc ...)
+             (and (pair? (cadr expr)) (equal? (caadr expr) fonc)))))  ; (define (fonc ...) ...)
+  (call-with-input-file f 
+    (lambda (p-in)
+      (car (filter good-def? (list-ref (read p-in) 3))))))   ; (module foo scheme (#%module-begin ...))
+
+(define (foo x y)   ; comment
+  (+ x y))
+
+(printf "The definition of the function foo in this file foo.ss is :\n")
+(chercher-definition 'foo "foo.ss")

collects/tests/jpr/jeu-du-chaos.ss

@@ -0,0 +1,40 @@
+#lang scheme
+(require graphics/graphics)
+
+(open-graphics)
+(define VIEW (open-viewport "Essai Graphics" 300 100))
+(define tr-segment (draw-line VIEW))  ; un traceur de segment
+(define tr-pixel (draw-pixel VIEW))   ; un traceur de pixel
+
+(define A (make-posn 150 10))
+(define B (make-posn 10 90))
+(define C (make-posn 290 90))
+
+(tr-segment A B "red")
+(tr-segment B C "red")
+(tr-segment C A "red")
+
+(define M-INIT (make-posn (random 300) (random 100)))
+
+(define (jeu-du-chaos)
+  (define (moyenne x y)
+    (/ (+ x y) 2))
+  (define (milieu A B)
+    (make-posn (moyenne (posn-x A) (posn-x B))
+               (moyenne (posn-y A) (posn-y B))))
+  (define (iter nb-fois M)   ; M est le dernier point courant affiche
+    (if (= nb-fois 0)
+      (void)
+      (let* ((S (case (random 3) ((0) A) ((1) B) ((2) C)))
+             (Msuiv (milieu M S)))
+        (tr-pixel Msuiv "blue")
+        (iter (- nb-fois 1) Msuiv))))
+  (tr-pixel M-INIT "blue")
+  (iter 4000 M-INIT))
+
+(jeu-du-chaos)
+
+
+
+
+

collects/tests/jpr/mon-script.ss

@@ -0,0 +1,30 @@
+#!/usr/bin/env  mzscheme
+#lang scheme
+;;; a Unix script but also a plain Scheme file...
+
+(define (get-scheme-files)      ; la A-liste ((fichier nb-defs) ...)
+  (map (lambda (f) (list f (nb-defs f)))
+       (filter (lambda (f)
+                 (and (file-exists? f) (regexp-match ".ss$" f)))
+               (map path->string (directory-list)))))
+
+(define (nb-defs f)              ; number of definitions in f
+  (define (is-def? x)            ; x is a definition ?
+    (and (pair? x) (equal? (car x) 'define)))
+  (call-with-input-file f
+    (lambda (p-in)
+      (let ((x (read p-in)))     ; is f a module ?
+        ;(printf "x=~s\n\n" x)
+        (if (and (pair? x) (equal? (car x) 'module))   ; yes
+            (length (filter is-def? (list-ref x 3)))   ; one only read is enough !
+            (do ((e (read p-in) (read p-in))           ; non
+                 (acc (if (is-def? x) 1 0) (if (is-def? e) (+ acc 1) acc)))
+            ((eof-object? e) acc)))))))
+
+(read-accept-reader #t)          ; for the #lang line
+(printf "Current directory is :\n   ~a\n" (current-directory))
+(define FILES (get-scheme-files))
+(printf "It contains ~a Scheme files. " (length FILES))
+(printf "Here they are, sorted by the number of definitions :\n")
+(printf "~s\n" (sort FILES (lambda (L1 L2) 
+                              (<= (second L1) (second L2)))))

collects/tests/jpr/monte-carlo.ss

@@ -0,0 +1,51 @@
+;;; Simulation graphique a la Monte Carlo
+;;; ----> Some red points are outside the circle on the bottom right ???
+
+#lang scheme/gui
+
+(define RED-PEN (make-object pen% "red" 2 'solid))
+(define BLACK-PEN (make-object pen% "black" 2 'solid))
+(define BLUE-PEN (make-object pen% "blue" 2 'solid))
+(define YELLOW-BRUSH (make-object brush% "yellow" 'solid))
+
+(define FRAME 
+  (new frame% (label "Monte-Carlo") (stretchable-width #f) (stretchable-height #f)))
+
+(define VPANEL 
+  (new vertical-panel% (parent FRAME)))
+
+(define TEXT-FIELD 
+  (new text-field% (parent VPANEL) 
+       (label "Nombre de points N =") 
+       (init-value "5000")
+       (callback (lambda (t e)
+                   (when (eq? (send e get-event-type) 'text-field-enter)
+                     (send CANVAS refresh))))))
+
+(define MSG (new message% (parent VPANEL) (label "?") (min-width 50)))
+
+(define CANVAS 
+  (new canvas% (parent VPANEL) 
+       (min-width 300) (min-height 300) (style '(border))
+       (paint-callback 
+        (lambda (obj evt)   ; c est le canvas et e est l'evenement
+          (let ((dc (send obj get-dc)))
+            (send dc clear)
+            (send dc set-pen BLUE-PEN)          ; le bord du disque
+            (send dc set-brush YELLOW-BRUSH)    ; l'interieur du disque
+            (send dc draw-ellipse 0 0 299 299)
+            (let ((s 0) (N (string->number (send TEXT-FIELD get-value))))
+              (do ((i 0 (+ i 1)))
+                ((= i N) (send MSG set-label (number->string (* 4.0 (/ s N)))))
+                (let ((x (random 300)) (y (random 300)))
+                  (if (< (+ (sqr (- x 150)) (sqr (- y 150))) (sqr 150))
+                      (begin (send dc set-pen RED-PEN) (set! s (+ s 1)))
+                      (send dc set-pen BLACK-PEN))
+                  (send dc draw-point x y)))))))))
+
+(define BUTTON 
+  (new button% (parent VPANEL) (label "Go !")
+       (callback (lambda (obj evt)
+                   (send CANVAS on-paint)))))
+
+(send FRAME show #t)

collects/tests/jpr/streams.ss

@@ -0,0 +1,52 @@
+#lang scheme
+
+#|
+(define-syntax scons                                  ; SICP ==> ERROR (see Rationale of SRFI-41)
+  (syntax-rules ()
+    ((scons obj s) (cons obj (delay s)))))
+
+(define (scar s) (car s))
+(define (scdr s) (force (cdr s)))
+|#
+
+(define-syntax scons
+  (syntax-rules ()
+    ((scons obj s) (delay (cons obj (delay s))))))    ; from my book
+
+(define (scar s) (car (force s)))
+(define (scdr s) (force (cdr (force s))))
+
+; -------------------------------------------------------------------
+
+(define (element s k)          ; k-th element of s
+  (if (= k 1) 
+      (scar s)
+      (element (scdr s) (- k 1))))
+
+(define (smerge s1 s2)        ; s1 et s2 infinite ascending streams
+  (let ((x1 (scar s1)) (x2 (scar s2)))
+    (cond ((< x1 x2) (scons x1 (smerge (scdr s1) s2)))
+          ((> x1 x2) (scons x2 (smerge s1 (scdr s2))))
+          (else (scons x1 (smerge (scdr s1) (scdr s2)))))))
+
+(define (szoom x S)
+  (scons (* x (scar S)) (szoom x (scdr S))))
+
+(define H (scons 1 (smerge (szoom 2 H) (smerge (szoom 3 H) (szoom 5 H)))))   ; Hamming
+
+(time (element H 20000))
+
+;;; SRFI-41 bug
+
+(define (sfrom n step)
+  (scons n (sfrom (+ n step) step)))
+
+(define (smap f s)
+  (scons (f (scar s)) (smap f (scdr s))))
+
+(define (s->list n s)
+  (if (= n 0)
+      '()
+      (cons (scar s) (s->list (- n 1) (scdr s)))))
+
+(s->list 4 (smap / (sfrom 4 -1)))    ; error ou (1/4 1/3 1/2 1) ?

collects/tests/jpr/valrose.ss

@@ -0,0 +1,110 @@
+;;; teachpack valrose.ss - jpr, Mars 2010
+
+#lang scheme
+
+(require 2htdp/image 2htdp/universe)                     ; images et animations, version 2
+
+(provide 
+ (all-from-out 2htdp/image 2htdp/universe)
+ show match                                             ; quelques utilitaires manquants
+ arbre racine fg fd fdd feuille? operateur?             ; les arbres (2-3) d'expressions arithmetiques
+ pile-vide pile-vide? empiler depiler sommet            ; les piles fonctionnelles
+ atome? make-neg make-fbf2 connecteur arg1 arg2)        ; les FBF de la Logique d'ordre 0
+
+; petit utilitaire pour avoir les tests dans l'editeur avec echo au toplevel
+
+(define-syntax show
+  (syntax-rules ()
+    ((show e) (begin (printf "? ~s\n" 'e) (printf "--> ~s\n" e)))))
+
+; le type abstrait "arbre 2-3 d'expression algebrique". Toutes les operations sont O(1)
+
+(define (arbre r Ag . Lfils)    ; au moins un fils !
+  (cons r (cons Ag Lfils)))
+
+(define (racine A)
+  (if (feuille? A)
+      (error (format "pas de racine pour une feuille : ~a" A))
+      (first A)))
+
+(define (fg A)
+  (if (feuille? A)
+      (error (format "pas de fg pour une feuille : ~a" A))
+      (second A)))
+
+(define (fd A)
+  (if (feuille? A)
+      (error (format "pas de fd pour une feuille : ~a" A))
+      (third A)))
+
+(define (fdd A)
+  (if (or (feuille? A) (empty? (rest (rest (rest A)))))
+      (error (format "le fdd n'existe pas : ~a" A))
+      (fourth A)))
+
+(define (feuille? obj)
+  (or (number? obj) 
+      (boolean? obj)
+      (and (symbol? obj) (not (operateur? obj)))))
+
+(define (operateur? obj)
+  (if (member obj '(+ * - / < > <= >= =)) #t #f))
+
+; le type abstrait "pile fonctionnelle". Toutes les operations sont O(1)
+
+(define (pile-vide) 
+  empty)
+
+(define (pile-vide? pile) 
+  (empty? pile))
+
+(define (empiler x pile)
+  (cons x pile)) 
+
+(define (sommet pile)
+  (if (empty? pile)
+      (error "Pile vide !")
+      (first pile)))
+
+(define (depiler pile)
+  (if (empty? pile)
+      (error "Pile vide !")
+      (rest pile)))
+
+; le type abstrait "fbf en logique d'ordre 0"
+; un parametre F denote une fbf
+
+(define (atome? F)            ; le reconnaisseur d'atomes [symboles p, q, r...]
+  (symbol? F))
+
+(define (make-neg F)      ; le constructeur de molecule unaire (negation)
+  (cond ((atome? F) (list 'non F))
+        ((equal? (connecteur F) 'non) (arg1 F))   ; petite simplification au passage...
+        (else (list 'non F))))
+
+(define (make-fbf2 r Fg Fd)   ; le constructeur de molecule binaire (et, ou, =>)
+  (if (not (member r '(et ou =>)))
+      (error "Mauvais connecteur" r)
+      (list Fg r Fd)))          ; representation interne infixee
+
+(define (connecteur mol)      ; on suppose que mol est une molecule
+  (if (= (length mol) 2)
+      (first mol)             ; non
+      (second mol)))          ; et, ou, =>
+
+(define (arg1 mol)            ; mol est une molecule
+  (if (= (length mol) 2)
+      (second mol)
+      (first mol)))
+
+(define (arg2 mol)            ; mol est une molecule
+  (if (= (length mol) 2)
+      (error "Molecule unaire" mol)
+      (third mol)))
+
+;(printf "Module valrose : (show expr), (assoc x AL), (sleep n), (current-milliseconds), (gensym symb),
+(printf "Module valrose : 
+(show expr), (match expr clauses ...),
+(arbre r Ag Ad), (racine A), (fg A), (fd A), (fdd A), (feuille? A), (operateur? obj), 
+(pile-vide? P), (pile-vide), (empiler x P), (sommet P), (depiler P), 
+(atome? F), (make-neg F), (make-fbf2 r Fg Fd), (connecteur mol), (arg1 mol), (arg2 mol)\n")