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")

30
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
@ -33,31 +34,20 @@
(when (file-exists? OUT) (delete-file OUT)) (when (file-exists? OUT) (delete-file OUT))
(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))
;; 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 list OUT) "convert: The conversion function must produce a number; result: (212)")
;; first: expects argument of type <non-empty list>; given 212
(test-error (convert-file IN fx OUT)) (check-error (convert-file IN first OUT) "first: expected argument of type <non-empty list>; given 212")
;; convert: The conversion function must produce a number; result: 'xyz
(test-error (convert-file IN f2c 10)) (check-error (convert-file IN fx OUT) "convert: The conversion function must produce a number; result: xyz")
;; convert-file: expected <string> as third argument, given: 10
(check-error (convert-file IN f2c 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)

22
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>)
(write-file (check-expect
(list '<p> 'hello 'world 'is 'the 'most 'stupid 'program 'in 'the 'world '</p> (write-file
"so let's test this" 'with "How's that")) (list '<p> 'hello 'world 'is 'the 'most 'stupid 'program 'in 'the 'world '</p>
"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)

15
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))
(create-window (define w
(list (list txt msg chc) (create-window
(list (make-button "Okay?" call-back)) (list (list txt msg chc)
(list (make-button "Close" hide-window)))) (list (make-button "Okay?" call-back))
(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)

13
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 ()

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

@ -1,86 +1,85 @@
#cs(module arrow-gui mzscheme #lang scheme/gui
(require htdp/error (require htdp/error
htdp/big-draw htdp/big-draw
mzlib/etc lang/prim
mzlib/class mzlib/etc
mred mzlib/class)
(lib "prim.ss" "lang"))
(provide
(provide control ; modelT modelT modelT modelT -> true
control ; modelT modelT modelT modelT -> true view ; X -> true
view ; X -> true connect ; -> Symbol
connect ; -> Symbol )
)
(define-higher-order-primitive connect connect/proc (left right up down))
(define-higher-order-primitive connect connect/proc (left right up down)) (define-primitive control control/proc)
(define-primitive control control/proc) (define-primitive view view/proc)
(define-primitive view view/proc)
;; CONSTANTS ---------------------------------------------------------------
;; CONSTANTS --------------------------------------------------------------- (define MY-ICONS "/home/matthias/icons/")
(define MY-ICONS "/home/matthias/icons/") (define TITLE "Controller")
(define TITLE "Controller") (define COLLECT (collection-path "icons"))
(define COLLECT (collection-path "icons")) (define ARR "arrow.blue.~a.gif")
(define ARR "arrow.blue.~a.gif")
;; LAYOUT CONSTRUCTION ----------------------------------------------------
;; LAYOUT CONSTRUCTION ----------------------------------------------------
;; mk-image-constant : str (button% event% -> true) -> (panel% -> button%)
;; mk-image-constant : str (button% event% -> true) -> (panel% -> button%) ;; to create a panel-parameterized button with a picture and a specific call-back
;; to create a panel-parameterized button with a picture and a specific call-back (define (mk-image-constant kind model)
(define (mk-image-constant kind model) (local ([define an-item
(local ([define an-item (make-object bitmap% (build-path COLLECT (format ARR kind)) 'gif)])
(make-object bitmap% (build-path COLLECT (format ARR kind)) 'gif)]) (lambda (panel)
(lambda (panel) (make-object button% an-item panel model))))
(make-object button% an-item panel model))))
;; make-button-table :
;; make-button-table : ;; panel% layout -> (listof (listof (union panel% button%)))
;; panel% layout -> (listof (listof (union panel% button%))) ;; to translate a layout table into a button table
;; to translate a layout table into a button table ;; each button is controled by (control a-bitmap)
;; each button is controled by (control a-bitmap) (define (make-button-table panel layout)
(define (make-button-table panel layout) (local ((define (make-row a-row)
(local ((define (make-row a-row) (local ((define row-panel (make-object horizontal-panel% panel))
(local ((define row-panel (make-object horizontal-panel% panel)) (define (make-item an-item)
(define (make-item an-item) (if an-item (an-item row-panel)
(if an-item (an-item row-panel) (let ([panel (make-object horizontal-panel% row-panel)])
(let ([panel (make-object horizontal-panel% row-panel)]) (send panel min-width 30)))))
(send panel min-width 30))))) (map make-item a-row))))
(map make-item a-row)))) (map make-row layout)))
(map make-row layout)))
(define frame (make-object frame% TITLE #f 10 10))
(define frame (make-object frame% TITLE #f 10 10)) (define panel (make-object vertical-panel% frame))
(define panel (make-object vertical-panel% frame)) (define hor (make-object horizontal-panel% panel '(border)))
(define hor (make-object horizontal-panel% panel '(border))) (define lab (make-object message% "Going where?" hor))
(define lab (make-object message% "Going where?" hor)) (define msg (make-object message% "Nowhere" hor))
(define msg (make-object message% "Nowhere" hor))
;; X -> true
;; X -> true ;; to display s in the msg panel
;; to display s in the msg panel (define (view/proc s)
(define (view/proc s) (send msg set-label (format "~a" s))
(send msg set-label (format "~a" s)) true)
true)
;; WIRING THINGS UP ----------------------------------------------------
;; WIRING THINGS UP ---------------------------------------------------- ;; -> symbol
;; -> symbol ;; to read out the current state of the msg field
;; to read out the current state of the msg field (define (control/proc)
(define (control/proc) (string->symbol (send msg get-label)))
(string->symbol (send msg get-label)))
;; modelT = (button% event% -> true)
;; modelT = (button% event% -> true) ;; connect/proc : modelT modelT modelT modelT -> true
;; connect/proc : modelT modelT modelT modelT -> true (define (connect/proc left right up down)
(define (connect/proc left right up down) (check-proc 'connect left 2 "'left' argument" "two arguments")
(check-proc 'connect left 2 "'left' argument" "two arguments") (check-proc 'connect right 2 "'right' argument" "two arguments")
(check-proc 'connect right 2 "'right' argument" "two arguments") (check-proc 'connect up 2 "'up' argument" "two arguments")
(check-proc 'connect up 2 "'up' argument" "two arguments") (check-proc 'connect down 2 "'down' argument" "two arguments")
(check-proc 'connect down 2 "'down' argument" "two arguments") (local ((define LEFT-ARROW (mk-image-constant "left" left))
(local ((define LEFT-ARROW (mk-image-constant "left" left)) (define RIGHT-ARROW (mk-image-constant "right" right))
(define RIGHT-ARROW (mk-image-constant "right" right)) (define UP-ARROW (mk-image-constant "up" up))
(define UP-ARROW (mk-image-constant "up" up)) (define DOWN-ARROW (mk-image-constant "down" down))
(define DOWN-ARROW (mk-image-constant "down" down)) (define FOUR
(define FOUR `( (,#f ,UP-ARROW ,#f)
`( (,#f ,UP-ARROW ,#f) (,LEFT-ARROW ,#f ,RIGHT-ARROW)
(,LEFT-ARROW ,#f ,RIGHT-ARROW) (,#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)))

257
collects/htdp/arrow.ss
View File

@ -1,134 +1,133 @@
#cs(module arrow mzscheme #lang scheme/gui
(require htdp/error
htdp/big-draw
mzlib/etc
mzlib/class
mred
(lib "prim.ss" "lang"))
(provide
control
control-up-down
control-left-right
)
(define-higher-order-primitive control-up-down control-up-down/proc (require htdp/error
(_ _ up-down draw)) htdp/big-draw
lang/prim
mzlib/etc
mzlib/class)
(define-higher-order-primitive control-left-right control-left-right/proc (provide
(_ _ left-right draw)) control
control-up-down
control-left-right
)
(define-higher-order-primitive control control/proc (define-higher-order-primitive control-up-down control-up-down/proc
(_ _ left-right up-down draw)) (_ _ up-down draw))
(define-higher-order-primitive control-left-right control-left-right/proc
;; CONSTANTS --------------------------------------------------------------- (_ _ left-right draw))
(define MY-ICONS "/home/matthias/icons/")
(define TITLE "Controller") (define-higher-order-primitive control control/proc
(_ _ left-right up-down draw))
(define (mk-image-constant kind)
(make-object bitmap%
(build-path (collection-path "icons") (format "arrow.~a.gif" kind)) 'gif)) ;; CONSTANTS ---------------------------------------------------------------
(define MY-ICONS "/home/matthias/icons/")
;(define LEFT-ARROW (mk-image-constant "marble.left")) (define TITLE "Controller")
;(define RIGHT-ARROW (mk-image-constant "marble.right"))
;(define UP-ARROW (mk-image-constant "marble.up")) (define (mk-image-constant kind)
;(define DOWN-ARROW (mk-image-constant "marble.down")) (make-object bitmap%
(build-path (collection-path "icons") (format "arrow.~a.gif" kind)) 'gif))
(define LEFT-ARROW (mk-image-constant "blue.left"))
(define RIGHT-ARROW (mk-image-constant "blue.right")) ;(define LEFT-ARROW (mk-image-constant "marble.left"))
(define UP-ARROW (mk-image-constant "blue.up")) ;(define RIGHT-ARROW (mk-image-constant "marble.right"))
(define DOWN-ARROW (mk-image-constant "blue.down")) ;(define UP-ARROW (mk-image-constant "marble.up"))
;(define DOWN-ARROW (mk-image-constant "marble.down"))
;; LAYOUT ------------------------------------------------------------------
(define LEFT-ARROW (mk-image-constant "blue.left"))
;; layout = (listof (listof (union #f bitmap%))) (define RIGHT-ARROW (mk-image-constant "blue.right"))
(define UP-ARROW (mk-image-constant "blue.up"))
(define FOUR (define DOWN-ARROW (mk-image-constant "blue.down"))
`( (,#f ,UP-ARROW ,#f)
(,LEFT-ARROW ,#f ,RIGHT-ARROW) ;; LAYOUT ------------------------------------------------------------------
(,#f ,DOWN-ARROW ,#f) ))
;; layout = (listof (listof (union #f bitmap%)))
(define UP-DOWN
`( (,UP-ARROW ) (define FOUR
(,DOWN-ARROW ) )) `( (,#f ,UP-ARROW ,#f)
(,LEFT-ARROW ,#f ,RIGHT-ARROW)
(define LEFT-RIGHT (,#f ,DOWN-ARROW ,#f) ))
`( (,LEFT-ARROW ,RIGHT-ARROW ) ))
(define UP-DOWN
;; make-button-table : `( (,UP-ARROW )
;; panel% layout (bitmap% -> (_ _ -> X)) (,DOWN-ARROW ) ))
;; ->
;; (listof (listof (union panel% button%))) (define LEFT-RIGHT
;; to translate a layout table into a button table `( (,LEFT-ARROW ,RIGHT-ARROW ) ))
;; each button is controled by (control a-bitmap)
(define (make-button-table panel control layout) ;; make-button-table :
(define (make-row a-row) ;; panel% layout (bitmap% -> (_ _ -> X))
(define row-panel (make-object horizontal-panel% panel)) ;; ->
(define (make-item an-item) ;; (listof (listof (union panel% button%)))
(if an-item ;; to translate a layout table into a button table
(make-object button% an-item row-panel (control an-item)) ;; each button is controled by (control a-bitmap)
(let ([panel (make-object horizontal-panel% row-panel)]) (define (make-button-table panel control layout)
(send panel min-width 30)))) (define (make-row a-row)
;; --- (define row-panel (make-object horizontal-panel% panel))
(map make-item a-row)) (define (make-item an-item)
(if an-item
(make-object button% an-item row-panel (control an-item))
(let ([panel (make-object horizontal-panel% row-panel)])
(send panel min-width 30))))
;; --- ;; ---
(map make-row layout)) (map make-item a-row))
;; ---
;; GUI --------------------------------------------------------------------- (map make-row layout))
;; make-controller : ;; GUI ---------------------------------------------------------------------
;; symbol layout number X (number X -> true) (number X -> true) (X -> true)-> void
;; effect: create a left-right controller that invokes move on delta ;; make-controller :
(define (make-controller tag layout shape delta left-right-action up-down-action draw-shape) ;; symbol layout number X (number X -> true) (number X -> true) (X -> true)-> void
(check-arg tag ;; effect: create a left-right controller that invokes move on delta
(and (number? delta) (integer? delta) (>= delta 1)) (define (make-controller tag layout shape delta left-right-action up-down-action draw-shape)
"positive integer" (check-arg tag
'2nd (and (number? delta) (integer? delta) (>= delta 1))
delta) "positive integer"
(check-proc tag left-right-action 2 "move-left-right" "two arguments") '2nd
(check-proc tag up-down-action 2 "move-up-down" "two arguments") delta)
(check-proc tag draw-shape 1 "draw" "one argument") (check-proc tag left-right-action 2 "move-left-right" "two arguments")
;; --- (check-proc tag up-down-action 2 "move-up-down" "two arguments")
(local ((define frame (make-object frame% TITLE #f 10 10)) (check-proc tag draw-shape 1 "draw" "one argument")
(define panel (make-object vertical-panel% frame)) ;; ---
;; control : bitmap% -> (_ _ -> void) (local ((define frame (make-object frame% TITLE #f 10 10))
;; to check which button was clicked (define panel (make-object vertical-panel% frame))
(define (control an-item) ;; control : bitmap% -> (_ _ -> void)
(lambda (x y) ;; to check which button was clicked
;; DESIGN DECISION: (define (control an-item)
;; by handing over the number first, nesting the moves becomes easier (lambda (x y)
(evcase an-item ;; DESIGN DECISION:
(UP-ARROW ;; by handing over the number first, nesting the moves becomes easier
(set! shape (up-down-action (- delta) shape))) (evcase an-item
(DOWN-ARROW (UP-ARROW
(set! shape (up-down-action delta shape))) (set! shape (up-down-action (- delta) shape)))
(LEFT-ARROW (DOWN-ARROW
(set! shape (left-right-action (- delta) shape))) (set! shape (up-down-action delta shape)))
(RIGHT-ARROW (LEFT-ARROW
(set! shape (left-right-action delta shape)))) (set! shape (left-right-action (- delta) shape)))
(draw-shape shape)))) (RIGHT-ARROW
(make-button-table panel control layout) (set! shape (left-right-action delta shape))))
(send frame show #t) (draw-shape shape))))
#t)) (make-button-table panel control layout)
(send frame show #t)
;; EXPORTS: #t))
(define (void2 x y) (void)) ;; EXPORTS:
;; control-left-right/proc : XShape number (number XShape -> XShape) (XShape -> true) -> true (define (void2 x y) (void))
;; effect: create a window from which a user can control L/R moves
(define (control-left-right/proc shape delta lr draw) ;; control-left-right/proc : XShape number (number XShape -> XShape) (XShape -> true) -> true
(make-controller 'control-left-right LEFT-RIGHT shape delta lr void2 draw)) ;; effect: create a window from which a user can control L/R moves
(define (control-left-right/proc shape delta lr draw)
;; control-up-down : X number (number X -> true) (X -> true) -> true (make-controller 'control-left-right LEFT-RIGHT shape delta lr void2 draw))
;; effect: create a window from which a user can control U/D moves
(define (control-up-down/proc shape delta ud draw) ;; control-up-down : X number (number X -> true) (X -> true) -> true
(make-controller 'control-up-down UP-DOWN shape delta void2 ud draw)) ;; effect: create a window from which a user can control U/D moves
(define (control-up-down/proc shape delta ud draw)
;; control/proc : X number (number X -> true) (number X -> true) (X -> true) -> true (make-controller 'control-up-down UP-DOWN shape delta void2 ud draw))
;; effect: create a window from which a user can control moves
(define (control/proc shape delta lr ud draw) ;; control/proc : X number (number X -> true) (number X -> true) (X -> true) -> true
(make-controller 'control FOUR shape delta lr ud draw)) ;; effect: create a window from which a user can control moves
) (define (control/proc shape delta lr ud draw)
(make-controller 'control FOUR shape delta lr ud draw))

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

@ -1,331 +1,330 @@
#cs #lang scheme/gui
(module big-draw mzscheme
(require "error.ss"
"draw-sig.ss"
mzlib/etc
lang/posn
lang/prim
mzlib/unit
(prefix mred: mred)
mzlib/class
mred/mred-sig
mred/mred-unit
graphics/graphics-sig
graphics/graphics-posn-less-unit)
(define-unit-from-context p@ graphics:posn^)
(define-compound-unit/infer g@ (import) (export graphics^)
(link standard-mred@ p@ graphics-posn-less@))
(define-values/invoke-unit/infer g@)
(provide-signature-elements graphics^)
(define-primitive stop stop/proc)
(define-primitive draw-solid-disk draw-solid-disk/proc) (require htdp/error
(define-primitive draw-circle draw-circle/proc) htdp/draw-sig
(define-primitive draw-solid-rect draw-solid-rect/proc) lang/posn
(define-primitive draw-solid-line draw-solid-line/proc) lang/prim
mzlib/etc
(define-primitive clear-solid-disk clear-solid-disk/proc) mzlib/unit
(define-primitive clear-circle clear-circle/proc) mzlib/class
(define-primitive clear-solid-rect clear-solid-rect/proc) mred/mred-sig
(define-primitive clear-solid-line clear-solid-line/proc) mred/mred-unit
(define-primitive clear-all clear-all/proc) graphics/graphics-sig
graphics/graphics-posn-less-unit)
(define-primitive draw-solid-string draw-string/proc) (define-unit-from-context p@ graphics:posn^)
(define-primitive clear-solid-string clear-string/proc) (define-compound-unit/infer g@ (import) (export graphics^)
(link standard-mred@ p@ graphics-posn-less@))
(define-values/invoke-unit/infer g@)
(provide-signature-elements graphics^)
(define-primitive stop stop/proc)
(define-primitive draw-solid-disk draw-solid-disk/proc)
(define-primitive draw-circle draw-circle/proc)
(define-primitive draw-solid-rect draw-solid-rect/proc)
(define-primitive draw-solid-line draw-solid-line/proc)
(define-primitive clear-solid-disk clear-solid-disk/proc)
(define-primitive clear-circle clear-circle/proc)
(define-primitive clear-solid-rect clear-solid-rect/proc)
(define-primitive clear-solid-line clear-solid-line/proc)
(define-primitive clear-all clear-all/proc)
(define-primitive draw-solid-string draw-string/proc)
(define-primitive clear-solid-string clear-string/proc)
(define-primitive sleep-for-a-while sleep-for-a-while/proc)
(define-primitive wait-for-mouse-click wait-for-mouse-click/proc)
(define-primitive get-mouse-event get-mouse-event/proc)
(define-primitive get-key-event get-key-event/proc)
(define-higher-order-primitive on-key-event on-key-event/proc (handle-event))
(define-higher-order-primitive on-tick-event on-tick-event/proc (handle-tick))
(define-primitive big-bang big-bang/proc)
(define-primitive end-of-time end-of-time/proc)
;; (union #f viewport)
;; the view port for normal operation
(define @vp #f)
;; boolean
;; state: are the operations "grouped" into a draw sequence?
(define in-sequence? #f)
;; (union #f pixmap)
;; the pixmap for "grouped" operations
(define @pm #f)
;; -> (list Viewport Viewport)
(define (get-@VP) (list @vp @pm))
(define the-error (lambda x (error "evaluate (start <num> <num>) first")))
(define-syntax (define-hook stx)
(syntax-case stx ()
[(_ name)
(let* ([stuff (symbol->string (syntax-e (syntax name)))]
[fools (lambda (x) (datum->syntax #'name (string->symbol x)))]
[%name (fools (format "%~a" stuff))] ;; works on viewport
[proc (fools (format "~a/proc" stuff))])
#`(define-values (#,%name #,proc)
(values the-error (lambda a (apply #,%name a)))))]))
(define-syntax (define-hook-draw/clear stx)
(syntax-case stx ()
[(_ name)
(let* ([stuff (symbol->string (syntax-e (syntax name)))]
[fools (lambda (x) (datum->syntax #'name (string->symbol x)))]
[clear (fools (format "clear-~a" stuff))]
[draw (fools (format "draw-~a" stuff))])
#`(begin
(define-hook #,clear)
(define-hook #,draw)))]))
(define-hook-draw/clear solid-disk)
(define-hook-draw/clear circle)
(define-hook-draw/clear string)
(define-hook-draw/clear solid-rect)
(define-hook-draw/clear solid-line)
(define-hook clear-all)
(define-hook get-key-event)
(define-hook get-mouse-event)
(define-hook wait-for-mouse-click)
(define-hook big-bang)
(define-hook on-key-event)
(define-hook on-tick-event)
(define-hook end-of-time)
(define-hook stop)
(define (sleep-for-a-while/proc s) (sleep/yield s) #t)
(define-syntax (define-make stx)
(syntax-case stx ()
[(_ tag procedure)
(identifier? (syntax tag))
(let* ([stuff (symbol->string (syntax-e (syntax tag)))]
[fools (lambda (x) (datum->syntax stx (string->symbol x)))]
[make- (fools (format "make-~a" stuff))]
[name (fools "name")]
[ffff (fools "f")]
[x (fools "x")])
#`(define (#,make- #,name #,ffff)
(lambda #,x
(apply procedure #,x)
#t)))]))
(define-make line
(lambda (p1 p2 . c)
(check-arg name (posn? p1) "posn" "first" p1)
(check-arg name (posn? p2) "posn" "second" p2)
(f p1 p2 (check-optional name 3 c "third" x))))
(define-make rect
(lambda (p w h . c)
(check-arg name (posn? p) "posn" "first" p)
(check-arg name (and (integer? w) (> w 0)) "positive integer" "second" w)
(check-arg name (and (integer? h) (> h 0)) "positive integer" "third" h)
(f p w h (check-optional name 4 c "fourth" x))))
(define-make %string
(lambda (p s)
(check-arg name (posn? p) "posn" "first" p)
(check-arg name (string? s) "string" "second" s)
(f p s)))
(define-make circle
(lambda (p r . c)
(check-arg name (posn? p) "posn" "first" p)
(check-arg name (and (integer? r) (> r 0)) "positive integer" "second" r)
((ellipsis-2-circle f) p r (check-optional name 3 c "third" x))))
;; Local function for make-circle
;; (Posn Number Symbol[color] -> void) -> (Posn Number Symbol[color] -> void)
(define (ellipsis-2-circle f)
(lambda (p r c)
(let ((d (* r 2)))
(f (make-posn (- (posn-x p) r) (- (posn-y p) r)) d d c))))
;; (Listof _) String (Listof _) -> Symbol[color]
;; contract: c is shared suffix of all
;; check whether c contains a single color symbol and all has proper length
(define (check-optional name n c position x)
(if (pair? c)
(begin
(check-arity name n x)
(check-arg name (symbol? (car c)) "symbol" position (car c)))
(check-arity name (- n 1) x))
(symbol->color (if (null? c) 'black (car c))))
;; Semaphore
;; only one world can perform a draw sequence, including a start-up sequence
(define seq-lock (make-semaphore 1))
(define is-graphics-open? #f)
(define (start WIDTH HEIGHT) (start-and-export WIDTH HEIGHT (make-hash)))
(define (start-and-export WIDTH HEIGHT h)
(define-syntax setter
(syntax-rules ()
[(_ vp* pm* name exp)
(begin
(set! name
(let ([direct (let ([vp* vp*]) exp)][pmap (let ([vp* pm*]) exp)])
(lambda a (if in-sequence? (apply pmap a) (apply direct a)))))
(hash-set! h 'name name))]))
(define-primitive sleep-for-a-while sleep-for-a-while/proc) ;; Call after (start ... ...) to collect all the newly created closures
(define-primitive wait-for-mouse-click wait-for-mouse-click/proc) (check-arg 'start (and (integer? WIDTH) (> WIDTH 0)) "positive integer" "first" WIDTH)
(define-primitive get-mouse-event get-mouse-event/proc) (check-arg 'start (and (integer? HEIGHT) (> HEIGHT 0)) "positive integer" "second" HEIGHT)
(define-primitive get-key-event get-key-event/proc) (semaphore-wait seq-lock)
;; ---
(define-higher-order-primitive on-key-event on-key-event/proc (handle-event)) (unless is-graphics-open?
(define-higher-order-primitive on-tick-event on-tick-event/proc (handle-tick)) (set! is-graphics-open? #t)
(define-primitive big-bang big-bang/proc) (open-graphics))
(define-primitive end-of-time end-of-time/proc) (let* ((tag (symbol->string (gensym)))
(vpn (string-append "Canvas VP: " tag))
;; (union #f viewport) (pmn (string-append "Canvas PM: " tag))
;; the view port for normal operation (vp* (open-viewport vpn WIDTH HEIGHT))
(define @vp #f) (pm* (open-pixmap pmn WIDTH HEIGHT))
(lbl (lambda () (if in-sequence? pmn vpn)))
;; boolean (*delta* 0))
;; state: are the operations "grouped" into a draw sequence? (hash-set! h 'label lbl)
(define in-sequence? #f) (set! @vp vp*)
(set! @pm pm*)
;; (union #f pixmap) ;; --- the following need two versions
;; the pixmap for "grouped" operations (setter vp* pm* %clear-all (clear-viewport vp*))
(define @pm #f) (setter vp* pm* %draw-solid-line (make-line 'draw-solid-line (draw-line vp*)))
(setter vp* pm* %clear-solid-line (make-line 'clear-solid-line (lambda (p1 p2 c) ((clear-line vp*) p1 p2))))
;; -> (list Viewport Viewport) (setter vp* pm* %draw-solid-rect (make-rect 'draw-solid-rect (draw-solid-rectangle vp*)))
(define (get-@VP) (list @vp @pm)) (setter vp* pm* %clear-solid-rect (make-rect 'clear-solid-rect (lambda (p w h c) ((clear-solid-rectangle vp*) p w h))))
(setter vp* pm* %draw-solid-disk (make-circle 'draw-solid-disk (draw-solid-ellipse vp*)))
(define the-error (lambda x (error "evaluate (start <num> <num>) first"))) (setter vp* pm* %clear-solid-disk (make-circle 'clear-solid-disk (lambda (p r1 r2 c) ((clear-solid-ellipse vp*) p r1 r2))))
(define-syntax (define-hook stx) (setter vp* pm* %draw-circle (make-circle 'draw-circle (draw-ellipse vp*)))
(syntax-case stx () (setter vp* pm* %clear-circle (make-circle 'clear-circle (lambda (p r1 r2 c) ((clear-ellipse vp*) p r1 r2))))
[(_ name) (setter vp* pm* %draw-string (make-%string 'draw-string (lambda (p s) [(draw-string vp*) p s])))
(let* ([stuff (symbol->string (syntax-e (syntax name)))] (setter vp* pm* %clear-string (make-%string 'clear-string (clear-string vp*)))
[fools (lambda (x) (datum->syntax-object #'name (string->symbol x)))] ;; ---
[%name (fools (format "%~a" stuff))] ;; works on viewport (set! %end-of-time
[proc (fools (format "~a/proc" stuff))]) (let () #;([vp* vp*][pm* pm*])
#`(define-values (#,%name #,proc)
(values the-error (lambda a (apply #,%name a)))))]))
(define-syntax (define-hook-draw/clear stx)
(syntax-case stx ()
[(_ name)
(let* ([stuff (symbol->string (syntax-e (syntax name)))]
[fools (lambda (x) (datum->syntax-object #'name (string->symbol x)))]
[clear (fools (format "clear-~a" stuff))]
[draw (fools (format "draw-~a" stuff))])
#`(begin
(define-hook #,clear)
(define-hook #,draw)))]))
(define-hook-draw/clear solid-disk)
(define-hook-draw/clear circle)
(define-hook-draw/clear string)
(define-hook-draw/clear solid-rect)
(define-hook-draw/clear solid-line)
(define-hook clear-all)
(define-hook get-key-event)
(define-hook get-mouse-event)
(define-hook wait-for-mouse-click)
(define-hook big-bang)
(define-hook on-key-event)
(define-hook on-tick-event)
(define-hook end-of-time)
(define-hook stop)
(define (sleep-for-a-while/proc s) (mred:sleep/yield s) #t)
(define-syntax (define-make stx)
(syntax-case stx ()
[(_ tag procedure)
(identifier? (syntax tag))
(let* ([stuff (symbol->string (syntax-e (syntax tag)))]
[fools (lambda (x) (datum->syntax-object stx (string->symbol x)))]
[make- (fools (format "make-~a" stuff))]
[name (fools "name")]
[ffff (fools "f")]
[x (fools "x")])
#`(define (#,make- #,name #,ffff)
(lambda #,x
(apply procedure #,x)
#t)))]))
(define-make line
(lambda (p1 p2 . c)
(check-arg name (posn? p1) "posn" "first" p1)
(check-arg name (posn? p2) "posn" "second" p2)
(f p1 p2 (check-optional name 3 c "third" x))))
(define-make rect
(lambda (p w h . c)
(check-arg name (posn? p) "posn" "first" p)
(check-arg name (and (integer? w) (> w 0)) "positive integer" "second" w)
(check-arg name (and (integer? h) (> h 0)) "positive integer" "third" h)
(f p w h (check-optional name 4 c "fourth" x))))
(define-make %string
(lambda (p s)
(check-arg name (posn? p) "posn" "first" p)
(check-arg name (string? s) "string" "second" s)
(f p s)))
(define-make circle
(lambda (p r . c)
(check-arg name (posn? p) "posn" "first" p)
(check-arg name (and (integer? r) (> r 0)) "positive integer" "second" r)
((ellipsis-2-circle f) p r (check-optional name 3 c "third" x))))
;; Local function for make-circle
;; (Posn Number Symbol[color] -> void) -> (Posn Number Symbol[color] -> void)
(define (ellipsis-2-circle f)
(lambda (p r c)
(let ((d (* r 2)))
(f (make-posn (- (posn-x p) r) (- (posn-y p) r)) d d c))))
;; (Listof _) String (Listof _) -> Symbol[color]
;; contract: c is shared suffix of all
;; check whether c contains a single color symbol and all has proper length
(define (check-optional name n c position x)
(if (pair? c)
(begin
(check-arity name n x)
(check-arg name (symbol? (car c)) "symbol" position (car c)))
(check-arity name (- n 1) x))
(symbol->color (if (null? c) 'black (car c))))
;; Semaphore
;; only one world can perform a draw sequence, including a start-up sequence
(define seq-lock (make-semaphore 1))
(define is-graphics-open? #f)
(define (start WIDTH HEIGHT) (start-and-export WIDTH HEIGHT (make-hash-table)))
(define (start-and-export WIDTH HEIGHT h)
(define-syntax setter
(syntax-rules ()
[(_ vp* pm* name exp)
(begin
(set! name
(let ([direct (let ([vp* vp*]) exp)][pmap (let ([vp* pm*]) exp)])
(lambda a (if in-sequence? (apply pmap a) (apply direct a)))))
(hash-table-put! h 'name name))]))
;; 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? HEIGHT) (> HEIGHT 0)) "positive integer" "second" HEIGHT)
(semaphore-wait seq-lock)
;; ---
(unless is-graphics-open?
(set! is-graphics-open? #t)
(open-graphics))
(let* ((tag (symbol->string (gensym)))
(vpn (string-append "Canvas VP: " tag))
(pmn (string-append "Canvas PM: " tag))
(vp* (open-viewport vpn WIDTH HEIGHT))
(pm* (open-pixmap pmn WIDTH HEIGHT))
(lbl (lambda () (if in-sequence? pmn vpn)))
(*delta* 0))
(hash-table-put! h 'label lbl)
(set! @vp vp*)
(set! @pm pm*)
;; --- the following need two versions
(setter vp* pm* %clear-all (clear-viewport vp*))
(setter vp* pm* %draw-solid-line (make-line 'draw-solid-line (draw-line vp*)))
(setter vp* pm* %clear-solid-line (make-line 'clear-solid-line (lambda (p1 p2 c) ((clear-line vp*) p1 p2))))
(setter vp* pm* %draw-solid-rect (make-rect 'draw-solid-rect (draw-solid-rectangle vp*)))
(setter vp* pm* %clear-solid-rect (make-rect 'clear-solid-rect (lambda (p w h c) ((clear-solid-rectangle vp*) p w h))))
(setter vp* pm* %draw-solid-disk (make-circle 'draw-solid-disk (draw-solid-ellipse vp*)))
(setter vp* pm* %clear-solid-disk (make-circle 'clear-solid-disk (lambda (p r1 r2 c) ((clear-solid-ellipse vp*) p r1 r2))))
(setter vp* pm* %draw-circle (make-circle 'draw-circle (draw-ellipse vp*)))
(setter vp* pm* %clear-circle (make-circle 'clear-circle (lambda (p r1 r2 c) ((clear-ellipse vp*) p r1 r2))))
(setter vp* pm* %draw-string (make-%string 'draw-string (lambda (p s) [(draw-string vp*) p s])))
(setter vp* pm* %clear-string (make-%string 'clear-string (clear-string vp*)))
;; ---
(set! %end-of-time
(let () #;([vp* vp*][pm* pm*])
(lambda () (lambda ()
[(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*]
[pm* pm*] [pm* pm*]
[a (lambda () (close-viewport vp*) (close-viewport pm*))]) [a (lambda () (close-viewport vp*) (close-viewport pm*))])
(lambda ()
[(stop-tick vp*)]
[(stop-tick pm*)]
(if in-sequence?
(set! @end-actions (cons a @end-actions))
[a])
#t)))
(hash-table-put! h '%stop %stop)
;; ---
;; 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*)]))
;; ---
;; --- the following can't happend during a draw sequence ---
(set! %wait-for-mouse-click (lambda () (mouse-click-posn (get-mouse-click vp*))))
(set! %get-key-event
(lambda () (lambda ()
(cond [(stop-tick vp*)]
[(ready-key-press vp*) => key-value] [(stop-tick pm*)]
[else false]))) (if in-sequence?
(set! %get-mouse-event (set! @end-actions (cons a @end-actions))
(lambda () [a])
(cond #t)))
[(ready-mouse-click vp*) => mouse-click-posn] (hash-set! h '%stop %stop)
[else false]))) ;; ---
(set! %on-key-event ;; see ../htdch/draw/support.scm (copy) for explanation and design rationale
(lambda (f) (hash-set! h 'copy (lambda () (set! @vp vp*) (set! @pm pm*) [(clear-viewport pm*)]))
(check-proc 'on-key-event f 2 'first 'two) ;; ---
((set-on-key-event vp*) ;; --- the following can't happend during a draw sequence ---
(lambda (x y) (f (key-value x) y))) (set! %wait-for-mouse-click (lambda () (mouse-click-posn (get-mouse-click vp*))))
#t)) (set! %get-key-event
(set! %on-tick-event (lambda ()
(lambda (f) (cond
(let* ([w (ceiling (* 1000 *delta*))] [(ready-key-press vp*) => key-value]
[w (if (exact? w) w (inexact->exact w))]) [else false])))
(check-proc 'on-key-event f 1 'first 'one) (set! %get-mouse-event
((set-on-tick-event vp*) w (lambda (x) (f x))) (lambda ()
#t))) (cond
(set! %big-bang [(ready-mouse-click vp*) => mouse-click-posn]
(lambda (delta w) [else false])))
(check-arg 'big-bang (set! %on-key-event
(and (number? delta) (>= delta 0)) (lambda (f)
"number [of seconds] between 0 and 1000000" (check-proc 'on-key-event f 2 'first 'two)
"first" ((set-on-key-event vp*)
delta) (lambda (x y) (f (key-value x) y)))
(set! *delta* delta) #t))
((init-world vp*) w) (set! %on-tick-event
#t)) (lambda (f)
(let* ([w (ceiling (* 1000 *delta*))]
(semaphore-post seq-lock) [w (if (exact? w) w (inexact->exact w))])
#t)) (check-proc 'on-key-event f 1 'first 'one)
((set-on-tick-event vp*) w (lambda (x) (f x)))
;; [Listof (-> Void)] #t)))
;; a list of actions to be performed after the drawing action is done. (set! %big-bang
(define @end-actions '()) (lambda (delta w)
(check-arg 'big-bang
;; Viewport Pixmap -> true (and (number? delta) (>= delta 0))
;; start a drawing sequence by clearing the pixmap and making it the "target" for all operations "number [of seconds] between 0 and 1000000"
;; effect: in-sequence?, @vp and @pm so that copy-viewport can work later "first"
;; The draw sequence can only draw (and clear) elements from the pixmap. delta)
;; It doesn't react to events. Should it disable them? (set! *delta* delta)
;; Or do we count on finishing the sequence fast enough? ((init-world vp*) w)
(define (begin-draw-sequence) #t))
(semaphore-wait seq-lock)
(set! in-sequence? #t)
#t)
;; -> true
;; stop a drawing sequence and copy the pixmap into the viewport
;; effect: in-sequence?
(define (end-draw-sequence)
(set! in-sequence? #f)
(copy-viewport @pm @vp)
(for-each (lambda (th) (th)) @end-actions)
(set! @end-actions '())
(semaphore-post seq-lock) (semaphore-post seq-lock)
#t) #t))
;; start/cartesian-plane : Number Number -> true ;; [Listof (-> Void)]
;; start up a canvas of size width x height and draw a centered cartesian coordinate ;; a list of actions to be performed after the drawing action is done.
(define (start/cartesian-plane width height) (define @end-actions '())
(check-arg 'start/cartesian-plane
(and (integer? width) (> width 0)) "positive integer" "first" width) ;; Viewport Pixmap -> true
(check-arg 'start/cartesian-plane ;; start a drawing sequence by clearing the pixmap and making it the "target" for all operations
(and (integer? height) (> height 0)) "positive integer" "second" height) ;; effect: in-sequence?, @vp and @pm so that copy-viewport can work later
(local ((define trash (start width height)) ;; The draw sequence can only draw (and clear) elements from the pixmap.
(define mid-x (quotient width 2)) ;; It doesn't react to events. Should it disable them?
(define mid-y (quotient height 2))) ;; Or do we count on finishing the sequence fast enough?
(and (draw-solid-line (make-posn mid-x 0) (make-posn mid-x height)) (define (begin-draw-sequence)
(draw-solid-line (make-posn 0 mid-y) (make-posn width mid-y))))) (semaphore-wait seq-lock)
(set! in-sequence? #t)
(provide-signature-elements draw^) #t)
;; symbol->color : symbol -> color ;; -> true
;; to convert symbol to ;; stop a drawing sequence and copy the pixmap into the viewport
(define (symbol->color s) ;; effect: in-sequence?
(check-arg 'draw.ss (symbol? s) "symbol" "first" s) (define (end-draw-sequence)
(case s (set! in-sequence? #f)
((white) (make-rgb 1 1 1)) (copy-viewport @pm @vp)
((yellow) (make-rgb 1 1 0)) (for-each (lambda (th) (th)) @end-actions)
((red) (make-rgb 1.0 0 0)) (set! @end-actions '())
((green) (make-rgb 0 1.0 0)) (semaphore-post seq-lock)
((blue) (make-rgb 0 0 1.0)) #t)
((black) (make-rgb 0 0 0))
(else ;; start/cartesian-plane : Number Number -> true
(let ([x (send mred:the-color-database find-color (symbol->string s))]) ;; start up a canvas of size width x height and draw a centered cartesian coordinate
(if (rgb? x) (define (start/cartesian-plane width height)
x (check-arg 'start/cartesian-plane
(error 'draw.ss "The symbol ~e is not a legal color in draw.ss." s))))))) (and (integer? width) (> width 0)) "positive integer" "first" width)
(check-arg 'start/cartesian-plane
(and (integer? height) (> height 0)) "positive integer" "second" height)
(local ((define trash (start width height))
(define mid-x (quotient width 2))
(define mid-y (quotient height 2)))
(and (draw-solid-line (make-posn mid-x 0) (make-posn mid-x height))
(draw-solid-line (make-posn 0 mid-y) (make-posn width mid-y)))))
(provide-signature-elements draw^)
;; symbol->color : symbol -> color
;; to convert symbol to
(define (symbol->color s)
(check-arg 'draw.ss (symbol? s) "symbol" "first" s)
(case s
((white) (make-rgb 1 1 1))
((yellow) (make-rgb 1 1 0))
((red) (make-rgb 1.0 0 0))
((green) (make-rgb 0 1.0 0))
((blue) (make-rgb 0 0 1.0))
((black) (make-rgb 0 0 0))
(else
(let ([x (send the-color-database find-color (symbol->string s))])
(if (rgb? x)
x
(error 'draw.ss "The symbol ~e is not a legal color in draw.ss." s))))))

497
collects/htdp/convert.ss
View File

@ -1,259 +1,258 @@
#lang scheme/gui #lang scheme/gui
;(module convert mzscheme (require mzlib/etc
(require mzlib/etc lang/prim
htdp/error htdp/error)
lang/prim)
(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)) (provide-higher-order-primitive convert-file (_ f2c _))
(provide-higher-order-primitive convert-file (_ f2c _))
(define black-pen (send the-pen-list find-or-create-pen "BLACK" 2 'solid))
(define black-pen (send the-pen-list find-or-create-pen "BLACK" 2 'solid)) (define red-brush (send the-brush-list find-or-create-brush "RED" 'solid))
(define red-brush (send the-brush-list find-or-create-brush "RED" 'solid)) (define white-brush (send the-brush-list find-or-create-brush "WHITE" 'solid))
(define white-brush (send the-brush-list find-or-create-brush "WHITE" 'solid))
;; scale% : (union false (num -> str)) frame% -> scale<%>
;; scale% : (union false (num -> str)) frame% -> scale<%> ;; scale<%> : set-current-x + canvas<%>
;; scale<%> : set-current-x + canvas<%> (define scale%
(define scale% (class canvas%
(class canvas% (inherit get-dc get-size get-client-size)
(inherit get-dc get-size get-client-size)
(define value 0)
(define value 0)
(define (draw-something)
(define (draw-something) (let ([dc (get-dc)])
(let ([dc (get-dc)]) (send dc clear)
(send dc clear) (let-values ([(width height) (get-client-size)])
(let-values ([(width height) (get-client-size)]) (send dc set-pen black-pen)
(send dc set-pen black-pen) (send dc set-brush white-brush)
(send dc set-brush white-brush) (send dc draw-rectangle 0 0 width height)
(send dc draw-rectangle 0 0 width height) (send dc set-brush red-brush)
(send dc set-brush red-brush) (send dc draw-rectangle 0 0
(send dc draw-rectangle 0 0 (* width (max 0 (min 1 (/ (- value SLI-MIN) (- SLI-MAX SLI-MIN))))) height)
(* width (max 0 (min 1 (/ (- value SLI-MIN) (- SLI-MAX SLI-MIN))))) height) (let*-values ([(cw ch) (get-client-size)]
(let*-values ([(cw ch) (get-client-size)] [(number) value])
[(number) value]) (when (and (number? number)
(when (and (number? number) (exact? number)
(exact? number) (real? number))
(real? number)) (let* ([whole (if (number . < . 0)
(let* ([whole (if (number . < . 0) (ceiling number)
(ceiling number) (floor number))]
(floor number))] [fractional-part (- (abs number) (floor (abs number)))]
[fractional-part (- (abs number) (floor (abs number)))] [num (numerator fractional-part)]
[num (numerator fractional-part)] [den (denominator fractional-part)]
[den (denominator fractional-part)] [wholes (if (and (zero? whole) (not (zero? number)))
[wholes (if (and (zero? whole) (not (zero? number))) ""
"" (number->string whole))]
(number->string whole))] [nums (number->string num)]
[nums (number->string num)] [dens (number->string den)])
[dens (number->string den)]) (let-values ([(ww wh wa wd) (send dc get-text-extent wholes)]
(let-values ([(ww wh wa wd) (send dc get-text-extent wholes)] [(nw nh na nd) (send dc get-text-extent nums)]
[(nw nh na nd) (send dc get-text-extent nums)] [(dw dh da dd) (send dc get-text-extent dens)])
[(dw dh da dd) (send dc get-text-extent dens)]) (let ([w (if (integer? number) (+ ww (max nw dw)) ww)]
(let ([w (if (integer? number) (+ ww (max nw dw)) ww)] [h (if (integer? number)
[h (if (integer? number) wh
wh (+ nh dh))])
(+ nh dh))]) (cond
(cond [(integer? number)
[(integer? number) (send dc draw-text
(send dc draw-text wholes
wholes (- (/ cw 2) (/ w 2))
(- (/ cw 2) (/ w 2)) (- (/ ch 2) (/ wh 2)))]
(- (/ ch 2) (/ wh 2)))] [else
[else (send dc draw-text
(send dc draw-text wholes
wholes (- (/ cw 2) (/ w 2))
(- (/ cw 2) (/ w 2)) (- (/ ch 2) (/ wh 2)))
(- (/ ch 2) (/ wh 2))) (send dc draw-text
(send dc draw-text nums
nums (+ ww (- (/ cw 2) (/ w 2)))
(+ ww (- (/ cw 2) (/ w 2))) (- (/ ch 2) (/ h 2)))
(- (/ ch 2) (/ h 2))) (send dc draw-text
(send dc draw-text dens
dens (+ ww (- (/ cw 2) (/ w 2)))
(+ ww (- (/ cw 2) (/ w 2))) (+ nh (- (/ ch 2) (/ h 2))))
(+ nh (- (/ ch 2) (/ h 2)))) (send dc draw-line
(send dc draw-line (+ ww (- (/ cw 2) (/ w 2)))
(+ ww (- (/ cw 2) (/ w 2))) (/ ch 2)
(/ ch 2) (+ ww (max nw dw) (- (/ cw 2) (/ w 2)))
(+ ww (max nw dw) (- (/ cw 2) (/ w 2))) (/ ch 2))])))))))))
(/ ch 2))]))))))))) (override on-paint)
(override on-paint) (define (on-paint) (draw-something))
(define (on-paint) (draw-something)) (public set-value)
(public set-value) (define (set-value v)
(define (set-value v) (set! value v)
(set! value v) (draw-something))
(draw-something)) (inherit min-width min-height)
(inherit min-width min-height) (super-instantiate ())
(super-instantiate ()) (let-values ([(w h a d) (send (get-dc) get-text-extent "100100100")])
(let-values ([(w h a d) (send (get-dc) get-text-extent "100100100")]) (min-width (+ 4 (inexact->exact w)))
(min-width (+ 4 (inexact->exact w))) (min-height (+ 4 (inexact->exact (* 2 h)))))))
(min-height (+ 4 (inexact->exact (* 2 h)))))))
;; ------------------------------------------------------------------------
;; ------------------------------------------------------------------------ (define OUT-ERROR
(define OUT-ERROR "The conversion function must produce a number; result: ~e")
"The conversion function must produce a number; result: ~e")
;; ============================================================================
;; ============================================================================ ;; MODEL
;; MODEL ;; 2int : num -> int
;; 2int : num -> int ;; to convert a real number into an exact number
;; to convert a real number into an exact number (define (2int x)
(define (2int x) (if (and (real? x) (number? x))
(if (and (real? x) (number? x)) (inexact->exact x)
(inexact->exact x) (error 'convert OUT-ERROR x)))
(error 'convert OUT-ERROR x)))
;; f2c : num -> num
;; f2c : num -> num ;; to convert a Fahrenheit temperature into a Celsius temperature
;; to convert a Fahrenheit temperature into a Celsius temperature (define (f2c f)
(define (f2c f) (2int (* 5/9 (- f 32))))
(2int (* 5/9 (- f 32))))
;; fahr->cel : num -> num
;; fahr->cel : num -> num ;; student-supplied function for converting F to C
;; student-supplied function for converting F to C (define (fahr->cel f)
(define (fahr->cel f) (error 'convert "not initialized"))
(error 'convert "not initialized"))
;; slider-cb : slider% event% -> void
;; slider-cb : slider% event% -> void ;; to use fahr->cel to perform the conversion
;; to use fahr->cel to perform the conversion (define (slider-cb c s)
(define (slider-cb c s) (send sliderC set-value
(send sliderC set-value ((compose in-slider-range 2int fahr->cel)
((compose in-slider-range 2int fahr->cel) (send sliderF get-value))))
(send sliderF get-value))))
;; in-slider-range : number -> number
;; in-slider-range : number -> number ;; to check and to convert the new temperature into an appropriate scale
;; to check and to convert the new temperature into an appropriate scale (define (in-slider-range x)
(define (in-slider-range x) (cond
(cond [(<= SLI-MIN x SLI-MAX) x]
[(<= SLI-MIN x SLI-MAX) x] [else (error 'convert-gui "result out of range for Celsius display")]))
[else (error 'convert-gui "result out of range for Celsius display")]))
#| --------------------------------------------------------------------
#| --------------------------------------------------------------------
view (exports sliderF sliderC SLI-MIN SLI-MAX) (imports f2c slider-cb) view (exports sliderF sliderC SLI-MIN SLI-MAX) (imports f2c slider-cb)
model (imports sliderF sliderC SLI-MIN SLI-MAX) (exports f2c slider-cb) model (imports sliderF sliderC SLI-MIN SLI-MAX) (exports f2c slider-cb)
----------------------------------------------------------------------- |# ----------------------------------------------------------------------- |#
;; ============================================================================ ;; ============================================================================
;; VIEW ;; VIEW
(define frame (make-object frame% "Fahrenheit to Celsius Conversion")) (define frame (make-object frame% "Fahrenheit to Celsius Conversion"))
(send frame set-alignment 'center 'center) (send frame set-alignment 'center 'center)
(define main-panel (instantiate horizontal-panel% () (parent frame) (define main-panel (instantiate horizontal-panel% () (parent frame)
(stretchable-height #f))) (stretchable-height #f)))
;; create labels; aligned with sliders ;; create labels; aligned with sliders
(define mpanel (make-object vertical-panel% main-panel)) (define mpanel (make-object vertical-panel% main-panel))
(begin (begin
(make-object message% "Fahrenheit" mpanel) (make-object message% "Fahrenheit" mpanel)
(make-object message% "" mpanel) (make-object message% "" mpanel)
(make-object message% "Celsius" mpanel)) (make-object message% "Celsius" mpanel))
(send mpanel stretchable-width #f) (send mpanel stretchable-width #f)
(define panel (make-object vertical-panel% main-panel)) (define panel (make-object vertical-panel% main-panel))
(send panel set-alignment 'center 'center) (send panel set-alignment 'center 'center)
(define F-SLI-MIN -50) (define F-SLI-MIN -50)
(define F-SLI-MAX 250) (define F-SLI-MAX 250)
(define F-SLI-0 32) (define F-SLI-0 32)
(define SLI-MIN (f2c F-SLI-MIN)) (define SLI-MIN (f2c F-SLI-MIN))
(define SLI-MAX (f2c F-SLI-MAX)) (define SLI-MAX (f2c F-SLI-MAX))
;; sliderF : slider% ;; sliderF : slider%
;; to display the Fahrenheit temperature ;; to display the Fahrenheit temperature
(define sliderF (make-object slider% #f F-SLI-MIN F-SLI-MAX panel void F-SLI-0)) (define sliderF (make-object slider% #f F-SLI-MIN F-SLI-MAX panel void F-SLI-0))
(send sliderF min-width (- F-SLI-MAX F-SLI-MIN)) (send sliderF min-width (- F-SLI-MAX F-SLI-MIN))
;; sliderC : slider% ;; sliderC : slider%
;; to display the Celsius temperature ;; to display the Celsius temperature
(define sliderC (make-object scale% panel)) (define sliderC (make-object scale% panel))
(define _set-sliderC (send sliderC set-value (in-slider-range (f2c F-SLI-0)))) (define _set-sliderC (send sliderC set-value (in-slider-range (f2c F-SLI-0))))
(define button-panel (instantiate vertical-panel% () (define button-panel (instantiate vertical-panel% ()
(stretchable-width #f) (stretchable-width #f)
(stretchable-height #f) (stretchable-height #f)
(parent main-panel))) (parent main-panel)))
;; convert : button% ;; convert : button%
;; to convert fahrenheit to celsius ;; to convert fahrenheit to celsius
(define convert (make-object button% "Convert" button-panel slider-cb)) (define convert (make-object button% "Convert" button-panel slider-cb))
(define close (make-object button% "Close" button-panel (define close (make-object button% "Close" button-panel
(lambda (x e) (send frame show #f)))) (lambda (x e) (send frame show #f))))
;; convert-gui : (num -> num) -> void ;; convert-gui : (num -> num) -> void
;; to install f as the temperature converter ;; to install f as the temperature converter
;; effect: to create a window with two rulers for converting F to C ;; effect: to create a window with two rulers for converting F to C
(define (convert-gui f) (define (convert-gui f)
(check-proc 'convert-gui f 1 "convert-gui" "one argument") (check-proc 'convert-gui f 1 "convert-gui" "one argument")
(set! fahr->cel f) (set! fahr->cel f)
;; only initialize the slider based on the user's program ;; only initialize the slider based on the user's program
;; when there aren't any exceptions. ;; when there aren't any exceptions.
;; if there are exceptions, wait for the user to click ;; if there are exceptions, wait for the user to click
;; "convert" to see an error. ;; "convert" to see an error.
(with-handlers ([exn:fail? (lambda (x) (void))]) (with-handlers ([exn:fail? (lambda (x) (void))])
(send sliderC set-value (in-slider-range (fahr->cel F-SLI-0)))) (send sliderC set-value (in-slider-range (fahr->cel F-SLI-0))))
(send frame show #t)) (send frame show #t))
;; ============================================================================ ;; ============================================================================
;; convert-repl : (num -> num) -> void ;; convert-repl : (num -> num) -> void
;; to start a read-eval-print loop that reads numbers [temp in F], applies f, and prints ;; to start a read-eval-print loop that reads numbers [temp in F], applies f, and prints
;; the result; effects: read and write; ;; the result; effects: read and write;
;; exit on x as input ;; exit on x as input
(define (convert-repl f) (define (convert-repl f)
(check-proc 'convert-repl f 1 "convert-repl" "one argument") (check-proc 'convert-repl f 1 "convert-repl" "one argument")
(let repl () (let repl ()
(begin (begin
(printf "Enter Fahrenheit temperature and press <enter> [to exit, type x]: ") (printf "Enter Fahrenheit temperature and press <enter> [to exit, type x]: ")
(flush-output) (flush-output)
(let* ([ans (read)]) (let* ([ans (read)])
(cond (cond
[(or (eof-object? ans) (eq? ans 'x)) (void)] [(or (eof-object? ans) (eq? ans 'x)) (void)]
[(not (number? ans)) [(not (number? ans))
(printf "The input must be a number. Given: ~s~n" ans) (repl)] (printf "The input must be a number. Given: ~s~n" ans) (repl)]
[(number? ans) [(number? ans)
(let ([res (f ans)]) (let ([res (f ans)])
(if (number? res) (if (number? res)
(printf "~sF corresponds to ~sC~n" ans res) (printf "~sF corresponds to ~sC~n" ans res)
(error 'convert OUT-ERROR res)) (error 'convert OUT-ERROR res))
(repl))] (repl))]
[else (error 'convert "can't happen")]))))) [else (error 'convert "can't happen")])))))
;; ============================================================================ ;; ============================================================================
;; make-reader-for-f : (number -> number) -> ( -> void) ;; make-reader-for-f : (number -> number) -> ( -> void)
;; make-reader-for-f creates a function that reads numbers from a file ;; make-reader-for-f creates a function that reads numbers from a file
;; converts them accoring to f, and prints the results ;; converts them accoring to f, and prints the results
;; effect: if any of the S-expressions in the file aren't numbers or ;; effect: if any of the S-expressions in the file aren't numbers or
;; if any of f's results aren't numbers, ;; if any of f's results aren't numbers,
;; the function signals an error ;; the function signals an error
(define (make-reader-for f) (define (make-reader-for f)
(local ((define (read-until-eof) (local ((define (read-until-eof)
(let ([in (read)]) (let ([in (read)])
(cond
[(eof-object? in) (void)]
[(number? in) (begin (check-and-print (f in)) (read-until-eof))]
[else (error 'convert "The input must be a number. Given: ~e~n" in)])))
(define (check-and-print out)
(cond (cond
[(number? out) (printf "~s~n" out)] [(eof-object? in) (void)]
[else (error 'convert OUT-ERROR out)]))) [(number? in) (begin (check-and-print (f in)) (read-until-eof))]
read-until-eof)) [else (error 'convert "The input must be a number. Given: ~e~n" in)])))
(define (check-and-print out)
;; convert-file : str (num -> num) str -> void (cond
;; to read a number from file in, to convert it with f, and to write it to out [(number? out) (printf "~s~n" out)]
(define (convert-file in f out) [else (error 'convert OUT-ERROR out)])))
(check-arg 'convert-file (string? in) "string" "first" in) read-until-eof))
(check-arg 'convert-file (file-exists? in)
(format "name of existing file in ~a" (current-directory)) ;; convert-file : str (num -> num) str -> void
"first" in) ;; to read a number from file in, to convert it with f, and to write it to out
(check-proc 'convert-file f 1 "convert-file" "one argument") (define (convert-file in f out)
(check-arg 'convert-file (string? out) "string" "third" out) (check-arg 'convert-file (string? in) "string" "first" in)
(when (file-exists? out) (check-arg 'convert-file (file-exists? in)
(delete-file out)) (format "name of existing file in ~a" (current-directory))
(with-output-to-file out "first" in)
(lambda () (with-input-from-file in (make-reader-for f))))) (check-proc 'convert-file f 1 "convert-file" "one argument")
(check-arg 'convert-file (string? out) "string" "third" out)
(when (file-exists? out)
(delete-file out))
(with-output-to-file out
(lambda () (with-input-from-file in (make-reader-for f)))))
; ) ; )

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

206
collects/htdp/docs.ss
View File

@ -1,104 +1,106 @@
#cs(module docs mzscheme #lang scheme
(require htdp/error
mzlib/list
(lib "prim.ss" "lang"))
(provide
atom?
annotation?
end-annotation
write-file
)
(define-primitive atom? atom?/proc)
(define-primitive annotation? annotation?/proc)
(define-primitive end-annotation? end-annotation?/proc)
(define-primitive write-file write-file/proc)
;; mk-annotation : (require htdp/error
;; (str number[str-lenght] -> bool) -> (any-value -> bool) lang/prim
(define (mk-annotation test) mzlib/list)
(lambda (val)
(and (symbol? val) (provide
(let ((str (symbol->string val))) atom?
(test str (sub1 (string-length str))))))) annotation?
end-annotation
write-file
)
(define-primitive atom? atom?/proc)
(define-primitive annotation? annotation?/proc)
(define-primitive end-annotation? end-annotation?/proc)
(define-primitive write-file write-file/proc)
;; mk-annotation :
;; (str number[str-lenght] -> bool) -> (any-value -> bool)
(define (mk-annotation test)
(lambda (val)
(and (symbol? val)
(let ((str (symbol->string val)))
(test str (sub1 (string-length str)))))))
;; annotation? : any-value -> bool
(define annotation?/proc
(mk-annotation (lambda (str E);; str : string, E : integer
(and (> E 1)
(eqv? (string-ref str 0) #\<)
(eqv? (string-ref str E) #\>)))))
;; end-annotation? : any-value -> bool
(define end-annotation?/proc
(mk-annotation (lambda (str E);; str : string, E : integer
(and (> E 2)
(eqv? (string-ref str 0) #\<)
(eqv? (string-ref str 1) #\/)
(eqv? (string-ref str E) #\>)))))
;; end-annotation : annotation -> end-annotation
(define (end-annotation ann)
(check-arg 'end-annotation (annotation? ann) "annotation (str)" "first" ann)
(let ((str (symbol->string ann)))
(string->symbol
(string-append "</" (substring str 1 (string-length str))))))
;; line-breaking? : any-value -> bool
(define (line-breaking? x)
(and (annotation? x) (memq x LNBRK) #t))
(define LNBRK
(let ((x '(<html> <title> <body> <table> <ol> <li> <tr>)))
(append x (map end-annotation x))))
;; where to break lines in write-file
(define MAX-COLUMN 80)
;; atom? : TSV -> boolean
;; to determine whether x is a symbol, number, or string
(define (atom?/proc x)
(or (symbol? x) (number? x) (string? x)))
;; write-file : list-of-atom [file-name] -> void
;; effect: write los to file-name, in small column width
;; delete file-name if it exists
(define (write-file/proc los . file-name)
;; the-port : an output port,
;; determined from the optional second argument
(define the-port
(if (null? file-name)
(current-output-port)
(let ((the-name (car file-name)))
(check-arg 'write-file
(string? the-name)
"string" "(optional) second"
the-name)
(when (file-exists? the-name)
(delete-file the-name))
(open-output-file the-name))))
;; annotation? : any-value -> bool (check-arg 'write-file
(define annotation?/proc (and (list? los) (andmap atom? los)) "list of symbols" "first" los)
(mk-annotation (lambda (str E);; str : string, E : integer ;; --- the LOOP ---
(and (> E 1) (let loop ((i 0) (los los))
(eqv? (string-ref str 0) #\<) (if (null? los) (newline the-port)
(eqv? (string-ref str E) #\>))))) (let* ((wrd (first los))
(str (format "~a" wrd))
;; end-annotation? : any-value -> bool (j (+ i (string-length str) 1)))
(define end-annotation?/proc (cond
(mk-annotation (lambda (str E);; str : string, E : integer ((> i MAX-COLUMN) (newline the-port)
(and (> E 2) (loop 0 los))
(eqv? (string-ref str 0) #\<) ((line-breaking? wrd) (newline the-port)
(eqv? (string-ref str 1) #\/) (display wrd the-port)
(eqv? (string-ref str E) #\>))))) (newline the-port)
(loop j (rest los)))
;; end-annotation : annotation -> end-annotation
(define (end-annotation ann) (else (display wrd the-port)
(check-arg 'end-annotation (annotation? ann) "annotation (str)" "first" ann) (display #\SPACE the-port)
(let ((str (symbol->string ann))) (loop j (rest los)))))))
(string->symbol (when (cons? file-name)
(string-append "</" (substring str 1 (string-length str)))))) (close-output-port the-port))
#t)
;; line-breaking? : any-value -> bool
(define (line-breaking? x)
(and (annotation? x) (memq x LNBRK) #t))
(define LNBRK
(let ((x '(<html> <title> <body> <table> <ol> <li> <tr>)))
(append x (map end-annotation x))))
;; where to break lines in write-file
(define MAX-COLUMN 80)
;; atom? : TSV -> boolean
;; to determine whether x is a symbol, number, or string
(define (atom?/proc x)
(or (symbol? x) (number? x) (string? x)))
;; write-file : list-of-atom [file-name] -> void
;; effect: write los to file-name, in small column width
;; delete file-name if it exists
(define (write-file/proc los . file-name)
;; the-port : an output port,
;; determined from the optional second argument
(define the-port
(if (null? file-name)
(current-output-port)
(let ((the-name (car file-name)))
(check-arg 'write-file
(string? the-name)
"string" "(optional) second"
the-name)
(when (file-exists? the-name)
(delete-file the-name))
(open-output-file the-name))))
(check-arg 'write-file
(and (list? los) (andmap atom? los)) "list of symbols" "first" los)
;; --- the LOOP ---
(let loop ((i 0) (los los))
(if (null? los) (newline the-port)
(let* ((wrd (first los))
(str (format "~a" wrd))
(j (+ i (string-length str) 1)))
(cond
((> i MAX-COLUMN) (newline the-port)
(loop 0 los))
((line-breaking? wrd) (newline the-port)
(display wrd the-port)
(newline the-port)
(loop j (rest los)))
(else (display wrd the-port)
(display #\SPACE the-port)
(loop j (rest los)))))))
(when (cons? file-name)
(close-output-port the-port)))
)

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

@ -1,46 +1,48 @@
#cs(module draw-sig mzscheme #lang scheme
(provide core-draw^ draw^)
(require mzlib/unit) (provide core-draw^ draw^)
;; xxx-solid-rect cannot be called xxx-solid-rectangle because that (require mzlib/unit)
;; interferes with the existing xxx-solid-rectangle name in our unit
;; calculus -- mf ;; xxx-solid-rect cannot be called xxx-solid-rectangle because that
;; interferes with the existing xxx-solid-rectangle name in our unit
(define-signature core-draw^ ;; calculus -- mf
(start
start/cartesian-plane (define-signature core-draw^
stop (start
;; --- start/cartesian-plane
start-and-export stop
;; like start but also consumes a hashtable ;; ---
;; adds the procedures that can be called during a sequnce to the hashtable start-and-export
;; --- the following can be called during a draw sequence --- ;; like start but also consumes a hashtable
draw-circle ;; adds the procedures that can be called during a sequnce to the hashtable
draw-solid-disk ;; --- the following can be called during a draw sequence ---
draw-solid-rect draw-circle
draw-solid-line draw-solid-disk
draw-solid-string draw-solid-rect
clear-circle draw-solid-line
clear-solid-disk draw-solid-string
clear-solid-rect clear-circle
clear-solid-line clear-solid-disk
clear-solid-string clear-solid-rect
clear-all clear-solid-line
;; --- stupid stuff --- clear-solid-string
sleep-for-a-while clear-all
wait-for-mouse-click ; -> posn ;; --- stupid stuff ---
get-key-event ; -> (union #f char symbol) sleep-for-a-while
get-mouse-event ; -> (union #f posn) wait-for-mouse-click ; -> posn
;; get-key-event ; -> (union #f char symbol)
;; "hidden" access to viewports (for htdc/[i]draw mostly) get-mouse-event ; -> (union #f posn)
get-@VP ; -> Viewport ;;
begin-draw-sequence ; Viewport Viewport -> #t ;; "hidden" access to viewports (for htdc/[i]draw mostly)
end-draw-sequence ; -> #t get-@VP ; -> Viewport
;; begin-draw-sequence ; Viewport Viewport -> #t
big-bang ; World -> true end-draw-sequence ; -> #t
on-key-event ; (union char symbol) World -> World ;;
on-tick-event ; World -> World big-bang ; World -> true
end-of-time ; -> World on-key-event ; (union char symbol) World -> World
)) on-tick-event ; World -> World
end-of-time ; -> World
(define-signature draw^ extends core-draw^ ())) ))
(define-signature draw^ extends core-draw^ ())

43
collects/htdp/draw.ss
View File

@ -1,23 +1,24 @@
#cs(module draw mzscheme #lang scheme
(require htdp/big-draw
htdp/draw-sig
mzlib/unit)
(define-syntax (draw s) (require htdp/big-draw
(syntax-case s (produce) htdp/draw-sig
[(_ stmt ... produce exp) (syntax (begin (and stmt ...) exp))] mzlib/unit)
[(_ stmt ... produce)
(raise-syntax-error #f "produce must be followed by an expression" s)]
[(_ stmt ... produce exp exp2)
(raise-syntax-error #f "produce must be followed by exactly one expression" s)]
[(_ stmt ... produce exp exp2 exp3)
(raise-syntax-error #f "produce must be followed by exactly one expression" s)]
[(_ stmt ...)
(raise-syntax-error #f "use drawing instructions between _draw_ and _produce_ and an expression behind produce" s)]
))
(provide
draw ;; (draw <expression> ... produce <expression>)
)
(provide-signature-elements draw^)) (define-syntax (draw s)
(syntax-case s (produce)
[(_ stmt ... produce exp) (syntax (begin (and stmt ...) exp))]
[(_ stmt ... produce)
(raise-syntax-error #f "produce must be followed by an expression" s)]
[(_ stmt ... produce exp exp2)
(raise-syntax-error #f "produce must be followed by exactly one expression" s)]
[(_ stmt ... produce exp exp2 exp3)
(raise-syntax-error #f "produce must be followed by exactly one expression" s)]
[(_ stmt ...)
(raise-syntax-error #f "use drawing instructions between _draw_ and _produce_ and an expression behind produce" s)]
))
(provide
draw ;; (draw <expression> ... produce <expression>)
)
(provide-signature-elements draw^)

1528
collects/htdp/elevator.ss
View File

File diff suppressed because it is too large Load Diff

173
collects/htdp/graphing.ss
View File

@ -1,86 +1,87 @@
(module graphing mzscheme #lang scheme
(require htdp/error
mzlib/unit (require htdp/error
htdp/draw-sig lang/posn
htdp/big-draw lang/prim
(lib "posn.ss" "lang") mzlib/unit
(lib "prim.ss" "lang")) htdp/draw-sig
htdp/big-draw)
(provide-signature-elements draw^)
(provide-signature-elements draw^)
(provide
graph-fun (provide
graph-line graph-fun
) graph-line
)
(define-higher-order-primitive graph-line graph-line/proc (f _))
(define-higher-order-primitive graph-fun graph-fun/proc (f _)) (define-higher-order-primitive graph-line graph-line/proc (f _))
(define-higher-order-primitive graph-fun graph-fun/proc (f _))
;; --------------------------------------------------------------------------
;; --------------------------------------------------------------------------
;; make-graph : sym -> void
;; effect: set up pasteboard for drawing functions ;; make-graph : sym -> void
;; between [0,10] and [0,10] on x/y axis ;; effect: set up pasteboard for drawing functions
(define (make-graph name) ;; between [0,10] and [0,10] on x/y axis
(start EAST SOUTH) (define (make-graph name)
(let* ([vp+pm #cs(get-@VP)] (start EAST SOUTH)
[vp (car vp+pm)]) (let* ([vp+pm #cs(get-@VP)]
(draw-solid-line ORIGIN X-AXIS 'blue) [vp (car vp+pm)])
((draw-string vp) (make-posn (+ OFFSET 10) (+ OFFSET 10)) "Y-AXIS") (draw-solid-line ORIGIN X-AXIS 'blue)
(draw-solid-line ORIGIN Y-AXIS 'blue) ((draw-string vp) (make-posn (+ OFFSET 10) (+ OFFSET 10)) "Y-AXIS")
((draw-string vp) (make-posn (- EAST 100) (- SOUTH 15)) "X-AXIS"))) (draw-solid-line ORIGIN Y-AXIS 'blue)
((draw-string vp) (make-posn (- EAST 100) (- SOUTH 15)) "X-AXIS")))
;; (num -> num) symbol -> true
;; effect: draw function graph for x in [0,10] at delta = .1 ;; (num -> num) symbol -> true
(define (graph-line/proc f color) ;; effect: draw function graph for x in [0,10] at delta = .1
(check 'graph-line f color) (define (graph-line/proc f color)
(let ((p1 (translate (make-posn 0 (f 0)))) (check 'graph-line f color)
(p2 (translate (make-posn 10 (f 10))))) (let ((p1 (translate (make-posn 0 (f 0))))
(draw-solid-line p1 p2 color))) (p2 (translate (make-posn 10 (f 10)))))
(draw-solid-line p1 p2 color)))
;; (num -> num) symbol -> true
;; effect: draw function graph for x in [0,10] at delta = .1 ;; (num -> num) symbol -> true
(define (graph-fun/proc f color) ;; effect: draw function graph for x in [0,10] at delta = .1
(check 'graph-fun f color) (define (graph-fun/proc f color)
(draw-tab (map translate (tabulate f 0 10 DELTA)) color)) (check 'graph-fun f color)
(draw-tab (map translate (tabulate f 0 10 DELTA)) color))
;; check : tst tst tst -> void
(define (check tag f color) ;; check : tst tst tst -> void
(check-proc tag f 1 '1st "one argument") (define (check tag f color)
(check-arg tag (symbol? color) 'symbol '2nd color)) (check-proc tag f 1 '1st "one argument")
(check-arg tag (symbol? color) 'symbol '2nd color))
;; tabulate : (num -> num) num num num -> (list-of (make-posn num num))
(define (tabulate f left right delta) ;; tabulate : (num -> num) num num num -> (list-of (make-posn num num))
(if (> left right) null (define (tabulate f left right delta)
(cons (make-posn left (f left)) (if (> left right) null
(tabulate f (+ left delta) right delta)))) (cons (make-posn left (f left))
(tabulate f (+ left delta) right delta))))
;; translate : posn -> posn
(define (translate p) ;; translate : posn -> posn
(make-posn (+ (* FACT (/ 1 DELTA) (posn-x p)) OFFSET) (define (translate p)
(- (- SOUTH (* FACT (/ 1 DELTA) (posn-y p))) OFFSET))) (make-posn (+ (* FACT (/ 1 DELTA) (posn-x p)) OFFSET)
(- (- SOUTH (* FACT (/ 1 DELTA) (posn-y p))) OFFSET)))
;; draw-tab : (list-of (make-posn num num)) symbol -> true
(define (draw-tab lop color) ;; draw-tab : (list-of (make-posn num num)) symbol -> true
(for-each (lambda (p) (draw-solid-disk p DOT color)) lop) (define (draw-tab lop color)
(unless (or (null? lop) (null? (cdr lop))) (for-each (lambda (p) (draw-solid-disk p DOT color)) lop)
(let loop ([f (car lop)][r (cdr lop)]) (unless (or (null? lop) (null? (cdr lop)))
(unless (null? r) (let loop ([f (car lop)][r (cdr lop)])
(let ([next (car r)]) (unless (null? r)
(draw-solid-line f next color) (let ([next (car r)])
(loop next (cdr r)))))) (draw-solid-line f next color)
#t) (loop next (cdr r))))))
#t)
(define EAST 400)
(define SOUTH EAST) (define EAST 400)
(define FACT (/ (- EAST 100) 100)) (define SOUTH EAST)
(define OFFSET 10.) (define FACT (/ (- EAST 100) 100))
(define ORIGIN (make-posn OFFSET (- SOUTH OFFSET))) (define OFFSET 10.)
(define X-AXIS (make-posn OFFSET OFFSET)) (define ORIGIN (make-posn OFFSET (- SOUTH OFFSET)))
(define Y-AXIS (make-posn (- EAST OFFSET) (- SOUTH OFFSET))) (define X-AXIS (make-posn OFFSET OFFSET))
(define GRAPH-COLOR 'red) (define Y-AXIS (make-posn (- EAST OFFSET) (- SOUTH OFFSET)))
(define GRAPH-COLOR 'red)
(define DELTA .1)
(define DOT 1) (define DELTA .1)
(define DOT 1)
(make-graph 'ok))
(make-graph 'ok)

360
collects/htdp/guess.ss
View File

@ -1,63 +1,63 @@
#cs(module guess mzscheme #lang scheme/gui
(require htdp/error
mzlib/unitsig (require htdp/error
mzlib/etc lang/prim
mzlib/class mzlib/unitsig
mzlib/list mzlib/etc
mred mzlib/class
(lib "prim.ss" "lang")) mzlib/list)
(provide (provide
guess-with-gui guess-with-gui
guess-with-gui-3 guess-with-gui-3
guess-with-gui-list guess-with-gui-list
) )
(define-higher-order-primitive guess-with-gui guess-with-gui/proc (define-higher-order-primitive guess-with-gui guess-with-gui/proc
(check-guess)) (check-guess))
(define-higher-order-primitive guess-with-gui-3 guess-with-gui-3/proc (define-higher-order-primitive guess-with-gui-3 guess-with-gui-3/proc
(check-guess)) (check-guess))
(define-higher-order-primitive guess-with-gui-list guess-with-gui-list/proc (define-higher-order-primitive guess-with-gui-list guess-with-gui-list/proc
(_ check-guess-list)) (_ check-guess-list))
; ;
; ;
; ;
; ;;;; ; ;;;;
; ; ; ; ; ;
; ; ; ; ; ; ; ;
; ; ;;;; ; ;;; ;;;; ;;;; ;;; ; ;;; ;;;; ;;;; ; ; ;;;; ; ;;; ;;;; ;;;; ;;; ; ;;; ;;;; ;;;;
; ; ; ; ;; ; ; ; ; ; ;; ; ; ; ; ; ; ; ;; ; ; ; ; ; ;; ; ; ;
; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ;
; ; ; ; ; ; ;;; ; ;;;; ; ; ; ;;; ; ; ; ; ; ; ;;; ; ;;;; ; ; ; ;;;
; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ;
; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ;
; ;;;; ;;;; ; ; ;;;; ;; ;;;;; ; ; ;; ;;;; ; ;;;; ;;;; ; ; ;;;; ;; ;;;;; ; ; ;; ;;;;
; ;
; ;
; ;
(define TITLE "Bobby's Game") (define TITLE "Bobby's Game")
(define WELCOME "Welcome to Bobby's Game")
(define DIGITS (build-list 10 (lambda (i) (number->string i))))
(define BUT-SIZE 10)
(define WIDTH BUT-SIZE) ; (* 5 BUT-SIZE)
(define HIGHT BUT-SIZE)
(define STOPS (list 'Perfect 'perfect 'perfect! 'perfect_guess))
(define TRUMPET
(make-object bitmap%
(build-path (collection-path "icons") "trumpet.xbm")
'xbm))
(define WELCOME "Welcome to Bobby's Game")
(define DIGITS (build-list 10 (lambda (i) (number->string i))))
(define BUT-SIZE 10)
(define WIDTH BUT-SIZE) ; (* 5 BUT-SIZE)
(define HIGHT BUT-SIZE)
(define STOPS (list 'Perfect 'perfect 'perfect! 'perfect_guess))
(define TRUMPET
(make-object bitmap%
(build-path (collection-path "icons") "trumpet.xbm")
'xbm))
; ;
; ;
; ;
@ -75,9 +75,9 @@
; ;
; ;
#| ------------------------------------------------------------------------ #| ------------------------------------------------------------------------
------------------------------------------------------------------ ------------------------------------------------------------------
| |
@ -92,126 +92,126 @@
the first one with all the colors (as buttons) the first one with all the colors (as buttons)
the second is a sequence of colored buttons the second is a sequence of colored buttons
|# |#
;; ------------------------------------------------------------------------
;; Setting up the buttons
(define (init-game number-of-digits convert check-guess)
(local ((define GUESS number-of-digits)
;; layout ;; ------------------------------------------------------------------------
(define frame (make-object frame% TITLE #f WIDTH HIGHT)) ;; Setting up the buttons
(define verti (make-object vertical-panel% frame)) (define (init-game number-of-digits convert check-guess)
(local ((define GUESS number-of-digits)
;; layout
(define frame (make-object frame% TITLE #f WIDTH HIGHT))
(define verti (make-object vertical-panel% frame))
(define panel
(let ([panel (make-object horizontal-panel% verti)])
(send panel set-alignment 'center 'center)
panel))
(define guess-panel
(let ([guess-panel (make-object horizontal-panel% verti)])
(send guess-panel set-alignment 'center 'center)
guess-panel))
(define message-panel
(let ([message-panel (make-object horizontal-panel% verti)])
(send message-panel set-alignment 'center 'center)
message-panel))
;; message : a field for displaying basic messages about state of game
(define message (make-object message% WELCOME message-panel))
;; guesses: status vector, record the choice of digit when set
(define guesses (make-vector GUESS 0))
;; the-number : randomly chosen
(define the-number 0)
;; new-game : -> void
;; effect: set up new target number, send message that game's ready
(define (new-game)
(set! the-number (random (expt 10 GUESS)))
(send message-panel change-children (lambda (x) (list message)))
(send message set-label WELCOME))
;; call-back : _ _ -> void
;; check status and announce result, possibly set winner
(define (call-back x y)
(let ((response (check-guess (convert guesses) the-number)))
(send message set-label (symbol->string response))
(when (memq response STOPS)
;; announce winner and set up new game
(send message-panel change-children (lambda (x) empty))
(make-object message% TRUMPET message-panel)
(make-object button% "New Game?" message-panel
(lambda (x y) (new-game)))
(make-object button% "CLOSE?" message-panel
(lambda (x y) (send frame show #f)))))))
;; making the menu choices
(for-each (lambda (i)
(local ((define n (- GUESS i 1)))
(make-object choice% #f DIGITS panel
(lambda (x y)
(vector-set! guesses n (send x get-selection))))))
(build-list GUESS identity))
(new-game)
(make-object button% "Check" guess-panel call-back)
(send frame show #t)
#t))
(define panel
(let ([panel (make-object horizontal-panel% verti)])
(send panel set-alignment 'center 'center)
panel))
(define guess-panel
(let ([guess-panel (make-object horizontal-panel% verti)])
(send guess-panel set-alignment 'center 'center)
guess-panel))
(define message-panel
(let ([message-panel (make-object horizontal-panel% verti)])
(send message-panel set-alignment 'center 'center)
message-panel))
;; message : a field for displaying basic messages about state of game
(define message (make-object message% WELCOME message-panel))
;; guesses: status vector, record the choice of digit when set
(define guesses (make-vector GUESS 0))
;; the-number : randomly chosen
(define the-number 0)
;; new-game : -> void ;
;; effect: set up new target number, send message that game's ready ;
(define (new-game) ;
(set! the-number (random (expt 10 GUESS))) ; ;;;;;
(send message-panel change-children (lambda (x) (list message))) ; ;
(send message set-label WELCOME)) ; ; ;
; ; ; ; ; ;;; ;;;; ; ;;;;;; ;;;;
; ;;;; ; ; ;; ; ; ; ;; ; ;
; ; ; ; ; ; ; ; ; ; ;
; ; ; ; ; ; ; ; ; ;;;
; ; ; ; ; ; ; ; ; ; ;
; ; ; ; ;; ; ; ; ; ; ;
; ;;;;; ; ; ; ;;; ;;;; ; ;; ;;;;
; ;
; ;
; ;
;; convert : (vector DIGIT) -> number
;; to convert a vector of digits into a number
;; 0-th digit is right-most digit in number,
;; N-th digit is left-most digit in number
(define (convert guesses:vec)
(local ((define (convert digits)
(cond
((empty? digits) 0)
(else (+ (first digits) (* (convert (rest digits)) 10))))))
(convert (vector->list guesses:vec))))
;; guess-with-gui : (num num -> num) -> void
;; effect: init target, init frame, set the check-guess function and show the frame
(define (guess-with-gui/proc cg)
(check-proc 'guess-with-gui cg 2 'first "two arguments")
(init-game 5 convert cg))
;; guess-with-gui-3 : (digit digit digit num -> num) -> void
;; effect: init target, init frame, set the check-guess function and show the frame
(define (guess-with-gui-3/proc cg)
(check-proc 'guess-with-gui-3 cg (+ 3 1) 'first "four arguments")
(init-game 3 vector->list
(lambda (lod target) (apply cg (append lod (list target))))))
;; guess-with-gui-list : num ((listof digit) num -> num) -> void
;; effect: init target, init frame, set the check-guess function and show the frame
(define (guess-with-gui-list/proc n cg)
(check-arg 'guess-with-gui-list
(and (number? n) (integer? n) (>= n 1)) "positive integer" '1st n)
(check-proc 'guess-with-gui-list cg 2 'first "two arguments")
(unless (<= (expt 10 n) 2147483647)
(error 'guess-with-gui-list "the given number of digits (~a) is too large" n))
(init-game n vector->list cg))
;; call-back : _ _ -> void
;; check status and announce result, possibly set winner
(define (call-back x y)
(let ((response (check-guess (convert guesses) the-number)))
(send message set-label (symbol->string response))
(when (memq response STOPS)
;; announce winner and set up new game
(send message-panel change-children (lambda (x) empty))
(make-object message% TRUMPET message-panel)
(make-object button% "New Game?" message-panel
(lambda (x y) (new-game)))
(make-object button% "CLOSE?" message-panel
(lambda (x y) (send frame show #f)))))))
;; making the menu choices
(for-each (lambda (i)
(local ((define n (- GUESS i 1)))
(make-object choice% #f DIGITS panel
(lambda (x y)
(vector-set! guesses n (send x get-selection))))))
(build-list GUESS identity))
(new-game)
(make-object button% "Check" guess-panel call-back)
(send frame show #t)
#t))
;
;
;
; ;;;;;
; ;
; ; ;
; ; ; ; ; ;;; ;;;; ; ;;;;;; ;;;;
; ;;;; ; ; ;; ; ; ; ;; ; ;
; ; ; ; ; ; ; ; ; ; ;
; ; ; ; ; ; ; ; ; ;;;
; ; ; ; ; ; ; ; ; ; ;
; ; ; ; ;; ; ; ; ; ; ;
; ;;;;; ; ; ; ;;; ;;;; ; ;; ;;;;
; ;
; ;
; ;
;; convert : (vector DIGIT) -> number
;; to convert a vector of digits into a number
;; 0-th digit is right-most digit in number,
;; N-th digit is left-most digit in number
(define (convert guesses:vec)
(local ((define (convert digits)
(cond
((empty? digits) 0)
(else (+ (first digits) (* (convert (rest digits)) 10))))))
(convert (vector->list guesses:vec))))
;; guess-with-gui : (num num -> num) -> void
;; effect: init target, init frame, set the check-guess function and show the frame
(define (guess-with-gui/proc cg)
(check-proc 'guess-with-gui cg 2 'first "two arguments")
(init-game 5 convert cg))
;; guess-with-gui-3 : (digit digit digit num -> num) -> void
;; effect: init target, init frame, set the check-guess function and show the frame
(define (guess-with-gui-3/proc cg)
(check-proc 'guess-with-gui-3 cg (+ 3 1) 'first "four arguments")
(init-game 3 vector->list
(lambda (lod target) (apply cg (append lod (list target))))))
;; guess-with-gui-list : num ((listof digit) num -> num) -> void
;; effect: init target, init frame, set the check-guess function and show the frame
(define (guess-with-gui-list/proc n cg)
(check-arg 'guess-with-gui-list
(and (number? n) (integer? n) (>= n 1)) "positive integer" '1st n)
(check-proc 'guess-with-gui-list cg 2 'first "two arguments")
(unless (<= (expt 10 n) 2147483647)
(error 'guess-with-gui-list "the given number of digits (~a) is too large" n))
(init-game n vector->list cg)))

338
collects/htdp/gui.ss
View File

@ -1,118 +1,116 @@
;; 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 (require htdp/error
(module gui mzscheme lang/prim
(require htdp/error mzlib/class
mred mzlib/list
mzlib/class mzlib/etc)
mzlib/list
mzlib/etc
(lib "prim.ss" "lang"))
(provide-primitives
create-window ; (listof (listof GUI-ITEM)) -> window
show-window ; window -> true
hide-window ; window -> true
make-text ; Str -> GUI-ITEM
text-contents ; GUI-ITEM[text%] -> Str
make-choice ; (listof Str) -> GUI-ITEM
choice-index ; GUI-ITEM[choice%] -> Str
; make-button ; Str (Event% -> Boolean) -> GUI-ITEM
make-message ; Str -> GUI-ITEM
draw-message ; GUI-ITEM[message%] Str -> true
)
(provide-higher-order-primitive make-button (_ call-back))
#| ------------------------------------------------------------------ (provide-primitives
window? ; any/c -> boolean
create-window ; (listof (listof GUI-ITEM)) -> window
show-window ; window -> true
hide-window ; window -> true
make-text ; Str -> GUI-ITEM
text-contents ; GUI-ITEM[text%] -> Str
make-choice ; (listof Str) -> GUI-ITEM
choice-index ; GUI-ITEM[choice%] -> Str
; make-button ; Str (Event% -> Boolean) -> GUI-ITEM
make-message ; Str -> GUI-ITEM
draw-message ; GUI-ITEM[message%] Str -> true
)
(provide-higher-order-primitive make-button (_ call-back))
#| ------------------------------------------------------------------
Students build a window from a "matrix" list of GUI-ITEMS. Students build a window from a "matrix" list of GUI-ITEMS.
To build GUI-ITEMs, they need to use make-text, make-choice, To build GUI-ITEMs, they need to use make-text, make-choice,
make-button, make-choice, or make-message. A GUI-ITEM can be make-button, make-choice, or make-message. A GUI-ITEM can be
added to the window only once. added to the window only once.
|# |#
;; INFRASTRUCTURE OPERATIONS:
;; ------------------------------------------------------------------
(define-struct window (get-frame)) ;; INFRASTRUCTURE OPERATIONS:
;; ------------------------------------------------------------------
;; show-window : -> true
;; effect: to show the window
(define (show-window w)
(check-arg 'show-window (window? w) "window" "its" w)
(send ((window-get-frame w)) show true)
true)
;; hide-window : X -> true
;; effect: to hide the window
(define (hide-window w)
(check-arg 'hide-window (window? w) "window" "its" w)
(send ((window-get-frame w)) show false)
true)
;; MAKING ITEMS:
;; ------------------------------------------------------------------
(define-struct gui-item (builder))
;; A gui-item[C < control%] is a structure: (make-gui-item f)
;; where f is a function: (panel% -> C)
;; create-gui-item : ((union panel% #f) -> C[< control%])
;; to create a memoizing gui-item
;; create-window is the only caller that can pass in a panel
;; exceptions: ;; if the gui-item is already "panel'ed", error
;; all other callers must pass in #f
(define (create-gui-item builder)
(let ([C false])
(make-gui-item
(lambda (p)
(cond
[(and p C)
(error 'create-window "item added to window twice")]
[(and p (not C)) (set! C (builder p)) C]
[(and (not p) C) C]
[(and (not p) (not C))
(error 'gui "gui-items must be added to window before use (see create-window)")])))))
;; create-window : (listof (listof gui-item)) -> true
;; to add gui-items to the window and to show window
(define (create-window loi)
(check-list-list 'create-window (listoflistof? gui-item? "gui-item" loi) "gui-items" loi)
(let ([the-frame (make-object frame% "GUI" false 10 10)]) (define-struct window (get-frame))
(for-each (lambda (loi)
(let ((p (make-object horizontal-pane% the-frame))) ;; show-window : -> true
(send p set-alignment 'center 'center) ;; effect: to show the window
(for-each (lambda (i) ((gui-item-builder i) p)) loi))) (define (show-window w)
loi) (check-arg 'show-window (window? w) "window" "its" w)
(let ([w (make-window (lambda () the-frame))]) (send ((window-get-frame w)) show true)
(show-window w) true)
w)))
;; hide-window : X -> true
;; effect: to hide the window
(define (hide-window w)
(check-arg 'hide-window (window? w) "window" "its" w)
(send ((window-get-frame w)) show false)
true)
;; MAKING ITEMS:
;; ------------------------------------------------------------------
(define-struct gui-item (builder))
;; A gui-item[C < control%] is a structure: (make-gui-item f)
;; where f is a function: (panel% -> C)
;; create-gui-item : ((union panel% #f) -> C[< control%])
;; to create a memoizing gui-item
;; create-window is the only caller that can pass in a panel
;; exceptions: ;; if the gui-item is already "panel'ed", error
;; all other callers must pass in #f
(define (create-gui-item builder)
(let ([C false])
(make-gui-item
(lambda (p)
(cond
[(and p C)
(error 'create-window "item added to window twice")]
[(and p (not C)) (set! C (builder p)) C]
[(and (not p) C) C]
[(and (not p) (not C))
(error 'gui "gui-items must be added to window before use (see create-window)")])))))
;; create-window : (listof (listof gui-item)) -> true
;; to add gui-items to the window and to show window
(define (create-window loi)
(check-list-list 'create-window (listoflistof? gui-item? "gui-item" loi) "gui-items" loi)
;; (_ -> Boolean) String X -> (union String true) (let ([the-frame (make-object frame% "GUI" false 10 10)])
(define (listoflistof? pred? pred given) (for-each (lambda (loi)
(cond (let ((p (make-object horizontal-pane% the-frame)))
[(not (list? given)) (format NONLIST given)] (send p set-alignment 'center 'center)
[(find-non list? given) (for-each (lambda (i) ((gui-item-builder i) p)) loi)))
=> (lambda (non-list) loi)
(format NONLISTLIST non-list))] (let ([w (make-window (lambda () the-frame))])
[(ormap identity (map (lambda (ll) (find-non pred? ll)) given)) (show-window w)
=> (lambda (non-x) w)))
(format NONX pred non-x))]
[else #t])) ;; (_ -> Boolean) String X -> (union String true)
(define (listoflistof? pred? pred given)
(define NONLIST "list expected, given: ~e") (cond
(define NONLISTLIST "list of lists expected, given list with ~e") [(not (list? given)) (format NONLIST given)]
(define NONX "list of lists of ~a expected, given list of lists with ~e") [(find-non list? given)
=> (lambda (non-list)
(format NONLISTLIST non-list))]
#| Tests ------------------------------------------------------------------ [(ormap identity (map (lambda (ll) (find-non pred? ll)) given))
=> (lambda (non-x)
(format NONX pred non-x))]
[else #t]))
(define NONLIST "list expected, given: ~e")
(define NONLISTLIST "list of lists expected, given list with ~e")
(define NONX "list of lists of ~a expected, given list of lists with ~e")
#| Tests ------------------------------------------------------------------
(listoflistof? number? "number" '((1 2 3) (4 5 6))) (listoflistof? number? "number" '((1 2 3) (4 5 6)))
(string=? (format NONX "number" 'a) (string=? (format NONX "number" 'a)
@ -121,74 +119,74 @@
(string=? (format NONLISTLIST 1) (string=? (format NONLISTLIST 1)
(listoflistof? number? "number" '(1 (2 3) (4 5 6)))) (listoflistof? number? "number" '(1 (2 3) (4 5 6))))
|# |#
;; make-text : str -> gui-item ;; make-text : str -> gui-item
;; to create a text-item with label lbl ;; to create a text-item with label lbl
(define (make-text lbl) (define (make-text lbl)
(check-arg 'make-text (string? lbl) "string" "first" lbl) (check-arg 'make-text (string? lbl) "string" "first" lbl)
(create-gui-item (create-gui-item
(lambda (the-panel) (lambda (the-panel)
(make-object text-field% lbl the-panel void)))) (make-object text-field% lbl the-panel void))))
;; make-message : str -> gui-item ;; make-message : str -> gui-item
;; to create a message-item with current contents txt ;; to create a message-item with current contents txt
(define (make-message txt) (define (make-message txt)
(check-arg 'make-message (string? txt) "string" "first" txt) (check-arg 'make-message (string? txt) "string" "first" txt)
(create-gui-item (create-gui-item
(lambda (the-panel) (lambda (the-panel)
(new message% [label txt] [parent the-panel] [stretchable-width #t])))) (new message% [label txt] [parent the-panel] [stretchable-width #t]))))
;; make-button : str (event% -> boolean) -> gui-item ;; make-button : str (event% -> boolean) -> gui-item
;; to create a button-item with label and call-back function ;; to create a button-item with label and call-back function
(define (make-button label call-back) (define (make-button label call-back)
(check-arg 'make-button (string? label) "string" 'first label) (check-arg 'make-button (string? label) "string" 'first label)
(check-proc 'make-button call-back 1 'second "1 argument") (check-proc 'make-button call-back 1 'second "1 argument")
(create-gui-item (create-gui-item
(lambda (the-panel) (lambda (the-panel)
(make-object button% label (make-object button% label
the-panel the-panel
(lambda (b e) (lambda (b e)
(check-result 'button-callback boolean? "Boolean" (call-back e))))))) (check-result 'button-callback boolean? "Boolean" (call-back e)))))))
;; make-choice : (listof str) -> gui-item ;; make-choice : (listof str) -> gui-item
;; to create a choice-item that permits users to choose from the ;; to create a choice-item that permits users to choose from the
;; alternatives on loc ;; alternatives on loc
(define (make-choice loc) (define (make-choice loc)
(check-arg 'make-choice (and (list? loc) (andmap string? loc)) "list of strings" "first" loc) (check-arg 'make-choice (and (list? loc) (andmap string? loc)) "list of strings" "first" loc)
(create-gui-item (create-gui-item
(lambda (the-panel) (lambda (the-panel)
(make-object choice% "" loc the-panel void)))) (make-object choice% "" loc the-panel void))))
;; DISPLAYING MESSAGES: ;; DISPLAYING MESSAGES:
;; ------------------------------------------------------------------ ;; ------------------------------------------------------------------
;; draw-message : gui-item[message%] str -> true ;; draw-message : gui-item[message%] str -> true
;; to change the current contents of a message field ;; to change the current contents of a message field
(define (draw-message msg txt) (define (draw-message msg txt)
(check-arg 'draw-message (gui-item? msg) "gui-item" "first" msg) (check-arg 'draw-message (gui-item? msg) "gui-item" "first" msg)
(check-arg 'draw-message (string? txt) "string" "second" txt) (check-arg 'draw-message (string? txt) "string" "second" txt)
(let* ([o ((gui-item-builder msg) #f)]) (let* ([o ((gui-item-builder msg) #f)])
(when (<= (send o min-width) (string-length txt)) (when (<= (send o min-width) (string-length txt))
(let*-values ;; MF: I couldn't think of a better way of doing this (let*-values ;; MF: I couldn't think of a better way of doing this
([(m) (new message% [parent (new frame% [label "hello"])][label txt])] ([(m) (new message% [parent (new frame% [label "hello"])][label txt])]
[(x y) (send m get-graphical-min-size)]) [(x y) (send m get-graphical-min-size)])
(send o min-width x))) (send o min-width x)))
(send o set-label txt) (send o set-label txt)
true)) true))
;; PROBING ITEMS: ;; PROBING ITEMS:
;; ------------------------------------------------------------------ ;; ------------------------------------------------------------------
;; text-contents : gui-item[text-field%] -> str ;; text-contents : gui-item[text-field%] -> str
;; to determine the contents of a text-item ;; to determine the contents of a text-item
(define (text-contents a-text-gui) (define (text-contents a-text-gui)
(check-arg 'text-contents (gui-item? a-text-gui) "gui-item" "first" a-text-gui) (check-arg 'text-contents (gui-item? a-text-gui) "gui-item" "first" a-text-gui)
(send ((gui-item-builder a-text-gui) #f) get-value)) (send ((gui-item-builder a-text-gui) #f) get-value))
;; choice-index : gui-item[choice%] -> number ;; choice-index : gui-item[choice%] -> number
;; to determine which choice is currently selected in a choice-item ;; to determine which choice is currently selected in a choice-item
(define (choice-index a-choice) (define (choice-index a-choice)
(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))
)

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

@ -1,52 +1,53 @@
(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)
(define-primitive go go/proc)
(define-primitive go go/proc)
#| ------------------------------------------------------------------------
#| ------------------------------------------------------------------------
draw-next-part : draw-next-part :
{ 'noose 'head 'right-arm 'left-arm 'body 'right-leg 'left-leg } -> #t { 'noose 'head 'right-arm 'left-arm 'body 'right-leg 'left-leg } -> #t
result: #t if things went okay result: #t if things went okay
effect: to draw the specified body part in a canvas of size W x H effect: to draw the specified body part in a canvas of size W x H
credit: John Clements credit: John Clements
|# |#
(define (draw-next-part body-part) (define (draw-next-part body-part)
(cond ((eq? body-part 'body) (cond ((eq? body-part 'body)
(draw-solid-line (make-posn 100 60) (make-posn 100 130) 'black)) (draw-solid-line (make-posn 100 60) (make-posn 100 130) 'black))
((eq? body-part 'right-leg) ((eq? body-part 'right-leg)
(draw-solid-line (make-posn 100 130) (make-posn 30 170) 'black)) (draw-solid-line (make-posn 100 130) (make-posn 30 170) 'black))
((eq? body-part 'left-leg) ((eq? body-part 'left-leg)
(draw-solid-line (make-posn 100 130) (make-posn 170 170) 'black)) (draw-solid-line (make-posn 100 130) (make-posn 170 170) 'black))
((eq? body-part 'right-arm) ((eq? body-part 'right-arm)
(draw-solid-line (make-posn 100 75) (make-posn 40 65) 'black)) (draw-solid-line (make-posn 100 75) (make-posn 40 65) 'black))
((eq? body-part 'left-arm) ((eq? body-part 'left-arm)
(draw-solid-line (make-posn 100 75) (make-posn 160 65) 'black)) (draw-solid-line (make-posn 100 75) (make-posn 160 65) 'black))
((eq? body-part 'head) ((eq? body-part 'head)
(draw-circle (make-posn 100 50) 10 'black)) (draw-circle (make-posn 100 50) 10 'black))
((eq? body-part 'noose) ((eq? body-part 'noose)
(and (and
(draw-solid-line (make-posn 100 30) (make-posn 100 10) 'black) (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 100 10) (make-posn 0 10) 'black)
(draw-solid-line (make-posn 115 35) (make-posn 123 43) '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 123 35) (make-posn 115 43) 'black)
(draw-solid-line (make-posn 131 40) (make-posn 139 48) '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-solid-line (make-posn 139 40) (make-posn 131 48) 'black)
(draw-circle (make-posn 120 50) 30 'red))))) (draw-circle (make-posn 120 50) 30 'red)))))
;; reveal-list : list-of-letters list-of-letters letter -> list-of-letters ;; reveal-list : list-of-letters list-of-letters letter -> list-of-letters
(define (reveal-list l1 l2 gu) (define (reveal-list l1 l2 gu)
(map (lambda (x1 x2) (map (lambda (x1 x2)
(cond (cond
[(eq? x1 gu) gu] [(eq? x1 gu) gu]
[else x2])) [else x2]))
l1 l2)) l1 l2))
(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))
)

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

@ -1,62 +1,63 @@
#cs(module lkup-gui mzscheme #lang scheme/gui
(require htdp/error
mzlib/class (require htdp/error
(lib "prim.ss" "lang") lang/prim
mred) mzlib/class)
(provide control view connect) (provide control view connect)
(define-primitive control control/proc) (define-primitive control control/proc)
(define-primitive view view/proc) (define-primitive view view/proc)
(define-higher-order-primitive connect connect/proc (call-back)) (define-higher-order-primitive connect connect/proc (call-back))
;; ------------------------------------------------------------------------ ;; ------------------------------------------------------------------------
;; Basic constants: ;; Basic constants:
(define TITLE "LOOKUP") (define TITLE "LOOKUP")
(define WIDTH 100) (define WIDTH 100)
(define HIGHT 50) (define HIGHT 50)
;; ------------------------------------------------------------------------ ;; ------------------------------------------------------------------------
;; GUI LAYOUT ;; GUI LAYOUT
(define frame (make-object frame% TITLE #f WIDTH HIGHT)) (define frame (make-object frame% TITLE #f WIDTH HIGHT))
(define panel (make-object horizontal-panel% frame)) (define panel (make-object horizontal-panel% frame))
(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))
;; ------------------------------------------------------------------------ ;; ------------------------------------------------------------------------
;; guess : handle CONTROL ;; guess : handle CONTROL
(define query-tf (make-object text-field% "" vert2 (define query-tf (make-object text-field% "" vert2
(lambda (x y) (send result set-label "")))) (lambda (x y) (send result set-label ""))))
;; control : -> symbol ;; control : -> symbol
;; to supply the name that a user typed into the query text-field ;; to supply the name that a user typed into the query text-field
(define (control/proc) (define (control/proc)
(string->symbol (send query-tf get-value))) (string->symbol (send query-tf get-value)))
;; connect : (button% control-event% -> true) -> void ;; connect : (button% control-event% -> true) -> void
;; effect: to add a check button with call-back to frame and to show frame ;; effect: to add a check button with call-back to frame and to show frame
;; the button is "border" style, so <CR> in query-tf will use call-back ;; the button is "border" style, so <CR> in query-tf will use call-back
(define button #f) (define button #f)
(define (connect/proc call-back) (define (connect/proc call-back)
(check-proc 'connect call-back 2 '1st "2 arguments") (check-proc 'connect call-back 2 '1st "2 arguments")
(if button (if button
(printf "connect: called a second time~n") (printf "connect: called a second time~n")
(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 ;; ------------------------------------------------------------------------
(define result (make-object message% "ddd.ddd.dddd" vert2)) ;; message : display VIEW
(define result (make-object message% "ddd.ddd.dddd" vert2))
;; view : symbol -> void
;; effect: to display the phone number n in the message panel ;; view : symbol -> void
(define (view/proc n) ;; effect: to display the phone number n in the message panel
(check-arg 'view (symbol? n) "symbol" "first" n) (define (view/proc n)
(send result set-label (symbol->string n))) (check-arg 'view (symbol? n) "symbol" "first" n)
) (send result set-label (symbol->string n)))

300
collects/htdp/master.ss
View File

@ -1,40 +1,40 @@
#cs(module master mzscheme #lang scheme/gui
(provide master)
(require htdp/error
(require "error.ss" lang/prim
mzlib/class mzlib/class
mzlib/class100 mzlib/class100
mred mzlib/etc)
(lib "prim.ss" "lang")
mzlib/etc) (provide master)
(define-higher-order-primitive master master/proc (compare-guess)) (define-higher-order-primitive master master/proc (compare-guess))
#| --------------------------------------------------------------------------- #| ---------------------------------------------------------------------------
The Basic Constants |# The Basic Constants |#
(define TITLE "TeachScheme Color Guessing") (define TITLE "TeachScheme Color Guessing")
(define WELCOME "Welcome to the TeachScheme Color-Guessing Game") (define WELCOME "Welcome to the TeachScheme Color-Guessing Game")
(define COLORS (define COLORS
(list 'black 'white 'red 'blue 'green 'gold 'pink 'orange 'purple 'navy)) (list 'black 'white 'red 'blue 'green 'gold 'pink 'orange 'purple 'navy))
(define COL# (length COLORS)) (define COL# (length COLORS))
(define GUESSES# 2) (define GUESSES# 2)
(define BUT-SIZE 30) (define BUT-SIZE 30)
(define WIDTH (* COL# BUT-SIZE)) (define WIDTH (* COL# BUT-SIZE))
(define HIGHT BUT-SIZE) (define HIGHT BUT-SIZE)
(define STOPS (define STOPS
(list 'PerfectGuess 'perfect_guess 'perfect! 'perfect 'Perfect 'perfekt 'Perfekt)) (list 'PerfectGuess 'perfect_guess 'perfect! 'perfect 'Perfect 'perfekt 'Perfekt))
(define TRUMPET (define TRUMPET
(make-object bitmap% (build-path (collection-path "icons") "trumpet.xbm") 'xbm)) (make-object bitmap% (build-path (collection-path "icons") "trumpet.xbm") 'xbm))
#| #|
cd ~.../plt/collects/icons cd ~.../plt/collects/icons
cp where/ever/trumpet.xbm . cp where/ever/trumpet.xbm .
svn update svn update
@ -42,8 +42,8 @@
svn setprop svn:mime-type image/x-xbitmap svn setprop svn:mime-type image/x-xbitmap
svn commit -m "added trumpet image" svn commit -m "added trumpet image"
|# |#
#| ------------------------------------------------------------------------ #| ------------------------------------------------------------------------
The Layout: (computed as a function of constants) The Layout: (computed as a function of constants)
------------------------------------------------------------------ ------------------------------------------------------------------
@ -59,117 +59,117 @@
the first one with all the colors (as buttons) the first one with all the colors (as buttons)
the second is a sequence of colored buttons the second is a sequence of colored buttons
|# |#
(define frame (make-object frame% TITLE #f WIDTH HIGHT)) (define frame (make-object frame% TITLE #f WIDTH HIGHT))
(define verti (make-object vertical-panel% frame)) (define verti (make-object vertical-panel% frame))
(define panel (make-object horizontal-panel% verti)) (define panel (make-object horizontal-panel% verti))
(define guess-panels (define guess-panels
(let ((p (make-object horizontal-panel% verti))) (let ((p (make-object horizontal-panel% verti)))
(build-list GUESSES# (lambda (i) (make-object horizontal-panel% p))))) (build-list GUESSES# (lambda (i) (make-object horizontal-panel% p)))))
(for-each (lambda (p) (send p set-alignment 'center 'center)) guess-panels) (for-each (lambda (p) (send p set-alignment 'center 'center)) guess-panels)
(define message-panel (make-object horizontal-panel% verti)) (define message-panel (make-object horizontal-panel% verti))
(send message-panel set-alignment 'center 'center) (send message-panel set-alignment 'center 'center)
(define message #f) (define message #f)
(define (add-message!) (define (add-message!)
(send message-panel change-children (lambda (x) null)) (send message-panel change-children (lambda (x) null))
(set! message (make-object message% WELCOME message-panel))) (set! message (make-object message% WELCOME message-panel)))
(define (add-winner!) (define (add-winner!)
(send message-panel change-children (lambda (x) null)) (send message-panel change-children (lambda (x) null))
(make-object message% TRUMPET message-panel) (make-object message% TRUMPET message-panel)
(make-object button% "New Game?" message-panel new-game)) (make-object button% "New Game?" message-panel new-game))
#| ------------------------------------------------------------------------ #| ------------------------------------------------------------------------
Some additional functionality |# Some additional functionality |#
(define colored-button% (define colored-button%
(class100 button% (color:str parent call-back [_width BUT-SIZE] [_height BUT-SIZE]) (class100 button% (color:str parent call-back [_width BUT-SIZE] [_height BUT-SIZE])
(private-field (width _width) (private-field (width _width)
(height _height)) (height _height))
(private (private
(make-colored-bm (make-colored-bm
(lambda (color:str) (lambda (color:str)
(let* ([bm (make-object bitmap% width height)] (let* ([bm (make-object bitmap% width height)]
[dc (make-object bitmap-dc% bm)]) [dc (make-object bitmap-dc% bm)])
(send dc set-brush (make-object brush% color:str 'solid)) (send dc set-brush (make-object brush% color:str 'solid))
(send dc draw-rectangle 0 0 width height) (send dc draw-rectangle 0 0 width height)
(send dc set-bitmap #f) (send dc set-bitmap #f)
bm)))) bm))))
(public (public
(change-color (change-color
(lambda (color:str) (lambda (color:str)
(send this set-label (make-colored-bm color:str))))) (send this set-label (make-colored-bm color:str)))))
(sequence (sequence
(super-init (make-colored-bm color:str) parent call-back)) (super-init (make-colored-bm color:str) parent call-back))
)) ))
(define (make-color-button color:sym) (define (make-color-button color:sym)
(let ((color:str (symbol->string color:sym))) (let ((color:str (symbol->string color:sym)))
(letrec ((this (letrec ((this
(lambda (x y) (lambda (x y)
(let* ((guess-button (pop!))) (let* ((guess-button (pop!)))
(send guess-button change-color color:str) (send guess-button change-color color:str)
(add-a-guess! color:sym) (add-a-guess! color:sym)
(if (pair? guesses) (if (pair? guesses)
(send message set-label "Another guess, please!") (send message set-label "Another guess, please!")
(let ((response (check-now!))) (let ((response (check-now!)))
(initialize-guesses) (initialize-guesses)
(send message set-label (symbol->string response)) (send message set-label (symbol->string response))
(when (memq response STOPS) (add-winner!)))))))) (when (memq response STOPS) (add-winner!))))))))
(make-object colored-button% color:str panel this)))) (make-object colored-button% color:str panel this))))
;; master : (color-symbol color-symbol color-symbol color-symbol -> symbol) -> ??? ;; master : (color-symbol color-symbol color-symbol color-symbol -> symbol) -> ???
(define (master/proc cg) (define (master/proc cg)
(check-proc 'master cg 4 'first 'arguments) (check-proc 'master cg 4 'first 'arguments)
(set! check-guess cg) (set! check-guess cg)
(send frame show #t) (send frame show #t)
#t) #t)
#| ------------------------------------------------------------------------ #| ------------------------------------------------------------------------
Setting up the buttons |# Setting up the buttons |#
(for-each make-color-button COLORS) (for-each make-color-button COLORS)
(define guess-buttons (define guess-buttons
(map (lambda (p) (make-object colored-button% "gray" p void)) guess-panels)) (map (lambda (p) (make-object colored-button% "gray" p void)) guess-panels))
;; ------------------------------------------------------------------------ ;; ------------------------------------------------------------------------
;; State of Game ;; State of Game
(define choices null) (define choices null)
(define (new-game . x) (define (new-game . x)
(add-message!) (add-message!)
(set! choices (set! choices
(build-list GUESSES# (lambda (i) (list-ref COLORS (random COL#)))))) (build-list GUESSES# (lambda (i) (list-ref COLORS (random COL#))))))
(new-game) (new-game)
(define guesses null) (define guesses null)
(define (initialize-guesses) (define (initialize-guesses)
(set! guesses guess-buttons)) (set! guesses guess-buttons))
(define (pop!) (define (pop!)
(when (null? guesses) (error 'TeachMind "can't happen")) (when (null? guesses) (error 'TeachMind "can't happen"))
(let ((g (car guesses))) (let ((g (car guesses)))
(set! guesses (cdr guesses)) (set! guesses (cdr guesses))
g)) g))
(initialize-guesses) (initialize-guesses)
(define guessed-colors null) (define guessed-colors null)
(define (add-a-guess! color:sym) (define (add-a-guess! color:sym)
(set! guessed-colors (cons color:sym guessed-colors))) (set! guessed-colors (cons color:sym guessed-colors)))
(define (check-now!) (define (check-now!)
(begin0 (begin0
(if (= GUESSES# 2) (if (= GUESSES# 2)
(apply check-guess (append choices (reverse guessed-colors))) (apply check-guess (append choices (reverse guessed-colors)))
(check-guess choices (reverse guessed-colors))) (check-guess choices (reverse guessed-colors)))
(set! guessed-colors null))) (set! guessed-colors null)))
;; ------------------------------------------------------------------------ ;; ------------------------------------------------------------------------
;; Student Contribution ;; Student Contribution
(define check-guess #f)) (define check-guess #f)