hackerbase/src/util-dict.scm

;;
;; util-dict-list.scm
;;
;; Simple dictionary implementation using list backend.
;;
;; ISC License
;;
;; Copyright 2023 Brmlab, z.s.
;; Dominik Pantůček <dominik.pantucek@trustica.cz>
;;
;; Permission to use, copy, modify, and/or distribute this software
;; for any purpose with or without fee is hereby granted, provided
;; that the above copyright notice and this permission notice appear
;; in all copies.
;; 
;; THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL
;; WARRANTIES WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED
;; WARRANTIES OF MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE
;; AUTHOR BE LIABLE FOR ANY SPECIAL, DIRECT, INDIRECT, OR
;; CONSEQUENTIAL DAMAGES OR ANY DAMAGES WHATSOEVER RESULTING FROM LOSS
;; OF USE, DATA OR PROFITS, WHETHER IN AN ACTION OF CONTRACT,
;; NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF OR IN
;; CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE.
;;

(declare (unit util-dict-list))

(module
 util-dict-list
 (
  TAG-LDICT
  
  make-ldict

  ldict-empty?
  
  ldict-has-key?
  ldict-ref
  ldict-remove
  ldict-set
  ldict-keys
  ldict-map
  ldict-filter
  ldict-reduce
  ldict-update
  ldict-tests!
  )

 (import scheme
	 (chicken base)
	 testing
	 util-tag)

 ;; Tag used for identifying list dictionaries from this module
 (define TAG-LDICT (make-tag LDICT))

 ;; Creates an empty dictionary and optionally populates it with
 ;; provided pairs. Default equality is eq?, default are '().
 (define (make-ldict . equality?/pairs)
   (let ((equality? (if (or (null? equality?/pairs)
			    (not (procedure? (car equality?/pairs))))
			eq?
			(car equality?/pairs)))
	 (pairs (if (or (null? equality?/pairs)
			(procedure? (car equality?/pairs)))
		    '()
		    (car equality?/pairs))))
     (let loop ((ld (list TAG-LDICT
			  (list equality?)))
		(pairs pairs))
       (if (null? pairs)
	   ld
	   (loop (ldict-set ld (caar pairs) (cdar pairs))
		 (cdr pairs))))))

 ;; Convenience accessors
 (define ldict-meta cadr)
 (define ldict-equality? caadr)
 (define ldict-list cddr)

 ;; Returns true if given dictionary contains no keys
 (define (ldict-empty? d)
   (null? (ldict-list d)))

 ;; Checks whether given dictionary d contains the key k.
 (define (dict-has-key? d k)
   (if (assq k d) #t #f))

 ;; Retrieves the value for key k from dictionary d. If third argument
 ;; is provided it is used as default value in case the key does not
 ;; exist. If only two arguments are given and the key does not exist,
 ;; raises an error.
 (define (dict-ref d k . r)
   (let ((p (assq k d)))
     (if p
	 (cdr p)
	 (if (null? r)
	     (error 'dict-ref "Key does not exist" k)
	     (car r)))))

 ;; Returns a new dictionary based on d with key k removed. If it
 ;; doesn't contain the key, an error is raised.
 (define (dict-remove d k)
   (let loop ((s d)
	      (r '())
	      (e #t))
     (if (null? s)
	 (if e
	     (error 'dict-remove "Key does not exist" k)
	     r)
	 (if (eq? (caar s) k)
	     (loop (cdr s) r #f)
	     (loop (cdr s) (cons (car s) r) e)))))

 ;; Adds a new value v under the key k to the dictionary d possibly
 ;; overwriting any value which has been stored under the key
 ;; before. Returns the updated dictionary.
 (define (dict-set d k v)
   (let ((dr (let loop ((s d)
			(r '()))
	       (if (null? s)
		   r
		   (if (eq? (caar s) k)
		       (loop (cdr s) r)
		       (loop (cdr s) (cons (car s) r)))))))
     (cons (cons k v)
	   dr)))

 ;; Returns the list of keys stored in given dictionary.
 (define (dict-keys d)
   (map car d))

 ;; Maps dictionary values, the procedure gets key-value pairs if it
 ;; accepts more than one argument. If it accepts a third argument,
 ;; index gets passed as well.
 (define (dict-map proc d)
   (let* ((lpi (length (procedure-information proc)))
	  (both? (> lpi 2))
	  (index? (> lpi 3)))
     (let loop ((d d)
		(r '())
		(i 0))
       (if (null? d)
	   r ; No reverse needed, order does not matter
	   (loop (cdr d)
		 (let ((k (caar d))
		       (v (cdar d)))
		   (cons (cons k (if both?
				     (if index?
					 (proc k v i)
					 (proc k v))
				     (proc v)))
			 r))
		 (add1 i))))))
 
 ;; Returns a dictionary containing only kv pairs matching the
 ;; predicate which must accept two arguments. Unlike list filter,
 ;; does not perform final reverse on the result.
 (define (dict-filter pred? d)
   (let loop ((d d)
	      (r '()))
     (if (null? d)
	 r
	 (loop (cdr d)
	       (if (pred? (caar d) (cdar d))
		   (cons (car d) r)
		   r)))))

 ;; Reduce over dictinary, the reducing procedure gets accumulator,
 ;; key and value as its three arguments.
 (define (dict-reduce init proc d)
   (let loop ((d d)
	      (acc init))
     (if (null? d)
	 acc
	 (loop (cdr d)
	       (proc acc (caar d) (cdar d))))))

 ;; Functional update
 (define (dict-update d k proc . dfls)
   (dict-set d k
	     (proc (apply dict-ref d k dfls))))

 ;; Performs self-tests of the dictionary module.
 (define (ldict-tests!)
   (run-tests
    dict
   (test-true make-dict (null? (make-dict)))
   (test-exn dict-ref (dict-ref (make-dict) 'nonexistent))
   (test-true dict-ref (dict-ref (make-dict) 'nonexistent #t))
   (test-equal? dict-set (dict-set (make-dict) 'nonexistent 1) '((nonexistent . 1)))
   (test-equal? dict-set (dict-set (dict-set (make-dict) 'existent 1) 'existent 2) '((existent . 2)))
   (test-exn dict-remove (dict-remove (make-dict) 'nonexistent))
   (test-true dict-remove (null? (dict-remove (dict-set (make-dict) 'existing 1) 'existing)))
   (test-equal? dict-keys (dict-keys (dict-set (make-dict) 'existing 1)) '(existing))
   (test-equal? dict-map (dict-map (lambda (v) (* 2 v))
				   '((a . 1)
				     (b . 2)))
		'((b . 4)
		  (a . 2)))
   (test-equal? dict-map (dict-map (lambda (k v) (* 2 v))
				   '((a . 1)
				     (b . 2)))
		'((b . 4)
		  (a . 2)))
   (test-equal? dict-filter (dict-filter (lambda (k v)
					   (odd? v))
					 '((a . 1)
					   (b . 2)))
		'((a . 1)))
   (test-eq? dict-reduce
	     (dict-reduce 0 (lambda (a k v) (+ a v)) '((a . 1) (b . 2)))
	     3)
   ))

 )