diff --git a/collects/racket/list.rkt b/collects/racket/list.rkt index 74d2db6183..b6c8c4c6c4 100644 --- a/collects/racket/list.rkt +++ b/collects/racket/list.rkt @@ -15,9 +15,13 @@ split-at takef dropf + splitf-at drop-right take-right split-at-right + takef-right + dropf-right + splitf-at-right append* flatten @@ -134,25 +138,32 @@ (define (takef pred list) (unless (procedure? pred) (raise-argument-error 'takef "procedure?" 0 pred list)) - (unless (list? list) - (raise-argument-error 'takef "list?" 1 pred list)) (let loop ([list list]) - (if (null? list) - '() + (if (pair? list) (let ([x (car list)]) (if (pred x) (cons x (loop (cdr list))) - '()))))) + '())) + ;; could return `list' here, but make it behave like `take' + ;; exmaple: (takef symbol? '(a b c . d)) should be similar + ;; to (take '(a b c . d) 3) + '()))) (define (dropf pred list) (unless (procedure? pred) (raise-argument-error 'dropf "procedure?" 0 pred list)) - (unless (list? list) - (raise-argument-error 'dropf "list?" 1 pred list)) (let loop ([list list]) - (cond [(null? list) '()] - [(pred (car list)) (loop (cdr list))] - [else list]))) + (if (and (pair? list) (pred (car list))) + (loop (cdr list)) + list))) + +(define (splitf-at pred list) + (unless (procedure? pred) + (raise-argument-error 'splitf-at "procedure?" 0 pred list)) + (let loop ([list list] [pfx '()]) + (if (and (pair? list) (pred (car list))) + (loop (cdr list) (cons (car list) pfx)) + (values (reverse pfx) list)))) ;; take/drop-right are originally from srfi-1, uses the same lead-pointer trick @@ -187,6 +198,39 @@ (loop (cdr list) (cdr lead) (cons (car list) pfx)) (values (reverse pfx) list)))) +;; For just `takef-right', it's possible to do something smart that +;; scans the list in order, keeping a pointer to the beginning of the +;; "current good block". This avoids a double scan *but* the payment is +;; in applying the predicate on all emlements. There might be a point +;; in that in some cases, but probably in most cases it's best to apply +;; it in reverse order, get the index, then do the usual thing -- in +;; many cases applying the predicate on all items could be more +;; expensive than the allocation needed for reverse. +;; +;; That's mildly useful in a completely unexciting way, but when it gets +;; to the other *f-right functions, it gets worse in that the first +;; approach won't work, so there's not much else to do than the second +;; one -- reverse the list, look for the place where the predicate flips +;; to #f, then use the non-f from-right functions above to do the work. + +(define (count-from-right who pred list) + (unless (procedure? pred) + (raise-argument-error who "procedure?" 0 pred list)) + (let loop ([list list] [rev '()] [n 0]) + (if (pair? list) + (loop (cdr list) (cons (car list) rev) (add1 n)) + (let loop ([n n] [list rev]) + (if (and (pair? list) (pred (car list))) + (loop (sub1 n) (cdr list)) + n))))) + +(define (takef-right pred list) + (drop list (count-from-right 'takef-right pred list))) +(define (dropf-right pred list) + (take list (count-from-right 'dropf-right pred list))) +(define (splitf-at-right pred list) + (split-at list (count-from-right 'splitf-at-right pred list))) + (define append* (case-lambda [(ls) (apply append ls)] ; optimize common case [(l1 l2) (apply append l1 l2)] diff --git a/collects/scribblings/reference/pairs.scrbl b/collects/scribblings/reference/pairs.scrbl index 55f38d100a..bec97cd69c 100644 --- a/collects/scribblings/reference/pairs.scrbl +++ b/collects/scribblings/reference/pairs.scrbl @@ -895,28 +895,41 @@ Returns the same result as except that it can be faster.} -@defproc[(takef [pred procedure?] [lst list?]) +@defproc[(takef [lst any/c] [pred procedure?]) list?]{ Returns a fresh list whose elements are taken successively from -@racket[lst] as long as they satisfy @racket[pred]. The returned list +@racket[lst] as long as they satisfy @racket[pred]. The returned list includes up to, but not including, the first element in @racket[lst] for which @racket[pred] returns @racket[#f]. -@mz-examples[#:eval list-eval - (dropf even? '(2 4 5 8)) - (dropf odd? '(2 4 6 8))]} - - -@defproc[(dropf [pred procedure?] [lst list?]) - list?]{ - -Returns a fresh list with elements successively removed from -@racket[lst] from the front as long as they satisfy @racket[pred]. +The @racket[lst] argument need not actually be a list; @racket[lst] +must merely start with a chain of at least @racket[pos] pairs. @mz-examples[#:eval list-eval - (dropf even? '(2 4 5 8)) - (dropf odd? '(2 4 6 8))]} + (dropf '(2 4 5 8) even?) + (dropf '(2 4 6 8) odd?)]} + + +@defproc[(dropf [lst any/c] [pred procedure?]) + any/c]{ + +Drops elements from the front of @racket[lst] as long as they satisfy +@racket[pred]. + +@mz-examples[#:eval list-eval + (dropf '(2 4 5 8) even?) + (dropf '(2 4 6 8) odd?)]} + + +@defproc[(splitf-at [lst any/c] [pred procedure?]) + (values list? any/c)]{ + +Returns the same result as + +@racketblock[(values (take lst pred) (drop lst pred))] + +except that it can be faster.} @defproc[(take-right [lst any/c] [pos exact-nonnegative-integer?]) @@ -963,6 +976,18 @@ except that it can be faster. (split-at-right '(1 2 3 4 5 6) 4)]} +@deftogether[( + @defproc[(takef-right [lst any/c] [pred procedure?]) list?] + @defproc[(dropf-right [lst any/c] [pred procedure?]) any/c] + @defproc[(splitf-at-right [lst any/c] [pred procedure?]) (values list? any/c)] +)]{ + +Like @racket[takef], @racket[dropf], and @racket[splitf-at], but +combined with the from-right functionality of @racket[take-right], +@racket[drop-right], and @racket[split-right-at].} + + + @defproc[(add-between [lst list?] [v any/c] [#:before-first before-first list? '()] [#:before-last before-last any/c v] diff --git a/collects/tests/racket/list.rktl b/collects/tests/racket/list.rktl index 2af73094f4..a70ea98461 100644 --- a/collects/tests/racket/list.rktl +++ b/collects/tests/racket/list.rktl @@ -180,22 +180,57 @@ (test '(x x) make-list 2 'x) (err/rt-test (make-list -3 'x))) -;; ---------- take/drop[-right] ---------- +;; ---------- take/drop/splt-at[-right] ---------- (let () - (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 (vals f) + (procedure-reduce-arity + (lambda xs (call-with-values (lambda () (apply f xs)) list)) + (procedure-arity f))) + (define split-at* (vals split-at)) + (define split-at-right* (vals split-at-right)) + (define splitf-at* (vals splitf-at)) + (define splitf-at-right* (vals splitf-at-right)) (define funs (list take drop take-right drop-right split-at* split-at-right*)) + (define ffuns (list takef dropf takef-right dropf-right + splitf-at* splitf-at-right*)) (define tests - ;; -----args------ --take--- --drop--- --take-r--- --drop-r- - '([((a b c d) 2) (a b) (c d) (c d) (a b) ] - [((a b c d) 0) () (a b c d) () (a b c d)] - [((a b c d) 4) (a b c d) () (a b c d) () ] - [((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 () ])) + ;; -----args------ --take--- --drop--- ---take-r---- --drop-r- + '([((a b c d) 0) ( ) (a b c d) ( ) (a b c d)] + [((a b c d) 1) (a ) ( b c d) ( d) (a b c )] + [((a b c d) 2) (a b ) ( c d) ( c d) (a b )] + [((a b c d) 3) (a b c ) ( d) ( b c d) (a )] + [((a b c d) 4) (a b c d) ( ) (a b c d) ( )] + [((a b c . d) 0) ( ) (a b c . d) d (a b c )] + [((a b c . d) 1) (a ) ( b c . d) ( c . d) (a b )] + [((a b c . d) 2) (a b ) ( c . d) ( b c . d) (a )] + [((a b c . d) 3) (a b c) d (a b c . d) ( )] + [(() 0) () () () () ] + [(99 0) () 99 99 () ])) + (define ftests ; the predicate is always `symbol?' + ;; ---args---- --takef-- ---dropf--- --takef-r-- --dropf-r-- + `([(a b c d) (a b c d) ( ) (a b c d) ( ) ] + [(a b c 4) (a b c ) ( 4) ( ) (a b c 4) ] + [(a b 3 4) (a b ) ( 3 4) ( ) (a b 3 4) ] + [(a 2 3 4) (a ) ( 2 3 4) ( ) (a 2 3 4) ] + [(1 2 3 4) ( ) (1 2 3 4) ( ) (1 2 3 4) ] + [(1 2 3 d) ( ) (1 2 3 d) ( d) (1 2 3 ) ] + [(1 2 c d) ( ) (1 2 c d) ( c d) (1 2 ) ] + [(1 b c d) ( ) (1 b c d) ( b c d) (1 ) ] + [(a 2 3 d) (a ) ( 2 3 d) ( d) (a 2 3 ) ] + [(1 b c 4) ( ) (1 b c 4) ( ) (1 b c 4) ] + [(a b c . d) (a b c ) d (a b c . d) ( )] + [(a b c . 4) (a b c ) 4 (a b c . 4) ( )] + [(a b 3 . 4) (a b ) ( 3 . 4) 4 (a b 3 )] + [(a 2 3 . 4) (a ) ( 2 3 . 4) 4 (a 2 3 )] + [(1 2 3 . 4) ( ) (1 2 3 . 4) 4 (1 2 3 )] + [(1 2 3 . d) ( ) (1 2 3 . d) d (1 2 3 )] + [(1 2 c . d) ( ) (1 2 c . d) ( c . d) (1 2 )] + [(1 b c . d) ( ) (1 b c . d) ( b c . d) (1 )] + [(a 2 c . d) (a ) ( 2 c . d) ( c . d) (a 2 )] + [(1 b 3 . 4) ( ) (1 b 3 . 4) 4 (1 b 3 )] + [() () () () () ] + [99 () 99 99 () ])) (for ([t tests] #:when #t [expect `(,@(cdr t) @@ -203,7 +238,14 @@ ,(list (list-ref t 4) (list-ref t 3)))] [fun funs]) (apply test expect fun (car t))) - (for ([fun funs]) + (for ([t ftests] + #:when #t + [expect `(,@(cdr t) + ,(list (list-ref t 1) (list-ref t 2)) + ,(list (list-ref t 4) (list-ref t 3)))] + [fun ffuns]) + (test expect fun symbol? (car t))) + (for ([fun (append funs ffuns)]) (arity-test fun 2 2) (err/rt-test (fun 1 1) exn:application:mismatch?) (err/rt-test (fun '(1 2 3) 2.0)) @@ -214,16 +256,18 @@ ;; ---------- takef/dropf ---------- -(let () +#;(let () (define list-1 '(2 4 6 8 1 3 5)) (err/rt-test (takef 5 '()) exn:application:mismatch?) (err/rt-test (dropf 5 '()) exn:application:mismatch?) (err/rt-test (takef even? 1) exn:application:mismatch?) (err/rt-test (dropf even? 1) exn:application:mismatch?) + (define (vals f . xs) (call-with-values (λ() (apply f xs)) list)) (define (t pred take-l drop-l) (define l (append take-l drop-l)) (test take-l takef pred l) - (test drop-l dropf pred l)) + (test drop-l dropf pred l) + (test (list take-l drop-l) vals splitf-at pred l)) (t even? '() '()) (t even? '(2 4) '(5 7)) (t even? '(2 4 6 8) '())