brmlab/hackerbase
4
0
Fork 0
Code Issues Pull requests Projects Releases Packages Wiki Activity

Work on migrating to the new dictionary implementation.

Browse source
This commit is contained in:
Dominik Pantůček 2023-04-09 20:36:49 +02:00
parent 42466416cd
commit ced789ca06
7 changed files with 69 additions and 68 deletions
Download patch file Download diff file Expand all files Collapse all files

244
src/util-dict.scm
View file

@ -1,244 +0,0 @@
;;
;; 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-contains?
ldict-ref
ldict-remove
ldict-set
ldict-keys
ldict-map
ldict-filter
ldict-reduce
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-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* ((lpi (length (procedure-information proc)))
(both? (> lpi 2))
(index? (> lpi 3)))
(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))))))
;; Performs self-tests of the dictionary module.
(define (ldict-tests!)
(run-tests
dict
(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)
))
)