(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.types")
(include-relative "s9fes.char-canvas.shape.inlines")

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

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

;;

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

;; Private

(define HORZ-JUSTS '(left center right))
(define VERT-JUSTS '(top center botton))

(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-justify-horz info)  (the symbol (@info 2 info)))
(define-inline (*info-justify-vert info)  (the symbol (@info 3 info)))
(define-inline (*info-pad-chars info)     (the pad-chars (@info 4 info)))

(define (jpad-info->fpad info #!optional justified-dims)
;(newline)
;(print "jpad-info->fpad" " info: " info " jdims: " 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-inline (*canvas-draw-jpad cv x0 y0 shape pad-dims jh jv pad-chars)
  ((jpad-info->fpad (^real-info 'jpad shape pad-dims jh jv pad-chars)) cv x0 y0)
  cv )

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

(define-inline (justify-horz jh left right rem-wd)
  (if (zero? rem-wd) (values left right)
      (let ((rem-1/2-wd (/ rem-wd 2)))
        (case jh
          ((left)   (values left                (+ right rem-wd)))
          ((center) (values (floor rem-1/2-wd)  (ceiling rem-1/2-wd)))
          ((right)  (values (+ left rem-wd)     right))
          (else
            (error 'jpad-layout "unknown horizontal justification" jh))) ) ) )

(define-inline (justify-vert jv top bottom rem-ht)
  (if (zero? rem-ht) (values top bottom)
      (let ((rem-1/2-ht (/ rem-ht 2)))
        (case jv
          ((top)    (values top                 (+ bottom rem-ht)))
          ((center) (values (floor rem-1/2-ht)  (ceiling rem-1/2-ht)))
          ((bottom) (values (+ top rem-ht)      bottom))
          (else
            (error 'jpad-layout "unknown vertical justification" jv))) ) ) )

;; Public

(define (real-shape-jpad shape #!optional (pad-dims ONE-DIMS) (jh 'center) (jv 'center) (pad-chars (%bkgd-pad-chars)))
  (assert (%shape? shape) 'real-shape-jpad "bad argument type - not shape" shape)
  (assert (%pad-dims? pad-dims) 'real-shape-jpad "bad argument type - not pad-dims" pad-dims)
  (assert (memq jh HORZ-JUSTS) 'real-shape-jpad "bad argument type - not left | center | right" jh)
  (assert (memq jv VERT-JUSTS) 'real-shape-jpad "bad argument type - not top | center | bottom" jv)
  (assert (%pad-chars? pad-chars) 'real-shape-jpad "bad argument type - not pad-chars" pad-chars)
  (shape-lambda-info!
    (lambda (#!optional cv x0 y0)
      (if cv
          (*canvas-draw-jpad cv x0 y0 shape pad-dims jh jv pad-chars)
          (^real-info 'jpad shape pad-dims jh jv pad-chars) ) ) ) )

(define (shape-jpad shape #!optional (pad-dims ONE-DIMS) (jh 'center) (jv 'center) (pad-chars (%bkgd-pad-chars)))
  (assert (%shape? shape) 'shape-jpad "bad argument type - not shape" shape)
  (assert (%pad-dims? pad-dims) 'shape-jpad "bad argument type - not pad-dims" pad-dims)
  (assert (memq jh HORZ-JUSTS) 'shape-jpad "bad argument type - not left | center | right" jh)
  (assert (memq jv VERT-JUSTS) 'shape-jpad "bad argument type - not top | center | bottom" jv)
  (assert (%pad-chars? pad-chars) 'shape-jpad "bad argument type - not pad-chars" pad-chars)
  (shape-lambda-info!
    (lambda (#!optional cv x0 y0)
      (if cv
          (*canvas-plot-jpad cv x0 y0 shape pad-dims jh jv pad-chars)
          (^virtual-info 'jpad shape pad-dims jh jv pad-chars) ) ) ) )

;;

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

(define (class-shape-layout shp info bb parent)
  (let ((shape (*info-shape info))
         (pad-dims (*info-pad-dims info))
         (jh (*info-justify-horz info))
         (jv (*info-justify-vert info)) )
    (let ((top (%dims-top pad-dims))
           (bottom (%dims-bottom pad-dims))
           (left (%dims-left pad-dims))
           (right (%dims-right pad-dims)) )
      (let-values (((w h) (shape-size shape)))
        ;bb.size - shape.size is apportion-able unless negative then error
        (let ((rem-wd (- (%rect-wd bb) w))    ;(+ left w right)
              (rem-ht (- (%rect-ht bb) h)) )  ;(+ top h bottom)
          ;apportion amongst top bottom left right
          (if (or (negative? rem-wd) (negative? rem-ht))
              ;then can't fit
              (error 'jpad-layout "overflows bounding-box" rem-wd rem-ht bb pad-dims)
              ;else justify
              (let-values (((new-left new-right) (justify-horz jh left right rem-wd))
                           ((new-top new-bottom) (justify-vert jv top bottom rem-ht)) )
                (let ((justified-dims (%make-dims new-top   new-bottom
                                                  new-left  new-right)) )
                  (shape-layout (jpad-info->fpad info justified-dims)
                                bb shp) ) ) ) ) ) ) ) )

(define (class-shape-reify-args no-shp no-info 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-justify-horz info) (*info-justify-vert info)
         (*info-pad-chars info)) )

(register-shape 'jpad shape-jpad real-shape-jpad)
(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))
(register-shape-method 'jpad 'reify-args class-shape-reify-args)
(register-shape-method 'jpad 'reflect class-shape-reflect)

) ;module (s9fes char-canvas shape jpad)