syndicate-lang
/
syndicate-2017
1
0
Fork 0
Code Issues Pull Requests Projects Releases Wiki Activity

Factor out support/hash.rkt

This commit is contained in:
Tony Garnock-Jones 2016-07-13 16:53:07 -04:00
parent fe272ab514
commit 95fe020ed1
5 changed files with 45 additions and 39 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

6
racket/syndicate/actor.rkt
View File

@ -64,6 +64,7 @@
(require "trie.rkt")
(require "pattern.rkt")
(require "dataflow.rkt")
(require "support/hash.rkt")
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Data Definitions and Structures
@ -506,10 +507,7 @@
(define a (current-actor-state))
(current-actor-state
(struct-copy actor-state a
[facets
(if new-facet
(hash-set (actor-state-facets a) fid new-facet)
(hash-remove (actor-state-facets a) fid))])))
[facets (hash-set/remove (actor-state-facets a) fid new-facet)])))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Entering and Leaving Facet Context; Queueing of Work Items

19
racket/syndicate/dataflow.rkt
View File

@ -12,6 +12,7 @@
dataflow-repair-damage!)
(require racket/set)
(require "support/hash.rkt")
(struct dataflow-graph (edges-forward ;; object-id -> (Setof subject-id)
edges-reverse ;; subject-id -> (Setof object-id)
@ -26,25 +27,13 @@
(hash)
(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 subject-id (current-dataflow-subject-id))
(when subject-id
(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))
(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)
(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))
(for [(object-id (in-set subject-objects))]
(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 repaired-this-round (set))

5
racket/syndicate/demand-matcher.rkt
View File

@ -6,6 +6,7 @@
(require "core.rkt")
(require "drivers/timer.rkt")
(require "pretty.rkt")
(require "support/hash.rkt")
(provide (except-out (struct-out demand-matcher) demand-matcher)
(rename-out [make-demand-matcher demand-matcher])
@ -179,9 +180,7 @@
start-task
on-task-exit
actions))
(values (if new-supervision-state
(hash-set supervision-states captures new-supervision-state)
(hash-remove supervision-states captures))
(values (hash-set/remove supervision-states captures new-supervision-state)
(cons actions new-actions))))
(transition (struct-copy demand-matcher d

29
racket/syndicate/examples/actor/query-set.rkt
View File

@ -1,45 +1,40 @@
#lang syndicate/actor
(require racket/set)
(require syndicate/support/hash)
(require (submod syndicate/actor priorities))
(define-syntax-rule (query-set field-name P expr)
(let ()
(field [field-name (set)])
(on (asserted P) #:priority *query-priority* (field-name (set-add (field-name) expr)))
(on (retracted P) #:priority *query-priority* (field-name (set-remove (field-name) expr)))
(on (asserted P) #:priority *query-priority*
(field-name (set-add (field-name) expr)))
(on (retracted P) #:priority *query-priority*
(field-name (set-remove (field-name) expr)))
field-name))
(define-syntax-rule (query-hash field-name P key-expr value-expr)
(let ()
(field [field-name (hash)])
(on (asserted P)
(on (asserted P) #:priority *query-priority*
(let ((key key-expr))
(when (hash-has-key? (field-name) key)
(log-warning "query-hash: ~a: overwriting existing entry ~v"
'field-name
key))
(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))
(define-syntax-rule (query-hash-set field-name P key-expr value-expr)
(let ()
(field [field-name (hash)])
(on (asserted P)
(let ((key key-expr))
(field-name (hash-set (field-name)
key
(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))))))
(on (asserted P) #:priority *query-priority*
(field-name (hashset-add (field-name) key-expr value-expr)))
(on (retracted P) #:priority
*query-priority* (field-name (hashset-remove (field-name) key-expr value-expr)))
field-name))
(define-syntax-rule (define/query-set id P expr) (define id (query-set id P expr)))

25
racket/syndicate/support/hash.rkt Normal file
View File

@ -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))