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

(module list-utils

(;export
  skip+
  split-at+
  section
  length=0? length=1? length=2? length>1?
  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*
  ;DEPRECATED
  alist-delete/count
  alist-delete!/count
  alist-delete-with-count
  alist-delete-with-count!
  alist-delete-for-count
  alist-delete-for-count! )

(import scheme chicken)
(use
  (only data-structures
    rassoc)
  (only (srfi 1)
    make-list cons*
    proper-list?
    reverse! append-reverse! append!
    take drop
    every
    split-at)
  (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-predicate (* * --> boolean))

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

;;

(define-error-type plist)

;;;

;; Returns the original list starting at element n.

(: skip+ (list fixnum --> list fixnum))
;
(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.

(: split-at+ (list fixnum #!optional (or boolean list) --> list list))
;
(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

(: section (list fixnum #!optional fixnum (or boolean list) --> list))
;
(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
          (fx-
            (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
                        ((fx= 0 bias)
                          nls )
                        ;step < n so skip from starting this section element
                        ((fx> 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 ()
		((_ ?var)
		  (shift!/set ?var #f) )
		((_ ?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 ()
		((_ ?obj)
		  (null? ?obj) ) ) )

;; List of length = 1?

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

;; List of length > 1?

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

;; List of length = 2?

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

;; Returns a list

(define-syntax ensure-list
	(syntax-rules ()
		((_ ?obj)
      (let ((_obj ?obj))
        (or
          (and (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)
      (let ((_obj ?obj))
        (and (not (null? _obj)) _obj) ) ) ) )

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

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

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

(define-syntax alist-delete-first!
	(syntax-rules ()
		((_ ?key ?als)
      (alist-delete-first ?key ?als eqv?) )
		((_ ?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 ()
		((_ ?key ?als)
		  (assoc-def ?key ?als equal?) )
		((_ ?key ?als ?=)
		  (or
		    (assoc ?key ?als ?=)
        (error 'assoc-def "key not found" ?key)) )
		((_ ?key ?als ?= ?def)
      (or
        (assoc ?key ?als ?=)
        (if (procedure? ?def) (?def) ?def)) ) ) )

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

(define-syntax assv-def
	(syntax-rules ()
		((_ ?key ?als)
		  (or
		    (assv ?key ?als)
        (error 'assv-def "key not found" ?key)) )
		((_ ?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))

(: plist->alist (list --> alist))
;
(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)

(: alist->plist (alist --> list))
;
(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)) ) ) ) ) )

;;

(: alist? (* -> boolean : alist))
;
(define (alist? obj)
  (and
    (proper-list? obj)
    (every pair? obj) ) )

;; Search the alist from back to front.

(: alist-inverse-ref (* alist #!optional binary-predicate * --> *))
;
(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)

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

(: alist-delete-duplicates! (* alist #!optional binary-predicate fixnum --> alist))
;
(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.
(: zip-alist (list list --> 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)

(: unzip-alist (alist --> list list))
;
(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:

(: shift! (list #!optional * --> *))
;
(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 ) ) )

(: unshift! (* list --> list))
;
(define (unshift! x ls)
  (check-pair 'unshift! ls)
  (set-car! ls x)
  (set-cdr! ls (cons (car ls) (cdr ls)))
  ls )

;;

(: andmap (procedure list #!rest list --> *))
;
(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)))) ) ) ) )

(: ormap (procedure list #!rest list --> *))
;
(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)) ) ) ) )

(: pair-ref (list fixnum --> list))
;
(define pair-ref drop)

(: list-set! (list fixnum * -> void))
;
(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) ) ) )

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

;;;

(: *skip+ (list fixnum --> list fixnum))
;
(define (*skip+ ls n)
  (if (or (null? ls) (fx<= n 0))
    (values ls n)
    (*skip+ (cdr ls) (fx- n 1))) )

(: *split-at+ (list fixnum list --> list list))
;
(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
        ((fx<= 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) (fx- n 1) (cons (car ls) part)) ) ) ) ) )

(: *alist-delete-duplicates (symbol * alist binary-predicate fixnum --> alist))
;
(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) ) ) ) )

(: *alist-delete-duplicates! (symbol * alist binary-predicate fixnum --> alist))
;
(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) (fx>= 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 (fx- cnt 1)) )
                 (else
                   (loop nxt cal cnt) ) ) ) ) )
        (else
          (error-alist loc al) ) ) ) ) )

;;;DEPRECATED

(define alist-delete-for-count alist-delete-duplicates)
(define alist-delete-for-count! alist-delete-duplicates! )

(define alist-delete/count alist-delete-for-count)
(define alist-delete!/count alist-delete-for-count!)

(: alist-delete-with-count (* alist #!optional fixnum binary-predicate --> alist))
(define (alist-delete-with-count key al #!optional (cnt most-positive-fixnum) (cmp eqv?))
  (*alist-delete-duplicates 'alist-delete-for-count key al cmp cnt) )

(: alist-delete-with-count! (* alist #!optional fixnum binary-predicate --> alist))
(define (alist-delete-with-count! key al #!optional (cnt most-positive-fixnum) (cmp eqv?))
  (*alist-delete-duplicates! 'alist-delete-for-count! key al cmp cnt) )

) ;module list-utils