Move sources to separate directory.

src/dictionary.scm

@@ -0,0 +1,180 @@
+;;
+;; dictionary.scm
+;;
+;; Simple dictionary implementation using assq lists.
+;;
+;; 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 dictionary))
+
+(module
+ dictionary
+ (
+  make-dict
+  dict-has-key?
+  dict-ref
+  dict-remove
+  dict-set
+  dict-keys
+  dict-map
+  dict-filter
+  dict-reduce
+  dictionary-tests!
+  )
+
+ (import scheme
+	 (chicken base)
+	 testing)
+
+ ;; Returns an empty dictionary represented as empty list or a list of
+ ;; pre-initialized cons pairs.
+ (define (make-dict . pairs)
+   (if (null? pairs)
+       '()
+       (car pairs)))
+
+ ;; 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))))))
+
+ ;; Performs self-tests of the dictionary module.
+ (define (dictionary-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)))
+		'((a . 2)
+		  (b . 4)))
+   (test-equal? dict-map (dict-map (lambda (k v) (* 2 v))
+				   '((a . 1)
+				     (b . 2)))
+		'((a . 2)
+		  (b . 4)))
+   (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)
+   ))
+
+ )