Factor out support/hash.rkt
This commit is contained in:
parent
fe272ab514
commit
95fe020ed1
|
@ -64,6 +64,7 @@
|
||||||
(require "trie.rkt")
|
(require "trie.rkt")
|
||||||
(require "pattern.rkt")
|
(require "pattern.rkt")
|
||||||
(require "dataflow.rkt")
|
(require "dataflow.rkt")
|
||||||
|
(require "support/hash.rkt")
|
||||||
|
|
||||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||||
;; Data Definitions and Structures
|
;; Data Definitions and Structures
|
||||||
|
@ -506,10 +507,7 @@
|
||||||
(define a (current-actor-state))
|
(define a (current-actor-state))
|
||||||
(current-actor-state
|
(current-actor-state
|
||||||
(struct-copy actor-state a
|
(struct-copy actor-state a
|
||||||
[facets
|
[facets (hash-set/remove (actor-state-facets a) fid new-facet)])))
|
||||||
(if new-facet
|
|
||||||
(hash-set (actor-state-facets a) fid new-facet)
|
|
||||||
(hash-remove (actor-state-facets a) fid))])))
|
|
||||||
|
|
||||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||||
;; Entering and Leaving Facet Context; Queueing of Work Items
|
;; Entering and Leaving Facet Context; Queueing of Work Items
|
||||||
|
|
|
@ -12,6 +12,7 @@
|
||||||
dataflow-repair-damage!)
|
dataflow-repair-damage!)
|
||||||
|
|
||||||
(require racket/set)
|
(require racket/set)
|
||||||
|
(require "support/hash.rkt")
|
||||||
|
|
||||||
(struct dataflow-graph (edges-forward ;; object-id -> (Setof subject-id)
|
(struct dataflow-graph (edges-forward ;; object-id -> (Setof subject-id)
|
||||||
edges-reverse ;; subject-id -> (Setof object-id)
|
edges-reverse ;; subject-id -> (Setof object-id)
|
||||||
|
@ -26,25 +27,13 @@
|
||||||
(hash)
|
(hash)
|
||||||
(set)))
|
(set)))
|
||||||
|
|
||||||
(define (hash-set-add ht k v [set-ctor set])
|
|
||||||
(hash-set ht k (set-add (hash-ref ht k set-ctor) v)))
|
|
||||||
|
|
||||||
(define (hash-set-remove ht k v)
|
|
||||||
(define old (hash-ref ht k #f))
|
|
||||||
(if old
|
|
||||||
(let ((new (set-remove old v)))
|
|
||||||
(if (set-empty? new)
|
|
||||||
(hash-remove ht k)
|
|
||||||
(hash-set ht k new)))
|
|
||||||
ht))
|
|
||||||
|
|
||||||
(define (dataflow-record-observation! g object-id)
|
(define (dataflow-record-observation! g object-id)
|
||||||
(define subject-id (current-dataflow-subject-id))
|
(define subject-id (current-dataflow-subject-id))
|
||||||
(when subject-id
|
(when subject-id
|
||||||
(define fwd (dataflow-graph-edges-forward g))
|
(define fwd (dataflow-graph-edges-forward g))
|
||||||
(set-dataflow-graph-edges-forward! g (hash-set-add fwd object-id subject-id))
|
(set-dataflow-graph-edges-forward! g (hashset-add fwd object-id subject-id))
|
||||||
(define rev (dataflow-graph-edges-reverse g))
|
(define rev (dataflow-graph-edges-reverse g))
|
||||||
(set-dataflow-graph-edges-reverse! g (hash-set-add rev subject-id object-id))))
|
(set-dataflow-graph-edges-reverse! g (hashset-add rev subject-id object-id))))
|
||||||
|
|
||||||
(define (dataflow-record-damage! g object-id)
|
(define (dataflow-record-damage! g object-id)
|
||||||
(set-dataflow-graph-damaged-nodes! g (set-add (dataflow-graph-damaged-nodes g) object-id)))
|
(set-dataflow-graph-damaged-nodes! g (set-add (dataflow-graph-damaged-nodes g) object-id)))
|
||||||
|
@ -55,7 +44,7 @@
|
||||||
(set-dataflow-graph-edges-reverse! g (hash-remove rev subject-id))
|
(set-dataflow-graph-edges-reverse! g (hash-remove rev subject-id))
|
||||||
(for [(object-id (in-set subject-objects))]
|
(for [(object-id (in-set subject-objects))]
|
||||||
(define fwd (dataflow-graph-edges-forward g))
|
(define fwd (dataflow-graph-edges-forward g))
|
||||||
(set-dataflow-graph-edges-forward! g (hash-set-remove fwd object-id subject-id))))
|
(set-dataflow-graph-edges-forward! g (hashset-remove fwd object-id subject-id))))
|
||||||
|
|
||||||
(define (dataflow-repair-damage! g repair-node!)
|
(define (dataflow-repair-damage! g repair-node!)
|
||||||
(define repaired-this-round (set))
|
(define repaired-this-round (set))
|
||||||
|
|
|
@ -6,6 +6,7 @@
|
||||||
(require "core.rkt")
|
(require "core.rkt")
|
||||||
(require "drivers/timer.rkt")
|
(require "drivers/timer.rkt")
|
||||||
(require "pretty.rkt")
|
(require "pretty.rkt")
|
||||||
|
(require "support/hash.rkt")
|
||||||
|
|
||||||
(provide (except-out (struct-out demand-matcher) demand-matcher)
|
(provide (except-out (struct-out demand-matcher) demand-matcher)
|
||||||
(rename-out [make-demand-matcher demand-matcher])
|
(rename-out [make-demand-matcher demand-matcher])
|
||||||
|
@ -179,9 +180,7 @@
|
||||||
start-task
|
start-task
|
||||||
on-task-exit
|
on-task-exit
|
||||||
actions))
|
actions))
|
||||||
(values (if new-supervision-state
|
(values (hash-set/remove supervision-states captures new-supervision-state)
|
||||||
(hash-set supervision-states captures new-supervision-state)
|
|
||||||
(hash-remove supervision-states captures))
|
|
||||||
(cons actions new-actions))))
|
(cons actions new-actions))))
|
||||||
|
|
||||||
(transition (struct-copy demand-matcher d
|
(transition (struct-copy demand-matcher d
|
||||||
|
|
|
@ -1,45 +1,40 @@
|
||||||
#lang syndicate/actor
|
#lang syndicate/actor
|
||||||
|
|
||||||
(require racket/set)
|
(require racket/set)
|
||||||
|
(require syndicate/support/hash)
|
||||||
|
|
||||||
(require (submod syndicate/actor priorities))
|
(require (submod syndicate/actor priorities))
|
||||||
|
|
||||||
(define-syntax-rule (query-set field-name P expr)
|
(define-syntax-rule (query-set field-name P expr)
|
||||||
(let ()
|
(let ()
|
||||||
(field [field-name (set)])
|
(field [field-name (set)])
|
||||||
(on (asserted P) #:priority *query-priority* (field-name (set-add (field-name) expr)))
|
(on (asserted P) #:priority *query-priority*
|
||||||
(on (retracted P) #:priority *query-priority* (field-name (set-remove (field-name) expr)))
|
(field-name (set-add (field-name) expr)))
|
||||||
|
(on (retracted P) #:priority *query-priority*
|
||||||
|
(field-name (set-remove (field-name) expr)))
|
||||||
field-name))
|
field-name))
|
||||||
|
|
||||||
(define-syntax-rule (query-hash field-name P key-expr value-expr)
|
(define-syntax-rule (query-hash field-name P key-expr value-expr)
|
||||||
(let ()
|
(let ()
|
||||||
(field [field-name (hash)])
|
(field [field-name (hash)])
|
||||||
(on (asserted P)
|
(on (asserted P) #:priority *query-priority*
|
||||||
(let ((key key-expr))
|
(let ((key key-expr))
|
||||||
(when (hash-has-key? (field-name) key)
|
(when (hash-has-key? (field-name) key)
|
||||||
(log-warning "query-hash: ~a: overwriting existing entry ~v"
|
(log-warning "query-hash: ~a: overwriting existing entry ~v"
|
||||||
'field-name
|
'field-name
|
||||||
key))
|
key))
|
||||||
(field-name (hash-set (field-name) key value-expr))))
|
(field-name (hash-set (field-name) key value-expr))))
|
||||||
(on (retracted P) (field-name (hash-remove (field-name) key-expr)))
|
(on (retracted P) #:priority *query-priority*
|
||||||
|
(field-name (hash-remove (field-name) key-expr)))
|
||||||
field-name))
|
field-name))
|
||||||
|
|
||||||
(define-syntax-rule (query-hash-set field-name P key-expr value-expr)
|
(define-syntax-rule (query-hash-set field-name P key-expr value-expr)
|
||||||
(let ()
|
(let ()
|
||||||
(field [field-name (hash)])
|
(field [field-name (hash)])
|
||||||
(on (asserted P)
|
(on (asserted P) #:priority *query-priority*
|
||||||
(let ((key key-expr))
|
(field-name (hashset-add (field-name) key-expr value-expr)))
|
||||||
(field-name (hash-set (field-name)
|
(on (retracted P) #:priority
|
||||||
key
|
*query-priority* (field-name (hashset-remove (field-name) key-expr value-expr)))
|
||||||
(set-add (hash-ref (field-name) key set)
|
|
||||||
value-expr)))))
|
|
||||||
(on (retracted P)
|
|
||||||
(let ((key key-expr))
|
|
||||||
(let ((new-entries (set-remove (hash-ref (field-name) key set)
|
|
||||||
value-expr)))
|
|
||||||
(field-name (if (set-empty? new-entries)
|
|
||||||
(hash-remove (field-name) key)
|
|
||||||
(hash-set (field-name) key new-entries))))))
|
|
||||||
field-name))
|
field-name))
|
||||||
|
|
||||||
(define-syntax-rule (define/query-set id P expr) (define id (query-set id P expr)))
|
(define-syntax-rule (define/query-set id P expr) (define id (query-set id P expr)))
|
||||||
|
|
|
@ -0,0 +1,25 @@
|
||||||
|
#lang racket/base
|
||||||
|
;; Hash-table utilities that are not (yet) part of Racket
|
||||||
|
|
||||||
|
(provide hash-set/remove
|
||||||
|
hashset-add
|
||||||
|
hashset-remove)
|
||||||
|
|
||||||
|
(require racket/set)
|
||||||
|
|
||||||
|
(define (hash-set/remove ht key val [default-val #f] #:compare [compare equal?])
|
||||||
|
(if (compare val default-val)
|
||||||
|
(hash-remove ht key)
|
||||||
|
(hash-set ht key val)))
|
||||||
|
|
||||||
|
(define (hashset-add ht key val #:set [set set])
|
||||||
|
(hash-set ht key (set-add (hash-ref ht key set) val)))
|
||||||
|
|
||||||
|
(define (hashset-remove ht k v)
|
||||||
|
(define old (hash-ref ht k #f))
|
||||||
|
(if old
|
||||||
|
(let ((new (set-remove old v)))
|
||||||
|
(if (set-empty? new)
|
||||||
|
(hash-remove ht k)
|
||||||
|
(hash-set ht k new)))
|
||||||
|
ht))
|
Loading…
Reference in New Issue