276 lines
7.6 KiB
Scheme
276 lines
7.6 KiB
Scheme
;;
|
|
;; 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?
|
|
|
|
ldict-empty?
|
|
|
|
ldict-contains?
|
|
ldict-ref
|
|
|
|
ldict-remove
|
|
ldict-set
|
|
|
|
ldict-keys
|
|
|
|
ldict-map
|
|
ldict-filter
|
|
ldict-reduce
|
|
|
|
ldict-equal?
|
|
|
|
ldict-tests!
|
|
)
|
|
|
|
(import scheme
|
|
(chicken base)
|
|
testing
|
|
util-tag
|
|
util-proc
|
|
util-set-list)
|
|
|
|
;; 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))))))
|
|
|
|
;; Returns true if given value is a ldict
|
|
(define (ldict? v)
|
|
(and (pair? v)
|
|
(eq? (car v) TAG-LDICT)))
|
|
|
|
;; Convenience accessors
|
|
(define ldict-meta cadr)
|
|
(define ldict-equality? caadr)
|
|
(define ldict-pairs cddr)
|
|
|
|
;; Returns true if given dictionary contains no keys
|
|
(define (ldict-empty? ld)
|
|
(null? (ldict-pairs ld)))
|
|
|
|
;; Checks whether given dictionary d contains the key k.
|
|
(define (ldict-contains? ld k)
|
|
(let ((equality? (ldict-equality? ld)))
|
|
(let loop ((pairs (ldict-pairs ld)))
|
|
(if (null? pairs)
|
|
#f
|
|
(if (equality? (caar pairs) k)
|
|
#t
|
|
(loop (cdr pairs)))))))
|
|
|
|
;; 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 (ldict-ref ld k . ds)
|
|
(let ((equality? (ldict-equality? ld)))
|
|
(let loop ((pairs (ldict-pairs ld)))
|
|
(if (null? pairs)
|
|
(if (null? ds)
|
|
(error 'ldict-ref "Key does not exist" k)
|
|
(car ds))
|
|
(if (equality? (caar pairs) k)
|
|
(cdar pairs)
|
|
(loop (cdr pairs)))))))
|
|
|
|
;; Returns a new dictionary based on d with key k removed. If it
|
|
;; doesn't contain the key, an error is raised.
|
|
(define (ldict-remove ld k)
|
|
(let ((equality? (ldict-equality? ld)))
|
|
(let loop ((pairs (ldict-pairs ld))
|
|
(res '())
|
|
(failure #t))
|
|
(if (null? pairs)
|
|
(if failure
|
|
(error 'dict-remove "Key does not exist" k)
|
|
(cons TAG-LDICT
|
|
(cons (ldict-meta ld)
|
|
res)))
|
|
(loop (cdr pairs)
|
|
(if (equality? (caar pairs) k)
|
|
res
|
|
(cons (car pairs) res))
|
|
(and failure
|
|
(not (equality? (caar pairs) k))))))))
|
|
|
|
;; 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 (ldict-set ld k v)
|
|
(let ((equality? (ldict-equality? ld)))
|
|
(let loop ((pairs (ldict-pairs ld))
|
|
(res '()))
|
|
(if (null? pairs)
|
|
(cons TAG-LDICT
|
|
(cons (ldict-meta ld)
|
|
(cons (cons k v)
|
|
res)))
|
|
(loop (cdr pairs)
|
|
(if (equality? (caar pairs) k)
|
|
res
|
|
(cons (car pairs) res)))))))
|
|
|
|
;; Returns the list of keys stored in given dictionary.
|
|
(define (ldict-keys ld)
|
|
(map car (ldict-pairs ld)))
|
|
|
|
;; 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 (ldict-map proc ld)
|
|
(let ((both? ((procedure-arity>=? 2) proc))
|
|
(index? ((procedure-arity>=? 3) proc)))
|
|
(let loop ((pairs (ldict-pairs ld))
|
|
(res '())
|
|
(i 0))
|
|
(if (null? pairs)
|
|
(cons TAG-LDICT
|
|
(cons (ldict-meta ld)
|
|
res))
|
|
(loop (cdr pairs)
|
|
(let ((k (caar pairs))
|
|
(v (cdar pairs)))
|
|
(cons (cons k (if both?
|
|
(if index?
|
|
(proc k v i)
|
|
(proc k v))
|
|
(proc v)))
|
|
res))
|
|
(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 (ldict-filter pred? ld)
|
|
(let loop ((pairs (ldict-pairs ld))
|
|
(res '()))
|
|
(if (null? pairs)
|
|
(cons TAG-LDICT
|
|
(cons (ldict-meta ld)
|
|
res))
|
|
(loop (cdr pairs)
|
|
(if (pred? (caar pairs) (cdar pairs))
|
|
(cons (car pairs) res)
|
|
res)))))
|
|
|
|
;; Reduce over dictinary, the reducing procedure gets accumulator,
|
|
;; key and value as its three arguments.
|
|
(define (ldict-reduce init proc ld)
|
|
(let loop ((pairs (ldict-pairs ld))
|
|
(acc init))
|
|
(if (null? pairs)
|
|
acc
|
|
(loop (cdr pairs)
|
|
(proc acc (caar pairs) (cdar pairs))))))
|
|
|
|
;; Returns true if both dictionaries contain the same keys and
|
|
;; values.
|
|
(define (ldict-equal? d1 d2 . equality?)
|
|
(let ((e1 (ldict-equality? d1))
|
|
(e2 (ldict-equality? d2)))
|
|
(let ((equality? (if (null? equality?)
|
|
equal?
|
|
(car equality?))))
|
|
(if (not (eq? e1 e2))
|
|
#f
|
|
(let ((k1 (list->lset (ldict-keys d1)))
|
|
(k2 (list->lset (ldict-keys d2))))
|
|
(if (lset=? k1 k2)
|
|
(let loop ((keys (lset->list k1)))
|
|
(if (null? keys)
|
|
#t
|
|
(if (equality? (ldict-ref d1 (car keys))
|
|
(ldict-ref d2 (car keys)))
|
|
(loop (cdr keys))
|
|
#f)))
|
|
#f))))))
|
|
|
|
;; Performs self-tests of the dictionary module.
|
|
(define (ldict-tests!)
|
|
(run-tests
|
|
ldict
|
|
(test-equal? make-ldict (make-ldict) `(,TAG-LDICT (,eq?)))
|
|
(test-exn ldict-ref (ldict-ref (make-ldict) 'nonexistent))
|
|
(test-true ldict-ref (ldict-ref (make-ldict) 'nonexistent #t))
|
|
(test-equal? ldict-set (ldict-set (make-ldict) 'nonexistent 1)
|
|
`(,TAG-LDICT (,eq?) (nonexistent . 1)))
|
|
(test-equal? ldict-set (ldict-set (ldict-set (make-ldict) 'existent 1) 'existent 2)
|
|
`(,TAG-LDICT (,eq?) (existent . 2)))
|
|
(test-exn ldict-remove (ldict-remove (make-ldict) 'nonexistent))
|
|
(test-equal? ldict-remove
|
|
(ldict-remove (ldict-set (make-ldict) 'existing 1) 'existing)
|
|
(make-ldict))
|
|
(test-equal? ldict-keys (ldict-keys (ldict-set (make-ldict) 'existing 1)) '(existing))
|
|
(test-equal? ldict-map
|
|
(ldict-map (lambda (v) (* 2 v))
|
|
(make-ldict '((a . 1)
|
|
(b . 2))))
|
|
(make-ldict '((b . 4)
|
|
(a . 2))))
|
|
(test-equal? ldict-map
|
|
(ldict-map (lambda (k v) (* 2 v))
|
|
(make-ldict '((a . 1)
|
|
(b . 2))))
|
|
(make-ldict '((b . 4)
|
|
(a . 2))))
|
|
(test-equal? ldict-filter
|
|
(ldict-filter (lambda (k v)
|
|
(odd? v))
|
|
(make-ldict '((a . 1)
|
|
(b . 2))))
|
|
(make-ldict '((a . 1))))
|
|
(test-eq? ldict-reduce
|
|
(ldict-reduce 0 (lambda (a k v) (+ a v))
|
|
(make-ldict '((a . 1) (b . 2))))
|
|
3)
|
|
))
|
|
|
|
)
|