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

Last change on this file since 38846 was 38846, checked in by Kon Lovett, 10 months ago

fix *split-at+ type, strict-types, drop fx in favor of compiler, test optional arguments (a little) better, drop redundant local

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