add examples from J-P Roy's textbook to check before a release
This commit is contained in:
parent
6006a4c84d
commit
d923ef135f
6
collects/tests/jpr/README.TXT
Normal file
6
collects/tests/jpr/README.TXT
Normal file
|
@ -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.
|
||||
|
48
collects/tests/jpr/balle-grav-frot.ss
Normal file
48
collects/tests/jpr/balle-grav-frot.ss
Normal file
|
@ -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)
|
BIN
collects/tests/jpr/ballon.png
Normal file
BIN
collects/tests/jpr/ballon.png
Normal file
Binary file not shown.
After Width: | Height: | Size: 4.1 KiB |
34
collects/tests/jpr/dessine-arbre.ss
Normal file
34
collects/tests/jpr/dessine-arbre.ss
Normal file
|
@ -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)))
|
||||
|
||||
|
18
collects/tests/jpr/foo.ss
Normal file
18
collects/tests/jpr/foo.ss
Normal file
|
@ -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")
|
40
collects/tests/jpr/jeu-du-chaos.ss
Normal file
40
collects/tests/jpr/jeu-du-chaos.ss
Normal file
|
@ -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)
|
||||
|
||||
|
||||
|
||||
|
||||
|
30
collects/tests/jpr/mon-script.ss
Executable file
30
collects/tests/jpr/mon-script.ss
Executable file
|
@ -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)))))
|
51
collects/tests/jpr/monte-carlo.ss
Normal file
51
collects/tests/jpr/monte-carlo.ss
Normal file
|
@ -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)
|
52
collects/tests/jpr/streams.ss
Normal file
52
collects/tests/jpr/streams.ss
Normal file
|
@ -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) ?
|
110
collects/tests/jpr/valrose.ss
Normal file
110
collects/tests/jpr/valrose.ss
Normal file
|
@ -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")
|
Loading…
Reference in New Issue
Block a user