(module (s9fes char-canvas shape shape)

(;export
  ;
  register-shape
  register-shape-method
  registered-shapes
  registered-shape-methods
  ;
  shape-size
  shape-cardinality
  shape-elements
  shape-layout
  shape-show
  shape-fold)

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

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

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

(: register-shape (symbol -> void))
(: register-shape-method (symbol symbol (list -> . *) -> void))
(: registered-shapes (-> (list-of symbol)))
(: registered-shape-methods (symbol -> (list-of symbol)))

(: shape-size (shape-plotter -> integer integer))
(: shape-cardinality (shape-plotter -> fixnum))
(: shape-elements (shape-plotter -> (list-of shape-plotter)))
(: shape-layout (shape-plotter -> shape-plotter))
(: shape-show (shape-plotter canvas integer integer -> canvas))
(: shape-fold (shape-plotter (shape-plotter 'a -> 'a) 'a -> 'a))

;;

(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 shps)
  (let* ((info (shp))
         (fn (lookup-shape-method (car info) nm shps)) )
    (fn info) ) )

(define (perform-shape-optional-method shp nm shps thunk)
  (let* ((info (shp))
         (fn (lookup-shape-optional-method (car info) nm shps)) )
    (if fn (fn info)
        (thunk)) ) )

;;

;catalog operations
(define register-shape)
(define register-shape-method)
(define registered-shapes)
(define registered-shape-methods)
;instance methods
(define shape-size)
(define shape-cardinality)
(define shape-elements)
(define shape-layout)
(define shape-show)
(define shape-fold)
;catalog
(let ((+shapes+ '()))

  ;; catalog

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

  (set! register-shape-method
    (lambda (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 (cons `(,nm . ,fn) ms) +shapes+ eq?)) ) ) )

  (set! registered-shapes (lambda () (map car +shapes+)))

  (set! registered-shape-methods (lambda (id) (map car (lookup-shape id +shapes+))))

  ;; instance methods

  (set! shape-show
    (lambda (shp cv x y)
      (let* ((info (shp))
             (fn (lookup-shape-optional-method (car info) 'show +shapes+)) )
        (if fn (fn cv x y)
            (lambda () (shp cv x y))) ) ) )

  (set! shape-fold (lambda (shp fn seed) (fold fn seed (shape-elements shp))))

  (set! shape-size (lambda (shp) (perform-shape-method shp 'size +shapes+)))

  (set! shape-cardinality
    (lambda (shp)
      (perform-shape-optional-method shp 'elements +shapes+ (lambda () 0))))

  (set! shape-elements
    (lambda (shp)
      (perform-shape-optional-method shp 'elements +shapes+ (lambda () `()))))

  ;`jpad' => `hpad',
  (set! shape-layout
    (lambda (shp)
      (perform-shape-optional-method shp 'elements +shapes+ (lambda () shp)))) )

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