diff --git a/collects/tests/jpr/README.TXT b/collects/tests/jpr/README.TXT new file mode 100644 index 0000000000..deadad3c6d --- /dev/null +++ b/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. + diff --git a/collects/tests/jpr/balle-grav-frot.ss b/collects/tests/jpr/balle-grav-frot.ss new file mode 100644 index 0000000000..058becac8b --- /dev/null +++ b/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) \ No newline at end of file diff --git a/collects/tests/jpr/ballon.png b/collects/tests/jpr/ballon.png new file mode 100644 index 0000000000..3f615e55ca Binary files /dev/null and b/collects/tests/jpr/ballon.png differ diff --git a/collects/tests/jpr/dessine-arbre.ss b/collects/tests/jpr/dessine-arbre.ss new file mode 100644 index 0000000000..d7ad76f446 --- /dev/null +++ b/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))) + + diff --git a/collects/tests/jpr/foo.ss b/collects/tests/jpr/foo.ss new file mode 100644 index 0000000000..ba773def0f --- /dev/null +++ b/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") diff --git a/collects/tests/jpr/jeu-du-chaos.ss b/collects/tests/jpr/jeu-du-chaos.ss new file mode 100644 index 0000000000..21ff5262d6 --- /dev/null +++ b/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) + + + + + diff --git a/collects/tests/jpr/mon-script.ss b/collects/tests/jpr/mon-script.ss new file mode 100755 index 0000000000..b485c8beaf --- /dev/null +++ b/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))))) diff --git a/collects/tests/jpr/monte-carlo.ss b/collects/tests/jpr/monte-carlo.ss new file mode 100644 index 0000000000..3a69e98bef --- /dev/null +++ b/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) diff --git a/collects/tests/jpr/streams.ss b/collects/tests/jpr/streams.ss new file mode 100644 index 0000000000..d9e46a72ca --- /dev/null +++ b/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) ? diff --git a/collects/tests/jpr/valrose.ss b/collects/tests/jpr/valrose.ss new file mode 100644 index 0000000000..76dfda623f --- /dev/null +++ b/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")