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

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

(define-type real-pad-dims (list fixnum fixnum fixnum fixnum))
(define-type pad-dims (list fixnum fixnum fixnum fixnum))

(define-type pad-chars (list (or false char) (or false char) (or false char) (or false char)))

(: 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 (*fpad-shape-size w h pad-dims)
  (let-values (((top bottom left right) (apply values pad-dims)))
    (values (+ left w right) (+ top h bottom)) ) )

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

(define (top-rect w h xm ym top bottom right left)
  (let ((x (round (- xm (/ w 2)))) (y (round (+ ym (/ h 2))))
        (wd (round (+ left (+ w right)))) (ht top) )
    (%rect x y wd ht) ) )

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

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

(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 (bkgd-pad-chars) (make-list 4 (current-plotter-bkgd-char)))

(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 (the shape-plotter (@info 3 info)))
         (pad-dims (the pad-dims (@info 4 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 (fpad-shape-size shp info)
  (let ((shape (the shape-plotter (@info 0 info)))
        (pad-dims (the pad-dims (@info 1 info))) )
    (let-values (((w h) (shape-size shape)))
      (*fpad-shape-size w h pad-dims) ) ) )

(: shape-cardinality (shape-plotter -> fixnum))
(: shape-elements (shape-plotter -> (list-of shape-plotter)))

(register-shape-method 'fpad 'size fpad-shape-size)
(register-shape-method 'fpad 'cardinality (lambda (shp info) 1))
(register-shape-method 'fpad 'elements (lambda (shp info) (the shape-plotter (@info 0 info))))
(register-shape-method 'fpad 'shape-layout (lambda (shp info) shp))

) ;module (s9fes char-canvas shape fpad)