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

endOf* now consumes string and displays in separate message box

Browse Source 
svn: r3897
This commit is contained in:
Matthias Felleisen 2006-07-31 02:52:25 +00:00
parent ac9b34f3b2
commit 380d1cc92a
6 changed files with 96 additions and 91 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

2
collects/htdch/draw/World-native-methods.ss
View File

@ -2,7 +2,7 @@
(module World-native-methods mzscheme (module World-native-methods mzscheme
(require (lib "support.scm" "htdch" "draw") (lib "unitsig.ss")) (require (lib "support.scm" "htdch" "draw") (lib "unitsig.ss"))
(provide endOfTime-native endOfWorld-native bigBangO-double-native) (provide endOfTime-java.lang.String-native endOfWorld-java.lang.String-native bigBangO-double-native)
(define void-or-true #t) (define void-or-true #t)
(define (imperative world@t+1 world@t) world@t+1) (define (imperative world@t+1 world@t) world@t+1)

4
collects/htdch/draw/World.java
View File

@ -25,8 +25,8 @@ public abstract class World {
// -------------------------------------------------------- // --------------------------------------------------------
public native boolean endOfTime(); public native boolean endOfTime(String s);
public native World endOfWorld(); public native World endOfWorld(String s);
public abstract World onTick(); public abstract World onTick();
public abstract World onKeyEvent(String ke); public abstract World onKeyEvent(String ke);
public abstract boolean draw(); public abstract boolean draw();

167
collects/htdch/draw/support.scm
View File

@ -1,18 +1,19 @@
#cs #cs
(module support mzscheme (module support mzscheme
(require (lib "draw.ss" "htdp") (require (lib "draw.ss" "htdp")
(lib "posn.ss" "lang") (lib "posn.ss" "lang")
(lib "class.ss") (lib "class.ss")
(lib "unit.ss") (lib "unitsig.ss") (lib "mred.ss" "mred")
(lib "String.ss" "profj" "libs" "java" "lang") (lib "unit.ss") (lib "unitsig.ss")
(lib "Throwable.ss" "profj" "libs""java""lang") (lib "String.ss" "profj" "libs" "java" "lang")
(lib "RuntimeException.ss" "profj" "libs" "java" "lang")) (lib "Throwable.ss" "profj" "libs""java""lang")
(lib "RuntimeException.ss" "profj" "libs" "java" "lang"))
(provide world-native@ world-native^ canvas-native@ canvas-native^ support^) (provide world-native@ world-native^ canvas-native@ canvas-native^ support^)
(define-signature world-native^ (define-signature world-native^
(endOfTime-native (endOfTime-java.lang.String-native
endOfWorld-native endOfWorld-java.lang.String-native
bigBangO-double-native)) bigBangO-double-native))
(define-signature canvas-native^ (define-signature canvas-native^
@ -29,42 +30,49 @@
clearDisk-geometry.Posn-int-colors.Color-native clearDisk-geometry.Posn-int-colors.Color-native
clearRect-geometry.Posn-int-int-colors.Color-native clearRect-geometry.Posn-int-int-colors.Color-native
clearLine-geometry.Posn-geometry.Posn-colors.Color-native)) clearLine-geometry.Posn-geometry.Posn-colors.Color-native))
(define-signature support^ (void-or-true imperative)) (define-signature support^ (void-or-true imperative))
;Raises an error if string is null
;check-string: string string string -> boolean
(define (check-string value method argument)
(when (null? value)
(raise-error (format "Method ~a expects a non-null String for ~a argument, given null" method argument)))
#t)
;raises a Java exception with the specified error message
;raise-error: String -> void
(define (raise-error message)
(raise
(create-java-exception RuntimeException message
(lambda (exn str)
(send exn RuntimeException-constructor-java.lang.String str))
(current-continuation-marks))))
(define canvas-native@ (define canvas-native@
(unit/sig canvas-native^ (unit/sig canvas-native^
(import support^) (import support^)
;raises a Java exception with the specified error message
;raise-error: String -> void
(define (raise-error message)
(raise
(create-java-exception RuntimeException message
(lambda (exn str)
(send exn RuntimeException-constructor-java.lang.String str))
(current-continuation-marks))))
(define-syntax (wrap-start-check stx) (define-syntax (wrap-start-check stx)
(syntax-case stx () (syntax-case stx ()
[(_ body ...) [(_ body ...)
#'(with-handlers #'(with-handlers
((exn:fail? ((exn:fail?
(lambda (e) (lambda (e)
(raise-error (raise-error
(format (format
(string-append (string-append
"The method show() must be called on the canvas" "The method show() must be called on the canvas"
"before using any drawing methods [~s]") "before using any drawing methods [~s]")
(exn-message e)))))) (exn-message e))))))
(begin (begin body ...) void-or-true))])) (begin (begin body ...) void-or-true))]))
(define Posn-x-get (dynamic-require '(lib "Posn.ss" "htdch" "geometry") 'Posn-x-get)) (define Posn-x-get (dynamic-require '(lib "Posn.ss" "htdch" "geometry") 'Posn-x-get))
(define Posn-y-get (dynamic-require '(lib "Posn.ss" "htdch" "geometry") 'Posn-y-get)) (define Posn-y-get (dynamic-require '(lib "Posn.ss" "htdch" "geometry") 'Posn-y-get))
(define (build-posn posnO) (make-posn (Posn-x-get posnO) (Posn-y-get posnO))) (define (build-posn posnO) (make-posn (Posn-x-get posnO) (Posn-y-get posnO)))
(define (color->symbol colorO) (string->symbol (to-lower-case (send colorO my-name)))) (define (color->symbol colorO) (string->symbol (to-lower-case (send colorO my-name))))
;Raises an error if value less than or equal to 0 ;Raises an error if value less than or equal to 0
;check-arg: num string string -> boolean ;check-arg: num string string -> boolean
(define (check-arg value method argument) (define (check-arg value method argument)
@ -72,22 +80,15 @@
(raise-error (raise-error
(format "Method ~a expects an int >= 0 for ~a argument, given ~a" method argument value)))) (format "Method ~a expects an int >= 0 for ~a argument, given ~a" method argument value))))
;Raises an error if string is null
;check-string: string string string -> boolean
(define (check-string value method argument)
(when (null? value)
(raise-error (format "Method ~a expects a non-null String for ~a argument, given null" method argument)))
#t)
(define (to-lower-case s) (define (to-lower-case s)
(letrec ((lower (letrec ((lower
(lambda (s) (lambda (s)
(cond (cond
((null? s) s) ((null? s) s)
(else (cons (char-downcase (car s)) (else (cons (char-downcase (car s))
(lower (cdr s)))))))) (lower (cdr s))))))))
(list->string (lower (string->list s))))) (list->string (lower (string->list s)))))
(define (xshow-native this accs gets privates) (define (xshow-native this accs gets privates)
;; Kathy: it looks like I am working around a bug here. ;; Kathy: it looks like I am working around a bug here.
;; I really wanted to write ([hash-table-get privates 'width] this) ;; I really wanted to write ([hash-table-get privates 'width] this)
@ -99,14 +100,14 @@
(define y (with-method ([g (this Canvas-height-get)]) (g '___))) (define y (with-method ([g (this Canvas-height-get)]) (g '___)))
(start-and-export x y privates) (start-and-export x y privates)
void-or-true) void-or-true)
(define (xclose-native this accs gets privates) (define (xclose-native this accs gets privates)
(wrap-start-check ([hash-table-get privates '%stop])) (wrap-start-check ([hash-table-get privates '%stop]))
void-or-true) void-or-true)
(define (stop-native this accs gets privates) (define (stop-native this accs gets privates)
(wrap-start-check ([hash-table-get privates '%end-of-time]))) (wrap-start-check ([hash-table-get privates '%end-of-time])))
;; (copy) restores the viewport and the pixmap so that ;; (copy) restores the viewport and the pixmap so that
;; (end-draw-sequence) can copy the pixmap into the viewport. ;; (end-draw-sequence) can copy the pixmap into the viewport.
;; It also clears the pixmap from anything that was on there. ;; It also clears the pixmap from anything that was on there.
@ -118,59 +119,59 @@
;; install. I couldn't figure out how to do this at the time. ;; install. I couldn't figure out how to do this at the time.
(define (copy-native this accs gets privates) (define (copy-native this accs gets privates)
(wrap-start-check ([hash-table-get privates 'copy]))) (wrap-start-check ([hash-table-get privates 'copy])))
(define (drawCircle-geometry.Posn-int-colors.Color-native this accs gets privates posn r c) (define (drawCircle-geometry.Posn-int-colors.Color-native this accs gets privates posn r c)
(wrap-start-check (wrap-start-check
(check-arg r "drawCircle(Posn, int, Color)" "second") (check-arg r "drawCircle(Posn, int, Color)" "second")
([hash-table-get privates '%draw-circle] (build-posn posn) r (color->symbol c)))) ([hash-table-get privates '%draw-circle] (build-posn posn) r (color->symbol c))))
(define (drawDisk-geometry.Posn-int-colors.Color-native this accs gets privates posn r c) (define (drawDisk-geometry.Posn-int-colors.Color-native this accs gets privates posn r c)
(wrap-start-check (wrap-start-check
(check-arg r "drawDisk(Posn, int, Color)" "second") (check-arg r "drawDisk(Posn, int, Color)" "second")
([hash-table-get privates '%draw-solid-disk] (build-posn posn) r (color->symbol c)))) ([hash-table-get privates '%draw-solid-disk] (build-posn posn) r (color->symbol c))))
(define (drawRect-geometry.Posn-int-int-colors.Color-native this accs gets privates posn w h c) (define (drawRect-geometry.Posn-int-int-colors.Color-native this accs gets privates posn w h c)
(wrap-start-check (wrap-start-check
(check-arg w "drawRect(Posn, int, int, Color)" "second") (check-arg w "drawRect(Posn, int, int, Color)" "second")
(check-arg h "drawRect(Posn, int, int, Color)" "third") (check-arg h "drawRect(Posn, int, int, Color)" "third")
([hash-table-get privates '%draw-solid-rect] (build-posn posn) w h (color->symbol c)))) ([hash-table-get privates '%draw-solid-rect] (build-posn posn) w h (color->symbol c))))
(define (drawLine-geometry.Posn-geometry.Posn-colors.Color-native this accs gets privates p0 p1 c) (define (drawLine-geometry.Posn-geometry.Posn-colors.Color-native this accs gets privates p0 p1 c)
(wrap-start-check (wrap-start-check
([hash-table-get privates '%draw-solid-line] (build-posn p0) (build-posn p1) (color->symbol c)))) ([hash-table-get privates '%draw-solid-line] (build-posn p0) (build-posn p1) (color->symbol c))))
(define (drawString-geometry.Posn-java.lang.String-native this accs gets privates p s) (define (drawString-geometry.Posn-java.lang.String-native this accs gets privates p s)
(define _ (check-string s "drawString(Posn, String)" "second")) (define _ (check-string s "drawString(Posn, String)" "second"))
(define s* (send s get-mzscheme-string)) (define s* (send s get-mzscheme-string))
(wrap-start-check (wrap-start-check
([hash-table-get privates '%draw-string] (build-posn p) s*))) ([hash-table-get privates '%draw-string] (build-posn p) s*)))
(define (clearCircle-geometry.Posn-int-colors.Color-native this accs gets privates p r c) (define (clearCircle-geometry.Posn-int-colors.Color-native this accs gets privates p r c)
(wrap-start-check (wrap-start-check
(check-arg r "clearCircle(Posn, int, Color)" "second") (check-arg r "clearCircle(Posn, int, Color)" "second")
([hash-table-get privates '%clear-circle] (build-posn p) r (color->symbol c)))) ([hash-table-get privates '%clear-circle] (build-posn p) r (color->symbol c))))
(define (clearDisk-geometry.Posn-int-colors.Color-native this accs gets privates p r c) (define (clearDisk-geometry.Posn-int-colors.Color-native this accs gets privates p r c)
(wrap-start-check (wrap-start-check
(check-arg r "clearDisk(Posn, int, Color)" "second") (check-arg r "clearDisk(Posn, int, Color)" "second")
([hash-table-get privates '%clear-solid-disk] (build-posn p) r (color->symbol c)))) ([hash-table-get privates '%clear-solid-disk] (build-posn p) r (color->symbol c))))
(define (clearRect-geometry.Posn-int-int-colors.Color-native this accs gets privates p w h c) (define (clearRect-geometry.Posn-int-int-colors.Color-native this accs gets privates p w h c)
(wrap-start-check (wrap-start-check
(check-arg w "clearRect(Posn, int, int, Color)" "second") (check-arg w "clearRect(Posn, int, int, Color)" "second")
(check-arg h "clearRect(Posn, int, int, Color)" "third") (check-arg h "clearRect(Posn, int, int, Color)" "third")
([hash-table-get privates '%clear-solid-rect] (build-posn p) w h (color->symbol c)))) ([hash-table-get privates '%clear-solid-rect] (build-posn p) w h (color->symbol c))))
(define (clearLine-geometry.Posn-geometry.Posn-colors.Color-native this accs gets privates p0 p1 c) (define (clearLine-geometry.Posn-geometry.Posn-colors.Color-native this accs gets privates p0 p1 c)
(wrap-start-check (wrap-start-check
([hash-table-get privates '%clear-solid-line] (build-posn p0) (build-posn p1) (color->symbol c)))) ([hash-table-get privates '%clear-solid-line] (build-posn p0) (build-posn p1) (color->symbol c))))
)) ))
(define world-native@ (define world-native@
(unit/sig world-native^ (unit/sig world-native^
(import support^) (import support^)
(define (bigBangO-double-native this accs gets privates i) (define (bigBangO-double-native this accs gets privates i)
(define theCanvas ((hash-table-get accs 'theCanvas) this)) (define theCanvas ((hash-table-get accs 'theCanvas) this))
(define setCanvas (hash-table-get gets 'theCanvas)) (define setCanvas (hash-table-get gets 'theCanvas))
@ -190,21 +191,25 @@
(send theCanvas show) (send theCanvas show)
(big-bang i this) (big-bang i this)
(on-tick-event (on-tick-event
(lambda (world) (lambda (world)
(on-event world (lambda () (send world onTick))))) (on-event world (lambda () (send world onTick)))))
(on-key-event (on-key-event
(lambda (ke world) (lambda (ke world)
(define ke* (make-java-string (if (char? ke) (string ke) (symbol->string ke)))) (define ke* (make-java-string (if (char? ke) (string ke) (symbol->string ke))))
(on-event world (lambda () (send world onKeyEvent-java.lang.String ke*))))) (on-event world (lambda () (send world onKeyEvent-java.lang.String ke*)))))
void-or-true) void-or-true)
(define (endOfTime-native this accs gets privates) (define (endOfTime-java.lang.String-native this accs gets privates s)
(define theCanvas ((hash-table-get accs 'theCanvas) this)) (define theCanvas ((hash-table-get accs 'theCanvas) this))
(define _ (check-string s "endOfTime(String)" "first"))
(message-box "end of time" (send s get-mzscheme-string))
(send theCanvas stop) (send theCanvas stop)
#t) #t)
(define (endOfWorld-native this accs gets privates) (define (endOfWorld-java.lang.String-native this accs gets privates s)
(define theCanvas ((hash-table-get accs 'theCanvas) this)) (define theCanvas ((hash-table-get accs 'theCanvas) this))
(define _ (check-string s "endOfWorld(String)" "first"))
(message-box "end of world" (send s get-mzscheme-string))
(send theCanvas stop) (send theCanvas stop)
this))) this)))
) )

2
collects/htdch/idraw/World-native-methods.ss
View File

@ -2,7 +2,7 @@
(module World-native-methods mzscheme (module World-native-methods mzscheme
(require (lib "support.scm" "htdch" "draw") (lib "unitsig.ss")) (require (lib "support.scm" "htdch" "draw") (lib "unitsig.ss"))
(provide endOfTime-native endOfWorld-native bigBangO-double-native) (provide endOfTime-java.lang.String-native endOfWorld-java.lang.String-native bigBangO-double-native)
(define void-or-true void) (define void-or-true void)
(define (imperative world@t+1 world@t) world@t) (define (imperative world@t+1 world@t) world@t)

4
collects/htdch/idraw/World.java
View File

@ -26,8 +26,8 @@ public abstract class World {
// -------------------------------------------------------- // --------------------------------------------------------
public native boolean endOfTime(); public native boolean endOfTime(String s);
public native World endOfWorld(); public native World endOfWorld(String s);
public abstract void onTick(); public abstract void onTick();
public abstract void onKeyEvent(String ke); public abstract void onKeyEvent(String ke);
public abstract void draw(); public abstract void draw();

8
collects/teachpack/htdc/Docs/draw.thtml
View File

@ -14,8 +14,8 @@ import geometry.*;
| Canvas theCanvas |------>| Canvas | | Canvas theCanvas |------>| Canvas |
+-----------------------------------+ +---------------------------------------+ +-----------------------------------+ +---------------------------------------+
| boolean bigBang(int,int,double) | +---------------------------------------+ | boolean bigBang(int,int,double) | +---------------------------------------+
| boolean endOfTime() | | boolean show() | | boolean endOfTime(String) | | boolean show() |
| World endOfWorld() | | boolean close() | | World endOfWorld(String) | | boolean close() |
| | | boolean drawCircle(Posn,int,Color) | | | | boolean drawCircle(Posn,int,Color) |
| | | boolean drawDisk(Posn,int,Color) | | | | boolean drawDisk(Posn,int,Color) |
| abstract World onTick() | | boolean drawRect(Posn,int,int,Color) | | abstract World onTick() | | boolean drawRect(Posn,int,int,Color) |
@ -51,13 +51,13 @@ produces <code>true</code>.
</p> </p>
</li> </li>
<li><code>endOfTime</code>, stops the clock and, if it succeeds, produces <li><code>endOfTime</code>, displays the given message, stops the clock and, if it succeeds, produces
<code>true</code>. After the end of time, events no longer trigger calls <code>true</code>. After the end of time, events no longer trigger calls
to <code>onTick</code> or <code>onKeyEvent</code> (see below). The canvas to <code>onTick</code> or <code>onKeyEvent</code> (see below). The canvas
remains visible. remains visible.
</li> </li>
<li><code>endOfWorld</code>, stops the clock and, if it succeeds, produces the <li><code>endOfWorld</code>, displays the given message, stops the clock and, if it succeeds, produces the
last <code>World</code>. After the end of the world, events no longer trigger calls last <code>World</code>. After the end of the world, events no longer trigger calls
to <code>onTick</code> or <code>onKeyEvent</code> (see below). The canvas to <code>onTick</code> or <code>onKeyEvent</code> (see below). The canvas
remains visible. remains visible.