[uim-commit] r268 - in trunk: scm test
yamaken@freedesktop.org
yamaken@freedesktop.org
Wed Jan 12 09:40:05 PST 2005
Author: yamaken
Date: 2005-01-12 09:39:59 -0800 (Wed, 12 Jan 2005)
New Revision: 268
Modified:
trunk/scm/util.scm
trunk/test/test-util.scm
Log:
* This commit adds string-join and other new utility procedures to
util.scm. All changes are validated by test-util.scm
* scm/util.scm
- Update copyright
- (join, string-join, string-append-map, append-map): New procedure
- (iota): Support optional 'start' argument
- (alist-replace): Remove the comment "not yet tested"
* test/test-util.scm
- (test join, test string-join, test string-append-map, test
append-map): New test
- (test iota): Add tests for 'start' argument
Modified: trunk/scm/util.scm
===================================================================
--- trunk/scm/util.scm 2005-01-12 16:52:21 UTC (rev 267)
+++ trunk/scm/util.scm 2005-01-12 17:39:59 UTC (rev 268)
@@ -1,6 +1,6 @@
;;; util.scm: Utility functions for uim.
;;;
-;;; Copyright (c) 2003,2004 uim Project http://uim.freedesktop.org/
+;;; Copyright (c) 2003-2005 uim Project http://uim.freedesktop.org/
;;;
;;; All rights reserved.
;;;
@@ -133,7 +133,6 @@
new-state
(iterate-lists mapper new-state rests)))))))
-;; not yet tested -- YamaKen 2004-10-30
(define alist-replace
(lambda (kons alist)
(let* ((id (car kons))
@@ -144,6 +143,22 @@
alist)
(cons kons alist)))))
+(define join
+ (lambda (sep list)
+ (let ((len (length list)))
+ (if (= len 0)
+ ()
+ (cdr (apply append (zip (make-list len sep)
+ list)))))))
+
+(define string-join
+ (lambda (sep str-list)
+ (apply string-append (join sep str-list))))
+
+(define string-append-map
+ (lambda args
+ (apply string-append (apply map args))))
+
;;
;; R5RS procedures (don't expect 100% compatibility)
;;
@@ -228,12 +243,16 @@
fill))))
;; This procedure does not conform to the SRFI-1 specification. The
-;; optional arguments 'start' and 'step' is not supported.
+;; optional argument 'step' is not supported.
(define iota
- (lambda (count)
- (list-tabulate count
- (lambda (i)
- i))))
+ (lambda args
+ (let ((count (car args))
+ (start (if (not (null? (cdr args)))
+ (cadr args)
+ 0)))
+ (list-tabulate (- count start)
+ (lambda (i)
+ (+ start i))))))
(define zip
(lambda lists
@@ -244,6 +263,10 @@
(rests (map cdr lists)))
(cons elms (apply zip rests)))))))
+(define append-map
+ (lambda args
+ (apply append (apply map args))))
+
(define append-reverse
(lambda (rev-head tail)
(fold cons tail rev-head)))
Modified: trunk/test/test-util.scm
===================================================================
--- trunk/test/test-util.scm 2005-01-12 16:52:21 UTC (rev 267)
+++ trunk/test/test-util.scm 2005-01-12 17:39:59 UTC (rev 268)
@@ -29,7 +29,7 @@
;;; SUCH DAMAGE.
;;;;
-;; This file is tested with revision 142(new repository)
+;; This file is tested with revision 268 (new repository)
(use test.unit)
@@ -316,8 +316,99 @@
(uim 'alist))
(uim '(set! alist (alist-replace '(second two "two") alist)))
(assert-equal '((third 3 "3") (second two "two") (first 1 "1"))
- (uim 'alist))))
+ (uim 'alist)))
+ ("test join"
+ (assert-equal ()
+ (uim '(join () ())))
+ (assert-equal '(())
+ (uim '(join () '(()))))
+ (assert-equal '(1)
+ (uim '(join () '(1))))
+ (assert-equal '(() () ())
+ (uim '(join () '(() ()))))
+ (assert-equal '(1 () 2)
+ (uim '(join () '(1 2))))
+ (assert-equal '(1 () 2 () 3)
+ (uim '(join () '(1 2 3))))
+ (assert-equal '(one () two () three)
+ (uim '(join () '(one two three))))
+ (assert-equal '("1" () "2" () "3")
+ (uim '(join () '("1" "2" "3"))))
+ (assert-equal '(() () () () ())
+ (uim '(join () '(() () ()))))
+
+ (assert-equal ()
+ (uim '(join "/" ())))
+ (assert-equal '(())
+ (uim '(join "/" '(()))))
+ (assert-equal '(1)
+ (uim '(join "/" '(1))))
+ (assert-equal '(() "/" ())
+ (uim '(join "/" '(() ()))))
+ (assert-equal '(1 "/" 2)
+ (uim '(join "/" '(1 2))))
+ (assert-equal '(1 "/" 2 "/" 3)
+ (uim '(join "/" '(1 2 3))))
+ (assert-equal '(one "/" two "/" three)
+ (uim '(join "/" '(one two three))))
+ (assert-equal '("1" "/" "2" "/" "3")
+ (uim '(join "/" '("1" "2" "3"))))
+ (assert-equal '(() "/" () "/" ())
+ (uim '(join "/" '(() () ())))))
+
+ ("test string-join"
+ (assert-equal ""
+ (uim '(string-join () ())))
+ (assert-error (lambda ()
+ (uim '(string-join () '(())))))
+ (assert-error (lambda ()
+ (uim '(string-join () '(1)))))
+ (assert-error (lambda ()
+ (uim '(string-join () '(() ())))))
+ (assert-error (lambda ()
+ (uim '(string-join () '(1 2)))))
+ (assert-error (lambda ()
+ (uim '(string-join () '(1 2 3)))))
+ (assert-error (lambda ()
+ (uim '(string-join () '(one two three)))))
+ (assert-error (lambda ()
+ (uim '(string-join () '("1" "2" "3")))))
+ (assert-error (lambda ()
+ (uim '(string-join () '(() () ())))))
+
+ (assert-equal ""
+ (uim '(string-join "/" ())))
+ (assert-equal ""
+ (uim '(string-join "/" '(""))))
+ (assert-equal "1"
+ (uim '(string-join "/" '("1"))))
+ (assert-equal "1/2"
+ (uim '(string-join "/" '("1" "2"))))
+ (assert-equal "1/2/3"
+ (uim '(string-join "/" '("1" "2" "3"))))
+
+ (assert-equal ""
+ (uim '(string-join "-sep-" ())))
+ (assert-equal ""
+ (uim '(string-join "-sep-" '(""))))
+ (assert-equal "1"
+ (uim '(string-join "-sep-" '("1"))))
+ (assert-equal "1-sep-2"
+ (uim '(string-join "-sep-" '("1" "2"))))
+ (assert-equal "1-sep-2-sep-3"
+ (uim '(string-join "-sep-" '("1" "2" "3")))))
+
+ ("test string-append-map"
+ (assert-equal ""
+ (uim '(string-append-map car ())))
+ (assert-equal "c"
+ (uim '(string-append-map car '(("c" "C")))))
+ (assert-equal "ca"
+ (uim '(string-append-map car '(("c" "C") ("a" "A")))))
+ (assert-equal "car"
+ (uim '(string-append-map car '(("c" "C") ("a" "A") ("r" "R")))))))
+
(define-uim-test-case "testcase util R5RS procedures"
(setup
(lambda ()
@@ -593,8 +684,36 @@
(assert-equal '(0 1 2 3 4)
(uim '(iota 5)))
(assert-error (lambda ()
- (uim '(iota -1)))))
+ (uim '(iota -1))))
+ (assert-equal ()
+ (uim '(iota 0 0)))
+ (assert-equal '(0)
+ (uim '(iota 1 0)))
+ (assert-equal '(0 1 2 3 4)
+ (uim '(iota 5 0)))
+ (assert-error (lambda ()
+ (uim '(iota -1 0))))
+
+ (assert-error (lambda ()
+ (uim '(iota 0 1))))
+ (assert-equal '()
+ (uim '(iota 1 1)))
+ (assert-equal '(1 2 3 4)
+ (uim '(iota 5 1)))
+ (assert-error (lambda ()
+ (uim '(iota -1 1))))
+
+ (assert-error (lambda ()
+ (uim '(iota 1 3))))
+ (assert-equal '(3 4)
+ (uim '(iota 5 3)))
+ (assert-error (lambda ()
+ (uim '(iota -1 3))))
+
+ (assert-equal '()
+ (uim '(iota 5 5))))
+
("test zip"
(assert-equal '((1) (2) (3) (4) (5))
(uim '(zip '(1 2 3 4 5))))
@@ -612,6 +731,17 @@
'(one two three))))
(assert-equal ()
(uim '(zip ()))))
+
+ ("test append-map"
+ (assert-equal '()
+ (uim '(append-map car ())))
+ (assert-equal '(c)
+ (uim '(append-map car '(((c) (C))))))
+ (assert-equal '(c a)
+ (uim '(append-map car '(((c) (C)) ((a) (A))))))
+ (assert-equal '(c a r)
+ (uim '(append-map car '(((c) (C)) ((a) (A)) ((r) (R)))))))
+
("test append-reverse"
(assert-equal '("5" "4" "3" "2" "1" six seven eight)
(uim '(append-reverse '("1" "2" "3" "4" "5")
More information about the Uim-commit
mailing list