From 7ce6693974c837ddcbd9dbafa970f268e718bde4 Mon Sep 17 00:00:00 2001 From: Noel Welsh Date: Fri, 16 Dec 2005 22:02:09 +0000 Subject: [PATCH] Test suites for SRFIs svn: r1630 --- collects/tests/srfi/1/alist-test.ss | 459 ++++++++++++ collects/tests/srfi/1/all-1-tests.ss | 31 + collects/tests/srfi/1/cons-test.ss | 222 ++++++ collects/tests/srfi/1/delete-test.ss | 359 +++++++++ collects/tests/srfi/1/filter-test.ss | 274 +++++++ collects/tests/srfi/1/fold-test.ss | 958 ++++++++++++++++++++++++ collects/tests/srfi/1/lset-test.ss | 112 +++ collects/tests/srfi/1/misc-test.ss | 384 ++++++++++ collects/tests/srfi/1/predicate-test.ss | 170 +++++ collects/tests/srfi/1/run-tests.ss | 5 + collects/tests/srfi/1/search-test.ss | 529 +++++++++++++ collects/tests/srfi/1/selector-test.ss | 341 +++++++++ collects/tests/srfi/all-srfi-tests.ss | 24 + collects/tests/srfi/run-tests.ss | 5 + 14 files changed, 3873 insertions(+) create mode 100644 collects/tests/srfi/1/alist-test.ss create mode 100644 collects/tests/srfi/1/all-1-tests.ss create mode 100644 collects/tests/srfi/1/cons-test.ss create mode 100644 collects/tests/srfi/1/delete-test.ss create mode 100644 collects/tests/srfi/1/filter-test.ss create mode 100644 collects/tests/srfi/1/fold-test.ss create mode 100644 collects/tests/srfi/1/lset-test.ss create mode 100644 collects/tests/srfi/1/misc-test.ss create mode 100644 collects/tests/srfi/1/predicate-test.ss create mode 100644 collects/tests/srfi/1/run-tests.ss create mode 100644 collects/tests/srfi/1/search-test.ss create mode 100644 collects/tests/srfi/1/selector-test.ss create mode 100644 collects/tests/srfi/all-srfi-tests.ss create mode 100644 collects/tests/srfi/run-tests.ss diff --git a/collects/tests/srfi/1/alist-test.ss b/collects/tests/srfi/1/alist-test.ss new file mode 100644 index 0000000000..0330aadec9 --- /dev/null +++ b/collects/tests/srfi/1/alist-test.ss @@ -0,0 +1,459 @@ +;;; +;;; ---- 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 +;; +;; +;; 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 diff --git a/collects/tests/srfi/1/all-1-tests.ss b/collects/tests/srfi/1/all-1-tests.ss new file mode 100644 index 0000000000..88bb23830d --- /dev/null +++ b/collects/tests/srfi/1/all-1-tests.ss @@ -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 + )) + ) diff --git a/collects/tests/srfi/1/cons-test.ss b/collects/tests/srfi/1/cons-test.ss new file mode 100644 index 0000000000..6c1c242d01 --- /dev/null +++ b/collects/tests/srfi/1/cons-test.ss @@ -0,0 +1,222 @@ +;;; +;;; ---- 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 +;; +;; +;; 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 diff --git a/collects/tests/srfi/1/delete-test.ss b/collects/tests/srfi/1/delete-test.ss new file mode 100644 index 0000000000..1520a005c8 --- /dev/null +++ b/collects/tests/srfi/1/delete-test.ss @@ -0,0 +1,359 @@ +;;; +;;; ---- 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 +;; +;; +;; 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 diff --git a/collects/tests/srfi/1/filter-test.ss b/collects/tests/srfi/1/filter-test.ss new file mode 100644 index 0000000000..e7311ba331 --- /dev/null +++ b/collects/tests/srfi/1/filter-test.ss @@ -0,0 +1,274 @@ +;;; +;;; ---- 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 +;; +;; +;; 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 diff --git a/collects/tests/srfi/1/fold-test.ss b/collects/tests/srfi/1/fold-test.ss new file mode 100644 index 0000000000..05d3383076 --- /dev/null +++ b/collects/tests/srfi/1/fold-test.ss @@ -0,0 +1,958 @@ +;;; +;;; ---- 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 +;; +;; +;; 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 diff --git a/collects/tests/srfi/1/lset-test.ss b/collects/tests/srfi/1/lset-test.ss new file mode 100644 index 0000000000..d14bdbcbf4 --- /dev/null +++ b/collects/tests/srfi/1/lset-test.ss @@ -0,0 +1,112 @@ +;;; +;;; ---- 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 +;; +;; +;; 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 diff --git a/collects/tests/srfi/1/misc-test.ss b/collects/tests/srfi/1/misc-test.ss new file mode 100644 index 0000000000..fd02228295 --- /dev/null +++ b/collects/tests/srfi/1/misc-test.ss @@ -0,0 +1,384 @@ +;;; +;;; ---- 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 +;; +;; +;; 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 diff --git a/collects/tests/srfi/1/predicate-test.ss b/collects/tests/srfi/1/predicate-test.ss new file mode 100644 index 0000000000..63b124a9a3 --- /dev/null +++ b/collects/tests/srfi/1/predicate-test.ss @@ -0,0 +1,170 @@ +;;; +;;; ---- 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 +;; +;; +;; 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 diff --git a/collects/tests/srfi/1/run-tests.ss b/collects/tests/srfi/1/run-tests.ss new file mode 100644 index 0000000000..9c3648d8f4 --- /dev/null +++ b/collects/tests/srfi/1/run-tests.ss @@ -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) diff --git a/collects/tests/srfi/1/search-test.ss b/collects/tests/srfi/1/search-test.ss new file mode 100644 index 0000000000..8c65041f8c --- /dev/null +++ b/collects/tests/srfi/1/search-test.ss @@ -0,0 +1,529 @@ +;;; +;;; ---- 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 +;; +;; +;; 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 diff --git a/collects/tests/srfi/1/selector-test.ss b/collects/tests/srfi/1/selector-test.ss new file mode 100644 index 0000000000..4a673bc717 --- /dev/null +++ b/collects/tests/srfi/1/selector-test.ss @@ -0,0 +1,341 @@ +;;; +;;; ---- 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 +;; +;; +;; 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 diff --git a/collects/tests/srfi/all-srfi-tests.ss b/collects/tests/srfi/all-srfi-tests.ss new file mode 100644 index 0000000000..7d6072305f --- /dev/null +++ b/collects/tests/srfi/all-srfi-tests.ss @@ -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 + )) + ) diff --git a/collects/tests/srfi/run-tests.ss b/collects/tests/srfi/run-tests.ss new file mode 100644 index 0000000000..af81aae1cd --- /dev/null +++ b/collects/tests/srfi/run-tests.ss @@ -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)