;;;; F-operator-test.scm
;;;; Kon Lovett, Apr 6 '06

(use test)
(use shift-reset bshift-breset gshift-greset reflect-reify range)
(use srfi-1)

;; Generated value saving

(define (make-collector)
  (let ((lst '()))
    (lambda v
      (if (null? v) (reverse! lst)
        (begin
          (set-cdr! v lst)
          (set! lst v))))))

;; Monads

(define-unit maybe obj)

(define-bind maybe (and monad (func monad)) )

(define (maybe-foo x)
  (if (zero? x) (reflect maybe #f)  ; exception
      (/ 1 x) ) )

(define (maybe-bar x)
  (+ x x) )

(define (maybe-baz x)
  (if (zero? x) (reflect maybe #f)
      (/ 1 x) ) )

;; Generalized shift/reset implementations of some control operators

(define-syntax prompt
  (syntax-rules ()
    ((_ e) (greset hr-stop e)) ) )

(define-syntax control
  (syntax-rules ()
    ((_ f e) (gshift hs-prop f e)) ) )

(define-syntax prompt0
  (syntax-rules ()
    ((_ e) (greset hr-prop e)) ) )

(define-syntax shift0
  (syntax-rules ()
    ((_ f e) (gshift hs-stop f e)) ) )

;;;

(test-group "Shift/Reset Family"

  (test-group "%shift/%reset"

    (test 5
      (+ 1 (%reset (* 2 (%shift k 4)))))

    (test 117
      (+ 10 (%reset (+ 2 (%shift k (+ 100 (k (k 3))))))))

    (test 60
      (* 10 (%reset (* 2 (%shift g (%reset (* 5 (%shift f (+ (f 1) 1)))))))))

    (test 121
      (let ((f (lambda (x) (%shift k (k (k x))))))
        (+ 1 (%reset (+ 10 (f 100))))))

    (test '(a)
      (%reset
        (let ((x (%shift f (cons 'a (f '())))))
          (%shift g x))))

    (test '(a 1 b b c) ; not '(a b 1 b b c)
      (cons 'a (%reset (cons 'b (%shift f (cons 1 (f (f (cons 'c '())))))))))

    (test-error (%shift t 'x))
  )

  (test-group "shift/reset"

    (test 5
      (+ 1 (reset (* 2 (shift k 4)))))

    (test 117
      (+ 10 (reset (+ 2 (shift k (+ 100 (k (k 3))))))))

    (test 60
      (* 10 (reset (* 2 (shift g (reset (* 5 (shift f (+ (f 1) 1)))))))))

    (test 121
      (let ((f (lambda (x) (shift k (k (k x))))))
        (+ 1 (reset (+ 10 (f 100))))))

    (test '(a)
      (reset
        (let ((x (shift f (cons 'a (f '())))))
          (shift g x))))

    (test '(a 1 b b c) ; not '(a b 1 b b c)
      (cons 'a (reset (cons 'b (shift f (cons 1 (f (f (cons 'c '())))))))))

    (test-error (shift t 'x))
  )

  (test-group "%shift-values/%reset-values"

    (test 5
      (+ 1 (%reset-values (* 2 (%shift-values k 4)))))

    (test 117
      (+ 10 (%reset-values (+ 2 (%shift-values k (+ 100 (k (k 3))))))))

    (test 60
      (* 10 (%reset-values (* 2 (%shift-values g (%reset-values (* 5 (%shift-values f (+ (f 1) 1)))))))))

    (test 121
      (let ((f (lambda (x) (%shift-values k (k (k x))))))
        (+ 1 (%reset-values (+ 10 (f 100))))))

    (test '(a)
      (%reset-values
        (let ((x (%shift-values f (cons 'a (f '())))))
          (%shift-values g x))))

    (test '(a 1 b b c)
      (cons 'a (%reset-values (cons 'b (%shift-values f (cons 1 (f (f (cons 'c '())))))))))

    (test-error (%shift-values t 'x))

    (test '(a 1 b 2 b 3) ; not '(a b 1 b 2 b 3)
      (cons 'a
        (%reset-values
          (cons 'b
            (let-values (((x y) (%shift-values f (cons 1 (f '2 (f 3 '()))))))
              (cons x y))))))
  )

  (test-group "shift-values/reset-values"

    (test 5
      (+ 1 (reset-values (* 2 (shift-values k 4)))))

    (test 117
      (+ 10 (reset-values (+ 2 (shift-values k (+ 100 (k (k 3))))))))

    (test 60
      (* 10 (reset-values (* 2 (shift-values g (reset-values (* 5 (shift-values f (+ (f 1) 1)))))))))

    (test 121
      (let ((f (lambda (x) (shift-values k (k (k x))))))
        (+ 1 (reset-values (+ 10 (f 100))))))

    (test '(a)
      (reset-values
        (let ((x (shift-values f (cons 'a (f '())))))
          (shift-values g x))))

    (test '(a 1 b b c)
      (cons 'a (reset-values (cons 'b (shift-values f (cons 1 (f (f (cons 'c '())))))))))

    (test-error (shift-values t 'x))

    (test '(a 1 b 2 b 3) ; not '(a b 1 b 2 b 3)
      (cons 'a
        (reset-values
          (cons 'b
            (let-values (((x y) (shift-values f (cons 1 (f '2 (f 3 '()))))))
              (cons x y))))))
  )

  (test-group "%bshift/%breset"

    (let ((gather (make-collector)))

      (define (fact n) (let loop ((n n)) (if (<= n 0) 1 (* n (loop (- n 1))))))

      (test "step 1" '(1 2 6 24 120)
        (begin
          (%breset r
            (gather (fact (%range r 1 5))))
          (gather)))
      (set! gather (make-collector))

      (test "step 2" '(1 6 120 5040 362880 39916800 6227020800)
        (begin
          (%breset r
            (gather (fact (%range r 1 2 14))))
          (gather)))
      (set! gather (make-collector))

      (test "two %ranges" '(101 111 121 102 112 122)
        (begin
          (%breset r1
            (%breset r2 (gather (+ (%range r1 1 2) (%range r2 100 10 120)))))
          (gather)))
      (set! gather (make-collector))

      (test "collect" 120
        (%breset r1
          (%breset r2
            (%bshift r1 f
              (let ((n (%range r2 1 5))
                    (nprev (f #f)))
                (* n (if (range-empty? nprev) 1 nprev)))))))

      (test "%range-collect" '(120 120 60 20 5)
        (begin
          (%breset r3
            (gather
              (%breset r1
                (%breset r2
                  (%bshift r1 f
                    (let ((n (%range r2 (%range r3 1 5) 5))
                          (nprev (f #f)))
                      (* n (if (range-empty? nprev) 1 nprev))))))))
          (gather)))
      (set! gather (make-collector))

      (test '(11 14 17)
        (begin
          (%breset r
            (let* ((k (%range r 1 3 9))
                  (j (+ 10 k)))
              (gather j)))
          (gather)))
      (set! gather (make-collector))

      (test '(1 2 3)
        (begin
          (%breset out
            (%breset r
              (let ((k (%range r 1 4)))
                (gather k)
                (when (> k 2)
                  (%bshift out f #f)))))
          (gather)))
      (set! gather (make-collector))

      (test '((2 10) (2 12) (2 14) (2 16) (2 18) (2 20) (4 10) (4 14) (4 18) (4 22) (4 26) (4 30) (4 34) (4 38))
        (begin
          (%breset r
            (let ((k (%range r 1 4)))
              (%breset inner
                (let ((j (%range inner 10 k (* 10 k))))
                  (when (odd? k)
                    (%bshift r f #f))
                  (gather (list k j))))))
          (gather)))
      (set! gather (make-collector)) )
  )

  (test-group "bshift/breset"

    (let ((gather (make-collector)))

      (define (fact n) (let loop ((n n)) (if (<= n 0) 1 (* n (loop (- n 1))))))

      (test "step 1" '(1 2 6 24 120)
        (begin
          (breset r
            (gather (fact (range r 1 5))))
          (gather)))
      (set! gather (make-collector))

      (test "step 2" '(1 6 120 5040 362880 39916800 6227020800)
        (begin
          (breset r
            (gather (fact (range r 1 2 14))))
          (gather)))
      (set! gather (make-collector))

      (test "two ranges" '(101 111 121 102 112 122)
        (begin
          (breset r1
            (breset r2 (gather (+ (range r1 1 2) (range r2 100 10 120)))))
          (gather)))
      (set! gather (make-collector))

      (test "collect" 120
        (breset r1
          (breset r2
            (bshift r1 f
              (let ((n (range r2 1 5))
                    (nprev (f #f)))
                (* n (if (range-empty? nprev) 1 nprev)))))))

      (test "range-collect" '(120 120 60 20 5)
        (begin
          (breset r3
            (gather
              (breset r1
                (breset r2
                  (bshift r1 f
                    (let ((n (range r2 (range r3 1 5) 5))
                          (nprev (f #f)))
                      (* n (if (range-empty? nprev) 1 nprev))))))))
          (gather)))
      (set! gather (make-collector))

      (test '(11 14 17)
        (begin
          (breset r
            (let* ((k (range r 1 3 9))
                  (j (+ 10 k)))
              (gather j)))
          (gather)))
      (set! gather (make-collector))

      (test '(1 2 3)
        (begin
          (breset out
            (breset r
              (let ((k (range r 1 4)))
                (gather k)
                (when (> k 2)
                  (bshift out f #f)))))
          (gather)))
      (set! gather (make-collector))

      (test '((2 10) (2 12) (2 14) (2 16) (2 18) (2 20) (4 10) (4 14) (4 18) (4 22) (4 26) (4 30) (4 34) (4 38))
        (begin
          (breset r
            (let ((k (range r 1 4)))
              (breset inner
                (let ((j (range inner 10 k (* 10 k))))
                  (when (odd? k)
                    (bshift r f #f))
                  (gather (list k j))))))
          (gather)))
      (set! gather (make-collector)) )
  )

  (test-group "%bshift-values/%breset-values"

    (test '(a 1 b 2 b 3) ; not '(a b 1 b 2 b 3)
      (cons 'a
        (%breset-values r
          (cons 'b
            (let-values (((x y) (%bshift-values r f (cons 1 (f '2 (f 3 '()))))))
              (cons x y))))))
  )

  (test-group "bshift-values/breset-values"

    (test '(a 1 b 2 b 3) ; not '(a b 1 b 2 b 3)
      (cons 'a
        (breset-values r
          (cons 'b
            (let-values (((x y) (bshift-values r f (cons 1 (f '2 (f 3 '()))))))
              (cons x y))))))
  )

  (test-group "gshift/greset"

    (test 117 (+ 10 (prompt (+ 2 (control k (+ 100 (k (k 3))))))))

    (test '() (prompt (let ((x (control f (cons 'a (f '()))))) (control g x))))

    (test 2 (prompt ((lambda (x) (control l 2)) (control l (+ 1 (l 0))))))

    (test '(a) (prompt (control f (cons 'a (f '())))))

    (test '(a) (prompt (let ((x (control f (cons 'a (f '()))))) (control g (g x)))))

    (test 117 (+ 10 (prompt0 (+ 2 (control k (+ 100 (k (k 3))))))))

    (test '() (prompt0 (prompt0 (let ((x (control f (cons 'a (f '()))))) (control g x)))))

    (test 117 (+ 10 (prompt0 (+ 2 (shift0 k (+ 100 (k (k 3))))))))

    (test '() (prompt0 (cons 'a (prompt0 (shift0 f (shift0 g '()))))))

    (test '(a) (prompt0 (cons 'a (prompt0 (prompt0 (shift0 f (shift0 g '())))))))
  )

  (test-group "reflect/reify"

    (test 0.5
      (reify maybe
        (maybe-baz
          (maybe-bar
            (reflect maybe
              (or (reify maybe (maybe-foo 0))
                (reify maybe (maybe-foo 1))))))))
  )
)