;;;; list-utils.scm  -*- scheme -*-
;;;; Kon Lovett, Jul '07

(module list-utils

(;export
  list-count
  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!
  sort-alist sort-alist!
  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
  #;maplist #;pair-map
  list-set!
  list-copy*)

(import scheme)
(import (chicken base))
(import (chicken type))
(import (chicken fixnum))
(import (only (chicken sort) sort sort!))
(import (only (srfi 1) count first make-list cons* proper-list?
                       reverse! append-reverse! append!
                       take drop every split-at concatenate
                       any pair-fold take!))
(import (only type-checks-basic define-check+error-type))
(import (check-errors sys))

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

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

(: list-count (('a #!rest * -> *) (list-of 'a) #!rest list --> fixnum))
(: list-unique/duplicates (list #!optional binary-test -> list list))
(: list-unique (list #!optional binary-test -> list))

(: skip+ (list fixnum --> list fixnum))
(: split-at+ (list fixnum #!optional (or false list) --> list list))
(: section (list fixnum #!optional fixnum (or false list) --> list))

(: alist? (* -> boolean : alist))
(: plist? (* -> boolean : plist))
(: plist->alist (list --> alist))
(: alist->plist (alist --> list))

(: 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))

(: sort-alist (alist #!optional procedure -> alist))
(: sort-alist! (alist #!optional procedure -> alist))

(: zip-alist (list list --> alist))
(: unzip-alist (alist --> list list))

(: ensure-flat-list (* -> list))
(: list-flatten (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 false list) --> list list))

(: *alist-delete-duplicates (symbol * alist binary-test fixnum --> alist))
(: *alist-delete-duplicates! (symbol * alist binary-test fixnum --> alist))

#;(: maplist (procedure list #!rest list -> . *))
#;(: pair-map (procedure list #!rest list -> . *))

;;

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

(define-check+error-type plist)
(define-check+error-type alist)

(define-inline (check-positive-fixnum loc obj)
  (check-fixnum-in-range loc (check-fixnum loc obj) 1 most-positive-fixnum))

;;;

; helps w/ readable code
;
(define list-count count)

;; Unique sorted list

;=> (values ls dups)
;
(define (list-unique/duplicates ls #!optional (eqal? equal?))
  (check-procedure 'list-unique/duplicates eqal?)
  (let loop ((ils (check-list 'list-unique/duplicates ls)) (ols '()) (prev list-unique/duplicates) (dups '()))
    (if (null? ils)
        (values (reverse! ols) (reverse! dups))
        (let ((curr (first ils)) (rst (cdr ils)))
          (if (and (not (eq? list-unique/duplicates prev)) (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?)
  (let loop ((ils (check-list 'list-unique ls)) (ols '()) (prev list-unique))
    (if (null? ils) (reverse! ols)
        (let ((curr (car ils)) (rst (cdr ils)))
          (if (and (not (eq? list-unique prev)) (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) (check-fixnum 'skip+ 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)
    (check-fixnum 'split-at+ n)
    (and pads (check-list 'split-at+ 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 '()))
       ;Do not attempt to section the padding list when
       ;the primary list is empty.
 (cond ((null? (check-list 'section ls))
          '() )
        ;Remaining elements between sections
        (else
          (let ((bias (- (check-positive-fixnum 'section step)
                         (check-positive-fixnum 'section n))) )
            (let loop ((ls ls) (parts '()))
              ;Get this section
              #;(assert (not (null? ls)))
              (let-values (((part nls) (*split-at+ ls n (and pads (check-list 'section 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 ((= 0 bias) ;step = n
                                        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 (_tmp)
    ;
    ((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 (_obj)
    ((length=1? ?obj)
      (let ((_obj ?obj))
        (and (pair? _obj)
             (null? (cdr _obj))) ) ) ) )

;; List of length > 1?

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

;; List of length = 2?

(define-syntax length=2?
  (syntax-rules (_obj)
    ((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 (_obj)
    ((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 (_obj)
    ((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)) ) ) ) ) )

;; 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) )

(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)))) )

;; 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)
  (if (null? (check-list 'shift! 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)
        ;1 list
  (cond ((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)
                      ;Unless padding is desired throw away the section
                (cond ((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) ) ) ) ) )

;;

#| ;experimental
;Bird & Wadler 1988
(define (inits xs)
  (if (null? xs) '(())
      (cons '() (map (lambda (ys) (cons (car xs) ys)) (inits (cdr xs)))) ) )

(define (maplist fun . cls)
  (let loop ((cls cls))
    (if (any null? cls) '()
        (cons (receive (apply fun cls))
              (loop (##srfi1#cdrs cls) #;(map cdr cls))) ) ) )

(define (pair-map fun . cls)
  (apply pair-fold
         (lambda args
           (let-values (((cls ls) (split-at args (sub1 (length args)))))
             (cons (receive (apply fun cls)) ls) ) )
         '()
         cls))
|#

) ;module list-utils