~ chicken-core (chicken-5) /mini-srfi-1.scm

  1;;;; minimal implementation of SRFI-1 primitives
  2;
  3;
  4; Copyright (c) 2015-2022, The CHICKEN Team
  5; All rights reserved.
  6;
  7; Redistribution and use in source and binary forms, with or without modification, are permitted provided that the following
  8; conditions are met:
  9;
 10;   Redistributions of source code must retain the above copyright notice, this list of conditions and the following
 11;     disclaimer.
 12;   Redistributions in binary form must reproduce the above copyright notice, this list of conditions and the following
 13;     disclaimer in the documentation and/or other materials provided with the distribution.
 14;   Neither the name of the author nor the names of its contributors may be used to endorse or promote
 15;     products derived from this software without specific prior written permission.
 16;
 17; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND ANY EXPRESS
 18; OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY
 19; AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDERS OR
 20; CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
 21; CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR
 22; SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
 23; THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR
 24; OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
 25; POSSIBILITY OF SUCH DAMAGE.
 26
 27
 28(declare 
 29  (unused take span drop partition split-at append-map every any cons* concatenate
 30	  first second third fourth alist-cons fifth remove
 31	  filter filter-map unzip1 last list-index lset-adjoin/eq? lset-difference/eq?
 32	  lset-union/eq? lset-intersection/eq? list-tabulate lset<=/eq? lset=/eq? length+
 33	  find find-tail iota make-list posq posv)
 34  (hide take span drop partition split-at append-map every any cons* concatenate delete
 35	first second third fourth alist-cons delete-duplicates fifth remove
 36	filter filter-map unzip1 last list-index lset-adjoin/eq? lset-difference/eq?
 37	lset-union/eq? lset-intersection/eq? list-tabulate lset<=/eq? lset=/eq? length+
 38	find find-tail iota make-list posq posv))
 39
 40
 41(define (partition pred lst)
 42  (let loop ((yes '()) (no '()) (lst lst))
 43    (cond ((null? lst) (values (reverse yes) (reverse no)))
 44	  ((pred (car lst)) (loop (cons (car lst) yes) no (cdr lst)))
 45	  (else (loop yes (cons (car lst) no) (cdr lst))))))
 46
 47(define (span pred lst)
 48  (let loop ((lst lst) (head '()))
 49    (cond ((null? lst) (values (reverse head) lst))
 50	  ((pred (car lst)) (loop (cdr lst) (cons (car lst) head)))
 51	  (else (values (reverse head) lst)))))
 52
 53(define (take lst n)
 54  (if (fx<= n 0)
 55      '()
 56      (cons (car lst) (take (cdr lst) (fx- n 1)))))
 57
 58(define (drop lst n)
 59  (let loop ((lst lst) (n n))
 60    (if (fx<= n 0)
 61	lst
 62	(loop (cdr lst) (fx- n 1)))))
 63
 64(define (split-at lst n)
 65  (let loop ((n n) (prev '()) (node lst))
 66    (if (fx<= n 0)
 67	(values (reverse prev) node)
 68	(loop (fx- n 1) (cons (car node) prev) (cdr node)))))
 69
 70(define (append-map proc lst1 . lsts)
 71  (if (null? lsts)
 72      (foldr (lambda (x r) (append (proc x) r)) '() lst1)
 73      (let loop ((lsts (cons lst1 lsts)))
 74	(if (any null? lsts)
 75	    '()
 76	    (append (apply proc (map (lambda (x) (car x)) lsts))
 77		    (loop (map (lambda (x) (cdr x)) lsts)))))))
 78
 79(define (every pred lst)
 80  (let loop ((lst lst))
 81    (cond ((null? lst))
 82	  ((not (pred (car lst))) #f)
 83	  (else (loop (cdr lst))))))
 84
 85(define (any pred lst)
 86  (let loop ((lst lst))
 87    (cond ((null? lst) #f)
 88	  ((pred (car lst)))
 89	  (else (loop (cdr lst))))))
 90
 91(define (cons* x1 . xs)
 92  (let loop ((x x1) (rest xs))
 93    (if (null? rest)
 94	x
 95	(cons x (loop (car rest) (cdr rest))))))
 96
 97(define (concatenate lst)
 98  (let loop ((lst lst))
 99    (if (null? lst) 
100	'()
101	(append (car lst) (loop (cdr lst))))))
102
103(define (delete x lst test)
104  (let loop ((lst lst))
105    (cond ((null? lst) lst)
106	  ((test x (car lst))
107	   (loop (cdr lst)))
108	  (else
109	   (cons (car lst) (loop (cdr lst)))))))
110
111(define (first x) (car x))
112(define (second x) (cadr x))
113(define (third x) (caddr x))
114(define (fourth x) (cadddr x))
115(define (fifth x) (car (cddddr x)))
116
117(define (delete-duplicates lst test)
118  (let loop ((lst lst))
119    (if (null? lst)
120	lst
121	(let* ((x (car lst))
122	       (tail (cdr lst))
123	       (new-tail (loop (delete x tail test))))
124	  (if (equal? tail new-tail) 
125	      lst
126	      (cons x new-tail))))))
127
128(define (alist-cons x y z) (cons (cons x y) z))
129
130(define (filter pred lst)
131  (foldr (lambda (x r) (if (pred x) (cons x r) r)) '() lst))
132
133(define (filter-map pred lst)
134  (foldr (lambda (x r) 
135	   (cond ((pred x) => (lambda (y) (cons y r)))
136		 (else r)))
137	 '()
138	 lst))
139
140(define (remove pred lst)
141  (filter (lambda (x) (not (pred x))) lst))
142
143(define (unzip1 lst) (map (lambda (x) (car x)) lst))
144
145(define (last lst)
146  (let loop ((lst lst))
147    (if (null? (cdr lst))
148	(car lst)
149	(loop (cdr lst)))))
150
151(define (list-index pred lst)
152  (let loop ((i 0) (lst lst))
153    (cond ((null? lst) #f)
154	  ((pred (car lst)) i)
155	  (else (loop (fx+ i 1) (cdr lst))))))
156
157(define (lset-adjoin/eq? lst . vals)
158  (let loop ((vals vals) (lst lst))
159    (cond ((null? vals) lst)
160	  ((memq (car vals) lst) (loop (cdr vals) lst))
161	  (else (loop (cdr vals) (cons (car vals) lst))))))
162
163(define (lset-difference/eq? ls . lss)
164  (foldl
165   (lambda (ls lst)
166     (filter (lambda (x) (not (memq x lst))) ls))
167   ls
168   lss))
169
170(define (lset-union/eq? ls . lss)
171  (foldl
172   (lambda (ls lst)
173     (foldl
174      (lambda (ls x)
175	(if (any (lambda (y) (eq? y x)) ls)
176	    ls
177	    (cons x ls)))
178      ls lst))
179   ls lss))
180
181(define (lset-intersection/eq? ls1 . lss)
182  (filter (lambda (x)
183	    (every (lambda (lis) (memq x lis)) lss))
184	  ls1))
185  
186(define (list-tabulate n proc)
187  (let loop ((i 0))
188    (if (fx>= i n)
189	'()
190	(cons (proc i) (loop (fx+ i 1))))))
191
192(define (lset<=/eq? s1 s2)
193  (every (lambda (s) (memq s s2)) s1))
194
195(define (lset=/eq? s1 s2)
196  (and (eq? (length s1) (length s2))
197       (every (lambda (s) (memq s s2)) s1)))
198
199;; from SRFI-1 ref. impl.
200(define (length+ x)			; Returns #f if X is circular.
201  (let lp ((x x) (lag x) (len 0))
202    (if (pair? x)
203	(let ((x (cdr x))
204	      (len (fx+ len 1)))
205	  (if (pair? x)
206	      (let ((x   (cdr x))
207		    (lag (cdr lag))
208		    (len (fx+ len 1)))
209		(and (not (eq? x lag)) (lp x lag len)))
210	      len))
211	len)))
212
213(define (find pred lst)
214  (let loop ((lst lst))
215    (cond ((null? lst) #f)
216	  ((pred (car lst)) (car lst))
217	  (else (loop (cdr lst))))))
218
219(define (find-tail pred ls)
220  (let lp ((ls ls))
221    (cond ((null? ls) #f)
222	  ((pred (car ls)) ls)
223	  (else (lp (cdr ls))))))
224
225(define (iota n) (list-tabulate n (lambda (i) i)))
226
227(define (make-list n #!optional x)
228  (list-tabulate n (lambda _ x)))
229
230(define (posq x lst)
231  (let loop ((i 0) (lst lst))
232    (cond ((null? lst) #f)
233	  ((eq? (car lst) x) i)
234	  (else (loop (fx+ i 1) (cdr lst))))))
235
236(define (posv x lst)
237  (let loop ((i 0) (lst lst))
238    (cond ((null? lst) #f)
239	  ((eqv? (car lst) x) i)
240	  (else (loop (fx+ i 1) (cdr lst))))))
241