; Author: Juergen Lorenz
; ju (at) jugilo (dot) de
;
; Copyright (c) 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 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 is inspired by

Roshan James'
call/cc based implementation of Yield the Magnificent for Scheme

Iterators are implemented with the macro lambda-yield and accessed with
the macro iterate.

They are then packaged into a coroutine object.

]|#

(module iterators (
  iterators
  lambda-yield
  define-iterator
  iterate
  yield-all
  coroutine
  coroutine?
  co-move
  co-value
  co-return
  co-finished?
  co-not-finished?
  coroutines
  co-move-all
  co-all-finished?
  co-any-finished?
  co-none-finished?
  co-values
  co-return-all
  co-return-each
  )

  (import scheme
          (only (chicken base)
                define-record-type
                case-lambda
                print))

;;; MACROS

;;; (lambda-yield args xpr . xprs)
;;; ------------------------------
;;; curried lambda, which can yield a value in its body.
;;; Not hygienic because of yield.
(define-syntax lambda-yield
  (er-macro-transformer
    (lambda (form rename compare?)
      (let ((args (cadr form))
            (xpr (caddr form))
            (xprs (cdddr form))
            (%lambda (rename 'lambda)))
        `(,%lambda ,args
           (,%lambda (yield) ,xpr ,@xprs))))))

;;; (define-iterator (name . args) xpr . xprs)
;;; ------------------------------------------
;;; defines a procedure, name, with lambda-yield instead of lambda.
;;; Not hygienic because of yield.
(define-syntax define-iterator
  (er-macro-transformer
    (lambda (form rename compare?)
      (let ((signature (cadr form))
            (xpr (caddr form))
            (xprs (cdddr form))
            (%define (rename 'define))
            (%lambda-yield (rename 'lambda-yield)))
        `(,%define ,(car signature)
           (,%lambda-yield ,(cdr signature) ,xpr ,@xprs))))))

;;; (iterate iterator xpr . xprs)
;;; -----------------------------
;;; invokes xpr . xprs whenever the iterator yields;
;;; not hygienic, exports 'break' and 'it';
;;; 'it' is the result of a yield and 'break' an escape-procedure.
(define-syntax iterate
  (er-macro-transformer
    (lambda (form rename compare?)
      (let ((iter (cadr form))
            (xpr (caddr form))
            (xprs (cdddr form))
            (%lambda (rename 'lambda))
            (%call-with-current-continuation
              (rename 'call-with-current-continuation)))
        `(,%call-with-current-continuation
           (,%lambda  (break)
             (,iter (,%lambda (it) ,xpr ,@xprs))))))))

;;; (yield-all iterator)
;;; --------------------
;;; yields all values of an iterator;
;;; equivalent to (iterate iterator (yield it));
;;; not hygienic because of yield
(define-syntax yield-all
  (er-macro-transformer
    (lambda (form rename compare?)
      (let ((iter (cadr form))
            (%it (rename 'it))
            (%lambda (rename 'lambda)))
        `(,iter (,%lambda (,%it) (yield ,%it)))))))
      ;(let ((iter (cadr form))
      ;      (%iterate (rename 'iterate)))
      ;  `(,%iterate ,iter (yield it))))))

;;; Coroutines
;;; ----------
;;; A coroutine wraps an iterator into a coroutine object.
;;; This object is represented by a record with two slots:
;;; cont and val.
;;;
;;; values of cont
;;; --------------
;;; when couroutine is created: continuation obtained by moving the first lambda, 
;;; when iterator is running: the continuation of iterator
;;; when iterator has returned: #f
;;;
;;; values of val
;;; -------------
;;; when coroutine is created: #t
;;; when iterator is running: current yielded value
;;; when iterator has returned: final return value
;;;
;;; Coroutines can sent return values, by replacing val before calling
;;; co-move

;; coroutine as record
;; -------------------
(define-record-type Coroutine
  (co-maker cont val)
  coroutine?
  (cont co-proc)
  (val  co-val))

;;; (coroutine iterator)
;;; --------------------
;;; packages the iterator, i.e. a unary procedure of the yield
;;; argument, into a coroutine and does a first move, so that the proc
;;; field is an escape-procedure 
(define (coroutine iter)
  (co-move
    (co-maker
      ;; first lambda
      (lambda (co)
        (let* ((esc (co-proc co))
               (next (lambda (it)
                       (let ((res (call-with-current-continuation
                                    (lambda (k)
                                      (esc (co-maker k it))))))
                         (set! esc (co-proc res))
                         (co-val res))))
               (stopped (co-maker #f (iter next))))
          (esc stopped)))
      #t)))

(define (co-move co)
  ;; iterates internal iterator till it yields or till it returns.
  ;; returns new coroutine
  (call-with-current-continuation
    (lambda (esc)
    ((co-proc co) (co-maker esc (co-val co))))))

(define co-value co-val)

(define (co-finished? co)
  (not (co-proc co)))

(define (co-not-finished? co)
  (procedure? (co-proc co)))

(define (co-return val co)
  ;; sets a return value into the coroutine and returns the new
  ;; coroutine. This return value can be yielded by the internal
  ;; iterator
  (co-maker (co-proc co) val))

;;; coroutines (plural!)
;;; --------------------
(define (reduce proc xs) ; internal
  (if (null? (cddr xs))
      (proc (car xs) (cadr xs))
      (proc (car xs) (reduce proc (cdr xs)))))

(define (coroutines . iters)
  (map coroutine iters))

(define (co-all-finished? cos)
  (reduce (lambda (a b) (and a b))
          (map (lambda (co) (co-finished? co))
               cos)))

(define (co-any-finished? cos)
  (reduce (lambda (a b) (or a b))
          (map (lambda (co) (co-finished? co))
               cos)))

(define (co-none-finished? cos)
  (reduce (lambda (a b) (and a b))
          (map (lambda (co) (co-not-finished? co))
               cos)))

(define (co-values cos)
  (map co-value cos))

(define (co-move-all cos)
  (map co-move cos))

(define (co-return-all ret cos)
  (map (lambda (co) (co-return ret co))
       cos))

(define (co-return-each vals cos)
  (map (lambda (val co) (co-return val co))
       vals cos))

;;; documentation
(define iterators
  (let (
    (alist '(
      (iterators
        procedure:
        (iterators [sym])
        "documentation procedure")
      (lambda-yield
        macro:
        (lambda-yield args xpr . xprs)
        "a curried lambda which can yield a value in its body"
        "not hygienic because of yield")
      (define-iterator
        macro:
        (define-iterator (name . args) xpr . xprs)
        "defines a procedure, name, with lambda-yield instead of lambda"
        "not hygienic because of yield")
      (iterate
        macro:
        (iterate iter xpr . xprs)
        "invokes xpr . xprs whenever the iterator yields"
        "the yielded value is available as 'it'"
        "iterator can be aborted calling escape-procedure 'break'"
        "not hygienic because of it and break")
      (yield-all
        macro:
        (yield-all iter)
        "yields all values of an iterator"
        "equivalent to (iterate iter (yield it))"
        "not hygienic because of yield")
      (coroutine
        procedure:
        (coroutine iter)
        "wraps an iterator into a coroutine object")
      (coroutine?
        procedure:
        (coroutine xpr)
        "type predicate")
      (co-move
        procedure:
        (co-move co)
        "moves the internal iterator of a coroutine"
        "till it yields or till it returns")
      (co-value
        procedure:
        (co-value co)
        "retrieves the current value of the coroutine")
      (co-return
        procedure:
        (co-return val co)
        "sets a return value into the coroutine")
      (co-finished?
        procedure:
        (co-finished co)
        "true, if the coroutine can not be moved")
      (co-not-finished?
        procedure:
        (co-not-finished co)
        "true, if the coroutine can be moved")
      (coroutines
        procedure:
        (coroutines . iters)
        "creates multiple coroutines from multiple iterators")
      (co-move-all
        procedure:
        (co-move-all cos)
        "moves each coroutine")
      (co-all-finished?
        procedure:
        (co-all-finished? cos)
        "true if no coroutine can be moved")
      (co-any-finished?
        procedure:
        (co-any-finished? cos)
        "true, if some coroutine can not be moved")
      (co-none-finished?
        procedure:
        (co-none-finished? cos)
        "true, if all coroutines can be moved")
      (co-values
        procedure:
        (co-values cos)
        "returns all the coroutines values")
      (co-return-all
        procedure:
        (co-return-all val cos)
        "sets all coroutines values to val"
        "and returns the new corotines")
      (co-return-each
        procedure:
        (co-retrurn-each vals cos)
        "sets each coroutine's value"
        "to the corresponding item of vals"
        "and returns the new corotines")
      ))
    )
    (case-lambda
      (() (map car alist))
      ((sym)
       (let ((pair (assq sym alist)))
         (if pair
           (cdr pair)
           (print "Choose one of " (map car alist))))))))

) ; module iterators