suzanne.soy/racket
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

Added splitf-at', takef-right', dropf-right', splitf-at-right', and more.

Browse Source 
* See comment about implementation issues.

* Removed the `list?' requirement on `takef' etc -- so it matches the
  non-*f versions.  (IMO, it'd be better to drop it from all of them.)
  This also changes the output of `dropf' to `any/c'.

* Swapped the argument order so the predicate is last -- this makes it
  uniform with the non-f* versions.  (IMO, it'b be better to use the
  popular order in all of them instead.)

* Includes tests, and also improved version of previous tests.

* Includes docs, and also fixes to previous docs (eg, drop* doesn't
  return a fresh list).
This commit is contained in:
Eli Barzilay 2013-03-09 15:33:38 -05:00
parent 0d217af2f0
commit 3af72ecab4
3 changed files with 152 additions and 39 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

64
collects/racket/list.rkt
View File

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

51
collects/scribblings/reference/pairs.scrbl
View File

@ -895,7 +895,7 @@ 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
@ -903,20 +903,33 @@ Returns a fresh list whose elements are taken successively from
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]

66
collects/tests/racket/list.rktl
View File

@ -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)]
;; -----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) '())