suzanne.soy/racket
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

relevant teachpacks converted

Browse Source 
svn: r9470
This commit is contained in:
Matthias Felleisen 2008-04-25 00:50:03 +00:00
parent 1bf7d81a50
commit fb644c1caf
39 changed files with 2569 additions and 2983 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

19
collects/htdp/Test/TEST
View File

@ -1,28 +1,19 @@
TEST: TEST:
---- ----
* draw.ss
* arrow.ss * arrow.ss
* arrow-gui.ss * arrow-gui.ss
* convert.ss * convert.ss
* dir.ss * dir.ss
* docs.ss * docs.ss
* draw.ss
* elevator.ss * elevator.ss
* graphing.ss * graphing.ss
* guess.ss * guess1.ss
* guess2.ss * guess2.ss
* guess3.ss * guess3.ss
* gui.ss * gui.ss
* lkup-gui.ss * lkup-gui.ss
* hangman.ss : changed, docs * hangman1.ss
* master.ss : changed, docs * master.ss
* pingp.ss * matrix.ss
* - pingp-test-play.ss : play with a ping-pong
* - pingp-test-trace.ss : test the two tracer interfaces
* protect.ss
* pingp-play.ss
* protect-play.ss
- both are tested with pingp-play-test.ss
rectangle.ss
Mon Oct 18 16:56:38 CDT 1999: re-organization into teachpacks

4
collects/htdp/Test/TODO
View File

@ -1,7 +1,3 @@
teachpack/htdp
collects/htdp
svn commit -m ""
----------------------------------------------------------------------------------- -----------------------------------------------------------------------------------
docs: docs:

29
collects/htdp/Test/arrow-gui.ss
View File

@ -1,27 +1,14 @@
;; TeachPack : arrow-gui.ss, gui.ss ;; 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.
(define msg (make-message (make-string 22 #\space))) #reader(lib "htdp-beginner-reader.ss" "lang")((modname arrow-gui) (read-case-sensitive #t) (teachpacks ()) (htdp-settings #(#t constructor repeating-decimal #f #t none #f ())))
(create-window (list (list msg))) (require (lib "arrow-gui.ss" "htdp"))
(require (lib "gui.ss" "htdp"))
#| Language: Intermediate with Lambda
;; make-model : sym -> (button% event% -> void)
(define (make-model2 dir)
(lambda (b e)
(local ([define _ (view dir)])
(draw-message msg (format "~a ~n" (control))))))
(connect
(make-model "left")
(make-model "right")
(make-model "up")
(make-model "down"))
|#
#| Language: Beginner |#
(define (left b e) (draw-message msg "left")) (define (left b e) (draw-message msg "left"))
(define (right b e) (draw-message msg "right")) (define (right b e) (draw-message msg "right"))
(define (up b e) (draw-message msg "up")) (define (up b e) (draw-message msg "up"))
(define (down b e) (draw-message msg "down")) (define (down b e) (draw-message msg "down"))
(connect left right up down) (define msg (make-message (make-string 22 #\space)))
(check-expect (window? (create-window (list (list msg)))) true)
(check-expect (connect left right up down) true)

14
collects/htdp/Test/arrow.ss
View File

@ -1,7 +1,8 @@
; (load "tester.ss") ;; 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.
;; TeachPack : arrow.ss, draw.ss #reader(lib "htdp-beginner-reader.ss" "lang")((modname arrow) (read-case-sensitive #t) (teachpacks ()) (htdp-settings #(#t constructor repeating-decimal #f #t none #f ())))
;; Language: Beginner (require (lib "arrow.ss" "htdp"))
(require (lib "draw.ss" "htdp"))
;; --------------------------------------------------------------------- ;; ---------------------------------------------------------------------
;; ;;
@ -35,10 +36,11 @@
;; TESTS: ;; TESTS:
;; this creates the canvas ;; this creates the canvas
(start 100 50) (check-expect (start 100 50) true)
(check-expect (draw-solid-string (make-posn 5 10) "click on arrow keys") true)
;; this creates the controller GUI ;; this creates the controller GUI
(control-left-right (make-posn 10 20) 10 move draw-it) (check-expect (control-left-right (make-posn 10 20) 10 move draw-it) true)
; (load "tester.ss") ; (load "tester.ss")

28
collects/htdp/Test/convert.ss
View File

@ -1,6 +1,7 @@
;; test errors by hand in GUI #lang scheme
(load "tester.ss")
(require htdp/convert) (require (lib "testing.ss" "htdp"))
(require (lib "convert.ss" "htdp"))
;; f2c : num -> num ;; f2c : num -> num
;; to convert a Fahrenheit temperature into a Celsius temperature ;; to convert a Fahrenheit temperature into a Celsius temperature
@ -34,30 +35,19 @@
(convert-file IN f2c OUT) (convert-file IN f2c OUT)
(with-input-from-file OUT check-convert-out) (with-input-from-file OUT check-convert-out)
(test-error (convert-file IN list OUT)) (check-error (convert-file IN list OUT) "convert: The conversion function must produce a number; result: (212)")
;; convert-file: procedure of one argument expected as "convert-gui" argument;
;; given procedure ...
(test-error (convert-file IN first OUT)) (check-error (convert-file IN first OUT) "first: expected argument of type <non-empty list>; given 212")
;; first: expects argument of type <non-empty list>; given 212
(test-error (convert-file IN fx OUT)) (check-error (convert-file IN fx OUT) "convert: The conversion function must produce a number; result: xyz")
;; convert: The conversion function must produce a number; result: 'xyz
(test-error (convert-file IN f2c 10)) (check-error (convert-file IN f2c 10) "convert-file: expected <string> as third argument, given: 10")
;; convert-file: expected <string> as third argument, given: 10
;; ---------------------------------------------------------------------------- ;; ----------------------------------------------------------------------------
;; convert by repl: ;; convert by repl:
(convert-repl f2c) (convert-repl f2c)
;; type in 0 212 40 into the repl ;; type in 0 212 40 into the repl
(test-error (convert-repl first))
;; hilight first
(test-error (convert-repl fx))
;; signal an error about not returning a number
;; ---------------------------------------------------------------------------- ;; ----------------------------------------------------------------------------
;; convert by GUI ;; convert by GUI
@ -72,3 +62,5 @@
;; TEST BY HAND: (convert-gui fx) ;; TEST BY HAND: (convert-gui fx)
;; signal an error about not returning a number ;; signal an error about not returning a number
(generate-report)

8
collects/htdp/Test/dir.ss
View File

@ -1,8 +1,7 @@
;; The first three lines of this file were inserted by DrScheme. They record metadata ;; 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. ;; about the language level of this file in a form that our tools can easily process.
#reader(lib "htdp-intermediate-lambda-reader.ss" "lang")((modname dir) (read-case-sensitive #t) (teachpacks ((lib "dir.ss" "teachpack" "htdp"))) (htdp-settings #(#t constructor repeating-decimal #f #t none #f ((lib "dir.ss" "teachpack" "htdp"))))) #reader(lib "htdp-intermediate-lambda-reader.ss" "lang")((modname dir) (read-case-sensitive #t) (teachpacks ()) (htdp-settings #(#t constructor repeating-decimal #f #t none #f ())))
;; TeachPack: dir.ss (require (lib "dir.ss" "htdp"))
;; Language: Intermediate with Lambda
(define current (create-dir ".")) (define current (create-dir "."))
(define teachps (create-dir (string-append "/Users/matthias/plt/" "collects/teachpack/htdp"))) (define teachps (create-dir (string-append "/Users/matthias/plt/" "collects/teachpack/htdp")))
@ -16,8 +15,5 @@
(map (lambda (x) (format "in Test, not in Teachpacks: ~s" x)) (map (lambda (x) (format "in Test, not in Teachpacks: ~s" x))
(filter (lambda (x) (not (member x teachps-files))) current-files))) (filter (lambda (x) (not (member x teachps-files))) current-files)))
(require htdp/testing)
(check-expect (make-file 'a 1 2) (make-file 'a 1 2)) (check-expect (make-file 'a 1 2) (make-file 'a 1 2))
(generate-report)

16
collects/htdp/Test/docs.ss
View File

@ -1,12 +1,16 @@
;; TeachPack: docs.ss ;; The first three lines of this file were inserted by DrScheme. They record metadata
;; Language: Beginner ;; about the language level of this file in a form that our tools can easily process.
#reader(lib "htdp-beginner-reader.ss" "lang")((modname docs) (read-case-sensitive #t) (teachpacks ()) (htdp-settings #(#t constructor repeating-decimal #f #t none #f ())))
(require (lib "docs.ss" "htdp"))
(annotation? '<html>) (check-expect (annotation? '<html>) true)
(not (annotation? 'html)) (check-expect (annotation? 'html) false)
(annotation? '<p>) (check-expect (annotation? '<p>) true)
(eq? '</html> (end-annotation '<html>)) (check-expect (end-annotation '<html>) '</html>)
(check-expect
(write-file (write-file
(list '<p> 'hello 'world 'is 'the 'most 'stupid 'program 'in 'the 'world '</p> (list '<p> 'hello 'world 'is 'the 'most 'stupid 'program 'in 'the 'world '</p>
"so let's test this" 'with "How's that")) "so let's test this" 'with "How's that"))
true)

92
collects/htdp/Test/draw.ss
View File

@ -1,6 +1,6 @@
;; The first three lines of this file were inserted by DrScheme. They record metadata ;; 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. ;; about the language level of this file in a form that our tools can easily process.
#reader(lib "htdp-intermediate-lambda-reader.ss" "lang")((modname draw) (read-case-sensitive #t) (teachpacks ((lib "draw.ss" "teachpack" "htdp"))) (htdp-settings #8(#t constructor repeating-decimal #f #t none #f ((lib "draw.ss" "teachpack" "htdp"))))) #reader(lib "htdp-intermediate-lambda-reader.ss" "lang")((modname draw) (read-case-sensitive #t) (teachpacks ((lib "draw.ss" "teachpack" "htdp"))) (htdp-settings #(#t constructor repeating-decimal #f #t none #f ((lib "draw.ss" "teachpack" "htdp")))))
;; This tests a good portion but needs some more ;; This tests a good portion but needs some more
;; This needs some tests for error behavior of functions ... ;; This needs some tests for error behavior of functions ...
@ -10,74 +10,44 @@
(define (draw-next-part body-part) (define (draw-next-part body-part)
(cond (cond
[(eq? body-part 'body) [(eq? body-part 'body)
(draw-solid-line (make-posn 100 60) (draw-solid-line (make-posn 100 60) (make-posn 100 130) 'black)]
(make-posn 100 130)
'black)]
[(eq? body-part 'right-leg) [(eq? body-part 'right-leg)
(draw-solid-line (make-posn 100 130) (draw-solid-line (make-posn 100 130) (make-posn 30 170) 'black)]
(make-posn 30 170)
'black)]
[(eq? body-part 'left-leg) [(eq? body-part 'left-leg)
(draw-solid-line (make-posn 100 130) (draw-solid-line (make-posn 100 130) (make-posn 170 170) 'black)]
(make-posn 170 170)
'black)]
[(eq? body-part 'right-arm) [(eq? body-part 'right-arm)
(draw-solid-line (make-posn 100 75) (draw-solid-line (make-posn 100 75) (make-posn 40 65) 'black)]
(make-posn 40 65)
'black)]
[(eq? body-part 'left-arm) [(eq? body-part 'left-arm)
(draw-solid-line (make-posn 100 75) (draw-solid-line (make-posn 100 75) (make-posn 160 65) 'black)]
(make-posn 160 65)
'black)]
[(eq? body-part 'head) [(eq? body-part 'head)
(draw-solid-disk (make-posn 100 50) 10 'black)] (draw-solid-disk (make-posn 100 50) 10 'black)]
[(eq? body-part 'noose) [(eq? body-part 'noose)
(and (and
(draw-solid-disk (make-posn 120 50) 30 'red) (draw-solid-disk (make-posn 120 50) 30 'red)
(draw-solid-line (make-posn 100 30) (draw-solid-line (make-posn 100 30) (make-posn 100 10) 'black)
(make-posn 100 10) (draw-solid-line (make-posn 100 10) (make-posn 0 10) 'black)
'black) (draw-solid-line (make-posn 115 35) (make-posn 123 43) 'black)
(draw-solid-line (make-posn 100 10) (draw-solid-line (make-posn 123 35) (make-posn 115 43) 'black)
(make-posn 0 10) (draw-solid-line (make-posn 131 40) (make-posn 139 48) 'black)
'black) (draw-solid-line (make-posn 139 40) (make-posn 131 48) 'black))]))
(draw-solid-line (make-posn 115 35)
(make-posn 123 43)
'black)
(draw-solid-line (make-posn 123 35)
(make-posn 115 43)
'black)
(draw-solid-line (make-posn 131 40)
(make-posn 139 48)
'black)
(draw-solid-line (make-posn 139 40)
(make-posn 131 48)
'black))]))
#| Tests ---------------------------------------------------------- ;; ----- Tests -----------------------------------------------------------------
|#
(check-expect (start 200 400) true)
(start 200 400) (check-expect (sleep-for-a-while 1) true)
(sleep-for-a-while 1) (check-expect (draw-next-part 'noose) true)
(draw-next-part 'noose) (check-expect (sleep-for-a-while 1) true)
(sleep-for-a-while 1) (check-expect (draw-next-part 'head) true)
(draw-next-part 'head) (check-expect (sleep-for-a-while 1) true)
(sleep-for-a-while 1) (check-expect (draw-next-part 'left-arm) true)
(draw-next-part 'left-arm) (check-expect (sleep-for-a-while 1) true)
(sleep-for-a-while 1) (check-expect (draw-next-part 'right-arm) true)
(draw-next-part 'right-arm) (check-expect (sleep-for-a-while 1) true)
(sleep-for-a-while 1) (check-expect (draw-next-part 'body) true)
(draw-next-part 'body) (check-expect (sleep-for-a-while 1) true)
(sleep-for-a-while 1) (check-expect (draw-next-part 'left-leg) true)
(draw-next-part 'left-leg) (check-expect (sleep-for-a-while 1) true)
(sleep-for-a-while 1) (check-expect (draw-next-part 'right-leg) true)
(draw-next-part 'right-leg) (check-expect (draw-solid-string (make-posn 10 200) "please click on the canvas") true)
"please click on the canvas" (check-expect (posn? (wait-for-mouse-click)) true)
(posn? (wait-for-mouse-click)) (check-expect (stop) true)
(stop)
#|
(load "tester.ss")
(start 200 400)
(test-error (draw-solid-line 'a 'b 'c))
|#

6
collects/htdp/Test/elevator.ss
View File

@ -1,5 +1,7 @@
;; TeachPack: elevator.ss ;; The first three lines of this file were inserted by DrScheme. They record metadata
;; Language: Beginner ;; about the language level of this file in a form that our tools can easily process.
#reader(lib "htdp-beginner-reader.ss" "lang")((modname elevator) (read-case-sensitive #t) (teachpacks ()) (htdp-settings #(#t constructor repeating-decimal #f #t none #f ())))
(require (lib "elevator.ss" "htdp"))
;; next3 : (union 'up 'down) N X -> N ;; next3 : (union 'up 'down) N X -> N
;; always sends elevator to next floor up or down, ;; always sends elevator to next floor up or down,

16
collects/htdp/Test/graphing.ss
View File

@ -1,16 +1,16 @@
;; TeachPack: graphing.ss ;; The first three lines of this file were inserted by DrScheme. They record metadata
;; Language: Beginner ;; about the language level of this file in a form that our tools can easily process.
#reader(lib "htdp-beginner-reader.ss" "lang")((modname graphing) (read-case-sensitive #t) (teachpacks ()) (htdp-settings #(#t constructor repeating-decimal #f #t none #f ())))
;; ------------------------------------------------------------------------ (require (lib "graphing.ss" "htdp"))
(define (fun1 x) (+ (* x x) 1)) (define (fun1 x) (+ (* x x) 1))
(graph-fun fun1 'red) (check-expect (graph-fun fun1 'red) true)
(define (fun2 x) (+ (* -1 x x) 1)) (define (fun2 x) (+ (* -1 x x) 1))
(graph-fun fun2 'blue) (check-expect (graph-fun fun2 'blue) true)
(define (line1 x) (+ (* +1 x) 10)) (define (line1 x) (+ (* +1 x) 10))
(graph-line line1 'black) (check-expect (graph-line line1 'black) true)
(define (line2 x) (+ (* -1 x) 10)) (define (line2 x) (+ (* -1 x) 10))
(graph-line line2 'green) (check-expect (graph-line line2 'green) true)

9
collects/htdp/Test/guess1.ss
View File

@ -1,6 +1,7 @@
;; ------------------------------------------------------------------------ ;; The first three lines of this file were inserted by DrScheme. They record metadata
;; language: beginner ;; about the language level of this file in a form that our tools can easily process.
;; teachpack: guess.ss #reader(lib "htdp-beginner-reader.ss" "lang")((modname guess1) (read-case-sensitive #t) (teachpacks ()) (htdp-settings #(#t constructor repeating-decimal #f #t none #f ())))
(require (lib "guess.ss" "htdp"))
;; check-guess : number number -> symbol ;; check-guess : number number -> symbol
;; to determine how guess and target relate to each other ;; to determine how guess and target relate to each other
@ -16,7 +17,7 @@
(eq? (check-guess 5631 5631) 'Perfect) (eq? (check-guess 5631 5631) 'Perfect)
;; Test with GUI lib: set lib to guess-lib.ss ;; Test with GUI lib: set lib to guess-lib.ss
(guess-with-gui check-guess) (check-expect (guess-with-gui check-guess) true)
; (guess-with-gui list) ; (guess-with-gui list)
; (define (foo x) x) (guess-with-gui foo) ; (define (foo x) x) (guess-with-gui foo)

12
collects/htdp/Test/guess2.ss
View File

@ -1,9 +1,7 @@
; (load "tester.ss") ;; The first three lines of this file were inserted by DrScheme. They record metadata
;; by hand, bottom ;; about the language level of this file in a form that our tools can easily process.
#reader(lib "htdp-beginner-reader.ss" "lang")((modname guess2) (read-case-sensitive #t) (teachpacks ()) (htdp-settings #(#t constructor repeating-decimal #f #t none #f ())))
;; ------------------------------------------------------------------------ (require (lib "guess.ss" "htdp"))
;; testing repl3
;; teachpack: guess.ss
;; check-guess3 : digit digit digit number -> symbol ;; check-guess3 : digit digit digit number -> symbol
;; to determine how three guess digits and target relate to each other ;; to determine how three guess digits and target relate to each other
@ -33,7 +31,7 @@
(eq? (check-guess3 1 3 6 631) 'Perfect) (eq? (check-guess3 1 3 6 631) 'Perfect)
;; Test with GUI: set lib to guess-lib.ss ;; Test with GUI: set lib to guess-lib.ss
(guess-with-gui-3 check-guess3) (check-expect (guess-with-gui-3 check-guess3) true)
; (define (foo x) x) (guess-with-gui-3 foo) ; (define (foo x) x) (guess-with-gui-3 foo)
; (guess-with-gui-3 'a) ; (guess-with-gui-3 'a)

12
collects/htdp/Test/guess3.ss
View File

@ -1,9 +1,7 @@
; (load "tester.ss") ;; The first three lines of this file were inserted by DrScheme. They record metadata
;; by hand, bottom ;; about the language level of this file in a form that our tools can easily process.
#reader(lib "htdp-beginner-reader.ss" "lang")((modname guess3) (read-case-sensitive #t) (teachpacks ()) (htdp-settings #(#t constructor repeating-decimal #f #t none #f ())))
;; ------------------------------------------------------------------------ (require (lib "guess.ss" "htdp"))
;; testing repl-list
;; teachpack: guess.ss
;; check-guess-for-list : (listof DIGIT) number -> symbol ;; check-guess-for-list : (listof DIGIT) number -> symbol
;; to determine how guess digits and target relate to each other ;; to determine how guess digits and target relate to each other
@ -37,5 +35,5 @@
(eq? (check-guess-for-list (cons 1 (cons 3 (cons 6 empty))) 631) 'Perfect) (eq? (check-guess-for-list (cons 1 (cons 3 (cons 6 empty))) 631) 'Perfect)
;; Test with GUI: set lib to guess-lib.ss ;; Test with GUI: set lib to guess-lib.ss
(guess-with-gui-list 2 check-guess-for-list) (check-expect (guess-with-gui-list 2 check-guess-for-list) true)

9
collects/htdp/Test/gui.ss
View File

@ -1,5 +1,7 @@
;; TeachPack: gui.ss ;; The first three lines of this file were inserted by DrScheme. They record metadata
;; Language Level: Advanced ;; about the language level of this file in a form that our tools can easily process.
#reader(lib "htdp-advanced-reader.ss" "lang")((modname gui) (read-case-sensitive #t) (teachpacks ()) (htdp-settings #(#t constructor repeating-decimal #t #t none #f ())))
(require (lib "gui.ss" "htdp"))
;; type in text, choose, click okay, watch message field change, close ;; type in text, choose, click okay, watch message field change, close
@ -17,8 +19,9 @@
(define (destroy x) (hide-window x)) (define (destroy x) (hide-window x))
(define w
(create-window (create-window
(list (list txt msg chc) (list (list txt msg chc)
(list (make-button "Okay?" call-back)) (list (make-button "Okay?" call-back))
(list (make-button "Close" hide-window)))) (list (make-button "Close" (lambda (x) (hide-window w)))))))

20
collects/htdp/Test/hangman1.ss
View File

@ -1,4 +1,7 @@
;; Language: Advanced ;; 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-beginner-reader.ss" "lang")((modname hangman1) (read-case-sensitive #t) (teachpacks ()) (htdp-settings #(#t constructor repeating-decimal #f #t none #f ())))
(require (lib "hangman.ss" "htdp"))
; (load "tester.ss") ; (load "tester.ss")
;; by hand, Beginner for plain, Full for errors ;; by hand, Beginner for plain, Full for errors
@ -44,7 +47,14 @@
(make-word '_ '_ '_)) (make-word '_ '_ '_))
;; check errors ;; check errors
; (hangman make-word) (check-error (hangman make-word) "hangman: primitive operator requires 3 arguments")
; (hangman (make-word 'a 'b 'c) reveal draw-next-part)
; (hangman make-word (reveal (make-word 'd 'e 'r) (make-word '_ '_ '_) 'd) draw-next-part) (check-error (hangman (make-word 'a 'b 'c) reveal draw-next-part)
; (hangman make-word reveal 100) "hangman: primitive operator hangman expects a defined procedure name (usually `make-word') in this position")
(check-error (hangman make-word (reveal (make-word 'd 'e 'r) (make-word '_ '_ '_) 'd) draw-next-part)
"hangman: primitive operator hangman expects a defined procedure name (usually `reveal') in this position")
(check-error (hangman make-word reveal 100)
"hangman: primitive operator hangman expects a defined procedure name (usually `draw-next') in this position")

50
collects/htdp/Test/hangman2.ss
View File

@ -1,50 +0,0 @@
(load "tester.ss")
#| ------------------------------------------------------------------------
draw-next-part :
{ 'noose 'head 'right-arm 'left-arm 'body 'right-leg 'left-leg } -> #t
result: #t if things went okay
effect: to draw the specified body part in a canvas of size W x H
credit: John Clements
|#
(define (draw-next-part body-part)
(cond ((eq? body-part 'body)
(draw-solid-line (make-posn 100 60) (make-posn 100 130) BLACK))
((eq? body-part 'right-leg)
(draw-solid-line (make-posn 100 130) (make-posn 30 170) BLACK))
((eq? body-part 'left-leg)
(draw-solid-line (make-posn 100 130) (make-posn 170 170) BLACK))
((eq? body-part 'right-arm)
(draw-solid-line (make-posn 100 75) (make-posn 40 65) BLACK))
((eq? body-part 'left-arm)
(draw-solid-line (make-posn 100 75) (make-posn 160 65) BLACK))
((eq? body-part 'head)
(draw-circle (make-posn 100 50) 10 BLACK))
((eq? body-part 'noose)
(and
(draw-solid-line (make-posn 100 30) (make-posn 100 10) BLACK)
(draw-solid-line (make-posn 100 10) (make-posn 0 10) BLACK)
(draw-solid-line (make-posn 115 35) (make-posn 123 43) BLACK)
(draw-solid-line (make-posn 123 35) (make-posn 115 43) BLACK)
(draw-solid-line (make-posn 131 40) (make-posn 139 48) BLACK)
(draw-solid-line (make-posn 139 40) (make-posn 131 48) BLACK)
(draw-circle (make-posn 120 50) 30 RED)))))
;; reveal-list : list-of-letters list-of-letters letter -> list-of-letters
(define (reveal-list word1 word2 letter)
(cond
((empty? word1) empty)
(else (cons (reveal1 (first word1) (first word2) letter)
(reveal-list (rest word1) (rest word2) letter)))))
;; TESTS:
;(start 200 400)
;(hangman-list reveal-list draw-next-part)
;
; (hangman-list reveal-list)
; (hangman-list reveal-list 1)
; (hangman-list 1 reveal-list)
; (hangman-list cons first)

9
collects/htdp/Test/lkup-gui.ss
View File

@ -1,6 +1,9 @@
;; TeachPack: lkup-gui.ss ;; The first three lines of this file were inserted by DrScheme. They record metadata
;; Language: Advanced ;; about the language level of this file in a form that our tools can easily process.
#reader(lib "htdp-advanced-reader.ss" "lang")((modname lkup-gui) (read-case-sensitive #t) (teachpacks ()) (htdp-settings #(#t constructor repeating-decimal #t #t none #f ())))
(require (lib "lkup-gui.ss" "htdp"))
(connect (check-expect (connect
(lambda (e b) (lambda (e b)
(view (control)))) (view (control))))
true)

11
collects/htdp/Test/master.ss
View File

@ -1,3 +1,8 @@
;; 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-beginner-reader.ss" "lang")((modname master) (read-case-sensitive #t) (teachpacks ()) (htdp-settings #(#t constructor repeating-decimal #f #t none #f ())))
(require (lib "master.ss" "htdp"))
; (load "tester.ss") ; (load "tester.ss")
;; check-guess : color color color color -> symbol ;; check-guess : color color color color -> symbol
@ -18,6 +23,6 @@
(eq? (check-guess 'white 'blue 'blue 'red) 'the_colors_occur) (eq? (check-guess 'white 'blue 'blue 'red) 'the_colors_occur)
(eq? (check-guess 'white 'blue 'red 'green) 'nothing_correct) (eq? (check-guess 'white 'blue 'red 'green) 'nothing_correct)
(master check-guess) (check-expect (master check-guess) true)
; (master 1) ; (check-error (master 1) "master: primitive operator master expects a defined procedure name (usually `compare-guess') in this position")
; (master first) ; (check-error (master first) ...)

13
collects/htdp/Test/matrix-test.ss
View File

@ -1,9 +1,8 @@
;; The first three lines of this file were inserted by DrScheme. They record metadata ;; 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. ;; about the language level of this file in a form that our tools can easily process.
#reader(lib "htdp-intermediate-lambda-reader.ss" "lang")((modname matrix-test) (read-case-sensitive #t) (teachpacks ()) (htdp-settings #(#t constructor repeating-decimal #f #t none #f ()))) #reader(lib "htdp-intermediate-lambda-reader.ss" "lang")((modname matrix-test) (read-case-sensitive #t) (teachpacks ()) (htdp-settings #(#t constructor repeating-decimal #f #t none #f ())))
; (require htdp/matrix-invisible) (require (lib "matrix-invisible.ss" "htdp"))
(require htdp/matrix) ;(require (lib "matrix.ss" "htdp"))
(require htdp/testing)
(define r1 '((a00 a01 a02) (define r1 '((a00 a01 a02)
(a10 a11 a12))) (a10 a11 a12)))
@ -37,6 +36,7 @@
(check-expect 1 (matrix-ref m2 (random 2) (random 3))) (check-expect 1 (matrix-ref m2 (random 2) (random 3)))
(define (is1 x) (= x 1)) (define (is1 x) (= x 1))
(check-expect (matrix-where? m2 is1) (check-expect (matrix-where? m2 is1)
(list (make-posn 0 0) (make-posn 0 1) (make-posn 0 2) (list (make-posn 0 0) (make-posn 0 1) (make-posn 0 2)
@ -52,8 +52,5 @@
;; --- IMPERATIVE --- ;; --- IMPERATIVE ---
(check-expect (matrix-ref m1 0 0) 'a00) (check-expect (matrix-ref m1 0 0) 'a00)
(define m1-modified (matrix-set! m1 0 0 'xxx)) (define m1-modified (matrix-set! m1 0 0 'xxx)) ;; <-------- uncomment this and the test engine breaks
(check-expect (matrix-ref m1 0 0) 'xxx) ; (check-expect (matrix-ref m1 0 0) 'xxx)
(generate-report)

6
collects/htdp/Test/pingp-play.ss
View File

@ -1,6 +0,0 @@
;; TeachPack:
;; 1. pingp-play.ss
;; 2. protect-play.ss
;; Language: Beginner
(go 'Matthias)

101
collects/htdp/Test/pingp-trace.ss
View File

@ -1,101 +0,0 @@
;; TeachPack: pingp.ss
;; Language: Advanced
;; This file tests the trace functions. It is not used anywhere else.
;; Speed and its relationship to positions
;; ---------------------------------------
(define-struct speed (x y))
;; posn+ : posn vec -> vec
(define (posn+ p v)
(make-posn (+ (posn-x p) (speed-x v)) (+ (posn-y p) (speed-y v))))
;; posn*s : number vec -> posn
(define (posn*s f p)
(make-speed (* f (speed-x p)) (* f (speed-y p))))
;; vec* : vec vec -> vec
(define (vec* v1 v2)
(make-speed (* (speed-x v1) (speed-x v2)) (* (speed-y v1) (speed-y v2))))
;; The ball representation and some basic primitives:
;; ---------------------------------------------------
(define-struct ball (posn speed))
;; make-direction : (speed -> num) X Y -> (ball -> (union X Y))
(define (make-direction access dir1 dir2)
(lambda (ball)
(cond
((< (access (ball-speed ball)) 0) dir1)
((> (access (ball-speed ball)) 0) dir2)
(else (error 'make-direction "can't happen")))))
;; ns-direction : ball -> {'NORTH, 'SOUTH}
(define ns-direction (make-direction speed-y 'NORTH 'SOUTH))
;; ew-direction : ball -> {'EAST, 'WEST}
(define ew-direction (make-direction speed-x 'WEST 'EAST))
;; make-distance : (posn -> num) (ball -> sym) sym num num -> (ball -> num)
(define (make-distance direction access dir bound1 bound2)
(lambda (ball)
(if (eq? (direction ball) dir)
(- (access (ball-posn ball)) bound1)
(- bound2 (access (ball-posn ball))))))
;; make-time : (ball -> num) (speed -> num) -> (ball -> number)
(define (make-time distance access)
(lambda (ball)
(/ (distance ball) (abs (access (ball-speed ball))))))
;; ns-time-to-wall : ball -> number (time before ns wall is hit)
(define ns-time-to-wall
(make-time (make-distance ns-direction posn-y 'NORTH NORTH SOUTH) speed-y))
;; ew-time-to-wall : ball -> number (time before ew wall is hit)
(define ew-time-to-wall
(make-time (make-distance ew-direction posn-x 'WEST WEST EAST) speed-x))
;; Moving a Ball
;; -------------
;; move-in-box : ball number -> ball
(define (move-in-box ball t)
(case (bounces-from ball t)
((NORTH SOUTH) (bouncing-move ns-bounce (ns-time-to-wall ball) t ball))
((EAST WEST) (bouncing-move ew-bounce (ew-time-to-wall ball) t ball))
(else (move-ball ball t))))
;; bouncing-move : (ball -> ball) num num ball -> ball
(define (bouncing-move bounce t-bounce t ball)
(move-in-box (bounce (move-ball ball t-bounce)) (- t t-bounce)))
;; bounces-from : ball number -> {'NORTH, 'SOUTH, 'EAST, 'WEST, 'none}
(define (bounces-from ball t)
(cond
((<= (ns-time-to-wall ball) (min (ew-time-to-wall ball) t)) (ns-direction ball))
((<= (ew-time-to-wall ball) (min t (ns-time-to-wall ball))) (ew-direction ball))
(else 'none)))
;; move : ball number -> ball
(define (move-ball ball t)
(make-ball (posn+ (ball-posn ball) (posn*s t (ball-speed ball))) (ball-speed ball)))
;; make-bounce : speed -> (ball -> ball)
(define (make-bounce bounceV)
(lambda (ball)
(make-ball (ball-posn ball) (vec* (ball-speed ball) bounceV))))
;; ns-bounce : ball -> ball
(define ns-bounce (make-bounce (make-speed 1 -1)))
;; ew-bounce-west : ball -> ball
(define ew-bounce (make-bounce (make-speed -1 1)))
;; mover : posn speed number -> posn
(define (mover p s t)
(posn+ p (posn*s t s)))
(trace-ball (make-ball (make-posn 100 100) (make-speed 8 -2)) ball-posn move-in-box 222)
(trace (make-posn 100 100) (make-speed 8 -2) mover 222)

103
collects/htdp/Test/pingp.ss
View File

@ -1,103 +0,0 @@
; (require-library "core.ss")
;; TeachPack: pingp.ss
;; Language: Full
;; ---------------------------------------------------------------------------
;; To test: uncomment the last line.
;; The file tests the function play from pingp.ss.
;; The file is used to build protect-text.ss.
;; Speed and its relationship to positions
;; ---------------------------------------
(define-struct speed (x y))
;; posn+ : posn vec -> vec
(define (posn+ p v)
(make-posn (+ (posn-x p) (speed-x v)) (+ (posn-y p) (speed-y v))))
;; posn*s : number vec -> posn
(define (posn*s f p)
(make-speed (* f (speed-x p)) (* f (speed-y p))))
;; vec* : vec vec -> vec
(define (vec* v1 v2)
(make-speed (* (speed-x v1) (speed-x v2)) (* (speed-y v1) (speed-y v2))))
;; The ball representation and some basic primitives:
;; ---------------------------------------------------
(define-struct ball (posn speed))
;; make-direction : (speed -> num) X Y -> (ball -> (union X Y))
(define (make-direction access dir1 dir2)
(lambda (ball)
(cond
((< (access (ball-speed ball)) 0) dir1)
((> (access (ball-speed ball)) 0) dir2)
(else (error 'make-direction "can't happen")))))
;; ns-direction : ball -> {'NORTH, 'SOUTH}
(define ns-direction (make-direction speed-y 'NORTH 'SOUTH))
;; ew-direction : ball -> {'EAST, 'WEST}
(define ew-direction (make-direction speed-x 'WEST 'EAST))
;; make-distance : (posn -> num) (ball -> sym) sym num num -> (ball -> num)
(define (make-distance direction access dir bound1 bound2)
(lambda (ball)
(if (eq? (direction ball) dir)
(- (access (ball-posn ball)) bound1)
(- bound2 (access (ball-posn ball))))))
;; make-time : (ball -> num) (speed -> num) -> (ball -> number)
(define (make-time distance access)
(lambda (ball)
(/ (distance ball) (abs (access (ball-speed ball))))))
;; ns-time-to-wall : ball -> number (time before ns wall is hit)
(define ns-time-to-wall
(make-time (make-distance ns-direction posn-y 'NORTH NORTH SOUTH) speed-y))
;; ew-time-to-wall : ball -> number (time before ew wall is hit)
(define ew-time-to-wall
(make-time (make-distance ew-direction posn-x 'WEST WEST EAST) speed-x))
;; Moving a Ball
;; -------------
;; move-in-box : ball number -> ball
(define (move-in-box ball t)
(case (bounces-from ball t)
((NORTH SOUTH) (bouncing-move ns-bounce (ns-time-to-wall ball) t ball))
((EAST WEST) (bouncing-move ew-bounce (ew-time-to-wall ball) t ball))
(else (move-ball ball t))))
;; bouncing-move : (ball -> ball) num num ball -> ball
(define (bouncing-move bounce t-bounce t ball)
(move-in-box (bounce (move-ball ball t-bounce)) (- t t-bounce)))
;; bounces-from : ball number -> {'NORTH, 'SOUTH, 'EAST, 'WEST, 'none}
(define (bounces-from ball t)
(cond
((<= (ns-time-to-wall ball) (min t (ew-time-to-wall ball))) (ns-direction ball))
((<= (ew-time-to-wall ball) (min t (ns-time-to-wall ball)))
(cond
((landed-on-paddle? (ball-posn (move-ball ball (ew-time-to-wall ball))))
(ew-direction ball))
(else 'none)))
(else 'none)))
;; move : ball number -> ball
(define (move-ball ball t)
(make-ball (posn+ (ball-posn ball) (posn*s t (ball-speed ball))) (ball-speed ball)))
;; make-bounce : speed -> (ball -> ball)
(define (make-bounce bounceV)
(lambda (ball)
(make-ball (ball-posn ball) (vec* (ball-speed ball) bounceV))))
;; ns-bounce : ball -> ball
(define ns-bounce (make-bounce (make-speed 1 -1)))
;; ew-bounce-west : ball -> ball
(define ew-bounce (make-bounce (make-speed -1 1)))
(play make-ball make-speed ball-posn move-in-box)

113
collects/htdp/Test/protect.ss
View File

@ -1,113 +0,0 @@
(load "pingp.ss")
;; ---------------------------------------------------------------------------
;; TeachPack: pingp.ss
;; Language: Advanced
;; To test: uncomment the block at the bottom.
;; The file tests the function protect from pingp.ss.
;; The file is used to build protect-play.ss.
(define (test-go x) (void))
(define (test-go x)
(protect (mk-balls 10)
; (list (make-ball (make-posn 100 100) (make-speed 8 -16)))
move-balls
remove-balls-hit-paddle
remove-outside-balls
balls-posn))
;; Adapting the relevant functions from the pingp game
;; ---------------------------------------------------
;; move-in-box : ball number -> ball or #f (if the ball gets destroyed)
(define (move-in-box ball t)
(case (bounces-off ball t)
((NORTH-SOUTH)
(move-in-box
(ns-bounce
(move-ball ball (ns-time-to-wall ball)))
(- t (ns-time-to-wall ball))))
((PADDLE) #f)
(else (move-ball ball t))))
;; bounces-off : ball number -> {'NORTH-SOUTH,'PADDLE,'none}
(define (bounces-off ball t)
(cond
((<= (ns-time-to-wall ball) (min (ew-time-to-wall ball) t)) 'NORTH-SOUTH)
((<= (ew-time-to-wall ball) (min (ns-time-to-wall ball) t))
(cond
[(landed-on-paddle? (ball-posn (move-ball ball (ew-time-to-wall ball))))
'PADDLE]
[else 'none]))
(else 'none)))
;; Dealing with collections of balls
;; ---------------------------------
;; mk-balls : natnum -> list-of-balls
(define (mk-balls a-nn)
(cond
((zero? a-nn) null)
(else
(cons
(make-ball (make-posn (random-between FAR_WEST EAST) (random SOUTH))
(make-speed (random-between MIN-X-SPEED MAX-X-SPEED)
(random-between MIN-Y-SPEED MAX-Y-SPEED)))
(mk-balls (- a-nn 1))))))
;; random-between : int int -> int (randomly in betweeen he two inputs)
(define (random-between low high)
(+ low (random (+ (abs low) (abs high)))))
;; move-balls : list-of-balls -> list-of-balls
(define (move-balls loballs)
(cond
((null? loballs) null)
(else (cons (move-in-box (first loballs) 1) (move-balls (rest loballs))))))
;; remove-balls-hit-paddle : list-of-balls/#f -> list-of-balls
;; (those that hit paddle during a move or are outside after a move)
(define (remove-balls-hit-paddle loballs)
(cond
((null? loballs) null)
(else (cond
((boolean? (first loballs))
(remove-balls-hit-paddle (rest loballs)))
(else
(cons (first loballs) (remove-balls-hit-paddle (rest loballs))))))))
;; remove-outside-balls : list-of-balls -> list-of-balls
;; (those that hit paddle during a move or are outside after a move)
(define (remove-outside-balls loballs)
(cond
((null? loballs) null)
(else (cond
((inside? (first loballs))
(cons (first loballs) (remove-outside-balls (rest loballs))))
(else
(remove-outside-balls (rest loballs)))))))
;; inside? : ball -> boolean (is the ball inside the user-defined space)
(define (inside? aball)
(and (<= FAR_WEST (posn-x (ball-posn aball)) EAST)
(<= NORTH (posn-y (ball-posn aball)) SOUTH)))
;; balls-posn : list-of-balls -> list-of-posn (a projection)
(define (balls-posn l)
(cond
((null? l) null)
(else (cons (ball-posn (first l)) (balls-posn (rest l))))))
;; the true extent of the space
(define FAR_WEST (* -1 EAST))
(define MIN-X-SPEED 05)
(define MAX-X-SPEED 15)
(define MIN-Y-SPEED 1)
(define MAX-Y-SPEED 4)
(test-go 'x)

4
collects/htdp/Test/tester.ss
View File

@ -1,3 +1,7 @@
#lang scheme
(provide test-error)
(define-syntax test-error (define-syntax test-error
(lambda (stx) (lambda (stx)
(syntax-case stx () (syntax-case stx ()

9
collects/htdp/arrow-gui.ss
View File

@ -1,11 +1,10 @@
#cs(module arrow-gui mzscheme #lang scheme/gui
(require htdp/error (require htdp/error
htdp/big-draw htdp/big-draw
lang/prim
mzlib/etc mzlib/etc
mzlib/class mzlib/class)
mred
(lib "prim.ss" "lang"))
(provide (provide
control ; modelT modelT modelT modelT -> true control ; modelT modelT modelT modelT -> true
@ -83,4 +82,4 @@
(,#f ,DOWN-ARROW ,#f) )) (,#f ,DOWN-ARROW ,#f) ))
(define layout (make-button-table frame FOUR))) (define layout (make-button-table frame FOUR)))
(send frame show true) (send frame show true)
true))) true))

9
collects/htdp/arrow.ss
View File

@ -1,11 +1,10 @@
#cs(module arrow mzscheme #lang scheme/gui
(require htdp/error (require htdp/error
htdp/big-draw htdp/big-draw
lang/prim
mzlib/etc mzlib/etc
mzlib/class mzlib/class)
mred
(lib "prim.ss" "lang"))
(provide (provide
control control
@ -131,4 +130,4 @@
;; effect: create a window from which a user can control moves ;; effect: create a window from which a user can control moves
(define (control/proc shape delta lr ud draw) (define (control/proc shape delta lr ud draw)
(make-controller 'control FOUR shape delta lr ud draw)) (make-controller 'control FOUR shape delta lr ud draw))
)

35
collects/htdp/big-draw.ss
View File

@ -1,12 +1,11 @@
#cs #lang scheme/gui
(module big-draw mzscheme
(require "error.ss" (require htdp/error
"draw-sig.ss" htdp/draw-sig
mzlib/etc
lang/posn lang/posn
lang/prim lang/prim
mzlib/etc
mzlib/unit mzlib/unit
(prefix mred: mred)
mzlib/class mzlib/class
mred/mred-sig mred/mred-sig
mred/mred-unit mred/mred-unit
@ -66,7 +65,7 @@
(syntax-case stx () (syntax-case stx ()
[(_ name) [(_ name)
(let* ([stuff (symbol->string (syntax-e (syntax name)))] (let* ([stuff (symbol->string (syntax-e (syntax name)))]
[fools (lambda (x) (datum->syntax-object #'name (string->symbol x)))] [fools (lambda (x) (datum->syntax #'name (string->symbol x)))]
[%name (fools (format "%~a" stuff))] ;; works on viewport [%name (fools (format "%~a" stuff))] ;; works on viewport
[proc (fools (format "~a/proc" stuff))]) [proc (fools (format "~a/proc" stuff))])
#`(define-values (#,%name #,proc) #`(define-values (#,%name #,proc)
@ -76,7 +75,7 @@
(syntax-case stx () (syntax-case stx ()
[(_ name) [(_ name)
(let* ([stuff (symbol->string (syntax-e (syntax name)))] (let* ([stuff (symbol->string (syntax-e (syntax name)))]
[fools (lambda (x) (datum->syntax-object #'name (string->symbol x)))] [fools (lambda (x) (datum->syntax #'name (string->symbol x)))]
[clear (fools (format "clear-~a" stuff))] [clear (fools (format "clear-~a" stuff))]
[draw (fools (format "draw-~a" stuff))]) [draw (fools (format "draw-~a" stuff))])
#`(begin #`(begin
@ -102,14 +101,14 @@
(define-hook stop) (define-hook stop)
(define (sleep-for-a-while/proc s) (mred:sleep/yield s) #t) (define (sleep-for-a-while/proc s) (sleep/yield s) #t)
(define-syntax (define-make stx) (define-syntax (define-make stx)
(syntax-case stx () (syntax-case stx ()
[(_ tag procedure) [(_ tag procedure)
(identifier? (syntax tag)) (identifier? (syntax tag))
(let* ([stuff (symbol->string (syntax-e (syntax tag)))] (let* ([stuff (symbol->string (syntax-e (syntax tag)))]
[fools (lambda (x) (datum->syntax-object stx (string->symbol x)))] [fools (lambda (x) (datum->syntax stx (string->symbol x)))]
[make- (fools (format "make-~a" stuff))] [make- (fools (format "make-~a" stuff))]
[name (fools "name")] [name (fools "name")]
[ffff (fools "f")] [ffff (fools "f")]
@ -167,7 +166,7 @@
(define seq-lock (make-semaphore 1)) (define seq-lock (make-semaphore 1))
(define is-graphics-open? #f) (define is-graphics-open? #f)
(define (start WIDTH HEIGHT) (start-and-export WIDTH HEIGHT (make-hash-table))) (define (start WIDTH HEIGHT) (start-and-export WIDTH HEIGHT (make-hash)))
(define (start-and-export WIDTH HEIGHT h) (define (start-and-export WIDTH HEIGHT h)
(define-syntax setter (define-syntax setter
(syntax-rules () (syntax-rules ()
@ -176,7 +175,7 @@
(set! name (set! name
(let ([direct (let ([vp* vp*]) exp)][pmap (let ([vp* pm*]) exp)]) (let ([direct (let ([vp* vp*]) exp)][pmap (let ([vp* pm*]) exp)])
(lambda a (if in-sequence? (apply pmap a) (apply direct a))))) (lambda a (if in-sequence? (apply pmap a) (apply direct a)))))
(hash-table-put! h 'name name))])) (hash-set! h 'name name))]))
;; Call after (start ... ...) to collect all the newly created closures ;; Call after (start ... ...) to collect all the newly created closures
(check-arg 'start (and (integer? WIDTH) (> WIDTH 0)) "positive integer" "first" WIDTH) (check-arg 'start (and (integer? WIDTH) (> WIDTH 0)) "positive integer" "first" WIDTH)
@ -193,7 +192,7 @@
(pm* (open-pixmap pmn WIDTH HEIGHT)) (pm* (open-pixmap pmn WIDTH HEIGHT))
(lbl (lambda () (if in-sequence? pmn vpn))) (lbl (lambda () (if in-sequence? pmn vpn)))
(*delta* 0)) (*delta* 0))
(hash-table-put! h 'label lbl) (hash-set! h 'label lbl)
(set! @vp vp*) (set! @vp vp*)
(set! @pm pm*) (set! @pm pm*)
;; --- the following need two versions ;; --- the following need two versions
@ -215,7 +214,7 @@
[(stop-tick vp*)] [(stop-tick vp*)]
[(stop-tick pm*)] [(stop-tick pm*)]
#t))) #t)))
(hash-table-put! h '%end-of-time %end-of-time) (hash-set! h '%end-of-time %end-of-time)
;; --- ;; ---
(set! %stop (set! %stop
(let* ([vp* vp*] (let* ([vp* vp*]
@ -228,10 +227,10 @@
(set! @end-actions (cons a @end-actions)) (set! @end-actions (cons a @end-actions))
[a]) [a])
#t))) #t)))
(hash-table-put! h '%stop %stop) (hash-set! h '%stop %stop)
;; --- ;; ---
;; see ../htdch/draw/support.scm (copy) for explanation and design rationale ;; see ../htdch/draw/support.scm (copy) for explanation and design rationale
(hash-table-put! h 'copy (lambda () (set! @vp vp*) (set! @pm pm*) [(clear-viewport pm*)])) (hash-set! h 'copy (lambda () (set! @vp vp*) (set! @pm pm*) [(clear-viewport pm*)]))
;; --- ;; ---
;; --- the following can't happend during a draw sequence --- ;; --- the following can't happend during a draw sequence ---
(set! %wait-for-mouse-click (lambda () (mouse-click-posn (get-mouse-click vp*)))) (set! %wait-for-mouse-click (lambda () (mouse-click-posn (get-mouse-click vp*))))
@ -325,7 +324,7 @@
((blue) (make-rgb 0 0 1.0)) ((blue) (make-rgb 0 0 1.0))
((black) (make-rgb 0 0 0)) ((black) (make-rgb 0 0 0))
(else (else
(let ([x (send mred:the-color-database find-color (symbol->string s))]) (let ([x (send the-color-database find-color (symbol->string s))])
(if (rgb? x) (if (rgb? x)
x x
(error 'draw.ss "The symbol ~e is not a legal color in draw.ss." s))))))) (error 'draw.ss "The symbol ~e is not a legal color in draw.ss." s))))))

5
collects/htdp/convert.ss
View File

@ -1,9 +1,8 @@
#lang scheme/gui #lang scheme/gui
;(module convert mzscheme
(require mzlib/etc (require mzlib/etc
htdp/error lang/prim
lang/prim) htdp/error)
(provide-higher-order-primitive convert-gui (f2c)) (provide-higher-order-primitive convert-gui (f2c))
(provide-higher-order-primitive convert-repl (f2c)) (provide-higher-order-primitive convert-repl (f2c))

2
collects/htdp/dir.ss
View File

@ -1,7 +1,7 @@
#lang scheme #lang scheme
(require htdp/error (require htdp/error
(lib "prim.ss" "lang")) lang/prim)
(provide (provide
create-dir ; path -> Directory create-dir ; path -> Directory

12
collects/htdp/docs.ss
View File

@ -1,7 +1,8 @@
#cs(module docs mzscheme #lang scheme
(require htdp/error (require htdp/error
mzlib/list lang/prim
(lib "prim.ss" "lang")) mzlib/list)
(provide (provide
atom? atom?
@ -99,6 +100,7 @@
(display #\SPACE the-port) (display #\SPACE the-port)
(loop j (rest los))))))) (loop j (rest los)))))))
(when (cons? file-name) (when (cons? file-name)
(close-output-port the-port))) (close-output-port the-port))
#t)
)

6
collects/htdp/draw-sig.ss
View File

@ -1,5 +1,7 @@
#cs(module draw-sig mzscheme #lang scheme
(provide core-draw^ draw^) (provide core-draw^ draw^)
(require mzlib/unit) (require mzlib/unit)
;; xxx-solid-rect cannot be called xxx-solid-rectangle because that ;; xxx-solid-rect cannot be called xxx-solid-rectangle because that
@ -43,4 +45,4 @@
end-of-time ; -> World end-of-time ; -> World
)) ))
(define-signature draw^ extends core-draw^ ())) (define-signature draw^ extends core-draw^ ())

5
collects/htdp/draw.ss
View File

@ -1,4 +1,5 @@
#cs(module draw mzscheme #lang scheme
(require htdp/big-draw (require htdp/big-draw
htdp/draw-sig htdp/draw-sig
mzlib/unit) mzlib/unit)
@ -20,4 +21,4 @@
draw ;; (draw <expression> ... produce <expression>) draw ;; (draw <expression> ... produce <expression>)
) )
(provide-signature-elements draw^)) (provide-signature-elements draw^)

16
collects/htdp/elevator.ss
View File

@ -1,10 +1,10 @@
(module elevator mzscheme #lang scheme/gui
(require htdp/big-draw (require htdp/big-draw
htdp/error htdp/error
(lib "posn.ss" "lang") lang/prim
mzlib/etc lang/posn
mred mzlib/etc)
(lib "prim.ss" "lang"))
;; Implementation: ;; Implementation:
;; Stephanie Weirich (1994), ;; Stephanie Weirich (1994),
@ -502,7 +502,7 @@
;; ;;
(define INFO-ORIGIN #f) (define INFO-ORIGIN #f)
(define-struct einfo (sym posn label prev)) (define-struct einfo (sym posn label prev) #:mutable)
(define INFO-LIST (define INFO-LIST
(list (make-einfo 'floor (make-posn 0 12) "floor = " #f) (list (make-einfo 'floor (make-posn 0 12) "floor = " #f)
@ -705,7 +705,7 @@
(make-elevator THE-MAX-FLOOR k) (make-elevator THE-MAX-FLOOR k)
(elevator 'open #f 'up)))) (elevator 'open #f 'up))))
close-graphics) close-graphics)
(void))) (lambda () #t)))
;; ;;
;; Main Loop. ;; Main Loop.
@ -814,5 +814,3 @@
(check-proc 'run f 3 'first "3 arguments") (check-proc 'run f 3 'first "3 arguments")
(set! Next-Floor f) (set! Next-Floor f)
(start-program))) (start-program)))
)

11
collects/htdp/graphing.ss
View File

@ -1,10 +1,11 @@
(module graphing mzscheme #lang scheme
(require htdp/error (require htdp/error
lang/posn
lang/prim
mzlib/unit mzlib/unit
htdp/draw-sig htdp/draw-sig
htdp/big-draw htdp/big-draw)
(lib "posn.ss" "lang")
(lib "prim.ss" "lang"))
(provide-signature-elements draw^) (provide-signature-elements draw^)
@ -83,4 +84,4 @@
(define DELTA .1) (define DELTA .1)
(define DOT 1) (define DOT 1)
(make-graph 'ok)) (make-graph 'ok)

10
collects/htdp/guess.ss
View File

@ -1,11 +1,11 @@
#cs(module guess mzscheme #lang scheme/gui
(require htdp/error (require htdp/error
lang/prim
mzlib/unitsig mzlib/unitsig
mzlib/etc mzlib/etc
mzlib/class mzlib/class
mzlib/list mzlib/list)
mred
(lib "prim.ss" "lang"))
(provide (provide
guess-with-gui guess-with-gui
@ -213,5 +213,5 @@
(check-proc 'guess-with-gui-list cg 2 'first "two arguments") (check-proc 'guess-with-gui-list cg 2 'first "two arguments")
(unless (<= (expt 10 n) 2147483647) (unless (<= (expt 10 n) 2147483647)
(error 'guess-with-gui-list "the given number of digits (~a) is too large" n)) (error 'guess-with-gui-list "the given number of digits (~a) is too large" n))
(init-game n vector->list cg))) (init-game n vector->list cg))

12
collects/htdp/gui.ss
View File

@ -1,20 +1,18 @@
;; This is a modified version of the original "gui.ss" teachpack: ;; This is a modified version of the original "gui.ss" teachpack:
;; - Instead of having one window, each call to "create-window" ;; - Instead of having one window, each call to "create-window"
;; returns a window ;; returns a window
;; - Message items stretch horizontally to fill the window, ;; - Message items stretch horizontally to fill the window,
;; avoiding the need for long initialization messages ;; avoiding the need for long initialization messages
#lang scheme/gui
#cs
(module gui mzscheme
(require htdp/error (require htdp/error
mred lang/prim
mzlib/class mzlib/class
mzlib/list mzlib/list
mzlib/etc mzlib/etc)
(lib "prim.ss" "lang"))
(provide-primitives (provide-primitives
window? ; any/c -> boolean
create-window ; (listof (listof GUI-ITEM)) -> window create-window ; (listof (listof GUI-ITEM)) -> window
show-window ; window -> true show-window ; window -> true
hide-window ; window -> true hide-window ; window -> true
@ -191,4 +189,4 @@
(check-arg 'choice-index (gui-item? a-choice) "gui-item" "first" a-choice) (check-arg 'choice-index (gui-item? a-choice) "gui-item" "first" a-choice)
(send ((gui-item-builder a-choice) #f) get-selection)) (send ((gui-item-builder a-choice) #f) get-selection))
)

13
collects/htdp/hangman-play.ss
View File

@ -1,8 +1,9 @@
(module hangman-play mzscheme #lang scheme
(require "hangman.ss"
"big-draw.ss" (require htdp/hangman
(lib "prim.ss" "lang") htdp/big-draw
(lib "posn.ss" "lang")) lang/prim
lang/posn)
(provide go) (provide go)
@ -49,4 +50,4 @@
(define (go/proc x) (define (go/proc x)
(start 200 400) (start 200 400)
(hangman-list reveal-list draw-next-part)) (hangman-list reveal-list draw-next-part))
)

17
collects/htdp/lkup-gui.ss
View File

@ -1,8 +1,8 @@
#cs(module lkup-gui mzscheme #lang scheme/gui
(require htdp/error (require htdp/error
mzlib/class lang/prim
(lib "prim.ss" "lang") mzlib/class)
mred)
(provide control view connect) (provide control view connect)
@ -23,8 +23,8 @@
(send panel set-alignment 'left 'top) (send panel set-alignment 'left 'top)
(define vert1 (make-object vertical-panel% panel)) (define vert1 (make-object vertical-panel% panel))
(send vert1 set-alignment 'left 'top) (send vert1 set-alignment 'left 'top)
(make-object message% "Name:" vert1) (void (make-object message% "Name:" vert1)
(make-object message% "Number:" vert1) (make-object message% "Number:" vert1))
(define vert2 (make-object vertical-panel% panel)) (define vert2 (make-object vertical-panel% panel))
;; ------------------------------------------------------------------------ ;; ------------------------------------------------------------------------
@ -48,7 +48,8 @@
(begin (begin
(set! button (make-object button% "LookUp" panel call-back '(border))) (set! button (make-object button% "LookUp" panel call-back '(border)))
(send query-tf focus) (send query-tf focus)
(send frame show #t)))) (send frame show #t)
#t)))
;; ------------------------------------------------------------------------ ;; ------------------------------------------------------------------------
;; message : display VIEW ;; message : display VIEW
@ -59,4 +60,4 @@
(define (view/proc n) (define (view/proc n)
(check-arg 'view (symbol? n) "symbol" "first" n) (check-arg 'view (symbol? n) "symbol" "first" n)
(send result set-label (symbol->string n))) (send result set-label (symbol->string n)))
)

12
collects/htdp/master.ss
View File

@ -1,13 +1,13 @@
#cs(module master mzscheme #lang scheme/gui
(provide master)
(require "error.ss" (require htdp/error
lang/prim
mzlib/class mzlib/class
mzlib/class100 mzlib/class100
mred
(lib "prim.ss" "lang")
mzlib/etc) mzlib/etc)
(provide master)
(define-higher-order-primitive master master/proc (compare-guess)) (define-higher-order-primitive master master/proc (compare-guess))
#| --------------------------------------------------------------------------- #| ---------------------------------------------------------------------------
@ -172,4 +172,4 @@
;; ------------------------------------------------------------------------ ;; ------------------------------------------------------------------------
;; Student Contribution ;; Student Contribution
(define check-guess #f)) (define check-guess #f)