From 04b89daa5a9ecd2cff575ec6757b6049cb2e01f7 Mon Sep 17 00:00:00 2001 From: Matthias Felleisen Date: Mon, 13 Feb 2006 15:58:58 +0000 Subject: [PATCH] idraw created svn: r2207 --- collects/htdch/draw/doc.txt | 30 ++-- collects/htdch/idraw/Black.java | 3 + collects/htdch/idraw/Blue.java | 3 + collects/htdch/idraw/Canvas-native-methods.ss | 129 ++++++++++++++++++ collects/htdch/idraw/Canvas.java | 26 ++++ collects/htdch/idraw/Color.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/World-native-methods.ss | 122 +++++++++++++++++ collects/htdch/idraw/World.java | 18 +++ collects/htdch/idraw/Yellow.java | 3 + collects/htdch/idraw/doc.txt | 50 +++++++ collects/htdch/idraw/info.ss | 4 + collects/htdch/idraw/installer.ss | 28 ++++ collects/htdch/idraw/pre-installer.ss | 15 ++ collects/htdch/info.ss | 3 +- 18 files changed, 443 insertions(+), 13 deletions(-) create mode 100644 collects/htdch/idraw/Black.java create mode 100644 collects/htdch/idraw/Blue.java create mode 100644 collects/htdch/idraw/Canvas-native-methods.ss create mode 100644 collects/htdch/idraw/Canvas.java create mode 100644 collects/htdch/idraw/Color.java create mode 100644 collects/htdch/idraw/Green.java create mode 100644 collects/htdch/idraw/Posn.java create mode 100644 collects/htdch/idraw/Red.java create mode 100644 collects/htdch/idraw/White.java create mode 100644 collects/htdch/idraw/World-native-methods.ss create mode 100644 collects/htdch/idraw/World.java create mode 100644 collects/htdch/idraw/Yellow.java create mode 100644 collects/htdch/idraw/doc.txt create mode 100644 collects/htdch/idraw/info.ss create mode 100644 collects/htdch/idraw/installer.ss create mode 100644 collects/htdch/idraw/pre-installer.ss diff --git a/collects/htdch/draw/doc.txt b/collects/htdch/draw/doc.txt index 2d7c27d5ec..50ef90a986 100644 --- a/collects/htdch/draw/doc.txt +++ b/collects/htdch/draw/doc.txt @@ -1,17 +1,23 @@ This `draw' package provides libraries for modeling in a visual world: - - +----------+ +----------+ - | World | +->| Canvas | - +----------+ | +----------+ - | Canvas c |--+ +----------+ - +----------+ | draw | - +----------+ | clear | - +----------+ - - - abstract class World - - - class Canvas + +-----------------------------------+ + | abstract World | + +-----------------------------------+ +---------------------------------------+ + | Canvas theCanvas |------>| Canvas | + +-----------------------------------+ +---------------------------------------+ + | boolean bigBang(int,int,double) | +---------------------------------------+ + | boolean endOfTime() | | boolean start(int,int) | + | boolean endOfWorld() | | boolean stop() | + | World lastWorld() | | boolean drawCircle(Posn,int,Color) | + | | | boolean drawDisk(Posn,int,Color) | + | abstract World onTick() | | boolean drawRect(Posn,int,int,Color) | + | abstract World onKeyEvent(String) | | boolean drawLine(Posn,Posn,Color) | + | abstract boolean draw() | | boolean drawString(Posn,String) | + | abstract boolean erase( | | boolean clearCircle(Posn,int,Color) | + +-----------------------------------+ | boolean clearDisk(Posn,int,Color) | + | boolean clearRect(Posn,int,int,Color) | + | boolean clearLine(Posn,Posn,Color) | + +---------------------------------------+ - class Posn diff --git a/collects/htdch/idraw/Black.java b/collects/htdch/idraw/Black.java new file mode 100644 index 0000000000..199d6d2e12 --- /dev/null +++ b/collects/htdch/idraw/Black.java @@ -0,0 +1,3 @@ +package idraw; + +public class Black extends Color { } diff --git a/collects/htdch/idraw/Blue.java b/collects/htdch/idraw/Blue.java new file mode 100644 index 0000000000..bea4b3947d --- /dev/null +++ b/collects/htdch/idraw/Blue.java @@ -0,0 +1,3 @@ +package idraw; + +public class Blue extends Color { } diff --git a/collects/htdch/idraw/Canvas-native-methods.ss b/collects/htdch/idraw/Canvas-native-methods.ss new file mode 100644 index 0000000000..59d8415f80 --- /dev/null +++ b/collects/htdch/idraw/Canvas-native-methods.ss @@ -0,0 +1,129 @@ +#cs +(module Canvas-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") + + ;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 "The method start(int,int) must be called on the canvas before using any drawing methods"))))) + body)])) + + (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)))) + + ;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)))) + + (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) + (and (check-arg x "start(int,int)" "first") + (check-arg x "start(int,int)" "second") + (start x y) + (void))) + + (define/provide (stop-native this accs gets privates) (stop) (void)) + + (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)))) + + (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)))) + + (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)))) + + (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)))) + + (define/provide (drawString-idraw.Posn-java.lang.String-native this accs gets privates p s) + (wrap-start-check + (and + (draw-solid-string (build-posn p) (send s get-mzscheme-string)) + (void)))) + + (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)))) + + (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)))) + + (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)))) + + (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)))) +) + diff --git a/collects/htdch/idraw/Canvas.java b/collects/htdch/idraw/Canvas.java new file mode 100644 index 0000000000..273dde97af --- /dev/null +++ b/collects/htdch/idraw/Canvas.java @@ -0,0 +1,26 @@ +package idraw; + +public class Canvas { + + 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); +} diff --git a/collects/htdch/idraw/Color.java b/collects/htdch/idraw/Color.java new file mode 100644 index 0000000000..22f65bdc77 --- /dev/null +++ b/collects/htdch/idraw/Color.java @@ -0,0 +1,3 @@ +package idraw; + +public abstract class Color { } diff --git a/collects/htdch/idraw/Green.java b/collects/htdch/idraw/Green.java new file mode 100644 index 0000000000..39e9717730 --- /dev/null +++ b/collects/htdch/idraw/Green.java @@ -0,0 +1,3 @@ +package idraw; + +public class Green extends Color { } diff --git a/collects/htdch/idraw/Posn.java b/collects/htdch/idraw/Posn.java new file mode 100644 index 0000000000..4dd699a16e --- /dev/null +++ b/collects/htdch/idraw/Posn.java @@ -0,0 +1,10 @@ +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 new file mode 100644 index 0000000000..cebb82679b --- /dev/null +++ b/collects/htdch/idraw/Red.java @@ -0,0 +1,3 @@ +package idraw; + +public class Red extends Color { } diff --git a/collects/htdch/idraw/White.java b/collects/htdch/idraw/White.java new file mode 100644 index 0000000000..e9b41730d3 --- /dev/null +++ b/collects/htdch/idraw/White.java @@ -0,0 +1,3 @@ +package idraw; + +public class White extends Color { } diff --git a/collects/htdch/idraw/World-native-methods.ss b/collects/htdch/idraw/World-native-methods.ss new file mode 100644 index 0000000000..fe8ccb32fa --- /dev/null +++ b/collects/htdch/idraw/World-native-methods.ss @@ -0,0 +1,122 @@ +#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") + + ;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 (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) + (void)) +) + diff --git a/collects/htdch/idraw/World.java b/collects/htdch/idraw/World.java new file mode 100644 index 0000000000..49fb922836 --- /dev/null +++ b/collects/htdch/idraw/World.java @@ -0,0 +1,18 @@ +package idraw; + +public abstract class World { + + public Canvas theCanvas = new Canvas(); + + public native void bigBang(int width, int height, double s); + + public native void endOfTime(); + + public abstract void onTick(); + + public abstract void onKeyEvent(String ke); + + public abstract void draw(); + + public abstract void erase(); +} diff --git a/collects/htdch/idraw/Yellow.java b/collects/htdch/idraw/Yellow.java new file mode 100644 index 0000000000..fbeaf1c975 --- /dev/null +++ b/collects/htdch/idraw/Yellow.java @@ -0,0 +1,3 @@ +package idraw; + +public class Yellow extends Color { } diff --git a/collects/htdch/idraw/doc.txt b/collects/htdch/idraw/doc.txt new file mode 100644 index 0000000000..24eab3d81b --- /dev/null +++ b/collects/htdch/idraw/doc.txt @@ -0,0 +1,50 @@ +This `idraw' package provides libraries for modeling in a visual world: + + +---------------------------------+ + | abstract World | + +---------------------------------+ +------------------------------------+ + | Canvas theCanvas |------>| Canvas | + +---------------------------------+ +------------------------------------+ + | void bigBang(int,int,double) | +------------------------------------+ + | void endOfTime() | | void start(int,int) | + | | | void stop() | + | abstract void onTick() | | void drawCircle(Posn,int,Color) | + | abstract void onKeyEvent(String)| | void drawDisk(Posn,int,Color) | + | abstract void draw() | | void drawRect(Posn,int,int,Color) | + | abstract void erase() | | void drawLine(Posn,Posn,Color) | + +---------------------------------+ | void drawString(Posn,String) | + | void clearCircle(Posn,int,Color) | + | void clearDisk(Posn,int,Color) | + | void clearRect(Posn,int,int,Color) | + | void clearLine(Posn,Posn,Color) | + +------------------------------------+ + + - class Posn + + +----------+ + | Posn | + +----------+ + | int x | + | int y | + +----------+ + + - Color with five subclasses: + + Blue + + Green + + Red + + White + + Yellow + + +-------+ + | Color | + +-------+ + | + / \ + --- + | + ------------------------------------------ + | | | | | + +-------+ +-------+ +-------+ +-------+ +-------+ + | Blue | | Green | | Red | | White | | Yellow| + +-------+ +-------+ +-------+ +-------+ +-------+ + diff --git a/collects/htdch/idraw/info.ss b/collects/htdch/idraw/info.ss new file mode 100644 index 0000000000..fa53ffba14 --- /dev/null +++ b/collects/htdch/idraw/info.ss @@ -0,0 +1,4 @@ +(module info (lib "infotab.ss" "setup") + (define name "Imperative Draw Teachpack") + (define install-collection "installer.ss") + #;(define pre-install-collection "pre-installer.ss")) diff --git a/collects/htdch/idraw/installer.ss b/collects/htdch/idraw/installer.ss new file mode 100644 index 0000000000..7f0f975176 --- /dev/null +++ b/collects/htdch/idraw/installer.ss @@ -0,0 +1,28 @@ +(module installer mzscheme + (require (lib "compile.ss" "profj")) + (provide installer) + + (define (mprintf a) + (fprintf a (current-error-port))) + + (define (installer plthome) + (let ((draw-path (build-path (collection-path "htdch" "idraw")))) + (let ((javac + (lambda (file) + (parameterize ([current-load-relative-directory draw-path] + [current-directory draw-path] ) + (compile-java 'file 'file 'full + (build-path draw-path file) + #f #f))))) + (javac "Posn.java") + (javac "Color.java") + (javac "Canvas.java") + (javac "World.java") + (javac "Red.java") + (javac "White.java") + (javac "Blue.java") + (javac "Black.java") + (javac "Green.java") + (javac "Yellow.java") + )))) + diff --git a/collects/htdch/idraw/pre-installer.ss b/collects/htdch/idraw/pre-installer.ss new file mode 100644 index 0000000000..2c0d4f9a82 --- /dev/null +++ b/collects/htdch/idraw/pre-installer.ss @@ -0,0 +1,15 @@ +(module pre-installer mzscheme + (require (lib "compile.ss" "profj")) + (provide pre-installer) + + (define (pre-installer plthome) + (let ((draw-path (build-path (collection-path "htdch" "idraw")))) + (let ((javac + (lambda (file) + (parameterize ([current-load-relative-directory draw-path]) + (compile-java 'file 'file 'full + (build-path draw-path file) + #f #f))))) + (javac "Posn.java") + )))) + diff --git a/collects/htdch/info.ss b/collects/htdch/info.ss index 41f1498d7c..9397d8b5f8 100644 --- a/collects/htdch/info.ss +++ b/collects/htdch/info.ss @@ -1,6 +1,7 @@ (module info (lib "infotab.ss" "setup") (define name "htdch") (define compile-subcollections (list (list "htdch" "draw") - (list "htdch" "graphics") + (list "htdch" "graphics") + (list "htdch" "idraw") )) )