idraw created

svn: r2207

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 
 

collects/htdch/idraw/Black.java

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

collects/htdch/idraw/Blue.java

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

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

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

collects/htdch/idraw/Color.java

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

collects/htdch/idraw/Green.java

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

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

collects/htdch/idraw/Red.java

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

collects/htdch/idraw/White.java

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

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

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

collects/htdch/idraw/Yellow.java

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

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

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

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

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

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