1;; The (rnrs lists (6)) library. Contains some code from Kawa's SRFI-1 2;; implementation (i.e. the reference implementation, which is 3;; Copyright (c) 1998, 1999 by Olin Shivers). Documentation strings 4;; are adapted from the text of the R6RS List utilities library 5;; specification. The rest is Copyright (c) 2011 by Jamison Hope. 6 7(module-name kawa.lib.rnrs.lists) 8(module-export find for-all exists filter partition fold-left 9 fold-right remp remove remv remq memp member memv memq 10 assp assoc assv assq cons*) 11(require kawa.lib.prim_imports) 12(require kawa.lib.std_syntax) 13(require kawa.lib.syntax) 14(require kawa.lib.misc) 15(require kawa.lib.lists "../lists.scm") 16 17;;; Helper Functions 18 19(define (complement (proc ::procedure)) ::procedure 20 (lambda (x) (not (proc x)))) 21 22;; car+cdr, %cars+cdrs, %cars+cdrs/pair, %cdrs, %cars+ taken from 23;; srfi1.scm 24(define (car+cdr (pair ::pair)) (values (car pair) (cdr pair))) 25 26(define (%cars+cdrs (lists ::list)) 27 "LISTS is a (not very long) non-empty list of lists. Return two 28lists: the cars & the cdrs of the lists. However, if any of the lists 29is empty, just abort and return [() ()]." 30 (call-with-current-continuation 31 (lambda (abort) 32 (let recur ((lists lists)) 33 (if (pair? lists) 34 (let-values (((list other-lists) (car+cdr lists))) 35 (if (null? list) (abort '() '()) ; LIST is empty -- bail out 36 (let-values (((a d) (car+cdr list)) 37 ((cars cdrs) (recur other-lists))) 38 (values (cons a cars) (cons d cdrs))))) 39 (values '() '())))))) 40 41(define (%cars+cdrs/pair (lists ::list)) ::pair 42 "Return the `%cars+cdrs' result as a pair instead of a multiple 43value return. Kawa finds it easier to optimize a tail recursive loop 44when the `%cars+cdrs' logic is called this way." 45 (let-values (((cars cdrs) (%cars+cdrs lists))) 46 (cons cars cdrs))) 47 48(define (%cdrs lists) 49 "Return (map cdr lists). However, if any element of LISTS is empty, 50just abort and return '()." 51 (call-with-current-continuation 52 (lambda (abort) 53 (let recur ((lists lists)) 54 (if (pair? lists) 55 (let ((lis (car lists))) 56 (if (null? lis) (abort '()) 57 (cons (cdr lis) (recur (cdr lists))))) 58 '()))))) 59 60(define (%cars+ (lists ::list) last-elt) ::list 61 ; (append! (map car lists) (list last-elt)) 62 (let recur ((lists lists)) 63 (if (pair? lists) (cons (caar lists) (recur (cdr lists))) 64 (list last-elt)))) 65 66;;; Exported Functions 67 68;;; find 69(define (find (proc ::procedure) (lst ::list)) 70 "PROC should accept one argument and return a single value. PROC 71should not mutate LST. The `find' procedure applies PROC to the 72elements of LST in order. If PROC returns a true value for an 73element, `find' immediately returns that element. If PROC returns #f 74for all elements of the list, `find' returns #f. PROC is always called 75in the same dynamic environment as `find' itself." 76 (let loop ((list lst)) 77 (if (null? list) #f 78 (let ((x (car list))) 79 (if (proc x) x 80 (loop (cdr list))))))) 81 82;;; for-all, exists (based upon SRFI-1 every, any) 83(define (for-all (proc ::procedure) (list1 ::list) . lists) 84 "The LISTs should all have the same length, and PROC should accept N 85arguments and return a single value. PROC should not mutate the LIST 86arguments. 87 88For natural numbers I=0,1,..., the `for-all' procedure successively 89applies PROC to arguments X_I^1 ... X_I^N, where X_I^J is the Ith 90element of LIST_J, until #f is returned. If PROC returns true values 91for all but the last element of LIST_1, `for-all' performs a tail call 92of PROC on the Kth elements, where K is the length of LIST_1. If PROC 93returns #f on any set of elements, `for-all' returns #f after the 94first such application of PROC. If the LISTs are all empty, `for-all' 95returns #t. 96 97PROC is always called in the same dynamic environment as `for-all' 98itself." 99 (if (pair? lists) 100 ;; N-ary case 101 (let-values (((heads tails) (%cars+cdrs (cons list1 lists)))) 102 (or (not (pair? heads)) 103 (let lp ((heads heads) (tails tails)) 104 (let-values (((next-heads next-tails) (%cars+cdrs tails))) 105 (if (pair? next-heads) 106 (and (apply proc heads) (lp next-heads next-tails)) 107 (apply proc heads)))))) ; Last PROC app is tail call. 108 ;; Fast path 109 (or (null? list1) 110 (let lp ((head (car list1)) (tail (cdr list1))) 111 (if (null? tail) 112 (proc head) ; Last PROC app is tail call. 113 (and (proc head) (lp (car tail) (cdr tail)))))))) 114 115(define (exists (proc ::procedure) (list1 ::list) . lists) 116 "The LISTs should all have the same length, and PROC should accept N 117arguments and return a single value. PROC should not mutate the LIST 118arguments. 119 120For natural numbers I=0,1,..., the `exists' procedure applies PROC 121successively to arguments X_I^1 ... X_I^N, where X_I^N is the Ith 122element of LIST_J, until a true value is returned. If PROC returns #f 123for all but the last elements of the LISTs, `exists' performs a tail 124call of PROC on the Kth elements, where K is the length of LIST_1. If 125PROC returns a true value on any set of elements, `exists' returns 126that value after the first such application of PROC. If the LISTs are 127all empty, `exists' returns #f. 128 129PROC is always called in the same dynamic environment as `exists' 130itself." 131 (if (pair? lists) 132 ;; N-ary case 133 (let-values (((heads tails) (%cars+cdrs (cons list1 lists)))) 134 (and (pair? heads) 135 (let lp ((heads heads) (tails tails)) 136 (let* ((split (%cars+cdrs/pair tails)) 137 (next-heads (car split)) 138 (next-tails (cdr split))) 139 (if (pair? next-heads) 140 (or (apply proc heads) (lp next-heads next-tails)) 141 (apply proc heads)))))) ; Last PROC app is tail call. 142 ;; Fast path 143 (and (not (null? list1)) 144 (let lp ((head (car list1)) (tail (cdr list1))) 145 (if (null? tail) 146 (proc head) ; Last PROC app is tail call. 147 (or (proc head) (lp (car tail) (cdr tail)))))))) 148 149;;; filter, partition 150(define (filter (proc ::procedure) (lst ::list)) 151 "PROC should accept one argument and return a single value. PROC 152should not mutate LST. 153 154The `filter' procedure applies PROC to each element of LST and 155returns a list of the elements of LST for which PROC returned a true 156value. The elements of the result list are in the same order as they 157appear in the input list. PROC is always called in the same dynamic 158environment as `filter' itself. If multiple returns occur from 159`filter', the return values returned by earlier returns are not 160mutated." 161 (let recur ((list lst) (res '())) 162 (if (null? list) 163 (reverse! res) 164 (let ((head (car list)) 165 (tail (cdr list))) 166 (if (proc head) 167 (recur tail (cons head res)) 168 (recur tail res)))))) 169 170(define (partition (proc ::procedure) (lst ::list)) 171 "PROC should accept one argument and return a single value. PROC 172should not mutate LST. 173 174The `partition' procedure applies PROC to each element of LST, and 175returns two values, the first one a list of the elements of LST for 176which PROC returned a true value, and the second a list of the 177elements of LST for which PROC returned #f. The elements of the 178result lists are in the same order as they appear in the input 179list. PROC is always called in the same dynamic environment as 180`partition' itself. If multiple returns occur from `partition', the 181return values returned by earlier returns are not mutated." 182 (let loop ((list lst) (in '()) (out '())) 183 (if (null? list) 184 (values (reverse! in) (reverse! out)) 185 (let ((head (car list)) 186 (tail (cdr list))) 187 (if (proc head) 188 (loop tail (cons head in) out) 189 (loop tail in (cons head out))))))) 190 191;;; fold-left 192(define (fold-left (combine ::procedure) nil (list1 ::list) . lists) 193 "The LISTs should all have the same length. COMBINE must be a 194procedure. It should accept one more argument than there are LISTs and 195return a single value. It should not mutate the LIST arguments. The 196`fold-left' procedure iterates the COMBINE procedure over an 197accumulator value and the elements of the LISTs from left to right, 198starting with an accumulator value of NIL. More specifically, 199`fold-left' returns NIL if the LISTs are empty. If they are not empty, 200COMBINE is first applied to NIL and the respective first elements of 201the LISTs in order. The result becomes the new accumulator value, and 202COMBINE is applied to the new accumulator value and the respective 203next elements of the LISTs. This step is repeated until the end of the 204list is reached; then the accumulator value is returned. COMBINE is 205always called in the same dynamic environment as `fold-left' itself." 206 (if (pair? lists) 207 ;; N-ary case 208 (let lp ((lists (cons list1 lists)) (ans nil)) 209 (let-values (((cars cdrs) (%cars+cdrs lists))) 210 (if (null? cars) ans ; Done. 211 (lp cdrs (apply combine ans cars))))) 212 ;; Fast path 213 (let lp ((list list1) (ans nil)) 214 (if (null? list) ans 215 (lp (cdr list) (combine ans (car list))))))) 216 217;;; fold-right 218(define (fold-right (combine ::procedure) nil (list1 ::list) . lists) 219 "The LISTs should all have the same length. COMBINE must be a 220procedure. It should accept one more argument than there are LISTs and 221return a single value. COMBINE should not mutate the LIST 222arguments. The `fold-right' procedure iterates the COMBINE procedure 223over the elements of the LISTs from right to left and an accumulator 224value, starting with an accumulator value of NIL. More specifically, 225`fold-right' returns NIL if the LISTs are empty. If they are not 226empty, COMBINE is first applied to the respective last elements of the 227LISTs in order and NIL. The result becomes the new accumulator value, 228and COMBINE is applied to the respective previous elements of the 229LISTs and the new accumulator value. This step is repeated until the 230beginning of the list is reached; then the accumulator value is 231returned. PROC is always called in the same dynamic environment as 232`fold-right' itself." 233 (if (pair? lists) 234 ;; N-ary case 235 (let recur ((lists (cons list1 lists))) 236 (let ((cdrs (%cdrs lists))) 237 (if (null? cdrs) nil 238 (apply combine (%cars+ lists (recur cdrs)))))) 239 ;; Fast path 240 (let recur ((list list1)) 241 (if (null? list) nil 242 (let ((head (car list))) 243 (combine head (recur (cdr list)))))))) 244 245;;; remp, remove, remv, remq 246(define (remp (proc ::procedure) (lst ::list)) ::list 247 "PROC should accept one argument and return a single value. PROC 248should not mutate LIST. 249 250The `remp' procedure applies PROC to each element of LIST and returns 251a list of the elements of LIST for which PROC returned #f. PROC is 252always called in the same dynamic environment as `remp' itself. The 253elements of the result list are in the same order as they appear in 254the input list. If multiple returns occur from `remp', the return 255values returned by earlier returns are not mutated." 256 (filter (complement proc) lst)) 257 258(define (remove obj (lst ::list)) ::list 259 "The `remove' procedure returns a list of the elements that are not 260OBJ. `remove' uses `equal?' to compare OBJ with the elements of 261LST. The elements of the result list are in the same order as they 262appear in the input list." 263 (filter (lambda (o) (not (equal? o obj))) lst)) 264 265(define (remv obj (lst ::list)) ::list 266 "The `remv' procedure returns a list of the elements that are not 267OBJ. `remv' uses `eqv?' to compare OBJ with the elements of LST. The 268elements of the result list are in the same order as they appear in 269the input list." 270 (filter (lambda (o) (not (eqv? o obj))) lst)) 271 272(define (remq obj (lst ::list)) ::list 273 "The `remq' procedure returns a list of the elements that are not 274OBJ. `remq' uses `eq?' to compare OBJ with the elements of LIST. The 275elements of the result list are in the same order as they appear in 276the input list." 277 (filter (lambda (o) (not (eq? o obj))) lst)) 278 279;;; memp, member, memv, memq 280(define (memp (proc ::procedure) (lst ::list)) 281 "PROC should accept one argument and return a single value. PROC 282should not mutate LST. 283 284`memp' returns the first sublist of LST whose car satisfies a given 285condition, where the sublists of LST are the lists returned by 286(`list-tail' LST K) for K less than the length of LST. The `memp' 287procedure applies PROC to the cars of the sublists of LST until it 288finds one for which PROC returns a true value. PROC is always called 289in the same dynamic environment as `memp' itself. If LST does not 290contain an element satisfying the condition, then #f (not the empty 291list) is returned." 292 (let recur ((list lst)) 293 (cond ((null? list) #f) 294 ((proc (car list)) list) 295 (else (recur (cdr list)))))) 296 297;; member, memv, and memq are defined in kawa.lib.lists 298;; (define (member obj (lst ::list))) 299;; (define (memv obj (lst ::list))) 300;; (define (memq obj (lst ::list))) 301 302;;; assp, assoc, assv, assq 303(define (assp (proc ::procedure) (alist ::list)) 304 "ALIST (for \"association list\") should be a list of pairs. PROC 305should accept one argument and return a single value. PROC should not 306mutate ALIST. 307 308The `assp' procedure finds the first pair in ALIST whose car field 309satisfies a given condition, and returns that pair without traversing 310ALIST further. If no pair in ALIST satisfies the condition, then #f is 311returned. The `assp' procedure successively applies PROC to the car 312fields of ALIST and looks for a pair for which it returns a true 313value. PROC is always called in the same dynamic environment as `assp' 314itself." 315 (let recur ((alist alist)) 316 (cond ((null? alist) #f) 317 ((proc (caar alist)) (car alist)) 318 (else (recur (cdr alist)))))) 319 320;; assoc, assv, and assq are defined in kawa.lib.lists 321;; (define (assoc obj (alist ::list))) 322;; (define (assv obj (alist ::list))) 323;; (define (assq obj (alist ::list))) 324 325;;; cons* 326(define (cons* #!rest (args :: object[])) 327 "If called with at least two arguments, `cons*' returns a freshly 328allocated chain of pairs whose cars are OBJ1,...,OBJN, and whose last 329cdr is OBJ. If called with only one argument, `cons*' returns that 330argument." 331 (gnu.lists.LList:consX args)) 332