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


#|[
This module implements some list creating routines, in particular the
macros for and for*. The latter is inspired by Clojure's for.
]|#

(module list-comprehensions
  (list-comprehensions for for* range repeat
   iterate-while iterate-until iterate-times)

  (import scheme
          (only chicken case-lambda error print))

(define range
  (case-lambda
    ((upto)
     (if (>= upto 0)
       (range 0 upto 1)
       (range 0 upto -1)))
    ((from upto)
     (if (>= upto from)
       (range from upto 1)
       (range from upto -1)))
    ((from upto step)
     (cond
       ((and (>= upto from) (positive? step))
        (let loop ((k from) (result '()))
          (if (>= k upto)
            (reverse result)
            (loop (+ k step) (cons k result)))))
       ((and (< upto from) (negative? step))
        (let loop ((k from) (result '()))
          (if (<= k upto)
            (reverse result)
            (loop (+ k step) (cons k result)))))
       (else
         (error 'range "wrong sign of" step))))))

(define (repeat times)
  (lambda (x)
    (let loop ((k 0) (result '()))
      (if (= k times)
        result
        (loop (+ k 1) (cons x result))))))

(define (iterate-while fn ok?)
  (lambda (start)
    (let loop ((var start) (result '()))
      (if (ok? var)
        (loop (fn var) (cons var result))
        (reverse result)))))

(define (iterate-until fn ok?)
  (lambda (start)
    (let loop ((var start) (result '()))
      (if (ok? var)
        (reverse result)
        (loop (fn var) (cons var result))))))

(define (iterate-times fn times)
  (lambda (start)
    (let loop ((var start) (k 0) (result '()))
      (if (= k times)
        (reverse result)
        (loop (fn var) (+ k 1) (cons var result))))))

;;; (for ((x xstart xnext xstop? xwhen? ...)
;;;       (y ystart ynext ystop? ywhen? ...)
;;;       ...)
;;;      xpr . xprs) 
;;; ----------------------------------------
;;; parallel version
(define-syntax for
  (er-macro-transformer
    (lambda (form rename compare?)
      (let ((decls (cadr form))
            (xpr (caddr form))
            (xprs (cdddr form))
            (%if (rename 'if))
            (%let (rename 'let))
            (%and (rename 'and))
            (%cons (rename 'cons))
            (%proc (rename 'proc))
            (%loop (rename 'loop))
            (%lambda (rename 'lambda))
            (%append (rename 'append))
            (%result (rename 'result))
            (%reverse (rename 'reverse))
            )
        (let ((vars (map car decls))
              (starts (map cadr decls))
              (nexts (map caddr decls))
              (stops (map cadddr decls))
              (whens (map cddddr decls)))
          (letrec (
            (every?
              (lambda whens
                (lambda (x)
                  (let loop ((ws whens))
                    (if (null? ws)
                      #t
                      (and ((car whens) x)
                           ((apply every? (cdr whens)) x)))))))
            (multi
              (lambda (next . whens)
                (lambda (arg)
                  (let loop ((result arg))
                    (if ((apply every? whens) result)
                      result
                      (loop (next result)))))))
            )
            `(,%let (
               (,%proc (,%lambda ,vars ,xpr ,@xprs))
               )
               (,%let ,%loop
                 ,(cons
                    `(,%result '())
                    (map (lambda (var start next when)
                           `(,var ((,multi
                                     (,%lambda (,var) ,next)
                                     ,@(map (lambda (w)
                                              `(,%lambda (,var) ,w))
                                            when))
                                   ,start)))
                         vars starts nexts whens))
                 (,%if (,%and ,@stops)
                   (,%reverse ,%result)
                   (,%loop (,%cons (,%proc ,@vars) ,%result)
                           ,@(map (lambda (var start next when)
                                    `((,multi
                                        (,%lambda (,var) ,next)
                                        ,@(map (lambda (w)
                                                 `(,%lambda (,var) ,w))
                                               when))
                                      ,next))
                                  vars starts nexts whens)))
                 ))))))))

;;; (for* ((x xstart xnext xstop? xwhen? ...)
;;;        (y ystart ynext ystop? ywhen? ...)
;;;        ...)
;;;       xpr . xprs) 
;;; ----------------------------------------
;;; sequential version
(define-syntax for*
  (syntax-rules ()
    ((_ ((x xstart xnext xstop? xwhen? ...))
        xpr) 
     (for ((x xstart xnext xstop? xwhen? ...))
       xpr)) 
    ((_ ((x xstart xnext xstop? xwhen? ...)
         (y ystart ynext ystop? ywhen? ...)
         ...)
        xpr . xprs) 
     (apply append
       (for ((x xstart xnext xstop? xwhen? ...))
         (for* ((y ystart ynext ystop? ywhen? ...)
                ...)
               xpr . xprs))))))

;;; (list-comprehensions sym ..)
;;; ----------------------------
;;; documentation procedure
(define list-comprehensions
  (let ((als '(
    (list-comprehensions
      procedure:
      (list-comprehensions sym ..)
      "documentation procedure")
    (range
      procedure:
      (range upto)
      (range from upto)
      (range from upto step)
      "creates a list of numbers with given limits"
      "from defaults to 0"
      "step defaults to 1")
    (repeat
      procedure:
      (repeat times)
      "returns a unary procedure which repeats its only argument"
      "a number of times")
    (iterate-times
      procedure:
      (iterate-times fn times)
      "returns a unary procedure which iterates the function fn"
      "on its only argument a number of times")
    (iterate-while
      procedure:
      (iterate-while fn ok?)
      "returns a unary procedure which iterates the function fn"
      "on its only argument while the predicate ok? returns true")
    (iterate-until
      procedure:
      (iterate-until fn ok?)
      "returns a unary procedure which iterates the function fn"
      "on its only argument until the predicate ok? returns true")
    (for
      macro:
      (for ((x xstart xnext xstop xwhen ...)
            (y ystart ynext ystop ywhen ...)
            ...) xpr . xprs)
     "creates a list from items x y ..."
     "im parallel starting at xstart ystart ..."
     "iterating them with xnext ynext ..."
     "upto xstop ystop ..."
     "under the condition xwhen ... ywhen ..."
     "by means of the body xpr . xprs")
    (for*
      macro:
      (for* ((x xstart xnext xstop xwhen ...)
             (y ystart ynext ystop ywhen ...)
             ...) xpr . xprs)
     "creates a list from items x y ..."
     "sequentially starting at xstart ystart ..."
     "iterating them with xnext ynext ..."
     "upto xstop ystop ..."
     "under the condition xwhen ... ywhen ..."
     "by means of the body xpr . xprs")
    )))
    (case-lambda
      (()
       (map car als))
      ((sym)
       (let ((pair (assq sym als)))
         (if pair
           (for-each print (cdr pair))
           (error "Not in list"
                  sym
                  (map car als))))))))

) ; module list-comprehensions