(module (s9fes char-canvas shape hgroup)

(;export
  ;
  real-shape-hgroup
  ;
  shape-hgroup)

(import scheme utf8)
(import (chicken base))
(import (chicken fixnum))
(import (chicken type))
(import record-variants)
(import (s9fes char-canvas)
        (s9fes char-canvas rect)
        (s9fes char-canvas shape shape))

(include-relative "s9fes.char-canvas.types")
(include-relative "s9fes.char-canvas.inlines")

(include-relative "s9fes.char-canvas.shape.pad.incl")

;group rest arg is (list-ofshape-plotter) or (list (list-ofshape-plotter))
;due to new group not using `apply'

(: real-shape-hgroup (#!rest real-shape-plotter -> real-shape-plotter))
(: shape-hgroup (#!rest shape-plotter -> shape-plotter))

;; Private

(define (*info-elements info) (the (list-of shape-plotter) (@info 0 info)))

(define (*new-hgroup info elms)
  (case (@info-coords info)
    ((real) (real-shape-hgroup elms))
    (else   (shape-hgroup elms))) )

(define (*canvas-draw-hgroup cv x0 y0 shps)
  ;FIXME
  (define (next shp x y) (receive (w h) (shape-size shp) (values (fx+ x w) y)))
  (let loop ((shps shps) (x x0) (y y0))
    (unless (null? shps)
      (let ((shp (car shps)))
        (shp cv x y)
        (receive (x y) (next shp x y)
          (loop (cdr shps) x y) ) ) ) )
  cv )

(define (*canvas-plot-hgroup cv x0 y0 shps)
  ;FIXME
  (define (next shp x y) (receive (w h) (shape-size shp) (values x (+ y h))))
  (let loop ((shps shps) (x x0) (y y0))
    (unless (null? shps)
      (let ((shp (car shps)))
        (shp cv x y)
        (receive (x y) (next shp x y)
          (loop (cdr shps) x y) ) ) ) )
  cv )

;; Public

(define (real-shape-hgroup #!rest args)
  (let ((shps (if (%length-1/kind? args list?) (car args) args)))
    (assert (%shapes? shps) 'real-shape-hgroup "bad argument type - not list-of shape" shps)
    (lambda (#!optional cv x0 y0)
      (if cv
          (*canvas-draw-hgroup cv x0 y0 shps)
          (^real-info hgroup shps) ) ) ) )

(define (shape-hgroup #!rest args)
  (let ((shps (if (%length-1/kind? args list?) (car args) args)))
    (assert (%shapes? shps) 'shape-hgroup "bad argument type - not list-of shape" shps)
    (lambda (#!optional cv x0 y0)
      (if cv
          (*canvas-plot-hgroup cv x0 y0 shps)
          (^virtual-info hgroup shps) ) ) ) )

;;

(define (class-shape-size shp info)
  (let* ((shps (*info-elements info))
         (sizs (map (lambda (shp) (receive (shape-size shp))) shps)) )
    (values (apply + (map car sizs)) (apply max (map cadr sizs))) ) )

(define (class-shape-layout shp info bb)
  ;FIXME finish apportionment - rqr-wd rqr-ht
  (let-values (((rqr-wd rqr-ht) (class-shape-size shp info)))
    ; v is bottom to top
    (let* ((shps (*info-elements info))
           (nshps (length shps))
           (wd-per (/ (%rect-wd bb) nshps))
           (rem-y (%rect-y bb))
           (rem-wd (%rect-wd bb))
           (rem-ht (%rect-ht bb)) )
      (if (or (< (%rect-wd bb) rqr-wd) (< (%rect-ht bb) rqr-ht))
          ;then can't fit
          (error 'hgroup-layout "overflows bounding-box" rqr-wd rqr-ht bb)
          ;else try to fit
          (let loop ((shps shps) (new-x (%rect-x bb)) (rem-wd rem-wd) (jsts '()))
            ;FIXME what if out of room
            (if (null? shps)
                (*new-hgroup info jsts)
                (let ((shp (car shps)))
                  ;FIXME new-ht negotiated how?
                  (let* ((this-wd (if (null? (cdr shps))
                                      ;then this is last
                                      (if (= 1 nshps)
                                          ;then full
                                          wd-per
                                          ;else last bit
                                          (ceiling wd-per))
                                      ;else per bit
                                      (floor wd-per)))
                         (this-bb (%rect new-x rem-y rem-ht rem-wd)) )
                    (loop (cdr shps)
                          (+ new-x this-wd) (- rem-wd this-wd)
                          (cons (shape-layout shp this-bb) jsts) ) ) ) ) ) ) ) ) )

(define (class-shape-justified? shp info)
  (let loop ((shps (*info-elements info)))
    (or (null? shps)
        (let ((shp (car shps)))
          (and (shape-justified? shp)
               (loop (cdr shps))) ) ) ) )

(register-shape-method 'hgroup 'size class-shape-size)
(register-shape-method 'hgroup 'cardinality (lambda (shp info) (length (*info-elements info))))
(register-shape-method 'hgroup 'elements (lambda (shp info) (*info-elements info)))
(register-shape-method 'hgroup 'layout class-shape-layout)
(register-shape-method 'hgroup 'justified? class-shape-justified?)

) ;module (s9fes char-canvas shape hgroup)