summaryrefslogtreecommitdiff
path: root/module/srfi/srfi-1.scm
diff options
context:
space:
mode:
Diffstat (limited to 'module/srfi/srfi-1.scm')
-rw-r--r--module/srfi/srfi-1.scm127
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)