diff --git a/collects/unstable/gui/ppict.rkt b/collects/unstable/gui/ppict.rkt index 8b05ab8649..1d8da4cf67 100644 --- a/collects/unstable/gui/ppict.rkt +++ b/collects/unstable/gui/ppict.rkt @@ -64,6 +64,9 @@ (->* () ((or/c real? 'auto) (or/c real? 'auto)) placer?)] + [tile + (-> exact-positive-integer? exact-positive-integer? + placer?)] [at-find-pict (->* ((or/c tag-path? pict-path?)) (procedure? diff --git a/collects/unstable/gui/private/ppict.rkt b/collects/unstable/gui/private/ppict.rkt index 1b7248f784..89b65d6409 100644 --- a/collects/unstable/gui/private/ppict.rkt +++ b/collects/unstable/gui/private/ppict.rkt @@ -9,6 +9,9 @@ #| TODO - [lcr]bl alignments... not sure about [lcr]tl +- document composer contract +- generalize ppict-add to ppict-add* (put 'next support there) +- find a way to support slide animation |# ;; ============================================================ @@ -79,24 +82,20 @@ In a placer function's arguments: (+ depy ya)))) (define-values (newpict newsep) (apply-compose compose sep (cons (and cont? (blank 0)) picts))) - (define newpict-w (pict-width newpict)) - (define newpict-h (pict-height newpict)) (define newscene - (let ([localrefx (* newpict-w (align->frac halign))] - [localrefy (* newpict-h (align->frac valign))]) - (pin-over scene (- dx localrefx) (- dy localrefy) newpict))) + (pin-over/align scene dx dy halign valign newpict)) (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 newscene (new refpoint% - (xa dx) (ya (+ dy newpict-h)) (depxy #f) + (xa dx) (ya (+ dy (pict-height newpict))) (depxy #f) (halign halign) (valign valign) (compose compose) (sep newsep) (cont? #t)))] [(and (eq? halign 'l) (eq? compose (valign->hcompose valign))) ;; ie, going left-right and compose is the natural compose ... (mk-ppict newscene (new refpoint% - (xa (+ dx newpict-w)) (ya dy) (depxy #f) + (xa (+ dx (pict-width newpict))) (ya dy) (depxy #f) (halign halign) (valign valign) (compose compose) (sep newsep) (cont? #t)))] [else newscene])) @@ -155,9 +154,8 @@ In a placer function's arguments: (super-new) (define/public (place scene elems) - (for/or ([e (in-list elems)]) - (when (real? e) - (error 'cascade "spacing changes not allowed: ~e" e))) + (for ([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 @@ -181,6 +179,39 @@ In a placer function's arguments: ;; FIXME: add align arg, determines position of each pict w/in bbox (new cascade% (step-x0 step-x0) (step-y0 step-y0))) +(define tile% + (class* object% (placer<%>) + (init-field cols rows + [start-at 0]) + (super-new) + + (define/public (place scene elems) + (for ([e (in-list elems)]) + (when (real? e) (error 'tile "spacing changes not allowed: ~e" e))) + (let* ([picts (filter pict? elems)] + [scene-w (pict-width scene)] + [scene-h (pict-height scene)] + [dx (/ scene-w cols)] + [dy (/ scene-h rows)] + [newscene + (for/fold ([scene scene]) + ([pict (in-list picts)] + [i (in-naturals start-at)]) + (let ([r (quotient i cols)] + [c (remainder i cols)]) + (pin-over/align scene + (+ (/ dx 2) (* c dx)) + (+ (/ dy 2) (* r dy)) + 'c 'c pict)))]) + (mk-ppict newscene + (new tile% + (cols cols) + (rows rows) + (start-at (+ start-at (length picts))))))))) + +(define (tile cols rows) + (new tile% (cols cols) (rows rows))) + ;; at-find-pict : ... -> placer (define (at-find-pict path [find cc-find] @@ -199,6 +230,11 @@ In a placer function's arguments: (find p pict-path)))) (halign halign) (valign valign) (compose compose))) +(define (pin-over/align scene x y halign valign pict) + (let ([localrefx (* (pict-width pict) (align->frac halign))] + [localrefy (* (pict-height pict) (align->frac valign))]) + (pin-over scene (- x localrefx) (- y localrefy) pict))) + ;; ---- ;; apply-compose : compose real (listof (U #f pict real)) -> (values pict real) diff --git a/collects/unstable/scribblings/gui/pslide.scrbl b/collects/unstable/scribblings/gui/pslide.scrbl index 2fade893ba..acf46baf09 100644 --- a/collects/unstable/scribblings/gui/pslide.scrbl +++ b/collects/unstable/scribblings/gui/pslide.scrbl @@ -288,6 +288,23 @@ spacing between the last pict and the base. ] } +@defproc[(tile [cols exact-positive-integer?] + [rows exact-positive-integer?]) + placer?]{ + +Returns a placer that places picts by tiling them in a grid +@racket[cols] columns wide and @racket[rows] rows high. + +@examples[#:eval the-eval +(ppict-do base + #:go (tile 2 2) + (circle 50) + (rectangle 50 50) + (jack-o-lantern 50) + (standard-fish 50 30 #:color "red")) +] +} + @defproc[(at-find-pict [find-path (or/c tag-path? pict-path?)] [finder procedure? cc-find] [align (or/c 'lt 'ct 'rt 'lc 'cc 'rc 'lb 'cb 'rb) 'cc]