; Author: Juergen Lorenz ; ju (at jugilo (dot) de
;
; Copyright (c) 2013-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.


(module pseudolists (
  pl-sentinel pl-check-sentinel? pl-change-sentinel
  pl pl-maker pl-null? pl? pl-of?
  pl-iterate pl-length pl-head pl-tail
  pl-flatten pl-reverse
  pl-index pl-filter pl-map pl-for-each
  pl-memp pl-member pl-memq pl-memv
  pl-adjoin pl-remove-dups
  pl-at pl-drop pl-take pl-append
  pl-drop-while pl-take-while
  pl-fold-right pl-fold-left
  pl-fold-right0 pl-fold-left0
  pl-collect pseudolists
  )

  (import scheme
          (only (chicken base) receive
                unless cut case-lambda assert print error make-parameter))

(define pl-sentinel
  (make-parameter '()
                  (lambda (x)
                    (if (pair? x)
                      '()
                      x))))

(define (pl . args)
  (let recur ((args args))
    (if (null? args)
      (pl-sentinel)
      (cons (car args) (recur (cdr args))))))

(define (pl-maker len . args)
  (cond
    ((null? args)
     (pl-maker len (pl-sentinel)))
    ((null? (cdr args))
     (let ((fill (car args)))
         (if (zero? len)
           (pl-sentinel)
           (cons fill (pl-maker (- len 1) fill)))))
    (else (error 'pl-maker "too many arguments"))))

(define (pl-null? xpr)
  ;(equal? xpr (pl-sentinel)))
  (not (pair? xpr)))

(define (pl? xpr) #t)
  ;(or (pl-null? xpr)
  ;    (pair? xpr)))

(define (pl-check-sentinel? . pls)
  (cond
    ((null? pls)
     (lambda (pl) (pl-check-sentinel? pl)))
    ((null? (cdr pls))
     (equal? (pl-tail pl) (pl-sentinel)))
    (else (error 'pl-check-sentinel? "too many arguments"))))

(define (my-conjoin . preds)
  (let recur ((preds preds))
    (lambda (xpr)
      (cond
        ((null? preds) #t)
        (((car preds) xpr)
         ((recur (cdr preds)) xpr))
        (else #f)))))

(define (pl-of? . preds)
  (let ((ok? (apply my-conjoin preds)))
    (lambda (xpr)
      (if (pair? xpr)
        (and (ok? (car xpr))
             ((pl-of? ok?) (cdr xpr)))
        (pl-null? xpr)))))

(define (pl-length pl)
  ;; sentinel doesn't count in length!
  (if (pl-null? pl)
    0
    (+ 1 (pl-length (cdr pl)))))

(define (pl-head pl)
  (let recur ((pl pl))
    (if (pl-null? pl)
      '()
      (cons (car pl) (recur (cdr pl))))))

(define (pl-tail pl)
  (let loop ((pl pl))
    (if (pl-null? pl)
      pl
      (loop (cdr pl)))))

(define (pl-iterate fn times . inits)
  (cond
    ((null? inits)
     (lambda (init)
       (pl-iterate fn times init)))
    ((null? (cdr inits))
     (let recur ((x (car inits)) (k 0))
       (if (= k times)
         (pl-sentinel)
         (cons x (recur (fn x) (+ k 1))))))
    (else (error 'pl-iterate "too many arguments"))))

(define (pl-change-sentinel new-sentinel . pls)
  (cond
    ((null? pls)
     (lambda (pl)
       (pl-change-sentinel new-sentinel pl)))
    ((null? (cdr pls))
     (let recur ((pl (car pls)))
       (if (pair? pl)
         (cons (car pl) (recur (cdr pl)))
         new-sentinel)))
    (else (error 'pl-change-sentinel "too many arguments"))))

(define (pl-at n . pls)
  (cond
    ((null? pls)
     (lambda (pl)
       (pl-at n pl)))
    ((null? (cdr pls))
     (let ((pl (car pls)))
       (assert (< -1 n (pl-length pl))) 
       (let loop ((k 0) (pl pl))
         (cond
           ((pl-null? pl) pl)
           ((= k n) (car pl))
           (else
             (loop (+ k 1) (cdr pl)))))))
    (else (error 'pl-at "too many arguments"))))

(define (pl-drop n . pls)
  (cond
    ((null? pls)
     (lambda (pl)
       (pl-drop n pl)))
    ((null? (cdr pls))
     (let ((pl (car pls)))
       (assert (or (pl-null? pl) (< -1 n (pl-length pl)))) 
       (let loop ((n n) (pl pl))
         (cond
           ((pl-null? pl) pl)
           ((zero? n) pl)
           (else
             (loop (- n 1) (cdr pl)))))))
    (else
      (error 'pl-drop "too many arguments"))))

(define (pl-drop-while ok? . pls)
  (cond
    ((null? pls)
     (lambda (pl)
       (pl-drop-while ok? pl)))
    ((null? (cdr pls))
     (let loop ((pl (car pls)))
       (if (pair? pl)
         (if (ok? (car pl))
           (loop (cdr pl))
           pl)
         pl)))
    (else (error 'pl-drop-while "too many arguments"))))

(define (pl-take n . pls)
  (cond
    ((null? pls)
     (lambda (pl)
       (pl-take n pl)))
    ((null? (cdr pls))
     (let ((pl (car pls)))
       (assert (or (pl-null? pl) (< -1 n (pl-length pl)))) 
       (let recur ((k 0) (pl pl))
         (cond
           ((pl-null? pl) pl)
           ((< k n)
            (cons (car pl) (recur (+ k 1) (cdr pl))))
           (else (recur (+ k 1) (cdr pl)))))))
    (else (error 'pl-take "too many arguments"))))
     
(define (pl-take-while ok? . pls)
  (cond
    ((null? pls)
     (lambda (pl)
       (pl-take-while ok? pl)))
    ((null? (cdr pls))
     (let recur ((pl (car pls)))
       (if (pl-null? pl)
         pl
         (let ((first (car pl)) (rest (cdr pl)))
           (if (ok? first)
             (cons first (recur rest))
             (pl-tail rest))))))
    (else (error 'pl-take-while "too many arguments"))))

(define (pl-reverse pl)
  (let loop ((pl pl) (result (pl-tail pl)))
    (if (pl-null? pl)
      result
      (loop (cdr pl) (cons (car pl) result)))))

(define (pl-map fn . pls)
  (cond
    ((null? pls)
     (lambda pls
       (apply pl-map fn pls)))
    ((null? (cdr pls))
     (let recur ((pl (car pls)))
       (if (pl-null? pl)
         pl
         (cons (fn (car pl)) (recur (cdr pl))))))
    (else
      (let recur ((pls pls))
        (let ((ls (memq #t (map pl-null? pls))))
          (if ls
            (pl-tail (list-ref pls (- (length pls) (length ls))))
            (cons (apply fn (map car pls))
                  (recur (map cdr pls)))))))
        ;(if (memq #t (map pl-null? pls))
        ;  (pl-sentinel)
        ;  (cons (apply fn (map car pls))
        ;        (recur (map cdr pls))))))
    ))

(define (pl-for-each fn pl . pls)
  (if (null? pls)
    (let loop ((pl pl))
      (unless (pl-null? pl)
        (fn (car pl))
        (loop (cdr pl))))
    (let loop ((pls (cons pl pls)))
      (unless (memq #t (map pl-null? pls))
        (apply fn (map car pls))
        (loop (map cdr pls))))))

(define (pl-memp ok? . pls)
  (cond
    ((null? pls)
     (lambda (pl)
       (pl-memp ok? pl)))
    ((null? (cdr pls))
     (let loop ((pl (car pls)))
       (cond
         ((pl-null? pl) #f)
         ((ok? (car pl)) pl)
         (else (loop (cdr pl))))))
    (else (error 'pl-memp "too many arguments"))))

(define (pl-memq x . pls)
  (apply pl-memp (cut eq? <> x) pls))

(define (pl-memv x . pls)
  (apply pl-memp (cut eqv? <> x) pls))

(define (pl-member x . pls)
  (apply pl-memp (cut equal? <> x) pls))

(define (pl-index ok? . pls)
  (cond
    ((null? pls)
     (lambda (pl)
       (pl-index ok? pl)))
    ((null? (cdr pls))
     (let loop ((k 0) (pl (car pls)))
       (cond
         ((pl-null? pl) -1)
         ((ok? (car pl)) k)
         (else
           (loop (+ k 1) (cdr pl))))))
    (else (error 'pl-index "too many arguments"))))

(define (pl-filter ok? . pls)
  (cond
    ((null? pls)
     (lambda (pl)
       (pl-filter ok? pl)))
    ((null? (cdr pls))
     (let recur ((pl (car pls)))
       (if (pl-null? pl)
         (values pl pl)
         (receive (yes no) (pl-filter ok? (cdr pl))
           (if (ok? (car pl))
             (values (cons (car pl) yes) no)
             (values yes (cons (car pl) no)))))))
    (else (error 'pl-filter "too many arguments"))))

(define (pl-append pl . pls)
  (cond
    ((null? pls) pl)
    ((null? (cdr pls))
     (let recur ((pl pl))
       (if (pl-null? pl)
         (car pls)
         (cons (car pl) (recur (cdr pl))))))
    (else
      (pl-append pl (apply pl-append (car pls) (cdr pls))))
    ))

(define (pl-fold-right op init . pls)
  (cond
    ((null? pls)
     (lambda (pl)
       (pl-fold-right op init pl)))
    ((null? (cdr pls))
     (let recur ((pl (car pls)))
       (if (pl-null? pl)
         init
         (op (car pl) (recur (cdr pl))))))
    (else (error 'pl-fold-right "too many arguments"))))

(define (pl-fold-right0 op . pls)
  (cond
    ((null? pls)
     (lambda (pl)
       (pl-fold-right0 op pl)))
    ((null? (cdr pls))
     (let ((pl (car pls)))
       (if (pl-null? pl)
         (error 'pl-fold-right0 "pseudolist empty" pl)
         (apply pl-fold-right op (car pl) (cdr pl)))))
    (else (error 'pl-fold-right0 "too many arguments"))
    ))

(define (pl-fold-left op init . pls)
  (cond
    ((null? pls)
     (lambda (pl)
       (pl-fold-left op init pl)))
    ((null? (cdr pls))
     (let loop ((pl (car pls)) (result init))
       (if (pl-null? pl)
         result
         (loop (cdr pl) (op result (car pl))))))
    (else (error 'pl-fold-left "too many arguments"))
    ))

(define (pl-fold-left0 op . pls)
  (cond
    ((null? pls)
     (lambda (pl)
       (pl-fold-left0 op pl)))
    ((null? (cdr pls))
     (let ((pl (car pls)))
       (if (pl-null? pl)
         (error 'pl-fold-left0 "pseudolist empty" pl)
         (apply pl-fold-left op (car pl) (cdr pl)))))
    (else (error 'pl-fold-left0 "too many arguments"))
    ))

(define (pl-adjoin obj . pls)
  (cond
    ((null? pls)
     (lambda (pl)
       (pl-adjoin obj pl)))
    ((null? (cdr pls))
     (let ((pl (car pls)))
       (if (pair? (pl-member obj pl))
         pl
         (cons obj pl))))
    (else (error 'pl-adjoin "too many arguments"))
    ))

(define (pl-remove-dups pl)
  (let recur ((pl pl))
    (if (pl-null? pl)
      pl
      (pl-adjoin (car pl) (recur (cdr pl))))))

(define (pl-flatten pl-tree)
  ;(let recur ((tree pl-tree) (result (pl-sentinel)))
  (let recur ((tree (pl-head pl-tree)) (result (pl-tail pl-tree)))
    (if (pair? tree)
      (let ((head (car tree)) (tail (cdr tree)))
        (cond
          ((pair? head)
           (recur head (recur tail result)))
          (else
            (cons head (recur tail result)))))
      result)))

(define-syntax pl-collect
  (syntax-rules ()
   ((_ item-xpr (var pl ok-xpr ...))
     (let recur ((seq pl))
       (if (pl-null? seq)
         seq
         (let ((var (car seq)))
           (if (and ok-xpr ...)
             (cons item-xpr (recur (cdr seq)))
             (recur (cdr seq)))))))
   ((_ item-xpr (var pl ok-xpr ...) (var1 pl1 ok-xpr1 ...) ...)
    (let recur ((seq pl))
      (if (pl-null? seq)
        seq
        (let ((var (car seq)))
          (if (and ok-xpr ...)
            (pl-append (pl-collect item-xpr (var1 pl1 ok-xpr1 ...) ...)
                       (recur (cdr seq)))
            (recur (cdr seq)))))))
   ))


;;; (pseudolists sym ..)
;;; ----------------------------
;;; documentation procedure.
(define pseudolists
  (let ((alst '(
    (pseudolists
      procedure:
      (pseudolists)
      (pseudolists sym)
      "documentation procedure,"
      "the first call returns all exported symbols,"
      "the second documentation of symbol sym")
    (pl-sentinel
      parameter:
      (pl-sentinel)
      (pl-sentinel atom)
      "returns or sets the sentinel")
    (pl-check-sentinel?
      procedure?
      (pl-check-sentinel?)
      (pl-check-sentinel? pl)
      "checks if pl's sentinel is equal to (pl-sentinel)")
    (pl-change-sentinel
      procedure:
      (pl-change-sentinel new-sentinel)
      (pl-change-sentinel new-sentinel pl)
      "changes the sentinel of pl")
    (pl
      procedure:
      (pl . args)
      "creates a pseudolist from args with sentinel from pl-sentinel")
    (pl-maker
      procedure:
      (pl-maker len)
      (pl-maker len fill)
      "creates a pseudolist of length len and sentinel from pl-sentinel"
      "with items fill if given, (pl-sentinel) otherwise")
    (pl-null?
      procedure:
        (pl-null? xpr)
        "is xpr an atom equal to (pl-sentinel)")
    (pl?
      procedure:
      (pl? xpr)
      "is xpr a pseudolist, i.e either a pair or the atom (pl-sentinel)")
    (pl-of?
      procedure:
      (pl-of? . preds)
      "returns a unary predicate, which checks"
      "if its argument passes each predicate in preds")
    (pl-length
      procedure:
        (pl-length pl)
        "length of a pseudolist pl"
        "the sentinel doesn't count")
    (pl-head
      procedure:
        (pl-head pl)
        "returns the list of items with pl's sentinel stripped")
    (pl-tail
      procedure:
        (pl-tail pl)
        "returns the sentinel of the pseudolist")
    (pl-iterate
      procedure:
      (pl-iterate fn k)
      (pl-iterate fn k init)
      "creates a pseudolist with sentinel (pl-sentinel) applying fn to init"
      "recursively k times")
    (pl-at
      procedure:
        (pl-at k)
        (pl-at k pl)
        "returns the kth item of pl")
    (pl-drop
      procedure:
        (pl-drop n)
        (pl-drop n pl)
        "returns the tail of pl removing the first n items")
    (pl-drop-while
      procedure:
        (pl-drop-while ok?)
        (pl-drop-while ok? pl)
        "returns the tail of pl starting with the first item"
        "that does not pass the ok? test")
    (pl-take
      procedure:
        (pl-take n)
        (pl-take n pl)
        "returns the sublist of pl up to but excluding index n,"
        "where n is less than or equal to pl's pl-length."
        "The sentinel is unchanged")
    (pl-take-while
      procedure:
        (pl-take-while ok?)
        (pl-take-while ok? pl)
        "returns the sublist of pl consisting of items"
        "until the first item doesn't pass the ok? test."
        "The sentinel remains unchanged")
    (pl-map
      procedure:
        (pl-map fn)
        (pl-map fn . pls)
        "maps fn over the pseudolists pls as long as none of the"
        "items is pl-null? and returns a new pseudolist with pl-sentinel."
        "The sentinel is that of the first pl-null item."
        "Note, that this is R7RS-, not R5RS-logic")
    (pl-for-each
      procedure:
        (pl-for-each fn pl . pls)
        "applies fn over the pseudolists (cons pl pls)"
        "stops if one of the items is pl-null?"
        "Note, that this is R7RS-, not R5RS-logic")
    (pl-index
      procedure:
      (pl-index ok?)
      (pl-index ok? pl)
      "returns the index of the first item passing"
      "the ok? test, -1 otherwise")
    (pl-filter
      procedure:
        (pl-filter ok?)
        (pl-filter ok? pl)
        "filters a pseudolist by means of a predicate ok?"
        "Both values (passing or not passing ok?) keep pl's sentinel.")
    (pl-reverse
      procedure:
      (pl-reverse pl)
      "reverses its pseudolist argument to a new pseudolist"
      "with same sentinel")
    (pl-append
      procedure:
      (pl-append pl . pls)
      "appends all argument pseudolists to a pseudolist"
      "with sentinel of the last item")
    (pl-memp
      procedure:
      (pl-memp ok?)
      (pl-memp ok? pl)
      "returns the sublist starting at the first"
      "item which passes the ok? test, keeping ps's sentinel."
      "Returns #f if no item passes the ok? test")
    (pl-member
      procedure:
      (pl-member x)
      (pl-member x pl)
      "same as (pl-memp (cut equal? <> x) pl)")
    (pl-memq
      procedure:
      (pl-memq x)
      (pl-memq x pl)
      "same as (pl-memp (cut eq? <> x) pl)")
    (pl-memv
      procedure:
      (pl-memv x)
      (pl-memv x pl)
      "same as (pl-memp (cut eqv? <> x) pl)")
    (pl-fold-right
      procedure:
      (pl-fold-right op init)
      (pl-fold-right op init pl)
      "folds pl from the right with binary operation op"
      "and starting value init")
    (pl-fold-right0
      procedure:
      (pl-fold-right0 op)
      (pl-fold-right0 op pl)
      "folds (cdr pl) from the right with binary operation op"
      "and starting value (car pl)")
    (pl-fold-left
      procedure:
      (pl-fold-left op init)
      (pl-fold-left op init pl)
      "folds pl from the left with binary operation op"
      "and starting value init")
    (pl-fold-left0
      procedure:
      (pl-fold-left0 op)
      "folds (cdr pl) from the left with binary operation op"
      "and starting value (car pl)")
      (pl-fold-left0 op pl)
    (pl-adjoin
      procedure:
        (pl-adjoin obj)
        (pl-adjoin obj pl)
        "adds obj to a pseudolist provided, it isn't already there")
    (pl-remove-dups
      procedure:
        (pl-remove-dups lst)
        "removes duplicates of a pseudolist keeping the sentinel")
    (pl-flatten
      procedure:
        (pl-flatten pl-tree)
        "flattens the nested pseudolist tree to a pseudolist"
        "with sentinel from the pseudolist of depth 0")
    (pl-collect
      macro:
      (pl-collect xpr (var pl ok-xpr ...) ....)
      "creates a new list by binding var to each element"
      "of the pseudolist pl in sequence, and if it passes the checks,"
      "ok-xpr ..., inserts the value of xpr into the resulting pseudolist."
      "The qualifieres, (var pl ok-xpr ...), are processed"
      "sequentially from left to right, so that filters of a"
      "qualifier have access to the variables of qualifiers"
      "to its left."
      "The leftmost pseudolist determines the result's sentinel")
    )))
    (case-lambda
      (()
       (map car alst))
      ((sym)
       (let ((lst (assq sym alst)))
         (if lst
           (for-each print (cdr lst))
           (error 'basic-macros
                  "not exported" sym)))))))
) ; module pseudolists

;(import pseudolists simple-tests)
;(pl-sentinel 0)
;(ppp (pl-maker 3 0)
;     (pl-memp odd? '(0 1 2 . 0))
;     (pl-memp odd? '(0 4 2 . 0))
;     (pl-memp odd? 0)
;     (pl-filter odd? '(0 1 2 3 4 . 0))
;     (pl-flatten '(0 (1 2 (3 4 . 0) . 0) . 0))
;     (pl-flatten '(0 (1 2 (3 4))))
;     )