(module (s9fes char-canvas shape vgroup)

(;export
  ;
  real-shape-vgroup
  ;
  shape-vgroup)

(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)
        (s9fes char-canvas shape shape group))

(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")

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

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

;; Private

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

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

(define (*canvas-draw-vgroup cv x0 y0 shps)
  ;FIXME
  (define (next shp x y) (receive (w h) (shape-size shp) (values x (fx+ y h))))
  (let loop ((shps (reverse 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-vgroup cv x0 y0 shps)
  ;FIXME
  (define (next shp x y) (receive (w h) (shape-size shp) (values x (+ y h))))
  (let loop ((shps (reverse 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

#; ;w/ check- & error-
(define (real-shape-vgroup . args)
  (let ((shps (check-shapes 'real-shape-vgroup
                            (if (%length-1/kind? args list?) (car args)
                                args))) )
    (lambda (#!optional cv x0 y0)
      (if cv
          (begin
            (check-real-xy 'real-shape-vgroup x0 y0)
            (*canvas-draw-vgroup (check-canvas 'real-shape-vgroup cv)
                                 x0 y0 shps) )
          (^real-info 'vgroup shps)) ) ) )

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

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

;;

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

(define (class-shape-layout shp info bb parent)
  (receive (jshps ret-wd ret-ht)
           (group-layout shp (reverse (%info-elements info)) bb parent
                         (lambda (lbb)
                           (let ((lbb-x (%rect-x lbb)) (lbb-y (%rect-y lbb))
                                 (lbb-wd (%rect-wd lbb)) (lbb-ht (%rect-ht lbb)) )
                             (values (%rect (%rect-x bb) lbb-y
                                            (%rect-wd bb) lbb-ht)
                                     (%rect-x bb)
                                     (+ lbb-y lbb-ht)))))
;(print "vgroup layout res " ret-wd " " ret-ht)
    (if jshps (*new-vgroup info jshps)
        (error 'vgroup-layout "overflows bounding-box" ret-wd ret-ht bb)) ) )

(register-shape 'vgroup shape-vgroup real-shape-vgroup)
(register-shape-method 'vgroup 'size class-shape-size)
(register-shape-method 'vgroup 'cardinality class-group-cardinality)
(register-shape-method 'vgroup 'elements class-group-elements)
(register-shape-method 'vgroup 'layout class-shape-layout)
(register-shape-method 'vgroup 'justified? class-group-justified?)
(register-shape-method 'vgroup 'reify-args class-group-reify-args)
(register-shape-method 'vgroup 'reflect class-group-reflect)

) ;module (s9fes char-canvas shape vgroup)