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

#|[
Only some routines of this module are used in generics. But all might be of
interest in other modules as well.
]|#

(module generic-helpers
  (generic-helpers 1+ 1- index? mfx+ mfx* ?? map* insert-before in?
   random-choice project reverse* rsplit-with rsplit-at repeat split-at
   split-with split-along always any? none? some? all? exists for-all
   cxr filter adjoin curry uncurry symbol-dispatcher nlambda dlambda
   mdefine mdefine* mset! memp assp)

(import scheme
        (only (chicken base)
              case-lambda error print identity
              list-of? o chop cut receive)
        (only (chicken random) pseudo-random-integer)
        (only (chicken string) ->string)
        (only (chicken fixnum) fx+ fx- fx* fx<=))

;;; fixnum operations
(define (1+ n) (fx+ n 1))
(define (1- n) (fx- n 1))
(define (index? 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)))))

(define (split-at k . args)
  (cond
    ((null? args)
     (lambda (xs)
       (split-at k xs)))
    ((null? (cdr args))
     (let loop ((n k) (tail (car args)) (head '()))
       (if (null? tail)
         (values (reverse head) tail)
         (if (zero? n)
           (values (reverse head) tail)
           (loop (1- n) (cdr tail) (cons (car tail) head))))))
    (else
      (error 'split-at "too many arguments"))))

(define (split-with ok? . args)
  (cond
    ((null? args)
     (lambda (xs)
       (split-with ok? xs)))
    ((null? (cdr args))
     (let loop ((tail (car args)) (head '()))
       (if (null? tail)
         (values (reverse head) tail)
         (if (ok? (car tail))
           (values (reverse head) tail)
           (loop (cdr tail) (cons (car tail) head))))))
    (else
      (error 'split-with "too many arguments"))))

(define (split-along pair . args)
  (cond
    ((null? args)
     (lambda (xs)
       (split-along pair xs)))
    ((null? (cdr args))
     (let loop ((tail (car args)) (pair pair) (head '()))
       (if (null? tail)
         (values (reverse head) tail)
         (if (pair? pair)
           (loop (cdr tail) (cdr pair) (cons (car tail) head))
           (values (reverse head) tail)))))
    (else
      (error 'split-along "too many arguments"))))

;;; (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?)
;;; (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? . args)
  (cond
    ((null? args)
     (lambda (lst)
       (rsplit-with ok? lst)))
    ((null? (cdr args))
     (let loop ((tail (car args)) (rhead '()))
       (cond
         ((null? tail)
          (values rhead tail))
         ((ok? (car tail))
          (values rhead tail))
         (else
           (loop (cdr tail) (cons (car tail) rhead))))))
    (else
      (error 'rsplit-with "too many arguments"))))

;;; (rsplit-at k)
;;; (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 . args)
  (cond
    ((null? args)
     (lambda (lst)
       (rsplit-at k lst)))
    ((null? (cdr args))
     (let loop ((n 0) (tail (car args)) (rhead '()))
       (if (= n k)
         (values rhead tail)
         (loop (1+ n) (cdr tail) (cons (car tail) rhead)))))
    (else
      (error 'rsplit-at "too many arguments"))))

;;; (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)))))
  ;(lambda (xs)
  ;  (let loop ((n 0) (result xs))
  ;    (if (= n k)
  ;      result
  ;      (loop (1+ n) (fn result))))))

;;; (map* fn)
;;; (map* fn xs)
;;; ------------
;;; maps the items of the nested pseudo-list xs via function vn
(define (map* fn . args)
  (cond
    ((null? args)
     (lambda (pl)
       (map* fn pl)))
    ((null? (cdr args))
     (let recur ((pl (car args)))
       (cond
         ((pair? pl)
          (cons (recur (car pl)) (recur (cdr pl))))
         ((null? pl) '())
         (else (fn pl)))))
    (else (error 'map* "too many arguments"))))

;;; (project k)
;;; -----------
;;; returns a procedure, which chooses the kth item of its argument list
(define (project k)
  (lambda args (list-ref args k)))

(define (always xpr)
  (lambda args xpr))

(define (any? x) #t)

(define (none? x) #f)

(define (all? ok?)
  (lambda (xs)
    (let loop ((xs xs))
      (cond
        ((null? xs) #t)
        ((ok? (car xs))
         (loop (cdr xs)))
        (else #f)))))

(define (some? ok?)
  (lambda (xs)
    (let loop ((xs xs))
      (cond
        ((null? xs) #f)
        ((ok? (car xs)) #t)
        (else (loop (cdr xs)))))))

;; a la Dybvig
(define (exists fn xs . xss)
  (and (not (null? xs))
       (let loop ((x (car xs)) (xs (cdr xs)) (xss xss))
         (if (null? xs)
           (apply fn x (map car xss))
           (or (apply fn x (map car xss))
               (loop (car xs) (cdr xs) (map cdr xss)))))))

(define (for-all fn xs . xss)
  (or (null? xs)
      (let loop ((x (car xs)) (xs (cdr xs)) (xss xss))
        (if (null? xs)
          (apply fn x (map car xss))
          (and (apply fn x (map car xss))
               (loop (car xs) (cdr xs) (map cdr xss)))))))

(define (curry proc)
  (lambda (x) (lambda args (apply proc x args))))

(define (uncurry proc)
  (lambda args (apply (proc (car args)) (cdr args))))

(define (memp ok? . args)
  (cond
    ((null? args)
     (lambda (xs)
       (memp ok? xs)))
    ((null? (cdr args))
     (let recur ((xs (car args)))
       (cond
         ((pair? xs)
          (if (ok? (car xs))
              xs
              (recur (cdr xs))))
         ((null? xs) #f)
         (else
           (error 'memp "not a list" xs)))))
    (else
      (error 'memp "too many arguments"))))

(define (assp ok? . args)
  (cond
    ((null? args)
     (lambda (xs)
       (assp ok? xs)))
    ((null? (cdr args))
     (let recur ((xs (car args)))
       (cond
         ((pair? xs)
          (if (pair? (car xs))
            (if (ok? (caar xs))
              (car xs)
              (recur (cdr xs)))
            (error 'assp "not a pair" (car xs))))
         ((null? xs) #f)
         (else
           (error 'assp "not an alist" xs)))))
    (else
      (error 'assp "too many arguments"))))

(define (filter ok? . args)
  (cond
    ((null? args)
     (lambda (xs) (filter ok? xs)))
    ((null? (cdr args))
     (let loop ((xs (car args)) (yes '()) (no '()))
       (cond
         ((pair? xs)
          (let ((x (car xs)) (xs (cdr xs)))
            (if (ok? x)
              (loop xs (cons x yes) no)
              (loop xs yes (cons x no)))))
         ((null? xs)
          (values (reverse yes) (reverse no)))
         (else
           (error 'filter "not a list" xs)))))
    (else
      (error 'filter "too many arguments"))))

(define (adjoin equ? x . args)
  (cond
    ((null? args)
     (lambda (xs) (adjoin equ? x xs)))
    ((null? (cdr args))
     (receive (head tail)
       (rsplit-with (cut equ? x <>) (car args))
       (if (null? tail)
         (reverse* head (list x))
         (reverse* head tail))))
    (else
      (error 'adjoin "too many arguments"))))

(define (insert-before equ? x before . args)
  (cond
    ((null? args)
     (lambda (xs) (insert-before equ? x before xs)))
    ((null? (cdr args))
     (receive (head tail)
       (rsplit-with (cut equ? before <>) (car args))
       (cond
         ((null? tail)
          (reverse* head (list x)))
         ((equ? (car tail) before)
          (reverse* head (cons x tail)))
         (else
           (reverse* head tail)))))
    (else
      (error 'insert-before "too many arguments"))))

;; (cxr 'ad) == cadr
;; (cxr '(1 a 2 d)) == caddr
(define (cxr ads . args)
  (cond
    ((symbol? ads)
     (cond
       ((null? args)
        ;curry
        (lambda (xs)
          (cxr ads xs)))
       ((null? (cdr args))
        (let ((xs (car args)) (str (symbol->string ads)))
          (if (string=? str "")
            xs
            (let ((first (string-ref str 0))
                  (rest (string->symbol (substring str 1))))
              (let ((restval (cxr rest xs)))
                (if (pair? restval)
                  (case first 
                    ((#\a)
                     (car restval))
                    ((#\d)
                     (cdr restval))
                    (else
                      (error 'cxr "only a or d allowed" first)))
                  (error 'cxr "car/cdr tries to access an atom with" rest)))))))
       (else
         (error 'cxr "at most one pair argument allowed"))))
    ((list? ads)
     (apply cxr
       (let loop ((pairs (chop ads 2)) (str ""));(chars '()))
         (if (null? pairs)
           (string->symbol str);(list->string (reverse chars)))
           (loop (cdr pairs)
                 (string-append
                   str
                   (apply make-string
                          (caar pairs)
                          (string->list
                            (symbol->string (cadar pairs))))))))
       args))
    ))

;;; (?? xpr ok? . oks?)
;;; -------------------
;;; precondition tests: passes xpr through unchanged
;;; if all predicates succed.
(define-syntax ??
  (syntax-rules ()
    ((_ xpr ok?)
     (if (ok? xpr)
       xpr
       (error '?? "precondition violated" '(ok? xpr))))
    ((_ xpr ok? . oks?)
     (if (ok? xpr)
       (?? xpr . oks?)
       (error '?? "precondition violated" '(ok? xpr))))
    ))

(define-syntax in?
  (syntax-rules ()
    ((_ equ? x x1 x2 ...)
     (let ((%x x))
       (or (equ? %x x1) (equ? %x x2) ...)))))
  
(define-syntax random-choice
  (er-macro-transformer
    (lambda (form rename compare?)
      (let ((xprs (cdr form))
            (nums
              (lambda (lst)
                (let loop ((lst lst) (k 0) (result '()))
                  (if (pair? lst)
                    (loop (cdr lst) (+ 1 k) (cons k result))
                    (reverse result)))))
            (%case (rename 'case))
            (%pseudo-random-integer (rename 'pseudo-random-integer)))
        `(,%case (,%pseudo-random-integer ,(length xprs))
           ,@(let ((key -1))
               (map (lambda (xpr k) `((,k) ,xpr))
                    xprs (nums xprs))))))))

;;; (nlambda name args xpr . xprs)
;;; ------------------------------
;;; named lambda, where the body xpr ... can refer to name, so that
;;; recursion is possible
(define-syntax nlambda
  (syntax-rules ()
    ((_ name args xpr . xprs)
     (letrec ((name (lambda args xpr . xprs)))
       name))))

(define-syntax dlambda
  (er-macro-transformer
    (lambda (form rename compare?)
      (let ((ds (cdr form)))
        ;; handle else-clause separately
        (let* ((rds (reverse ds)) (first (car rds)))
          (receive (tail head)
            (if (compare? (car first) 'else)
              (values (list first) (reverse (cdr rds)))
              (values '() (reverse rds)))
            (let ((keys (map car head))
                  (sigs (map cadr head))
                  (bodies (map cddr head)))
              `(lambda args 
                 (case (if (pair? args) (car args) args)
                   ,@(map (lambda (k s bs)
                            `((,k) (apply (nlambda ,k ,s ,@bs) (cdr args))))
                            ;`((,k) (apply (lambda ,s ,@bs) (cdr args))))
                          keys sigs bodies)
                   ,@(cond
                       ((null? tail) tail)
                       ((null? (cdr tail))
                        `((else (apply (lambda ,(cadar tail) ,@(cddar tail))
                                args))))
                       (else `(error 'dlambda "multiple else clauses"))
                       ))))))))))

(define-syntax mdefine
  (syntax-rules ()
    ((_ var val)
     (define var val))
    ((_ var val pairs ...)
     (begin
       (define var val)
       (mdefine pairs ...)))))

(define-syntax mdefine*
  (syntax-rules ()
    ((_ var)
     (define var 'var))
    ((_ var vars ...)
     (begin
       (define var 'var)
       (mdefine* vars ...)))))

(define-syntax mset!
  (syntax-rules ()
    ((_ var val)
     (set! var val))
    ((_ var val pairs ...)
     (begin
       (set! var val)
       (mset! pairs ...)))))

(define (symbol-dispatcher alist)
  (case-lambda
    (()
     (map car alist))
    ((sym)
     (let ((pair (assq sym alist)))
       (if pair
         (for-each print (cdr pair))
         (error "Not in list"
                sym
                (map car alist)))))))

;;; (generic-helpers sym ..)
;;; ------------------------
;;; documentation procedure
(define generic-helpers
  (symbol-dispatcher
    '((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?)
        (rsplit-with ok? xs)
        "returns two values by"
        "splitting the list xs at the first position where ok? returns true"
        "and reversing the head")
      (rsplit-at
        procedure:
        (rsplit-at k)
        (rsplit-at k xs)
        "returns two values by"
        "splitting the list xs at position k and reversing the head")
      (split-at
        procedure:
        (split-at k)
        (split-at k xs)
        "splitting xs at index k, curried and uncurried")
      (split-with
        procedure:
        (split-with ok?)
        (split-with ok? xs)
        "splitting xs at predicate ok?, curried and uncurried")
      (split-along
        procedure:
        (split-along pair)
        (split-along pair xs)
        "splitting a list along a pseudolist at the latters sentinel,"
        "curried and uncurried")
      (repeat
        procedure:
        (repeat k fn)
        "applies function fn k times in sequence")
      (map*
        procedure:
        (map* fn)
        (map* fn xs)
        "maps the items of the nested pseudo-list xs via function fn")
      (project
        procedure:
        (project k)
        "returns a procedure which selects the kth item of its argument"
        "argument list")
      (1+
        procedure:
        (1+ n)
        "add 1 to fixnum n")
      (1-
        procedure:
        (1- n)
        "subtract 1 from fixnum n")
      (index?
        procedure:
        (index? 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")
      (always
        procedure:
        (always xpr)
        "returns a procedure which always returns xpr")
      (any?
        procedure:
        (any? xpr)
        "returns always #t")
      (none?
        procedure:
        (none? xpr)
        "returns always #f")
      (all?
        procedure:
        (all? ok?)
        "returns a unary predicate which tests, if all items of"
        "the argument list pass the ok? test")
      (some?
        procedure:
        (some? ok?)
        "returns a unary predicate which tests, if some item of"
        "the argument list passes the ok? test")
      (for-all
        procedure:
        (for-all fn xs ....)
        "applies fn to corresponding items in xs .... in sequence"
        "until either a call returns #f or return the call to the"
        "last items")
      (exists
        procedure:
        (exists fn xs ....)
        "returns #f if all lists xs are empty."
        "Otherwise applies fn to corresponding items in xs .... in sequence"
        "until either a call returns #t or return the call to the"
        "last items")
      (cxr
        procedure:
        (cxr ads)
        (cxr ads xs)
        "aritrarily deep car and cdr invocations."
        "The first is a curried version of the second,"
        "which in turn uses the symbol ads consisting of"
        "any mixture of a's and d's to to apply recursively"
        "car and cdr to xs, so that, eg., (cxr 'dadd) is"
        "equivalent to cdaddr."
        "Instead of a symbol, ads can be a list of alternating"
        "integers and symbols 'a or 'd. Then cdaddr is"
        "equivalent to (cxr '(1 d 1 a 2 d))")
      (curry
        procedure:
        (curry proc)
        "curries the first arg only")
      (uncurry
        procedure:
        (uncurry proc)
        "uncurries the first arg only")
      (filter
        procedure:
        (filter ok?)
        (filter ok? xs)
        "curried and uncurried filtering;"
        "two values")
      (memp
        procedure:
        (memp ok?)
        (memp ok? xs)
        "curried and uncurried member function")
      (assp
        procedure:
        (assp ok?)
        (assp ok? alist)
        "curried and uncurried association function")
      (adjoin
        procedure:
        (adjoin equ? x)
        (adjoin equ? x xs)
        "curried and uncurried insertion routine:"
        "only insert items not already in xs")
      (insert-before
        procedure:
        (insert-before equ? x before)
        (insert-before equ? x before xs)
        "curried and uncurried insertion routine")
      (??
        macro:
        (?? xpr ok? ....)
        "precondition test: passes xpr through unchanged"
        "if all tests ok? succeed")
      (in?
        macro:
        (in? equ? x . xs)
        "checks, if x is equ? to one of xs")
      (random-choice
        macro:
        (random-choice . xprs)
        "evaluates one of xprs at random")
      (nlambda
        macro:
        (nlambda name args xpr . xprs)
        "named lambda, can be recursively accessed via name")
      (dlambda
        macro:
        (dlambda (sym args . body) ....)
        "destructuring lambda:"
        "creates as many procedures as there are clauses,"
        "used to create objects with message passing")
      (mdefine
        macro:
        (mdefine var val ....)
        "defines var with val ....")
      (mdefine*
        macro:
        (mdefine var ....)
        "defines var 'var ....")
      (mset!
        macro:
        (mset! var val . other-pairs)
        "sets var to val ....")
      )))

) ; module generic-helpers

;(import generic-helpers simple-tests)