(require :sb-queue)

(defpackage :sb-queue-test
  (:use :cl :sb-thread :sb-queue)
  (:export))

(in-package :sb-queue-test)

(let ((q (make-queue :name 'test-q :initial-contents '(1 2 3))))
  (enqueue 4 q)
  (assert (eq 'test-q (queue-name q)))
  (multiple-value-bind (v ok) (dequeue q)
    (assert (eql 1 v))
    (assert (eq t ok)))
  (assert (equal (list-queue-contents q) (list 2 3 4))))

(assert (equal (list nil nil) (multiple-value-list (dequeue (make-queue)))))

(assert (equal (list nil t) (multiple-value-list (dequeue (make-queue :initial-contents '(nil))))))

(let ((x (make-instance 'structure-object))
      (y (make-queue)))
  (assert (not (typep x 'queue)))
  (assert (not (queuep x)))
  (assert (typep y 'queue))
  (assert (queuep y)))

(let ((q (make-queue :initial-contents (vector 1 2 3 4 5))))
  (assert (= 5 (queue-count q)))
  (enqueue 'foo q)
  (assert (= 6 (queue-count q)))
  (dequeue q)
  (assert (= 5 (queue-count q)))
  (dequeue q)
  (assert (= 4 (queue-count q)))
  (dequeue q)
  (assert (= 3 (queue-count q)))
  (dequeue q)
  (assert (= 2 (queue-count q)))
  (dequeue q)
  (assert (= 1 (queue-count q)))
  (assert (not (queue-empty-p q)))
  (dequeue q)
  (assert (= 0 (queue-count q)))
  (assert (queue-empty-p q))
  (dequeue q)
  (assert (= 0 (queue-count q)))
  (assert (queue-empty-p q)))

#+sb-thread
(let* ((q (make-queue))
       (w (make-semaphore))
       (r (make-semaphore))
       (n 100000)
       (schedulers (list
                    (make-thread (lambda ()
                                   (signal-semaphore r)
                                   (wait-on-semaphore w)
                                   (dotimes (i n)
                                     (enqueue (cons :a i) q))))
                    (make-thread (lambda ()
                                   (signal-semaphore r)
                                   (wait-on-semaphore w)
                                   (dotimes (i n)
                                     (enqueue (cons :b i) q))))
                    (make-thread (lambda ()
                                   (signal-semaphore r)
                                   (wait-on-semaphore w)
                                   (dotimes (i n)
                                     (enqueue (cons :c i) q))))
                    (make-thread (lambda ()
                                   (signal-semaphore r)
                                   (wait-on-semaphore w)
                                   (dotimes (i n)
                                     (enqueue (cons :d i) q)))))))
  (loop repeat 4 do (wait-on-semaphore r))
  (signal-semaphore w 4)
  (mapc #'join-thread schedulers)
  (let (a b c d)
    (loop
      (multiple-value-bind (item ok) (dequeue q)
        (cond (item
               (assert ok)
               (case (car item)
                 (:a (push (cdr item) a))
                 (:b (push (cdr item) b))
                 (:c (push (cdr item) c))
                 (:d (push (cdr item) d))))
              (t
               (assert (not ok))
               (return)))))
    (labels ((check-list (list)
               (when list
                 (if (cdr list)
                     (when (= (first list) (1- (second list)))
                       (check-list (cdr list)))
                     (= (first list) (1- n))))))
      (assert (eq t (check-list (nreverse a))))
      (assert (eq t (check-list (nreverse b))))
      (assert (eq t (check-list (nreverse c))))
      (assert (eq t (check-list (nreverse d)))))))

#+sb-thread
(let ((q (make-queue))
          (w (make-semaphore))
          (r (make-semaphore)))
      (dotimes (i 1000000)
        (enqueue i q))
      (flet ((dq ()
               (signal-semaphore r)
               (wait-on-semaphore w)
               (let ((last -1))
                 (loop
                   (multiple-value-bind (x ok) (dequeue q)
                     (cond (x
                            (if (and (> x last) ok)
                                (setf last x)
                                (return (list last x ok))))
                           (t
                            (if (not ok)
                                (return t)
                                (return (list last x ok))))))))))
        (let ((deschedulers
               (list (make-thread #'dq)
                     (make-thread #'dq)
                     (make-thread #'dq)
                     (make-thread #'dq))))
          (loop repeat 4 do (wait-on-semaphore r))
          (signal-semaphore w 4)
          (mapcar (lambda (th)
                    (assert (eq t (join-thread th))))
                  deschedulers))))

#+sb-thread
(let* ((q (make-queue))
       (w (make-semaphore))
       (r (make-semaphore))
       (n 100000)
       (schedulers (list
                    (make-thread (lambda ()
                                   (signal-semaphore r)
                                   (wait-on-semaphore w)
                                   (dotimes (i n)
                                     (enqueue (cons :a i) q))))
                    (make-thread (lambda ()
                                   (signal-semaphore r)
                                   (wait-on-semaphore w)
                                   (dotimes (i n)
                                     (enqueue (cons :b i) q))))
                    (make-thread (lambda ()
                                   (signal-semaphore r)
                                   (wait-on-semaphore w)
                                   (dotimes (i n)
                                     (enqueue (cons :c i) q))))
                    (make-thread (lambda ()
                                   (signal-semaphore r)
                                   (wait-on-semaphore w)
                                   (dotimes (i n)
                                     (enqueue (cons :d i) q)))))))
  (flet ((dq ()
           (let ((a -1)
                 (ac 0)
                 (b -1)
                 (bc 0)
                 (c -1)
                 (cc 0)
                 (d -1)
                 (dc 0))
             (signal-semaphore r)
             (wait-on-semaphore w)
             (loop (multiple-value-bind (item ok) (dequeue q)
                     (cond (item
                            (let ((n (cdr item)))
                              (macrolet ((test (name c)
                                           `(if (< ,name n)
                                                (progn
                                                  (setf ,name n)
                                                  (incf ,c))
                                                (return nil))))
                                (ecase (car item)
                                  (:a (test a ac))
                                  (:b (test b bc))
                                  (:c (test c cc))
                                  (:d (test d dc))))))
                           (t
                            (assert (not ok))
                            (unless (or (some #'thread-alive-p schedulers)
                                        (not (queue-empty-p q)))
                              (return (list a ac b bc c cc d dc))))))))))
    (let ((deschedulers (list
                         (make-thread #'dq)
                         (make-thread #'dq)
                         (make-thread #'dq)
                         (make-thread #'dq))))
      (loop repeat 8 do (wait-on-semaphore r))
      (signal-semaphore w 8)
      (let ((a -1)
            (ac 0)
            (b -1)
            (bc 0)
            (c -1)
            (cc 0)
            (d -1)
            (dc 0))
        (mapc (lambda (th)
                (let ((results (join-thread th)))
                  (when results
                    (destructuring-bind (ta tac tb tbc tc tcc td tdc) results
                      (setf a (max ta a)
                            b (max tb b)
                            c (max tc c)
                            d (max td d))
                      (incf ac tac)
                      (incf bc tbc)
                      (incf cc tcc)
                      (incf dc tdc)))))
              deschedulers)
        (assert (and (= n ac (1+ a))
                     (= n bc (1+ b))
                     (= n cc (1+ c))
                     (= n dc (1+ d))))))))

;;;; Unix success convention for exit codes
(sb-ext:quit :unix-status 0)