From d246a0bcc167266e8fd5062291472c26cb943f7f Mon Sep 17 00:00:00 2001 From: Ryan Culpepper Date: Sun, 3 Jul 2011 21:41:45 -0600 Subject: [PATCH] unstable/gui/ppict: added cascade placer --- collects/unstable/gui/ppict.rkt | 4 + collects/unstable/gui/private/ppict.rkt | 107 ++++++++++++------ .../unstable/scribblings/gui/pslide.scrbl | 46 +++++++- 3 files changed, 115 insertions(+), 42 deletions(-) diff --git a/collects/unstable/gui/ppict.rkt b/collects/unstable/gui/ppict.rkt index 0d9be445e8..1a30bc4a0e 100644 --- a/collects/unstable/gui/ppict.rkt +++ b/collects/unstable/gui/ppict.rkt @@ -53,4 +53,8 @@ exact-nonnegative-integer? exact-nonnegative-integer?) (align/c #:compose procedure?) + placer?)] + [cascade + (->* () + ((or/c real? 'auto) (or/c real? 'auto)) placer?)]) diff --git a/collects/unstable/gui/private/ppict.rkt b/collects/unstable/gui/private/ppict.rkt index e0eabba0e8..166aac4b29 100644 --- a/collects/unstable/gui/private/ppict.rkt +++ b/collects/unstable/gui/private/ppict.rkt @@ -56,57 +56,92 @@ In a placer function's arguments: ;; ---- -;; row, column indexes are 0-based (define (grid cols rows col row [align 'cc] - #:compose [composer (align->vcomposer align)] + #:abs-x [abs-x 0] + #:abs-y [abs-y 0] + #:compose [compose (halign->vcompose (align->h align))] #:sep [sep 0]) + ;; row, column indexes are 1-based (define halign (align->h align)) (define valign (align->v align)) - (define refxfrac (/ (+ col (align->frac halign)) cols)) - (define refyfrac (/ (+ row (align->frac valign)) rows)) - (coord refxfrac refyfrac align #:compose composer #:sep sep)) + (define xfrac (/ (+ (sub1 col) (align->frac halign)) cols)) + (define yfrac (/ (+ (sub1 row) (align->frac valign)) rows)) + (refpoint* xfrac yfrac abs-x abs-y halign valign compose sep)) -(define (coord refxfrac refyfrac [align 'cc] - #:compose [composer (align->vcomposer align)] +(define (coord xfrac yfrac [align 'cc] + #:abs-x [abs-x 0] + #:abs-y [abs-y 0] + #:compose [compose (halign->vcompose (align->h align))] #:sep [sep 0] #:internal:skip [skip #f]) (define halign (align->h align)) (define valign (align->v align)) + (refpoint* xfrac yfrac abs-x abs-y halign valign compose sep)) + +(define (refpoint* xfrac yfrac dxabs dyabs + halign valign compose sep) (placer (lambda (scene picts) (define scene-w (pict-width scene)) (define scene-h (pict-height scene)) - (define refx (* scene-w refxfrac)) - (define refy (* scene-h refyfrac)) + (define dx (+ (* scene-w xfrac) dxabs)) + (define dy (+ (* scene-h yfrac) dyabs)) (define-values (newpict newsep) - (apply-composer composer sep (cons skip picts))) + (apply-compose compose sep picts)) (define newpict-w (pict-width newpict)) (define newpict-h (pict-height newpict)) - (define localrefx (* newpict-w (align->frac halign))) - (define localrefy (* newpict-h (align->frac valign))) (define newscene - (lt-superimpose scene (inset newpict (- refx localrefx) (- refy localrefy) 0 0))) + (let ([localrefx (* newpict-w (align->frac halign))] + [localrefy (* newpict-h (align->frac valign))]) + (lt-superimpose scene (inset newpict (- dx localrefx) (- dy localrefy) 0 0)))) (let ([result-pict (refocus newscene scene)]) - (cond [(and (eq? valign 't) (eq? composer (align->vcomposer align))) - ;; ie, going top-down and composer is the natural composer for this align + (cond [(and (eq? valign 't) (eq? compose (halign->vcompose halign))) + ;; ie, going top-down and compose is the natural compose for this align (mk-ppict result-pict - (coord refxfrac refyfrac align - #:compose composer - #:sep newsep - #:internal:skip (blank 0 newpict-h)))] - [(and (eq? halign 'l) (eq? composer (align->hcomposer align))) + (refpoint* 0 0 dx (+ dy newpict-h) halign valign compose newsep))] + [(and (eq? halign 'l) (eq? compose (valign->hcompose valign))) + ;; ie, going left-right and compose is the natural compose ... (mk-ppict result-pict - (coord refxfrac refyfrac align - #:compose composer - #:sep newsep - #:internal:skip (blank newpict-w 0)))] + (refpoint* 0 0 (+ dx newpict-w) dy halign valign compose newsep))] [else result-pict]))))) ;; ---- -;; apply-composer : composer real (listof (U #f pict real)) -> (values pict real) +;; cascade : -> placer +(define (cascade [step-x0 'auto] [step-y0 'auto]) + ;; Auto cascade by largest bounding box. + ;; FIXME: add align arg, determines position of each pict w/in bbox + (placer + (lambda (scene elems) + (for/or ([e (in-list elems)]) + (when (real? e) + (error 'cascade "spacing changes not allowed: ~e" e))) + (let* ([picts (filter pict? elems)] + [max-w (apply max 1 (map pict-width picts))] ;; avoid 0 + [max-h (apply max 1 (map pict-height picts))] ;; avoid 0 + [auto-step-x (/ (- (pict-width scene) max-w) (+ 1 (length picts)))] + [auto-step-y (/ (- (pict-height scene) max-h) (+ 1 (length picts)))] + [step-x (if (eq? step-x0 'auto) auto-step-x step-x0)] + [step-y (if (eq? step-y0 'auto) auto-step-y step-y0)] + [bbox (blank max-w max-h)] + [positioned-picts + (for/list ([pict (in-list picts)] + [i (in-naturals 1)]) + (inset (cc-superimpose bbox pict) + (* i step-x) (* i step-y) 0 0))] + [newscene + (lt-superimpose scene + (apply lt-superimpose positioned-picts))] + [result-pict (refocus newscene scene)]) + ;; Can't continue a cascade, since depends on number of picts. + ;; FIXME: If step is given rather than computed, then we can. + result-pict)))) + +;; ---- + +;; apply-compose : compose real (listof (U #f pict real)) -> (values pict real) ;; Returns composed pict and last given separator num in elems (or init-sep, if none) -(define (apply-composer composer init-sep elems) +(define (apply-compose compose init-sep elems) (define (start-loop sep elems) (cond [(and (pair? elems) (real? (car elems))) (start-loop (car elems) (cdr elems))] @@ -118,7 +153,7 @@ In a placer function's arguments: (cond [(and (pair? elems) (real? (car elems))) (join-loop base (car elems) (cdr elems))] [(and (pair? elems) (pict? (car elems))) - (join-loop (composer sep base (car elems)) + (join-loop (compose sep base (car elems)) sep (cdr elems))] [(null? elems) base])) @@ -145,17 +180,17 @@ In a placer function's arguments: ((lc cc rc) 'c) ((lb cb rb) 'r))) -(define (align->vcomposer align) - (case align - ((lt lc lb) vl-append) - ((ct cc cb) vc-append) - ((rt rc rb) vr-append))) +(define (halign->vcompose halign) + (case halign + ((l) vl-append) + ((c) vc-append) + ((r) vr-append))) -(define (align->hcomposer align) +(define (valign->hcompose align) (case align - ((lt ct rt) ht-append) - ((lc cc rc) hc-append) - ((lb cb rb) hb-append))) + ((t) ht-append) + ((c) hc-append) + ((b) hb-append))) ;; ---- diff --git a/collects/unstable/scribblings/gui/pslide.scrbl b/collects/unstable/scribblings/gui/pslide.scrbl index c0912033ba..1f69ced7e0 100644 --- a/collects/unstable/scribblings/gui/pslide.scrbl +++ b/collects/unstable/scribblings/gui/pslide.scrbl @@ -35,7 +35,7 @@ compact notation for sequences of those two operations. base (define circles-down-1 (ppict-do base - #:go (grid 2 2 1 0 'ct) + #:go (grid 2 2 2 1 'ct) 10 (circle 20) (circle 20) @@ -192,27 +192,61 @@ another progressive pict only if Returns a placer that places picts according to a position in a virtual grid. The @racket[row] and @racket[col] indexes are numbered -starting at @racket[0]. +starting at @racket[1]. Uses of @racket[grid] can be translated into uses of @racket[coord], but the translation depends on the alignment. For example, -@racket[(grid 2 2 0 0 'lt)] is equivalent to @racket[(coord 0 0 'lt)], -but @racket[(grid 2 2 0 0 'rt)] is equivalent to @racket[(coord 1/2 0 'rt)]. +@racket[(grid 2 2 1 1 'lt)] is equivalent to @racket[(coord 0 0 'lt)], +but @racket[(grid 2 2 1 1 'rt)] is equivalent to @racket[(coord 1/2 0 'rt)]. @examples[#:eval the-eval (define none-for-me-thanks (ppict-do base - #:go (grid 2 2 0 0 'lt) + #:go (grid 2 2 1 1 'lt) (text "You do not like") (colorize (text "green eggs and ham?") "darkgreen"))) none-for-me-thanks (ppict-do none-for-me-thanks - #:go (grid 2 2 1 0 'rb) + #:go (grid 2 2 2 1 'rb) (colorize (text "I do not like them,") "red") (text "Sam-I-am.")) ] } +@defproc[(cascade [step-x (or/c real? 'auto) 'auto] + [step-y (or/c real? 'auto) 'auto]) + placer?]{ + +Returns a placer that places picts by evenly spreading them diagonally +across the base pict in ``cascade'' style. This placer does not +support changing the spacing by including a real number within the +pict sequence. + +When a list picts is to be placed, their bounding boxes are normalized +to the maximum width and height of all picts in the list; each pict is +centered in its new bounding box. The picts are then cascaded so there +is @racket[step-x] space between each of the picts' left edges; there +is also @racket[step-x] space between the base pict's left edge and +the first pict's left edge. Similarly for @racket[step-y] and the +vertical spacing. + +If @racket[step-x] or @racket[step-y] is @racket['auto], the spacing +between the centers of the picts to be placed is determined +automatically so that the inter-pict spacing is the same as the +spacing between the last pict and the base. + +@examples[#:eval the-eval +(ppict-do base + #:go (cascade) + (colorize (filled-rectangle 100 100) "red") + (colorize (filled-rectangle 100 100) "blue")) +(ppict-do base + #:go (cascade 40 20) + (colorize (filled-rectangle 100 100) "red") + (colorize (filled-rectangle 100 100) "blue")) +] +} + @section[#:tag "pslide"]{Progressive Slides}