whiteline/kekkonen
1
0
Fork 0
Code Issues Pull Requests Releases Wiki Activity

wtf

Browse Source
This commit is contained in:
Victor Fors 2022-01-22 21:09:44 +01:00
parent 011e7a34a1
commit 0ccdb42173
1 changed files with 90 additions and 0 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

90
database.scm Normal file
View File

@ -0,0 +1,90 @@
;;; Database module, serializing kv stores associated with symbols
;;; to and from s-expressions on file.
(module database (database-set database-get database-save *database* database-load database-remove get-all-objects object-exists? has-property? toggle-flag database-null)
(import scheme)
(import chicken.io)
(import util)
;; The global database.
(define *database* '())
;; This has to exist and be exported in order for the test suite
;; not to trigger warnings.
(define (database-null)
(set! *database* '()))
;; Set KEY associated with symbol NAME to VALUE.
(define (database-set name key value)
(set! *database* (let loop ((kv *database*))
(if (null? kv)
(list (cons name (list (cons key value))))
(if (equal? name (caar kv))
(cons (cons name (let loop ((kv (cdar kv)))
(if (null? kv)
(list (cons key value))
(if (equal? key (caar kv))
(cons (cons key value) (cdr kv))
(cons (car kv) (loop (cdr kv))))))) (cdr kv))
(cons (car kv) (loop (cdr kv))))))))
;; Get KEY associated with symbol NAME, returning DEFAULT if it doesn't exist.
(define (database-get name key default)
(let loop ((kv *database*))
(if (null? kv)
default
(if (equal? name (caar kv))
(let loop ((kv (cdar kv)))
(if (null? kv)
default
(if (equal? key (caar kv))
(cdar kv)
(loop (cdr kv)))))
(loop (cdr kv))))))
;; Save database to a file, in s-expression format.
(define (database-save filename)
(with-output-to-file filename (thunk (write *database*))))
;; Load database from a file.
(define (database-load filename)
(with-input-from-file filename (thunk (set! *database* (car (read-list))))))
;; Remove all associations from symbol NAME from database.
(define (database-remove name)
(set! *database* (let loop ((kv *database*))
(if (null? kv)
'()
(if (equal? name (caar kv))
(cdr kv)
(cons (car kv) (loop (cdr kv))))))))
;; Get a list of all symbols in the database.
(define (get-all-objects)
(map car *database*))
;; Does a symbol exist in the database, e.g. is there
;; a symbol that has values associated with it in the database?
(define (object-exists? object)
(list? (member object (get-all-objects))))
;; Is there a value PROPERTY associated with the symbol OBJECT?
(define (has-property? object property)
(let loop ((kv *database*))
(if (null? kv)
#f
(if (eq? (caar kv) object)
(let loop ((kv (cdar kv)))
(if (null? kv)
#f
(if (eq? (caar kv) property)
#t
(loop (cdr kv)))))
(loop (cdr kv))))))
;; If OBJECT has a value FLAG that is unset or false, set it to true.
;; Else set it to false.
(define (toggle-flag object flag)
(if (database-get object flag #f)
(database-set object flag #f)
(database-set object flag #t))))