diff --git a/collects/frtime/animation.ss b/collects/frtime/animation.ss index 059c93e9e2..0377c09621 100644 --- a/collects/frtime/animation.ss +++ b/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)] diff --git a/collects/frtime/demos/growing-points.ss b/collects/frtime/demos/growing-points.ss index 3a60671345..411037b963 100644 --- a/collects/frtime/demos/growing-points.ss +++ b/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)) diff --git a/collects/frtime/demos/needles.ss b/collects/frtime/demos/needles.ss index a648380cec..c25a5ad49a 100644 --- a/collects/frtime/demos/needles.ss +++ b/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) diff --git a/collects/frtime/demos/pong.ss b/collects/frtime/demos/pong.ss index 0699edb559..0ed66b2132 100644 --- a/collects/frtime/demos/pong.ss +++ b/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"))) diff --git a/collects/frtime/demos/tetris.ss b/collects/frtime/demos/tetris.ss new file mode 100644 index 0000000000..bd1c448c93 --- /dev/null +++ b/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))) diff --git a/collects/frtime/graphics-posn-less-unit.ss b/collects/frtime/graphics-posn-less-unit.ss index 64b93f6ca1..23a5daf039 100644 --- a/collects/frtime/graphics-posn-less-unit.ss +++ b/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) diff --git a/collects/frtime/gui.ss b/collects/frtime/gui.ss index eb2865836e..5b1965fdf2 100644 --- a/collects/frtime/gui.ss +++ b/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))) diff --git a/collects/frtime/gui/mixin-macros.ss b/collects/frtime/gui/mixin-macros.ss index f0f5b2cac8..e3223df4e6 100644 --- a/collects/frtime/gui/mixin-macros.ss +++ b/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 diff --git a/collects/frtime/lang-ext.ss b/collects/frtime/lang-ext.ss index e6b5bcd995..942c66f33a 100644 --- a/collects/frtime/lang-ext.ss +++ b/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)) diff --git a/collects/gui-debugger/debug-tool.ss b/collects/gui-debugger/debug-tool.ss index c1aac89f1e..beefad7907 100644 --- a/collects/gui-debugger/debug-tool.ss +++ b/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)