From f3559964fbe18e22b8e63720b8f26a46755a3bd4 Mon Sep 17 00:00:00 2001 From: Eli Barzilay Date: Wed, 2 Jul 2008 13:12:26 +0000 Subject: [PATCH] Added `split-at' and `split-at-right', with documentation and tests, and made srfi/1 use it. svn: r10558 --- collects/scheme/list.ss | 31 ++++++++++++++++++---- collects/scribblings/reference/pairs.scrbl | 16 +++++++++++ collects/srfi/1/selector.ss | 3 ++- collects/tests/mzscheme/list.ss | 14 ++++++++-- 4 files changed, 56 insertions(+), 8 deletions(-) diff --git a/collects/scheme/list.ss b/collects/scheme/list.ss index 64b8ff34ba..550faf8f3b 100644 --- a/collects/scheme/list.ss +++ b/collects/scheme/list.ss @@ -10,8 +10,10 @@ drop take + split-at drop-right take-right + split-at-right append* flatten @@ -99,28 +101,47 @@ (raise-type-error 'drop "non-negative exact integer" n)) (or (drop* list n) (too-large 'drop list n))) +(define (split-at list0 n0) + (unless (exact-nonnegative-integer? n0) + (raise-type-error 'split-at "non-negative exact integer" n0)) + (let loop ([list list0] [n n0] [pfx '()]) + (cond [(zero? n) (values (reverse pfx) list)] + [(pair? list) (loop (cdr list) (sub1 n) (cons (car list) pfx))] + [else (too-large 'take list0 n0)]))) + ;; take/drop-right are originally from srfi-1, uses the same lead-pointer trick (define (take-right list n) (unless (exact-nonnegative-integer? n) (raise-type-error 'take-right "non-negative exact integer" n)) - (let loop ([lag list] + (let loop ([list list] [lead (or (drop* list n) (too-large 'take-right list n))]) ;; could throw an error for non-lists, but be more like `take' (if (pair? lead) - (loop (cdr lag) (cdr lead)) - lag))) + (loop (cdr list) (cdr lead)) + list))) (define (drop-right list n) (unless (exact-nonnegative-integer? n) (raise-type-error 'drop-right "non-negative exact integer" n)) - (let loop ([lag list] + (let loop ([list list] [lead (or (drop* list n) (too-large 'drop-right list n))]) ;; could throw an error for non-lists, but be more like `drop' (if (pair? lead) - (cons (car lag) (loop (cdr lag) (cdr lead))) + (cons (car list) (loop (cdr list) (cdr lead))) '()))) +(define (split-at-right list n) + (unless (exact-nonnegative-integer? n) + (raise-type-error 'split-at-right "non-negative exact integer" n)) + (let loop ([list list] + [lead (or (drop* list n) (too-large 'split-at-right list n))] + [pfx '()]) + ;; could throw an error for non-lists, but be more like `split-at' + (if (pair? lead) + (loop (cdr list) (cdr lead) (cons (car list) pfx)) + (values (reverse pfx) list)))) + (define append* (case-lambda [(ls) (apply append ls)] ; optimize common case [(l . lss) (apply append (apply list* l lss))])) diff --git a/collects/scribblings/reference/pairs.scrbl b/collects/scribblings/reference/pairs.scrbl index b8eee8635e..dc9157a451 100644 --- a/collects/scribblings/reference/pairs.scrbl +++ b/collects/scribblings/reference/pairs.scrbl @@ -532,6 +532,14 @@ must merely start with a chain of at least @scheme[pos] pairs. @defproc[(drop [lst any/c] [pos nonnegative-exact-integer?]) any/c]{ Just like @scheme[list-tail].} +@defproc[(split-at [lst any/c] [pos nonnegative-exact-integer?]) + (values list? any/c)]{ +Returns the same result as + +@schemeblock[(values (take lst pos) (drop lst pos))] + +except that it can be faster.} + @defproc[(take-right [lst any/c] [pos nonnegative-exact-integer?]) any/c]{ Returns the @scheme[list]'s @scheme[pos]-length tail. If @scheme[lst] has fewer than @scheme[pos] elements, then the @@ -558,6 +566,14 @@ must merely end with a chain of at least @scheme[pos] pairs. (drop-right 'non-list 0) ]} +@defproc[(split-at-right [lst any/c] [pos nonnegative-exact-integer?]) + (values list? any/c)]{ +Returns the same result as + +@schemeblock[(values (drop-right lst pos) (take-right lst pos))] + +except that it can be faster.} + @defproc[(add-between [lst list?] [v any/c]) list?]{ Returns a list with the same elements as @scheme[lst], but with diff --git a/collects/srfi/1/selector.ss b/collects/srfi/1/selector.ss index 2a62d382df..fce12036ce 100644 --- a/collects/srfi/1/selector.ss +++ b/collects/srfi/1/selector.ss @@ -35,7 +35,7 @@ #lang scheme/base (require srfi/optional - (only-in scheme/list take drop take-right drop-right)) + (only-in scheme/list take drop take-right drop-right split-at)) (provide first second third fourth @@ -120,6 +120,7 @@ lis))) '()))) ; Special case dropping everything -- no cons to side-effect. +#; ; provided by scheme/list (define (split-at x k) (check-arg integer? k 'split-at) (let recur ((lis x) (k k)) diff --git a/collects/tests/mzscheme/list.ss b/collects/tests/mzscheme/list.ss index 5179fdf435..6938d9a641 100644 --- a/collects/tests/mzscheme/list.ss +++ b/collects/tests/mzscheme/list.ss @@ -147,7 +147,12 @@ ;; ---------- take/drop[-right] ---------- (let () - (define funs (list take drop take-right drop-right)) + (define-syntax-rule (vals-list expr) + (call-with-values (lambda () expr) list)) + (define (split-at* l n) (vals-list (split-at l n))) + (define (split-at-right* l n) (vals-list (split-at-right l n))) + (define funs (list take drop take-right drop-right + split-at* split-at-right*)) (define tests ;; -----args------ --take--- --drop--- --take-r--- --drop-r- '([((a b c d) 2) (a b) (c d) (c d) (a b) ] @@ -156,7 +161,12 @@ [((a b c . d) 1) (a) (b c . d) (c . d) (a b) ] [((a b c . d) 3) (a b c) d (a b c . d) () ] [(99 0) () 99 99 () ])) - (for ([t tests] #:when #t [expect (cdr t)] [fun funs]) + (for ([t tests] + #:when #t + [expect `(,@(cdr t) + ,(list (list-ref t 1) (list-ref t 2)) + ,(list (list-ref t 4) (list-ref t 3)))] + [fun funs]) (apply test expect fun (car t))) (for ([fun funs]) (arity-test fun 2 2)