'An Archaeology-inspired database' (but in Racket) (https://www.aosabook.org/en/500L/an-archaeology-inspired-database.html) (Incomplete -- does not include queries)

circledb.rkt

#lang racket
(require racket/generic
         racket/match
         racket/pretty
         struct-update
         threading)

(define flip
  (curry (λ (f a b) (f b a))))

(define (ref? attr)
  (symbol=? 'db/ref (Attr-type attr)))

(define (always . etc)
  #t)

(define number->symbol
  (compose string->symbol number->string))

; START hash-table utilities (via Clojure)
(define (get-in m ks (not-found #f))
  (for/fold ((m m))
            ((k ks)
             #:break (not (hash? m)))
    (hash-ref m k not-found)))

(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)))))
; END hash-table utilities (via Clojure)

(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 in-mem eid)
     (hash-ref (InMemory-store in-mem) eid))

   (define (write-entity in-mem entity)
     (InMemory-store-update in-mem (λ (store) (hash-set store (Entity-id entity) entity))))

   (define (drop-entity in-mem entity)
     (InMemory-store-update in-mem (λ (store) (hash-remove 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)

(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 (eav->vae e a v) (list v a e))
(define (vae->eav v a e) (list e a v))
(define (make-VAET-index) (make-index eav->vae vae->eav ref?))

(define (eav->ave e a v) (list a v e))
(define (ave->eav a v e) (list e a v))
(define (make-AVET-index) (make-index eav->ave ave->eav always))

(define (eav->vea e a v) (list v e a))
(define (vea->eav v e a) (list e a v))
(define (make-VEAT-index) (make-index eav->vea vea->eav always))

(define (eav->eav e a v) (list e a v))
(define (make-EAVT-index) (make-index eav->eav eav->eav 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) (if (number? ent-id) (number->symbol ent-id) 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) ((get-index-fn 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 (Layer-store-update latest-layer (λ (store) (write-entity store new-entity))))
               (add-fn (λ (index layer) (add-entity-to-index new-entity layer index)))
               (new-layer (foldl add-fn layer-with-updated-store indexes)))
    (~> db
        (Database-layers-update (λ (layers) (append layers (list new-layer))))
        (Database-top-id-set 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 (Entity-id-set ent ent-id) new-ts) next-top-id)))

(define (get-update-layer-fn layer layer-fn-name)
  (match layer-fn-name
    ('VAET (λ (q) (Layer-VAET-set layer q)))
    ('AVET (λ (q) (Layer-AVET-set layer q)))
    ('VEAT (λ (q) (Layer-VEAT-set layer q)))
    ('EAVT (λ (q) (Layer-EAVT-set layer q)))))

(define (add-entity-to-index ent layer index-fn)
  (let* ((ent-id (Entity-id ent))
         (index ((get-index-fn 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-store 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 (Layer-VAET-update layer
                                          (λ (VAET-index)
                                            (Index-store-update VAET-index
                                                                (λ (store)
                                                                  (hash-remove store ent-id))))))
         (no-ent-layer (Layer-store-update no-ref-layer (λ (store) (drop-entity store ent))))
         (new-layer (foldl (λ (index layer) (remove-entity-from-index ent layer index)) no-ent-layer indexes)))
    (Database-layers-update db (λ (layers) (append layers (list new-layer))))))

(define (remove-entity-from-index ent layer ind-name)
  (let* ((ent-id (Entity-id ent))
         (index ((get-index-fn 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 path index)
  (let* ((path-head (first path))
         (path-to-items (drop-right path 1))
         (val-to-remove (last path))
         (old-entries-set (get-in (Index-store index) path-to-items)))
    (cond
      ((not (set-member? old-entries-set val-to-remove)) index)
      ((= 1 (set-count old-entries-set)) (Index-store-update index (λ (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 (symbol=? 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*/list (((attr-name reffing-set) (hash-ref (Index-store VAET-index) (number->symbol eid) '()))
                (reffing reffing-set))
      (list reffing attr-name))))

(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 ((get-index-fn 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 layer 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 new-layer (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))
      (Attr-value-update
       attr
       (λ (curr-value)
         (case operation
           ('db/reset-to value)
           ('db/add (set-union curr-value (set value)))
           ('db/remove (set-subtract curr-value (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)))

(define-syntax-rule (transact db (tx-f tx-args ...) ...)
  (foldr
   (λ (tx curr-db)
     (Database-curr-time-set
      (apply (car tx) curr-db (cdr tx))
      (next-ts curr-db)))
   db
   (list (list tx-f tx-args ...) ...)))

(define (incoming-refs db ts ent-id . ref-names)
  (let* ((VAET-index (index-at db 'VAET ts))
         (all-attr-map (hash-ref (Index-store VAET-index) ent-id))
         (filtered-map (if (not (null? ref-names))
                           (make-immutable-hash
                            (filter (λ (attr) (member (Attr-name attr) ref-names))
                                              (hash->list all-attr-map)))
                           all-attr-map)))
    (list->set (hash-values all-attr-map))))

(define (select-keys h ks)
  (for/hash ((k ks) #:when (hash-has-key? h k))
    (values k (hash-ref h k))))

(define (select-attrs ref-names attrs-map)
  (if (null? ref-names)
      (hash-values attrs-map)
      (hash-values (select-keys attrs-map ref-names))))

(define (outgoing-refs db ts ent-id . ref-names)
  (for/list ((attr (select-attrs ref-names (Entity-attrs (entity-at db ts ent-id))))
             #:when (ref? attr))
    (Attr-value attr)))

(let* ((db (make-db))
       (attr (make-attr "user-id" 0 'db/user))
       (entity (add-attr (make-entity) attr))
       (entity-2 (add-attr (make-entity) (make-attr "user-id" 1 'db/user)))
       (db-2 (transact db [add-entity entity] [add-entity entity-2])))
  (pretty-print db-2)
  (pretty-print (transact db-2 [remove-entity 1] [remove-entity 2])))