suzanne.soy/racket
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

Converted tests to SchemeUnit 3, fixed tests. Added tests from Schematics that were mentioned in the main test suite but were actually missing from the repository. Note: Tests for SRFIs 40 and 43 are mentioned in the test suite but the actual test cases are missing

Browse Source 
svn: r3300
This commit is contained in:
Noel Welsh 2006-06-09 15:42:45 +00:00
parent cc4f2270b7
commit 173e1e2ec3
19 changed files with 1463 additions and 867 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

142
collects/tests/srfi/1/alist-test.ss
View File

@ -34,32 +34,32 @@
(module alist-test mzscheme (module alist-test mzscheme
(require (planet "test.ss" ("schematics" "schemeunit.plt" 1 1)) (require (planet "test.ss" ("schematics" "schemeunit.plt" 2))
(all-except (lib "alist.ss" "srfi" "1") assoc) (all-except (lib "alist.ss" "srfi" "1") assoc)
(rename (lib "alist.ss" "srfi" "1") s:assoc assoc)) (rename (lib "alist.ss" "srfi" "1") s:assoc assoc))
(provide alist-tests) (provide alist-tests)
(define alist-tests (define alist-tests
(make-test-suite (test-suite
"Association list tests" "Association list tests"
;; ALIST-CONS ;; ALIST-CONS
(make-test-case (test-case
"alist-cons:null-list" "alist-cons:null-list"
(assert-equal? (alist-cons 'Manawa 'Manchester '()) (check-equal? (alist-cons 'Manawa 'Manchester '())
'((Manawa . Manchester)))) '((Manawa . Manchester))))
(make-test-case (test-case
"alist-cons:singleton-list" "alist-cons:singleton-list"
(let* ((base '((Manilla . Manly))) (let* ((base '((Manilla . Manly)))
(result (alist-cons 'Manning 'Manson base))) (result (alist-cons 'Manning 'Manson base)))
(assert-equal? result '((Manning . Manson) (check-equal? result '((Manning . Manson)
(Manilla . Manly))) (Manilla . Manly)))
(assert-eq? (cdr result) base))) (check-eq? (cdr result) base)))
(make-test-case (test-case
"alist-cons:longer-list" "alist-cons:longer-list"
(let* ((base '((Manteno . Mapleside) (let* ((base '((Manteno . Mapleside)
(Mapleton . Maquoketa) (Mapleton . Maquoketa)
@ -67,16 +67,16 @@
(Marengo . Marietta) (Marengo . Marietta)
(Marion . Mark))) (Marion . Mark)))
(result (alist-cons 'Marne 'Marquette base))) (result (alist-cons 'Marne 'Marquette base)))
(assert-equal? result (check-equal? result
'((Marne . Marquette) '((Marne . Marquette)
(Manteno . Mapleside) (Manteno . Mapleside)
(Mapleton . Maquoketa) (Mapleton . Maquoketa)
(Marathon . Marcus) (Marathon . Marcus)
(Marengo . Marietta) (Marengo . Marietta)
(Marion . Mark))) (Marion . Mark)))
(assert-eq? (cdr result) base))) (check-eq? (cdr result) base)))
(make-test-case (test-case
"alist-cons:longer-list-with-duplicate-key" "alist-cons:longer-list-with-duplicate-key"
(let* ((base '((Marquisville . Marsh) (let* ((base '((Marquisville . Marsh)
(Marshalltown . Martelle) (Marshalltown . Martelle)
@ -86,7 +86,7 @@
(Massey . Massilon) (Massey . Massilon)
(Matlock . Maud))) (Matlock . Maud)))
(result (alist-cons 'Masonville 'Maurice base))) (result (alist-cons 'Masonville 'Maurice base)))
(assert-equal? result '((Masonville . Maurice) (check-equal? result '((Masonville . Maurice)
(Marquisville . Marsh) (Marquisville . Marsh)
(Marshalltown . Martelle) (Marshalltown . Martelle)
(Martensdale . Martinsburg) (Martensdale . Martinsburg)
@ -94,15 +94,15 @@
(Masonville . Massena) (Masonville . Massena)
(Massey . Massilon) (Massey . Massilon)
(Matlock . Maud))) (Matlock . Maud)))
(assert-eq? (cdr result) base))) (check-eq? (cdr result) base)))
;; ALIST-COPY ;; ALIST-COPY
(make-test-case (test-case
"alist-copy:null-list" "alist-copy:null-list"
(assert-true (null? (alist-copy '())))) (check-true (null? (alist-copy '()))))
(make-test-case (test-case
"alist-copy:flat-list" "alist-copy:flat-list"
(let* ((original '((Maxon . Maxwell) (let* ((original '((Maxon . Maxwell)
(Maynard . Maysville) (Maynard . Maysville)
@ -110,7 +110,7 @@
(McClelland . McGregor) (McClelland . McGregor)
(McIntire . McNally))) (McIntire . McNally)))
(result (alist-copy original))) (result (alist-copy original)))
(assert-true (check-true
(and (equal? result original) (and (equal? result original)
(not (eq? result original)) (not (eq? result original))
(not (eq? (car result) (car original))) (not (eq? (car result) (car original)))
@ -124,7 +124,7 @@
(not (eq? (car (cddddr result)) (not (eq? (car (cddddr result))
(car (cddddr original)))))))) (car (cddddr original))))))))
(make-test-case (test-case
"alist-copy:bush" "alist-copy:bush"
(let* ((first '(McPaul)) (let* ((first '(McPaul))
(second '(McPherson (second '(McPherson
@ -137,7 +137,7 @@
(cons 'Melvin second) (cons 'Melvin second)
(cons 'Menlo third))) (cons 'Menlo third)))
(result (alist-copy original))) (result (alist-copy original)))
(assert-true (check-true
(and (equal? result original) (and (equal? result original)
(not (eq? result original)) (not (eq? result original))
(not (eq? (car result) (car original))) (not (eq? (car result) (car original)))
@ -151,20 +151,20 @@
;; ALIST-DELETE ;; ALIST-DELETE
(make-test-case (test-case
"alist-delete:null-list" "alist-delete:null-list"
(assert-true (null? (alist-delete 'Mercer '() (lambda (x y) #t))))) (check-true (null? (alist-delete 'Mercer '() (lambda (x y) #t)))))
(make-test-case (test-case
"alist-delete:singleton-list" "alist-delete:singleton-list"
(assert-equal? (check-equal?
(alist-delete 'Meriden (alist-delete 'Meriden
'((Merrill . Merrimac))) '((Merrill . Merrimac)))
'((Merrill . Merrimac)))) '((Merrill . Merrimac))))
(make-test-case (test-case
"alist-delete:all-elements-removed" "alist-delete:all-elements-removed"
(assert-true (check-true
(null? (alist-delete 'Meservey (null? (alist-delete 'Meservey
'((Metz . Meyer) '((Metz . Meyer)
(Middleburg . Middletwon) (Middleburg . Middletwon)
@ -173,9 +173,9 @@
(Miller . Millersburg)) (Miller . Millersburg))
(lambda (x y) #t))))) (lambda (x y) #t)))))
(make-test-case (test-case
"alist-delete:some-elements-removed" "alist-delete:some-elements-removed"
(assert-equal? (check-equal?
(alist-delete 561 (alist-delete 561
'((562 . 563) '((562 . 563)
(565 . 564) (565 . 564)
@ -185,9 +185,9 @@
(lambda (x y) (odd? (+ x y)))) (lambda (x y) (odd? (+ x y))))
'((565 . 564) (569 . 568)))) '((565 . 564) (569 . 568))))
(make-test-case (test-case
"alist-delete:no-elements-removed" "alist-delete:no-elements-removed"
(assert-equal? (check-equal?
(alist-delete 'Millerton (alist-delete 'Millerton
'((Millman . Millnerville) '((Millman . Millnerville)
(Millville . Milo) (Millville . Milo)
@ -203,20 +203,20 @@
;; ALIST-DELETE! ;; ALIST-DELETE!
(make-test-case (test-case
"alist-delete!:null-list" "alist-delete!:null-list"
(assert-true (null? (alist-delete! 'Mitchell '() (lambda (x y) #t))))) (check-true (null? (alist-delete! 'Mitchell '() (lambda (x y) #t)))))
(make-test-case (test-case
"alist-delete!:singleton-list" "alist-delete!:singleton-list"
(assert-equal? (check-equal?
(alist-delete! 'Mitchellville (alist-delete! 'Mitchellville
(list (cons 'Modale 'Moingona))) (list (cons 'Modale 'Moingona)))
'((Modale . Moingona)))) '((Modale . Moingona))))
(make-test-case (test-case
"alist-delete!:all-elements-removed" "alist-delete!:all-elements-removed"
(assert-true (check-true
(null? (null?
(alist-delete! 'Mona (alist-delete! 'Mona
(list (cons 'Mondamin 'Moneta) (list (cons 'Mondamin 'Moneta)
@ -226,9 +226,9 @@
(cons 'Montezuma 'Montgomery)) (cons 'Montezuma 'Montgomery))
(lambda (x y) #t))))) (lambda (x y) #t)))))
(make-test-case (test-case
"alist-delete!:some-elements-removed" "alist-delete!:some-elements-removed"
(assert-equal? (check-equal?
(alist-delete! 572 (alist-delete! 572
(list (cons 573 574) (list (cons 573 574)
(cons 576 575) (cons 576 575)
@ -238,9 +238,9 @@
(lambda (x y) (even? (+ x y)))) (lambda (x y) (even? (+ x y))))
'((573 . 574) (577 . 578) (581 . 582)))) '((573 . 574) (577 . 578) (581 . 582))))
(make-test-case (test-case
"alist-delete!:no-elements-removed" "alist-delete!:no-elements-removed"
(assert-equal? (check-equal?
(alist-delete! 'Monti (alist-delete! 'Monti
(list (cons 'Monticello 'Montour) (list (cons 'Monticello 'Montour)
(cons 'Montpelier 'Montrose) (cons 'Montpelier 'Montrose)
@ -255,26 +255,26 @@
;; ALIST-DELETE ;; ALIST-DELETE
(make-test-case (test-case
"alist-delete:null-list" "alist-delete:null-list"
(assert-true (null? (alist-delete '(Reasnor . Redding) '())))) (check-true (null? (alist-delete '(Reasnor . Redding) '()))))
(make-test-case (test-case
"alist-delete:in-singleton-list" "alist-delete:in-singleton-list"
(assert-true (null? (check-true (null?
(alist-delete '(Redfield . Reeceville) (alist-delete '(Redfield . Reeceville)
'(((Redfield . Reeceville) . Reinbeck)))))) '(((Redfield . Reeceville) . Reinbeck))))))
(make-test-case (test-case
"alist-delete:not-in-singleton-list" "alist-delete:not-in-singleton-list"
(assert-equal? (check-equal?
(alist-delete '(Rembrandt . Remsen) (alist-delete '(Rembrandt . Remsen)
'(((Renwick . Republic) . Rhodes))) '(((Renwick . Republic) . Rhodes)))
'(((Renwick . Republic) . Rhodes)))) '(((Renwick . Republic) . Rhodes))))
(make-test-case (test-case
"alist-delete:at-beginning-of-longer-list" "alist-delete:at-beginning-of-longer-list"
(assert-equal? (check-equal?
(alist-delete '(Riceville . Richard) (alist-delete '(Riceville . Richard)
'(((Riceville . Richard) . Richfield) '(((Riceville . Richard) . Richfield)
((Richland . Richmond) . Rickardsville) ((Richland . Richmond) . Rickardsville)
@ -286,9 +286,9 @@
((Ridgeway . Riggs) . Rinard) ((Ridgeway . Riggs) . Rinard)
((Ringgold . Ringsted) . Rippey)))) ((Ringgold . Ringsted) . Rippey))))
(make-test-case (test-case
"alist-delete:in-middle-of-longer-list" "alist-delete:in-middle-of-longer-list"
(assert-equal? (check-equal?
(alist-delete '(Ritter . Riverdale) (alist-delete '(Ritter . Riverdale)
'(((Riverside . Riverton) . Roberts) '(((Riverside . Riverton) . Roberts)
((Robertson . Robins) . Robinson) ((Robertson . Robins) . Robinson)
@ -304,9 +304,9 @@
((Roelyn . Rogers) . Roland) ((Roelyn . Rogers) . Roland)
((Rolfe . Rome) . Roscoe)))) ((Rolfe . Rome) . Roscoe))))
(make-test-case (test-case
"alist-delete:at-end-of-longer-list" "alist-delete:at-end-of-longer-list"
(assert-equal? (check-equal?
(alist-delete '(Rose . Roselle) (alist-delete '(Rose . Roselle)
'(((Roseville . Ross) . Rosserdale) '(((Roseville . Ross) . Rosserdale)
((Rossie . Rossville) . Rowan) ((Rossie . Rossville) . Rowan)
@ -318,9 +318,9 @@
((Rowley . Royal) . Rubio) ((Rowley . Royal) . Rubio)
((Ruble . Rudd) . Runnells)))) ((Ruble . Rudd) . Runnells))))
(make-test-case (test-case
"alist-delete:not-in-longer-list" "alist-delete:not-in-longer-list"
(assert-equal? (check-equal?
(alist-delete '(Ruthven . Rutland) (alist-delete '(Ruthven . Rutland)
'(((Rutledge . Ryan) . Sabula) '(((Rutledge . Ryan) . Sabula)
((Sageville . Salem) . Salina) ((Sageville . Salem) . Salina)
@ -333,9 +333,9 @@
((Sandyville . Santiago) . Saratoga) ((Sandyville . Santiago) . Saratoga)
((Sattre . Saude) . Savannah)))) ((Sattre . Saude) . Savannah))))
(make-test-case (test-case
"alist-delete:several-matches-in-longer-list" "alist-delete:several-matches-in-longer-list"
(assert-equal? (check-equal?
(alist-delete '(Sawyer . Saylor) (alist-delete '(Sawyer . Saylor)
'(((Saylorville . Scarville) . Schaller) '(((Saylorville . Scarville) . Schaller)
((Schleswig . Schley) . Sciola) ((Schleswig . Schley) . Sciola)
@ -351,28 +351,28 @@
;; ALIST-DELETE! ;; ALIST-DELETE!
(make-test-case (test-case
"alist-delete!:null-list" "alist-delete!:null-list"
(assert-true (null? (alist-delete! (cons 'Unionville 'Unique) (list))))) (check-true (null? (alist-delete! (cons 'Unionville 'Unique) (list)))))
(make-test-case (test-case
"alist-delete!:in-singleton-list" "alist-delete!:in-singleton-list"
(assert-true (check-true
(null? (null?
(alist-delete! (cons 'Updegraff 'Urbana) (alist-delete! (cons 'Updegraff 'Urbana)
(list (cons (cons 'Updegraff 'Urbana) (list (cons (cons 'Updegraff 'Urbana)
'Summitville)))))) 'Summitville))))))
(make-test-case (test-case
"alist-delete!:not-in-singleton-list" "alist-delete!:not-in-singleton-list"
(assert-equal? (check-equal?
(alist-delete! (cons 'Urbandale 'Ute) (alist-delete! (cons 'Urbandale 'Ute)
(list (cons (cons 'Utica 'Vail) 'Valeria))) (list (cons (cons 'Utica 'Vail) 'Valeria)))
'(((Utica . Vail) . Valeria)))) '(((Utica . Vail) . Valeria))))
(make-test-case (test-case
"alist-delete!:at-beginning-of-longer-list" "alist-delete!:at-beginning-of-longer-list"
(assert-equal? (check-equal?
(alist-delete! (cons 'Valley 'Vandalia) (alist-delete! (cons 'Valley 'Vandalia)
(list (cons (cons 'Valley 'Vandalia) 'Varina) (list (cons (cons 'Valley 'Vandalia) 'Varina)
(cons (cons 'Ventura 'Vernon) 'Victor) (cons (cons 'Ventura 'Vernon) 'Victor)
@ -384,9 +384,9 @@
((Vincent . Vining) . Vinje) ((Vincent . Vining) . Vinje)
((Vinton . Viola) . Volga)))) ((Vinton . Viola) . Volga))))
(make-test-case (test-case
"alist-delete!:in-middle-of-longer-list" "alist-delete!:in-middle-of-longer-list"
(assert-equal? (check-equal?
(alist-delete! (cons 'Volney 'Voorhies) (alist-delete! (cons 'Volney 'Voorhies)
(list (cons (cons 'Wadena 'Wahpeton) 'Walcott) (list (cons (cons 'Wadena 'Wahpeton) 'Walcott)
(cons (cons 'Wald 'Wales) 'Walford) (cons (cons 'Wald 'Wales) 'Walford)
@ -403,9 +403,9 @@
((Washburn . Washington) . Washta) ((Washburn . Washington) . Washta)
((Waterloo . Waterville) . Watkins)))) ((Waterloo . Waterville) . Watkins))))
(make-test-case (test-case
"alist-delete!:at-end-of-longer-list" "alist-delete!:at-end-of-longer-list"
(assert-equal? (check-equal?
(alist-delete! (cons 'Watson 'Watterson) (alist-delete! (cons 'Watson 'Watterson)
(list (cons (cons 'Waubeek 'Waucoma) 'Waukee) (list (cons (cons 'Waubeek 'Waucoma) 'Waukee)
(cons (cons 'Waukon 'Waupeton) 'Waverly) (cons (cons 'Waukon 'Waupeton) 'Waverly)
@ -417,9 +417,9 @@
((Wayland . Webb) . Webster) ((Wayland . Webb) . Webster)
((Weldon . Weller) . Wellman)))) ((Weldon . Weller) . Wellman))))
(make-test-case (test-case
"alist-delete!:not-in-longer-list" "alist-delete!:not-in-longer-list"
(assert-equal? (check-equal?
(alist-delete! (cons 'Welton 'Wesley) (alist-delete! (cons 'Welton 'Wesley)
(list (cons (cons 'Western 'Westerville) (list (cons (cons 'Western 'Westerville)
'Westfield) 'Westfield)
@ -434,9 +434,9 @@
((Wheatland . Whiting) . Whittemore) ((Wheatland . Whiting) . Whittemore)
((Whitten . Whittier) . Wichita)))) ((Whitten . Whittier) . Wichita))))
(make-test-case (test-case
"alist-delete!:several-matches-in-longer-list" "alist-delete!:several-matches-in-longer-list"
(assert-equal? (check-equal?
(alist-delete! (cons 'Wick 'Wightman) (alist-delete! (cons 'Wick 'Wightman)
(list (cons (cons 'Wilke 'Willey) 'Williams) (list (cons (cons 'Wilke 'Willey) 'Williams)
(cons (cons 'Williamsburg 'Williamson) (cons (cons 'Williamsburg 'Williamson)

4
collects/tests/srfi/1/all-1-tests.ss
View File

@ -1,6 +1,6 @@
(module all-1-tests mzscheme (module all-1-tests mzscheme
(require (planet "test.ss" ("schematics" "schemeunit.plt" 1 1))) (require (planet "test.ss" ("schematics" "schemeunit.plt" 2)))
(require "alist-test.ss" (require "alist-test.ss"
"cons-test.ss" "cons-test.ss"
"delete-test.ss" "delete-test.ss"
@ -15,7 +15,7 @@
(provide all-1-tests) (provide all-1-tests)
(define all-1-tests (define all-1-tests
(make-test-suite (test-suite
"all-1-tests" "all-1-tests"
alist-tests alist-tests
cons-tests cons-tests

138
collects/tests/srfi/1/cons-test.ss
View File

@ -35,62 +35,62 @@
(module cons-test (module cons-test
mzscheme mzscheme
(require (planet "test.ss" ("schematics" "schemeunit.plt" 1 1)) (require (planet "test.ss" ("schematics" "schemeunit.plt" 2))
(lib "cons.ss" "srfi" "1")) (lib "cons.ss" "srfi" "1"))
(provide cons-tests) (provide cons-tests)
(define cons-tests (define cons-tests
(make-test-suite (test-suite
"List constructor tests" "List constructor tests"
;; XCONS ;; XCONS
(make-test-case (test-case
"xcons:null-cdr" "xcons:null-cdr"
(assert-equal? (xcons '() 'Andromeda) '(Andromeda))) (check-equal? (xcons '() 'Andromeda) '(Andromeda)))
(make-test-case (test-case
"xcons:pair-cdr" "xcons:pair-cdr"
(let* ((base '(Antlia)) (let* ((base '(Antlia))
(result (xcons base 'Apus))) (result (xcons base 'Apus)))
(assert-equal? result '(Apus Antlia)) (check-equal? result '(Apus Antlia))
(assert-eq? (cdr result) base))) (check-eq? (cdr result) base)))
(make-test-case (test-case
"xcons:datum-cdr" "xcons:datum-cdr"
(assert-equal? (xcons 'Aquarius 'Aquila) '(Aquila . Aquarius))) (check-equal? (xcons 'Aquarius 'Aquila) '(Aquila . Aquarius)))
;; MAKE-LIST ;; MAKE-LIST
(make-test-case (test-case
"make-list:zero-length" "make-list:zero-length"
(assert-true (null? (make-list 0)))) (check-true (null? (make-list 0))))
(make-test-case (test-case
"make-list:default-element" "make-list:default-element"
(assert-equal? (make-list 5) '(#f #f #f #f #f))) (check-equal? (make-list 5) '(#f #f #f #f #f)))
(make-test-case (test-case
"make-list:fill-element" "make-list:fill-element"
(assert-equal? (make-list 7 'Circinus) (check-equal? (make-list 7 'Circinus)
'(Circinus Circinus Circinus Circinus '(Circinus Circinus Circinus Circinus
Circinus Circinus Circinus))) Circinus Circinus Circinus)))
;; LIST-TABULATE ;; LIST-TABULATE
(make-test-case (test-case
"list-tabulate:zero-length" "list-tabulate:zero-length"
(assert-true (null? (list-tabulate 0 (lambda (position) #f))))) (check-true (null? (list-tabulate 0 (lambda (position) #f)))))
(make-test-case (test-case
"list-tabulate:identity" "list-tabulate:identity"
(assert-equal? (list-tabulate 5 (lambda (position) position)) (check-equal? (list-tabulate 5 (lambda (position) position))
'(0 1 2 3 4))) '(0 1 2 3 4)))
(make-test-case (test-case
"list-tabulate:factorial" "list-tabulate:factorial"
(assert-equal? (list-tabulate 7 (lambda (position) (check-equal? (list-tabulate 7 (lambda (position)
(do ((multiplier 1 (+ multiplier 1)) (do ((multiplier 1 (+ multiplier 1))
(product 1 (* product multiplier))) (product 1 (* product multiplier)))
((< position multiplier) product)))) ((< position multiplier) product))))
@ -98,52 +98,52 @@
;; LIST* ;; LIST*
(make-test-case (test-case
"list*:one-argument" "list*:one-argument"
(assert-eq? (list* 'Columba) (check-eq? (list* 'Columba)
'Columba)) 'Columba))
(make-test-case (test-case
"list*:two-arguments" "list*:two-arguments"
(assert-equal? (list* 'Corvus 'Crater) (check-equal? (list* 'Corvus 'Crater)
'(Corvus . Crater))) '(Corvus . Crater)))
(make-test-case (test-case
"list*:many-arguments" "list*:many-arguments"
(assert-equal? (list* 'Crux 'Cygnus 'Delphinus 'Dorado 'Draco) (check-equal? (list* 'Crux 'Cygnus 'Delphinus 'Dorado 'Draco)
'(Crux Cygnus Delphinus Dorado . Draco))) '(Crux Cygnus Delphinus Dorado . Draco)))
(make-test-case (test-case
"list*:last-argument-null" "list*:last-argument-null"
(assert-equal? (list* 'Equuleus 'Fornax '()) (check-equal? (list* 'Equuleus 'Fornax '())
'(Equuleus Fornax))) '(Equuleus Fornax)))
(make-test-case (test-case
"list*:last-argument-non-empty-list" "list*:last-argument-non-empty-list"
(let* ((base '(Gemini Grus)) (let* ((base '(Gemini Grus))
(result (list* 'Hercules 'Horologium 'Hydra 'Hydrus base))) (result (list* 'Hercules 'Horologium 'Hydra 'Hydrus base)))
(assert-equal? result (check-equal? result
'(Hercules Horologium Hydra Hydrus Gemini Grus)) '(Hercules Horologium Hydra Hydrus Gemini Grus))
(assert-eq? (cddddr result) base))) (check-eq? (cddddr result) base)))
;; LIST-COPY ;; LIST-COPY
(make-test-case (test-case
"list-copy:null-list" "list-copy:null-list"
(assert-true (null? (list-copy '())))) (check-true (null? (list-copy '()))))
(make-test-case (test-case
"list-copy:flat-list" "list-copy:flat-list"
(let* ((original '(Indus Lacerta Leo Lepus Libra)) (let* ((original '(Indus Lacerta Leo Lepus Libra))
(result (list-copy original))) (result (list-copy original)))
(assert-equal? result original) (check-equal? result original)
(assert-true (not (eq? result original))) (check-true (not (eq? result original)))
(assert-true (not (eq? (cdr result) (cdr original)))) (check-true (not (eq? (cdr result) (cdr original))))
(assert-true (not (eq? (cddr result) (cddr original)))) (check-true (not (eq? (cddr result) (cddr original))))
(assert-true (not (eq? (cdddr result) (cdddr original)))) (check-true (not (eq? (cdddr result) (cdddr original))))
(assert-true (not (eq? (cddddr result) (cddddr original)))))) (check-true (not (eq? (cddddr result) (cddddr original))))))
(make-test-case (test-case
"list-copy:bush" "list-copy:bush"
(let* ((first '(Lupus)) (let* ((first '(Lupus))
(second '(Lynx Malus Mensa (Microscopium Monoceros) (second '(Lynx Malus Mensa (Microscopium Monoceros)
@ -151,27 +151,27 @@
(third 'Ophiuchus) (third 'Ophiuchus)
(original (list first second third)) (original (list first second third))
(result (list-copy original))) (result (list-copy original)))
(assert-equal? result original) (check-equal? result original)
(assert-true (not (eq? result original))) (check-true (not (eq? result original)))
(assert-eq? (car result) first) (check-eq? (car result) first)
(assert-true (not (eq? (cdr result) (cdr original)))) (check-true (not (eq? (cdr result) (cdr original))))
(assert-eq? (cadr result) second) (check-eq? (cadr result) second)
(assert-true (not (eq? (cddr result) (cddr original)))) (check-true (not (eq? (cddr result) (cddr original))))
(assert-eq? (caddr result) third))) (check-eq? (caddr result) third)))
;; CIRCULAR-LIST ;; CIRCULAR-LIST
(make-test-case (test-case
"circular-list:one-element" "circular-list:one-element"
(let ((result (circular-list 'Orion))) (let ((result (circular-list 'Orion)))
(assert-true (and (pair? result) (check-true (and (pair? result)
(eq? (car result) 'Orion) (eq? (car result) 'Orion)
(eq? (cdr result) result))))) (eq? (cdr result) result)))))
(make-test-case (test-case
"circular-list:many-elements" "circular-list:many-elements"
(let ((result (circular-list 'Pavo 'Pegasus 'Perseus 'Phoenix 'Pictor))) (let ((result (circular-list 'Pavo 'Pegasus 'Perseus 'Phoenix 'Pictor)))
(assert-true (and (pair? result) (check-true (and (pair? result)
(eq? (car result) 'Pavo) (eq? (car result) 'Pavo)
(pair? (cdr result)) (pair? (cdr result))
(eq? (cadr result) 'Pegasus) (eq? (cadr result) 'Pegasus)
@ -185,37 +185,37 @@
;; IOTA ;; IOTA
(make-test-case (test-case
"iota:zero-count" "iota:zero-count"
(assert-equal? (iota 0) (list))) (check-equal? (iota 0) (list)))
(make-test-case (test-case
"iota:zero-count-and-step" "iota:zero-count-and-step"
(assert-equal? (iota 0 0) (list))) (check-equal? (iota 0 0) (list)))
(make-test-case (test-case
"iota:count-only" "iota:count-only"
(assert-equal? (iota 4) (list 0 1 2 3))) (check-equal? (iota 4) (list 0 1 2 3)))
(make-test-case (test-case
"iota:count-and-start" "iota:count-and-start"
(assert-equal? (iota 3 1) (list 1 2 3))) (check-equal? (iota 3 1) (list 1 2 3)))
(make-test-case (test-case
"iota:count-start-and-step" "iota:count-start-and-step"
(assert-equal? (iota 4 3 2) (list 3 5 7 9))) (check-equal? (iota 4 3 2) (list 3 5 7 9)))
(make-test-case (test-case
"iota:negative-step" "iota:negative-step"
(assert-equal? (iota 4 0 -1) (list 0 -1 -2 -3))) (check-equal? (iota 4 0 -1) (list 0 -1 -2 -3)))
(make-test-case (test-case
"iota:non-integer-step" "iota:non-integer-step"
(assert-equal? (iota 5 0 1/2) (list 0 1/2 1 3/2 2))) (check-equal? (iota 5 0 1/2) (list 0 1/2 1 3/2 2)))
(make-test-case (test-case
"iota;negative-count" "iota;negative-count"
(assert-equal? (iota -1) (list))) (check-equal? (iota -1) (list)))
)) ))
) )

116
collects/tests/srfi/1/delete-test.ss
View File

@ -35,38 +35,38 @@
(module delete-test (module delete-test
mzscheme mzscheme
(require (planet "test.ss" ("schematics" "schemeunit.plt" 1 1)) (require (planet "test.ss" ("schematics" "schemeunit.plt" 2))
(all-except (lib "delete.ss" "srfi" "1") member)) (all-except (lib "delete.ss" "srfi" "1") member))
(provide delete-tests) (provide delete-tests)
(define delete-tests (define delete-tests
(make-test-suite (test-suite
"List deletion tests" "List deletion tests"
;; DELETE ;; DELETE
(make-test-case (test-case
"delete:null-list" "delete:null-list"
(assert-true (check-true
(null? (delete '(Fraser . Frederic) '())))) (null? (delete '(Fraser . Frederic) '()))))
(make-test-case (test-case
"delete:in-singleton-list" "delete:in-singleton-list"
(assert-true (check-true
(null? (null?
(delete '(Fredericksburg . Frederika) (delete '(Fredericksburg . Frederika)
'((Fredericksburg . Frederika)))))) '((Fredericksburg . Frederika))))))
(make-test-case (test-case
"delete:not-in-singleton-list" "delete:not-in-singleton-list"
(assert-equal? (check-equal?
(delete '(Fredonia . Fredsville) '((Freeman . Freeport))) (delete '(Fredonia . Fredsville) '((Freeman . Freeport)))
'((Freeman . Freeport)))) '((Freeman . Freeport))))
(make-test-case (test-case
"delete:at-beginning-of-longer-list" "delete:at-beginning-of-longer-list"
(assert-equal? (check-equal?
(delete '(Fremont . Froelich) '((Fremont . Froelich) (delete '(Fremont . Froelich) '((Fremont . Froelich)
(Fruitland . Fulton) (Fruitland . Fulton)
(Furay . Galbraith) (Furay . Galbraith)
@ -77,9 +77,9 @@
(Galesburg . Galland) (Galesburg . Galland)
(Galt . Galva)))) (Galt . Galva))))
(make-test-case (test-case
"delete:in-middle-of-longer-list" "delete:in-middle-of-longer-list"
(assert-equal? (check-equal?
(delete '(Gambrill . Garber) '((Gardiner . Gardner) (delete '(Gambrill . Garber) '((Gardiner . Gardner)
(Garfield . Garland) (Garfield . Garland)
(Garnavillo . Garner) (Garnavillo . Garner)
@ -94,9 +94,9 @@
(Gaza . Geneva) (Gaza . Geneva)
(Genoa . George)))) (Genoa . George))))
(make-test-case (test-case
"delete:at-end-of-longer-list" "delete:at-end-of-longer-list"
(assert-equal? (check-equal?
(delete '(Georgetown . Gerled) '((Germantown . Germanville) (delete '(Georgetown . Gerled) '((Germantown . Germanville)
(Giard . Gibbsville) (Giard . Gibbsville)
(Gibson . Gifford) (Gibson . Gifford)
@ -107,9 +107,9 @@
(Gibson . Gifford) (Gibson . Gifford)
(Gilbert . Gilbertville)))) (Gilbert . Gilbertville))))
(make-test-case (test-case
"delete:not-in-longer-list" "delete:not-in-longer-list"
(assert-equal? (check-equal?
(delete '(Gilliatt . Gilman) '((Givin . Gladbrook) (delete '(Gilliatt . Gilman) '((Givin . Gladbrook)
(Gladstone . Gladwin) (Gladstone . Gladwin)
(Glasgow . Glendon) (Glasgow . Glendon)
@ -121,9 +121,9 @@
(Glenwood . Glidden) (Glenwood . Glidden)
(Goddard . Goldfield)))) (Goddard . Goldfield))))
(make-test-case (test-case
"delete:several-matches-in-longer-list" "delete:several-matches-in-longer-list"
(assert-equal? (check-equal?
(delete '(Goodell . Gosport) '((Gowrie . Goddard) (delete '(Goodell . Gosport) '((Gowrie . Goddard)
(Grable . Graettinger) (Grable . Graettinger)
(Goodell . Gosport) (Goodell . Gosport)
@ -138,27 +138,27 @@
;; DELETE! ;; DELETE!
(make-test-case (test-case
"delete!:null-list" "delete!:null-list"
(assert-true (null? (delete! (cons 'Henshaw 'Hentons) (list))))) (check-true (null? (delete! (cons 'Henshaw 'Hentons) (list)))))
(make-test-case (test-case
"delete!:in-singleton-list" "delete!:in-singleton-list"
(assert-true (check-true
(null? (null?
(delete! (cons 'Hepburn 'Herndon) (delete! (cons 'Hepburn 'Herndon)
(list (cons 'Hepburn 'Herndon)))))) (list (cons 'Hepburn 'Herndon))))))
(make-test-case (test-case
"delete!:not-in-singleton-list" "delete!:not-in-singleton-list"
(assert-equal? (check-equal?
(delete! (cons 'Hesper 'Hiattsville) (delete! (cons 'Hesper 'Hiattsville)
(list (cons 'Hiawatha 'Hicks))) (list (cons 'Hiawatha 'Hicks)))
'((Hiawatha . Hicks)))) '((Hiawatha . Hicks))))
(make-test-case (test-case
"delete!:at-beginning-of-longer-list" "delete!:at-beginning-of-longer-list"
(assert-equal? (check-equal?
(delete! (cons 'Highland 'Highlandville) (delete! (cons 'Highland 'Highlandville)
(list (cons 'Highland 'Highlandville) (list (cons 'Highland 'Highlandville)
(cons 'Highview 'Hills) (cons 'Highview 'Hills)
@ -170,9 +170,9 @@
(Hilltop . Hinton) (Hilltop . Hinton)
(Hiteman . Hobarton)))) (Hiteman . Hobarton))))
(make-test-case (test-case
"delete!:in-middle-of-longer-list" "delete!:in-middle-of-longer-list"
(assert-equal? (check-equal?
(delete! (cons 'Hocking 'Holbrook) (delete! (cons 'Hocking 'Holbrook)
(list (cons 'Holland 'Holmes) (list (cons 'Holland 'Holmes)
(cons 'Holstein 'Homer) (cons 'Holstein 'Homer)
@ -188,9 +188,9 @@
(Horton . Hospers) (Horton . Hospers)
(Houghton . Howardville)))) (Houghton . Howardville))))
(make-test-case (test-case
"delete!:at-end-of-longer-list" "delete!:at-end-of-longer-list"
(assert-equal? (check-equal?
(delete! (cons 'Howe 'Hubbard) (delete! (cons 'Howe 'Hubbard)
(list (cons 'Hudson 'Hugo) (list (cons 'Hudson 'Hugo)
(cons 'Hull 'Humboldt) (cons 'Hull 'Humboldt)
@ -202,9 +202,9 @@
(Humeston . Huntington) (Humeston . Huntington)
(Hurley . Huron)))) (Hurley . Huron))))
(make-test-case (test-case
"delete!:not-in-longer-list" "delete!:not-in-longer-list"
(assert-equal? (check-equal?
(delete! (cons 'Hurstville 'Hutchins) (delete! (cons 'Hurstville 'Hutchins)
(list (cons 'Huxley 'Iconium) (list (cons 'Huxley 'Iconium)
(cons 'Illyria 'Imogene) (cons 'Illyria 'Imogene)
@ -217,9 +217,9 @@
(Indianola . Industry) (Indianola . Industry)
(Inwood . Ion)))) (Inwood . Ion))))
(make-test-case (test-case
"delete!:several-matches-in-longer-list" "delete!:several-matches-in-longer-list"
(assert-equal? (check-equal?
(delete! (cons 'Ionia 'Ira) (delete! (cons 'Ionia 'Ira)
(list (cons 'Ireton 'Ironhills) (list (cons 'Ireton 'Ironhills)
(cons 'Irving 'Irvington) (cons 'Irving 'Irvington)
@ -235,25 +235,25 @@
;; DELETE-DUPLICATES ;; DELETE-DUPLICATES
(make-test-case (test-case
"delete-duplicates:null-list" "delete-duplicates:null-list"
(assert-true (null? (delete-duplicates '())))) (check-true (null? (delete-duplicates '()))))
(make-test-case (test-case
"delete-duplicates:singleton-list" "delete-duplicates:singleton-list"
(assert-equal? (check-equal?
(delete-duplicates '((Knierim . Knittel))) (delete-duplicates '((Knierim . Knittel)))
'((Knierim . Knittel)))) '((Knierim . Knittel))))
(make-test-case (test-case
"delete-duplicates:in-doubleton-list" "delete-duplicates:in-doubleton-list"
(assert-equal? (check-equal?
(delete-duplicates '((Knoke . Knowlton) (Knoke . Knowlton))) (delete-duplicates '((Knoke . Knowlton) (Knoke . Knowlton)))
'((Knoke . Knowlton)))) '((Knoke . Knowlton))))
(make-test-case (test-case
"delete-duplicates:none-removed-in-longer-list" "delete-duplicates:none-removed-in-longer-list"
(assert-equal? (check-equal?
(delete-duplicates '((Knox . Knoxville) (delete-duplicates '((Knox . Knoxville)
(Konigsmark . Kossuth) (Konigsmark . Kossuth)
(Koszta . Lacelle) (Koszta . Lacelle)
@ -265,9 +265,9 @@
(Lacey . Lacona) (Lacey . Lacona)
(Ladoga . Ladora)))) (Ladoga . Ladora))))
(make-test-case (test-case
"delete-duplicates:some-removed-in-longer-list" "delete-duplicates:some-removed-in-longer-list"
(assert-equal? (check-equal?
(delete-duplicates '((Lafayette . Lainsville) (delete-duplicates '((Lafayette . Lainsville)
(Lakeside . Lakewood) (Lakeside . Lakewood)
(Lakeside . Lakewood) (Lakeside . Lakewood)
@ -283,9 +283,9 @@
(Lamoille . Lamoni) (Lamoille . Lamoni)
(Lamont . Lancaster)))) (Lamont . Lancaster))))
(make-test-case (test-case
"delete-duplicates:all-but-one-removed-in-longer-list" "delete-duplicates:all-but-one-removed-in-longer-list"
(assert-equal? (check-equal?
(delete-duplicates '((Lanesboro . Langdon) (delete-duplicates '((Lanesboro . Langdon)
(Lanesboro . Langdon) (Lanesboro . Langdon)
(Lanesboro . Langdon) (Lanesboro . Langdon)
@ -295,26 +295,26 @@
;; DELETE-DUPLICATES! ;; DELETE-DUPLICATES!
(make-test-case (test-case
"delete-duplicates!:null-list" "delete-duplicates!:null-list"
(assert-true (null? (delete-duplicates! (list))))) (check-true (null? (delete-duplicates! (list)))))
(make-test-case (test-case
"delete-duplicates!:singleton-list" "delete-duplicates!:singleton-list"
(assert-equal? (check-equal?
(delete-duplicates! (list (cons 'Lester 'Letts))) (delete-duplicates! (list (cons 'Lester 'Letts)))
'((Lester . Letts)))) '((Lester . Letts))))
(make-test-case (test-case
"delete-duplicates!:in-doubleton-list" "delete-duplicates!:in-doubleton-list"
(assert-equal? (check-equal?
(delete-duplicates! (list (cons 'Leverette 'Levey) (delete-duplicates! (list (cons 'Leverette 'Levey)
(cons 'Leverette 'Levey))) (cons 'Leverette 'Levey)))
'((Leverette . Levey)))) '((Leverette . Levey))))
(make-test-case (test-case
"delete-duplicates!:none-removed-in-longer-list" "delete-duplicates!:none-removed-in-longer-list"
(assert-equal? (check-equal?
(delete-duplicates! (list (cons 'Lewis 'Lexington) (delete-duplicates! (list (cons 'Lewis 'Lexington)
(cons 'Liberty 'Libertyville) (cons 'Liberty 'Libertyville)
(cons 'Lidderdale 'Lima) (cons 'Lidderdale 'Lima)
@ -326,9 +326,9 @@
(Linby . Lincoln) (Linby . Lincoln)
(Linden . Lineville)))) (Linden . Lineville))))
(make-test-case (test-case
"delete-duplicates!:some-removed-in-longer-list" "delete-duplicates!:some-removed-in-longer-list"
(assert-equal? (check-equal?
(delete-duplicates! (list (cons 'Lisbon 'Liscomb) (delete-duplicates! (list (cons 'Lisbon 'Liscomb)
(cons 'Littleport 'Littleton) (cons 'Littleport 'Littleton)
(cons 'Littleport 'Littleton) (cons 'Littleport 'Littleton)
@ -344,9 +344,9 @@
(Lockman . Lockridge) (Lockman . Lockridge)
(Locust . Logan)))) (Locust . Logan))))
(make-test-case (test-case
"delete-duplicates!:all-but-one-removed-in-longer-list" "delete-duplicates!:all-but-one-removed-in-longer-list"
(assert-equal? (check-equal?
(delete-duplicates! (list (cons 'Logansport 'Lohrville) (delete-duplicates! (list (cons 'Logansport 'Lohrville)
(cons 'Logansport 'Lohrville) (cons 'Logansport 'Lohrville)
(cons 'Logansport 'Lohrville) (cons 'Logansport 'Lohrville)

130
collects/tests/srfi/1/filter-test.ss
View File

@ -35,235 +35,235 @@
(module filter-test (module filter-test
mzscheme mzscheme
(require (planet "test.ss" ("schematics" "schemeunit.plt" 1 1)) (require (planet "test.ss" ("schematics" "schemeunit.plt" 2))
(all-except (lib "filter.ss" "srfi" "1") member)) (all-except (lib "filter.ss" "srfi" "1") member))
(provide filter-tests) (provide filter-tests)
(define filter-tests (define filter-tests
(make-test-suite (test-suite
"List filtering tests" "List filtering tests"
;; FILTER ;; FILTER
(make-test-case (test-case
"filter:null-list" "filter:null-list"
(assert-true (null? (filter (lambda (x) #t) '())))) (check-true (null? (filter (lambda (x) #t) '()))))
(make-test-case (test-case
"filter:singleton-list" "filter:singleton-list"
(assert-equal? (check-equal?
(filter (lambda (x) #t) '(Agency)) (filter (lambda (x) #t) '(Agency))
'(Agency))) '(Agency)))
(make-test-case (test-case
"filter:all-elements-removed" "filter:all-elements-removed"
(assert-true (check-true
(null? (filter (lambda (x) #f) (null? (filter (lambda (x) #f)
'(Ainsworth Akron Albany Albaton Albia))))) '(Ainsworth Akron Albany Albaton Albia)))))
(make-test-case (test-case
"filter:some-elements-removed" "filter:some-elements-removed"
(assert-equal? (check-equal?
(filter even? '(86 87 88 89 90)) (filter even? '(86 87 88 89 90))
'(86 88 90))) '(86 88 90)))
(make-test-case (test-case
"filter:no-elements-removed" "filter:no-elements-removed"
(assert-equal? (check-equal?
(filter (lambda (x) #t) (filter (lambda (x) #t)
'(Albion Alburnett Alden Alexander Algona)) '(Albion Alburnett Alden Alexander Algona))
'(Albion Alburnett Alden Alexander Algona))) '(Albion Alburnett Alden Alexander Algona)))
;; FILTER! ;; FILTER!
(make-test-case (test-case
"filter!:null-list" "filter!:null-list"
(assert-true (check-true
(null? (filter! (lambda (x) #t) (list))))) (null? (filter! (lambda (x) #t) (list)))))
(make-test-case (test-case
"filter!:singleton-list" "filter!:singleton-list"
(assert-equal? (check-equal?
(filter! (lambda (x) #t) (list 'Alice)) (filter! (lambda (x) #t) (list 'Alice))
'(Alice))) '(Alice)))
(make-test-case (test-case
"filter!:all-elements-removed" "filter!:all-elements-removed"
(assert-true (check-true
(null? (filter! (lambda (x) #f) (null? (filter! (lambda (x) #f)
(list 'Alleman 'Allendorf 'Allerton 'Allison 'Almont))))) (list 'Alleman 'Allendorf 'Allerton 'Allison 'Almont)))))
(make-test-case (test-case
"filter!:some-elements-removed" "filter!:some-elements-removed"
(assert-equal? (check-equal?
(filter! even? (list 91 92 93 94 95)) (filter! even? (list 91 92 93 94 95))
'(92 94))) '(92 94)))
(make-test-case (test-case
"filter!:no-elements-removed" "filter!:no-elements-removed"
(assert-equal? (check-equal?
(filter! (lambda (x) #t) (filter! (lambda (x) #t)
(list 'Almoral 'Alpha 'Alta 'Alton 'Altoona)) (list 'Almoral 'Alpha 'Alta 'Alton 'Altoona))
'(Almoral Alpha Alta Alton Altoona))) '(Almoral Alpha Alta Alton Altoona)))
;; REMOVE ;; REMOVE
(make-test-case (test-case
"remove:null-list" "remove:null-list"
(assert-true (check-true
(null? (remove (lambda (x) #t) '())))) (null? (remove (lambda (x) #t) '()))))
(make-test-case (test-case
"remove:singleton-list" "remove:singleton-list"
(assert-equal? (check-equal?
(remove (lambda (x) #f) '(Alvord)) (remove (lambda (x) #f) '(Alvord))
'(Alvord))) '(Alvord)))
(make-test-case (test-case
"remove:all-elements-removed" "remove:all-elements-removed"
(assert-true (check-true
(null? (remove (lambda (x) #t) '(Amana Amber Ames Amish Anamosa))))) (null? (remove (lambda (x) #t) '(Amana Amber Ames Amish Anamosa)))))
(make-test-case (test-case
"remove:some-elements-removed" "remove:some-elements-removed"
(assert-equal? (check-equal?
(remove even? '(96 97 98 99 100)) (remove even? '(96 97 98 99 100))
'(97 99))) '(97 99)))
(make-test-case (test-case
"remove:no-elements-removed" "remove:no-elements-removed"
(assert-equal? (check-equal?
(remove (lambda (x) #f) (remove (lambda (x) #f)
'(Anderson Andover Andrew Andrews Angus)) '(Anderson Andover Andrew Andrews Angus))
'(Anderson Andover Andrew Andrews Angus))) '(Anderson Andover Andrew Andrews Angus)))
;; REMOVE! ;; REMOVE!
(make-test-case (test-case
"remove!:null-list" "remove!:null-list"
(assert-true (null? (remove! (lambda (x) #t) (list))))) (check-true (null? (remove! (lambda (x) #t) (list)))))
(make-test-case (test-case
"remove!:singleton-list" "remove!:singleton-list"
(assert-equal? (check-equal?
(remove! (lambda (x) #f) (list 'Anita)) (remove! (lambda (x) #f) (list 'Anita))
'(Anita))) '(Anita)))
(make-test-case (test-case
"remove!:all-elements-removed" "remove!:all-elements-removed"
(assert-true (check-true
(null? (null?
(remove! (lambda (x) #t) (remove! (lambda (x) #t)
(list 'Ankeny 'Anthon 'Aplington 'Arcadia 'Archer))))) (list 'Ankeny 'Anthon 'Aplington 'Arcadia 'Archer)))))
(make-test-case (test-case
"remove!:some-elements-removed" "remove!:some-elements-removed"
(assert-equal? (check-equal?
(remove! even? (list 101 102 103 104 105)) (remove! even? (list 101 102 103 104 105))
'(101 103 105))) '(101 103 105)))
(make-test-case (test-case
"remove!:no-elements-removed" "remove!:no-elements-removed"
(assert-equal? (check-equal?
(remove! (lambda (x) #f) (remove! (lambda (x) #f)
(list 'Ardon 'Aredale 'Argo 'Argyle 'Arion)) (list 'Ardon 'Aredale 'Argo 'Argyle 'Arion))
'(Ardon Aredale Argo Argyle Arion))) '(Ardon Aredale Argo Argyle Arion)))
;; PARTITION ;; PARTITION
(make-test-case (test-case
"partition:null-list" "partition:null-list"
(let-values (((in out) (partition (lambda (x) #f) '()))) (let-values (((in out) (partition (lambda (x) #f) '())))
(assert-true (and (null? in) (null? out))))) (check-true (and (null? in) (null? out)))))
(make-test-case (test-case
"partition:singleton-list" "partition:singleton-list"
(let-values (((in out) (partition (lambda (x) #f) '(Arispe)))) (let-values (((in out) (partition (lambda (x) #f) '(Arispe))))
(assert-true (and (null? in) (equal? out '(Arispe)))))) (check-true (and (null? in) (equal? out '(Arispe))))))
(make-test-case (test-case
"partition:all-satisfying" "partition:all-satisfying"
(let-values (((in out) (let-values (((in out)
(partition (lambda (x) #t) (partition (lambda (x) #t)
'(Arlington Armstrong Arnold Artesian Arthur)))) '(Arlington Armstrong Arnold Artesian Arthur))))
(assert-true (check-true
(and (equal? in (and (equal? in
'(Arlington Armstrong Arnold Artesian Arthur)) '(Arlington Armstrong Arnold Artesian Arthur))
(null? out))))) (null? out)))))
(make-test-case (test-case
"partition:mixed-starting-in" "partition:mixed-starting-in"
(let-values (((in out) (let-values (((in out)
(partition even? '(106 108 109 111 113 114 115 117 118 120)))) (partition even? '(106 108 109 111 113 114 115 117 118 120))))
(assert-true (and (equal? in '(106 108 114 118 120)) (check-true (and (equal? in '(106 108 114 118 120))
(equal? out '(109 111 113 115 117)))))) (equal? out '(109 111 113 115 117))))))
(make-test-case (test-case
"partition:mixed-starting-out" "partition:mixed-starting-out"
(let-values (((in out) (let-values (((in out)
(partition even? '(121 122 124 126)))) (partition even? '(121 122 124 126))))
(assert-true (and (equal? in '(122 124 126)) (check-true (and (equal? in '(122 124 126))
(equal? out '(121)))))) (equal? out '(121))))))
(make-test-case (test-case
"partition:none-satisfying" "partition:none-satisfying"
(let-values (((in out) (let-values (((in out)
(partition (lambda (x) #f) (partition (lambda (x) #f)
'(Asbury Ashawa Ashland Ashton Aspinwall)))) '(Asbury Ashawa Ashland Ashton Aspinwall))))
(assert-true (and (null? in) (check-true (and (null? in)
(equal? out (equal? out
'(Asbury Ashawa Ashland Ashton Aspinwall)))))) '(Asbury Ashawa Ashland Ashton Aspinwall))))))
;; PARTITION! ;; PARTITION!
(make-test-case (test-case
"partition!:null-list" "partition!:null-list"
(let-values (((in out) (let-values (((in out)
(partition! (lambda (x) #f) (list)))) (partition! (lambda (x) #f) (list))))
(assert-true (and (null? in) (null? out))))) (check-true (and (null? in) (null? out)))))
(make-test-case (test-case
"partition!:singleton-list" "partition!:singleton-list"
(let-values (((in out) (let-values (((in out)
(partition! (lambda (x) #f) (list 'Astor)))) (partition! (lambda (x) #f) (list 'Astor))))
(lambda (in out) (and (null? in) (equal? out '(Astor)))))) (lambda (in out) (and (null? in) (equal? out '(Astor))))))
(make-test-case (test-case
"partition!:all-satisfying" "partition!:all-satisfying"
(let-values (((in out) (let-values (((in out)
(partition! (lambda (x) #t) (partition! (lambda (x) #t)
(list 'Atalissa 'Athelstan 'Atkins 'Atlantic (list 'Atalissa 'Athelstan 'Atkins 'Atlantic
'Attica)))) 'Attica))))
(assert-true (check-true
(and (equal? in (and (equal? in
'(Atalissa Athelstan Atkins Atlantic Attica)) '(Atalissa Athelstan Atkins Atlantic Attica))
(null? out))))) (null? out)))))
(make-test-case (test-case
"partition!:mixed-starting-in" "partition!:mixed-starting-in"
(let-values (((in out) (let-values (((in out)
(partition! odd? (partition! odd?
(list 127 129 130 132 134 135 136 138 139 141)))) (list 127 129 130 132 134 135 136 138 139 141))))
(assert-true (check-true
(and (equal? in '(127 129 135 139 141)) (and (equal? in '(127 129 135 139 141))
(equal? out '(130 132 134 136 138)))))) (equal? out '(130 132 134 136 138))))))
(make-test-case (test-case
"partition!:mixed-starting-out" "partition!:mixed-starting-out"
(let-values (((in out) (let-values (((in out)
(partition! odd? (list 142 143 145 147)))) (partition! odd? (list 142 143 145 147))))
(assert-true (check-true
(and (equal? in '(143 145 147)) (and (equal? in '(143 145 147))
(equal? out '(142)))))) (equal? out '(142))))))
(make-test-case (test-case
"partition!:none-satisfying" "partition!:none-satisfying"
(let-values (((in out) (let-values (((in out)
(partition! (lambda (x) #f) (partition! (lambda (x) #f)
(list 'Auburn 'Audubon 'Augusta 'Aurelia (list 'Auburn 'Audubon 'Augusta 'Aurelia
'Aureola)))) 'Aureola))))
(assert-true (check-true
(and (null? in) (and (null? in)
(equal? out (equal? out
'(Auburn Audubon Augusta Aurelia Aureola)))))) '(Auburn Audubon Augusta Aurelia Aureola))))))

328
collects/tests/srfi/1/fold-test.ss
View File

@ -36,7 +36,7 @@
mzscheme mzscheme
(require (require
(planet "test.ss" ("schematics" "schemeunit.plt" 1 1)) (planet "test.ss" ("schematics" "schemeunit.plt" 2))
(all-except (lib "fold.ss" "srfi" "1") map for-each) (all-except (lib "fold.ss" "srfi" "1") map for-each)
(rename (lib "fold.ss" "srfi" "1") s:map map) (rename (lib "fold.ss" "srfi" "1") s:map map)
(rename (lib "fold.ss" "srfi" "1") s:for-each for-each)) (rename (lib "fold.ss" "srfi" "1") s:for-each for-each))
@ -44,22 +44,22 @@
(provide fold-tests) (provide fold-tests)
(define fold-tests (define fold-tests
(make-test-suite (test-suite
"Folding list procedures tests" "Folding list procedures tests"
;; UNFOLD ;; UNFOLD
(make-test-case (test-case
"unfold:predicate-always-satisfied" "unfold:predicate-always-satisfied"
(assert-true (null? (check-true (null?
(unfold (lambda (seed) #t) (unfold (lambda (seed) #t)
(lambda (seed) (* seed 2)) (lambda (seed) (* seed 2))
(lambda (seed) (* seed 3)) (lambda (seed) (* seed 3))
1)))) 1))))
(make-test-case (test-case
"unfold:normal-case" "unfold:normal-case"
(assert-equal? (check-equal?
(unfold (lambda (seed) (= seed 729)) (unfold (lambda (seed) (= seed 729))
(lambda (seed) (* seed 2)) (lambda (seed) (* seed 2))
(lambda (seed) (* seed 3)) (lambda (seed) (* seed 3))
@ -68,9 +68,9 @@
;; UNFOLD-RIGHT ;; UNFOLD-RIGHT
(make-test-case (test-case
"unfold-right:predicate-always-satisfied" "unfold-right:predicate-always-satisfied"
(assert-equal? (check-equal?
(unfold-right (lambda (seed) #t) (unfold-right (lambda (seed) #t)
(lambda (seed) (* seed 2)) (lambda (seed) (* seed 2))
(lambda (seed) (* seed 3)) (lambda (seed) (* seed 3))
@ -78,9 +78,9 @@
1) 1)
(list 1))) (list 1)))
(make-test-case (test-case
"unfold-right:normal-case" "unfold-right:normal-case"
(assert-equal? (check-equal?
(unfold-right (lambda (seed) (= seed 729)) (unfold-right (lambda (seed) (= seed 729))
(lambda (seed) (* seed 2)) (lambda (seed) (* seed 2))
(lambda (seed) (* seed 3)) (lambda (seed) (* seed 3))
@ -90,36 +90,36 @@
;; FOLD ;; FOLD
(make-test-case (test-case
"fold:one-null-list" "fold:one-null-list"
(assert = (fold (lambda (alpha beta) (* alpha (+ beta 1))) 13 '()) 13)) (check = (fold (lambda (alpha beta) (* alpha (+ beta 1))) 13 '()) 13))
(make-test-case (test-case
"fold:one-singleton-list" "fold:one-singleton-list"
(assert = (fold (lambda (alpha beta) (* alpha (+ beta 1))) 13 '(15)) 210)) (check = (fold (lambda (alpha beta) (* alpha (+ beta 1))) 13 '(15)) 210))
(make-test-case (test-case
"fold:one-longer-list" "fold:one-longer-list"
(assert = (check =
(fold (lambda (alpha beta) (* alpha (+ beta 1))) (fold (lambda (alpha beta) (* alpha (+ beta 1)))
13 13
'(15 17 19 21 23)) '(15 17 19 21 23))
32927582)) 32927582))
(make-test-case (test-case
"fold:several-null-lists" "fold:several-null-lists"
(assert-eq? (fold vector 'Chad '() '() '() '() '()) 'Chad)) (check-eq? (fold vector 'Chad '() '() '() '() '()) 'Chad))
(make-test-case (test-case
"fold:several-singleton-lists" "fold:several-singleton-lists"
(assert-equal? (check-equal?
(fold vector 'Chile '(China) '(Colombia) '(Comoros) '(Congo) (fold vector 'Chile '(China) '(Colombia) '(Comoros) '(Congo)
'(Croatia)) '(Croatia))
'#(China Colombia Comoros Congo Croatia Chile))) '#(China Colombia Comoros Congo Croatia Chile)))
(make-test-case (test-case
"fold:several-longer-lists" "fold:several-longer-lists"
(assert-equal? (check-equal?
(fold (lambda (alpha beta gamma delta epsilon zeta) (fold (lambda (alpha beta gamma delta epsilon zeta)
(cons (vector alpha beta gamma delta epsilon) zeta)) (cons (vector alpha beta gamma delta epsilon) zeta))
'() '()
@ -137,9 +137,9 @@
#(Cyprus Estonia Georgia Guyana Iran) #(Cyprus Estonia Georgia Guyana Iran)
#(Cuba Eritrea Gambia Guinea Indonesia)))) #(Cuba Eritrea Gambia Guinea Indonesia))))
(make-test-case (test-case
"fold:lists-of-different-lengths" "fold:lists-of-different-lengths"
(assert-equal? (check-equal?
(fold (lambda (alpha beta gamma delta) (fold (lambda (alpha beta gamma delta)
(cons (vector alpha beta gamma) delta)) (cons (vector alpha beta gamma) delta))
'() '()
@ -151,38 +151,38 @@
;; FOLD-RIGHT ;; FOLD-RIGHT
(make-test-case (test-case
"fold-right:one-null-list" "fold-right:one-null-list"
(assert = (fold-right (lambda (alpha beta) (* alpha (+ beta 1))) 13 '()) (check = (fold-right (lambda (alpha beta) (* alpha (+ beta 1))) 13 '())
13)) 13))
(make-test-case (test-case
"fold-right:one-singleton-list" "fold-right:one-singleton-list"
(assert = (fold-right (lambda (alpha beta) (* alpha (+ beta 1))) 13 '(15)) (check = (fold-right (lambda (alpha beta) (* alpha (+ beta 1))) 13 '(15))
210)) 210))
(make-test-case (test-case
"fold-right:one-longer-list" "fold-right:one-longer-list"
(assert = (fold-right (lambda (alpha beta) (* alpha (+ beta 1))) (check = (fold-right (lambda (alpha beta) (* alpha (+ beta 1)))
13 13
'(15 17 19 21 23)) '(15 17 19 21 23))
32868750)) 32868750))
(make-test-case (test-case
"fold-right:several-null-lists" "fold-right:several-null-lists"
(assert-eq? (fold-right vector 'Lebanon '() '() '() '() '()) (check-eq? (fold-right vector 'Lebanon '() '() '() '() '())
'Lebanon)) 'Lebanon))
(make-test-case (test-case
"fold-right:several-singleton-lists" "fold-right:several-singleton-lists"
(assert-equal? (check-equal?
(fold-right vector 'Lesotho '(Liberia) '(Libya) '(Liechtenstein) (fold-right vector 'Lesotho '(Liberia) '(Libya) '(Liechtenstein)
'(Lithuania) '(Luxembourg)) '(Lithuania) '(Luxembourg))
#(Liberia Libya Liechtenstein Lithuania Luxembourg Lesotho))) #(Liberia Libya Liechtenstein Lithuania Luxembourg Lesotho)))
(make-test-case (test-case
"fold-right:several-longer-lists" "fold-right:several-longer-lists"
(assert-equal? (check-equal?
(fold-right (lambda (alpha beta gamma delta epsilon zeta) (fold-right (lambda (alpha beta gamma delta epsilon zeta)
(cons (vector alpha beta gamma delta epsilon) zeta)) (cons (vector alpha beta gamma delta epsilon) zeta))
'() '()
@ -204,9 +204,9 @@
#(Mali Monaco Nepal Pakistan Portugal) #(Mali Monaco Nepal Pakistan Portugal)
#(Malta Mongolia Netherlands Palau Qatar)))) #(Malta Mongolia Netherlands Palau Qatar))))
(make-test-case (test-case
"fold-right:lists-of-different-lengths" "fold-right:lists-of-different-lengths"
(assert-equal? (check-equal?
(fold-right (lambda (alpha beta gamma delta) (fold-right (lambda (alpha beta gamma delta)
(cons (vector alpha beta gamma) delta)) (cons (vector alpha beta gamma) delta))
'() '()
@ -229,24 +229,24 @@
(revappend first (revappend first
(loop (car rest) (loop (car rest)
(cdr rest)))))))) (cdr rest))))))))
(make-test-suite (test-suite
"Pair-fold tests" "Pair-fold tests"
(make-test-case (test-case
"pair-fold:one-null-list" "pair-fold:one-null-list"
(assert-equal? (check-equal?
(pair-fold revappend '(Spain Sudan) '()) (pair-fold revappend '(Spain Sudan) '())
'(Spain Sudan))) '(Spain Sudan)))
(make-test-case (test-case
"pair-fold:one-singleton-list" "pair-fold:one-singleton-list"
(assert-equal? (check-equal?
(pair-fold revappend '(Suriname Swaziland) '(Sweden)) (pair-fold revappend '(Suriname Swaziland) '(Sweden))
'(Sweden Suriname Swaziland))) '(Sweden Suriname Swaziland)))
(make-test-case (test-case
"pair-fold:one-longer-list" "pair-fold:one-longer-list"
(assert-equal? (check-equal?
(pair-fold revappend (pair-fold revappend
'(Switzerland Syria) '(Switzerland Syria)
'(Taiwan Tajikistan Tanzania Thailand Togo)) '(Taiwan Tajikistan Tanzania Thailand Togo))
@ -254,15 +254,15 @@
Thailand Tanzania Tajikistan Togo Thailand Thailand Tanzania Tajikistan Togo Thailand
Tanzania Tajikistan Taiwan Switzerland Syria))) Tanzania Tajikistan Taiwan Switzerland Syria)))
(make-test-case (test-case
"pair-fold:several-null-lists" "pair-fold:several-null-lists"
(assert-equal? (check-equal?
(pair-fold revappall '(Tonga Tunisia) '() '() '() '() '()) (pair-fold revappall '(Tonga Tunisia) '() '() '() '() '())
'(Tonga Tunisia))) '(Tonga Tunisia)))
(make-test-case (test-case
"pair-fold:several-singleton-lists" "pair-fold:several-singleton-lists"
(assert-equal? (check-equal?
(pair-fold revappall (pair-fold revappall
'(Turkey Turkmenistan) '(Turkey Turkmenistan)
'(Tuvalu) '(Tuvalu)
@ -273,9 +273,9 @@
'(Tuvalu Uganda Ukraine Uruguay Uzbekistan Turkey '(Tuvalu Uganda Ukraine Uruguay Uzbekistan Turkey
Turkmenistan))) Turkmenistan)))
(make-test-case (test-case
"pair-fold:several-longer-lists" "pair-fold:several-longer-lists"
(assert-equal? (check-equal?
(pair-fold revappall (pair-fold revappall
'(Vanuatu Venezuela) '(Vanuatu Venezuela)
'(Vietnam Yemen Yugoslavia Zaire Zambia Zimbabwe '(Vietnam Yemen Yugoslavia Zaire Zambia Zimbabwe
@ -314,9 +314,9 @@
Gjellerup Gide Galsworthy Faulkner Vanuatu Gjellerup Gide Galsworthy Faulkner Vanuatu
Venezuela))) Venezuela)))
(make-test-case (test-case
"pair-fold:lists-of-different-lengths" "pair-fold:lists-of-different-lengths"
(assert-equal? (check-equal?
(pair-fold revappall (pair-fold revappall
'(Hauptmann Hemingway Hesse) '(Hauptmann Hemingway Hesse)
'(Heyse Jensen Jimenez Johnson) '(Heyse Jensen Jimenez Johnson)
@ -342,23 +342,23 @@
(revappend first (revappend first
(loop (car rest) (loop (car rest)
(cdr rest)))))))) (cdr rest))))))))
(make-test-suite (test-suite
"Pair-fold-right tests" "Pair-fold-right tests"
(make-test-case (test-case
"pair-fold-right:one-null-list" "pair-fold-right:one-null-list"
(assert-equal? (check-equal?
(pair-fold-right revappend '(Maeterlinck Mahfouz) '()) (pair-fold-right revappend '(Maeterlinck Mahfouz) '())
'(Maeterlinck Mahfouz))) '(Maeterlinck Mahfouz)))
(make-test-case (test-case
"pair-fold-right:one-singleton-list" "pair-fold-right:one-singleton-list"
(assert-equal? (check-equal?
(pair-fold-right revappend '(Mann Martinson) '(Mauriac)) (pair-fold-right revappend '(Mann Martinson) '(Mauriac))
'(Mauriac Mann Martinson))) '(Mauriac Mann Martinson)))
(make-test-case (test-case
"pair-fold-right:one-longer-list" "pair-fold-right:one-longer-list"
(assert-equal? (check-equal?
(pair-fold-right revappend (pair-fold-right revappend
'(Milosz Mistral) '(Milosz Mistral)
'(Mommsen Montale Morrison Neruda Oe)) '(Mommsen Montale Morrison Neruda Oe))
@ -366,15 +366,15 @@
Morrison Montale Oe Neruda Morrison Oe Neruda Oe Morrison Montale Oe Neruda Morrison Oe Neruda Oe
Milosz Mistral))) Milosz Mistral)))
(make-test-case (test-case
"pair-fold-right:several-null-lists" "pair-fold-right:several-null-lists"
(assert-equal? (check-equal?
(pair-fold-right revappall '(Pasternak Paz) '() '() '() '() '()) (pair-fold-right revappall '(Pasternak Paz) '() '() '() '() '())
'(Pasternak Paz))) '(Pasternak Paz)))
(make-test-case (test-case
"pair-fold-right:several-singleton-lists" "pair-fold-right:several-singleton-lists"
(assert-equal? (check-equal?
(pair-fold-right revappall (pair-fold-right revappall
'(Perse Pirandello) '(Perse Pirandello)
'(Pontoppidan) '(Pontoppidan)
@ -385,9 +385,9 @@
'(Pontoppidan Quasimodo Reymont Rolland Russell '(Pontoppidan Quasimodo Reymont Rolland Russell
Perse Pirandello))) Perse Pirandello)))
(make-test-case (test-case
"pair-fold-right:several-longer-lists" "pair-fold-right:several-longer-lists"
(assert-equal? (check-equal?
(pair-fold-right revappall (pair-fold-right revappall
'(Sachs Sartre) '(Sachs Sartre)
'(Seferis Shaw Sholokov Siefert Sienkiewicz '(Seferis Shaw Sholokov Siefert Sienkiewicz
@ -427,9 +427,9 @@
Bosque Borden Simon Undset Aransas Bastrop Bowie Bosque Borden Simon Undset Aransas Bastrop Bowie
Bosque Sachs Sartre))) Bosque Sachs Sartre)))
(make-test-case (test-case
"pair-fold-right:lists-of-different-lengths" "pair-fold-right:lists-of-different-lengths"
(assert-equal? (check-equal?
(pair-fold-right revappall (pair-fold-right revappall
'(Brazoria Brazos Brewster) '(Brazoria Brazos Brewster)
'(Briscoe Brooks Brown Burleson) '(Briscoe Brooks Brown Burleson)
@ -443,25 +443,25 @@
;; REDUCE ;; REDUCE
(make-test-case (test-case
"reduce:null-list" "reduce:null-list"
(assert-true (zero? (reduce (lambda (alpha beta) (* alpha (+ beta 1))) 0 '())))) (check-true (zero? (reduce (lambda (alpha beta) (* alpha (+ beta 1))) 0 '()))))
(make-test-case (test-case
"reduce:singleton-list" "reduce:singleton-list"
(assert = (reduce (lambda (alpha beta) (* alpha (+ beta 1))) 0 '(25)) 25)) (check = (reduce (lambda (alpha beta) (* alpha (+ beta 1))) 0 '(25)) 25))
(make-test-case (test-case
"reduce:doubleton-list" "reduce:doubleton-list"
(assert = (check =
(reduce (lambda (alpha beta) (* alpha (+ beta 1))) (reduce (lambda (alpha beta) (* alpha (+ beta 1)))
0 0
'(27 29)) '(27 29))
812)) 812))
(make-test-case (test-case
"reduce:longer-list" "reduce:longer-list"
(assert = (check =
(reduce (lambda (alpha beta) (* alpha (+ beta 1))) (reduce (lambda (alpha beta) (* alpha (+ beta 1)))
0 0
'(31 33 35 37 39 41 43)) '(31 33 35 37 39 41 43))
@ -469,27 +469,27 @@
;; REDUCE-RIGHT ;; REDUCE-RIGHT
(make-test-case (test-case
"reduce-right:null-list" "reduce-right:null-list"
(assert-true (zero? (reduce-right (lambda (alpha beta) (* alpha (+ beta 1))) 0 '())))) (check-true (zero? (reduce-right (lambda (alpha beta) (* alpha (+ beta 1))) 0 '()))))
(make-test-case (test-case
"reduce-right:singleton-list" "reduce-right:singleton-list"
(assert = (check =
(reduce-right (lambda (alpha beta) (* alpha (+ beta 1))) 0 '(25)) (reduce-right (lambda (alpha beta) (* alpha (+ beta 1))) 0 '(25))
25)) 25))
(make-test-case (test-case
"reduce-right:doubleton-list" "reduce-right:doubleton-list"
(assert = (check =
(reduce-right (lambda (alpha beta) (* alpha (+ beta 1))) (reduce-right (lambda (alpha beta) (* alpha (+ beta 1)))
0 0
'(27 29)) '(27 29))
810)) 810))
(make-test-case (test-case
"reduce-right:longer-list" "reduce-right:longer-list"
(assert = (check =
(reduce-right (lambda (alpha beta) (* alpha (+ beta 1))) (reduce-right (lambda (alpha beta) (* alpha (+ beta 1)))
0 0
'(31 33 35 37 39 41 43)) '(31 33 35 37 39 41 43))
@ -497,30 +497,30 @@
;; APPEND-MAP ;; APPEND-MAP
(make-test-case (test-case
"append-map:one-null-list" "append-map:one-null-list"
(assert-true (null? (append-map (lambda (element) (list element element)) '())))) (check-true (null? (append-map (lambda (element) (list element element)) '()))))
(make-test-case (test-case
"append-map:one-singleton-list" "append-map:one-singleton-list"
(assert-equal? (append-map (lambda (element) (list element element)) '(Cass)) (check-equal? (append-map (lambda (element) (list element element)) '(Cass))
'(Cass Cass))) '(Cass Cass)))
(make-test-case (test-case
"append-map:one-longer-list" "append-map:one-longer-list"
(assert-equal? (append-map (lambda (element) (list element element)) (check-equal? (append-map (lambda (element) (list element element))
'(Castro Chambers Cherokee Childress Clay)) '(Castro Chambers Cherokee Childress Clay))
'(Castro Castro Chambers Chambers Cherokee Cherokee '(Castro Castro Chambers Chambers Cherokee Cherokee
Childress Childress Clay Clay))) Childress Childress Clay Clay)))
(make-test-case (test-case
"append-map:several-null-lists" "append-map:several-null-lists"
(assert-true (null? (append-map (lambda elements (reverse elements)) (check-true (null? (append-map (lambda elements (reverse elements))
'() '() '() '() '())))) '() '() '() '() '()))))
(make-test-case (test-case
"append-map:several-singleton-lists" "append-map:several-singleton-lists"
(assert-equal? (append-map (lambda elements (reverse elements)) (check-equal? (append-map (lambda elements (reverse elements))
'(Cochran) '(Cochran)
'(Coke) '(Coke)
'(Coleman) '(Coleman)
@ -528,9 +528,9 @@
'(Collingsworth)) '(Collingsworth))
'(Collingsworth Collin Coleman Coke Cochran))) '(Collingsworth Collin Coleman Coke Cochran)))
(make-test-case (test-case
"append-map:several-longer-lists" "append-map:several-longer-lists"
(assert-equal? (check-equal?
(append-map (lambda elements (reverse elements)) (append-map (lambda elements (reverse elements))
'(Colorado Comal Comanche Concho Cooke Coryell '(Colorado Comal Comanche Concho Cooke Coryell
Cottle) Cottle)
@ -549,39 +549,39 @@
;; APPEND-MAP! ;; APPEND-MAP!
(make-test-case (test-case
"append-map!:one-null-list" "append-map!:one-null-list"
(assert-true (null? (append-map! (lambda (element) (list element element)) (check-true (null? (append-map! (lambda (element) (list element element))
(list))))) (list)))))
(make-test-case (test-case
"append-map!:one-singleton-list" "append-map!:one-singleton-list"
(assert-equal? (check-equal?
(append-map! (lambda (element) (list element element)) (append-map! (lambda (element) (list element element))
(list 'Gaines)) (list 'Gaines))
'(Gaines Gaines))) '(Gaines Gaines)))
(make-test-case (test-case
"append-map!:one-longer-list" "append-map!:one-longer-list"
(assert-equal? (check-equal?
(append-map! (lambda (element) (list element element)) (append-map! (lambda (element) (list element element))
(list 'Galveston 'Garza 'Gillespie 'Glasscock (list 'Galveston 'Garza 'Gillespie 'Glasscock
'Goliad)) 'Goliad))
'(Galveston Galveston Garza Garza Gillespie '(Galveston Galveston Garza Garza Gillespie
Gillespie Glasscock Glasscock Goliad Goliad))) Gillespie Glasscock Glasscock Goliad Goliad)))
(make-test-case (test-case
"append-map!:several-null-lists" "append-map!:several-null-lists"
(assert-true (null? (append-map! (lambda elements (reverse elements)) (check-true (null? (append-map! (lambda elements (reverse elements))
(list) (list)
(list) (list)
(list) (list)
(list) (list)
(list))))) (list)))))
(make-test-case (test-case
"append-map!:several-singleton-lists" "append-map!:several-singleton-lists"
(assert-equal? (check-equal?
(append-map! (lambda elements (reverse elements)) (append-map! (lambda elements (reverse elements))
(list 'Gonzales) (list 'Gonzales)
(list 'Gray) (list 'Gray)
@ -590,9 +590,9 @@
(list 'Grimes)) (list 'Grimes))
'(Grimes Gregg Grayson Gray Gonzales))) '(Grimes Gregg Grayson Gray Gonzales)))
(make-test-case (test-case
"append-map!:several-longer-lists" "append-map!:several-longer-lists"
(assert-equal? (check-equal?
(append-map! (lambda elements (reverse elements)) (append-map! (lambda elements (reverse elements))
(list 'Guadalupe 'Hale 'Hall 'Hamilton 'Hansford (list 'Guadalupe 'Hale 'Hall 'Hamilton 'Hansford
'Hardeman 'Hardin) 'Hardeman 'Hardin)
@ -613,28 +613,28 @@
;; MAP! ;; MAP!
(make-test-case (test-case
"map!:one-null-list" "map!:one-null-list"
(assert-true (null? (map! vector (list))))) (check-true (null? (map! vector (list)))))
(make-test-case (test-case
"map!:one-singleton-list" "map!:one-singleton-list"
(assert-equal? (map! vector (list 'Kent)) (check-equal? (map! vector (list 'Kent))
'(#(Kent)))) '(#(Kent))))
(make-test-case (test-case
"map!:one-longer-list" "map!:one-longer-list"
(assert-equal? (check-equal?
(map! vector (list 'Kerr 'Kimble 'King 'Kinney 'Kleberg)) (map! vector (list 'Kerr 'Kimble 'King 'Kinney 'Kleberg))
'(#(Kerr) #(Kimble) #(King) #(Kinney) #(Kleberg)))) '(#(Kerr) #(Kimble) #(King) #(Kinney) #(Kleberg))))
(make-test-case (test-case
"map!:several-null-lists" "map!:several-null-lists"
(assert-true (null? (map! vector (list) (list) (list) (list) (list))))) (check-true (null? (map! vector (list) (list) (list) (list) (list)))))
(make-test-case (test-case
"map!:several-singleton-lists" "map!:several-singleton-lists"
(assert-equal? (check-equal?
(map! vector (map! vector
(list 'Knox) (list 'Knox)
(list 'Lamar) (list 'Lamar)
@ -643,9 +643,9 @@
(list 'Lavaca)) (list 'Lavaca))
'(#(Knox Lamar Lamb Lampasas Lavaca)))) '(#(Knox Lamar Lamb Lampasas Lavaca))))
(make-test-case (test-case
"map!:several-longer-lists" "map!:several-longer-lists"
(assert-equal? (check-equal?
(map! vector (map! vector
(list 'Lee 'Leon 'Liberty 'Limestone 'Lipscomb 'Llano (list 'Lee 'Leon 'Liberty 'Limestone 'Lipscomb 'Llano
'Loving) 'Loving)
@ -667,17 +667,17 @@
;; MAP-IN-ORDER ;; MAP-IN-ORDER
(make-test-case (test-case
"map-in-order:one-null-list" "map-in-order:one-null-list"
(assert-true (null? (let ((counter 0)) (check-true (null? (let ((counter 0))
(map-in-order (lambda (element) (map-in-order (lambda (element)
(set! counter (+ counter 1)) (set! counter (+ counter 1))
(cons counter element)) (cons counter element))
'()))))) '())))))
(make-test-case (test-case
"map-in-order:one-singleton-list" "map-in-order:one-singleton-list"
(assert-equal? (check-equal?
(let ((counter 0)) (let ((counter 0))
(map-in-order (lambda (element) (map-in-order (lambda (element)
(set! counter (+ counter 1)) (set! counter (+ counter 1))
@ -685,9 +685,9 @@
'(Oldham))) '(Oldham)))
'((1 . Oldham)))) '((1 . Oldham))))
(make-test-case (test-case
"map-in-order:one-longer-list" "map-in-order:one-longer-list"
(assert-equal? (check-equal?
(let ((counter 0)) (let ((counter 0))
(map-in-order (lambda (element) (map-in-order (lambda (element)
(set! counter (+ counter 1)) (set! counter (+ counter 1))
@ -699,17 +699,17 @@
(4 . Parmer) (4 . Parmer)
(5 . Pecos)))) (5 . Pecos))))
(make-test-case (test-case
"map-in-order:several-null-lists" "map-in-order:several-null-lists"
(assert-true (null? (let ((counter 0)) (check-true (null? (let ((counter 0))
(map-in-order (lambda elements (map-in-order (lambda elements
(set! counter (+ counter 1)) (set! counter (+ counter 1))
(apply vector counter elements)) (apply vector counter elements))
'() '() '() '() '()))))) '() '() '() '() '())))))
(make-test-case (test-case
"map-in-order:several-singleton-lists" "map-in-order:several-singleton-lists"
(assert-equal? (check-equal?
(let ((counter 0)) (let ((counter 0))
(map-in-order (lambda elements (map-in-order (lambda elements
(set! counter (+ counter 1)) (set! counter (+ counter 1))
@ -721,9 +721,9 @@
'(Randall))) '(Randall)))
'(#(1 Polk Potter Presidio Rains Randall)))) '(#(1 Polk Potter Presidio Rains Randall))))
(make-test-case (test-case
"map-in-order:several-longer-lists" "map-in-order:several-longer-lists"
(assert-equal? (check-equal?
(let ((counter 0)) (let ((counter 0))
(map-in-order (lambda elements (map-in-order (lambda elements
(set! counter (+ counter 1)) (set! counter (+ counter 1))
@ -749,18 +749,18 @@
;; PAIR-FOR-EACH ;; PAIR-FOR-EACH
(make-test-case (test-case
"pair-for-each:one-null-list" "pair-for-each:one-null-list"
(assert-true (check-true
(null? (let ((base '())) (null? (let ((base '()))
(pair-for-each (lambda (tail) (pair-for-each (lambda (tail)
(set! base (append tail base))) (set! base (append tail base)))
'()) '())
base)))) base))))
(make-test-case (test-case
"pair-for-each:one-singleton-list" "pair-for-each:one-singleton-list"
(assert-equal? (check-equal?
(let ((base '())) (let ((base '()))
(pair-for-each (lambda (tail) (pair-for-each (lambda (tail)
(set! base (append tail base))) (set! base (append tail base)))
@ -768,9 +768,9 @@
base) base)
'(Victoria))) '(Victoria)))
(make-test-case (test-case
"pair-for-each:one-longer-list" "pair-for-each:one-longer-list"
(assert-equal? (check-equal?
(let ((base '())) (let ((base '()))
(pair-for-each (lambda (tail) (pair-for-each (lambda (tail)
(set! base (append tail base))) (set! base (append tail base)))
@ -780,9 +780,9 @@
Ward Washington Webb Walker Waller Ward Ward Washington Webb Walker Waller Ward
Washington Webb))) Washington Webb)))
(make-test-case (test-case
"pair-for-each:several-null-lists" "pair-for-each:several-null-lists"
(assert-true (check-true
(null? (let ((base '())) (null? (let ((base '()))
(pair-for-each (lambda tails (pair-for-each (lambda tails
(set! base (set! base
@ -790,9 +790,9 @@
'() '() '() '() '()) '() '() '() '() '())
base)))) base))))
(make-test-case (test-case
"pair-for-each:several-singleton-lists" "pair-for-each:several-singleton-lists"
(assert-equal? (check-equal?
(let ((base '())) (let ((base '()))
(pair-for-each (lambda tails (pair-for-each (lambda tails
(set! base (set! base
@ -806,9 +806,9 @@
'(#((Wharton) (Wheeler) (Wichita) (Wilbarger) '(#((Wharton) (Wheeler) (Wichita) (Wilbarger)
(Willacy))))) (Willacy)))))
(make-test-case (test-case
"pair-for-each:several-longer-lists" "pair-for-each:several-longer-lists"
(assert-equal? (check-equal?
(let ((base '())) (let ((base '()))
(pair-for-each (lambda tails (pair-for-each (lambda tails
(set! base (set! base
@ -860,42 +860,42 @@
;; FILTER-MAP ;; FILTER-MAP
(make-test-case (test-case
"filter-map:one-null-list" "filter-map:one-null-list"
(assert-true (null? (filter-map values '())))) (check-true (null? (filter-map values '()))))
(make-test-case (test-case
"filter-map:one-singleton-list" "filter-map:one-singleton-list"
(assert-equal? (check-equal?
(filter-map values '(Crest)) (filter-map values '(Crest))
'(Crest))) '(Crest)))
(make-test-case (test-case
"filter-map:one-list-all-elements-removed" "filter-map:one-list-all-elements-removed"
(assert-true (check-true
(null? (filter-map (lambda (x) #f) (null? (filter-map (lambda (x) #f)
'(Crisco Degree Doritos Dristan Efferdent))))) '(Crisco Degree Doritos Dristan Efferdent)))))
(make-test-case (test-case
"filter-map:one-list-some-elements-removed" "filter-map:one-list-some-elements-removed"
(assert-equal? (check-equal?
(filter-map (lambda (n) (and (even? n) n)) (filter-map (lambda (n) (and (even? n) n))
'(44 45 46 47 48 49 50)) '(44 45 46 47 48 49 50))
'(44 46 48 50))) '(44 46 48 50)))
(make-test-case (test-case
"filter-map:one-list-no-elements-removed" "filter-map:one-list-no-elements-removed"
(assert-equal? (check-equal?
(filter-map values '(ESPN Everready Excedrin Fab Fantastik)) (filter-map values '(ESPN Everready Excedrin Fab Fantastik))
'(ESPN Everready Excedrin Fab Fantastik))) '(ESPN Everready Excedrin Fab Fantastik)))
(make-test-case (test-case
"filter-map:several-null-lists" "filter-map:several-null-lists"
(assert-true (null? (filter-map vector '() '() '() '() '())))) (check-true (null? (filter-map vector '() '() '() '() '()))))
(make-test-case (test-case
"filter-map:several-singleton-lists" "filter-map:several-singleton-lists"
(assert-equal? (check-equal?
(filter-map vector (filter-map vector
'(Foamy) '(Foamy)
'(Gatorade) '(Gatorade)
@ -904,9 +904,9 @@
'(Halcion)) '(Halcion))
'(#(Foamy Gatorade Glad Gleem Halcion)))) '(#(Foamy Gatorade Glad Gleem Halcion))))
(make-test-case (test-case
"filter-map:several-lists-all-elements-removed" "filter-map:several-lists-all-elements-removed"
(assert-true (check-true
(null? (null?
(filter-map (lambda arguments #f) (filter-map (lambda arguments #f)
'(Hanes HBO Hostess Huggies Ivory Kent Kinney) '(Hanes HBO Hostess Huggies Ivory Kent Kinney)
@ -919,9 +919,9 @@
'(Prego Prell Prozac Purex Ritz Robitussin '(Prego Prell Prozac Purex Ritz Robitussin
Rolaids))))) Rolaids)))))
(make-test-case (test-case
"filter-map:several-lists-some-elements-removed" "filter-map:several-lists-some-elements-removed"
(assert-equal? (check-equal?
(filter-map (lambda arguments (filter-map (lambda arguments
(let ((sum (apply + arguments))) (let ((sum (apply + arguments)))
(and (odd? sum) sum))) (and (odd? sum) sum)))
@ -932,9 +932,9 @@
'(79 80 81 82 83 84 85)) '(79 80 81 82 83 84 85))
'(325 335 345 355))) '(325 335 345 355)))
(make-test-case (test-case
"filter-map:several-lists-no-elements-removed" "filter-map:several-lists-no-elements-removed"
(assert-equal? (check-equal?
(filter-map vector (filter-map vector
'(Ronzoni Ruffles Scotch Skippy SnackWell Snapple '(Ronzoni Ruffles Scotch Skippy SnackWell Snapple
Spam) Spam)

64
collects/tests/srfi/1/lset-test.ss
View File

@ -35,76 +35,76 @@
(module lset-test (module lset-test
mzscheme mzscheme
(require (planet "test.ss" ("schematics" "schemeunit.plt" 1 1)) (require (planet "test.ss" ("schematics" "schemeunit.plt" 2))
(lib "lset.ss" "srfi" "1")) (lib "lset.ss" "srfi" "1"))
(provide lset-tests) (provide lset-tests)
(define lset-tests (define lset-tests
(make-test-suite (test-suite
"List as set procedures tests" "List as set procedures tests"
(make-test-case (test-case
"lset<=:singleton" "lset<=:singleton"
(assert-true (lset<= eq?))) (check-true (lset<= eq?)))
(make-test-case (test-case
"lset<=:empty-list" "lset<=:empty-list"
(assert-true (lset<= eq? (list)))) (check-true (lset<= eq? (list))))
(make-test-case (test-case
"lset<=:empty-lists" "lset<=:empty-lists"
(assert-true (lset<= eq? (list) (list)))) (check-true (lset<= eq? (list) (list))))
(make-test-case (test-case
"lset<=:normal-case" "lset<=:normal-case"
(assert-true (lset<= = (list 1 2 3 4) (list 1 2 3 4)))) (check-true (lset<= = (list 1 2 3 4) (list 1 2 3 4))))
(make-test-case (test-case
"lset<=:normal-case-fail" "lset<=:normal-case-fail"
(assert-true (not (lset<= = (list 2 3 4 5) (list 1 2 3 4))))) (check-true (not (lset<= = (list 2 3 4 5) (list 1 2 3 4)))))
(make-test-case (test-case
"lset=:empty-list" "lset=:empty-list"
(assert-true (lset= eq?))) (check-true (lset= eq?)))
(make-test-case (test-case
"lset=:singleton" "lset=:singleton"
(assert-true (lset= eq? '(a b c d e)))) (check-true (lset= eq? '(a b c d e))))
(make-test-case (test-case
"lset=:normal-case" "lset=:normal-case"
(assert-true (lset= = '(1 2 3 4 5) '(5 4 3 2 1)))) (check-true (lset= = '(1 2 3 4 5) '(5 4 3 2 1))))
(make-test-case (test-case
"lset=:normal-case-fail" "lset=:normal-case-fail"
(assert-false (lset= eq? '(a b c d e) '(a b c d)))) (check-false (lset= eq? '(a b c d e) '(a b c d))))
(make-test-case (test-case
"lset-xor:empty-list" "lset-xor:empty-list"
(assert-equal? (lset-xor eq?) '())) (check-equal? (lset-xor eq?) '()))
(make-test-case (test-case
"lset-xor:singleton" "lset-xor:singleton"
(assert-equal? (lset-xor eq? '(a b c d e)) '(a b c d e))) (check-equal? (lset-xor eq? '(a b c d e)) '(a b c d e)))
(make-test-case (test-case
"lset-xor:normal-case" "lset-xor:normal-case"
(assert-true (lset= eq? (check-true (lset= eq?
(lset-xor eq? '(a b c d e) '(a e i o u)) (lset-xor eq? '(a b c d e) '(a e i o u))
'(d c b i o u)))) '(d c b i o u))))
(make-test-case (test-case
"lset-xor!:empty-list" "lset-xor!:empty-list"
(assert-equal? (lset-xor! eq?) '())) (check-equal? (lset-xor! eq?) '()))
(make-test-case (test-case
"lset-xor!:singleton" "lset-xor!:singleton"
(assert-equal? (lset-xor! eq? '(a b c d e)) '(a b c d e))) (check-equal? (lset-xor! eq? '(a b c d e)) '(a b c d e)))
(make-test-case (test-case
"lset-xor!:normal-case" "lset-xor!:normal-case"
(assert-true (lset= eq? (check-true (lset= eq?
(lset-xor! eq? '(a b c d e) '(a e i o u)) (lset-xor! eq? '(a b c d e) '(a e i o u))
'(d c b i o u)))) '(d c b i o u))))
)) ))

150
collects/tests/srfi/1/misc-test.ss
View File

@ -36,7 +36,7 @@
mzscheme mzscheme
(require (require
(planet "test.ss" ("schematics" "schemeunit.plt" 1 1)) (planet "test.ss" ("schematics" "schemeunit.plt" 2))
(all-except (lib "misc.ss" "srfi" "1") append! reverse!) (all-except (lib "misc.ss" "srfi" "1") append! reverse!)
(rename (lib "misc.ss" "srfi" "1") s:append! append!) (rename (lib "misc.ss" "srfi" "1") s:append! append!)
(rename (lib "misc.ss" "srfi" "1") s:reverse! reverse!)) (rename (lib "misc.ss" "srfi" "1") s:reverse! reverse!))
@ -44,23 +44,23 @@
(provide misc-tests) (provide misc-tests)
(define misc-tests (define misc-tests
(make-test-suite (test-suite
"Miscellaneous list procedures tests" "Miscellaneous list procedures tests"
;; ZIP ;; ZIP
(make-test-case (test-case
"zip:all-lists-empty" "zip:all-lists-empty"
(assert-true (null? (zip '() '() '() '() '())))) (check-true (null? (zip '() '() '() '() '()))))
(make-test-case (test-case
"zip:one-list" "zip:one-list"
(assert-equal? (zip '(Pisces Puppis Reticulum)) (check-equal? (zip '(Pisces Puppis Reticulum))
'((Pisces) (Puppis) (Reticulum)))) '((Pisces) (Puppis) (Reticulum))))
(make-test-case (test-case
"zip:two-lists" "zip:two-lists"
(assert-equal? (zip '(Sagitta Sagittarius Scorpio Scutum Serpens) (check-equal? (zip '(Sagitta Sagittarius Scorpio Scutum Serpens)
'(Sextans Taurus Telescopium Triangulum Tucana)) '(Sextans Taurus Telescopium Triangulum Tucana))
'((Sagitta Sextans) '((Sagitta Sextans)
(Sagittarius Taurus) (Sagittarius Taurus)
@ -68,14 +68,14 @@
(Scutum Triangulum) (Scutum Triangulum)
(Serpens Tucana)))) (Serpens Tucana))))
(make-test-case (test-case
"zip:short-lists" "zip:short-lists"
(assert-equal? (zip '(Vela) '(Virgo) '(Volens) '(Vulpecula)) (check-equal? (zip '(Vela) '(Virgo) '(Volens) '(Vulpecula))
'((Vela Virgo Volens Vulpecula)))) '((Vela Virgo Volens Vulpecula))))
(make-test-case (test-case
"zip:several-lists" "zip:several-lists"
(assert-equal? (zip '(actinium aluminum americium antimony argon) (check-equal? (zip '(actinium aluminum americium antimony argon)
'(arsenic astatine barium berkeleium beryllium) '(arsenic astatine barium berkeleium beryllium)
'(bismuth boron bromine cadmium calcium) '(bismuth boron bromine cadmium calcium)
'(californium carbon cerium cesium chlorine) '(californium carbon cerium cesium chlorine)
@ -95,18 +95,18 @@
;; UNZIP2 ;; UNZIP2
(make-test-case (test-case
"unzip2:empty-list-of-lists" "unzip2:empty-list-of-lists"
(let-values (((firsts seconds) (unzip2 '()))) (let-values (((firsts seconds) (unzip2 '())))
(assert-true (and (null? firsts) (null? seconds))))) (check-true (and (null? firsts) (null? seconds)))))
(make-test-case (test-case
"unzip2:singleton-list-of-lists" "unzip2:singleton-list-of-lists"
(let-values (((firsts seconds) (unzip2 '((retriever rottweiler))))) (let-values (((firsts seconds) (unzip2 '((retriever rottweiler)))))
(assert-true (and (equal? firsts '(retriever)) (check-true (and (equal? firsts '(retriever))
(equal? seconds '(rottweiler)))))) (equal? seconds '(rottweiler))))))
(make-test-case (test-case
"unzip2:longer-list-of-lists" "unzip2:longer-list-of-lists"
(let-values (((firsts seconds) (let-values (((firsts seconds)
(unzip2 '((saluki samoyed) (unzip2 '((saluki samoyed)
@ -114,38 +114,38 @@
(setter shepherd) (setter shepherd)
(skye spaniel) (skye spaniel)
(spitz staghound))))) (spitz staghound)))))
(assert-true (and (equal? firsts '(saluki shipperke setter skye spitz)) (check-true (and (equal? firsts '(saluki shipperke setter skye spitz))
(equal? seconds '(samoyed schnauzer shepherd spaniel (equal? seconds '(samoyed schnauzer shepherd spaniel
staghound)))))) staghound))))))
(make-test-case (test-case
"unzip2:lists-with-extra-elements" "unzip2:lists-with-extra-elements"
(let-values (((firsts seconds) (let-values (((firsts seconds)
(unzip2 '((terrier turnspit vizsla wiemaraner) (unzip2 '((terrier turnspit vizsla wiemaraner)
(whippet wolfhound) (whippet wolfhound)
(bells bones bongo carillon celesta) (bells bones bongo carillon celesta)
(chimes clappers conga))))) (chimes clappers conga)))))
(assert-true (and (equal? firsts '(terrier whippet bells chimes)) (check-true (and (equal? firsts '(terrier whippet bells chimes))
(equal? seconds (equal? seconds
'(turnspit wolfhound bones clappers)))))) '(turnspit wolfhound bones clappers))))))
;; UNZIP3 ;; UNZIP3
(make-test-case (test-case
"unzip3:empty-list-of-lists" "unzip3:empty-list-of-lists"
(let-values (((firsts seconds thirds) (let-values (((firsts seconds thirds)
(unzip3 '()))) (unzip3 '())))
(assert-true (and (null? firsts) (null? seconds) (null? thirds))))) (check-true (and (null? firsts) (null? seconds) (null? thirds)))))
(make-test-case (test-case
"unzip3:singleton-list-of-lists" "unzip3:singleton-list-of-lists"
(let-values (((firsts seconds thirds) (let-values (((firsts seconds thirds)
(unzip3 '((cymbals gamelan glockenspiel))))) (unzip3 '((cymbals gamelan glockenspiel)))))
(assert-true (and (equal? firsts '(cymbals)) (check-true (and (equal? firsts '(cymbals))
(equal? seconds '(gamelan)) (equal? seconds '(gamelan))
(equal? thirds '(glockenspiel)))))) (equal? thirds '(glockenspiel))))))
(make-test-case (test-case
"unzip3:longer-list-of-lists" "unzip3:longer-list-of-lists"
(let-values (((firsts seconds thirds) (let-values (((firsts seconds thirds)
(unzip3 '((gong handbells kettledrum) (unzip3 '((gong handbells kettledrum)
@ -153,45 +153,45 @@
(mbira membranophone metallophone) (mbira membranophone metallophone)
(nagara naker rattle) (nagara naker rattle)
(sizzler snappers tabor))))) (sizzler snappers tabor)))))
(assert-true (and (equal? firsts '(gong lyra mbira nagara sizzler)) (check-true (and (equal? firsts '(gong lyra mbira nagara sizzler))
(equal? seconds '(handbells maraca membranophone naker (equal? seconds '(handbells maraca membranophone naker
snappers)) snappers))
(equal? thirds '(kettledrum marimba metallophone rattle (equal? thirds '(kettledrum marimba metallophone rattle
tabor)))))) tabor))))))
(make-test-case (test-case
"unzip3:lists-with-extra-elements" "unzip3:lists-with-extra-elements"
(let-values (((firsts seconds thirds) (let-values (((firsts seconds thirds)
(unzip3 '((tambourine timbrel timpani tintinnabula tonitruone) (unzip3 '((tambourine timbrel timpani tintinnabula tonitruone)
(triangle vibraphone xylophone) (triangle vibraphone xylophone)
(baccarat banker bezique bingo bridge canasta) (baccarat banker bezique bingo bridge canasta)
(casino craps cribbage euchre))))) (casino craps cribbage euchre)))))
(assert-true (and (equal? firsts '(tambourine triangle baccarat casino)) (check-true (and (equal? firsts '(tambourine triangle baccarat casino))
(equal? seconds '(timbrel vibraphone banker craps)) (equal? seconds '(timbrel vibraphone banker craps))
(equal? thirds (equal? thirds
'(timpani xylophone bezique cribbage)))))) '(timpani xylophone bezique cribbage))))))
;; UNZIP4 ;; UNZIP4
(make-test-case (test-case
"unzip4:empty-list-of-lists" "unzip4:empty-list-of-lists"
(let-values (((firsts seconds thirds fourths) (let-values (((firsts seconds thirds fourths)
(unzip4 '()))) (unzip4 '())))
(assert-true (and (null? firsts) (check-true (and (null? firsts)
(null? seconds) (null? seconds)
(null? thirds) (null? thirds)
(null? fourths))))) (null? fourths)))))
(make-test-case (test-case
"unzip4:singleton-list-of-lists" "unzip4:singleton-list-of-lists"
(let-values (((firsts seconds thirds fourths) (let-values (((firsts seconds thirds fourths)
(unzip4 '((fantan faro gin hazard))))) (unzip4 '((fantan faro gin hazard)))))
(assert-true (and (equal? firsts '(fantan)) (check-true (and (equal? firsts '(fantan))
(equal? seconds '(faro)) (equal? seconds '(faro))
(equal? thirds '(gin)) (equal? thirds '(gin))
(equal? fourths '(hazard)))))) (equal? fourths '(hazard))))))
(make-test-case (test-case
"unzip4:longer-list-of-lists" "unzip4:longer-list-of-lists"
(let-values (((firsts seconds thirds fourths) (let-values (((firsts seconds thirds fourths)
(unzip4 '((hearts keno loo lottery) (unzip4 '((hearts keno loo lottery)
@ -199,13 +199,13 @@
(ombre picquet pinball pinochle) (ombre picquet pinball pinochle)
(poker policy quinze romesteq) (poker policy quinze romesteq)
(roulette rum rummy skat))))) (roulette rum rummy skat)))))
(assert-true (and (equal? firsts '(hearts lotto ombre poker roulette)) (check-true (and (equal? firsts '(hearts lotto ombre poker roulette))
(equal? seconds '(keno lowball picquet policy rum)) (equal? seconds '(keno lowball picquet policy rum))
(equal? thirds '(loo monte pinball quinze rummy)) (equal? thirds '(loo monte pinball quinze rummy))
(equal? fourths (equal? fourths
'(lottery numbers pinochle romesteq skat)))))) '(lottery numbers pinochle romesteq skat))))))
(make-test-case (test-case
"unzip4:lists-with-extra-elements" "unzip4:lists-with-extra-elements"
(let-values (((firsts seconds thirds fourths) (let-values (((firsts seconds thirds fourths)
(unzip4 '((adamant agate alexandrite amethyst aquamarine (unzip4 '((adamant agate alexandrite amethyst aquamarine
@ -214,7 +214,7 @@
(chalcedony chrysoberyl chrysolite chrysoprase (chalcedony chrysoberyl chrysolite chrysoprase
citrine coral demantoid) citrine coral demantoid)
(diamond emerald garnet girasol heliotrope))))) (diamond emerald garnet girasol heliotrope)))))
(assert-true (and (equal? firsts '(adamant bloodstone chalcedony diamond)) (check-true (and (equal? firsts '(adamant bloodstone chalcedony diamond))
(equal? seconds '(agate brilliant chrysoberyl emerald)) (equal? seconds '(agate brilliant chrysoberyl emerald))
(equal? thirds (equal? thirds
'(alexandrite carbuncle chrysolite garnet)) '(alexandrite carbuncle chrysolite garnet))
@ -223,18 +223,18 @@
;; UNZIP5 ;; UNZIP5
(make-test-case (test-case
"unzip5:empty-list-of-lists" "unzip5:empty-list-of-lists"
(let-values (((firsts seconds thirds fourths fifths) (let-values (((firsts seconds thirds fourths fifths)
(unzip5 '()))) (unzip5 '())))
(assert-true (check-true
(and (null? firsts) (and (null? firsts)
(null? seconds) (null? seconds)
(null? thirds) (null? thirds)
(null? fourths) (null? fourths)
(null? fifths))))) (null? fifths)))))
(make-test-case (test-case
"unzip5:singleton-list-of-lists" "unzip5:singleton-list-of-lists"
(let-values (((firsts seconds thirds fourths fifths) (let-values (((firsts seconds thirds fourths fifths)
(unzip5 '((hyacinth jacinth jade jargoon jasper))))) (unzip5 '((hyacinth jacinth jade jargoon jasper)))))
@ -245,7 +245,7 @@
(equal? fourths '(jargoon)) (equal? fourths '(jargoon))
(equal? fifths '(jasper)))))) (equal? fifths '(jasper))))))
(make-test-case (test-case
"unzip5:longer-list-of-lists" "unzip5:longer-list-of-lists"
(let-values (((firsts seconds thirds fourths fifths) (let-values (((firsts seconds thirds fourths fifths)
(unzip5 '((kunzite moonstone morganite onyx opal) (unzip5 '((kunzite moonstone morganite onyx opal)
@ -253,7 +253,7 @@
(sardonyx spinel star sunstone topaz) (sardonyx spinel star sunstone topaz)
(tourmaline turquoise zircon Argus basilisk) (tourmaline turquoise zircon Argus basilisk)
(Bigfoot Briareus bucentur Cacus Caliban))))) (Bigfoot Briareus bucentur Cacus Caliban)))))
(assert-true (check-true
(and (equal? firsts (and (equal? firsts
'(kunzite peridot sardonyx tourmaline Bigfoot)) '(kunzite peridot sardonyx tourmaline Bigfoot))
(equal? seconds (equal? seconds
@ -262,7 +262,7 @@
(equal? fourths '(onyx sapphire sunstone Argus Cacus)) (equal? fourths '(onyx sapphire sunstone Argus Cacus))
(equal? fifths '(opal sard topaz basilisk Caliban)))))) (equal? fifths '(opal sard topaz basilisk Caliban))))))
(make-test-case (test-case
"unzip5:lists-with-extra-elements" "unzip5:lists-with-extra-elements"
(let-values (((firsts seconds thirds fourths fifths) (let-values (((firsts seconds thirds fourths fifths)
(unzip5 '((centaur Cerberus Ceto Charybdis chimera cockatrice (unzip5 '((centaur Cerberus Ceto Charybdis chimera cockatrice
@ -271,7 +271,7 @@
(Gigantes Gorgon Grendel griffin Harpy hippocampus (Gigantes Gorgon Grendel griffin Harpy hippocampus
hippocentaur hippocerf) hippocentaur hippocerf)
(hirocervus Hydra Kraken Ladon manticore Medusa))))) (hirocervus Hydra Kraken Ladon manticore Medusa)))))
(assert-true (check-true
(and (equal? firsts '(centaur dipsas Gigantes hirocervus)) (and (equal? firsts '(centaur dipsas Gigantes hirocervus))
(equal? seconds '(Cerberus dragon Gorgon Hydra)) (equal? seconds '(Cerberus dragon Gorgon Hydra))
(equal? thirds '(Ceto drake Grendel Kraken)) (equal? thirds '(Ceto drake Grendel Kraken))
@ -280,18 +280,18 @@
;; APPEND! ;; APPEND!
(make-test-case (test-case
"append!:no-arguments" "append!:no-arguments"
(assert-true (null? (s:append!)))) (check-true (null? (s:append!))))
(make-test-case (test-case
"append!:one-argument" "append!:one-argument"
(assert-equal? (s:append! (list 'mermaid 'merman 'Minotaur)) (check-equal? (s:append! (list 'mermaid 'merman 'Minotaur))
'(mermaid merman Minotaur))) '(mermaid merman Minotaur)))
(make-test-case (test-case
"append!:several-arguments" "append!:several-arguments"
(assert-equal? (check-equal?
(s:append! (list 'nixie 'ogre 'ogress 'opinicus) (s:append! (list 'nixie 'ogre 'ogress 'opinicus)
(list 'Orthos) (list 'Orthos)
(list 'Pegasus 'Python) (list 'Pegasus 'Python)
@ -301,36 +301,36 @@
Python roc Sagittary salamander Sasquatch Python roc Sagittary salamander Sasquatch
satyr Scylla simurgh siren))) satyr Scylla simurgh siren)))
(make-test-case (test-case
"append!:some-null-arguments" "append!:some-null-arguments"
(assert-equal? (check-equal?
(s:append! (list) (list) (list 'Sphinx 'Talos 'troll) (list) (s:append! (list) (list) (list 'Sphinx 'Talos 'troll) (list)
(list 'Typhoeus) (list) (list) (list)) (list 'Typhoeus) (list) (list) (list))
'(Sphinx Talos troll Typhoeus))) '(Sphinx Talos troll Typhoeus)))
(make-test-case (test-case
"append!:all-null-arguments" "append!:all-null-arguments"
(assert-true (null? (s:append! (list) (list) (list) (list) (list))))) (check-true (null? (s:append! (list) (list) (list) (list) (list)))))
;; APPEND-REVERSE ;; APPEND-REVERSE
(make-test-case (test-case
"append-reverse:first-argument-null" "append-reverse:first-argument-null"
(assert-equal? (append-reverse '() '(Typhon unicorn vampire werewolf)) (check-equal? (append-reverse '() '(Typhon unicorn vampire werewolf))
'(Typhon unicorn vampire werewolf))) '(Typhon unicorn vampire werewolf)))
(make-test-case (test-case
"append-reverse:second-argument-null" "append-reverse:second-argument-null"
(assert-equal? (append-reverse '(windigo wivern xiphopagus yeti zombie) '()) (check-equal? (append-reverse '(windigo wivern xiphopagus yeti zombie) '())
'(zombie yeti xiphopagus wivern windigo))) '(zombie yeti xiphopagus wivern windigo)))
(make-test-case (test-case
"append-reverse:both-arguments-null" "append-reverse:both-arguments-null"
(assert-true (null? (append-reverse '() '())))) (check-true (null? (append-reverse '() '()))))
(make-test-case (test-case
"append-reverse:neither-argument-null" "append-reverse:neither-argument-null"
(assert-equal? (check-equal?
(append-reverse '(Afghanistan Albania Algeria Andorra) (append-reverse '(Afghanistan Albania Algeria Andorra)
'(Angola Argentina Armenia)) '(Angola Argentina Armenia))
'(Andorra Algeria Albania Afghanistan Angola '(Andorra Algeria Albania Afghanistan Angola
@ -338,43 +338,43 @@
;; APPEND-REVERSE! ;; APPEND-REVERSE!
(make-test-case (test-case
"append-reverse!:first-argument-null" "append-reverse!:first-argument-null"
(assert-equal? (append-reverse! (list) (check-equal? (append-reverse! (list)
(list 'Australia 'Austria 'Azerbaijan)) (list 'Australia 'Austria 'Azerbaijan))
'(Australia Austria Azerbaijan))) '(Australia Austria Azerbaijan)))
(make-test-case (test-case
"append-reverse!:second-argument-null" "append-reverse!:second-argument-null"
(assert-equal? (append-reverse! (list 'Bahrain 'Bangladesh 'Barbados (check-equal? (append-reverse! (list 'Bahrain 'Bangladesh 'Barbados
'Belarus 'Belgium) 'Belarus 'Belgium)
(list)) (list))
'(Belgium Belarus Barbados Bangladesh Bahrain))) '(Belgium Belarus Barbados Bangladesh Bahrain)))
(make-test-case (test-case
"append-reverse!:both-arguments-null" "append-reverse!:both-arguments-null"
(assert-true (null? (append-reverse! (list) (list))))) (check-true (null? (append-reverse! (list) (list)))))
(make-test-case (test-case
"append-reverse!:neither-argument-null" "append-reverse!:neither-argument-null"
(assert-equal? (append-reverse! (list 'Belize 'Benin 'Bhutan 'Bolivia) (check-equal? (append-reverse! (list 'Belize 'Benin 'Bhutan 'Bolivia)
(list 'Bosnia 'Botswana 'Brazil)) (list 'Bosnia 'Botswana 'Brazil))
'(Bolivia Bhutan Benin Belize Bosnia Botswana Brazil))) '(Bolivia Bhutan Benin Belize Bosnia Botswana Brazil)))
;; REVERSE! ;; REVERSE!
(make-test-case (test-case
"reverse!:empty-list" "reverse!:empty-list"
(assert-true (null? (s:reverse! (list))))) (check-true (null? (s:reverse! (list)))))
(make-test-case (test-case
"reverse!:singleton-list" "reverse!:singleton-list"
(assert-equal? (s:reverse! (list 'Brunei)) (check-equal? (s:reverse! (list 'Brunei))
'(Brunei))) '(Brunei)))
(make-test-case (test-case
"reverse!:longer-list" "reverse!:longer-list"
(assert-equal? (s:reverse! (list 'Bulgaria 'Burundi 'Cambodia 'Cameroon (check-equal? (s:reverse! (list 'Bulgaria 'Burundi 'Cambodia 'Cameroon
'Canada)) 'Canada))
'(Canada Cameroon Cambodia Burundi Bulgaria))) '(Canada Cameroon Cambodia Burundi Bulgaria)))

108
collects/tests/srfi/1/predicate-test.ss
View File

@ -36,134 +36,134 @@
mzscheme mzscheme
(require (require
(planet "test.ss" ("schematics" "schemeunit.plt" 1 1)) (planet "test.ss" ("schematics" "schemeunit.plt" 2))
(lib "predicate.ss" "srfi" "1") (lib "predicate.ss" "srfi" "1")
(lib "cons.ss" "srfi" "1")) (lib "cons.ss" "srfi" "1"))
(provide predicate-tests) (provide predicate-tests)
(define predicate-tests (define predicate-tests
(make-test-suite (test-suite
"List predicate tests" "List predicate tests"
;; PROPER-LIST? ;; PROPER-LIST?
(make-test-case (test-case
"proper-list?:list" "proper-list?:list"
(assert-true (proper-list? (list 1 2 3 4 5)))) (check-true (proper-list? (list 1 2 3 4 5))))
(make-test-case (test-case
"proper-list?:dotted-list" "proper-list?:dotted-list"
(assert-true (not (proper-list? (cons 1 (cons 2 (cons 3 4))))))) (check-true (not (proper-list? (cons 1 (cons 2 (cons 3 4)))))))
(make-test-case (test-case
"proper-list?:zero-length" "proper-list?:zero-length"
(assert-true (proper-list? (list)))) (check-true (proper-list? (list))))
(make-test-case (test-case
"proper-list?:circular-list" "proper-list?:circular-list"
(assert-true (not (proper-list? (circular-list 'a 'b 'c 'd))))) (check-true (not (proper-list? (circular-list 'a 'b 'c 'd)))))
(make-test-case (test-case
"proper-list?:simple-value" "proper-list?:simple-value"
(assert-true (not (proper-list? 1)))) (check-true (not (proper-list? 1))))
;; DOTTED-LIST? ;; DOTTED-LIST?
(make-test-case (test-case
"dotted-list?:dotted-list" "dotted-list?:dotted-list"
(assert-true (dotted-list? '(1 2 3 . 4)))) (check-true (dotted-list? '(1 2 3 . 4))))
(make-test-case (test-case
"dotted-list?:proper-list" "dotted-list?:proper-list"
(assert-true (not (dotted-list? (list 'a 'b 'c 'd))))) (check-true (not (dotted-list? (list 'a 'b 'c 'd)))))
(make-test-case (test-case
"dotted-list?:empty-list" "dotted-list?:empty-list"
(assert-true (not (dotted-list? (list))))) (check-true (not (dotted-list? (list)))))
(make-test-case (test-case
"dotted-list?:simple-value" "dotted-list?:simple-value"
(assert-true (dotted-list? "hello"))) (check-true (dotted-list? "hello")))
;; CIRCULAR-LIST ;; CIRCULAR-LIST
(make-test-case (test-case
"circular-list?:proper-list" "circular-list?:proper-list"
(assert-true (not (circular-list? (list 1 2 3 4))))) (check-true (not (circular-list? (list 1 2 3 4)))))
(make-test-case (test-case
"circular-list?:dotted-list" "circular-list?:dotted-list"
(assert-true (not (circular-list? '(a b c . d))))) (check-true (not (circular-list? '(a b c . d)))))
(make-test-case (test-case
"circular-list?:simple-value" "circular-list?:simple-value"
(assert-true (not (circular-list? 1)))) (check-true (not (circular-list? 1))))
(make-test-case (test-case
"circular-list?:circular-list" "circular-list?:circular-list"
(assert-true (circular-list? (circular-list 1 2 3 4)))) (check-true (circular-list? (circular-list 1 2 3 4))))
;; NOT-PAIR ;; NOT-PAIR
(make-test-case (test-case
"not-pair?:list" "not-pair?:list"
(assert-true (not (not-pair? (list 1 2 3 4))))) (check-true (not (not-pair? (list 1 2 3 4)))))
(make-test-case (test-case
"not-pair?:number" "not-pair?:number"
(assert-true (not-pair? 1))) (check-true (not-pair? 1)))
(make-test-case (test-case
"not-pair?:symbol" "not-pair?:symbol"
(assert-true (not-pair? 'symbol))) (check-true (not-pair? 'symbol)))
(make-test-case (test-case
"not-pair?:string" "not-pair?:string"
(assert-true (not-pair? "string"))) (check-true (not-pair? "string")))
;; NULL-LIST? ;; NULL-LIST?
(make-test-case (test-case
"null-list?:null-list" "null-list?:null-list"
(assert-true (null-list? (list)))) (check-true (null-list? (list))))
(make-test-case (test-case
"null-list?:list" "null-list?:list"
(assert-true (not (null-list? (list 'a 'b 'c))))) (check-true (not (null-list? (list 'a 'b 'c)))))
(make-test-case (test-case
"null-list?:pair" "null-list?:pair"
(assert-true (not (null-list? (cons 1 2))))) (check-true (not (null-list? (cons 1 2)))))
;; LIST= ;; LIST=
(make-test-case (test-case
"list=:number-list" "list=:number-list"
(assert-true (list= = (list 1.0 2.0 3.0) (list 1 2 3)))) (check-true (list= = (list 1.0 2.0 3.0) (list 1 2 3))))
(make-test-case (test-case
"list=:symbol-vs-string-list" "list=:symbol-vs-string-list"
(assert-true (list= (lambda (x y) (check-true (list= (lambda (x y)
(string=? (symbol->string x) y)) (string=? (symbol->string x) y))
(list 'a 'b 'c) (list 'a 'b 'c)
(list "a" "b" "c")))) (list "a" "b" "c"))))
(make-test-case (test-case
"list=:unequal-lists" "list=:unequal-lists"
(assert-true (not (list= eq? (list 1 2 3) (list 'a 'b 'c) (list 1 2 3))))) (check-true (not (list= eq? (list 1 2 3) (list 'a 'b 'c) (list 1 2 3)))))
(make-test-case (test-case
"list=:unequal-lengths" "list=:unequal-lengths"
(assert-true (not (list= eq? (list 1 2 3) (list 1 2 3 4))))) (check-true (not (list= eq? (list 1 2 3) (list 1 2 3 4)))))
(make-test-case (test-case
"list=:empty-lists" "list=:empty-lists"
(assert-true (list= eq? (list) (list) (list)))) (check-true (list= eq? (list) (list) (list))))
(make-test-case (test-case
"list=:no-list" "list=:no-list"
(assert-true (list= eq?))) (check-true (list= eq?)))
)) ))
) )

4
collects/tests/srfi/1/run-tests.ss
View File

@ -1,5 +1,5 @@
(require (planet "test.ss" ("schematics" "schemeunit.plt" 1 1))) (require (planet "test.ss" ("schematics" "schemeunit.plt" 2)))
(require (planet "text-ui.ss" ("schematics" "schemeunit.plt" 1 1))) (require (planet "text-ui.ss" ("schematics" "schemeunit.plt" 2)))
(require "all-1-tests.ss") (require "all-1-tests.ss")
(test/text-ui all-1-tests) (test/text-ui all-1-tests)

234
collects/tests/srfi/1/search-test.ss
View File

@ -35,148 +35,148 @@
(module search-test (module search-test
mzscheme mzscheme
(require (planet "test.ss" ("schematics" "schemeunit.plt" 1 1)) (require (planet "test.ss" ("schematics" "schemeunit.plt" 2))
(all-except (lib "search.ss" "srfi" "1") member)) (all-except (lib "search.ss" "srfi" "1") member))
(provide search-tests) (provide search-tests)
(define search-tests (define search-tests
(make-test-suite (test-suite
"List search tests" "List search tests"
;; FIND ;; FIND
(make-test-case (test-case
"find:in-null-list" "find:in-null-list"
(assert-true (not (find (lambda (x) #t) '())))) (check-true (not (find (lambda (x) #t) '()))))
(make-test-case (test-case
"find:in-singleton-list" "find:in-singleton-list"
(assert-eq? (find (lambda (x) #t) '(Aurora)) (check-eq? (find (lambda (x) #t) '(Aurora))
'Aurora)) 'Aurora))
(make-test-case (test-case
"find:not-in-singleton-list" "find:not-in-singleton-list"
(assert-true (not (find (lambda (x) #f) '(Austinville))))) (check-true (not (find (lambda (x) #f) '(Austinville)))))
(make-test-case (test-case
"find:at-front-of-longer-list" "find:at-front-of-longer-list"
(assert-eq? (check-eq?
(find (lambda (x) #t) '(Avery Avoca Avon Ayrshire Badger)) (find (lambda (x) #t) '(Avery Avoca Avon Ayrshire Badger))
'Avery)) 'Avery))
(make-test-case (test-case
"find:in-middle-of-longer-list" "find:in-middle-of-longer-list"
(assert = (check =
(find even? '(149 151 153 155 156 157 159)) (find even? '(149 151 153 155 156 157 159))
156)) 156))
(make-test-case (test-case
"find:at-end-of-longer-list" "find:at-end-of-longer-list"
(assert = (check =
(find even? '(161 163 165 167 168)) (find even? '(161 163 165 167 168))
168)) 168))
(make-test-case (test-case
"find:not-in-longer-list" "find:not-in-longer-list"
(assert-true (check-true
(not (not
(find (lambda (x) #f) (find (lambda (x) #f)
'(Bagley Bailey Badwin Balfour Balltown))))) '(Bagley Bailey Badwin Balfour Balltown)))))
;;; FIND-TAIL ;;; FIND-TAIL
(make-test-case (test-case
"find-tail:in-null-list" "find-tail:in-null-list"
(assert-true (not (find-tail (lambda (x) #t) '())))) (check-true (not (find-tail (lambda (x) #t) '()))))
(make-test-case (test-case
"find-tail:in-singleton-list" "find-tail:in-singleton-list"
(let ((source '(Ballyclough))) (let ((source '(Ballyclough)))
(assert-eq? (check-eq?
(find-tail (lambda (x) #t) source) (find-tail (lambda (x) #t) source)
source))) source)))
(make-test-case (test-case
"find-tail:not-in-singleton-list" "find-tail:not-in-singleton-list"
(assert-true (not (find-tail (lambda (x) #f) '(Bancroft))))) (check-true (not (find-tail (lambda (x) #f) '(Bancroft)))))
(make-test-case (test-case
"find-tail:at-front-of-longer-list" "find-tail:at-front-of-longer-list"
(let ((source '(Bangor Bankston Barney Barnum Bartlett))) (let ((source '(Bangor Bankston Barney Barnum Bartlett)))
(assert-eq? (check-eq?
(find-tail (lambda (x) #t) source) (find-tail (lambda (x) #t) source)
source))) source)))
(make-test-case (test-case
"find-tail:in-middle-of-longer-list" "find-tail:in-middle-of-longer-list"
(let ((source '(169 171 173 175 176 177 179))) (let ((source '(169 171 173 175 176 177 179)))
(assert-eq? (check-eq?
(find-tail even? source) (find-tail even? source)
(cddddr source)))) (cddddr source))))
(make-test-case (test-case
"find-tail:at-end-of-longer-list" "find-tail:at-end-of-longer-list"
(let ((source '(181 183 185 187 188))) (let ((source '(181 183 185 187 188)))
(assert-eq? (check-eq?
(find-tail even? source) (find-tail even? source)
(cddddr source)))) (cddddr source))))
(make-test-case (test-case
"find-tail:not-in-longer-list" "find-tail:not-in-longer-list"
(assert-true (check-true
(not (not
(find-tail (lambda (x) #f) (find-tail (lambda (x) #f)
'(Batavia Bauer Baxter Bayard Beacon)) ))) '(Batavia Bauer Baxter Bayard Beacon)) )))
;;; ANY ;;; ANY
(make-test-case (test-case
"any:in-one-null-list" "any:in-one-null-list"
(assert-true (not (any values '())))) (check-true (not (any values '()))))
(make-test-case (test-case
"any:in-one-singleton-list" "any:in-one-singleton-list"
(assert-equal? (any vector '(Beaconsfield)) '#(Beaconsfield))) (check-equal? (any vector '(Beaconsfield)) '#(Beaconsfield)))
(make-test-case (test-case
"any:not-in-one-singleton-list" "any:not-in-one-singleton-list"
(assert-true (not (any (lambda (x) #f) '(Beaman))))) (check-true (not (any (lambda (x) #f) '(Beaman)))))
(make-test-case (test-case
"any:at-beginning-of-one-longer-list" "any:at-beginning-of-one-longer-list"
(assert-equal? (check-equal?
(any vector '(Beaver Beaverdale Beckwith Bedford Beebeetown)) (any vector '(Beaver Beaverdale Beckwith Bedford Beebeetown))
'#(Beaver))) '#(Beaver)))
(make-test-case (test-case
"any:in-middle-of-one-longer-list" "any:in-middle-of-one-longer-list"
(assert = (check =
(any (lambda (x) (and (odd? x) (+ x 189))) (any (lambda (x) (and (odd? x) (+ x 189)))
'(190 192 194 196 197 198 200)) '(190 192 194 196 197 198 200))
386)) 386))
(make-test-case (test-case
"any:at-end-of-one-longer-list" "any:at-end-of-one-longer-list"
(assert = (check =
(any (lambda (x) (and (odd? x) (+ x 201))) (any (lambda (x) (and (odd? x) (+ x 201)))
'(202 204 206 208 209)) '(202 204 206 208 209))
410)) 410))
(make-test-case (test-case
"any:not-in-one-longer-list" "any:not-in-one-longer-list"
(assert-true (check-true
(not (any (lambda (x) #f) (not (any (lambda (x) #f)
'(Beech Belinda Belknap Bellefountain Bellevue))))) '(Beech Belinda Belknap Bellefountain Bellevue)))))
(make-test-case (test-case
"any:in-several-null-lists" "any:in-several-null-lists"
(assert-true (check-true
(not (any vector '() '() '() '() '())))) (not (any vector '() '() '() '() '()))))
(make-test-case (test-case
"any:in-several-singleton-lists" "any:in-several-singleton-lists"
(assert-equal? (check-equal?
(any vector (any vector
'(Belmond) '(Belmond)
'(Beloit) '(Beloit)
@ -185,9 +185,9 @@
'(Bentley)) '(Bentley))
'#(Belmond Beloit Bennett Benson Bentley))) '#(Belmond Beloit Bennett Benson Bentley)))
(make-test-case (test-case
"any:not-in-several-singleton-lists" "any:not-in-several-singleton-lists"
(assert-true (check-true
(not (not
(any (lambda arguments #f) (any (lambda arguments #f)
'(Benton) '(Benton)
@ -196,9 +196,9 @@
'(Berkley) '(Berkley)
'(Bernard))))) '(Bernard)))))
(make-test-case (test-case
"any:at-beginning-of-several-longer-lists" "any:at-beginning-of-several-longer-lists"
(assert-equal? (check-equal?
(any vector (any vector
'(Berne Bertram Berwick Bethesda Bethlehem Bettendorf '(Berne Bertram Berwick Bethesda Bethlehem Bettendorf
Beulah) Beulah)
@ -210,9 +210,9 @@
'(Booneville Botany Botna Bouton Bowsher Boxholm Boyd)) '(Booneville Botany Botna Bouton Bowsher Boxholm Boyd))
'#(Berne Bevington Blakesburg Bluffton Booneville))) '#(Berne Bevington Blakesburg Bluffton Booneville)))
(make-test-case (test-case
"any:in-middle-of-several-longer-lists" "any:in-middle-of-several-longer-lists"
(assert = (check =
(any (lambda arguments (any (lambda arguments
(let ((sum (apply + arguments))) (let ((sum (apply + arguments)))
(and (odd? sum) (+ sum 210)))) (and (odd? sum) (+ sum 210))))
@ -223,9 +223,9 @@
'(240 242 244 246 247 248 250)) '(240 242 244 246 247 248 250))
1359)) 1359))
(make-test-case (test-case
"any:at-end-of-several-longer-lists" "any:at-end-of-several-longer-lists"
(assert = (check =
(any (lambda arguments (any (lambda arguments
(let ((sum (apply + arguments))) (let ((sum (apply + arguments)))
(and (even? sum) (+ sum 210)))) (and (even? sum) (+ sum 210))))
@ -236,9 +236,9 @@
'(281 283 285 287 289 291 292)) '(281 283 285 287 289 291 292))
1576)) 1576))
(make-test-case (test-case
"any:not-in-several-longer-lists" "any:not-in-several-longer-lists"
(assert-true (check-true
(not (not
(any (lambda arguments #f) (any (lambda arguments #f)
'(Boyden Boyer Braddyville Bradford Bradgate Brainard '(Boyden Boyer Braddyville Bradford Bradgate Brainard
@ -252,9 +252,9 @@
'(Buckeye Buckhorn Buckingham Bucknell Budd Buffalo '(Buckeye Buckhorn Buckingham Bucknell Budd Buffalo
Burchinal))))) Burchinal)))))
(make-test-case (test-case
"any:not-in-lists-of-unequal-length" "any:not-in-lists-of-unequal-length"
(assert-true (check-true
(not (any (lambda arguments #f) (not (any (lambda arguments #f)
'(Burdette Burlington Burnside Burt) '(Burdette Burlington Burnside Burt)
'(Bushville Bussey) '(Bushville Bussey)
@ -263,57 +263,57 @@
;;; EVERY ;;; EVERY
(make-test-case (test-case
"every:in-one-null-list" "every:in-one-null-list"
(assert-true (every values '()))) (check-true (every values '())))
(make-test-case (test-case
"every:in-one-singleton-list" "every:in-one-singleton-list"
(assert-equal? (check-equal?
(every vector '(Camanche)) (every vector '(Camanche))
'#(Camanche))) '#(Camanche)))
(make-test-case (test-case
"every:not-in-one-singleton-list" "every:not-in-one-singleton-list"
(assert-true (check-true
(not (every (lambda (x) #f) '(Cambria))))) (not (every (lambda (x) #f) '(Cambria)))))
(make-test-case (test-case
"every:failing-at-beginning-of-one-longer-list" "every:failing-at-beginning-of-one-longer-list"
(assert-true (check-true
(not (not
(every (lambda (x) #f) (every (lambda (x) #f)
'(Cambridge Cameron Canby Canton Cantril)) ))) '(Cambridge Cameron Canby Canton Cantril)) )))
(make-test-case (test-case
"every:failing-in-middle-of-one-longer-list" "every:failing-in-middle-of-one-longer-list"
(assert-true (check-true
(not (not
(every (lambda (x) (and (even? x) (+ x 293))) (every (lambda (x) (and (even? x) (+ x 293)))
'(294 296 298 300 301 302 304))))) '(294 296 298 300 301 302 304)))))
(make-test-case (test-case
"every:failing-at-end-of-one-longer-list" "every:failing-at-end-of-one-longer-list"
(assert-true (check-true
(not (not
(every (lambda (x) (and (even? x) (+ x 305))) (every (lambda (x) (and (even? x) (+ x 305)))
'(306 308 310 312 313))))) '(306 308 310 312 313)))))
(make-test-case (test-case
"every:in-one-longer-list" "every:in-one-longer-list"
(assert-equal? (check-equal?
(every vector (every vector
'(Carbon Carbondale Carl Carlisle Carmel)) '(Carbon Carbondale Carl Carlisle Carmel))
'#(Carmel))) '#(Carmel)))
(make-test-case (test-case
"every:in-several-null-lists" "every:in-several-null-lists"
(assert-true (check-true
(every vector '() '() '() '() '()))) (every vector '() '() '() '() '())))
(make-test-case (test-case
"every:in-several-singleton-lists" "every:in-several-singleton-lists"
(assert-equal? (check-equal?
(every vector (every vector
'(Carnarvon) '(Carnarvon)
'(Carnes) '(Carnes)
@ -322,9 +322,9 @@
'(Carpenter)) '(Carpenter))
'#(Carnarvon Carnes Carney Carnforth Carpenter))) '#(Carnarvon Carnes Carney Carnforth Carpenter)))
(make-test-case (test-case
"every:not-in-several-singleton-lists" "every:not-in-several-singleton-lists"
(assert-true (check-true
(not (not
(every (lambda arguments #f) (every (lambda arguments #f)
'(Carroll) '(Carroll)
@ -333,9 +333,9 @@
'(Carson) '(Carson)
'(Cartersville))))) '(Cartersville)))))
(make-test-case (test-case
"every:failing-at-beginning-of-several-longer-lists" "every:failing-at-beginning-of-several-longer-lists"
(assert-true (check-true
(not (not
(every (lambda arguments #f) (every (lambda arguments #f)
'(Cascade Casey Castalia Castana Cattese Cedar '(Cascade Casey Castalia Castana Cattese Cedar
@ -350,9 +350,9 @@
Clearfield)) Clearfield))
))) )))
(make-test-case (test-case
"every:failing-in-middle-of-several-longer-lists" "every:failing-in-middle-of-several-longer-lists"
(assert-true (check-true
(not (not
(every (lambda arguments (every (lambda arguments
(let ((sum (apply + arguments))) (let ((sum (apply + arguments)))
@ -364,9 +364,9 @@
'(343 345 347 349 350 351 353)) '(343 345 347 349 350 351 353))
))) )))
(make-test-case (test-case
"every:failing-at-end-of-several-longer-lists" "every:failing-at-end-of-several-longer-lists"
(assert-true (check-true
(not (not
(every (lambda arguments (every (lambda arguments
(let ((sum (apply + arguments))) (let ((sum (apply + arguments)))
@ -378,9 +378,9 @@
'(383 385 387 389 391 393 394)) '(383 385 387 389 391 393 394))
))) )))
(make-test-case (test-case
"every:in-several-longer-lists" "every:in-several-longer-lists"
(assert-equal? (check-equal?
(every vector (every vector
'(Cleghorn Clemons Clermont Cleves Cliffland Climax '(Cleghorn Clemons Clermont Cleves Cliffland Climax
Clinton) Clinton)
@ -392,9 +392,9 @@
Consol)) Consol))
'#(Clinton Coalville Collins Concord Consol))) '#(Clinton Coalville Collins Concord Consol)))
(make-test-case (test-case
"every:in-lists-of-unequal-length" "every:in-lists-of-unequal-length"
(assert-equal? (check-equal?
(every vector (every vector
'(Conway Cool Cooper Coppock) '(Conway Cool Cooper Coppock)
'(Coralville Corley) '(Coralville Corley)
@ -405,55 +405,55 @@
;;; LIST-INDEX ;;; LIST-INDEX
(make-test-case (test-case
"list-index:in-one-null-list" "list-index:in-one-null-list"
(assert-true (check-true
(not (list-index (lambda (x) #t) '())))) (not (list-index (lambda (x) #t) '()))))
(make-test-case (test-case
"list-index:in-one-singleton-list" "list-index:in-one-singleton-list"
(assert-true (check-true
(zero? (zero?
(list-index (lambda (x) #t) '(Cottonville))))) (list-index (lambda (x) #t) '(Cottonville)))))
(make-test-case (test-case
"list-index:not-in-one-singleton-list" "list-index:not-in-one-singleton-list"
(assert-true (check-true
(not (list-index (lambda (x) #f) '(Coulter))))) (not (list-index (lambda (x) #f) '(Coulter)))))
(make-test-case (test-case
"list-index:at-front-of-one-longer-list" "list-index:at-front-of-one-longer-list"
(assert-true (check-true
(zero? (zero?
(list-index (lambda (x) #t) (list-index (lambda (x) #t)
'(Covington Craig Cranston Crathorne '(Covington Craig Cranston Crathorne
Crawfordsville))))) Crawfordsville)))))
(make-test-case (test-case
"list-index:in-middle-of-one-longer-list" "list-index:in-middle-of-one-longer-list"
(list-index even? '(395 397 399 401 402 403 405)) (list-index even? '(395 397 399 401 402 403 405))
(lambda (result) (= result 4))) (lambda (result) (= result 4)))
(make-test-case (test-case
"list-index:at-end-of-one-longer-list" "list-index:at-end-of-one-longer-list"
(assert = (check =
(list-index odd? '(406 408 410 412 414 415)) (list-index odd? '(406 408 410 412 414 415))
5)) 5))
(make-test-case (test-case
"list-index:not-in-one-longer-list" "list-index:not-in-one-longer-list"
(assert-true (check-true
(not (not
(list-index (lambda (x) #f) (list-index (lambda (x) #f)
'(Crescent Cresco Creston Crocker Crombie))))) '(Crescent Cresco Creston Crocker Crombie)))))
(make-test-case (test-case
"list-index:in-several-null-lists" "list-index:in-several-null-lists"
(assert-true (check-true
(not (list-index (lambda arguments #t) '() '() '() '() '())))) (not (list-index (lambda arguments #t) '() '() '() '() '()))))
(make-test-case (test-case
"list-index:in-several-singleton-lists" "list-index:in-several-singleton-lists"
(assert-true (check-true
(zero? (list-index (lambda arguments #t) (zero? (list-index (lambda arguments #t)
'(Cromwell) '(Cromwell)
'(Croton) '(Croton)
@ -461,9 +461,9 @@
'(Cumming) '(Cumming)
'(Curlew))))) '(Curlew)))))
(make-test-case (test-case
"list-index:not-in-several-singleton-lists" "list-index:not-in-several-singleton-lists"
(assert-true (check-true
(not (list-index (lambda arguments #f) (not (list-index (lambda arguments #f)
'(Cushing) '(Cushing)
'(Cylinder) '(Cylinder)
@ -471,9 +471,9 @@
'(Dalby) '(Dalby)
'(Dale))))) '(Dale)))))
(make-test-case (test-case
"list-index:at-front-of-several-longer-lists" "list-index:at-front-of-several-longer-lists"
(assert-true (check-true
(zero? (list-index (lambda arguments #t) (zero? (list-index (lambda arguments #t)
'(Dallas Dana Danbury Danville Darbyville '(Dallas Dana Danbury Danville Darbyville
Davenport Dawson) Davenport Dawson)
@ -485,9 +485,9 @@
'(Dewar Dexter Diagonal Dickens Dickieville Dike '(Dewar Dexter Diagonal Dickens Dickieville Dike
Dillon))))) Dillon)))))
(make-test-case (test-case
"list-index:in-middle-of-several-longer-lists" "list-index:in-middle-of-several-longer-lists"
(assert = (check =
(list-index (lambda arguments (odd? (apply + arguments))) (list-index (lambda arguments (odd? (apply + arguments)))
'(416 417 418 419 420 421 422) '(416 417 418 419 420 421 422)
'(423 424 425 426 427 428 429) '(423 424 425 426 427 428 429)
@ -496,9 +496,9 @@
'(444 446 448 450 451 452 454)) '(444 446 448 450 451 452 454))
4)) 4))
(make-test-case (test-case
"list-index:at-end-of-several-longer-lists" "list-index:at-end-of-several-longer-lists"
(assert = (check =
(list-index (lambda arguments (even? (apply + arguments))) (list-index (lambda arguments (even? (apply + arguments)))
'(455 456 457 458 459 460) '(455 456 457 458 459 460)
'(461 462 463 464 465 466) '(461 462 463 464 465 466)
@ -507,9 +507,9 @@
'(479 481 483 485 487 488)) '(479 481 483 485 487 488))
5)) 5))
(make-test-case (test-case
"list-index:not-in-several-longer-lists" "list-index:not-in-several-longer-lists"
(assert-true (check-true
(not (not
(list-index (lambda arguments #f) (list-index (lambda arguments #f)
'(Dinsdale Dixon Dodgeville Dolliver Donahue '(Dinsdale Dixon Dodgeville Dolliver Donahue

188
collects/tests/srfi/1/selector-test.ss
View File

@ -35,214 +35,214 @@
(module selector-test (module selector-test
mzscheme mzscheme
(require (planet "test.ss" ("schematics" "schemeunit.plt" 1 1)) (require (planet "test.ss" ("schematics" "schemeunit.plt" 2))
(lib "selector.ss" "srfi" "1")) (lib "selector.ss" "srfi" "1"))
(provide selector-tests) (provide selector-tests)
(define selector-tests (define selector-tests
(make-test-suite (test-suite
"List selector tests" "List selector tests"
;; FIRST ;; FIRST
(make-test-case (test-case
"first:of-one" "first:of-one"
(assert-eq? (first '(hafnium)) 'hafnium)) (check-eq? (first '(hafnium)) 'hafnium))
(make-test-case (test-case
"first:of-many" "first:of-many"
(assert-eq? (first '(hahnium helium holmium hydrogen indium)) (check-eq? (first '(hahnium helium holmium hydrogen indium))
'hahnium)) 'hahnium))
;; SECOND ;; SECOND
(make-test-case (test-case
"second:of-two" "second:of-two"
(assert-eq? (second '(iodine iridium)) 'iridium)) (check-eq? (second '(iodine iridium)) 'iridium))
(make-test-case (test-case
"second:of-many" "second:of-many"
(assert-eq? (second '(iron krypton lanthanum lawrencium lead lithium)) (check-eq? (second '(iron krypton lanthanum lawrencium lead lithium))
'krypton)) 'krypton))
;; THIRD ;; THIRD
(make-test-case (test-case
"third:of-three" "third:of-three"
(assert-eq? (third '(lutetium magnesium manganese)) (check-eq? (third '(lutetium magnesium manganese))
'manganese)) 'manganese))
(make-test-case (test-case
"third:of-many" "third:of-many"
(assert-eq? (third '(mendelevium mercury molybdenum neodymium neon (check-eq? (third '(mendelevium mercury molybdenum neodymium neon
neptunium nickel)) neptunium nickel))
'molybdenum)) 'molybdenum))
;; FOURTH ;; FOURTH
(make-test-case (test-case
"fourth:of-four" "fourth:of-four"
(assert-eq? (fourth '(niobium nitrogen nobelium osmium)) (check-eq? (fourth '(niobium nitrogen nobelium osmium))
'osmium)) 'osmium))
(make-test-case (test-case
"fourth:of-many" "fourth:of-many"
(assert-eq? (fourth '(oxygen palladium phosphorus platinum plutonium (check-eq? (fourth '(oxygen palladium phosphorus platinum plutonium
polonium potassium praseodymium)) polonium potassium praseodymium))
'platinum)) 'platinum))
;; FIFTH ;; FIFTH
(make-test-case (test-case
"fifth:of-five" "fifth:of-five"
(assert-eq? (fifth '(promethium protatctinium radium radon rhenium)) (check-eq? (fifth '(promethium protatctinium radium radon rhenium))
'rhenium)) 'rhenium))
(make-test-case (test-case
"fifth:of-many" "fifth:of-many"
(assert-eq? (fifth '(rhodium rubidium ruthenium rutherfordium samarium (check-eq? (fifth '(rhodium rubidium ruthenium rutherfordium samarium
scandium selenium silicon silver)) scandium selenium silicon silver))
'samarium)) 'samarium))
;; SIXTH ;; SIXTH
(make-test-case (test-case
"sixth:of-six" "sixth:of-six"
(assert-eq? (sixth '(sodium strontium sulfur tantalum technetium (check-eq? (sixth '(sodium strontium sulfur tantalum technetium
tellurium)) tellurium))
'tellurium)) 'tellurium))
(make-test-case (test-case
"sixth:of-many" "sixth:of-many"
(assert-eq? (sixth '(terbium thallium thorium thulium tin titanium (check-eq? (sixth '(terbium thallium thorium thulium tin titanium
tungsten uranium vanadium xenon)) tungsten uranium vanadium xenon))
'titanium)) 'titanium))
;; SEVENTH ;; SEVENTH
(make-test-case (test-case
"seventh:of-seven" "seventh:of-seven"
(assert-eq? (seventh '(ytterbium yttrium zinc zirconium acacia abele (check-eq? (seventh '(ytterbium yttrium zinc zirconium acacia abele
ailanthus)) ailanthus))
'ailanthus)) 'ailanthus))
(make-test-case (test-case
"seventh:of-many" "seventh:of-many"
(assert-eq? (seventh '(alder allspice almond apple apricot ash aspen (check-eq? (seventh '(alder allspice almond apple apricot ash aspen
avocado balsa balsam banyan)) avocado balsa balsam banyan))
'aspen)) 'aspen))
;; EIGHTH ;; EIGHTH
(make-test-case (test-case
"eighth:of-eight" "eighth:of-eight"
(assert-eq? (eighth '(basswood bay bayberry beech birch boxwood breadfruit (check-eq? (eighth '(basswood bay bayberry beech birch boxwood breadfruit
buckeye)) buckeye))
'buckeye)) 'buckeye))
(make-test-case (test-case
"eighth:of-many" "eighth:of-many"
(assert-eq? (eighth '(butternut buttonwood cacao candleberry cashew cassia (check-eq? (eighth '(butternut buttonwood cacao candleberry cashew cassia
catalpa cedar cherry chestnut chinaberry catalpa cedar cherry chestnut chinaberry
chinquapin)) chinquapin))
'cedar)) 'cedar))
;; NINTH ;; NINTH
(make-test-case (test-case
"ninth:of-nine" "ninth:of-nine"
(assert-eq? (ninth '(cinnamon citron clove coconut cork cottonwood cypress (check-eq? (ninth '(cinnamon citron clove coconut cork cottonwood cypress
date dogwood)) date dogwood))
'dogwood)) 'dogwood))
(make-test-case (test-case
"ninth:of-many" "ninth:of-many"
(assert-eq? (ninth '(ebony elder elm eucalyptus ficus fig fir frankincense (check-eq? (ninth '(ebony elder elm eucalyptus ficus fig fir frankincense
ginkgo grapefruit guava gum hawthorn)) ginkgo grapefruit guava gum hawthorn))
'ginkgo)) 'ginkgo))
;; TENTH ;; TENTH
(make-test-case (test-case
"tenth:of-ten" "tenth:of-ten"
(assert-eq? (tenth '(hazel hemlock henna hickory holly hornbeam ironwood (check-eq? (tenth '(hazel hemlock henna hickory holly hornbeam ironwood
juniper kumquat laburnum)) juniper kumquat laburnum))
'laburnum)) 'laburnum))
(make-test-case (test-case
"tenth:of-many" "tenth:of-many"
(assert-eq? (tenth '(lancewood larch laurel lemon lime linden litchi (check-eq? (tenth '(lancewood larch laurel lemon lime linden litchi
locust logwood magnolia mahogany mango locust logwood magnolia mahogany mango
mangrove maple)) mangrove maple))
'magnolia)) 'magnolia))
;; CAR+CDR ;; CAR+CDR
(make-test-case (test-case
"car+cdr:pair" "car+cdr:pair"
(let-values (((first second) (car+cdr (cons 'a 'b)))) (let-values (((first second) (car+cdr (cons 'a 'b))))
(assert-eq? first 'a) (check-eq? first 'a)
(assert-eq? second 'b))) (check-eq? second 'b)))
(make-test-case (test-case
"car+cdr:list" "car+cdr:list"
(let-values (((first second) (car+cdr (list 'a 'b)))) (let-values (((first second) (car+cdr (list 'a 'b))))
(assert-eq? first 'a) (check-eq? first 'a)
(assert-equal? second (list 'b)))) (check-equal? second (list 'b))))
;; TAKE ;; TAKE
(make-test-case (test-case
"take:all-of-list" "take:all-of-list"
(assert-equal? (take '(medlar mimosa mulberry nutmeg oak) 5) (check-equal? (take '(medlar mimosa mulberry nutmeg oak) 5)
'(medlar mimosa mulberry nutmeg oak))) '(medlar mimosa mulberry nutmeg oak)))
(make-test-case (test-case
"take:front-of-list" "take:front-of-list"
(assert-equal? (take '(olive orange osier palm papaw peach pear) 5) (check-equal? (take '(olive orange osier palm papaw peach pear) 5)
'(olive orange osier palm papaw))) '(olive orange osier palm papaw)))
(make-test-case (test-case
"take:rear-of-list" "take:rear-of-list"
(assert-equal? (check-equal?
(take-right '(pecan persimmon pine pistachio plane plum pomegranite) 5) (take-right '(pecan persimmon pine pistachio plane plum pomegranite) 5)
'(pine pistachio plane plum pomegranite))) '(pine pistachio plane plum pomegranite)))
(make-test-case (test-case
"take:none-of-list" "take:none-of-list"
(assert-true (null? (take '(poplar quince redwood) 0)))) (check-true (null? (take '(poplar quince redwood) 0))))
(make-test-case (test-case
"take:empty-list" "take:empty-list"
(assert-true (null? (take '() 0)))) (check-true (null? (take '() 0))))
;; DROP ;; DROP
(make-test-case (test-case
"drop:all-of-list" "drop:all-of-list"
(assert-true (null? (drop '(rosewood sandalwood sassfras satinwood senna) 5)))) (check-true (null? (drop '(rosewood sandalwood sassfras satinwood senna) 5))))
(make-test-case (test-case
"drop:front-of-list" "drop:front-of-list"
(assert-equal? (drop '(sequoia serviceberry spruce sycamore tamarack tamarind (check-equal? (drop '(sequoia serviceberry spruce sycamore tamarack tamarind
tamarugo) tamarugo)
5) 5)
'(tamarind tamarugo))) '(tamarind tamarugo)))
(make-test-case (test-case
"drop:rear-of-list" "drop:rear-of-list"
(assert-equal? (drop-right '(tangerine teak thuja torchwood upas walnut wandoo) 5) (check-equal? (drop-right '(tangerine teak thuja torchwood upas walnut wandoo) 5)
'(tangerine teak))) '(tangerine teak)))
(make-test-case (test-case
"drop:none-of-list" "drop:none-of-list"
(assert-equal? (drop '(whitebeam whitethorn wicopy) 0) (check-equal? (drop '(whitebeam whitethorn wicopy) 0)
'(whitebeam whitethorn wicopy))) '(whitebeam whitethorn wicopy)))
(make-test-case (test-case
"drop:empty-list" "drop:empty-list"
(assert-true (null? (drop '() 0)))) (check-true (null? (drop '() 0))))
;; TAKE! ;; TAKE!
@ -250,14 +250,14 @@
;; with the LIST procedure rather than as quoted data, since in ;; with the LIST procedure rather than as quoted data, since in
;; some implementations quoted data are not mutable. ;; some implementations quoted data are not mutable.
(make-test-case (test-case
"take!:all-of-list" "take!:all-of-list"
(assert-equal? (take! (list 'willow 'woollybutt 'wychelm 'yellowwood 'yew) 5) (check-equal? (take! (list 'willow 'woollybutt 'wychelm 'yellowwood 'yew) 5)
'(willow woollybutt wychelm yellowwood yew))) '(willow woollybutt wychelm yellowwood yew)))
(make-test-case (test-case
"take!:front-of-list" "take!:front-of-list"
(assert-equal? (take! (list 'ylang-ylang 'zebrawood 'affenpinscher 'afghan (check-equal? (take! (list 'ylang-ylang 'zebrawood 'affenpinscher 'afghan
'airedale 'alsatian 'barbet) 'airedale 'alsatian 'barbet)
5) 5)
'(ylang-ylang zebrawood affenpinscher afghan airedale))) '(ylang-ylang zebrawood affenpinscher afghan airedale)))
@ -270,69 +270,69 @@
; (equal? result '(beagle bloodhound boarhound borzoi ; (equal? result '(beagle bloodhound boarhound borzoi
; boxer)))) ; boxer))))
(make-test-case (test-case
"take!:none-of-list" "take!:none-of-list"
(assert-true (null? (take! (list 'briard 'bulldog 'chihuahua) 0)))) (check-true (null? (take! (list 'briard 'bulldog 'chihuahua) 0))))
(make-test-case (test-case
"take!:empty-list" "take!:empty-list"
(assert-true (null? (take! '() 0)))) (check-true (null? (take! '() 0))))
;; DROP-RIGHT! ;; DROP-RIGHT!
(make-test-case (test-case
"drop-right!:all-of-list" "drop-right!:all-of-list"
(assert-true (null? (drop-right! (list 'chow 'collie 'coonhound 'clydesdale 'dachshund) (check-true (null? (drop-right! (list 'chow 'collie 'coonhound 'clydesdale 'dachshund)
5)))) 5))))
(make-test-case (test-case
"drop-right!:rear-of-list" "drop-right!:rear-of-list"
(assert-equal? (drop-right! (list 'groenendael 'harrier 'hound 'husky 'keeshond (check-equal? (drop-right! (list 'groenendael 'harrier 'hound 'husky 'keeshond
'komondor 'kuvasz) 'komondor 'kuvasz)
5) 5)
'(groenendael harrier))) '(groenendael harrier)))
(make-test-case (test-case
"drop-right!:none-of-list" "drop-right!:none-of-list"
(assert-equal? (drop-right! (list 'labrador 'malamute 'malinois) 0) (check-equal? (drop-right! (list 'labrador 'malamute 'malinois) 0)
'(labrador malamute malinois))) '(labrador malamute malinois)))
(make-test-case (test-case
"drop-right!:empty-list" "drop-right!:empty-list"
(assert-true (null? (drop-right! '() 0)))) (check-true (null? (drop-right! '() 0))))
;; LAST ;; LAST
(make-test-case (test-case
"last:of-singleton" "last:of-singleton"
(assert-eq? (last '(maltese)) (check-eq? (last '(maltese))
'maltese)) 'maltese))
(make-test-case (test-case
"last:of-longer-list" "last:of-longer-list"
(assert-eq? (last '(mastiff newfoundland nizinny otterhound papillon)) (check-eq? (last '(mastiff newfoundland nizinny otterhound papillon))
'papillon)) 'papillon))
;; LAST-PAIR ;; LAST-PAIR
(make-test-case (test-case
"last-pair:of-singleton" "last-pair:of-singleton"
(let ((pair '(pekingese))) (let ((pair '(pekingese)))
(assert-eq? (last-pair pair) (check-eq? (last-pair pair)
pair))) pair)))
(make-test-case (test-case
"last-pair:of-longer-list" "last-pair:of-longer-list"
(let ((pair '(pointer))) (let ((pair '(pointer)))
(assert-eq? (last-pair (cons 'pomeranian (check-eq? (last-pair (cons 'pomeranian
(cons 'poodle (cons 'poodle
(cons 'pug (cons 'puli pair))))) (cons 'pug (cons 'puli pair)))))
pair))) pair)))
(make-test-case (test-case
"last-pair:of-improper-list" "last-pair:of-improper-list"
(let ((pair '(manx . siamese))) (let ((pair '(manx . siamese)))
(assert-eq? (last-pair (cons 'abyssinian (cons 'calico pair))) (check-eq? (last-pair (cons 'abyssinian (cons 'calico pair)))
pair))) pair)))
)) ))

82
collects/tests/srfi/13/string-test.ss Normal file
View File

@ -0,0 +1,82 @@
;;;
;;; <string-test.ss> ---- SRFI-13 (string) tests
;;; Time-stamp: <06/06/09 16:05:08 nhw>
;;;
;;; Copyright (C) 2002 by Francisco Solsona.
;;;
;;; This file is part of PLT SRFI.
;;; PLT SRFI is free software; you can redistribute it and/or
;;; modify it under the terms of the GNU Lesser General Public
;;; License as published by the Free Software Foundation; either
;;; version 2.1 of the License, or (at your option) any later version.
;;; PLT SRFI is distributed in the hope that it will be useful,
;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
;;; Lesser General Public License for more details.
;;; You should have received a copy of the GNU Lesser General Public
;;; License along with PLT SRFI; if not, write to the Free Software
;;; Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
;;; Author: Francisco Solsona <solsona@acm.org>
;;
;;
;; Commentary:
(module string-test mzscheme
;; Noel's Test Framework: (get your copy @ schematics.sourceforge.net)
(require (planet "test.ss" ("schematics" "schemeunit.plt" 2))
(lib "string.ss" "srfi" "13")
(lib "char-set.ss" "srfi" "14")
)
(provide string-tests)
(define string-tests
(let ((abc null)
(cba null)
(test-string "This is a simple test string to generate a very simple char set!")
)
(test-suite
"String tests"
(test-case "string? test 1"
(check-true (string? test-string)))
(test-case "string? test 2"
(check-true (not (string? 'hello))))
(test-case "string-null? test 1"
(check-true (string-null? "")))
(test-case "string-null? test 2"
(check-true (not (string-null? "not empty"))))
(test-case "string-every test 1 (all #\a)"
(check-true (string-every #\a "aaaaaaaa")))
(test-case "string-every test 2 (charset a b c)"
(check-true (string-every
(char-set #\a #\b #\c)
"baacaaaabbaa")))
(test-case "string-every test 3 (pred vowel?)"
(check-true (string-every vowel? "aeiou")))
;; string-every char/char-set/pred s [start end] -> value
;; string-any char/char-set/pred s [start end] -> value
)))
(define vowel?
(lambda (v)
(and (char? v)
(or (char=? v #\a) (char=? v #\e) (char=? v #\i) (char=? v #\o) (char=? v #\u)))))
)
;;; string-test.ss ends here

237
collects/tests/srfi/14/char-set-test.ss Normal file
View File

@ -0,0 +1,237 @@
;;;
;;; <char-set-test.ss> ---- Test driver for the SRFI-14 port: char-set
;;; Time-stamp: <06/06/09 16:38:25 nhw>
;;;
;;; Copyright (C) 2002 by Francisco Solsona.
;;;
;;; This file is part of PLT SRFI.
;;; PLT SRFI is free software; you can redistribute it and/or
;;; modify it under the terms of the GNU Lesser General Public
;;; License as published by the Free Software Foundation; either
;;; version 2.1 of the License, or (at your option) any later version.
;;; PLT SRFI is distributed in the hope that it will be useful,
;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
;;; Lesser General Public License for more details.
;;; You should have received a copy of the GNU Lesser General Public
;;; License along with PLT SRFI; if not, write to the Free Software
;;; Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
;;; Author: Francisco Solsona <solsona@acm.org>
;;
;;
;; Commentary:
(module char-set-test mzscheme
(require (planet "test.ss" ("schematics" "schemeunit.plt" 2))
(lib "char-set.ss" "srfi" "14")
)
(provide char-set-tests)
(define char-set-tests
(test-suite
"Char-Set tests"
(test-case
"char-set? correct"
(check-false (char-set? null))
(check-true (char-set? (char-set #\a #\b #\c))))
(test-case
"char-set= equality"
(let ((abc (char-set #\a #\b #\c)))
(check-true (char-set= abc (char-set #\a #\b #\c)))))
(test-case
"char-set<= test 1 (strictly less than)"
(check-true (char-set<= (char-set #\a #\b #\c)
(char-set #\a #\b #\c #\d))))
(test-case
"char-set<= test 2 (equal)"
(check-true (char-set<= (char-set #\a #\b #\c)
(char-set #\a #\b #\c))))
(test-case
"Hash invariant (default bound)"
(check-eqv? (char-set-hash char-set:ascii)
(char-set-hash char-set:ascii)))
(test-case
"Char set cursor test"
(let ((abc (char-set #\a #\b #\c)))
(check-equal?
(let lp ((cur (char-set-cursor abc)) (ans '()))
(if (end-of-char-set? cur) ans
(lp (char-set-cursor-next abc cur)
(cons (char-set-ref abc cur) ans))))
'(#\c #\b #\a))))
(test-case
"char-set-fold test 1 (cs members)"
(check-equal? (char-set-fold cons '() (char-set #\a #\b #\c))
'(#\c #\b #\a)))
(test-case
"char-set-fold test 2 (cs size)"
(check-eqv? (char-set-fold (lambda (c i) (+ i 1)) 0 (char-set #\a #\b #\c))
3))
(test-case
"char-set-fold test 3 (how many vowels in cs)"
(check-eqv? (char-set-fold (lambda (c i) (if (vowel? c) (+ i 1) i))
0 (char-set #\a #\b #\c))
1))
(test-case
"char-set-unfold test 1 (string-port->char-set)"
(check-equal?
;; FIXME: We haven't see if char-set->string works, and we are using it.
(char-set->string
((lambda (sp)
(char-set-unfold eof-object? values
(lambda (x) (read-char sp))
(read-char sp)))
(open-input-string "This is a simple test string to generate a very simple char set!")))
"yvtsrponmlihgecaT! "))
(test-case
"char-set-for-each (dummy, really)"
(begin
(char-set-for-each (lambda (c)
(char? c)) (char-set #\a #\b #\c))
(check-true #t)))
(test-case
"char-set-map test 1 (downcase)"
(check-true
(char-set=
(char-set-map char-downcase (char-set #\A #\b #\C))
(char-set #\a #\b #\c))))
(test-case
"char-set-copy (copy constructor)"
(check-true
(let* ((orig (char-set #\a #\b #\c))
(copy (char-set-copy orig)))
(and (char-set= orig copy)
(not (char-set=
(char-set-difference orig (char-set #\a))
copy))))))
(test-case
"list->char-set test 1 (using empty char-set)"
(check-true
(char-set= (list->char-set '(#\a #\b #\c #\a #\b #\a))
(char-set #\a #\b #\c))))
(test-case
"list->char-set test 2 (adding to an existent char-set)"
(check-true
(let ((c (char-set #\a #\b)))
(and
(char-set= (list->char-set '(#\a #\b #\c #\a #\b #\a) c)
(char-set #\a #\b #\c))
;; It has to be non-destructive:
(char-set= c (char-set #\a #\b))))))
(test-case
"list->char-set! (destructive addition)"
(let ((c (char-set #\a #\b)))
(check
char-set=
(list->char-set! '(#\a #\b #\c #\a #\b #\a) c)
(char-set #\a #\b #\c))))
(test-case
"string->char-set test 1 (using empty char-set)"
(check-true
(char-set= (string->char-set "aaaabbaaccc")
(char-set #\a #\b #\c))))
(test-case
"string->char-set test 2 (using a non empty char-set)"
(check-true
(let ((c (char-set #\a #\b)))
(and
(char-set= (string->char-set "aaabbbaaaccc" c)
(char-set #\a #\b #\c))
;; It has to be non-destructive:
(char-set= c (char-set #\a #\b))))))
(test-case
"string->char-set! (destructive addition)"
(let ((c (char-set #\a #\b)))
(check
char-set=
(string->char-set! "aaabbbaaaccc" c)
(char-set #\a #\b #\c))))
(test-case
"char-set-filter test 1 (using an empty set)"
(check-true
(char-set= (char-set-filter vowel? (char-set #\a #\b #\a #\e #\i #\c #\c #\d))
(char-set #\a #\e #\i))))
(test-case
"char-set-filter test 2 (using a non empty char-set)"
(check-true
(let ((c (char-set #\a #\e)))
(and
(char-set= (char-set-filter vowel? (char-set #\a #\b #\a #\e #\i #\c #\c #\d) c)
(char-set #\a #\e #\i))
;; It has to be non destructive
(char-set= c (char-set #\a #\e))))))
(test-case
"char-set-filter! test (using a non empty char-set)"
(let ((c (char-set #\a #\e)))
(check
char-set=
(char-set-filter! vowel? (char-set #\a #\b #\a #\e #\i #\c #\c #\d) c)
(char-set #\a #\e #\i))))
;; MISSIGN:
;; ucs-range->char-set, ucs-range->char-set!
;; ->char-set
(test-case
"char-set-size test"
(check-true (= (char-set-size (char-set #\a #\b #\c)) 3)))
(test-case
"char-set-count test"
(check-true (= (char-set-count vowel? (char-set #\a #\b #\a #\e #\i #\z)) 3)))
(test-case
"char-set->list test"
(check-true
(let ((l (char-set->list (char-set #\a #\b #\c))))
(and (pair? l) (= (length l) 3)))))
(test-case
"char-set->string test"
(check-true
(string=? (char-set->string (char-set #\a #\b #\c)) "cba")))
(test-case
"char-set-contains? test (if there)"
(check-true (char-set-contains? (char-set #\a #\b #\c) #\b)))
(test-case
"char-set-contains? test (if not there)"
(check-true (not (char-set-contains? (char-set #\a #\b #\c) #\z))))
))
(define vowel?
(lambda (v)
(and (char? v)
(or (char=? v #\a) (char=? v #\e) (char=? v #\i) (char=? v #\o) (char=? v #\u)))))
)
;;; char-set-test.ss ends here

194
collects/tests/srfi/2/and-let-test.ss Normal file
View File

@ -0,0 +1,194 @@
;;;
;;; <and-let-test.ss> ---- and-let* macro tests
;;; Time-stamp: <06/06/09 15:58:59 nhw>
;;;
;;; Copyright (C) 2002 by Francisco Solsona.
;;;
;;; This file is part of PLT SRFI.
;;; PLT SRFI is free software; you can redistribute it and/or
;;; modify it under the terms of the GNU Lesser General Public
;;; License as published by the Free Software Foundation; either
;;; version 2.1 of the License, or (at your option) any later version.
;;; PLT SRFI is distributed in the hope that it will be useful,
;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
;;; Lesser General Public License for more details.
;;; You should have received a copy of the GNU Lesser General Public
;;; License along with PLT SRFI; if not, write to the Free Software
;;; Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
;;; Author: Francisco Solsona <solsona@acm.org>
;;
;;
;; Commentary:
(module and-let-test mzscheme
(require (planet "test.ss" ("schematics" "schemeunit.plt" 2))
(lib "and-let.ss" "srfi" "2"))
(provide and-let*-tests)
(define and-let*-tests
(test-suite
"and-let* tests"
(test-case "empty body 1"
;; check-true, check-eqv?, etc.
(check-eqv? (and-let* () ) #t))
(test-case "empty claws 1"
(check-eqv? (and-let* () 1) 1))
(test-case "empty claws 2"
(check-eqv? (and-let* () 1 2) 2))
(test-case "singleton claw 1"
(check-eqv? (let ((x #f))
(and-let* (x)))
#f))
(test-case "singleton claw 2"
(check-eqv? (let ((x 1))
(and-let* (x)))
1))
(test-case "let-like assignment 1"
(check-eqv? (and-let* ((x #f))) #f))
(test-case "let-like assignment 2"
(check-eqv? (and-let* ((x 1))) 1))
;;(test-case "gotta break 1"
;; (check-true (and-let* (#f (x 1)))))
(test-case "mixed claws 1"
(check-eqv? (and-let* ((#f) (x 1))) #f))
;; (test-case "gotta break 2"
;; (check-true (and-let* (2 (x 1)))))
(test-case "mixed claws 2"
(check-eqv? (and-let* ((2) (x 1))) 1))
(test-case "mixed claws 3"
(check-eqv? (and-let* ((x 1) (2))) 2))
(test-case "simple claw 1"
(check-eqv?
(let ((x #f))
(and-let* (x) x))
#f))
(test-case "simple claw 2"
(check-equal?
(let ((x ""))
(and-let* (x) x))
""))
(test-case "simple claw 3"
(check-equal?
(let ((x ""))
(and-let* (x)))
""))
(test-case "simple claw 4"
(check-eqv?
(let ((x 1))
(and-let* (x) (+ x 1)))
2))
(test-case "simple claw 5"
(check-eqv?
(let ((x #f))
(and-let* (x) (+ x 1)))
#f))
(test-case "simple claw 6"
(check-eqv?
(let ((x 1))
(and-let* (((positive? x))) (+ x 1)))
2))
(test-case "simple claw 7"
(check-eqv?
(let ((x 1))
(and-let* (((positive? x)))))
#t))
(test-case "simple claw 8"
(check-eqv?
(let ((x 0))
(and-let* (((positive? x))) (+ x 1)))
#f))
(test-case "simple claw 9"
(check-eqv?
(let ((x 1))
(and-let* (((positive? x)) (x (+ x 1))) (+ x 1)))
3))
;; (test-case "gotta break 3"
;; (check-true (and-let* (((positive? x)) (x (+ x 1)) (x (+ x 1))) (+ x 1))))
(test-case "complex claw 1"
(check-eqv?
(let ((x 1))
(and-let* (x ((positive? x))) (+ x 1)))
2))
(test-case "complex claw 2"
(check-eqv?
(let ((x 1))
(and-let* (((begin x)) ((positive? x))) (+ x 1)))
2))
(test-case "complex claw 3"
(check-eqv?
(let ((x 0))
(and-let* (x ((positive? x))) (+ x 1)))
#f))
(test-case "complex claw 4"
(check-eqv?
(let ((x #f))
(and-let* (x ((positive? x))) (+ x 1)))
#f))
(test-case "complex claw 5"
(check-eqv?
(let ((x #f))
(and-let* (((begin x)) ((positive? x))) (+ x 1)))
#f))
(test-case "funky claw 1"
(check-eqv?
(let ((x 1))
(and-let* (x (y (- x 1)) ((positive? y))) (/ x y)))
#f))
(test-case "funky claw 2"
(check-eqv?
(let ((x 0))
(and-let* (x (y (- x 1)) ((positive? y))) (/ x y)))
#f))
(test-case "funky claw 3"
(check-eqv?
(let ((x #f))
(and-let* (x (y (- x 1)) ((positive? y))) (/ x y)))
#f))
(test-case "funky claw 4"
(check-eqv?
(let ((x 3))
(and-let* (x (y (- x 1)) ((positive? y))) (/ x y)))
3/2))
))
)
;;; and-let-test.ss ends here

83
collects/tests/srfi/26/cut-test.ss Normal file
View File

@ -0,0 +1,83 @@
;;;
;;; <cut-test.ss> ---- SRFI 26 tests
;;; Time-stamp: <06/06/09 16:04:14 nhw>
;;;
;;; Usually, I would add a copyright notice, and the announce that
;;; this code is under the LGPL licence. However, I only did the
;;; port to PLT Scheme, the original comment follows:
; CONFIDENCE TEST FOR IMPLEMENTATION OF SRFI-26
; =============================================
;
; Sebastian.Egner@philips.com, 3-Jun-2002.
;
; This file checks a few checks about the implementation.
; If you run it and no error message is issued, the implementation
; is correct on the cases that have been tested.
;
; compliance:
; Scheme R5RS with
; SRFI-23: error
;
; $Id: cut-test.ss,v 1.1 2002/06/20 15:40:52 noel Exp $
(module cut-test mzscheme
(require (planet "test.ss" ("schematics" "schemeunit.plt" 2))
(lib "cut.ss" "srfi" "26"))
(provide cut-tests)
(define cut-tests
(test-suite
"Cut (SRFI 26) Tests"
(test-case
"Cut test"
(begin
(check-equal? ((cut list)) '())
(check-equal? ((cut list <...>)) '())
(check-equal? ((cut list 1)) '(1))
(check-equal? ((cut list <>) 1) '(1))
(check-equal? ((cut list <...>) 1) '(1))
(check-equal? ((cut list 1 2)) '(1 2))
(check-equal? ((cut list 1 <>) 2) '(1 2))
(check-equal? ((cut list 1 <...>) 2) '(1 2))
(check-equal? ((cut list 1 <...>) 2 3 4) '(1 2 3 4))
(check-equal? ((cut list 1 <> 3 <>) 2 4) '(1 2 3 4))
(check-equal? ((cut list 1 <> 3 <...>) 2 4 5 6) '(1 2 3 4 5 6))
(check-equal?
(let* ((x 'wrong) (y (cut list x)))
(set! x 'ok) (y))
'(ok))
(check-equal?
(let ((a 0))
(map (cut + (begin (set! a (+ a 1)) a) <>)
'(1 2))
a)
2)))
(test-case
"Cute test"
(begin
(check-equal? ((cute list)) '())
(check-equal? ((cute list <...>)) '())
(check-equal? ((cute list 1)) '(1))
(check-equal? ((cute list <>) 1) '(1))
(check-equal? ((cute list <...>) 1) '(1))
(check-equal? ((cute list 1 2)) '(1 2))
(check-equal? ((cute list 1 <>) 2) '(1 2))
(check-equal? ((cute list 1 <...>) 2) '(1 2))
(check-equal? ((cute list 1 <...>) 2 3 4) '(1 2 3 4))
(check-equal? ((cute list 1 <> 3 <>) 2 4) '(1 2 3 4))
(check-equal? ((cute list 1 <> 3 <...>) 2 4 5 6) '(1 2 3 4 5 6))
(check-equal?
(let ((a 0))
(map (cute + (begin (set! a (+ a 1)) a) <>)
'(1 2))
a)
1)))
))
)
;;; cut-test.scm ends here

112
collects/tests/srfi/69/hash-tests.ss
View File

@ -1,6 +1,6 @@
(module hash-tests mzscheme (module hash-tests mzscheme
(require (planet "test.ss" ("schematics" "schemeunit.plt" 1 1))) (require (planet "test.ss" ("schematics" "schemeunit.plt" 2)))
(require (lib "list.ss" "srfi" "1") (require (lib "list.ss" "srfi" "1")
(prefix h: (lib "69.ss" "srfi"))) (prefix h: (lib "69.ss" "srfi")))
@ -13,120 +13,120 @@
(h:alist->hash-table '(("a" . 1) ("b" . 2) ("c" . 3)) string-ci=? h:string-ci-hash)) (h:alist->hash-table '(("a" . 1) ("b" . 2) ("c" . 3)) string-ci=? h:string-ci-hash))
(define hash-tests (define hash-tests
(make-test-suite (test-suite
"srfi-69 test suite" "srfi-69 test suite"
(make-test-case (test-case
"make-hash-table and hash-table?" "make-hash-table and hash-table?"
(assert-true (check-true
(h:hash-table? (h:make-hash-table)))) (h:hash-table? (h:make-hash-table))))
(make-test-case (test-case
"alist->hash-table" "alist->hash-table"
(assert-true (check-true
(h:hash-table? test-hash-table1))) (h:hash-table? test-hash-table1)))
(make-test-case (test-case
"hash-table-equivalence-function" "hash-table-equivalence-function"
(assert-eq? (check-eq?
(h:hash-table-equivalence-function (h:make-hash-table)) (h:hash-table-equivalence-function (h:make-hash-table))
equal?) equal?)
(assert-eq? (check-eq?
(h:hash-table-equivalence-function (h:make-hash-table eq?)) (h:hash-table-equivalence-function (h:make-hash-table eq?))
eq?) eq?)
(assert-eq? (check-eq?
(h:hash-table-equivalence-function test-hash-table2) (h:hash-table-equivalence-function test-hash-table2)
string-ci=?)) string-ci=?))
(make-test-case (test-case
"hash-table-hash-function" "hash-table-hash-function"
(assert-eq? (check-eq?
(h:hash-table-hash-function (h:make-hash-table)) (h:hash-table-hash-function (h:make-hash-table))
h:hash) h:hash)
(assert-eq? (check-eq?
(h:hash-table-hash-function (h:make-hash-table eq?)) (h:hash-table-hash-function (h:make-hash-table eq?))
h:hash-by-identity) h:hash-by-identity)
(assert-eq? (check-eq?
(h:hash-table-hash-function test-hash-table2) (h:hash-table-hash-function test-hash-table2)
h:string-ci-hash)) h:string-ci-hash))
(make-test-case (test-case
"hash-table-ref" "hash-table-ref"
(assert-equal? (check-equal?
(h:hash-table-ref test-hash-table1 'b) (h:hash-table-ref test-hash-table1 'b)
2) 2)
(assert-equal? (check-equal?
(h:hash-table-ref test-hash-table2 "C") (h:hash-table-ref test-hash-table2 "C")
3) 3)
(assert-false (check-false
(h:hash-table-ref test-hash-table1 'd (lambda () #f)))) (h:hash-table-ref test-hash-table1 'd (lambda () #f))))
(make-test-case (test-case
"hash-table-ref/default" "hash-table-ref/default"
(assert-false (check-false
(h:hash-table-ref/default test-hash-table2 "d" #f))) (h:hash-table-ref/default test-hash-table2 "d" #f)))
(make-test-case (test-case
"hash-table-set!" "hash-table-set!"
(assert-equal? (check-equal?
(begin (h:hash-table-set! test-hash-table1 'c 4) (begin (h:hash-table-set! test-hash-table1 'c 4)
(h:hash-table-ref test-hash-table1 'c)) (h:hash-table-ref test-hash-table1 'c))
4) 4)
(assert-equal? (check-equal?
(begin (h:hash-table-set! test-hash-table2 "d" 4) (begin (h:hash-table-set! test-hash-table2 "d" 4)
(h:hash-table-ref test-hash-table2 "D")) (h:hash-table-ref test-hash-table2 "D"))
4)) 4))
(make-test-case (test-case
"hash-table-delete!" "hash-table-delete!"
(assert-false (check-false
(begin (h:hash-table-delete! test-hash-table2 "D") (begin (h:hash-table-delete! test-hash-table2 "D")
(h:hash-table-ref/default test-hash-table2 "d" #f)))) (h:hash-table-ref/default test-hash-table2 "d" #f))))
(make-test-case (test-case
"hash-table-exists?" "hash-table-exists?"
(assert-true (check-true
(h:hash-table-exists? test-hash-table2 "B")) (h:hash-table-exists? test-hash-table2 "B"))
(assert-false (check-false
(h:hash-table-exists? test-hash-table1 'd))) (h:hash-table-exists? test-hash-table1 'd)))
(make-test-case (test-case
"hash-table-update!" "hash-table-update!"
(assert-equal? (check-equal?
(begin (h:hash-table-update! test-hash-table1 'c sub1) (begin (h:hash-table-update! test-hash-table1 'c sub1)
(h:hash-table-ref test-hash-table1 'c)) (h:hash-table-ref test-hash-table1 'c))
3) 3)
(assert-equal? (check-equal?
(begin (h:hash-table-update! test-hash-table2 "d" add1 (lambda () 3)) (begin (h:hash-table-update! test-hash-table2 "d" add1 (lambda () 3))
(h:hash-table-ref test-hash-table2 "d")) (h:hash-table-ref test-hash-table2 "d"))
4)) 4))
(make-test-case (test-case
"hash-table-update!/default" "hash-table-update!/default"
(assert-equal? (check-equal?
(begin (h:hash-table-update!/default test-hash-table1 'd add1 3) (begin (h:hash-table-update!/default test-hash-table1 'd add1 3)
(h:hash-table-ref test-hash-table1 'd)) (h:hash-table-ref test-hash-table1 'd))
4)) 4))
(make-test-case (test-case
"hash-table-size" "hash-table-size"
(assert-equal? (check-equal?
(h:hash-table-size test-hash-table1) (h:hash-table-size test-hash-table1)
4) 4)
(assert-equal? (check-equal?
(h:hash-table-size test-hash-table2) (h:hash-table-size test-hash-table2)
4)) 4))
(make-test-case (test-case
"hash-table-keys" "hash-table-keys"
(assert-true (check-true
(lset= eq? (lset= eq?
(h:hash-table-keys test-hash-table1) (h:hash-table-keys test-hash-table1)
'(a b c d))) '(a b c d)))
(assert-true (check-true
(lset= equal? (lset= equal?
(h:hash-table-keys test-hash-table2) (h:hash-table-keys test-hash-table2)
(list "a" "b" "c" "d")))) (list "a" "b" "c" "d"))))
(make-test-case (test-case
"hash-table-values" "hash-table-values"
(assert-true (check-true
(lset= eqv? (lset= eqv?
(h:hash-table-values test-hash-table1) (h:hash-table-values test-hash-table1)
'(1 2 3 4))) '(1 2 3 4)))
(assert-true (check-true
(lset= eqv? (lset= eqv?
(h:hash-table-values test-hash-table2) (h:hash-table-values test-hash-table2)
'(1 2 3 4)))) '(1 2 3 4))))
(make-test-case (test-case
"hash-table-walk" "hash-table-walk"
(assert-true (check-true
(let ((a '())) (let ((a '()))
(h:hash-table-walk test-hash-table1 (h:hash-table-walk test-hash-table1
(lambda (key value) (lambda (key value)
@ -134,9 +134,9 @@
(lset= equal? (lset= equal?
a a
'((a . 1) (b . 2) (c . 3) (d . 4)))))) '((a . 1) (b . 2) (c . 3) (d . 4))))))
(make-test-case (test-case
"hash-table-fold" "hash-table-fold"
(assert-true (check-true
(lset= equal? (lset= equal?
(h:hash-table-fold test-hash-table2 (h:hash-table-fold test-hash-table2
(lambda (key value accu) (lambda (key value accu)
@ -146,37 +146,37 @@
(cons "b" 2) (cons "b" 2)
(cons "c" 3) (cons "c" 3)
(cons "d" 4))))) (cons "d" 4)))))
(make-test-case (test-case
"hash-table->alist" "hash-table->alist"
(assert-true (check-true
(lset= equal? (lset= equal?
(h:hash-table->alist test-hash-table1) (h:hash-table->alist test-hash-table1)
'((a . 1) (b . 2) (c . 3) (d . 4))))) '((a . 1) (b . 2) (c . 3) (d . 4)))))
(make-test-case (test-case
"hash-table-copy" "hash-table-copy"
(assert-true (check-true
(lset= equal? (lset= equal?
(h:hash-table->alist (h:hash-table-copy test-hash-table2)) (h:hash-table->alist (h:hash-table-copy test-hash-table2))
(list (cons "a" 1) (list (cons "a" 1)
(cons "b" 2) (cons "b" 2)
(cons "c" 3) (cons "c" 3)
(cons "d" 4)))) (cons "d" 4))))
(assert-false (check-false
(eq? (h:hash-table-copy test-hash-table1) (eq? (h:hash-table-copy test-hash-table1)
test-hash-table1)) test-hash-table1))
(assert-eq? (check-eq?
(h:hash-table-equivalence-function (h:hash-table-equivalence-function
test-hash-table1) test-hash-table1)
(h:hash-table-equivalence-function (h:hash-table-equivalence-function
(h:hash-table-copy test-hash-table1))) (h:hash-table-copy test-hash-table1)))
(assert-eq? (check-eq?
(h:hash-table-hash-function (h:hash-table-hash-function
test-hash-table2) test-hash-table2)
(h:hash-table-hash-function (h:hash-table-hash-function
(h:hash-table-copy test-hash-table2)))) (h:hash-table-copy test-hash-table2))))
(make-test-case (test-case
"hash-table->alist" "hash-table->alist"
(assert-true (check-true
(lset= equal? (lset= equal?
(h:hash-table->alist (h:hash-table->alist
(h:hash-table-merge! test-hash-table1 (h:hash-table-merge! test-hash-table1
@ -189,7 +189,7 @@
(b . 2) (b . 2)
(c . 3) (c . 3)
(d . 4)))) (d . 4))))
(assert-true (check-true
(lset= equal? (lset= equal?
(h:hash-table->alist (h:hash-table->alist
(h:hash-table-merge! test-hash-table2 (h:hash-table-merge! test-hash-table2

12
collects/tests/srfi/all-srfi-tests.ss
View File

@ -1,26 +1,26 @@
(module all-srfi-tests mzscheme (module all-srfi-tests mzscheme
(require (planet "test.ss" ("schematics" "schemeunit.plt" 1 1))) (require (planet "test.ss" ("schematics" "schemeunit.plt" 2)))
(require "1/all-1-tests.ss" (require "1/all-1-tests.ss"
"2/and-let-test.ss" "2/and-let-test.ss"
"13/string-test.ss" "13/string-test.ss"
"14/char-set-test.ss" "14/char-set-test.ss"
"26/cut-test.ss" "26/cut-test.ss"
"40/all-srfi-40-tests.ss" ;"40/all-srfi-40-tests.ss"
"43/all-srfi-43-tests.ss" ;"43/all-srfi-43-tests.ss"
"69/hash-tests.ss") "69/hash-tests.ss")
(provide all-srfi-tests) (provide all-srfi-tests)
(define all-srfi-tests (define all-srfi-tests
(make-test-suite (test-suite
"all-srfi-tests" "all-srfi-tests"
all-1-tests all-1-tests
and-let*-tests and-let*-tests
string-tests string-tests
char-set-tests char-set-tests
cut-tests cut-tests
all-srfi-40-tests ;all-srfi-40-tests
all-srfi-43-tests ;all-srfi-43-tests
hash-tests hash-tests
)) ))
) )

4
collects/tests/srfi/run-tests.ss
View File

@ -1,5 +1,5 @@
(require (planet "test.ss" ("schematics" "schemeunit.plt" 1 1))) (require (planet "test.ss" ("schematics" "schemeunit.plt" 2)))
(require (planet "text-ui.ss" ("schematics" "schemeunit.plt" 1 1))) (require (planet "text-ui.ss" ("schematics" "schemeunit.plt" 2)))
(require "all-srfi-tests.ss") (require "all-srfi-tests.ss")
(test/text-ui all-srfi-tests) (test/text-ui all-srfi-tests)