diff --git a/collects/htdch/draw/World-native-methods.ss b/collects/htdch/draw/World-native-methods.ss
index 77b111eeeb..e177ef122a 100644
--- a/collects/htdch/draw/World-native-methods.ss
+++ b/collects/htdch/draw/World-native-methods.ss
@@ -2,7 +2,7 @@
(module World-native-methods mzscheme
(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 (imperative world@t+1 world@t) world@t+1)
diff --git a/collects/htdch/draw/World.java b/collects/htdch/draw/World.java
index 4dd7575daf..c62a2093cd 100644
--- a/collects/htdch/draw/World.java
+++ b/collects/htdch/draw/World.java
@@ -25,8 +25,8 @@ public abstract class World {
// --------------------------------------------------------
- public native boolean endOfTime();
- public native World endOfWorld();
+ public native boolean endOfTime(String s);
+ public native World endOfWorld(String s);
public abstract World onTick();
public abstract World onKeyEvent(String ke);
public abstract boolean draw();
diff --git a/collects/htdch/draw/support.scm b/collects/htdch/draw/support.scm
index cd73d8af41..1e3ec7a4bc 100644
--- a/collects/htdch/draw/support.scm
+++ b/collects/htdch/draw/support.scm
@@ -1,18 +1,19 @@
#cs
(module support mzscheme
(require (lib "draw.ss" "htdp")
- (lib "posn.ss" "lang")
- (lib "class.ss")
- (lib "unit.ss") (lib "unitsig.ss")
- (lib "String.ss" "profj" "libs" "java" "lang")
- (lib "Throwable.ss" "profj" "libs""java""lang")
- (lib "RuntimeException.ss" "profj" "libs" "java" "lang"))
+ (lib "posn.ss" "lang")
+ (lib "class.ss")
+ (lib "mred.ss" "mred")
+ (lib "unit.ss") (lib "unitsig.ss")
+ (lib "String.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^)
(define-signature world-native^
- (endOfTime-native
- endOfWorld-native
+ (endOfTime-java.lang.String-native
+ endOfWorld-java.lang.String-native
bigBangO-double-native))
(define-signature canvas-native^
@@ -29,42 +30,49 @@
clearDisk-geometry.Posn-int-colors.Color-native
clearRect-geometry.Posn-int-int-colors.Color-native
clearLine-geometry.Posn-geometry.Posn-colors.Color-native))
-
+
(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@
(unit/sig canvas-native^
(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)
(syntax-case stx ()
[(_ body ...)
#'(with-handlers
- ((exn:fail?
- (lambda (e)
- (raise-error
+ ((exn:fail?
+ (lambda (e)
+ (raise-error
(format
- (string-append
- "The method show() must be called on the canvas"
- "before using any drawing methods [~s]")
- (exn-message e))))))
+ (string-append
+ "The method show() must be called on the canvas"
+ "before using any drawing methods [~s]")
+ (exn-message e))))))
(begin (begin body ...) void-or-true))]))
-
+
(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 (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))))
-
+
;Raises an error if value less than or equal to 0
;check-arg: num string string -> boolean
(define (check-arg value method argument)
@@ -72,22 +80,15 @@
(raise-error
(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)
(letrec ((lower
- (lambda (s)
- (cond
- ((null? s) s)
- (else (cons (char-downcase (car s))
- (lower (cdr s))))))))
+ (lambda (s)
+ (cond
+ ((null? s) s)
+ (else (cons (char-downcase (car s))
+ (lower (cdr s))))))))
(list->string (lower (string->list s)))))
-
+
(define (xshow-native this accs gets privates)
;; Kathy: it looks like I am working around a bug here.
;; 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 '___)))
(start-and-export x y privates)
void-or-true)
-
+
(define (xclose-native this accs gets privates)
(wrap-start-check ([hash-table-get privates '%stop]))
void-or-true)
-
+
(define (stop-native this accs gets privates)
(wrap-start-check ([hash-table-get privates '%end-of-time])))
-
+
;; (copy) restores the viewport and the pixmap so that
;; (end-draw-sequence) can copy the pixmap into the viewport.
;; 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.
(define (copy-native this accs gets privates)
(wrap-start-check ([hash-table-get privates 'copy])))
-
+
(define (drawCircle-geometry.Posn-int-colors.Color-native this accs gets privates posn r c)
(wrap-start-check
- (check-arg r "drawCircle(Posn, int, Color)" "second")
- ([hash-table-get privates '%draw-circle] (build-posn posn) r (color->symbol c))))
-
+ (check-arg r "drawCircle(Posn, int, Color)" "second")
+ ([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)
(wrap-start-check
- (check-arg r "drawDisk(Posn, int, Color)" "second")
- ([hash-table-get privates '%draw-solid-disk] (build-posn posn) r (color->symbol c))))
-
+ (check-arg r "drawDisk(Posn, int, Color)" "second")
+ ([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)
(wrap-start-check
- (check-arg w "drawRect(Posn, int, int, Color)" "second")
- (check-arg h "drawRect(Posn, int, int, Color)" "third")
- ([hash-table-get privates '%draw-solid-rect] (build-posn posn) w h (color->symbol c))))
-
+ (check-arg w "drawRect(Posn, int, int, Color)" "second")
+ (check-arg h "drawRect(Posn, int, int, Color)" "third")
+ ([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)
(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 _ (check-string s "drawString(Posn, String)" "second"))
(define s* (send s get-mzscheme-string))
(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)
(wrap-start-check
- (check-arg r "clearCircle(Posn, int, Color)" "second")
- ([hash-table-get privates '%clear-circle] (build-posn p) r (color->symbol c))))
-
+ (check-arg r "clearCircle(Posn, int, Color)" "second")
+ ([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)
(wrap-start-check
- (check-arg r "clearDisk(Posn, int, Color)" "second")
- ([hash-table-get privates '%clear-solid-disk] (build-posn p) r (color->symbol c))))
-
+ (check-arg r "clearDisk(Posn, int, Color)" "second")
+ ([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)
(wrap-start-check
- (check-arg w "clearRect(Posn, int, int, Color)" "second")
- (check-arg h "clearRect(Posn, int, int, Color)" "third")
- ([hash-table-get privates '%clear-solid-rect] (build-posn p) w h (color->symbol c))))
-
+ (check-arg w "clearRect(Posn, int, int, Color)" "second")
+ (check-arg h "clearRect(Posn, int, int, Color)" "third")
+ ([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)
(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@
(unit/sig world-native^
(import support^)
-
+
(define (bigBangO-double-native this accs gets privates i)
(define theCanvas ((hash-table-get accs 'theCanvas) this))
(define setCanvas (hash-table-get gets 'theCanvas))
@@ -190,21 +191,25 @@
(send theCanvas show)
(big-bang i this)
(on-tick-event
- (lambda (world)
- (on-event world (lambda () (send world onTick)))))
+ (lambda (world)
+ (on-event world (lambda () (send world onTick)))))
(on-key-event
- (lambda (ke world)
- (define ke* (make-java-string (if (char? ke) (string ke) (symbol->string ke))))
- (on-event world (lambda () (send world onKeyEvent-java.lang.String ke*)))))
+ (lambda (ke world)
+ (define ke* (make-java-string (if (char? ke) (string ke) (symbol->string ke))))
+ (on-event world (lambda () (send world onKeyEvent-java.lang.String ke*)))))
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 _ (check-string s "endOfTime(String)" "first"))
+ (message-box "end of time" (send s get-mzscheme-string))
(send theCanvas stop)
#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 _ (check-string s "endOfWorld(String)" "first"))
+ (message-box "end of world" (send s get-mzscheme-string))
(send theCanvas stop)
this)))
)
diff --git a/collects/htdch/idraw/World-native-methods.ss b/collects/htdch/idraw/World-native-methods.ss
index 26c3fb0ef2..7e95625c58 100644
--- a/collects/htdch/idraw/World-native-methods.ss
+++ b/collects/htdch/idraw/World-native-methods.ss
@@ -2,7 +2,7 @@
(module World-native-methods mzscheme
(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 (imperative world@t+1 world@t) world@t)
diff --git a/collects/htdch/idraw/World.java b/collects/htdch/idraw/World.java
index e07561bd77..c70e5ef51a 100644
--- a/collects/htdch/idraw/World.java
+++ b/collects/htdch/idraw/World.java
@@ -26,8 +26,8 @@ public abstract class World {
// --------------------------------------------------------
- public native boolean endOfTime();
- public native World endOfWorld();
+ public native boolean endOfTime(String s);
+ public native World endOfWorld(String s);
public abstract void onTick();
public abstract void onKeyEvent(String ke);
public abstract void draw();
diff --git a/collects/teachpack/htdc/Docs/draw.thtml b/collects/teachpack/htdc/Docs/draw.thtml
index 07064004a0..f4dbec86df 100644
--- a/collects/teachpack/htdc/Docs/draw.thtml
+++ b/collects/teachpack/htdc/Docs/draw.thtml
@@ -14,8 +14,8 @@ import geometry.*;
| Canvas theCanvas |------>| Canvas |
+-----------------------------------+ +---------------------------------------+
| boolean bigBang(int,int,double) | +---------------------------------------+
- | boolean endOfTime() | | boolean show() |
- | World endOfWorld() | | boolean close() |
+ | boolean endOfTime(String) | | boolean show() |
+ | World endOfWorld(String) | | boolean close() |
| | | boolean drawCircle(Posn,int,Color) |
| | | boolean drawDisk(Posn,int,Color) |
| abstract World onTick() | | boolean drawRect(Posn,int,int,Color) |
@@ -51,13 +51,13 @@ produces true.
-endOfTime, stops the clock and, if it succeeds, produces
+endOfTime, displays the given message, stops the clock and, if it succeeds, produces
true. After the end of time, events no longer trigger calls
to onTick or onKeyEvent (see below). The canvas
remains visible.
-endOfWorld, stops the clock and, if it succeeds, produces the
+endOfWorld, displays the given message, stops the clock and, if it succeeds, produces the
last World. After the end of the world, events no longer trigger calls
to onTick or onKeyEvent (see below). The canvas
remains visible.