(module (s9fes char-canvas shape jpad)

(;export
  ;
  real-shape-jpad
  ;
  shape-jpad)

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

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

(include-relative "s9fes.char-canvas.shape.pad.incl")

(define-type box (struct box))

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

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

;;

;moremacros
(define-syntax ->boolean (syntax-rules () ((->boolean ?v) (and ?v #t))))

;; 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 (dims-top dims) (car dims))
(define (dims-bottom dims) (cadr dims))
(define (dims-left dims) (caddr dims))
(define (dims-right dims) (cadddr dims))

(define (jpad-info->fpad info #!optional justified-dims)
  (let* ((shape (info-shape info))
         (pad-dims (or justified-dims (info-pad-dims info)))
         (pad-chars (info-pad-chars info)) )
    (case (@info-coords info)
      ((real) (real-shape-fpad shape pad-dims pad-chars))
      (else   (shape-fpad shape pad-dims pad-chars))) ) )

#|
(define (*jpad-shape-size w h pad-dims)
  ;FIXME
  (let-values (((top bottom left right) (apply values pad-dims)))
    (values (+ left w right) (+ top h bottom)) ) )

(define (*jpad-center w h pad-dims x0 y0)
  ;FIXME
  (if (and x0 y0) (values x0 y0)
      (receive (wd ht) (*jpad-shape-size w h pad-dims)
        (values (round (/ wd 2)) (round (/ ht 2))))) )
|#

(define (*canvas-draw-jpad cv x0 y0 shape pad-dims pad-chars)
  ((jpad-info->fpad (^real-info jpad shape pad-dims pad-chars)) cv x0 y0)
  cv )

(define (*canvas-plot-jpad cv x0 y0 shape pad-dims pad-chars)
  ((jpad-info->fpad (^virtual-info jpad shape pad-dims pad-chars)) cv x0 y0)
  cv )

;; Public

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

;;

(define ((shape-jpad shape pad-dims #!optional (pad-chars (%bkgd-pad-chars))) #!optional cv x0 y0)
  (if cv
      (*canvas-plot-jpad cv x0 y0 shape pad-dims pad-chars)
      (^virtual-info jpad shape pad-dims pad-chars) ) )

;;

(define (class-shape-size shp info)
  (shape-size (jpad-info->fpad info)) )

(define (class-shape-layout shp info bb)
  (let* ((shape (info-shape info))
         (pad-dims (info-pad-dims info))
         (rem-wd (- (%rect-wd bb) (+ (dims-left pad-dims) (dims-right pad-dims))))
         (rem-ht (- (%rect-ht bb) (+ (dims-top pad-dims) (dims-bottom pad-dims)))) )
    (if (or (negative? rem-wd) (negative? rem-ht))
        #;(error 'jpad-shape-layout "too large for the parent" rem-wd rem-ht info)
        (jpad-info->fpad info)
        ;odd rem goes on the right or bottom
        (let* ((dst-left (/ rem-wd 2)) (dst-right (- rem-wd dst-left))
               (dst-top (/ rem-ht 2)) (dst-bottom (- rem-ht dst-top))
               (justified-dims (list dst-top dst-bottom dst-left dst-right)) )
          (jpad-info->fpad info justified-dims) ) ) ) )

(register-shape-method 'jpad 'size class-shape-size)
(register-shape-method 'jpad 'cardinality (lambda (shp info) 1))
(register-shape-method 'jpad 'elements (lambda (shp info) `(,(info-shape info))))
(register-shape-method 'jpad 'layout class-shape-layout)
(register-shape-method 'jpad 'justified? (lambda (shp info) #f))

) ;module (s9fes char-canvas shape jpad)