From 3616a2a0a84df7e318ce0fe180110e5ef5674a9e Mon Sep 17 00:00:00 2001 From: Matthias Felleisen Date: Wed, 19 Apr 2006 03:23:59 +0000 Subject: [PATCH] full support for Canvas, multiple Worlds svn: r2712 --- collects/htdch/idraw/Canvas-native-methods.ss | 110 +++++++-------- collects/htdch/idraw/Canvas.java | 48 ++++--- collects/htdch/idraw/World-native-methods.ss | 127 +----------------- collects/htdch/idraw/World.java | 36 +++-- collects/htdch/idraw/support.scm | 51 +++++++ 5 files changed, 164 insertions(+), 208 deletions(-) create mode 100644 collects/htdch/idraw/support.scm diff --git a/collects/htdch/idraw/Canvas-native-methods.ss b/collects/htdch/idraw/Canvas-native-methods.ss index 59d8415f80..355025229c 100644 --- a/collects/htdch/idraw/Canvas-native-methods.ss +++ b/collects/htdch/idraw/Canvas-native-methods.ss @@ -1,13 +1,14 @@ #cs (module Canvas-native-methods mzscheme - (require (lib "draw.ss" "htdp") + (require (lib "big-draw.ss" "htdp") (lib "posn.ss" "lang") (lib "class.ss") (lib "String.ss" "profj" "libs" "java" "lang") (lib "Throwable.ss" "profj" "libs" "java" "lang") (lib "RuntimeException.ss" "profj" "libs" "java" "lang")) - ;(require "Posn.ss") - + + (define void-or-true (void)) + ;raises a Java exception with the specified error message ;raise-error: String -> void (define (raise-error message) @@ -19,17 +20,17 @@ (define-syntax (wrap-start-check stx) (syntax-case stx () - [(_ body) + [(_ body ...) #'(with-handlers ((exn:fail? (lambda (e) (raise-error - (format "The method start(int,int) must be called on the canvas before using any drawing methods"))))) - body)])) + (format "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-syntax (define/provide stx) (syntax-case stx () - [(_ id val) + #;[(_ id val) (identifier? #'id) #'(begin (define id val) @@ -42,17 +43,14 @@ (define Posn-x-get (dynamic-require '(lib "Posn.ss" "htdch" "idraw") 'Posn-x-get)) (define Posn-y-get (dynamic-require '(lib "Posn.ss" "htdch" "idraw") '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)))) + (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) (or (> value 0) - (raise-error (format "Method ~a expects an int greater than 0 for ~a argument, given ~a" - method argument value)))) + (raise-error (format "Method ~a expects an int >= 0 for ~a argument, given ~a" method argument value)))) (define (to-lower-case s) (letrec ((lower @@ -63,67 +61,69 @@ (lower (cdr s)))))))) (list->string (lower (string->list s))))) - (define/provide (start-int-int-native this accs gets privates x y) - (and (check-arg x "start(int,int)" "first") - (check-arg x "start(int,int)" "second") - (start x y) - (void))) + (define/provide (show-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) + ;; but that didn't work at all. 'width is not a key for privates, + ;; even though it is a private field. Then I wanted to write + ;; ([hash-table-get privates 'width] this), just like in World-native-methods. + ;; That failed, too, with an arity error. + (define x (with-method ([g (this Canvas-width-get)]) (g '___))) + (define y (with-method ([g (this Canvas-height-get)]) (g '___))) + (start-and-export x y privates) + void-or-true) - (define/provide (stop-native this accs gets privates) (stop) (void)) + (define/provide (close-native this accs gets privates) + (wrap-start-check ([hash-table-get privates '%stop]))) + + (define/provide (stop-native this accs gets privates) + (wrap-start-check ([hash-table-get privates '%end-of-time]))) + + (define/provide (copy-native this accs gets privates) + (wrap-start-check ([hash-table-get privates 'copy]))) (define/provide (drawCircle-idraw.Posn-int-idraw.Color-native this accs gets privates posn r c) (wrap-start-check - (and (check-arg r "drawCircle(Posn, int, Color)" "second") - (draw-circle (build-posn posn) r (color->symbol c)) - (void)))) + (check-arg r "drawCircle(Posn, int, Color)" "second") + ([hash-table-get privates '%draw-circle] (build-posn posn) r (color->symbol c)))) (define/provide (drawDisk-idraw.Posn-int-idraw.Color-native this accs gets privates posn r c) (wrap-start-check - (and (check-arg r "drawDisk(Posn, int, Color)" "second") - (draw-solid-disk (build-posn posn) r (color->symbol c)) - (void)))) + (check-arg r "drawDisk(Posn, int, Color)" "second") + ([hash-table-get privates '%draw-solid-disk] (build-posn posn) r (color->symbol c)))) (define/provide (drawRect-idraw.Posn-int-int-idraw.Color-native this accs gets privates posn w h c) - (wrap-start-check - (and (check-arg w "drawRect(Posn, int, int, Color)" "second") - (check-arg h "drawRect(Posn, int, int, Color)" "third") - (draw-solid-rect (build-posn posn) w h (color->symbol c)) - (void)))) + (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)))) (define/provide (drawLine-idraw.Posn-idraw.Posn-idraw.Color-native this accs gets privates p0 p1 c) - (wrap-start-check - (and (draw-solid-line (build-posn p0) (build-posn p1) (color->symbol c)) - (void)))) + (wrap-start-check + ([hash-table-get privates '%draw-solid-line] (build-posn p0) (build-posn p1) (color->symbol c)))) (define/provide (drawString-idraw.Posn-java.lang.String-native this accs gets privates p s) + (define s* (send s get-mzscheme-string)) (wrap-start-check - (and - (draw-solid-string (build-posn p) (send s get-mzscheme-string)) - (void)))) + ([hash-table-get privates '%draw-string] (build-posn p) s*))) (define/provide (clearCircle-idraw.Posn-int-idraw.Color-native this accs gets privates p r c) - (wrap-start-check - (and (check-arg r "clearCircle(Posn, int, Color)" "second") - (clear-circle (build-posn p) r (color->symbol c)) - (void)))) + (wrap-start-check + (check-arg r "clearCircle(Posn, int, Color)" "second") + ([hash-table-get privates '%clear-circle] (build-posn p) r (color->symbol c)))) (define/provide (clearDisk-idraw.Posn-int-idraw.Color-native this accs gets privates p r c) - (wrap-start-check - (and (check-arg r "clearDisk(Posn, int, Color)" "second") - (clear-solid-disk (build-posn p) r (color->symbol c)) - (void)))) + (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)))) (define/provide (clearRect-idraw.Posn-int-int-idraw.Color-native this accs gets privates p w h c) - (wrap-start-check - (and (check-arg w "clearRect(Posn, int, int, Color)" "second") - (check-arg h "clearRect(Posn, int, int, Color)" "third") - (clear-solid-rect (build-posn p) w h (color->symbol c)) - (void)))) + (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)))) (define/provide (clearLine-idraw.Posn-idraw.Posn-idraw.Color-native this accs gets privates p0 p1 c) - (wrap-start-check - (and - (clear-solid-line (build-posn p0) (build-posn p1) (color->symbol c)) - (void)))) -) - + (wrap-start-check + ([hash-table-get privates '%clear-solid-line] (build-posn p0) (build-posn p1) (color->symbol c)))) + ) diff --git a/collects/htdch/idraw/Canvas.java b/collects/htdch/idraw/Canvas.java index 273dde97af..5db4d821a9 100644 --- a/collects/htdch/idraw/Canvas.java +++ b/collects/htdch/idraw/Canvas.java @@ -1,26 +1,32 @@ package idraw; public class Canvas { + private int width = 0; + private int height = 0; - public native void start(int width, int height); - - public native void stop(); - - public native void drawCircle(Posn p, int r, Color c); - - public native void drawDisk(Posn p, int r, Color c); - - public native void drawRect(Posn p, int width, int height, Color c); - - public native void drawLine(Posn p0, Posn p1, Color c); - - public native void drawString(Posn p, String s); - - public native void clearCircle(Posn p, int r, Color c); - - public native void clearDisk(Posn p, int r, Color c); - - public native void clearRect(Posn p, int width, int height, Color c); - - public native void clearLine(Posn p0, Posn p1, Color c); + public Canvas(int width, int height) { + this.width = width; + this.height = height; + } + + // these two are cheats: + public native void copy(); + public native void stop(); + // I need to figure out how to accomplish these two things, especially stop, + // directly at the Scheme level w/o going thru the Java layer. + // BUG: this is actually a bug in ProfessorJ. Making these protected should + // work just fine. Indeed, leaving off the access control qualifier should + // work, too. (That's package protected.) + + public native void show(); + public native void close(); + public native void drawCircle(Posn p, int r, Color c); + public native void drawDisk(Posn p, int r, Color c); + public native void drawRect(Posn p, int width, int height, Color c); + public native void drawLine(Posn p0, Posn p1, Color c); + public native void drawString(Posn p, String s); + public native void clearCircle(Posn p, int r, Color c); + public native void clearDisk(Posn p, int r, Color c); + public native void clearRect(Posn p, int width, int height, Color c); + public native void clearLine(Posn p0, Posn p1, Color c); } diff --git a/collects/htdch/idraw/World-native-methods.ss b/collects/htdch/idraw/World-native-methods.ss index 217c06ccf7..8a2609ea10 100644 --- a/collects/htdch/idraw/World-native-methods.ss +++ b/collects/htdch/idraw/World-native-methods.ss @@ -1,125 +1,10 @@ #cs (module World-native-methods mzscheme - (require (lib "draw.ss" "htdp") - (lib "posn.ss" "lang") - (lib "class.ss") - (lib "String.ss" "profj" "libs" "java" "lang") - (lib "Throwable.ss" "profj" "libs""java""lang") - (lib "RuntimeException.ss" "profj" "libs" "java" "lang")) - ;(require "Posn.ss") + (require "support.scm" (lib "unitsig.ss")) - ;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)))) + (provide endOfTime-native endOfWorld-native bigBangO-double-native) + + (define void-or-true void) + (define (world-return w) w) - (define-syntax (define/provide stx) - (syntax-case stx () - [(_ id val) - (identifier? #'id) - #'(begin - (define id val) - (provide id))] - [(_ (id . formals) . rest) - #'(begin - (define (id . formals) . rest) - (provide id))])) - - (define Posn-x-get (dynamic-require '(lib "Posn.ss" "htdch" "idraw") 'Posn-x-get)) - (define Posn-y-get (dynamic-require '(lib "Posn.ss" "htdch" "idraw") '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)))) - - (define (to-lower-case s) - (letrec ((lower - (lambda (s) - (cond - ((null? s) s) - (else (cons (char-downcase (car s)) - (lower (cdr s)))))))) - (list->string (lower (string->list s))))) - -#| - (define/provide (start-int-int-native this accs gets privates x y) - (start x y)) - - (define/provide (stop-native this accs gets privates) (stop)) - - (define/provide (drawCircle-draw.Posn-int-draw.Color-native this accs gets privates posn r c) - (draw-circle (build-posn posn) r (color->symbol c))) - - (define/provide (drawDisk-draw.Posn-int-draw.Color-native this accs gets privates posn r c) - (draw-solid-disk (build-posn posn) r (color->symbol c))) - - (define/provide (drawRect-draw.Posn-int-int-draw.Color-native this accs gets privates posn w h c) - (draw-solid-rect (build-posn posn) w h (color->symbol c))) - - (define/provide (drawLine-draw.Posn-draw.Posn-draw.Color-native this accs gets privates p0 p1 c) - (draw-solid-line (build-posn p0) (build-posn p1) (color->symbol c))) - - (define/provide (drawString-draw.Posn-java.lang.String-native this accs gets privates p s) - (draw-solid-string (build-posn p) (send s get-mzscheme-string))) - - (define/provide (clearCircle-draw.Posn-int-draw.Color-native this accs gets privates p r c) - (clear-circle (build-posn p) r (color->symbol c))) - - (define/provide (clearDisk-draw.Posn-int-draw.Color-native this accs gets privates p r c) - (clear-solid-disk (build-posn p) r (color->symbol c))) - - (define/provide (clearRect-draw.Posn-int-int-draw.Color-native this accs gets privates p w h c) - (clear-solid-rect (build-posn p) w h (color->symbol c))) - - (define/provide (clearLine-draw.Posn-draw.Posn-draw.Color-native this accs gets privates p0 p1 c) - (clear-solid-line (build-posn p0) (build-posn p1) (color->symbol c))) - - (define/provide (sleepForAWhile-int-native this accs gets privates s) - (sleep-for-a-while s)) -|# - - (define/provide (bigBang-int-int-double-native this accs gets privates width height i) - (define theCanvas ((hash-table-get accs 'theCanvas) this)) - (unless (> width 0) - (raise-error - (format "The method bigBang(int,int,double) expected first argument to be greather than 0, given ~a" width))) - (unless (> height 0) - (raise-error - (format "The method bigBang(int,int,double) expected second argument to be greater than 0, given ~a" height))) - - (unless (>= i 0) - (raise-error - (format "The method bigBang(int,int,double) expected third argument to be 0 or greater, given ~a" i))) - (send theCanvas start-int-int width height) - (big-bang i this) - (on-tick-event - (lambda (world) - (send world erase) - (send world onTick) - (send world draw) - world)) - (on-key-event - (lambda (ke world) - (send world erase) - (send world onKeyEvent-java.lang.String (make-java-string (keyevent->string ke))) - (send world draw) - world)) - (void)) - - ;; (union Char Symbol) -> String - (define (keyevent->string ke) - (if (char? ke) (string ke) (symbol->string ke))) - - (define/provide (endOfTime-native this accs gets privates) - (end-of-time) - this) - - (define/provide (endOfWorld-native this accs gets privates) - (end-of-time) - this) -) + (define-values/invoke-unit/sig world-native^ world-native@ #f support^)) diff --git a/collects/htdch/idraw/World.java b/collects/htdch/idraw/World.java index 38651ce2e8..fc4b2305a8 100644 --- a/collects/htdch/idraw/World.java +++ b/collects/htdch/idraw/World.java @@ -2,19 +2,33 @@ package idraw; public abstract class World { - public Canvas theCanvas = new Canvas(); + public Canvas theCanvas; - public native void bigBang(int width, int height, double s); - - public native World endOfTime(); + public void bigBang(int width, int height, double s) { + if (width <= 0) + Util.error("The method bigBang(int,int,double) expects " + + "the first argument to be greather than 0, given " + + width); + if (height <= 0) + Util.error("The method bigBang(int,int,double) expects " + + "the second argument to be greather than 0, given " + + height); + if (s <= 0) + Util.error("The method bigBang(int,int,double) expects " + + "the third argument to be greather than 0, given " + + s); + theCanvas = new Canvas(width,height); + bigBangO(s); + } - public native World endOfWorld(); + private native void bigBangO(double s); - public abstract void onTick(); + // -------------------------------------------------------- - public abstract void onKeyEvent(String ke); - - public abstract void draw(); - - public abstract void erase(); + public native World endOfTime(); + public native World endOfWorld(); + public abstract void onTick(); + public abstract void onKeyEvent(String ke); + public abstract void draw(); + public abstract void erase(); } diff --git a/collects/htdch/idraw/support.scm b/collects/htdch/idraw/support.scm new file mode 100644 index 0000000000..fb6fde473d --- /dev/null +++ b/collects/htdch/idraw/support.scm @@ -0,0 +1,51 @@ +(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") + + (provide world-native@ world-native^ support^) + + (define-signature world-native^ (endOfTime-native endOfWorld-native bigBangO-double-native)) + (define-signature support^ (world-return void-or-true)) + + (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 width (with-method ([g (theCanvas Canvas-width-get)]) (g '___))) + (define height (with-method ([g (theCanvas Canvas-height-get)]) (g '___))) + ;; call only *after* start + (define (on-event world th) + (begin-draw-sequence) + (send theCanvas copy) + (send world erase) + (th) + (send world draw) + (end-draw-sequence) + world) + (send theCanvas show) + (big-bang i this) + (on-tick-event + (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*))))) + (void-or-true)) + + (define (endOfTime-native this accs gets privates) + (define theCanvas ((hash-table-get accs 'theCanvas) this)) + (send theCanvas stop) + (world-return this)) + + (define (endOfWorld-native this accs gets privates) + (define theCanvas ((hash-table-get accs 'theCanvas) this)) + (send theCanvas stop) + (world-return this)))) + ) \ No newline at end of file