[uim-commit] r775 - in branches/composer: scm test

[yamaken at freedesktop.org]

Author: yamaken
Date: 2005-03-08 11:30:51 -0800 (Tue, 08 Mar 2005)
New Revision: 775

Modified:
   branches/composer/scm/util.scm
   branches/composer/test/test-util.scm
Log:
* scm/util.scm
  - (zero?, positive?, negative?): New R5RS procedure
  - (clamp): New procedure
* test/test-util.scm
  - (test clamp, test zero?, test positive?, test negative?): New test


Modified: branches/composer/scm/util.scm
===================================================================
--- branches/composer/scm/util.scm	2005-03-08 18:25:47 UTC (rev 774)
+++ branches/composer/scm/util.scm	2005-03-08 19:30:51 UTC (rev 775)
@@ -175,6 +175,11 @@
   (lambda (key alist)
     (safe-cdr (assq key alist))))
 
+(define clamp
+  (lambda (x bottom ceiling)
+    (max bottom
+	 (min x ceiling))))
+
 ;;
 ;; R5RS procedures (don't expect 100% compatibility)
 ;;
@@ -197,6 +202,20 @@
 	(and (pair? x)
 	     (list? (cdr x))))))
 
+(define zero?
+  (lambda (x)
+    (if (integer? x)
+	(= x 0)
+	(error "non-numeric value for zero?"))))
+
+(define positive?
+  (lambda (x)
+    (> x 0)))
+
+(define negative?
+  (lambda (x)
+    (< x 0)))
+
 (define string->symbol intern)
 
 (define map

Modified: branches/composer/test/test-util.scm
===================================================================
--- branches/composer/test/test-util.scm	2005-03-08 18:25:47 UTC (rev 774)
+++ branches/composer/test/test-util.scm	2005-03-08 19:30:51 UTC (rev 775)
@@ -569,8 +569,78 @@
    (assert-equal 4
 		 (uim '((compose car cdr reverse) test-list)))
    (assert-equal 3
-		 (uim '((compose car cdr cdr reverse) test-list)))))
+		 (uim '((compose car cdr cdr reverse) test-list))))
+  ("test clamp"
+   (assert-equal 0 (uim '(clamp -2 0 -1)))
+   (assert-equal 0 (uim '(clamp -1 0 -1)))
+   (assert-equal 0 (uim '(clamp 0  0 -1)))
+   (assert-equal 0 (uim '(clamp 1  0 -1)))
+   (assert-equal 0 (uim '(clamp 2  0 -1)))
+   (assert-equal 0 (uim '(clamp 10 0 -1)))
 
+   (assert-equal -2 (uim '(clamp -2 -2 0)))
+   (assert-equal -1 (uim '(clamp -1 -2 0)))
+   (assert-equal 0  (uim '(clamp 0  -2 0)))
+   (assert-equal 0  (uim '(clamp 1  -2 0)))
+   (assert-equal 0  (uim '(clamp 2  -2 0)))
+   (assert-equal 0  (uim '(clamp 10 -2 0)))
+
+   (assert-equal -1 (uim '(clamp -2 -1 0)))
+   (assert-equal -1 (uim '(clamp -1 -1 0)))
+   (assert-equal 0  (uim '(clamp 0  -1 0)))
+   (assert-equal 0  (uim '(clamp 1  -1 0)))
+   (assert-equal 0  (uim '(clamp 2  -1 0)))
+   (assert-equal 0  (uim '(clamp 10 -1 0)))
+
+   (assert-equal 0 (uim '(clamp -2 0 0)))
+   (assert-equal 0 (uim '(clamp -1 0 0)))
+   (assert-equal 0 (uim '(clamp 0  0 0)))
+   (assert-equal 0 (uim '(clamp 1  0 0)))
+   (assert-equal 0 (uim '(clamp 2  0 0)))
+   (assert-equal 0 (uim '(clamp 10 0 0)))
+
+   (assert-equal 0 (uim '(clamp -2 0 1)))
+   (assert-equal 0 (uim '(clamp -1 0 1)))
+   (assert-equal 0 (uim '(clamp 0  0 1)))
+   (assert-equal 1 (uim '(clamp 1  0 1)))
+   (assert-equal 1 (uim '(clamp 2  0 1)))
+   (assert-equal 1 (uim '(clamp 10 0 1)))
+
+   (assert-equal 0 (uim '(clamp -2 0 2)))
+   (assert-equal 0 (uim '(clamp -1 0 2)))
+   (assert-equal 0 (uim '(clamp 0  0 2)))
+   (assert-equal 1 (uim '(clamp 1  0 2)))
+   (assert-equal 2 (uim '(clamp 2  0 2)))
+   (assert-equal 2 (uim '(clamp 10 0 2)))
+
+   (assert-equal 0 (uim '(clamp -2 0 3)))
+   (assert-equal 0 (uim '(clamp -1 0 3)))
+   (assert-equal 0 (uim '(clamp 0  0 3)))
+   (assert-equal 1 (uim '(clamp 1  0 3)))
+   (assert-equal 2 (uim '(clamp 2  0 3)))
+   (assert-equal 3 (uim '(clamp 10 0 3)))
+
+   (assert-equal 1 (uim '(clamp -2 1 3)))
+   (assert-equal 1 (uim '(clamp -1 1 3)))
+   (assert-equal 1 (uim '(clamp 0  1 3)))
+   (assert-equal 1 (uim '(clamp 1  1 3)))
+   (assert-equal 2 (uim '(clamp 2  1 3)))
+   (assert-equal 3 (uim '(clamp 10 1 3)))
+
+   (assert-equal -1 (uim '(clamp -2 -1 3)))
+   (assert-equal -1 (uim '(clamp -1 -1 3)))
+   (assert-equal 0  (uim '(clamp 0  -1 3)))
+   (assert-equal 1  (uim '(clamp 1  -1 3)))
+   (assert-equal 2  (uim '(clamp 2  -1 3)))
+   (assert-equal 3  (uim '(clamp 10 -1 3)))
+
+   (assert-equal -2 (uim '(clamp -2 -5 5)))
+   (assert-equal -1 (uim '(clamp -1 -5 5)))
+   (assert-equal 0  (uim '(clamp 0  -5 5)))
+   (assert-equal 1  (uim '(clamp 1  -5 5)))
+   (assert-equal 2  (uim '(clamp 2  -5 5)))
+   (assert-equal 5  (uim '(clamp 10 -5 5))))
+
 (define-uim-test-case "testcase util R5RS procedures"
   (setup
    (lambda ()
@@ -643,6 +713,48 @@
    (assert-true  (uim-bool '(list? '(1))))
    (assert-true  (uim-bool '(list? '(1 "2"))))
    (assert-true  (uim-bool '(list? '(1 "2" 'three)))))
+  ("test zero?"
+   (assert-error (lambda () (uim-bool '(zero? #f))))
+   (assert-error (lambda () (uim-bool '(zero? "foo"))))
+   (assert-error (lambda () (uim-bool '(zero? 'foo))))
+   (assert-false (uim-bool '(zero? -2)))
+   (assert-false (uim-bool '(zero? -1)))
+   (assert-true  (uim-bool '(zero? 0)))
+   (assert-false (uim-bool '(zero? 1)))
+   (assert-false (uim-bool '(zero? 2)))
+   (assert-false (uim-bool '(zero? 10)))
+   (assert-error (lambda () (uim-bool '(zero? ()))))
+   (assert-error (lambda () (uim-bool '(zero? '(1)))))
+   (assert-error (lambda () (uim-bool '(zero? '(1 "2")))))
+   (assert-error (lambda () (uim-bool '(zero? '(1 "2" 'three))))))
+  ("test positive?"
+   (assert-error (lambda () (uim-bool '(positive? #f))))
+   (assert-error (lambda () (uim-bool '(positive? "foo"))))
+   (assert-error (lambda () (uim-bool '(positive? 'foo))))
+   (assert-false (uim-bool '(positive? -2)))
+   (assert-false (uim-bool '(positive? -1)))
+   (assert-false (uim-bool '(positive? 0)))
+   (assert-true  (uim-bool '(positive? 1)))
+   (assert-true  (uim-bool '(positive? 2)))
+   (assert-true  (uim-bool '(positive? 10)))
+   (assert-error (lambda () (uim-bool '(positive? ()))))
+   (assert-error (lambda () (uim-bool '(positive? '(1)))))
+   (assert-error (lambda () (uim-bool '(positive? '(1 "2")))))
+   (assert-error (lambda () (uim-bool '(positive? '(1 "2" 'three))))))
+  ("test negative?"
+   (assert-error (lambda () (uim-bool '(negative? #f))))
+   (assert-error (lambda () (uim-bool '(negative? "foo"))))
+   (assert-error (lambda () (uim-bool '(negative? 'foo))))
+   (assert-true  (uim-bool '(negative? -2)))
+   (assert-true  (uim-bool '(negative? -1)))
+   (assert-false (uim-bool '(negative? 0)))
+   (assert-false (uim-bool '(negative? 1)))
+   (assert-false (uim-bool '(negative? 2)))
+   (assert-false (uim-bool '(negative? 10)))
+   (assert-error (lambda () (uim-bool '(negative? ()))))
+   (assert-error (lambda () (uim-bool '(negative? '(1)))))
+   (assert-error (lambda () (uim-bool '(negative? '(1 "2")))))
+   (assert-error (lambda () (uim-bool '(negative? '(1 "2" 'three))))))
   ("test string->symbol"
    (assert-equal 'foo1
 		 (uim '(string->symbol "foo1")))