(module (s9fes char-canvas shape fpad)

(;export
  ;
  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.pad.incl")

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

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

;; Private

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

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

;FIXME dups `shape-center'
(define (*fpad-center w h pad-dims x0 y0)
  (if (and x0 y0) (values x0 y0)
      (receive (wd ht) (*fpad-shape-size w h pad-dims)
        (values (round (/ wd 2)) (round (/ ht 2))))) )

; bb max y <= shape max y (rect overlap shape top)
(define (top-rect w h xm ym top bottom right left)
;(print)
;(print " top-rect: " " w: " w " h: " h " xm: " xm " ym: " ym " top: " top " bottom: " bottom " right: " right " left: " left)
  (let ((x (round (- xm (/ w 2)))) (y (round (+ ym (/ h 2))))
        (wd (round (+ left (+ w right)))) (ht top) )
;(print " x: " x " y: " y " wd: " wd " ht: " ht)
    ; must be 1 beyond top row
    (cond ((< h (* (round (/ h 2)) 2)) (set! y (- y 1)))  ;rounded up
          ((> h (* (round (/ h 2)) 2)) (set! y (+ y 1)))) ;rounded down
    (cond ((< w (* (round (/ w 2)) 2)) (set! x (- x 1)))  ;rounded up
          ((> w (* (round (/ w 2)) 2)) (set! x (+ x 1)))) ;rounded down
;(print " x: " x " y: " y " wd: " wd " ht: " ht)
 (%rect x y wd ht) ) )

; bb max x >= shape min x (rect overlap shape left)
(define (left-rect w h xm ym top bottom right left)
  (let ((x (round (- xm (/ w 2)))) (y (round (- ym (/ h 2))))
        (wd left) (ht h) )
    (%rect x y wd ht) ) )

; bb min x >= shape max x (rect overlap shape right)
(define (right-rect w h xm ym top bottom right left)
  (let ((x (round (+ xm (/ w 2)))) (y (round (- ym (/ h 2))))
        (wd right) (ht h) )
    (%rect x y wd ht) ) )

; bb max y >= shape min y (rect overlap shape bottom)
(define (bottom-rect w h xm ym top bottom right left)
  (let ((x (round (- xm (/ w 2)))) (y (round (- ym (+ (/ h 2) bottom))))
        (wd (round (+ left (+ w right)))) (ht bottom) )
    (%rect x y wd ht) ) )

(define (*canvas-do-fpad flooder cv x0 y0 shape pad-dims pad-chars)
  (let*-values (((w h) (shape-size shape))
                ((xm ym) (*fpad-center w h pad-dims x0 y0))
                ((top bottom left right) (apply values pad-dims))
                ((top-char bottom-char left-char right-char) (apply values pad-chars)) )
    (unless (or (fx= 0 top) (not top-char))
      (let ((rect (top-rect w h xm ym top bottom right left)))
        (flooder cv top-char rect) ) )
    (unless (or (fx= 0 left) (not left-char))
      (let ((rect (left-rect w h xm ym top bottom right left)))
        (flooder cv left-char rect) ) )
    (shape cv xm ym)
    (unless (or (fx= 0 right) (not right-char))
      (let ((rect (right-rect w h xm ym top bottom right left)))
        (flooder cv right-char rect) ) )
    (unless (or (fx= 0 bottom) (not bottom-char))
      (let ((rect (bottom-rect w h xm ym top bottom right left)))
        (flooder cv bottom-char rect) ) ) ) )

(define (*canvas-draw-fpad cv x0 y0 shape pad-dims pad-chars)
  (*canvas-do-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-do-fpad canvas-flood cv x0 y0 shape pad-dims pad-chars) )

;; Public

(define (fpad-center fpad #!optional x0 y0)
  (let* ((info (fpad))
         (shape (info-shape info))
         (pad-dims (info-pad-dims info)) )
    (let*-values (((w h) (shape-size shape)))
      (*fpad-center w h pad-dims x0 y0) ) ) )

(define ((real-shape-fpad shape pad-dims #!optional (pad-chars (%bkgd-pad-chars))) #!optional cv x0 y0)
  (if cv
      (begin
        (*canvas-draw-fpad cv x0 y0 shape pad-dims pad-chars)
        cv )
      (^real-info fpad shape pad-dims pad-chars) ) )

(define ((shape-fpad shape pad-dims #!optional (pad-chars (%bkgd-pad-chars))) #!optional cv x0 y0)
  (if cv
      (begin
        (*canvas-plot-fpad cv x0 y0 shape pad-dims pad-chars)
        cv )
      (^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) ) ) )

(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 (lambda (shp info bb) shp))
(register-shape-method 'jpad 'justified? (lambda (shp info) #t))

) ;module (s9fes char-canvas shape fpad)