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

(module (list-utils alist)

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

(import scheme)
(import (chicken base))
(import (chicken type))
(import (chicken fixnum))
(import (only (chicken sort) sort sort!))
(import (only (srfi 1) cons* proper-list? reverse! every))
(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)))

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

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

;;

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

;;;

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

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