X-Git-Url: http://git.kpe.io/?p=kmrcl.git;a=blobdiff_plain;f=tests.lisp;h=fb6f977cc5c63481c8e242eb4552aebafa854f11;hp=e149575ba02cb992b29efc7aee3600f4f164b67b;hb=251043d4c96c996a35cd48c4452b03fbef2ea21a;hpb=ce1dec84d6dfd0d4270ddc01f72ec9810c655fce

diff --git a/tests.lisp b/tests.lisp
index e149575..fb6f977 100644
--- a/tests.lisp
+++ b/tests.lisp
@@ -1,4 +1,4 @@
-;;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Package: kmrcl-tests -*-
+;;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp -*-
 ;;;; *************************************************************************
 ;;;; FILE IDENTIFICATION
 ;;;;
@@ -7,9 +7,7 @@
 ;;;; Author:        Kevin M. Rosenberg
 ;;;; Date Started:  Apr 2003
 ;;;;
-;;;; $Id$
-;;;;
-;;;; This file is Copyright (c) 2000-2002 by Kevin M. Rosenberg
+;;;; This file is Copyright (c) 2000-2010 by Kevin M. Rosenberg
 ;;;;
 ;;;; *************************************************************************
 
@@ -17,7 +15,7 @@
 (defpackage #:kmrcl-tests
   (:use #:kmrcl #:cl #:rtest))
 (in-package #:kmrcl-tests)
- 
+
 (rem-all-tests)
 
 
@@ -45,9 +43,9 @@
 (deftest :str.17 (nstring-trim-last-character "ab") "a")
 
 (deftest :str.18 (delimited-string-to-list "ab|cd|ef" #\|)
-					  ("ab" "cd" "ef"))
+                                          ("ab" "cd" "ef"))
 (deftest :str.19 (delimited-string-to-list "ab|cd|ef" #\| t)
-					  ("ab" "cd" "ef"))
+                                          ("ab" "cd" "ef"))
 (deftest :str.20 (delimited-string-to-list "") (""))
 (deftest :str.21 (delimited-string-to-list "" #\space t) (""))
 (deftest :str.22 (delimited-string-to-list "ab") ("ab"))
@@ -64,13 +62,29 @@
 (deftest :sdstl.4 (string-delimited-string-to-list "ab|cd|ef" "ab")
   ("" "|cd|ef"))
 
+(deftest :hexstr.1 (binary-sequence-to-hex-string ())
+  "")
+
+(deftest :hexstr.2 (binary-sequence-to-hex-string #())
+  "")
+
+(deftest :hexstr.3 (binary-sequence-to-hex-string #(165))
+  "a5"
+)
+
+(deftest :hexstr.4 (binary-sequence-to-hex-string (list 165))
+  "a5")
+
+(deftest :hexstr.5 (binary-sequence-to-hex-string #(165 86))
+  "a556")
+
 (deftest :apsl.1 (append-sublists '((a b) (c d))) (a b c d))
 (deftest :apsl.2 (append-sublists nil) nil)
 (deftest :apsl.3 (append-sublists '((a b))) (a b))
 (deftest :apsl.4 (append-sublists '((a))) (a))
 (deftest :apsl.5 (append-sublists '((a) (b) (c d (e f g)))) (a b c d (e f g)))
 
-(deftest :pss.0 (with-output-to-string (s) (print-separated-strings s "|" nil)) 
+(deftest :pss.0 (with-output-to-string (s) (print-separated-strings s "|" nil))
   "")
 
 (deftest :pss.1
@@ -103,9 +117,9 @@
 (deftest :css.5 (concat-separated-strings "|" '("ab" "cd") nil '("ef")) "ab|cd|ef")
 
 (deftest :f.1 (map-and-remove-nils #'(lambda (x) (when (oddp x) (* x x)))
-		     '(0 1 2 3 4 5 6 7 8 9)) (1 9 25 49 81))
+                     '(0 1 2 3 4 5 6 7 8 9)) (1 9 25 49 81))
 (deftest :f.2 (filter #'(lambda (x) (when (oddp x) (* x x)))
-		     '(0 1 2 3 4 5 6 7 8 9)) (1 3 5 7 9))
+                     '(0 1 2 3 4 5 6 7 8 9)) (1 3 5 7 9))
 (deftest :an.1 (appendnew '(a b c d) '(c c e f)) (a b c d e f))
 
 
@@ -186,6 +200,15 @@
 (deftest :sse.4 (string-strip-ending "abc" '("ab")) "abc")
 (deftest :sse.5 (string-strip-ending "abcd" '("a" "cd")) "ab")
 
+(deftest :rcs.1 (remove-char-string #\space "") "")
+(deftest :rcs.2 (remove-char-string #\space "a") "a")
+(deftest :rcs.3 (remove-char-string #\space "ab") "ab")
+(deftest :rcs.4 (remove-char-string #\space "a b") "ab")
+(deftest :rcs.5 (remove-char-string #\space " a b") "ab")
+(deftest :rcs.6 (remove-char-string #\space "a b ") "ab")
+(deftest :rcs.7 (remove-char-string #\space "a  b   c  ") "abc")
+(deftest :rcs.8 (remove-char-string #\space "a  b   c  d") "abcd")
+
 
 (defun test-color-conversion ()
   (dotimes (ih 11)
@@ -197,7 +220,7 @@
           (multiple-value-bind (r g b) (hsv->rgb h s v)
             (multiple-value-bind (h2 s2 v2) (rgb->hsv r g b)
               (unless (hsv-equal h s v h2 s2 v2)
-                (warn "Colors not equal: ~4D ~4D ~4D | ~6D:~6D ~6D:~6D ~6D:~6D~%" 
+                (warn "Colors not equal: ~4D ~4D ~4D | ~6D:~6D ~6D:~6D ~6D:~6D~%"
                         (float r) (float g) (float b)
                         (when (typep h 'number) (float h))
                         (when (typep h2 'number) (float h2))
@@ -220,7 +243,7 @@
               (unless (hsv-similar h s v h2 (/ s2 255) (/ v2 255)
                                    :hue-range 10 :saturation-range .1
                                    :value-range 1 :black-limit 0 :gray-limit 0)
-                (warn "Colors not equal: ~4D ~4D ~4D | ~6D:~6D ~6D:~6D ~6D:~6D~%" 
+                (warn "Colors not equal: ~4D ~4D ~4D | ~6D:~6D ~6D:~6D ~6D:~6D~%"
                       r g b
                       (when (typep h 'number) (float h))
                       (when (typep h2 'number) (float h2))
@@ -245,14 +268,14 @@
               (unless (hsv-similar h s v h2 s2 v2
                                    :hue-range 10 :saturation-range .1
                                    :value-range 1 :black-limit 0 :gray-limit 0)
-                (warn "Colors not equal: ~4D ~4D ~4D | ~6D:~6D ~6D:~6D ~6D:~6D~%" 
+                (warn "Colors not equal: ~4D ~4D ~4D | ~6D:~6D ~6D:~6D ~6D:~6D~%"
                       r g b
                       (when (typep h 'number) (float h))
                       (when (typep h2 'number) (float h2))
                       (float s) (float (/ s2 255)) (float v) (float (/ v2 255)))
                 (return-from test-color-conversion-255-float nil))))))))
   t)
- 
+
 (defun test-color-conversion-255 ()
   (dotimes (ih 11)
     (dotimes (is 11)
@@ -265,7 +288,7 @@
               (unless (hsv255-similar h s v h2 s2 v2 :hue-range 10 :saturation-range 5
                                       :value-range 5 :black-limit 0 :gray-limit 0)
                 (warn "Colors not equal: ~D ~D ~D |~
- ~3,'0D:~3,'0D ~3,'0D:~3,'0D ~3,'0D:~3,'0D~%" 
+ ~3,'0D:~3,'0D ~3,'0D:~3,'0D ~3,'0D:~3,'0D~%"
                       r g b
                       h h2 s s2 v v2)
                 (return-from test-color-conversion-255 nil))))))))
@@ -274,7 +297,7 @@
 (deftest :color.conv (test-color-conversion) t)
 (deftest :color.conv.float.255 (test-color-conversion-float-255) t)
 (deftest :color.conv.255.float (test-color-conversion-255-float) t)
-(deftest :color.conv.255 (test-color-conversion-255) t) 
+(deftest :color.conv.255 (test-color-conversion-255) t)
 
 (deftest :hue.diff.1 (hue-difference 10 10) 0)
 (deftest :hue.diff.2 (hue-difference 10 9) -1)
@@ -382,12 +405,12 @@
 (defclass test-unique ()
   ((a :initarg :a)
    (b :initarg :b)))
-     
+
 
 (deftest :unique.1
     (let ((list (list (make-instance 'test-unique :a 1 :b 1)
-		      (make-instance 'test-unique :a 2 :b 2)
-		      (make-instance 'test-unique :a 3 :b 2))))
+                      (make-instance 'test-unique :a 2 :b 2)
+                      (make-instance 'test-unique :a 3 :b 2))))
       (values
        (unique-slot-values list 'a)
        (unique-slot-values list 'b)))
@@ -397,16 +420,69 @@
     (unique-slot-values nil 'a)
   nil)
 
-(deftest :nwp.1     
+(deftest :nwp.1
        (numbers-within-percentage 1. 1.1 9)
   nil)
 
 (deftest :nwp.2
        (numbers-within-percentage 1. 1.1 11)
   t)
-  
-	   
- ;;; MOP Testing
+
+(deftest :pfs.1 (prefixed-fixnum-string 0 #\A 5) "A00000")
+
+(deftest :pfs.2 (prefixed-fixnum-string 1 #\A 5) "A00001")
+
+(deftest :pfs.3 (prefixed-fixnum-string 21 #\B 3) "B021")
+
+(deftest :pis.4 (prefixed-integer-string 234134 #\C 7) "C0234134")
+
+;;; Binary tree search tests
+
+(defvar *btree-vector*)
+
+(defun init-btree-vector (len)
+  (make-random-state t)
+  (setq *btree-vector* (make-array (list len)
+                                   :element-type 'fixnum
+                                   :initial-element 0))
+  (dotimes (i (length *btree-vector*))
+    (setf (aref *btree-vector* i) (random most-positive-fixnum)))
+  (setq *btree-vector* (sort *btree-vector* #'<)))
+
+(defun test-btree-vector (len)
+  (init-btree-vector len)
+  (dotimes (i (length *btree-vector*) t)
+    (let ((stored (aref *btree-vector* i)))
+      (multiple-value-bind (pos value last-pos count)
+          (sorted-vector-find stored *btree-vector*)
+        (declare (ignore last-pos))
+        (when (or (not (eql i pos)) (not (eql stored value)))
+          (format t "~&Error: btree value ~D at pos ~D: found ~D at pos ~D [count ~D].~%"
+                  stored i value pos count)
+          (return nil))))))
+
+(deftest :btree.1
+    (dotimes (i 1000 t)
+      (test-btree-vector i))
+  t)
+
+(defun time-btree (&optional (fn #'sorted-vector-find) (return-on-error nil))
+  (time
+   (let ((total-count 0))
+     (declare (fixnum total-count))
+     (dotimes (i (length *btree-vector*) t)
+       (let ((stored (aref *btree-vector* i)))
+         (multiple-value-bind (value pos count)
+             (funcall fn stored *btree-vector*)
+           (incf total-count count)
+           (when (or (/= i pos) (/= stored value))
+             (format t "~&Error: btree value ~D at pos ~D: found ~D at pos ~D [count ~D].~%"
+                     stored i value pos count)
+             (when return-on-error
+               (return-from time-btree nil))))))
+     (float (/ total-count (length *btree-vector*))))))
+
+;;; MOP Testing
 
 ;; Disable attrib class until understand changes in sbcl/cmucl
 ;; using COMPUTE-SLOT-ACCESSOR-INFO and defining method
@@ -422,7 +498,7 @@
 (setf (find-class 'monitored-credit-rating) nil)
 #+kmrtest-mop
 (setf (find-class 'credit-rating) nil)
-  
+
 #+kmrtest-mop
 (defclass credit-rating ()
   ((level :attributes (date-set time-set))
@@ -430,7 +506,7 @@
   #+lispworks (:optimize-slot-access nil)
   (:metaclass attributes-class))
 
-  
+
 #+kmrtest-mop
 (defclass monitored-credit-rating ()
   ((level :attributes (last-checked interval date-set))
@@ -452,7 +528,7 @@
              (setf (slot-attribute cr 'level 'date-set) nil)
              result))
          "12/15/1990")
- 
+
 #+kmrtest-mop
 (deftest :attrib.mop.3
          (let ((mcr (make-instance 'monitored-credit-rating)))
@@ -460,8 +536,8 @@
            (let ((result (slot-attribute mcr 'level 'date-set)))
              (setf (slot-attribute mcr 'level 'date-set) nil)
              result))
-         "01/05/2002") 
-  
+         "01/05/2002")
+
 
 #+kmrtest-mop
 (eval-when (:compile-toplevel :load-toplevel :execute)