; 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
   Some-sentinel No-sentinel sentinel ;sentinel-option sentinel-option?
   )

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

(define (any? xpr) #t)

(define-datatype sentinel-option sentinel-option?
  (Some-sentinel (x any?))
  (No-sentinel))

(define (sentinel opt)
  (cases sentinel-option opt
    (Some-sentinel (x) x)
    (No-sentinel () '())))

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

(define (pl-iterate opt fn times . inits)
  (cond
    ((null? inits)
     (lambda (x)
       (pl-iterate opt fn times x)))
    ((null? (cdr inits))
     (let recur ((x (car inits)) (k 0))
       (if (= k times)
         (sentinel opt)
         (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)
  (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))
         (cond
           ((pl-null? pl) pl)
           ((zero? n) 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)
         pl
         (let ((first (car pl)) (rest (cdr pl)))
           (if (ok? first)
             (loop rest)
             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)
          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)
         pl
         (let ((first (car pl)) (rest (cdr pl)))
           (if (ok? first)
             (cons first (recur rest))
             (recur rest))))))
    )) 

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

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

(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
  (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)
         pl
         (let ((first (car pl)) (rest (cdr pl)))
           (if (ok? first)
             (cons first (recur rest))
             (recur rest))))))
    ))

(define (pl-append opt pl . pls)
  (cond
    ((null? pls); pl)
     (let recur ((pl pl))
       (if (pl-null? pl)
         (sentinel opt)
         (cons (car pl) (recur (cdr pl))))))
    ((null? (cdr pls))
     (let recur ((pl pl))
       (if (pl-null? pl)
         (pl-append opt (car pls))
         (cons (car pl) (recur (cdr pl))))))
    (else
      (pl-append opt pl (apply pl-append opt (car pls) (cdr 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
         (cons obj pl))))
    ))

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

(define (pl-flatten opt pl-tree)
  (let recur ((tree pl-tree) (result (sentinel opt)))
    (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)))

;;; (pl-for ((var pl ok-xpr ...) ....) opt item-xpr)
;;; ------------------------------------------------
(define-syntax pl-for
  (syntax-rules ()
   ;((_ ((var pl ok-xpr ...)) opt item-xpr)
   ((_ opt item-xpr (var pl ok-xpr ...))
     (let recur ((seq pl))
       (if (pl-null? seq)
         (sentinel opt)
         (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 ...) ...) opt item-xpr)
   ((_ opt item-xpr (var pl ok-xpr ...) (var1 pl1 ok-xpr1 ...) ...)
    (let recur ((seq pl))
      (if (pl-null? seq)
        (sentinel opt)
        (let ((var (car seq)))
          (if (and ok-xpr ...)
            (pl-append opt ;(pl-for ((var1 pl1 ok-xpr1 ...) ...) opt item-xpr)
                       (pl-for opt 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 opt . args)
        "creates a new pseudolist with (sentinel opt) 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 pl-null?, i.e. not a pair")
    (pl-iterate
      procedure:
      (pl-iterate opt fn k)
      (pl-iterate opt fn k init)
      "creates a pseudolist with (sentinel opt) 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 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 opt fn)
        (pl-map opt fn pl)
        "maps fn over the pseudolist pl"
        "and returns a new pseudolist with (sentinel opt)")
    (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 opt pl)
      "reverses its pseudolist argument to a now one"
      "with (sentinel opt)")
    (pl-append
      procedure:
      (pl-append opt pl . pls)
      "appends all argument pseudolists to a pseudolist"
      "with (sentinel opt)")
    (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 opt pl-tree)
        "flattens the nested pseudolist tree to a"
        "pseudolist with (sentinel opt)")
    (pl-for
      macro:
      (pl-for opt xpr (var pl ok-xpr ...) ....)
      "creates a new pseudolist with (sentinel opt) 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)
;(ppp
;  (pl-iterate (No-sentinel) add1 5 0)
;  (pl-iterate (Some-sentinel #f) add1 5 0)
;  (pl-iterate (No-sentinel) add1 5)
;  (map (pl-iterate (No-sentinel) add1 5) '(0 1 2 3))
;  (pl-map (No-sentinel) add1 '(0 1 2 3 . #f))
;  (map (pl-map (No-sentinel) add1) '((0 1 2) (10 20 30)))
;  ;(pl-for ((x '(0 1 2 3 . #f))) (Some-sentinel #t) (add1 x)) ; map
;  (pl-for (Some-sentinel #t) (add1 x) (x '(0 1 2 3 . #f)))
;  ;(pl-for ((x '(0 1 2 3))) (No-sentinel) (add1 x)) ; map
;  (pl-for (No-sentinel) (add1 x) (x '(0 1 2 3)))
;  ;(pl-for ((x '(0 1 2)) (y '(10 20 30))) (No-sentinel) (+ x y))
;  (pl-for (No-sentinel) (+ x y) (x '(0 1 2)) (y '(10 20 30)))
;  (pl-flatten (Some-sentinel #t) '(0 (1 (2 . #f) . #f) . #f))
;  (pl-flatten (No-sentinel) '(0 (1 2) (3 4 . #f) 5 . #f))
;  (pl-append (No-sentinel) '(0 1 2 . #f))
;  (pl-append (Some-sentinel #t) '(0 1 . #f) '(2 . #f) '(3 . #f))
;  )
;