idraw created

svn: r2207
This commit is contained in:
Matthias Felleisen 2006-02-13 15:58:58 +00:00
parent 3cdb386436
commit 04b89daa5a
18 changed files with 443 additions and 13 deletions

View File

@ -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

View File

@ -0,0 +1,3 @@
package idraw;
public class Black extends Color { }

View File

@ -0,0 +1,3 @@
package idraw;
public class Blue extends Color { }

View File

@ -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))))
)

View File

@ -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);
}

View File

@ -0,0 +1,3 @@
package idraw;
public abstract class Color { }

View File

@ -0,0 +1,3 @@
package idraw;
public class Green extends Color { }

View File

@ -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;
}
}

View File

@ -0,0 +1,3 @@
package idraw;
public class Red extends Color { }

View File

@ -0,0 +1,3 @@
package idraw;
public class White extends Color { }

View File

@ -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))
)

View File

@ -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();
}

View File

@ -0,0 +1,3 @@
package idraw;
public class Yellow extends Color { }

View File

@ -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|
+-------+ +-------+ +-------+ +-------+ +-------+

View File

@ -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"))

View File

@ -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")
))))

View File

@ -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")
))))

View File

@ -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")
))
)