; Author: Juergen Lorenz ; ju (at jugilo (dot) de
;
; Copyright (c) 2013-2019, 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-maker pl-iterate pl? pl-of?
   pl-null? pl-length pl-head pl-sentinel
   pl-flatten pl-reverse
   pl-index pl-filter pl-map 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-for pseudolists
   )

  (import scheme
          (only (chicken base) cut case-lambda assert print error))

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

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

(define (pl? xpr)
  #t)

(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)))
        (ok? xpr)))))

(define (pl-null? xpr)
  (not (pair? xpr)))

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

(define (pl-sentinel pl)
  (if (pl-null? pl)
    pl
    (let ((rest (cdr pl)))
      (if (pl-null? rest)
        rest
        (pl-sentinel rest)))))

(define (pl-head pl)
  (let ((len (pl-length pl)))
    (let recur ((k 0) (pl pl))
      (cond
        ((pl-null? pl) '())
        ((< k len)
         (cons (car pl) (recur (+ k 1) (cdr pl))))
        (else (recur (+ k 1) (cdr pl)))))))

(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 (pl-null? pl)
           pl
           (let ((first (car pl)) (rest (cdr pl)))
             (if (ok? first)
               (loop rest)
               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))
             (recur rest))))))
    (else (error 'pl-take-while "too many arguments"))))
     
(define (pl-reverse pl)
  (let loop ((pl pl) (result (pl-sentinel pl)))
    (if (pl-null? pl)
      result
      (loop (cdr pl) (cons (car pl) result)))))

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

(define (pl-memp ok? . pls)
  (cond
    ((null? pls)
     (lambda (pl)
       (pl-memp 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 rest)
             (recur rest))))))
    (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)
         pl
         (let ((first (car pl)) (rest (cdr pl)))
           (if (ok? first)
             (cons first (recur rest))
             (recur rest))))))
    (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)))))
    ))

(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)))))
    ))

(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 tree)
  ; imported flatten doesn't work with pl-makers
  (let recur ((tree tree) (result '()))
    (cond
      ((pair? tree)
       (recur (car tree) (recur (cdr tree) result)))
      ((null? tree) result)
      (else
        (cons tree result)))))

;;; (pl-for ((var pl ok-xpr ...) (var1 pl1 ok-xpr1 ...) ...) item-xpr)
;;; ------------------------------------------------------------------
(define-syntax pl-for
  (syntax-rules ()
   ((_ ((var pl ok-xpr ...)) item-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)))))))
    ((_ ((var pl ok-xpr ...) (var1 pl1 ok-xpr1 ...) ...) item-xpr)
     (let recur ((seq pl))
       (if (pl-null? seq)
         seq
         (let ((var (car seq)))
           (if (and ok-xpr ...)
             (pl-append (pl-for ((var1 pl1 ok-xpr1 ...) ...) item-xpr)
                        (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-maker
      procedure:
        (pl-maker sentinel . args)
        "creates a new pseudolist from args"
        "and sentinel")
    (pl?
      procedure:
        (pl? xpr)
        "is xpr a pl?"
        "i.e. not a list?")
    (pl-of?
      procedure:
      (pl-of? . preds)
      "returns a unary predicate, which checks"
      "if its argument passes each predicate in preds")
    (pl-null?
      procedure:
        (pl-null? xpr)
        "is xpr pl-null?, i.e. not a pair")
    (pl-iterate
      procedure:
      (pl-iterate sentinel k fn)
      (pl-iterate sentinel k fn init)
      "creates a pseudolist with sentinel applying fn to int"
      "recursively k times")
    (pl-length
      procedure:
        (pl-length pl)
        "length of a pseudolist pl"
        "the sentinel doesn't count")
    (pl-sentinel
      procedure:
        (pl-sentinel pl)
        "returns the sentinel of pl")
    (pl-head
      procedure:
        (pl-head pl)
        "returns the list of items with pl's sentinel stripped")
    (pl-at
      procedure:
        (pl-at k)
        (pl-at k pl)
        "returns the kth item of pl")
    (pl-drop
      procedure:
        (pl-drop pl)
        (pl-drop n pl)
        "returns the tail of pl removing all head items"
        "that pass the ok? test")
    (pl-drop-while
      procedure:
        (pl-drop-while pl)
        (pl-drop-while n 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)
        (pl-take pl)
        "returns the head of pl up to but excluding index n,"
        "where n is less than or equal to pl's pl-length")
    (pl-take-while
      procedure:
        (pl-take-while pl)
        (pl-take-while ok? pl)
        "returns the head of pl consisting of items"
        "which pass the ok? test")
    (pl-map
      procedure:
        (pl-map fn pl)
        "maps fn over the pseudolist pl")
    (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?")
    (pl-reverse
      procedure:
      (pl-reverse pl)
      "reverses its pseudolist argument")
    (pl-append
      procedure:
      (pl-append pl . pls)
      "appends all argument pseudolists")
    (pl-memp
      procedure:
      (pl-memp ok? pl)
      "returns the sub-pseudolist starting at the first"
      "item which passes the ok? test")
    (pl-member
      procedure:
      (pl-member x pl)
      "same as (pl-memp (cut equal? <> x) pl)")
    (pl-memq
      procedure:
      (pl-memq x pl)
      "same as (pl-memp (cut eq? <> x) pl)")
    (pl-memv
      procedure:
      (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")
    (pl-flatten
      procedure:
        (pl-flatten tree)
        "flattens the nested pseudolist tree to a proper list")
    (pl-for
      macro:
      (pl-for ((var pl ok-xpr ...) (var1 pl1 ok-xpr1 ...) ...) xpr)
      "creates a new pseudolist 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.")
    )))
    (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)