home *** CD-ROM | disk | FTP | other *** search
/ OS/2 Shareware BBS: 10 Tools / 10-Tools.zip / mitsch75.zip / scheme-7_5_17-src.zip / scheme-7.5.17 / src / swat / scheme / geometry.scm < prev    next >
Text File  |  1995-08-02  |  30KB  |  935 lines
  1. ;;;;; -*- Scheme -*-
  2. ;;;;;
  3. ;;;;; $Id: geometry.scm,v 1.1 1995/08/02 21:26:49 adams Exp $
  4. ;;;;; derived from geometry.sc,v 1.1 1993/02/16 14:04:09 jmiller Exp $
  5.  
  6. ;; The box makers - one for horizontal, one for vertical
  7.  
  8. (define (make-hbox . kids)
  9.   (make-box h-size h-arrange h-get-hglue h-get-vglue kids))
  10.  
  11. (define (make-vbox  . kids)
  12.   (make-box v-size v-arrange v-get-hglue v-get-vglue kids))
  13.  
  14. ;; user-level accessor
  15. (define (box-children box)
  16.   (cond ((box%? box)
  17.      (box%.kids box))
  18.     ((arraybox%? box)
  19.      (arraybox%.kids-lists box))
  20.     (else (error "not a box -- BOX-CHILDREN" box))))
  21.  
  22. ;; Vertical sizer
  23.  
  24. (define (v-size kids)
  25.   (make-size
  26.    (apply max (cons 0
  27.             (map (lambda (kid)
  28.                (Size.Width (get-desired-size kid)))
  29.              kids)))
  30.    (apply + (map (lambda (kid)
  31.            (Size.Height (get-desired-size kid)))
  32.          kids))))
  33.  
  34. ;; Horizontal sizer
  35.  
  36. (define (h-size kids)
  37.   (make-size
  38.    (apply + (map (lambda (kid)
  39.              (Size.Width (get-desired-size kid)))
  40.          kids))
  41.    (apply max (cons 0
  42.             (map (lambda (kid)
  43.                (Size.Height (get-desired-size kid)))
  44.              kids)))))
  45.  
  46. ;; Vertical arranger
  47.  
  48. (define (v-arrange kids my-screen-area)
  49.   (let* ((my-height (UITKRectangle.Height my-screen-area))
  50.      (full-width (UITKRectangle.Width my-screen-area))
  51.      (my-offset (UITKRectangle.Offset my-screen-area))
  52.      (Y (point.Y my-offset))
  53.      (vglues (map %vglue kids)))
  54.     (conquer-space
  55.      my-height
  56.      vglues
  57.      (lambda (positions-vector)
  58.        (let loop ((n 0) (rest kids))
  59.      (if (null? rest)
  60.          #F
  61.          (let* ((kid (car rest))
  62.             (kid-y-offset (vector-ref positions-vector n))
  63.             (height (- (vector-ref positions-vector (+ n 1)) 
  64.                    kid-y-offset))
  65.             (desired-size (get-desired-size kid))
  66.             (desired-width (Size.Width Desired-Size))
  67.             (hglue (%hglue kid))
  68.             (width (cond ((or (fil-glue? hglue)
  69.                       (fill-glue? hglue))
  70.                   full-width)
  71.                  ((rigid-glue? hglue) desired-width)
  72.                  ;;((percent-glue? hglue)
  73.                  ;;(max desired-width
  74.                  ;;(inexact->exact
  75.                  ;;(ceiling (* .01 (glue.value hglue) height)))))
  76.                  (else (error "Unknown glue class"
  77.                           (glue.class hglue)))))
  78.             (X (+ (Point.X my-offset)
  79.               (ceiling
  80.                (/ (- (UITKRectangle.Width my-screen-area) width)
  81.                   2)))))
  82.            (assign-screen-area!
  83.         kid
  84.         (make-UITKRectangle (make-point X (+ Y kid-y-offset))
  85.                     (make-size width height)))
  86.            (loop (+ n 1) (cdr rest)))))))))
  87.  
  88.  
  89. ;; Horizontal arranger
  90.  
  91. (define (h-arrange kids my-screen-area)
  92.   (let* ((my-width (UITKRectangle.Width my-screen-area))
  93.      (full-height (UITKRectangle.Height my-screen-area))
  94.      (my-offset (UITKRectangle.Offset my-screen-area))
  95.      (X (point.X my-offset))
  96.      (hglues (map %hglue kids)))
  97.     (conquer-space
  98.      my-width
  99.      hglues
  100.      (lambda (positions-vector)
  101.        (let loop ((n 0) (rest kids))
  102.      (if (null? rest)
  103.          #F
  104.          (let* ((kid (car rest))
  105.             (kid-x-offset (vector-ref positions-vector n))
  106.             (width (- (vector-ref positions-vector (+ n 1)) 
  107.                   kid-x-offset))
  108.             (desired-size (get-desired-size kid))
  109.             (desired-height (Size.Height Desired-Size))
  110.             (vglue (%vglue kid))
  111.             (height (cond ((or (fil-glue? vglue)
  112.                        (fill-glue? vglue))
  113.                    full-height)
  114.                   ((rigid-glue? vglue) desired-height)
  115.                   ;;((percent-glue? vglue)
  116.                   ;;(max desired-height 
  117.                   ;;(inexact->exact
  118.                   ;;(ceiling (* .01 (glue.value vglue) width)))))
  119.                   (else (error "Unknown glue class"
  120.                            (glue.class vglue)))))
  121.             (Y (+ (Point.Y my-offset)
  122.               (ceiling
  123.                (/ (- (UITKRectangle.Height my-screen-area) height)
  124.                   2)))))
  125.            (assign-screen-area!
  126.         kid
  127.         (make-UITKRectangle (make-point (+ X kid-x-offset) Y)
  128.                     (make-size width height)))
  129.            (loop (+ n 1) (cdr rest)))))))))
  130.  
  131.  
  132. ;;; Calculate hglue and vglue for hboxes...
  133.  
  134. (define (h-get-hglue kids)
  135.   (series-compose-glues (map %hglue kids)))
  136.  
  137. (define (h-get-vglue kids)
  138.   (parallel-compose-glues (map %vglue kids)))
  139.  
  140. ;;; ... and vboxes.
  141.  
  142. (define (v-get-hglue kids)
  143.   (parallel-compose-glues (map %hglue kids)))
  144.  
  145. (define (v-get-vglue kids)
  146.   (series-compose-glues (map %vglue kids)))
  147.  
  148.  
  149. ;; Generic arranger
  150.  
  151. (define (retract-area objects)
  152.   (for-each (lambda (obj) (assign-screen-area! obj #F))
  153.         objects))
  154.  
  155. (define (box-add-child! me kid)
  156.   (if (not (valid-child? kid))
  157.       (error "BOX-ADD-CHILD!: Bad UIObj" kid))
  158.   (one-parent-only! kid me)
  159.   (set-Box%.kids! me (append (Box%.kids me) (list kid)))
  160.   (on-geometry-change!
  161.    kid 'BOX
  162.    (lambda (old-screen-area new-screen-area)
  163.      old-screen-area            ; Not used
  164.      (if (eq? new-screen-area #T)    ; Instigated by child, not manager
  165.      (box:rearrange me))))
  166.   (on-death! kid 'BOX (lambda () (box-remove-child! me kid)))
  167.   (assign-drawing-surface! kid (drawing-surface me))
  168.   (box:rearrange me))
  169.  
  170. (define (box-remove-child! me kid)
  171.   (if (not (valid-child? kid))
  172.       (error "BOX-REMOVE-CHILD!: Bad UIObj" kid))
  173.   (set-Box%.kids! me (delq! kid (Box%.kids me)))
  174.   (forget! kid 'BOX)
  175.   (assign-drawing-surface! kid 'RETRACTED)
  176.   (box:rearrange me))
  177.  
  178. (define (box-assign-drawing-surface! me surface)
  179.   (check-drawing-surface! me surface)
  180.   (for-each (lambda (kid)
  181.           (if (eq? surface 'RETRACTED)
  182.           (forget! kid 'BOX))
  183.           (assign-drawing-surface! kid surface))
  184.         (Box%.kids me))
  185.   (if (DrawingSurface? surface)
  186.       (set-%desired-size! me ((Box%.sizer me) (Box%.kids me))))
  187.   (if (eq? Surface 'RETRACTED)
  188.       (death! me)
  189.       (geometry-change! me #F #F))
  190.   'OK)
  191.  
  192. (define (box-assign-screen-area! me screen-area)
  193.   (cond ((vector? screen-area)
  194.      (set-assigned-screen-area! me screen-area)
  195.      (let ((old (used-screen-area me)))
  196.        (if (not (screen-area= old screen-area))
  197.            (begin
  198.          (set-used-screen-area! me screen-area)
  199.          (box:rearrange me)
  200.          (geometry-change! me old screen-area))))
  201.      screen-area)
  202.     ((not screen-area)
  203.      (set-assigned-screen-area! me screen-area)
  204.      (let ((old (used-screen-area me)))
  205.        (if (not (screen-area= old screen-area))
  206.            (begin
  207.          (set-used-screen-area! me screen-area)
  208.          (retract-area (Box%.kids me))
  209.          (geometry-change! me old screen-area))))
  210.      screen-area)
  211.     (else
  212.      (error "BOX-ASSIGN-SCREEN-AREA!: Bad screen-area" screen-area))))
  213.  
  214. (define (box-assign-glue! me)
  215.   (let ((kids (Box%.kids me)))
  216.     (for-each assign-glue! kids)
  217.     (set-%hglue! me ((Box%.get-hglue me) kids)) 
  218.     (set-%vglue! me ((Box%.get-vglue me) kids))))
  219.  
  220. ;; Box Maker
  221. (define (box-maker size-proc screen-area-proc get-hglue get-vglue)
  222.   (make-Box%
  223.    (make-UIObjInternals box-add-child!
  224.             'invalid
  225.             UIObj-set-context!
  226.             box-assign-screen-area!
  227.             box-assign-drawing-surface!
  228.             UIObj-point-within?
  229.             UIObj-rectangle-overlaps?
  230.             UIObj-handle-event
  231.             UIObj-get-desired-size
  232.             UIObj-assigned-screen-area
  233.             UIObj-used-screen-area
  234.             UIObj-set-assigned-screen-area!
  235.             UIObj-set-used-screen-area!
  236.             box-assign-glue!)
  237.    size-proc
  238.    screen-area-proc
  239.    get-hglue
  240.    get-vglue))
  241.  
  242. (define (box:rearrange me)
  243.   (let ((screen-area (used-screen-area me))
  244.     (arrange (Box%.arranger me))
  245.     (size (Box%.sizer me))
  246.     (kids (Box%.kids me)))
  247.     (if screen-area
  248.     (let ((new-size (size kids)))
  249.       (set-%desired-size! me new-size)
  250.       (if (size= new-size (UITKRectangle.Size screen-area))
  251.           (begin (assign-glue! me)
  252.              (arrange kids screen-area))
  253.           (begin
  254.         (set-%desired-size! me new-size)
  255.         (geometry-change! me screen-area #T)
  256.         (if (eq? screen-area (used-screen-area me))
  257.             (begin (assign-glue! me)
  258.                (arrange kids screen-area)))))))))
  259.             
  260. (define (box:event-propagator box)
  261.   (lambda (event)
  262.     (for-each (lambda (kid)
  263.         (if (event-within? kid event)
  264.             (handle-event kid event)))
  265.           (Box%.kids box))))
  266.   
  267.  
  268. (define (make-box size-proc screen-area-proc get-hglue get-vglue children)
  269.   (let ((me (box-maker size-proc screen-area-proc get-hglue get-vglue)))
  270.     (on-event! me 'BOX
  271.            (box:event-propagator me))
  272.     (for-each (lambda (kid) (add-child! me kid)) children)
  273.     me))
  274.  
  275. ;;; Glue Mechanism snarfed from Halstead
  276.  
  277. ;;; Glue abstraction, captures a minimum size (horizontal or vertical,
  278. ;;; depending on usage) below which the object really ought not to shrink.
  279. ;;; Also specifies a stretchability value (glue-value) and a stretchability
  280. ;;; class (glue-class).  Space is divided between two series-composed
  281. ;;; glues as follows:
  282. ;;;
  283. ;;; 1. If the total is less than the sum of the glues' minimum sizes
  284. ;;;    then divide the space in proportion to the minimum sizes (everybody
  285. ;;;    has to give up the same percentage of their minimum size).
  286. ;;;
  287. ;;; 2. Else, if both glues have the same glue-class, then divide the excess
  288. ;;;    of available space (over the sum of their minimum sizes)
  289. ;;;    in proportion to their glue-values.
  290. ;;;
  291. ;;; 3. If the glue-classes differ, then the glue with the smaller glue-class
  292. ;;;    gets its minimum size, and the glue with the larger glue-class gets
  293. ;;;    all the rest (thus glue of a given glue-class is "infinitely" more
  294. ;;;    stretchable than any glue from a lower glue-class -- this is useful
  295. ;;;    for filling out to a boundary without stretching the item before the
  296. ;;;    fill).
  297.  
  298. ;;; Conventional glue classes:
  299.  
  300. (define *rigid-glue-class* -1)    ; for things that really don't want to stretch
  301. (define *percent-glue-class* 0)    ; for proportionally allocating space
  302. (define *fill-glue-class* 1)    ; for things intended to be infinitely stretchable
  303. (define *fil-glue-class* 2)    ; even stretchier!
  304.  
  305. (define (make-rigid-glue minsize value)
  306.   (make-glue minsize *rigid-glue-class* value))
  307.  
  308. (define (make-percent-glue minsize percent)
  309.   (make-glue minsize *percent-glue-class* percent))
  310.  
  311. (define (make-fill-glue minsize value)
  312.   (make-glue minsize *fill-glue-class* value))
  313.  
  314. (define (make-fil-glue minsize value)
  315.   (make-glue minsize *fil-glue-class* value))
  316.  
  317. (define (rigid-glue? glue)
  318.   (= (glue.class glue) *rigid-glue-class*))
  319.  
  320. (define (percent-glue? glue)
  321.   (= (glue.class glue) *percent-glue-class*))
  322.  
  323. (define (fill-glue? glue)
  324.   (= (glue.class glue) *fill-glue-class*))
  325.  
  326. (define (fil-glue? glue)
  327.   (= (glue.class glue) *fil-glue-class*))
  328.  
  329. (define *fil-glue* (make-fil-glue 0 1))
  330. (define *rigid-glue* (make-rigid-glue 0 1))
  331.    
  332.  
  333. ;;; Compose two glues laid end-to-end -- sum their minimum sizes
  334. ;;;   and their glue values (which implies that if the glue-classes
  335. ;;;   differ, then the resulting glue-class and glue-value are those
  336. ;;;   of the input glue with the larger glue-class).
  337.  
  338. (define (series-compose-glue g1 g2)
  339.   (let ((c1 (glue.class g1))
  340.      (c2 (glue.class g2)))
  341.     (if (< c2 c1)
  342.      (series-compose-glue g2 g1)
  343.     (make-glue (+ (glue.minsize g1) (glue.minsize g2))
  344.            c2
  345.            (if (= c1 c2)
  346.                (+ (glue.value g1) (glue.value g2))
  347.                (glue.value g2))))))
  348.  
  349. ;;; Compose two glues laid in parallel -- use the max of their
  350. ;;;   minimum sizes and the min of their stretchabilities (which
  351. ;;;   implies using the stretchability of the glue with the smaller
  352. ;;;   glue-class, or the smaller glue-value if the glue-classes are
  353. ;;;   equal).
  354.  
  355. (define (parallel-compose-glue g1 g2)
  356.   (let ((c1 (glue.class g1))
  357.     (c2 (glue.class g2)))
  358.     (if (< c2 c1)
  359.      (parallel-compose-glue g2 g1)
  360.     (make-glue (max (glue.minsize g1) (glue.minsize g2))
  361.            c1
  362.            (if (= c1 c2)
  363.                (min (glue.value g1) (glue.value g2))
  364.                (glue.value g1))))))
  365.  
  366. ;;; Support > 2 glues as arguments
  367.  
  368. (define (compose-glues fcn list-of-glues)
  369.   ;; If there's no glue at all, make it be fil glue.
  370.   (if (null? list-of-glues)
  371.       *fil-glue*
  372.       (let loop ((cumulative-glue (car list-of-glues))
  373.          (rest (cdr list-of-glues)))
  374.     (if (null? rest)
  375.         cumulative-glue
  376.         (let ((next-glue (car rest)))
  377.           (loop (fcn cumulative-glue next-glue)
  378.             (cdr rest)))))))
  379.  
  380. (define (series-compose-glues list-of-glues)
  381.   (compose-glues series-compose-glue list-of-glues))
  382.  
  383. (define (parallel-compose-glues list-of-glues)
  384.   (compose-glues parallel-compose-glue list-of-glues))
  385.  
  386.  
  387. ;;; Choose the less restrictive (in terms of minimum size) of two
  388. ;;;   glues.  This procedure is used for implementing the "orbox" combiner:
  389.  
  390. (define (choose-minimum-glue list-of-glues)
  391.   (define (min-glue g1 g2)
  392.     (let ((min1 (glue.minsize g1))
  393.       (min2 (glue.minsize g2)))
  394.       (cond ((< min1 min2) g1)
  395.         ((> min1 min2) g2)
  396.         (else g1))))    ; arbitrary choice
  397.   (let ((g1 (car list-of-glues)))
  398.     (let loop ((list-of-glues list-of-glues) (g g1))
  399.       (if (null? (cdr list-of-glues))
  400.       (min-glue g (car list-of-glues))
  401.       (let* ((next-glue (car list-of-glues)))
  402.         (loop (cdr list-of-glues) (min-glue g next-glue)))))))
  403.  
  404. (define (choose-maximum-glue list-of-glues)
  405.   (define (max-glue g1 g2)
  406.     (let ((max1 (glue.minsize g1))
  407.       (max2 (glue.minsize g2)))
  408.       (cond ((< max1 max2) g2)
  409.         ((> max1 max2) g1)
  410.         (else g1))))    ; arbitrary choice
  411.   (let ((g1 (car list-of-glues)))
  412.     (let loop ((list-of-glues list-of-glues) (g g1))
  413.       (if (null? list-of-glues)
  414.       g
  415.       (let* ((next-glue (car list-of-glues)))
  416.         (loop (cdr list-of-glues) (max-glue g next-glue)))))))
  417.  
  418. #|
  419. ;;; Magnify the minsize and stretchability of a glue by a factor:
  420.  
  421. (define (magnify-glue g factor)
  422.   (make-glue (* factor (glue.minsize g))
  423.          (glue.class g)
  424.          (* factor (glue.value g))))
  425.  
  426. ;;; Decide whether the given glue fits happily into the given space:
  427.  
  428. (define (glue-fits-space? g space)
  429.   (<= (glue.minsize g) space))
  430. |#
  431.  
  432. ;;; Divide a given amount of space between two glues, according to the
  433. ;;;   rules given above.  Returns the amounts of space allocated to the
  434. ;;;   two glues to the continuation k.
  435.  
  436. (define (divide-space space g1 g2 k)
  437.   (let ((m1 (glue.minsize g1))
  438.     (m2 (glue.minsize g2)))
  439.     (let ((msum (+ m1 m2)))
  440.       (if (and (<= space msum) (> msum 0))
  441.       (let ((x1 (inexact->exact
  442.              (floor
  443.               (quotient (+ (* 2 m1 space) msum)
  444.                 (* 2 msum)))))) ; round off space allocation
  445.         (k x1 (- space x1)))
  446.       (let ((c1 (glue.class g1))
  447.          (c2 (glue.class g2)))
  448.         (cond ((< c1 c2) (k m1 (- space m1)))
  449.           ((> c1 c2) (k (- space m2) m2))
  450.           (else (let ((v1 (glue.value g1))
  451.                   (v2 (glue.value g2)))
  452.               (let ((vsum (+ v1 v2)))
  453.                 (let ((x1 (+ m1
  454.                      (inexact->exact
  455.                       (floor
  456.                        (quotient
  457.                         (+ (* 2 v1 (- space msum))
  458.                            vsum)
  459.                         (* 2 vsum)))))))
  460.                   (k x1 (- space x1))))))))))))
  461.  
  462.  
  463. ;;; Given a space (width or height), a list of glues (assuming the
  464. ;;; order of glues provided is left to right), and a receiver, divides
  465. ;;; the space between the glues according to their properties.
  466. ;;; Receiver is applied to the resulting vector of positions which are
  467. ;;; offsets into the space. 
  468.  
  469. (define (conquer-space space list-of-glues receiver)
  470.   (let* ((num-glues (length list-of-glues))
  471.      (glues (list->vector list-of-glues))
  472.      (cum-glues (compute-cumulative-glues list-of-glues))
  473.      (positions-vector (make-vector (+ num-glues 1))))
  474.     (let loop ((s space) (n (- num-glues 1)))
  475.       (vector-set! positions-vector (+ n 1) s)
  476.       (if (> n 0)
  477.       (divide-space
  478.        s (vector-ref cum-glues (- n 1)) (vector-ref glues n)
  479.        (lambda (s1 s2)
  480.          s2                ; ignore
  481.          (loop s1 (- n 1))))))
  482.     (vector-set! positions-vector 0 0)
  483.     (receiver positions-vector)))
  484.      
  485.  
  486. ;;; Given a list of glues, returns a vector of cumulative glues --
  487. ;;; glues obtained by series composition of g1, g1&g2, (g1&g2)&g3, and
  488. ;;; so on.  For example,
  489. ;;;
  490. ;;;  (compute-cumulative-glues (list g1 g2 g3)) is equivalent to:
  491. ;;; 
  492. ;;;      (let* ((g12 (series-compose-glue g1 g2))
  493. ;;;             (g123 (series-compose-glue g12 g3)))     
  494. ;;;        `#(,g1 ,g12 ,g123))
  495.  
  496. (define (compute-cumulative-glues list-of-glues)
  497.   ;; If there's no glue at all, make it be fil glue.
  498.   (if (null? list-of-glues)
  499.       *fil-glue*
  500.       (let* ((num-glues (length list-of-glues))
  501.          (cum-glues (make-vector num-glues))
  502.          (g1 (car list-of-glues)))
  503.     (vector-set! cum-glues 0 g1)
  504.     (let loop ((n 1) (old-glue g1) (glues (cdr list-of-glues)))
  505.       (if (= n num-glues)
  506.           cum-glues
  507.           (let* ((g (car glues))
  508.              (new-glue (series-compose-glue old-glue g)))
  509.         (vector-set! cum-glues n new-glue)
  510.         (loop (+ n 1) new-glue (cdr glues))))))))
  511.  
  512.  
  513. ;;; A space is basically a "piece of glue." It is of class fil, so it
  514. ;;; is very stretchable (more so than anything else). It can be used
  515. ;;; to fill in spaces between widgets in a box.
  516. ;;; This would probably be better off if implemented as a shape
  517. ;;; instead of a canvas, but for now (till shapes are working
  518. ;;; right)... 
  519.  
  520. (define (make-space . options)
  521.   (let* ((configure-options (if options (car options) '()))
  522.      (space (make-canvas `(-width 0 -height 0 ,@configure-options))))
  523.     (set-%hglue! space *fil-glue*)
  524.     (set-%vglue! space *fil-glue*)
  525.     space))
  526.  
  527.  
  528.  
  529. ;;; Build a tabular array of boxes.  Each argument is a list of kids that
  530. ;;;   are to be arranged left-to-right, in hbox fashion.  These rows of boxes
  531. ;;;   are in turn stacked vertically, in vbox fashion; however, the sizes of
  532. ;;;   the boxes in different rows interact so that columns, as well as rows,
  533. ;;;   of boxes are kept aligned.  Thus (array-box '(A B C) '(D E F) '(G H J))
  534. ;;;   will generate the following arrangement of kids A-J:
  535. ;;;
  536. ;;;        A   B   C
  537. ;;;
  538. ;;;        D   E   F
  539. ;;;
  540. ;;;        G   H   J
  541. ;;;
  542. ;;;   regardless of the individual sizes of the component boxes.  Instead of
  543. ;;;   boxes, the following symbols may also appear as elements of an argument:
  544. ;;;
  545. ;;;      skip -- indicates the corresponding cell is to be left empty.
  546. ;;;      left -- indicates the box to the left spans into this cell as well.
  547. ;;;      up -- indicates the box above spans into this cell as well.
  548. ;;;
  549. ;;;   If the argument lists are not all of the same length, they are considered
  550. ;;;   to be padded out at the end with as many occurrences of the symbol "left"
  551. ;;;   as needed to make their lengths all equal.
  552.  
  553. (define (kids-lists->complete-kids-lists kids-lists)
  554.   (let ((num-cols (apply max (map length kids-lists))))
  555.     (define (kids-list->complete-kids-list kids-list)
  556.       (let loop ((col 0) (complete-kids-list '()) (rest-kids kids-list))
  557.     (if (= col num-cols)
  558.         complete-kids-list
  559.         (let* ((next-kid
  560.             (if (null? rest-kids)
  561.             'left
  562.             (car rest-kids)))
  563.            (rest-kids
  564.             (if (null? rest-kids)
  565.             '()
  566.             (cdr rest-kids)))
  567.            (next-complete-list
  568.             (append complete-kids-list (list next-kid))))
  569.           (loop (+ col 1) next-complete-list rest-kids)))))
  570.     
  571.     (let loop ((complete-kids-lists '()) (rest-kids-lists kids-lists))
  572.       (if (null? rest-kids-lists)
  573.       complete-kids-lists
  574.       (let ((next-list (car rest-kids-lists)))
  575.         (loop (append complete-kids-lists
  576.               (list (kids-list->complete-kids-list next-list)))
  577.           (cdr rest-kids-lists)))))))
  578.  
  579.  
  580. (define (row-lists->col-lists kids-lists)
  581.   (let ((kids-lists (kids-lists->complete-kids-lists kids-lists)))
  582.     (let loop ((col 0) (col-lists '()))
  583.       (if (= col (apply max (map length kids-lists)))
  584.       col-lists
  585.       (let ((col-list
  586.          (let loop ((row 0) (col-list '()))
  587.            (if (= row (length kids-lists))
  588.                col-list
  589.                (loop (+ row 1)
  590.                  (cons (list-ref (list-ref kids-lists row) col)
  591.                    col-list))))))
  592.         (loop (+ col 1) (cons col-list col-lists)))))))
  593.  
  594. (define (array-size kids-lists)
  595.   (let ((col-lists (row-lists->col-lists kids-lists)))
  596.     (make-size
  597.      (apply +
  598.         (map (lambda (col-list)
  599.            (apply max
  600.               (map (lambda (kid)
  601.                  (if (symbol? kid)
  602.                      0
  603.                      (size.width (get-desired-size kid))))
  604.                    col-list)))
  605.          col-lists))
  606.      (apply +
  607.         (map (lambda (row-list)
  608.            (apply max
  609.               (map (lambda (kid)
  610.                  (if (symbol? kid)
  611.                      0
  612.                      (size.height (get-desired-size kid))))
  613.                    row-list)))
  614.          kids-lists)))))
  615.  
  616. (define (array-arrange kids-lists my-screen-area)
  617.   (let* ((my-width (UITKRectangle.Width my-screen-area))
  618.      (my-height (UITKRectangle.Height my-screen-area))
  619.      (my-offset (UITKRectangle.Offset my-screen-area))
  620.      (X (point.X my-offset))
  621.      (Y (point.Y my-offset))
  622.      (kids-lists (kids-lists->complete-kids-lists kids-lists))
  623.      )
  624.  
  625.     (define (kids-lists->kids-array kids-lists)
  626.       (let loop ((kids-lists kids-lists) (kids-array-list '()))
  627.     (if (null? kids-lists)
  628.         (list->vector kids-array-list)
  629.         (loop (cdr kids-lists)
  630.           (append kids-array-list
  631.               (list (list->vector (car kids-lists))))))))
  632.  
  633.     (let* ((kids-array (kids-lists->kids-array kids-lists))
  634.        (num-rows (vector-length kids-array))
  635.        (num-cols (vector-length (vector-ref kids-array 0))))
  636.  
  637.       (define (aref array row col)
  638.     (vector-ref (vector-ref array row) col))
  639.  
  640.       (define (aset! array row col value)
  641.     (vector-set! (vector-ref array row) col value))
  642.  
  643.       (define (kids-column-hglue col)
  644.     (define (get-hglue kid)
  645.       (if (symbol? kid)
  646.           *fil-glue*
  647.           (%hglue kid)))
  648.     (let* ((kid1 (aref kids-array 0 col))
  649.            (g1 (get-hglue kid1)))
  650.       (let loop ((row 1) (g g1))
  651.         (if (< row num-rows)
  652.         (let* ((next-kid (aref kids-array row col))
  653.                (next-glue (get-hglue next-kid)))
  654.           (loop (+ row 1) (parallel-compose-glue g next-glue)))
  655.         g))))
  656.  
  657.       (define (kids-row-vglue row)
  658.     (define (get-vglue kid)
  659.       (if (symbol? kid)
  660.           *fil-glue*
  661.           (%vglue kid)))
  662.     (let* ((kid1 (aref kids-array row 0))
  663.            (g1 (get-vglue kid1)))
  664.       (let loop ((col 1) (g g1))
  665.         (if (< col num-cols)
  666.         (let* ((next-kid (aref kids-array row col))
  667.                (next-glue (get-vglue next-kid)))
  668.           (loop (+ col 1) (parallel-compose-glue g next-glue)))
  669.         g))))
  670.  
  671.       (define (enumerate-interval from to)
  672.     (if (> from to)
  673.         '()
  674.         (cons from (enumerate-interval (+ from 1) to))))
  675.  
  676.       (define (instantiate-kids h-positions-vector v-positions-vector)
  677.     (let loop-rows ((row 0))
  678.       (if (= row num-rows)
  679.           'done
  680.           (let loop-cols ((col 0))
  681.         (if (= col num-cols)
  682.             (loop-rows (+ row 1))
  683.             (let ((kid (aref kids-array row col)))
  684.               (if (symbol? kid)
  685.               (cond ((eq? kid 'skip)
  686.                  (loop-cols (+ col 1)))
  687.                 ((or (eq? kid 'left) (eq? kid 'up))
  688.                  ;; wasn't to the right or below a
  689.                  ;; valid child, so it's either been
  690.                  ;; taken care of already, or needs to
  691.                  ;; be 'skip.
  692.                  (aset! kids-array row col 'skip)
  693.                  (loop-cols (+ col 1)))
  694.                 (else
  695.                  (error
  696.                   "Illegal symbol in array box:"
  697.                   "Must be 'skip, 'left, or 'up." kid)))
  698.               (let* ((kid-x-offset
  699.                   (vector-ref h-positions-vector col))
  700.                  (kid-y-offset
  701.                   (vector-ref v-positions-vector row))
  702.                  (width (- (vector-ref h-positions-vector
  703.                                (+ col 1))
  704.                        kid-x-offset))
  705.                  (height (- (vector-ref v-positions-vector
  706.                             (+ row 1))
  707.                         kid-y-offset)))
  708.  
  709.                 (let expand-h-loop ((col+ 1) (wid width))
  710.                   (let ((new-col (+ col+ col)))
  711.                 (if (= new-col num-cols)
  712.                     (set! width wid)
  713.                     (let ((next-h-kid (aref kids-array row new-col)))
  714.                       (if (symbol? next-h-kid)
  715.                       (cond
  716.                        ((eq? next-h-kid 'left)
  717.                         (let* ((x-offset
  718.                             (vector-ref h-positions-vector
  719.                                 new-col))
  720.                            (new-wid
  721.                             (+ wid
  722.                                (- (vector-ref
  723.                                    h-positions-vector
  724.                                  (+ new-col 1))
  725.                               x-offset))))
  726.                           (aset! kids-array row new-col 'skip)
  727.                           (expand-h-loop (+ col+ 1) new-wid)))
  728.                        ((eq? next-h-kid 'skip)
  729.                         (set! width wid))
  730.                        ((eq? next-h-kid 'up)
  731.                         (set! width wid))
  732.                        (else
  733.                         (error "Illegal symbol in array box:"
  734.                            "Must be 'skip, 'left, or 'up."
  735.                            next-h-kid)))
  736.                       (set! width wid))))))
  737.               
  738.                 (let expand-v-loop ((row+ 1) (ht height))
  739.                   (let ((new-row (+ row+ row)))
  740.                 (if (= new-row num-rows)
  741.                     (set! height ht)
  742.                     (let ((next-v-kid (aref kids-array new-row col)))
  743.                       (if (symbol? next-v-kid)
  744.                       (cond
  745.                        ((eq? next-v-kid 'up)
  746.                         (let* ((y-offset
  747.                             (vector-ref v-positions-vector
  748.                                 new-row))
  749.                            (new-ht
  750.                             (+ ht (- (vector-ref
  751.                                       v-positions-vector
  752.                                 (+ new-row 1))
  753.                                  y-offset))))
  754.                           (aset! kids-array new-row col 'skip)
  755.                           (expand-v-loop (+ row+ 1) new-ht)))
  756.                        ((eq? next-v-kid 'skip)
  757.                         (set! height ht))
  758.                        ((eq? next-v-kid 'left)
  759.                         (set! height ht))
  760.                        (else
  761.                         (error "Illegal symbol in array box:"
  762.                            "Must be 'skip, 'left, or 'up."
  763.                            next-v-kid)))
  764.                       (set! height ht))))))
  765.               
  766.                 (assign-screen-area!
  767.                  kid
  768.                  (make-UITKRectangle (make-point (+ X kid-x-offset)
  769.                                  (+ Y kid-y-offset))
  770.                          (make-size width height)))
  771.                 (loop-cols (+ col 1))))))))))
  772.  
  773.       (let ((cols-hglues (map kids-column-hglue (enumerate-interval 0 (- num-cols 1))))
  774.         (rows-vglues (map kids-row-vglue (enumerate-interval 0 (- num-rows 1)))))
  775.     (conquer-space
  776.      my-width
  777.      cols-hglues
  778.      (lambda (h-positions-vector)
  779.        (conquer-space
  780.         my-height
  781.         rows-vglues
  782.         (lambda (v-positions-vector)
  783.           (instantiate-kids h-positions-vector v-positions-vector))))))
  784.       )))
  785.  
  786. (define (array-get-hglue kids-lists)
  787.   ;; or minimum?
  788.   (choose-maximum-glue
  789.    (map (lambda (kids-list)
  790.       (series-compose-glues
  791.        (map (lambda (kid)
  792.           (if (symbol? kid)
  793.               *rigid-glue*
  794.               (%hglue kid)))
  795.         kids-list)))
  796.     kids-lists)))
  797.  
  798. (define (array-get-vglue kids-lists)
  799.   (choose-maximum-glue
  800.    (map (lambda (kids-list)
  801.       (series-compose-glues
  802.        (map (lambda (kid)
  803.           (if (symbol? kid)
  804.               *rigid-glue*
  805.               (%vglue kid)))
  806.         kids-list)))
  807.     (row-lists->col-lists kids-lists))))
  808.  
  809.  
  810. (define (find-real-array-box-children kids-lists)
  811.   (let loop-lists ((kids-lists kids-lists)
  812.            (valid-kids-list '()))
  813.     (if (null? kids-lists)
  814.     valid-kids-list
  815.     (let loop-list ((kids-list (car kids-lists))
  816.             (valid-kids '()))
  817.       (if (null? kids-list)
  818.           (loop-lists (cdr kids-lists)
  819.               (append valid-kids-list valid-kids))
  820.           (let ((kid (car kids-list)))
  821.         (if (symbol? kid)
  822.             (loop-list (cdr kids-list) valid-kids)
  823.             (loop-list (cdr kids-list)
  824.                    (append valid-kids (list kid))))))))))
  825.  
  826. (define (array:rearrange me)
  827.   (let ((screen-area (used-screen-area me))
  828.     (kids-lists (ArrayBox%.kids-lists me)))
  829.     (if screen-area
  830.     (let ((new-size (array-size kids-lists)))
  831.       (set-%desired-size! me new-size)
  832.       (if (size= new-size (UITKRectangle.Size screen-area))
  833.           (begin (assign-glue! me)
  834.              (array-arrange kids-lists screen-area))
  835.           (begin
  836.         (set-%desired-size! me new-size)
  837.         (geometry-change! me screen-area #T)
  838.         (if (eq? screen-area (used-screen-area me))
  839.             (begin (assign-glue! me)
  840.                (array-arrange kids-lists screen-area)))))))))
  841.  
  842. (define (array-box-add-child! me kid)
  843.   (if (not (valid-child? kid))
  844.       (error "ARRAY-BOX-ADD-CHILD!: Bad UIObj" kid))
  845.   (one-parent-only! kid me)
  846.   (set-ArrayBox%.kids! me (append (ArrayBox%.kids me) (list kid)))
  847.   (on-geometry-change!
  848.    kid 'ARRAY-BOX
  849.    (lambda (old-screen-area new-screen-area)
  850.      old-screen-area            ; Not used
  851.      (if (eq? new-screen-area #T)    ; Instigated by child, not manager
  852.      (array:rearrange me))))
  853.   (on-death! kid 'ARRAY-BOX        ; Die horribly ....
  854.          (lambda ()
  855.            (assign-drawing-surface! me 'RETRACTED)))
  856.   (assign-drawing-surface! kid (drawing-surface me))
  857.   (array:rearrange me))
  858.  
  859. (define (array-box-assign-drawing-surface! me surface)
  860.   (check-drawing-surface! me surface)
  861.   (for-each (lambda (kid)
  862.           (if (eq? surface 'RETRACTED)
  863.           (forget! kid 'ARRAY-BOX))
  864.           (assign-drawing-surface! kid surface))
  865.         (ArrayBox%.kids me))
  866.   (if (DrawingSurface? surface)
  867.       (set-%desired-size! me (array-size (ArrayBox%.kids-lists me))))
  868.   (if (eq? surface 'RETRACTED)
  869.       (death! me)
  870.       (geometry-change! me #F #F))
  871.   'OK)
  872.  
  873. (define (array-box-assign-screen-area! me screen-area)
  874.   (cond ((vector? screen-area)
  875.      (set-assigned-screen-area! me screen-area)
  876.      (let ((old (used-screen-area me)))
  877.        (if (not (screen-area= old screen-area))
  878.            (begin
  879.          (set-used-screen-area! me screen-area)
  880.          (array:rearrange me)
  881.          (geometry-change! me old screen-area))))
  882.      screen-area)
  883.     ((not screen-area)
  884.      (set-assigned-screen-area! me screen-area)
  885.      (let ((old (used-screen-area me)))
  886.        (if (not (screen-area= old screen-area))
  887.            (begin
  888.          (set-used-screen-area! me screen-area)
  889.          (retract-area (ArrayBox%.kids me))
  890.          (geometry-change! me old screen-area))))
  891.      screen-area)
  892.     (else
  893.      (error "ARRAY-BOX-ASSIGN-SCREEN-AREA!: Bad screen-area" screen-area))))
  894.  
  895. (define (array-box-assign-glue! me)
  896.   (let ((kids-lists (ArrayBox%.kids-lists me)))
  897.     (for-each assign-glue! (ArrayBox%.kids me))
  898.     (set-%hglue! me (array-get-hglue kids-lists)) 
  899.     (set-%vglue! me (array-get-vglue kids-lists))))
  900.  
  901. ;; Box Maker
  902. (define (array-box-maker kids-lists)
  903.   (make-ArrayBox%
  904.    (make-UIObjInternals 'invalid-arraybox-1 ; array-box-add-child!
  905.             'invalid-arraybox-2 ; array-box-remove-child!
  906.             UIObj-set-context!
  907.             array-box-assign-screen-area!
  908.             array-box-assign-drawing-surface!
  909.             UIObj-point-within?
  910.             UIObj-rectangle-overlaps?
  911.             UIObj-handle-event
  912.             UIObj-get-desired-size
  913.             UIObj-assigned-screen-area
  914.             UIObj-used-screen-area
  915.             UIObj-set-assigned-screen-area!
  916.             UIObj-set-used-screen-area!
  917.             array-box-assign-glue!)
  918.    kids-lists))
  919.  
  920. (define (array-box-propagator box)
  921.   (lambda (event)
  922.     (for-each (lambda (kid)
  923.         (if (event-within? kid event)
  924.             (handle-event kid event)))
  925.           (array-box%.kids box))))
  926.           
  927. (define (make-array-box . kids-lists)
  928.   (let ((kids (find-real-array-box-children kids-lists)))
  929.     (let ((me (array-box-maker kids-lists)))
  930.       (on-event! me 'ARRAY-BOX
  931.          (array-box-propagator me))
  932.       (for-each (lambda (kid) (array-box-add-child! me kid))
  933.         kids)
  934.       me)))
  935.