1;;;
2;;; SRFI-116 Immutable List Library
3;;;
4
5;; Gauche supports immutable pairs natively.  They work transparently
6;; as mutable pairs, except set-car! and set-cdr!.
7;; Procedures that don't cons are just alias of builtin procedures.
8;; Whenever a procedure need to cons, we make an ipair instead of an mpair.
9
10;; Note that we won't reject mpair passed to these procedures.
11
12(define-module srfi-116
13  (use srfi-1)
14  (use srfi-114 :only (make-car-comparator
15                       make-cdr-comparator
16                       make-improper-list-comparator))
17  (use util.match)
18  (export ipair                         ;builtin
19          ilist                         ;builtin
20          xipair ipair* make-ilist ilist-tabulate
21          ilist-copy iiota
22
23          iq
24
25          ipair?                        ;builtin
26          ;; NB: Other predicates don't distinguish mutable and immutable
27          ;; pairs.
28          (rename proper-list? proper-ilist?)
29          (rename list? ilist?)
30          (rename dotted-list? dotted-ilist?)
31          (rename not-pair? not-ipair?)
32          (rename null-list? null-ilist?)
33          (rename list= ilist=)
34
35          (rename car icar) (rename cdr icdr)
36          (rename caar icaar) (rename cadr icadr)
37          (rename cdar icdar) (rename cddr icddr)
38          (rename caaar icaaar) (rename caadr icaadr)
39          (rename cadar icadar) (rename caddr icaddr)
40          (rename cdaar icdaar) (rename cdadr icdadr)
41          (rename cddar icddar) (rename cdddr icdddr)
42          (rename caaaar icaaaar) (rename caaadr icaaadr)
43          (rename caadar icaadar) (rename caaddr icaaddr)
44          (rename cadaar icadaar) (rename cadadr icadadr)
45          (rename caddar icaddar) (rename cadddr icadddr)
46          (rename cdaaar icdaaar) (rename cdaadr icdaadr)
47          (rename cdadar icdadar) (rename cdaddr icdaddr)
48          (rename cddaar icddaar) (rename cddadr icddadr)
49          (rename cdddar icdddar) (rename cddddr icddddr)
50          (rename car+cdr icar+icdr)
51          (rename list-ref ilist-ref)
52
53          (rename first ifirst) (rename second isecond)
54          (rename third ithird)
55          (rename fourth ifourth)
56          (rename fifth ififth)
57          (rename sixth isixth)
58          (rename seventh iseventh)
59          (rename eighth ieighth)
60          (rename ninth ininth)
61          (rename tenth itenth)
62          itake
63          (rename drop idrop)
64          (rename list-tail ilist-tail)
65          (rename take-right itake-right)
66          idrop-right
67          isplit-at
68          (rename last ilast)
69          (rename last-pair last-ipair)
70
71          (rename length ilength)
72          iappend
73          iconcatenate
74          ireverse
75          iappend-reverse
76          izip
77          iunzip1
78          iunzip2
79          iunzip3
80          iunzip4
81          iunzip5
82          (rename count icount)
83
84          imap
85          (rename for-each ifor-each)
86          (rename fold ifold)
87          iunfold
88          (rename pair-fold ipair-fold)
89          (rename reduce ireduce)
90          (rename fold-right ifold-right)
91          iunfold-right
92          (rename pair-fold-right ipair-fold-right)
93          (rename reduce-right ireduce-right)
94          iappend-map
95          (rename pair-for-each ipair-for-each)
96          ifilter-map
97          imap-in-order
98
99          ifilter
100          ipartition
101          iremove
102
103          (rename member imember)
104          (rename memq imemq)
105          (rename memv imemv)
106          ifind
107          (rename find-tail ifind-tail)
108          (rename any iany)
109          (rename every ievery)
110          (rename list-index ilist-index)
111          itake-while
112          (rename drop-while idrop-while)
113          ispan
114          ibreak
115
116          idelete
117          idelete-duplicates
118
119          (rename assoc iassoc)
120          (rename assq iassq)
121          (rename assv iassv)
122          ialist-cons
123          ialist-delete
124
125          replace-icar
126          replace-icdr
127
128          pair->ipair
129          ipair->pair
130          list->ilist
131          ilist->list
132          tree->itree
133          itree->tree
134          gtree->itree
135          gtree->tree
136
137          (rename apply iapply)
138
139          ipair-comparator
140          ilist-comparator
141          (rename make-list-comparator make-ilist-comparator)
142          (rename make-improper-list-comparator make-improper-ilist-comparator)
143          (rename make-car-comparator make-icar-comparator)
144          (rename make-cdr-comparator make-icdr-comparator)
145          ))
146(select-module srfi-116)
147
148(define-syntax iq
149  (syntax-rules ()
150    [(iq x ...)
151     (gtree->itree '(x ...))]))
152
153(define (xipair cd ca) (ipair ca cd))
154(define (ipair* x . xs)
155  (if (null? xs)
156    x
157    (ipair x (apply ipair* xs))))
158(define (make-ilist n :optional (fill (undefined)))
159  (let loop ([r '()] [n n])
160    (if (<= n 0)
161      r
162      (loop (ipair fill r) (- n 1)))))
163(define (ilist-tabulate n init-proc)
164  (let loop ([r '()] [n (- n 1)])
165    (if (< n 0)
166      r
167      (loop (ipair (init-proc n) r) (- n 1)))))
168(define (ilist-copy lis)
169  (fold ipair '() (reverse lis)))
170
171;; Almost identical code of iota in src/liblist.scm, but using ipair instead
172;; of cons.
173(define (iiota count :optional (start 0) (step 1))
174  (unless (and (integer? count) (>= count 0))
175    (error "count must be nonnegative integer: " count))
176  (if (and (exact? start) (exact? step))
177    ;; we allow inexact integer as 'count', for the consistency of
178    ;; giota and liota in which we can also accept +inf.0 as count.
179    (let1 count (exact count)
180      (do ([c count (- c 1)]
181           [v (+ start (* (- count 1) step)) (- v step)]
182           [r '() (ipair v r)])
183          [(<= c 0) r]))
184    ;; for inexact numbers, we use multiplication to avoid error accumulation.
185    (do ([c count (- c 1)]
186         [r '() (ipair (+ start (*. (- c 1) step)) r)])
187        [(<= c 0) r])))
188
189(define (itake lis i)
190  (assume exact-integer? i)
191  (if (<= i 0)
192    '()
193    (ipair (car lis) (itake (cdr lis) (- i 1)))))
194(define (idrop-right lis i)
195  (assume exact-integer? i)
196  (let rec ([p0 (list-tail lis i)] [p1 lis])
197    (if (pair? p0) (ipair (car p1) (rec (cdr p0) (cdr p1))) '())))
198(define (isplit-at lis i)
199  (assume exact-integer? i)
200  (let rec ([lis lis] [i i])
201    (if (<= i 0)
202      (values '() lis)
203      (receive (hd tl) (rec (cdr lis) (- i 1))
204        (values (ipair (car lis) hd) tl)))))
205
206(define (iappend . liss) (iconcatenate liss))
207
208(define (iconcatenate liss)
209  (match liss
210    ([] '())
211    ([lis] lis)
212    ([lis1 . liss]
213     (let1 tail (iconcatenate liss)
214       (let rec ([lis1 lis1])
215         (if (null? lis1)
216           tail
217           (ipair (car lis1) (rec (cdr lis1)))))))))
218
219(define (ireverse lis) (fold ipair '() lis))
220
221(define (iappend-reverse rev-head tail) (fold ipair tail rev-head))
222
223(define (izip lis1 . liss) (apply imap ilist lis1 liss))
224
225;; These are dupe of srfi-1.scm except map/cons replaced with imap/ipair
226(define (iunzip1 lis) (imap car lis))
227
228(define (iunzip2 lis)
229  (let recur ((lis lis))
230    (if (null-list? lis) (values lis lis)       ; Use NOT-PAIR? to handle
231        (let ((elt (car lis)))                  ; dotted lists.
232          (receive (a b) (recur (cdr lis))
233            (values (ipair (car  elt) a)
234                    (ipair (cadr elt) b)))))))
235
236(define (iunzip3 lis)
237  (let recur ((lis lis))
238    (if (null-list? lis) (values lis lis lis)
239        (let ((elt (car lis)))
240          (receive (a b c) (recur (cdr lis))
241            (values (ipair (car   elt) a)
242                    (ipair (cadr  elt) b)
243                    (ipair (caddr elt) c)))))))
244
245(define (iunzip4 lis)
246  (let recur ((lis lis))
247    (if (null-list? lis) (values lis lis lis lis)
248        (let ((elt (car lis)))
249          (receive (a b c d) (recur (cdr lis))
250            (values (ipair (car    elt) a)
251                    (ipair (cadr   elt) b)
252                    (ipair (caddr  elt) c)
253                    (ipair (cadddr elt) d)))))))
254
255(define (iunzip5 lis)
256  (let recur ((lis lis))
257    (if (null-list? lis) (values lis lis lis lis lis)
258        (let ((elt (car lis)))
259          (receive (a b c d e) (recur (cdr lis))
260            (values (ipair (car     elt) a)
261                    (ipair (cadr    elt) b)
262                    (ipair (caddr   elt) c)
263                    (ipair (cadddr  elt) d)
264                    (ipair (car (cddddr  elt)) e)))))))
265
266
267(define imap
268  (case-lambda
269    ([proc lis] (fold-right (^[x ys] (ipair (proc x) ys)) '() lis))
270    ([proc lis . liss]
271     (ireverse (apply fold-left (^[ys . xs] (cons (apply proc xs) ys)) '()
272                      lis liss)))))
273
274(define (iunfold p f g seed :optional (tail-gen (^_ '())))
275  (let rec ((seed seed))
276    (if (p seed)
277      (tail-gen seed)
278      (ipair (f seed) (rec (g seed))))))
279
280(define (iunfold-right p f g seed :optional (ans '()))
281  (let loop ((seed seed) (ans ans))
282    (if (p seed)
283      ans
284      (loop (g seed)
285            (ipair (f seed) ans)))))
286
287(define (iappend-map proc lis . lists)
288  (iconcatenate (apply map proc lis lists)))
289
290(define (ifilter-map proc lis . lists)
291  (if (null? lists)
292    (let loop ([lis lis] [r '()])
293      (cond [(null-list? lis) (ireverse r)]
294            [(proc (car lis)) => (^x (loop (cdr lis) (cons x r)))]
295            [else (loop (cdr lis) r)]))
296    (let loop ([liss (cons lis lists)] [r '()])
297      (receive (cars cdrs)
298          ((with-module gauche.internal %zip-nary-args) liss)
299        (cond [(not cars) (ireverse r)]
300              [(apply proc cars) => (^x (loop cdrs (cons x r)))]
301              [else (loop cdrs r)])))))
302
303(define imap-in-order
304  (case-lambda
305    ([proc lis] (ireverse (fold (^[x ys] (cons (proc x) ys)) '() lis)))
306    ([proc lis . liss]
307     (ireverse (apply fold-left (^[ys . xs] (cons (apply proc xs) ys)) '()
308                      lis liss)))))
309
310(define (ifilter pred lis)
311  (let loop ([lis lis] [r '()])
312    (cond [(null-list? lis) (ireverse r)]
313          [(pred (car lis)) (loop (cdr lis) (cons (car lis) r))]
314          [else (loop (cdr lis) r)])))
315
316(define (iremove  pred l) (ifilter  (^x (not (pred x))) l))
317
318;;built-in find tolerate improper lists.  we're bit more strict here.
319(define (ifind pred lis)
320  (cond [(null? lis) #f]
321        [(not (pair? lis)) (error "pair expected, but got:" lis)]
322        [(pred (car lis)) (car lis)]
323        [else (ifind pred (cdr lis))]))
324
325(define (ipartition pred lis)
326  (let rec ([lis lis] [xs '()] [ys '()])
327    (if (null-list? lis)
328      (values (ireverse xs) (ireverse ys))
329      (if (pred (car lis))
330        (rec (cdr lis) (cons (car lis) xs) ys)
331        (rec (cdr lis) xs (cons (car lis) ys))))))
332
333(define (itake-while pred lis)
334  (cond [(null? lis) '()]
335        [(pred (car lis)) (ipair (car lis) (itake-while pred (cdr lis)))]
336        [else '()]))
337
338(define (ispan pred lis)
339  (cond [(null? lis) '()]
340        [(pred (car lis))
341         (receive (pre post) (ispan pred (cdr lis))
342           (values (ipair (car lis) pre) post))]
343        [else (values '() lis)]))
344
345(define (ibreak pred lis) (ispan (complement pred) lis))
346
347(define (idelete x lis :optional (eq equal?))
348  (if (null? lis)
349    '()
350    (let1 tail (idelete x (cdr lis) eq)
351      (cond [(eq x (car lis)) tail]
352            [(eq? (cdr lis) tail) lis]
353            [else (ipair (car lis) tail)]))))
354
355(define (idelete-duplicates lis :optional (eq equal?))
356  (cond [(null? lis) lis]
357        [(null? (cdr lis)) lis]
358        [else (let1 tail (idelete (car lis)
359                                  (idelete-duplicates (cdr lis) eq)
360                                  eq)
361                (if (eq? tail (cdr lis))
362                  lis
363                  (ipair (car lis) tail)))]))
364
365(define (ialist-cons k d alis)
366  (ipair (ipair k d) alis))
367
368(define (ialist-delete k alis :optional (eq equal?))
369  (cond [(null? alis) '()]
370        [(eq k (caar alis)) (ialist-delete k (cdr alis) eq)]
371        [else (let1 tail (ialist-delete k (cdr alis) eq)
372                (if (eq? tail (cdr alis))
373                  alis
374                  (ipair (car alis) tail)))]))
375
376(define (replace-icar p obj) (ipair obj (cdr p)))
377(define (replace-icdr p obj) (ipair (car p) obj))
378
379(define (pair->ipair p) (ipair (car p) (cdr p)))
380(define (ipair->pair p) (cons (car p) (cdr p)))
381
382(define (list->ilist p)
383  (cond [(null? p) '()]
384        [(ipair? p) (let1 tail (list->ilist (cdr p))
385                      (if (eq? (cdr p) tail)
386                        p
387                        (ipair (car p) tail)))]
388        [(pair? p) (ipair (car p) (list->ilist (cdr p)))]
389        [else p]))
390(define (ilist->list p)
391  (cond [(null? p) '()]
392        [(pair? p) (let1 tail (ilist->list (cdr p))
393                      (if (eq? (cdr p) tail)
394                        p
395                        (cons (car p) tail)))]
396        [(ipair? p) (cons (car p) (ilist->list (cdr p)))]
397        [else p]))
398
399(define (tree->itree p)
400  (cond [(ipair? p)
401         (let ([ca (tree->itree (car p))]
402               [cd (tree->itree (cdr p))])
403           (if (and (eq? ca (car p)) (eq? cd (cdr p)))
404             p
405             (ipair ca cd)))]
406        [(pair? p)
407         (ipair (tree->itree (car p)) (tree->itree (cdr p)))]
408        [else p]))
409(define (itree->tree p)
410  (cond [(pair? p)
411         (let ([ca (itree->tree (car p))]
412               [cd (itree->tree (cdr p))])
413           (if (and (eq? ca (car p)) (eq? cd (cdr p)))
414             p
415             (cons ca cd)))]
416        [(ipair? p)
417         (cons (itree->tree (car p)) (itree->tree (cdr p)))]
418        [else p]))
419
420;; Our itree->tree and tree->itree accepts mixed trees, so these are the same.
421(define (gtree->itree obj) (tree->itree obj))
422(define (gtree->tree obj)  (itree->tree obj))
423
424
425(define ipair-comparator
426  (make-comparator/compare ipair? #t compare default-hash 'ipair-comparator))
427(define ilist-comparator
428  (make-comparator/compare list? #t compare default-hash 'ilist-comparator))
429