(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-read shape-write
  shape-load shape-store
  shapes-read shapes-write
  shapes-load shapes-store
  ;
  ;internal
  ^info @info ^real-info ^virtual-info
  @info-class @info-coords @info-args)

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

;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 real-shape-creator -> void))
(: registered-shape? (symbol -> boolean))
(: registered-shape-creator (symbol symbol -> 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-class (shape-plotter -> symbol))
(: shape-coords (shape-plotter -> symbol))

(: shape-creator (shape-plotter #!optional symbol -> 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 -> (list-of shape-plotter)))
(: shape-contains? (shape-plotter shape-plotter -> fixnum))
(: shape-fold (shape-plotter (shape-plotter 'a -> 'a) 'a -> 'a))

(: shape-layout (shape-plotter rect -> 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-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 -> (list-of shape-plotter)))
(: shapes-write ((list-of shape-plotter) #!optional output-port -> void))

(: shapes-load (pathname #!optional fixnum -> (list-of shape-plotter)))
(: shapes-store ((list-of shape-plotter) pathname -> void))

;;

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

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

;;

;FIXME virtual mehtod?
(define (shape-show shp cv x y)
  (perform-shape-optional-method shp 'show '() +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+)) )
    (apply (registered-shape-creator id (@info-coords info))
           (if fn (fn #f #f args) args)) ) )

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

;;

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