suzanne.soy/racket
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

htdch/draw and htdch/idraw fixed, common code basis

Browse Source 
svn: r2759
This commit is contained in:
Matthias Felleisen 2006-04-24 12:35:59 +00:00
parent e87c19f719
commit 770e6aa288
10 changed files with 93 additions and 464 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

170
collects/htdch/draw/Canvas-native-methods.ss
View File

@ -1,170 +1,12 @@
#cs #cs
(module Canvas-native-methods mzscheme (module Canvas-native-methods mzscheme
(require (lib "draw.ss" "htdp") (require (lib "support.scm" "htdch" "draw") (lib "unitsig.ss"))
(lib "posn.ss" "lang")
(lib "class.ss") (define void-or-true #t)
(lib "String.ss" "profj" "libs" "java" "lang") (define (imperative w@t+1 w@t) w@t+1)
(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 (define-values/invoke-unit/sig canvas-native^ canvas-native@ #f support^)
;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
"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" "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 (provide-signature-elements canvas-native^))
;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)))
(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)
(wrap-start-check
(and (check-arg r "drawCircle(Posn, int, Color)" "second")
(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)
(wrap-start-check
(and (check-arg r "drawDisk(Posn, int, Color)" "second")
(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)
(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)))))
(define/provide (drawLine-draw.Posn-draw.Posn-draw.Color-native this accs gets privates p0 p1 c)
(wrap-start-check
(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)
(wrap-start-check
(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)
(wrap-start-check
(and (check-arg r "clearCircle(Posn, int, Color)" "second")
(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)
(wrap-start-check
(and (check-arg r "clearDisk(Posn, int, Color)" "second")
(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)
(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)))))
(define/provide (clearLine-draw.Posn-draw.Posn-draw.Color-native this accs gets privates p0 p1 c)
(wrap-start-check
(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-double-native this accs gets privates i)
(big-bang i this)
(on-tick-event
(lambda (world)
(set! last-world world)
(let ([next-world (send world onTick)])
(send last-world erase)
(send next-world draw)
next-world)))
(on-key-event
(lambda (ke world)
(set! last-world world)
(let ([next-world (send world onKeyEvent-java.lang.String
(make-java-string (keyevent->string ke)))])
(send last-world erase)
(send next-world draw)
next-world)))
#t)
;; (union Char Symbol) -> String
(define (keyevent->string ke)
(if (char? ke) (string ke) (symbol->string ke)))
(define/provide (draw-native this accs gets privates)
#t)
(define/provide (erase-native this accs gets privates)
#t)
(define/provide (onTick-native this accs gets privates)
this)
(define/provide (onKeyEvent-java.lang.String-native this accs gets privates ke)
this)
(define last-world #f)
(define/provide (endOfTime-native this accs gets privates)
(set! last-world (end-of-time))
#t)
(define/provide (endOfWorld-native this accs gets privates)
(set! last-world (end-of-time))
last-world)
(define/provide (lastWorld-native this accs gets privates)
(if last-world last-world this))
|#
)

48
collects/htdch/draw/Canvas.java
View File

@ -1,26 +1,32 @@
package draw; package draw;
public class Canvas { public class Canvas {
private int width = 0;
private int height = 0;
public native boolean start(int width, int height); public Canvas(int width, int height) {
this.width = width;
public native boolean stop(); this.height = height;
}
public native boolean drawCircle(Posn p, int r, Color c);
// these two are cheats:
public native boolean drawDisk(Posn p, int r, Color c); protected native boolean copy();
protected native boolean stop();
public native boolean drawRect(Posn p, int width, int height, Color c); // 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.
public native boolean drawLine(Posn p0, Posn p1, Color c); // BUG: this is actually a bug in ProfessorJ. Making these protected should
// work just fine. Indeed, leaving off the access control qualifier should
public native boolean drawString(Posn p, String s); // work, too. (That's package protected.)
public native boolean clearCircle(Posn p, int r, Color c); public native boolean show();
public native boolean close();
public native boolean clearDisk(Posn p, int r, Color c); public native boolean drawCircle(Posn p, int r, Color c);
public native boolean drawDisk(Posn p, int r, Color c);
public native boolean clearRect(Posn p, int width, int height, Color c); public native boolean drawRect(Posn p, int width, int height, Color c);
public native boolean drawLine(Posn p0, Posn p1, Color c);
public native boolean clearLine(Posn p0, Posn p1, Color c); public native boolean drawString(Posn p, String s);
public native boolean clearCircle(Posn p, int r, Color c);
public native boolean clearDisk(Posn p, int r, Color c);
public native boolean clearRect(Posn p, int width, int height, Color c);
public native boolean clearLine(Posn p0, Posn p1, Color c);
} }

134
collects/htdch/draw/World-native-methods.ss
View File

@ -1,134 +1,12 @@
#cs #cs
(module World-native-methods mzscheme (module World-native-methods mzscheme
(require (lib "draw.ss" "htdp") (require (lib "support.scm" "htdch" "draw") (lib "unitsig.ss"))
(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 (provide endOfTime-native endOfWorld-native bigBangO-double-native)
;raise-error: String -> void
(define (raise-error message) (define void-or-true #t)
(raise (define (imperative world@t+1 world@t) world@t+1)
(create-java-exception RuntimeException message
(lambda (exn str)
(send exn RuntimeException-constructor-java.lang.String str))
(current-continuation-marks))))
(define-syntax (define/provide stx) (define-values/invoke-unit/sig world-native^ world-native@ #f support^))
(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" "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))))
(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)
(set! last-world world)
(let ([next-world (send world onTick)])
(send last-world erase)
(send next-world draw)
next-world)))
(on-key-event
(lambda (ke world)
(set! last-world world)
(let ([next-world (send world onKeyEvent-java.lang.String
(make-java-string (keyevent->string ke)))])
(send last-world erase)
(send next-world draw)
next-world)))
#t)
;; (union Char Symbol) -> String
(define (keyevent->string ke)
(if (char? ke) (string ke) (symbol->string ke)))
(define last-world #f)
(define/provide (endOfTime-native this accs gets privates)
(set! last-world (end-of-time))
#t)
(define/provide (endOfWorld-native this accs gets privates)
(set! last-world (end-of-time))
last-world)
(define/provide (lastWorld-native this accs gets privates)
(if last-world last-world this))
)

42
collects/htdch/draw/World.java
View File

@ -1,13 +1,37 @@
package draw; package draw;
public abstract class World { public abstract class World {
public Canvas theCanvas = new Canvas(); protected Canvas theCanvas;
public native boolean bigBang(int width, int height, double s); protected void putCanvas(Canvas c) {
public native boolean endOfTime(); this.theCanvas = c;
public native World endOfWorld(); };
public native World lastWorld(); public boolean bigBang(int width, int height, double s) {
public abstract World onTick(); if (width <= 0)
public abstract World onKeyEvent(String ke); throw new RuntimeException(
public abstract boolean draw(); "The method bigBang(int,int,double) expects " +
public abstract boolean erase(); "the first argument to be greather than 0, given "
+ width);
if (height <= 0)
throw new RuntimeException(
"The method bigBang(int,int,double) expects " +
"the second argument to be greather than 0, given "
+ height);
if (s <= 0)
throw new RuntimeException(
"The method bigBang(int,int,double) expects " +
"the third argument to be greather than 0, given "
+ s);
theCanvas = new Canvas(width,height);
return bigBangO(s);
};
private native boolean bigBangO(double s);
// --------------------------------------------------------
public native boolean endOfTime();
public native World endOfWorld();
public abstract World onTick();
public abstract World onKeyEvent(String ke);
public abstract boolean draw();
public abstract boolean erase();
} }

129
collects/htdch/idraw/Canvas-native-methods.ss
View File

@ -1,129 +1,10 @@
#cs #cs
(module Canvas-native-methods mzscheme (module Canvas-native-methods mzscheme
(require (lib "big-draw.ss" "htdp") (require (lib "support.scm" "htdch" "draw") (lib "unitsig.ss"))
(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"))
(define void-or-true (void)) (define void-or-true (void))
(define (imperative w@t+1 w@t) w@t+1)
(define-values/invoke-unit/sig canvas-native^ canvas-native@ #f support^)
;raises a Java exception with the specified error message (provide-signature-elements canvas-native^))
;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 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)
(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 >= 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 (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 (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
(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
(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
(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
([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
([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
(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
(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
(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
([hash-table-get privates '%clear-solid-line] (build-posn p0) (build-posn p1) (color->symbol c))))
)

14
collects/htdch/idraw/Canvas.java
View File

@ -1,4 +1,7 @@
package idraw; package idraw;
import draw.Color;
import draw.Posn;
public class Canvas { public class Canvas {
private int width = 0; private int width = 0;
@ -10,13 +13,10 @@ public class Canvas {
} }
// these two are cheats: // these two are cheats:
public native void copy(); protected native void copy();
public native void stop(); protected native void stop();
// I need to figure out how to accomplish these two things, especially stop, // MF: I need to figure out how to accomplish these two things, especially
// directly at the Scheme level w/o going thru the Java layer. // 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 show();
public native void close(); public native void close();

4
collects/htdch/idraw/World-native-methods.ss
View File

@ -1,10 +1,10 @@
#cs #cs
(module World-native-methods mzscheme (module World-native-methods mzscheme
(require "support.scm" (lib "unitsig.ss")) (require (lib "support.scm" "htdch" "draw") (lib "unitsig.ss"))
(provide endOfTime-native endOfWorld-native bigBangO-double-native) (provide endOfTime-native endOfWorld-native bigBangO-double-native)
(define void-or-true void) (define void-or-true void)
(define (world-return w) w) (define (imperative world@t+1 world@t) world@t)
(define-values/invoke-unit/sig world-native^ world-native@ #f support^)) (define-values/invoke-unit/sig world-native^ world-native@ #f support^))

6
collects/htdch/idraw/World.java
View File

@ -1,9 +1,7 @@
package idraw; package idraw;
public abstract class World { public abstract class World {
public Canvas theCanvas; public Canvas theCanvas;
public void bigBang(int width, int height, double s) { public void bigBang(int width, int height, double s) {
if (width <= 0) if (width <= 0)
throw new RuntimeException( throw new RuntimeException(
@ -22,13 +20,13 @@ public abstract class World {
+ s); + s);
theCanvas = new Canvas(width,height); theCanvas = new Canvas(width,height);
bigBangO(s); bigBangO(s);
return ;
} }
private native void bigBangO(double s); private native void bigBangO(double s);
// -------------------------------------------------------- // --------------------------------------------------------
public native World endOfTime(); public native boolean endOfTime();
public native World endOfWorld(); public native World endOfWorld();
public abstract void onTick(); public abstract void onTick();
public abstract void onKeyEvent(String ke); public abstract void onKeyEvent(String ke);

6
collects/htdch/idraw/installer.ss
View File

@ -11,14 +11,16 @@
(compile-java 'file 'file 'full (compile-java 'file 'file 'full
(build-path draw-path file) (build-path draw-path file)
#f #f))))) #f #f)))))
(javac "Posn.java")
(javac "Color.java")
(javac "Canvas.java") (javac "Canvas.java")
(javac "World.java") (javac "World.java")
#|
(javac "Posn.java")
(javac "Color.java")
(javac "Red.java") (javac "Red.java")
(javac "White.java") (javac "White.java")
(javac "Blue.java") (javac "Blue.java")
(javac "Black.java") (javac "Black.java")
(javac "Green.java") (javac "Green.java")
(javac "Yellow.java") (javac "Yellow.java")
|#
)))) ))))

4
collects/htdch/info.ss
View File

@ -2,6 +2,4 @@
(define name "htdch") (define name "htdch")
(define compile-subcollections (list (list "htdch" "draw") (define compile-subcollections (list (list "htdch" "draw")
(list "htdch" "graphics") (list "htdch" "graphics")
(list "htdch" "idraw") (list "htdch" "idraw"))))
))
)