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:
----
* draw.ss
* arrow.ss
* arrow-gui.ss
* convert.ss
* dir.ss
* docs.ss
* draw.ss
* elevator.ss
* graphing.ss
* guess.ss
* guess1.ss
* guess2.ss
* guess3.ss
* gui.ss
* lkup-gui.ss
* hangman.ss : changed, docs
* master.ss : changed, docs
* pingp.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
* hangman1.ss
* master.ss
* matrix.ss

4
collects/htdp/Test/TODO
View File

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

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

@ -1,27 +1,14 @@
;; TeachPack : arrow-gui.ss, gui.ss
(define msg (make-message (make-string 22 #\space)))
(create-window (list (list msg)))
#| 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 |#
;; 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 arrow-gui) (read-case-sensitive #t) (teachpacks ()) (htdp-settings #(#t constructor repeating-decimal #f #t none #f ())))
(require (lib "arrow-gui.ss" "htdp"))
(require (lib "gui.ss" "htdp"))
(define (left b e) (draw-message msg "left"))
(define (right b e) (draw-message msg "right"))
(define (up b e) (draw-message msg "up"))
(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")
;; TeachPack : arrow.ss, draw.ss
;; Language: Beginner
;; 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 arrow) (read-case-sensitive #t) (teachpacks ()) (htdp-settings #(#t constructor repeating-decimal #f #t none #f ())))
(require (lib "arrow.ss" "htdp"))
(require (lib "draw.ss" "htdp"))
;; ---------------------------------------------------------------------
;;
@ -35,10 +36,11 @@
;; TESTS:
;; 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
(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")

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

@ -1,6 +1,7 @@
;; test errors by hand in GUI
(load "tester.ss")
(require htdp/convert)
#lang scheme
(require (lib "testing.ss" "htdp"))
(require (lib "convert.ss" "htdp"))
;; f2c : num -> num
;; to convert a Fahrenheit temperature into a Celsius temperature
@ -33,31 +34,20 @@
(when (file-exists? OUT) (delete-file OUT))
(convert-file IN f2c 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))
;; first: expects argument of type <non-empty list>; given 212
(check-error (convert-file IN list OUT) "convert: The conversion function must produce a number; result: (212)")
(test-error (convert-file IN fx OUT))
;; convert: The conversion function must produce a number; result: 'xyz
(check-error (convert-file IN first OUT) "first: expected argument of type <non-empty list>; given 212")
(test-error (convert-file IN f2c 10))
;; convert-file: expected <string> as third argument, given: 10
(check-error (convert-file IN fx OUT) "convert: The conversion function must produce a number; result: xyz")
(check-error (convert-file IN f2c 10) "convert-file: expected <string> as third argument, given: 10")
;; ----------------------------------------------------------------------------
;; convert by repl:
(convert-repl f2c)
;; 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
@ -72,3 +62,5 @@
;; TEST BY HAND: (convert-gui fx)
;; 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
;; 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")))))
;; TeachPack: dir.ss
;; Language: Intermediate with Lambda
#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 ())))
(require (lib "dir.ss" "htdp"))
(define current (create-dir "."))
(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))
(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))
(generate-report)

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

@ -1,12 +1,16 @@
;; TeachPack: docs.ss
;; Language: Beginner
;; 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 docs) (read-case-sensitive #t) (teachpacks ()) (htdp-settings #(#t constructor repeating-decimal #f #t none #f ())))
(require (lib "docs.ss" "htdp"))
(annotation? '<html>)
(not (annotation? 'html))
(annotation? '<p>)
(check-expect (annotation? '<html>) true)
(check-expect (annotation? 'html) false)
(check-expect (annotation? '<p>) true)
(eq? '</html> (end-annotation '<html>))
(check-expect (end-annotation '<html>) '</html>)
(write-file
(list '<p> 'hello 'world 'is 'the 'most 'stupid 'program 'in 'the 'world '</p>
"so let's test this" 'with "How's that"))
(check-expect
(write-file
(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
;; 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 needs some tests for error behavior of functions ...
@ -10,74 +10,44 @@
(define (draw-next-part body-part)
(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)
(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)
(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)
(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)
(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)
(draw-solid-disk (make-posn 100 50) 10 'black)]
[(eq? body-part 'noose)
(and
(draw-solid-disk (make-posn 120 50) 30 'red)
(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-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))]))
#| Tests ----------------------------------------------------------
|#
;; ----- Tests -----------------------------------------------------------------
(start 200 400)
(sleep-for-a-while 1)
(draw-next-part 'noose)
(sleep-for-a-while 1)
(draw-next-part 'head)
(sleep-for-a-while 1)
(draw-next-part 'left-arm)
(sleep-for-a-while 1)
(draw-next-part 'right-arm)
(sleep-for-a-while 1)
(draw-next-part 'body)
(sleep-for-a-while 1)
(draw-next-part 'left-leg)
(sleep-for-a-while 1)
(draw-next-part 'right-leg)
"please click on the canvas"
(posn? (wait-for-mouse-click))
(stop)
#|
(load "tester.ss")
(start 200 400)
(test-error (draw-solid-line 'a 'b 'c))
|#
(check-expect (start 200 400) true)
(check-expect (sleep-for-a-while 1) true)
(check-expect (draw-next-part 'noose) true)
(check-expect (sleep-for-a-while 1) true)
(check-expect (draw-next-part 'head) true)
(check-expect (sleep-for-a-while 1) true)
(check-expect (draw-next-part 'left-arm) true)
(check-expect (sleep-for-a-while 1) true)
(check-expect (draw-next-part 'right-arm) true)
(check-expect (sleep-for-a-while 1) true)
(check-expect (draw-next-part 'body) true)
(check-expect (sleep-for-a-while 1) true)
(check-expect (draw-next-part 'left-leg) true)
(check-expect (sleep-for-a-while 1) true)
(check-expect (draw-next-part 'right-leg) true)
(check-expect (draw-solid-string (make-posn 10 200) "please click on the canvas") true)
(check-expect (posn? (wait-for-mouse-click)) true)
(check-expect (stop) true)

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

@ -1,5 +1,7 @@
;; TeachPack: elevator.ss
;; Language: Beginner
;; 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 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
;; always sends elevator to next floor up or down,

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

@ -1,16 +1,16 @@
;; TeachPack: graphing.ss
;; Language: Beginner
;; ------------------------------------------------------------------------
;; 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 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))
(graph-fun fun1 'red)
(check-expect (graph-fun fun1 'red) true)
(define (fun2 x) (+ (* -1 x x) 1))
(graph-fun fun2 'blue)
(check-expect (graph-fun fun2 'blue) true)
(define (line1 x) (+ (* +1 x) 10))
(graph-line line1 'black)
(check-expect (graph-line line1 'black) true)
(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 @@
;; ------------------------------------------------------------------------
;; language: beginner
;; teachpack: guess.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.
#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
;; to determine how guess and target relate to each other
@ -16,7 +17,7 @@
(eq? (check-guess 5631 5631) 'Perfect)
;; 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)
; (define (foo x) x) (guess-with-gui foo)

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

@ -1,9 +1,7 @@
; (load "tester.ss")
;; by hand, bottom
;; ------------------------------------------------------------------------
;; testing repl3
;; teachpack: guess.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.
#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"))
;; check-guess3 : digit digit digit number -> symbol
;; to determine how three guess digits and target relate to each other
@ -33,7 +31,7 @@
(eq? (check-guess3 1 3 6 631) 'Perfect)
;; 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)
; (guess-with-gui-3 'a)

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

@ -1,9 +1,7 @@
; (load "tester.ss")
;; by hand, bottom
;; ------------------------------------------------------------------------
;; testing repl-list
;; teachpack: guess.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.
#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"))
;; check-guess-for-list : (listof DIGIT) number -> symbol
;; 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)
;; 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
;; Language Level: 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-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
@ -17,8 +19,9 @@
(define (destroy x) (hide-window x))
(create-window
(list (list txt msg chc)
(list (make-button "Okay?" call-back))
(list (make-button "Close" hide-window))))
(define w
(create-window
(list (list txt msg chc)
(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")
;; by hand, Beginner for plain, Full for errors
@ -44,7 +47,14 @@
(make-word '_ '_ '_))
;; check errors
; (hangman make-word)
; (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)
; (hangman make-word reveal 100)
(check-error (hangman make-word) "hangman: primitive operator requires 3 arguments")
(check-error (hangman (make-word 'a 'b 'c) reveal draw-next-part)
"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
;; 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-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
(lambda (e b)
(view (control))))
(check-expect (connect
(lambda (e b)
(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")
;; 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 'red 'green) 'nothing_correct)
(master check-guess)
; (master 1)
; (master first)
(check-expect (master check-guess) true)
; (check-error (master 1) "master: primitive operator master expects a defined procedure name (usually `compare-guess') in this position")
; (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
;; 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 ())))
; (require htdp/matrix-invisible)
(require htdp/matrix)
(require htdp/testing)
(require (lib "matrix-invisible.ss" "htdp"))
;(require (lib "matrix.ss" "htdp"))
(define r1 '((a00 a01 a02)
(a10 a11 a12)))
@ -37,6 +36,7 @@
(check-expect 1 (matrix-ref m2 (random 2) (random 3)))
(define (is1 x) (= x 1))
(check-expect (matrix-where? m2 is1)
(list (make-posn 0 0) (make-posn 0 1) (make-posn 0 2)
@ -52,8 +52,5 @@
;; --- IMPERATIVE ---
(check-expect (matrix-ref m1 0 0) 'a00)
(define m1-modified (matrix-set! m1 0 0 'xxx))
(check-expect (matrix-ref m1 0 0) 'xxx)
(generate-report)
(define m1-modified (matrix-set! m1 0 0 'xxx)) ;; <-------- uncomment this and the test engine breaks
; (check-expect (matrix-ref m1 0 0) 'xxx)

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
(lambda (stx)
(syntax-case stx ()

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

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

257
collects/htdp/arrow.ss
View File

@ -1,134 +1,133 @@
#cs(module arrow mzscheme
(require htdp/error
htdp/big-draw
mzlib/etc
mzlib/class
mred
(lib "prim.ss" "lang"))
(provide
control
control-up-down
control-left-right
)
#lang scheme/gui
(define-higher-order-primitive control-up-down control-up-down/proc
(_ _ up-down draw))
(require htdp/error
htdp/big-draw
lang/prim
mzlib/etc
mzlib/class)
(define-higher-order-primitive control-left-right control-left-right/proc
(_ _ left-right draw))
(provide
control
control-up-down
control-left-right
)
(define-higher-order-primitive control control/proc
(_ _ left-right up-down draw))
(define-higher-order-primitive control-up-down control-up-down/proc
(_ _ up-down draw))
;; CONSTANTS ---------------------------------------------------------------
(define MY-ICONS "/home/matthias/icons/")
(define TITLE "Controller")
(define (mk-image-constant kind)
(make-object bitmap%
(build-path (collection-path "icons") (format "arrow.~a.gif" kind)) 'gif))
;(define LEFT-ARROW (mk-image-constant "marble.left"))
;(define RIGHT-ARROW (mk-image-constant "marble.right"))
;(define UP-ARROW (mk-image-constant "marble.up"))
;(define DOWN-ARROW (mk-image-constant "marble.down"))
(define LEFT-ARROW (mk-image-constant "blue.left"))
(define RIGHT-ARROW (mk-image-constant "blue.right"))
(define UP-ARROW (mk-image-constant "blue.up"))
(define DOWN-ARROW (mk-image-constant "blue.down"))
;; LAYOUT ------------------------------------------------------------------
;; layout = (listof (listof (union #f bitmap%)))
(define FOUR
`( (,#f ,UP-ARROW ,#f)
(,LEFT-ARROW ,#f ,RIGHT-ARROW)
(,#f ,DOWN-ARROW ,#f) ))
(define UP-DOWN
`( (,UP-ARROW )
(,DOWN-ARROW ) ))
(define LEFT-RIGHT
`( (,LEFT-ARROW ,RIGHT-ARROW ) ))
;; make-button-table :
;; panel% layout (bitmap% -> (_ _ -> X))
;; ->
;; (listof (listof (union panel% button%)))
;; to translate a layout table into a button table
;; each button is controled by (control a-bitmap)
(define (make-button-table panel control layout)
(define (make-row a-row)
(define row-panel (make-object horizontal-panel% panel))
(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-item a-row))
(define-higher-order-primitive control-left-right control-left-right/proc
(_ _ left-right draw))
(define-higher-order-primitive control control/proc
(_ _ left-right up-down draw))
;; CONSTANTS ---------------------------------------------------------------
(define MY-ICONS "/home/matthias/icons/")
(define TITLE "Controller")
(define (mk-image-constant kind)
(make-object bitmap%
(build-path (collection-path "icons") (format "arrow.~a.gif" kind)) 'gif))
;(define LEFT-ARROW (mk-image-constant "marble.left"))
;(define RIGHT-ARROW (mk-image-constant "marble.right"))
;(define UP-ARROW (mk-image-constant "marble.up"))
;(define DOWN-ARROW (mk-image-constant "marble.down"))
(define LEFT-ARROW (mk-image-constant "blue.left"))
(define RIGHT-ARROW (mk-image-constant "blue.right"))
(define UP-ARROW (mk-image-constant "blue.up"))
(define DOWN-ARROW (mk-image-constant "blue.down"))
;; LAYOUT ------------------------------------------------------------------
;; layout = (listof (listof (union #f bitmap%)))
(define FOUR
`( (,#f ,UP-ARROW ,#f)
(,LEFT-ARROW ,#f ,RIGHT-ARROW)
(,#f ,DOWN-ARROW ,#f) ))
(define UP-DOWN
`( (,UP-ARROW )
(,DOWN-ARROW ) ))
(define LEFT-RIGHT
`( (,LEFT-ARROW ,RIGHT-ARROW ) ))
;; make-button-table :
;; panel% layout (bitmap% -> (_ _ -> X))
;; ->
;; (listof (listof (union panel% button%)))
;; to translate a layout table into a button table
;; each button is controled by (control a-bitmap)
(define (make-button-table panel control layout)
(define (make-row a-row)
(define row-panel (make-object horizontal-panel% panel))
(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))
;; GUI ---------------------------------------------------------------------
;; make-controller :
;; symbol layout number X (number X -> true) (number X -> true) (X -> true)-> void
;; effect: create a left-right controller that invokes move on delta
(define (make-controller tag layout shape delta left-right-action up-down-action draw-shape)
(check-arg tag
(and (number? delta) (integer? delta) (>= delta 1))
"positive integer"
'2nd
delta)
(check-proc tag left-right-action 2 "move-left-right" "two arguments")
(check-proc tag up-down-action 2 "move-up-down" "two arguments")
(check-proc tag draw-shape 1 "draw" "one argument")
;; ---
(local ((define frame (make-object frame% TITLE #f 10 10))
(define panel (make-object vertical-panel% frame))
;; control : bitmap% -> (_ _ -> void)
;; to check which button was clicked
(define (control an-item)
(lambda (x y)
;; DESIGN DECISION:
;; by handing over the number first, nesting the moves becomes easier
(evcase an-item
(UP-ARROW
(set! shape (up-down-action (- delta) shape)))
(DOWN-ARROW
(set! shape (up-down-action delta shape)))
(LEFT-ARROW
(set! shape (left-right-action (- delta) shape)))
(RIGHT-ARROW
(set! shape (left-right-action delta shape))))
(draw-shape shape))))
(make-button-table panel control layout)
(send frame show #t)
#t))
;; EXPORTS:
(define (void2 x y) (void))
;; control-left-right/proc : XShape number (number XShape -> XShape) (XShape -> true) -> true
;; effect: create a window from which a user can control L/R moves
(define (control-left-right/proc shape delta lr draw)
(make-controller 'control-left-right LEFT-RIGHT shape delta lr void2 draw))
;; control-up-down : X number (number X -> true) (X -> true) -> true
;; effect: create a window from which a user can control U/D moves
(define (control-up-down/proc shape delta ud draw)
(make-controller 'control-up-down UP-DOWN shape delta void2 ud draw))
;; control/proc : X number (number X -> true) (number X -> true) (X -> true) -> true
;; 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))
)
(map make-item a-row))
;; ---
(map make-row layout))
;; GUI ---------------------------------------------------------------------
;; make-controller :
;; symbol layout number X (number X -> true) (number X -> true) (X -> true)-> void
;; effect: create a left-right controller that invokes move on delta
(define (make-controller tag layout shape delta left-right-action up-down-action draw-shape)
(check-arg tag
(and (number? delta) (integer? delta) (>= delta 1))
"positive integer"
'2nd
delta)
(check-proc tag left-right-action 2 "move-left-right" "two arguments")
(check-proc tag up-down-action 2 "move-up-down" "two arguments")
(check-proc tag draw-shape 1 "draw" "one argument")
;; ---
(local ((define frame (make-object frame% TITLE #f 10 10))
(define panel (make-object vertical-panel% frame))
;; control : bitmap% -> (_ _ -> void)
;; to check which button was clicked
(define (control an-item)
(lambda (x y)
;; DESIGN DECISION:
;; by handing over the number first, nesting the moves becomes easier
(evcase an-item
(UP-ARROW
(set! shape (up-down-action (- delta) shape)))
(DOWN-ARROW
(set! shape (up-down-action delta shape)))
(LEFT-ARROW
(set! shape (left-right-action (- delta) shape)))
(RIGHT-ARROW
(set! shape (left-right-action delta shape))))
(draw-shape shape))))
(make-button-table panel control layout)
(send frame show #t)
#t))
;; EXPORTS:
(define (void2 x y) (void))
;; control-left-right/proc : XShape number (number XShape -> XShape) (XShape -> true) -> true
;; effect: create a window from which a user can control L/R moves
(define (control-left-right/proc shape delta lr draw)
(make-controller 'control-left-right LEFT-RIGHT shape delta lr void2 draw))
;; control-up-down : X number (number X -> true) (X -> true) -> true
;; effect: create a window from which a user can control U/D moves
(define (control-up-down/proc shape delta ud draw)
(make-controller 'control-up-down UP-DOWN shape delta void2 ud draw))
;; control/proc : X number (number X -> true) (number X -> true) (X -> true) -> true
;; 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
(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)
#lang scheme/gui
(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)
(require htdp/error
htdp/draw-sig
lang/posn
lang/prim
mzlib/etc
mzlib/unit
mzlib/class
mred/mred-sig
mred/mred-unit
graphics/graphics-sig
graphics/graphics-posn-less-unit)
(define-primitive draw-solid-string draw-string/proc)
(define-primitive clear-solid-string clear-string/proc)
(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)
(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)
(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-object #'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-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*])
;; 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-set! 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 ()
[(stop-tick vp*)]
[(stop-tick pm*)]
#t)))
(hash-table-put! h '%end-of-time %end-of-time)
;; ---
(set! %stop
(let* ([vp* vp*]
[pm* 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
(hash-set! h '%end-of-time %end-of-time)
;; ---
(set! %stop
(let* ([vp* vp*]
[pm* pm*]
[a (lambda () (close-viewport vp*) (close-viewport pm*))])
(lambda ()
(cond
[(ready-key-press vp*) => key-value]
[else false])))
(set! %get-mouse-event
(lambda ()
(cond
[(ready-mouse-click vp*) => mouse-click-posn]
[else false])))
(set! %on-key-event
(lambda (f)
(check-proc 'on-key-event f 2 'first 'two)
((set-on-key-event vp*)
(lambda (x y) (f (key-value x) y)))
#t))
(set! %on-tick-event
(lambda (f)
(let* ([w (ceiling (* 1000 *delta*))]
[w (if (exact? w) w (inexact->exact w))])
(check-proc 'on-key-event f 1 'first 'one)
((set-on-tick-event vp*) w (lambda (x) (f x)))
#t)))
(set! %big-bang
(lambda (delta w)
(check-arg 'big-bang
(and (number? delta) (>= delta 0))
"number [of seconds] between 0 and 1000000"
"first"
delta)
(set! *delta* delta)
((init-world vp*) w)
#t))
(semaphore-post seq-lock)
#t))
;; [Listof (-> Void)]
;; a list of actions to be performed after the drawing action is done.
(define @end-actions '())
;; Viewport Pixmap -> true
;; start a drawing sequence by clearing the pixmap and making it the "target" for all operations
;; effect: in-sequence?, @vp and @pm so that copy-viewport can work later
;; The draw sequence can only draw (and clear) elements from the pixmap.
;; It doesn't react to events. Should it disable them?
;; Or do we count on finishing the sequence fast enough?
(define (begin-draw-sequence)
(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 '())
[(stop-tick vp*)]
[(stop-tick pm*)]
(if in-sequence?
(set! @end-actions (cons a @end-actions))
[a])
#t)))
(hash-set! h '%stop %stop)
;; ---
;; see ../htdch/draw/support.scm (copy) for explanation and design rationale
(hash-set! 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 ()
(cond
[(ready-key-press vp*) => key-value]
[else false])))
(set! %get-mouse-event
(lambda ()
(cond
[(ready-mouse-click vp*) => mouse-click-posn]
[else false])))
(set! %on-key-event
(lambda (f)
(check-proc 'on-key-event f 2 'first 'two)
((set-on-key-event vp*)
(lambda (x y) (f (key-value x) y)))
#t))
(set! %on-tick-event
(lambda (f)
(let* ([w (ceiling (* 1000 *delta*))]
[w (if (exact? w) w (inexact->exact w))])
(check-proc 'on-key-event f 1 'first 'one)
((set-on-tick-event vp*) w (lambda (x) (f x)))
#t)))
(set! %big-bang
(lambda (delta w)
(check-arg 'big-bang
(and (number? delta) (>= delta 0))
"number [of seconds] between 0 and 1000000"
"first"
delta)
(set! *delta* delta)
((init-world vp*) w)
#t))
(semaphore-post seq-lock)
#t)
;; start/cartesian-plane : Number Number -> true
;; start up a canvas of size width x height and draw a centered cartesian coordinate
(define (start/cartesian-plane width height)
(check-arg 'start/cartesian-plane
(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 mred: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)))))))
#t))
;; [Listof (-> Void)]
;; a list of actions to be performed after the drawing action is done.
(define @end-actions '())
;; Viewport Pixmap -> true
;; start a drawing sequence by clearing the pixmap and making it the "target" for all operations
;; effect: in-sequence?, @vp and @pm so that copy-viewport can work later
;; The draw sequence can only draw (and clear) elements from the pixmap.
;; It doesn't react to events. Should it disable them?
;; Or do we count on finishing the sequence fast enough?
(define (begin-draw-sequence)
(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)
#t)
;; start/cartesian-plane : Number Number -> true
;; start up a canvas of size width x height and draw a centered cartesian coordinate
(define (start/cartesian-plane width height)
(check-arg 'start/cartesian-plane
(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
;(module convert mzscheme
(require mzlib/etc
htdp/error
lang/prim)
(provide-higher-order-primitive convert-gui (f2c))
(provide-higher-order-primitive convert-repl (f2c))
(provide-higher-order-primitive convert-file (_ f2c _))
(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 white-brush (send the-brush-list find-or-create-brush "WHITE" 'solid))
;; scale% : (union false (num -> str)) frame% -> scale<%>
;; scale<%> : set-current-x + canvas<%>
(define scale%
(class canvas%
(inherit get-dc get-size get-client-size)
(define value 0)
(define (draw-something)
(let ([dc (get-dc)])
(send dc clear)
(let-values ([(width height) (get-client-size)])
(send dc set-pen black-pen)
(send dc set-brush white-brush)
(send dc draw-rectangle 0 0 width height)
(send dc set-brush red-brush)
(send dc draw-rectangle 0 0
(* width (max 0 (min 1 (/ (- value SLI-MIN) (- SLI-MAX SLI-MIN))))) height)
(let*-values ([(cw ch) (get-client-size)]
[(number) value])
(when (and (number? number)
(exact? number)
(real? number))
(let* ([whole (if (number . < . 0)
(ceiling number)
(floor number))]
[fractional-part (- (abs number) (floor (abs number)))]
[num (numerator fractional-part)]
[den (denominator fractional-part)]
[wholes (if (and (zero? whole) (not (zero? number)))
""
(number->string whole))]
[nums (number->string num)]
[dens (number->string den)])
(let-values ([(ww wh wa wd) (send dc get-text-extent wholes)]
[(nw nh na nd) (send dc get-text-extent nums)]
[(dw dh da dd) (send dc get-text-extent dens)])
(let ([w (if (integer? number) (+ ww (max nw dw)) ww)]
[h (if (integer? number)
wh
(+ nh dh))])
(cond
[(integer? number)
(send dc draw-text
wholes
(- (/ cw 2) (/ w 2))
(- (/ ch 2) (/ wh 2)))]
[else
(send dc draw-text
wholes
(- (/ cw 2) (/ w 2))
(- (/ ch 2) (/ wh 2)))
(send dc draw-text
nums
(+ ww (- (/ cw 2) (/ w 2)))
(- (/ ch 2) (/ h 2)))
(send dc draw-text
dens
(+ ww (- (/ cw 2) (/ w 2)))
(+ nh (- (/ ch 2) (/ h 2))))
(send dc draw-line
(+ ww (- (/ cw 2) (/ w 2)))
(/ ch 2)
(+ ww (max nw dw) (- (/ cw 2) (/ w 2)))
(/ ch 2))])))))))))
(override on-paint)
(define (on-paint) (draw-something))
(public set-value)
(define (set-value v)
(set! value v)
(draw-something))
(inherit min-width min-height)
(super-instantiate ())
(let-values ([(w h a d) (send (get-dc) get-text-extent "100100100")])
(min-width (+ 4 (inexact->exact w)))
(min-height (+ 4 (inexact->exact (* 2 h)))))))
;; ------------------------------------------------------------------------
(define OUT-ERROR
"The conversion function must produce a number; result: ~e")
;; ============================================================================
;; MODEL
;; 2int : num -> int
;; to convert a real number into an exact number
(define (2int x)
(if (and (real? x) (number? x))
(inexact->exact x)
(error 'convert OUT-ERROR x)))
;; f2c : num -> num
;; to convert a Fahrenheit temperature into a Celsius temperature
(define (f2c f)
(2int (* 5/9 (- f 32))))
;; fahr->cel : num -> num
;; student-supplied function for converting F to C
(define (fahr->cel f)
(error 'convert "not initialized"))
;; slider-cb : slider% event% -> void
;; to use fahr->cel to perform the conversion
(define (slider-cb c s)
(send sliderC set-value
((compose in-slider-range 2int fahr->cel)
(send sliderF get-value))))
;; in-slider-range : number -> number
;; to check and to convert the new temperature into an appropriate scale
(define (in-slider-range x)
(cond
[(<= SLI-MIN x SLI-MAX) x]
[else (error 'convert-gui "result out of range for Celsius display")]))
#| --------------------------------------------------------------------
(require mzlib/etc
lang/prim
htdp/error)
(provide-higher-order-primitive convert-gui (f2c))
(provide-higher-order-primitive convert-repl (f2c))
(provide-higher-order-primitive convert-file (_ f2c _))
(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 white-brush (send the-brush-list find-or-create-brush "WHITE" 'solid))
;; scale% : (union false (num -> str)) frame% -> scale<%>
;; scale<%> : set-current-x + canvas<%>
(define scale%
(class canvas%
(inherit get-dc get-size get-client-size)
(define value 0)
(define (draw-something)
(let ([dc (get-dc)])
(send dc clear)
(let-values ([(width height) (get-client-size)])
(send dc set-pen black-pen)
(send dc set-brush white-brush)
(send dc draw-rectangle 0 0 width height)
(send dc set-brush red-brush)
(send dc draw-rectangle 0 0
(* width (max 0 (min 1 (/ (- value SLI-MIN) (- SLI-MAX SLI-MIN))))) height)
(let*-values ([(cw ch) (get-client-size)]
[(number) value])
(when (and (number? number)
(exact? number)
(real? number))
(let* ([whole (if (number . < . 0)
(ceiling number)
(floor number))]
[fractional-part (- (abs number) (floor (abs number)))]
[num (numerator fractional-part)]
[den (denominator fractional-part)]
[wholes (if (and (zero? whole) (not (zero? number)))
""
(number->string whole))]
[nums (number->string num)]
[dens (number->string den)])
(let-values ([(ww wh wa wd) (send dc get-text-extent wholes)]
[(nw nh na nd) (send dc get-text-extent nums)]
[(dw dh da dd) (send dc get-text-extent dens)])
(let ([w (if (integer? number) (+ ww (max nw dw)) ww)]
[h (if (integer? number)
wh
(+ nh dh))])
(cond
[(integer? number)
(send dc draw-text
wholes
(- (/ cw 2) (/ w 2))
(- (/ ch 2) (/ wh 2)))]
[else
(send dc draw-text
wholes
(- (/ cw 2) (/ w 2))
(- (/ ch 2) (/ wh 2)))
(send dc draw-text
nums
(+ ww (- (/ cw 2) (/ w 2)))
(- (/ ch 2) (/ h 2)))
(send dc draw-text
dens
(+ ww (- (/ cw 2) (/ w 2)))
(+ nh (- (/ ch 2) (/ h 2))))
(send dc draw-line
(+ ww (- (/ cw 2) (/ w 2)))
(/ ch 2)
(+ ww (max nw dw) (- (/ cw 2) (/ w 2)))
(/ ch 2))])))))))))
(override on-paint)
(define (on-paint) (draw-something))
(public set-value)
(define (set-value v)
(set! value v)
(draw-something))
(inherit min-width min-height)
(super-instantiate ())
(let-values ([(w h a d) (send (get-dc) get-text-extent "100100100")])
(min-width (+ 4 (inexact->exact w)))
(min-height (+ 4 (inexact->exact (* 2 h)))))))
;; ------------------------------------------------------------------------
(define OUT-ERROR
"The conversion function must produce a number; result: ~e")
;; ============================================================================
;; MODEL
;; 2int : num -> int
;; to convert a real number into an exact number
(define (2int x)
(if (and (real? x) (number? x))
(inexact->exact x)
(error 'convert OUT-ERROR x)))
;; f2c : num -> num
;; to convert a Fahrenheit temperature into a Celsius temperature
(define (f2c f)
(2int (* 5/9 (- f 32))))
;; fahr->cel : num -> num
;; student-supplied function for converting F to C
(define (fahr->cel f)
(error 'convert "not initialized"))
;; slider-cb : slider% event% -> void
;; to use fahr->cel to perform the conversion
(define (slider-cb c s)
(send sliderC set-value
((compose in-slider-range 2int fahr->cel)
(send sliderF get-value))))
;; in-slider-range : number -> number
;; to check and to convert the new temperature into an appropriate scale
(define (in-slider-range x)
(cond
[(<= SLI-MIN x SLI-MAX) x]
[else (error 'convert-gui "result out of range for Celsius display")]))
#| --------------------------------------------------------------------
view (exports sliderF sliderC SLI-MIN SLI-MAX) (imports f2c slider-cb)
model (imports sliderF sliderC SLI-MIN SLI-MAX) (exports f2c slider-cb)
----------------------------------------------------------------------- |#
;; ============================================================================
;; VIEW
(define frame (make-object frame% "Fahrenheit to Celsius Conversion"))
(send frame set-alignment 'center 'center)
(define main-panel (instantiate horizontal-panel% () (parent frame)
(stretchable-height #f)))
;; create labels; aligned with sliders
(define mpanel (make-object vertical-panel% main-panel))
(begin
(make-object message% "Fahrenheit" mpanel)
(make-object message% "" mpanel)
(make-object message% "Celsius" mpanel))
(send mpanel stretchable-width #f)
(define panel (make-object vertical-panel% main-panel))
(send panel set-alignment 'center 'center)
(define F-SLI-MIN -50)
(define F-SLI-MAX 250)
(define F-SLI-0 32)
(define SLI-MIN (f2c F-SLI-MIN))
(define SLI-MAX (f2c F-SLI-MAX))
;; sliderF : slider%
;; to display the Fahrenheit temperature
(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))
;; sliderC : slider%
;; to display the Celsius temperature
(define sliderC (make-object scale% panel))
(define _set-sliderC (send sliderC set-value (in-slider-range (f2c F-SLI-0))))
(define button-panel (instantiate vertical-panel% ()
(stretchable-width #f)
(stretchable-height #f)
(parent main-panel)))
;; convert : button%
;; to convert fahrenheit to celsius
(define convert (make-object button% "Convert" button-panel slider-cb))
(define close (make-object button% "Close" button-panel
(lambda (x e) (send frame show #f))))
;; convert-gui : (num -> num) -> void
;; to install f as the temperature converter
;; effect: to create a window with two rulers for converting F to C
(define (convert-gui f)
(check-proc 'convert-gui f 1 "convert-gui" "one argument")
(set! fahr->cel f)
;; only initialize the slider based on the user's program
;; when there aren't any exceptions.
;; if there are exceptions, wait for the user to click
;; "convert" to see an error.
(with-handlers ([exn:fail? (lambda (x) (void))])
(send sliderC set-value (in-slider-range (fahr->cel F-SLI-0))))
(send frame show #t))
;; ============================================================================
;; convert-repl : (num -> num) -> void
;; to start a read-eval-print loop that reads numbers [temp in F], applies f, and prints
;; the result; effects: read and write;
;; exit on x as input
(define (convert-repl f)
(check-proc 'convert-repl f 1 "convert-repl" "one argument")
(let repl ()
(begin
(printf "Enter Fahrenheit temperature and press <enter> [to exit, type x]: ")
(flush-output)
(let* ([ans (read)])
(cond
[(or (eof-object? ans) (eq? ans 'x)) (void)]
[(not (number? ans))
(printf "The input must be a number. Given: ~s~n" ans) (repl)]
[(number? ans)
(let ([res (f ans)])
(if (number? res)
(printf "~sF corresponds to ~sC~n" ans res)
(error 'convert OUT-ERROR res))
(repl))]
[else (error 'convert "can't happen")])))))
;; ============================================================================
;; make-reader-for-f : (number -> number) -> ( -> void)
;; make-reader-for-f creates a function that reads numbers from a file
;; converts them accoring to f, and prints the results
;; effect: if any of the S-expressions in the file aren't numbers or
;; if any of f's results aren't numbers,
;; the function signals an error
(define (make-reader-for f)
(local ((define (read-until-eof)
(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)
;; ============================================================================
;; VIEW
(define frame (make-object frame% "Fahrenheit to Celsius Conversion"))
(send frame set-alignment 'center 'center)
(define main-panel (instantiate horizontal-panel% () (parent frame)
(stretchable-height #f)))
;; create labels; aligned with sliders
(define mpanel (make-object vertical-panel% main-panel))
(begin
(make-object message% "Fahrenheit" mpanel)
(make-object message% "" mpanel)
(make-object message% "Celsius" mpanel))
(send mpanel stretchable-width #f)
(define panel (make-object vertical-panel% main-panel))
(send panel set-alignment 'center 'center)
(define F-SLI-MIN -50)
(define F-SLI-MAX 250)
(define F-SLI-0 32)
(define SLI-MIN (f2c F-SLI-MIN))
(define SLI-MAX (f2c F-SLI-MAX))
;; sliderF : slider%
;; to display the Fahrenheit temperature
(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))
;; sliderC : slider%
;; to display the Celsius temperature
(define sliderC (make-object scale% panel))
(define _set-sliderC (send sliderC set-value (in-slider-range (f2c F-SLI-0))))
(define button-panel (instantiate vertical-panel% ()
(stretchable-width #f)
(stretchable-height #f)
(parent main-panel)))
;; convert : button%
;; to convert fahrenheit to celsius
(define convert (make-object button% "Convert" button-panel slider-cb))
(define close (make-object button% "Close" button-panel
(lambda (x e) (send frame show #f))))
;; convert-gui : (num -> num) -> void
;; to install f as the temperature converter
;; effect: to create a window with two rulers for converting F to C
(define (convert-gui f)
(check-proc 'convert-gui f 1 "convert-gui" "one argument")
(set! fahr->cel f)
;; only initialize the slider based on the user's program
;; when there aren't any exceptions.
;; if there are exceptions, wait for the user to click
;; "convert" to see an error.
(with-handlers ([exn:fail? (lambda (x) (void))])
(send sliderC set-value (in-slider-range (fahr->cel F-SLI-0))))
(send frame show #t))
;; ============================================================================
;; convert-repl : (num -> num) -> void
;; to start a read-eval-print loop that reads numbers [temp in F], applies f, and prints
;; the result; effects: read and write;
;; exit on x as input
(define (convert-repl f)
(check-proc 'convert-repl f 1 "convert-repl" "one argument")
(let repl ()
(begin
(printf "Enter Fahrenheit temperature and press <enter> [to exit, type x]: ")
(flush-output)
(let* ([ans (read)])
(cond
[(or (eof-object? ans) (eq? ans 'x)) (void)]
[(not (number? ans))
(printf "The input must be a number. Given: ~s~n" ans) (repl)]
[(number? ans)
(let ([res (f ans)])
(if (number? res)
(printf "~sF corresponds to ~sC~n" ans res)
(error 'convert OUT-ERROR res))
(repl))]
[else (error 'convert "can't happen")])))))
;; ============================================================================
;; make-reader-for-f : (number -> number) -> ( -> void)
;; make-reader-for-f creates a function that reads numbers from a file
;; converts them accoring to f, and prints the results
;; effect: if any of the S-expressions in the file aren't numbers or
;; if any of f's results aren't numbers,
;; the function signals an error
(define (make-reader-for f)
(local ((define (read-until-eof)
(let ([in (read)])
(cond
[(number? out) (printf "~s~n" out)]
[else (error 'convert OUT-ERROR out)])))
read-until-eof))
;; convert-file : str (num -> num) str -> void
;; to read a number from file in, to convert it with f, and to write it to out
(define (convert-file in f out)
(check-arg 'convert-file (string? in) "string" "first" in)
(check-arg 'convert-file (file-exists? in)
(format "name of existing file in ~a" (current-directory))
"first" in)
(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)))))
[(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
[(number? out) (printf "~s~n" out)]
[else (error 'convert OUT-ERROR out)])))
read-until-eof))
;; convert-file : str (num -> num) str -> void
;; to read a number from file in, to convert it with f, and to write it to out
(define (convert-file in f out)
(check-arg 'convert-file (string? in) "string" "first" in)
(check-arg 'convert-file (file-exists? in)
(format "name of existing file in ~a" (current-directory))
"first" in)
(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
(require htdp/error
(lib "prim.ss" "lang"))
lang/prim)
(provide
create-dir ; path -> Directory

206
collects/htdp/docs.ss
View File

@ -1,104 +1,106 @@
#cs(module docs mzscheme
(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)
#lang scheme
;; 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)))))))
(require htdp/error
lang/prim
mzlib/list)
(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 :
;; (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
(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))))
(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)))
)
(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))
#t)

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

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

43
collects/htdp/draw.ss
View File

@ -1,23 +1,24 @@
#cs(module draw mzscheme
(require htdp/big-draw
htdp/draw-sig
mzlib/unit)
#lang scheme
(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>)
)
(require htdp/big-draw
htdp/draw-sig
mzlib/unit)
(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
(require htdp/error
mzlib/unit
htdp/draw-sig
htdp/big-draw
(lib "posn.ss" "lang")
(lib "prim.ss" "lang"))
(provide-signature-elements draw^)
(provide
graph-fun
graph-line
)
(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
;; between [0,10] and [0,10] on x/y axis
(define (make-graph name)
(start EAST SOUTH)
(let* ([vp+pm #cs(get-@VP)]
[vp (car vp+pm)])
(draw-solid-line ORIGIN X-AXIS 'blue)
((draw-string vp) (make-posn (+ OFFSET 10) (+ OFFSET 10)) "Y-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
(define (graph-line/proc f color)
(check 'graph-line f color)
(let ((p1 (translate (make-posn 0 (f 0))))
(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
(define (graph-fun/proc f 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-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)
(if (> left right) null
(cons (make-posn left (f left))
(tabulate f (+ left delta) right delta))))
;; translate : posn -> posn
(define (translate p)
(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)
(for-each (lambda (p) (draw-solid-disk p DOT color)) lop)
(unless (or (null? lop) (null? (cdr lop)))
(let loop ([f (car lop)][r (cdr lop)])
(unless (null? r)
(let ([next (car r)])
(draw-solid-line f next color)
(loop next (cdr r))))))
#t)
(define EAST 400)
(define SOUTH EAST)
(define FACT (/ (- EAST 100) 100))
(define OFFSET 10.)
(define ORIGIN (make-posn OFFSET (- SOUTH OFFSET)))
(define X-AXIS (make-posn OFFSET OFFSET))
(define Y-AXIS (make-posn (- EAST OFFSET) (- SOUTH OFFSET)))
(define GRAPH-COLOR 'red)
(define DELTA .1)
(define DOT 1)
(make-graph 'ok))
#lang scheme
(require htdp/error
lang/posn
lang/prim
mzlib/unit
htdp/draw-sig
htdp/big-draw)
(provide-signature-elements draw^)
(provide
graph-fun
graph-line
)
(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
;; between [0,10] and [0,10] on x/y axis
(define (make-graph name)
(start EAST SOUTH)
(let* ([vp+pm #cs(get-@VP)]
[vp (car vp+pm)])
(draw-solid-line ORIGIN X-AXIS 'blue)
((draw-string vp) (make-posn (+ OFFSET 10) (+ OFFSET 10)) "Y-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
(define (graph-line/proc f color)
(check 'graph-line f color)
(let ((p1 (translate (make-posn 0 (f 0))))
(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
(define (graph-fun/proc f 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-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)
(if (> left right) null
(cons (make-posn left (f left))
(tabulate f (+ left delta) right delta))))
;; translate : posn -> posn
(define (translate p)
(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)
(for-each (lambda (p) (draw-solid-disk p DOT color)) lop)
(unless (or (null? lop) (null? (cdr lop)))
(let loop ([f (car lop)][r (cdr lop)])
(unless (null? r)
(let ([next (car r)])
(draw-solid-line f next color)
(loop next (cdr r))))))
#t)
(define EAST 400)
(define SOUTH EAST)
(define FACT (/ (- EAST 100) 100))
(define OFFSET 10.)
(define ORIGIN (make-posn OFFSET (- SOUTH OFFSET)))
(define X-AXIS (make-posn OFFSET OFFSET))
(define Y-AXIS (make-posn (- EAST OFFSET) (- SOUTH OFFSET)))
(define GRAPH-COLOR 'red)
(define DELTA .1)
(define DOT 1)
(make-graph 'ok)

360
collects/htdp/guess.ss
View File

@ -1,63 +1,63 @@
#cs(module guess mzscheme
(require htdp/error
mzlib/unitsig
mzlib/etc
mzlib/class
mzlib/list
mred
(lib "prim.ss" "lang"))
(provide
guess-with-gui
guess-with-gui-3
guess-with-gui-list
)
(define-higher-order-primitive guess-with-gui guess-with-gui/proc
(check-guess))
(define-higher-order-primitive guess-with-gui-3 guess-with-gui-3/proc
(check-guess))
(define-higher-order-primitive guess-with-gui-list guess-with-gui-list/proc
(_ check-guess-list))
;
;
;
; ;;;;
; ; ;
; ; ; ;
; ; ;;;; ; ;;; ;;;; ;;;; ;;; ; ;;; ;;;; ;;;;
; ; ; ; ;; ; ; ; ; ; ;; ; ; ;
; ; ; ; ; ; ; ; ; ; ; ; ;
; ; ; ; ; ; ;;; ; ;;;; ; ; ; ;;;
; ; ; ; ; ; ; ; ; ; ; ; ; ;
; ; ; ; ; ; ; ; ; ; ; ; ; ; ;
; ;;;; ;;;; ; ; ;;;; ;; ;;;;; ; ; ;; ;;;;
;
;
;
(define TITLE "Bobby's Game")
#lang scheme/gui
(require htdp/error
lang/prim
mzlib/unitsig
mzlib/etc
mzlib/class
mzlib/list)
(provide
guess-with-gui
guess-with-gui-3
guess-with-gui-list
)
(define-higher-order-primitive guess-with-gui guess-with-gui/proc
(check-guess))
(define-higher-order-primitive guess-with-gui-3 guess-with-gui-3/proc
(check-guess))
(define-higher-order-primitive guess-with-gui-list guess-with-gui-list/proc
(_ check-guess-list))
;
;
;
; ;;;;
; ; ;
; ; ; ;
; ; ;;;; ; ;;; ;;;; ;;;; ;;; ; ;;; ;;;; ;;;;
; ; ; ; ;; ; ; ; ; ; ;; ; ; ;
; ; ; ; ; ; ; ; ; ; ; ; ;
; ; ; ; ; ; ;;; ; ;;;; ; ; ; ;;;
; ; ; ; ; ; ; ; ; ; ; ; ; ;
; ; ; ; ; ; ; ; ; ; ; ; ; ; ;
; ;;;; ;;;; ; ; ;;;; ;; ;;;;; ; ; ;; ;;;;
;
;
;
(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 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:
;; - Instead of having one window, each call to "create-window"
;; returns a window
;; - Message items stretch horizontally to fill the window,
;; avoiding the need for long initialization messages
#lang scheme/gui
#cs
(module gui mzscheme
(require htdp/error
mred
mzlib/class
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))
(require htdp/error
lang/prim
mzlib/class
mzlib/list
mzlib/etc)
#| ------------------------------------------------------------------
(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.
To build GUI-ITEMs, they need to use make-text, make-choice,
make-button, make-choice, or make-message. A GUI-ITEM can be
added to the window only once.
|#
;; INFRASTRUCTURE OPERATIONS:
;; ------------------------------------------------------------------
(define-struct window (get-frame))
;; 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)
;; INFRASTRUCTURE OPERATIONS:
;; ------------------------------------------------------------------
(let ([the-frame (make-object frame% "GUI" false 10 10)])
(for-each (lambda (loi)
(let ((p (make-object horizontal-pane% the-frame)))
(send p set-alignment 'center 'center)
(for-each (lambda (i) ((gui-item-builder i) p)) loi)))
loi)
(let ([w (make-window (lambda () the-frame))])
(show-window w)
w)))
(define-struct window (get-frame))
;; 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)
;; (_ -> Boolean) String X -> (union String true)
(define (listoflistof? pred? pred given)
(cond
[(not (list? given)) (format NONLIST given)]
[(find-non list? given)
=> (lambda (non-list)
(format NONLISTLIST non-list))]
[(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 ------------------------------------------------------------------
(let ([the-frame (make-object frame% "GUI" false 10 10)])
(for-each (lambda (loi)
(let ((p (make-object horizontal-pane% the-frame)))
(send p set-alignment 'center 'center)
(for-each (lambda (i) ((gui-item-builder i) p)) loi)))
loi)
(let ([w (make-window (lambda () the-frame))])
(show-window w)
w)))
;; (_ -> Boolean) String X -> (union String true)
(define (listoflistof? pred? pred given)
(cond
[(not (list? given)) (format NONLIST given)]
[(find-non list? given)
=> (lambda (non-list)
(format NONLISTLIST non-list))]
[(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)))
(string=? (format NONX "number" 'a)
@ -121,74 +119,74 @@
(string=? (format NONLISTLIST 1)
(listoflistof? number? "number" '(1 (2 3) (4 5 6))))
|#
;; make-text : str -> gui-item
;; to create a text-item with label lbl
(define (make-text lbl)
(check-arg 'make-text (string? lbl) "string" "first" lbl)
(create-gui-item
(lambda (the-panel)
(make-object text-field% lbl the-panel void))))
;; make-message : str -> gui-item
;; to create a message-item with current contents txt
(define (make-message txt)
(check-arg 'make-message (string? txt) "string" "first" txt)
(create-gui-item
(lambda (the-panel)
(new message% [label txt] [parent the-panel] [stretchable-width #t]))))
;; make-button : str (event% -> boolean) -> gui-item
;; to create a button-item with label and call-back function
(define (make-button label call-back)
(check-arg 'make-button (string? label) "string" 'first label)
(check-proc 'make-button call-back 1 'second "1 argument")
(create-gui-item
(lambda (the-panel)
(make-object button% label
the-panel
(lambda (b e)
(check-result 'button-callback boolean? "Boolean" (call-back e)))))))
;; make-choice : (listof str) -> gui-item
;; to create a choice-item that permits users to choose from the
;; alternatives on loc
(define (make-choice loc)
(check-arg 'make-choice (and (list? loc) (andmap string? loc)) "list of strings" "first" loc)
(create-gui-item
(lambda (the-panel)
(make-object choice% "" loc the-panel void))))
;; DISPLAYING MESSAGES:
;; ------------------------------------------------------------------
;; draw-message : gui-item[message%] str -> true
;; to change the current contents of a message field
(define (draw-message msg txt)
(check-arg 'draw-message (gui-item? msg) "gui-item" "first" msg)
(check-arg 'draw-message (string? txt) "string" "second" txt)
(let* ([o ((gui-item-builder msg) #f)])
(when (<= (send o min-width) (string-length txt))
(let*-values ;; MF: I couldn't think of a better way of doing this
([(m) (new message% [parent (new frame% [label "hello"])][label txt])]
[(x y) (send m get-graphical-min-size)])
(send o min-width x)))
(send o set-label txt)
true))
;; PROBING ITEMS:
;; ------------------------------------------------------------------
;; text-contents : gui-item[text-field%] -> str
;; to determine the contents of a text-item
(define (text-contents 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))
;; choice-index : gui-item[choice%] -> number
;; to determine which choice is currently selected in a choice-item
(define (choice-index a-choice)
(check-arg 'choice-index (gui-item? a-choice) "gui-item" "first" a-choice)
(send ((gui-item-builder a-choice) #f) get-selection))
)
;; make-text : str -> gui-item
;; to create a text-item with label lbl
(define (make-text lbl)
(check-arg 'make-text (string? lbl) "string" "first" lbl)
(create-gui-item
(lambda (the-panel)
(make-object text-field% lbl the-panel void))))
;; make-message : str -> gui-item
;; to create a message-item with current contents txt
(define (make-message txt)
(check-arg 'make-message (string? txt) "string" "first" txt)
(create-gui-item
(lambda (the-panel)
(new message% [label txt] [parent the-panel] [stretchable-width #t]))))
;; make-button : str (event% -> boolean) -> gui-item
;; to create a button-item with label and call-back function
(define (make-button label call-back)
(check-arg 'make-button (string? label) "string" 'first label)
(check-proc 'make-button call-back 1 'second "1 argument")
(create-gui-item
(lambda (the-panel)
(make-object button% label
the-panel
(lambda (b e)
(check-result 'button-callback boolean? "Boolean" (call-back e)))))))
;; make-choice : (listof str) -> gui-item
;; to create a choice-item that permits users to choose from the
;; alternatives on loc
(define (make-choice loc)
(check-arg 'make-choice (and (list? loc) (andmap string? loc)) "list of strings" "first" loc)
(create-gui-item
(lambda (the-panel)
(make-object choice% "" loc the-panel void))))
;; DISPLAYING MESSAGES:
;; ------------------------------------------------------------------
;; draw-message : gui-item[message%] str -> true
;; to change the current contents of a message field
(define (draw-message msg txt)
(check-arg 'draw-message (gui-item? msg) "gui-item" "first" msg)
(check-arg 'draw-message (string? txt) "string" "second" txt)
(let* ([o ((gui-item-builder msg) #f)])
(when (<= (send o min-width) (string-length txt))
(let*-values ;; MF: I couldn't think of a better way of doing this
([(m) (new message% [parent (new frame% [label "hello"])][label txt])]
[(x y) (send m get-graphical-min-size)])
(send o min-width x)))
(send o set-label txt)
true))
;; PROBING ITEMS:
;; ------------------------------------------------------------------
;; text-contents : gui-item[text-field%] -> str
;; to determine the contents of a text-item
(define (text-contents 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))
;; choice-index : gui-item[choice%] -> number
;; to determine which choice is currently selected in a choice-item
(define (choice-index a-choice)
(check-arg 'choice-index (gui-item? a-choice) "gui-item" "first" a-choice)
(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
(require "hangman.ss"
"big-draw.ss"
(lib "prim.ss" "lang")
(lib "posn.ss" "lang"))
(provide go)
(define-primitive go go/proc)
#| ------------------------------------------------------------------------
#lang scheme
(require htdp/hangman
htdp/big-draw
lang/prim
lang/posn)
(provide go)
(define-primitive go go/proc)
#| ------------------------------------------------------------------------
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 l1 l2 gu)
(map (lambda (x1 x2)
(cond
[(eq? x1 gu) gu]
[else x2]))
l1 l2))
(define (go/proc x)
(start 200 400)
(hangman-list reveal-list draw-next-part))
)
(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 l1 l2 gu)
(map (lambda (x1 x2)
(cond
[(eq? x1 gu) gu]
[else x2]))
l1 l2))
(define (go/proc x)
(start 200 400)
(hangman-list reveal-list draw-next-part))

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

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