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

Last change on this file since 39547 was 39547, checked in by Kon Lovett, 5 months ago

add unique, fix test

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