PROPER-LIST-LENGTH and related changes

[alexandria.git] / tests.lisp

(in-package :cl-user)

(eval-when (:compile-toplevel :load-toplevel)
  (require :sb-rt))

(require :alexandria)

(defpackage :alexandria-test
  (:use :cl :alexandria :sb-rt))

(in-package :alexandria-test)

;;;; Arrays

(deftest copy-array.1
    (let* ((orig (vector 1 2 3))
           (copy (copy-array orig)))
      (values (eq orig copy) (equalp orig copy)))
  nil t)

(deftest copy-array.2
    (let ((orig (make-array 1024 :fill-pointer 0)))
      (vector-push-extend 1 orig)
      (vector-push-extend 2 orig)
      (vector-push-extend 3 orig)
      (let ((copy (copy-array orig)))
        (values (eq orig copy) (equalp orig copy)
                (array-has-fill-pointer-p copy)
                (eql (fill-pointer orig) (fill-pointer copy)))))
  nil t t t)

(deftest array-index.1
    (typep 0 'array-index)
  t)

;;;; Conditions

(deftest unwind-protect-case.1
    (let (result)
      (unwind-protect-case ()
          (random 10)
        (:normal (push :normal result))
        (:abort  (push :abort result))
        (:always (push :always result)))
      result)
  (:always :normal))

(deftest unwind-protect-case.2
    (let (result)
      (unwind-protect-case ()
          (random 10)
        (:always (push :always result))
        (:normal (push :normal result))
        (:abort  (push :abort result)))
      result)
  (:normal :always))

(deftest unwind-protect-case.3
    (let (result1 result2 result3)
      (ignore-errors
        (unwind-protect-case ()
            (error "FOOF!")
          (:normal (push :normal result1))
          (:abort  (push :abort result1))
          (:always (push :always result1))))
      (catch 'foof
        (unwind-protect-case ()
            (throw 'foof 42)
          (:normal (push :normal result2))
          (:abort  (push :abort result2))
          (:always (push :always result2))))
      (block foof
        (unwind-protect-case ()
            (return-from foof 42)
          (:normal (push :normal result3))
          (:abort  (push :abort result3))
          (:always (push :always result3))))
      (values result1 result2 result3))
  (:always :abort)
  (:always :abort)
  (:always :abort))

(deftest unwind-protect-case.4
    (let (result)
      (unwind-protect-case (aborted-p)
          (random 42)
        (:always (setq result aborted-p)))
      result)
  nil)

(deftest unwind-protect-case.5
    (let (result)
      (block foof
        (unwind-protect-case (aborted-p)
            (return-from foof)
          (:always (setq result aborted-p))))
      result)
  t)

;;;; Control flow

(deftest switch.1
    (switch (13 :test =)
      (12 :oops)
      (13.0 :yay))
  :yay)

(deftest switch.2
    (switch (13)
      ((+ 12 2) :oops)
      ((- 13 1) :oops2)
      (t :yay))
  :yay)

(deftest eswitch.1
    (let ((x 13))
      (eswitch (x :test =)
        (12 :oops)
        (13.0 :yay)))
  :yay)

(deftest eswitch.2
    (let ((x 13))
      (eswitch (x :key 1+)
        (11 :oops)
        (14 :yay)))
  :yay)

(deftest cswitch.1
    (cswitch (13 :test =)
      (12 :oops)
      (13.0 :yay))
  :yay)

(deftest cswitch.2
    (cswitch (13 :key 1-)
      (12 :yay)
      (13.0 :oops))
  :yay)

(deftest whichever.1
    (let ((x (whichever 1 2 3)))
      (and (member x '(1 2 3)) t))
  t)

(deftest whichever.2
    (let* ((a 1)
           (b 2)
           (c 3)
           (x (whichever a b c)))
      (and (member x '(1 2 3)) t))
  t)

(deftest xor.1
    (xor nil nil 1 nil)
  1
  t)

;;;; Definitions

(deftest define-constant.1
    (let ((name (gensym)))
      (eval `(define-constant ,name "FOO" :test 'equal))
      (eval `(define-constant ,name "FOO" :test 'equal))
      (values (equal "FOO" (symbol-value name))
              (constantp name)))
  t
  t)

(deftest define-constant.2
    (let ((name (gensym)))
      (eval `(define-constant ,name 13))
      (eval `(define-constant ,name 13))
      (values (eql 13 (symbol-value name))
              (constantp name)))
  t
  t)

;;;; Errors

(deftest required-argument.1
    (multiple-value-bind (res err)
        (ignore-errors (required-argument))
      (typep err 'error))
  t)

;;;; Hash tables

(deftest ensure-hash-table.1
    (let ((table (make-hash-table))
          (x (list 1)))
      (multiple-value-bind (value already-there)
          (ensure-gethash x table 42)
        (and (= value 42)
             (not already-there)
             (= 42 (gethash x table))
             (multiple-value-bind (value2 already-there2)
                 (ensure-gethash x table 13)
               (and (= value2 42)
                    already-there2
                    (= 42 (gethash x table)))))))
  t)

(deftest copy-hash-table.1
    (let ((orig (make-hash-table :test 'eq :size 123))
          (foo "foo"))
      (setf (gethash orig orig) t
            (gethash foo orig) t)
      (let ((eq-copy (copy-hash-table orig))
            (eql-copy (copy-hash-table orig :test 'eql))
            (equal-copy (copy-hash-table orig :test 'equal))
            (equalp-copy (copy-hash-table orig :test 'equalp)))
        (list (hash-table-size eq-copy)
              (hash-table-count eql-copy)
              (gethash orig eq-copy)
              (gethash (copy-seq foo) eql-copy)
              (gethash foo eql-copy)
              (gethash (copy-seq foo) equal-copy)
              (gethash "FOO" equal-copy)
              (gethash "FOO" equalp-copy))))
  (123 2 t nil t t nil t))

(deftest copy-hash-table.2
    (let ((ht (make-hash-table))
          (list (list :list (vector :A :B :C))))
      (setf (gethash 'list ht) list)
      (let* ((shallow-copy (copy-hash-table ht))
             (deep1-copy (copy-hash-table ht :key 'copy-list))
             (list         (gethash 'list ht))
             (shallow-list (gethash 'list shallow-copy))
             (deep1-list   (gethash 'list deep1-copy)))
        (list (eq ht shallow-copy)
              (eq ht deep1-copy)
              (eq list shallow-list)
              (eq list deep1-list)                   ; outer list was copied.
              (eq (second list) (second shallow-list))
              (eq (second list) (second deep1-list)) ; inner vector wasn't copied.
              )))
  (nil nil t nil t t))

(deftest maphash-keys.1
    (let ((keys nil)
          (table (make-hash-table)))
      (declare (notinline maphash-keys))
      (dotimes (i 10)
        (setf (gethash i table) t))
      (maphash-keys (lambda (k) (push k keys)) table)
      (set-equal keys '(0 1 2 3 4 5 6 7 8 9)))
  t)

(deftest maphash-values.1
    (let ((vals nil)
          (table (make-hash-table)))
      (declare (notinline maphash-values))
      (dotimes (i 10)
        (setf (gethash i table) (- i)))
      (maphash-values (lambda (v) (push v vals)) table)
      (set-equal vals '(0 -1 -2 -3 -4 -5 -6 -7 -8 -9)))
  t)

(deftest hash-table-keys.1
    (let ((table (make-hash-table)))
      (dotimes (i 10)
        (setf (gethash i table) t))
      (set-equal (hash-table-keys table) '(0 1 2 3 4 5 6 7 8 9)))
  t)

(deftest hash-table-values.1
    (let ((table (make-hash-table)))
      (dotimes (i 10)
        (setf (gethash (gensym) table) i))
      (set-equal (hash-table-values table) '(0 1 2 3 4 5 6 7 8 9)))
  t)

(deftest hash-table-alist.1
    (let ((table (make-hash-table)))
      (dotimes (i 10)
        (setf (gethash i table) (- i)))
      (let ((alist (hash-table-alist table)))
        (list (length alist)
              (assoc 0 alist)
              (assoc 3 alist)
              (assoc 9 alist)
              (assoc nil alist))))
  (10 (0 . 0) (3 . -3) (9 . -9) nil))

(deftest hash-table-plist.1
    (let ((table (make-hash-table)))
      (dotimes (i 10)
        (setf (gethash i table) (- i)))
      (let ((plist (hash-table-plist table)))
        (list (length plist)
              (getf plist 0)
              (getf plist 2)
              (getf plist 7)
              (getf plist nil))))
  (20 0 -2 -7 nil))

(deftest alist-hash-table.1
    (let* ((alist '((0 a) (1 b) (2 c)))
           (table (alist-hash-table alist)))
      (list (hash-table-count table)
            (gethash 0 table)
            (gethash 1 table)
            (gethash 2 table)
            (hash-table-test table)))
  (3 (a) (b) (c) eql))

(deftest plist-hash-table.1
    (let* ((plist '(:a 1 :b 2 :c 3))
           (table (plist-hash-table plist :test 'eq)))
      (list (hash-table-count table)
            (gethash :a table)
            (gethash :b table)
            (gethash :c table)
            (gethash 2 table)
            (gethash nil table)
            (hash-table-test table)))
  (3 1 2 3 nil nil eq))

;;;; Functions

(deftest disjoin.1
    (let ((disjunction (disjoin (lambda (x)
                                  (and (consp x) :cons))
                                (lambda (x)
                                  (and (stringp x) :string)))))
      (list (funcall disjunction 'zot)
            (funcall disjunction '(foo bar))
            (funcall disjunction "test")))
  (nil :cons :string))

(deftest conjoin.1
    (let ((conjunction (conjoin #'consp
                                (lambda (x)
                                  (stringp (car x)))
                                (lambda (x)
                                  (char (car x) 0)))))
      (list (funcall conjunction 'zot)
            (funcall conjunction '(foo))
            (funcall conjunction '("foo"))))
  (nil nil #\f))

(deftest compose.1
    (let ((composite (compose '1+
                              (lambda (x)
                                (* x 2))
                              #'read-from-string)))
      (funcall composite "1"))
  3)

(deftest compose.2
    (let ((composite
           (locally (declare (notinline compose))
             (compose '1+
                      (lambda (x)
                        (* x 2))
                      #'read-from-string))))
      (funcall composite "2"))
  5)

(deftest compose.3
    (let ((compose-form (funcall (compiler-macro-function 'compose)
                                 '(compose '1+
                                   (lambda (x)
                                     (* x 2))
                                   #'read-from-string)
                                 nil)))
      (let ((fun (funcall (compile nil `(lambda () ,compose-form)))))
        (funcall fun "3")))
  7)

(deftest multiple-value-compose.1
    (let ((composite (multiple-value-compose
                      #'truncate
                      (lambda (x y)
                        (values y x))
                      (lambda (x)
                        (with-input-from-string (s x)
                          (values (read s) (read s)))))))
      (multiple-value-list (funcall composite "2 7")))
  (3 1))

(deftest multiple-value-compose.2
    (let ((composite (locally (declare (notinline multiple-value-compose))
                       (multiple-value-compose
                        #'truncate
                        (lambda (x y)
                          (values y x))
                       (lambda (x)
                         (with-input-from-string (s x)
                           (values (read s) (read s))))))))
      (multiple-value-list (funcall composite "2 11")))
  (5 1))

(deftest multiple-value-compose.3
    (let ((compose-form (funcall (compiler-macro-function 'multiple-value-compose)
                                 '(multiple-value-compose
                                   #'truncate
                                   (lambda (x y)
                                     (values y x))
                                   (lambda (x)
                                     (with-input-from-string (s x)
                                       (values (read s) (read s)))))
                                 nil)))
      (let ((fun (funcall (compile nil `(lambda () ,compose-form)))))
        (multiple-value-list (funcall fun "2 9"))))
  (4 1))

(deftest curry.1
    (let ((curried (curry '+ 3)))
      (funcall curried 1 5))
  9)

(deftest curry.2
    (let ((curried (locally (declare (notinline curry))
                     (curry '* 2 3))))
      (funcall curried 7))
  42)

(deftest curry.3
    (let ((curried-form (funcall (compiler-macro-function 'curry)
                                 '(curry '/ 8)
                                 nil)))
      (let ((fun (funcall (compile nil `(lambda () ,curried-form)))))
        (funcall fun 2)))
  4)

(deftest rcurry.1
    (let ((r (rcurry '/ 2)))
      (funcall r 8))
  4)

(deftest named-lambda.1
    (let ((fac (named-lambda fac (x)
                 (if (> x 1)
                     (* x (fac (- x 1)))
                     x))))
      (funcall fac 5))
  120)

(deftest named-lambda.2
    (let ((fac (named-lambda fac (&key x)
                 (if (> x 1)
                     (* x (fac :x (- x 1)))
                     x))))
      (funcall fac :x 5))
  120)

;;;; Lists

(deftest alist-plist.1
    (alist-plist '((a . 1) (b . 2) (c . 3)))
  (a 1 b 2 c 3))

(deftest plist-alist.1
    (plist-alist '(a 1 b 2 c 3))
  ((a . 1) (b . 2) (c . 3)))

(deftest unionf.1
    (let* ((list (list 1 2 3))
           (orig list))
      (unionf list (list 1 2 4))
      (values (equal orig (list 1 2 3))
              (eql (length list) 4)
              (set-difference list (list 1 2 3 4))
              (set-difference (list 1 2 3 4) list)))
  t
  t
  nil
  nil)

(deftest nunionf.1
    (let ((list (list 1 2 3)))
      (nunionf list (list 1 2 4))
      (values (eql (length list) 4)
              (set-difference (list 1 2 3 4) list)
              (set-difference list (list 1 2 3 4))))
  t
  nil
  nil)

(deftest appendf.1
    (let* ((list (list 1 2 3))
           (orig list))
      (appendf list '(4 5 6) '(7 8))
      (list list (eq list orig)))
  ((1 2 3 4 5 6 7 8) nil))

(deftest nconcf.1
    (let ((list1 (list 1 2 3))
          (list2 (list 4 5 6)))
      (nconcf list1 list2 (list 7 8 9))
      list1)
  (1 2 3 4 5 6 7 8 9))

(deftest circular-list.1
    (let ((circle (circular-list 1 2 3)))
      (list (first circle)
            (second circle)
            (third circle)
            (fourth circle)
            (eq circle (nthcdr 3 circle))))
  (1 2 3 1 t))

(deftest circular-list-p.1
    (let* ((circle (circular-list 1 2 3 4))
           (tree (list circle circle))
           (dotted (cons circle t))
           (proper (list 1 2 3 circle))
           (tailcirc (list* 1 2 3 circle)))
      (list (circular-list-p circle)
            (circular-list-p tree)
            (circular-list-p dotted)
            (circular-list-p proper)
            (circular-list-p tailcirc)))
  (t nil nil nil t))

(deftest circular-list-p.2
    (circular-list-p 'foo)
  nil)

(deftest circular-tree-p.1
    (let* ((circle (circular-list 1 2 3 4))
           (tree1 (list circle circle))
           (tree2 (let* ((level2 (list 1 nil 2))
                         (level1 (list level2)))
                    (setf (second level2) level1)
                    level1))
           (dotted (cons circle t))
           (proper (list 1 2 3 circle))
           (tailcirc (list* 1 2 3 circle))
           (quite-proper (list 1 2 3))
           (quite-dotted (list 1 (cons 2 3))))
      (list (circular-tree-p circle)
            (circular-tree-p tree1)
            (circular-tree-p tree2)
            (circular-tree-p dotted)
            (circular-tree-p proper)
            (circular-tree-p tailcirc)
            (circular-tree-p quite-proper)
            (circular-tree-p quite-dotted)))
  (t t t t t t nil nil))

(deftest proper-list-p.1
    (let ((l1 (list 1))
          (l2 (list 1 2))
          (l3 (cons 1 2))
          (l4 (list (cons 1 2) 3))
          (l5 (circular-list 1 2)))
      (list (proper-list-p l1)
            (proper-list-p l2)
            (proper-list-p l3)
            (proper-list-p l4)
            (proper-list-p l5)))
  (t t nil t nil))

(deftest proper-list-p.2
    (proper-list-p '(1 2 . 3))
  nil)

(deftest proper-list.type.1
    (let ((l1 (list 1))
          (l2 (list 1 2))
          (l3 (cons 1 2))
          (l4 (list (cons 1 2) 3))
          (l5 (circular-list 1 2)))
      (list (typep l1 'proper-list)
            (typep l2 'proper-list)
            (typep l3 'proper-list)
            (typep l4 'proper-list)
            (typep l5 'proper-list)))
  (t t nil t nil))

(deftest proper-list-length.1
    (values
     (proper-list-length nil)
     (proper-list-length (list 1))
     (proper-list-length (list 2 2))
     (proper-list-length (list 3 3 3))
     (proper-list-length (list 4 4 4 4))
     (proper-list-length (list 5 5 5 5 5))
     (proper-list-length (list 6 6 6 6 6 6))
     (proper-list-length (list 7 7 7 7 7 7 7))
     (proper-list-length (list 8 8 8 8 8 8 8 8))
     (proper-list-length (list 9 9 9 9 9 9 9 9 9)))
  0 1 2 3 4 5 6 7 8 9)

(deftest proper-list-length.2
    (flet ((plength (x)
             (handler-case
                 (proper-list-length x)
               (type-error ()
                 :ok))))
      (values
       (plength (list* 1))
       (plength (list* 2 2))
       (plength (list* 3 3 3))
       (plength (list* 4 4 4 4))
       (plength (list* 5 5 5 5 5))
       (plength (list* 6 6 6 6 6 6))
       (plength (list* 7 7 7 7 7 7 7))
       (plength (list* 8 8 8 8 8 8 8 8))
       (plength (list* 9 9 9 9 9 9 9 9 9))))
  :ok :ok :ok
  :ok :ok :ok
  :ok :ok :ok)

(deftest lastcar.1
    (let ((l1 (list 1))
          (l2 (list 1 2)))
      (list (lastcar l1)
            (lastcar l2)))
  (1 2))

(deftest lastcar.error.2
    (handler-case
        (progn
          (lastcar (circular-list 1 2 3))
          nil)
      (error ()
        t))
  t)

(deftest setf-lastcar.1
    (let ((l (list 1 2 3 4)))
      (values (lastcar l)
              (progn
                (setf (lastcar l) 42)
                (lastcar l))))
  4
  42)

(deftest setf-lastcar.2
    (let ((l (circular-list 1 2 3)))
      (multiple-value-bind (res err)
          (ignore-errors (setf (lastcar l) 4))
        (typep err 'type-error)))
  t)

(deftest make-circular-list.1
    (let ((l (make-circular-list 3 :initial-element :x)))
      (setf (car l) :y)
      (list (eq l (nthcdr 3 l))
            (first l)
            (second l)
            (third l)
            (fourth l)))
  (t :y :x :x :y))

(deftest circular-list.type.1
    (let* ((l1 (list 1 2 3))
           (l2 (circular-list 1 2 3))
           (l3 (list* 1 2 3 l2)))
      (list (typep l1 'circular-list)
            (typep l2 'circular-list)
            (typep l3 'circular-list)))
  (nil t t))

(deftest ensure-list.1
    (let ((x (list 1))
          (y 2))
      (list (ensure-list x)
            (ensure-list y)))
  ((1) (2)))

(deftest ensure-cons.1
    (let ((x (cons 1 2))
          (y nil)
          (z "foo"))
      (values (ensure-cons x)
              (ensure-cons y)
              (ensure-cons z)))
  (1 . 2)
  (nil)
  ("foo"))

(deftest setp.1
    (setp '(1))
  t)

(deftest setp.2
    (setp nil)
  t)

(deftest setp.3
    (setp "foo")
  nil)

(deftest setp.4
    (setp '(1 2 3 1))
  nil)

(deftest setp.5
    (setp '(1 2 3))
  t)

(deftest setp.6
    (setp '(a :a))
  t)

(deftest setp.7
    (setp '(a :a) :key 'character)
  nil)

(deftest setp.8
    (setp '(a :a) :key 'character :test (constantly nil))
  t)

(deftest set-equal.1
    (set-equal '(1 2 3) '(3 1 2))
  t)

(deftest set-equal.2
    (set-equal '("Xa") '("Xb")
               :test (lambda (a b) (eql (char a 0) (char b 0))))
  t)

(deftest set-equal.3
    (set-equal '(1 2) '(4 2))
  nil)

(deftest set-equal.4
    (set-equal '(a b c) '(:a :b :c) :key 'string :test 'equal)
  t)

(deftest set-equal.5
    (set-equal '(a d c) '(:a :b :c) :key 'string :test 'equal)
  nil)

(deftest set-equal.6
    (set-equal '(a b c) '(a b c d))
  nil)

(deftest map-product.1
    (map-product 'cons '(2 3) '(1 4))
  ((2 . 1) (2 . 4) (3 . 1) (3 . 4)))

(deftest map-product.2
    (map-product #'cons '(2 3) '(1 4))
  ((2 . 1) (2 . 4) (3 . 1) (3 . 4)))

(deftest flatten.1
    (flatten '((1) 2 (((3 4))) ((((5)) 6)) 7))
  (1 2 3 4 5 6 7))

(deftest remove-from-plist.1
    (let ((orig '(a 1 b 2 c 3 d 4)))
      (list (remove-from-plist orig 'a 'c)
            (remove-from-plist orig 'b 'd)
            (remove-from-plist orig 'b)
            (remove-from-plist orig 'a)
            (remove-from-plist orig 'd 42 "zot")
            (remove-from-plist orig 'a 'b 'c 'd)
            (remove-from-plist orig 'a 'b 'c 'd 'x)
            (equal orig '(a 1 b 2 c 3 d 4))))
  ((b 2 d 4)
   (a 1 c 3)
   (a 1 c 3 d 4)
   (b 2 c 3 d 4)
   (a 1 b 2 c 3)
   nil
   nil
   t))

(deftest mappend.1
    (mappend (compose 'list '*) '(1 2 3) '(1 2 3))
  (1 4 9))

;;;; Numbers

(deftest clamp.1
    (list (clamp 1.5 1 2)
          (clamp 2.0 1 2)
          (clamp 1.0 1 2)
          (clamp 3 1 2)
          (clamp 0 1 2))
  (1.5 2.0 1.0 2 1))

(deftest gaussian-random.1
    (let ((min -0.2)
          (max +0.2))
      (multiple-value-bind (g1 g2)
          (gaussian-random min max)
        (values (<= min g1 max)
                (<= min g2 max)
                (/= g1 g2) ;uh
                )))
  t
  t
  t)

(deftest iota.1
    (iota 3)
  (0 1 2))

(deftest iota.2
    (iota 3 :start 0.0d0)
  (0.0d0 1.0d0 2.0d0))

(deftest iota.3
    (iota 3 :start 2 :step 3.0)
  (2.0 5.0 8.0))

(deftest map-iota.1
    (let (all)
      (declare (notinline map-iota))
      (values (map-iota (lambda (x) (push x all))
                        3
                        :start 2
                        :step 1.1d0)
              all))
  3
  (4.2d0 3.1d0 2.0d0))

(deftest lerp.1
    (lerp 0.5 1 2)
  1.5)

(deftest lerp.2
    (lerp 0.1 1 2)
  1.1)

(deftest mean.1
    (mean '(1 2 3))
  2)

(deftest mean.2
    (mean '(1 2 3 4))
  5/2)

(deftest mean.3
    (mean '(1 2 10))
  13/3)

(deftest median.1
    (median '(100 0 99 1 98 2 97))
  97)

(deftest median.2
    (median '(100 0 99 1 98 2 97 96))
  195/2)

(deftest variance.1
    (variance (list 1 2 3))
  2/3)

(deftest standard-deviation.1
    (< 0 (standard-deviation (list 1 2 3)) 1)
  t)

(deftest maxf.1
    (let ((x 1))
      (maxf x 2)
      x)
  2)

(deftest maxf.2
    (let ((x 1))
      (maxf x 0)
      x)
  1)

(deftest maxf.3
    (let ((x 1)
          (c 0))
      (maxf x (incf c))
      (list x c))
  (1 1))

(deftest maxf.4
    (let ((xv (vector 0 0 0))
          (p 0))
      (maxf (svref xv (incf p)) (incf p))
      (list p xv))
  (2 #(0 2 0)))

(deftest minf.1
    (let ((y 1))
      (minf y 0)
      y)
  0)

(deftest minf.2
    (let ((xv (vector 10 10 10))
          (p 0))
      (minf (svref xv (incf p)) (incf p))
      (list p xv))
  (2 #(10 2 10)))

;;;; Arrays

#+nil
(deftest array-index.type)

#+nil
(deftest copy-array)

;;;; Sequences

(deftest rotate.1
    (list (rotate (list 1 2 3) 0)
          (rotate (list 1 2 3) 1)
          (rotate (list 1 2 3) 2)
          (rotate (list 1 2 3) 3)
          (rotate (list 1 2 3) 4))
  ((1 2 3)
   (3 1 2)
   (2 3 1)
   (1 2 3)
   (3 1 2)))

(deftest rotate.2
    (list (rotate (vector 1 2 3 4) 0)
          (rotate (vector 1 2 3 4))
          (rotate (vector 1 2 3 4) 2)
          (rotate (vector 1 2 3 4) 3)
          (rotate (vector 1 2 3 4) 4)
          (rotate (vector 1 2 3 4) 5))
  (#(1 2 3 4)
    #(4 1 2 3)
    #(3 4 1 2)
    #(2 3 4 1)
    #(1 2 3 4)
    #(4 1 2 3)))

(deftest rotate.3
    (list (rotate (list 1 2 3) 0)
          (rotate (list 1 2 3) -1)
          (rotate (list 1 2 3) -2)
          (rotate (list 1 2 3) -3)
          (rotate (list 1 2 3) -4))
  ((1 2 3)
   (2 3 1)
   (3 1 2)
   (1 2 3)
   (2 3 1)))

(deftest rotate.4
    (list (rotate (vector 1 2 3 4) 0)
          (rotate (vector 1 2 3 4) -1)
          (rotate (vector 1 2 3 4) -2)
          (rotate (vector 1 2 3 4) -3)
          (rotate (vector 1 2 3 4) -4)
          (rotate (vector 1 2 3 4) -5))
  (#(1 2 3 4)
   #(2 3 4 1)
   #(3 4 1 2)
   #(4 1 2 3)
   #(1 2 3 4)
   #(2 3 4 1)))

(deftest rotate.5
    (values (rotate (list 1) 17)
            (rotate (list 1) -5))
  (1)
  (1))

(deftest shuffle.1
    (let ((s (shuffle (iota 100))))
      (list (equal s (iota 100))
            (every (lambda (x)
                     (member x s))
                   (iota 100))
            (every (lambda (x)
                     (typep x '(integer 0 99)))
                   s)))
  (nil t t))

(deftest shuffle.2
    (let ((s (shuffle (coerce (iota 100) 'vector))))
      (list (equal s (coerce (iota 100) 'vector))
            (every (lambda (x)
                     (find x s))
                   (iota 100))
            (every (lambda (x)
                     (typep x '(integer 0 99)))
                   s)))
  (nil t t))

(deftest random-elt.1
    (let ((s1 #(1 2 3 4))
          (s2 '(1 2 3 4)))
      (list (dotimes (i 1000 nil)
              (unless (member (random-elt s1) s2)
                (return nil))
              (when (/= (random-elt s1) (random-elt s1))
                (return t)))
            (dotimes (i 1000 nil)
              (unless (member (random-elt s2) s2)
                (return nil))
              (when (/= (random-elt s2) (random-elt s2))
                (return t)))))
  (t t))

(deftest removef.1
    (let* ((x '(1 2 3))
           (x* x)
           (y #(1 2 3))
           (y* y))
      (removef x 1)
      (removef y 3)
      (list x x* y y*))
  ((2 3)
   (1 2 3)
   #(1 2)
   #(1 2 3)))

(deftest deletef.1
    (let* ((x (list 1 2 3))
           (x* x)
           (y (vector 1 2 3)))
      (deletef x 2)
      (deletef y 1)
      (list x x* y))
  ((1 3)
   (1 3)
   #(2 3)))

(deftest map-permutations.1
    (let ((seq (list 1 2 3))
          (seen nil)
          (ok t))
      (map-permutations (lambda (s)
                          (unless (set-equal s seq)
                            (setf ok nil))
                          (when (member s seen :test 'equal)
                            (setf ok nil))
                          (push s seen))
                        seq
                        :copy t)
      (values ok (length seen)))
  t
  6)

(deftest proper-sequence.type.1
    (mapcar (lambda (x)
              (typep x 'proper-sequence))
            (list (list 1 2 3)
                  (vector 1 2 3)
                  #2a((1 2) (3 4))
                  (circular-list 1 2 3 4)))
  (t t nil nil))

(deftest emptyp.1
    (mapcar #'emptyp
            (list (list 1)
                  (circular-list 1)
                  nil
                  (vector)
                  (vector 1)))
  (nil nil t t nil))

(deftest sequence-of-length-p.1
    (mapcar #'sequence-of-length-p
            (list nil
                  #()
                  (list 1)
                  (vector 1)
                  (list 1 2)
                  (vector 1 2)
                  (list 1 2)
                  (vector 1 2)
                  (list 1 2)
                  (vector 1 2))
            (list 0
                  0
                  1
                  1
                  2
                  2
                  1
                  1
                  4
                  4))
  (t t t t t t nil nil nil nil))

(deftest length=.1
    (mapcar #'length=
            (list nil
                  #()
                  (list 1)
                  (vector 1)
                  (list 1 2)
                  (vector 1 2)
                  (list 1 2)
                  (vector 1 2)
                  (list 1 2)
                  (vector 1 2))
            (list 0
                  0
                  1
                  1
                  2
                  2
                  1
                  1
                  4
                  4))
  (t t t t t t nil nil nil nil))

(deftest length=.2
    ;; test the compiler macro
    (macrolet ((x (&rest args)
                 (funcall
                  (compile nil
                           `(lambda ()
                              (length= ,@args))))))
      (list (x 2 '(1 2))
            (x '(1 2) '(3 4))
            (x '(1 2) 2)
            (x '(1 2) 2 '(3 4))
            (x 1 2 3)))
  (t t t t nil))

(deftest copy-sequence.1
    (let ((l (list 1 2 3))
          (v (vector #\a #\b #\c)))
      (declare (notinline copy-sequence))
      (let ((l.list (copy-sequence 'list l))
            (l.vector (copy-sequence 'vector l))
            (l.spec-v (copy-sequence '(vector fixnum) l))
            (v.vector (copy-sequence 'vector v))
            (v.list (copy-sequence 'list v))
            (v.string (copy-sequence 'string v)))
        (list (member l (list l.list l.vector l.spec-v))
              (member v (list v.vector v.list v.string))
              (equal l.list l)
              (equalp l.vector #(1 2 3))
              (eq 'fixnum (array-element-type l.spec-v))
              (equalp v.vector v)
              (equal v.list '(#\a #\b #\c))
              (equal "abc" v.string))))
  (nil nil t t t t t t))

(deftest first-elt.1
    (mapcar #'first-elt
            (list (list 1 2 3)
                  "abc"
                  (vector :a :b :c)))
  (1 #\a :a))

(deftest first-elt.error.1
    (mapcar (lambda (x)
              (handler-case
                  (first-elt x)
                (type-error ()
                  :type-error)))
            (list nil
                  #()
                  12
                  :zot))
  (:type-error
   :type-error
   :type-error
   :type-error))

(deftest setf-first-elt.1
    (let ((l (list 1 2 3))
          (s (copy-seq "foobar"))
          (v (vector :a :b :c)))
      (setf (first-elt l) -1
            (first-elt s) #\x
            (first-elt v) 'zot)
      (values l s v))
  (-1 2 3)
  "xoobar"
  #(zot :b :c))

(deftest setf-first-elt.error.1
    (let ((l 'foo))
      (multiple-value-bind (res err)
          (ignore-errors (setf (first-elt l) 4))
        (typep err 'type-error)))
  t)

(deftest last-elt.1
    (mapcar #'last-elt
            (list (list 1 2 3)
                  (vector :a :b :c)
                  "FOOBAR"
                  #*001
                  #*010))
  (3 :c #\R 1 0))

(deftest last-elt.error.1
    (mapcar (lambda (x)
              (handler-case
                  (last-elt x)
                (type-error ()
                  :type-error)))
            (list nil
                  #()
                  12
                  :zot
                  (circular-list 1 2 3)
                  (list* 1 2 3 (circular-list 4 5))))
  (:type-error
   :type-error
   :type-error
   :type-error
   :type-error
   :type-error))

(deftest setf-last-elt.1
    (let ((l (list 1 2 3))
          (s (copy-seq "foobar"))
          (b (copy-seq #*010101001)))
      (setf (last-elt l) '???
            (last-elt s) #\?
            (last-elt b) 0)
      (values l s b))
  (1 2 ???)
  "fooba?"
  #*010101000)

(deftest setf-last-elt.error.1
    (handler-case
        (setf (last-elt 'foo) 13)
      (type-error ()
        :type-error))
  :type-error)

(deftest starts-with.1
    (list (starts-with 1 '(1 2 3))
          (starts-with 1 #(1 2 3))
          (starts-with #\x "xyz")
          (starts-with 2 '(1 2 3))
          (starts-with 3 #(1 2 3))
          (starts-with 1 1)
          (starts-with nil nil))
  (t t t nil nil nil nil))

(deftest starts-with.2
    (values (starts-with 1 '(-1 2 3) :key '-)
            (starts-with "foo" '("foo" "bar") :test 'equal)
            (starts-with "f" '(#\f) :key 'string :test 'equal)
            (starts-with -1 '(0 1 2) :key #'1+)
            (starts-with "zot" '("ZOT") :test 'equal))
  t
  t
  t
  nil
  nil)

(deftest ends-with.1
    (list (ends-with 3 '(1 2 3))
          (ends-with 3 #(1 2 3))
          (ends-with #\z "xyz")
          (ends-with 2 '(1 2 3))
          (ends-with 1 #(1 2 3))
          (ends-with 1 1)
          (ends-with nil nil))
  (t t t nil nil nil nil))

(deftest ends-with.2
    (values (ends-with 2 '(0 13 1) :key '1+)
            (ends-with "foo" (vector "bar" "foo") :test 'equal)
            (ends-with "X" (vector 1 2 #\X) :key 'string :test 'equal)
            (ends-with "foo" "foo" :test 'equal))
  t
  t
  t
  nil)

(deftest ends-with.error.1
    (handler-case
        (ends-with 3 (circular-list 3 3 3 1 3 3))
      (type-error ()
        :type-error))
  :type-error)

(deftest sequences.passing-improper-lists
    (macrolet ((signals-error-p (form)
                 `(handler-case 
                      (progn ,form nil)
                    (type-error (e)
                      t)))
               (cut (fn &rest args)
                 (with-gensyms (arg)
                   (print`(lambda (,arg)
                       (apply ,fn (list ,@(substitute arg '_ args))))))))
      (let ((circular-list (make-circular-list 5 :initial-element :foo))
            (dotted-list (list* 'a 'b 'c 'd)))
        (loop for nth from 0
              for fn in (list
                         (cut #'lastcar _)
                         (cut #'rotate _ 3)
                         (cut #'rotate _ -3)
                         (cut #'shuffle _)
                         (cut #'random-elt _)
                         (cut #'last-elt _)
                         (cut #'ends-with :foo _))
              nconcing
                 (let ((on-circular-p (signals-error-p (funcall fn circular-list)))
                       (on-dotted-p (signals-error-p (funcall fn dotted-list))))
                   (when (or (not on-circular-p) (not on-dotted-p))
                     (append
                      (unless on-circular-p
                        (let ((*print-circle* t))
                          (list
                           (format nil
                                   "No appropriate error signalled when passing ~S to ~Ath entry."
                                   circular-list nth))))
                      (unless on-dotted-p
                        (list
                         (format nil
                                 "No appropriate error signalled when passing ~S to ~Ath entry."
                                 dotted-list nth)))))))))
  nil)

(deftest with-unique-names.1
    (let ((*gensym-counter* 0))
      (let ((syms (with-unique-names (foo bar quux)
                    (list foo bar quux))))
        (list (find-if #'symbol-package syms)
              (equal '("FOO0" "BAR1" "QUUX2")
                     (mapcar #'symbol-name syms)))))
  (nil t))

(deftest with-unique-names.2
    (let ((*gensym-counter* 0))
      (let ((syms (with-unique-names ((foo "_foo_") (bar -bar-) (quux #\q))
                    (list foo bar quux))))
        (list (find-if #'symbol-package syms)
              (equal '("_foo_0" "-BAR-1" "q2")
                     (mapcar #'symbol-name syms)))))
  (nil t))

(deftest with-unique-names.3
    (let ((*gensym-counter* 0))
      (multiple-value-bind (res err)
          (ignore-errors
            (eval
             '(let ((syms
                     (with-unique-names ((foo "_foo_") (bar -bar-) (quux 42))
                       (list foo bar quux))))
               (list (find-if #'symbol-package syms)
                (equal '("_foo_0" "-BAR-1" "q2")
                 (mapcar #'symbol-name syms))))))
        (typep err 'error)))
  t)

(deftest once-only.1
    (macrolet ((cons1.good (x)
                 (once-only (x)
                   `(cons ,x ,x)))
               (cons1.bad (x)
                 `(cons ,x ,x)))
      (let ((y 0))
        (list (cons1.good (incf y))
              y
              (cons1.bad (incf y))
              y)))
  ((1 . 1) 1 (2 . 3) 3))

(deftest once-only.2
    (macrolet ((cons1 (x)
                 (once-only ((y x))
                   `(cons ,y ,y))))
      (let ((z 0))
        (list (cons1 (incf z))
              z
              (cons1 (incf z)))))
  ((1 . 1) 1 (2 . 2)))

(deftest parse-body.1
    (parse-body '("doc" "body") :documentation t)
  ("body")
  nil
  "doc")

(deftest parse-body.2
    (parse-body '("body") :documentation t)
  ("body")
  nil
  nil)

(deftest parse-body.3
    (parse-body '("doc" "body"))
  ("doc" "body")
  nil
  nil)

(deftest parse-body.4
    (parse-body '((declare (foo)) "doc" (declare (bar)) body) :documentation t)
  (body)
  ((declare (foo)) (declare (bar)))
  "doc")

(deftest parse-body.5
    (parse-body '((declare (foo)) "doc" (declare (bar)) body))
  ("doc" (declare (bar)) body)
  ((declare (foo)))
  nil)

(deftest parse-body.6
    (multiple-value-bind (res err)
        (ignore-errors
          (parse-body '("foo" "bar" "quux")
                      :documentation t))
      (typep err 'error))
  t)

;;;; Symbols

(deftest ensure-symbol.1
    (ensure-symbol :cons :cl)
  cons
  :external)

(deftest ensure-symbol.2
    (ensure-symbol "CONS" :alexandria)
  cons
  :inherited)

(deftest ensure-symbol.3
    (ensure-symbol 'foo :keyword)
  :foo
  :external)

(deftest ensure-symbol.4
    (ensure-symbol #\* :alexandria)
  *
  :inherited)

(deftest format-symbol.1
    (let ((s (format-symbol nil "X-~D" 13)))
      (list (symbol-package s)
            (symbol-name s)))
  (nil "X-13"))

(deftest format-symbol.2
    (format-symbol :keyword "SYM-~A" :bolic)
  :sym-bolic)

(deftest format-symbol.3
    (let ((*package* (find-package :cl)))
      (format-symbol t "FIND-~A" 'package))
  find-package)

(deftest make-keyword.1
    (list (make-keyword 'zot)
          (make-keyword "FOO")
          (make-keyword #\Q))
  (:zot :foo :q))

(deftest make-gensym-list.1
    (let ((*gensym-counter* 0))
      (let ((syms (make-gensym-list 3 "FOO")))
        (list (find-if 'symbol-package syms)
              (equal '("FOO0" "FOO1" "FOO2")
                     (mapcar 'symbol-name syms)))))
  (nil t))

(deftest make-gensym-list.2
    (let ((*gensym-counter* 0))
      (let ((syms (make-gensym-list 3)))
        (list (find-if 'symbol-package syms)
              (equal '("G0" "G1" "G2")
                     (mapcar 'symbol-name syms)))))
  (nil t))

;;;; Type-system

(deftest of-type.1
    (locally
        (declare (notinline of-type))
    (let ((f (of-type 'string)))
      (list (funcall f "foo")
            (funcall f 'bar))))
  (t nil))

(deftest type=.1
    (type= 'string 'string)
  t
  t)

(deftest type=.2
    (type= 'list '(or null cons))
  t
  t)

(deftest type=.3
    (type= 'null '(and symbol list))
  t
  t)

(deftest type=.4
    (type= 'string '(satisfies emptyp))
  nil
  nil)

(deftest type=.5
    (type= 'string 'list)
  nil
  t)

(macrolet
    ((test (type numbers)
       `(deftest ,(format-symbol t "CDR5.~A" type)
            (let ((numbers ,numbers))
              (values (mapcar (of-type ',(format-symbol t "NEGATIVE-~A" type)) numbers)
                      (mapcar (of-type ',(format-symbol t "NON-POSITIVE-~A" type)) numbers)
                      (mapcar (of-type ',(format-symbol t "NON-NEGATIVE-~A" type)) numbers)
                      (mapcar (of-type ',(format-symbol t "POSITIVE-~A" type)) numbers)))
          (t t t nil nil nil nil)
          (t t t t nil nil nil)
          (nil nil nil t t t t)
          (nil nil nil nil t t t))))
  (test fixnum       (list most-negative-fixnum       -42      -1     0     1     42      most-positive-fixnum))
  (test integer      (list (1- most-negative-fixnum)  -42      -1     0     1     42      (1+ most-positive-fixnum)))
  (test rational     (list (1- most-negative-fixnum)  -42/13   -1     0     1     42/13   (1+ most-positive-fixnum)))
  (test real         (list most-negative-long-float   -42/13   -1     0     1     42/13   most-positive-long-float))
  (test float        (list most-negative-short-float  -42.02   -1.0   0.0   1.0   42.02   most-positive-short-float))
  (test short-float  (list most-negative-short-float  -42.02s0 -1.0s0 0.0s0 1.0s0 42.02s0 most-positive-short-float))
  (test single-float (list most-negative-single-float -42.02f0 -1.0f0 0.0f0 1.0f0 42.02f0 most-positive-single-float))
  (test double-float (list most-negative-double-float -42.02d0 -1.0d0 0.0d0 1.0d0 42.02d0 most-positive-double-float))
  (test long-float   (list most-negative-long-float   -42.02l0 -1.0l0 0.0l0 1.0l0 42.02l0 most-positive-long-float)))

;;;; Bindings

(declaim (notinline opaque))
(defun opaque (x)
  x)

(deftest if-let.1
    (if-let (x (opaque :ok))
            x
            :bad)
  :ok)

(deftest if-let.2
    (if-let (x (opaque nil))
            :bad
            (and (not x) :ok))
  :ok)

(deftest if-let.3
    (let ((x 1))
      (if-let ((x 2)
               (y x))
              (+ x y)
              :oops))
  3)

(deftest if-let.4
    (if-let ((x 1)
             (y nil))
            :oops
            (and (not y) x))
  1)

(deftest if-let.5
    (if-let (x)
            :oops
            (not x))
  t)

(deftest if-let.error.1
    (handler-case
        (eval '(if-let x
                :oops
                :oops))
      (type-error ()
        :type-error))
  :type-error)

(deftest when-let.1
    (when-let (x (opaque :ok))
      (setf x (cons x x))
      x)
  (:ok . :ok))

(deftest when-let.2
    (when-let ((x 1)
               (y nil)
               (z 3))
      :oops)
  nil)

(deftest when-let.3
    (let ((x 1))
      (when-let ((x 2)
                 (y x))
        (+ x y)))
  3)

(deftest when-let.error.1
    (handler-case
        (eval '(when-let x :oops))
      (type-error ()
        :type-error))
  :type-error)

(deftest when-let*.1
    (let ((x 1))
      (when-let* ((x 2)
                  (y x))
        (+ x y)))
  4)

(deftest when-let*.2
    (let ((y 1))
      (when-let* (x y)
        (1+ x)))
  2)

(deftest when-let*.3
    (when-let* ((x t)
                (y (consp x))
                (z (error "OOPS")))
      t)
  nil)

(deftest when-let*.error.1
    (handler-case
        (eval '(when-let* x :oops))
      (type-error ()
        :type-error))
  :type-error)

(deftest nth-value-or.1
    (multiple-value-bind (a b c)
        (nth-value-or 1
                      (values 1 nil 1)
                      (values 2 2 2))
      (= a b c 2))
  t)

(deftest doplist.1
    (let (keys values)
      (doplist (k v '(a 1 b 2 c 3) (values t (reverse keys) (reverse values) k v))
        (push k keys)
        (push v values)))
  t
  (a b c)
  (1 2 3)
  nil
  nil)