-
-
Save narslan/7a7dfbb464d7b7bd092e83cdcd1cfaad to your computer and use it in GitHub Desktop.
'An Archaeology-inspired database' (but in Racket) (https://www.aosabook.org/en/500L/an-archaeology-inspired-database.html) (Incomplete -- does not include queries)
This file contains hidden or bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters.
Learn more about bidirectional Unicode characters
| #lang racket | |
| (require racket/generic) | |
| (require racket/match) | |
| (require racket/pretty) | |
| (require struct-update) | |
| (require threading) | |
| (define flip | |
| (curry (λ (f a b) (f b a)))) | |
| (define (ref? attr) | |
| (equal? 'db/ref (Attr-type attr))) | |
| (define (always . etc) | |
| #t) | |
| ; Hash-table utilities (via Clojure) | |
| (define get-in | |
| (case-lambda | |
| ((m ks) (get-in m ks #f)) | |
| ((m ks not-found) | |
| (foldl (lambda (k m) (if (hash? m) | |
| (hash-ref m k not-found) | |
| not-found)) m ks)))) | |
| (define (assoc-in m ks v) | |
| (match ks | |
| ('() m) | |
| ((list k) (hash-set m k v)) | |
| ((list-rest k ks) (hash-set m k (assoc-in (hash-ref m k (hash)) ks v))) | |
| (else (hash-set m ks v)))) | |
| (define (update-in m ks f . args) | |
| (match ks | |
| ((list k) (hash-set m k (apply f (hash-ref m k) args))) | |
| ((list-rest k ks) (hash-set m k (apply update-in (hash-ref m k) ks f args))))) | |
| (define-generics Storage | |
| (get-entity Storage eid) | |
| (write-entity Storage entity) | |
| (drop-entity Storage entity)) | |
| (struct InMemory (store) | |
| #:transparent | |
| #:methods gen:Storage | |
| ((define (get-entity store eid) | |
| (hash-ref (InMemory-store store) eid)) | |
| (define (write-entity store entity) | |
| (struct-copy InMemory store | |
| (store (hash-set (InMemory-store store) | |
| (Entity-id entity) | |
| entity)))) | |
| (define (drop-entity store entity) | |
| (struct-copy InMemory store | |
| (store (hash-remove (InMemory-store store) | |
| (Entity-id entity))))))) | |
| (define-struct-updaters InMemory) | |
| (struct Index (store from-eav to-eav usage-pred) #:transparent) | |
| (define-struct-updaters Index) | |
| (struct Layer (store VAET AVET VEAT EAVT) #:transparent) | |
| (define-struct-updaters Layer) | |
| (struct Database (layers top-id curr-time) #:transparent) | |
| (define-struct-updaters Database) | |
| (struct Entity (id attrs) #:transparent) | |
| (define-struct-updaters Entity) | |
| (struct Attr (name value ts prev-ts type cardinality) #:transparent) | |
| (define-struct-updaters Attr) | |
| ; Keywords are functions in Clojure ... map symbols to functions to emulate here | |
| ; TODO: Refactor (??) | |
| (define indexes '(VAET AVET VEAT EAVT)) | |
| (define index-fns (hash 'VAET Layer-VAET | |
| 'AVET Layer-AVET | |
| 'VEAT Layer-VEAT | |
| 'EAVT Layer-EAVT)) | |
| (define (get-index-fn idx) | |
| (hash-ref index-fns idx)) | |
| (define (make-index from-eav to-eav usage-pred) | |
| (Index #hash() from-eav to-eav usage-pred)) | |
| (define (make-VAET-index) | |
| (make-index (λ (x y z) (list z y x)) | |
| (λ (x y z) (list z y x)) | |
| ref?)) | |
| (define (make-AVET-index) | |
| (make-index (λ (x y z) (list y z x)) | |
| (λ (x y z) (list z x y)) | |
| always)) | |
| (define (make-VEAT-index) | |
| (make-index (λ (x y z) (list z x y)) | |
| (λ (x y z) (list y z y)) | |
| always)) | |
| (define (make-EAVT-index) | |
| (make-index (λ (x y z) (list x y z)) | |
| (λ (x y z) (list x y z)) | |
| always)) | |
| (define (initial-db-layer) | |
| (Layer (InMemory #hash()) (make-VAET-index) (make-AVET-index) (make-VEAT-index) (make-EAVT-index))) | |
| (define (make-db) | |
| (Database (list (initial-db-layer)) 0 0)) | |
| (define (make-entity (id 'db/no-id-yet)) (Entity id (hash))) | |
| (define (make-attr name value type #:cardinality (cardinality 'db/single)) | |
| (Attr name value -1 -1 type cardinality)) | |
| (define (add-attr ent attr) | |
| ; Returns a new entity containing attr in its attr map | |
| (Entity-attrs-update ent (λ (attrs) (hash-set attrs (string->symbol (Attr-name attr)) attr)))) | |
| (define entity-at | |
| (case-lambda | |
| ((db ent-id) (entity-at db (Database-curr-time db) ent-id)) | |
| ((db ts ent-id) | |
| (let* ((db-layers (Database-layers db)) | |
| (layer-at-ts (list-ref db-layers ts)) | |
| (ts-layer-store (Layer-store layer-at-ts))) | |
| (get-entity ts-layer-store ent-id))))) | |
| (define attr-at | |
| (case-lambda | |
| ((db ent-id attr-name) (attr-at db ent-id attr-name (Database-curr-time db))) | |
| ((db ent-id attr-name ts) (hash-ref (Entity-attrs (entity-at db ts ent-id)) attr-name)))) | |
| (define value-of-at | |
| (case-lambda | |
| ((db ent-id attr-name) (Attr-value (attr-at db ent-id attr-name))) | |
| ((db ent-id attr-name ts) (Attr-value (attr-at db ent-id attr-name ts))))) | |
| (define index-at | |
| (case-lambda | |
| ((db kind) (index-at db kind (Database-curr-time db))) | |
| ((db kind ts) (kind (list-ref (Database-layers db) ts))))) | |
| (define (evolution-of db ent-id attr-name) | |
| (define (at-time res ts) | |
| (if (-1 ts) | |
| res | |
| (let ((attr (attr-at db ent-id attr-name ts))) | |
| (at-time (cons (hash (Attr-ts attr) (Attr-value attr)) res) (Attr-prev-ts attr))))) | |
| (at-time '() (Database-curr-time db))) | |
| (define (add-entity db ent) | |
| (match-let* (((cons new-entity new-id) (fix-new-entity db ent)) | |
| (latest-layer (last (Database-layers db))) | |
| (layer-with-updated-store (struct-copy Layer latest-layer | |
| (store (write-entity (Layer-store latest-layer) | |
| new-entity)))) | |
| (add-fn (λ (index layer) (add-entity-to-index new-entity layer index))) | |
| (new-layer (foldl add-fn layer-with-updated-store indexes))) | |
| (struct-copy Database db | |
| (layers (append (Database-layers db) (list new-layer))) | |
| (top-id new-id)))) | |
| (define (next-ts db) (+ (Database-curr-time db) 1)) | |
| (define (update-creation-ts ent ts-val) | |
| (Entity-attrs-update | |
| ent (λ (attrs) (make-immutable-hash | |
| (hash-map attrs | |
| (λ (k v) (cons k (Attr-ts-set v ts-val)))))))) | |
| (define (next-id db ent) | |
| (let* ((top-id (Database-top-id db)) | |
| (ent-id (Entity-id ent)) | |
| (increased-id (+ top-id 1))) | |
| (if (symbol=? ent-id 'db/no-id-yet) | |
| (cons (string->symbol (number->string increased-id)) increased-id) | |
| (cons ent-id top-id)))) | |
| (define (fix-new-entity db ent) | |
| (match-let* (((cons ent-id next-top-id) (next-id db ent)) | |
| (new-ts (next-ts db))) | |
| (cons (update-creation-ts (struct-copy Entity ent (id ent-id)) new-ts) next-top-id))) | |
| (define (get-update-layer-fn layer layer-fn-name) | |
| (match layer-fn-name | |
| ('VAET (λ (q) (struct-copy Layer layer (VAET q)))) | |
| ('AVET (λ (q) (struct-copy Layer layer (AVET q)))) | |
| ('VEAT (λ (q) (struct-copy Layer layer (VEAT q)))) | |
| ('EAVT (λ (q) (struct-copy Layer layer (EAVT q)))))) | |
| (define (add-entity-to-index ent layer index-fn) | |
| (let* ((ent-id (Entity-id ent)) | |
| (index ((hash-ref index-fns index-fn) layer)) | |
| (all-attrs (hash-values (Entity-attrs ent))) | |
| (relevant-attrs (filter (λ (attr) ((Index-usage-pred index) attr)) all-attrs)) | |
| (add-in-index-fn (λ (attr ind) (update-attr-in-index ind ent-id | |
| (Attr-name attr) | |
| (Attr-value attr) | |
| 'db/add)))) | |
| ((get-update-layer-fn layer index-fn) (foldl add-in-index-fn index relevant-attrs)))) | |
| (define (collify item) | |
| (if (list? item) | |
| item | |
| (list item))) | |
| (define (update-attr-in-index index ent-id attr-name target-val operation) | |
| (let* ((colled-target-val (collify target-val)) | |
| (update-entry-fn (λ (vl ind) | |
| (update-entry-in-index ind | |
| ((Index-from-eav index) ent-id attr-name vl) | |
| operation)))) | |
| (foldl update-entry-fn index colled-target-val))) | |
| (define (update-entry-in-index index path operation) | |
| (let* ((update-path (drop-right path 1)) | |
| (update-value (last path)) | |
| (index-store (Index-store index)) | |
| (to-be-updated-set (get-in index update-path (set)))) | |
| (Index-store-update | |
| index (λ (index-store) | |
| (assoc-in index-store | |
| update-path | |
| (set-add to-be-updated-set | |
| update-value)))))) | |
| (define (add-entities db . ents) (foldl (flip add-entity) db ents)) | |
| (define (remove-entity db ent-id) | |
| (let* ((ent (entity-at db ent-id)) | |
| (layer (remove-back-refs db ent-id (last (Database-layers db)))) | |
| (VAET-index (Layer-VAET layer)) | |
| (no-ref-layer ((get-update-layer-fn 'VAET) (hash-remove (Index-store VAET-index) ent-id))) | |
| (no-ent-layer (struct-copy Layer no-ref-layer (store (drop-entity (Layer-store layer) ent)))) | |
| (new-layer (foldl (λ (index layer) (remove-entity-from-index layer index ent) no-ent-layer indexes)))) | |
| (struct-copy Database db (layers (append (Database-layers db) (list new-layer)))))) | |
| (define (remove-entity-from-index ent layer ind-name) | |
| (let* ((ent-id (Entity-id ent)) | |
| (index ((index-fns ind-name) layer)) | |
| (all-attrs (hash-values (Entity-attrs ent))) | |
| (relevant-attrs (filter (λ (attr) ((Index-usage-pred index) attr)) all-attrs)) | |
| (remove-from-index-fn (λ (attr index) (remove-entries-from-index ent-id 'db/remove index attr)))) | |
| ((get-update-layer-fn layer ind-name) (foldl remove-from-index-fn index relevant-attrs)))) | |
| (define (remove-entry-from-index index path) | |
| (let* ((path-head (first path)) | |
| (path-to-items (drop-right path 1)) | |
| (val-to-remove (last path)) | |
| (old-entries-set (get-in index path-to-items))) | |
| (cond | |
| ((not (member val-to-remove old-entries-set)) index) | |
| ((= 1 (length old-entries-set)) (Index-store-update (λ (store) | |
| (update-in store | |
| (collify path-head) | |
| hash-remove | |
| (cadr path))))) | |
| (else (Index-store-update (λ (store) (update-in store path-to-items set-remove val-to-remove))))))) | |
| (define (remove-entries-from-index ent-id operation index attr) | |
| (if (not (equal? operation 'db/add)) | |
| (let* ((attr-name (Attr-name attr)) | |
| (datom-vals (collify (Attr-value attr))) | |
| (paths (map (λ (datom-val) ((Index-from-eav index) ent-id attr-name datom-val)) datom-vals))) | |
| (foldl remove-entry-from-index index paths)) | |
| index)) | |
| (define (remove-back-refs db eid layer) | |
| (let* ((reffing-datoms (reffing-to eid layer)) | |
| (remove-fn (λ (ea db) (update-entity db (car ea) (cadr ea) eid 'db/remove))) | |
| (clean-db (foldl remove-fn db reffing-datoms))) | |
| (last (Database-layers clean-db)))) | |
| (define (reffing-to eid layer) | |
| (let ((VAET-index (Layer-VAET layer))) | |
| (for ((attr-name-and-reffing-set (hash-ref (Layer-store layer) eid))) | |
| (let ((attr-name (car attr-name-and-reffing-set)) | |
| (reffing-set (cadr attr-name-and-reffing-set))) | |
| (for ((reffing reffing-set)) | |
| (list reffing (car attr-name-and-reffing-set))))))) | |
| (define (update-index ent-id old-attr target-val operation layer ind-name) | |
| (if (((Index-usage-pred ((get-index-fn ind-name) layer)) (get-in layer (list ind-name))) old-attr) | |
| (let* ((index ((index-fns ind-name) layer)) | |
| (cleaned-index (remove-entries-from-index ent-id operation index old-attr)) | |
| (updated-index (if (symbol=? operation 'db/remove) | |
| cleaned-index | |
| (update-attr-in-index cleaned-index ent-id (Attr-name old-attr) target-val operation)))) | |
| ((get-update-layer-fn ind-name) updated-index)) | |
| layer)) | |
| (define (put-entity storage eid new-attr) | |
| (Entity-attrs-update (get-entity storage eid) | |
| (λ (attrs) (hash-set attrs (Attr-name new-attr) new-attr)))) | |
| (define (update-layer layer ent-id old-attr updated-attr new-val operation) | |
| (let* ((storage (Layer-store layer)) | |
| (new-layer (foldl (λ (index) (update-index ent-id old-attr new-val operation index layer) layer indexes)))) | |
| (Layer-store-set (write-entity storage (put-entity storage ent-id updated-attr))))) | |
| (define (update-entity db ent-id attr-name new-val (operation 'db/reset-to)) | |
| (let* ((update-ts (next-ts db)) | |
| (layer (last (Database-layers db))) | |
| (attr (attr-at db ent-id attr-name)) | |
| (updated-attr (update-attr attr new-val update-ts operation)) | |
| (fully-updated-layer (update-layer layer ent-id attr updated-attr new-val operation))) | |
| (Database-layers-update db (λ (layer) (append layer (list fully-updated-layer)))))) | |
| (define (update-attr-modification-time attr new-ts) | |
| (Attr-ts-set (Attr-prev-ts-set attr (Attr-ts attr)) new-ts)) | |
| (define (update-attr-value attr value operation) | |
| (if (equal? 'db/single (Attr-cardinality attr)) | |
| (Attr-value-set attr (set value)) | |
| (case operation | |
| ('db/reset-to (Attr-value-set attr value)) | |
| ('db/add (Attr-value-update (λ (curr-value-set) (set-union curr-value-set (set value))))) | |
| ('db/remove (Attr-value-update (λ (curr-value-set) (set-subtract curr-value-set (set value)))))))) | |
| (define (update-attr attr new-val new-ts operation) | |
| (~> attr | |
| (Attr-prev-ts-set (Attr-ts attr)) | |
| (Attr-ts-set new-ts) | |
| (update-attr-value attr new-val operation))) | |
| (let* ((db (make-db)) | |
| (attr (make-attr "user-id" 0 'int)) | |
| (entity (add-attr (make-entity) attr)) | |
| (entity-2 (add-attr (make-entity) (make-attr "user-id" 1 'int))) | |
| (db-2 (add-entities db entity entity-2))) | |
| (pretty-print db-2) | |
| (pretty-print (remove-entity db-2 "user-id"))) |
Sign up for free
to join this conversation on GitHub.
Already have an account?
Sign in to comment