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
svn: r3300
This commit is contained in:
Noel Welsh
parent
cc4f2270b7
commit
173e1e2ec3
|
|
@ -34,32 +34,32 @@
|
|||
|
||||
(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)
|
||||
(rename (lib "alist.ss" "srfi" "1") s:assoc assoc))
|
||||
|
||||
(provide alist-tests)
|
||||
|
||||
(define alist-tests
|
||||
(make-test-suite
|
||||
(test-suite
|
||||
"Association list tests"
|
||||
|
||||
;; ALIST-CONS
|
||||
|
||||
(make-test-case
|
||||
(test-case
|
||||
"alist-cons:null-list"
|
||||
(assert-equal? (alist-cons 'Manawa 'Manchester '())
|
||||
(check-equal? (alist-cons 'Manawa 'Manchester '())
|
||||
'((Manawa . Manchester))))
|
||||
|
||||
(make-test-case
|
||||
(test-case
|
||||
"alist-cons:singleton-list"
|
||||
(let* ((base '((Manilla . Manly)))
|
||||
(result (alist-cons 'Manning 'Manson base)))
|
||||
(assert-equal? result '((Manning . Manson)
|
||||
(check-equal? result '((Manning . Manson)
|
||||
(Manilla . Manly)))
|
||||
(assert-eq? (cdr result) base)))
|
||||
(check-eq? (cdr result) base)))
|
||||
|
||||
(make-test-case
|
||||
(test-case
|
||||
"alist-cons:longer-list"
|
||||
(let* ((base '((Manteno . Mapleside)
|
||||
(Mapleton . Maquoketa)
|
||||
|
|
@ -67,16 +67,16 @@
|
|||
(Marengo . Marietta)
|
||||
(Marion . Mark)))
|
||||
(result (alist-cons 'Marne 'Marquette base)))
|
||||
(assert-equal? result
|
||||
(check-equal? result
|
||||
'((Marne . Marquette)
|
||||
(Manteno . Mapleside)
|
||||
(Mapleton . Maquoketa)
|
||||
(Marathon . Marcus)
|
||||
(Marengo . Marietta)
|
||||
(Marion . Mark)))
|
||||
(assert-eq? (cdr result) base)))
|
||||
(check-eq? (cdr result) base)))
|
||||
|
||||
(make-test-case
|
||||
(test-case
|
||||
"alist-cons:longer-list-with-duplicate-key"
|
||||
(let* ((base '((Marquisville . Marsh)
|
||||
(Marshalltown . Martelle)
|
||||
|
|
@ -86,7 +86,7 @@
|
|||
(Massey . Massilon)
|
||||
(Matlock . Maud)))
|
||||
(result (alist-cons 'Masonville 'Maurice base)))
|
||||
(assert-equal? result '((Masonville . Maurice)
|
||||
(check-equal? result '((Masonville . Maurice)
|
||||
(Marquisville . Marsh)
|
||||
(Marshalltown . Martelle)
|
||||
(Martensdale . Martinsburg)
|
||||
|
|
@ -94,15 +94,15 @@
|
|||
(Masonville . Massena)
|
||||
(Massey . Massilon)
|
||||
(Matlock . Maud)))
|
||||
(assert-eq? (cdr result) base)))
|
||||
(check-eq? (cdr result) base)))
|
||||
|
||||
;; ALIST-COPY
|
||||
|
||||
(make-test-case
|
||||
(test-case
|
||||
"alist-copy:null-list"
|
||||
(assert-true (null? (alist-copy '()))))
|
||||
(check-true (null? (alist-copy '()))))
|
||||
|
||||
(make-test-case
|
||||
(test-case
|
||||
"alist-copy:flat-list"
|
||||
(let* ((original '((Maxon . Maxwell)
|
||||
(Maynard . Maysville)
|
||||
|
|
@ -110,7 +110,7 @@
|
|||
(McClelland . McGregor)
|
||||
(McIntire . McNally)))
|
||||
(result (alist-copy original)))
|
||||
(assert-true
|
||||
(check-true
|
||||
(and (equal? result original)
|
||||
(not (eq? result original))
|
||||
(not (eq? (car result) (car original)))
|
||||
|
|
@ -124,7 +124,7 @@
|
|||
(not (eq? (car (cddddr result))
|
||||
(car (cddddr original))))))))
|
||||
|
||||
(make-test-case
|
||||
(test-case
|
||||
"alist-copy:bush"
|
||||
(let* ((first '(McPaul))
|
||||
(second '(McPherson
|
||||
|
|
@ -137,7 +137,7 @@
|
|||
(cons 'Melvin second)
|
||||
(cons 'Menlo third)))
|
||||
(result (alist-copy original)))
|
||||
(assert-true
|
||||
(check-true
|
||||
(and (equal? result original)
|
||||
(not (eq? result original))
|
||||
(not (eq? (car result) (car original)))
|
||||
|
|
@ -151,20 +151,20 @@
|
|||
|
||||
;; ALIST-DELETE
|
||||
|
||||
(make-test-case
|
||||
(test-case
|
||||
"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"
|
||||
(assert-equal?
|
||||
(check-equal?
|
||||
(alist-delete 'Meriden
|
||||
'((Merrill . Merrimac)))
|
||||
'((Merrill . Merrimac))))
|
||||
|
||||
(make-test-case
|
||||
(test-case
|
||||
"alist-delete:all-elements-removed"
|
||||
(assert-true
|
||||
(check-true
|
||||
(null? (alist-delete 'Meservey
|
||||
'((Metz . Meyer)
|
||||
(Middleburg . Middletwon)
|
||||
|
|
@ -173,9 +173,9 @@
|
|||
(Miller . Millersburg))
|
||||
(lambda (x y) #t)))))
|
||||
|
||||
(make-test-case
|
||||
(test-case
|
||||
"alist-delete:some-elements-removed"
|
||||
(assert-equal?
|
||||
(check-equal?
|
||||
(alist-delete 561
|
||||
'((562 . 563)
|
||||
(565 . 564)
|
||||
|
|
@ -185,9 +185,9 @@
|
|||
(lambda (x y) (odd? (+ x y))))
|
||||
'((565 . 564) (569 . 568))))
|
||||
|
||||
(make-test-case
|
||||
(test-case
|
||||
"alist-delete:no-elements-removed"
|
||||
(assert-equal?
|
||||
(check-equal?
|
||||
(alist-delete 'Millerton
|
||||
'((Millman . Millnerville)
|
||||
(Millville . Milo)
|
||||
|
|
@ -203,20 +203,20 @@
|
|||
|
||||
;; ALIST-DELETE!
|
||||
|
||||
(make-test-case
|
||||
(test-case
|
||||
"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"
|
||||
(assert-equal?
|
||||
(check-equal?
|
||||
(alist-delete! 'Mitchellville
|
||||
(list (cons 'Modale 'Moingona)))
|
||||
'((Modale . Moingona))))
|
||||
|
||||
(make-test-case
|
||||
(test-case
|
||||
"alist-delete!:all-elements-removed"
|
||||
(assert-true
|
||||
(check-true
|
||||
(null?
|
||||
(alist-delete! 'Mona
|
||||
(list (cons 'Mondamin 'Moneta)
|
||||
|
|
@ -226,9 +226,9 @@
|
|||
(cons 'Montezuma 'Montgomery))
|
||||
(lambda (x y) #t)))))
|
||||
|
||||
(make-test-case
|
||||
(test-case
|
||||
"alist-delete!:some-elements-removed"
|
||||
(assert-equal?
|
||||
(check-equal?
|
||||
(alist-delete! 572
|
||||
(list (cons 573 574)
|
||||
(cons 576 575)
|
||||
|
|
@ -238,9 +238,9 @@
|
|||
(lambda (x y) (even? (+ x y))))
|
||||
'((573 . 574) (577 . 578) (581 . 582))))
|
||||
|
||||
(make-test-case
|
||||
(test-case
|
||||
"alist-delete!:no-elements-removed"
|
||||
(assert-equal?
|
||||
(check-equal?
|
||||
(alist-delete! 'Monti
|
||||
(list (cons 'Monticello 'Montour)
|
||||
(cons 'Montpelier 'Montrose)
|
||||
|
|
@ -255,26 +255,26 @@
|
|||
|
||||
;; ALIST-DELETE
|
||||
|
||||
(make-test-case
|
||||
(test-case
|
||||
"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"
|
||||
(assert-true (null?
|
||||
(check-true (null?
|
||||
(alist-delete '(Redfield . Reeceville)
|
||||
'(((Redfield . Reeceville) . Reinbeck))))))
|
||||
|
||||
(make-test-case
|
||||
(test-case
|
||||
"alist-delete:not-in-singleton-list"
|
||||
(assert-equal?
|
||||
(check-equal?
|
||||
(alist-delete '(Rembrandt . Remsen)
|
||||
'(((Renwick . Republic) . Rhodes)))
|
||||
'(((Renwick . Republic) . Rhodes))))
|
||||
|
||||
(make-test-case
|
||||
(test-case
|
||||
"alist-delete:at-beginning-of-longer-list"
|
||||
(assert-equal?
|
||||
(check-equal?
|
||||
(alist-delete '(Riceville . Richard)
|
||||
'(((Riceville . Richard) . Richfield)
|
||||
((Richland . Richmond) . Rickardsville)
|
||||
|
|
@ -286,9 +286,9 @@
|
|||
((Ridgeway . Riggs) . Rinard)
|
||||
((Ringgold . Ringsted) . Rippey))))
|
||||
|
||||
(make-test-case
|
||||
(test-case
|
||||
"alist-delete:in-middle-of-longer-list"
|
||||
(assert-equal?
|
||||
(check-equal?
|
||||
(alist-delete '(Ritter . Riverdale)
|
||||
'(((Riverside . Riverton) . Roberts)
|
||||
((Robertson . Robins) . Robinson)
|
||||
|
|
@ -304,9 +304,9 @@
|
|||
((Roelyn . Rogers) . Roland)
|
||||
((Rolfe . Rome) . Roscoe))))
|
||||
|
||||
(make-test-case
|
||||
(test-case
|
||||
"alist-delete:at-end-of-longer-list"
|
||||
(assert-equal?
|
||||
(check-equal?
|
||||
(alist-delete '(Rose . Roselle)
|
||||
'(((Roseville . Ross) . Rosserdale)
|
||||
((Rossie . Rossville) . Rowan)
|
||||
|
|
@ -318,9 +318,9 @@
|
|||
((Rowley . Royal) . Rubio)
|
||||
((Ruble . Rudd) . Runnells))))
|
||||
|
||||
(make-test-case
|
||||
(test-case
|
||||
"alist-delete:not-in-longer-list"
|
||||
(assert-equal?
|
||||
(check-equal?
|
||||
(alist-delete '(Ruthven . Rutland)
|
||||
'(((Rutledge . Ryan) . Sabula)
|
||||
((Sageville . Salem) . Salina)
|
||||
|
|
@ -333,9 +333,9 @@
|
|||
((Sandyville . Santiago) . Saratoga)
|
||||
((Sattre . Saude) . Savannah))))
|
||||
|
||||
(make-test-case
|
||||
(test-case
|
||||
"alist-delete:several-matches-in-longer-list"
|
||||
(assert-equal?
|
||||
(check-equal?
|
||||
(alist-delete '(Sawyer . Saylor)
|
||||
'(((Saylorville . Scarville) . Schaller)
|
||||
((Schleswig . Schley) . Sciola)
|
||||
|
|
@ -351,28 +351,28 @@
|
|||
|
||||
;; ALIST-DELETE!
|
||||
|
||||
(make-test-case
|
||||
(test-case
|
||||
"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"
|
||||
(assert-true
|
||||
(check-true
|
||||
(null?
|
||||
(alist-delete! (cons 'Updegraff 'Urbana)
|
||||
(list (cons (cons 'Updegraff 'Urbana)
|
||||
'Summitville))))))
|
||||
|
||||
(make-test-case
|
||||
(test-case
|
||||
"alist-delete!:not-in-singleton-list"
|
||||
(assert-equal?
|
||||
(check-equal?
|
||||
(alist-delete! (cons 'Urbandale 'Ute)
|
||||
(list (cons (cons 'Utica 'Vail) 'Valeria)))
|
||||
'(((Utica . Vail) . Valeria))))
|
||||
|
||||
(make-test-case
|
||||
(test-case
|
||||
"alist-delete!:at-beginning-of-longer-list"
|
||||
(assert-equal?
|
||||
(check-equal?
|
||||
(alist-delete! (cons 'Valley 'Vandalia)
|
||||
(list (cons (cons 'Valley 'Vandalia) 'Varina)
|
||||
(cons (cons 'Ventura 'Vernon) 'Victor)
|
||||
|
|
@ -384,9 +384,9 @@
|
|||
((Vincent . Vining) . Vinje)
|
||||
((Vinton . Viola) . Volga))))
|
||||
|
||||
(make-test-case
|
||||
(test-case
|
||||
"alist-delete!:in-middle-of-longer-list"
|
||||
(assert-equal?
|
||||
(check-equal?
|
||||
(alist-delete! (cons 'Volney 'Voorhies)
|
||||
(list (cons (cons 'Wadena 'Wahpeton) 'Walcott)
|
||||
(cons (cons 'Wald 'Wales) 'Walford)
|
||||
|
|
@ -403,9 +403,9 @@
|
|||
((Washburn . Washington) . Washta)
|
||||
((Waterloo . Waterville) . Watkins))))
|
||||
|
||||
(make-test-case
|
||||
(test-case
|
||||
"alist-delete!:at-end-of-longer-list"
|
||||
(assert-equal?
|
||||
(check-equal?
|
||||
(alist-delete! (cons 'Watson 'Watterson)
|
||||
(list (cons (cons 'Waubeek 'Waucoma) 'Waukee)
|
||||
(cons (cons 'Waukon 'Waupeton) 'Waverly)
|
||||
|
|
@ -417,9 +417,9 @@
|
|||
((Wayland . Webb) . Webster)
|
||||
((Weldon . Weller) . Wellman))))
|
||||
|
||||
(make-test-case
|
||||
(test-case
|
||||
"alist-delete!:not-in-longer-list"
|
||||
(assert-equal?
|
||||
(check-equal?
|
||||
(alist-delete! (cons 'Welton 'Wesley)
|
||||
(list (cons (cons 'Western 'Westerville)
|
||||
'Westfield)
|
||||
|
|
@ -434,9 +434,9 @@
|
|||
((Wheatland . Whiting) . Whittemore)
|
||||
((Whitten . Whittier) . Wichita))))
|
||||
|
||||
(make-test-case
|
||||
(test-case
|
||||
"alist-delete!:several-matches-in-longer-list"
|
||||
(assert-equal?
|
||||
(check-equal?
|
||||
(alist-delete! (cons 'Wick 'Wightman)
|
||||
(list (cons (cons 'Wilke 'Willey) 'Williams)
|
||||
(cons (cons 'Williamsburg 'Williamson)
|
||||
|
|
|
|||
|
|
@ -1,6 +1,6 @@
|
|||
(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"
|
||||
"cons-test.ss"
|
||||
"delete-test.ss"
|
||||
|
|
@ -15,7 +15,7 @@
|
|||
(provide all-1-tests)
|
||||
|
||||
(define all-1-tests
|
||||
(make-test-suite
|
||||
(test-suite
|
||||
"all-1-tests"
|
||||
alist-tests
|
||||
cons-tests
|
||||
|
|
|
|||
|
|
@ -35,62 +35,62 @@
|
|||
(module cons-test
|
||||
mzscheme
|
||||
|
||||
(require (planet "test.ss" ("schematics" "schemeunit.plt" 1 1))
|
||||
(require (planet "test.ss" ("schematics" "schemeunit.plt" 2))
|
||||
(lib "cons.ss" "srfi" "1"))
|
||||
|
||||
(provide cons-tests)
|
||||
|
||||
(define cons-tests
|
||||
(make-test-suite
|
||||
(test-suite
|
||||
"List constructor tests"
|
||||
|
||||
;; XCONS
|
||||
|
||||
(make-test-case
|
||||
(test-case
|
||||
"xcons:null-cdr"
|
||||
(assert-equal? (xcons '() 'Andromeda) '(Andromeda)))
|
||||
(check-equal? (xcons '() 'Andromeda) '(Andromeda)))
|
||||
|
||||
(make-test-case
|
||||
(test-case
|
||||
"xcons:pair-cdr"
|
||||
(let* ((base '(Antlia))
|
||||
(result (xcons base 'Apus)))
|
||||
(assert-equal? result '(Apus Antlia))
|
||||
(assert-eq? (cdr result) base)))
|
||||
(check-equal? result '(Apus Antlia))
|
||||
(check-eq? (cdr result) base)))
|
||||
|
||||
(make-test-case
|
||||
(test-case
|
||||
"xcons:datum-cdr"
|
||||
(assert-equal? (xcons 'Aquarius 'Aquila) '(Aquila . Aquarius)))
|
||||
(check-equal? (xcons 'Aquarius 'Aquila) '(Aquila . Aquarius)))
|
||||
|
||||
;; MAKE-LIST
|
||||
|
||||
(make-test-case
|
||||
(test-case
|
||||
"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"
|
||||
(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"
|
||||
(assert-equal? (make-list 7 'Circinus)
|
||||
(check-equal? (make-list 7 'Circinus)
|
||||
'(Circinus Circinus Circinus Circinus
|
||||
Circinus Circinus Circinus)))
|
||||
|
||||
;; LIST-TABULATE
|
||||
|
||||
(make-test-case
|
||||
(test-case
|
||||
"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"
|
||||
(assert-equal? (list-tabulate 5 (lambda (position) position))
|
||||
(check-equal? (list-tabulate 5 (lambda (position) position))
|
||||
'(0 1 2 3 4)))
|
||||
|
||||
(make-test-case
|
||||
(test-case
|
||||
"list-tabulate:factorial"
|
||||
(assert-equal? (list-tabulate 7 (lambda (position)
|
||||
(check-equal? (list-tabulate 7 (lambda (position)
|
||||
(do ((multiplier 1 (+ multiplier 1))
|
||||
(product 1 (* product multiplier)))
|
||||
((< position multiplier) product))))
|
||||
|
|
@ -98,52 +98,52 @@
|
|||
|
||||
;; LIST*
|
||||
|
||||
(make-test-case
|
||||
(test-case
|
||||
"list*:one-argument"
|
||||
(assert-eq? (list* 'Columba)
|
||||
(check-eq? (list* 'Columba)
|
||||
'Columba))
|
||||
|
||||
(make-test-case
|
||||
(test-case
|
||||
"list*:two-arguments"
|
||||
(assert-equal? (list* 'Corvus 'Crater)
|
||||
(check-equal? (list* 'Corvus 'Crater)
|
||||
'(Corvus . Crater)))
|
||||
|
||||
(make-test-case
|
||||
(test-case
|
||||
"list*:many-arguments"
|
||||
(assert-equal? (list* 'Crux 'Cygnus 'Delphinus 'Dorado 'Draco)
|
||||
(check-equal? (list* 'Crux 'Cygnus 'Delphinus 'Dorado 'Draco)
|
||||
'(Crux Cygnus Delphinus Dorado . Draco)))
|
||||
|
||||
(make-test-case
|
||||
(test-case
|
||||
"list*:last-argument-null"
|
||||
(assert-equal? (list* 'Equuleus 'Fornax '())
|
||||
(check-equal? (list* 'Equuleus 'Fornax '())
|
||||
'(Equuleus Fornax)))
|
||||
|
||||
(make-test-case
|
||||
(test-case
|
||||
"list*:last-argument-non-empty-list"
|
||||
(let* ((base '(Gemini Grus))
|
||||
(result (list* 'Hercules 'Horologium 'Hydra 'Hydrus base)))
|
||||
(assert-equal? result
|
||||
(check-equal? result
|
||||
'(Hercules Horologium Hydra Hydrus Gemini Grus))
|
||||
(assert-eq? (cddddr result) base)))
|
||||
(check-eq? (cddddr result) base)))
|
||||
|
||||
;; LIST-COPY
|
||||
|
||||
(make-test-case
|
||||
(test-case
|
||||
"list-copy:null-list"
|
||||
(assert-true (null? (list-copy '()))))
|
||||
(check-true (null? (list-copy '()))))
|
||||
|
||||
(make-test-case
|
||||
(test-case
|
||||
"list-copy:flat-list"
|
||||
(let* ((original '(Indus Lacerta Leo Lepus Libra))
|
||||
(result (list-copy original)))
|
||||
(assert-equal? result original)
|
||||
(assert-true (not (eq? result original)))
|
||||
(assert-true (not (eq? (cdr result) (cdr original))))
|
||||
(assert-true (not (eq? (cddr result) (cddr original))))
|
||||
(assert-true (not (eq? (cdddr result) (cdddr original))))
|
||||
(assert-true (not (eq? (cddddr result) (cddddr original))))))
|
||||
(check-equal? result original)
|
||||
(check-true (not (eq? result original)))
|
||||
(check-true (not (eq? (cdr result) (cdr original))))
|
||||
(check-true (not (eq? (cddr result) (cddr original))))
|
||||
(check-true (not (eq? (cdddr result) (cdddr original))))
|
||||
(check-true (not (eq? (cddddr result) (cddddr original))))))
|
||||
|
||||
(make-test-case
|
||||
(test-case
|
||||
"list-copy:bush"
|
||||
(let* ((first '(Lupus))
|
||||
(second '(Lynx Malus Mensa (Microscopium Monoceros)
|
||||
|
|
@ -151,27 +151,27 @@
|
|||
(third 'Ophiuchus)
|
||||
(original (list first second third))
|
||||
(result (list-copy original)))
|
||||
(assert-equal? result original)
|
||||
(assert-true (not (eq? result original)))
|
||||
(assert-eq? (car result) first)
|
||||
(assert-true (not (eq? (cdr result) (cdr original))))
|
||||
(assert-eq? (cadr result) second)
|
||||
(assert-true (not (eq? (cddr result) (cddr original))))
|
||||
(assert-eq? (caddr result) third)))
|
||||
(check-equal? result original)
|
||||
(check-true (not (eq? result original)))
|
||||
(check-eq? (car result) first)
|
||||
(check-true (not (eq? (cdr result) (cdr original))))
|
||||
(check-eq? (cadr result) second)
|
||||
(check-true (not (eq? (cddr result) (cddr original))))
|
||||
(check-eq? (caddr result) third)))
|
||||
|
||||
;; CIRCULAR-LIST
|
||||
|
||||
(make-test-case
|
||||
(test-case
|
||||
"circular-list:one-element"
|
||||
(let ((result (circular-list 'Orion)))
|
||||
(assert-true (and (pair? result)
|
||||
(check-true (and (pair? result)
|
||||
(eq? (car result) 'Orion)
|
||||
(eq? (cdr result) result)))))
|
||||
|
||||
(make-test-case
|
||||
(test-case
|
||||
"circular-list:many-elements"
|
||||
(let ((result (circular-list 'Pavo 'Pegasus 'Perseus 'Phoenix 'Pictor)))
|
||||
(assert-true (and (pair? result)
|
||||
(check-true (and (pair? result)
|
||||
(eq? (car result) 'Pavo)
|
||||
(pair? (cdr result))
|
||||
(eq? (cadr result) 'Pegasus)
|
||||
|
|
@ -185,37 +185,37 @@
|
|||
|
||||
;; IOTA
|
||||
|
||||
(make-test-case
|
||||
(test-case
|
||||
"iota:zero-count"
|
||||
(assert-equal? (iota 0) (list)))
|
||||
(check-equal? (iota 0) (list)))
|
||||
|
||||
(make-test-case
|
||||
(test-case
|
||||
"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"
|
||||
(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"
|
||||
(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"
|
||||
(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"
|
||||
(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"
|
||||
(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"
|
||||
(assert-equal? (iota -1) (list)))
|
||||
(check-equal? (iota -1) (list)))
|
||||
|
||||
))
|
||||
)
|
||||
|
|
|
|||
|
|
@ -35,38 +35,38 @@
|
|||
(module delete-test
|
||||
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))
|
||||
|
||||
(provide delete-tests)
|
||||
|
||||
(define delete-tests
|
||||
(make-test-suite
|
||||
(test-suite
|
||||
"List deletion tests"
|
||||
|
||||
;; DELETE
|
||||
|
||||
(make-test-case
|
||||
(test-case
|
||||
"delete:null-list"
|
||||
(assert-true
|
||||
(check-true
|
||||
(null? (delete '(Fraser . Frederic) '()))))
|
||||
|
||||
(make-test-case
|
||||
(test-case
|
||||
"delete:in-singleton-list"
|
||||
(assert-true
|
||||
(check-true
|
||||
(null?
|
||||
(delete '(Fredericksburg . Frederika)
|
||||
'((Fredericksburg . Frederika))))))
|
||||
|
||||
(make-test-case
|
||||
(test-case
|
||||
"delete:not-in-singleton-list"
|
||||
(assert-equal?
|
||||
(check-equal?
|
||||
(delete '(Fredonia . Fredsville) '((Freeman . Freeport)))
|
||||
'((Freeman . Freeport))))
|
||||
|
||||
(make-test-case
|
||||
(test-case
|
||||
"delete:at-beginning-of-longer-list"
|
||||
(assert-equal?
|
||||
(check-equal?
|
||||
(delete '(Fremont . Froelich) '((Fremont . Froelich)
|
||||
(Fruitland . Fulton)
|
||||
(Furay . Galbraith)
|
||||
|
|
@ -77,9 +77,9 @@
|
|||
(Galesburg . Galland)
|
||||
(Galt . Galva))))
|
||||
|
||||
(make-test-case
|
||||
(test-case
|
||||
"delete:in-middle-of-longer-list"
|
||||
(assert-equal?
|
||||
(check-equal?
|
||||
(delete '(Gambrill . Garber) '((Gardiner . Gardner)
|
||||
(Garfield . Garland)
|
||||
(Garnavillo . Garner)
|
||||
|
|
@ -94,9 +94,9 @@
|
|||
(Gaza . Geneva)
|
||||
(Genoa . George))))
|
||||
|
||||
(make-test-case
|
||||
(test-case
|
||||
"delete:at-end-of-longer-list"
|
||||
(assert-equal?
|
||||
(check-equal?
|
||||
(delete '(Georgetown . Gerled) '((Germantown . Germanville)
|
||||
(Giard . Gibbsville)
|
||||
(Gibson . Gifford)
|
||||
|
|
@ -107,9 +107,9 @@
|
|||
(Gibson . Gifford)
|
||||
(Gilbert . Gilbertville))))
|
||||
|
||||
(make-test-case
|
||||
(test-case
|
||||
"delete:not-in-longer-list"
|
||||
(assert-equal?
|
||||
(check-equal?
|
||||
(delete '(Gilliatt . Gilman) '((Givin . Gladbrook)
|
||||
(Gladstone . Gladwin)
|
||||
(Glasgow . Glendon)
|
||||
|
|
@ -121,9 +121,9 @@
|
|||
(Glenwood . Glidden)
|
||||
(Goddard . Goldfield))))
|
||||
|
||||
(make-test-case
|
||||
(test-case
|
||||
"delete:several-matches-in-longer-list"
|
||||
(assert-equal?
|
||||
(check-equal?
|
||||
(delete '(Goodell . Gosport) '((Gowrie . Goddard)
|
||||
(Grable . Graettinger)
|
||||
(Goodell . Gosport)
|
||||
|
|
@ -138,27 +138,27 @@
|
|||
|
||||
;; DELETE!
|
||||
|
||||
(make-test-case
|
||||
(test-case
|
||||
"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"
|
||||
(assert-true
|
||||
(check-true
|
||||
(null?
|
||||
(delete! (cons 'Hepburn 'Herndon)
|
||||
(list (cons 'Hepburn 'Herndon))))))
|
||||
|
||||
(make-test-case
|
||||
(test-case
|
||||
"delete!:not-in-singleton-list"
|
||||
(assert-equal?
|
||||
(check-equal?
|
||||
(delete! (cons 'Hesper 'Hiattsville)
|
||||
(list (cons 'Hiawatha 'Hicks)))
|
||||
'((Hiawatha . Hicks))))
|
||||
|
||||
(make-test-case
|
||||
(test-case
|
||||
"delete!:at-beginning-of-longer-list"
|
||||
(assert-equal?
|
||||
(check-equal?
|
||||
(delete! (cons 'Highland 'Highlandville)
|
||||
(list (cons 'Highland 'Highlandville)
|
||||
(cons 'Highview 'Hills)
|
||||
|
|
@ -170,9 +170,9 @@
|
|||
(Hilltop . Hinton)
|
||||
(Hiteman . Hobarton))))
|
||||
|
||||
(make-test-case
|
||||
(test-case
|
||||
"delete!:in-middle-of-longer-list"
|
||||
(assert-equal?
|
||||
(check-equal?
|
||||
(delete! (cons 'Hocking 'Holbrook)
|
||||
(list (cons 'Holland 'Holmes)
|
||||
(cons 'Holstein 'Homer)
|
||||
|
|
@ -188,9 +188,9 @@
|
|||
(Horton . Hospers)
|
||||
(Houghton . Howardville))))
|
||||
|
||||
(make-test-case
|
||||
(test-case
|
||||
"delete!:at-end-of-longer-list"
|
||||
(assert-equal?
|
||||
(check-equal?
|
||||
(delete! (cons 'Howe 'Hubbard)
|
||||
(list (cons 'Hudson 'Hugo)
|
||||
(cons 'Hull 'Humboldt)
|
||||
|
|
@ -202,9 +202,9 @@
|
|||
(Humeston . Huntington)
|
||||
(Hurley . Huron))))
|
||||
|
||||
(make-test-case
|
||||
(test-case
|
||||
"delete!:not-in-longer-list"
|
||||
(assert-equal?
|
||||
(check-equal?
|
||||
(delete! (cons 'Hurstville 'Hutchins)
|
||||
(list (cons 'Huxley 'Iconium)
|
||||
(cons 'Illyria 'Imogene)
|
||||
|
|
@ -217,9 +217,9 @@
|
|||
(Indianola . Industry)
|
||||
(Inwood . Ion))))
|
||||
|
||||
(make-test-case
|
||||
(test-case
|
||||
"delete!:several-matches-in-longer-list"
|
||||
(assert-equal?
|
||||
(check-equal?
|
||||
(delete! (cons 'Ionia 'Ira)
|
||||
(list (cons 'Ireton 'Ironhills)
|
||||
(cons 'Irving 'Irvington)
|
||||
|
|
@ -235,25 +235,25 @@
|
|||
|
||||
;; DELETE-DUPLICATES
|
||||
|
||||
(make-test-case
|
||||
(test-case
|
||||
"delete-duplicates:null-list"
|
||||
(assert-true (null? (delete-duplicates '()))))
|
||||
(check-true (null? (delete-duplicates '()))))
|
||||
|
||||
(make-test-case
|
||||
(test-case
|
||||
"delete-duplicates:singleton-list"
|
||||
(assert-equal?
|
||||
(check-equal?
|
||||
(delete-duplicates '((Knierim . Knittel)))
|
||||
'((Knierim . Knittel))))
|
||||
|
||||
(make-test-case
|
||||
(test-case
|
||||
"delete-duplicates:in-doubleton-list"
|
||||
(assert-equal?
|
||||
(check-equal?
|
||||
(delete-duplicates '((Knoke . Knowlton) (Knoke . Knowlton)))
|
||||
'((Knoke . Knowlton))))
|
||||
|
||||
(make-test-case
|
||||
(test-case
|
||||
"delete-duplicates:none-removed-in-longer-list"
|
||||
(assert-equal?
|
||||
(check-equal?
|
||||
(delete-duplicates '((Knox . Knoxville)
|
||||
(Konigsmark . Kossuth)
|
||||
(Koszta . Lacelle)
|
||||
|
|
@ -265,9 +265,9 @@
|
|||
(Lacey . Lacona)
|
||||
(Ladoga . Ladora))))
|
||||
|
||||
(make-test-case
|
||||
(test-case
|
||||
"delete-duplicates:some-removed-in-longer-list"
|
||||
(assert-equal?
|
||||
(check-equal?
|
||||
(delete-duplicates '((Lafayette . Lainsville)
|
||||
(Lakeside . Lakewood)
|
||||
(Lakeside . Lakewood)
|
||||
|
|
@ -283,9 +283,9 @@
|
|||
(Lamoille . Lamoni)
|
||||
(Lamont . Lancaster))))
|
||||
|
||||
(make-test-case
|
||||
(test-case
|
||||
"delete-duplicates:all-but-one-removed-in-longer-list"
|
||||
(assert-equal?
|
||||
(check-equal?
|
||||
(delete-duplicates '((Lanesboro . Langdon)
|
||||
(Lanesboro . Langdon)
|
||||
(Lanesboro . Langdon)
|
||||
|
|
@ -295,26 +295,26 @@
|
|||
|
||||
;; DELETE-DUPLICATES!
|
||||
|
||||
(make-test-case
|
||||
(test-case
|
||||
"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"
|
||||
(assert-equal?
|
||||
(check-equal?
|
||||
(delete-duplicates! (list (cons 'Lester 'Letts)))
|
||||
'((Lester . Letts))))
|
||||
|
||||
(make-test-case
|
||||
(test-case
|
||||
"delete-duplicates!:in-doubleton-list"
|
||||
(assert-equal?
|
||||
(check-equal?
|
||||
(delete-duplicates! (list (cons 'Leverette 'Levey)
|
||||
(cons 'Leverette 'Levey)))
|
||||
'((Leverette . Levey))))
|
||||
|
||||
(make-test-case
|
||||
(test-case
|
||||
"delete-duplicates!:none-removed-in-longer-list"
|
||||
(assert-equal?
|
||||
(check-equal?
|
||||
(delete-duplicates! (list (cons 'Lewis 'Lexington)
|
||||
(cons 'Liberty 'Libertyville)
|
||||
(cons 'Lidderdale 'Lima)
|
||||
|
|
@ -326,9 +326,9 @@
|
|||
(Linby . Lincoln)
|
||||
(Linden . Lineville))))
|
||||
|
||||
(make-test-case
|
||||
(test-case
|
||||
"delete-duplicates!:some-removed-in-longer-list"
|
||||
(assert-equal?
|
||||
(check-equal?
|
||||
(delete-duplicates! (list (cons 'Lisbon 'Liscomb)
|
||||
(cons 'Littleport 'Littleton)
|
||||
(cons 'Littleport 'Littleton)
|
||||
|
|
@ -344,9 +344,9 @@
|
|||
(Lockman . Lockridge)
|
||||
(Locust . Logan))))
|
||||
|
||||
(make-test-case
|
||||
(test-case
|
||||
"delete-duplicates!:all-but-one-removed-in-longer-list"
|
||||
(assert-equal?
|
||||
(check-equal?
|
||||
(delete-duplicates! (list (cons 'Logansport 'Lohrville)
|
||||
(cons 'Logansport 'Lohrville)
|
||||
(cons 'Logansport 'Lohrville)
|
||||
|
|
|
|||
|
|
@ -35,235 +35,235 @@
|
|||
(module filter-test
|
||||
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))
|
||||
|
||||
(provide filter-tests)
|
||||
|
||||
(define filter-tests
|
||||
(make-test-suite
|
||||
(test-suite
|
||||
"List filtering tests"
|
||||
|
||||
;; FILTER
|
||||
|
||||
(make-test-case
|
||||
(test-case
|
||||
"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"
|
||||
(assert-equal?
|
||||
(check-equal?
|
||||
(filter (lambda (x) #t) '(Agency))
|
||||
'(Agency)))
|
||||
|
||||
(make-test-case
|
||||
(test-case
|
||||
"filter:all-elements-removed"
|
||||
(assert-true
|
||||
(check-true
|
||||
(null? (filter (lambda (x) #f)
|
||||
'(Ainsworth Akron Albany Albaton Albia)))))
|
||||
|
||||
(make-test-case
|
||||
(test-case
|
||||
"filter:some-elements-removed"
|
||||
(assert-equal?
|
||||
(check-equal?
|
||||
(filter even? '(86 87 88 89 90))
|
||||
'(86 88 90)))
|
||||
|
||||
(make-test-case
|
||||
(test-case
|
||||
"filter:no-elements-removed"
|
||||
(assert-equal?
|
||||
(check-equal?
|
||||
(filter (lambda (x) #t)
|
||||
'(Albion Alburnett Alden Alexander Algona))
|
||||
'(Albion Alburnett Alden Alexander Algona)))
|
||||
|
||||
;; FILTER!
|
||||
|
||||
(make-test-case
|
||||
(test-case
|
||||
"filter!:null-list"
|
||||
(assert-true
|
||||
(check-true
|
||||
(null? (filter! (lambda (x) #t) (list)))))
|
||||
|
||||
(make-test-case
|
||||
(test-case
|
||||
"filter!:singleton-list"
|
||||
(assert-equal?
|
||||
(check-equal?
|
||||
(filter! (lambda (x) #t) (list 'Alice))
|
||||
'(Alice)))
|
||||
|
||||
(make-test-case
|
||||
(test-case
|
||||
"filter!:all-elements-removed"
|
||||
(assert-true
|
||||
(check-true
|
||||
(null? (filter! (lambda (x) #f)
|
||||
(list 'Alleman 'Allendorf 'Allerton 'Allison 'Almont)))))
|
||||
|
||||
(make-test-case
|
||||
(test-case
|
||||
"filter!:some-elements-removed"
|
||||
(assert-equal?
|
||||
(check-equal?
|
||||
(filter! even? (list 91 92 93 94 95))
|
||||
'(92 94)))
|
||||
|
||||
(make-test-case
|
||||
(test-case
|
||||
"filter!:no-elements-removed"
|
||||
(assert-equal?
|
||||
(check-equal?
|
||||
(filter! (lambda (x) #t)
|
||||
(list 'Almoral 'Alpha 'Alta 'Alton 'Altoona))
|
||||
'(Almoral Alpha Alta Alton Altoona)))
|
||||
|
||||
;; REMOVE
|
||||
|
||||
(make-test-case
|
||||
(test-case
|
||||
"remove:null-list"
|
||||
(assert-true
|
||||
(check-true
|
||||
(null? (remove (lambda (x) #t) '()))))
|
||||
|
||||
(make-test-case
|
||||
(test-case
|
||||
"remove:singleton-list"
|
||||
(assert-equal?
|
||||
(check-equal?
|
||||
(remove (lambda (x) #f) '(Alvord))
|
||||
'(Alvord)))
|
||||
|
||||
(make-test-case
|
||||
(test-case
|
||||
"remove:all-elements-removed"
|
||||
(assert-true
|
||||
(check-true
|
||||
(null? (remove (lambda (x) #t) '(Amana Amber Ames Amish Anamosa)))))
|
||||
|
||||
(make-test-case
|
||||
(test-case
|
||||
"remove:some-elements-removed"
|
||||
(assert-equal?
|
||||
(check-equal?
|
||||
(remove even? '(96 97 98 99 100))
|
||||
'(97 99)))
|
||||
|
||||
(make-test-case
|
||||
(test-case
|
||||
"remove:no-elements-removed"
|
||||
(assert-equal?
|
||||
(check-equal?
|
||||
(remove (lambda (x) #f)
|
||||
'(Anderson Andover Andrew Andrews Angus))
|
||||
'(Anderson Andover Andrew Andrews Angus)))
|
||||
|
||||
;; REMOVE!
|
||||
|
||||
(make-test-case
|
||||
(test-case
|
||||
"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"
|
||||
(assert-equal?
|
||||
(check-equal?
|
||||
(remove! (lambda (x) #f) (list 'Anita))
|
||||
'(Anita)))
|
||||
|
||||
(make-test-case
|
||||
(test-case
|
||||
"remove!:all-elements-removed"
|
||||
(assert-true
|
||||
(check-true
|
||||
(null?
|
||||
(remove! (lambda (x) #t)
|
||||
(list 'Ankeny 'Anthon 'Aplington 'Arcadia 'Archer)))))
|
||||
|
||||
(make-test-case
|
||||
(test-case
|
||||
"remove!:some-elements-removed"
|
||||
(assert-equal?
|
||||
(check-equal?
|
||||
(remove! even? (list 101 102 103 104 105))
|
||||
'(101 103 105)))
|
||||
|
||||
(make-test-case
|
||||
(test-case
|
||||
"remove!:no-elements-removed"
|
||||
(assert-equal?
|
||||
(check-equal?
|
||||
(remove! (lambda (x) #f)
|
||||
(list 'Ardon 'Aredale 'Argo 'Argyle 'Arion))
|
||||
'(Ardon Aredale Argo Argyle Arion)))
|
||||
|
||||
;; PARTITION
|
||||
|
||||
(make-test-case
|
||||
(test-case
|
||||
"partition:null-list"
|
||||
(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"
|
||||
(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"
|
||||
(let-values (((in out)
|
||||
(partition (lambda (x) #t)
|
||||
'(Arlington Armstrong Arnold Artesian Arthur))))
|
||||
(assert-true
|
||||
(check-true
|
||||
(and (equal? in
|
||||
'(Arlington Armstrong Arnold Artesian Arthur))
|
||||
(null? out)))))
|
||||
|
||||
(make-test-case
|
||||
(test-case
|
||||
"partition:mixed-starting-in"
|
||||
(let-values (((in out)
|
||||
(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))))))
|
||||
|
||||
(make-test-case
|
||||
(test-case
|
||||
"partition:mixed-starting-out"
|
||||
(let-values (((in out)
|
||||
(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))))))
|
||||
|
||||
(make-test-case
|
||||
(test-case
|
||||
"partition:none-satisfying"
|
||||
(let-values (((in out)
|
||||
(partition (lambda (x) #f)
|
||||
'(Asbury Ashawa Ashland Ashton Aspinwall))))
|
||||
(assert-true (and (null? in)
|
||||
(check-true (and (null? in)
|
||||
(equal? out
|
||||
'(Asbury Ashawa Ashland Ashton Aspinwall))))))
|
||||
|
||||
;; PARTITION!
|
||||
|
||||
(make-test-case
|
||||
(test-case
|
||||
"partition!:null-list"
|
||||
(let-values (((in out)
|
||||
(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"
|
||||
(let-values (((in out)
|
||||
(partition! (lambda (x) #f) (list 'Astor))))
|
||||
(lambda (in out) (and (null? in) (equal? out '(Astor))))))
|
||||
|
||||
(make-test-case
|
||||
(test-case
|
||||
"partition!:all-satisfying"
|
||||
(let-values (((in out)
|
||||
(partition! (lambda (x) #t)
|
||||
(list 'Atalissa 'Athelstan 'Atkins 'Atlantic
|
||||
'Attica))))
|
||||
(assert-true
|
||||
(check-true
|
||||
(and (equal? in
|
||||
'(Atalissa Athelstan Atkins Atlantic Attica))
|
||||
(null? out)))))
|
||||
|
||||
(make-test-case
|
||||
(test-case
|
||||
"partition!:mixed-starting-in"
|
||||
(let-values (((in out)
|
||||
(partition! odd?
|
||||
(list 127 129 130 132 134 135 136 138 139 141))))
|
||||
(assert-true
|
||||
(check-true
|
||||
(and (equal? in '(127 129 135 139 141))
|
||||
(equal? out '(130 132 134 136 138))))))
|
||||
|
||||
(make-test-case
|
||||
(test-case
|
||||
"partition!:mixed-starting-out"
|
||||
(let-values (((in out)
|
||||
(partition! odd? (list 142 143 145 147))))
|
||||
(assert-true
|
||||
(check-true
|
||||
(and (equal? in '(143 145 147))
|
||||
(equal? out '(142))))))
|
||||
|
||||
(make-test-case
|
||||
(test-case
|
||||
"partition!:none-satisfying"
|
||||
(let-values (((in out)
|
||||
(partition! (lambda (x) #f)
|
||||
(list 'Auburn 'Audubon 'Augusta 'Aurelia
|
||||
'Aureola))))
|
||||
(assert-true
|
||||
(check-true
|
||||
(and (null? in)
|
||||
(equal? out
|
||||
'(Auburn Audubon Augusta Aurelia Aureola))))))
|
||||
|
|
|
|||
|
|
@ -36,7 +36,7 @@
|
|||
mzscheme
|
||||
|
||||
(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)
|
||||
(rename (lib "fold.ss" "srfi" "1") s:map map)
|
||||
(rename (lib "fold.ss" "srfi" "1") s:for-each for-each))
|
||||
|
|
@ -44,22 +44,22 @@
|
|||
(provide fold-tests)
|
||||
|
||||
(define fold-tests
|
||||
(make-test-suite
|
||||
(test-suite
|
||||
"Folding list procedures tests"
|
||||
|
||||
;; UNFOLD
|
||||
|
||||
(make-test-case
|
||||
(test-case
|
||||
"unfold:predicate-always-satisfied"
|
||||
(assert-true (null?
|
||||
(check-true (null?
|
||||
(unfold (lambda (seed) #t)
|
||||
(lambda (seed) (* seed 2))
|
||||
(lambda (seed) (* seed 3))
|
||||
1))))
|
||||
|
||||
(make-test-case
|
||||
(test-case
|
||||
"unfold:normal-case"
|
||||
(assert-equal?
|
||||
(check-equal?
|
||||
(unfold (lambda (seed) (= seed 729))
|
||||
(lambda (seed) (* seed 2))
|
||||
(lambda (seed) (* seed 3))
|
||||
|
|
@ -68,9 +68,9 @@
|
|||
|
||||
;; UNFOLD-RIGHT
|
||||
|
||||
(make-test-case
|
||||
(test-case
|
||||
"unfold-right:predicate-always-satisfied"
|
||||
(assert-equal?
|
||||
(check-equal?
|
||||
(unfold-right (lambda (seed) #t)
|
||||
(lambda (seed) (* seed 2))
|
||||
(lambda (seed) (* seed 3))
|
||||
|
|
@ -78,9 +78,9 @@
|
|||
1)
|
||||
(list 1)))
|
||||
|
||||
(make-test-case
|
||||
(test-case
|
||||
"unfold-right:normal-case"
|
||||
(assert-equal?
|
||||
(check-equal?
|
||||
(unfold-right (lambda (seed) (= seed 729))
|
||||
(lambda (seed) (* seed 2))
|
||||
(lambda (seed) (* seed 3))
|
||||
|
|
@ -90,36 +90,36 @@
|
|||
|
||||
;; FOLD
|
||||
|
||||
(make-test-case
|
||||
(test-case
|
||||
"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"
|
||||
(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"
|
||||
(assert =
|
||||
(check =
|
||||
(fold (lambda (alpha beta) (* alpha (+ beta 1)))
|
||||
13
|
||||
'(15 17 19 21 23))
|
||||
32927582))
|
||||
|
||||
(make-test-case
|
||||
(test-case
|
||||
"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"
|
||||
(assert-equal?
|
||||
(check-equal?
|
||||
(fold vector 'Chile '(China) '(Colombia) '(Comoros) '(Congo)
|
||||
'(Croatia))
|
||||
'#(China Colombia Comoros Congo Croatia Chile)))
|
||||
|
||||
(make-test-case
|
||||
(test-case
|
||||
"fold:several-longer-lists"
|
||||
(assert-equal?
|
||||
(check-equal?
|
||||
(fold (lambda (alpha beta gamma delta epsilon zeta)
|
||||
(cons (vector alpha beta gamma delta epsilon) zeta))
|
||||
'()
|
||||
|
|
@ -137,9 +137,9 @@
|
|||
#(Cyprus Estonia Georgia Guyana Iran)
|
||||
#(Cuba Eritrea Gambia Guinea Indonesia))))
|
||||
|
||||
(make-test-case
|
||||
(test-case
|
||||
"fold:lists-of-different-lengths"
|
||||
(assert-equal?
|
||||
(check-equal?
|
||||
(fold (lambda (alpha beta gamma delta)
|
||||
(cons (vector alpha beta gamma) delta))
|
||||
'()
|
||||
|
|
@ -151,38 +151,38 @@
|
|||
|
||||
;; FOLD-RIGHT
|
||||
|
||||
(make-test-case
|
||||
(test-case
|
||||
"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))
|
||||
|
||||
(make-test-case
|
||||
(test-case
|
||||
"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))
|
||||
|
||||
(make-test-case
|
||||
(test-case
|
||||
"fold-right:one-longer-list"
|
||||
(assert = (fold-right (lambda (alpha beta) (* alpha (+ beta 1)))
|
||||
(check = (fold-right (lambda (alpha beta) (* alpha (+ beta 1)))
|
||||
13
|
||||
'(15 17 19 21 23))
|
||||
32868750))
|
||||
|
||||
(make-test-case
|
||||
(test-case
|
||||
"fold-right:several-null-lists"
|
||||
(assert-eq? (fold-right vector 'Lebanon '() '() '() '() '())
|
||||
(check-eq? (fold-right vector 'Lebanon '() '() '() '() '())
|
||||
'Lebanon))
|
||||
|
||||
(make-test-case
|
||||
(test-case
|
||||
"fold-right:several-singleton-lists"
|
||||
(assert-equal?
|
||||
(check-equal?
|
||||
(fold-right vector 'Lesotho '(Liberia) '(Libya) '(Liechtenstein)
|
||||
'(Lithuania) '(Luxembourg))
|
||||
#(Liberia Libya Liechtenstein Lithuania Luxembourg Lesotho)))
|
||||
|
||||
(make-test-case
|
||||
(test-case
|
||||
"fold-right:several-longer-lists"
|
||||
(assert-equal?
|
||||
(check-equal?
|
||||
(fold-right (lambda (alpha beta gamma delta epsilon zeta)
|
||||
(cons (vector alpha beta gamma delta epsilon) zeta))
|
||||
'()
|
||||
|
|
@ -204,9 +204,9 @@
|
|||
#(Mali Monaco Nepal Pakistan Portugal)
|
||||
#(Malta Mongolia Netherlands Palau Qatar))))
|
||||
|
||||
(make-test-case
|
||||
(test-case
|
||||
"fold-right:lists-of-different-lengths"
|
||||
(assert-equal?
|
||||
(check-equal?
|
||||
(fold-right (lambda (alpha beta gamma delta)
|
||||
(cons (vector alpha beta gamma) delta))
|
||||
'()
|
||||
|
|
@ -229,24 +229,24 @@
|
|||
(revappend first
|
||||
(loop (car rest)
|
||||
(cdr rest))))))))
|
||||
(make-test-suite
|
||||
(test-suite
|
||||
"Pair-fold tests"
|
||||
|
||||
(make-test-case
|
||||
(test-case
|
||||
"pair-fold:one-null-list"
|
||||
(assert-equal?
|
||||
(check-equal?
|
||||
(pair-fold revappend '(Spain Sudan) '())
|
||||
'(Spain Sudan)))
|
||||
|
||||
(make-test-case
|
||||
(test-case
|
||||
"pair-fold:one-singleton-list"
|
||||
(assert-equal?
|
||||
(check-equal?
|
||||
(pair-fold revappend '(Suriname Swaziland) '(Sweden))
|
||||
'(Sweden Suriname Swaziland)))
|
||||
|
||||
(make-test-case
|
||||
(test-case
|
||||
"pair-fold:one-longer-list"
|
||||
(assert-equal?
|
||||
(check-equal?
|
||||
(pair-fold revappend
|
||||
'(Switzerland Syria)
|
||||
'(Taiwan Tajikistan Tanzania Thailand Togo))
|
||||
|
|
@ -254,15 +254,15 @@
|
|||
Thailand Tanzania Tajikistan Togo Thailand
|
||||
Tanzania Tajikistan Taiwan Switzerland Syria)))
|
||||
|
||||
(make-test-case
|
||||
(test-case
|
||||
"pair-fold:several-null-lists"
|
||||
(assert-equal?
|
||||
(check-equal?
|
||||
(pair-fold revappall '(Tonga Tunisia) '() '() '() '() '())
|
||||
'(Tonga Tunisia)))
|
||||
|
||||
(make-test-case
|
||||
(test-case
|
||||
"pair-fold:several-singleton-lists"
|
||||
(assert-equal?
|
||||
(check-equal?
|
||||
(pair-fold revappall
|
||||
'(Turkey Turkmenistan)
|
||||
'(Tuvalu)
|
||||
|
|
@ -273,9 +273,9 @@
|
|||
'(Tuvalu Uganda Ukraine Uruguay Uzbekistan Turkey
|
||||
Turkmenistan)))
|
||||
|
||||
(make-test-case
|
||||
(test-case
|
||||
"pair-fold:several-longer-lists"
|
||||
(assert-equal?
|
||||
(check-equal?
|
||||
(pair-fold revappall
|
||||
'(Vanuatu Venezuela)
|
||||
'(Vietnam Yemen Yugoslavia Zaire Zambia Zimbabwe
|
||||
|
|
@ -314,9 +314,9 @@
|
|||
Gjellerup Gide Galsworthy Faulkner Vanuatu
|
||||
Venezuela)))
|
||||
|
||||
(make-test-case
|
||||
(test-case
|
||||
"pair-fold:lists-of-different-lengths"
|
||||
(assert-equal?
|
||||
(check-equal?
|
||||
(pair-fold revappall
|
||||
'(Hauptmann Hemingway Hesse)
|
||||
'(Heyse Jensen Jimenez Johnson)
|
||||
|
|
@ -342,23 +342,23 @@
|
|||
(revappend first
|
||||
(loop (car rest)
|
||||
(cdr rest))))))))
|
||||
(make-test-suite
|
||||
(test-suite
|
||||
"Pair-fold-right tests"
|
||||
(make-test-case
|
||||
(test-case
|
||||
"pair-fold-right:one-null-list"
|
||||
(assert-equal?
|
||||
(check-equal?
|
||||
(pair-fold-right revappend '(Maeterlinck Mahfouz) '())
|
||||
'(Maeterlinck Mahfouz)))
|
||||
|
||||
(make-test-case
|
||||
(test-case
|
||||
"pair-fold-right:one-singleton-list"
|
||||
(assert-equal?
|
||||
(check-equal?
|
||||
(pair-fold-right revappend '(Mann Martinson) '(Mauriac))
|
||||
'(Mauriac Mann Martinson)))
|
||||
|
||||
(make-test-case
|
||||
(test-case
|
||||
"pair-fold-right:one-longer-list"
|
||||
(assert-equal?
|
||||
(check-equal?
|
||||
(pair-fold-right revappend
|
||||
'(Milosz Mistral)
|
||||
'(Mommsen Montale Morrison Neruda Oe))
|
||||
|
|
@ -366,15 +366,15 @@
|
|||
Morrison Montale Oe Neruda Morrison Oe Neruda Oe
|
||||
Milosz Mistral)))
|
||||
|
||||
(make-test-case
|
||||
(test-case
|
||||
"pair-fold-right:several-null-lists"
|
||||
(assert-equal?
|
||||
(check-equal?
|
||||
(pair-fold-right revappall '(Pasternak Paz) '() '() '() '() '())
|
||||
'(Pasternak Paz)))
|
||||
|
||||
(make-test-case
|
||||
(test-case
|
||||
"pair-fold-right:several-singleton-lists"
|
||||
(assert-equal?
|
||||
(check-equal?
|
||||
(pair-fold-right revappall
|
||||
'(Perse Pirandello)
|
||||
'(Pontoppidan)
|
||||
|
|
@ -385,9 +385,9 @@
|
|||
'(Pontoppidan Quasimodo Reymont Rolland Russell
|
||||
Perse Pirandello)))
|
||||
|
||||
(make-test-case
|
||||
(test-case
|
||||
"pair-fold-right:several-longer-lists"
|
||||
(assert-equal?
|
||||
(check-equal?
|
||||
(pair-fold-right revappall
|
||||
'(Sachs Sartre)
|
||||
'(Seferis Shaw Sholokov Siefert Sienkiewicz
|
||||
|
|
@ -427,9 +427,9 @@
|
|||
Bosque Borden Simon Undset Aransas Bastrop Bowie
|
||||
Bosque Sachs Sartre)))
|
||||
|
||||
(make-test-case
|
||||
(test-case
|
||||
"pair-fold-right:lists-of-different-lengths"
|
||||
(assert-equal?
|
||||
(check-equal?
|
||||
(pair-fold-right revappall
|
||||
'(Brazoria Brazos Brewster)
|
||||
'(Briscoe Brooks Brown Burleson)
|
||||
|
|
@ -443,25 +443,25 @@
|
|||
|
||||
;; REDUCE
|
||||
|
||||
(make-test-case
|
||||
(test-case
|
||||
"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"
|
||||
(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"
|
||||
(assert =
|
||||
(check =
|
||||
(reduce (lambda (alpha beta) (* alpha (+ beta 1)))
|
||||
0
|
||||
'(27 29))
|
||||
812))
|
||||
|
||||
(make-test-case
|
||||
(test-case
|
||||
"reduce:longer-list"
|
||||
(assert =
|
||||
(check =
|
||||
(reduce (lambda (alpha beta) (* alpha (+ beta 1)))
|
||||
0
|
||||
'(31 33 35 37 39 41 43))
|
||||
|
|
@ -469,27 +469,27 @@
|
|||
|
||||
;; REDUCE-RIGHT
|
||||
|
||||
(make-test-case
|
||||
(test-case
|
||||
"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"
|
||||
(assert =
|
||||
(check =
|
||||
(reduce-right (lambda (alpha beta) (* alpha (+ beta 1))) 0 '(25))
|
||||
25))
|
||||
|
||||
(make-test-case
|
||||
(test-case
|
||||
"reduce-right:doubleton-list"
|
||||
(assert =
|
||||
(check =
|
||||
(reduce-right (lambda (alpha beta) (* alpha (+ beta 1)))
|
||||
0
|
||||
'(27 29))
|
||||
810))
|
||||
|
||||
(make-test-case
|
||||
(test-case
|
||||
"reduce-right:longer-list"
|
||||
(assert =
|
||||
(check =
|
||||
(reduce-right (lambda (alpha beta) (* alpha (+ beta 1)))
|
||||
0
|
||||
'(31 33 35 37 39 41 43))
|
||||
|
|
@ -497,30 +497,30 @@
|
|||
|
||||
;; APPEND-MAP
|
||||
|
||||
(make-test-case
|
||||
(test-case
|
||||
"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"
|
||||
(assert-equal? (append-map (lambda (element) (list element element)) '(Cass))
|
||||
(check-equal? (append-map (lambda (element) (list element element)) '(Cass))
|
||||
'(Cass Cass)))
|
||||
|
||||
(make-test-case
|
||||
(test-case
|
||||
"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 Castro Chambers Chambers Cherokee Cherokee
|
||||
Childress Childress Clay Clay)))
|
||||
|
||||
(make-test-case
|
||||
(test-case
|
||||
"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"
|
||||
(assert-equal? (append-map (lambda elements (reverse elements))
|
||||
(check-equal? (append-map (lambda elements (reverse elements))
|
||||
'(Cochran)
|
||||
'(Coke)
|
||||
'(Coleman)
|
||||
|
|
@ -528,9 +528,9 @@
|
|||
'(Collingsworth))
|
||||
'(Collingsworth Collin Coleman Coke Cochran)))
|
||||
|
||||
(make-test-case
|
||||
(test-case
|
||||
"append-map:several-longer-lists"
|
||||
(assert-equal?
|
||||
(check-equal?
|
||||
(append-map (lambda elements (reverse elements))
|
||||
'(Colorado Comal Comanche Concho Cooke Coryell
|
||||
Cottle)
|
||||
|
|
@ -549,39 +549,39 @@
|
|||
|
||||
;; APPEND-MAP!
|
||||
|
||||
(make-test-case
|
||||
(test-case
|
||||
"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)))))
|
||||
|
||||
(make-test-case
|
||||
(test-case
|
||||
"append-map!:one-singleton-list"
|
||||
(assert-equal?
|
||||
(check-equal?
|
||||
(append-map! (lambda (element) (list element element))
|
||||
(list 'Gaines))
|
||||
'(Gaines Gaines)))
|
||||
|
||||
(make-test-case
|
||||
(test-case
|
||||
"append-map!:one-longer-list"
|
||||
(assert-equal?
|
||||
(check-equal?
|
||||
(append-map! (lambda (element) (list element element))
|
||||
(list 'Galveston 'Garza 'Gillespie 'Glasscock
|
||||
'Goliad))
|
||||
'(Galveston Galveston Garza Garza Gillespie
|
||||
Gillespie Glasscock Glasscock Goliad Goliad)))
|
||||
|
||||
(make-test-case
|
||||
(test-case
|
||||
"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)))))
|
||||
|
||||
(make-test-case
|
||||
(test-case
|
||||
"append-map!:several-singleton-lists"
|
||||
(assert-equal?
|
||||
(check-equal?
|
||||
(append-map! (lambda elements (reverse elements))
|
||||
(list 'Gonzales)
|
||||
(list 'Gray)
|
||||
|
|
@ -590,9 +590,9 @@
|
|||
(list 'Grimes))
|
||||
'(Grimes Gregg Grayson Gray Gonzales)))
|
||||
|
||||
(make-test-case
|
||||
(test-case
|
||||
"append-map!:several-longer-lists"
|
||||
(assert-equal?
|
||||
(check-equal?
|
||||
(append-map! (lambda elements (reverse elements))
|
||||
(list 'Guadalupe 'Hale 'Hall 'Hamilton 'Hansford
|
||||
'Hardeman 'Hardin)
|
||||
|
|
@ -613,28 +613,28 @@
|
|||
|
||||
;; MAP!
|
||||
|
||||
(make-test-case
|
||||
(test-case
|
||||
"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"
|
||||
(assert-equal? (map! vector (list 'Kent))
|
||||
(check-equal? (map! vector (list 'Kent))
|
||||
'(#(Kent))))
|
||||
|
||||
(make-test-case
|
||||
(test-case
|
||||
"map!:one-longer-list"
|
||||
(assert-equal?
|
||||
(check-equal?
|
||||
(map! vector (list 'Kerr 'Kimble 'King 'Kinney 'Kleberg))
|
||||
'(#(Kerr) #(Kimble) #(King) #(Kinney) #(Kleberg))))
|
||||
|
||||
(make-test-case
|
||||
(test-case
|
||||
"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"
|
||||
(assert-equal?
|
||||
(check-equal?
|
||||
(map! vector
|
||||
(list 'Knox)
|
||||
(list 'Lamar)
|
||||
|
|
@ -643,9 +643,9 @@
|
|||
(list 'Lavaca))
|
||||
'(#(Knox Lamar Lamb Lampasas Lavaca))))
|
||||
|
||||
(make-test-case
|
||||
(test-case
|
||||
"map!:several-longer-lists"
|
||||
(assert-equal?
|
||||
(check-equal?
|
||||
(map! vector
|
||||
(list 'Lee 'Leon 'Liberty 'Limestone 'Lipscomb 'Llano
|
||||
'Loving)
|
||||
|
|
@ -667,17 +667,17 @@
|
|||
|
||||
;; MAP-IN-ORDER
|
||||
|
||||
(make-test-case
|
||||
(test-case
|
||||
"map-in-order:one-null-list"
|
||||
(assert-true (null? (let ((counter 0))
|
||||
(check-true (null? (let ((counter 0))
|
||||
(map-in-order (lambda (element)
|
||||
(set! counter (+ counter 1))
|
||||
(cons counter element))
|
||||
'())))))
|
||||
|
||||
(make-test-case
|
||||
(test-case
|
||||
"map-in-order:one-singleton-list"
|
||||
(assert-equal?
|
||||
(check-equal?
|
||||
(let ((counter 0))
|
||||
(map-in-order (lambda (element)
|
||||
(set! counter (+ counter 1))
|
||||
|
|
@ -685,9 +685,9 @@
|
|||
'(Oldham)))
|
||||
'((1 . Oldham))))
|
||||
|
||||
(make-test-case
|
||||
(test-case
|
||||
"map-in-order:one-longer-list"
|
||||
(assert-equal?
|
||||
(check-equal?
|
||||
(let ((counter 0))
|
||||
(map-in-order (lambda (element)
|
||||
(set! counter (+ counter 1))
|
||||
|
|
@ -699,17 +699,17 @@
|
|||
(4 . Parmer)
|
||||
(5 . Pecos))))
|
||||
|
||||
(make-test-case
|
||||
(test-case
|
||||
"map-in-order:several-null-lists"
|
||||
(assert-true (null? (let ((counter 0))
|
||||
(check-true (null? (let ((counter 0))
|
||||
(map-in-order (lambda elements
|
||||
(set! counter (+ counter 1))
|
||||
(apply vector counter elements))
|
||||
'() '() '() '() '())))))
|
||||
|
||||
(make-test-case
|
||||
(test-case
|
||||
"map-in-order:several-singleton-lists"
|
||||
(assert-equal?
|
||||
(check-equal?
|
||||
(let ((counter 0))
|
||||
(map-in-order (lambda elements
|
||||
(set! counter (+ counter 1))
|
||||
|
|
@ -721,9 +721,9 @@
|
|||
'(Randall)))
|
||||
'(#(1 Polk Potter Presidio Rains Randall))))
|
||||
|
||||
(make-test-case
|
||||
(test-case
|
||||
"map-in-order:several-longer-lists"
|
||||
(assert-equal?
|
||||
(check-equal?
|
||||
(let ((counter 0))
|
||||
(map-in-order (lambda elements
|
||||
(set! counter (+ counter 1))
|
||||
|
|
@ -749,18 +749,18 @@
|
|||
|
||||
;; PAIR-FOR-EACH
|
||||
|
||||
(make-test-case
|
||||
(test-case
|
||||
"pair-for-each:one-null-list"
|
||||
(assert-true
|
||||
(check-true
|
||||
(null? (let ((base '()))
|
||||
(pair-for-each (lambda (tail)
|
||||
(set! base (append tail base)))
|
||||
'())
|
||||
base))))
|
||||
|
||||
(make-test-case
|
||||
(test-case
|
||||
"pair-for-each:one-singleton-list"
|
||||
(assert-equal?
|
||||
(check-equal?
|
||||
(let ((base '()))
|
||||
(pair-for-each (lambda (tail)
|
||||
(set! base (append tail base)))
|
||||
|
|
@ -768,9 +768,9 @@
|
|||
base)
|
||||
'(Victoria)))
|
||||
|
||||
(make-test-case
|
||||
(test-case
|
||||
"pair-for-each:one-longer-list"
|
||||
(assert-equal?
|
||||
(check-equal?
|
||||
(let ((base '()))
|
||||
(pair-for-each (lambda (tail)
|
||||
(set! base (append tail base)))
|
||||
|
|
@ -780,9 +780,9 @@
|
|||
Ward Washington Webb Walker Waller Ward
|
||||
Washington Webb)))
|
||||
|
||||
(make-test-case
|
||||
(test-case
|
||||
"pair-for-each:several-null-lists"
|
||||
(assert-true
|
||||
(check-true
|
||||
(null? (let ((base '()))
|
||||
(pair-for-each (lambda tails
|
||||
(set! base
|
||||
|
|
@ -790,9 +790,9 @@
|
|||
'() '() '() '() '())
|
||||
base))))
|
||||
|
||||
(make-test-case
|
||||
(test-case
|
||||
"pair-for-each:several-singleton-lists"
|
||||
(assert-equal?
|
||||
(check-equal?
|
||||
(let ((base '()))
|
||||
(pair-for-each (lambda tails
|
||||
(set! base
|
||||
|
|
@ -806,9 +806,9 @@
|
|||
'(#((Wharton) (Wheeler) (Wichita) (Wilbarger)
|
||||
(Willacy)))))
|
||||
|
||||
(make-test-case
|
||||
(test-case
|
||||
"pair-for-each:several-longer-lists"
|
||||
(assert-equal?
|
||||
(check-equal?
|
||||
(let ((base '()))
|
||||
(pair-for-each (lambda tails
|
||||
(set! base
|
||||
|
|
@ -860,42 +860,42 @@
|
|||
|
||||
;; FILTER-MAP
|
||||
|
||||
(make-test-case
|
||||
(test-case
|
||||
"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"
|
||||
(assert-equal?
|
||||
(check-equal?
|
||||
(filter-map values '(Crest))
|
||||
'(Crest)))
|
||||
|
||||
(make-test-case
|
||||
(test-case
|
||||
"filter-map:one-list-all-elements-removed"
|
||||
(assert-true
|
||||
(check-true
|
||||
(null? (filter-map (lambda (x) #f)
|
||||
'(Crisco Degree Doritos Dristan Efferdent)))))
|
||||
|
||||
(make-test-case
|
||||
(test-case
|
||||
"filter-map:one-list-some-elements-removed"
|
||||
(assert-equal?
|
||||
(check-equal?
|
||||
(filter-map (lambda (n) (and (even? n) n))
|
||||
'(44 45 46 47 48 49 50))
|
||||
'(44 46 48 50)))
|
||||
|
||||
(make-test-case
|
||||
(test-case
|
||||
"filter-map:one-list-no-elements-removed"
|
||||
(assert-equal?
|
||||
(check-equal?
|
||||
(filter-map values '(ESPN Everready Excedrin Fab Fantastik))
|
||||
'(ESPN Everready Excedrin Fab Fantastik)))
|
||||
|
||||
(make-test-case
|
||||
(test-case
|
||||
"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"
|
||||
(assert-equal?
|
||||
(check-equal?
|
||||
(filter-map vector
|
||||
'(Foamy)
|
||||
'(Gatorade)
|
||||
|
|
@ -904,9 +904,9 @@
|
|||
'(Halcion))
|
||||
'(#(Foamy Gatorade Glad Gleem Halcion))))
|
||||
|
||||
(make-test-case
|
||||
(test-case
|
||||
"filter-map:several-lists-all-elements-removed"
|
||||
(assert-true
|
||||
(check-true
|
||||
(null?
|
||||
(filter-map (lambda arguments #f)
|
||||
'(Hanes HBO Hostess Huggies Ivory Kent Kinney)
|
||||
|
|
@ -919,9 +919,9 @@
|
|||
'(Prego Prell Prozac Purex Ritz Robitussin
|
||||
Rolaids)))))
|
||||
|
||||
(make-test-case
|
||||
(test-case
|
||||
"filter-map:several-lists-some-elements-removed"
|
||||
(assert-equal?
|
||||
(check-equal?
|
||||
(filter-map (lambda arguments
|
||||
(let ((sum (apply + arguments)))
|
||||
(and (odd? sum) sum)))
|
||||
|
|
@ -932,9 +932,9 @@
|
|||
'(79 80 81 82 83 84 85))
|
||||
'(325 335 345 355)))
|
||||
|
||||
(make-test-case
|
||||
(test-case
|
||||
"filter-map:several-lists-no-elements-removed"
|
||||
(assert-equal?
|
||||
(check-equal?
|
||||
(filter-map vector
|
||||
'(Ronzoni Ruffles Scotch Skippy SnackWell Snapple
|
||||
Spam)
|
||||
|
|
|
|||
|
|
@ -35,76 +35,76 @@
|
|||
(module lset-test
|
||||
mzscheme
|
||||
|
||||
(require (planet "test.ss" ("schematics" "schemeunit.plt" 1 1))
|
||||
(require (planet "test.ss" ("schematics" "schemeunit.plt" 2))
|
||||
(lib "lset.ss" "srfi" "1"))
|
||||
|
||||
(provide lset-tests)
|
||||
|
||||
(define lset-tests
|
||||
(make-test-suite
|
||||
(test-suite
|
||||
"List as set procedures tests"
|
||||
|
||||
(make-test-case
|
||||
(test-case
|
||||
"lset<=:singleton"
|
||||
(assert-true (lset<= eq?)))
|
||||
(check-true (lset<= eq?)))
|
||||
|
||||
(make-test-case
|
||||
(test-case
|
||||
"lset<=:empty-list"
|
||||
(assert-true (lset<= eq? (list))))
|
||||
(check-true (lset<= eq? (list))))
|
||||
|
||||
(make-test-case
|
||||
(test-case
|
||||
"lset<=:empty-lists"
|
||||
(assert-true (lset<= eq? (list) (list))))
|
||||
(check-true (lset<= eq? (list) (list))))
|
||||
|
||||
(make-test-case
|
||||
(test-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"
|
||||
(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"
|
||||
(assert-true (lset= eq?)))
|
||||
(check-true (lset= eq?)))
|
||||
|
||||
(make-test-case
|
||||
(test-case
|
||||
"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"
|
||||
(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"
|
||||
(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"
|
||||
(assert-equal? (lset-xor eq?) '()))
|
||||
(check-equal? (lset-xor eq?) '()))
|
||||
|
||||
(make-test-case
|
||||
(test-case
|
||||
"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"
|
||||
(assert-true (lset= eq?
|
||||
(check-true (lset= eq?
|
||||
(lset-xor eq? '(a b c d e) '(a e i o u))
|
||||
'(d c b i o u))))
|
||||
|
||||
(make-test-case
|
||||
(test-case
|
||||
"lset-xor!:empty-list"
|
||||
(assert-equal? (lset-xor! eq?) '()))
|
||||
(check-equal? (lset-xor! eq?) '()))
|
||||
|
||||
(make-test-case
|
||||
(test-case
|
||||
"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"
|
||||
(assert-true (lset= eq?
|
||||
(check-true (lset= eq?
|
||||
(lset-xor! eq? '(a b c d e) '(a e i o u))
|
||||
'(d c b i o u))))
|
||||
))
|
||||
|
|
|
|||
|
|
@ -36,7 +36,7 @@
|
|||
mzscheme
|
||||
|
||||
(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!)
|
||||
(rename (lib "misc.ss" "srfi" "1") s:append! append!)
|
||||
(rename (lib "misc.ss" "srfi" "1") s:reverse! reverse!))
|
||||
|
|
@ -44,23 +44,23 @@
|
|||
(provide misc-tests)
|
||||
|
||||
(define misc-tests
|
||||
(make-test-suite
|
||||
(test-suite
|
||||
"Miscellaneous list procedures tests"
|
||||
|
||||
;; ZIP
|
||||
|
||||
(make-test-case
|
||||
(test-case
|
||||
"zip:all-lists-empty"
|
||||
(assert-true (null? (zip '() '() '() '() '()))))
|
||||
(check-true (null? (zip '() '() '() '() '()))))
|
||||
|
||||
(make-test-case
|
||||
(test-case
|
||||
"zip:one-list"
|
||||
(assert-equal? (zip '(Pisces Puppis Reticulum))
|
||||
(check-equal? (zip '(Pisces Puppis Reticulum))
|
||||
'((Pisces) (Puppis) (Reticulum))))
|
||||
|
||||
(make-test-case
|
||||
(test-case
|
||||
"zip:two-lists"
|
||||
(assert-equal? (zip '(Sagitta Sagittarius Scorpio Scutum Serpens)
|
||||
(check-equal? (zip '(Sagitta Sagittarius Scorpio Scutum Serpens)
|
||||
'(Sextans Taurus Telescopium Triangulum Tucana))
|
||||
'((Sagitta Sextans)
|
||||
(Sagittarius Taurus)
|
||||
|
|
@ -68,14 +68,14 @@
|
|||
(Scutum Triangulum)
|
||||
(Serpens Tucana))))
|
||||
|
||||
(make-test-case
|
||||
(test-case
|
||||
"zip:short-lists"
|
||||
(assert-equal? (zip '(Vela) '(Virgo) '(Volens) '(Vulpecula))
|
||||
(check-equal? (zip '(Vela) '(Virgo) '(Volens) '(Vulpecula))
|
||||
'((Vela Virgo Volens Vulpecula))))
|
||||
|
||||
(make-test-case
|
||||
(test-case
|
||||
"zip:several-lists"
|
||||
(assert-equal? (zip '(actinium aluminum americium antimony argon)
|
||||
(check-equal? (zip '(actinium aluminum americium antimony argon)
|
||||
'(arsenic astatine barium berkeleium beryllium)
|
||||
'(bismuth boron bromine cadmium calcium)
|
||||
'(californium carbon cerium cesium chlorine)
|
||||
|
|
@ -95,18 +95,18 @@
|
|||
|
||||
;; UNZIP2
|
||||
|
||||
(make-test-case
|
||||
(test-case
|
||||
"unzip2:empty-list-of-lists"
|
||||
(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"
|
||||
(let-values (((firsts seconds) (unzip2 '((retriever rottweiler)))))
|
||||
(assert-true (and (equal? firsts '(retriever))
|
||||
(check-true (and (equal? firsts '(retriever))
|
||||
(equal? seconds '(rottweiler))))))
|
||||
|
||||
(make-test-case
|
||||
(test-case
|
||||
"unzip2:longer-list-of-lists"
|
||||
(let-values (((firsts seconds)
|
||||
(unzip2 '((saluki samoyed)
|
||||
|
|
@ -114,38 +114,38 @@
|
|||
(setter shepherd)
|
||||
(skye spaniel)
|
||||
(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
|
||||
staghound))))))
|
||||
|
||||
(make-test-case
|
||||
(test-case
|
||||
"unzip2:lists-with-extra-elements"
|
||||
(let-values (((firsts seconds)
|
||||
(unzip2 '((terrier turnspit vizsla wiemaraner)
|
||||
(whippet wolfhound)
|
||||
(bells bones bongo carillon celesta)
|
||||
(chimes clappers conga)))))
|
||||
(assert-true (and (equal? firsts '(terrier whippet bells chimes))
|
||||
(check-true (and (equal? firsts '(terrier whippet bells chimes))
|
||||
(equal? seconds
|
||||
'(turnspit wolfhound bones clappers))))))
|
||||
|
||||
;; UNZIP3
|
||||
|
||||
(make-test-case
|
||||
(test-case
|
||||
"unzip3:empty-list-of-lists"
|
||||
(let-values (((firsts seconds thirds)
|
||||
(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"
|
||||
(let-values (((firsts seconds thirds)
|
||||
(unzip3 '((cymbals gamelan glockenspiel)))))
|
||||
(assert-true (and (equal? firsts '(cymbals))
|
||||
(check-true (and (equal? firsts '(cymbals))
|
||||
(equal? seconds '(gamelan))
|
||||
(equal? thirds '(glockenspiel))))))
|
||||
|
||||
(make-test-case
|
||||
(test-case
|
||||
"unzip3:longer-list-of-lists"
|
||||
(let-values (((firsts seconds thirds)
|
||||
(unzip3 '((gong handbells kettledrum)
|
||||
|
|
@ -153,45 +153,45 @@
|
|||
(mbira membranophone metallophone)
|
||||
(nagara naker rattle)
|
||||
(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
|
||||
snappers))
|
||||
(equal? thirds '(kettledrum marimba metallophone rattle
|
||||
tabor))))))
|
||||
|
||||
(make-test-case
|
||||
(test-case
|
||||
"unzip3:lists-with-extra-elements"
|
||||
(let-values (((firsts seconds thirds)
|
||||
(unzip3 '((tambourine timbrel timpani tintinnabula tonitruone)
|
||||
(triangle vibraphone xylophone)
|
||||
(baccarat banker bezique bingo bridge canasta)
|
||||
(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? thirds
|
||||
'(timpani xylophone bezique cribbage))))))
|
||||
|
||||
;; UNZIP4
|
||||
|
||||
(make-test-case
|
||||
(test-case
|
||||
"unzip4:empty-list-of-lists"
|
||||
(let-values (((firsts seconds thirds fourths)
|
||||
(unzip4 '())))
|
||||
(assert-true (and (null? firsts)
|
||||
(check-true (and (null? firsts)
|
||||
(null? seconds)
|
||||
(null? thirds)
|
||||
(null? fourths)))))
|
||||
|
||||
(make-test-case
|
||||
(test-case
|
||||
"unzip4:singleton-list-of-lists"
|
||||
(let-values (((firsts seconds thirds fourths)
|
||||
(unzip4 '((fantan faro gin hazard)))))
|
||||
(assert-true (and (equal? firsts '(fantan))
|
||||
(check-true (and (equal? firsts '(fantan))
|
||||
(equal? seconds '(faro))
|
||||
(equal? thirds '(gin))
|
||||
(equal? fourths '(hazard))))))
|
||||
|
||||
(make-test-case
|
||||
(test-case
|
||||
"unzip4:longer-list-of-lists"
|
||||
(let-values (((firsts seconds thirds fourths)
|
||||
(unzip4 '((hearts keno loo lottery)
|
||||
|
|
@ -199,13 +199,13 @@
|
|||
(ombre picquet pinball pinochle)
|
||||
(poker policy quinze romesteq)
|
||||
(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? thirds '(loo monte pinball quinze rummy))
|
||||
(equal? fourths
|
||||
'(lottery numbers pinochle romesteq skat))))))
|
||||
|
||||
(make-test-case
|
||||
(test-case
|
||||
"unzip4:lists-with-extra-elements"
|
||||
(let-values (((firsts seconds thirds fourths)
|
||||
(unzip4 '((adamant agate alexandrite amethyst aquamarine
|
||||
|
|
@ -214,7 +214,7 @@
|
|||
(chalcedony chrysoberyl chrysolite chrysoprase
|
||||
citrine coral demantoid)
|
||||
(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? thirds
|
||||
'(alexandrite carbuncle chrysolite garnet))
|
||||
|
|
@ -223,18 +223,18 @@
|
|||
|
||||
;; UNZIP5
|
||||
|
||||
(make-test-case
|
||||
(test-case
|
||||
"unzip5:empty-list-of-lists"
|
||||
(let-values (((firsts seconds thirds fourths fifths)
|
||||
(unzip5 '())))
|
||||
(assert-true
|
||||
(check-true
|
||||
(and (null? firsts)
|
||||
(null? seconds)
|
||||
(null? thirds)
|
||||
(null? fourths)
|
||||
(null? fifths)))))
|
||||
|
||||
(make-test-case
|
||||
(test-case
|
||||
"unzip5:singleton-list-of-lists"
|
||||
(let-values (((firsts seconds thirds fourths fifths)
|
||||
(unzip5 '((hyacinth jacinth jade jargoon jasper)))))
|
||||
|
|
@ -245,7 +245,7 @@
|
|||
(equal? fourths '(jargoon))
|
||||
(equal? fifths '(jasper))))))
|
||||
|
||||
(make-test-case
|
||||
(test-case
|
||||
"unzip5:longer-list-of-lists"
|
||||
(let-values (((firsts seconds thirds fourths fifths)
|
||||
(unzip5 '((kunzite moonstone morganite onyx opal)
|
||||
|
|
@ -253,7 +253,7 @@
|
|||
(sardonyx spinel star sunstone topaz)
|
||||
(tourmaline turquoise zircon Argus basilisk)
|
||||
(Bigfoot Briareus bucentur Cacus Caliban)))))
|
||||
(assert-true
|
||||
(check-true
|
||||
(and (equal? firsts
|
||||
'(kunzite peridot sardonyx tourmaline Bigfoot))
|
||||
(equal? seconds
|
||||
|
|
@ -262,7 +262,7 @@
|
|||
(equal? fourths '(onyx sapphire sunstone Argus Cacus))
|
||||
(equal? fifths '(opal sard topaz basilisk Caliban))))))
|
||||
|
||||
(make-test-case
|
||||
(test-case
|
||||
"unzip5:lists-with-extra-elements"
|
||||
(let-values (((firsts seconds thirds fourths fifths)
|
||||
(unzip5 '((centaur Cerberus Ceto Charybdis chimera cockatrice
|
||||
|
|
@ -271,7 +271,7 @@
|
|||
(Gigantes Gorgon Grendel griffin Harpy hippocampus
|
||||
hippocentaur hippocerf)
|
||||
(hirocervus Hydra Kraken Ladon manticore Medusa)))))
|
||||
(assert-true
|
||||
(check-true
|
||||
(and (equal? firsts '(centaur dipsas Gigantes hirocervus))
|
||||
(equal? seconds '(Cerberus dragon Gorgon Hydra))
|
||||
(equal? thirds '(Ceto drake Grendel Kraken))
|
||||
|
|
@ -280,18 +280,18 @@
|
|||
|
||||
;; APPEND!
|
||||
|
||||
(make-test-case
|
||||
(test-case
|
||||
"append!:no-arguments"
|
||||
(assert-true (null? (s:append!))))
|
||||
(check-true (null? (s:append!))))
|
||||
|
||||
(make-test-case
|
||||
(test-case
|
||||
"append!:one-argument"
|
||||
(assert-equal? (s:append! (list 'mermaid 'merman 'Minotaur))
|
||||
(check-equal? (s:append! (list 'mermaid 'merman 'Minotaur))
|
||||
'(mermaid merman Minotaur)))
|
||||
|
||||
(make-test-case
|
||||
(test-case
|
||||
"append!:several-arguments"
|
||||
(assert-equal?
|
||||
(check-equal?
|
||||
(s:append! (list 'nixie 'ogre 'ogress 'opinicus)
|
||||
(list 'Orthos)
|
||||
(list 'Pegasus 'Python)
|
||||
|
|
@ -301,36 +301,36 @@
|
|||
Python roc Sagittary salamander Sasquatch
|
||||
satyr Scylla simurgh siren)))
|
||||
|
||||
(make-test-case
|
||||
(test-case
|
||||
"append!:some-null-arguments"
|
||||
(assert-equal?
|
||||
(check-equal?
|
||||
(s:append! (list) (list) (list 'Sphinx 'Talos 'troll) (list)
|
||||
(list 'Typhoeus) (list) (list) (list))
|
||||
'(Sphinx Talos troll Typhoeus)))
|
||||
|
||||
(make-test-case
|
||||
(test-case
|
||||
"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
|
||||
|
||||
(make-test-case
|
||||
(test-case
|
||||
"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)))
|
||||
|
||||
(make-test-case
|
||||
(test-case
|
||||
"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)))
|
||||
|
||||
(make-test-case
|
||||
(test-case
|
||||
"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"
|
||||
(assert-equal?
|
||||
(check-equal?
|
||||
(append-reverse '(Afghanistan Albania Algeria Andorra)
|
||||
'(Angola Argentina Armenia))
|
||||
'(Andorra Algeria Albania Afghanistan Angola
|
||||
|
|
@ -338,43 +338,43 @@
|
|||
|
||||
;; APPEND-REVERSE!
|
||||
|
||||
(make-test-case
|
||||
(test-case
|
||||
"append-reverse!:first-argument-null"
|
||||
(assert-equal? (append-reverse! (list)
|
||||
(check-equal? (append-reverse! (list)
|
||||
(list 'Australia 'Austria 'Azerbaijan))
|
||||
'(Australia Austria Azerbaijan)))
|
||||
|
||||
(make-test-case
|
||||
(test-case
|
||||
"append-reverse!:second-argument-null"
|
||||
(assert-equal? (append-reverse! (list 'Bahrain 'Bangladesh 'Barbados
|
||||
(check-equal? (append-reverse! (list 'Bahrain 'Bangladesh 'Barbados
|
||||
'Belarus 'Belgium)
|
||||
(list))
|
||||
'(Belgium Belarus Barbados Bangladesh Bahrain)))
|
||||
|
||||
(make-test-case
|
||||
(test-case
|
||||
"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"
|
||||
(assert-equal? (append-reverse! (list 'Belize 'Benin 'Bhutan 'Bolivia)
|
||||
(check-equal? (append-reverse! (list 'Belize 'Benin 'Bhutan 'Bolivia)
|
||||
(list 'Bosnia 'Botswana 'Brazil))
|
||||
'(Bolivia Bhutan Benin Belize Bosnia Botswana Brazil)))
|
||||
|
||||
;; REVERSE!
|
||||
|
||||
(make-test-case
|
||||
(test-case
|
||||
"reverse!:empty-list"
|
||||
(assert-true (null? (s:reverse! (list)))))
|
||||
(check-true (null? (s:reverse! (list)))))
|
||||
|
||||
(make-test-case
|
||||
(test-case
|
||||
"reverse!:singleton-list"
|
||||
(assert-equal? (s:reverse! (list 'Brunei))
|
||||
(check-equal? (s:reverse! (list 'Brunei))
|
||||
'(Brunei)))
|
||||
|
||||
(make-test-case
|
||||
(test-case
|
||||
"reverse!:longer-list"
|
||||
(assert-equal? (s:reverse! (list 'Bulgaria 'Burundi 'Cambodia 'Cameroon
|
||||
(check-equal? (s:reverse! (list 'Bulgaria 'Burundi 'Cambodia 'Cameroon
|
||||
'Canada))
|
||||
'(Canada Cameroon Cambodia Burundi Bulgaria)))
|
||||
|
||||
|
|
|
|||
|
|
@ -36,134 +36,134 @@
|
|||
mzscheme
|
||||
|
||||
(require
|
||||
(planet "test.ss" ("schematics" "schemeunit.plt" 1 1))
|
||||
(planet "test.ss" ("schematics" "schemeunit.plt" 2))
|
||||
(lib "predicate.ss" "srfi" "1")
|
||||
(lib "cons.ss" "srfi" "1"))
|
||||
|
||||
(provide predicate-tests)
|
||||
|
||||
(define predicate-tests
|
||||
(make-test-suite
|
||||
(test-suite
|
||||
"List predicate tests"
|
||||
|
||||
;; PROPER-LIST?
|
||||
|
||||
(make-test-case
|
||||
(test-case
|
||||
"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"
|
||||
(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"
|
||||
(assert-true (proper-list? (list))))
|
||||
(check-true (proper-list? (list))))
|
||||
|
||||
(make-test-case
|
||||
(test-case
|
||||
"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"
|
||||
(assert-true (not (proper-list? 1))))
|
||||
(check-true (not (proper-list? 1))))
|
||||
|
||||
;; DOTTED-LIST?
|
||||
|
||||
(make-test-case
|
||||
(test-case
|
||||
"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"
|
||||
(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"
|
||||
(assert-true (not (dotted-list? (list)))))
|
||||
(check-true (not (dotted-list? (list)))))
|
||||
|
||||
(make-test-case
|
||||
(test-case
|
||||
"dotted-list?:simple-value"
|
||||
(assert-true (dotted-list? "hello")))
|
||||
(check-true (dotted-list? "hello")))
|
||||
|
||||
;; CIRCULAR-LIST
|
||||
|
||||
(make-test-case
|
||||
(test-case
|
||||
"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"
|
||||
(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"
|
||||
(assert-true (not (circular-list? 1))))
|
||||
(check-true (not (circular-list? 1))))
|
||||
|
||||
(make-test-case
|
||||
(test-case
|
||||
"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
|
||||
|
||||
(make-test-case
|
||||
(test-case
|
||||
"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"
|
||||
(assert-true (not-pair? 1)))
|
||||
(check-true (not-pair? 1)))
|
||||
|
||||
(make-test-case
|
||||
(test-case
|
||||
"not-pair?:symbol"
|
||||
(assert-true (not-pair? 'symbol)))
|
||||
(check-true (not-pair? 'symbol)))
|
||||
|
||||
(make-test-case
|
||||
(test-case
|
||||
"not-pair?:string"
|
||||
(assert-true (not-pair? "string")))
|
||||
(check-true (not-pair? "string")))
|
||||
|
||||
;; NULL-LIST?
|
||||
|
||||
(make-test-case
|
||||
(test-case
|
||||
"null-list?:null-list"
|
||||
(assert-true (null-list? (list))))
|
||||
(check-true (null-list? (list))))
|
||||
|
||||
(make-test-case
|
||||
(test-case
|
||||
"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"
|
||||
(assert-true (not (null-list? (cons 1 2)))))
|
||||
(check-true (not (null-list? (cons 1 2)))))
|
||||
|
||||
;; LIST=
|
||||
|
||||
(make-test-case
|
||||
(test-case
|
||||
"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"
|
||||
(assert-true (list= (lambda (x y)
|
||||
(check-true (list= (lambda (x y)
|
||||
(string=? (symbol->string x) y))
|
||||
(list 'a 'b 'c)
|
||||
(list "a" "b" "c"))))
|
||||
|
||||
(make-test-case
|
||||
(test-case
|
||||
"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"
|
||||
(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"
|
||||
(assert-true (list= eq? (list) (list) (list))))
|
||||
(check-true (list= eq? (list) (list) (list))))
|
||||
|
||||
(make-test-case
|
||||
(test-case
|
||||
"list=:no-list"
|
||||
(assert-true (list= eq?)))
|
||||
(check-true (list= eq?)))
|
||||
|
||||
))
|
||||
)
|
||||
|
|
|
|||
|
|
@ -1,5 +1,5 @@
|
|||
(require (planet "test.ss" ("schematics" "schemeunit.plt" 1 1)))
|
||||
(require (planet "text-ui.ss" ("schematics" "schemeunit.plt" 1 1)))
|
||||
(require (planet "test.ss" ("schematics" "schemeunit.plt" 2)))
|
||||
(require (planet "text-ui.ss" ("schematics" "schemeunit.plt" 2)))
|
||||
(require "all-1-tests.ss")
|
||||
|
||||
(test/text-ui all-1-tests)
|
||||
|
|
|
|||
|
|
@ -35,148 +35,148 @@
|
|||
(module search-test
|
||||
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))
|
||||
|
||||
(provide search-tests)
|
||||
|
||||
(define search-tests
|
||||
(make-test-suite
|
||||
(test-suite
|
||||
"List search tests"
|
||||
|
||||
;; FIND
|
||||
|
||||
(make-test-case
|
||||
(test-case
|
||||
"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"
|
||||
(assert-eq? (find (lambda (x) #t) '(Aurora))
|
||||
(check-eq? (find (lambda (x) #t) '(Aurora))
|
||||
'Aurora))
|
||||
|
||||
(make-test-case
|
||||
(test-case
|
||||
"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"
|
||||
(assert-eq?
|
||||
(check-eq?
|
||||
(find (lambda (x) #t) '(Avery Avoca Avon Ayrshire Badger))
|
||||
'Avery))
|
||||
|
||||
(make-test-case
|
||||
(test-case
|
||||
"find:in-middle-of-longer-list"
|
||||
(assert =
|
||||
(check =
|
||||
(find even? '(149 151 153 155 156 157 159))
|
||||
156))
|
||||
|
||||
(make-test-case
|
||||
(test-case
|
||||
"find:at-end-of-longer-list"
|
||||
(assert =
|
||||
(check =
|
||||
(find even? '(161 163 165 167 168))
|
||||
168))
|
||||
|
||||
(make-test-case
|
||||
(test-case
|
||||
"find:not-in-longer-list"
|
||||
(assert-true
|
||||
(check-true
|
||||
(not
|
||||
(find (lambda (x) #f)
|
||||
'(Bagley Bailey Badwin Balfour Balltown)))))
|
||||
|
||||
;;; FIND-TAIL
|
||||
|
||||
(make-test-case
|
||||
(test-case
|
||||
"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"
|
||||
(let ((source '(Ballyclough)))
|
||||
(assert-eq?
|
||||
(check-eq?
|
||||
(find-tail (lambda (x) #t) source)
|
||||
source)))
|
||||
|
||||
(make-test-case
|
||||
(test-case
|
||||
"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"
|
||||
(let ((source '(Bangor Bankston Barney Barnum Bartlett)))
|
||||
(assert-eq?
|
||||
(check-eq?
|
||||
(find-tail (lambda (x) #t) source)
|
||||
source)))
|
||||
|
||||
(make-test-case
|
||||
(test-case
|
||||
"find-tail:in-middle-of-longer-list"
|
||||
(let ((source '(169 171 173 175 176 177 179)))
|
||||
(assert-eq?
|
||||
(check-eq?
|
||||
(find-tail even? source)
|
||||
(cddddr source))))
|
||||
|
||||
(make-test-case
|
||||
(test-case
|
||||
"find-tail:at-end-of-longer-list"
|
||||
(let ((source '(181 183 185 187 188)))
|
||||
(assert-eq?
|
||||
(check-eq?
|
||||
(find-tail even? source)
|
||||
(cddddr source))))
|
||||
|
||||
(make-test-case
|
||||
(test-case
|
||||
"find-tail:not-in-longer-list"
|
||||
(assert-true
|
||||
(check-true
|
||||
(not
|
||||
(find-tail (lambda (x) #f)
|
||||
'(Batavia Bauer Baxter Bayard Beacon)) )))
|
||||
|
||||
;;; ANY
|
||||
|
||||
(make-test-case
|
||||
(test-case
|
||||
"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"
|
||||
(assert-equal? (any vector '(Beaconsfield)) '#(Beaconsfield)))
|
||||
(check-equal? (any vector '(Beaconsfield)) '#(Beaconsfield)))
|
||||
|
||||
(make-test-case
|
||||
(test-case
|
||||
"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"
|
||||
(assert-equal?
|
||||
(check-equal?
|
||||
(any vector '(Beaver Beaverdale Beckwith Bedford Beebeetown))
|
||||
'#(Beaver)))
|
||||
|
||||
(make-test-case
|
||||
(test-case
|
||||
"any:in-middle-of-one-longer-list"
|
||||
(assert =
|
||||
(check =
|
||||
(any (lambda (x) (and (odd? x) (+ x 189)))
|
||||
'(190 192 194 196 197 198 200))
|
||||
386))
|
||||
|
||||
(make-test-case
|
||||
(test-case
|
||||
"any:at-end-of-one-longer-list"
|
||||
(assert =
|
||||
(check =
|
||||
(any (lambda (x) (and (odd? x) (+ x 201)))
|
||||
'(202 204 206 208 209))
|
||||
410))
|
||||
|
||||
(make-test-case
|
||||
(test-case
|
||||
"any:not-in-one-longer-list"
|
||||
(assert-true
|
||||
(check-true
|
||||
(not (any (lambda (x) #f)
|
||||
'(Beech Belinda Belknap Bellefountain Bellevue)))))
|
||||
|
||||
(make-test-case
|
||||
(test-case
|
||||
"any:in-several-null-lists"
|
||||
(assert-true
|
||||
(check-true
|
||||
(not (any vector '() '() '() '() '()))))
|
||||
|
||||
(make-test-case
|
||||
(test-case
|
||||
"any:in-several-singleton-lists"
|
||||
(assert-equal?
|
||||
(check-equal?
|
||||
(any vector
|
||||
'(Belmond)
|
||||
'(Beloit)
|
||||
|
|
@ -185,9 +185,9 @@
|
|||
'(Bentley))
|
||||
'#(Belmond Beloit Bennett Benson Bentley)))
|
||||
|
||||
(make-test-case
|
||||
(test-case
|
||||
"any:not-in-several-singleton-lists"
|
||||
(assert-true
|
||||
(check-true
|
||||
(not
|
||||
(any (lambda arguments #f)
|
||||
'(Benton)
|
||||
|
|
@ -196,9 +196,9 @@
|
|||
'(Berkley)
|
||||
'(Bernard)))))
|
||||
|
||||
(make-test-case
|
||||
(test-case
|
||||
"any:at-beginning-of-several-longer-lists"
|
||||
(assert-equal?
|
||||
(check-equal?
|
||||
(any vector
|
||||
'(Berne Bertram Berwick Bethesda Bethlehem Bettendorf
|
||||
Beulah)
|
||||
|
|
@ -210,9 +210,9 @@
|
|||
'(Booneville Botany Botna Bouton Bowsher Boxholm Boyd))
|
||||
'#(Berne Bevington Blakesburg Bluffton Booneville)))
|
||||
|
||||
(make-test-case
|
||||
(test-case
|
||||
"any:in-middle-of-several-longer-lists"
|
||||
(assert =
|
||||
(check =
|
||||
(any (lambda arguments
|
||||
(let ((sum (apply + arguments)))
|
||||
(and (odd? sum) (+ sum 210))))
|
||||
|
|
@ -223,9 +223,9 @@
|
|||
'(240 242 244 246 247 248 250))
|
||||
1359))
|
||||
|
||||
(make-test-case
|
||||
(test-case
|
||||
"any:at-end-of-several-longer-lists"
|
||||
(assert =
|
||||
(check =
|
||||
(any (lambda arguments
|
||||
(let ((sum (apply + arguments)))
|
||||
(and (even? sum) (+ sum 210))))
|
||||
|
|
@ -236,9 +236,9 @@
|
|||
'(281 283 285 287 289 291 292))
|
||||
1576))
|
||||
|
||||
(make-test-case
|
||||
(test-case
|
||||
"any:not-in-several-longer-lists"
|
||||
(assert-true
|
||||
(check-true
|
||||
(not
|
||||
(any (lambda arguments #f)
|
||||
'(Boyden Boyer Braddyville Bradford Bradgate Brainard
|
||||
|
|
@ -252,9 +252,9 @@
|
|||
'(Buckeye Buckhorn Buckingham Bucknell Budd Buffalo
|
||||
Burchinal)))))
|
||||
|
||||
(make-test-case
|
||||
(test-case
|
||||
"any:not-in-lists-of-unequal-length"
|
||||
(assert-true
|
||||
(check-true
|
||||
(not (any (lambda arguments #f)
|
||||
'(Burdette Burlington Burnside Burt)
|
||||
'(Bushville Bussey)
|
||||
|
|
@ -263,57 +263,57 @@
|
|||
|
||||
;;; EVERY
|
||||
|
||||
(make-test-case
|
||||
(test-case
|
||||
"every:in-one-null-list"
|
||||
(assert-true (every values '())))
|
||||
(check-true (every values '())))
|
||||
|
||||
(make-test-case
|
||||
(test-case
|
||||
"every:in-one-singleton-list"
|
||||
(assert-equal?
|
||||
(check-equal?
|
||||
(every vector '(Camanche))
|
||||
'#(Camanche)))
|
||||
|
||||
(make-test-case
|
||||
(test-case
|
||||
"every:not-in-one-singleton-list"
|
||||
(assert-true
|
||||
(check-true
|
||||
(not (every (lambda (x) #f) '(Cambria)))))
|
||||
|
||||
(make-test-case
|
||||
(test-case
|
||||
"every:failing-at-beginning-of-one-longer-list"
|
||||
(assert-true
|
||||
(check-true
|
||||
(not
|
||||
(every (lambda (x) #f)
|
||||
'(Cambridge Cameron Canby Canton Cantril)) )))
|
||||
|
||||
(make-test-case
|
||||
(test-case
|
||||
"every:failing-in-middle-of-one-longer-list"
|
||||
(assert-true
|
||||
(check-true
|
||||
(not
|
||||
(every (lambda (x) (and (even? x) (+ x 293)))
|
||||
'(294 296 298 300 301 302 304)))))
|
||||
|
||||
(make-test-case
|
||||
(test-case
|
||||
"every:failing-at-end-of-one-longer-list"
|
||||
(assert-true
|
||||
(check-true
|
||||
(not
|
||||
(every (lambda (x) (and (even? x) (+ x 305)))
|
||||
'(306 308 310 312 313)))))
|
||||
|
||||
(make-test-case
|
||||
(test-case
|
||||
"every:in-one-longer-list"
|
||||
(assert-equal?
|
||||
(check-equal?
|
||||
(every vector
|
||||
'(Carbon Carbondale Carl Carlisle Carmel))
|
||||
'#(Carmel)))
|
||||
|
||||
(make-test-case
|
||||
(test-case
|
||||
"every:in-several-null-lists"
|
||||
(assert-true
|
||||
(check-true
|
||||
(every vector '() '() '() '() '())))
|
||||
|
||||
(make-test-case
|
||||
(test-case
|
||||
"every:in-several-singleton-lists"
|
||||
(assert-equal?
|
||||
(check-equal?
|
||||
(every vector
|
||||
'(Carnarvon)
|
||||
'(Carnes)
|
||||
|
|
@ -322,9 +322,9 @@
|
|||
'(Carpenter))
|
||||
'#(Carnarvon Carnes Carney Carnforth Carpenter)))
|
||||
|
||||
(make-test-case
|
||||
(test-case
|
||||
"every:not-in-several-singleton-lists"
|
||||
(assert-true
|
||||
(check-true
|
||||
(not
|
||||
(every (lambda arguments #f)
|
||||
'(Carroll)
|
||||
|
|
@ -333,9 +333,9 @@
|
|||
'(Carson)
|
||||
'(Cartersville)))))
|
||||
|
||||
(make-test-case
|
||||
(test-case
|
||||
"every:failing-at-beginning-of-several-longer-lists"
|
||||
(assert-true
|
||||
(check-true
|
||||
(not
|
||||
(every (lambda arguments #f)
|
||||
'(Cascade Casey Castalia Castana Cattese Cedar
|
||||
|
|
@ -350,9 +350,9 @@
|
|||
Clearfield))
|
||||
)))
|
||||
|
||||
(make-test-case
|
||||
(test-case
|
||||
"every:failing-in-middle-of-several-longer-lists"
|
||||
(assert-true
|
||||
(check-true
|
||||
(not
|
||||
(every (lambda arguments
|
||||
(let ((sum (apply + arguments)))
|
||||
|
|
@ -364,9 +364,9 @@
|
|||
'(343 345 347 349 350 351 353))
|
||||
)))
|
||||
|
||||
(make-test-case
|
||||
(test-case
|
||||
"every:failing-at-end-of-several-longer-lists"
|
||||
(assert-true
|
||||
(check-true
|
||||
(not
|
||||
(every (lambda arguments
|
||||
(let ((sum (apply + arguments)))
|
||||
|
|
@ -378,9 +378,9 @@
|
|||
'(383 385 387 389 391 393 394))
|
||||
)))
|
||||
|
||||
(make-test-case
|
||||
(test-case
|
||||
"every:in-several-longer-lists"
|
||||
(assert-equal?
|
||||
(check-equal?
|
||||
(every vector
|
||||
'(Cleghorn Clemons Clermont Cleves Cliffland Climax
|
||||
Clinton)
|
||||
|
|
@ -392,9 +392,9 @@
|
|||
Consol))
|
||||
'#(Clinton Coalville Collins Concord Consol)))
|
||||
|
||||
(make-test-case
|
||||
(test-case
|
||||
"every:in-lists-of-unequal-length"
|
||||
(assert-equal?
|
||||
(check-equal?
|
||||
(every vector
|
||||
'(Conway Cool Cooper Coppock)
|
||||
'(Coralville Corley)
|
||||
|
|
@ -405,55 +405,55 @@
|
|||
|
||||
;;; LIST-INDEX
|
||||
|
||||
(make-test-case
|
||||
(test-case
|
||||
"list-index:in-one-null-list"
|
||||
(assert-true
|
||||
(check-true
|
||||
(not (list-index (lambda (x) #t) '()))))
|
||||
|
||||
(make-test-case
|
||||
(test-case
|
||||
"list-index:in-one-singleton-list"
|
||||
(assert-true
|
||||
(check-true
|
||||
(zero?
|
||||
(list-index (lambda (x) #t) '(Cottonville)))))
|
||||
|
||||
(make-test-case
|
||||
(test-case
|
||||
"list-index:not-in-one-singleton-list"
|
||||
(assert-true
|
||||
(check-true
|
||||
(not (list-index (lambda (x) #f) '(Coulter)))))
|
||||
|
||||
(make-test-case
|
||||
(test-case
|
||||
"list-index:at-front-of-one-longer-list"
|
||||
(assert-true
|
||||
(check-true
|
||||
(zero?
|
||||
(list-index (lambda (x) #t)
|
||||
'(Covington Craig Cranston Crathorne
|
||||
Crawfordsville)))))
|
||||
(make-test-case
|
||||
(test-case
|
||||
"list-index:in-middle-of-one-longer-list"
|
||||
(list-index even? '(395 397 399 401 402 403 405))
|
||||
(lambda (result) (= result 4)))
|
||||
|
||||
(make-test-case
|
||||
(test-case
|
||||
"list-index:at-end-of-one-longer-list"
|
||||
(assert =
|
||||
(check =
|
||||
(list-index odd? '(406 408 410 412 414 415))
|
||||
5))
|
||||
|
||||
(make-test-case
|
||||
(test-case
|
||||
"list-index:not-in-one-longer-list"
|
||||
(assert-true
|
||||
(check-true
|
||||
(not
|
||||
(list-index (lambda (x) #f)
|
||||
'(Crescent Cresco Creston Crocker Crombie)))))
|
||||
|
||||
(make-test-case
|
||||
(test-case
|
||||
"list-index:in-several-null-lists"
|
||||
(assert-true
|
||||
(check-true
|
||||
(not (list-index (lambda arguments #t) '() '() '() '() '()))))
|
||||
|
||||
(make-test-case
|
||||
(test-case
|
||||
"list-index:in-several-singleton-lists"
|
||||
(assert-true
|
||||
(check-true
|
||||
(zero? (list-index (lambda arguments #t)
|
||||
'(Cromwell)
|
||||
'(Croton)
|
||||
|
|
@ -461,9 +461,9 @@
|
|||
'(Cumming)
|
||||
'(Curlew)))))
|
||||
|
||||
(make-test-case
|
||||
(test-case
|
||||
"list-index:not-in-several-singleton-lists"
|
||||
(assert-true
|
||||
(check-true
|
||||
(not (list-index (lambda arguments #f)
|
||||
'(Cushing)
|
||||
'(Cylinder)
|
||||
|
|
@ -471,9 +471,9 @@
|
|||
'(Dalby)
|
||||
'(Dale)))))
|
||||
|
||||
(make-test-case
|
||||
(test-case
|
||||
"list-index:at-front-of-several-longer-lists"
|
||||
(assert-true
|
||||
(check-true
|
||||
(zero? (list-index (lambda arguments #t)
|
||||
'(Dallas Dana Danbury Danville Darbyville
|
||||
Davenport Dawson)
|
||||
|
|
@ -485,9 +485,9 @@
|
|||
'(Dewar Dexter Diagonal Dickens Dickieville Dike
|
||||
Dillon)))))
|
||||
|
||||
(make-test-case
|
||||
(test-case
|
||||
"list-index:in-middle-of-several-longer-lists"
|
||||
(assert =
|
||||
(check =
|
||||
(list-index (lambda arguments (odd? (apply + arguments)))
|
||||
'(416 417 418 419 420 421 422)
|
||||
'(423 424 425 426 427 428 429)
|
||||
|
|
@ -496,9 +496,9 @@
|
|||
'(444 446 448 450 451 452 454))
|
||||
4))
|
||||
|
||||
(make-test-case
|
||||
(test-case
|
||||
"list-index:at-end-of-several-longer-lists"
|
||||
(assert =
|
||||
(check =
|
||||
(list-index (lambda arguments (even? (apply + arguments)))
|
||||
'(455 456 457 458 459 460)
|
||||
'(461 462 463 464 465 466)
|
||||
|
|
@ -507,9 +507,9 @@
|
|||
'(479 481 483 485 487 488))
|
||||
5))
|
||||
|
||||
(make-test-case
|
||||
(test-case
|
||||
"list-index:not-in-several-longer-lists"
|
||||
(assert-true
|
||||
(check-true
|
||||
(not
|
||||
(list-index (lambda arguments #f)
|
||||
'(Dinsdale Dixon Dodgeville Dolliver Donahue
|
||||
|
|
|
|||
|
|
@ -35,214 +35,214 @@
|
|||
(module selector-test
|
||||
mzscheme
|
||||
|
||||
(require (planet "test.ss" ("schematics" "schemeunit.plt" 1 1))
|
||||
(require (planet "test.ss" ("schematics" "schemeunit.plt" 2))
|
||||
(lib "selector.ss" "srfi" "1"))
|
||||
|
||||
(provide selector-tests)
|
||||
|
||||
(define selector-tests
|
||||
(make-test-suite
|
||||
(test-suite
|
||||
"List selector tests"
|
||||
|
||||
;; FIRST
|
||||
|
||||
(make-test-case
|
||||
(test-case
|
||||
"first:of-one"
|
||||
(assert-eq? (first '(hafnium)) 'hafnium))
|
||||
(check-eq? (first '(hafnium)) 'hafnium))
|
||||
|
||||
(make-test-case
|
||||
(test-case
|
||||
"first:of-many"
|
||||
(assert-eq? (first '(hahnium helium holmium hydrogen indium))
|
||||
(check-eq? (first '(hahnium helium holmium hydrogen indium))
|
||||
'hahnium))
|
||||
|
||||
;; SECOND
|
||||
|
||||
(make-test-case
|
||||
(test-case
|
||||
"second:of-two"
|
||||
(assert-eq? (second '(iodine iridium)) 'iridium))
|
||||
(check-eq? (second '(iodine iridium)) 'iridium))
|
||||
|
||||
(make-test-case
|
||||
(test-case
|
||||
"second:of-many"
|
||||
(assert-eq? (second '(iron krypton lanthanum lawrencium lead lithium))
|
||||
(check-eq? (second '(iron krypton lanthanum lawrencium lead lithium))
|
||||
'krypton))
|
||||
|
||||
;; THIRD
|
||||
|
||||
(make-test-case
|
||||
(test-case
|
||||
"third:of-three"
|
||||
(assert-eq? (third '(lutetium magnesium manganese))
|
||||
(check-eq? (third '(lutetium magnesium manganese))
|
||||
'manganese))
|
||||
|
||||
(make-test-case
|
||||
(test-case
|
||||
"third:of-many"
|
||||
(assert-eq? (third '(mendelevium mercury molybdenum neodymium neon
|
||||
(check-eq? (third '(mendelevium mercury molybdenum neodymium neon
|
||||
neptunium nickel))
|
||||
'molybdenum))
|
||||
|
||||
;; FOURTH
|
||||
|
||||
(make-test-case
|
||||
(test-case
|
||||
"fourth:of-four"
|
||||
(assert-eq? (fourth '(niobium nitrogen nobelium osmium))
|
||||
(check-eq? (fourth '(niobium nitrogen nobelium osmium))
|
||||
'osmium))
|
||||
|
||||
(make-test-case
|
||||
(test-case
|
||||
"fourth:of-many"
|
||||
(assert-eq? (fourth '(oxygen palladium phosphorus platinum plutonium
|
||||
(check-eq? (fourth '(oxygen palladium phosphorus platinum plutonium
|
||||
polonium potassium praseodymium))
|
||||
'platinum))
|
||||
|
||||
;; FIFTH
|
||||
|
||||
(make-test-case
|
||||
(test-case
|
||||
"fifth:of-five"
|
||||
(assert-eq? (fifth '(promethium protatctinium radium radon rhenium))
|
||||
(check-eq? (fifth '(promethium protatctinium radium radon rhenium))
|
||||
'rhenium))
|
||||
|
||||
(make-test-case
|
||||
(test-case
|
||||
"fifth:of-many"
|
||||
(assert-eq? (fifth '(rhodium rubidium ruthenium rutherfordium samarium
|
||||
(check-eq? (fifth '(rhodium rubidium ruthenium rutherfordium samarium
|
||||
scandium selenium silicon silver))
|
||||
'samarium))
|
||||
|
||||
;; SIXTH
|
||||
|
||||
(make-test-case
|
||||
(test-case
|
||||
"sixth:of-six"
|
||||
(assert-eq? (sixth '(sodium strontium sulfur tantalum technetium
|
||||
(check-eq? (sixth '(sodium strontium sulfur tantalum technetium
|
||||
tellurium))
|
||||
'tellurium))
|
||||
|
||||
(make-test-case
|
||||
(test-case
|
||||
"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))
|
||||
'titanium))
|
||||
|
||||
;; SEVENTH
|
||||
|
||||
(make-test-case
|
||||
(test-case
|
||||
"seventh:of-seven"
|
||||
(assert-eq? (seventh '(ytterbium yttrium zinc zirconium acacia abele
|
||||
(check-eq? (seventh '(ytterbium yttrium zinc zirconium acacia abele
|
||||
ailanthus))
|
||||
'ailanthus))
|
||||
|
||||
(make-test-case
|
||||
(test-case
|
||||
"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))
|
||||
'aspen))
|
||||
|
||||
;; EIGHTH
|
||||
|
||||
(make-test-case
|
||||
(test-case
|
||||
"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))
|
||||
|
||||
(make-test-case
|
||||
(test-case
|
||||
"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
|
||||
chinquapin))
|
||||
'cedar))
|
||||
|
||||
;; NINTH
|
||||
|
||||
(make-test-case
|
||||
(test-case
|
||||
"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))
|
||||
'dogwood))
|
||||
|
||||
(make-test-case
|
||||
(test-case
|
||||
"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))
|
||||
|
||||
;; TENTH
|
||||
|
||||
(make-test-case
|
||||
(test-case
|
||||
"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))
|
||||
'laburnum))
|
||||
|
||||
(make-test-case
|
||||
(test-case
|
||||
"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
|
||||
mangrove maple))
|
||||
'magnolia))
|
||||
|
||||
;; CAR+CDR
|
||||
|
||||
(make-test-case
|
||||
(test-case
|
||||
"car+cdr:pair"
|
||||
(let-values (((first second) (car+cdr (cons 'a 'b))))
|
||||
(assert-eq? first 'a)
|
||||
(assert-eq? second 'b)))
|
||||
(check-eq? first 'a)
|
||||
(check-eq? second 'b)))
|
||||
|
||||
(make-test-case
|
||||
(test-case
|
||||
"car+cdr:list"
|
||||
(let-values (((first second) (car+cdr (list 'a 'b))))
|
||||
(assert-eq? first 'a)
|
||||
(assert-equal? second (list 'b))))
|
||||
(check-eq? first 'a)
|
||||
(check-equal? second (list 'b))))
|
||||
|
||||
;; TAKE
|
||||
|
||||
(make-test-case
|
||||
(test-case
|
||||
"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)))
|
||||
|
||||
(make-test-case
|
||||
(test-case
|
||||
"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)))
|
||||
|
||||
(make-test-case
|
||||
(test-case
|
||||
"take:rear-of-list"
|
||||
(assert-equal?
|
||||
(check-equal?
|
||||
(take-right '(pecan persimmon pine pistachio plane plum pomegranite) 5)
|
||||
'(pine pistachio plane plum pomegranite)))
|
||||
|
||||
(make-test-case
|
||||
(test-case
|
||||
"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"
|
||||
(assert-true (null? (take '() 0))))
|
||||
(check-true (null? (take '() 0))))
|
||||
|
||||
;; DROP
|
||||
|
||||
(make-test-case
|
||||
(test-case
|
||||
"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"
|
||||
(assert-equal? (drop '(sequoia serviceberry spruce sycamore tamarack tamarind
|
||||
(check-equal? (drop '(sequoia serviceberry spruce sycamore tamarack tamarind
|
||||
tamarugo)
|
||||
5)
|
||||
'(tamarind tamarugo)))
|
||||
|
||||
(make-test-case
|
||||
(test-case
|
||||
"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)))
|
||||
|
||||
(make-test-case
|
||||
(test-case
|
||||
"drop:none-of-list"
|
||||
(assert-equal? (drop '(whitebeam whitethorn wicopy) 0)
|
||||
(check-equal? (drop '(whitebeam whitethorn wicopy) 0)
|
||||
'(whitebeam whitethorn wicopy)))
|
||||
|
||||
(make-test-case
|
||||
(test-case
|
||||
"drop:empty-list"
|
||||
(assert-true (null? (drop '() 0))))
|
||||
(check-true (null? (drop '() 0))))
|
||||
|
||||
;; TAKE!
|
||||
|
||||
|
|
@ -250,14 +250,14 @@
|
|||
;; with the LIST procedure rather than as quoted data, since in
|
||||
;; some implementations quoted data are not mutable.
|
||||
|
||||
(make-test-case
|
||||
(test-case
|
||||
"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)))
|
||||
|
||||
(make-test-case
|
||||
(test-case
|
||||
"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)
|
||||
5)
|
||||
'(ylang-ylang zebrawood affenpinscher afghan airedale)))
|
||||
|
|
@ -270,69 +270,69 @@
|
|||
; (equal? result '(beagle bloodhound boarhound borzoi
|
||||
; boxer))))
|
||||
|
||||
(make-test-case
|
||||
(test-case
|
||||
"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"
|
||||
(assert-true (null? (take! '() 0))))
|
||||
(check-true (null? (take! '() 0))))
|
||||
|
||||
;; DROP-RIGHT!
|
||||
|
||||
(make-test-case
|
||||
(test-case
|
||||
"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))))
|
||||
|
||||
(make-test-case
|
||||
(test-case
|
||||
"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)
|
||||
5)
|
||||
'(groenendael harrier)))
|
||||
|
||||
(make-test-case
|
||||
(test-case
|
||||
"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)))
|
||||
|
||||
(make-test-case
|
||||
(test-case
|
||||
"drop-right!:empty-list"
|
||||
(assert-true (null? (drop-right! '() 0))))
|
||||
(check-true (null? (drop-right! '() 0))))
|
||||
|
||||
;; LAST
|
||||
|
||||
(make-test-case
|
||||
(test-case
|
||||
"last:of-singleton"
|
||||
(assert-eq? (last '(maltese))
|
||||
(check-eq? (last '(maltese))
|
||||
'maltese))
|
||||
|
||||
(make-test-case
|
||||
(test-case
|
||||
"last:of-longer-list"
|
||||
(assert-eq? (last '(mastiff newfoundland nizinny otterhound papillon))
|
||||
(check-eq? (last '(mastiff newfoundland nizinny otterhound papillon))
|
||||
'papillon))
|
||||
|
||||
;; LAST-PAIR
|
||||
|
||||
(make-test-case
|
||||
(test-case
|
||||
"last-pair:of-singleton"
|
||||
(let ((pair '(pekingese)))
|
||||
(assert-eq? (last-pair pair)
|
||||
(check-eq? (last-pair pair)
|
||||
pair)))
|
||||
|
||||
(make-test-case
|
||||
(test-case
|
||||
"last-pair:of-longer-list"
|
||||
(let ((pair '(pointer)))
|
||||
(assert-eq? (last-pair (cons 'pomeranian
|
||||
(check-eq? (last-pair (cons 'pomeranian
|
||||
(cons 'poodle
|
||||
(cons 'pug (cons 'puli pair)))))
|
||||
pair)))
|
||||
|
||||
(make-test-case
|
||||
(test-case
|
||||
"last-pair:of-improper-list"
|
||||
(let ((pair '(manx . siamese)))
|
||||
(assert-eq? (last-pair (cons 'abyssinian (cons 'calico pair)))
|
||||
(check-eq? (last-pair (cons 'abyssinian (cons 'calico pair)))
|
||||
pair)))
|
||||
|
||||
))
|
||||
|
|
|
|||
82
collects/tests/srfi/13/string-test.ss
Normal file
82
collects/tests/srfi/13/string-test.ss
Normal 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
237
collects/tests/srfi/14/char-set-test.ss
Normal 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
194
collects/tests/srfi/2/and-let-test.ss
Normal 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
83
collects/tests/srfi/26/cut-test.ss
Normal 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
|
||||
|
|
@ -1,6 +1,6 @@
|
|||
(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")
|
||||
(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))
|
||||
|
||||
(define hash-tests
|
||||
(make-test-suite
|
||||
(test-suite
|
||||
"srfi-69 test suite"
|
||||
(make-test-case
|
||||
(test-case
|
||||
"make-hash-table and hash-table?"
|
||||
(assert-true
|
||||
(check-true
|
||||
(h:hash-table? (h:make-hash-table))))
|
||||
(make-test-case
|
||||
(test-case
|
||||
"alist->hash-table"
|
||||
(assert-true
|
||||
(check-true
|
||||
(h:hash-table? test-hash-table1)))
|
||||
(make-test-case
|
||||
(test-case
|
||||
"hash-table-equivalence-function"
|
||||
(assert-eq?
|
||||
(check-eq?
|
||||
(h:hash-table-equivalence-function (h:make-hash-table))
|
||||
equal?)
|
||||
(assert-eq?
|
||||
(check-eq?
|
||||
(h:hash-table-equivalence-function (h:make-hash-table eq?))
|
||||
eq?)
|
||||
(assert-eq?
|
||||
(check-eq?
|
||||
(h:hash-table-equivalence-function test-hash-table2)
|
||||
string-ci=?))
|
||||
(make-test-case
|
||||
(test-case
|
||||
"hash-table-hash-function"
|
||||
(assert-eq?
|
||||
(check-eq?
|
||||
(h:hash-table-hash-function (h:make-hash-table))
|
||||
h:hash)
|
||||
(assert-eq?
|
||||
(check-eq?
|
||||
(h:hash-table-hash-function (h:make-hash-table eq?))
|
||||
h:hash-by-identity)
|
||||
(assert-eq?
|
||||
(check-eq?
|
||||
(h:hash-table-hash-function test-hash-table2)
|
||||
h:string-ci-hash))
|
||||
(make-test-case
|
||||
(test-case
|
||||
"hash-table-ref"
|
||||
(assert-equal?
|
||||
(check-equal?
|
||||
(h:hash-table-ref test-hash-table1 'b)
|
||||
2)
|
||||
(assert-equal?
|
||||
(check-equal?
|
||||
(h:hash-table-ref test-hash-table2 "C")
|
||||
3)
|
||||
(assert-false
|
||||
(check-false
|
||||
(h:hash-table-ref test-hash-table1 'd (lambda () #f))))
|
||||
(make-test-case
|
||||
(test-case
|
||||
"hash-table-ref/default"
|
||||
(assert-false
|
||||
(check-false
|
||||
(h:hash-table-ref/default test-hash-table2 "d" #f)))
|
||||
(make-test-case
|
||||
(test-case
|
||||
"hash-table-set!"
|
||||
(assert-equal?
|
||||
(check-equal?
|
||||
(begin (h:hash-table-set! test-hash-table1 'c 4)
|
||||
(h:hash-table-ref test-hash-table1 'c))
|
||||
4)
|
||||
(assert-equal?
|
||||
(check-equal?
|
||||
(begin (h:hash-table-set! test-hash-table2 "d" 4)
|
||||
(h:hash-table-ref test-hash-table2 "D"))
|
||||
4))
|
||||
(make-test-case
|
||||
(test-case
|
||||
"hash-table-delete!"
|
||||
(assert-false
|
||||
(check-false
|
||||
(begin (h:hash-table-delete! test-hash-table2 "D")
|
||||
(h:hash-table-ref/default test-hash-table2 "d" #f))))
|
||||
(make-test-case
|
||||
(test-case
|
||||
"hash-table-exists?"
|
||||
(assert-true
|
||||
(check-true
|
||||
(h:hash-table-exists? test-hash-table2 "B"))
|
||||
(assert-false
|
||||
(check-false
|
||||
(h:hash-table-exists? test-hash-table1 'd)))
|
||||
(make-test-case
|
||||
(test-case
|
||||
"hash-table-update!"
|
||||
(assert-equal?
|
||||
(check-equal?
|
||||
(begin (h:hash-table-update! test-hash-table1 'c sub1)
|
||||
(h:hash-table-ref test-hash-table1 'c))
|
||||
3)
|
||||
(assert-equal?
|
||||
(check-equal?
|
||||
(begin (h:hash-table-update! test-hash-table2 "d" add1 (lambda () 3))
|
||||
(h:hash-table-ref test-hash-table2 "d"))
|
||||
4))
|
||||
(make-test-case
|
||||
(test-case
|
||||
"hash-table-update!/default"
|
||||
(assert-equal?
|
||||
(check-equal?
|
||||
(begin (h:hash-table-update!/default test-hash-table1 'd add1 3)
|
||||
(h:hash-table-ref test-hash-table1 'd))
|
||||
4))
|
||||
(make-test-case
|
||||
(test-case
|
||||
"hash-table-size"
|
||||
(assert-equal?
|
||||
(check-equal?
|
||||
(h:hash-table-size test-hash-table1)
|
||||
4)
|
||||
(assert-equal?
|
||||
(check-equal?
|
||||
(h:hash-table-size test-hash-table2)
|
||||
4))
|
||||
(make-test-case
|
||||
(test-case
|
||||
"hash-table-keys"
|
||||
(assert-true
|
||||
(check-true
|
||||
(lset= eq?
|
||||
(h:hash-table-keys test-hash-table1)
|
||||
'(a b c d)))
|
||||
(assert-true
|
||||
(check-true
|
||||
(lset= equal?
|
||||
(h:hash-table-keys test-hash-table2)
|
||||
(list "a" "b" "c" "d"))))
|
||||
(make-test-case
|
||||
(test-case
|
||||
"hash-table-values"
|
||||
(assert-true
|
||||
(check-true
|
||||
(lset= eqv?
|
||||
(h:hash-table-values test-hash-table1)
|
||||
'(1 2 3 4)))
|
||||
(assert-true
|
||||
(check-true
|
||||
(lset= eqv?
|
||||
(h:hash-table-values test-hash-table2)
|
||||
'(1 2 3 4))))
|
||||
(make-test-case
|
||||
(test-case
|
||||
"hash-table-walk"
|
||||
(assert-true
|
||||
(check-true
|
||||
(let ((a '()))
|
||||
(h:hash-table-walk test-hash-table1
|
||||
(lambda (key value)
|
||||
|
|
@ -134,9 +134,9 @@
|
|||
(lset= equal?
|
||||
a
|
||||
'((a . 1) (b . 2) (c . 3) (d . 4))))))
|
||||
(make-test-case
|
||||
(test-case
|
||||
"hash-table-fold"
|
||||
(assert-true
|
||||
(check-true
|
||||
(lset= equal?
|
||||
(h:hash-table-fold test-hash-table2
|
||||
(lambda (key value accu)
|
||||
|
|
@ -146,37 +146,37 @@
|
|||
(cons "b" 2)
|
||||
(cons "c" 3)
|
||||
(cons "d" 4)))))
|
||||
(make-test-case
|
||||
(test-case
|
||||
"hash-table->alist"
|
||||
(assert-true
|
||||
(check-true
|
||||
(lset= equal?
|
||||
(h:hash-table->alist test-hash-table1)
|
||||
'((a . 1) (b . 2) (c . 3) (d . 4)))))
|
||||
(make-test-case
|
||||
(test-case
|
||||
"hash-table-copy"
|
||||
(assert-true
|
||||
(check-true
|
||||
(lset= equal?
|
||||
(h:hash-table->alist (h:hash-table-copy test-hash-table2))
|
||||
(list (cons "a" 1)
|
||||
(cons "b" 2)
|
||||
(cons "c" 3)
|
||||
(cons "d" 4))))
|
||||
(assert-false
|
||||
(check-false
|
||||
(eq? (h:hash-table-copy test-hash-table1)
|
||||
test-hash-table1))
|
||||
(assert-eq?
|
||||
(check-eq?
|
||||
(h:hash-table-equivalence-function
|
||||
test-hash-table1)
|
||||
(h:hash-table-equivalence-function
|
||||
(h:hash-table-copy test-hash-table1)))
|
||||
(assert-eq?
|
||||
(check-eq?
|
||||
(h:hash-table-hash-function
|
||||
test-hash-table2)
|
||||
(h:hash-table-hash-function
|
||||
(h:hash-table-copy test-hash-table2))))
|
||||
(make-test-case
|
||||
(test-case
|
||||
"hash-table->alist"
|
||||
(assert-true
|
||||
(check-true
|
||||
(lset= equal?
|
||||
(h:hash-table->alist
|
||||
(h:hash-table-merge! test-hash-table1
|
||||
|
|
@ -189,7 +189,7 @@
|
|||
(b . 2)
|
||||
(c . 3)
|
||||
(d . 4))))
|
||||
(assert-true
|
||||
(check-true
|
||||
(lset= equal?
|
||||
(h:hash-table->alist
|
||||
(h:hash-table-merge! test-hash-table2
|
||||
|
|
|
|||
|
|
@ -1,26 +1,26 @@
|
|||
(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"
|
||||
"2/and-let-test.ss"
|
||||
"13/string-test.ss"
|
||||
"14/char-set-test.ss"
|
||||
"26/cut-test.ss"
|
||||
"40/all-srfi-40-tests.ss"
|
||||
"43/all-srfi-43-tests.ss"
|
||||
;"40/all-srfi-40-tests.ss"
|
||||
;"43/all-srfi-43-tests.ss"
|
||||
"69/hash-tests.ss")
|
||||
(provide all-srfi-tests)
|
||||
|
||||
(define all-srfi-tests
|
||||
(make-test-suite
|
||||
(test-suite
|
||||
"all-srfi-tests"
|
||||
all-1-tests
|
||||
and-let*-tests
|
||||
string-tests
|
||||
char-set-tests
|
||||
cut-tests
|
||||
all-srfi-40-tests
|
||||
all-srfi-43-tests
|
||||
;all-srfi-40-tests
|
||||
;all-srfi-43-tests
|
||||
hash-tests
|
||||
))
|
||||
)
|
||||
|
|
|
|||
|
|
@ -1,5 +1,5 @@
|
|||
(require (planet "test.ss" ("schematics" "schemeunit.plt" 1 1)))
|
||||
(require (planet "text-ui.ss" ("schematics" "schemeunit.plt" 1 1)))
|
||||
(require (planet "test.ss" ("schematics" "schemeunit.plt" 2)))
|
||||
(require (planet "text-ui.ss" ("schematics" "schemeunit.plt" 2)))
|
||||
(require "all-srfi-tests.ss")
|
||||
|
||||
(test/text-ui all-srfi-tests)
|
||||
|
|
|
|||
Loading…
Reference in New Issue
Block a user