(declare
  (bound-to-procedure
    ##sys#lambda-info? ##sys#decorate-lambda ##sys#make-lambda-info))

(module (s9fes char-canvas shape shape)

(;export
  ;
  ONE-DIMS
  pad-dims
  pad-chars
  wh-class-shape-size
  ;
  register-shape
  registered-shape?
  #;registered-shape-creator
  register-shape-method
  registered-shapes
  registered-shape-methods
  ;
  shape-class shape-coords
  shape-creator
  shape-size shape-center shape-center-rect
  shape-cardinality shape-elements shape-contains? shape-fold
  shape-layout shape-justified?
  shape-show
  ;
  shape-reify shape-reflect
  create-shape
  shape-call
  ;
  shape-read shape-write
  shape-load shape-store
  shapes-read shapes-write
  shapes-load shapes-store
  ;
  ;internal
  ^info ^real-info ^virtual-info
  @info @info-class @info-coords @info-args
  shape-lambda-info!)

(import scheme utf8)
(import (chicken base))
(import (chicken fixnum))
(import (chicken type))
(import (only (chicken io) read-list))
(import (s9fes char-canvas rect))
(import (only (srfi 1) list-copy fold every lset-intersection))

;moremacros
(define-syntax define-syntax-rule
  (er-macro-transformer
    (lambda (x r c)
      (if (or (not (pair? (cdr x)))
              (not (pair? (cadr x)))
              (not (symbol? (caadr x))))
          (syntax-error "invalid argument syntax")
          (let ((name (caadr x))
                (args (cdadr x)))
            `(,(r 'define-syntax) ,name
              (,(r 'syntax-rules) ()
                ((_ . ,(cdadr x)) ,@(cddr x)))))))))

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

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

(: pad-dims (integer integer integer integer -> pad-dims))
(: pad-chars (char char char char -> pad-chars))

(: register-shape (symbol shape-creator #!optional real-shape-creator -> void))
(: registered-shape? (symbol -> boolean))
(: registered-shape-creator (symbol symbol -> (or false shape-creator)))
(: register-shape-method (symbol symbol ((or false shape-plotter) (or false shape-info) #!rest * -> . *) -> void))

(: registered-shapes (-> (list-of symbol)))
(: registered-shape-methods (symbol -> (list-of symbol)))

(: shape-new (symbol shape-creator ;#!optional real-shape-creator
                                   #!rest #;method-plist
                                   -> void))

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

(: shape-creator (shape-plotter #!optional symbol -> (or false shape-creator)))

(: shape-size (shape-plotter -> integer integer))
(: shape-center (shape-plotter -> integer integer integer integer))
(: shape-center-rect (shape-plotter -> rect))

(: shape-cardinality (shape-plotter -> fixnum))
(: shape-elements (shape-plotter -> shape-plotters))
(: shape-contains? (shape-plotter shape-plotter -> fixnum))
(: shape-fold (shape-plotter (shape-plotter 'a -> 'a) 'a -> 'a))

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

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

(: shape-reflect (shape-plotter -> shape-info))
(: shape-reify (shape-info -> shape-plotter))

(: shape-call (shape-plotter symbol #!rest -> . *))

(: shape-read (#!optional input-port -> shape-plotter))
(: shape-write (shape #!optional output-port -> void))

(: shape-load (pathname -> shape-plotter))
(: shape-store (shape-plotter pathname -> void))

(: shapes-read (#!optional input-port fixnum -> shape-plotters))
(: shapes-write (shape-plotters #!optional output-port -> void))

(: shapes-load (pathname #!optional fixnum -> shape-plotters))
(: shapes-store (shape-plotters pathname -> void))

;shape last since lambda definition
(: shape-lambda-info! ((or string shape-plotter) #!optional shape-plotter -> shape-plotter))

;;

(define-syntax-rule (^info ?cls ?crd ?arg ...)    (vector ?cls ?crd ?arg ...))
(define-syntax-rule (^real-info ?cls ?arg ...)    (^info ?cls 'real ?arg  ...))
(define-syntax-rule (^virtual-info ?cls ?arg ...) (^info ?cls 'virtual ?arg  ...))

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

(define-syntax-rule (@info-args ?vec) (cddr (vector->list ?vec)))

;;

(define-inline (method-alist defs) (cddr defs))
(define-inline (set-method-alist! defs ms) (set! (cddr defs) ms))

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

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

(define (lookup-shape id shps)
  (let ((defs (*lookup-shape id shps)))
    (or defs
        (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* ((defs (*lookup-shape id shps)))
    (*lookup-method nm defs) ) )

(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 ONE-DIMS (%make-dims 1 1 1 1))

;NOTE the warning below occurred when pad-dims & pad-chars were exported along
;w/ pad-dimensions & pad-characters and pad-dims & pad-chars as aliases
;
;Warning: Cannot export `pad-dims' because it is a type abbreviation.

(define (pad-dims t b l r) (%make-dims t b l r))
(define (pad-chars 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

;NOTE assumes small # of number of shape-classes
(define +shapes+ '())

(define (register-shape id virtor #!optional realor)
  ;allow overwrite
  (set! +shapes+ (alist-update! id `(,virtor ,realor) +shapes+ eq?)) )

(define (register-shape-method id nm fn)
  (let ((defs (lookup-shape id +shapes+)))
    ;whack it in place!
    (set-method-alist! defs (alist-update! nm fn (method-alist defs) eq?)) ) )

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

(define (registered-shape-creator id coords)
  (let ((defs (lookup-shape id +shapes+)))
    (case coords
      ((real REAL)        (the (or false real-shape-creator) (cadr defs)))
      ((virtual VIRTUAL)  (the shape-creator (car defs)))
      (else
        (error 'registered-shape-creator "bad argument type - not a symbol virtual | real" coords))) ) )

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

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

;; Meta-Class method

(define (shape-new id ctor . args)
  (assert (not (registered-shape? id)) 'shape-new "existing shape" id)
  (assert (procedure? ctor) 'shape-new "bad argument type - not procedure" id ctor)
  (assert (not (null? args)) 'shape-new "missing required methods" id args)
  (let-optionals* args ((real-ctor #f) args)
    (assert (even? args) 'shape-new "bad argument type - not plist" args)
    (let loop ((args args) (nms '()))
      (let ((nm (car args)) (fn (cadr args)))
        (assert (symbol? nm) 'shape-new "bad argument type - not symbol" id nm)
        (assert (procedure? fn) 'shape-new "bad argument type - not procedure" id nm fn)
        (register-shape-method id nm fn)
        (if (null? args)
            ;then check all done
            (let ((nms (cons nm nms)))
              (for-each (lambda (nm)
                          (assert (assq nm nms) 'shape-new "missing required method" nm))
                        '(size show))
              (for-each (lambda (optn)
                          (assert (let ((some-optn (lset-intersection eq? optn nms)))
                                    (or (null? some-optn)
                                        (every (cut memq <> some-optn) optn)) )
                            'shape-new "missing optional method of set" nm optn))
                        '((reflect reify) (layout justified?))) )
            ;else more to do
            (loop (cddr args) (cons nm nms))) ) ) ) )

;; procedure-decoration

(define (update-lambda-decoration! proc pred decr #!optional def)
  (##sys#decorate-lambda
    proc
    ##sys#lambda-info?
    (lambda (to-proc at-i)
      (assert (eq? to-proc proc)
        'update-lambda-decoration!
        "must be decorating same procedrue" to-proc proc)
      (let* ((val (##sys#slot to-proc at-i))
             ;when new use def; (void) can't be true
             (val (if (pred val) val def)) )
        (##sys#setslot to-proc at-i (decr val)) )
      to-proc)) )

;(shape-plotter-lambda-info-update! "(hgroup #!optional cv x0 y0)"
;                                   (lambda (#!optional cv x0 y0) ...))

(define (make-shape-lambda-info-string uniqid class coords args)
  (string-append "("
                   (symbol->string uniqid)
                   " "
                   (let ((cls (symbol->string class)))
                     (if (eq? 'virtual coords) cls
                         (string-append cls "-" (symbol->string coords))) )
                   " "
                   args
                 ")") )

(define (make-shape-lambda-info shp args)
  (let ((info (shp)))
    (##sys#make-lambda-info
     (make-shape-lambda-info-string (car (procedure-information shp))
                                    (@info-class info)
                                    (@info-coords info)
                                    args)) ) )

(define (shape-lambda-info! args #!optional shp)
  ;string shape-plotter | shape-plotter
  (unless shp
    (set! shp (the shape-plotter args))
    (set! args "#!optional cv x0 y0") )
  (define (update-info! _)
    ;ignore existing lambda-info
    (make-shape-lambda-info shp args) )
  (update-lambda-decoration! shp ##sys#lambda-info? update-info!) )

;; instance methods

;not virtual
(define (shape-class shp)   (@info-class (shp)))
(define (shape-coords shp)  (@info-coords (shp)))

(define (shape-creator shp #!optional (coords 'virtual))
  (registered-shape-creator (@info-class (shp)) coords) )

;;

;virtual, required
(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)))))) )

;not virtual
(define (shape-center-rect shp)
  (receive (wdmf wdmc htmf htmc) (shape-center shp)
    (rect wdmf htmf (+ (- wdmc wdmf) 1) (+ (- htmc htmf) 1))) )

;;

(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-contains? shpa shpb)
  (shape-fold shpa (lambda (shp t?) (and t? (eq? shp shpb))) #t) )

(define (shape-fold shp fn seed)
  (perform-shape-optional-method shp 'fold '() +shapes+
    (lambda (shp info)
      (if (zero? (shape-cardinality shp)) seed
          ;else elements to check
          ;use srfi-1 fold & not foldl since shape-* routines
          ;have the shape 1st so same signature
          (fold fn seed (shape-elements shp)))) ) )

;;

;FIXME layout should take wd & ht (as original, dip)
(define (shape-layout shp bb #!optional parent)
  (perform-shape-optional-method shp 'layout `(,bb ,parent) +shapes+
    (lambda (shp info bb parent) shp)) )

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

;;

;FIXME virtual mehtod?
(define (shape-show shp cv x y)
  (perform-shape-optional-method shp 'show `(,cv ,x ,y) +shapes+
    (lambda (shp info) (shp cv x y))) )

;;

(define (shape-reflect shp)
  (perform-shape-optional-method shp 'reflect '() +shapes+
    ;FIXME not a deep-copy
    (lambda (shp info) (list-copy info)) ) )

(define (shape-reify info)
  (let* ((id (@info-class info))
         (args (@info-args info))
         (fn (lookup-shape-optional-method id 'reify-args +shapes+))
         (ctor (registered-shape-creator id (@info-coords info))) )
    (if ctor
        (apply ctor (if fn (fn #f #f args) args))
        (error 'shape-reify "no such creator" id (@info-coords info))) ) )

(define-syntax create-shape
  (syntax-rules ()
    ;
    ((create-shape (?id ?coords) ?arg0 ...)
      (shape-reify (^info '?id '?coords ?arg0 ...)) )
    ;
    ((create-shape ?id ?arg0 ...)
      (create-shape (?id virtual) ?arg0 ...) ) ) )

(define (shape-call shp nm . args)
  (perform-shape-method shp nm args +shapes+) )

;;

; Single

(define (shape-read #!optional (in (current-input-port)))
  (let ((obj (read in)))
    ;pass-thru
    (if (eof-object? obj) obj
        (shape-reify obj)) ) )

(define (shape-write shp #!optional (out (current-output-port)))
  (write (shape-reflect shp) out) )

(define (shape-load pn)
  (with-input-from-file pn shape-read) )

(define (shape-store shp pn)
  (with-output-to-file pn (cut shape-write shp)) )

; Multiple

(define (shapes-read #!optional (in (current-input-port)) (max most-positive-fixnum))
  (read-list in shape-read max) )

(define (shapes-write shps #!optional (out (current-output-port)))
  (for-each (cut shape-write <>) shps) )

(define (shapes-load pn #!optional (max most-positive-fixnum))
  (with-input-from-file pn (cut shapes-read (current-input-port) max)) )

(define (shapes-store shps pn)
  (with-output-to-file pn (cut shapes-write shps)) )

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