Author: yamakenz
Date: Thu Jul 5 03:12:29 2007
New Revision: 4664
Modified:
sigscheme-trunk/test/test-srfi1-another.scm
Log:
* test/test-srfi1-another.scm
- Add tests for take, map, map-in-order
Modified: sigscheme-trunk/test/test-srfi1-another.scm
==============================================================================
--- sigscheme-trunk/test/test-srfi1-another.scm (original)
+++ sigscheme-trunk/test/test-srfi1-another.scm Thu Jul 5 03:12:29 2007
@@ -36,6 +36,7 @@
(use srfi-1)
(use srfi-6)
+(use srfi-38)
(if (not (provided? "srfi-1"))
(test-skip "SRFI-1 is not enabled"))
@@ -694,12 +695,231 @@
(eq? kdr elm1)))))
;; take
-(tn "take")
+;;
+;; SRFI-1: take returns the first i elements of list x.
+;; x may be any value -- a proper, circular, or dotted list.
+(tn "take proper list invalid forms")
+(assert-error (tn) (lambda () (take '() -1)))
+(assert-error (tn) (lambda () (take '(1 2) -1)))
+(tn "take proper list index 0")
+(assert-equal? (tn) '() (take '() 0))
+(assert-equal? (tn) '() (take '(1) 0))
+(assert-equal? (tn) '() (take '(1 2) 0))
+(assert-equal? (tn) '() (take '(1 2 3) 0))
+(assert-equal? (tn) '() (take '(1 2 3 4) 0))
+(assert-eq? (tn) '() (take lst 0))
+(assert-eq? (tn) '() (take cdr9 0))
+(tn "take proper list index 1")
+(assert-error (tn) (lambda () (take '() 1)))
+(assert-equal? (tn) '(1) (take '(1) 1))
+(assert-equal? (tn) '(1) (take '(1 2) 1))
+(assert-equal? (tn) '(1) (take '(1 2 3) 1))
+(assert-equal? (tn) '(1) (take '(1 2 3 4) 1))
+(assert-equal? (tn) (list elm0) (take lst 1))
+(assert-equal? (tn) (list elm8) (take cdr8 1))
+(assert-equal? (tn) (list elm9) (take cdr9 1))
+(tn "take proper list index 2")
+(assert-error (tn) (lambda () (take '() 2)))
+(assert-error (tn) (lambda () (take '(1) 2)))
+(assert-equal? (tn) '(1 2) (take '(1 2) 2))
+(assert-equal? (tn) '(1 2) (take '(1 2 3) 2))
+(assert-equal? (tn) '(1 2) (take '(1 2 3 4) 2))
+(assert-equal? (tn) (list elm0 elm1) (take lst 2))
+(assert-equal? (tn) (list elm7 elm8) (take cdr7 2))
+(assert-equal? (tn) (list elm8 elm9) (take cdr8 2))
+(assert-error (tn) (lambda () (take cdr9 2)))
+(tn "take proper list index 3")
+(assert-error (tn) (lambda () (take '() 3)))
+(assert-error (tn) (lambda () (take '(1) 3)))
+(assert-error (tn) (lambda () (take '(1 2) 3)))
+(assert-equal? (tn) '(1 2 3) (take '(1 2 3) 3))
+(assert-equal? (tn) '(1 2 3) (take '(1 2 3 4) 3))
+(assert-equal? (tn) (list elm0 elm1 elm2) (take lst 3))
+(assert-equal? (tn) (list elm6 elm7 elm8) (take cdr6 3))
+(assert-equal? (tn) (list elm7 elm8 elm9) (take cdr7 3))
+(assert-error (tn) (lambda () (take cdr8 3)))
+(assert-error (tn) (lambda () (take cdr9 3)))
+(tn "take proper list index 4")
+(assert-error (tn) (lambda () (take '() 4)))
+(assert-error (tn) (lambda () (take '(1) 4)))
+(assert-error (tn) (lambda () (take '(1 2) 4)))
+(assert-error (tn) (lambda () (take '(1 2 3) 4)))
+(assert-equal? (tn) '(1 2 3 4) (take '(1 2 3 4) 4))
+(assert-equal? (tn) (list elm0 elm1 elm2 elm3) (take lst 4))
+(assert-equal? (tn) (list elm5 elm6 elm7 elm8) (take cdr5 4))
+(assert-equal? (tn) (list elm6 elm7 elm8 elm9) (take cdr6 4))
+(assert-error (tn) (lambda () (take cdr7 4)))
+(assert-error (tn) (lambda () (take cdr8 4)))
+(assert-error (tn) (lambda () (take cdr9 4)))
+(tn "take proper list index 5")
+(assert-error (tn) (lambda () (take '() 5)))
+(assert-error (tn) (lambda () (take '(1) 5)))
+(assert-error (tn) (lambda () (take '(1 2) 5)))
+(assert-error (tn) (lambda () (take '(1 2 3) 5)))
+(assert-error (tn) (lambda () (take '(1 2 3 4) 5)))
+(assert-equal? (tn) (list elm0 elm1 elm2 elm3 elm4) (take lst 5))
+(assert-equal? (tn) (list elm4 elm5 elm6 elm7 elm8) (take cdr4 5))
+(assert-equal? (tn) (list elm5 elm6 elm7 elm8 elm9) (take cdr5 5))
+(assert-error (tn) (lambda () (take cdr6 5)))
+(assert-error (tn) (lambda () (take cdr7 5)))
+(assert-error (tn) (lambda () (take cdr8 5)))
+(assert-error (tn) (lambda () (take cdr9 5)))
+(tn "take proper list other indices")
+(assert-equal? (tn)
+ (list elm0 elm1 elm2 elm3 elm4 elm5)
+ (take lst 6))
+(assert-equal? (tn)
+ (list elm0 elm1 elm2 elm3 elm4 elm5 elm6)
+ (take lst 7))
+(assert-equal? (tn)
+ (list elm0 elm1 elm2 elm3 elm4 elm5 elm6 elm7)
+ (take lst 8))
+(assert-equal? (tn)
+ (list elm0 elm1 elm2 elm3 elm4 elm5 elm6 elm7 elm8)
+ (take lst 9))
+(assert-equal? (tn)
+ (list elm0 elm1 elm2 elm3 elm4 elm5 elm6 elm7 elm8 elm9)
+ (take lst 10))
+(assert-error (tn) (lambda () (take lst 11)))
+
+(tn "take dotted list invalid forms")
+(assert-error (tn) (lambda () (take 1 -1)))
+(assert-error (tn) (lambda () (take '(1 . 2) -1)))
+(tn "take dotted list index 0")
+(assert-equal? (tn) '() (take 1 0))
+(assert-equal? (tn) '() (take '(1 . 2) 0))
+(assert-equal? (tn) '() (take '(1 2 . 3) 0))
+(assert-equal? (tn) '() (take '(1 2 3 . 4) 0))
+(assert-equal? (tn) '() (take '(1 2 3 4 . 5) 0))
+(tn "take dotted list index 1")
+(assert-error (tn) (lambda () (take 1 1)))
+(assert-equal? (tn) '(1) (take '(1 . 2) 1))
+(assert-equal? (tn) '(1) (take '(1 2 . 3) 1))
+(assert-equal? (tn) '(1) (take '(1 2 3 . 4) 1))
+(assert-equal? (tn) '(1) (take '(1 2 3 4 . 5) 1))
+(tn "take dotted list index 2")
+(assert-error (tn) (lambda () (take 1 2)))
+(assert-error (tn) (lambda () (take '(1 . 2) 2)))
+(assert-equal? (tn) '(1 2) (take '(1 2 . 3) 2))
+(assert-equal? (tn) '(1 2) (take '(1 2 3 . 4) 2))
+(assert-equal? (tn) '(1 2) (take '(1 2 3 4 . 5) 2))
+(tn "take dotted list index 3")
+(assert-error (tn) (lambda () (take 1 3)))
+(assert-error (tn) (lambda () (take '(1 . 2) 3)))
+(assert-error (tn) (lambda () (take '(1 2 . 3) 3)))
+(assert-equal? (tn) '(1 2 3) (take '(1 2 3 . 4) 3))
+(assert-equal? (tn) '(1 2 3) (take '(1 2 3 4 . 5) 3))
+(tn "take dotted list index 4")
+(assert-error (tn) (lambda () (take 1 4)))
+(assert-error (tn) (lambda () (take '(1 . 2) 4)))
+(assert-error (tn) (lambda () (take '(1 2 . 3) 4)))
+(assert-error (tn) (lambda () (take '(1 2 3 . 4) 4)))
+(assert-equal? (tn) '(1 2 3 4) (take '(1 2 3 4 . 5) 4))
+(tn "take dotted list index 5")
+(assert-error (tn) (lambda () (take 1 5)))
+(assert-error (tn) (lambda () (take '(1 . 2) 5)))
+(assert-error (tn) (lambda () (take '(1 2 . 3) 5)))
+(assert-error (tn) (lambda () (take '(1 2 3 . 4) 5)))
+(assert-error (tn) (lambda () (take '(1 2 3 4 . 5) 5)))
+
+(tn "take circular list invalid forms")
+;; SigScheme's implementation does not detect negative index on circular list
+;; since it is an user error. It goes an infinite loop.
+;;(assert-error (tn) (lambda () (take clst1 -1)))
+;;(assert-error (tn) (lambda () (take clst2 -1)))
+(tn "take circular list index 0")
+(assert-eq? (tn) '() (take clst1 0))
+(assert-eq? (tn) '() (take clst2 0))
+(assert-eq? (tn) '() (take clst3 0))
+(assert-eq? (tn) '() (take clst4 0))
+(tn "take circular list index 1")
+(assert-equal? (tn) (list (list-ref clst1 0)) (take clst1 1))
+(assert-equal? (tn) (list (list-ref clst2 0)) (take clst2 1))
+(assert-equal? (tn) (list (list-ref clst3 0)) (take clst3 1))
+(assert-equal? (tn) (list (list-ref clst4 0)) (take clst4 1))
+(tn "take circular list index 2")
+(assert-equal? (tn) (list (list-ref clst1 0)
+ (list-ref clst1 0)) (take clst1 2))
+(assert-equal? (tn) (list (list-ref clst2 0)
+ (list-ref clst2 1)) (take clst2 2))
+(assert-equal? (tn) (list (list-ref clst3 0)
+ (list-ref clst3 1)) (take clst3 2))
+(assert-equal? (tn) (list (list-ref clst4 0)
+ (list-ref clst4 1)) (take clst4 2))
+(tn "take circular list index 3")
+(assert-equal? (tn) (list (list-ref clst1 0)
+ (list-ref clst1 0)
+ (list-ref clst1 0)) (take clst1 3))
+(assert-equal? (tn) (list (list-ref clst2 0)
+ (list-ref clst2 1)
+ (list-ref clst2 0)) (take clst2 3))
+(assert-equal? (tn) (list (list-ref clst3 0)
+ (list-ref clst3 1)
+ (list-ref clst3 2)) (take clst3 3))
+(assert-equal? (tn) (list (list-ref clst4 0)
+ (list-ref clst4 1)
+ (list-ref clst4 2)) (take clst4 3))
+(tn "take circular list index 4")
+(assert-equal? (tn) (list (list-ref clst1 0)
+ (list-ref clst1 0)
+ (list-ref clst1 0)
+ (list-ref clst1 0)) (take clst1 4))
+(assert-equal? (tn) (list (list-ref clst2 0)
+ (list-ref clst2 1)
+ (list-ref clst2 0)
+ (list-ref clst2 1)) (take clst2 4))
+(assert-equal? (tn) (list (list-ref clst3 0)
+ (list-ref clst3 1)
+ (list-ref clst3 2)
+ (list-ref clst3 0)) (take clst3 4))
+(assert-equal? (tn) (list (list-ref clst4 0)
+ (list-ref clst4 1)
+ (list-ref clst4 2)
+ (list-ref clst4 3)) (take clst4 4))
+(tn "take circular list index 5")
+(assert-equal? (tn) (list (list-ref clst1 0)
+ (list-ref clst1 0)
+ (list-ref clst1 0)
+ (list-ref clst1 0)
+ (list-ref clst1 0)) (take clst1 5))
+(assert-equal? (tn) (list (list-ref clst2 0)
+ (list-ref clst2 1)
+ (list-ref clst2 0)
+ (list-ref clst2 1)
+ (list-ref clst2 0)) (take clst2 5))
+(assert-equal? (tn) (list (list-ref clst3 0)
+ (list-ref clst3 1)
+ (list-ref clst3 2)
+ (list-ref clst3 0)
+ (list-ref clst3 1)) (take clst3 5))
+(assert-equal? (tn) (list (list-ref clst4 0)
+ (list-ref clst4 1)
+ (list-ref clst4 2)
+ (list-ref clst4 3)
+ (list-ref clst4 0)) (take clst4 5))
+(tn "take freshly-allocated entire list")
;; SRFI-1: If the argument is a list of non-zero length, take is guaranteed to
;; return a freshly-allocated list, even in the case where the entire list is
;; taken, e.g. (take lis (length lis)).
(assert-false (tn) (eq? lst (take lst (length lst))))
(assert-true (tn) (equal? lst (take lst (length lst))))
+(define find-pair
+ (lambda (x lst)
+ (let rec ((rest lst))
+ (if (null? rest)
+ #f
+ (or (eq? x rest)
+ (rec (cdr rest)))))))
+;; Check uniqueness for each pair in the new list.
+(assert-true (tn) (let rec ((rest (take lst (length lst))))
+ (if (null? rest)
+ #t
+ (and (not (find-pair rest lst))
+ (rec (cdr rest))))))
+(tn "take SRFI-1 examples")
+(assert-equal? (tn) '(a b) (take '(a b c d e) 2))
+(assert-equal? (tn) '(1 2) (take '(1 2 3 . d) 2))
+(assert-equal? (tn) '(1 2 3) (take '(1 2 3 . d) 3))
;; drop
;;
@@ -1223,7 +1443,105 @@
(lambda (x) tail))))
;; unfold-right
+
;; map
+(tn "map invalid forms")
+(assert-error (tn) (lambda () (map +)))
+(assert-error (tn) (lambda () (map + '#())))
+(assert-error (tn) (lambda () (map + '(1) '#(2))))
+(assert-error (tn) (lambda () (map #\a '(1))))
+(tn "map single list")
+(assert-equal? (tn) '() (map + '()))
+(assert-equal? (tn) '() (map even? '()))
+(assert-equal? (tn) '(2 4 6 8) (map + '(2 4 6 8)))
+(assert-equal? (tn) '(#t #t #t #t) (map even? '(2 4 6 8)))
+(assert-equal? (tn) '(#f #t #t #t #t) (map even? '(3 2 4 6 8)))
+(assert-equal? (tn) '(#t #t #f #t #t) (map even? '(2 4 3 6 8)))
+(assert-equal? (tn) '(#t #t #t #t #f) (map even? '(2 4 6 8 3)))
+(tn "map 3 lists")
+(assert-equal? (tn) '() (map + '() '() '()))
+(assert-equal? (tn) '(12 17 22 27) (map +
+ '(2 4 6 8)
+ '(1 3 5 7)
+ '(9 10 11 12)))
+(assert-equal? (tn) '(12 #f 22 #f) (map (lambda args
+ (let ((sum (apply + args)))
+ (and (even? sum)
+ sum)))
+ '(2 4 6 8)
+ '(1 3 5 7)
+ '(9 10 11 12)))
+(assert-equal? (tn) '(12 18 22 28) (map (lambda args
+ (let ((sum (apply + args)))
+ (and (even? sum)
+ sum)))
+ '(2 4 6 8)
+ '(1 4 5 8)
+ '(9 10 11 12)))
+(tn "map 3 lists unequal length")
+(assert-equal? (tn) '(12 17 22) (map +
+ '(2 4 6)
+ '(1 3 5 7)
+ '(9 10 11 12)))
+(assert-equal? (tn) '(12 17 22) (map +
+ '(2 4 6 8)
+ '(1 3 5)
+ '(9 10 11 12)))
+(assert-equal? (tn) '(12 17 22) (map +
+ '(2 4 6 8)
+ '(1 3 5 7)
+ '(9 10 11)))
+(assert-equal? (tn) '() (map +
+ '()
+ '(1 3 5 7)
+ '(9 10 11 12)))
+(assert-equal? (tn) '() (map +
+ '(2 4 6 8)
+ '()
+ '(9 10 11 12)))
+(assert-equal? (tn) '() (map +
+ '(2 4 6 8)
+ '(1 3 5 7)
+ '()))
+(tn "map 3 lists with circular list")
+(assert-equal? (tn) '(11 15 17 21) (map +
+ clst2
+ '(1 3 5 7)
+ '(9 10 11 12)))
+(assert-equal? (tn) '(11 15 17 21) (map +
+ '(1 3 5 7)
+ clst2
+ '(9 10 11 12)))
+(assert-equal? (tn) '(11 15 17 21) (map +
+ '(1 3 5 7)
+ '(9 10 11 12)
+ clst2))
+(tn "map SRFI-1 examples")
+(assert-equal? (tn)
+ '(b e h)
+ (map cadr '((a b) (d e) (g h))))
+(define expt
+ (lambda (x y)
+ (apply * (make-list y x))))
+(assert-equal? (tn)
+ '(1 4 27 256 3125)
+ (map (lambda (n) (expt n n))
+ '(1 2 3 4 5)))
+(assert-equal? (tn)
+ '(5 7 9)
+ (map + '(1 2 3) '(4 5 6)))
+(assert-true (tn)
+ (let ((result (let ((count 0))
+ (map (lambda (ignored)
+ (set! count (+ count 1))
+ count)
+ '(a b)))))
+ (or (equal? result '(1 2))
+ (equal? result '(2 1)))))
+(assert-equal? (tn)
+ '(4 1 5 1)
+ (map + '(3 1 4 1) (circular-list 1 0)))
+
;; for-each
;; append-map
@@ -1344,7 +1662,39 @@
(append-map! (lambda (x) (list x (- x))) '(1 3 8)))
;; map!
+
;; map-in-order
+(tn "map-in-order")
+;; derived from SRFI-1 example of map
+(assert-equal? (tn)
+ '()
+ (let ((count 0))
+ (map-in-order (lambda (ignored)
+ (set! count (+ count 1))
+ count)
+ '())))
+(assert-equal? (tn)
+ '(1 2)
+ (let ((count 0))
+ (map-in-order (lambda (ignored)
+ (set! count (+ count 1))
+ count)
+ '(a b))))
+(assert-equal? (tn)
+ '(1 2 3)
+ (let ((count 0))
+ (map-in-order (lambda (ignored)
+ (set! count (+ count 1))
+ count)
+ '(a b c))))
+(assert-equal? (tn)
+ '(1 2 3 4)
+ (let ((count 0))
+ (map-in-order (lambda (ignored)
+ (set! count (+ count 1))
+ count)
+ '(a b c d))))
+
;; pair-for-each
;; filter-map
