htdch/draw and htdch/idraw fixed, common code basis
svn: r2759
This commit is contained in:
Matthias Felleisen
parent
e87c19f719
commit
770e6aa288
|
|
@ -1,170 +1,12 @@
|
|||
#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")
|
||||
(require (lib "support.scm" "htdch" "draw") (lib "unitsig.ss"))
|
||||
|
||||
(define void-or-true #t)
|
||||
(define (imperative w@t+1 w@t) w@t+1)
|
||||
|
||||
;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
|
||||
"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))))
|
||||
(define-values/invoke-unit/sig canvas-native^ canvas-native@ #f support^)
|
||||
|
||||
;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)))
|
||||
|
||||
(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)))))
|
||||
(provide-signature-elements canvas-native^))
|
||||
|
||||
(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))
|
||||
|#
|
||||
)
|
||||
|
||||
|
|
|
|||
|
|
@ -1,26 +1,32 @@
|
|||
package draw;
|
||||
|
||||
public class Canvas {
|
||||
private int width = 0;
|
||||
private int height = 0;
|
||||
|
||||
public native boolean start(int width, int height);
|
||||
|
||||
public native boolean stop();
|
||||
|
||||
public native boolean drawCircle(Posn p, int r, Color c);
|
||||
|
||||
public native boolean drawDisk(Posn p, int r, 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 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);
|
||||
public Canvas(int width, int height) {
|
||||
this.width = width;
|
||||
this.height = height;
|
||||
}
|
||||
|
||||
// these two are cheats:
|
||||
protected native boolean copy();
|
||||
protected native boolean 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 boolean show();
|
||||
public native boolean close();
|
||||
public native boolean drawCircle(Posn p, int r, Color c);
|
||||
public native boolean drawDisk(Posn p, int r, 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 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);
|
||||
}
|
||||
|
|
|
|||
|
|
@ -1,134 +1,12 @@
|
|||
#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 (lib "support.scm" "htdch" "draw") (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 #t)
|
||||
(define (imperative world@t+1 world@t) world@t+1)
|
||||
|
||||
(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))))
|
||||
|
||||
(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-values/invoke-unit/sig world-native^ world-native@ #f support^))
|
||||
|
||||
(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))
|
||||
)
|
||||
|
||||
|
|
|
|||
|
|
@ -1,13 +1,37 @@
|
|||
package draw;
|
||||
|
||||
public abstract class World {
|
||||
public Canvas theCanvas = new Canvas();
|
||||
public native boolean bigBang(int width, int height, double s);
|
||||
public native boolean endOfTime();
|
||||
public native World endOfWorld();
|
||||
public native World lastWorld();
|
||||
public abstract World onTick();
|
||||
public abstract World onKeyEvent(String ke);
|
||||
public abstract boolean draw();
|
||||
public abstract boolean erase();
|
||||
protected Canvas theCanvas;
|
||||
protected void putCanvas(Canvas c) {
|
||||
this.theCanvas = c;
|
||||
};
|
||||
public boolean bigBang(int width, int height, double s) {
|
||||
if (width <= 0)
|
||||
throw new RuntimeException(
|
||||
"The method bigBang(int,int,double) expects " +
|
||||
"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();
|
||||
}
|
||||
|
|
|
|||
|
|
@ -1,129 +1,10 @@
|
|||
#cs
|
||||
(module Canvas-native-methods mzscheme
|
||||
(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 (lib "support.scm" "htdch" "draw") (lib "unitsig.ss"))
|
||||
|
||||
(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
|
||||
;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))))
|
||||
)
|
||||
(provide-signature-elements canvas-native^))
|
||||
|
|
|
|||
|
|
@ -1,4 +1,7 @@
|
|||
package idraw;
|
||||
|
||||
import draw.Color;
|
||||
import draw.Posn;
|
||||
|
||||
public class Canvas {
|
||||
private int width = 0;
|
||||
|
|
@ -10,13 +13,10 @@ public class Canvas {
|
|||
}
|
||||
|
||||
// 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.)
|
||||
protected native void copy();
|
||||
protected native void stop();
|
||||
// MF: 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 void show();
|
||||
public native void close();
|
||||
|
|
|
|||
|
|
@ -1,10 +1,10 @@
|
|||
#cs
|
||||
(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)
|
||||
|
||||
(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^))
|
||||
|
|
|
|||
|
|
@ -1,9 +1,7 @@
|
|||
package idraw;
|
||||
|
||||
public abstract class World {
|
||||
|
||||
public Canvas theCanvas;
|
||||
|
||||
public void bigBang(int width, int height, double s) {
|
||||
if (width <= 0)
|
||||
throw new RuntimeException(
|
||||
|
|
@ -22,13 +20,13 @@ public abstract class World {
|
|||
+ s);
|
||||
theCanvas = new Canvas(width,height);
|
||||
bigBangO(s);
|
||||
return ;
|
||||
}
|
||||
|
||||
private native void bigBangO(double s);
|
||||
|
||||
// --------------------------------------------------------
|
||||
|
||||
public native World endOfTime();
|
||||
public native boolean endOfTime();
|
||||
public native World endOfWorld();
|
||||
public abstract void onTick();
|
||||
public abstract void onKeyEvent(String ke);
|
||||
|
|
|
|||
|
|
@ -11,14 +11,16 @@
|
|||
(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 "Posn.java")
|
||||
(javac "Color.java")
|
||||
(javac "Red.java")
|
||||
(javac "White.java")
|
||||
(javac "Blue.java")
|
||||
(javac "Black.java")
|
||||
(javac "Green.java")
|
||||
(javac "Yellow.java")
|
||||
|#
|
||||
))))
|
||||
|
|
|
|||
|
|
@ -2,6 +2,4 @@
|
|||
(define name "htdch")
|
||||
(define compile-subcollections (list (list "htdch" "draw")
|
||||
(list "htdch" "graphics")
|
||||
(list "htdch" "idraw")
|
||||
))
|
||||
)
|
||||
(list "htdch" "idraw"))))
|
||||
|
|
|
|||
Loading…
Reference in New Issue
Block a user