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

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

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) '()]
+    (if (and (pair? list) (pred (car list)))
-          [(pred (car list)) (loop (cdr list))]
+      (loop (cdr list))
-          [else 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)]

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
+The @racket[lst] argument need not actually be a list; @racket[lst]
-  (dropf even? '(2 4 5 8))
+must merely start with a chain of at least @racket[pos] pairs.
-  (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].
 
 @mz-examples[#:eval list-eval
-  (dropf even? '(2 4 5 8))
+  (dropf '(2 4 5 8) even?)
-  (dropf odd? '(2 4 6 8))]}
+  (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]

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)
+  (define (vals f)
-    (call-with-values (lambda () expr) list))
+    (procedure-reduce-arity
-  (define (split-at*       l n) (vals-list (split-at       l n)))
+     (lambda xs (call-with-values (lambda () (apply f xs)) list))
-  (define (split-at-right* l n) (vals-list (split-at-right l n)))
+     (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-
+    ;; -----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) 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) 4)   (a b c d) ()        (a b c d)   ()       ]
+      [((a b c d) 2)   (a b    ) (    c d)   (    c d)   (a b    )]
-      [((a b c . d) 1) (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) 3) (a b c)   d         (a b c . d) ()       ]
+      [((a b c d) 4)   (a b c d) (       )   (a b c d)   (       )]
-      [(99 0)          ()        99        99          ()       ]))
+      [((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) '())