; 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-collect
   pseudolists
   )

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


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

(define pl-iterate
  (case-lambda
    ((fn times)
     (lambda (init)
       (pl-iterate fn times init)))
    ((fn times init)
     (let recur ((x init) (k 0))
       (if (= k times)
         '()
         (cons x (recur (fn x) (+ k 1))))))
    ))

(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)
  (let loop ((pl pl))
    (if (pl-null? pl)
      pl
      (loop (cdr pl)))))

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

(define pl-at
  (case-lambda
    ((n)
     (lambda (pl)
       (pl-at n pl)))
    ((n pl)
     (let ((pl pl))
       (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)))))))
    ))

(define pl-drop
  (case-lambda
    ((n)
     (lambda (pl)
       (pl-drop n pl)))
    ((n pl)
     (let ((pl pl))
       (assert (or (pl-null? pl) (< -1 n (pl-length pl)))) 
       (let loop ((n n) (pl pl))
         (print "PPP " pl)
         (cond
           ((pl-null? pl) (pl-head pl))
           ((zero? n) (pl-head pl))
           (else
             (loop (- n 1) (cdr pl)))))))
    ))

(define pl-drop-while
  (case-lambda
    ((ok?)
     (lambda (pl)
       (pl-drop-while ok? pl)))
    ((ok? pl)
     (let loop ((pl pl))
       (if (pl-null? pl)
         '()
         (let ((first (car pl)) (rest (cdr pl)))
           (if (ok? first)
             (loop rest)
             (pl-head pl))))))
    ))

(define pl-take
  (case-lambda
    ((n)
     (lambda (pl)
       (pl-take n pl)))
    ((n pl)
     (assert (or (pl-null? pl) (< -1 n (pl-length pl)))) 
     (let recur ((k 0) (pl pl))
       (cond
         ((pl-null? pl)
          '())
         ((< k n)
          (cons (car pl) (recur (+ k 1) (cdr pl))))
         (else (recur (+ k 1) (cdr pl))))))
    ))
     
(define pl-take-while
  (case-lambda
    ((ok?)
     (lambda (pl)
       (pl-take-while ok? pl)))
    ((ok? pl)
     (let recur ((pl pl))
       (if (pl-null? pl)
         '()
         (let ((first (car pl)) (rest (cdr pl)))
           (if (ok? first)
             (cons first (recur rest))
             (recur rest))))))
    )) 

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

(define pl-map
  (case-lambda
    ((fn)
     (lambda (pl)
       (pl-map fn pl)))
    ((fn pl)
     (let recur ((pl pl))
       (if (pl-null? pl)
         '()
         (cons (fn (car pl)) (recur (cdr pl))))))
    ))

(define pl-memp
  (case-lambda
    ((ok?)
     (lambda (pl)
       (pl-memp ok? pl)))
    ((ok? pl)
     (let ((result
             (let recur ((pl pl))
               (if (pl-null? pl)
                 '()
                 (let ((first (car pl))
                       (rest (cdr pl)))
                   (if (ok? first)
                     (cons first rest)
                     (recur rest)))))))
       (if (null? result) #f (pl-head result))))
    ))

(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
  (case-lambda
    ((ok?)
     (lambda (pl)
       (pl-index ok? pl)))
    ((ok? pl)
     (let loop ((k 0) (pl pl))
       (cond
         ((pl-null? pl) -1)
         ((ok? (car pl)) k)
         (else
           (loop (+ k 1) (cdr pl))))))
    ))

(define pl-filter
  (case-lambda
    ((ok?)
     (lambda (pl)
       (pl-filter ok? pl)))
    ((ok? pl)
     (let recur ((pl pl))
       (if (pl-null? pl)
         '()
         (let ((first (car pl)) (rest (cdr pl)))
           (if (ok? first)
             (cons first (recur rest))
             (recur rest))))))
    ))

(define pl-append
  (case-lambda
    ((pl) pl)
    ((pl0 pl1)
     (let recur ((pl pl0))
       (if (pl-null? pl)
         (pl-head pl1)
         (cons (car pl) (recur (cdr pl))))))
    ((pl0 pl1 . pls)
     (pl-append pl0 (apply pl-append pl1 pls)))
    ))

(define pl-fold-right
  (case-lambda
    ((op init)
     (lambda (pl)
       (pl-fold-right op init pl)))
    ((op init pl)
     (let recur ((pl pl))
       (if (pl-null? pl)
         init
         (op (car pl) (recur (cdr pl))))))
    ))

(define pl-fold-right0
  (case-lambda
    ((op)
     (lambda (pl)
       (pl-fold-right0 op pl)))
    ((op pl)
     (let ((pl pl))
       (if (pl-null? pl)
         (error 'pl-fold-right0 "pseudolist empty" pl)
         (apply pl-fold-right op (car pl) (cdr pl)))))
    ))

(define pl-fold-left
  (case-lambda
    ((op init)
     (lambda (pl)
       (pl-fold-left op init pl)))
    ((op init pl)
     (let loop ((pl pl) (result init))
       (if (pl-null? pl)
         result
         (loop (cdr pl) (op result (car pl))))))
    ))

(define pl-fold-left0
  (case-lambda
    ((op)
     (lambda (pl)
       (pl-fold-left0 op pl)))
    ((op pl)
     (let ((pl pl))
       (if (pl-null? pl)
         (error 'pl-fold-left0 "pseudolist empty" pl)
         (apply pl-fold-left op (car pl) (cdr pl)))))
    ))

(define pl-adjoin
  (case-lambda
    ((obj)
     (lambda (pl)
       (pl-adjoin obj pl)))
    ((obj pl)
     (let ((pl pl))
       (if (pair? (pl-member obj pl))
         (pl-head pl)
         (pl-head (cons obj pl)))))
    ))

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

(define (pl-flatten pl-tree)
  (let recur ((tree pl-tree) (result '()))
    (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)
         '()
         (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)
        '()
        (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-maker
      procedure:
      (pl-maker sentinel . args)
      "creates a pseudolist with sentinel from args")
    (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 an atom, i.e. not a pair?")
    (pl-iterate
      procedure:
      (pl-iterate fn k)
      (pl-iterate fn k init)
      "creates a list  applying fn to init"
      "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 sublist 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 sublist of pl consisting of items"
        "which pass the ok? test")
    (pl-map
      procedure:
        (pl-map fn)
        (pl-map fn pl)
        "maps fn over the pseudolist pl and returns a new list")
    (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 to a new list")
    (pl-append
      procedure:
      (pl-append pl . pls)
      "appends all argument pseudolists to a list")
    (pl-memp
      procedure:
      (pl-memp ok?)
      (pl-memp ok? pl)
      "returns the sublist starting at the first"
      "item which passes the ok? test,"
      "returns #f if now 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 stripping the sentinel,"
        "provided, it isn't already there")
    (pl-remove-dups
      procedure:
        (pl-remove-dups lst)
        "removes duplicates of a pseudolist stripping the sentinel")
    (pl-flatten
      procedure:
        (pl-flatten pl-tree)
        "flattens the nested pseudolist tree to a list")
    (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 list."
      "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)