#lang scheme
(require (lib "etc.ss") test-engine/scheme-tests scheme/control)

(define (make-lon n) (build-list n identity))
(check-expect (make-lon 10) '(0 1 2 3 4 5 6 7 8 9))

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

(define counter (make-counter 10))

(check-expect (counter) 0)
(check-expect (counter) 1)
(check-expect (counter) 2)
(check-expect (counter) 3)
(check-expect (counter) 4)
(check-expect (counter) 5)
(check-expect (counter) 6)
(check-expect (counter) 7)
(check-expect (counter) 8)
(check-expect (counter) 9)
(check-error (counter) "counter exhausted")

(define coroutine1
 (letrec
  ((entry
    (lambda ()
     (return 0)
     (return 1)
     (return 2)
     (error "expired coroutine")))
   (exit "we don't know yet")
   (return
    (lambda (return-value)
     (call-with-current-continuation
      (lambda (cc)
       (set! entry cc)
       (exit return-value)))))
   (coroutine
    (lambda ()
     (call-with-current-continuation
      (lambda (cc)
       (set! exit cc)
       (entry))))))
  coroutine))

(check-expect (coroutine1) 0)
(check-expect (coroutine1) 1)
(check-expect (coroutine1) 2)
(check-error (prompt (coroutine1)) "expired coroutine")

(define coroutine2
 (letrec
  ((entry
    (lambda (first-resume-value)
     (return 0)
     (return 1)
     (return 2)
     (error "expired coroutine")))
   (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))

(check-expect (coroutine2 'ignored) 0)
(check-expect (coroutine2 'ignored) 1)
(check-expect (coroutine2 'ignored) 2)
(check-error (prompt (coroutine2 'ignored)) "expired coroutine")

(define coroutine3
 (letrec
  ((local-state
    (lambda (first-resume-value)
     (return 0)
     (return 1)
     (return 2)
     (error "expired coroutine")))
   (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))

(check-expect (coroutine3 'ignored) 0)
(check-expect (coroutine3 'ignored) 1)
(check-expect (coroutine3 'ignored) 2)
(check-error (prompt (coroutine3 'ignored)) "expired coroutine")

(define coroutine4
 (letrec
  ((local-state
    (lambda (first-resume-value)
     (toggle 0)
     (toggle 1)
     (toggle 2)
     (error "expired coroutine")))
   (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))

(check-expect (coroutine4 'ignored) 0)
(check-expect (coroutine4 'ignored) 1)
(check-expect (coroutine4 'ignored) 2)
(check-error (prompt (coroutine4 'ignored)) "expired coroutine")

(define coroutine5
 (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))

(check-expect (coroutine5 'ignored) 0)
(check-expect (coroutine5 'ignored) 1)
(check-expect (coroutine5 'ignored) 2)
(check-expect (coroutine5 'ignored)
 "this marks the expiration of the coroutine")
(check-error (prompt (coroutine5 'ignored))
 "expired-coroutine called with resume-value: ignored")

(define (make-coroutine-constr proc-maker terminator)
 (lambda constr-args ; args for data provided during the construction of the coroutine
  (letrec
   ((local-state
     (lambda first-resume-values
      (call-with-values
       (lambda ()
        (apply procedure-proper first-resume-values))
       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))))
    (procedure-proper (apply proc-maker toggle finish constr-args)))
   toggle)))

(define make-consing-counter
 (make-coroutine-constr
  (lambda (toggle finish limit)
   (lambda (resume-value)
    (let loop ((i 0))
     (if (>= i limit) (finish) 
      (begin
       (set! resume-value (toggle (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 toggle 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))

(check-expect (consing-up-to-5 'aap)  '(0 . aap))
(check-expect (consing-up-to-5 'noot) '(1 . noot))
(check-expect (consing-up-to-5 'mies) '(2 . mies))
(check-expect (consing-up-to-5 'wim)  '(3 . wim))
(check-expect (consing-up-to-5 'zus)  '(4 . zus))
(check-expect (consing-up-to-5 'jet)  '#f)
(check-error  (consing-up-to-5 'teun)
 "expired-coroutine called with resume-values: teun") 

(define (list-permutations list-to-be-permuted)
 (if (null? list-to-be-permuted) '(())
  (let loop ((list-to-be-permuted list-to-be-permuted) (already-been-at-car '()))
   (let ((rotation (find-rotation list-to-be-permuted already-been-at-car)))
    (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)))))))))

(define (find-rotation list-to-be-rotated already-been-at-car) 
 (let loop ((head list-to-be-rotated) (tail '())) 
  (and (not (null? head)) 
   (or
    (and (not (memq (car head) already-been-at-car)) (append head (reverse tail)))
    (loop (cdr head) (cons (car head) tail))))))

(check-expect (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)))

(define make-permuter
 (make-coroutine-constr
  (lambda (toggle finish list-to-be-permuted)
   (lambda ()
    (if (null? list-to-be-permuted) (toggle '())
     (let ((rotator (make-rotator list-to-be-permuted)))
      (let rotation-loop ()
       (let ((rotation (rotator)))
        (when 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
              (toggle (cons kar kdr-permutation))
              (kdr-permutation-loop)))))))))))))
  (lambda x #f)))

(define make-rotator
 (make-coroutine-constr
  (lambda (toggle finish list-to-be-rotated)
   (lambda ()
    (let loop ((head list-to-be-rotated) (tail '()))
     (cond
      ((null? head) (finish))
      ((memq (car head) tail) (loop (cdr head) (cons (car head) tail)))
      (else (toggle (append head (reverse tail))) 
       (loop (cdr head) (cons (car head) tail)))))))
  (lambda x #f)))

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

(check-expect (permute-aabc) '(a a b c))
(check-expect (permute-aabc) '(a a c b))
(check-expect (permute-aabc) '(a b c a))
(check-expect (permute-aabc) '(a b a c))
(check-expect (permute-aabc) '(a c a b))
(check-expect (permute-aabc) '(a c b a))
(check-expect (permute-aabc) '(b c a a))
(check-expect (permute-aabc) '(b a a c))
(check-expect (permute-aabc) '(b a c a))
(check-expect (permute-aabc) '(c a a b))
(check-expect (permute-aabc) '(c a b a))
(check-expect (permute-aabc) '(c b a a))
(check-expect (permute-aabc) #f)

(require scheme/mpair)

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

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

(define make-exchanger
 (make-coroutine-constr
  (lambda (toggle finish list-to-be-exchanged)
   (define (return-and-resume) (toggle #t))
   (lambda ()
    (let loop ((head list-to-be-exchanged) (tail '()))
     (when (not (null? head))
      (let ((car-head (mcar head)))
       (when (not (mmemq car-head tail))
        (let ((car-list-to-be-exchanged (mcar list-to-be-exchanged)))
         ; make exchange
         (set-mcar! list-to-be-exchanged car-head)
         (set-mcar! head car-list-to-be-exchanged)
         (return-and-resume)
         ; undo exchange
         (set-mcar! list-to-be-exchanged car-list-to-be-exchanged)
         (set-mcar! head car-head)))
        (loop (mcdr head) (mcons car-head tail)))))))
  (lambda x #f)))

(check-expect
 (let ((string-port (open-output-string)))
  (parameterize ((current-output-port string-port))
   (let ((list-to-be-permuted (mlist 'a 'a 'b 'c)))
    (let ((permuter (make-permuter2 list-to-be-permuted)))
     (while (permuter) (printf "~s~n" list-to-be-permuted)))))
  (get-output-string string-port))
"{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}
")

(define (make-coroutine-constr2 proc-maker terminator)
 (lambda constr-args
  (letrec
   ((local-state
     (lambda first-resume-values
      (call-with-values
       (lambda ()
        (apply procedure-proper first-resume-values))
       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 r/r-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 r/r-values))
       (control-state-error call-type expected-control-state r/r-values))))
    (control-state 'inactive) ; other feasible states are: active and expired
    (control-state-error
     (lambda (call-type expected-control-state r/r-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: ,@r/r-values))))
    (procedure-proper (apply proc-maker return finish constr-args)))
   coroutine)))

(check-expect
 (let ((string-port (open-output-string)))
  (parameterize ((current-output-port string-port))
   (let ((list-to-be-permuted (mlist 'a 'a 'b 'c)))
    (let ((permuter (make-permuter2 list-to-be-permuted)))
     (while (permuter) (printf "~s~n" list-to-be-permuted)))))
  (get-output-string string-port))
"{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}
")

(test)