diff options
Diffstat (limited to 'module/srfi/srfi-1.scm')
-rw-r--r-- | module/srfi/srfi-1.scm | 127 |
1 files changed, 127 insertions, 0 deletions
diff --git a/module/srfi/srfi-1.scm b/module/srfi/srfi-1.scm index 852729346..1e27d6f91 100644 --- a/module/srfi/srfi-1.scm +++ b/module/srfi/srfi-1.scm @@ -350,6 +350,30 @@ end-of-list checking in contexts where dotted lists are allowed." (define take list-head) (define drop list-tail) +(define (take! lst i) + "Linear-update variant of `take'." + (if (= i 0) + '() + (let ((tail (drop lst (- i 1)))) + (set-cdr! tail '()) + lst))) + +(define (drop-right! lst i) + "Linear-update variant of `drop-right'." + (let ((tail (drop lst i))) + (if (null? tail) + '() + (let loop ((prev lst) + (tail (cdr tail))) + (if (null? tail) + (if (pair? prev) + (begin + (set-cdr! prev '()) + lst) + lst) + (loop (cdr prev) + (cdr tail))))))) + (define (last pair) "Return the last element of the non-empty, finite list PAIR." (car (last-pair pair))) @@ -441,6 +465,24 @@ that result. See the manual for details." lis (uf (g seed) (cons (f seed) lis))))) +(define (reduce f ridentity lst) + "`reduce' is a variant of `fold', where the first call to F is on two +elements from LST, rather than one element and a given initial value. +If LST is empty, RIDENTITY is returned. If LST has just one element +then that's the return value." + (if (null? lst) + ridentity + (fold f (car lst) (cdr lst)))) + +(define (reduce-right f ridentity lst) + "`reduce-right' is a variant of `fold-right', where the first call to +F is on two elements from LST, rather than one element and a given +initial value. If LST is empty, RIDENTITY is returned. If LST +has just one element then that's the return value." + (if (null? lst) + ridentity + (fold-right f (last lst) (drop-right lst 1)))) + ;; Internal helper procedure. Map `f' over the single list `ls'. ;; @@ -470,8 +512,72 @@ that result. See the manual for details." (apply f l) (lp (map1 cdr l))))))) + ;;; Searching +(define (take-while pred ls) + "Return a new list which is the longest initial prefix of LS whose +elements all satisfy the predicate PRED." + (cond ((null? ls) '()) + ((not (pred (car ls))) '()) + (else + (let ((result (list (car ls)))) + (let lp ((ls (cdr ls)) (p result)) + (cond ((null? ls) result) + ((not (pred (car ls))) result) + (else + (set-cdr! p (list (car ls))) + (lp (cdr ls) (cdr p))))))))) + +(define (take-while! pred lst) + "Linear-update variant of `take-while'." + (let loop ((prev #f) + (rest lst)) + (cond ((null? rest) + lst) + ((pred (car rest)) + (loop rest (cdr rest))) + (else + (if (pair? prev) + (begin + (set-cdr! prev '()) + lst) + '()))))) + +(define (drop-while pred lst) + "Drop the longest initial prefix of LST whose elements all satisfy the +predicate PRED." + (let loop ((lst lst)) + (cond ((null? lst) + '()) + ((pred (car lst)) + (loop (cdr lst))) + (else lst)))) + +(define (span pred lst) + "Return two values, the longest initial prefix of LST whose elements +all satisfy the predicate PRED, and the remainder of LST." + (let lp ((lst lst) (rl '())) + (if (and (not (null? lst)) + (pred (car lst))) + (lp (cdr lst) (cons (car lst) rl)) + (values (reverse! rl) lst)))) + +(define (span! pred list) + "Linear-update variant of `span'." + (let loop ((prev #f) + (rest list)) + (cond ((null? rest) + (values list '())) + ((pred (car rest)) + (loop rest (cdr rest))) + (else + (if (pair? prev) + (begin + (set-cdr! prev '()) + (values list rest)) + (values '() list)))))) + (define (break pred clist) "Return two values, the longest initial prefix of LST whose elements all fail the predicate PRED, and the remainder of LST." @@ -587,6 +693,27 @@ CLIST1 ... CLISTN, that satisfies PRED." (every (lambda (el) (member el f (lambda (x y) (= y x)))) (car r)) (lp (car r) (cdr r))))))) +;; It's not quite clear if duplicates among the `rest' elements are meant to +;; be cast out. The spec says `=' is called as (= lstelem restelem), +;; suggesting perhaps not, but the reference implementation shows the "list" +;; at each stage as including those elements already added. The latter +;; corresponds to what's described for lset-union, so that's what's done. +;; +(define (lset-adjoin = list . rest) + "Add to LIST any of the elements of REST not already in the list. +These elements are `cons'ed onto the start of LIST (so the return shares +a common tail with LIST), but the order they're added is unspecified. + +The given `=' procedure is used for comparing elements, called +as `(@var{=} listelem elem)', i.e., the second argument is one of the +given REST parameters." + (let lp ((l rest) (acc list)) + (if (null? l) + acc + (if (member (car l) acc (lambda (x y) (= y x))) + (lp (cdr l) acc) + (lp (cdr l) (cons (car l) acc)))))) + (define (lset-union = . rest) (let ((acc '())) (for-each (lambda (lst) |