;; Single Threaded

;;

(test-group "whoopsie"
  (test "Escaped"
    "ABORT!"
    (begin
      (call/cc
        (lambda (abort!)
          (cons 'a
            (reset
              (cons 'b
                (begin
                  ;(gloss)
                  (let-values (((x y) (shift k (cons 1 (k '2 (k 3 '()))))))
                    ;(gloss x #\| y)
                    (when (eq? x '2) (abort! "ABORT!"))
                    (cons x y)))))) ) )
      ;1) Reused `reset'
      "ABORT!") )

  (test-error "1) Reused `reset', then 2) Missing `reset'"
    (shift t 'x))
)

;; Basic

(test-group "basic"

  (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 k (+ (k 1) 1)))))))))

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

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

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

  (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 k (+ (k 1) 1)))))))))

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

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

  (test '(a 1 b b c)
    (cons 'a (reset (cons 'b (shift k (cons 1 (k (k (cons 'c '())))))))))

  (test "multi-valued w/ in-stream \"capture\""
    '(a 1 b 2 b 3) ;not '(a b 1 b 2 b 3)
    (cons 'a
      (reset
        (cons 'b
          (begin
            ;(gloss)
            (let-values (((x y) (shift k (cons 1 (k '2 (k 3 '()))))))
              ;(gloss x #\| y)
              (cons x y)))))))

  ;NOTE no "-unsafe" or "-no-argc-checks" declaration
  (test-error "multi-valued bad argument count"
    ;bad argument count - received 1 but expected 2: #<procedure (? x692693 y694695)>
    (cons 'a
      (reset
        (cons 'b
          (begin
            ;(gloss)
            (let-values (((x y) (shift k (cons 1 (k (k '2 (k 3 '())))))))
              ;(gloss x #\| y)
              (cons x y)))))))
)

;; Multi Threaded

(define-constant THREAD-COUNT 5)
(define-constant ELEMENT-COUNT (expt 10 6))

(define-constant NOTIFY-EVERY (/ ELEMENT-COUNT 100))

(test-group (string-append
              (number->string THREAD-COUNT) " threads"
              " X "
              (number->string ELEMENT-COUNT) " list")

  (define (valid-thread-work? work start end)
    (and (pair? work)
         (= (* 2 (- end start)) (length work))
         (eq? 'b (first work))
         (= start (last work))
         (= (sub1 end) (second work))
         (every
          (lambda (x)
            (or (eq? 'b x)
                (and (<= start x) (< x end))) )
          work)) )

  (define (worker-thread-action start end id)
    (reset
      (cons 'b
        (let-values (((x y) (shift k (do ((i start (add1 i))
                                          (y '() (k i y)))
                                         ((= i end) y))) ) )
          (when (and NOTIFY-EVERY (zero? (modulo x NOTIFY-EVERY)))
            (gloss "in" id "at" x) )
          (cons x y)))) )

  (define (make-worker-thread start end id)
    (make-thread
      (lambda ()
        (begin
          (when NOTIFY-EVERY (gloss "start" id))
          (let ((work (worker-thread-action start end id)))
            (when NOTIFY-EVERY (gloss "end" id))
            (set! (thread-specific (current-thread)) work) ) ) )
      id) )

  (define (make-worker-thread-configs n-threads way-limit)
    (let* ((stride (/ way-limit n-threads))
           (starts (iota n-threads 0 stride))
           (ends (iota n-threads stride stride)) )
      (define (kons-worker-thread-config start end cs)
        (cons (list start end (quotient start stride)) cs) )
      (fold kons-worker-thread-config '() starts ends) ) )

  (define (make-worker-threads n-threads way-limit)
    (map (cut apply make-worker-thread <>)
         (make-worker-thread-configs n-threads way-limit)) )

  ;required for ease of split
  (test-assert (exact? (/ ELEMENT-COUNT THREAD-COUNT)))

  ;FIXME randomize the list before start?
  (let ((threads (make-worker-threads THREAD-COUNT ELEMENT-COUNT)))
    (for-each thread-start! threads)
    (for-each thread-join! threads)
    (let* ((ordered-workers (sort threads ;highest to lowest, as the thread work
                                  (lambda (a b) (> (thread-name a) (thread-name b)))))
           (work (append-map!
                  (lambda (t) ;transfer ownership
                    (let ((ts (thread-specific t)))
                      (set! (thread-specific t) #f)
                      ts ) )
                  ordered-workers)) )
      (test-assert (valid-thread-work? work 0 ELEMENT-COUNT)) ) )
)