more cleanup

* fix a bug in initialization of FrTime widgets
* fix a bug in the pong demo
* allow needles and growing points to have larger grids
* purge the old GUI wrapper implementation
* fix a couple of bugs in the debugger
* add bitmap support to the animation library

svn: r9647

collects/frtime/animation.ss

@@ -96,7 +96,11 @@
   (define-struct curve (xmin xmax ymin ymax fn))
   (define-struct polygon (posn-list posn color))
   (define-struct solid-polygon (posn-list posn color))
+  (define-struct image (pos renderer))
   
+  (define (prep-image file)
+    (draw-pixmap-posn file))
+
   (define (make-circle center r color)
     (make-solid-ellipse (make-posn (- (posn-x center) r)
                                    (- (posn-y center) r))
@@ -140,6 +144,10 @@
                  (* 2 radius)
                  (* 2 radius)
                  (if (undefined? color) "black" color))))]
+           [($ image pos renderer)
+            (let ([renderer (v-n renderer)]
+                  [pos (v-n pos)])
+              ((renderer pixmap) pos))]
            [($ solid-ellipse ul w h color)
             (let ([ul (v-n ul)]
                   [w (v-n w)]

collects/frtime/demos/growing-points.ss

@@ -18,7 +18,7 @@
   (sqrt (+ (sqr (- x1 x2)) (sqr (- y1 y2)))))
 
 ;; How many growing points on one side of the grid of growing points.
-(define GRID-SIZE (make-slider "Width" 1 10 8))
+(define GRID-SIZE (make-slider "Width" 1 12 8))
 
 ;; The distance between the centers of two adjacent growing points.
 (define grid-resolution (make-slider "Resolution" 2 30 20))

collects/frtime/demos/needles.ss

@@ -13,7 +13,7 @@
          frtime/gui)
 
 ;; How many needles on one side of the grid of needles
-(define GRID-SIZE (make-slider "Grid size:" 1 10 8))
+(define GRID-SIZE (make-slider "Grid size:" 1 12 8))
 
 ;; The length of a needle in pixels
 (define NEEDLE-LENGTH 10)

collects/frtime/demos/pong.ss

@@ -101,13 +101,11 @@
  (list 
   (make-line (make-posn 200 0) (make-posn 200 399) "gray")
   (make-circle ball-pos 10 "blue")
-  ;(make-circle (delay-by ball-pos 200) 8 "lightblue")
   (make-circle paddle1-pos paddle-radius "black")
   (make-circle paddle2-pos paddle-radius "black")
   (make-graph-string (make-posn 30 30) (number->string p2-score)
-                     (if (= p2-score (delay-by p2-score 600)) "black" "red"))
+                     (if (= p2-score (delay-by p2-score 600)) "black" "red" "black"))
   (make-graph-string (make-posn 350 30) (number->string p1-score)
-                     (if (= p1-score (delay-by p1-score 600)) "black" "red"))
-  ;(make-graph-string (make-posn 120 30) (number->string (posn-len ball-vel)) "black")
+                     (if (= p1-score (delay-by p1-score 600)) "black" "red" "black"))
   (make-line (make-posn 0 150) (make-posn 0 250) "red")
   (make-line (make-posn 399 150) (make-posn 399 250) "red")))

collects/frtime/demos/tetris.ss

@@ -0,0 +1,190 @@
+(require (lifted texpict/mrpict colorize vl-append vr-append text
+                 cc-superimpose hb-append ht-append pin-over blank
+                 dc-for-text-size)
+         (lifted texpict/utils filled-rectangle rectangle)
+         frtime/gui/fred
+         (only frtime/frp-core do-in-manager do-in-manager-after)
+         mred)
+
+;; TODO: layered drawing, pause, game over
+
+(do-in-manager
+ (dc-for-text-size (new bitmap-dc% [bitmap (make-object bitmap% 64 64)])))
+
+(define size (new-cell 20))
+(define row-width 12)
+
+(define tomato-ev (event-receiver))
+(define tomato (new-cell "tomato"))
+(do-in-manager-after ())
+
+(define list-ref*
+  (case-lambda
+    [(lst idx) (list-ref lst idx)]
+    [(lst idx . is) (apply list-ref* (list-ref lst idx) is)]))
+
+(define (rotate matrix)
+  (let ([rows (length matrix)]
+        [columns (length (first matrix))])
+    (build-list
+     columns
+     (lambda (i)
+       (build-list rows (lambda (j) (list-ref* matrix j (- columns i 1))))))))
+
+(define shapes
+  (map (lambda (desc)
+         (map (lambda (row)
+                (map (lambda (cell) (if (zero? cell) #f (first desc))) ; color
+                     row))
+              (rest desc)))
+       `(; T shape
+         (,tomato
+          (0 1 0)
+          (1 1 1))
+         ; S shape
+         ("orange"
+          (0 1 1)
+          (1 1 0))
+         ; Z shape
+         ("lightblue"
+          (1 1 0)
+          (0 1 1))
+         ; L shape
+         ("lightgreen"
+          (1 1 1)
+          (1 0 0))
+         ; reverse L shape
+         ("gray"
+          (1 1 1)
+          (0 0 1))
+         ; I shape
+         ("lavender"
+          (1 1 1 1))
+         ; block shape
+         ("purple"
+          (1 1)
+          (1 1)))))
+
+(define 1x1 (cc-superimpose (colorize (rectangle size size) "black")
+                            (filled-rectangle (- size 2) (- size 2))))
+
+(define (make-cell c)
+  (if c (colorize 1x1 c) (blank size)))
+
+(define (make-row lst)
+  (apply hb-append (map make-cell lst)))
+
+(define (make-shape lol)
+  (apply vl-append (map make-row lol)))
+
+(define frame (new ft-frame% [label "Tetris"] [shown #t]
+                   [min-width (* size 20)] [min-height (* size 20)]))
+
+(define (intersects grid shape h-pos v-pos)
+  (ormap (lambda (shape-row cell-v)
+           (ormap (lambda (shape-cell cell-h)
+                    (and (value-now shape-cell) (value-now (list-ref* grid cell-v cell-h))))
+                  shape-row
+                  (build-list (length shape-row) (lambda (i) (+ i h-pos)))))
+         shape
+         (build-list (length shape) (lambda (i) (+ i v-pos)))))
+
+(define empty-row (build-list row-width (lambda (j) (and (or (= j 0) (= j (sub1 row-width))) "black"))))
+
+(define n-rows 20)
+
+(define bottom-row
+  (append (build-list row-width (lambda (_) "black")) (list #f)))
+
+(define (replenish-rows grid)
+  (append (build-list (- n-rows (length grid)) (lambda (_) empty-row)) grid))
+
+(define (remove-completed-rows grid)
+  (let ([new-grid (filter (lambda (row) (not (andmap identity row))) grid)])
+    (list new-grid (case (- (length grid) (length new-grid))
+                     [(0) 0]
+                     [(1) 20]
+                     [(2) 60]
+                     [(3) 200]
+                     [(4) 1000]))))
+
+(define (add-shape grid shape h-pos v-pos)
+  (map (lambda (row row-num)
+         (map (lambda (cell col-num)
+                (or cell (let ([shape-v-pos (- row-num v-pos)]
+                               [shape-h-pos (- col-num h-pos)])
+                           (and (< -1 shape-v-pos (length shape))
+                                (< -1 shape-h-pos (length (first shape)))
+                                (list-ref* shape shape-v-pos shape-h-pos)))))
+              row (build-list (length row) identity)))
+       grid (build-list (length grid) identity)))
+
+(define (move direction grid shape h-pos v-pos new-shape score)
+  (case direction
+    [(left right rotate)
+     (let ([new-h ((case direction
+                     [(left) sub1]
+                     [(right) add1]
+                     [(rotate) identity]) h-pos)]
+           [rshape (if (eq? direction 'rotate) (rotate shape) shape)])
+       (cons grid
+             (if (intersects grid rshape new-h v-pos)
+                 (list shape h-pos v-pos new-shape score)
+                 (list rshape new-h v-pos new-shape score))))]
+    [(down)
+     (if (intersects grid shape h-pos (add1 v-pos))
+         (let ([new-grid/points (remove-completed-rows
+                                 (add-shape grid shape h-pos v-pos))])
+           (list (replenish-rows (first new-grid/points))
+                 new-shape 5 0 (list-ref shapes (random (length shapes))) (+ (second new-grid/points) score)))
+         (list grid shape h-pos (add1 v-pos) new-shape score))]
+    [(drop) (let ([new-state (move 'down grid shape h-pos v-pos new-shape score)])
+              (if (not (eq? (first new-state) grid))
+                  (list grid shape h-pos v-pos new-shape score)
+                  (move 'drop grid shape h-pos (add1 v-pos) new-shape score)))]
+    [(reset) (list init-grid new-shape 5 0 (list-ref shapes (random (length shapes))) 0)]))
+
+(define init-grid
+  (append (build-list (sub1 n-rows) (lambda (i) empty-row)) (list bottom-row)))
+
+(define-values (canvas state rate)
+  (letrec ([canvas (new ft-canvas% [parent frame] [style '(no-autoclear)]
+                        [pict anim])]
+           [keys (send canvas get-key-events)]
+           [left (keys 'left)] [right (keys 'right)]
+           [up (keys 'up)] [down (keys 'down)]
+           [space (keys #\space)]
+           [reset (keys #\r)]
+           [state (collect-b
+                   (merge-e (left . -=> . 'left)
+                            (right . -=> . 'right)
+                            (up . -=> . 'rotate)
+                            ((changes (quotient (modulo (inexact->exact (floor milliseconds)) 100000000)
+                                                rate)) . -=> . 'down)
+                            (down . -=> . 'down)
+                            (space . -=> . 'drop)
+                            (reset . -=> . 'reset))
+                   (list init-grid (list-ref shapes (random (length shapes))) 5 0
+                         (list-ref shapes (random (length shapes))) 0)
+                   (lambda (direction old-state)
+                     (apply move direction old-state)))]
+           [grid (first state)]
+           [shape (second state)]
+           [h-pos (third state)]
+           [v-pos (fourth state)]
+           [new-shape (fifth state)]
+           [score (sixth state)]
+           [rate (inf-delay (+ 250 (quotient 75000 (+ 100 score))))]
+           [anim (ht-append
+                  (pin-over (make-shape grid)
+                            (* size h-pos)
+                            (* size v-pos)
+                            (make-shape shape))
+                  (vl-append
+                   (blank size)
+                   (cc-superimpose
+                    (rectangle (* size 6) (* size 6))
+                    (make-shape new-shape))
+                   (blank size)
+                   (text (format "Score: ~a" score))))])
+    (values canvas state rate)))

collects/frtime/graphics-posn-less-unit.ss

@@ -923,7 +923,7 @@
   (define draw-pixmap-posn
     (opt-lambda (filename [type 'unknown/mask])
       (check 'draw-pixmap-posn
-	     (andp string? file-exists?) filename "filename"
+	     string? filename "filename"
 	     (lambda (x) (memq x '(gif xbm xpm bmp pict unknown unknown/mask gif/mask))) type "file type symbol")
       (let* ([bitmap (make-object mred:bitmap% filename type)])
 	(lambda (viewport)

collects/frtime/gui.ss

@@ -1,235 +1,42 @@
-(module gui "frtime.ss"
+(module gui frtime
   (require
    (all-except mzlib/etc rec)
    mzlib/list
-   mzlib/class
+   frtime/gui/fred
    (rename frtime/frp-core proc->signal proc->signal)
    (all-except mred send-event))
   
-  (define reactive-control<%>
-    (interface (control<%>)
-      get-event))
-  
-  (define (insert-in-list list position new-element)
-    (let loop ((list list) (position position))
-      (cond
-        ((zero? position)
-         (cons new-element list))
-        ((null? list)
-         '())
-        (else
-         (cons (car list) (loop (cdr list) (sub1 position)))))))
-  
-  (define (reactive-control-mixin super)
-    (class* super (reactive-control<%>)
-;    (mixin (control<%>) (reactive-control<%>)
-      (define event (event-receiver))
-      (define/public (get-event) event)
-      (define/public (extract-value)
-        (error 'extract-value "abstract method"))
-      (super-instantiate ()
-        (callback
-         (lambda (self control-event)
-           (send-event event
-                       (list self
-                             control-event
-                             (extract-value))))))))
-  
-  (define reactive-slider%
-    (class (reactive-control-mixin slider%)
-      (inherit get-value)
-      (define/override (extract-value)
-        (get-value))
-      (super-instantiate ())))
-  
-  (define (make-control-behavior reactive-control)
-    (hold ((send reactive-control get-event) . ==> . third)
-          (send reactive-control extract-value)))
-  
-  ;(define (get-button-event reactive-button)
-  ;  ((send reactive-button get-event) . -=> . #t))
-  
-  (define reactive-slider-1d% reactive-slider%)
-  
-  (define make-slider-1d-behavior make-control-behavior)
-  
-;   (define reactive-slider-2d%
-;     (class (reactive-control-mixin slider-2d%)
-;       (inherit get-values)
-;       (define/override (extract-value)
-;         (call-with-values (lambda () (get-values))
-;                           cons))
-;       (super-instantiate ())))
-;   
-;   (define (make-slider-2d-behavior reactive-slider)
-;     (hold ((send reactive-slider get-event) . ==> . third)
-;           (call-with-values
-;            (lambda () (send reactive-slider get-values))
-;            cons)))
-;   
-; 
- 
-  
-  (define reactive-button%
-    (class (reactive-control-mixin button%)
-      (define/override (extract-value)
-        'button-press)
-      (super-instantiate ())))
-  
-  (define reactive-check-box%
-    (class (reactive-control-mixin check-box%)
-      (inherit get-value)
-      (define/override (extract-value)
-        (get-value))
-      (super-instantiate ())))
-  
-  (define reactive-list-box%
-    (class (reactive-control-mixin list-box%)
-      (inherit get-selections)
-      (define/override (extract-value)
-        (get-selections))
-      (super-instantiate ())))
-  
-  (define reactive-choice%
-    (class (reactive-control-mixin choice%)
-      (inherit get-selection)
-      (define/override (extract-value)
-        (get-selection))
-      (super-instantiate ())))
-  
-  (define reactive-text-field%
-    (class (reactive-control-mixin text-field%)
-      (inherit get-value)
-      (define/override (extract-value)
-        (get-value))
-      (super-instantiate ())))
-  
-  (define view<%>
-    (interface ()
-      set-value))
-  
-  (define reactive-view<%>
-    (interface ()
-      set-behavior))
-  
-  (define (reactive-view-mixin super)
-    (class* super (reactive-view<%>)
-;    (mixin (view<%>) (reactive-view<%>)
-      (init-field
-       [cell (new-cell undefined)]
-       [updater #f])
-      
-      (super-instantiate ())
-      
-      (define/public (set-behavior beh)
-        (unless updater
-          (set! updater
-                (proc->signal
-                 (lambda ()
-                   (send this set-value (value-now cell))
-                   (value-now cell))
-                 cell)))
-        (set-cell! cell beh))))
-;   (define (drive-view-thread view event)
-;     (let ((view-box (make-weak-box view)))
-;       (set! view (void))
-;       (dynamic-disable-break
-;        (lambda ()
-;          (thread
-;           (lambda ()
-;             (let/ec k
-;               (with-handlers ((exn:break? k))
-;                 (run-callback event
-;                               (lambda (value)
-;                                 (cond
-;                                   ((weak-box-value view-box)
-;                                    => (lambda (view)
-;                                         (send view set-value value)))
-;                                   (else (k 'fick-dich-ins-knie)))))))))))))
-; 
-
-  (define reactive-gauge%
-    (reactive-view-mixin
-     (class* gauge% (view<%>)
-       (override set-value)
-       (inherit show is-shown?)
-       (define (set-value val)
-         (if (undefined? val)
-             (when (is-shown?)
-               (show #f))
-             (begin
-               (unless (is-shown?)
-                 (show #t))
-               (super set-value val))))
-       (super-instantiate ()))))
-  
-  (define reactive-message%
-    (reactive-view-mixin
-     (class* message% (view<%>)
-       (inherit set-label)
-       (define/public (set-value label)
-         (if (undefined? label)
-             (set-label "")
-             (set-label label)))
-       (super-instantiate ()))))
-  
-  (define frame (instantiate frame% () (label "GUI") (height 150) (width 200)))
-  (send frame show #t)
-  
-  (define-struct gui-item (builder))
-  
-  (define (create-gui-item builder)
-    (let ([C false])
-      (make-gui-item
-       (lambda (p)
-         (cond
-           [(and p C)
-            (error 'create-window "item added to window twice")]
-           [(and p (not C)) (set! C (builder p)) C]
-           [(and (not p) C) C]
-           [(and (not p) (not C))
-            (error 'gui "gui-items must be added to window before use (see create-window)")])))))
+  (define frame (new ft-frame% [label "GUI"] [min-height 150] [min-width 200] [shown #t]))
   
   (define (make-button str)
-    (send (instantiate reactive-button% () (label str) (parent frame)) get-event))
+    (send (new ft-button% [parent frame] [label str]) get-value-e))
   
   (define (make-message str~)
-    (send (instantiate reactive-message% ()
-            (label (if (undefined? (value-now str~))
-                       ""
-                       (value-now str~)))
-            (parent frame)
-            (stretchable-height #t)
-            (stretchable-width #t))
-          set-behavior
-          str~))
+    (new ft-message% [parent frame] [label str~]
+         [stretchable-height #t]
+         [stretchable-width #t]))
   
   (define (make-gauge rng val~)
-    (send (instantiate reactive-gauge% ()
-            (label "")
-            (range rng)
-            (parent frame)
-            (stretchable-width #t))
-          set-behavior
-          val~))
+    (new ft-gauge% [parent frame] [label ""] [range rng] [stretchable-width #t]
+         [value val~]))
   
   (define (make-text str)
-    (make-control-behavior (instantiate reactive-text-field% () (label str) (init-value "") (parent frame))))
+    (send (new ft-text-field% [parent frame] [label str] [init-value ""])
+          get-value-b))
   
   (define (make-choice str los)
-    (make-control-behavior (instantiate reactive-choice% () (choices los) (parent frame) (label str))))
+    (send (new ft-choice% [parent frame] [label str] [choices los])
+          get-selection-b))
 
   (define (make-slider str min max init)
-    (make-control-behavior (instantiate reactive-slider-1d% () (label str)
-                             (min-value min) (max-value max) (parent frame)
-                             (init-value init)
-                             ;(style (list 'plain 'horizontal))
-                             )))
+    (send (new ft-slider% [parent frame] [min-value min] [max-value max]
+               [init-value init] [label str])
+          get-value-b))
   
   (define make-check-box
     (opt-lambda (str [val #f])
-      (make-control-behavior (instantiate reactive-check-box% ()
-                               (label str) (parent frame) (value val)))))
+      (send (new ft-check-box% [parent frame] [label str] [value val])
+            get-value-b)))
   
   (define fresh-window
     (let ([first #t])
@@ -237,7 +44,7 @@
         (if first
             (set! first #f)
             (begin
-              (set! frame (instantiate frame% () (label "GUI") (height 150) (width 200)))
-              (send frame show #t))))))
+              (set! frame (new ft-frame% [label "GUI"] [min-height 150] [min-width 200]
+                               [shown #t])))))))
   
   (provide (all-defined)))

collects/frtime/gui/mixin-macros.ss

@@ -44,9 +44,9 @@
            #'(lambda (default-proc super-class)
                (class super-class
                  (init (processor default-proc))
-                 (super-new)
                  (define name-e (event-receiver))
                  (define processed-events (processor name-e))
+                 (super-new)
                  ;what about when the super call returns an error?
                  (define/override method-name
                    (lambda args 

collects/frtime/lang-ext.ss

@@ -43,17 +43,14 @@
         (apply fn (map value-now/no-copy args))
         (with-continuation-mark
             'frtime 'lift-active
-          (if (ormap signal? args)
-              (begin
-                #;(when (ormap signal:compound? args)
-                  (printf "attempting to lift ~a over a signal:compound in ~a!~n" fn (map value-now args)))
-                (apply
-                 proc->signal
-                 (apply (if strict? create-strict-thunk create-thunk) fn args)
-                 args))
-              (if (and strict? (ormap undefined? args))
-                  undefined
-                  (apply fn args))))))
+          (cond
+            [(ormap signal? args)
+             (apply
+              proc->signal
+              (apply (if strict? create-strict-thunk create-thunk) fn args)
+              args)]
+            [(and strict? (ormap undefined? args)) undefined]
+            [else (apply fn args)]))))
   
   (define (lift-strict . args)
     (apply lift #t args))

collects/gui-debugger/debug-tool.ss

@@ -57,13 +57,11 @@
         (void))
       
       (define (truncate str n)
-        (if (< (string-length str) n)
-            str
-            (if (>= n 3)
-                (string-append
-                 (substring str 0 (- n 3))
-                 "...")
-                (substring str 0 (min n (string-length str))))))
+        (cond [(< (string-length str) n) str]
+              [(>= n 3) (string-append
+                          (substring str 0 (- n 3))
+                          "...")]
+              [else (substring str 0 (min n (string-length str)))]))
       
       (define (clean-status s)
 	(truncate (regexp-replace* #rx"\n" s " ") 200))
@@ -896,9 +894,8 @@
                 (send (send (get-frame) get-step-out-button) enable (can-step-out? frames status))
                 (send (send (get-frame) get-resume-button) enable #t)
                 (send (get-frame) register-stack-frames frames already-stopped?)
-                (send (get-frame) register-vars (if (empty? frames)
-                                                    empty
-                                                    (list-ref frames (get-frame-num))))
+                (unless (empty? frames)
+                  (send (get-frame) register-vars (list-ref frames (get-frame-num))))
                 (send status-message set-label
                       (if (and (cons? status) top-of-stack?)
                           (let ([expr (mark-source (first frames))])
@@ -941,7 +938,7 @@
             (send (send (get-frame) get-step-out-button) enable #f)
             (send (send (get-frame) get-resume-button) enable #f)
             (send (send (get-frame) get-status-message) set-label "")
-            (send (get-frame) clear-stack-frames)
+            (send (get-frame) clear-stack-frames/vars)
             (send (get-defs) invalidate-bitmap-cache))
           
           (define/public suspend
@@ -1126,12 +1123,17 @@
               (send stack-frames lock #t)
               (send stack-frames end-edit-sequence)))
           
-          (define/public (clear-stack-frames)
+          (define/public (clear-stack-frames/vars)
             (send stack-frames begin-edit-sequence)
             (send stack-frames lock #f)
             (send stack-frames delete 0 (send stack-frames last-position))
             (send stack-frames lock #t)
-            (send stack-frames end-edit-sequence))
+            (send stack-frames end-edit-sequence)
+            (send variables-text begin-edit-sequence)
+            (send variables-text lock #f)
+            (send variables-text delete 0 (send variables-text last-position))
+            (send variables-text lock #t)
+            (send variables-text end-edit-sequence))
           
           (define debug-grandparent-panel 'uninitialized-debug-grandparent-panel)
           (define debug-parent-panel 'uninitialized-debug-parent-panel)