; Copyright (c) 2013-2021 , Juergen Lorenz, ju (at) jugilo (dot) de
; 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 disclaimer.
; 
; Redistributions in binary form must reproduce the above copyright
; notice, this list of conditions and the following disclaimer 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 module exports routines to handle pseudolists as a generalisation
of ordinary lists. They can be considered as parametrized (or
tagged) lists, where the parameter (or tag) is stored in the sentinel of a
dotted list. In such a naive approch, we are faced with two problems.

First, since dotted lists differ from lists only insofor, as their
sentinels might be arbitrary atoms instead of the empty list. In other
words, a dotted list is either a pair or an atom. But since an atom is
simply not a pair, everything is a pseudolist, in particular, a list is
one. Hence, there is no meaningfull predicate for dotted lists.

Second, there is an efficency problem: to get a handle to the sentinel,
we have to traverse the whole dotted list. This is not acceptable, if,
for example, the parameter is a type predicate to check the type of
items to be put into the dotted list. Ok, as in previous versions of
this module, we can put the sentinel into a parameter, but this alone
doesn't help much, if different parameters are used simultaneously.

This module offers a simple solution to both problems: Make the dotted
list callable, in other words, put it into a closure and acces the items
as well as the sentinel -- and the length for that matter -- via calls
to that closure, e.g. (pls i), where i is an index.

Note, that most procedures are implemented in a curried and uncurried
form, but only the latter is described in detail in the documentation.
The former can be used in map and friends.

Note also, that the order or arguments of all procedures is consistent:
The pseudolist argument(s) are always last, other procedures first.
]|#

(module pseudolists (
  pl-parameter
  pl-checker
  pl-checker?
  pl
  pl?
  pl-maker
  pl-at
  pl-set!
  pl-length
  pl-null?
  pl-head
  pl-tail
  pl-data
  pl-cons
  pl-car
  pl-cdr
  pl-of?
  pl-iterate
  pl-drop
  pl-drop-while
  pl-take
  pl-take-while
  pl-reverse
  pl-map
  pl-for-each
  pl-memp
  pl-memq
  pl-memv
  pl-member
  pl-index
  pl-filter
  pl-append
  pl-fold-right
  pl-fold-right0
  pl-fold-left
  pl-fold-left0
  pl-adjoin
  pl-remove-dups
  pl-flat?
  pl-flatten
  pl-collect
  pseudolists
  )

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

#|[
(pl-parameter)
(pl-parameter new)
--- parameter ---
returns or resets the sentinel of a pseudolist, initially '()
]|#
(define pl-parameter
  (make-parameter '()
                  (lambda (x)
                    (if (pair? x)
                      '()
                      x))))

;(define pl-sentinel pl-parameter) ; deprecated

#|[
(pl-checker ok? arg)
(pl-checker ok?)
--- procedure ---
type constructor: wrap the predicate ok? into a unary procedure,
which returns its argument unchanged, if only it passes the ok? test.
An uncurried version is given as well
]|#
(define pl-checker 'pl-checker)

#|[
(pl-checker? xpr)
--- procedure ---
type predicate. Used to check if the tag can be used to check all items.
]|#
(define pl-checker? 'pl-checker?)

(let ((in (gensym 'in)) (out (gensym 'out)))
  (set! pl-checker
    (case-lambda
      ((ok?)
       (lambda (arg)
         (pl-checker ok? arg)))
      ((ok? arg)
       (cond
         ((eq? arg in) out)
         ((ok? arg) arg)
         (else
           (error 'pl-checker
                  "argument not accepted by predicate"
                  ok?
                  arg))))))
  (set! pl-checker?
    (lambda (xpr)
      (and (procedure? xpr)
           (condition-case (eq? (xpr in) out)
             ((exn) #f)))))
  )

#|[
(pl . args)
--- procedure ---
constructor: creates a pseudolist with sentinel tag from pl-parameter
and items from args, encapsulated into a closure, which, when called with an
index, returns the argument at that index, or, when called with -1,
returns the length of args.
]|#
(define pl 'pl)

#|[
(pl? xpr)
--- procedure ---
type predicate
]|#
(define pl? 'pl?)

(let ((in (gensym 'in)) (out (gensym 'out)))

  (set! pl
    (lambda args
      (let ((tag (pl-parameter))
            (args args)
            (len (length args)))
        (let ((args 
                (if (pl-checker? tag)
                  (map tag args)
                  args)))
          (case-lambda
            (() (values args tag))
            ((k)
             (cond
               ((and (symbol? k) (eq? k in)) out)
               ((= k -1) len)
               ((or (>= k len) (< k -1))
                (error 'pl "out of range" k))
               (else
                (list-ref args k))))
            ((k val)
             (if (or (< k 0) (>= k len))
               (error 'pl "out of range" k)
               (set! (list-ref args k)
                 (if (pl-checker? tag)
                   (tag val)
                   val))))
               )))))

  (set! pl?
    (lambda (xpr)
      (and (procedure? xpr)
           (condition-case (eq? out (xpr in))
             ((exn) #f)))))
  )
#|[
(pl-maker len fill)
(pl-maker len)
--- procedure ---
creates a pseudolist of length len with sentinel (pl-parameter),
items fill or (pl-sentinel), if fill is not given
]|#
(define (pl-maker len . args)
  (let ((parameter (pl-parameter)))
    (cond
      ((null? args)
       (pl-maker len parameter))
      ((null? (cdr args))
       (let ((fill (car args)))
         (apply pl
           (let recur ((i 0))
             (if (= i len)
               parameter
               (cons fill (recur (+ i 1))))))))
      (else (error 'pl-maker "too many arguments")))))

#|[
(pl-at k pls)
(pl-at k)
--- procedure ---
returns the kth item of pls
]|#
(define (pl-at k . plss)
  (cond
    ((null? plss)
     (lambda (pls) (pls k)))
    ((null? (cdr plss))
     (let ((pls ((pl-checker pl?) (car plss))))
       (pls k)))
    (else 'pl-at "to many arguments")))

#|[
(pl-set! k val pls)
--- procedure ---
sets the kth item of pls to val
]|#
(define (pl-set! k val pls)
  (((pl-checker pl?) pls) k val))

#|[
(pl-length pls)
--- procedure ---
returns the length of the pseudolist pls
]|#
(define (pl-length pls)
  ((pl-checker pl? pls) -1))

#|[
(pl-null? xpr)
--- procedure ---
checks, if no items are stored in the pseudolist xpr
]|#
(define (pl-null? xpr)
  (and (pl? xpr)
       (zero? (pl-length xpr))))

#|[
(pl-head pls)
--- procedure ---
returns the list part of the pseudolist pls
]|#
(define (pl-head pls)
  ((pl-checker pl? pls)))
  ;(let ((pls (pl-checker pl? pls)))
  ;  (let recur ((lst (pls)))
  ;    (if (null? lst)
  ;      '()
  ;      (cons (car lst)
  ;            (recur (cdr lst)))))))

#|[
(pl-tail pls)
--- procedure ---
returns the sentinel of the pseudolist pls
]|#
(define (pl-tail pls)
  (receive (_ tail) ((pl-checker pl? pls)) tail))

#|[
(pl-data pls)
--- procedure ---
returns the dotted list underlying the pseudolist pls
]|#
(define (pl-data pls)
  (receive (head tail) ((pl-checker pl? pls))
    (append head tail)))

#|[
(pl-cons x pls)
(pl-cons x)
--- procedure ---
adds the item x to the front of the pseudolist pls
]|#
(define (pl-cons x . plss)
  (cond
    ((null? plss)
     (lambda (pls) (pl-cons x pls)))
    ((null? (cdr plss))
     (let ((pls (pl-checker pl? (car plss))))
       (let ((lst (pl-head pls)) (tag (pl-tail pls)))
         (parameterize ((pl-parameter tag))
           (apply pl
             (if (pl-checker? tag)
               (cons (tag x) lst)
               (cons x lst)))))))
    (else (error 'pl-cons "too many arguments"))))

#|[
(pl-car pls)
--- procedure ---
returns the first item of the pseudolist pls
]|#
(define (pl-car pls)
  (pl-at 0 (pl-checker pl? pls)))

#|[
(pl-cdr pls)
--- procedure ---
returns a new pseudolist removing the first item of pls
]|#
(define (pl-cdr pls)
  (pl-drop 1 (pl-checker pl? pls)))

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

#|[
(pl-of? tag . preds)
--- procedure ---
creates a unary predicate, which tests, if its argument is a
pseudolist with parameter tag, whose items pass all the predicates preds
]|#
(define (pl-of? tag . preds)
  (lambda (xpr)
    (and (pl? xpr)
         (equal? tag (pl-tail xpr))
         (if (null? preds)
           #t
           (let ((ok? (if (null? (cdr preds))
                        (car preds)
                        (apply my-conjoin preds)))
                 (lst (pl-head xpr)))
             (let loop ((lst lst))
               (cond
                 ((null? lst) #t)
                 ((ok? (car lst)) (loop (cdr lst)))
                 (else #f))))))))

#|[
(pl-iterate fn times init)
(pl-iterate fn times)
--- procedure ---
creates a pseudolist with sentinel (pl-parameter) applying fn
to init recursively k times
]|#
(define (pl-iterate fn times . inits)
  (cond
    ((null? inits)
     (lambda (init)
       (pl-iterate fn times init)))
    ((null? (cdr inits))
     (apply pl
       (let recur ((x (car inits)) (k 0))
         (if (= k times)
           '()
           (cons x (recur (fn x) (+ k 1)))))))
    (else (error 'pl-iterate "too many arguments"))))

#|[
(pl-drop n pls)
(pl-drop n)
--- procedure ---
returns a new pseudolist removing the first n items of the pseudolist pls
]|#
(define (pl-drop n . plss)
  (cond
    ((null? plss)
     (lambda (pls)
       (pl-drop n pls)))
    ((null? (cdr plss))
     (let ((pls (pl-checker pl? (car plss))))
       (parameterize ((pl-parameter (pl-tail pls)))
         (apply pl
           (list-tail (pl-head pls)
                      (pl-checker (cut < -1 <> (pl-length pls)) n))))))
    (else
      (error 'pl-drop "too many arguments"))))

#|[
(pl-drop-while ok? pls)
(pl-drop-while ok?)
--- procedure ---
returns the tail of pls starting with the first item
that does not pass the ok? test
]|#
(define (pl-drop-while ok? . plss)
  (cond
    ((null? plss)
     (lambda (pls)
       (pl-drop-while ok? pls)))
    ((null? (cdr plss))
     (let ((pls (pl-checker pl? (car plss)))
           (ok? (pl-checker procedure? ok?)))
       (parameterize ((pl-parameter (pl-tail pls)))
         (apply pl
           (let loop ((lst (pl-head pls)))
             (if (null? lst)
               lst
               (if (ok? (car lst))
                 (loop (cdr lst))
                 lst)))))))
    (else (error 'pl-drop-while "too many arguments"))))

#|[
(pl-take n pls)
(pl-take n)
--- procedure ---
returns a new pseudolist consisting of the first n items of
the pseudolist pls, keeping the sentinel
]|#
(define (pl-take n . plss)
  (cond
    ((null? plss)
     (lambda (pls)
       (pl-take n pls)))
    ((null? (cdr plss))
     (let* ((pls (pl-checker pl? (car plss)))
            (n (pl-checker (cut < -1 <> (pl-length pls)) n)))
       (parameterize ((pl-parameter (pl-tail pls)))
         (apply pl
           (let recur ((k 0) (lst (pl-head pls)))
             (cond
               ((null? lst) lst)
               ((< k n) (cons (car lst) (recur (+ k 1) (cdr lst))))
               (else (recur (+ k 1) (cdr lst)))))))))
    (else (error 'pl-take "too many arguments"))))
     
#|[
(pl-take-while ok? pls)
(pl-take-while ok?)
--- procedure ---
returns the sublist of pls consisting of items
until the first item doesn't pass the ok? test.
]|#
(define (pl-take-while ok? . plss)
  (cond
    ((null? plss)
     (lambda (pls)
       (pl-take-while ok? pls)))
    ((null? (cdr plss))
     (let ((pls (pl-checker pl? (car plss)))
           (ok? (pl-checker procedure? ok?)))
       (parameterize ((pl-parameter (pl-tail pls)))
         (apply pl
           (let recur ((lst (pl-head pls)))
             (if (null? lst)
               lst
               (let ((first (car lst)) (rest (cdr lst)))
                 (if (ok? first)
                   (cons first (recur rest))
                   '()))))))))
    (else (error 'pl-take-while "too many arguments"))))

#|[
(pl-reverse pl)
--- procedure ---
reverses its pseudolist argument to a new pseudolist
with same sentinel
]|#
(define (pl-reverse pls)
  (let ((pls (pl-checker pl? pls)))
    (parameterize ((pl-parameter (pl-tail pls)))
      (apply pl (reverse (pl-head pls))))))

;(define (all-equal? lst)
;  (if (null? lst)
;    #t
;    (null? (cdr (let loop ((lst lst) (result '()))
;                  (cond
;                    ((null? lst) result)
;                    ((member (car lst) result)
;                     (loop (cdr lst) result))
;                    (else (loop (cdr lst)
;                                (cons (car lst) result)))))))))

(define (all cmp? lst)
  (if (null? lst)
    #t
    (let ((x (car lst)) (xs (cdr lst)))
      (let* ((gsym (gensym)) ; xs might be a list of #f
             (checker (lambda (arg)
                        (if (cmp? x arg) arg gsym))))
        (let loop ((xs xs))
          (cond
            ((null? xs) #t)
            ((cmp? (checker (car xs)) gsym) #f)
            (else (loop (cdr xs)))))))))


#|[
(pl-map fn . plss)
--- procedure ---
maps fn over the pseudolists plss as long as none of the items is
pl-null? and returns a new pseudolist if all sentinels are equal.
Note, that this is R7RS-, not R5RS-logic.
]|#
(define (pl-map fn . plss)
  (cond
    ((null? plss)
     (lambda plss
       (apply pl-map fn plss)))
    ((null? (cdr plss))
     (let ((pls (pl-checker pl? (car plss))))
       (parameterize ((pl-parameter (pl-tail pls)))
         (apply pl
           (let recur ((lst (pl-head pls)))
             (if (null? lst)
               lst
               (cons (fn (car lst))
                     (recur (cdr lst)))))))))
    (else
      (let ((plss (map (pl-checker pl?) plss)))
        (let ((len (apply min (map pl-length plss)))
              (tags (map pl-tail plss)))
          (if (all equal? tags)
            (parameterize ((pl-parameter (car tags)))
              (apply pl
                (let recur ((i 0))
                  (if (= i len)
                    '()
                    (cons (apply fn (map (pl-at i) plss))
                          (recur (+ i 1)))))))
            (error 'pl-map "not all tags equal" tags)))))
    ))

#|[
(pl-for-each fn pls . plss)
--- procedure ---
applies fn over the pseudolists (cons pls plss)
stops if one of the items is pl-null?
Note, that this is R7RS-, not R5RS-logic
]|#
(define (pl-for-each fn pls . plss)
  (if (null? plss)
    (let* ((pls (pl-checker pl? pls))
           (len (pl-length pls)))
      (let loop ((i 0))
        (unless (= i len)
          (fn (pl-at i pls))
          (loop (+ i 1)))))
    (let* ((plss (map (pl-checker pl?) (cons pls plss)))
           (len (apply min (map pl-length plss))))
      (let ((tags (map pl-tail plss)))
        (if (all equal? tags)
          (let recur ((i 0) (plss plss))
            (unless (= i len)
              (cons (apply fn (map car plss))
                    (recur (+ i 1) (map cdr plss)))))
          (error 'pl-for-each "not all tags equal" tags))))
    ))
#|[
(pl-memp ok? pls)
(pl-memp ok?)
--- procedure ---
returns the subpseudolist starting at the first
item which passes the ok? test, keeping ps's sentinel.
Returns #f if no item passes the ok? test
]|#
(define (pl-memp ok? . plss)
  (cond
    ((null? plss)
     (lambda (pls)
       (pl-memp ok? pls)))
    ((null? (cdr plss))
     (let ((pls (pl-checker pl? (car plss))))
       (let loop ((lst (pl-head pls)))
         (cond
           ((null? lst) #f)
           ((ok? (car lst))
            (parameterize ((pl-parameter (pl-tail pls)))
              (apply pl lst)))
           (else (loop (cdr lst)))))))
    (else (error 'pl-memp "too many arguments"))))

#|[
(pl-memq x pls)
(pl-memq x)
--- procedure ---
same as (pl-memp (cut eq? <> x) pls)
]|#
(define (pl-memq x . plss)
  (cond
    ((null? plss)
     (lambda (pls) (pl-memq x pls)))
    ((null? (cdr plss))
     (pl-memp (cut eq? <> x) (car plss)))
    (else (error 'pl-memq "too many arguments"))))

#|[
(pl-memv x pls)
(pl-memv x)
--- procedure ---
same as (pl-memp (cut eqv? <> x) pls)
]|#
(define (pl-memv x . plss)
  (cond
    ((null? plss)
     (lambda (pls) (pl-memv x pls)))
    ((null? (cdr plss))
     (pl-memp (cut eqv? <> x) (car plss)))
    (else (error 'pl-memv "too many arguments"))))

#|[
(pl-member x pls)
(pl-member x)
--- procedure ---
same as (pl-memp (cut equal? <> x) pls)
]|#
(define (pl-member x . plss)
  (cond
    ((null? plss)
     (lambda (pls) (pl-member x pls)))
    ((null? (cdr plss))
     (pl-memp (cut equal? <> x) (car plss)))
    (else (error 'pl-member "too many arguments"))))

#|[
(pl-index ok? pls)
(pl-index ok?)
--- procedure ---
returns the index of the first item passing
the ok? test, -1 otherwise
]|#
(define (pl-index ok? . plss)
  (cond
    ((null? plss)
     (lambda (pls)
       (pl-index ok? pls)))
    ((null? (cdr plss))
     (let ((pls(pl-checker pl? (car plss))))
     (let loop ((k 0) (lst (pl-head pls)))
       (cond
         ((null? lst) -1)
         ((ok? (car lst)) k)
         (else
           (loop (+ k 1) (cdr lst)))))))
    (else (error 'pl-index "too many arguments"))))

#|[
(pl-filter ok? pls)
(pl-filter ok?)
--- procedure ---
filters a pseudolist by means of a predicate ok?
returning two new pseudolists, those of items of pls
passing the ok? test, and those that don't
]|#
(define (pl-filter ok? . plss)
  (cond
    ((null? plss)
     (lambda (pls)
       (pl-filter ok? pls)))
    ((null? (cdr plss))
     (let* ((pls (pl-checker pl? (car plss))))
       (receive (yes no)
         (let loop ((lst (pl-head pls)) (yes '()) (no '()))
           (if (null? lst)
             (values (reverse yes) (reverse no))
             (let ((val (car lst)))
               (if (ok? val)
                 (loop (cdr lst) (cons val yes) no)
                 (loop (cdr lst) yes (cons val no))))))
         (parameterize ((pl-parameter (pl-tail pls)))
           (values (apply pl yes) (apply pl no))))))
    (else (error 'pl-filter "too many arguments"))))

#|[
(pl-append pls . plss)
--- procedure ---
appends all argument pseudolist, provided their tags are
all equal
]|#
(define (pl-append pls . plss)
  (let ((plss (map (pl-checker pl?) (cons pls plss))))
    (let ((tails (map pl-tail plss))
          (heads (map pl-head plss)))
      (if (all equal? tails)
        (parameterize ((pl-parameter (car tails)))
          (apply pl (apply append heads)))
        (error 'pl-append "not all equal" tails)))))

#|[
(pl-fold-right op init pls)
(pl-fold-right op init)
--- procedure ---
folds pls from the right with binary operation op
and starting value init
]|#
(define (pl-fold-right op init . plss)
  (cond
    ((null? plss)
     (lambda (pls)
       (pl-fold-right op init pls)))
    ((null? (cdr plss))
     (let ((pls (pl-checker pl? (car plss))))
       (let recur ((lst (pl-head pls)))
         (if (null? lst)
           init
           (op (car lst) (recur (cdr lst)))))))
    (else (error 'pl-fold-right "too many arguments"))))

#|[
(pl-fold-right0 op pls)
(pl-fold-right0 op)
--- procedure ---
folds (pl-cdr pls) from the right with binary operation op
and starting value (pl-car pls)
]|#
(define (pl-fold-right0 op . plss)
  (cond
    ((null? plss)
     (lambda (pls)
       (pl-fold-right0 op pls)))
    ((null? (cdr plss))
     (let ((pls (pl-checker pl? (car plss))))
       (if (pl-null? pls)
         (error 'pl-fold-right0 "pseudolist empty" pls)
         (pl-fold-right op (pl-car pls) (pl-cdr pls)))))
    (else (error 'pl-fold-right0 "too many arguments"))
    ))

#|[
(pl-fold-left op init pls)
(pl-fold-left op init)
--- procedure ---
folds pls from the left with binary operation op
and starting value init
]|#
(define (pl-fold-left op init . plss)
  (cond
    ((null? plss)
     (lambda (pls)
       (pl-fold-left op init pls)))
    ((null? (cdr plss))
     (let ((pls (pl-checker pl? (car plss))))
     (let loop ((lst (pl-head pls)) (result init))
       (if (null? lst)
         result
         (loop (cdr lst) (op result (car lst)))))))
    (else (error 'pl-fold-left "too many arguments"))
    ))

#|[
(pl-fold-left0 op pls)
(pl-fold-left0 op)
--- procedure ---
folds (pl-cdr pls) from the left with binary operation op
and starting value (pl-car pls)
]|#
(define (pl-fold-left0 op . plss)
  (cond
    ((null? plss)
     (lambda (pls)
       (pl-fold-left0 op pls)))
    ((null? (cdr plss))
     (let ((pls (pl-checker pl? (car plss))))
       (if (pl-null? pls)
         (error 'pl-fold-left0 "pseudolist empty" pls)
         (pl-fold-left op (pl-car pls) (pl-cdr pls)))))
    (else (error 'pl-fold-left0 "too many arguments"))
    ))

#|[
 (pl-adjoin obj pls)
 (pl-adjoin obj)
--- procedure ---
add obj to the front of pls only if it is not already a member of pls
]|#
(define (pl-adjoin obj . plss)
  (cond
    ((null? plss)
     (lambda (pls)
       (pl-adjoin obj pls)))
    ((null? (cdr plss))
     (let* ((pls (pl-checker pl? (car plss)))
            (lst (pl-head pls)))
       (parameterize ((pl-parameter (pl-tail pls)))
         (apply pl
           (if (member obj lst)
             lst
             (cons obj lst))))))
    (else (error 'pl-adjoin "too many arguments"))
    ))

#|[
(pl-remove-dups pls)
--- procedure ---
removes the duplicates in the pseudolist pls
]|#
(define (pl-remove-dups pls)
  (let* ((pls (pl-checker pl? pls))
         (lst (pl-head pls))
         (adjoin (lambda (obj lst)
                   (if (member obj lst)
                     lst
                     (cons obj lst)))))
    (parameterize ((pl-parameter (pl-tail pls)))
      (apply pl
        (let recur ((lst lst))
          (if (null? lst)
            lst
            (adjoin (car lst) (recur (cdr lst)))))))))

#|[
(pl-flat? xpr)
--- procedure ---
is xpr a flat pseudolist, i.e. not containing other pseudolists
]|#
(define (pl-flat? xpr)
  (and (pl? xpr)
       (not (pl-memp pl? xpr))))

#|[
(pl-flatten pl-tree)
--- procedure ---
flattens the nested pseudolist pl-tree to a pseudolist,
i.e. splices the pseudolist items of pl-tree into pl-tree
provided all parameters are equal
]|#
(define (pl-flatten pl-tree)
  (let ((pls (pl-map (lambda (x)
                       (cond
                         ((pl-flat? x) x)
                         ((pl? x) (pl-flatten x))
                         (else (pl x))))
                     pl-tree)))
    (apply pl-append (pl-head pls))))
           ; pl-append checks for equal tails

#|[
(pl-collect item-xpr (var pls ok-xpr ...))
(pl-collect item-xpr (var pls ok-xpr ...) (var1 pls1 ok-xpr1 ...) ...)
--- macro ---
creates a new pseudolist by binding var to each element
of the pseudolist pls in sequence, and if it passes the checks,
ok-xpr ..., inserts the value of xpr into the resulting pseudolist.
The qualifieres, (var pls 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.
]|#
(define-syntax pl-collect
  (syntax-rules ()
   ((_ item-xpr (var pls ok-xpr ...))
    (apply pl
      (let recur ((seq (pl-head (pl-checker pl? pls))))
         (if (null? seq)
           seq
           (let ((var (car seq)))
             (if (and ok-xpr ...)
               (cons item-xpr (recur (cdr seq)))
               (recur (cdr seq))))))))
   ((_ item-xpr (var pls ok-xpr ...) (var1 pls1 ok-xpr1 ...) ...)
    (apply pl
      (let recur ((seq (pl-head (pl-checker pl? pls))))
        (if (null? seq)
          seq
          (let ((var (car seq)))
            (if (and ok-xpr ...)
              ;(append (pl-head (pl-collect item-xpr (var1 pls1 ok-xpr1
              ;                                            ...) ...)))
              (pl-head
                (pl-append (pl-collect item-xpr (var1 pls1 ok-xpr1 ...) ...)
                (apply pl (recur (cdr seq)))))
              (recur (cdr seq))))))))
   ))

#|[
(pseudolists)
(pseudolists sym)
--- procedure ---
documentation procedure
]|#
(define pseudolists
  (let (
    (alist '(
      (pl-parameter
        parameter:
        (pl-parameter)
        (pl-parameter new)
        "returns or resets the sentinel of a pseudolist, initially '()"
        )
      (pl-checker
        procedure:
        (pl-checker ok? arg)
        (pl-checker ok?)
        "type constructor: wrap the predicate ok? into a unary procedure,"
        "which returns its argument unchanged, if only it passes the ok? test."
        "An uncurried version is given as well"
        )
      (pl-checker?
        procedure:
        (pl-checker? xpr)
        "type predicate. Used to check if the tag can be used to check all items."
        )
      (pl
        procedure:
        (pl . args)
        "constructor: creates a pseudolist with sentinel tag from pl-parameter"
        "and items from args, encapsulated into a closure, which, when called with an"
        "index, returns the argument at that index, or, when called with -1,"
        "returns the length of args."
        )
      (pl?
        procedure:
        (pl? xpr)
        "type predicate"
        )
      (pl-maker
        procedure:
        (pl-maker len fill)
        (pl-maker len)
        "creates a pseudolist of length len with sentinel (pl-parameter),"
        "items fill or (pl-sentinel), if fill is not given"
        )
      (pl-at
        procedure:
        (pl-at k pls)
        (pl-at k)
        "returns the kth item of pls"
        )
      (pl-set!
        procedure:
        (pl-set! k val pls)
        "sets the kth item of pls to val"
        )
      (pl-length
        procedure:
        (pl-length pls)
        "returns the length of the pseudolist pls"
        )
      (pl-null?
        procedure:
        (pl-null? xpr)
        "checks, if no items are stored in the pseudolist xpr"
        )
      (pl-head
        procedure:
        (pl-head pls)
        "returns the list part of the pseudolist pls"
        )
      (pl-tail
        procedure:
        (pl-tail pls)
        "returns the sentinel of the pseudolist pls"
        )
      (pl-data
        procedure:
        (pl-data pls)
        "returns the dotted list underlying the pseudolist pls"
        )
      (pl-cons
        procedure:
        (pl-cons x pls)
        (pl-cons x)
        "adds the item x to the front of the pseudolist pls"
        )
      (pl-car
        procedure:
        (pl-car pls)
        "returns the first item of the pseudolist pls"
        )
      (pl-cdr
        procedure:
        (pl-cdr pls)
        "returns a new pseudolist removing the first item of pls"
        )
      (pl-of?
        procedure:
        (pl-of? tag . preds)
        "creates a unary predicate, which tests, if its argument is a"
        "pseudolist with parameter tag, whose items pass all the predicates preds"
        )
      (pl-iterate
        procedure:
        (pl-iterate fn times init)
        (pl-iterate fn times)
        "creates a pseudolist with sentinel (pl-parameter) applying fn"
        "to init recursively k times"
        )
      (pl-drop
        procedure:
        (pl-drop n pls)
        (pl-drop n)
        "returns a new pseudolist removing the first n items of the pseudolist pls"
        )
      (pl-drop-while
        procedure:
        (pl-drop-while ok? pls)
        (pl-drop-while ok?)
        "returns the tail of pls starting with the first item"
        "that does not pass the ok? test"
        )
      (pl-take
        procedure:
        (pl-take n pls)
        (pl-take n)
        "returns a new pseudolist consisting of the first n items of"
        "the pseudolist pls, keeping the sentinel"
        )
      (pl-take-while
        procedure:
        (pl-take-while ok? pls)
        (pl-take-while ok?)
        "returns the sublist of pls consisting of items"
        "until the first item doesn't pass the ok? test."
        )
      (pl-reverse
        procedure:
        (pl-reverse pl)
        "reverses its pseudolist argument to a new pseudolist"
        "with same sentinel"
        )
      (pl-map
        procedure:
        (pl-map fn . plss)
        "maps fn over the pseudolists plss as long as none of the items is"
        "pl-null? and returns a new pseudolist if all sentinels are equal."
        "Note, that this is R7RS-, not R5RS-logic."
        )
      (pl-for-each
        procedure:
        (pl-for-each fn pls . plss)
        "applies fn over the pseudolists (cons pls plss)"
        "stops if one of the items is pl-null?"
        "Note, that this is R7RS-, not R5RS-logic"
        )
      (pl-memp
        procedure:
        (pl-memp ok? pls)
        (pl-memp ok?)
        "returns the subpseudolist starting at the first"
        "item which passes the ok? test, keeping ps's sentinel."
        "Returns #f if no item passes the ok? test"
        )
      (pl-memq
        procedure:
        (pl-memq x pls)
        (pl-memq x)
        "same as (pl-memp (cut eq? <> x) pls)"
        )
      (pl-memv
        procedure:
        (pl-memv x pls)
        (pl-memv x)
        "same as (pl-memp (cut eqv? <> x) pls)"
        )
      (pl-member
        procedure:
        (pl-member x pls)
        (pl-member x)
        "same as (pl-memp (cut equal? <> x) pls)"
        )
      (pl-index
        procedure:
        (pl-index ok? pls)
        (pl-index ok?)
        "returns the index of the first item passing"
        "the ok? test, -1 otherwise"
        )
      (pl-filter
        procedure:
        (pl-filter ok? pls)
        (pl-filter ok?)
        "filters a pseudolist by means of a predicate ok?"
        "returning two new pseudolists, those of items of pls"
        "passing the ok? test, and those that don't"
        )
      (pl-append
        procedure:
        (pl-append pls . plss)
        "appends all argument pseudolist, provided their tags are"
        "all equal"
        )
      (pl-fold-right
        procedure:
        (pl-fold-right op init pls)
        (pl-fold-right op init)
        "folds pls from the right with binary operation op"
        "and starting value init"
        )
      (pl-fold-right0
        procedure:
        (pl-fold-right0 op pls)
        (pl-fold-right0 op)
        "folds (pl-cdr pls) from the right with binary operation op"
        "and starting value (pl-car pls)"
        )
      (pl-fold-left
        procedure:
        (pl-fold-left op init pls)
        (pl-fold-left op init)
        "folds pls from the left with binary operation op"
        "and starting value init"
        )
      (pl-fold-left0
        procedure:
        (pl-fold-left0 op pls)
        (pl-fold-left0 op)
        "folds (pl-cdr pls) from the left with binary operation op"
        "and starting value (pl-car pls)"
        )
      (pl-adjoin
        procedure:
         (pl-adjoin obj pls)
         (pl-adjoin obj)
        "add obj to the front of pls only if it is not already a member of pls"
        )
      (pl-remove-dups
        procedure:
        (pl-remove-dups pls)
        "removes the duplicates in the pseudolist pls"
        )
      (pl-flat?
        procedure:
        (pl-flat? xpr)
        "is xpr a flat pseudolist, i.e. not containing other pseudolists"
        )
      (pl-flatten
        procedure:
        (pl-flatten pl-tree)
        "flattens the nested pseudolist pl-tree to a pseudolist,"
        "i.e. splices the pseudolist items of pl-tree into pl-tree"
        "provided all parameters are equal"
        )
      (pl-collect
        macro:
        (pl-collect item-xpr (var pls ok-xpr ...))
        (pl-collect item-xpr (var pls ok-xpr ...) (var1 pls1 ok-xpr1 ...) ...)
        "creates a new pseudolist by binding var to each element"
        "of the pseudolist pls in sequence, and if it passes the checks,"
        "ok-xpr ..., inserts the value of xpr into the resulting pseudolist."
        "The qualifieres, (var pls 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."
        )
      (pseudolists
        procedure:
        (pseudolists)
        (pseudolists sym)
        "with sym: documentation of exported symbol"
        "without sym: list of exported symbols"
        )
        ))
      )
      (case-lambda
        (() (map car alist))
        ((sym)
         (let ((pair (assq sym alist)))
           (if pair
             (for-each print (cdr pair))
             (print "Choose one of " (map car alist))))))))
)