;; SUI
;; 6.891 Spring 2006
;;
;; Layout manager definitions
;;
;; $Id: layouts.scm 60 2006-05-17 09:29:43Z nelhage $

(define-class (<layout>
               (constructor make-layout (name) (attribs)))
  (<container>))

(define-generic layout-children (layout))

(define-method layout-children ((layout <layout>))
  (container-contents layout))

(define-class (<row-layout>
               (constructor make-row-layout (name contents) (attribs)))
  (<layout>)
  (spacing initial-value 0
           define standard))

(define-method initialize-instance ((layout <row-layout>)
                                    attribs)
  (call-next-method layout attribs)
  (row-layout-recalculate-size! layout))

(define (row-layout-recalculate-size! layout)
  (let ((widgets (layout-children layout)))
    (set-widget-preferred-width! layout
                                 (reduce + 0 (map widget-preferred-width widgets)))
    (set-widget-min-width! layout
                           (reduce + 0 (map widget-min-width
                                            widgets)))
    (set-widget-preferred-height! layout
                                  (reduce max 0 (map widget-preferred-height widgets)))
    (set-widget-min-height! layout
                            (reduce max 0 (map widget-min-height
                                               widgets)))
    (set-widget-can-grow?! layout
                           (there-exists? (map widget-can-grow? widgets)
                                          (lambda (t-e) t-e)))))

(define-method initialize-children! ((layout <row-layout>))
  (row-layout-recalculate-size! layout)
  (for-each (lambda (widget)
              (set-widget-height! widget
                                  (if (widget-can-grow? widget)
                                      (widget-height layout)
                                      (min
                                       (widget-preferred-height widget)
                                       (widget-height layout)))))
            (layout-children layout))
  (cond ((> (widget-min-width layout) (widget-width layout))
         (row-layout-calculate-widths-too-small! layout))
        ((< (widget-preferred-width layout) (widget-width layout))
         (if (widget-can-grow? layout)
             (row-layout-calculate-widths-grow! layout)
             (row-layout-calculate-widths-too-large! layout)))
        (else
         (row-layout-calculate-widths-shrink! layout)))
  (call-next-method layout)
  (row-layout-calculate-positions! layout))

(define (row-layout-calculate-widths-too-small! layout)
  (error "Row layout too small -- " layout))

(define (row-layout-calculate-widths-grow! layout)
  (set-row-layout-spacing! layout 0)
  (let* ((must-grow (- (widget-width layout)
                       (widget-preferred-width layout)))
         (growable-components (fold-right
                               (lambda (w count)
                                 (if (widget-can-grow? w)
                                     (+ 1 count)
                                     count))
                               0 (layout-children layout)))
         (growth (ceiling (/ must-grow growable-components))))
    (for-each (lambda (widget)
                (set-widget-width! widget
                                   (+ (widget-preferred-width widget)
                                      (if (widget-can-grow? widget)
                                          growth
                                          0))))
              (layout-children layout))))

(define (row-layout-calculate-widths-too-large! layout)
  (set-row-layout-spacing! layout
                           (ceiling
                            (/ (- (widget-width layout)
                                  (widget-preferred-width layout))
                               (1+ (length (layout-children layout))))))
  (for-each (lambda (widget)
              (set-widget-width! widget
                                 (widget-preferred-width widget)))
            (layout-children layout)))

(define (row-layout-calculate-widths-shrink! layout)
  (set-row-layout-spacing! layout 0)
  (let ((children (layout-children layout)))
    (for-each (lambda (widget)
                (set-widget-width! widget
                                   (widget-preferred-width widget)))
              children)
    (let ((extra-width (- (reduce + 0 (map widget-width children))
                          (widget-width layout))))
      (if (> extra-width 0)
          (let loop ((extra-width extra-width)
                     (shrinkable (fold-right (lambda (widget count)
                                               (if (< (widget-min-width widget)
                                                      (widget-width widget))
                                                   (+ count 1)
                                                   count))
                                             0 (layout-children layout))))
            (let ((shrink (ceiling (/ extra-width shrinkable))))
              (let per-child
                  ((extra-width extra-width)
                   (shrinkable shrinkable)
                   (children children))
                (if (null? children)
                    (if (> extra-width 0)
                        (loop extra-width shrinkable))
                    (let* ((widget (car children))
                           (can-lose (- (widget-width widget)
                                        (widget-min-width widget))))
                      (cond ((>= can-lose shrink)
                             (set-widget-width! widget (- (widget-width widget) shrink))
                             (per-child (- extra-width shrink) shrinkable (cdr children))) 
                            ((zero? can-lose)
                             (per-child extra-width shrinkable (cdr children)))
                            ((< can-lose shrink)
                             (set-widget-width! widget (widget-min-width widget))
                             (per-child (- extra-width can-lose)
                                        (- shrinkable 1) (cdr children)))))))))))))

(define (row-layout-calculate-positions! layout)
  (for-each (lambda (w) (set-widget-y! w 0)) (layout-children layout))
  (let loop ((x (row-layout-spacing layout))
             (children (layout-children layout)))
    (if (not (null? children))
        (let ((widget (car children)))
          (set-widget-x! widget x)
          (loop (+ x (widget-width widget)
                   (row-layout-spacing layout))
                (cdr children))))))

(define (test-row)
  (let* ((w1 (make-widget 'w1 '()))
         (w2 (make-widget 'w2 '()))
         (w3 (make-widget 'w3 '())))
    (set-widget-preferred-width! w1 40)
    (set-widget-min-width! w1 20)
    (set-widget-can-grow?! w1 #f)
    (set-widget-preferred-height! w1 40)

    (set-widget-preferred-width! w2 50)
    (set-widget-can-grow?! w2 #t)
    (set-widget-preferred-height! w2 30)

    (set-widget-preferred-width! w3 30)
    (set-widget-can-grow?! w3 #t)
    (set-widget-preferred-height! w3 20)
    (let ((l1 (make-row-layout 'l1 (list w1 w2 w3)  '()))
          (l2 (make-row-layout 'l2 (list w1 w2) '())))
      (set-widget-height! l1 50)
      (set-widget-width! l1 110)

      (initialize-children! l1)

      (assert (= (widget-width w1) 30) "w1 correct width")
      (assert (= (widget-height w1) 40) "w1 correct height")
      (assert (= (widget-height w3) 50) "w3 correct heigth")

      (set-widget-width! l1 300)
      (initialize-children! l1)

      (assert (= (widget-width w1) (widget-preferred-width w1)))
      (assert (> (widget-width w2) (widget-preferred-width w2))))))

;;; Temporary horribly hacked column layout
;;; HERE BE DRAGONS

(define-class (<column-layout>
               (constructor make-column-layout (name contents) (attribs)))
  (<layout>)
  (spacing initial-value 0
           define standard))

(define-method initialize-instance ((layout <column-layout>)
                                    attribs)
  (call-next-method layout attribs)
  (column-layout-recalculate-size! layout))

(define (column-layout-recalculate-size! layout)
  (let ((widgets (layout-children layout)))
    (set-widget-preferred-height! layout
                                 (reduce + 0 (map widget-preferred-height widgets)))
    (set-widget-min-height! layout
                           (reduce + 0 (map widget-min-height
                                            widgets)))
    (set-widget-preferred-width! layout
                                  (reduce max 0 (map widget-preferred-width widgets)))
    (set-widget-min-width! layout
                            (reduce max 0 (map widget-min-width
                                               widgets)))
    (set-widget-can-grow?! layout
                           (there-exists? (map widget-can-grow? widgets)
                                          (lambda (t-e) t-e)))))

(define-method initialize-children! ((layout <column-layout>))
  (column-layout-recalculate-size! layout)
  (for-each (lambda (widget)
              (set-widget-width! widget
                                 (if (widget-can-grow? widget)
                                     (widget-width layout)
                                     (min
                                      (widget-preferred-width widget)
                                      (widget-width layout)))))
            (layout-children layout))
  (cond ((> (widget-min-height layout) (widget-height layout))
         (column-layout-calculate-heights-too-small! layout))
        ((< (widget-preferred-height layout) (widget-height layout))
         (if (widget-can-grow? layout)
             (column-layout-calculate-heights-grow! layout)
             (column-layout-calculate-heights-too-large! layout)))
        (else
         (column-layout-calculate-heights-shrink! layout)))
  (column-layout-calculate-positions! layout)
  (call-next-method layout))

(define (column-layout-calculate-heights-too-small! layout)
  (error "column layout too small -- " layout))

(define (column-layout-calculate-heights-grow! layout)
  (set-column-layout-spacing! layout 0)
  (let* ((must-grow (- (widget-height layout)
                       (widget-preferred-height layout)))
         (growable-components (fold-right
                               (lambda (w count)
                                 (if (widget-can-grow? w)
                                     (+ 1 count)
                                     count))
                               0 (layout-children layout)))
         (growth (ceiling (/ must-grow growable-components))))
    (for-each (lambda (widget)
                (set-widget-height! widget
                                   (+ (widget-preferred-height widget)
                                      (if (widget-can-grow? widget)
                                          growth
                                          0))))
              (layout-children layout))))

(define (column-layout-calculate-heights-too-large! layout)
  (set-column-layout-spacing! layout
                           (ceiling
                            (/ (- (widget-height layout)
                                  (widget-preferred-height layout))
                               (1+ (length (layout-children layout))))))
  (for-each (lambda (widget)
              (set-widget-height! widget
                                 (widget-preferred-height widget)))
            (layout-children layout)))

(define (column-layout-calculate-heights-shrink! layout)
  (set-column-layout-spacing! layout 0)
  (let ((children (layout-children layout)))
    (for-each (lambda (widget)
                (set-widget-height! widget
                                   (widget-preferred-height widget)))
              children)
    (let ((extra-height (- (reduce + 0 (map widget-height children))
                          (widget-height layout))))
      (if (> extra-height 0)
          (let loop ((extra-height extra-height)
                     (shrinkable (fold-right (lambda (widget count)
                                               (if (< (widget-min-height widget)
                                                      (widget-height widget))
                                                   (+ count 1)
                                                   count))
                                             0 (layout-children layout))))
            (let ((shrink (ceiling (/ extra-height shrinkable))))
              (let per-child
                  ((extra-height extra-height)
                   (shrinkable shrinkable)
                   (children children))
                (if (null? children)
                    (if (> extra-height 0)
                        (loop extra-height shrinkable))
                    (let* ((widget (car children))
                           (can-lose (- (widget-height widget)
                                        (widget-min-height widget))))
                      (cond ((>= can-lose shrink)
                             (set-widget-height! widget (- (widget-height widget) shrink))
                             (per-child (- extra-height shrink) shrinkable (cdr children))) 
                            ((zero? can-lose)
                             (per-child extra-height shrinkable (cdr children)))
                            ((< can-lose shrink)
                             (set-widget-height! widget (widget-min-height widget))
                             (per-child (- extra-height can-lose)
                                        (- shrinkable 1) (cdr children)))))))))))))

(define (column-layout-calculate-positions! layout)
  (for-each (lambda (w) (set-widget-x! layout 0)) (layout-children layout))
  (let loop ((y (column-layout-spacing layout))
             (children (layout-children layout)))
    (if (not (null? children))
        (let ((widget (car children)))
          (set-widget-y! widget y)
          (loop (+ y (widget-height widget)
                   (column-layout-spacing layout))
                (cdr children))))))

;;; Grid layout -- define in terms of a column of rows
(define (make-grid-layout name columns elements attribs)
  (let ((rows
         (let loop ((elts elements))
           (cond ((null? elts) '())
                 (else
                  (let ((len (min columns (length elts))))
                    (cons
                     (make-row-layout (generate-uninterned-symbol "grid-row")
                                      (list-head elts len)
                                      '())
                     (loop (list-tail elts len)))))))))
    (make-column-layout name rows attribs)))

;;
;; High-level constructors
;;

(define row-layout (make-container-convenience-constructor make-row-layout 0))
(define column-layout (make-container-convenience-constructor make-column-layout 0))
(define grid-layout (make-container-convenience-constructor make-grid-layout 1))