#|-------------------- 1.1.1 |# "./list-utils.meta" 357
;;;; list-utils.meta  -*- Hen -*-

((egg "list-utils.egg")
 (category lang-exts)
 (author "[[kon lovett]]")
 (license "BSD")
 (doc-from-wiki)
 (synopsis "list-utils")
 (depends
  (setup-helper "1.5.2")
  (check-errors "1.12.1"))
 (test-depends test)
 (files "list-utils.scm" "list-utils.release-info" "list-utils.setup" "list-utils.meta" "tests/run.scm") )

#|-------------------- 1.1.1 |# "./list-utils.scm" 10972
;;;; list-utils.scm
;;;; Kon Lovett, Jul '07

(module list-utils

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

  (import
    scheme
    chicken
    (only data-structures
      rassoc)
    (only srfi-1
      cons* reverse! append-reverse!)
    (only type-checks
      check-list check-pair check-procedure
      check-fixnum check-positive-fixnum)
    (only type-errors
      error-alist define-error-type))

  (require-library
    srfi-1 type-checks type-errors)

;; Returns the original list starting at element n.

(define (skip+ ls n)
  (if (or (null? ls) (<= n 0)) (values ls n)
    (skip+ (cdr ls) (sub1 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 '()))
  ;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         (values (append-reverse! part (split-at+ pads n)) '()) ) ) )
        (else
          (loop (cdr ls) (sub1 n) (cons (car ls) part)) ) ) ) ) )

;; 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 '()))
  (check-positive-fixnum 'section n 'size)
  (check-positive-fixnum 'section step 'step)
  (cond
    ;Do not attempt to section the padding list when
    ;the primary list is empty.
    ((null? ls)   '() )
    (else
      ;Remaining elements between sections
      (let ((inc (- step n)))
        (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
                (if (null? part) (reverse! parts)
                  (reverse! (cons part parts)) ) )
              (else
                ;Skip over "between" elements and
                ;continue sectioning the list.
                (let ((ls (cond
                            ;step = n
                            ((zero? inc)      nls )
                            ;step < n so skip from starting this section element
                            ((negative? inc)  (skip+ ls (+ n inc)) )
                            ;step > n so skip remaining elements in between
                            (else             (skip+ nls inc) ) ) ) )
                  (loop ls (cons part parts)) ) ) ) ) ) ) ) ) )

;;

(define-error-type plist)

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

(define (plist->alist pls)
  (let loop ((pls 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 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 alist cmp)))
    (if elt (car elt)
      default ) ) )

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

(define (*alist-delete/count loc key al cmp cnt)
  (check-procedure loc cmp)
  (let loop ((cal 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/count key al #!optional (cmp eqv?) (cnt 1073741823))
  (*alist-delete/count 'alist-delete/count key al cmp cnt) )

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

(define (*alist-delete!/count loc key al cmp cnt)
  (check-procedure loc cmp)
  (let ((ral al))
    (let loop ((cal al) (pal #f) (cnt (check-fixnum loc cnt)))
      (cond
        ((or (null? cal) (not (positive? 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 (sub1 cnt)) )
                   (else
                     (loop nxt cal cnt) ) ) ) ) )
        (else
          (error-alist loc al) ) ) ) ) )

(define (alist-delete!/count key al #!optional (cmp eqv?) (cnt 1073741823))
  (*alist-delete!/count 'alist-delete!/count 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)))
        (if (not (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 default)
  (if (null? ls) default
    (begin
      (check-pair 'shift! ls)
      (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
    ((null? rest)
      (let mapf ((ls ls0))
        (or (null? ls)
            (and (func (car ls))
                 (mapf (cdr ls)))) ) )
    ((null? (cdr rest))
      (let mapf ((ls1 ls0) (ls2 (car rest)))
        (or (null? ls1)
            (and (func (car ls1) (car ls2))
                 (mapf (cdr ls1) (cdr ls2)))) ) )
    (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)) ) ) ) )

) ;module list-utils

#|-------------------- 1.1.1 |# "./list-utils.setup" 324
;;;; list-utils.setup  -*- Hen -*-

(use setup-helper-mod)

(verify-extension-name "list-utils")

(setup-shared-extension-module 'list-utils (extension-version "1.1.1")
  #:inline? #t
  #:types? #t
  #:compile-options '(
    -scrutinize
    -fixnum-arithmetic
    -optimize-level 3 -debug-level 1
    -no-procedure-checks))