added take+drop+append to scheme/list (problems with texpict providing drop too)

svn: r9045

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]

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?]{
 

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

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))
 

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

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

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)

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)

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)

collects/tests/mzscheme/scheme.ss

@@ -3,3 +3,4 @@
 
 (load-relative "for.ss")
 (load-relative "list.ss")
+(load-relative "function.ss")