From fb8efd48164b72a09df6ea77877cfd526b2e649f Mon Sep 17 00:00:00 2001 From: Eli Barzilay Date: Fri, 21 Mar 2008 18:45:18 +0000 Subject: [PATCH] added take+drop+append to scheme/list (problems with texpict providing drop too) svn: r9045 --- collects/scheme/list.ss | 23 ++++++++++++++ collects/scribblings/reference/pairs.scrbl | 22 ++++++++++++++ collects/scribblings/slideshow/picts.scrbl | 2 +- collects/scribblings/slideshow/slides.scrbl | 2 +- collects/scribblings/slideshow/ss.ss | 2 +- collects/slideshow/viewer.ss | 2 +- collects/srfi/1/selector.ss | 11 ++++--- collects/tests/mzscheme/list.ss | 33 +++++++++++++++++++++ collects/tests/mzscheme/mzlib.ss | 27 ----------------- collects/tests/mzscheme/scheme.ss | 1 + 10 files changed, 90 insertions(+), 35 deletions(-) diff --git a/collects/scheme/list.ss b/collects/scheme/list.ss index 0bb6e5c423..18fb6db4e9 100644 --- a/collects/scheme/list.ss +++ b/collects/scheme/list.ss @@ -9,6 +9,10 @@ empty empty? + drop + take + + append* flatten) (define (first x) @@ -54,6 +58,25 @@ (define empty? (lambda (l) (null? l))) (define empty '()) +(define drop list-tail) +(define (take list0 n0) + (unless (and (integer? n0) (exact? n0)) + (raise-type-error 'take "non-negative integer" n0)) + (let loop ([list list0] [n n0]) + (cond [(zero? n) '()] + [(pair? list) (cons (car list) (loop (cdr list) (sub1 n)))] + [else (raise-mismatch-error + 'take + (format "index ~e too large for list~a: ~e" + n0 + (if (list? list) "" " (not a proper list)") + list0) + n0)]))) + +(define append* + (case-lambda [(ls) (apply append ls)] ; optimize common case + [(ls . lss) (apply append (apply list* ls lss))])) + (define (flatten orig-sexp) (let loop ([sexp orig-sexp] [acc null]) (cond [(null? sexp) acc] diff --git a/collects/scribblings/reference/pairs.scrbl b/collects/scribblings/reference/pairs.scrbl index 581bd50d6a..321b20666e 100644 --- a/collects/scribblings/reference/pairs.scrbl +++ b/collects/scribblings/reference/pairs.scrbl @@ -481,6 +481,28 @@ Like @scheme[assoc], but finds an element using the predicate @defproc[(last [lst list?]) any]{Returns the last element of the list.} +@defproc[(drop [lst list?] [pos nonnegative-exact-integer?]) list?]{ +Synonym for @scheme[list-tail]. +} + +@defproc[(take [lst list?] [pos nonnegative-exact-integer?]) list?]{ +Returns a fresh list, holding the first @scheme[pos] elements of +@scheme[lst]. An exception is raised if the list has fewer than +@scheme[pos] elements. +} + +@defproc[(append* [lst list?] ... [lsts (list/c list?)]) list?]{ + +Like @scheme[append], but the last argument is used as a list of +arguments for @scheme[append]. In other words, the relationship +between @scheme[append] and @scheme[append*] is similar to the one +between @scheme[list] and @scheme[list]. + +@list-examples[ + (cdr (append* (map (lambda (x) (list ", " x)) + '("Alpha" "Beta" "Gamma")))) +]} + @defproc[(flatten [v any/c]) list?]{ diff --git a/collects/scribblings/slideshow/picts.scrbl b/collects/scribblings/slideshow/picts.scrbl index a67f38a83e..1b671b8613 100644 --- a/collects/scribblings/slideshow/picts.scrbl +++ b/collects/scribblings/slideshow/picts.scrbl @@ -1,6 +1,6 @@ #lang scribble/doc @(require "ss.ss" - (for-label scheme/gui + (for-label (except-in scheme/gui drop) slideshow/code slideshow/flash slideshow/face diff --git a/collects/scribblings/slideshow/slides.scrbl b/collects/scribblings/slideshow/slides.scrbl index 79ec6e0bfe..0c8ed7feef 100644 --- a/collects/scribblings/slideshow/slides.scrbl +++ b/collects/scribblings/slideshow/slides.scrbl @@ -1,6 +1,6 @@ #lang scribble/doc @(require "ss.ss" - (for-label scheme/gui + (for-label (except-in scheme/gui drop) slideshow/step slideshow/slides-to-picts)) diff --git a/collects/scribblings/slideshow/ss.ss b/collects/scribblings/slideshow/ss.ss index a0c952ad65..7e833dc1a2 100644 --- a/collects/scribblings/slideshow/ss.ss +++ b/collects/scribblings/slideshow/ss.ss @@ -3,7 +3,7 @@ (require scribble/manual) (provide (all-from-out scribble/manual)) -(require (for-label (except-in scheme only) +(require (for-label (except-in scheme only drop) slideshow/base slideshow/pict)) (provide (for-label (all-from-out scheme diff --git a/collects/slideshow/viewer.ss b/collects/slideshow/viewer.ss index 6b272ca301..1545baab0b 100644 --- a/collects/slideshow/viewer.ss +++ b/collects/slideshow/viewer.ss @@ -3,7 +3,7 @@ (require scheme/class scheme/unit scheme/contract - scheme/list + (only-in scheme/list last) scheme/path scheme/file mred diff --git a/collects/srfi/1/selector.ss b/collects/srfi/1/selector.ss index bbc1c53523..6a258a58b1 100644 --- a/collects/srfi/1/selector.ss +++ b/collects/srfi/1/selector.ss @@ -34,7 +34,8 @@ #lang scheme/base -(require srfi/optional) +(require srfi/optional + (only-in scheme/list take drop)) (provide first second third fourth @@ -64,6 +65,7 @@ ;; take & drop +#; ; provided by scheme/list (define (take lis k) (check-arg integer? k 'take) (let recur ((lis lis) (k k)) @@ -71,12 +73,13 @@ (cons (car lis) (recur (cdr lis) (- k 1)))))) +#; ; provided by scheme/list (define (drop lis k) (check-arg integer? k 'drop) (let iter ((lis lis) (k k)) (if (zero? k) lis (iter (cdr lis) (- k 1))))) -#; +#; ; lists are immutable (define (take! lis k) (check-arg integer? k 'take!) (if (zero? k) '() @@ -103,7 +106,7 @@ ;; In this function, LEAD is actually K+1 ahead of LAG. This lets ;; us stop LAG one step early, in time to smash its cdr to (). -#; +#; ; lists are immutable (define (drop-right! lis k) (check-arg integer? k 'drop-right!) (let ((lead (drop lis k))) @@ -122,7 +125,7 @@ (let-values ([(prefix suffix) (recur (cdr lis) (- k 1))]) (values (cons (car lis) prefix) suffix))))) -#; +#; ; lists are immutable (define (split-at! x k) (check-arg integer? k 'split-at!) (if (zero? k) (values '() x) diff --git a/collects/tests/mzscheme/list.ss b/collects/tests/mzscheme/list.ss index 38d8ac4704..6692d84243 100644 --- a/collects/tests/mzscheme/list.ss +++ b/collects/tests/mzscheme/list.ss @@ -87,6 +87,39 @@ ((0 2) (1 1) (0 3)) ((0 2) (0 3) (1 1))))) +;; ---------- take/drop ---------- +(let () + (define tests + ;; ------call------- --take--- --drop--- + '([(? (a b c d) 2) (a b) (c d) ] + [(? (a b c d) 0) () (a b c d)] + [(? (a b c d) 4) (a b c d) () ] + [(? (a b c . d) 1) (a) (b c . d)] + [(? (a b c . d) 3) (a b c) d ] + [(? 99 0) () 99 ])) + (for ([t tests]) + (apply test (cadr t) take (cdar t)) + (apply test (caddr t) drop (cdar t))) + (arity-test take 2 2) + (arity-test drop 2 2) + (err/rt-test (drop 1 1) exn:application:mismatch?) + (err/rt-test (take 1 1) exn:application:mismatch?) + (err/rt-test (drop '(1 2 3) 2.0)) + (err/rt-test (take '(1 2 3) 2.0)) + (err/rt-test (drop '(1) '(1))) + (err/rt-test (take '(1) '(1))) + (err/rt-test (drop '(1) -1)) + (err/rt-test (take '(1) -1)) + (err/rt-test (drop '(1) 2) exn:application:mismatch?) + (err/rt-test (take '(1) 2) exn:application:mismatch?) + (err/rt-test (drop '(1 2 . 3) 3) exn:application:mismatch?) + (err/rt-test (take '(1 2 . 3) 3) exn:application:mismatch?)) + +;; ---------- append* ---------- +(let () + (test '(0 1 0 2 0 3) append* (map (lambda (x) (list 0 x)) '(1 2 3))) + (test '(1 2 3 4 5 6 7 8 9) append* '(1 2 3) '(4 5) '((6 7 8) (9)))) + ;; ---------- flatten ---------- (let () (define (all-sexps n) diff --git a/collects/tests/mzscheme/mzlib.ss b/collects/tests/mzscheme/mzlib.ss index ab1d184b3e..04a9792eae 100644 --- a/collects/tests/mzscheme/mzlib.ss +++ b/collects/tests/mzscheme/mzlib.ss @@ -3,57 +3,30 @@ ; See also pptest.ss and ztest.ss (load-relative "loadtest.ss") - (load-in-sandbox "mpair.ss") - (load-in-sandbox "md5.ss") - (load-in-sandbox "etc.ss") - (load-in-sandbox "structlib.ss") - (load-in-sandbox "async-channel.ss") - (load-in-sandbox "restart.ss") - -(load-in-sandbox "function.ss") - (load-in-sandbox "string.ss") - (load-in-sandbox "filelib.ss") - (load-in-sandbox "portlib.ss") - (load-in-sandbox "threadlib.ss") - (load-in-sandbox "date.ss") - (load-in-sandbox "compat.ss") - (load-in-sandbox "cmdline.ss") - (load-in-sandbox "pconvert.ss") - (load-in-sandbox "pretty.ss") - (load-in-sandbox "control.ss") - (load-in-sandbox "serialize.ss") - ;; (load-in-sandbox "package.ss") - (load-in-sandbox "contract-test.ss") ;; tests scheme/contract - (load-in-sandbox "contract-mzlib-test.ss") ;; tests mzlib/contract - (load-in-sandbox "match-test.ss") - (load-in-sandbox "sandbox.ss") - (load-in-sandbox "shared.ss") - (load-in-sandbox "kw.ss") - (load-in-sandbox "macrolib.ss") (report-errs) diff --git a/collects/tests/mzscheme/scheme.ss b/collects/tests/mzscheme/scheme.ss index a00717f75e..672407ab83 100644 --- a/collects/tests/mzscheme/scheme.ss +++ b/collects/tests/mzscheme/scheme.ss @@ -3,3 +3,4 @@ (load-relative "for.ss") (load-relative "list.ss") +(load-relative "function.ss")