source: project/release/5/list-utils/tags/2.3.3/list-utils.scm @ 39569

Last change on this file since 39569 was 39569, checked in by Kon Lovett, 4 months ago

rel 2.3.3

File size: 15.7 KB
Line 
1;;;; list-utils.scm  -*- scheme -*-
2;;;; Kon Lovett, Mar '20
3;;;; Kon Lovett, Jul '18
4;;;; Kon Lovett, Feb '18
5;;;; Kon Lovett, Sep '17
6;;;; Kon Lovett, Jul '07
7
8(module list-utils
9
10(;export
11  list-unique/duplicates
12  list-unique
13  skip+
14  split-at+
15  section
16  length=0? length=1? length=2? length>1?
17  ensure-flat-list list-flatten
18  ensure-list
19  not-null?
20  alist?
21  alist-delete-first alist-delete-first!
22  alist-delete-duplicates alist-delete-duplicates!
23  assoc-def assq-def assv-def
24  alist-inverse-ref
25  plist->alist alist->plist
26  unzip-alist zip-alist
27  shift! unshift! shift!/set
28  andmap ormap
29  pair-ref
30  list-set!
31  list-copy*)
32
33(import scheme
34  (chicken base)
35  (only (chicken fixnum) most-positive-fixnum)
36  (chicken type)
37  (only (srfi 1)
38    first
39    make-list cons*
40    proper-list?
41    reverse! append-reverse! append!
42    take drop
43    every
44    split-at
45    concatenate)
46  (only type-checks
47    check-list check-alist check-pair
48    check-procedure
49    check-fixnum check-positive-fixnum)
50  (only type-errors error-alist define-error-type))
51
52;;;
53
54(define-type binary-test (* * -> boolean))
55
56(define-type alist (or null (list-of pair)))
57
58#; ;too strong
59(: list-unique/duplicates (forall (e (s (list-of e))) (s #!optional (e e -> *) -> s s)))
60;(: list-unique (forall (e (s (list-of e))) (s #!optional (e e -> *) -> s)))
61(: list-unique/duplicates (list #!optional (* * -> *) -> list list))
62(: list-unique (list #!optional (* * -> *) -> list))
63(: sort-alist (alist #!optional procedure -> alist))
64(: sort-alist! (alist #!optional procedure -> void))
65(: skip+ (list fixnum --> list fixnum))
66(: split-at+ (list fixnum #!optional (or boolean list) --> list list))
67(: section (list fixnum #!optional fixnum (or boolean list) --> list))
68(: plist->alist (list --> alist))
69(: alist->plist (alist --> list))
70(: alist? (* -> boolean : alist))
71(: alist-inverse-ref (* alist #!optional binary-test * --> *))
72(: alist-delete-duplicates (* alist #!optional binary-test fixnum --> alist))
73(: alist-delete-duplicates! (* alist #!optional binary-test fixnum --> alist))
74(: ensure-flat-list (* -> list))
75(: list-flatten (list -> list))
76(: zip-alist (list list --> alist))
77(: unzip-alist (alist --> list list))
78(: shift! (list #!optional * --> *))
79(: unshift! (* list --> list))
80(: andmap (procedure list #!rest list --> *))
81(: ormap (procedure list #!rest list --> *))
82(: pair-ref (list fixnum --> list))
83(: list-set! (list fixnum * -> void))
84(: list-copy* (list #!optional fixnum fixnum * --> list))
85(: *skip+ (list fixnum --> list fixnum))
86(: *split-at+ (list fixnum (or boolean list) --> list list))
87(: *alist-delete-duplicates (symbol * alist binary-test fixnum --> alist))
88(: *alist-delete-duplicates! (symbol * alist binary-test fixnum --> alist))
89
90;;
91
92(define-error-type plist)
93
94;;
95
96#| ;UNUSED
97(import (chicken sort))
98
99(define (sort-alist xs #!optional (lt? <))
100  (sort xs (lambda (a b) (lt? (car a) (car b)))) )
101
102(define (sort-alist! xs #!optional (lt? <))
103  (sort! xs (lambda (a b) (lt? (car a) (car b)))) )
104|#
105
106;;;
107
108;; Unique sorted list
109
110;=> (values ls dups)
111;
112(define (list-unique/duplicates ls #!optional (eqal? equal?))
113  (check-procedure 'list-unique/duplicates eqal? 'eqal?)
114  (if (null? (check-list 'list-unique/duplicates ls))
115    ls
116    (let ((curr (first ls)))
117      (let loop ((ils (cdr ls)) (ols (list curr)) (prev curr) (dups '()))
118        (if (null? ils)
119          (values (reverse! ols) (reverse! dups))
120          (let ((curr (first ils)) (rst (cdr ils)))
121            (if (eqal? prev curr)
122              (loop rst ols prev (cons curr dups))
123              (loop rst (cons curr ols) curr dups) ) ) ) ) ) ) )
124
125;=> ls
126;
127(define (list-unique ls #!optional (eqal? equal?))
128  (check-procedure 'list-unique eqal? 'eqal?)
129  (if (null? (check-list 'list-unique ls))
130    ls
131    (let ((curr (first ls)))
132      (let loop ((ils (cdr ls)) (ols (list curr)) (prev curr))
133        (if (null? ils)
134          (reverse! ols)
135          (let ((curr (first ils)) (rst (cdr ils)))
136            (if (eqal? prev curr)
137              (loop rst ols prev)
138              (loop rst (cons curr ols) curr) ) ) ) ) ) ) )
139
140;; Returns the original list starting at element n.
141
142(define (skip+ ls n)
143  (*skip+ (check-list 'skip+ ls 'ls) (check-fixnum 'skip+ n 'n)) )
144
145;; Returns new list with all elements [0 n-1] and original list from n.
146;; The new list is padded upto n elements from pads, when supplied.
147;; Returns partial split when fewer than n elements are available,
148;; either from the primary or pad list, or no split when pads is #f. Default is
149;; no padding & paritial section.
150
151(define (split-at+ ls n #!optional pads)
152  (*split-at+
153    (check-list 'split-at+ ls 'ls)
154    (check-fixnum 'split-at+ n 'size)
155    (and pads (check-list 'split-at+ pads 'pads))) )
156
157;; Returns sublists of length n from the list, the last sublist padded, if
158;; necessary and possible, from pads. The sublists are constructed starting
159;; at every step element.
160
161;ls - list
162;n - elements per section
163;step - elements between section
164;pads - remainder fill
165
166(define (section ls n #!optional (step n) (pads '()))
167  (cond
168    ;Do not attempt to section the padding list when
169    ;the primary list is empty.
170    ((null? (check-list 'section ls 'ls))
171      '() )
172    ;Remaining elements between sections
173    (else
174      (let (
175        (bias
176          (-
177            (check-positive-fixnum 'section step 'step)
178            (check-positive-fixnum 'section n 'size))) )
179        (let loop ((ls ls) (parts '()))
180          ;Get this section
181          #;(assert (not (null? ls)))
182          (let-values (((part nls) (*split-at+ ls n pads)))
183            (cond
184              ((null? nls)
185                ;Possible empty section when no padding.
186                ;otherwise complete with this, the last, section
187                (reverse! (if (null? part) parts (cons part parts))) )
188              (else
189                ;Skip over "between" elements and continue sectioning the list.
190                (let (
191                    (ls
192                      (cond
193                        ;step = n
194                        ((= 0 bias)
195                          nls )
196                        ;step < n so skip from starting this section element
197                        ((> 0 bias)
198                          (receive (ls _) (*skip+ ls (+ n bias)) ls) )
199                        ;step > n so skip remaining elements in between
200                        (else
201                          (receive (ls _) (*skip+ nls bias) ls) ) ) ) )
202                  (loop ls (cons part parts)) ) ) ) ) ) ) ) ) )
203
204;; shift! with a variable
205
206(define-syntax shift!/set
207        (syntax-rules ()
208          ;
209                ((shift!/set ?var)
210                  (shift!/set ?var #f) )
211          ;
212                ((shift!/set ?var ?empval)
213      (if (not (pair? ?var))
214        ?empval
215        (let ((_tmp (car ?var)))
216          (set! ?var (cdr ?var))
217          _tmp ) ) ) ) )
218
219;; List of length = 0?
220
221(define-syntax length=0?
222        (syntax-rules ()
223                ((length=0? ?obj)
224                  (null? ?obj) ) ) )
225
226;; List of length = 1?
227
228(define-syntax length=1?
229        (syntax-rules ()
230                ((length=1? ?obj)
231                  (let ((_obj ?obj))
232                    (and (pair? _obj) (null? (cdr _obj))) ) ) ) )
233
234;; List of length > 1?
235
236(define-syntax length>1?
237        (syntax-rules ()
238                ((length>1? ?obj)
239                  (let ((_obj ?obj))
240        (and (pair? _obj) (pair? (cdr _obj))) ) ) ) )
241
242;; List of length = 2?
243
244(define-syntax length=2?
245        (syntax-rules ()
246                ((length=2? ?obj)
247                  (let ((_obj ?obj))
248        (and (length>1? _obj) (null? (cddr _obj))) ) ) ) )
249
250;; Returns a list
251
252(define (ensure-flat-list x)
253  (cond
254    ((null? x)  x)
255    ((pair? x)  (list-flatten x))
256    (else       (list x)) ) )
257
258(define (list-flatten ls)
259  (concatenate (map ensure-flat-list ls)) )
260
261;; Returns a list
262
263(define-syntax ensure-list
264        (syntax-rules ()
265                ((ensure-list ?obj)
266      (let ((_obj ?obj))
267        (if (list? _obj)
268          _obj
269          (list _obj)) ) ) ) )
270
271;; Returns #f if given list is empty and the list itself otherwise
272;; It is intended for emulation of MIT-style empty list treatment
273;; (not-null? <list>) may be considered as a counterpart to MIT-style <list>
274
275(define-syntax not-null?
276        (syntax-rules ()
277                ((not-null? ?obj)
278      (let ((_obj ?obj))
279        (and (not (null? _obj)) _obj) ) ) ) )
280
281;; Remove 1st matching elements from the alist (functional)
282
283(define-syntax alist-delete-first
284        (syntax-rules ()
285                ((alist-delete-first ?key ?als)
286      (alist-delete-first ?key ?als eqv?) )
287                ((alist-delete-first ?key ?als ?=)
288      (alist-delete-with-count ?key ?als 1 ?=) ) ) )
289
290;; Remove 1st matching elements from the alist (destructive)
291
292(define-syntax alist-delete-first!
293        (syntax-rules ()
294                ((alist-delete-first! ?key ?als)
295      (alist-delete-first ?key ?als eqv?) )
296                ((alist-delete-first! ?key ?als ?=)
297      (alist-delete-with-count! ?key ?als 1 ?=) ) ) )
298
299;; Some alist search macros.
300;; Supplied default maybe a thunk or other.
301;; The default is an error.
302
303(define-syntax assoc-def
304        (syntax-rules ()
305                ((assoc-def ?key ?als)
306                  (assoc-def ?key ?als equal?) )
307                ((assoc-def ?key ?als ?=)
308                  (or
309                    (assoc ?key ?als ?=)
310        (error 'assoc-def "key not found" ?key)) )
311                ((assoc-def ?key ?als ?= ?def)
312      (or
313        (assoc ?key ?als ?=)
314        (if (procedure? ?def) (?def) ?def)) ) ) )
315
316(define-syntax assq-def
317        (syntax-rules ()
318                ((assq-def ?key ?als)
319                  (or
320                    (assq ?key ?als)
321        (error 'assq-def "key not found" ?key)) )
322                ((assq-def ?key ?als ?def)
323      (or
324        (assq ?key ?als)
325        (if (procedure? ?def) (?def) ?def)) ) ) )
326
327(define-syntax assv-def
328        (syntax-rules ()
329                ((assv-def ?key ?als)
330                  (or
331                    (assv ?key ?als)
332        (error 'assv-def "key not found" ?key)) )
333                ((assv-def ?key ?als ?def)
334      (or
335        (assv ?key ?als)
336        (if (procedure? ?def) (?def) ?def)) ) ) )
337
338;;
339
340;Note - the order is preserved!
341
342; (<key>1 <val>1 ... <key>n <val>n) -> ((<key>1 . <val>1) ... (<key>n . <val>n))
343
344(define (plist->alist pls)
345  (let loop ((pls (check-list 'plist->alist pls)) (als '()))
346    (if (null? pls)
347      (reverse! als)
348      (let (
349        (hd (car pls))
350        (tl (cdr pls)) )
351        (if (null? tl)
352          (error-plist 'plist->alist pls)
353          (loop (cdr tl) (cons (cons hd (car tl)) als)) ) ) ) ) )
354
355; ((<key>1 . <val>1) ... (<key>n . <val>n)) -> (<key>1 <val>1 ... <key>n <val>n)
356
357(define (alist->plist als)
358  (let loop ((als (check-list 'alist->plist als)) (pls '()))
359    (if (null? als)
360      (reverse! pls)
361      (let ((elt (car als)))
362        (if (not (pair? elt))
363          (error-alist 'alist->plist als)
364          (loop (cdr als) (cons* (cdr elt) (car elt) pls)) ) ) ) ) )
365
366;;
367
368(define (alist? obj)
369  (and
370    (proper-list? obj)
371    (every pair? obj) ) )
372
373;; Search the alist from back to front.
374
375(define (alist-inverse-ref val alist #!optional (cmp eqv?) default)
376  (let (
377    (elt
378      (rassoc
379        val
380        (check-alist 'alist-inverse-ref alist)
381        (check-procedure  'alist-inverse-ref cmp))))
382    (if elt
383      (car elt)
384      default ) ) )
385
386;; Remove 1st N matching elements from the alist (functional)
387
388(define (alist-delete-duplicates key al #!optional (cmp eqv?) (cnt most-positive-fixnum))
389  (*alist-delete-duplicates 'alist-delete-duplicates key al cmp cnt) )
390
391(define (alist-delete-duplicates! key al #!optional (cmp eqv?) (cnt most-positive-fixnum))
392  (*alist-delete-duplicates! 'alist-delete-duplicates! key al cmp cnt) )
393
394;; Returns alist of improper lists
395;; The keys & vals lists must be of the same length!
396
397; This works with any proper list, not just an alist.
398(define (zip-alist keys vals)
399  (unless
400    (= (length (check-list 'zip-alist keys)) (length (check-list 'zip-alist vals)))
401    (error 'zip-alist "lists are not of same length" keys vals) )
402  (map cons keys vals) )
403
404;; Split alist into (values keys vals)
405
406(define (unzip-alist al)
407  (let loop ((al (check-list 'unzip-alist al)) (keys '()) (vals '()))
408    (if (null? al)
409      (values (reverse! keys) (reverse! vals))
410      (let ((elt (car al)))
411        (unless (pair? elt)
412          (error-alist 'unzip-alist al) )
413        (loop (cdr al) (cons (car elt) keys) (cons (cdr elt) vals)) ) ) ) )
414
415;;; Handy little things:
416
417(define (shift! ls #!optional def)
418  (check-list 'shift! ls)
419  (if (null? ls)
420    def
421    (let (
422      (x (car ls))
423      (d (cdr ls)) )
424      (check-pair 'shift! d)
425      (set-car! ls (car d))
426      (set-cdr! ls (cdr d))
427      x ) ) )
428
429(define (unshift! x ls)
430  (check-pair 'unshift! ls)
431  (set-car! ls x)
432  (set-cdr! ls (cons (car ls) (cdr ls)))
433  ls )
434
435;;
436
437(define (andmap func ls0 . rest)
438  (cond
439    ;1 list
440    ((null? rest)
441      (let mapf ((ls ls0))
442        (or
443          (null? ls)
444          (and
445            (func (car ls))
446            (mapf (cdr ls)))) ) )
447    ;2 lists
448    ((null? (cdr rest))
449      (let mapf ((ls1 ls0) (ls2 (car rest)))
450        (or
451          (null? ls1)
452          (and
453            (func (car ls1) (car ls2))
454            (mapf (cdr ls1) (cdr ls2)))) ) )
455    ;>2 lists
456    (else
457      (let mapf ((ls0 ls0) (rest rest))
458        (or
459          (null? ls0)
460          (and
461            (apply func (car ls0) (map car rest))
462            (mapf (cdr ls0) (map cdr rest)))) ) ) ) )
463
464(define (ormap func ls0 . rest)
465  (and
466    (pair? ls0)
467    (let ((rest (cons ls0 rest)))
468      (or
469        (apply func (map car rest))
470        (apply ormap func (map cdr rest)) ) ) ) )
471
472(define pair-ref drop)
473
474(define (list-set! ls idx val)
475  (let ((ls (pair-ref ls idx)))
476    (if (null? ls)
477      (error 'list-set! "index out-of-bounds" idx ls)
478      (set-car! ls val) ) ) )
479
480(define (list-copy* ls #!optional (start 0) (end (length ls)) (fill (void)))
481  (unless (<= start end)
482    (error 'list-copy* "start > end" start end) )
483  (let* (
484    (tot (- end start))
485    (end (min end (length ls)))
486    (len (- end start))
487    (ls (take (drop ls start) len)) )
488    ;(assert (<= tot len))
489    (append! ls (make-list (- tot len) fill)) ) )
490
491;;;
492
493(define (*skip+ ls n)
494  (if (or (null? ls) (<= n 0))
495    (values ls n)
496    (*skip+ (cdr ls) (- n 1))) )
497
498(define (*split-at+ ls n pads)
499  ;Do not attempt to padout when the primary list is empty.
500  (if (null? ls)
501    (values '() '())
502    (let loop ((ls ls) (n n) (part '()))
503      (cond
504        ((<= n 0)
505          (values (reverse! part) ls) )
506        ((null? ls)
507          (cond
508            ;Unless padding is desired throw away the section
509            ((not pads)
510              (values '() '()) )
511            ((null? pads)
512              (values (reverse! part) '()) )
513            (else
514              (receive (ls _) (*split-at+ pads n '())
515                (values (append-reverse! part ls) '()) ) ) ) )
516        (else
517          (loop (cdr ls) (- n 1) (cons (car ls) part)) ) ) ) ) )
518
519(define (*alist-delete-duplicates loc key al cmp cnt)
520  (check-procedure loc cmp)
521  (let loop ((cal (check-list loc al)) (cnt (check-fixnum loc cnt)) (oal '()))
522    (cond
523      ((null? cal)
524        (reverse! oal) )
525      ((pair? cal)
526        (let ((elt (car cal))
527              (nxt (cdr cal)))
528          (if (not (pair? elt))
529            (error-alist loc  al)
530            (if (positive? cnt)
531              ; then more deletion to attempt
532              (if (cmp key (car elt))
533                (loop nxt (sub1 cnt) oal)
534                (loop nxt cnt (cons elt oal)) )
535              ; else copy rest of spine
536              (loop nxt 0 (cons elt oal)) ) ) ) )
537      (else
538        (error-alist loc al) ) ) ) )
539
540(define (*alist-delete-duplicates! loc key al cmp cnt)
541  (check-procedure loc cmp)
542  (let ((ral (check-list loc al)))
543    (let loop ((cal al) (pal #f) (cnt (check-fixnum loc cnt)))
544      (cond
545        ((or (null? cal) (>= 0 cnt))
546          ral )
547        ((pair? cal)
548          (let (
549            (elt (car cal))
550            (nxt (cdr cal)))
551            (if (not (pair? elt))
552              (error-alist loc al)
553              (cond
554                ((cmp key (car elt))
555                  (if pal
556                    (set-cdr! pal nxt)
557                    (set! ral nxt) )
558                  (loop nxt pal (- cnt 1)) )
559                 (else
560                   (loop nxt cal cnt) ) ) ) ) )
561        (else
562          (error-alist loc al) ) ) ) ) )
563
564) ;module list-utils
Note: See TracBrowser for help on using the repository browser.