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

Test suites for SRFIs

Browse Source 
svn: r1630
This commit is contained in:
Noel Welsh 2005-12-16 22:02:09 +00:00
parent 723876317a
commit 7ce6693974
14 changed files with 3873 additions and 0 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

459
collects/tests/srfi/1/alist-test.ss Normal file
View File

@ -0,0 +1,459 @@
;;;
;;; <alist-test.ss> ---- Association list tests
;;; Time-stamp: <05/12/16 21:14:22 noel>
;;;
;;; Copyright (C) 2002 by Noel Welsh.
;;;
;;; This file is part of SRFI-1.
;;; SRFI-1 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.
;;; SRFI-1 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 SRFI-1; if not, write to the Free Software
;;; Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
;;; Author: Noel Welsh <noelwelsh@yahoo.com>
;;
;;
;; Commentary:
;; Originally created by:
;; John David Stone
;; Department of Mathematics and Computer Science
;; Grinnell College
;; stone@math.grin.edu
(module alist-test mzscheme
(require (planet "test.ss" ("schematics" "schemeunit.plt" 1 1))
(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
"Association list tests"
;; ALIST-CONS
(make-test-case
"alist-cons:null-list"
(assert-equal? (alist-cons 'Manawa 'Manchester '())
'((Manawa . Manchester))))
(make-test-case
"alist-cons:singleton-list"
(let* ((base '((Manilla . Manly)))
(result (alist-cons 'Manning 'Manson base)))
(assert-equal? result '((Manning . Manson)
(Manilla . Manly)))
(assert-eq? (cdr result) base)))
(make-test-case
"alist-cons:longer-list"
(let* ((base '((Manteno . Mapleside)
(Mapleton . Maquoketa)
(Marathon . Marcus)
(Marengo . Marietta)
(Marion . Mark)))
(result (alist-cons 'Marne 'Marquette base)))
(assert-equal? result
'((Marne . Marquette)
(Manteno . Mapleside)
(Mapleton . Maquoketa)
(Marathon . Marcus)
(Marengo . Marietta)
(Marion . Mark)))
(assert-eq? (cdr result) base)))
(make-test-case
"alist-cons:longer-list-with-duplicate-key"
(let* ((base '((Marquisville . Marsh)
(Marshalltown . Martelle)
(Martensdale . Martinsburg)
(Martinstown . Marysville)
(Masonville . Massena)
(Massey . Massilon)
(Matlock . Maud)))
(result (alist-cons 'Masonville 'Maurice base)))
(assert-equal? result '((Masonville . Maurice)
(Marquisville . Marsh)
(Marshalltown . Martelle)
(Martensdale . Martinsburg)
(Martinstown . Marysville)
(Masonville . Massena)
(Massey . Massilon)
(Matlock . Maud)))
(assert-eq? (cdr result) base)))
;; ALIST-COPY
(make-test-case
"alist-copy:null-list"
(assert-true (null? (alist-copy '()))))
(make-test-case
"alist-copy:flat-list"
(let* ((original '((Maxon . Maxwell)
(Maynard . Maysville)
(McCallsburg . McCausland)
(McClelland . McGregor)
(McIntire . McNally)))
(result (alist-copy original)))
(assert-true
(and (equal? result original)
(not (eq? result original))
(not (eq? (car result) (car original)))
(not (eq? (cdr result) (cdr original)))
(not (eq? (cadr result) (cadr original)))
(not (eq? (cddr result) (cddr original)))
(not (eq? (caddr result) (caddr original)))
(not (eq? (cdddr result) (cdddr original)))
(not (eq? (cadddr result) (cadddr original)))
(not (eq? (cddddr result) (cddddr original)))
(not (eq? (car (cddddr result))
(car (cddddr original))))))))
(make-test-case
"alist-copy:bush"
(let* ((first '(McPaul))
(second '(McPherson
Mechanicsville
Mederville
(Mediapolis Medora)
((Mekee Melbourne Melcher))))
(third 'Melrose)
(original (list (cons 'Meltonville first)
(cons 'Melvin second)
(cons 'Menlo third)))
(result (alist-copy original)))
(assert-true
(and (equal? result original)
(not (eq? result original))
(not (eq? (car result) (car original)))
(eq? (cdar result) first)
(not (eq? (cdr result) (cdr original)))
(not (eq? (cadr result) (cadr original)))
(eq? (cdadr result) second)
(not (eq? (cddr result) (cddr original)))
(not (eq? (caddr result) (caddr original)))
(eq? (cdaddr result) third)))))
;; ALIST-DELETE
(make-test-case
"alist-delete:null-list"
(assert-true (null? (alist-delete 'Mercer '() (lambda (x y) #t)))))
(make-test-case
"alist-delete:singleton-list"
(assert-equal?
(alist-delete 'Meriden
'((Merrill . Merrimac)))
'((Merrill . Merrimac))))
(make-test-case
"alist-delete:all-elements-removed"
(assert-true
(null? (alist-delete 'Meservey
'((Metz . Meyer)
(Middleburg . Middletwon)
(Midvale . Midway)
(Miles . Milford)
(Miller . Millersburg))
(lambda (x y) #t)))))
(make-test-case
"alist-delete:some-elements-removed"
(assert-equal?
(alist-delete 561
'((562 . 563)
(565 . 564)
(566 . 567)
(569 . 568)
(570 . 571))
(lambda (x y) (odd? (+ x y))))
'((565 . 564) (569 . 568))))
(make-test-case
"alist-delete:no-elements-removed"
(assert-equal?
(alist-delete 'Millerton
'((Millman . Millnerville)
(Millville . Milo)
(Milton . Minburn)
(Minden . Mineola)
(Minerva . Mingo))
(lambda (x y) #f))
'((Millman . Millnerville)
(Millville . Milo)
(Milton . Minburn)
(Minden . Mineola)
(Minerva . Mingo))))
;; ALIST-DELETE!
(make-test-case
"alist-delete!:null-list"
(assert-true (null? (alist-delete! 'Mitchell '() (lambda (x y) #t)))))
(make-test-case
"alist-delete!:singleton-list"
(assert-equal?
(alist-delete! 'Mitchellville
(list (cons 'Modale 'Moingona)))
'((Modale . Moingona))))
(make-test-case
"alist-delete!:all-elements-removed"
(assert-true
(null?
(alist-delete! 'Mona
(list (cons 'Mondamin 'Moneta)
(cons 'Moningers 'Monmouth)
(cons 'Monona 'Monroe)
(cons 'Monteith 'Monterey)
(cons 'Montezuma 'Montgomery))
(lambda (x y) #t)))))
(make-test-case
"alist-delete!:some-elements-removed"
(assert-equal?
(alist-delete! 572
(list (cons 573 574)
(cons 576 575)
(cons 577 578)
(cons 580 579)
(cons 581 582))
(lambda (x y) (even? (+ x y))))
'((573 . 574) (577 . 578) (581 . 582))))
(make-test-case
"alist-delete!:no-elements-removed"
(assert-equal?
(alist-delete! 'Monti
(list (cons 'Monticello 'Montour)
(cons 'Montpelier 'Montrose)
(cons 'Mooar 'Moorhead)
(cons 'Moorland 'Moran)
(cons 'Moravia 'Morley)))
'((Monticello . Montour)
(Montpelier . Montrose)
(Mooar . Moorhead)
(Moorland . Moran)
(Moravia . Morley))))
;; ALIST-DELETE
(make-test-case
"alist-delete:null-list"
(assert-true (null? (alist-delete '(Reasnor . Redding) '()))))
(make-test-case
"alist-delete:in-singleton-list"
(assert-true (null?
(alist-delete '(Redfield . Reeceville)
'(((Redfield . Reeceville) . Reinbeck))))))
(make-test-case
"alist-delete:not-in-singleton-list"
(assert-equal?
(alist-delete '(Rembrandt . Remsen)
'(((Renwick . Republic) . Rhodes)))
'(((Renwick . Republic) . Rhodes))))
(make-test-case
"alist-delete:at-beginning-of-longer-list"
(assert-equal?
(alist-delete '(Riceville . Richard)
'(((Riceville . Richard) . Richfield)
((Richland . Richmond) . Rickardsville)
((Ricketts . Rider) . Ridgeport)
((Ridgeway . Riggs) . Rinard)
((Ringgold . Ringsted) . Rippey)))
'(((Richland . Richmond) . Rickardsville)
((Ricketts . Rider) . Ridgeport)
((Ridgeway . Riggs) . Rinard)
((Ringgold . Ringsted) . Rippey))))
(make-test-case
"alist-delete:in-middle-of-longer-list"
(assert-equal?
(alist-delete '(Ritter . Riverdale)
'(((Riverside . Riverton) . Roberts)
((Robertson . Robins) . Robinson)
((Rochester . Rockdale) . Rockford)
((Rockville . Rockwell) . Rodman)
((Ritter . Riverdale) . Rodney)
((Roelyn . Rogers) . Roland)
((Rolfe . Rome) . Roscoe)))
'(((Riverside . Riverton) . Roberts)
((Robertson . Robins) . Robinson)
((Rochester . Rockdale) . Rockford)
((Rockville . Rockwell) . Rodman)
((Roelyn . Rogers) . Roland)
((Rolfe . Rome) . Roscoe))))
(make-test-case
"alist-delete:at-end-of-longer-list"
(assert-equal?
(alist-delete '(Rose . Roselle)
'(((Roseville . Ross) . Rosserdale)
((Rossie . Rossville) . Rowan)
((Rowley . Royal) . Rubio)
((Ruble . Rudd) . Runnells)
((Rose . Roselle) . Russell)))
'(((Roseville . Ross) . Rosserdale)
((Rossie . Rossville) . Rowan)
((Rowley . Royal) . Rubio)
((Ruble . Rudd) . Runnells))))
(make-test-case
"alist-delete:not-in-longer-list"
(assert-equal?
(alist-delete '(Ruthven . Rutland)
'(((Rutledge . Ryan) . Sabula)
((Sageville . Salem) . Salina)
((Salix . Sanborn) . Sandusky)
((Sandyville . Santiago) . Saratoga)
((Sattre . Saude) . Savannah)))
'(((Rutledge . Ryan) . Sabula)
((Sageville . Salem) . Salina)
((Salix . Sanborn) . Sandusky)
((Sandyville . Santiago) . Saratoga)
((Sattre . Saude) . Savannah))))
(make-test-case
"alist-delete:several-matches-in-longer-list"
(assert-equal?
(alist-delete '(Sawyer . Saylor)
'(((Saylorville . Scarville) . Schaller)
((Schleswig . Schley) . Sciola)
((Sawyer . Saylor) . Scranton)
((Searsboro . Sedan) . Selma)
((Sawyer . Saylor) . Seneca)
((Seney . Sewal) . Sexton)
((Sawyer . Saylor) . Seymour)))
'(((Saylorville . Scarville) . Schaller)
((Schleswig . Schley) . Sciola)
((Searsboro . Sedan) . Selma)
((Seney . Sewal) . Sexton))))
;; ALIST-DELETE!
(make-test-case
"alist-delete!:null-list"
(assert-true (null? (alist-delete! (cons 'Unionville 'Unique) (list)))))
(make-test-case
"alist-delete!:in-singleton-list"
(assert-true
(null?
(alist-delete! (cons 'Updegraff 'Urbana)
(list (cons (cons 'Updegraff 'Urbana)
'Summitville))))))
(make-test-case
"alist-delete!:not-in-singleton-list"
(assert-equal?
(alist-delete! (cons 'Urbandale 'Ute)
(list (cons (cons 'Utica 'Vail) 'Valeria)))
'(((Utica . Vail) . Valeria))))
(make-test-case
"alist-delete!:at-beginning-of-longer-list"
(assert-equal?
(alist-delete! (cons 'Valley 'Vandalia)
(list (cons (cons 'Valley 'Vandalia) 'Varina)
(cons (cons 'Ventura 'Vernon) 'Victor)
(cons (cons 'Viele 'Villisca) 'Vincennes)
(cons (cons 'Vincent 'Vining) 'Vinje)
(cons (cons 'Vinton 'Viola) 'Volga)))
'(((Ventura . Vernon) . Victor)
((Viele . Villisca) . Vincennes)
((Vincent . Vining) . Vinje)
((Vinton . Viola) . Volga))))
(make-test-case
"alist-delete!:in-middle-of-longer-list"
(assert-equal?
(alist-delete! (cons 'Volney 'Voorhies)
(list (cons (cons 'Wadena 'Wahpeton) 'Walcott)
(cons (cons 'Wald 'Wales) 'Walford)
(cons (cons 'Walker 'Wallin) 'Wallingford)
(cons (cons 'Walnut 'Wapello) 'Ward)
(cons (cons 'Volney 'Voorhies) 'Ware)
(cons (cons 'Washburn 'Washington) 'Washta)
(cons (cons 'Waterloo 'Waterville)
'Watkins)))
'(((Wadena . Wahpeton) . Walcott)
((Wald . Wales) . Walford)
((Walker . Wallin) . Wallingford)
((Walnut . Wapello) . Ward)
((Washburn . Washington) . Washta)
((Waterloo . Waterville) . Watkins))))
(make-test-case
"alist-delete!:at-end-of-longer-list"
(assert-equal?
(alist-delete! (cons 'Watson 'Watterson)
(list (cons (cons 'Waubeek 'Waucoma) 'Waukee)
(cons (cons 'Waukon 'Waupeton) 'Waverly)
(cons (cons 'Wayland 'Webb) 'Webster)
(cons (cons 'Weldon 'Weller) 'Wellman)
(cons (cons 'Watson 'Watterson) 'Wellsburg)))
'(((Waubeek . Waucoma) . Waukee)
((Waukon . Waupeton) . Waverly)
((Wayland . Webb) . Webster)
((Weldon . Weller) . Wellman))))
(make-test-case
"alist-delete!:not-in-longer-list"
(assert-equal?
(alist-delete! (cons 'Welton 'Wesley)
(list (cons (cons 'Western 'Westerville)
'Westfield)
(cons (cons 'Westgate 'Weston) 'Westphalia)
(cons (cons 'Westside 'Westview) 'Wever)
(cons (cons 'Wheatland 'Whiting)
'Whittemore)
(cons (cons 'Whitten 'Whittier) 'Wichita)))
'(((Western . Westerville) . Westfield)
((Westgate . Weston) . Westphalia)
((Westside . Westview) . Wever)
((Wheatland . Whiting) . Whittemore)
((Whitten . Whittier) . Wichita))))
(make-test-case
"alist-delete!:several-matches-in-longer-list"
(assert-equal?
(alist-delete! (cons 'Wick 'Wightman)
(list (cons (cons 'Wilke 'Willey) 'Williams)
(cons (cons 'Williamsburg 'Williamson)
'Williamstown)
(cons (cons 'Wick 'Wightman) 'Wilmar)
(cons (cons 'Wilton 'Winchester) 'Windham)
(cons (cons 'Wick 'Wightman) 'Winfield)
(cons (cons 'Winkelmans 'Winterset)
'Winthrop)
(cons (cons 'Wick 'Wightman) 'Wiota)))
'(((Wilke . Willey) . Williams)
((Williamsburg . Williamson)
. Williamstown)
((Wilton . Winchester) . Windham)
((Winkelmans . Winterset) . Winthrop))))
))
)
;;; alist-test.ss ends here

31
collects/tests/srfi/1/all-1-tests.ss Normal file
View File

@ -0,0 +1,31 @@
(module all-1-tests mzscheme
(require (planet "test.ss" ("schematics" "schemeunit.plt" 1 1)))
(require "alist-test.ss"
"cons-test.ss"
"delete-test.ss"
"filter-test.ss"
"fold-test.ss"
"lset-test.ss"
"misc-test.ss"
"predicate-test.ss"
"search-test.ss"
"selector-test.ss")
(provide all-1-tests)
(define all-1-tests
(make-test-suite
"all-1-tests"
alist-tests
cons-tests
delete-tests
filter-tests
fold-tests
lset-tests
misc-tests
predicate-tests
search-tests
selector-tests
))
)

222
collects/tests/srfi/1/cons-test.ss Normal file
View File

@ -0,0 +1,222 @@
;;;
;;; <cons-test.ss> ---- List constructor tests
;;; Time-stamp: <05/12/16 21:14:31 noel>
;;;
;;; Copyright (C) 2002 by Noel Welsh.
;;;
;;; This file is part of SRFI-1.
;;; SRFI-1 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.
;;; SRFI-1 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 SRFI-1; if not, write to the Free Software
;;; Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
;;; Author: Noel Welsh <noelwelsh@yahoo.com>
;;
;;
;; Commentary:
;; Originally created by:
;; John David Stone
;; Department of Mathematics and Computer Science
;; Grinnell College
;; stone@math.grin.edu
(module cons-test
mzscheme
(require (planet "test.ss" ("schematics" "schemeunit.plt" 1 1))
(lib "cons.ss" "srfi" "1"))
(provide cons-tests)
(define cons-tests
(make-test-suite
"List constructor tests"
;; XCONS
(make-test-case
"xcons:null-cdr"
(assert-equal? (xcons '() 'Andromeda) '(Andromeda)))
(make-test-case
"xcons:pair-cdr"
(let* ((base '(Antlia))
(result (xcons base 'Apus)))
(assert-equal? result '(Apus Antlia))
(assert-eq? (cdr result) base)))
(make-test-case
"xcons:datum-cdr"
(assert-equal? (xcons 'Aquarius 'Aquila) '(Aquila . Aquarius)))
;; MAKE-LIST
(make-test-case
"make-list:zero-length"
(assert-true (null? (make-list 0))))
(make-test-case
"make-list:default-element"
(assert-equal? (make-list 5) '(#f #f #f #f #f)))
(make-test-case
"make-list:fill-element"
(assert-equal? (make-list 7 'Circinus)
'(Circinus Circinus Circinus Circinus
Circinus Circinus Circinus)))
;; LIST-TABULATE
(make-test-case
"list-tabulate:zero-length"
(assert-true (null? (list-tabulate 0 (lambda (position) #f)))))
(make-test-case
"list-tabulate:identity"
(assert-equal? (list-tabulate 5 (lambda (position) position))
'(0 1 2 3 4)))
(make-test-case
"list-tabulate:factorial"
(assert-equal? (list-tabulate 7 (lambda (position)
(do ((multiplier 1 (+ multiplier 1))
(product 1 (* product multiplier)))
((< position multiplier) product))))
'(1 1 2 6 24 120 720)))
;; LIST*
(make-test-case
"list*:one-argument"
(assert-eq? (list* 'Columba)
'Columba))
(make-test-case
"list*:two-arguments"
(assert-equal? (list* 'Corvus 'Crater)
'(Corvus . Crater)))
(make-test-case
"list*:many-arguments"
(assert-equal? (list* 'Crux 'Cygnus 'Delphinus 'Dorado 'Draco)
'(Crux Cygnus Delphinus Dorado . Draco)))
(make-test-case
"list*:last-argument-null"
(assert-equal? (list* 'Equuleus 'Fornax '())
'(Equuleus Fornax)))
(make-test-case
"list*:last-argument-non-empty-list"
(let* ((base '(Gemini Grus))
(result (list* 'Hercules 'Horologium 'Hydra 'Hydrus base)))
(assert-equal? result
'(Hercules Horologium Hydra Hydrus Gemini Grus))
(assert-eq? (cddddr result) base)))
;; LIST-COPY
(make-test-case
"list-copy:null-list"
(assert-true (null? (list-copy '()))))
(make-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))))))
(make-test-case
"list-copy:bush"
(let* ((first '(Lupus))
(second '(Lynx Malus Mensa (Microscopium Monoceros)
((Musca Norma Octans))))
(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)))
;; CIRCULAR-LIST
(make-test-case
"circular-list:one-element"
(let ((result (circular-list 'Orion)))
(assert-true (and (pair? result)
(eq? (car result) 'Orion)
(eq? (cdr result) result)))))
(make-test-case
"circular-list:many-elements"
(let ((result (circular-list 'Pavo 'Pegasus 'Perseus 'Phoenix 'Pictor)))
(assert-true (and (pair? result)
(eq? (car result) 'Pavo)
(pair? (cdr result))
(eq? (cadr result) 'Pegasus)
(pair? (cddr result))
(eq? (caddr result) 'Perseus)
(pair? (cdddr result))
(eq? (cadddr result) 'Phoenix)
(pair? (cddddr result))
(eq? (car (cddddr result)) 'Pictor)
(eq? (cdr (cddddr result)) result)))))
;; IOTA
(make-test-case
"iota:zero-count"
(assert-equal? (iota 0) (list)))
(make-test-case
"iota:zero-count-and-step"
(assert-equal? (iota 0 0) (list)))
(make-test-case
"iota:count-only"
(assert-equal? (iota 4) (list 0 1 2 3)))
(make-test-case
"iota:count-and-start"
(assert-equal? (iota 3 1) (list 1 2 3)))
(make-test-case
"iota:count-start-and-step"
(assert-equal? (iota 4 3 2) (list 3 5 7 9)))
(make-test-case
"iota:negative-step"
(assert-equal? (iota 4 0 -1) (list 0 -1 -2 -3)))
(make-test-case
"iota:non-integer-step"
(assert-equal? (iota 5 0 1/2) (list 0 1/2 1 3/2 2)))
(make-test-case
"iota;negative-count"
(assert-equal? (iota -1) (list)))
))
)
;;; cons-test.ss ends here

359
collects/tests/srfi/1/delete-test.ss Normal file
View File

@ -0,0 +1,359 @@
;;;
;;; <delete-test.ss> ---- List deletion function tests
;;; Time-stamp: <05/12/16 21:16:28 noel>
;;;
;;; Copyright (C) 2002 by Noel Welsh.
;;;
;;; This file is part of SRFI-1.
;;; SRFI-1 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.
;;; SRFI-1 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 SRFI-1; if not, write to the Free Software
;;; Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
;;; Author: Noel Welsh <noelwelsh@yahoo.com>
;;
;;
;; Commentary:
;; Originally created by:
;; John David Stone
;; Department of Mathematics and Computer Science
;; Grinnell College
;; stone@math.grin.edu
(module delete-test
mzscheme
(require (planet "test.ss" ("schematics" "schemeunit.plt" 1 1))
(all-except (lib "delete.ss" "srfi" "1") member))
(provide delete-tests)
(define delete-tests
(make-test-suite
"List deletion tests"
;; DELETE
(make-test-case
"delete:null-list"
(assert-true
(null? (delete '(Fraser . Frederic) '()))))
(make-test-case
"delete:in-singleton-list"
(assert-true
(null?
(delete '(Fredericksburg . Frederika)
'((Fredericksburg . Frederika))))))
(make-test-case
"delete:not-in-singleton-list"
(assert-equal?
(delete '(Fredonia . Fredsville) '((Freeman . Freeport)))
'((Freeman . Freeport))))
(make-test-case
"delete:at-beginning-of-longer-list"
(assert-equal?
(delete '(Fremont . Froelich) '((Fremont . Froelich)
(Fruitland . Fulton)
(Furay . Galbraith)
(Galesburg . Galland)
(Galt . Galva)))
'((Fruitland . Fulton)
(Furay . Galbraith)
(Galesburg . Galland)
(Galt . Galva))))
(make-test-case
"delete:in-middle-of-longer-list"
(assert-equal?
(delete '(Gambrill . Garber) '((Gardiner . Gardner)
(Garfield . Garland)
(Garnavillo . Garner)
(Garrison . Garwin)
(Gambrill . Garber)
(Gaza . Geneva)
(Genoa . George)))
'((Gardiner . Gardner)
(Garfield . Garland)
(Garnavillo . Garner)
(Garrison . Garwin)
(Gaza . Geneva)
(Genoa . George))))
(make-test-case
"delete:at-end-of-longer-list"
(assert-equal?
(delete '(Georgetown . Gerled) '((Germantown . Germanville)
(Giard . Gibbsville)
(Gibson . Gifford)
(Gilbert . Gilbertville)
(Georgetown . Gerled)))
'((Germantown . Germanville)
(Giard . Gibbsville)
(Gibson . Gifford)
(Gilbert . Gilbertville))))
(make-test-case
"delete:not-in-longer-list"
(assert-equal?
(delete '(Gilliatt . Gilman) '((Givin . Gladbrook)
(Gladstone . Gladwin)
(Glasgow . Glendon)
(Glenwood . Glidden)
(Goddard . Goldfield)))
'((Givin . Gladbrook)
(Gladstone . Gladwin)
(Glasgow . Glendon)
(Glenwood . Glidden)
(Goddard . Goldfield))))
(make-test-case
"delete:several-matches-in-longer-list"
(assert-equal?
(delete '(Goodell . Gosport) '((Gowrie . Goddard)
(Grable . Graettinger)
(Goodell . Gosport)
(Graf . Grafton)
(Goodell . Gosport)
(Grandview . Granger)
(Goodell . Gosport)))
'((Gowrie . Goddard)
(Grable . Graettinger)
(Graf . Grafton)
(Grandview . Granger))))
;; DELETE!
(make-test-case
"delete!:null-list"
(assert-true (null? (delete! (cons 'Henshaw 'Hentons) (list)))))
(make-test-case
"delete!:in-singleton-list"
(assert-true
(null?
(delete! (cons 'Hepburn 'Herndon)
(list (cons 'Hepburn 'Herndon))))))
(make-test-case
"delete!:not-in-singleton-list"
(assert-equal?
(delete! (cons 'Hesper 'Hiattsville)
(list (cons 'Hiawatha 'Hicks)))
'((Hiawatha . Hicks))))
(make-test-case
"delete!:at-beginning-of-longer-list"
(assert-equal?
(delete! (cons 'Highland 'Highlandville)
(list (cons 'Highland 'Highlandville)
(cons 'Highview 'Hills)
(cons 'Hillsboro 'Hillsdale)
(cons 'Hilltop 'Hinton)
(cons 'Hiteman 'Hobarton)))
'((Highview . Hills)
(Hillsboro . Hillsdale)
(Hilltop . Hinton)
(Hiteman . Hobarton))))
(make-test-case
"delete!:in-middle-of-longer-list"
(assert-equal?
(delete! (cons 'Hocking 'Holbrook)
(list (cons 'Holland 'Holmes)
(cons 'Holstein 'Homer)
(cons 'Homestead 'Hopeville)
(cons 'Hopkinton 'Hornick)
(cons 'Hocking 'Holbrook)
(cons 'Horton 'Hospers)
(cons 'Houghton 'Howardville)))
'((Holland . Holmes)
(Holstein . Homer)
(Homestead . Hopeville)
(Hopkinton . Hornick)
(Horton . Hospers)
(Houghton . Howardville))))
(make-test-case
"delete!:at-end-of-longer-list"
(assert-equal?
(delete! (cons 'Howe 'Hubbard)
(list (cons 'Hudson 'Hugo)
(cons 'Hull 'Humboldt)
(cons 'Humeston 'Huntington)
(cons 'Hurley 'Huron)
(cons 'Howe 'Hubbard)))
'((Hudson . Hugo)
(Hull . Humboldt)
(Humeston . Huntington)
(Hurley . Huron))))
(make-test-case
"delete!:not-in-longer-list"
(assert-equal?
(delete! (cons 'Hurstville 'Hutchins)
(list (cons 'Huxley 'Iconium)
(cons 'Illyria 'Imogene)
(cons 'Independence 'Indianapolis)
(cons 'Indianola 'Industry)
(cons 'Inwood 'Ion)))
'((Huxley . Iconium)
(Illyria . Imogene)
(Independence . Indianapolis)
(Indianola . Industry)
(Inwood . Ion))))
(make-test-case
"delete!:several-matches-in-longer-list"
(assert-equal?
(delete! (cons 'Ionia 'Ira)
(list (cons 'Ireton 'Ironhills)
(cons 'Irving 'Irvington)
(cons 'Ionia 'Ira)
(cons 'Irwin 'Ivester)
(cons 'Ionia 'Ira)
(cons 'Iveyville 'Ivy)
(cons 'Ionia 'Ira)))
'((Ireton . Ironhills)
(Irving . Irvington)
(Irwin . Ivester)
(Iveyville . Ivy))))
;; DELETE-DUPLICATES
(make-test-case
"delete-duplicates:null-list"
(assert-true (null? (delete-duplicates '()))))
(make-test-case
"delete-duplicates:singleton-list"
(assert-equal?
(delete-duplicates '((Knierim . Knittel)))
'((Knierim . Knittel))))
(make-test-case
"delete-duplicates:in-doubleton-list"
(assert-equal?
(delete-duplicates '((Knoke . Knowlton) (Knoke . Knowlton)))
'((Knoke . Knowlton))))
(make-test-case
"delete-duplicates:none-removed-in-longer-list"
(assert-equal?
(delete-duplicates '((Knox . Knoxville)
(Konigsmark . Kossuth)
(Koszta . Lacelle)
(Lacey . Lacona)
(Ladoga . Ladora)))
'((Knox . Knoxville)
(Konigsmark . Kossuth)
(Koszta . Lacelle)
(Lacey . Lacona)
(Ladoga . Ladora))))
(make-test-case
"delete-duplicates:some-removed-in-longer-list"
(assert-equal?
(delete-duplicates '((Lafayette . Lainsville)
(Lakeside . Lakewood)
(Lakeside . Lakewood)
(Lakonta . Lakota)
(Lafayette . Lainsville)
(Lamoille . Lamoni)
(Lakeside . Lakewood)
(Lamont . Lancaster)
(Lakeside . Lakewood)))
'((Lafayette . Lainsville)
(Lakeside . Lakewood)
(Lakonta . Lakota)
(Lamoille . Lamoni)
(Lamont . Lancaster))))
(make-test-case
"delete-duplicates:all-but-one-removed-in-longer-list"
(assert-equal?
(delete-duplicates '((Lanesboro . Langdon)
(Lanesboro . Langdon)
(Lanesboro . Langdon)
(Lanesboro . Langdon)
(Lanesboro . Langdon)))
'((Lanesboro . Langdon))))
;; DELETE-DUPLICATES!
(make-test-case
"delete-duplicates!:null-list"
(assert-true (null? (delete-duplicates! (list)))))
(make-test-case
"delete-duplicates!:singleton-list"
(assert-equal?
(delete-duplicates! (list (cons 'Lester 'Letts)))
'((Lester . Letts))))
(make-test-case
"delete-duplicates!:in-doubleton-list"
(assert-equal?
(delete-duplicates! (list (cons 'Leverette 'Levey)
(cons 'Leverette 'Levey)))
'((Leverette . Levey))))
(make-test-case
"delete-duplicates!:none-removed-in-longer-list"
(assert-equal?
(delete-duplicates! (list (cons 'Lewis 'Lexington)
(cons 'Liberty 'Libertyville)
(cons 'Lidderdale 'Lima)
(cons 'Linby 'Lincoln)
(cons 'Linden 'Lineville)))
'((Lewis . Lexington)
(Liberty . Libertyville)
(Lidderdale . Lima)
(Linby . Lincoln)
(Linden . Lineville))))
(make-test-case
"delete-duplicates!:some-removed-in-longer-list"
(assert-equal?
(delete-duplicates! (list (cons 'Lisbon 'Liscomb)
(cons 'Littleport 'Littleton)
(cons 'Littleport 'Littleton)
(cons 'Livermore 'Livingston)
(cons 'Lisbon 'Liscomb)
(cons 'Lockman 'Lockridge)
(cons 'Littleport 'Littleton)
(cons 'Locust 'Logan)
(cons 'Littleport 'Littleton)))
'((Lisbon . Liscomb)
(Littleport . Littleton)
(Livermore . Livingston)
(Lockman . Lockridge)
(Locust . Logan))))
(make-test-case
"delete-duplicates!:all-but-one-removed-in-longer-list"
(assert-equal?
(delete-duplicates! (list (cons 'Logansport 'Lohrville)
(cons 'Logansport 'Lohrville)
(cons 'Logansport 'Lohrville)
(cons 'Logansport 'Lohrville)
(cons 'Logansport 'Lohrville)))
'((Logansport . Lohrville))))
))
)
;;; delete-test.ss ends here

274
collects/tests/srfi/1/filter-test.ss Normal file
View File

@ -0,0 +1,274 @@
;;;
;;; <filter-test.ss> ---- List filtering and partitioning tests
;;; Time-stamp: <05/12/16 21:16:28 noel>
;;;
;;; Copyright (C) 2002 by Noel Welsh.
;;;
;;; This file is part of SRFI-1.
;;; SRFI-1 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.
;;; SRFI-1 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 SRFI-1; if not, write to the Free Software
;;; Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
;;; Author: Noel Welsh <noelwelsh@yahoo.com>
;;
;;
;; Commentary:
;; Originally created by:
;; John David Stone
;; Department of Mathematics and Computer Science
;; Grinnell College
;; stone@math.grin.edu
(module filter-test
mzscheme
(require (planet "test.ss" ("schematics" "schemeunit.plt" 1 1))
(all-except (lib "filter.ss" "srfi" "1") member))
(provide filter-tests)
(define filter-tests
(make-test-suite
"List filtering tests"
;; FILTER
(make-test-case
"filter:null-list"
(assert-true (null? (filter (lambda (x) #t) '()))))
(make-test-case
"filter:singleton-list"
(assert-equal?
(filter (lambda (x) #t) '(Agency))
'(Agency)))
(make-test-case
"filter:all-elements-removed"
(assert-true
(null? (filter (lambda (x) #f)
'(Ainsworth Akron Albany Albaton Albia)))))
(make-test-case
"filter:some-elements-removed"
(assert-equal?
(filter even? '(86 87 88 89 90))
'(86 88 90)))
(make-test-case
"filter:no-elements-removed"
(assert-equal?
(filter (lambda (x) #t)
'(Albion Alburnett Alden Alexander Algona))
'(Albion Alburnett Alden Alexander Algona)))
;; FILTER!
(make-test-case
"filter!:null-list"
(assert-true
(null? (filter! (lambda (x) #t) (list)))))
(make-test-case
"filter!:singleton-list"
(assert-equal?
(filter! (lambda (x) #t) (list 'Alice))
'(Alice)))
(make-test-case
"filter!:all-elements-removed"
(assert-true
(null? (filter! (lambda (x) #f)
(list 'Alleman 'Allendorf 'Allerton 'Allison 'Almont)))))
(make-test-case
"filter!:some-elements-removed"
(assert-equal?
(filter! even? (list 91 92 93 94 95))
'(92 94)))
(make-test-case
"filter!:no-elements-removed"
(assert-equal?
(filter! (lambda (x) #t)
(list 'Almoral 'Alpha 'Alta 'Alton 'Altoona))
'(Almoral Alpha Alta Alton Altoona)))
;; REMOVE
(make-test-case
"remove:null-list"
(assert-true
(null? (remove (lambda (x) #t) '()))))
(make-test-case
"remove:singleton-list"
(assert-equal?
(remove (lambda (x) #f) '(Alvord))
'(Alvord)))
(make-test-case
"remove:all-elements-removed"
(assert-true
(null? (remove (lambda (x) #t) '(Amana Amber Ames Amish Anamosa)))))
(make-test-case
"remove:some-elements-removed"
(assert-equal?
(remove even? '(96 97 98 99 100))
'(97 99)))
(make-test-case
"remove:no-elements-removed"
(assert-equal?
(remove (lambda (x) #f)
'(Anderson Andover Andrew Andrews Angus))
'(Anderson Andover Andrew Andrews Angus)))
;; REMOVE!
(make-test-case
"remove!:null-list"
(assert-true (null? (remove! (lambda (x) #t) (list)))))
(make-test-case
"remove!:singleton-list"
(assert-equal?
(remove! (lambda (x) #f) (list 'Anita))
'(Anita)))
(make-test-case
"remove!:all-elements-removed"
(assert-true
(null?
(remove! (lambda (x) #t)
(list 'Ankeny 'Anthon 'Aplington 'Arcadia 'Archer)))))
(make-test-case
"remove!:some-elements-removed"
(assert-equal?
(remove! even? (list 101 102 103 104 105))
'(101 103 105)))
(make-test-case
"remove!:no-elements-removed"
(assert-equal?
(remove! (lambda (x) #f)
(list 'Ardon 'Aredale 'Argo 'Argyle 'Arion))
'(Ardon Aredale Argo Argyle Arion)))
;; PARTITION
(make-test-case
"partition:null-list"
(let-values (((in out) (partition (lambda (x) #f) '())))
(assert-true (and (null? in) (null? out)))))
(make-test-case
"partition:singleton-list"
(let-values (((in out) (partition (lambda (x) #f) '(Arispe))))
(assert-true (and (null? in) (equal? out '(Arispe))))))
(make-test-case
"partition:all-satisfying"
(let-values (((in out)
(partition (lambda (x) #t)
'(Arlington Armstrong Arnold Artesian Arthur))))
(assert-true
(and (equal? in
'(Arlington Armstrong Arnold Artesian Arthur))
(null? out)))))
(make-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))
(equal? out '(109 111 113 115 117))))))
(make-test-case
"partition:mixed-starting-out"
(let-values (((in out)
(partition even? '(121 122 124 126))))
(assert-true (and (equal? in '(122 124 126))
(equal? out '(121))))))
(make-test-case
"partition:none-satisfying"
(let-values (((in out)
(partition (lambda (x) #f)
'(Asbury Ashawa Ashland Ashton Aspinwall))))
(assert-true (and (null? in)
(equal? out
'(Asbury Ashawa Ashland Ashton Aspinwall))))))
;; PARTITION!
(make-test-case
"partition!:null-list"
(let-values (((in out)
(partition! (lambda (x) #f) (list))))
(assert-true (and (null? in) (null? out)))))
(make-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
"partition!:all-satisfying"
(let-values (((in out)
(partition! (lambda (x) #t)
(list 'Atalissa 'Athelstan 'Atkins 'Atlantic
'Attica))))
(assert-true
(and (equal? in
'(Atalissa Athelstan Atkins Atlantic Attica))
(null? out)))))
(make-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
(and (equal? in '(127 129 135 139 141))
(equal? out '(130 132 134 136 138))))))
(make-test-case
"partition!:mixed-starting-out"
(let-values (((in out)
(partition! odd? (list 142 143 145 147))))
(assert-true
(and (equal? in '(143 145 147))
(equal? out '(142))))))
(make-test-case
"partition!:none-satisfying"
(let-values (((in out)
(partition! (lambda (x) #f)
(list 'Auburn 'Audubon 'Augusta 'Aurelia
'Aureola))))
(assert-true
(and (null? in)
(equal? out
'(Auburn Audubon Augusta Aurelia Aureola))))))
))
)
;;; filter-test.ss ends here

958
collects/tests/srfi/1/fold-test.ss Normal file
View File

@ -0,0 +1,958 @@
;;;
;;; <fold-test.ss> ---- Tests for list folds
;;; Time-stamp: <05/12/16 21:19:37 noel>
;;;
;;; Copyright (C) 2002 by Noel Welsh.
;;;
;;; This file is part of SRFI-1.
;;; SRFI-1 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.
;;; SRFI-1 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 SRFI-1; if not, write to the Free Software
;;; Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
;;; Author: Noel Welsh <noelwelsh@yahoo.com>
;;
;;
;; Commentary:
;; Originally created by:
;; John David Stone
;; Department of Mathematics and Computer Science
;; Grinnell College
;; stone@math.grin.edu
(module fold-test
mzscheme
(require
(planet "test.ss" ("schematics" "schemeunit.plt" 1 1))
(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))
(provide fold-tests)
(define fold-tests
(make-test-suite
"Folding list procedures tests"
;; UNFOLD
(make-test-case
"unfold:predicate-always-satisfied"
(assert-true (null?
(unfold (lambda (seed) #t)
(lambda (seed) (* seed 2))
(lambda (seed) (* seed 3))
1))))
(make-test-case
"unfold:normal-case"
(assert-equal?
(unfold (lambda (seed) (= seed 729))
(lambda (seed) (* seed 2))
(lambda (seed) (* seed 3))
1)
'(2 6 18 54 162 486)))
;; UNFOLD-RIGHT
(make-test-case
"unfold-right:predicate-always-satisfied"
(assert-equal?
(unfold-right (lambda (seed) #t)
(lambda (seed) (* seed 2))
(lambda (seed) (* seed 3))
(lambda (seed) (* seed 5))
1)
(list 1)))
(make-test-case
"unfold-right:normal-case"
(assert-equal?
(unfold-right (lambda (seed) (= seed 729))
(lambda (seed) (* seed 2))
(lambda (seed) (* seed 3))
1
1)
'(486 162 54 18 6 2 1)))
;; FOLD
(make-test-case
"fold:one-null-list"
(assert = (fold (lambda (alpha beta) (* alpha (+ beta 1))) 13 '()) 13))
(make-test-case
"fold:one-singleton-list"
(assert = (fold (lambda (alpha beta) (* alpha (+ beta 1))) 13 '(15)) 210))
(make-test-case
"fold:one-longer-list"
(assert =
(fold (lambda (alpha beta) (* alpha (+ beta 1)))
13
'(15 17 19 21 23))
32927582))
(make-test-case
"fold:several-null-lists"
(assert-eq? (fold vector 'Chad '() '() '() '() '()) 'Chad))
(make-test-case
"fold:several-singleton-lists"
(assert-equal?
(fold vector 'Chile '(China) '(Colombia) '(Comoros) '(Congo)
'(Croatia))
'#(China Colombia Comoros Congo Croatia Chile)))
(make-test-case
"fold:several-longer-lists"
(assert-equal?
(fold (lambda (alpha beta gamma delta epsilon zeta)
(cons (vector alpha beta gamma delta epsilon) zeta))
'()
'(Cuba Cyprus Denmark Djibouti Dominica Ecuador Egypt)
'(Eritrea Estonia Ethiopia Fiji Finland France Gabon)
'(Gambia Georgia Germany Ghana Greece Grenada
Guatemala)
'(Guinea Guyana Haiti Honduras Hungary Iceland India)
'(Indonesia Iran Iraq Ireland Israel Italy Jamaica))
'(#(Egypt Gabon Guatemala India Jamaica)
#(Ecuador France Grenada Iceland Italy)
#(Dominica Finland Greece Hungary Israel)
#(Djibouti Fiji Ghana Honduras Ireland)
#(Denmark Ethiopia Germany Haiti Iraq)
#(Cyprus Estonia Georgia Guyana Iran)
#(Cuba Eritrea Gambia Guinea Indonesia))))
(make-test-case
"fold:lists-of-different-lengths"
(assert-equal?
(fold (lambda (alpha beta gamma delta)
(cons (vector alpha beta gamma) delta))
'()
'(Japan Jordan Kazakhstan Kenya)
'(Kiribati Kuwait)
'(Kyrgyzstan Laos Latvia))
'(#(Jordan Kuwait Laos)
#(Japan Kiribati Kyrgyzstan))))
;; FOLD-RIGHT
(make-test-case
"fold-right:one-null-list"
(assert = (fold-right (lambda (alpha beta) (* alpha (+ beta 1))) 13 '())
13))
(make-test-case
"fold-right:one-singleton-list"
(assert = (fold-right (lambda (alpha beta) (* alpha (+ beta 1))) 13 '(15))
210))
(make-test-case
"fold-right:one-longer-list"
(assert = (fold-right (lambda (alpha beta) (* alpha (+ beta 1)))
13
'(15 17 19 21 23))
32868750))
(make-test-case
"fold-right:several-null-lists"
(assert-eq? (fold-right vector 'Lebanon '() '() '() '() '())
'Lebanon))
(make-test-case
"fold-right:several-singleton-lists"
(assert-equal?
(fold-right vector 'Lesotho '(Liberia) '(Libya) '(Liechtenstein)
'(Lithuania) '(Luxembourg))
#(Liberia Libya Liechtenstein Lithuania Luxembourg Lesotho)))
(make-test-case
"fold-right:several-longer-lists"
(assert-equal?
(fold-right (lambda (alpha beta gamma delta epsilon zeta)
(cons (vector alpha beta gamma delta epsilon) zeta))
'()
'(Macedonia Madagascar Malawi Malaysia Maldives Mali
Malta)
'(Mauritania Mauritius Mexico Micronesia Moldova Monaco
Mongolia)
'(Morocco Mozambique Myanmar Namibia Nauru Nepal
Netherlands)
'(Nicaragua Niger Nigeria Norway Oman Pakistan Palau)
'(Panama Paraguay Peru Philippines Poland Portugal
Qatar))
'(#(Macedonia Mauritania Morocco Nicaragua Panama)
#(Madagascar Mauritius Mozambique Niger Paraguay)
#(Malawi Mexico Myanmar Nigeria Peru)
#(Malaysia Micronesia Namibia Norway Philippines)
#(Maldives Moldova Nauru Oman Poland)
#(Mali Monaco Nepal Pakistan Portugal)
#(Malta Mongolia Netherlands Palau Qatar))))
(make-test-case
"fold-right:lists-of-different-lengths"
(assert-equal?
(fold-right (lambda (alpha beta gamma delta)
(cons (vector alpha beta gamma) delta))
'()
'(Romania Russia Rwanda Senegal)
'(Seychelles Singapore)
'(Slovakia Slovenia Somalia))
'(#(Romania Seychelles Slovakia)
#(Russia Singapore Slovenia))))
;; PAIR-FOLD
(let* ((revappend (lambda (reversend base)
(do ((rest reversend (cdr rest))
(result base (cons (car rest) result)))
((null? rest) result))))
(revappall (lambda (first . rest)
(let loop ((first first) (rest rest))
(if (null? rest)
first
(revappend first
(loop (car rest)
(cdr rest))))))))
(make-test-suite
"Pair-fold tests"
(make-test-case
"pair-fold:one-null-list"
(assert-equal?
(pair-fold revappend '(Spain Sudan) '())
'(Spain Sudan)))
(make-test-case
"pair-fold:one-singleton-list"
(assert-equal?
(pair-fold revappend '(Suriname Swaziland) '(Sweden))
'(Sweden Suriname Swaziland)))
(make-test-case
"pair-fold:one-longer-list"
(assert-equal?
(pair-fold revappend
'(Switzerland Syria)
'(Taiwan Tajikistan Tanzania Thailand Togo))
'(Togo Togo Thailand Togo Thailand Tanzania Togo
Thailand Tanzania Tajikistan Togo Thailand
Tanzania Tajikistan Taiwan Switzerland Syria)))
(make-test-case
"pair-fold:several-null-lists"
(assert-equal?
(pair-fold revappall '(Tonga Tunisia) '() '() '() '() '())
'(Tonga Tunisia)))
(make-test-case
"pair-fold:several-singleton-lists"
(assert-equal?
(pair-fold revappall
'(Turkey Turkmenistan)
'(Tuvalu)
'(Uganda)
'(Ukraine)
'(Uruguay)
'(Uzbekistan))
'(Tuvalu Uganda Ukraine Uruguay Uzbekistan Turkey
Turkmenistan)))
(make-test-case
"pair-fold:several-longer-lists"
(assert-equal?
(pair-fold revappall
'(Vanuatu Venezuela)
'(Vietnam Yemen Yugoslavia Zaire Zambia Zimbabwe
Agnon)
'(Aleixandre Andric Asturias Beckett Bellow
Benavente Bergson)
'(Bjornson Brodsky Buck Bunin Camus Canetti
Carducci)
'(Cela Churchill Deledda Echegary Eliot Elytis
Eucken)
'(Faulkner Galsworthy Gide Gjellerup Golding
Gordimer Hamsun))
'(Agnon Bergson Carducci Eucken Hamsun Agnon
Zimbabwe Bergson Benavente Carducci Canetti
Eucken Elytis Hamsun Gordimer Agnon Zimbabwe
Zambia Bergson Benavente Bellow Carducci Canetti
Camus Eucken Elytis Eliot Hamsun Gordimer
Golding Agnon Zimbabwe Zambia Zaire Bergson
Benavente Bellow Beckett Carducci Canetti Camus
Bunin Eucken Elytis Eliot Echegary Hamsun
Gordimer Golding Gjellerup Agnon Zimbabwe Zambia
Zaire Yugoslavia Bergson Benavente Bellow
Beckett Asturias Carducci Canetti Camus Bunin
Buck Eucken Elytis Eliot Echegary Deledda Hamsun
Gordimer Golding Gjellerup Gide Agnon Zimbabwe
Zambia Zaire Yugoslavia Yemen Bergson Benavente
Bellow Beckett Asturias Andric Carducci Canetti
Camus Bunin Buck Brodsky Eucken Elytis Eliot
Echegary Deledda Churchill Hamsun Gordimer
Golding Gjellerup Gide Galsworthy Agnon Zimbabwe
Zambia Zaire Yugoslavia Yemen Vietnam Bergson
Benavente Bellow Beckett Asturias Andric
Aleixandre Carducci Canetti Camus Bunin Buck
Brodsky Bjornson Eucken Elytis Eliot Echegary
Deledda Churchill Cela Hamsun Gordimer Golding
Gjellerup Gide Galsworthy Faulkner Vanuatu
Venezuela)))
(make-test-case
"pair-fold:lists-of-different-lengths"
(assert-equal?
(pair-fold revappall
'(Hauptmann Hemingway Hesse)
'(Heyse Jensen Jimenez Johnson)
'(Karlfeldt Kawabata)
'(Kipling Lagerkvist Lagerlof Laxness Lewis))
'(Johnson Jimenez Jensen Kawabata Lewis Laxness
Lagerlof Lagerkvist Johnson Jimenez Jensen Heyse
Kawabata Karlfeldt Lewis Laxness Lagerlof
Lagerkvist Kipling Hauptmann Hemingway
Hesse)))
))
;; PAIR-FOLD-RIGHT
(let* ((revappend (lambda (reversend base)
(do ((rest reversend (cdr rest))
(result base (cons (car rest) result)))
((null? rest) result))))
(revappall (lambda (first . rest)
(let loop ((first first) (rest rest))
(if (null? rest)
first
(revappend first
(loop (car rest)
(cdr rest))))))))
(make-test-suite
"Pair-fold-right tests"
(make-test-case
"pair-fold-right:one-null-list"
(assert-equal?
(pair-fold-right revappend '(Maeterlinck Mahfouz) '())
'(Maeterlinck Mahfouz)))
(make-test-case
"pair-fold-right:one-singleton-list"
(assert-equal?
(pair-fold-right revappend '(Mann Martinson) '(Mauriac))
'(Mauriac Mann Martinson)))
(make-test-case
"pair-fold-right:one-longer-list"
(assert-equal?
(pair-fold-right revappend
'(Milosz Mistral)
'(Mommsen Montale Morrison Neruda Oe))
'(Oe Neruda Morrison Montale Mommsen Oe Neruda
Morrison Montale Oe Neruda Morrison Oe Neruda Oe
Milosz Mistral)))
(make-test-case
"pair-fold-right:several-null-lists"
(assert-equal?
(pair-fold-right revappall '(Pasternak Paz) '() '() '() '() '())
'(Pasternak Paz)))
(make-test-case
"pair-fold-right:several-singleton-lists"
(assert-equal?
(pair-fold-right revappall
'(Perse Pirandello)
'(Pontoppidan)
'(Quasimodo)
'(Reymont)
'(Rolland)
'(Russell))
'(Pontoppidan Quasimodo Reymont Rolland Russell
Perse Pirandello)))
(make-test-case
"pair-fold-right:several-longer-lists"
(assert-equal?
(pair-fold-right revappall
'(Sachs Sartre)
'(Seferis Shaw Sholokov Siefert Sienkiewicz
Sillanpaa Simon)
'(Singer Solzhenitsyn Soyinka Spitteler
Steinbeck Tagore Undset)
'(Walcott White Yeats Anderson Andrews Angelina
Aransas)
'(Archer Armstrong Alascosa Austin Bailey
Bandera Bastrop)
'(Baylor Bee Bell Bexar Blanco Borden Bosque
Bowie))
'(Simon Sillanpaa Sienkiewicz Siefert Sholokov
Shaw Seferis Undset Tagore Steinbeck Spitteler
Soyinka Solzhenitsyn Singer Aransas Angelina
Andrews Anderson Yeats White Walcott Bastrop
Bandera Bailey Austin Alascosa Armstrong Archer
Bowie Bosque Borden Blanco Bexar Bell Bee Baylor
Simon Sillanpaa Sienkiewicz Siefert Sholokov
Shaw Undset Tagore Steinbeck Spitteler Soyinka
Solzhenitsyn Aransas Angelina Andrews Anderson
Yeats White Bastrop Bandera Bailey Austin
Alascosa Armstrong Bowie Bosque Borden Blanco
Bexar Bell Bee Simon Sillanpaa Sienkiewicz
Siefert Sholokov Undset Tagore Steinbeck
Spitteler Soyinka Aransas Angelina Andrews
Anderson Yeats Bastrop Bandera Bailey Austin
Alascosa Bowie Bosque Borden Blanco Bexar Bell
Simon Sillanpaa Sienkiewicz Siefert Undset
Tagore Steinbeck Spitteler Aransas Angelina
Andrews Anderson Bastrop Bandera Bailey Austin
Bowie Bosque Borden Blanco Bexar Simon Sillanpaa
Sienkiewicz Undset Tagore Steinbeck Aransas
Angelina Andrews Bastrop Bandera Bailey Bowie
Bosque Borden Blanco Simon Sillanpaa Undset
Tagore Aransas Angelina Bastrop Bandera Bowie
Bosque Borden Simon Undset Aransas Bastrop Bowie
Bosque Sachs Sartre)))
(make-test-case
"pair-fold-right:lists-of-different-lengths"
(assert-equal?
(pair-fold-right revappall
'(Brazoria Brazos Brewster)
'(Briscoe Brooks Brown Burleson)
'(Burnet Caldwell)
'(Calhoun Callahan Cameron Camp Carson))
'(Burleson Brown Brooks Briscoe Caldwell Burnet
Carson Camp Cameron Callahan Calhoun Burleson
Brown Brooks Caldwell Carson Camp Cameron
Callahan Brazoria Brazos Brewster)))
))
;; REDUCE
(make-test-case
"reduce:null-list"
(assert-true (zero? (reduce (lambda (alpha beta) (* alpha (+ beta 1))) 0 '()))))
(make-test-case
"reduce:singleton-list"
(assert = (reduce (lambda (alpha beta) (* alpha (+ beta 1))) 0 '(25)) 25))
(make-test-case
"reduce:doubleton-list"
(assert =
(reduce (lambda (alpha beta) (* alpha (+ beta 1)))
0
'(27 29))
812))
(make-test-case
"reduce:longer-list"
(assert =
(reduce (lambda (alpha beta) (* alpha (+ beta 1)))
0
'(31 33 35 37 39 41 43))
94118227527))
;; REDUCE-RIGHT
(make-test-case
"reduce-right:null-list"
(assert-true (zero? (reduce-right (lambda (alpha beta) (* alpha (+ beta 1))) 0 '()))))
(make-test-case
"reduce-right:singleton-list"
(assert =
(reduce-right (lambda (alpha beta) (* alpha (+ beta 1))) 0 '(25))
25))
(make-test-case
"reduce-right:doubleton-list"
(assert =
(reduce-right (lambda (alpha beta) (* alpha (+ beta 1)))
0
'(27 29))
810))
(make-test-case
"reduce-right:longer-list"
(assert =
(reduce-right (lambda (alpha beta) (* alpha (+ beta 1)))
0
'(31 33 35 37 39 41 43))
93259601719))
;; APPEND-MAP
(make-test-case
"append-map:one-null-list"
(assert-true (null? (append-map (lambda (element) (list element element)) '()))))
(make-test-case
"append-map:one-singleton-list"
(assert-equal? (append-map (lambda (element) (list element element)) '(Cass))
'(Cass Cass)))
(make-test-case
"append-map:one-longer-list"
(assert-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
"append-map:several-null-lists"
(assert-true (null? (append-map (lambda elements (reverse elements))
'() '() '() '() '()))))
(make-test-case
"append-map:several-singleton-lists"
(assert-equal? (append-map (lambda elements (reverse elements))
'(Cochran)
'(Coke)
'(Coleman)
'(Collin)
'(Collingsworth))
'(Collingsworth Collin Coleman Coke Cochran)))
(make-test-case
"append-map:several-longer-lists"
(assert-equal?
(append-map (lambda elements (reverse elements))
'(Colorado Comal Comanche Concho Cooke Coryell
Cottle)
'(Crane Crockett Crosby Culberson Dallam Dallas
Dawson)
'(Delta Denton Dewitt Dickens Dimmit Donley Duval)
'(Eastland Ector Edwards Ellis Erath Falls Fannin)
'(Fayette Fisher Floyd Foard Franklin Freestone
Frio))
'(Fayette Eastland Delta Crane Colorado Fisher Ector
Denton Crockett Comal Floyd Edwards Dewitt Crosby
Comanche Foard Ellis Dickens Culberson Concho
Franklin Erath Dimmit Dallam Cooke Freestone Falls
Donley Dallas Coryell Frio Fannin Duval Dawson
Cottle)))
;; APPEND-MAP!
(make-test-case
"append-map!:one-null-list"
(assert-true (null? (append-map! (lambda (element) (list element element))
(list)))))
(make-test-case
"append-map!:one-singleton-list"
(assert-equal?
(append-map! (lambda (element) (list element element))
(list 'Gaines))
'(Gaines Gaines)))
(make-test-case
"append-map!:one-longer-list"
(assert-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
"append-map!:several-null-lists"
(assert-true (null? (append-map! (lambda elements (reverse elements))
(list)
(list)
(list)
(list)
(list)))))
(make-test-case
"append-map!:several-singleton-lists"
(assert-equal?
(append-map! (lambda elements (reverse elements))
(list 'Gonzales)
(list 'Gray)
(list 'Grayson)
(list 'Gregg)
(list 'Grimes))
'(Grimes Gregg Grayson Gray Gonzales)))
(make-test-case
"append-map!:several-longer-lists"
(assert-equal?
(append-map! (lambda elements (reverse elements))
(list 'Guadalupe 'Hale 'Hall 'Hamilton 'Hansford
'Hardeman 'Hardin)
(list 'Harris 'Harrison 'Hartley 'Haskell 'Hays
'Hemphill 'Henderson)
(list 'Hidalgo 'Hill 'Hockley 'Hood 'Hopkins
'Houston 'Howard)
(list 'Hudspeth 'Hunt 'Hutchinson 'Irion 'Jack
'Jackson 'Jasper)
(list 'Jefferson 'Johnson 'Jones 'Karnes 'Kaufman
'Kendall 'Kenedy))
'(Jefferson Hudspeth Hidalgo Harris Guadalupe
Johnson Hunt Hill Harrison Hale Jones Hutchinson
Hockley Hartley Hall Karnes Irion Hood Haskell
Hamilton Kaufman Jack Hopkins Hays Hansford
Kendall Jackson Houston Hemphill Hardeman Kenedy
Jasper Howard Henderson Hardin)))
;; MAP!
(make-test-case
"map!:one-null-list"
(assert-true (null? (map! vector (list)))))
(make-test-case
"map!:one-singleton-list"
(assert-equal? (map! vector (list 'Kent))
'(#(Kent))))
(make-test-case
"map!:one-longer-list"
(assert-equal?
(map! vector (list 'Kerr 'Kimble 'King 'Kinney 'Kleberg))
'(#(Kerr) #(Kimble) #(King) #(Kinney) #(Kleberg))))
(make-test-case
"map!:several-null-lists"
(assert-true (null? (map! vector (list) (list) (list) (list) (list)))))
(make-test-case
"map!:several-singleton-lists"
(assert-equal?
(map! vector
(list 'Knox)
(list 'Lamar)
(list 'Lamb)
(list 'Lampasas)
(list 'Lavaca))
'(#(Knox Lamar Lamb Lampasas Lavaca))))
(make-test-case
"map!:several-longer-lists"
(assert-equal?
(map! vector
(list 'Lee 'Leon 'Liberty 'Limestone 'Lipscomb 'Llano
'Loving)
(list 'Lubbock 'Lynn 'McCulloch 'McLennan 'McMullen
'Madison 'Marion)
(list 'Martin 'Mason 'Matagorda 'Maverick 'Medina
'Menard 'Midland)
(list 'Milam 'Mills 'Mitchell 'Montague 'Montgomery
'Moore 'Morris)
(list 'Motley 'Nacogdoches 'Navarro 'Newton 'Nolan
'Nueces 'Ochiltree))
'(#(Lee Lubbock Martin Milam Motley)
#(Leon Lynn Mason Mills Nacogdoches)
#(Liberty McCulloch Matagorda Mitchell Navarro)
#(Limestone McLennan Maverick Montague Newton)
#(Lipscomb McMullen Medina Montgomery Nolan)
#(Llano Madison Menard Moore Nueces)
#(Loving Marion Midland Morris Ochiltree))))
;; MAP-IN-ORDER
(make-test-case
"map-in-order:one-null-list"
(assert-true (null? (let ((counter 0))
(map-in-order (lambda (element)
(set! counter (+ counter 1))
(cons counter element))
'())))))
(make-test-case
"map-in-order:one-singleton-list"
(assert-equal?
(let ((counter 0))
(map-in-order (lambda (element)
(set! counter (+ counter 1))
(cons counter element))
'(Oldham)))
'((1 . Oldham))))
(make-test-case
"map-in-order:one-longer-list"
(assert-equal?
(let ((counter 0))
(map-in-order (lambda (element)
(set! counter (+ counter 1))
(cons counter element))
'(Orange Panola Parker Parmer Pecos)))
'((1 . Orange)
(2 . Panola)
(3 . Parker)
(4 . Parmer)
(5 . Pecos))))
(make-test-case
"map-in-order:several-null-lists"
(assert-true (null? (let ((counter 0))
(map-in-order (lambda elements
(set! counter (+ counter 1))
(apply vector counter elements))
'() '() '() '() '())))))
(make-test-case
"map-in-order:several-singleton-lists"
(assert-equal?
(let ((counter 0))
(map-in-order (lambda elements
(set! counter (+ counter 1))
(apply vector counter elements))
'(Polk)
'(Potter)
'(Presidio)
'(Rains)
'(Randall)))
'(#(1 Polk Potter Presidio Rains Randall))))
(make-test-case
"map-in-order:several-longer-lists"
(assert-equal?
(let ((counter 0))
(map-in-order (lambda elements
(set! counter (+ counter 1))
(apply vector counter elements))
'(Reagan Real Reeves Refugio Roberts Robertson
Rockwall)
'(Runnels Rusk Sabine Schleicher Scurry
Shackelford Shelby)
'(Sherman Smith Somervell Starr Stephens
Sterling Stonewall)
'(Sutton Swisher Tarrant Taylor Terrell Terry
Throckmorton)
'(Titus Travis Trinity Tyler Upshur Upton
Uvalde)))
'(#(1 Reagan Runnels Sherman Sutton Titus)
#(2 Real Rusk Smith Swisher Travis)
#(3 Reeves Sabine Somervell Tarrant Trinity)
#(4 Refugio Schleicher Starr Taylor Tyler)
#(5 Roberts Scurry Stephens Terrell Upshur)
#(6 Robertson Shackelford Sterling Terry Upton)
#(7 Rockwall Shelby Stonewall Throckmorton
Uvalde))))
;; PAIR-FOR-EACH
(make-test-case
"pair-for-each:one-null-list"
(assert-true
(null? (let ((base '()))
(pair-for-each (lambda (tail)
(set! base (append tail base)))
'())
base))))
(make-test-case
"pair-for-each:one-singleton-list"
(assert-equal?
(let ((base '()))
(pair-for-each (lambda (tail)
(set! base (append tail base)))
'(Victoria))
base)
'(Victoria)))
(make-test-case
"pair-for-each:one-longer-list"
(assert-equal?
(let ((base '()))
(pair-for-each (lambda (tail)
(set! base (append tail base)))
'(Walker Waller Ward Washington Webb))
base)
'(Webb Washington Webb Ward Washington Webb Waller
Ward Washington Webb Walker Waller Ward
Washington Webb)))
(make-test-case
"pair-for-each:several-null-lists"
(assert-true
(null? (let ((base '()))
(pair-for-each (lambda tails
(set! base
(cons (apply vector tails) base)))
'() '() '() '() '())
base))))
(make-test-case
"pair-for-each:several-singleton-lists"
(assert-equal?
(let ((base '()))
(pair-for-each (lambda tails
(set! base
(cons (apply vector tails) base)))
'(Wharton)
'(Wheeler)
'(Wichita)
'(Wilbarger)
'(Willacy))
base)
'(#((Wharton) (Wheeler) (Wichita) (Wilbarger)
(Willacy)))))
(make-test-case
"pair-for-each:several-longer-lists"
(assert-equal?
(let ((base '()))
(pair-for-each (lambda tails
(set! base
(cons (apply vector tails) base)))
'(Williamson Wilson Winkler Wise Wood Yoakum
Young)
'(Zapata Zavala Admiral Advil Ajax Anacin
Arrid)
'(Arnold Ban Barbie Beech Blockbuster Bounce
Breck)
'(Budweiser Bufferin BVD Carrier Celeste
Charmin Cheer)
'(Cheerios Cinemax Clairol Clorets Combat
Comet Coppertone))
base)
'(#((Young) (Arrid) (Breck) (Cheer) (Coppertone))
#((Yoakum Young) (Anacin Arrid) (Bounce Breck)
(Charmin Cheer) (Comet Coppertone))
#((Wood Yoakum Young)
(Ajax Anacin Arrid)
(Blockbuster Bounce Breck)
(Celeste Charmin Cheer)
(Combat Comet Coppertone))
#((Wise Wood Yoakum Young)
(Advil Ajax Anacin Arrid)
(Beech Blockbuster Bounce Breck)
(Carrier Celeste Charmin Cheer)
(Clorets Combat Comet Coppertone))
#((Winkler Wise Wood Yoakum Young)
(Admiral Advil Ajax Anacin Arrid)
(Barbie Beech Blockbuster Bounce Breck)
(BVD Carrier Celeste Charmin Cheer)
(Clairol Clorets Combat Comet Coppertone))
#((Wilson Winkler Wise Wood Yoakum Young)
(Zavala Admiral Advil Ajax Anacin Arrid)
(Ban Barbie Beech Blockbuster Bounce Breck)
(Bufferin BVD Carrier Celeste Charmin Cheer)
(Cinemax Clairol Clorets Combat Comet
Coppertone))
#((Williamson Wilson Winkler Wise Wood Yoakum
Young)
(Zapata Zavala Admiral Advil Ajax Anacin Arrid)
(Arnold Ban Barbie Beech Blockbuster Bounce
Breck)
(Budweiser Bufferin BVD Carrier Celeste Charmin
Cheer)
(Cheerios Cinemax Clairol Clorets Combat Comet
Coppertone)))))
;; FILTER-MAP
(make-test-case
"filter-map:one-null-list"
(assert-true (null? (filter-map values '()))))
(make-test-case
"filter-map:one-singleton-list"
(assert-equal?
(filter-map values '(Crest))
'(Crest)))
(make-test-case
"filter-map:one-list-all-elements-removed"
(assert-true
(null? (filter-map (lambda (x) #f)
'(Crisco Degree Doritos Dristan Efferdent)))))
(make-test-case
"filter-map:one-list-some-elements-removed"
(assert-equal?
(filter-map (lambda (n) (and (even? n) n))
'(44 45 46 47 48 49 50))
'(44 46 48 50)))
(make-test-case
"filter-map:one-list-no-elements-removed"
(assert-equal?
(filter-map values '(ESPN Everready Excedrin Fab Fantastik))
'(ESPN Everready Excedrin Fab Fantastik)))
(make-test-case
"filter-map:several-null-lists"
(assert-true (null? (filter-map vector '() '() '() '() '()))))
(make-test-case
"filter-map:several-singleton-lists"
(assert-equal?
(filter-map vector
'(Foamy)
'(Gatorade)
'(Glad)
'(Gleem)
'(Halcion))
'(#(Foamy Gatorade Glad Gleem Halcion))))
(make-test-case
"filter-map:several-lists-all-elements-removed"
(assert-true
(null?
(filter-map (lambda arguments #f)
'(Hanes HBO Hostess Huggies Ivory Kent Kinney)
'(Kleenex Knorr Lee Lenox Lerner Listerine
Marlboro)
'(Mazola Michelob Midas Miller NBC Newsweek
Noxema)
'(NutraSweet Oreo Pampers People Planters
Playskool Playtex)
'(Prego Prell Prozac Purex Ritz Robitussin
Rolaids)))))
(make-test-case
"filter-map:several-lists-some-elements-removed"
(assert-equal?
(filter-map (lambda arguments
(let ((sum (apply + arguments)))
(and (odd? sum) sum)))
'(51 52 53 54 55 56 57)
'(58 59 60 61 62 63 64)
'(65 66 67 68 69 70 71)
'(72 73 74 75 76 77 78)
'(79 80 81 82 83 84 85))
'(325 335 345 355)))
(make-test-case
"filter-map:several-lists-no-elements-removed"
(assert-equal?
(filter-map vector
'(Ronzoni Ruffles Scotch Skippy SnackWell Snapple
Spam)
'(Sprite Swanson Thomas Tide Tonka Trojan
Tupperware)
'(Tylenol Velveeta Vicks Victory Visine Wheaties
Wise)
'(Wonder Ziploc Abbott Abingdon Ackley Ackworth
Adair)
'(Adams Adaville Adaza Adel Adelphi Adena Afton))
'(#(Ronzoni Sprite Tylenol Wonder Adams)
#(Ruffles Swanson Velveeta Ziploc Adaville)
#(Scotch Thomas Vicks Abbott Adaza)
#(Skippy Tide Victory Abingdon Adel)
#(SnackWell Tonka Visine Ackley Adelphi)
#(Snapple Trojan Wheaties Ackworth Adena)
#(Spam Tupperware Wise Adair Afton))))
))
)
;;; fold-test.ss ends here

112
collects/tests/srfi/1/lset-test.ss Normal file
View File

@ -0,0 +1,112 @@
;;;
;;; <lset-test.ss> ---- Lists as Sets Tests
;;; Time-stamp: <05/12/16 21:15:22 noel>
;;;
;;; Copyright (C) 2002 by Noel Welsh.
;;;
;;; This file is part of SRFI-1.
;;; SRFI-1 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.
;;; SRFI-1 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 SRFI-1; if not, write to the Free Software
;;; Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
;;; Author: Noel Welsh <noelwelsh@yahoo.com>
;;
;;
;; Commentary:
;; Originally created by:
;; John David Stone
;; Department of Mathematics and Computer Science
;; Grinnell College
;; stone@math.grin.edu
(module lset-test
mzscheme
(require (planet "test.ss" ("schematics" "schemeunit.plt" 1 1))
(lib "lset.ss" "srfi" "1"))
(provide lset-tests)
(define lset-tests
(make-test-suite
"List as set procedures tests"
(make-test-case
"lset<=:singleton"
(assert-true (lset<= eq?)))
(make-test-case
"lset<=:empty-list"
(assert-true (lset<= eq? (list))))
(make-test-case
"lset<=:empty-lists"
(assert-true (lset<= eq? (list) (list))))
(make-test-case
"lset<=:normal-case"
(assert-true (lset<= = (list 1 2 3 4) (list 1 2 3 4))))
(make-test-case
"lset<=:normal-case-fail"
(assert-true (not (lset<= = (list 2 3 4 5) (list 1 2 3 4)))))
(make-test-case
"lset=:empty-list"
(assert-true (lset= eq?)))
(make-test-case
"lset=:singleton"
(assert-true (lset= eq? '(a b c d e))))
(make-test-case
"lset=:normal-case"
(assert-true (lset= = '(1 2 3 4 5) '(5 4 3 2 1))))
(make-test-case
"lset=:normal-case-fail"
(assert-false (lset= eq? '(a b c d e) '(a b c d))))
(make-test-case
"lset-xor:empty-list"
(assert-equal? (lset-xor eq?) '()))
(make-test-case
"lset-xor:singleton"
(assert-equal? (lset-xor eq? '(a b c d e)) '(a b c d e)))
(make-test-case
"lset-xor:normal-case"
(assert-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
"lset-xor!:empty-list"
(assert-equal? (lset-xor! eq?) '()))
(make-test-case
"lset-xor!:singleton"
(assert-equal? (lset-xor! eq? '(a b c d e)) '(a b c d e)))
(make-test-case
"lset-xor!:normal-case"
(assert-true (lset= eq?
(lset-xor! eq? '(a b c d e) '(a e i o u))
'(d c b i o u))))
))
)
;;; lset-test.ss ends here

384
collects/tests/srfi/1/misc-test.ss Normal file
View File

@ -0,0 +1,384 @@
;;;
;;; <misc-test.ss> ---- Misc list procedure tests
;;; Time-stamp: <05/12/16 21:15:50 noel>
;;;
;;; Copyright (C) 2002 by Noel Welsh.
;;;
;;; This file is part of SRFI-1.
;;; SRFI-1 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.
;;; SRFI-1 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 SRFI-1; if not, write to the Free Software
;;; Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
;;; Author: Noel Welsh <noelwelsh@yahoo.com>
;;
;;
;; Commentary:
;; Originally created by:
;; John David Stone
;; Department of Mathematics and Computer Science
;; Grinnell College
;; stone@math.grin.edu
(module misc-test
mzscheme
(require
(planet "test.ss" ("schematics" "schemeunit.plt" 1 1))
(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!))
(provide misc-tests)
(define misc-tests
(make-test-suite
"Miscellaneous list procedures tests"
;; ZIP
(make-test-case
"zip:all-lists-empty"
(assert-true (null? (zip '() '() '() '() '()))))
(make-test-case
"zip:one-list"
(assert-equal? (zip '(Pisces Puppis Reticulum))
'((Pisces) (Puppis) (Reticulum))))
(make-test-case
"zip:two-lists"
(assert-equal? (zip '(Sagitta Sagittarius Scorpio Scutum Serpens)
'(Sextans Taurus Telescopium Triangulum Tucana))
'((Sagitta Sextans)
(Sagittarius Taurus)
(Scorpio Telescopium)
(Scutum Triangulum)
(Serpens Tucana))))
(make-test-case
"zip:short-lists"
(assert-equal? (zip '(Vela) '(Virgo) '(Volens) '(Vulpecula))
'((Vela Virgo Volens Vulpecula))))
(make-test-case
"zip:several-lists"
(assert-equal? (zip '(actinium aluminum americium antimony argon)
'(arsenic astatine barium berkeleium beryllium)
'(bismuth boron bromine cadmium calcium)
'(californium carbon cerium cesium chlorine)
'(chromium cobalt copper curium dysprosium)
'(einsteinium erbium europium fermium fluorine)
'(francium gadolinium gallium germanium gold))
'((actinium arsenic bismuth californium
chromium einsteinium francium)
(aluminum astatine boron carbon cobalt
erbium gadolinium)
(americium barium bromine cerium copper
europium gallium)
(antimony berkeleium cadmium cesium curium
fermium germanium)
(argon beryllium calcium chlorine
dysprosium fluorine gold))))
;; UNZIP2
(make-test-case
"unzip2:empty-list-of-lists"
(let-values (((firsts seconds) (unzip2 '())))
(assert-true (and (null? firsts) (null? seconds)))))
(make-test-case
"unzip2:singleton-list-of-lists"
(let-values (((firsts seconds) (unzip2 '((retriever rottweiler)))))
(assert-true (and (equal? firsts '(retriever))
(equal? seconds '(rottweiler))))))
(make-test-case
"unzip2:longer-list-of-lists"
(let-values (((firsts seconds)
(unzip2 '((saluki samoyed)
(shipperke schnauzer)
(setter shepherd)
(skye spaniel)
(spitz staghound)))))
(assert-true (and (equal? firsts '(saluki shipperke setter skye spitz))
(equal? seconds '(samoyed schnauzer shepherd spaniel
staghound))))))
(make-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))
(equal? seconds
'(turnspit wolfhound bones clappers))))))
;; UNZIP3
(make-test-case
"unzip3:empty-list-of-lists"
(let-values (((firsts seconds thirds)
(unzip3 '())))
(assert-true (and (null? firsts) (null? seconds) (null? thirds)))))
(make-test-case
"unzip3:singleton-list-of-lists"
(let-values (((firsts seconds thirds)
(unzip3 '((cymbals gamelan glockenspiel)))))
(assert-true (and (equal? firsts '(cymbals))
(equal? seconds '(gamelan))
(equal? thirds '(glockenspiel))))))
(make-test-case
"unzip3:longer-list-of-lists"
(let-values (((firsts seconds thirds)
(unzip3 '((gong handbells kettledrum)
(lyra maraca marimba)
(mbira membranophone metallophone)
(nagara naker rattle)
(sizzler snappers tabor)))))
(assert-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
"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))
(equal? seconds '(timbrel vibraphone banker craps))
(equal? thirds
'(timpani xylophone bezique cribbage))))))
;; UNZIP4
(make-test-case
"unzip4:empty-list-of-lists"
(let-values (((firsts seconds thirds fourths)
(unzip4 '())))
(assert-true (and (null? firsts)
(null? seconds)
(null? thirds)
(null? fourths)))))
(make-test-case
"unzip4:singleton-list-of-lists"
(let-values (((firsts seconds thirds fourths)
(unzip4 '((fantan faro gin hazard)))))
(assert-true (and (equal? firsts '(fantan))
(equal? seconds '(faro))
(equal? thirds '(gin))
(equal? fourths '(hazard))))))
(make-test-case
"unzip4:longer-list-of-lists"
(let-values (((firsts seconds thirds fourths)
(unzip4 '((hearts keno loo lottery)
(lotto lowball monte numbers)
(ombre picquet pinball pinochle)
(poker policy quinze romesteq)
(roulette rum rummy skat)))))
(assert-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
"unzip4:lists-with-extra-elements"
(let-values (((firsts seconds thirds fourths)
(unzip4 '((adamant agate alexandrite amethyst aquamarine
beryl)
(bloodstone brilliant carbuncle carnelian)
(chalcedony chrysoberyl chrysolite chrysoprase
citrine coral demantoid)
(diamond emerald garnet girasol heliotrope)))))
(assert-true (and (equal? firsts '(adamant bloodstone chalcedony diamond))
(equal? seconds '(agate brilliant chrysoberyl emerald))
(equal? thirds
'(alexandrite carbuncle chrysolite garnet))
(equal? fourths
'(amethyst carnelian chrysoprase girasol))))))
;; UNZIP5
(make-test-case
"unzip5:empty-list-of-lists"
(let-values (((firsts seconds thirds fourths fifths)
(unzip5 '())))
(assert-true
(and (null? firsts)
(null? seconds)
(null? thirds)
(null? fourths)
(null? fifths)))))
(make-test-case
"unzip5:singleton-list-of-lists"
(let-values (((firsts seconds thirds fourths fifths)
(unzip5 '((hyacinth jacinth jade jargoon jasper)))))
(lambda (firsts seconds thirds fourths fifths)
(and (equal? firsts '(hyacinth))
(equal? seconds '(jacinth))
(equal? thirds '(jade))
(equal? fourths '(jargoon))
(equal? fifths '(jasper))))))
(make-test-case
"unzip5:longer-list-of-lists"
(let-values (((firsts seconds thirds fourths fifths)
(unzip5 '((kunzite moonstone morganite onyx opal)
(peridot plasma ruby sapphire sard)
(sardonyx spinel star sunstone topaz)
(tourmaline turquoise zircon Argus basilisk)
(Bigfoot Briareus bucentur Cacus Caliban)))))
(assert-true
(and (equal? firsts
'(kunzite peridot sardonyx tourmaline Bigfoot))
(equal? seconds
'(moonstone plasma spinel turquoise Briareus))
(equal? thirds '(morganite ruby star zircon bucentur))
(equal? fourths '(onyx sapphire sunstone Argus Cacus))
(equal? fifths '(opal sard topaz basilisk Caliban))))))
(make-test-case
"unzip5:lists-with-extra-elements"
(let-values (((firsts seconds thirds fourths fifths)
(unzip5 '((centaur Cerberus Ceto Charybdis chimera cockatrice
Cyclops)
(dipsas dragon drake Echidna Geryon)
(Gigantes Gorgon Grendel griffin Harpy hippocampus
hippocentaur hippocerf)
(hirocervus Hydra Kraken Ladon manticore Medusa)))))
(assert-true
(and (equal? firsts '(centaur dipsas Gigantes hirocervus))
(equal? seconds '(Cerberus dragon Gorgon Hydra))
(equal? thirds '(Ceto drake Grendel Kraken))
(equal? fourths '(Charybdis Echidna griffin Ladon))
(equal? fifths '(chimera Geryon Harpy manticore))))))
;; APPEND!
(make-test-case
"append!:no-arguments"
(assert-true (null? (s:append!))))
(make-test-case
"append!:one-argument"
(assert-equal? (s:append! (list 'mermaid 'merman 'Minotaur))
'(mermaid merman Minotaur)))
(make-test-case
"append!:several-arguments"
(assert-equal?
(s:append! (list 'nixie 'ogre 'ogress 'opinicus)
(list 'Orthos)
(list 'Pegasus 'Python)
(list 'roc 'Sagittary 'salamander 'Sasquatch 'satyr)
(list 'Scylla 'simurgh 'siren))
'(nixie ogre ogress opinicus Orthos Pegasus
Python roc Sagittary salamander Sasquatch
satyr Scylla simurgh siren)))
(make-test-case
"append!:some-null-arguments"
(assert-equal?
(s:append! (list) (list) (list 'Sphinx 'Talos 'troll) (list)
(list 'Typhoeus) (list) (list) (list))
'(Sphinx Talos troll Typhoeus)))
(make-test-case
"append!:all-null-arguments"
(assert-true (null? (s:append! (list) (list) (list) (list) (list)))))
;; APPEND-REVERSE
(make-test-case
"append-reverse:first-argument-null"
(assert-equal? (append-reverse '() '(Typhon unicorn vampire werewolf))
'(Typhon unicorn vampire werewolf)))
(make-test-case
"append-reverse:second-argument-null"
(assert-equal? (append-reverse '(windigo wivern xiphopagus yeti zombie) '())
'(zombie yeti xiphopagus wivern windigo)))
(make-test-case
"append-reverse:both-arguments-null"
(assert-true (null? (append-reverse '() '()))))
(make-test-case
"append-reverse:neither-argument-null"
(assert-equal?
(append-reverse '(Afghanistan Albania Algeria Andorra)
'(Angola Argentina Armenia))
'(Andorra Algeria Albania Afghanistan Angola
Argentina Armenia)))
;; APPEND-REVERSE!
(make-test-case
"append-reverse!:first-argument-null"
(assert-equal? (append-reverse! (list)
(list 'Australia 'Austria 'Azerbaijan))
'(Australia Austria Azerbaijan)))
(make-test-case
"append-reverse!:second-argument-null"
(assert-equal? (append-reverse! (list 'Bahrain 'Bangladesh 'Barbados
'Belarus 'Belgium)
(list))
'(Belgium Belarus Barbados Bangladesh Bahrain)))
(make-test-case
"append-reverse!:both-arguments-null"
(assert-true (null? (append-reverse! (list) (list)))))
(make-test-case
"append-reverse!:neither-argument-null"
(assert-equal? (append-reverse! (list 'Belize 'Benin 'Bhutan 'Bolivia)
(list 'Bosnia 'Botswana 'Brazil))
'(Bolivia Bhutan Benin Belize Bosnia Botswana Brazil)))
;; REVERSE!
(make-test-case
"reverse!:empty-list"
(assert-true (null? (s:reverse! (list)))))
(make-test-case
"reverse!:singleton-list"
(assert-equal? (s:reverse! (list 'Brunei))
'(Brunei)))
(make-test-case
"reverse!:longer-list"
(assert-equal? (s:reverse! (list 'Bulgaria 'Burundi 'Cambodia 'Cameroon
'Canada))
'(Canada Cameroon Cambodia Burundi Bulgaria)))
))
)
;;; misc-test.ss ends here

170
collects/tests/srfi/1/predicate-test.ss Normal file
View File

@ -0,0 +1,170 @@
;;;
;;; <predicate-test.ss> ---- List predicate tests
;;; Time-stamp: <05/12/16 21:16:27 noel>
;;;
;;; Copyright (C) 2002 by Noel Welsh.
;;;
;;; This file is part of SRFI-1.
;;; SRFI-1 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.
;;; SRFI-1 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 SRFI-1; if not, write to the Free Software
;;; Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
;;; Author: Noel Welsh <noelwelsh@yahoo.com>
;;
;;
;; Commentary:
;; Originally created by:
;; John David Stone
;; Department of Mathematics and Computer Science
;; Grinnell College
;; stone@math.grin.edu
(module predicate-test
mzscheme
(require
(planet "test.ss" ("schematics" "schemeunit.plt" 1 1))
(lib "predicate.ss" "srfi" "1")
(lib "cons.ss" "srfi" "1"))
(provide predicate-tests)
(define predicate-tests
(make-test-suite
"List predicate tests"
;; PROPER-LIST?
(make-test-case
"proper-list?:list"
(assert-true (proper-list? (list 1 2 3 4 5))))
(make-test-case
"proper-list?:dotted-list"
(assert-true (not (proper-list? (cons 1 (cons 2 (cons 3 4)))))))
(make-test-case
"proper-list?:zero-length"
(assert-true (proper-list? (list))))
(make-test-case
"proper-list?:circular-list"
(assert-true (not (proper-list? (circular-list 'a 'b 'c 'd)))))
(make-test-case
"proper-list?:simple-value"
(assert-true (not (proper-list? 1))))
;; DOTTED-LIST?
(make-test-case
"dotted-list?:dotted-list"
(assert-true (dotted-list? '(1 2 3 . 4))))
(make-test-case
"dotted-list?:proper-list"
(assert-true (not (dotted-list? (list 'a 'b 'c 'd)))))
(make-test-case
"dotted-list?:empty-list"
(assert-true (not (dotted-list? (list)))))
(make-test-case
"dotted-list?:simple-value"
(assert-true (dotted-list? "hello")))
;; CIRCULAR-LIST
(make-test-case
"circular-list?:proper-list"
(assert-true (not (circular-list? (list 1 2 3 4)))))
(make-test-case
"circular-list?:dotted-list"
(assert-true (not (circular-list? '(a b c . d)))))
(make-test-case
"circular-list?:simple-value"
(assert-true (not (circular-list? 1))))
(make-test-case
"circular-list?:circular-list"
(assert-true (circular-list? (circular-list 1 2 3 4))))
;; NOT-PAIR
(make-test-case
"not-pair?:list"
(assert-true (not (not-pair? (list 1 2 3 4)))))
(make-test-case
"not-pair?:number"
(assert-true (not-pair? 1)))
(make-test-case
"not-pair?:symbol"
(assert-true (not-pair? 'symbol)))
(make-test-case
"not-pair?:string"
(assert-true (not-pair? "string")))
;; NULL-LIST?
(make-test-case
"null-list?:null-list"
(assert-true (null-list? (list))))
(make-test-case
"null-list?:list"
(assert-true (not (null-list? (list 'a 'b 'c)))))
(make-test-case
"null-list?:pair"
(assert-true (not (null-list? (cons 1 2)))))
;; LIST=
(make-test-case
"list=:number-list"
(assert-true (list= = (list 1.0 2.0 3.0) (list 1 2 3))))
(make-test-case
"list=:symbol-vs-string-list"
(assert-true (list= (lambda (x y)
(string=? (symbol->string x) y))
(list 'a 'b 'c)
(list "a" "b" "c"))))
(make-test-case
"list=:unequal-lists"
(assert-true (not (list= eq? (list 1 2 3) (list 'a 'b 'c) (list 1 2 3)))))
(make-test-case
"list=:unequal-lengths"
(assert-true (not (list= eq? (list 1 2 3) (list 1 2 3 4)))))
(make-test-case
"list=:empty-lists"
(assert-true (list= eq? (list) (list) (list))))
(make-test-case
"list=:no-list"
(assert-true (list= eq?)))
))
)
;;; predicate-test.ss ends here

5
collects/tests/srfi/1/run-tests.ss Normal file
View File

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

529
collects/tests/srfi/1/search-test.ss Normal file
View File

@ -0,0 +1,529 @@
;;;
;;; <search-test.ss> ---- List searching functions tests
;;; Time-stamp: <05/12/16 21:16:26 noel>
;;;
;;; Copyright (C) 2002 by Noel Welsh.
;;;
;;; This file is part of SRFI-1.
;;; SRFI-1 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.
;;; SRFI-1 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 SRFI-1; if not, write to the Free Software
;;; Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
;;; Author: Noel Welsh <noelwelsh@yahoo.com>
;;
;;
;; Commentary:
;; Originally created by:
;; John David Stone
;; Department of Mathematics and Computer Science
;; Grinnell College
;; stone@math.grin.edu
(module search-test
mzscheme
(require (planet "test.ss" ("schematics" "schemeunit.plt" 1 1))
(all-except (lib "search.ss" "srfi" "1") member))
(provide search-tests)
(define search-tests
(make-test-suite
"List search tests"
;; FIND
(make-test-case
"find:in-null-list"
(assert-true (not (find (lambda (x) #t) '()))))
(make-test-case
"find:in-singleton-list"
(assert-eq? (find (lambda (x) #t) '(Aurora))
'Aurora))
(make-test-case
"find:not-in-singleton-list"
(assert-true (not (find (lambda (x) #f) '(Austinville)))))
(make-test-case
"find:at-front-of-longer-list"
(assert-eq?
(find (lambda (x) #t) '(Avery Avoca Avon Ayrshire Badger))
'Avery))
(make-test-case
"find:in-middle-of-longer-list"
(assert =
(find even? '(149 151 153 155 156 157 159))
156))
(make-test-case
"find:at-end-of-longer-list"
(assert =
(find even? '(161 163 165 167 168))
168))
(make-test-case
"find:not-in-longer-list"
(assert-true
(not
(find (lambda (x) #f)
'(Bagley Bailey Badwin Balfour Balltown)))))
;;; FIND-TAIL
(make-test-case
"find-tail:in-null-list"
(assert-true (not (find-tail (lambda (x) #t) '()))))
(make-test-case
"find-tail:in-singleton-list"
(let ((source '(Ballyclough)))
(assert-eq?
(find-tail (lambda (x) #t) source)
source)))
(make-test-case
"find-tail:not-in-singleton-list"
(assert-true (not (find-tail (lambda (x) #f) '(Bancroft)))))
(make-test-case
"find-tail:at-front-of-longer-list"
(let ((source '(Bangor Bankston Barney Barnum Bartlett)))
(assert-eq?
(find-tail (lambda (x) #t) source)
source)))
(make-test-case
"find-tail:in-middle-of-longer-list"
(let ((source '(169 171 173 175 176 177 179)))
(assert-eq?
(find-tail even? source)
(cddddr source))))
(make-test-case
"find-tail:at-end-of-longer-list"
(let ((source '(181 183 185 187 188)))
(assert-eq?
(find-tail even? source)
(cddddr source))))
(make-test-case
"find-tail:not-in-longer-list"
(assert-true
(not
(find-tail (lambda (x) #f)
'(Batavia Bauer Baxter Bayard Beacon)) )))
;;; ANY
(make-test-case
"any:in-one-null-list"
(assert-true (not (any values '()))))
(make-test-case
"any:in-one-singleton-list"
(assert-equal? (any vector '(Beaconsfield)) '#(Beaconsfield)))
(make-test-case
"any:not-in-one-singleton-list"
(assert-true (not (any (lambda (x) #f) '(Beaman)))))
(make-test-case
"any:at-beginning-of-one-longer-list"
(assert-equal?
(any vector '(Beaver Beaverdale Beckwith Bedford Beebeetown))
'#(Beaver)))
(make-test-case
"any:in-middle-of-one-longer-list"
(assert =
(any (lambda (x) (and (odd? x) (+ x 189)))
'(190 192 194 196 197 198 200))
386))
(make-test-case
"any:at-end-of-one-longer-list"
(assert =
(any (lambda (x) (and (odd? x) (+ x 201)))
'(202 204 206 208 209))
410))
(make-test-case
"any:not-in-one-longer-list"
(assert-true
(not (any (lambda (x) #f)
'(Beech Belinda Belknap Bellefountain Bellevue)))))
(make-test-case
"any:in-several-null-lists"
(assert-true
(not (any vector '() '() '() '() '()))))
(make-test-case
"any:in-several-singleton-lists"
(assert-equal?
(any vector
'(Belmond)
'(Beloit)
'(Bennett)
'(Benson)
'(Bentley))
'#(Belmond Beloit Bennett Benson Bentley)))
(make-test-case
"any:not-in-several-singleton-lists"
(assert-true
(not
(any (lambda arguments #f)
'(Benton)
'(Bentonsport)
'(Berea)
'(Berkley)
'(Bernard)))))
(make-test-case
"any:at-beginning-of-several-longer-lists"
(assert-equal?
(any vector
'(Berne Bertram Berwick Bethesda Bethlehem Bettendorf
Beulah)
'(Bevington Bidwell Bingham Birmingham Bladensburg
Blairsburg Blairstown)
'(Blakesburg Blanchard Blencoe Bliedorn Blockton
Bloomfield Bloomington)
'(Bluffton Bode Bolan Bonair Bonaparte Bondurant Boone)
'(Booneville Botany Botna Bouton Bowsher Boxholm Boyd))
'#(Berne Bevington Blakesburg Bluffton Booneville)))
(make-test-case
"any:in-middle-of-several-longer-lists"
(assert =
(any (lambda arguments
(let ((sum (apply + arguments)))
(and (odd? sum) (+ sum 210))))
'(211 212 213 214 215 216 217)
'(218 219 220 221 222 223 224)
'(225 226 227 228 229 230 231)
'(232 233 234 235 236 237 238)
'(240 242 244 246 247 248 250))
1359))
(make-test-case
"any:at-end-of-several-longer-lists"
(assert =
(any (lambda arguments
(let ((sum (apply + arguments)))
(and (even? sum) (+ sum 210))))
'(252 253 254 255 256 257 258)
'(259 260 261 262 263 264 265)
'(266 267 268 269 270 271 272)
'(273 274 275 276 277 278 279)
'(281 283 285 287 289 291 292))
1576))
(make-test-case
"any:not-in-several-longer-lists"
(assert-true
(not
(any (lambda arguments #f)
'(Boyden Boyer Braddyville Bradford Bradgate Brainard
Brandon)
'(Brayton Brazil Breda Bridgewater Brighton Bristol
Bristow)
'(Britt Bromley Brompton Bronson Brooklyn Brooks
Brookville)
'(Browns Brownville Brunsville Brushy Bryant Bryantsburg
Buchanan)
'(Buckeye Buckhorn Buckingham Bucknell Budd Buffalo
Burchinal)))))
(make-test-case
"any:not-in-lists-of-unequal-length"
(assert-true
(not (any (lambda arguments #f)
'(Burdette Burlington Burnside Burt)
'(Bushville Bussey)
'(Buxton Cairo Calamus)
'(Caledonia Clahoun Callender Calmar Caloma Calumet)))))
;;; EVERY
(make-test-case
"every:in-one-null-list"
(assert-true (every values '())))
(make-test-case
"every:in-one-singleton-list"
(assert-equal?
(every vector '(Camanche))
'#(Camanche)))
(make-test-case
"every:not-in-one-singleton-list"
(assert-true
(not (every (lambda (x) #f) '(Cambria)))))
(make-test-case
"every:failing-at-beginning-of-one-longer-list"
(assert-true
(not
(every (lambda (x) #f)
'(Cambridge Cameron Canby Canton Cantril)) )))
(make-test-case
"every:failing-in-middle-of-one-longer-list"
(assert-true
(not
(every (lambda (x) (and (even? x) (+ x 293)))
'(294 296 298 300 301 302 304)))))
(make-test-case
"every:failing-at-end-of-one-longer-list"
(assert-true
(not
(every (lambda (x) (and (even? x) (+ x 305)))
'(306 308 310 312 313)))))
(make-test-case
"every:in-one-longer-list"
(assert-equal?
(every vector
'(Carbon Carbondale Carl Carlisle Carmel))
'#(Carmel)))
(make-test-case
"every:in-several-null-lists"
(assert-true
(every vector '() '() '() '() '())))
(make-test-case
"every:in-several-singleton-lists"
(assert-equal?
(every vector
'(Carnarvon)
'(Carnes)
'(Carney)
'(Carnforth)
'(Carpenter))
'#(Carnarvon Carnes Carney Carnforth Carpenter)))
(make-test-case
"every:not-in-several-singleton-lists"
(assert-true
(not
(every (lambda arguments #f)
'(Carroll)
'(Carrollton)
'(Carrville)
'(Carson)
'(Cartersville)))))
(make-test-case
"every:failing-at-beginning-of-several-longer-lists"
(assert-true
(not
(every (lambda arguments #f)
'(Cascade Casey Castalia Castana Cattese Cedar
Centerdale)
'(Centerville Centralia Ceres Chapin Chariton
Charleston Charlotte)
'(Chatsworth Chautauqua Chelsea Cheney Cherokee Chester
Chickasaw)
'(Chillicothe Churchtown Churchville Churdan Cincinnati
Clare Clarence)
'(Clarinda Clarion Clark Clarkdale Clarksville Clayton
Clearfield))
)))
(make-test-case
"every:failing-in-middle-of-several-longer-lists"
(assert-true
(not
(every (lambda arguments
(let ((sum (apply + arguments)))
(and (odd? sum) (+ sum 314))))
'(315 316 317 318 319 320 321)
'(322 323 324 325 326 327 328)
'(329 330 331 332 333 334 335)
'(336 337 338 339 340 341 342)
'(343 345 347 349 350 351 353))
)))
(make-test-case
"every:failing-at-end-of-several-longer-lists"
(assert-true
(not
(every (lambda arguments
(let ((sum (apply + arguments)))
(and (odd? sum) (+ sum 354))))
'(355 356 357 358 359 360 361)
'(362 363 364 365 366 367 368)
'(369 370 371 372 373 374 375)
'(376 377 378 379 380 381 382)
'(383 385 387 389 391 393 394))
)))
(make-test-case
"every:in-several-longer-lists"
(assert-equal?
(every vector
'(Cleghorn Clemons Clermont Cleves Cliffland Climax
Clinton)
'(Clio Clive Cloverdale Clucas Clutier Clyde Coalville)
'(Coburg Coggon Coin Colesburg Colfax Collett Collins)
'(Colo Columbia Colwell Commerce Communia Competine
Concord)
'(Conesville Confidence Cono Conover Conrad Conroy
Consol))
'#(Clinton Coalville Collins Concord Consol)))
(make-test-case
"every:in-lists-of-unequal-length"
(assert-equal?
(every vector
'(Conway Cool Cooper Coppock)
'(Coralville Corley)
'(Cornelia Cornell Corning)
'(Correctionville Corwith Corydon Cosgrove Coster
Cotter))
'#(Cool Corley Cornell Corwith)))
;;; LIST-INDEX
(make-test-case
"list-index:in-one-null-list"
(assert-true
(not (list-index (lambda (x) #t) '()))))
(make-test-case
"list-index:in-one-singleton-list"
(assert-true
(zero?
(list-index (lambda (x) #t) '(Cottonville)))))
(make-test-case
"list-index:not-in-one-singleton-list"
(assert-true
(not (list-index (lambda (x) #f) '(Coulter)))))
(make-test-case
"list-index:at-front-of-one-longer-list"
(assert-true
(zero?
(list-index (lambda (x) #t)
'(Covington Craig Cranston Crathorne
Crawfordsville)))))
(make-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
"list-index:at-end-of-one-longer-list"
(assert =
(list-index odd? '(406 408 410 412 414 415))
5))
(make-test-case
"list-index:not-in-one-longer-list"
(assert-true
(not
(list-index (lambda (x) #f)
'(Crescent Cresco Creston Crocker Crombie)))))
(make-test-case
"list-index:in-several-null-lists"
(assert-true
(not (list-index (lambda arguments #t) '() '() '() '() '()))))
(make-test-case
"list-index:in-several-singleton-lists"
(assert-true
(zero? (list-index (lambda arguments #t)
'(Cromwell)
'(Croton)
'(Cumberland)
'(Cumming)
'(Curlew)))))
(make-test-case
"list-index:not-in-several-singleton-lists"
(assert-true
(not (list-index (lambda arguments #f)
'(Cushing)
'(Cylinder)
'(Dahlonega)
'(Dalby)
'(Dale)))))
(make-test-case
"list-index:at-front-of-several-longer-lists"
(assert-true
(zero? (list-index (lambda arguments #t)
'(Dallas Dana Danbury Danville Darbyville
Davenport Dawson)
'(Dayton Daytonville Dean Decorah Dedham Deerfield
Defiance)
'(Delaware Delhi Delmar Deloit Delphos Delta
Denhart)
'(Denison Denmark Denova Denver Depew Derby Devon)
'(Dewar Dexter Diagonal Dickens Dickieville Dike
Dillon)))))
(make-test-case
"list-index:in-middle-of-several-longer-lists"
(assert =
(list-index (lambda arguments (odd? (apply + arguments)))
'(416 417 418 419 420 421 422)
'(423 424 425 426 427 428 429)
'(430 431 432 433 434 435 436)
'(437 438 439 440 441 442 443)
'(444 446 448 450 451 452 454))
4))
(make-test-case
"list-index:at-end-of-several-longer-lists"
(assert =
(list-index (lambda arguments (even? (apply + arguments)))
'(455 456 457 458 459 460)
'(461 462 463 464 465 466)
'(467 468 469 470 471 472)
'(473 474 475 476 477 478)
'(479 481 483 485 487 488))
5))
(make-test-case
"list-index:not-in-several-longer-lists"
(assert-true
(not
(list-index (lambda arguments #f)
'(Dinsdale Dixon Dodgeville Dolliver Donahue
Donnan Donnelley)
'(Donnellson Doon Dorchester Doris Douds Dougherty
Douglas)
'(Doney Dows Drakesville Dresden Dubuque Dudley
Dumfries)
'(Dumont Dunbar Duncan Duncombe Dundee Dunkerton
Dunlap)
'(Durango Durant Durham Dutchtown Dyersville
Dysart Earlham)))))
))
)
;;; search-test.ss ends here

341
collects/tests/srfi/1/selector-test.ss Normal file
View File

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

24
collects/tests/srfi/all-srfi-tests.ss Normal file
View File

@ -0,0 +1,24 @@
(module all-srfi-tests mzscheme
(require (planet "test.ss" ("schematics" "schemeunit.plt" 1 1)))
(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")
(provide all-srfi-tests)
(define all-srfi-tests
(make-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
))
)

5
collects/tests/srfi/run-tests.ss Normal file
View File

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