foss-mmo/modules/goblins/ghash.scm

;;; Copyright 2021-2024 Christine Lemmer-Webber
;;; Copyright 2024 Jessica Tallon
;;;
;;; Licensed under the Apache License, Version 2.0 (the "License");
;;; you may not use this file except in compliance with the License.
;;; You may obtain a copy of the License at
;;;
;;;    http://www.apache.org/licenses/LICENSE-2.0
;;;
;;; Unless required by applicable law or agreed to in writing, software
;;; distributed under the License is distributed on an "AS IS" BASIS,
;;; WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
;;; See the License for the specific language governing permissions and
;;; limitations under the License.

;; An immutable hashtable with specific set/ref conventions.  Refrs
;; are hashed by eq?, everything else is hashed by equal?.
;;
;; TODO: Really presently built on top of vhashes.  Might be built on
;; top of something else, like fashes, in the future.  Especially since
;; vhashes are not thread safe...


(define-module (goblins ghash)
  ;; NOTE: Do not depend on core because it depends on us.
  #:use-module (goblins core-types)
  #:use-module (ice-9 vlist)
  #:use-module (hoot hashtables)
  #:use-module ((hoot lists) #:select (fold))
  #:use-module (ice-9 match)
  #:use-module (scheme write)
  #:export (make-ghash
            ghash?

            ghash-set
            ghash-ref
            ghash-remove
            ghash-null
            ghash-length
            ghash-has-key?

            ghash-fold
            ghash-fold-right
            ghash-for-each

            hashtable->ghash

            make-gset
            gset?
            gset-add
            gset-remove
            gset-length
            gset->list
            gset-member?

            gset-fold
            gset-for-each))

;; hoot hacks

(define (hashtable-fold proc init table)
  (let ((acc init))
    (hashtable-for-each
     (lambda (k v)
       (set! acc (proc k v acc)))
     table)))

(define-record-type <ghash>
  (_make-ghash vhash)
  ghash?
  (vhash ghash-vhash))

(define (vhash-length vhash)
  (vhash-fold (lambda (_k _v count) (+ count 1))
              0 vhash))

(define (print-ghash vhash port)
  (display
   (string-append
    "#<ghash (" (vhash-length (ghash-vhash vhash)) ")>")
   port))

(define ghash-null (_make-ghash vlist-null))

(define (make-ghash . key-vals)
  (_make-ghash
   (let lp ((key-vals key-vals)
            (vh vlist-null))
     (match key-vals
       [() vh]
       [(key val . rest)
        (lp rest
            (_vh-set vh key val))]))))

(define (_vh-set vh key val)
  (define conser
    (if (or (live-refr? key) (symbol? key))
        vhash-consq
        vhash-cons))
  (conser key val vh))

(define (ghash-set ghash key val)
  (define vh (ghash-vhash ghash))
  (_make-ghash (_vh-set vh key val)))

(define* (ghash-ref ghash key #:optional [dflt #f])
  (define vh (ghash-vhash ghash))
  (define assoc
    (if (or (live-refr? key) (symbol? key))
        vhash-assq
        vhash-assoc))
  (match (assoc key vh)
    ((_k . val) val)
    (#f dflt)))

(define (ghash-has-key? ghash key)
  (define vh (ghash-vhash ghash))
  (define assoc
    (if (or (live-refr? key) (symbol? key))
        vhash-assq
        vhash-assoc))
  (match (assoc key vh)
    ((_k . val) #t)
    (#f #f)))

(define (ghash-remove ghash key)
  (define vh (ghash-vhash ghash))
  (define del
    (if (or (live-refr? key) (symbol? key))
        vhash-delq
        vhash-delete))
  (_make-ghash (del key vh)))

(define (ghash-length ghash)
  (vlist-length (ghash-vhash ghash)))

(define (ghash-fold proc init ghash)
  (vhash-fold proc init (ghash-vhash ghash)))
(define (ghash-fold-right proc init ghash)
  (vhash-fold-right proc init (ghash-vhash ghash)))

(define (ghash-for-each proc ghash)
  (vhash-fold
   (lambda (k v _p)
     (proc k v))
   #f
   (ghash-vhash ghash)))

(define (hashtable->ghash table)
  (_make-ghash
   (hashtable-fold
    (lambda (key val vh)
      (_vh-set vh key val))
    vlist-null
    table)))

;;; Sets
(define-record-type <gset>
  (_make-gset ht)
  gset?
  (ht _set-ht))

(define (print-set set port)
  (define items
    (vhash-fold
     (lambda (k _v prev)
       (cons k prev))
     '()
     (_set-ht set)))
  (display (string-append "#<gset " items ">") port))

(define (make-gset . items)
  (define vh
    (fold
     (lambda (item vh)
       (define-values (add assoc)
         (if (or (live-refr? item) (symbol? item))
             (values vhash-consq vhash-assoc)
             (values vhash-cons vhash-assq)))
       ;; Ensure it's unique to the set
       (if (assoc item vh)
           vh
           (add item #t vh)))
     vlist-null items))
  (_make-gset vh))

(define (gset-add set item)
  (define add
    (if (or (live-refr? item) (symbol? item))
        vhash-consq
        vhash-cons))
  (if (gset-member? set item)
      set
      (_make-gset (add item #t (_set-ht set)))))

(define (gset-remove set item)
  (define del
    (if (or (live-refr? item) (symbol? item))
        vhash-delq
        vhash-delete))
  (_make-gset (del item (_set-ht set))))

(define (gset-fold proc init set)
  (vhash-fold
   (lambda (key _val prev)
     (proc key prev))
   init
   (_set-ht set)))

(define (gset-length set)
  (vhash-fold
   (lambda (_k _v count)
     (+ count 1))
   0
   (_set-ht set)))

(define (gset->list set)
  (vhash-fold
   (lambda (key _val prev)
     (cons key prev))
   '()
   (_set-ht set)))

(define (gset-member? set key)
  (define assoc
    (if (or (live-refr? key) symbol? key)
        vhash-assq
        vhash-assoc))

  (match (assoc key (_set-ht set))
    [(_val . #t) #t]
    [#f #f]))

(define (gset-for-each proc set)
  (vhash-fold
   (lambda (k v _p)
     (proc k v))
   #f
   (_set-ht set)))