;;; By Jacob J. A. Koot
; Tested with PLT version 352.4-svn15aug2006
; with languages MzScheme and R5RS,
; case insensitve and no debugging.

;;; Preparations -------------------------------------------------

(require (lib "etc.ss"))

; or when running in pure R5RS:
;(define (add1 x) (+ x 1))
;(define (printf s . r) (write (cons s r)) (newline)) ; Not nice, but simple.
;(define (error . x) (write (cons "error" x)) (newline) ("error"))
;(define (identity x) x)
;(define (build-list n p)
; (let loop ((i 0))
;  (if (>= i n) '() (cons (p i) (loop (add1 i))))))

;;; Replace the current evaluator by a version that
; does not halt the program after rasing an error.
; This allows us to show erroneous examples too.
; This does not work in R5RS, of course.

(define standard-eval (current-eval))

(current-eval
 (lambda (x) (let/ec ec
  (parameterize ((error-escape-handler (lambda x (ec (void)))))
   (standard-eval x)))))

"Example 1a" ;---------------------------------------------------------------------------

(define (make-lon n) (build-list n identity)) ; list-producer
(make-lon 10) ; --> (0 1 2 3 4 5 6 7 8 9)

"Example 1b"

(define (make-counter n) ; constructor
 (let ((i 0))
  (lambda ()
   (if (< i n) (let ((r i)) (set! i (add1 i)) r)
    (error "counter exhausted")))))

(define counter (make-counter 10)) ; element-by-element-producer
(counter) ;--> 0
(counter) ;--> 1
(counter) ;--> 2
(counter) ;--> 3
(counter) ;--> 4
(counter) ;--> 5
(counter) ;--> 6
(counter) ;--> 7
(counter) ;--> 8
(counter) ;--> 9
(counter) ; error: counter exhausted

"Example 2" ;-------------------------------------------------------------------------------
; A coroutine returning the numbers 0, 1 and 2 and refusing to be called more than 3 times.

(define coroutine
 (letrec
  ((entry ; The initial contents of the entry is the procedure proper.
    (lambda ()
     (return 0)
     (return 1)
     (return 2)
     (error "expired coroutine"))) ; Make sure no more calls are accepted.
   (exit "we don't know yet")
   (return
    (lambda (value)
     (call-with-current-continuation
      (lambda (cc)
       (set! entry cc)
       (exit value)))))
   (coroutine
    (lambda ()
     (call-with-current-continuation
      (lambda (cc)
       (set! exit cc)
       (entry))))))
  coroutine))
(coroutine) ;--> 0
(coroutine) ;--> 1
(coroutine) ;--> 2
(coroutine) ;--> error: expired coroutine

"Example 3" ;---------------------------------------------------------------------------
; Same as example 2, but with resume-value

(define coroutine
 (letrec
  ((entry ; The initial contents of the entry is the procedure proper.
    (lambda (unused-first-resume-value)
     (return 0)
     (return 1)
     (return 2)
     (error "expired coroutine"))) ; Make sure no more calls are accepted.
   (exit "we don't know yet")
   (return
    (lambda (return-value)
     (call-with-current-continuation
      (lambda (cc)
       (set! entry cc)
       (exit return-value)))))
   (coroutine
    (lambda (resume-value)
     (call-with-current-continuation
      (lambda (cc)
        (set! exit cc)
        (entry resume-value))))))
  coroutine))

(coroutine 'ignored) ;--> 0
(coroutine 'ignored) ;--> 1
(coroutine 'ignored) ;--> 2
(coroutine 'ignored) ;--> error: expired coroutine

"Example 4" ;-----------------------------------------------------------------------------------
; Same as example 3 but with shared variable (called 'local-state') for the entry and the exit.


(define coroutine
 (letrec
  ((local-state ; The initial contents is the procedure proper.
    (lambda (unused-first-resume-value)
     (return 0)
     (return 1)
     (return 2)
     (error "expired coroutine"))) ; Make sure no more calls are accepted.
   (return
    (lambda (return-value)
     (call-with-current-continuation
      (lambda (cc)
       (let ((old-state local-state))
        (set! local-state cc)
        (old-state return-value))))))
   (coroutine
    (lambda (resume-value)
     (call-with-current-continuation
      (lambda (cc)
       (let ((old-state local-state))
        (set! local-state cc)
       (old-state resume-value)))))))
  coroutine))

(coroutine 'ignored) ;--> 0
(coroutine 'ignored) ;--> 1
(coroutine 'ignored) ;--> 2
(coroutine 'ignored) ;--> error: expired coroutine

"Example 5" ;---------------------------------------------------------------------------------------
; Same as example 4, but with shared procedure (called 'toggle') for the coroutine and its returner.

(define coroutine
 (letrec
  ((local-state ; The initial contents is the procedure proper.
    (lambda (unused-first-resume-value)
     (toggle 0)
     (toggle 1)
     (toggle 2)
     (error "expired coroutine"))) ; Make sure no more calls are accepted.
   (toggle
    (lambda (return/resume-value)
     (call-with-current-continuation
      (lambda (cc)
       (let ((old-state local-state))
        (set! local-state cc)
        (old-state return/resume-value)))))))
  toggle))

(coroutine 'ignored) ;--> 0
(coroutine 'ignored) ;--> 1
(coroutine 'ignored) ;--> 2
(coroutine 'ignored) ;--> error: expired coroutine

"Example 6" ;---------------------------------------------------------------------------------------
; Same as example 5, but with finish-procedure.

(define coroutine
 (letrec
  ((local-state
    (lambda (first-resume-value)
     (toggle 0)       
     (toggle 1)
     (toggle 2)
     (finish "this marks the expiration of the coroutine")))
   (toggle
    (lambda (resume/return-value)
     (call-with-current-continuation
      (lambda (cc)
       (let ((old-local-state local-state))
        (set! local-state cc)
        (old-local-state resume/return-value))))))
   (finish
    (lambda (finish-mark)
     (let ((last-exit local-state))
      (set! local-state
       (lambda (resume-value)
        (error "expired-coroutine called with resume-value:" resume-value)))
      (last-exit finish-mark)))))
  toggle))

(coroutine 'ignored) ;--> 0
(coroutine 'ignored) ;--> 1
(coroutine 'ignored) ;--> 2
(coroutine 'ignored) ;--> "this marks the expiration of the coroutine"
(coroutine "one call too much") ;-->
; error: expired-coroutine called with resume-value: "one call too much"

"Procedure make-coroutine-constr" ;----------------------------------------------------------------------------------

(define (make-coroutine-constr procedure-proper terminator)
 (lambda args ; args for data provided during the constuction of the coroutine.
  (letrec
   ((local-state
     (lambda first-resume-values
      (call-with-values
       (lambda ()
        (apply procedure-proper toggle finish (append first-resume-values args)))
       finish)))
    (toggle
     (lambda resume/return-values
      (call-with-current-continuation
       (lambda (cc)
        (let ((old-state local-state))
         (set! local-state cc)
         (apply old-state resume/return-values))))))
    (finish
     (lambda last-return-values
      (let ((last-exit local-state))
       (set! local-state 
        (lambda resume-values
         (apply error "expired-coroutine called with resume-values:" resume-values)))
       (call-with-values (lambda () (apply terminator last-return-values)) last-exit)))))
   toggle)))

"Example 7" ;---------------------------------------------------------------------------------------

(define make-consing-counter
 (make-coroutine-constr
  (lambda (return finish resume-value limit)
   (let loop ((i 0))
    (if (>= i limit) (finish) 
     (begin
      (set! resume-value (return (cons i resume-value)))
      ; The cons is returned to the caller of the coroutine.
      ; When the coroutine is called again, the continuation of the call
      ; to return is called with the resume-value of that coroutine-call.
      ; Hence the resume-value of the next coroutine-call is assigned to
      ; variable resume-value.
      (loop (add1 i))))))
  (lambda x #f))) ; terminator, always returning #f

(define consing-up-to-5 (make-consing-counter 5))

(consing-up-to-5 'aap)  ;--> (0 . aap)
(consing-up-to-5 'noot) ;--> (1 . noot)
(consing-up-to-5 'mies) ;--> (2 . mies)
(consing-up-to-5 'wim)  ;--> (3 . wim)
(consing-up-to-5 'zus)  ;--> (4 . zus)
(consing-up-to-5 'jet)  ;--> #f indicating that the coroutine has expired.
(consing-up-to-5 'teun) ; error: expired-coroutine called with resume-values: teun

"Example 8" ;---------------------------------------------------------------------------------------

; Form a list of all permutations of a given list. Exchanges of equal elements
; (eq? via memq) are not considered to produce new permutations.
; Method: Take all rotations of the list that have different cars.
; Cons the car of each rotation to every permutation of its cdr.
; Append the lists obtained for each rotation such as to form one single list.
; WARNING: this is not the fastest method of making permutations.

(define (list-permutations list-to-be-permuted)
 (if (null? list-to-be-permuted) '(())
 ; The empty list has one permutation, namely the empty list itself.
 ; We must return a list of permutations, hence '(()).
  (let loop ((list-to-be-permuted list-to-be-permuted) (already-been-at-car-position ()))
   (let ((rotation (find-rotation list-to-be-permuted already-been-at-car-position)))
    (if (not rotation) '()
     (let ((kar (car rotation)) (kdr (cdr rotation)))
      (append
       (map (lambda (kdr) (cons kar kdr)) (list-permutations kdr))
       (loop rotation (cons kar already-been-at-car-position)))))))))

(define (find-rotation list-to-be-rotated already-been-at-car-position) 
 (let loop ((head list-to-be-rotated) (tail '())) 
  (and (not (null? head)) 
   (or
    (and (not (memq (car head) already-been-at-car-position)) (append head (reverse tail)))
    ; The reversal of the tail is not necessary.
    ; But without it all names with 'rotation' would be deceptive, of course.
    (loop (cdr head) (cons (car head) tail))))))

(list-permutations '(a a b c)) ; -->
;((a a b c) (a a c b) (a b c a) (a b a c) (a c a b) (a c b a)
; (b c a a) (b a a c) (b a c a) (c a a b) (c a b a) (c b a a))

"Example 9" ;---------------------------------------------------------------------------------------
; Conversion of example 8 into a coroutine.

(define make-permuter
 (make-coroutine-constr
  (lambda (return finish list-to-be-permuted)
   (if (null? list-to-be-permuted) (return '())
    (let ((rotator (make-rotator list-to-be-permuted)))
     (let rotation-loop ()
      (let ((rotation (rotator)))
       (if rotation
        (let ((kar (car rotation)) (kdr-permuter (make-permuter (cdr rotation))))
         (let kdr-permutation-loop ()
          (let ((kdr-permutation (kdr-permuter)))
           (if (not kdr-permutation) (rotation-loop)
            (begin
             (return (cons kar kdr-permutation))
             (kdr-permutation-loop))))))))))))
  (lambda x #f))) ; Terminator always returning #f.

(define make-rotator
 (make-coroutine-constr
  (lambda (return finish list-to-be-rotated)
   (let loop ((head list-to-be-rotated) (tail '()))
    (cond
     ((null? head) (finish))
     ((memq (car head) tail) (loop (cdr head) (cons (car head) tail)))
     (else (return (append head (reverse tail)))
      ; The reversal of the tail is not necessary.
      ; But without it all names with 'rotation' would be deceptive, of course. 
      (loop (cdr head) (cons (car head) tail))))))
  (lambda x #f))) ; Terminator always returning #f.

(define make-rotating-permuter make-permuter)

(define permute-aabc (make-permuter '(a a b c)))

(permute-aabc) ;--> (a a b c)
(permute-aabc) ;--> (a a c b)
(permute-aabc) ;--> (a b c a)
(permute-aabc) ;--> (a b a c)
(permute-aabc) ;--> (a c a b)
(permute-aabc) ;--> (a c b a)
(permute-aabc) ;--> (b c a a)
(permute-aabc) ;--> (b a a c)
(permute-aabc) ;--> (b a c a)
(permute-aabc) ;--> (c a a b)
(permute-aabc) ;--> (c a b a)
(permute-aabc) ;--> (c b a a)
(permute-aabc) ;--> #f ; indicating that the coroutine has expired.

"Example 10" ;---------------------------------------------------------------------------------------
; Same as example 9, but with in situ permutations and exchange in stead of rotation.

(define-syntax while
 (syntax-rules ()
  ((while (test) def/expr ...)
   (while (var test) def/expr ...))
  ((while (var test) def/expr ...)
   (let loop ()
    (let ((var test))
     (if var (let () def/expr ... (loop))))))))

(define make-permuter
 (make-coroutine-constr
  (lambda (return finish list-to-be-permuted)
   (define (return-and-resume) (return #t))
   (if (null? list-to-be-permuted) (return-and-resume)
    (let ((exchanger (make-exchanger list-to-be-permuted)))
     (while ((exchanger))
      (define kdr-permuter (make-permuter (cdr list-to-be-permuted)))
      (while ((kdr-permuter)) (return-and-resume))))))
  (lambda x #f)))

(define make-exchanger
 (make-coroutine-constr
  (lambda (return finish list-to-be-exchanged)
   (define (return-and-resume) (return #t))
   (let loop ((head list-to-be-exchanged) (tail ()))
    (if (not (null? head))
     (let ((car-head (car head)))
      (if (not (memq car-head tail))
       (let ((car-list-to-be-exchanged (car list-to-be-exchanged)))
        ; make exchange
        (set-car! list-to-be-exchanged car-head)
        (set-car! head car-list-to-be-exchanged)
        (return-and-resume)
        ; undo exchange
        (set-car! list-to-be-exchanged car-list-to-be-exchanged)
        (set-car! head car-head)))
       (loop (cdr head) (cons car-head tail))))))
  (lambda x #f)))

(let ((list-to-be-permuted (list 'a 'a 'b 'c)))
 (let ((permuter (make-permuter list-to-be-permuted)))
  (while ((permuter)) (printf "~s " list-to-be-permuted)))
 (newline)) ; --> void
; displayed
; (a a b c) (a a c b) (a b a c) (a b c a) (a c b a) (a c a b)
; (b a a c) (b a c a) (b c a a) (c a b a) (c a a b) (c b a a)

"Example 11: Tower of Hanoi" ;---------------------------------------------------------------------------------------

(define-syntax for ; nested count controlled loop
 (syntax-rules ()
  ((for ((var from to step)) body-expr ...)
   (let ((n (quotient (- to from) step)))
    (do ((i 0 (add1 i))) ((>= i n)) (let ((var (+ from (* i step)))) body-expr ...))))
  ((for ((var from to)) body-expr ...) (for ((var from to 1)) body-expr ...))
  ((for ((var to)) body-expr ...) (for ((var 0 to 1)) body-expr ...))
  ((for (control0 controls ...) body-expr ...)
   (for (control0) (for (controls ...) body-expr ...)))))

(define-for-syntax checking-mode #f)
(define-syntax (check stx)
 (if checking-mode #`(begin #,@(cdr (syntax->list stx))) #'(void)))

(define make-hanoi-mover
 (make-coroutine-constr
  (lambda (return finish mode h f t p)
   (define configuration (make-vector h f))
   (define move-count 0)
   ;------------------------------------------------
   (define               (shortest        h   f t p) ; for uniquely defined shortest path
    (let ((h-1 (sub1 h)))
     (if (positive? h-1) (shortest        h-1 f p t))
                         (move-disk       h-1 f t p)
     (if (positive? h-1) (shortest        h-1 p t f))))
   ;---------------------------------------------------
   (define               (longest         h   f t p) ; for uniquely defined longest non selfcrossing path
    (let ((h-1 (sub1 h)))
     (if (positive? h-1) (longest         h-1 f t p))
                         (move-disk       h-1 f p t)
     (if (positive? h-1) (longest         h-1 t f p))
                         (move-disk       h-1 p t f)
     (if (positive? h-1) (longest         h-1 f t p))))
   ;---------------------------------------------------
   (define               (hamilton        h   f t p) ; for uniquely defined Hamilton path
    (let ((h-1 (sub1 h)))                            ; i.e. circular, along all nodes and non selfcrossing
     (if (positive? h-1) (hamilton-start  h-1 f p t))
                         (move-disk       h-1 f t p)
     (if (positive? h-1) (longest         h-1 p f t)) 
                         (move-disk       h-1 t p f)
     (if (positive? h-1) (longest         h-1 f t p))
                         (move-disk       h-1 p f t)
     (if (positive? h-1) (hamilton-finish h-1 t f p))))
   ;--------------------------------------------------
   (define               (hamilton-start  h   f t p)
    (let ((h-1 (sub1 h)))
     (if (positive? h-1) (hamilton-start  h-1 f p t))
                         (move-disk       h-1 f t p)
     (if (positive? h-1) (longest         h-1 p t f))))
   ;---------------------------------------------------
   (define               (hamilton-finish h   f t p)
    (let ((h-1 (sub1 h)))
     (if (positive? h-1) (longest         h-1 f p t))
                         (move-disk       h-1 f t p)
     (if (positive? h-1) (hamilton-finish h-1 p t f))))
   ;---------------------------------------------------
   (define (move-disk h f t p)
    (check
     (if (not (eq? (vector-ref configuration h) f))
      (error "programming error in make-hanoi-mover"))
     (for ((i (sub1 h)))
      (if (not (eq? (vector-ref configuration i) p))
       (error "programming error in make-hanoi-mover"))))
    (vector-set! configuration h t)
    (let ((m move-count))
     (set! move-count (add1 move-count))
     (return m h f t (vector->list configuration))))
   ((case mode ((longest) longest) ((shortest) shortest) ((hamilton) hamilton)) h f t p))
  (lambda x (values #f #f #f #f #f))))

(for-each
 (lambda (mode)
  (printf "~s~n" mode)
  (let ((mover (make-hanoi-mover mode 3 'a 'b 'c)))
   (let loop ()
    (let-values (((m h f t c) (mover)))
     (if m
      (begin (printf "~s ~s ~s ~s ~s~n" m h f t c) (loop)))))))
'(shortest longest hamilton))

"Example 12: make-coroutine-constr" ;------------------------------------------------------------------------------------
;Pprohibiting procedure proper from calling its coroutine
; and prohibiting caller from calling the returner.

(define (make-coroutine-constr procedure-proper terminator)
 (lambda constr-args ; args for data provided during the constuction of the coroutine.
  (letrec
   ((local-state
     (lambda first-resume-values
      (call-with-values
       (lambda ()
        (apply procedure-proper return finish (append first-resume-values constr-args)))
       finish)))
    (coroutine
     (lambda resume-values
      (call-with-current-continuation
       (lambda (cc)
        (toggler cc resume-values 'coroutine-call 'inactive 'active)))))
    (return
     (lambda return-values
      (call-with-current-continuation
       (lambda (cc)
        (toggler cc return-values 'return 'active 'inactive)))))
    (finish
     (lambda return-values
      (toggler #f (call-with-values (lambda () (apply terminator return-values)) list)
      'finish 'active 'expired)))
    (toggler
     (lambda (new-local-state return/resume-values call-type expected-control-state new-control-state)
      (if (eq? control-state expected-control-state)
       (let ((old-local-state local-state))
        (set! local-state new-local-state)
        (set! control-state new-control-state)
        (apply old-local-state return/resume-values))
       (state-error call-type expected-control-state return/resume-values))))
    (control-state 'inactive) ; other feasible states are: active and expired
    (state-error
     (lambda (call-type expected-control-state return/resume-values)
      (apply error "Coroutine control-state error."
      `(Call-type: ,call-type
        Current-control-state: ,control-state
        Expected-control-state: ,expected-control-state
        Return/resume-values: ,@return/resume-values)))))
   coroutine)))

; A coroutine whose procedure proper tries to call its own coroutine.
(define make-cor (make-coroutine-constr (lambda (return finish) (cor 1 2 3)) (lambda x #f)))
(define cor (make-cor))
(cor) ;--> Error: Coroutine control-state error. call-type: coroutine-call current-control-state: active expected-control-state: inactive return/resume-values: 1 2 3

; A return-procedure being called by the caller.
(define make-cor (make-coroutine-constr (lambda (return finish) (return return)) (lambda x #f)))
(define cor (make-cor))
(define return (cor))
(return 4 5 6) ;Error: Coroutine control-state error. call-type: return current-control-state: inactive expected-control-state: active return/resume-values: 4 5 6

; Attempt to call an expired coroutine.
(define make-cor (make-coroutine-constr (lambda (return finish) (finish)) (lambda x #f)))
(define cor (make-cor))
(cor) ;--> #f
(cor 7 8 9) ;Error: Coroutine control-state error. call-type: coroutine-call current-control-state: expired expected-control-state: inactive return/resume-values: 7 8 9

"end"