(module (s9fes char-canvas shape shape)

(;export
  ;
  pad-dimensions
  pad-characters
  wh-class-shape-size
  ;
  register-shape
  register-shape-method
  registered-shape?
  registered-shapes
  registered-shape-methods
  ;
  shape-class shape-coords
  shape-size shape-center
  shape-cardinality
  shape-elements
  shape-layout
  shape-show
  shape-fold
  shape-justified?
  ;internal
  ^info @info ^real-info ^virtual-info @info-class @info-coords)

(import scheme utf8)
(import (chicken base))
(import (chicken type))
(import (only (srfi 1) fold))

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

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

#; ;UNUSED
(define-type shape-entry (pair symbol (list-of symbol)))

(: register-shape (symbol -> void))
(: register-shape-method (symbol symbol (shape-plotter shape-info #!rest * -> . *) -> void))
(: registered-shape? (symbol -> boolean))
(: registered-shapes (-> (list-of symbol)))
(: registered-shape-methods (symbol -> (list-of symbol)))

(: shape-class (shape-plotter -> symbol))
(: shape-coords (shape-plotter -> symbol))

(: shape-size (shape-plotter -> integer integer))
;ceiling+floor wd ht
(: shape-center (shape-plotter -> integer integer integer integer))
#; ;trivial give -size
(: shape-center (shape-plotter -> real))

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

(: shape-layout (shape-plotter rect -> shape-plotter))
(: shape-justified? (shape-plotter -> boolean))

(: shape-show (shape-plotter canvas integer integer -> canvas))

(: shape-fold (shape-plotter (shape-plotter 'a -> 'a) 'a -> 'a))

;;

(define-syntax ^info (syntax-rules () ((^info ?cls ?nam ?arg ...) (vector '?cls '?nam ?arg ...))))
(define-syntax ^real-info (syntax-rules () ((^real-info ?cls ?arg ...) (^info ?cls real ?arg  ...))))
(define-syntax ^virtual-info (syntax-rules () ((^virtual-info ?cls ?arg ...) (^info ?cls virtual ?arg  ...))))

(define-syntax @info (syntax-rules () ((@info ?idx ?vec) (vector-ref ?vec (+ ?idx 2)))))
(define-syntax @info-class (syntax-rules () ((@info-class ?vec) (@info -2 ?vec))))
(define-syntax @info-coords (syntax-rules () ((@info-coords ?vec) (@info -1 ?vec))))

;;

(define (*lookup-method nm ms) (alist-ref nm ms eq?))
(define (*lookup-shape id shps) (alist-ref id shps eq?))

(define (lookup-method id nm ms)
  (let ((fn (*lookup-method nm ms)))
    (or fn
        (error "unknown shape method" id nm)) ) )

(define (lookup-shape id shps)
  (let ((ms (*lookup-shape id shps)))
    (or ms
        (error "unknown shape" id)) ) )

(define (lookup-shape-method id nm shps)
  (lookup-method id nm (lookup-shape id shps)) )

(define (lookup-shape-optional-method id nm shps)
  (and-let* ((ms (*lookup-shape id shps)))
    (*lookup-method nm ms) ) )

(define (perform-shape-method shp nm args shps)
  (let* ((info (shp))
         (fn (lookup-shape-method (@info-class info) nm shps)) )
    (apply fn shp info args) ) )

(define (perform-shape-optional-method shp nm args shps def-fn)
  (let* ((info (shp))
         (fn (or (lookup-shape-optional-method (@info-class info) nm shps)
                 def-fn)) )
    (apply fn shp info args) ) )

;;

(define (pad-dimensions t b l r) (%make-dims t b l r))
(define (pad-characters t b l r) (%make-chars t b l r))

(define (wh-class-shape-size shp info)
  (let ((w (the integer (@info 0 info))) (h (the integer (@info 1 info))))
    (values w h) ) )

;; catalog

(define +shapes+ '())

(define (register-shape id)
    (unless (alist-ref id +shapes+ eq?)
      (set! +shapes+ (alist-update! id '() +shapes+ eq?)) ) )

(define (register-shape-method id nm fn)
    (let ((ms (alist-ref id +shapes+ eq? '())))
      ;don't bother to remove stale items from method list
      (set! +shapes+
            (alist-update! id `((,nm . ,fn) . ,ms) +shapes+ eq?))) )

(define (registered-shape? id) (and (*lookup-shape id +shapes+) #t))

(define (registered-shapes) (map car +shapes+))

(define (registered-shape-methods id) (map car (lookup-shape id +shapes+)))

;; instance methods

;FIXME optional method
(define (shape-fold shp fn seed) (fold fn seed (shape-elements shp)))

(define (shape-show shp cv x y)
  (perform-shape-optional-method shp 'show '() +shapes+
    (lambda (shp info) (shp cv x y))) )

(define (shape-class shp) (@info-class (shp)))

(define (shape-coords shp) (@info-coords (shp)))

(define (shape-size shp) (perform-shape-method shp 'size '() +shapes+))

(define (shape-center shp)
  (perform-shape-optional-method shp 'center '() +shapes+
    (lambda (shp info)
      (receive (wd ht) (shape-size shp)
        (let ((wdm (/ wd 2)) (htm (/ ht 2)))
          (values (floor wdm) (ceiling wdm)
                  (floor htm) (ceiling htm)))))) )

(define (shape-cardinality shp)
  (perform-shape-optional-method shp 'cardinality '() +shapes+ (lambda (shp info) 0)) )

(define (shape-elements shp)
  (perform-shape-optional-method shp 'elements '() +shapes+ (lambda (shp info) `())) )

(define (shape-layout shp bb)
  (perform-shape-optional-method shp 'layout `(,bb) +shapes+ (lambda (shp info bb) shp)) )

(define (shape-justified? shp)
  (perform-shape-optional-method shp 'justified? '() +shapes+ (lambda (shp info) #t)) )

) ;(module (s9fes char-canvas shape shape)