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

;;;; list-utils.scm  -*- scheme -*-
;;;; Kon Lovett, Mar '20
;;;; Kon Lovett, Jul '18
;;;; Kon Lovett, Feb '18
;;;; Kon Lovett, Sep '17
;;;; Kon Lovett, Jul '07

(module list-utils

(;export
  list-unique/duplicates
  list-unique
  skip+
  split-at+
  section
  length=0? length=1? length=2? length>1?
  ensure-flat-list list-flatten
  ensure-list
  not-null?
  alist?
  alist-delete-first alist-delete-first!
  alist-delete-duplicates alist-delete-duplicates!
  assoc-def assq-def assv-def
  alist-inverse-ref
  plist->alist alist->plist
  unzip-alist zip-alist
  shift! unshift! shift!/set
  andmap ormap
  pair-ref
  list-set!
  list-copy*)

(import scheme
  (chicken base)
  (only (chicken fixnum) most-positive-fixnum)
  (chicken type)
  (only (srfi 1)
    first
    make-list cons*
    proper-list?
    reverse! append-reverse! append!
    take drop
    every
    split-at
    concatenate)
  (only type-checks
    check-list check-alist check-pair
    check-procedure
    check-fixnum check-positive-fixnum)
  (only type-errors error-alist define-error-type))

;;;

(define-type binary-test (* * -> boolean))

(define-type alist (or null (list-of pair)))

#; ;too strong
(: list-unique/duplicates (forall (e (s (list-of e))) (s #!optional (e e -> *) -> s s)))
;(: list-unique (forall (e (s (list-of e))) (s #!optional (e e -> *) -> s)))
(: list-unique/duplicates (list #!optional (* * -> *) -> list list))
(: list-unique (list #!optional (* * -> *) -> list))
(: sort-alist (alist #!optional procedure -> alist))
(: sort-alist! (alist #!optional procedure -> void))
(: skip+ (list fixnum --> list fixnum))
(: split-at+ (list fixnum #!optional (or boolean list) --> list list))
(: section (list fixnum #!optional fixnum (or boolean list) --> list))
(: plist->alist (list --> alist))
(: alist->plist (alist --> list))
(: alist? (* -> boolean : alist))
(: alist-inverse-ref (* alist #!optional binary-test * --> *))
(: alist-delete-duplicates (* alist #!optional binary-test fixnum --> alist))
(: alist-delete-duplicates! (* alist #!optional binary-test fixnum --> alist))
(: ensure-flat-list (* -> list))
(: list-flatten (list -> list))
(: zip-alist (list list --> alist))
(: unzip-alist (alist --> list list))
(: shift! (list #!optional * --> *))
(: unshift! (* list --> list))
(: andmap (procedure list #!rest list --> *))
(: ormap (procedure list #!rest list --> *))
(: pair-ref (list fixnum --> list))
(: list-set! (list fixnum * -> void))
(: list-copy* (list #!optional fixnum fixnum * --> list))
(: *skip+ (list fixnum --> list fixnum))
(: *split-at+ (list fixnum (or boolean list) --> list list))
(: *alist-delete-duplicates (symbol * alist binary-test fixnum --> alist))
(: *alist-delete-duplicates! (symbol * alist binary-test fixnum --> alist))

;;

(define-error-type plist)

;;

#| ;UNUSED
(import (chicken sort))

(define (sort-alist xs #!optional (lt? <))
  (sort xs (lambda (a b) (lt? (car a) (car b)))) )

(define (sort-alist! xs #!optional (lt? <))
  (sort! xs (lambda (a b) (lt? (car a) (car b)))) )
|#

;;;

;; Unique sorted list

;=> (values ls dups)
;
(define (list-unique/duplicates ls #!optional (eqal? equal?))
  (check-procedure 'list-unique/duplicates eqal? 'eqal?)
  (if (null? (check-list 'list-unique/duplicates ls))
    ls
    (let ((curr (first ls)))
      (let loop ((ils (cdr ls)) (ols (list curr)) (prev curr) (dups '()))
        (if (null? ils)
          (values (reverse! ols) (reverse! dups))
          (let ((curr (first ils)) (rst (cdr ils)))
            (if (eqal? prev curr)
              (loop rst ols prev (cons curr dups))
              (loop rst (cons curr ols) curr dups) ) ) ) ) ) ) )

;=> ls
;
(define (list-unique ls #!optional (eqal? equal?))
  (check-procedure 'list-unique eqal? 'eqal?)
  (if (null? (check-list 'list-unique ls))
    ls
    (let ((curr (first ls)))
      (let loop ((ils (cdr ls)) (ols (list curr)) (prev curr))
        (if (null? ils)
          (reverse! ols)
          (let ((curr (first ils)) (rst (cdr ils)))
            (if (eqal? prev curr)
              (loop rst ols prev)
              (loop rst (cons curr ols) curr) ) ) ) ) ) ) )

;; Returns the original list starting at element n.

(define (skip+ ls n)
  (*skip+ (check-list 'skip+ ls 'ls) (check-fixnum 'skip+ n 'n)) )

;; Returns new list with all elements [0 n-1] and original list from n.
;; The new list is padded upto n elements from pads, when supplied.
;; Returns partial split when fewer than n elements are available,
;; either from the primary or pad list, or no split when pads is #f. Default is
;; no padding & paritial section.

(define (split-at+ ls n #!optional pads)
  (*split-at+
    (check-list 'split-at+ ls 'ls)
    (check-fixnum 'split-at+ n 'size)
    (and pads (check-list 'split-at+ pads 'pads))) )

;; Returns sublists of length n from the list, the last sublist padded, if
;; necessary and possible, from pads. The sublists are constructed starting
;; at every step element.

;ls - list
;n - elements per section
;step - elements between section
;pads - remainder fill

(define (section ls n #!optional (step n) (pads '()))
  (cond
    ;Do not attempt to section the padding list when
    ;the primary list is empty.
    ((null? (check-list 'section ls 'ls))
      '() )
    ;Remaining elements between sections
    (else
      (let (
        (bias
          (-
            (check-positive-fixnum 'section step 'step)
            (check-positive-fixnum 'section n 'size))) )
        (let loop ((ls ls) (parts '()))
          ;Get this section
          #;(assert (not (null? ls)))
          (let-values (((part nls) (*split-at+ ls n pads)))
            (cond
              ((null? nls)
                ;Possible empty section when no padding.
                ;otherwise complete with this, the last, section
                (reverse! (if (null? part) parts (cons part parts))) )
              (else
                ;Skip over "between" elements and continue sectioning the list.
                (let (
                    (ls
                      (cond
                        ;step = n
                        ((= 0 bias)
                          nls )
                        ;step < n so skip from starting this section element
                        ((> 0 bias)
                          (receive (ls _) (*skip+ ls (+ n bias)) ls) )
                        ;step > n so skip remaining elements in between
                        (else
                          (receive (ls _) (*skip+ nls bias) ls) ) ) ) )
                  (loop ls (cons part parts)) ) ) ) ) ) ) ) ) )

;; shift! with a variable

(define-syntax shift!/set
        (syntax-rules ()
          ;
                ((shift!/set ?var)
                  (shift!/set ?var #f) )
          ;
                ((shift!/set ?var ?empval)
      (if (not (pair? ?var))
        ?empval
        (let ((_tmp (car ?var)))
          (set! ?var (cdr ?var))
          _tmp ) ) ) ) )

;; List of length = 0?

(define-syntax length=0?
        (syntax-rules ()
                ((length=0? ?obj)
                  (null? ?obj) ) ) )

;; List of length = 1?

(define-syntax length=1?
        (syntax-rules ()
                ((length=1? ?obj)
                  (let ((_obj ?obj))
                    (and (pair? _obj) (null? (cdr _obj))) ) ) ) )

;; List of length > 1?

(define-syntax length>1?
        (syntax-rules ()
                ((length>1? ?obj)
                  (let ((_obj ?obj))
        (and (pair? _obj) (pair? (cdr _obj))) ) ) ) )

;; List of length = 2?

(define-syntax length=2?
        (syntax-rules ()
                ((length=2? ?obj)
                  (let ((_obj ?obj))
        (and (length>1? _obj) (null? (cddr _obj))) ) ) ) )

;; Returns a list

(define (ensure-flat-list x)
  (cond
    ((null? x)  x)
    ((pair? x)  (list-flatten x))
    (else       (list x)) ) )

(define (list-flatten ls)
  (concatenate (map ensure-flat-list ls)) )

;; Returns a list

(define-syntax ensure-list
        (syntax-rules ()
                ((ensure-list ?obj)
      (let ((_obj ?obj))
        (if (list? _obj)
          _obj
          (list _obj)) ) ) ) )

;; Returns #f if given list is empty and the list itself otherwise
;; It is intended for emulation of MIT-style empty list treatment
;; (not-null? <list>) may be considered as a counterpart to MIT-style <list>

(define-syntax not-null?
        (syntax-rules ()
                ((not-null? ?obj)
      (let ((_obj ?obj))
        (and (not (null? _obj)) _obj) ) ) ) )

;; Remove 1st matching elements from the alist (functional)

(define-syntax alist-delete-first
        (syntax-rules ()
                ((alist-delete-first ?key ?als)
      (alist-delete-first ?key ?als eqv?) )
                ((alist-delete-first ?key ?als ?=)
      (alist-delete-with-count ?key ?als 1 ?=) ) ) )

;; Remove 1st matching elements from the alist (destructive)

(define-syntax alist-delete-first!
        (syntax-rules ()
                ((alist-delete-first! ?key ?als)
      (alist-delete-first ?key ?als eqv?) )
                ((alist-delete-first! ?key ?als ?=)
      (alist-delete-with-count! ?key ?als 1 ?=) ) ) )

;; Some alist search macros.
;; Supplied default maybe a thunk or other.
;; The default is an error.

(define-syntax assoc-def
        (syntax-rules ()
                ((assoc-def ?key ?als)
                  (assoc-def ?key ?als equal?) )
                ((assoc-def ?key ?als ?=)
                  (or
                    (assoc ?key ?als ?=)
        (error 'assoc-def "key not found" ?key)) )
                ((assoc-def ?key ?als ?= ?def)
      (or
        (assoc ?key ?als ?=)
        (if (procedure? ?def) (?def) ?def)) ) ) )

(define-syntax assq-def
        (syntax-rules ()
                ((assq-def ?key ?als)
                  (or
                    (assq ?key ?als)
        (error 'assq-def "key not found" ?key)) )
                ((assq-def ?key ?als ?def)
      (or
        (assq ?key ?als)
        (if (procedure? ?def) (?def) ?def)) ) ) )

(define-syntax assv-def
        (syntax-rules ()
                ((assv-def ?key ?als)
                  (or
                    (assv ?key ?als)
        (error 'assv-def "key not found" ?key)) )
                ((assv-def ?key ?als ?def)
      (or
        (assv ?key ?als)
        (if (procedure? ?def) (?def) ?def)) ) ) )

;;

;Note - the order is preserved!

; (<key>1 <val>1 ... <key>n <val>n) -> ((<key>1 . <val>1) ... (<key>n . <val>n))

(define (plist->alist pls)
  (let loop ((pls (check-list 'plist->alist pls)) (als '()))
    (if (null? pls)
      (reverse! als)
      (let (
        (hd (car pls))
        (tl (cdr pls)) )
        (if (null? tl)
          (error-plist 'plist->alist pls)
          (loop (cdr tl) (cons (cons hd (car tl)) als)) ) ) ) ) )

; ((<key>1 . <val>1) ... (<key>n . <val>n)) -> (<key>1 <val>1 ... <key>n <val>n)

(define (alist->plist als)
  (let loop ((als (check-list 'alist->plist als)) (pls '()))
    (if (null? als)
      (reverse! pls)
      (let ((elt (car als)))
        (if (not (pair? elt))
          (error-alist 'alist->plist als)
          (loop (cdr als) (cons* (cdr elt) (car elt) pls)) ) ) ) ) )

;;

(define (alist? obj)
  (and
    (proper-list? obj)
    (every pair? obj) ) )

;; Search the alist from back to front.

(define (alist-inverse-ref val alist #!optional (cmp eqv?) default)
  (let (
    (elt
      (rassoc
        val
        (check-alist 'alist-inverse-ref alist)
        (check-procedure  'alist-inverse-ref cmp))))
    (if elt
      (car elt)
      default ) ) )

;; Remove 1st N matching elements from the alist (functional)

(define (alist-delete-duplicates key al #!optional (cmp eqv?) (cnt most-positive-fixnum))
  (*alist-delete-duplicates 'alist-delete-duplicates key al cmp cnt) )

(define (alist-delete-duplicates! key al #!optional (cmp eqv?) (cnt most-positive-fixnum))
  (*alist-delete-duplicates! 'alist-delete-duplicates! key al cmp cnt) )

;; Returns alist of improper lists
;; The keys & vals lists must be of the same length!

; This works with any proper list, not just an alist.
(define (zip-alist keys vals)
  (unless
    (= (length (check-list 'zip-alist keys)) (length (check-list 'zip-alist vals)))
    (error 'zip-alist "lists are not of same length" keys vals) )
  (map cons keys vals) )

;; Split alist into (values keys vals)

(define (unzip-alist al)
  (let loop ((al (check-list 'unzip-alist al)) (keys '()) (vals '()))
    (if (null? al)
      (values (reverse! keys) (reverse! vals))
      (let ((elt (car al)))
        (unless (pair? elt)
          (error-alist 'unzip-alist al) )
        (loop (cdr al) (cons (car elt) keys) (cons (cdr elt) vals)) ) ) ) )

;;; Handy little things:

(define (shift! ls #!optional def)
  (check-list 'shift! ls)
  (if (null? ls)
    def
    (let (
      (x (car ls))
      (d (cdr ls)) )
      (check-pair 'shift! d)
      (set-car! ls (car d))
      (set-cdr! ls (cdr d))
      x ) ) )

(define (unshift! x ls)
  (check-pair 'unshift! ls)
  (set-car! ls x)
  (set-cdr! ls (cons (car ls) (cdr ls)))
  ls )

;;

(define (andmap func ls0 . rest)
  (cond
    ;1 list
    ((null? rest)
      (let mapf ((ls ls0))
        (or
          (null? ls)
          (and
            (func (car ls))
            (mapf (cdr ls)))) ) )
    ;2 lists
    ((null? (cdr rest))
      (let mapf ((ls1 ls0) (ls2 (car rest)))
        (or
          (null? ls1)
          (and
            (func (car ls1) (car ls2))
            (mapf (cdr ls1) (cdr ls2)))) ) )
    ;>2 lists
    (else
      (let mapf ((ls0 ls0) (rest rest))
        (or
          (null? ls0)
          (and
            (apply func (car ls0) (map car rest))
            (mapf (cdr ls0) (map cdr rest)))) ) ) ) )

(define (ormap func ls0 . rest)
  (and
    (pair? ls0)
    (let ((rest (cons ls0 rest)))
      (or
        (apply func (map car rest))
        (apply ormap func (map cdr rest)) ) ) ) )

(define pair-ref drop)

(define (list-set! ls idx val)
  (let ((ls (pair-ref ls idx)))
    (if (null? ls)
      (error 'list-set! "index out-of-bounds" idx ls)
      (set-car! ls val) ) ) )

(define (list-copy* ls #!optional (start 0) (end (length ls)) (fill (void)))
  (unless (<= start end)
    (error 'list-copy* "start > end" start end) )
  (let* (
    (tot (- end start))
    (end (min end (length ls)))
    (len (- end start))
    (ls (take (drop ls start) len)) )
    ;(assert (<= tot len))
    (append! ls (make-list (- tot len) fill)) ) )

;;;

(define (*skip+ ls n)
  (if (or (null? ls) (<= n 0))
    (values ls n)
    (*skip+ (cdr ls) (- n 1))) )

(define (*split-at+ ls n pads)
  ;Do not attempt to padout when the primary list is empty.
  (if (null? ls)
    (values '() '())
    (let loop ((ls ls) (n n) (part '()))
      (cond
        ((<= n 0)
          (values (reverse! part) ls) )
        ((null? ls)
          (cond
            ;Unless padding is desired throw away the section
            ((not pads)
              (values '() '()) )
            ((null? pads)
              (values (reverse! part) '()) )
            (else
              (receive (ls _) (*split-at+ pads n '())
                (values (append-reverse! part ls) '()) ) ) ) )
        (else
          (loop (cdr ls) (- n 1) (cons (car ls) part)) ) ) ) ) )

(define (*alist-delete-duplicates loc key al cmp cnt)
  (check-procedure loc cmp)
  (let loop ((cal (check-list loc al)) (cnt (check-fixnum loc cnt)) (oal '()))
    (cond
      ((null? cal)
        (reverse! oal) )
      ((pair? cal)
        (let ((elt (car cal))
              (nxt (cdr cal)))
          (if (not (pair? elt))
            (error-alist loc  al)
            (if (positive? cnt)
              ; then more deletion to attempt
              (if (cmp key (car elt))
                (loop nxt (sub1 cnt) oal)
                (loop nxt cnt (cons elt oal)) )
              ; else copy rest of spine
              (loop nxt 0 (cons elt oal)) ) ) ) )
      (else
        (error-alist loc al) ) ) ) )

(define (*alist-delete-duplicates! loc key al cmp cnt)
  (check-procedure loc cmp)
  (let ((ral (check-list loc al)))
    (let loop ((cal al) (pal #f) (cnt (check-fixnum loc cnt)))
      (cond
        ((or (null? cal) (>= 0 cnt))
          ral )
        ((pair? cal)
          (let (
            (elt (car cal))
            (nxt (cdr cal)))
            (if (not (pair? elt))
              (error-alist loc al)
              (cond
                ((cmp key (car elt))
                  (if pal
                    (set-cdr! pal nxt)
                    (set! ral nxt) )
                  (loop nxt pal (- cnt 1)) )
                 (else
                   (loop nxt cal cnt) ) ) ) ) )
        (else
          (error-alist loc al) ) ) ) ) )

) ;module list-utils