Actually swap the argument order.
(This was supposed to be included with the other commit.)
This commit is contained in:
parent
c183711d34
commit
44c274e6c3
|
@ -135,9 +135,9 @@
|
||||||
[(pair? list) (loop (cdr list) (sub1 n) (cons (car list) pfx))]
|
[(pair? list) (loop (cdr list) (sub1 n) (cons (car list) pfx))]
|
||||||
[else (too-large 'split-at list0 n0)])))
|
[else (too-large 'split-at list0 n0)])))
|
||||||
|
|
||||||
(define (takef pred list)
|
(define (takef list pred)
|
||||||
(unless (procedure? pred)
|
(unless (procedure? pred)
|
||||||
(raise-argument-error 'takef "procedure?" 0 pred list))
|
(raise-argument-error 'takef "procedure?" 0 list pred))
|
||||||
(let loop ([list list])
|
(let loop ([list list])
|
||||||
(if (pair? list)
|
(if (pair? list)
|
||||||
(let ([x (car list)])
|
(let ([x (car list)])
|
||||||
|
@ -145,21 +145,21 @@
|
||||||
(cons x (loop (cdr list)))
|
(cons x (loop (cdr list)))
|
||||||
'()))
|
'()))
|
||||||
;; could return `list' here, but make it behave like `take'
|
;; could return `list' here, but make it behave like `take'
|
||||||
;; exmaple: (takef symbol? '(a b c . d)) should be similar
|
;; exmaple: (takef '(a b c . d) symbol?) should be similar
|
||||||
;; to (take '(a b c . d) 3)
|
;; to (take '(a b c . d) 3)
|
||||||
'())))
|
'())))
|
||||||
|
|
||||||
(define (dropf pred list)
|
(define (dropf list pred)
|
||||||
(unless (procedure? pred)
|
(unless (procedure? pred)
|
||||||
(raise-argument-error 'dropf "procedure?" 0 pred list))
|
(raise-argument-error 'dropf "procedure?" 0 list pred))
|
||||||
(let loop ([list list])
|
(let loop ([list list])
|
||||||
(if (and (pair? list) (pred (car list)))
|
(if (and (pair? list) (pred (car list)))
|
||||||
(loop (cdr list))
|
(loop (cdr list))
|
||||||
list)))
|
list)))
|
||||||
|
|
||||||
(define (splitf-at pred list)
|
(define (splitf-at list pred)
|
||||||
(unless (procedure? pred)
|
(unless (procedure? pred)
|
||||||
(raise-argument-error 'splitf-at "procedure?" 0 pred list))
|
(raise-argument-error 'splitf-at "procedure?" 0 list pred))
|
||||||
(let loop ([list list] [pfx '()])
|
(let loop ([list list] [pfx '()])
|
||||||
(if (and (pair? list) (pred (car list)))
|
(if (and (pair? list) (pred (car list)))
|
||||||
(loop (cdr list) (cons (car list) pfx))
|
(loop (cdr list) (cons (car list) pfx))
|
||||||
|
@ -213,9 +213,9 @@
|
||||||
;; one -- reverse the list, look for the place where the predicate flips
|
;; 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.
|
;; to #f, then use the non-f from-right functions above to do the work.
|
||||||
|
|
||||||
(define (count-from-right who pred list)
|
(define (count-from-right who list pred)
|
||||||
(unless (procedure? pred)
|
(unless (procedure? pred)
|
||||||
(raise-argument-error who "procedure?" 0 pred list))
|
(raise-argument-error who "procedure?" 0 list pred))
|
||||||
(let loop ([list list] [rev '()] [n 0])
|
(let loop ([list list] [rev '()] [n 0])
|
||||||
(if (pair? list)
|
(if (pair? list)
|
||||||
(loop (cdr list) (cons (car list) rev) (add1 n))
|
(loop (cdr list) (cons (car list) rev) (add1 n))
|
||||||
|
@ -224,12 +224,12 @@
|
||||||
(loop (sub1 n) (cdr list))
|
(loop (sub1 n) (cdr list))
|
||||||
n)))))
|
n)))))
|
||||||
|
|
||||||
(define (takef-right pred list)
|
(define (takef-right list pred)
|
||||||
(drop list (count-from-right 'takef-right pred list)))
|
(drop list (count-from-right 'takef-right list pred)))
|
||||||
(define (dropf-right pred list)
|
(define (dropf-right list pred)
|
||||||
(take list (count-from-right 'dropf-right pred list)))
|
(take list (count-from-right 'dropf-right list pred)))
|
||||||
(define (splitf-at-right pred list)
|
(define (splitf-at-right list pred)
|
||||||
(split-at list (count-from-right 'splitf-at-right pred list)))
|
(split-at list (count-from-right 'splitf-at-right list pred)))
|
||||||
|
|
||||||
(define append*
|
(define append*
|
||||||
(case-lambda [(ls) (apply append ls)] ; optimize common case
|
(case-lambda [(ls) (apply append ls)] ; optimize common case
|
||||||
|
|
|
@ -244,7 +244,7 @@
|
||||||
,(list (list-ref t 1) (list-ref t 2))
|
,(list (list-ref t 1) (list-ref t 2))
|
||||||
,(list (list-ref t 4) (list-ref t 3)))]
|
,(list (list-ref t 4) (list-ref t 3)))]
|
||||||
[fun ffuns])
|
[fun ffuns])
|
||||||
(test expect fun symbol? (car t)))
|
(test expect fun (car t) symbol?))
|
||||||
(for ([fun (append funs ffuns)])
|
(for ([fun (append funs ffuns)])
|
||||||
(arity-test fun 2 2)
|
(arity-test fun 2 2)
|
||||||
(err/rt-test (fun 1 1) exn:application:mismatch?)
|
(err/rt-test (fun 1 1) exn:application:mismatch?)
|
||||||
|
@ -254,26 +254,6 @@
|
||||||
(err/rt-test (fun '(1) 2) exn:application:mismatch?)
|
(err/rt-test (fun '(1) 2) exn:application:mismatch?)
|
||||||
(err/rt-test (fun '(1 2 . 3) 3) exn:application:mismatch?)))
|
(err/rt-test (fun '(1 2 . 3) 3) exn:application:mismatch?)))
|
||||||
|
|
||||||
;; ---------- takef/dropf ----------
|
|
||||||
|
|
||||||
#;(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 (list take-l drop-l) vals splitf-at pred l))
|
|
||||||
(t even? '() '())
|
|
||||||
(t even? '(2 4) '(5 7))
|
|
||||||
(t even? '(2 4 6 8) '())
|
|
||||||
(t even? '() '(1 3 5))
|
|
||||||
(t symbol? '(a b c) '(1 2 3 x y z)))
|
|
||||||
|
|
||||||
;; ---------- append* ----------
|
;; ---------- append* ----------
|
||||||
(let ()
|
(let ()
|
||||||
(test '() append* '())
|
(test '() append* '())
|
||||||
|
|
Loading…
Reference in New Issue
Block a user