From fb644c1cafe4f74d082f7722ccf0e29ae207bd28 Mon Sep 17 00:00:00 2001 From: Matthias Felleisen Date: Fri, 25 Apr 2008 00:50:03 +0000 Subject: [PATCH] relevant teachpacks converted svn: r9470 --- collects/htdp/Test/TEST | 19 +- collects/htdp/Test/TODO | 4 - collects/htdp/Test/arrow-gui.ss | 29 +- collects/htdp/Test/arrow.ss | 14 +- collects/htdp/Test/convert.ss | 30 +- collects/htdp/Test/dir.ss | 8 +- collects/htdp/Test/docs.ss | 22 +- collects/htdp/Test/draw.ss | 92 +- collects/htdp/Test/elevator.ss | 6 +- collects/htdp/Test/graphing.ss | 16 +- collects/htdp/Test/guess1.ss | 9 +- collects/htdp/Test/guess2.ss | 12 +- collects/htdp/Test/guess3.ss | 12 +- collects/htdp/Test/gui.ss | 15 +- collects/htdp/Test/hangman1.ss | 20 +- collects/htdp/Test/hangman2.ss | 50 - collects/htdp/Test/lkup-gui.ss | 13 +- collects/htdp/Test/master.ss | 11 +- collects/htdp/Test/matrix-test.ss | 13 +- collects/htdp/Test/pingp-play.ss | 6 - collects/htdp/Test/pingp-trace.ss | 101 -- collects/htdp/Test/pingp.ss | 103 -- collects/htdp/Test/protect.ss | 113 --- collects/htdp/Test/tester.ss | 4 + collects/htdp/arrow-gui.ss | 171 ++-- collects/htdp/arrow.ss | 257 +++-- collects/htdp/big-draw.ss | 643 ++++++------ collects/htdp/convert.ss | 497 +++++----- collects/htdp/dir.ss | 2 +- collects/htdp/docs.ss | 206 ++-- collects/htdp/draw-sig.ss | 94 +- collects/htdp/draw.ss | 43 +- collects/htdp/elevator.ss | 1528 ++++++++++++++--------------- collects/htdp/graphing.ss | 173 ++-- collects/htdp/guess.ss | 360 +++---- collects/htdp/gui.ss | 338 ++++--- collects/htdp/hangman-play.ss | 93 +- collects/htdp/lkup-gui.ss | 125 +-- collects/htdp/master.ss | 300 +++--- 39 files changed, 2569 insertions(+), 2983 deletions(-) delete mode 100644 collects/htdp/Test/hangman2.ss delete mode 100644 collects/htdp/Test/pingp-play.ss delete mode 100644 collects/htdp/Test/pingp-trace.ss delete mode 100644 collects/htdp/Test/pingp.ss delete mode 100644 collects/htdp/Test/protect.ss diff --git a/collects/htdp/Test/TEST b/collects/htdp/Test/TEST index 4669131705..e9a5b50f53 100644 --- a/collects/htdp/Test/TEST +++ b/collects/htdp/Test/TEST @@ -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 diff --git a/collects/htdp/Test/TODO b/collects/htdp/Test/TODO index 8838db08f2..fd66b5a698 100644 --- a/collects/htdp/Test/TODO +++ b/collects/htdp/Test/TODO @@ -1,7 +1,3 @@ -teachpack/htdp -collects/htdp - svn commit -m "" - ----------------------------------------------------------------------------------- docs: diff --git a/collects/htdp/Test/arrow-gui.ss b/collects/htdp/Test/arrow-gui.ss index ce9bcded35..7dd9b52985 100644 --- a/collects/htdp/Test/arrow-gui.ss +++ b/collects/htdp/Test/arrow-gui.ss @@ -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) diff --git a/collects/htdp/Test/arrow.ss b/collects/htdp/Test/arrow.ss index 0868284b62..a013b1352f 100644 --- a/collects/htdp/Test/arrow.ss +++ b/collects/htdp/Test/arrow.ss @@ -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") diff --git a/collects/htdp/Test/convert.ss b/collects/htdp/Test/convert.ss index 91ce2fd576..add77950a8 100644 --- a/collects/htdp/Test/convert.ss +++ b/collects/htdp/Test/convert.ss @@ -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 ; 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 ; given 212") -(test-error (convert-file IN f2c 10)) -;; convert-file: expected 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 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) \ No newline at end of file diff --git a/collects/htdp/Test/dir.ss b/collects/htdp/Test/dir.ss index 9b66c06ff6..9ce427b5a8 100644 --- a/collects/htdp/Test/dir.ss +++ b/collects/htdp/Test/dir.ss @@ -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) diff --git a/collects/htdp/Test/docs.ss b/collects/htdp/Test/docs.ss index d6696cd879..cfa86d97eb 100644 --- a/collects/htdp/Test/docs.ss +++ b/collects/htdp/Test/docs.ss @@ -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? ') -(not (annotation? 'html)) -(annotation? '

) +(check-expect (annotation? ') true) +(check-expect (annotation? 'html) false) +(check-expect (annotation? '

) true) -(eq? ' (end-annotation ')) +(check-expect (end-annotation ') ') -(write-file - (list '

'hello 'world 'is 'the 'most 'stupid 'program 'in 'the 'world '

- "so let's test this" 'with "How's that")) +(check-expect + (write-file + (list '

'hello 'world 'is 'the 'most 'stupid 'program 'in 'the 'world '

+ "so let's test this" 'with "How's that")) + true) diff --git a/collects/htdp/Test/draw.ss b/collects/htdp/Test/draw.ss index 84be0ffe1c..b5a84975ce 100644 --- a/collects/htdp/Test/draw.ss +++ b/collects/htdp/Test/draw.ss @@ -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) diff --git a/collects/htdp/Test/elevator.ss b/collects/htdp/Test/elevator.ss index 62b2d3634b..f217ba209c 100644 --- a/collects/htdp/Test/elevator.ss +++ b/collects/htdp/Test/elevator.ss @@ -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, diff --git a/collects/htdp/Test/graphing.ss b/collects/htdp/Test/graphing.ss index 9e125b8477..4068437eb1 100644 --- a/collects/htdp/Test/graphing.ss +++ b/collects/htdp/Test/graphing.ss @@ -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) diff --git a/collects/htdp/Test/guess1.ss b/collects/htdp/Test/guess1.ss index 40acd88ada..a162136fbb 100644 --- a/collects/htdp/Test/guess1.ss +++ b/collects/htdp/Test/guess1.ss @@ -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) diff --git a/collects/htdp/Test/guess2.ss b/collects/htdp/Test/guess2.ss index 3afa125d5b..67d0ddb90d 100644 --- a/collects/htdp/Test/guess2.ss +++ b/collects/htdp/Test/guess2.ss @@ -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) diff --git a/collects/htdp/Test/guess3.ss b/collects/htdp/Test/guess3.ss index 6353cd9b9c..acf45f46d3 100644 --- a/collects/htdp/Test/guess3.ss +++ b/collects/htdp/Test/guess3.ss @@ -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) diff --git a/collects/htdp/Test/gui.ss b/collects/htdp/Test/gui.ss index dcc26bcf30..577b78eb18 100644 --- a/collects/htdp/Test/gui.ss +++ b/collects/htdp/Test/gui.ss @@ -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))))))) diff --git a/collects/htdp/Test/hangman1.ss b/collects/htdp/Test/hangman1.ss index cca1a13c43..0757474134 100644 --- a/collects/htdp/Test/hangman1.ss +++ b/collects/htdp/Test/hangman1.ss @@ -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") diff --git a/collects/htdp/Test/hangman2.ss b/collects/htdp/Test/hangman2.ss deleted file mode 100644 index 0d80cddb14..0000000000 --- a/collects/htdp/Test/hangman2.ss +++ /dev/null @@ -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) - diff --git a/collects/htdp/Test/lkup-gui.ss b/collects/htdp/Test/lkup-gui.ss index f23ef44aaa..32c71f2f93 100644 --- a/collects/htdp/Test/lkup-gui.ss +++ b/collects/htdp/Test/lkup-gui.ss @@ -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) diff --git a/collects/htdp/Test/master.ss b/collects/htdp/Test/master.ss index cb48eac94d..cc091f2037 100644 --- a/collects/htdp/Test/master.ss +++ b/collects/htdp/Test/master.ss @@ -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) ...) diff --git a/collects/htdp/Test/matrix-test.ss b/collects/htdp/Test/matrix-test.ss index f15d167493..127e9f4a99 100644 --- a/collects/htdp/Test/matrix-test.ss +++ b/collects/htdp/Test/matrix-test.ss @@ -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) diff --git a/collects/htdp/Test/pingp-play.ss b/collects/htdp/Test/pingp-play.ss deleted file mode 100644 index b168aa1261..0000000000 --- a/collects/htdp/Test/pingp-play.ss +++ /dev/null @@ -1,6 +0,0 @@ -;; TeachPack: -;; 1. pingp-play.ss -;; 2. protect-play.ss -;; Language: Beginner - -(go 'Matthias) diff --git a/collects/htdp/Test/pingp-trace.ss b/collects/htdp/Test/pingp-trace.ss deleted file mode 100644 index 34eec186ed..0000000000 --- a/collects/htdp/Test/pingp-trace.ss +++ /dev/null @@ -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) diff --git a/collects/htdp/Test/pingp.ss b/collects/htdp/Test/pingp.ss deleted file mode 100644 index 166ead5e12..0000000000 --- a/collects/htdp/Test/pingp.ss +++ /dev/null @@ -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) diff --git a/collects/htdp/Test/protect.ss b/collects/htdp/Test/protect.ss deleted file mode 100644 index c0144df357..0000000000 --- a/collects/htdp/Test/protect.ss +++ /dev/null @@ -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) diff --git a/collects/htdp/Test/tester.ss b/collects/htdp/Test/tester.ss index ec08672de2..0497b77645 100644 --- a/collects/htdp/Test/tester.ss +++ b/collects/htdp/Test/tester.ss @@ -1,3 +1,7 @@ +#lang scheme + +(provide test-error) + (define-syntax test-error (lambda (stx) (syntax-case stx () diff --git a/collects/htdp/arrow-gui.ss b/collects/htdp/arrow-gui.ss index 97cba9c7c8..4d24b04462 100644 --- a/collects/htdp/arrow-gui.ss +++ b/collects/htdp/arrow-gui.ss @@ -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)) diff --git a/collects/htdp/arrow.ss b/collects/htdp/arrow.ss index a2eb5ece6d..92e454b9eb 100644 --- a/collects/htdp/arrow.ss +++ b/collects/htdp/arrow.ss @@ -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)) + diff --git a/collects/htdp/big-draw.ss b/collects/htdp/big-draw.ss index 87adc6f90a..c33b962db8 100644 --- a/collects/htdp/big-draw.ss +++ b/collects/htdp/big-draw.ss @@ -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 ) 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 ) 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)))))) diff --git a/collects/htdp/convert.ss b/collects/htdp/convert.ss index 93d60381e3..187e6a2835 100644 --- a/collects/htdp/convert.ss +++ b/collects/htdp/convert.ss @@ -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 [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 [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))))) ; ) diff --git a/collects/htdp/dir.ss b/collects/htdp/dir.ss index 0ead86c7e8..16773119db 100644 --- a/collects/htdp/dir.ss +++ b/collects/htdp/dir.ss @@ -1,7 +1,7 @@ #lang scheme (require htdp/error - (lib "prim.ss" "lang")) + lang/prim) (provide create-dir ; path -> Directory diff --git a/collects/htdp/docs.ss b/collects/htdp/docs.ss index e20760ca21..46c9d76fca 100644 --- a/collects/htdp/docs.ss +++ b/collects/htdp/docs.ss @@ -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 " bool +(define (line-breaking? x) + (and (annotation? x) (memq x LNBRK) #t)) + +(define LNBRK + (let ((x '( <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) + + diff --git a/collects/htdp/draw-sig.ss b/collects/htdp/draw-sig.ss index bd5c02eabc..29986c53c5 100644 --- a/collects/htdp/draw-sig.ss +++ b/collects/htdp/draw-sig.ss @@ -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^ ()) diff --git a/collects/htdp/draw.ss b/collects/htdp/draw.ss index 8116d00d65..c7c4ec55da 100644 --- a/collects/htdp/draw.ss +++ b/collects/htdp/draw.ss @@ -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^) diff --git a/collects/htdp/elevator.ss b/collects/htdp/elevator.ss index 5d6b20d6d5..3f12655052 100644 --- a/collects/htdp/elevator.ss +++ b/collects/htdp/elevator.ss @@ -1,818 +1,816 @@ -(module elevator mzscheme - (require htdp/big-draw - htdp/error - (lib "posn.ss" "lang") - mzlib/etc - mred - (lib "prim.ss" "lang")) - - ;; Implementation: - ;; Stephanie Weirich (1994), - ;; Mark Krentel (1995), - ;; Matthias Felleisen (1996) - - (provide run) - - (define-higher-order-primitive run run/proc (elevator-controller)) - - ;; There are really three distinct levels: graphics, hardware, - ;; and software. Don't mix them! - - ;; - ;; HARDWARE/GRAPHICS level for Elevator. - ;; This level provides the basic primitives for writing an elevator. - ;; The hardware level are the guards for the graphics level. - ;; - ;; Hardware functions: - ;; - ;; make-elevator max-floor - ;; current-floor move-up-floor move-down-floor - ;; update-input wait-for-input - ;; open? open-doors close-doors - ;; up-call? down-call? demand? - ;; clear-up-call clear-down-call clear-demand - ;; busy-wait info - ;; - - ;; Compute the layout and draw the window. - - (define init-graphics - (lambda () - (init-layout-and-window) - (init-shaft) - (init-calls) - (init-info) - (init-demands) - (init-stop) - (init-car) - (busy-wait 800) - (draw-open-doors))) - - ;; - ;; Overall layout for the window. - ;; Currently need max-floor >= 4. - ;; - - (define BORDER 100) - (define SHAFT-INFO-GAP 40) - (define STOP-DEMAND-GAP 50) - - (define init-layout-and-window - (lambda () - (let* - ([shaft (make-posn BORDER BORDER)] - [call (add-hv shaft SHAFT-WIDTH 0)] - [top (add-hv call CALL-WIDTH 0)] - [bot (add-hv top 0 (* (max-floor) FLOOR-SIZE))] - [info (add-hv top SHAFT-INFO-GAP 0)] - [stop (add-hv bot SHAFT-INFO-GAP (- STOP-HEIGHT))] - [demand (add-hv stop 0 (- 0 STOP-DEMAND-GAP DEMAND-HEIGHT))] - [horiz (+ (posn-x info) STOP-WIDTH BORDER)] - [vert (+ (posn-y bot) BORDER)]) - (set! SHAFT-ORIGIN shaft) - (set! CALL-ORIGIN call) - (set! INFO-ORIGIN info) - (set! STOP-ORIGIN stop) - (set! DEMAND-ORIGIN demand) - (init-window horiz vert)))) - - ;; - ;; Window primitives for lines, strings, mouse clicks. - ;; These should be the only functions that use elev-win. - ;; - - (define elev-win #f) - (define d-line #f) - (define c-line #f) - (define d-string #f) - (define c-string #f) - (define mouse-click? (lambda () (ready-mouse-click elev-win))) - (define wait-for-click (lambda () (get-mouse-click elev-win))) - - (define init-window - (lambda (horiz vert) - (set! elev-win (open-viewport "Elevator Simulation" horiz vert)) - (set! d-line (draw-line elev-win)) - (set! c-line (clear-line elev-win)) - (set! d-string (draw-string elev-win)) - (set! c-string (clear-string elev-win)))) - - (define d-string-bf - (lambda (posn string) - (d-string posn string) - (d-string (add-hv posn 1 0) string))) - - (define c-string-bf - (lambda (posn string) - (c-string posn string) - (c-string (add-hv posn 1 0) string))) - - ;; - ;; Helper functions for position, offsets, etc. - ;; SIXLib should provide better primitives here. - ;; - - (define under? (lambda (p1 p2) (> (posn-y p1) (posn-y p2)))) - - (define add-posn - (lambda (p1 p2) - (make-posn (+ (posn-x p1) (posn-x p2)) - (+ (posn-y p1) (posn-y p2))))) - - (define add-hv - (lambda (p horiz vert) - (make-posn (+ (posn-x p) horiz) - (+ (posn-y p) vert)))) - - ;; - ;; Low-level primitives for lines, rectangles, etc. - ;; - - (define paint-rect - (lambda (origin horiz vert) - (when (>= vert 0) - (let ([right (add-hv origin horiz 0)] - [next (add-hv origin 0 +1)]) - (d-line origin right) - (paint-rect next horiz (- vert 1)))))) - - (define outline-rect - (lambda (origin horiz vert thick) - (let* ([x0 (posn-x origin)] [y0 (posn-y origin)]) - (recur loop ([lf x0] [rt (+ x0 horiz thick -1)] - [top y0] [bot (+ y0 vert thick -1)] - [n thick]) - (when (> n 0) - (d-line (make-posn lf top) (make-posn rt top)) - (d-line (make-posn rt top) (make-posn rt bot)) - (d-line (make-posn rt bot) (make-posn lf bot)) - (d-line (make-posn lf bot) (make-posn lf top)) - (loop (+ lf 1) (- rt 1) (+ top 1) (- bot 1) (- n 1))))))) - - (define clear-inside-rect - (lambda (origin horiz vert thick) - (recur loop ([lf (add-hv origin thick thick)] - [rt (add-hv origin (- horiz 1) thick)] - [n thick]) - (when (< n vert) - (c-line lf rt) - (loop (add-hv lf 0 +1) (add-hv rt 0 +1) (+ n 1)))))) - - ;; - ;; Elevator Shaft and Car - ;; - - (define SHAFT-ORIGIN #f) - (define STOP-ORIGIN #f) - (define SHAFT-WIDTH 64) - (define FLOOR-SIZE 64) - (define CAR-WIDTH 44) - (define CAR-HEIGHT 44) - (define MIN-DOOR-SEP 3) - (define NUMBER-POSN (make-posn -22 (floor (/ FLOOR-SIZE 2)))) - - (define init-shaft - (lambda () - (let ([height (* (max-floor) FLOOR-SIZE)]) - (outline-rect SHAFT-ORIGIN SHAFT-WIDTH height 2) - (recur loop ([p (add-posn SHAFT-ORIGIN NUMBER-POSN)] - [n (max-floor)]) - (when (>= n 1) - (d-string-bf p (number->string n)) - (loop (add-hv p 0 FLOOR-SIZE) (- n 1))))))) - - (define init-car - (lambda () - (let* ([origin (car-posn 1)]) - (outline-rect origin CAR-WIDTH CAR-HEIGHT 1) - (outline-rect origin (floor (/ CAR-WIDTH 2)) CAR-HEIGHT 1)))) - - (define car-posn - (lambda (n) - (add-hv SHAFT-ORIGIN - (floor (/ (- SHAFT-WIDTH CAR-WIDTH) 2)) - (+ (floor (/ (- FLOOR-SIZE CAR-HEIGHT) 2)) - (* (- (max-floor) n) FLOOR-SIZE))))) - - (define move-car-door - (lambda (horiz delta) - (let* ([origin (car-posn (current-floor))] - [old-top (add-hv origin horiz +1)] - [old-bot (add-hv origin horiz (- CAR-HEIGHT 1))] - [new-top (add-hv old-top delta 0)] - [new-bot (add-hv old-bot delta 0)]) - (d-line new-top new-bot) - (c-line old-top old-bot)))) - - (define draw-open-doors - (lambda () - (recur loop ([lf (floor (/ CAR-WIDTH 2))] - [rt (ceiling (/ CAR-WIDTH 2))]) - (when (< MIN-DOOR-SEP lf) - (move-car-door lf -1) - (move-car-door rt +1) - (busy-wait) - (loop (- lf 1) (+ rt 1)))) - (draw-little-man))) - - (define draw-close-doors - (lambda () - (recur loop ([lf MIN-DOOR-SEP] - [rt (- CAR-WIDTH MIN-DOOR-SEP)]) - (when (>= (- rt lf) 2) - (move-car-door lf +1) - (move-car-door rt -1) - (busy-wait) - (loop (+ lf 1) (- rt 1)))))) - - (define move-fwd-edge - (lambda (origin delta) - (let* ([new-lf (add-hv origin 0 delta)] - [new-rt (add-hv origin CAR-WIDTH delta)] - [old-1-lf (add-hv origin +1 0)] - [old-1-rt (add-hv origin (- (floor (/ CAR-WIDTH 2)) 1) 0)] - [old-2-lf (add-hv origin (+ (ceiling (/ CAR-WIDTH 2)) 1) 0)] - [old-2-rt (add-hv origin (- CAR-WIDTH 1) 0)]) - (d-line new-lf new-rt) - (c-line old-1-lf old-1-rt) - (c-line old-2-lf old-2-rt)))) - - (define move-back-edge - (lambda (origin delta) - (let* ([new-lf (add-hv origin 0 delta)] - [new-rt (add-hv origin CAR-WIDTH delta)] - [old-lf origin] - [old-rt (add-hv origin CAR-WIDTH 0)]) - (d-line new-lf new-rt) - (c-line old-lf old-rt)))) - - (define draw-up-floor - (lambda () - (let ([goal (car-posn (+ (current-floor) 1))]) - (recur loop ([cur (car-posn (current-floor))]) - (when (under? cur goal) - (move-fwd-edge cur -1) - (move-back-edge (add-hv cur 0 CAR-HEIGHT) -1) - (busy-wait) - (loop (add-hv cur 0 -1))))))) - - (define draw-down-floor - (lambda () - (let ([goal (car-posn (- (current-floor) 1))]) - (recur loop ([cur (car-posn (current-floor))]) - (when (under? goal cur) - (move-fwd-edge (add-hv cur 0 CAR-HEIGHT) +1) - (move-back-edge cur +1) - (busy-wait) - (loop (add-hv cur 0 +1))))))) - - ;; This is probably going too far ... - ;; But he's more than just a list of lines! - - (define MAN-POSN (make-posn 18 14)) - - (define LITTLE-MAN - (list (make-posn 5 0) (make-posn 9 0) ; head - (make-posn 9 0) (make-posn 9 4) - (make-posn 9 4) (make-posn 5 4) - (make-posn 5 4) (make-posn 5 0) - (make-posn 7 4) (make-posn 7 12) ; body - (make-posn 7 12) (make-posn 2 23) ; legs - (make-posn 7 12) (make-posn 12 23) - (make-posn 0 23) (make-posn 2 23) ; feet - (make-posn 12 23) (make-posn 14 23) - (make-posn 1 8) (make-posn 13 8) ; arms - (make-posn 0 9) (make-posn 1 8) ; hands - (make-posn 13 8) (make-posn 14 7))) - - (define draw-little-man - (lambda () - (let ([origin (add-posn (car-posn (current-floor)) MAN-POSN)]) - (recur loop ([l LITTLE-MAN]) - (unless (null? l) - (d-line (add-posn origin (car l)) - (add-posn origin (cadr l))) - (loop (cddr l))))))) - - ;; - ;; Call Buttons - ;; - - (define CALL-ORIGIN #f) - (define CALL-WIDTH 50) - (define CALL-HEIGHT (floor (/ FLOOR-SIZE 2))) - - (define UP-CALL-SHAPE - (list (make-posn 13 28) (make-posn 25 4) (make-posn 37 28))) - (define DOWN-CALL-SHAPE - (list (make-posn 13 4) (make-posn 25 28) (make-posn 37 4))) - - (define UP-CALL-POSN - (lambda (floor) - (add-hv CALL-ORIGIN 0 (* FLOOR-SIZE (- (max-floor) floor))))) - - (define DOWN-CALL-POSN - (lambda (floor) - (add-hv (UP-CALL-POSN floor) 0 CALL-HEIGHT))) - - (define init-calls - (lambda () - (recur loop ([n 1]) - (when (<= n (max-floor)) - (outline-rect (UP-CALL-POSN n) CALL-WIDTH FLOOR-SIZE 2) - (outline-call (UP-CALL-POSN n) UP-CALL-SHAPE) - (outline-call (DOWN-CALL-POSN n) DOWN-CALL-SHAPE) - (loop (+ n 1)))))) - - (define draw-clear-up - (lambda (floor) - (clear-call (UP-CALL-POSN floor) UP-CALL-SHAPE) - (outline-call (UP-CALL-POSN floor) UP-CALL-SHAPE))) - - (define draw-clear-down - (lambda (floor) - (clear-call (DOWN-CALL-POSN floor) DOWN-CALL-SHAPE) - (outline-call (DOWN-CALL-POSN floor) DOWN-CALL-SHAPE))) - - (define paint-up-call - (lambda (floor) - (paint-call (UP-CALL-POSN floor) UP-CALL-SHAPE))) - - (define paint-down-call - (lambda (floor) - (paint-call (DOWN-CALL-POSN floor) DOWN-CALL-SHAPE))) - - (define outline-call - (lambda (origin l) - (let* ([p (add-posn origin (car l))] - [q (add-posn origin (cadr l))] - [r (add-posn origin (caddr l))]) - (d-line p q) - (d-line q r) - (d-line r p)))) - - (define clear-call - (lambda (origin l) - (let* ([p (add-posn origin (car l))] - [q (add-posn origin (cadr l))] - [r (add-posn origin (caddr l))] - [top (min (posn-y p) (posn-y q))] - [bot (max (posn-y p) (posn-y q))]) - (recur loop ([y (+ top 1)]) - (when (< y bot) - (let ([lf (ceiling (x-val p q y))] - [rt (floor (x-val q r y))]) - (c-line (make-posn lf y) (make-posn rt y)) - (loop (+ y 1)))))))) - - (define paint-call - (lambda (origin l) - (let* ([p (add-posn origin (car l))] - [q (add-posn origin (cadr l))] - [r (add-posn origin (caddr l))] - [top (min (posn-y p) (posn-y q))] - [bot (max (posn-y p) (posn-y q))]) - (recur loop ([y (+ top 1)]) - (when (< y bot) - (let ([lf (ceiling (x-val p q y))] - [rt (floor (x-val q r y))]) - (d-line (make-posn lf y) (make-posn rt y)) - (loop (+ y 1)))))))) - - (define x-val - (lambda (a b y) - (let ([ax (posn-x a)] [ay (posn-y a)] - [bx (posn-x b)] [by (posn-y b)]) - (+ ax (* (/ (- y ay) (- by ay)) - (- bx ax)))))) - - ;; - ;; Demand Buttons - ;; - - (define DEMAND-ORIGIN #f) - (define DEMAND-WIDTH 40) - (define DEMAND-HEIGHT 40) - (define DEMAND-TEXT (make-posn 18 25)) - - (define DEMAND-POSN - (let ([HORIZ (+ DEMAND-WIDTH 20)] - [VERT (+ DEMAND-HEIGHT 20)]) - (lambda (i) - (let ([x (remainder (sub1 i) 2)] - [y (quotient (sub1 i) 2)]) - (add-hv DEMAND-ORIGIN (* x HORIZ) (* -1 y VERT)))))) - - (define init-demands - (lambda () - (recur loop ([n 1]) - (when (<= n (max-floor)) - (outline-rect (DEMAND-POSN n) DEMAND-WIDTH DEMAND-HEIGHT 2) - (d-string-bf (add-posn (DEMAND-POSN n) DEMAND-TEXT) (number->string n)) - (loop (+ n 1)))))) - - (define paint-demand - (lambda (k) - (let ([nw (DEMAND-POSN k)]) - (paint-rect nw DEMAND-WIDTH DEMAND-HEIGHT) - (c-string-bf (add-posn nw DEMAND-TEXT) (number->string k))))) - - (define draw-clear-demand - (lambda (k) - (clear-inside-rect (DEMAND-POSN k) DEMAND-WIDTH DEMAND-HEIGHT 2) - (d-string-bf (add-posn (DEMAND-POSN k) DEMAND-TEXT) (number->string k)))) - - ;; - ;; "Stop Program" Button - ;; - - (define STOP-WIDTH 100) - (define STOP-HEIGHT 40) - (define STOP-TEXT (make-posn 15 25)) - - (define init-stop - (lambda () - (outline-rect STOP-ORIGIN STOP-WIDTH STOP-HEIGHT 2) - (d-string (add-posn STOP-ORIGIN STOP-TEXT) "Stop Program"))) - - ;; - ;; Mouse Clicks - ;; Look for up/down calls, demands and stop-program button. - ;; If you can get access to a real-time clock, then change the - ;; delay loop to use sleep-for or real-time. - ;; The units are (fake) milliseconds. - ;; SCALE is the multiplier for waiting time. - ;; SCALE > 1 slows down the simulation. - ;; - - (define DEFAULT-WAIT 25) - (define SCALE 0.75) - - (define busy-wait - (lambda l - (let* ([cur-time (current-milliseconds)] - [wait-time (if (null? l) DEFAULT-WAIT (car l))] - [new-time (+ cur-time (* SCALE wait-time))]) - (recur loop () - (check-buttons) - (yield) - (when (< (current-milliseconds) new-time) - (loop)))))) - - (define check-buttons - (lambda () - (let ([click (mouse-click?)]) - (when click - (process-click click) - (check-buttons))))) - - (define wait-for-button - (lambda () - (let ([click (wait-for-click)]) - (process-click click) - (check-buttons)))) - - (define process-click - (lambda (click) - (recur loop ([n 1]) - (cond - [(> n (max-floor)) (void)] - [(click-here? click (UP-CALL-POSN n) CALL-WIDTH CALL-HEIGHT) - (push-up-call n)] - [(click-here? click (DOWN-CALL-POSN n) CALL-WIDTH CALL-HEIGHT) - (push-down-call n)] - [(click-here? click (DEMAND-POSN n) DEMAND-WIDTH DEMAND-HEIGHT) - (push-demand n)] - [(click-here? click STOP-ORIGIN STOP-WIDTH STOP-HEIGHT) - (push-stop)] - [else (loop (+ n 1))])))) - - (define click-here? - (lambda (click origin horiz vert) - (let* ([x0 (posn-x origin)] - [y0 (posn-y origin)] - [x (posn-x (mouse-click-posn click))] - [y (posn-y (mouse-click-posn click))]) - (and (<= x0 x (+ x0 horiz)) +#lang scheme/gui + +(require htdp/big-draw + htdp/error + lang/prim + lang/posn + mzlib/etc) + +;; Implementation: +;; Stephanie Weirich (1994), +;; Mark Krentel (1995), +;; Matthias Felleisen (1996) + +(provide run) + +(define-higher-order-primitive run run/proc (elevator-controller)) + +;; There are really three distinct levels: graphics, hardware, +;; and software. Don't mix them! + +;; +;; HARDWARE/GRAPHICS level for Elevator. +;; This level provides the basic primitives for writing an elevator. +;; The hardware level are the guards for the graphics level. +;; +;; Hardware functions: +;; +;; make-elevator max-floor +;; current-floor move-up-floor move-down-floor +;; update-input wait-for-input +;; open? open-doors close-doors +;; up-call? down-call? demand? +;; clear-up-call clear-down-call clear-demand +;; busy-wait info +;; + +;; Compute the layout and draw the window. + +(define init-graphics + (lambda () + (init-layout-and-window) + (init-shaft) + (init-calls) + (init-info) + (init-demands) + (init-stop) + (init-car) + (busy-wait 800) + (draw-open-doors))) + +;; +;; Overall layout for the window. +;; Currently need max-floor >= 4. +;; + +(define BORDER 100) +(define SHAFT-INFO-GAP 40) +(define STOP-DEMAND-GAP 50) + +(define init-layout-and-window + (lambda () + (let* + ([shaft (make-posn BORDER BORDER)] + [call (add-hv shaft SHAFT-WIDTH 0)] + [top (add-hv call CALL-WIDTH 0)] + [bot (add-hv top 0 (* (max-floor) FLOOR-SIZE))] + [info (add-hv top SHAFT-INFO-GAP 0)] + [stop (add-hv bot SHAFT-INFO-GAP (- STOP-HEIGHT))] + [demand (add-hv stop 0 (- 0 STOP-DEMAND-GAP DEMAND-HEIGHT))] + [horiz (+ (posn-x info) STOP-WIDTH BORDER)] + [vert (+ (posn-y bot) BORDER)]) + (set! SHAFT-ORIGIN shaft) + (set! CALL-ORIGIN call) + (set! INFO-ORIGIN info) + (set! STOP-ORIGIN stop) + (set! DEMAND-ORIGIN demand) + (init-window horiz vert)))) + +;; +;; Window primitives for lines, strings, mouse clicks. +;; These should be the only functions that use elev-win. +;; + +(define elev-win #f) +(define d-line #f) +(define c-line #f) +(define d-string #f) +(define c-string #f) +(define mouse-click? (lambda () (ready-mouse-click elev-win))) +(define wait-for-click (lambda () (get-mouse-click elev-win))) + +(define init-window + (lambda (horiz vert) + (set! elev-win (open-viewport "Elevator Simulation" horiz vert)) + (set! d-line (draw-line elev-win)) + (set! c-line (clear-line elev-win)) + (set! d-string (draw-string elev-win)) + (set! c-string (clear-string elev-win)))) + +(define d-string-bf + (lambda (posn string) + (d-string posn string) + (d-string (add-hv posn 1 0) string))) + +(define c-string-bf + (lambda (posn string) + (c-string posn string) + (c-string (add-hv posn 1 0) string))) + +;; +;; Helper functions for position, offsets, etc. +;; SIXLib should provide better primitives here. +;; + +(define under? (lambda (p1 p2) (> (posn-y p1) (posn-y p2)))) + +(define add-posn + (lambda (p1 p2) + (make-posn (+ (posn-x p1) (posn-x p2)) + (+ (posn-y p1) (posn-y p2))))) + +(define add-hv + (lambda (p horiz vert) + (make-posn (+ (posn-x p) horiz) + (+ (posn-y p) vert)))) + +;; +;; Low-level primitives for lines, rectangles, etc. +;; + +(define paint-rect + (lambda (origin horiz vert) + (when (>= vert 0) + (let ([right (add-hv origin horiz 0)] + [next (add-hv origin 0 +1)]) + (d-line origin right) + (paint-rect next horiz (- vert 1)))))) + +(define outline-rect + (lambda (origin horiz vert thick) + (let* ([x0 (posn-x origin)] [y0 (posn-y origin)]) + (recur loop ([lf x0] [rt (+ x0 horiz thick -1)] + [top y0] [bot (+ y0 vert thick -1)] + [n thick]) + (when (> n 0) + (d-line (make-posn lf top) (make-posn rt top)) + (d-line (make-posn rt top) (make-posn rt bot)) + (d-line (make-posn rt bot) (make-posn lf bot)) + (d-line (make-posn lf bot) (make-posn lf top)) + (loop (+ lf 1) (- rt 1) (+ top 1) (- bot 1) (- n 1))))))) + +(define clear-inside-rect + (lambda (origin horiz vert thick) + (recur loop ([lf (add-hv origin thick thick)] + [rt (add-hv origin (- horiz 1) thick)] + [n thick]) + (when (< n vert) + (c-line lf rt) + (loop (add-hv lf 0 +1) (add-hv rt 0 +1) (+ n 1)))))) + +;; +;; Elevator Shaft and Car +;; + +(define SHAFT-ORIGIN #f) +(define STOP-ORIGIN #f) +(define SHAFT-WIDTH 64) +(define FLOOR-SIZE 64) +(define CAR-WIDTH 44) +(define CAR-HEIGHT 44) +(define MIN-DOOR-SEP 3) +(define NUMBER-POSN (make-posn -22 (floor (/ FLOOR-SIZE 2)))) + +(define init-shaft + (lambda () + (let ([height (* (max-floor) FLOOR-SIZE)]) + (outline-rect SHAFT-ORIGIN SHAFT-WIDTH height 2) + (recur loop ([p (add-posn SHAFT-ORIGIN NUMBER-POSN)] + [n (max-floor)]) + (when (>= n 1) + (d-string-bf p (number->string n)) + (loop (add-hv p 0 FLOOR-SIZE) (- n 1))))))) + +(define init-car + (lambda () + (let* ([origin (car-posn 1)]) + (outline-rect origin CAR-WIDTH CAR-HEIGHT 1) + (outline-rect origin (floor (/ CAR-WIDTH 2)) CAR-HEIGHT 1)))) + +(define car-posn + (lambda (n) + (add-hv SHAFT-ORIGIN + (floor (/ (- SHAFT-WIDTH CAR-WIDTH) 2)) + (+ (floor (/ (- FLOOR-SIZE CAR-HEIGHT) 2)) + (* (- (max-floor) n) FLOOR-SIZE))))) + +(define move-car-door + (lambda (horiz delta) + (let* ([origin (car-posn (current-floor))] + [old-top (add-hv origin horiz +1)] + [old-bot (add-hv origin horiz (- CAR-HEIGHT 1))] + [new-top (add-hv old-top delta 0)] + [new-bot (add-hv old-bot delta 0)]) + (d-line new-top new-bot) + (c-line old-top old-bot)))) + +(define draw-open-doors + (lambda () + (recur loop ([lf (floor (/ CAR-WIDTH 2))] + [rt (ceiling (/ CAR-WIDTH 2))]) + (when (< MIN-DOOR-SEP lf) + (move-car-door lf -1) + (move-car-door rt +1) + (busy-wait) + (loop (- lf 1) (+ rt 1)))) + (draw-little-man))) + +(define draw-close-doors + (lambda () + (recur loop ([lf MIN-DOOR-SEP] + [rt (- CAR-WIDTH MIN-DOOR-SEP)]) + (when (>= (- rt lf) 2) + (move-car-door lf +1) + (move-car-door rt -1) + (busy-wait) + (loop (+ lf 1) (- rt 1)))))) + +(define move-fwd-edge + (lambda (origin delta) + (let* ([new-lf (add-hv origin 0 delta)] + [new-rt (add-hv origin CAR-WIDTH delta)] + [old-1-lf (add-hv origin +1 0)] + [old-1-rt (add-hv origin (- (floor (/ CAR-WIDTH 2)) 1) 0)] + [old-2-lf (add-hv origin (+ (ceiling (/ CAR-WIDTH 2)) 1) 0)] + [old-2-rt (add-hv origin (- CAR-WIDTH 1) 0)]) + (d-line new-lf new-rt) + (c-line old-1-lf old-1-rt) + (c-line old-2-lf old-2-rt)))) + +(define move-back-edge + (lambda (origin delta) + (let* ([new-lf (add-hv origin 0 delta)] + [new-rt (add-hv origin CAR-WIDTH delta)] + [old-lf origin] + [old-rt (add-hv origin CAR-WIDTH 0)]) + (d-line new-lf new-rt) + (c-line old-lf old-rt)))) + +(define draw-up-floor + (lambda () + (let ([goal (car-posn (+ (current-floor) 1))]) + (recur loop ([cur (car-posn (current-floor))]) + (when (under? cur goal) + (move-fwd-edge cur -1) + (move-back-edge (add-hv cur 0 CAR-HEIGHT) -1) + (busy-wait) + (loop (add-hv cur 0 -1))))))) + +(define draw-down-floor + (lambda () + (let ([goal (car-posn (- (current-floor) 1))]) + (recur loop ([cur (car-posn (current-floor))]) + (when (under? goal cur) + (move-fwd-edge (add-hv cur 0 CAR-HEIGHT) +1) + (move-back-edge cur +1) + (busy-wait) + (loop (add-hv cur 0 +1))))))) + +;; This is probably going too far ... +;; But he's more than just a list of lines! + +(define MAN-POSN (make-posn 18 14)) + +(define LITTLE-MAN + (list (make-posn 5 0) (make-posn 9 0) ; head + (make-posn 9 0) (make-posn 9 4) + (make-posn 9 4) (make-posn 5 4) + (make-posn 5 4) (make-posn 5 0) + (make-posn 7 4) (make-posn 7 12) ; body + (make-posn 7 12) (make-posn 2 23) ; legs + (make-posn 7 12) (make-posn 12 23) + (make-posn 0 23) (make-posn 2 23) ; feet + (make-posn 12 23) (make-posn 14 23) + (make-posn 1 8) (make-posn 13 8) ; arms + (make-posn 0 9) (make-posn 1 8) ; hands + (make-posn 13 8) (make-posn 14 7))) + +(define draw-little-man + (lambda () + (let ([origin (add-posn (car-posn (current-floor)) MAN-POSN)]) + (recur loop ([l LITTLE-MAN]) + (unless (null? l) + (d-line (add-posn origin (car l)) + (add-posn origin (cadr l))) + (loop (cddr l))))))) + +;; +;; Call Buttons +;; + +(define CALL-ORIGIN #f) +(define CALL-WIDTH 50) +(define CALL-HEIGHT (floor (/ FLOOR-SIZE 2))) + +(define UP-CALL-SHAPE + (list (make-posn 13 28) (make-posn 25 4) (make-posn 37 28))) +(define DOWN-CALL-SHAPE + (list (make-posn 13 4) (make-posn 25 28) (make-posn 37 4))) + +(define UP-CALL-POSN + (lambda (floor) + (add-hv CALL-ORIGIN 0 (* FLOOR-SIZE (- (max-floor) floor))))) + +(define DOWN-CALL-POSN + (lambda (floor) + (add-hv (UP-CALL-POSN floor) 0 CALL-HEIGHT))) + +(define init-calls + (lambda () + (recur loop ([n 1]) + (when (<= n (max-floor)) + (outline-rect (UP-CALL-POSN n) CALL-WIDTH FLOOR-SIZE 2) + (outline-call (UP-CALL-POSN n) UP-CALL-SHAPE) + (outline-call (DOWN-CALL-POSN n) DOWN-CALL-SHAPE) + (loop (+ n 1)))))) + +(define draw-clear-up + (lambda (floor) + (clear-call (UP-CALL-POSN floor) UP-CALL-SHAPE) + (outline-call (UP-CALL-POSN floor) UP-CALL-SHAPE))) + +(define draw-clear-down + (lambda (floor) + (clear-call (DOWN-CALL-POSN floor) DOWN-CALL-SHAPE) + (outline-call (DOWN-CALL-POSN floor) DOWN-CALL-SHAPE))) + +(define paint-up-call + (lambda (floor) + (paint-call (UP-CALL-POSN floor) UP-CALL-SHAPE))) + +(define paint-down-call + (lambda (floor) + (paint-call (DOWN-CALL-POSN floor) DOWN-CALL-SHAPE))) + +(define outline-call + (lambda (origin l) + (let* ([p (add-posn origin (car l))] + [q (add-posn origin (cadr l))] + [r (add-posn origin (caddr l))]) + (d-line p q) + (d-line q r) + (d-line r p)))) + +(define clear-call + (lambda (origin l) + (let* ([p (add-posn origin (car l))] + [q (add-posn origin (cadr l))] + [r (add-posn origin (caddr l))] + [top (min (posn-y p) (posn-y q))] + [bot (max (posn-y p) (posn-y q))]) + (recur loop ([y (+ top 1)]) + (when (< y bot) + (let ([lf (ceiling (x-val p q y))] + [rt (floor (x-val q r y))]) + (c-line (make-posn lf y) (make-posn rt y)) + (loop (+ y 1)))))))) + +(define paint-call + (lambda (origin l) + (let* ([p (add-posn origin (car l))] + [q (add-posn origin (cadr l))] + [r (add-posn origin (caddr l))] + [top (min (posn-y p) (posn-y q))] + [bot (max (posn-y p) (posn-y q))]) + (recur loop ([y (+ top 1)]) + (when (< y bot) + (let ([lf (ceiling (x-val p q y))] + [rt (floor (x-val q r y))]) + (d-line (make-posn lf y) (make-posn rt y)) + (loop (+ y 1)))))))) + +(define x-val + (lambda (a b y) + (let ([ax (posn-x a)] [ay (posn-y a)] + [bx (posn-x b)] [by (posn-y b)]) + (+ ax (* (/ (- y ay) (- by ay)) + (- bx ax)))))) + +;; +;; Demand Buttons +;; + +(define DEMAND-ORIGIN #f) +(define DEMAND-WIDTH 40) +(define DEMAND-HEIGHT 40) +(define DEMAND-TEXT (make-posn 18 25)) + +(define DEMAND-POSN + (let ([HORIZ (+ DEMAND-WIDTH 20)] + [VERT (+ DEMAND-HEIGHT 20)]) + (lambda (i) + (let ([x (remainder (sub1 i) 2)] + [y (quotient (sub1 i) 2)]) + (add-hv DEMAND-ORIGIN (* x HORIZ) (* -1 y VERT)))))) + +(define init-demands + (lambda () + (recur loop ([n 1]) + (when (<= n (max-floor)) + (outline-rect (DEMAND-POSN n) DEMAND-WIDTH DEMAND-HEIGHT 2) + (d-string-bf (add-posn (DEMAND-POSN n) DEMAND-TEXT) (number->string n)) + (loop (+ n 1)))))) + +(define paint-demand + (lambda (k) + (let ([nw (DEMAND-POSN k)]) + (paint-rect nw DEMAND-WIDTH DEMAND-HEIGHT) + (c-string-bf (add-posn nw DEMAND-TEXT) (number->string k))))) + +(define draw-clear-demand + (lambda (k) + (clear-inside-rect (DEMAND-POSN k) DEMAND-WIDTH DEMAND-HEIGHT 2) + (d-string-bf (add-posn (DEMAND-POSN k) DEMAND-TEXT) (number->string k)))) + +;; +;; "Stop Program" Button +;; + +(define STOP-WIDTH 100) +(define STOP-HEIGHT 40) +(define STOP-TEXT (make-posn 15 25)) + +(define init-stop + (lambda () + (outline-rect STOP-ORIGIN STOP-WIDTH STOP-HEIGHT 2) + (d-string (add-posn STOP-ORIGIN STOP-TEXT) "Stop Program"))) + +;; +;; Mouse Clicks +;; Look for up/down calls, demands and stop-program button. +;; If you can get access to a real-time clock, then change the +;; delay loop to use sleep-for or real-time. +;; The units are (fake) milliseconds. +;; SCALE is the multiplier for waiting time. +;; SCALE > 1 slows down the simulation. +;; + +(define DEFAULT-WAIT 25) +(define SCALE 0.75) + +(define busy-wait + (lambda l + (let* ([cur-time (current-milliseconds)] + [wait-time (if (null? l) DEFAULT-WAIT (car l))] + [new-time (+ cur-time (* SCALE wait-time))]) + (recur loop () + (check-buttons) + (yield) + (when (< (current-milliseconds) new-time) + (loop)))))) + +(define check-buttons + (lambda () + (let ([click (mouse-click?)]) + (when click + (process-click click) + (check-buttons))))) + +(define wait-for-button + (lambda () + (let ([click (wait-for-click)]) + (process-click click) + (check-buttons)))) + +(define process-click + (lambda (click) + (recur loop ([n 1]) + (cond + [(> n (max-floor)) (void)] + [(click-here? click (UP-CALL-POSN n) CALL-WIDTH CALL-HEIGHT) + (push-up-call n)] + [(click-here? click (DOWN-CALL-POSN n) CALL-WIDTH CALL-HEIGHT) + (push-down-call n)] + [(click-here? click (DEMAND-POSN n) DEMAND-WIDTH DEMAND-HEIGHT) + (push-demand n)] + [(click-here? click STOP-ORIGIN STOP-WIDTH STOP-HEIGHT) + (push-stop)] + [else (loop (+ n 1))])))) + +(define click-here? + (lambda (click origin horiz vert) + (let* ([x0 (posn-x origin)] + [y0 (posn-y origin)] + [x (posn-x (mouse-click-posn click))] + [y (posn-y (mouse-click-posn click))]) + (and (<= x0 x (+ x0 horiz)) (<= y0 y (+ y0 vert)))))) - ;; - ;; Info - ;; Just floor, goal, dir. - ;; +;; +;; Info +;; Just floor, goal, dir. +;; - (define INFO-ORIGIN #f) - (define-struct einfo (sym posn label prev)) +(define INFO-ORIGIN #f) +(define-struct einfo (sym posn label prev) #:mutable) - (define INFO-LIST - (list (make-einfo 'floor (make-posn 0 12) "floor = " #f) - (make-einfo 'goal (make-posn 0 28) "goal = " #f) - (make-einfo 'dir (make-posn 0 44) "dir = " #f))) +(define INFO-LIST + (list (make-einfo 'floor (make-posn 0 12) "floor = " #f) + (make-einfo 'goal (make-posn 0 28) "goal = " #f) + (make-einfo 'dir (make-posn 0 44) "dir = " #f))) - (define init-info - (lambda () - (let loop ([l INFO-LIST]) - (unless (null? l) - (set-einfo-prev! (car l) "") - (loop (cdr l)))) - (info 'floor 1) - (info 'goal 1) - (info 'dir 'none))) +(define init-info + (lambda () + (let loop ([l INFO-LIST]) + (unless (null? l) + (set-einfo-prev! (car l) "") + (loop (cdr l)))) + (info 'floor 1) + (info 'goal 1) + (info 'dir 'none))) - (define my-lookup - (lambda (sym) - (let loop ([l INFO-LIST]) - (cond - [(null? l) (error 'info "Unknown info type: ~e" sym)] - [(eq? sym (einfo-sym (car l))) (car l)] - [else (loop (cdr l))])))) +(define my-lookup + (lambda (sym) + (let loop ([l INFO-LIST]) + (cond + [(null? l) (error 'info "Unknown info type: ~e" sym)] + [(eq? sym (einfo-sym (car l))) (car l)] + [else (loop (cdr l))])))) - (define info - (lambda (sym obj) - (let* ([item (my-lookup sym)] - [posn (add-posn INFO-ORIGIN (einfo-posn item))] - [str (if (string? obj) obj (format "~s" obj))] - [full-str (string-append (einfo-label item) str)]) - (unless (string=? full-str (einfo-prev item)) - (c-string posn (einfo-prev item)) - (d-string posn full-str) - (set-einfo-prev! item full-str))))) +(define info + (lambda (sym obj) + (let* ([item (my-lookup sym)] + [posn (add-posn INFO-ORIGIN (einfo-posn item))] + [str (if (string? obj) obj (format "~s" obj))] + [full-str (string-append (einfo-label item) str)]) + (unless (string=? full-str (einfo-prev item)) + (c-string posn (einfo-prev item)) + (d-string posn full-str) + (set-einfo-prev! item full-str))))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - ;; ;; - ;; Functions to show to the outside world. ;; - ;; ;; +;; ;; +;; Functions to show to the outside world. ;; +;; ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - ;; This is really the (virtual) elevator hardware level. - ;; This includes state and the basic elevator operations. - ;; You write an elevator from these primitives. - ;; - ;; This could be a separate module, but you'd just write all of - ;; these functions twice. Also, they make nice guards for the - ;; graphics functions. +;; This is really the (virtual) elevator hardware level. +;; This includes state and the basic elevator operations. +;; You write an elevator from these primitives. +;; +;; This could be a separate module, but you'd just write all of +;; these functions twice. Also, they make nice guards for the +;; graphics functions. - ;; Elevator State - ;; - ;; the-floor = integer 1..THE-MAX-FLOOR - ;; the-doors = 'open, 'closed - ;; up-call-vec, down-call-vec, demand-vec = vectors 1..THE-MAX-FLOOR - ;; for buttons, #t = pushed, #f = not pushed +;; Elevator State +;; +;; the-floor = integer 1..THE-MAX-FLOOR +;; the-doors = 'open, 'closed +;; up-call-vec, down-call-vec, demand-vec = vectors 1..THE-MAX-FLOOR +;; for buttons, #t = pushed, #f = not pushed - (define max-floor #f) - (define the-floor #f) - (define the-doors #f) - (define up-call-vec #f) - (define down-call-vec #f) - (define demand-vec #f) - (define exit-continuation #f) +(define max-floor #f) +(define the-floor #f) +(define the-doors #f) +(define up-call-vec #f) +(define down-call-vec #f) +(define demand-vec #f) +(define exit-continuation #f) - ;; Initialize the hardware state and draw the picture. - ;; f = THE-MAX-FLOOR, k = exit continuation +;; Initialize the hardware state and draw the picture. +;; f = THE-MAX-FLOOR, k = exit continuation - (define make-elevator - (lambda (f k) - (let ([n (add1 f)]) - (set! max-floor (lambda () f)) - (set! exit-continuation k) - (set! the-floor 1) - (set! the-doors 'open) - (set! up-call-vec (build-vector n (lambda (i) #f))) - (set! down-call-vec (build-vector n (lambda (i) #f))) - (set! demand-vec (build-vector n (lambda (i) #f))) - (init-graphics)))) +(define make-elevator + (lambda (f k) + (let ([n (add1 f)]) + (set! max-floor (lambda () f)) + (set! exit-continuation k) + (set! the-floor 1) + (set! the-doors 'open) + (set! up-call-vec (build-vector n (lambda (i) #f))) + (set! down-call-vec (build-vector n (lambda (i) #f))) + (set! demand-vec (build-vector n (lambda (i) #f))) + (init-graphics)))) - (define push-stop - (lambda () (exit-continuation 'game-over))) +(define push-stop + (lambda () (exit-continuation 'game-over))) - ;; Functions that use the-floor. - ;; Only (move-up-floor) and (move-down-floor) are allowed to use - ;; the-floor and THE-MAX-FLOOR directly. +;; Functions that use the-floor. +;; Only (move-up-floor) and (move-down-floor) are allowed to use +;; the-floor and THE-MAX-FLOOR directly. - (define current-floor (lambda () the-floor)) +(define current-floor (lambda () the-floor)) - (define move-up-floor - (lambda () - (if (= the-floor (max-floor)) - (error 'move-up-floor "Elevator already at MAX-FLOOR") - (begin (info 'dir 'up) - ;; (info 'floor (format "~s~s" the-floor '+)) - (when (open?) (close-doors)) - (draw-up-floor) - (set! the-floor (add1 the-floor)) - (info 'floor the-floor))))) +(define move-up-floor + (lambda () + (if (= the-floor (max-floor)) + (error 'move-up-floor "Elevator already at MAX-FLOOR") + (begin (info 'dir 'up) + ;; (info 'floor (format "~s~s" the-floor '+)) + (when (open?) (close-doors)) + (draw-up-floor) + (set! the-floor (add1 the-floor)) + (info 'floor the-floor))))) - (define move-down-floor - (lambda () - (if (= the-floor 1) - (error 'move-down-floor "Elevator already at ground floor") - (begin (info 'dir 'down) - ;; (info 'floor (format "~s~s" the-floor '-)) - (when (open?) (close-doors)) - (draw-down-floor) - (set! the-floor (sub1 the-floor)) - (info 'floor the-floor))))) +(define move-down-floor + (lambda () + (if (= the-floor 1) + (error 'move-down-floor "Elevator already at ground floor") + (begin (info 'dir 'down) + ;; (info 'floor (format "~s~s" the-floor '-)) + (when (open?) (close-doors)) + (draw-down-floor) + (set! the-floor (sub1 the-floor)) + (info 'floor the-floor))))) - ;; Functions that use the-doors. - ;; Again, only (open-doors) and (close-doors) are allowed to use - ;; the-doors directly. +;; Functions that use the-doors. +;; Again, only (open-doors) and (close-doors) are allowed to use +;; the-doors directly. - (define open? (lambda () (eq? the-doors 'open))) +(define open? (lambda () (eq? the-doors 'open))) - (define open-doors - (lambda () - (unless (open?) - (draw-open-doors) - (set! the-doors 'open)))) +(define open-doors + (lambda () + (unless (open?) + (draw-open-doors) + (set! the-doors 'open)))) - (define close-doors - (lambda () - (when (open?) - (draw-close-doors) - (set! the-doors 'closed)))) +(define close-doors + (lambda () + (when (open?) + (draw-close-doors) + (set! the-doors 'closed)))) - ;; Functions that use buttons: up/down-calls, demands. - ;; Again, these are the only functions that are allowed to use - ;; up/down-calls and demands directly. +;; Functions that use buttons: up/down-calls, demands. +;; Again, these are the only functions that are allowed to use +;; up/down-calls and demands directly. - (define up-call? (lambda (floor) (vector-ref up-call-vec floor))) - (define down-call? (lambda (floor) (vector-ref down-call-vec floor))) - (define demand? (lambda (floor) (vector-ref demand-vec floor))) +(define up-call? (lambda (floor) (vector-ref up-call-vec floor))) +(define down-call? (lambda (floor) (vector-ref down-call-vec floor))) +(define demand? (lambda (floor) (vector-ref demand-vec floor))) - (define update-input check-buttons) - (define wait-for-input wait-for-button) +(define update-input check-buttons) +(define wait-for-input wait-for-button) - (define clear-up-call - (lambda (floor) - (when (up-call? floor) - (draw-clear-up floor) - (vector-set! up-call-vec floor #f)))) +(define clear-up-call + (lambda (floor) + (when (up-call? floor) + (draw-clear-up floor) + (vector-set! up-call-vec floor #f)))) - (define clear-down-call - (lambda (floor) - (when (down-call? floor) - (draw-clear-down floor) - (vector-set! down-call-vec floor #f)))) +(define clear-down-call + (lambda (floor) + (when (down-call? floor) + (draw-clear-down floor) + (vector-set! down-call-vec floor #f)))) - (define clear-demand - (lambda (floor) - (when (demand? floor) - (draw-clear-demand floor) - (vector-set! demand-vec floor #f)))) +(define clear-demand + (lambda (floor) + (when (demand? floor) + (draw-clear-demand floor) + (vector-set! demand-vec floor #f)))) - ;; The push functions are not visible outside, but they need to - ;; be here because graphics calls them. +;; The push functions are not visible outside, but they need to +;; be here because graphics calls them. - (define push-up-call - (lambda (floor) - (when (not (up-call? floor)) - (paint-up-call floor) - (vector-set! up-call-vec floor #t)))) +(define push-up-call + (lambda (floor) + (when (not (up-call? floor)) + (paint-up-call floor) + (vector-set! up-call-vec floor #t)))) - (define push-down-call - (lambda (floor) - (when (not (down-call? floor)) - (paint-down-call floor) - (vector-set! down-call-vec floor #t)))) +(define push-down-call + (lambda (floor) + (when (not (down-call? floor)) + (paint-down-call floor) + (vector-set! down-call-vec floor #t)))) - (define push-demand - (lambda (floor) - (when (not (demand? floor)) - (paint-demand floor) - (vector-set! demand-vec floor #t)))) +(define push-demand + (lambda (floor) + (when (not (demand? floor)) + (paint-demand floor) + (vector-set! demand-vec floor #t)))) - ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - ;; ;; - ;; SOFTWARE level for elevator. ;; - ;; ;; - ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; ;; +;; SOFTWARE level for elevator. ;; +;; ;; +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - ;; Here, you design your own elevator, using the primitives from - ;; the graphics-module and the user's Control function. +;; Here, you design your own elevator, using the primitives from +;; the graphics-module and the user's Control function. - (define THE-MAX-FLOOR 8) +(define THE-MAX-FLOOR 8) - (define start-program - (lambda () - (dynamic-wind - (lambda () - (unless (graphics-open?) (open-graphics))) - (lambda () - (call/cc - (lambda (k) - (make-elevator THE-MAX-FLOOR k) - (elevator 'open #f 'up)))) - close-graphics) - (void))) +(define start-program + (lambda () + (dynamic-wind + (lambda () + (unless (graphics-open?) (open-graphics))) + (lambda () + (call/cc + (lambda (k) + (make-elevator THE-MAX-FLOOR k) + (elevator 'open #f 'up)))) + close-graphics) + (lambda () #t))) - ;; - ;; Main Loop. - ;; - ;; This version gives the user complete control. - ;; All we do is ask the user for a goal, move one floor closer, - ;; check to see if we're at the goal (stop and open doors if so), - ;; and ask for another goal. - ;; Any kind of fairness or ignoring the down-calls when moving up - ;; is totally up to Control. - ;; - ;; floor, goal = integer 1..THE-MAX-FLOOR - ;; state = 'arrive, 'open, 'wait, 'move - ;; 'arrive = just arrived at this floor, check if it's the goal - ;; 'open = open doors, wait, ignore goal, get new one - ;; 'wait = no requests, wait until there is one - ;; 'move = start moving toward the goal - ;; dir = 'up, 'down - ;; - ;; We call new-goal at each floor. - ;; +;; +;; Main Loop. +;; +;; This version gives the user complete control. +;; All we do is ask the user for a goal, move one floor closer, +;; check to see if we're at the goal (stop and open doors if so), +;; and ask for another goal. +;; Any kind of fairness or ignoring the down-calls when moving up +;; is totally up to Control. +;; +;; floor, goal = integer 1..THE-MAX-FLOOR +;; state = 'arrive, 'open, 'wait, 'move +;; 'arrive = just arrived at this floor, check if it's the goal +;; 'open = open doors, wait, ignore goal, get new one +;; 'wait = no requests, wait until there is one +;; 'move = start moving toward the goal +;; dir = 'up, 'down +;; +;; We call new-goal at each floor. +;; - (define OPEN-DOOR-WAIT-TIME 1500) +(define OPEN-DOOR-WAIT-TIME 1500) - (define elevator - (lambda (state goal dir) - (let ([floor (current-floor)]) - (cond - [(eq? state 'arrive) - (if (= floor goal) - (elevator 'open goal dir) - (elevator 'move (new-goal dir) dir))] - [(eq? state 'open) - (begin - (open-doors) - (clear-all-buttons floor) - (busy-wait OPEN-DOOR-WAIT-TIME) - (update-input) - (clear-all-buttons floor) - (elevator 'wait (new-goal dir) dir))] - [(eq? state 'wait) - (if (= floor goal) - (begin - (update-input) - (clear-all-buttons floor) - (wait-for-request) - (elevator 'wait (new-goal dir) dir)) - (elevator 'move goal dir))] - [(= goal floor) - (elevator 'open goal dir)] - [(< goal floor) - (begin - (move-down-floor) - (elevator 'arrive goal 'down))] - [(> goal floor) - (begin - (move-up-floor) - (elevator 'arrive goal 'up))] - [else (error 'elevator "Internal error in main loop")])))) +(define elevator + (lambda (state goal dir) + (let ([floor (current-floor)]) + (cond + [(eq? state 'arrive) + (if (= floor goal) + (elevator 'open goal dir) + (elevator 'move (new-goal dir) dir))] + [(eq? state 'open) + (begin + (open-doors) + (clear-all-buttons floor) + (busy-wait OPEN-DOOR-WAIT-TIME) + (update-input) + (clear-all-buttons floor) + (elevator 'wait (new-goal dir) dir))] + [(eq? state 'wait) + (if (= floor goal) + (begin + (update-input) + (clear-all-buttons floor) + (wait-for-request) + (elevator 'wait (new-goal dir) dir)) + (elevator 'move goal dir))] + [(= goal floor) + (elevator 'open goal dir)] + [(< goal floor) + (begin + (move-down-floor) + (elevator 'arrive goal 'down))] + [(> goal floor) + (begin + (move-up-floor) + (elevator 'arrive goal 'up))] + [else (error 'elevator "Internal error in main loop")])))) - ;; Don't get stuck on the same floor forever. +;; Don't get stuck on the same floor forever. - (define clear-all-buttons - (lambda (floor) - (clear-up-call floor) - (clear-down-call floor) - (clear-demand floor))) +(define clear-all-buttons + (lambda (floor) + (clear-up-call floor) + (clear-down-call floor) + (clear-demand floor))) - ;; Don't return until at least one button is pushed. +;; Don't return until at least one button is pushed. - (define wait-for-request - (lambda () - (recur loop ([n 1]) - (cond - [(> n (max-floor)) (wait-for-input)] - [(or (up-call? n) (down-call? n) (demand? n)) #t] - [else (loop (add1 n))])))) +(define wait-for-request + (lambda () + (recur loop ([n 1]) + (cond + [(> n (max-floor)) (wait-for-input)] + [(or (up-call? n) (down-call? n) (demand? n)) #t] + [else (loop (add1 n))])))) - ;; Call the user's function Control and check that the floor is valid. +;; Call the user's function Control and check that the floor is valid. - (define list-of-floors - (lambda () - (recur loop ([f (max-floor)] [l null]) - (cond - [(= f 0) l] - [(or (up-call? f) (down-call? f) (demand? f)) - (loop (sub1 f) (cons f l))] - [else (loop (sub1 f) l)])))) +(define list-of-floors + (lambda () + (recur loop ([f (max-floor)] [l null]) + (cond + [(= f 0) l] + [(or (up-call? f) (down-call? f) (demand? f)) + (loop (sub1 f) (cons f l))] + [else (loop (sub1 f) l)])))) - (define new-goal - (lambda (dir) - (update-input) - (let - ([ans (Next-Floor dir (current-floor) (list-of-floors))]) - (if (and (integer? ans) (exact? ans) (<= 1 ans (max-floor))) - (begin (info 'goal ans) ans) - (error 'Next-Floor "~e is not a valid floor number" ans))))) +(define new-goal + (lambda (dir) + (update-input) + (let + ([ans (Next-Floor dir (current-floor) (list-of-floors))]) + (if (and (integer? ans) (exact? ans) (<= 1 ans (max-floor))) + (begin (info 'goal ans) ans) + (error 'Next-Floor "~e is not a valid floor number" ans))))) - ;; Functions to show the user. - ;; Remember, the elevator calls Next-Floor, not the other way. +;; Functions to show the user. +;; Remember, the elevator calls Next-Floor, not the other way. - (define Next-Floor (lambda x (error 'Next-Floor "undefined"))) - - (define run/proc - (lambda (f) - (check-proc 'run f 3 'first "3 arguments") - (set! Next-Floor f) - (start-program))) +(define Next-Floor (lambda x (error 'Next-Floor "undefined"))) - ) +(define run/proc + (lambda (f) + (check-proc 'run f 3 'first "3 arguments") + (set! Next-Floor f) + (start-program))) diff --git a/collects/htdp/graphing.ss b/collects/htdp/graphing.ss index 9bb3f722b6..54099fe262 100644 --- a/collects/htdp/graphing.ss +++ b/collects/htdp/graphing.ss @@ -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) diff --git a/collects/htdp/guess.ss b/collects/htdp/guess.ss index c41b3647de..d7e991df3d 100644 --- a/collects/htdp/guess.ss +++ b/collects/htdp/guess.ss @@ -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))) - diff --git a/collects/htdp/gui.ss b/collects/htdp/gui.ss index 91e08ed1fc..fd1bb80b62 100644 --- a/collects/htdp/gui.ss +++ b/collects/htdp/gui.ss @@ -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)) + + diff --git a/collects/htdp/hangman-play.ss b/collects/htdp/hangman-play.ss index 6643381073..51b69a4f2b 100644 --- a/collects/htdp/hangman-play.ss +++ b/collects/htdp/hangman-play.ss @@ -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)) + diff --git a/collects/htdp/lkup-gui.ss b/collects/htdp/lkup-gui.ss index 5dc5292619..979c2dfa8e 100644 --- a/collects/htdp/lkup-gui.ss +++ b/collects/htdp/lkup-gui.ss @@ -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))) + diff --git a/collects/htdp/master.ss b/collects/htdp/master.ss index a46f1c5b0e..3badf0e388 100644 --- a/collects/htdp/master.ss +++ b/collects/htdp/master.ss @@ -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)