From 6376643994f54f91f37f1ce5b4261041fa4860a5 Mon Sep 17 00:00:00 2001 From: Matthias Felleisen Date: Mon, 24 Apr 2006 14:19:31 +0000 Subject: [PATCH] support added, duplicated code removed from idraw svn: r2762 --- collects/htdch/draw/support.scm | 190 +++++++++++++++++++++++++++++++ collects/htdch/idraw/Black.java | 3 - collects/htdch/idraw/Blue.java | 3 - collects/htdch/idraw/Green.java | 3 - collects/htdch/idraw/Posn.java | 10 -- collects/htdch/idraw/Red.java | 3 - collects/htdch/idraw/White.java | 3 - collects/htdch/idraw/Yellow.java | 3 - collects/htdch/idraw/support.scm | 51 --------- 9 files changed, 190 insertions(+), 79 deletions(-) create mode 100644 collects/htdch/draw/support.scm delete mode 100644 collects/htdch/idraw/Black.java delete mode 100644 collects/htdch/idraw/Blue.java delete mode 100644 collects/htdch/idraw/Green.java delete mode 100644 collects/htdch/idraw/Posn.java delete mode 100644 collects/htdch/idraw/Red.java delete mode 100644 collects/htdch/idraw/White.java delete mode 100644 collects/htdch/idraw/Yellow.java delete mode 100644 collects/htdch/idraw/support.scm diff --git a/collects/htdch/draw/support.scm b/collects/htdch/draw/support.scm new file mode 100644 index 0000000000..2d49103b3c --- /dev/null +++ b/collects/htdch/draw/support.scm @@ -0,0 +1,190 @@ +#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")) + + (provide world-native@ world-native^ canvas-native@ canvas-native^ support^) + + (define-signature world-native^ + (endOfTime-native + endOfWorld-native + bigBangO-double-native)) + + (define-signature canvas-native^ + (show-native + close-native + stop-native + copy-native + drawCircle-draw.Posn-int-draw.Color-native + drawDisk-draw.Posn-int-draw.Color-native + drawRect-draw.Posn-int-int-draw.Color-native + drawLine-draw.Posn-draw.Posn-draw.Color-native + drawString-draw.Posn-java.lang.String-native + clearCircle-draw.Posn-int-draw.Color-native + clearDisk-draw.Posn-int-draw.Color-native + clearRect-draw.Posn-int-int-draw.Color-native + clearLine-draw.Posn-draw.Posn-draw.Color-native)) + + (define-signature support^ (void-or-true imperative)) + + (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 + (format + (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" "draw") 'Posn-x-get)) + (define Posn-y-get (dynamic-require '(lib "Posn.ss" "htdch" "draw") '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) + (or (> value 0) + (raise-error + (format "Method ~a expects an int >= 0 for ~a argument, given ~a" method argument value)))) + + (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 (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 (close-native this accs gets privates) + (wrap-start-check ([hash-table-get privates '%stop]))) + + (define (stop-native this accs gets privates) + (wrap-start-check ([hash-table-get privates '%end-of-time]))) + + (define (copy-native this accs gets privates) + (wrap-start-check ([hash-table-get privates 'copy]))) + + (define (drawCircle-draw.Posn-int-draw.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)))) + + (define (drawDisk-draw.Posn-int-draw.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)))) + + (define (drawRect-draw.Posn-int-int-draw.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)))) + + (define (drawLine-draw.Posn-draw.Posn-draw.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)))) + + (define (drawString-draw.Posn-java.lang.String-native this accs gets privates p s) + (define s* (send s get-mzscheme-string)) + (wrap-start-check + ([hash-table-get privates '%draw-string] (build-posn p) s*))) + + (define (clearCircle-draw.Posn-int-draw.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)))) + + (define (clearDisk-draw.Posn-int-draw.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)))) + + (define (clearRect-draw.Posn-int-int-draw.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)))) + + (define (clearLine-draw.Posn-draw.Posn-draw.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)))) + )) + + + (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) + (let ([world (imperative (th) world)]) + (send world putCanvas-draw.Canvas theCanvas) + (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) + #t) + + (define (endOfWorld-native this accs gets privates) + (define theCanvas ((hash-table-get accs 'theCanvas) this)) + (send theCanvas stop) + this))) + ) diff --git a/collects/htdch/idraw/Black.java b/collects/htdch/idraw/Black.java deleted file mode 100644 index 199d6d2e12..0000000000 --- a/collects/htdch/idraw/Black.java +++ /dev/null @@ -1,3 +0,0 @@ -package idraw; - -public class Black extends Color { } diff --git a/collects/htdch/idraw/Blue.java b/collects/htdch/idraw/Blue.java deleted file mode 100644 index bea4b3947d..0000000000 --- a/collects/htdch/idraw/Blue.java +++ /dev/null @@ -1,3 +0,0 @@ -package idraw; - -public class Blue extends Color { } diff --git a/collects/htdch/idraw/Green.java b/collects/htdch/idraw/Green.java deleted file mode 100644 index 39e9717730..0000000000 --- a/collects/htdch/idraw/Green.java +++ /dev/null @@ -1,3 +0,0 @@ -package idraw; - -public class Green extends Color { } diff --git a/collects/htdch/idraw/Posn.java b/collects/htdch/idraw/Posn.java deleted file mode 100644 index 4dd699a16e..0000000000 --- a/collects/htdch/idraw/Posn.java +++ /dev/null @@ -1,10 +0,0 @@ -package idraw; - -public class Posn { - public int x, y; - - public Posn( int x, int y ) { - this.x = x; - this.y = y; - } -} diff --git a/collects/htdch/idraw/Red.java b/collects/htdch/idraw/Red.java deleted file mode 100644 index cebb82679b..0000000000 --- a/collects/htdch/idraw/Red.java +++ /dev/null @@ -1,3 +0,0 @@ -package idraw; - -public class Red extends Color { } diff --git a/collects/htdch/idraw/White.java b/collects/htdch/idraw/White.java deleted file mode 100644 index e9b41730d3..0000000000 --- a/collects/htdch/idraw/White.java +++ /dev/null @@ -1,3 +0,0 @@ -package idraw; - -public class White extends Color { } diff --git a/collects/htdch/idraw/Yellow.java b/collects/htdch/idraw/Yellow.java deleted file mode 100644 index fbeaf1c975..0000000000 --- a/collects/htdch/idraw/Yellow.java +++ /dev/null @@ -1,3 +0,0 @@ -package idraw; - -public class Yellow extends Color { } diff --git a/collects/htdch/idraw/support.scm b/collects/htdch/idraw/support.scm deleted file mode 100644 index fb6fde473d..0000000000 --- a/collects/htdch/idraw/support.scm +++ /dev/null @@ -1,51 +0,0 @@ -(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