; Author: Juergen Lorenz ; ju (at) jugilo (dot) de
;
; Copyright (c) 2018, 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
procedures, the actual 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 parent selector, which controls 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.

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 x??) ....) body ....) 
  (define-generic (Name (x x??) ... xs xs??) body ....)

for fixed or variable argument lists respectively and -- with the same
syntax

  (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, provided all the selectors are named. This is the reason,
we prefer the macro define-selector over the procedure selector.

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

]|#

(require-library simple-cells)

(module generic-helpers
  (generic-helpers named-lambda proc-name 1+ 1- 0<= mfx+ mfx*
                   reverse* rsplit-with rsplit-at repeat map*)
(import scheme
        (only chicken case-lambda error print fx+ fx- fx* fx<=)
        (only data-structures list-of? o identity ->string))

;;; (generic-helpers sym ..)
;;; ------------------------
;;; documentation procedure
(define generic-helpers
  (let ((alst '(
    (reverse*
      procedure:
      (reverse* rhead tail op)
      (reverse* rhead tail)
      (reverse* rhead)
      "a generalisation of reverse"
      "rhead is reversed onto tail or '()"
      "by means of op or cons.")
    (rsplit-with
      procedure:
      (rsplit-with ok? lst)
      "returns two values by"
      "splitting the list at the first position where ok? returns true"
      "and reversing the head")
    (rsplit-at
      procedure:
      (rsplit-at k lst)
      "returns two values by"
      "splitting the list at position k and reversing the head")
    (repeat
      procedure:
      (repeat k fn)
      "applies function fn k times in sequence")
    (proc-name
      procedure:
      (proc-name proc)
      "returns the name of proc")
    (map*
      procedure:
      (map* fn xs)
      "maps the items of the nested pseudo-list xs via function fn")
    (1+
      procedure:
      (1+ n)
      "add 1 to fixnum n")
    (1-
      procedure:
      (1- n)
      "subtract 1 from fixnum n")
    (0<=
      procedure:
      (0<= n)
      "is fixnum n greater or equal to 0")
    (mfx+
      procedure:
      (mfx+ . nums)
      "add all fixnums in nums")
    (mfx*
      procedure:
      (mfx+ . nums)
      "multiply all fixnums in nums")
    (named-lambda
      macro:
      (named-lambda (name . args) xpr . xprs)
      "a version of lambda which can be used"
      "recursively")
    )))
    (case-lambda
      (()
       (map car alst))
      ((sym)
       (let ((lst (assq sym alst)))
         (if lst
           (for-each print (cdr lst))
           (error 'generic-helpers
                  "not exported" sym)))))))

;;; fixnum operations
(define (1+ n) (fx+ n 1))
(define (1- n) (fx- n 1))
(define (0<= n) (fx<= 0 n))
(define (mfx+ . nums)
  (let loop ((nums nums) (result 0))
    (if (null? nums)
      result
      (loop (cdr nums) (fx+ (car nums) result)))))
(define (mfx* . nums)
  (let loop ((nums nums) (result 1))
    (if (null? nums)
      result
      (loop (cdr nums) (fx* (car nums) result)))))

;;; (named-lambda (name . args) xpr . xprs)
;;; ---------------------------------------
;;; a version of lambda, which can used recursively
(define-syntax named-lambda
  (syntax-rules ()
    ((_ (name . args) xpr . xprs)
     (begin
       (define name (lambda args xpr . xprs))
       name))))

;;; (proc-name proc)
;;; ---------------
;;; return the name of proc or sym
;;; Not portable, depends on Chicken's external representation
;;; of procedures, e.g.
;;; #<procedure (name arg ...)>
;;; #<procedure C_name>
(define (proc-name proc) ; not portable
  (let ((tail
          (let loop ((lst (string->list (->string proc))))
            (if (char=? (car lst) #\space)
              (cdr lst)
              (loop (cdr lst))))))
    (let ((rhead
            (if (char=? (car tail) #\()
              (let loop ((lst (cdr tail)) (result '()))
                (cond
                  ((char=? (car lst) #\))
                   result)
                  ((char=? (car lst) #\space)
                   result)
                  (else
                   (loop (cdr lst) (cons (car lst) result)))))
              (let loop ((lst tail) (result '()))
                (if (char=? (car lst) #\>)
                  result
                  (loop (cdr lst) (cons (car lst) result)))))))
      (string->symbol (list->string (reverse rhead))))))

;;; (reverse* rhead tail op)
;;; (reverse* rhead tail)
;;; (reverse* rhead)
;;; ------------------------
;;; a generalisation of reverse
;;; rhead is reversed onto tail or '()
;;; by means of op or cons.
(define reverse*
  (case-lambda
    ((rhead tail op)
     (let loop ((rhead rhead) (result tail))
       (if (null? rhead)
         result
         (cond
           (((list-of? pair?) result)
            (loop (cdr rhead) (cons (car rhead) result)))
           ((pair? result)
            (loop (cdr rhead) (op (car rhead) result)))
           (else
            (loop (cdr rhead) (cons (car rhead) result)))))))
    ((rhead tail)
     (reverse* rhead tail cons))
    ((rhead)
     (reverse* rhead '()))))

;;; To avoid unnecessary duplication of traversing code it seems
;;; preferable not to reverse the resulting head when splitting
;;; and to use reverse* instead of append

;;; (rsplit-with ok? lst)
;;; ---------------------
;;; returns a list of two items by
;;; splitting the list at the first position where ok? returns true
;;; and reversing the head
(define (rsplit-with ok? lst)
  (let loop ((tail lst) (rhead '()))
    (cond
      ((null? tail)
       (values rhead tail))
      ((ok? (car tail))
       (values rhead tail))
      (else
       (loop (cdr tail) (cons (car tail) rhead))))))

;;; (rsplit-at k lst)
;;; -----------------
;;; returns a list of two items by
;;; splitting the list at position k and reversing the head
(define (rsplit-at k lst)
  (let loop ((n 0) (tail lst) (rhead '()))
    (if (= n k)
      (values rhead tail)
      (loop (1+ n) (cdr tail) (cons (car tail) rhead)))))

;;; (repeat k fn)
;;; -------------
;;; applies function fn k times in sequence
(define (repeat k fn)
  (let loop ((n 0) (result identity))
    (if (= n k)
      result
      (loop (1+ n) (o fn result)))))

;;; (map* fn xs)
;;; ------------
;;; maps the items of the nested pseudo-list xs via function vn
(define (map* fn pl)
  (let recur ((pl pl))
    (cond
      ((null? pl) '())
      ((pair? pl)
       (cons (recur (car pl)) (recur (cdr pl))))
      (else (fn pl)))))

) ; module generic-helpers

(module generics
  (generics define-generic generic-method-tree
            generic? generic-variadic? generic-arity
            define-selector selector selector? selector-parents
            any?? 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 case-lambda receive condition-case define-values
              assert gensym error print fx< fx=)
        (only generic-helpers 1+ 1- 0<= reverse* map* proc-name)
        (only simple-cells cell)
        (only data-structures list-of?))

;;; (generics sym ..)
;;; -----------------
;;; documentation procedure
(define generics
  (let ((alst '(
    (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")
    (selector?
      procedure:
      (selector? xpr)
      "is xpr a selector?")
    (selector
      procedure:
      (selector pred parent??)
      "makes a special predicate from predicate pred"
      "and selector parent??, which might be #f")
    (define-selector
      macro:
      (define-selector name?? pred parent??)
      "defines a special predicate, name??,"
      "frome its base pradicate, pred,"
      "and its parent selector, parent??,"
      "which might be #f")
    (selector-parents
      procedure:
      (selector-parents sel??)
      "returns the parents of selector sel??")
    (any??
      procedure:
      (any?? xpr)
      "selector without parent which always returns #t")
    (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")
    )))
    (case-lambda
      (()
       (map car alst))
      ((sym)
       (let ((lst (assq sym alst)))
         (if lst
           (for-each print (cdr lst))
           (error 'generics
                  "not exported" sym)))))))

;;;;;;;;; selectors ;;;;;;;;;;;
;;;;;;;;; --------- ;;;;;;;;;;;

;;; (selector pred parent??)
;;; ----------------------
;;; makes a selector from predicate pred
;;; and selector parent??, which might be #f
;;; (selector? xpr)
;;; ---------------
;;; type predicate
(define-values (selector selector?)
  (let ((type (gensym 'selector)))
    (values
      (lambda (pred parent??)
        (lambda args
          (if (null? args)
            (values parent?? type)
            (let recur ((args args))
              (if (null? (cdr args))
                (pred (car args))
                (and (pred (car args))
                     (recur (cdr args))))))))
      (lambda (xpr)
        (and (procedure? xpr)
             (condition-case
               (receive (par typ) (xpr)
                 (eq? typ type))
               ((exn) #f)))))))

;;; (define-selector name?? pred parent??)
;;; --------------------------------------
;;; defines a special predicate, name??,
;;; from its base predicate, pred,
;;; and its parent selector, parent??,
;;; which might be #f.
;;; method-tree-items consist of such selectors
;;; and the procedure to be selected.
;;; Note, that contrary to the selector procedure above
;;; define-selector provides a name?? to be used in
;;; method-tree-show, for example
(define-syntax define-selector
  (syntax-rules ()
    ((_ name?? pred parent??)
     (define (name?? . args)
       (apply (selector pred parent??) args)))))

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

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

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

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

;;; (method-tree-item? xpr)
;;; -----------------------
;;; type predicate
(define (method-tree-item? xpr)
  (and (pair? xpr)
       (selector? (car xpr))
       (or (procedure? (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)
  ;(assert (method-tree? tree))
  (let loop ((tree 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-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)))
    (assert (<= depth (length args))
      'method-tree-dispatch
      "not enough arguments"
      args)
    ;; 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)
  (assert (method-tree? tree)
    'method-tree-insert
    "not a method-tree"
    tree)
  (assert (method-tree-item? item)
    'method-tree-insert
    "not a method-tree-item"
    item)
  (assert (fx= (method-tree-depth tree)
               (method-tree-depth (list item)))
    'method-tree-insert
    "depth mismatch"
    tree
    item)
  (let ((depth (method-tree-depth tree)) (sel (car 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))))))))

;;;;;;;;;;;;;;;; generics ;;;;;;;;;;;;;;;;;
;;;;;;;;;;;;;;;; -------- ;;;;;;;;;;;;;;;;;

;;; (define-generic (Name (x x??) ....) body ....) 
;;; (define-generic (Name (x x??) ... xs xs??) body ....)
;;; -----------------------------------------------------
;;; x ... and xs are symbols, x?? ... and xs?? selectors.
;;; Creates a generic function Name with one method from arguments x
;;; .... or x ... . xs, selectors 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
  (syntax-rules ()
    ((_ (Name (x x??) (y y??) ...) xpr . xprs)
     (define Name
       (let ((tree
               (cell
                 (list (method-tree-item
                         (lambda (x y ...) xpr . xprs)
                         x?? y?? ...))
                 method-tree?))
             (variadic? #f))
         (case-lambda
           (() (values tree variadic?))
           ((x y ...)
            (let (
              (method
                  (method-tree-dispatch ((Name)) x y ...))
              )
              (if method
                (method x y ...)
                (error 'Name "no method found"))))))))
    ((_ (Name (x x??) ... xs xs??) xpr . xprs)
     (define Name
       (let ((tree
               (cell
                 (list (method-tree-item
                         (lambda (x ... . xs) xpr . xprs)
                         x?? ... xs??))
                 method-tree?))
             (variadic? #t))
         (case-lambda
           (() (values tree variadic?))
           ((x ... . xs)
            (let (
              (method
                (apply method-tree-dispatch ((Name)) x ... xs))
              )
              (if method
                (apply method x ... xs)
                (error 'Name "no method found"))))))))
    ))

;;; (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
                 (lambda (x y ...) xpr . xprs)
                 x?? y?? ...)))))
    ((_ (Name (x x??) ... zs zs??) xpr . xprs)
     (let ((tree (Name)))
       (tree (method-tree-insert
               (tree)
               (method-tree-item
                 (lambda (x ... . zs) xpr . xprs)
                 x?? ... zs??)))))
    ))

;;; (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-variadic? Gen)
;;; -----------------------
;;; is the generic function Gen variadic?
(define (generic-variadic? Gen)
  (receive (tree variadic? . rest) (Gen)
    variadic?))

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

) ; module generics