unstable/gui/ppict: added cascade placer

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?)])

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 xfrac (/ (+ (sub1 col) (align->frac halign)) cols))
-  (define refyfrac (/ (+ row (align->frac valign)) rows))
+  (define yfrac (/ (+ (sub1 row) (align->frac valign)) rows))
-  (coord refxfrac refyfrac align #:compose composer #:sep sep))
+  (refpoint* xfrac yfrac abs-x abs-y halign valign compose sep))
 
-(define (coord refxfrac refyfrac [align 'cc]
+(define (coord xfrac yfrac [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]
                #: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 dx (+ (* scene-w xfrac) dxabs))
-     (define refy (* scene-h refyfrac))
+     (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)))
+       (cond [(and (eq? valign 't) (eq? compose (halign->vcompose halign)))
-              ;; ie, going top-down and composer is the natural composer for this align
+              ;; ie, going top-down and compose is the natural compose for this align
               (mk-ppict result-pict
-                        (coord refxfrac refyfrac align
+                        (refpoint* 0 0 dx (+ dy newpict-h) halign valign compose newsep))]
-                               #:compose composer
+             [(and (eq? halign 'l) (eq? compose (valign->hcompose valign)))
-                               #:sep newsep
+              ;; ie, going left-right and compose is the natural compose ...
-                               #:internal:skip (blank 0 newpict-h)))]
-             [(and (eq? halign 'l) (eq? composer (align->hcomposer align)))
               (mk-ppict result-pict
-                        (coord refxfrac refyfrac align
+                        (refpoint* 0 0 (+ dx newpict-w) dy halign valign compose newsep))]
-                               #:compose composer
-                               #:sep newsep
-                               #:internal:skip (blank newpict-w 0)))]
              [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)
+(define (halign->vcompose halign)
-  (case align
+  (case halign
-    ((lt lc lb) vl-append)
+    ((l) vl-append)
-    ((ct cc cb) vc-append)
+    ((c) vc-append)
-    ((rt rc rb) vr-append)))
+    ((r) vr-append)))
 
-(define (align->hcomposer align)
+(define (valign->hcompose align)
   (case align
-    ((lt ct rt) ht-append)
+    ((t) ht-append)
-    ((lc cc rc) hc-append)
+    ((c) hc-append)
-    ((lb cb rb) hb-append)))
+    ((b) hb-append)))
 
 ;; ----
 

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)],
+@racket[(grid 2 2 1 1 '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)].
+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}