; Author: Juergen Lorenz ; ju (at) jugilo (dot) de
;
; Copyright (c) 2018-2020, Juergen Lorenz
; All rights reserved.
; 
; Redistribution and use in source and binary forms, with or without
; modification, are permitted provided that the following conditions are
; met:
; 
; Redistributions of source code must retain the above copyright
; notice, this list of conditions and the following dispasser.
; 
; Redistributions in binary form must reproduce the above copyright
; notice, this list of conditions and the following dispasser in the
; documentation and/or other materials provided with the distribution.
; 
; Neither the name of the author nor the names of its contributors may be
; used to endorse or promote products derived from this software without
; specific prior written permission. 
; 
; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS
; IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED
; TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A
; PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT
; HOLDERS OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
; SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED
; TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR
; PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF
; LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING
; NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS
; SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.


#|[
This library implements simple generic functions.  They are ordinary
procedures with state, hence closures. The state consists of a cell
containing a method tree, which in turn consists of selectors and
methods.

The selectors are specialized predicates, which check the arguments of
the generic function in sequence and choose the corresponding method.
This method is than invoked on the generic's arguments.  Selectors are
able not only to check one but many arguments, so that rest arguments of
variadic functions are handled properly.  Moreover, when called without
arguments, they return a name and a parent selector, the latter
controlling the insertion point of a new method-tree-item in the tree:
Arguments of more specific or often used types should be checked and
found before less specific or seldom used ones. Methods in turn ar
ordinary procedures of at least one argument with special names.

The two fundamental macros are define-generic and define-method. The
former creates a closure with state a one-item method-tree, which can be
enhanced by the latter. This closure can then be invoked indirectly by
searching its method-tree and applying the first matching method.  The
latter macro inserts a method-tree-item into the former's method-tree at
the proper place controlled by the parents of the item's selectors.

Denoting selectors with two trailing question marks and using my
enhanced dot notation, two dots denote zero or one of the symbol to the
left, three dots zero or more, four dots one or more, their syntax is as
follows:

  (define-generic (Name x ....) body ....) 
  (define-generic (Name x ... . xs) body ....)

for fixed or variable argument lists respectively and

  (define-method (Name (x x??) ....) body ....)
  (define-method (Name (x x??) ... xs xs??) body ....)

How can define-method access local data of define-generic's Name? It's
simple.  Generic functions need at least one argument. In particular,
rest paramenter lists can't be empty. Otherwise, there is nothing to
dispatch on.  Hence we can use a thunk version of the generic function
Name to export its actual method-tree, which is packaged into a cell.
So define-method knows where to put the new method-tree-item and in
which position to insert it.

Since a generic function can export its method-tree, it can be
inspected. The function method-tree-show will do that in a human
readable form.

Note that we spoke about a method tree, not a method list. The reason,
of course, is efficiency of method dispatch. This has consequences to the
design of generic functions: The argument which probably varies the
most, should appear at the last position. Maybe, this is the reason,
why Clojure has Drop and Take functions with the sequence argument
last, not with the list argument first as in list-tail.

The format of a method-table of depth 2 is as follows

  ((x0?? (x00?? . proc.0.00)
         (x01?? . proc.0.01)
         ...)
   (x1?? (x10?? . proc.1.10)
         (x11?? . proc.1.11)
         ...)
   ...)

Not all positions of such a table need be occupied. For example,
consider the following definitions

  (define-generic (Add x y) (+ x y))
  (define-method  (Add (x number??) (y number??)) (+ x y))
  (define-method  (Add (x fixnum??) (y fixnum??)) (fx+ x y))

Since number?? is a parent of fixnum?? this would result in the table

  ((fixnum?? (fixnum?? . ?))
   (number?? (number?? . ?))
   (any?? (any?? . ?)))

In a naive implementation, we'd check the first argument against the
cars of the table and then the second against the cars of the resulting
subtables. But that would fail, if the first argument is a fixnum and
the second a number. Instead we would like to have dispatch to result in
+ in that case. In other words, we need backtracking, and that
complicates matters.

]|#

(module generic-functions
  (generics define-generic generic-method-tree
   generic? generic-variadic? generic-arity
   make-method method? method method-name proc-name
   make-selector selector selector? selector-parent selector-parents selector-name
   selector-predicate any?? number?? integer?? fixnum?? index??
   flonum?? list?? vector?? string?? pseudo-list?? pair?? procedure?? 
   define-method method-tree-item method-tree-item?
   method-tree? method-tree-depth method-tree-show
   method-tree-dispatch method-tree-insert)

(import scheme
        (only (chicken base) list-of? case-lambda receive define-values
              gensym error print fixnum? flonum? symbol-append cut)
        (only (chicken fixnum)  fx< fx=)
        (only (chicken condition) condition-case)
        (only generic-helpers 1+ 1- index? project reverse* map* any?
              all? ?? symbol-dispatcher)
        (only simple-cells cell))

;;;;;;;;; methods: special named procedures ;;;;;;;;;;;

;;; (make-method name proc)
;;; (method? xpr)
;;; ----------------------
;;; the first makes an method from procedure proc and names it
;;; the second is the type predicate
(define-values (make-method method?)
  (let ((type (gensym 'method)) (result (gensym 'method)))
       ; gensym is not referentially transparent
    (values
      (lambda (name proc)
        (lambda args
          (cond
            ((null? args) name)
            ((and (null? (cdr args))
                  (eq? (car args) type))
             result)
            (else
              (apply proc args)))))
      (lambda (xpr)
        (and (procedure? xpr)
             (condition-case (eq? (xpr type) result)
               ((exn) #f))))
      )))

(define-syntax method
  (syntax-rules ()
    ((_ proc)
     (make-method 'proc proc))))

(define (method-name act)
  (act))

;;;;;;;;; selectors: special named predicates ;;;;;;;;;;;

;;; (make-selector pred name parent-name)
;;; (selector? xpr)
;;; -------------------------------------
;;; the first makes a selector from predicate pred
;;; and two symbols,
;;; the second is the type predicate
(define-values (make-selector selector?)
  (let ((type (gensym 'selector)) (result (gensym 'selector)))
    (values
      (lambda (pred name parent)
        (lambda args
          (cond
            ((null? args)
             (cons name parent))
            ((null? (cdr args))
             (if (eq? (car args) type) ; can't happen externally
               result
               (pred (car args))))
            (else
              (let loop ((args args))
                (cond
                  ((null? args) #t)
                  ((pred (car args))
                   (loop (cdr args)))
                  (else #f)))))))
      (lambda (xpr)
        (and (procedure? xpr)
             (condition-case (eq? (xpr type) result)
               ((exn) #f))))
      )))

(define-syntax selector
  (syntax-rules ()
    ((_ pred parent)
     ;(make-selector pred (symbol-append 'pred '?) parent))))
     (make-selector pred 'pred parent))))

(define (selector-name sel??)
  (car (sel??)))
(define (selector-parent sel??)
;(define (selector-parent-name sel??)
  (cdr (sel??)))
(define (selector-predicate sel??)
  (lambda (xpr) (sel?? xpr)))

;;; (selector-parents sel??)
;;; ------------------------
;;; returns the parents of selector sel??
(define (selector-parents sel??)
  (let loop ((parent (selector-parent sel??)) (result '()))
    (if parent
      (loop (selector-parent parent) (cons parent result))
      (reverse result))))

(define (proc-name proc)
  (cond
    ((selector? proc) (selector-name proc))
    ((method? proc) (method-name proc))
    (else proc)))

;;; (any?? xpr)
;;; -----------
;;; selector without parent which always returns #t
;(define (any? xpr) #t)
(define any?? (selector any? #f))

;;; (number?? xpr)
;;; --------------
;;; number selector
(define number?? (selector number? any??))

;;; (integer?? xpr)
;;; ---------------
;;; integer selector
(define integer?? (selector integer? number??))

;;; (fixnum?? xpr)
;;; --------------
;;; fixnum selector
(define fixnum?? (selector fixnum? integer??))

;;; (flonum?? xpr)
;;; --------------
;;; flonum selector
(define flonum?? (selector flonum? number??))

;;; (pair?? xpr)
;;; ------------
;;; pair selector
(define pair?? (selector pair? any??))

;;; (vector?? xpr)
;;; --------------
;;; vector selector
(define vector?? (selector vector? pair??))

;;; (string?? xpr)
;;; --------------
;;; string selector
(define string?? (selector string? vector??))

;;; (list?? xpr)
;;; ------------
;;; list selector
(define list?? (selector list? string??))

;;; (pseudo-list?? xpr)
;;; -------------------
;;; pseudo-list selector
(define pseudo-list?? (selector any? any??))

;;; (procedure?? xpr)
;;; -----------------
;;; procedure selector
(define procedure?? (selector procedure? any??))

;;; (index?? xpr)
;;; -------------
;;; non-negative fixnum selector
(define index?? (selector index? any??))

;;;;;;;;; method-trees ;;;;;;;;;;;

;;;(method-tree-item meth sel?? ....)
;;;----------------------------------
;;;returns a method-tree-item from its arguments
(define (method-tree-item meth sel?? . sels??)
  (let recur ((sels?? (cons sel?? sels??)))
    (cond
      ((null? sels??) (?? meth method?))
      ((null? (cdr sels??))
       (cons (?? (car sels??) selector?)
             (?? meth method?)))
      (else
        (list (?? (car sels??) selector?)
              (recur (cdr sels??)))))))

;;; (method-tree-item? xpr)
;;; -----------------------
;;; type predicate
(define (method-tree-item? xpr)
  (and (pair? xpr)
       (selector? (car xpr))
       (or (method? (cdr xpr))
           (method-tree? (cdr xpr)))))

;;; (method-tree? xpr)
;;; ------------------
;;; type predicate
(define (method-tree? xpr)
  (and (not (null? xpr))
       ((list-of? method-tree-item?) xpr)))

;;; (method-tree-depth tree)
;;; ------------------------
;;; returns the depth of the tree argument
(define (method-tree-depth tree)
  (let loop ((tree (?? tree method-tree?)) (result 0))
    (cond
      ((null? tree) result)
      ((and (pair? tree)
            (pair? (car tree))
            (method-tree? (cdar tree)))
       (loop (cdar tree) (1+ result)))
      (else
       (1+ result)))))

;;; (method-tree-show tree)
;;; -----------------------
;;; returns a readable image of the tree
(define (method-tree-show tree)
  (map* proc-name (?? tree method-tree?)))

;;; (method-tree-dispatch tree arg . args)
;;; --------------------------------------
;;; searches the tree according to the types of arguments args
;;; and returns the matching method, if any, or #f;
;;; handles backtracking as needed
(define (method-tree-dispatch tree . args)
  (let* ((depth (method-tree-depth (?? tree method-tree?)))
         (args (?? args (lambda (x) (<= depth (length x))))))
    (if (fx= depth 1)
      ;; no backtracking necessary
      (let loop ((tree tree))
        (cond
          ((null? tree) #f)
          ((apply (caar tree) args)
           (cdar tree))
          (else (loop (cdr tree)))))
      ;; backtracking is organized by storing the
      ;; backtrack trees in a vector and manipulating
      ;; that vector
      (let ((trees (make-vector (1+ depth) #f))
            (vargs (make-vector depth #f)))
        ;; initialize trees and vargs
        (vector-set! trees 0 tree)
        (do ((k 0 (1+ k))
             (args args (cdr args)))
          ((fx= k depth) vargs)
          (if (fx= k (1- depth))
            ;; store rest args
            (vector-set! vargs k args)
            ;; store inner arg
            (vector-set! vargs k (car args))))
        (letrec (
          (dispatch!
            ;; manipulate the trees vector
            ;; and return its index argument changed accordingly
            (lambda (k)
              ;; bounds will be checked by
              ;; the outer loop
              (let ((tree (vector-ref trees k))
                    (arg (vector-ref vargs k))
                    (k+ (1+ k)))
                (and tree
                     (vector-set! trees
                                  k+
                                  (if (fx= k (1- depth))
                                    (and (apply (caar tree) arg)
                                         (cdar tree))
                                    (and ((caar tree) arg)
                                         (cdar tree))))
                     (vector-set! trees
                                  k
                                  (if (null? (cdr tree))
                                    #f
                                    (cdr tree))))
                (if (vector-ref trees k+)
                  k+
                  (if tree k (1- k))))))
          )
          ;;; outer loop: populate trees with dispatch!
          (do ((k 0 (dispatch! k)))
            ((or (fx< k 0) (fx= k depth))
             (if (fx< k 0)
               #f
               (vector-ref trees k)))
            ))))))

;;; (method-tree-insert tree item)
;;; ------------------------------
;;; inserts the item into the tree at the location
;;; governed by the selectors in item
(define (method-tree-insert tree item)
  (let ((depth (method-tree-depth (?? tree method-tree?)))
        (sel (car (?? item method-tree-item?))))
    (if (fx= (method-tree-depth tree) (method-tree-depth (list item)))
      (let ((parents (selector-parents sel)))
        (let loop ((tail tree) (head '()))
          (cond
            ((null? tail)
             ;; insert at end
             (reverse (cons item head)))
            ((eq? (caar tail) sel)
             (if (fx= depth 1)
               ;; replace (car tail)
               (reverse* head (cons item (cdr tail)))
               ;; step down
               (reverse* head
                         (cons (cons sel
                                     (method-tree-insert (cdar tail)
                                                         (cadr item)))
                               (cdr tail)))))
            ((memq (caar tail) parents)
             ;; insert before tail
             (reverse* head (cons item tail)))
            (else
              (loop (cdr tail) (cons (car tail) head))))))
      (error 'method-tree-insert
             "depth mismatch"
             tree
             item))))

;;;;;;;;;;;;;;;; generics ;;;;;;;;;;;;;;;;;

;;; (define-generic (Name x ....) body ....) 
;;; (define-generic (Name x ... . xs) body ....)
;;; -------------------------------------------------
;;; Creates a generic function Name with one method from arguments x
;;; .... or x ... . xs and body ....
;;; The state of this generic function consists of a cell 
;;; containing a method tree;
;;; the method tree is exported, when Name is called as thunk.
(define-syntax define-generic
  (ir-macro-transformer
    (lambda (form inject compare?)
      (let ((signature (cadr form))
            (xpr (caddr form))
            (xprs (cdddr form)))
        (let ((Name (car signature))
              (args (cdr signature)))
          ;; split args
          (receive (fargs varg)
            (let loop ((args args) (fixed '()))
              (cond
                ((pair? args)
                 (loop (cdr args) (cons (car args) fixed)))
                ((null? args)
                  (values (reverse fixed) args))
                (else
                  (values (reverse fixed) args))))
`(define ,Name
   (let (
     (tree
       (cell
         (list
           (apply method-tree-item
                  (make-method
                    (symbol-append
                      (apply symbol-append
                             (map (lambda (x) ',(inject 'any?))
                                  (append ',fargs
                                          ',(if (null? varg)
                                                varg
                                                (list varg)))))
                      ',Name)
                    (lambda ,args ,xpr ,@xprs))
                  ;; compile-time alternative
                  ,(if (null? varg)
                       `(map (lambda (x) any??) ',fargs)
                       `(cons any??
                              (map (lambda (x) any??) ',fargs)))))
         method-tree?))
     (variadic? ,(not (null? varg)))
     )
     (case-lambda
       (() (values tree variadic?))
       ((,@fargs ,@varg)
        ;; compile-time alternative
        ,(if (null? varg)
           `((method-tree-dispatch ((,Name)) ,@fargs) ,@fargs)
           `(apply (apply method-tree-dispatch ((,Name)) ,@fargs ,varg)
                   ,@fargs ,varg))))))
))))))

;;; (define-method (Name (x x??) ....) body ....)
;;; (define-method (Name (x x??) ... xs xs??) body ....)
;;; ----------------------------------------------------
;;; x ... and xs are symbols, x?? ... and xs?? selectors.
;;; Creates a new method from arguments x .... or x ... . xs
;;; and body .... and inserts it into the method-tree of Name at the
;;; proper place marked by the selectors' parents.
(define-syntax define-method
  (syntax-rules ()
    ((_ (Name (x x??) (y y??) ...) xpr . xprs)
     (let ((tree (Name)))
       (tree (method-tree-insert
               (tree)
               (method-tree-item
                 (make-method
                   (symbol-append (selector-name x??)
                                  (selector-name y??)
                                  ...
                                  'Name)
                   (lambda (x y ...) xpr . xprs))
                 x?? y?? ...)))
       (if #f #f)))
    ((_ (Name (x x??) ... zs zs??) xpr . xprs)
     (let ((tree (Name)))
       (tree (method-tree-insert
               (tree)
               (method-tree-item
                 (make-method
                   (symbol-append (selector-name x??)
                                  ...
                                  (selector-name zs??)
                                  'Name)
                   (lambda (x ... . zs) xpr . xprs))
                 x?? ... zs??)))
       (if #f #f)))
    ))

;;; (generic? xpr)
;;; --------------
;;; type predicate
(define (generic? xpr)
  (and (procedure? xpr)
       (condition-case
         (method-tree? ((xpr)))
         ((exn) #f))))

;;; (generic-method-tree Gen)
;;; -------------------------
;;; returns the method-tree of the generic Gen
(define (generic-method-tree Gen)
  ;(map* proc-name (((?? Gen generic?)))))
  (((?? Gen generic?))))

;;; (generic-variadic? Gen)
;;; -----------------------
;;; is the generic function Gen variadic?
(define (generic-variadic? Gen)
  (receive (tree variadic? . rest) ((?? Gen generic?))
    variadic?))

;;; (generic-arity Gen)
;;; -------------------
;;; returns the depth of the generic function's Gen method-tree
(define (generic-arity Gen)
  (method-tree-depth ;(((?? Gen generic?)))))
    (generic-method-tree Gen)))

;;; (generics sym ..)
;;; -----------------
;;; documentation procedure
(define generics
  (symbol-dispatcher '(
    (define-generic
      macro:
      (define-generic (Name (x x??) ....) body ....) 
      (define-generic (Name (x x??) ... xs xs??) body ....)
      "defines a new generic function Name with one anonymous"
      "method from arguments x .... or x ... . xs, selectors"
      "x?? .... or x?? ... xs?? and body ...."
      "The state of this generic consists of a cell containing"
      "a one-item method tree."
      "This state can be accessed by calling Name as a thunk")
    (define-method
      macro:
      (define-method (Name (x x??) ....) body ....)
      (define-method (Name (x x??) ... xs xs??) body ....)
      "inserts an anonymous method constructed from arguments"
      "x .... or x ... . xs, selectors x?? .... or x?? ... xs??"
      "and body .... into the method tree of the generic function"
      "Name at the position determined by selector's parents")
    (generic?
      procedure:
      (generic? xpr)
      "type predicate")
    (generic-method-tree
      procedure:
      (generic-method-tree Gen)
      "returns the method-tree of the generic Gen")
    (generic-variadic?
      procedure:
      (generic-variadic? Gen)
      "is the generic function Gen variadic?")
    (generic-arity
      procedure:
      (generic-arity Gen)
      "returns the arity of the generic function Gen"
      "i.e. the depth of its method tree")
    (method?
      procedure:
      (method? xpr)
      "is xpr a method?")
    (make-method
      procedure:
      (make-method name proc)
      "makes a named procedure from proc")
    (method
      macro:
      (method proc)
      "makes a name procedure from proc")
    (method-name
      procedure:
      (method-name sel??)
      "returns the name of method sel??")
    (selector?
      procedure:
      (selector? xpr)
      "is xpr a selector?")
    (make-selector
      procedure:
      (make-selector pred name parent-name)
      "makes a special predicate from predicate pred"
      "with name and parent-name, which might be #f")
    (selector
      macro:
      (selector pred parent-name)
      "makes a special predicate from predicate pred"
      "and parent-name, which might be #f")
    (selector-name
      procedure:
      (selector-name sel??)
      "returns the name of selector sel??")
    (selector-parent
      procedure:
      (selector-parent sel??)
      "returns the parent of selector sel??")
    (selector-parents
      procedure:
      (selector-parents sel??)
      "returns the parents of selector sel??")
    (selector-predicate
      procedure:
      (selector-predicate sel??)
      "returns the selector's sel?? generating predicate")
    (any??
      procedure:
      (any?? xpr)
      "selector without parent which always returns #t")
    (number??
      procedure:
      (number?? xpr)
      "number selector")
    (integer??
      procedure:
      (integer?? xpr)
      "integer selector")
    (fixnum??
      procedure:
      (fixnum?? xpr)
      "fixnum selector")
    (flonum??
      procedure:
      (flonum?? xpr)
      "flonum selector")
    (list??
      procedure:
      (list?? xpr)
      "list selector")
    (pseudo-list??
      procedure:
      (pseudo-list?? xpr)
      "pseudo-list selector")
    (pair??
      procedure:
      (pair?? xpr)
      "pair selector")
    (vector??
      procedure:
      (vector?? xpr)
      "vector selector")
    (string??
      procedure:
      (string?? xpr)
      "string selector")
    (procedure??
      procedure:
      (procedure?? xpr)
      "procedure selector")
    (index??
      procedure:
      (index?? xpr)
      "non-negative fixnum selector")
    (method-tree-item
      procedure:
      (method-tree-item proc sel?? ....)
      "returns a method tree item from its arguments"
      "a procedure and a non-empty list of selectors")
    (method-tree-item?
      procedure:
      (method-tree-item? xpr)
      "is xpr a method-tree-item?")
    (method-tree?
      procedure:
      (method-tree? xpr)
      "evaluates xpr to a method-tree?")
    (method-tree-depth
      procedure:
      (method-tree-depth tree)
      "returns the depth of a method tree")
    (method-tree-show
      procedure:
      (method-tree-show tree)
      "returns a readable image of the tree")
    (method-tree-dispatch
      procedure:
      (method-tree-dispatch tree . args)
      "searches the tree according to the types of arguments args"
      "and returns the matching method, if any, or #f")
    (method-tree-insert
      procedure:
      (method-tree-insert tree item)
      "inserts the item into the tree at the location"
      "governed by the selectors in item")
    )))

) ; module generics