#lang scheme/gui

(provide square-panel%)

; Horizontal panel where all children are quadratic.
; All children are magnified with the same factor.
; That is, stretchability is ignored.
; And so is margins.

(define square-panel%
  (let ()
    (define-syntax with-info
      (syntax-rules ()
        [(with-info (w h hs vs) i body ...)
         (let ([w  (list-ref i 0)]
               [h  (list-ref i 1)]
               [hs (list-ref i 2)]
               [vs (list-ref i 3)])
           body ...)]))
    (class panel%
      (define/override (container-size infos)
        (let* ([c (foldl (λ (i a) 
                           (with-info (w h hs vs) i
                             (let ([m (max w h)])
                               (match a [(list aw ah) (list (+ aw m) (max ah m))]))))
                         '(0 0)
                         infos)]
               [b (send this border)]
               [s (send this spacing)]
               [n (length infos)])
          (match c 
            [(list w h) 
             (values (+ w (* 2 b) (* s (max 0 (- n 1))))
                     (+ h (* 2 b)))])))
      (define/override (place-children infos width height)
        ; place the children within an width x height area
        (let* ([border (send this border)]
               [spacing (send this spacing)]
               [n (length infos)]
               [width (- width (* 2 border) (* spacing (max 0 (- n 1))))]
               [height (- height (* 2 border))]
               [total-horiz  (foldl (λ (i a) (with-info (w h hs vs) i (+ a (max w h)))) 0 infos)]
               [total-stretchable-horiz 
                (foldl (λ (i a) (with-info (w h hs vs) i (if (and hs vs) (+ a (max w h)) a))) 0 infos)]
               [non-stretchable-horiz (- total-horiz total-stretchable-horiz)]
               [total-vert   (foldl (λ (i a) (with-info (w h hs vs) i (max a w h))) 0 infos)]
               [total-stretchable-vert   
                (foldl (λ (i a) (with-info (w h hs vs) i (if (and hs vs) (max a w h) a))) 0 infos)]
               [vert-factor  (/ height total-stretchable-vert)]
               [horiz-factor (/ (- width non-stretchable-horiz) total-stretchable-horiz)]
               [factor       (min vert-factor horiz-factor)]
               [b border]
               [s spacing])
          (let-values ([(horiz-alignment vert-alignment) (send this get-alignment)])
            (define (mag s) (inexact->exact (floor (* factor s))))
            (reverse 
             (first 
              (foldl (λ (i a)
                       (match a
                         [(list specs x)
                          (with-info (w h hs vs) i
                            (let* ([m (max w h)]
                                   [m (if (and hs vs) (mag m) m)]
                                   [y (case vert-alignment
                                        [(top)    b]
                                        [(center) (+ b (- (quotient height 2)
                                                          (quotient m 2)))]
                                        [(bottom) (+ b (- height m))]
                                        [else (error 'unknown-alignment)])])
                              (list (cons (list x y m m) specs)
                                    (+ x m s))))]))
                     (list '() b)
                     infos))))))
        (super-new))))