(module (s9fes char-canvas shape shape group)

(;export
  ;
  group-layout
  ;
  class-group-cardinality
  class-group-elements
  class-group-justified?
  class-group-reify-args
  class-group-reflect)

(import scheme utf8)
(import (chicken base))
(import (chicken fixnum))
(import (chicken type))
(import (only (srfi 1) list-copy))
(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.types")
(include-relative "s9fes.char-canvas.shape.inlines")

(define-type layout-bb (rect -> rect real real))

(: group-layout (shape-plotter shape-plotters rect shape-plotter layout-bb
                  -> (or false shape-plotters) integer integer))

(: class-group-cardinality (shape shape-info -> fixnum))
(: class-group-elements (shape shape-info -> shape-plotters))
(: class-group-justified? (shape shape-info -> boolean))
(: class-group-reify-args (false false list -> list))
(: class-group-reflect (shape shape-info -> shape-info))

;; Private

(define-inline (%info-elements info) (the shape-plotters (@info 0 info)))

(define-inline (what-per shps per-x per-y)
  (if (null? (cdr shps))
      ;then this is last
      (values (round per-x) (round per-y))
      ;else per bit
      (values (floor per-x) (floor per-y))) )

;; Public

; @shp  the class-group shape
;@shps  the wrapped shapes, in the order desired by the group,
;       so passed, not ref'ed
; @bb   layout rect
;

;FIXME when @shp is tree-root then full ht|wd (depending) can be used!
(define (group-layout shp shps bb parent layout-bb)
  (let-values (((rqr-wd rqr-ht) (shape-size shp)))
    (if (or (< (%rect-wd bb) rqr-wd) (< (%rect-ht bb) rqr-ht))
        (values #f rqr-wd rqr-ht)
        (let* ((nshps (length shps))
               (wd-per (/ (%rect-wd bb) nshps))
               (ht-per (/ (%rect-ht bb) nshps)) )
          (let loop ((shps shps)
                     (new-x (%rect-y bb)) (new-y (%rect-y bb))
                     (jsts '()))
           (if (null? shps)
               (values jsts wd-per ht-per)
               (let ((this-shp (car shps)))
                 (let-values (((this-wd this-ht)
                               (what-per shps wd-per ht-per)) )
                   (let ((this-bb (%rect new-x new-y
                                         this-wd this-ht)))
                     (let-values (((this-bb new-x new-y)
                                   (layout-bb this-bb)) )
                       (let ((layshp (shape-layout this-shp this-bb shp)))
                         (loop (cdr shps)
                               new-x new-y
                               (cons layshp jsts) ) ) ) ) ) ) ) ) ) ) ) )

(define (class-group-cardinality shp info)
  (length (%info-elements info)) )

(define (class-group-elements shp info)
  (list-copy (%info-elements info)) )

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

(define (class-group-reify-args noshp noinfo args)
  (let ((elm-infos (car args)))
    `(,(map shape-reify elm-infos) ,@(cdr args)) ) )

(define (class-group-reflect shp info)
  (^info (@info-class info) (@info-coords info)
         (map (cut shape-reflect <>) (%info-elements info)) ) )

) ;module (s9fes char-canvas shape shape group)