(module (s9fes char-canvas shape fpad)

(;export
  ;
  #;fpad-center
  ;
  real-shape-fpad
  ;
  shape-fpad)

(import scheme utf8)
(import (chicken base))
(import (chicken fixnum))
(import (chicken type))
(import record-variants)
(import (only (srfi 1) make-list))
(import (s9fes char-canvas)
        (s9fes char-canvas block)
        (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")

#;(: fpad-center (shape-plotter #!optional integer integer -> integer integer))

(: real-shape-fpad (real-shape-plotter #!optional real-pad-dims pad-chars -> real-shape-plotter))
(: shape-fpad (shape-plotter #!optional pad-dims pad-chars -> shape-plotter))

;; Private

(define-inline (*info-shape info)     (the shape-plotter (@info 0 info)))
(define-inline (*info-pad-dims info)  (the (or false pad-dims) (@info 1 info)))
(define-inline (*info-pad-chars info) (the pad-chars (@info 2 info)))

(define (*fpad-shape-size w h pad-dims)
  (let ((top (%dims-top pad-dims))
        (bottom (%dims-bottom pad-dims))
        (left (%dims-left pad-dims))
        (right (%dims-right pad-dims)) )
    (values (+ left w right) (+ top h bottom)) ) )

#; ;UNUSED
(define-inline (fc-of n) (values (floor n) (ceiling n)))

;FIXME need frame-chars; we have CORNERS, this is frame-pad

(define (*canvas-show-fpad flooder cv x0 y0 shape pad-dims pad-chars)

  ;FIXME use fwd fht for mid, saves a virtual-dispatch

  ;@w, @h width, height; total shape size (fpad + shape)
  ;@w/2c, @w/2f, @h/2c, @h/2f wd/2 ceiling, wd/2 floor, ht/2 ceiling, ht/2 floor
  ;@top @bottom @right @left pad-dimensions
  ;@x0 @y0 optional supplied xm ym (center)

  ;get box context
  (let-values (((w h) (shape-size shape))
                ((w/2f w/2c h/2f h/2c) (shape-center shape)) )

    (let-values (((fwd fht) (*fpad-shape-size w h pad-dims)))

      (let ((top (%dims-top pad-dims))
            (bottom (%dims-bottom pad-dims))
            (left (%dims-left pad-dims))
            (right (%dims-right pad-dims))
            (top-char (%chars-top pad-chars))
            (bottom-char (%chars-bottom pad-chars))
            (left-char (%chars-left pad-chars))
            (right-char (%chars-right pad-chars)) )
        ;FIXME
        (let ((l-x (if x0 (- x0 w/2f left) 0))
              (r-x (if x0 (+ x0 w/2c left) (+ w/2c left)))
              ;WTF needs more testing
              (t-y (if y0 (+ y0 h/2c) h/2c #;(+ y0 h/2f bottom)  #;(+ h/2f bottom)))
              (b-y (if y0 (- y0 h/2f bottom) 0)) )

          ;top pad
          (unless (or (zero? top) (not top-char))
            (let ((top-rect (%rect l-x t-y fwd top)))
              (flooder cv top-char top-rect) ) )

          ;left pad
          (unless (or (zero? left) (not left-char))
            (let ((left-rect (%rect l-x (+ b-y bottom) left h)))
              (flooder cv left-char left-rect) ) )

          ;wrapped shape
          (shape cv (or x0 w/2f) (or y0 h/2f))

          ;right pad
          (unless (or (zero? right) (not right-char))
            (let ((right-rect (%rect r-x (+ b-y bottom) right h)))
              (flooder cv right-char right-rect) ) )

          ;bottom pad
          (unless (or (zero? bottom) (not bottom-char))
            (let ((bottom-rect (%rect l-x b-y fwd bottom)))
              (flooder cv bottom-char bottom-rect) ) ) ) ) ) )

  ;shape show return
  cv )

(define (*canvas-draw-fpad cv x0 y0 shape pad-dims pad-chars)
  (*canvas-show-fpad canvas-flood-chars cv x0 y0 shape pad-dims pad-chars) )

(define (*canvas-plot-fpad cv x0 y0 shape pad-dims pad-chars)
  (*canvas-show-fpad canvas-flood cv x0 y0 shape pad-dims pad-chars) )

(define (*new-fpad info shape pad-dims pad-chars)
  (case (@info-coords info)
    ((real) (real-shape-fpad shape pad-dims pad-chars))
    (else   (shape-fpad shape pad-dims pad-chars))) )

;; Public

(define (real-shape-fpad shape #!optional (pad-dims ONE-DIMS) (pad-chars (%bkgd-pad-chars)))
  (assert (%shape? shape) 'real-shape-fpad "bad argument type - not shape" shape)
  (assert (%pad-dims? pad-dims) 'real-shape-fpad "bad argument type - not pad-dims" pad-dims)
  (assert (%pad-chars? pad-chars) 'real-shape-fpad "bad argument type - not pad-chars" pad-chars)
  (shape-lambda-info!
    (lambda (#!optional cv x0 y0)
      (if cv
          (*canvas-draw-fpad cv x0 y0 shape pad-dims pad-chars)
          (^real-info 'fpad shape pad-dims pad-chars) ) ) ) )

(define (shape-fpad shape #!optional (pad-dims ONE-DIMS) (pad-chars (%bkgd-pad-chars)))
  (assert (%shape? shape) 'shape-fpad "bad argument type - not shape" shape)
  (assert (%pad-dims? pad-dims) 'shape-fpad "bad argument type - not pad-dims" pad-dims)
  (assert (%pad-chars? pad-chars) 'shape-fpad "bad argument type - not pad-chars" pad-chars)
  (shape-lambda-info!
    (lambda (#!optional cv x0 y0)
      (if cv
          (*canvas-plot-fpad cv x0 y0 shape pad-dims pad-chars)
          (^virtual-info 'fpad shape pad-dims pad-chars) ) ) ) )

;;

(define (class-shape-size shp info)
  (let ((shape (*info-shape info))
        (pad-dims (*info-pad-dims info)) )
    (let-values (((w h) (shape-size shape)))
      (*fpad-shape-size w h pad-dims) ) ) )

(define (class-shape-layout shp info bb parent)
  (let ((shape (*info-shape info))
        (pad-dims (*info-pad-dims info)) )
    (let ((top (%dims-top pad-dims))
          (bottom (%dims-bottom pad-dims))
          (left (%dims-left pad-dims))
          (right (%dims-right pad-dims)) )
      (let ((child-bb (%rect (%rect-x bb) (%rect-y bb)
                             (- (%rect-wd bb) left right)
                             (- (%rect-ht bb) top bottom))) )
        (let ((shape (shape-layout shape child-bb shp)))
          (*new-fpad info shape pad-dims (*info-pad-chars info)) ) ) ) ) )

(define (class-shape-justified? shp info)
  (shape-justified? (*info-shape info)) )

(define (class-shape-reify-args noshp noinfo args)
  (let ((shape-info (car args)))
    `(,(shape-reify shape-info) ,@(cdr args)) ) )

(define (class-shape-reflect shp info)
  (^info (@info-class info) (@info-coords info)
         (shape-reflect (*info-shape info))
         (*info-pad-dims info) (*info-pad-chars info)) )

(register-shape 'fpad shape-fpad real-shape-fpad)
(register-shape-method 'fpad 'size class-shape-size)
(register-shape-method 'fpad 'cardinality (lambda (shp info) 1))
(register-shape-method 'fpad 'elements (lambda (shp info) `(,(*info-shape info))))
(register-shape-method 'fpad 'layout class-shape-layout)
(register-shape-method 'fpad 'justified? class-shape-justified?)
(register-shape-method 'fpad 'reify-args class-shape-reify-args)
(register-shape-method 'fpad 'reflect class-shape-reflect)

) ;module (s9fes char-canvas shape fpad)