source: project/release/5/list-utils/trunk/list-utils.scm @ 39570

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

weaken other procs

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