diff --git a/graph-lib/graph/fold-queues.lp2.rkt b/graph-lib/graph/fold-queues.lp2.rkt
index b5a9a351..19501589 100644
--- a/graph-lib/graph/fold-queues.lp2.rkt
+++ b/graph-lib/graph/fold-queues.lp2.rkt
@@ -11,16 +11,13 @@
@section{Implementation}
@chunk[<fold-queues-signature>
- (fold-queues (~maybe #:root root-spec)
- root-value
+ (fold-queues ([root-name:id root-values:expr] …)
[(name [element :colon Element-Type]
[Δ-queues :colon Δ-Queues-Type-Name]
enqueue)
:colon Result-Type
. body]
- …
- (~parse (root-name . _)
- (template ((?? root-spec) 'name …))))]
+ …)]
@chunk[<enqueue-type>
(case→ (→ 'name
@@ -36,7 +33,8 @@
@chunk[<define-ids>
(define-temp-ids "~a/process-element" (name …))
- (define-temp-ids "~a/Δ-results-add" (name …))]
+ (define-temp-ids "~a/Δ-results-add" (name …))
+ (define-temp-ids "~a/index" (root-name …))]
@chunk[<process-element-type>
(∀ (Δ-Queues-Type-Name)
@@ -56,7 +54,7 @@
…
<Δ-hash2-definitions>
<Δ-results-definitions>
- <process-queues>)#|)|#)]
+ <process-queues>))]
@subsection{Representation of the queues}
@@ -75,6 +73,7 @@ which tracks the length of the list (i.e. the first unallocated result index):
<Δ-hash2-type>
<Δ-hash2-empty>
<Δ-hash2-enqueue>
+ <Δ-hash2-enqueue*>
<Δ-hash2-dequeue>]
@chunk[<Δ-hash2-queue-type>
@@ -209,8 +208,30 @@ position in the vector equal to the index associated to it in the hash table:
…
[else (Δ-results-to-vectors results)])))
- (% index Δ-hash = (Δ-hash2-enqueue root-name root-value Δ-hash2-empty)
- (process-queues Δ-hash Δ-results-empty))]
+ (let*-values ([(Δ-hash)
+ Δ-hash2-empty]
+ [(root-name/index Δ-hash)
+ (Δ-hash2-enqueue* 'root-name root-values Δ-hash)]
+ …)
+ (values (list root-name/index …)
+ (process-queues Δ-hash Δ-results-empty)))]
+
+@chunk[<Δ-hash2-enqueue*>
+ (: Δ-hash2-enqueue* (case→ (→ 'name
+ (Listof Element-Type)
+ Δ-hash2-type
+ (values (Listof Index)
+ Δ-hash2-type))
+ …))
+ (define (Δ-hash2-enqueue* selector elts qs)
+ (if (null? elts)
+ (values (list) qs)
+ (cond [(eq? selector 'name)
+ (% index qs2 = (Δ-hash2-enqueue selector (car elts) qs)
+ indices qs3 = (Δ-hash2-enqueue* selector (cdr elts) qs2)
+ (values (cons index indices)
+ qs3))]
+ …)))]
@chunk[<process-queue>
(% e name/queue = (Δ-hash2-dequeue name/queue) ;; to hide name/queue
diff --git a/graph-lib/graph/graph-test.rkt b/graph-lib/graph/graph-test.rkt
index ea271eb9..7e0242b5 100644
--- a/graph-lib/graph/graph-test.rkt
+++ b/graph-lib/graph/graph-test.rkt
@@ -3,20 +3,40 @@
(module test typed/racket
(require (for-syntax (submod "graph.lp2.rkt" test-syntax)
syntax/strip-context))
-
(provide g gr gr-simple)
(define-syntax (insert-tests stx)
(replace-context stx tests))
(require "graph.lp2.rkt"
- (only-in "../lib/low.rkt" cars cdrs check-equal?:)
+ (only-in "../lib/low.rkt" cars cdrs check-equal?: check-true: % in)
(only-in "adt.lp2.rkt" uniform-get)
"../type-expander/type-expander.lp2.rkt")
(insert-tests)
-
+
+ (define counter : Integer 0)
(define-graph gr-simple
- [Fountain [water : (Listof Symbol)]
+ [Fountain [ctr : Integer]
+ [water : (Listof Symbol)]
[(m-fountain [mountain : Symbol])
- (Fountain (list mountain mountain))]]))
\ No newline at end of file
+ (set! counter (+ counter 1))
+ (Fountain counter (list mountain mountain))]]
+ [Node2 [sym : Symbol]
+ [(m-node2 [s : Symbol])
+ (Node2 s)]]
+ [Node3 [err : Nothing]
+ [(m-node3)
+ (error "Should never be called")]])
+
+ ;; Check that the two requests for (splash) give the same node:
+ ;; Also, (n2) is disconnected from the rest of the graph.
+ (check-true:
+ (% ((a b c d) (e) ())
+ = (gr-simple #:roots
+ [Fountain '((splash) (splish) (splash) (soak))]
+ [Node2 '((n2))]
+ [Node3 '()])
+ in
+ (and (= (uniform-get a ctr) (uniform-get c ctr))
+ (not (= (uniform-get a ctr) (uniform-get b ctr)))))))
\ No newline at end of file
diff --git a/graph-lib/graph/graph.lp2.rkt b/graph-lib/graph/graph.lp2.rkt
index 8bac0c83..d124b181 100644
--- a/graph-lib/graph/graph.lp2.rkt
+++ b/graph-lib/graph/graph.lp2.rkt
@@ -213,6 +213,10 @@ We derive identifiers for these based on the @tc[node] name:
(define-temp-ids "~a/promise-type" (node …) #:prefix #'name)
(define-temp-ids "~a/constructor" (node …) #:first-base root
#:prefix #'name)
+ (define-temp-ids "~a/multi-constructor" name)
+ ;; node/multi-rest must not use #:prefix, because it is used as a syntax
+ ;; pattern, and syntax-parse trips over the ":".
+ (define-temp-ids "~a/multi-rest" (node …))
(define-temp-ids "~a?" (node …) #:prefix #'name)
(define-temp-ids "~a/make-placeholder" (node …) #:prefix #'name)
@@ -233,6 +237,8 @@ We derive identifiers for these based on the @tc[node] name:
@chunk[<pass-to-second-step>
(node/promise-type …)
(node/constructor …)
+ name/multi-constructor
+ (node/multi-rest …)
root/constructor
(node? …)
@@ -256,6 +262,7 @@ We derive identifiers for these based on the @tc[node] name:
(define/with-syntax ((root-param …) . _) #'((param …) …))
(define/with-syntax ((root-param-type …) . _) #'((param-type …) …))
(define-temp-ids "~a/main-constructor" name)
+ (define-temp-ids "~a/multi-indices" (node …))
(define-temp-ids "~a/placeholder-queue" (node …) #:prefix #'name)
@@ -309,6 +316,10 @@ The graph name will be used in several ways:
[(_ #:root (~datum node) . rest)
(syntax/loc stx (node/constructor . rest))]
…
+
+ [(_ #:roots [(~datum node) node/multi-rest] …)
+ (syntax/loc stx
+ (name/multi-constructor node/multi-rest …))]
;; TODO: TR has issues with occurrence typing and promises,
;; so we should wrap the nodes in a tag, which contains a
;; promise, instead of the opposite (tag inside promise).
@@ -417,9 +428,14 @@ It will be called from the first step with the following syntax:
(List (Vectorof node/with-indices-type) …))
…))
(define (fq queue-name placeholder)
- <fold-queues>)
+ (cond
+ [(eq? queue-name 'node/placeholder-queue)
+ (second-value <fold-queues>)]
+ …))
- <constructors>)))]
+ <constructors>
+ <multi-constructor>
+ )))]
We shall define a graph constructor for each node type, which accepts the
arguments for that node's mapping, and generates a graph rooted in the resulting
@@ -429,13 +445,40 @@ node.
(begin
(: node/constructor (→ param-type … node/promise-type))
(define (node/constructor param …)
- (match-let ([(list node/database …)
- (fq 'node/placeholder-queue
- (node/make-placeholder param …))])
- (begin <define-with-indices→with-promises>) …
- (node/with-indices→with-promises (vector-ref node/database 0)))))
+ (% (node/database …) = (fq 'node/placeholder-queue
+ (node/make-placeholder param …))
+ (begin <define-with-indices→with-promises>) …
+ (node/with-indices→with-promises (vector-ref node/database 0)))))
…]
+@chunk[<multi-constructor>
+ (: name/multi-constructor (→ (Listof (List param-type …))
+ …
+ (List (Listof node/promise-type) …)))
+ (define (name/multi-constructor node/multi-rest …)
+ (% (node/multi-indices …) (node/database …) = <fold-queues2>
+ in
+ (begin <define-with-indices→with-promises>) …
+ (list (map (λ ([idx : Index])
+ (node/with-indices→with-promises
+ (vector-ref node/database idx)))
+ node/multi-indices)
+ …)))]
+
+@chunk[<fold-queues2>
+ (fold-queues
+ ([node/placeholder-queue
+ (map (λ ([args : (List param-type …)])
+ (apply node/make-placeholder args))
+ node/multi-rest)]
+ …)
+ [(node/placeholder-queue [e : <fold-queue-type-element>]
+ [Δ-queues : Δ-Queues]
+ enqueue)
+ : <fold-queue-type-result>
+ <fold-queue-body>]
+ …)]
+
@section{Injecting the first placeholder in the queue}
@@ -495,8 +538,7 @@ two values: the result of processing the element, and the latest version of
@tc[Δ-queues], which stores the new elements to be added to the queue.
@chunk[<fold-queues>
- (fold-queues #:root queue-name
- placeholder
+ (fold-queues ([node/placeholder-queue (list placeholder)])
[(node/placeholder-queue [e : <fold-queue-type-element>]
[Δ-queues : Δ-Queues]
enqueue)
diff --git a/graph-lib/graph/remember.rkt b/graph-lib/graph/remember.rkt
index 948f18ff..9b409189 100644
--- a/graph-lib/graph/remember.rkt
+++ b/graph-lib/graph/remember.rkt
@@ -178,3 +178,8 @@
(constructor . mb/incomplete)
(constructor . ma/incomplete)
(constructor . ma/incomplete)
+(structure sym)
+(structure err)
+(structure sym)
+(structure ctr water)
+(structure ctr water)
diff --git a/graph-lib/lib/low/in.rkt b/graph-lib/lib/low/in.rkt
new file mode 100644
index 00000000..e2aa0af2
--- /dev/null
+++ b/graph-lib/lib/low/in.rkt
@@ -0,0 +1,8 @@
+#lang typed/racket
+
+(provide in)
+
+(require racket/stxparam)
+
+(define-syntax-parameter in
+ (λ _ "`in' used out of context. It can only be used in some forms."))
\ No newline at end of file
diff --git a/graph-lib/lib/low/percent.rkt b/graph-lib/lib/low/percent.rkt
index 9204bc4e..7b1acd3c 100644
--- a/graph-lib/lib/low/percent.rkt
+++ b/graph-lib/lib/low/percent.rkt
@@ -1,9 +1,10 @@
#lang typed/racket
(require "typed-untyped.rkt")
(define-typed/untyped-modules #:no-test
- (provide % define%)
+ (provide % define% in)
(require (for-syntax syntax/parse))
+ (require "in.rkt")
#|(define-syntax (% stx)
(syntax-parse stx #:literals (= → :)
@@ -23,13 +24,13 @@
#:with expanded #'(cons x.expanded rest.expanded)))
(define-splicing-syntax-class %assignment
#:attributes ([pat.expanded 1] [expr 0])
- #:literals (= →)
- (pattern (~seq (~and maybe-pat (~not (~or = →))) ... (~datum =) expr:expr)
+ #:literals (= in)
+ (pattern (~seq (~and maybe-pat (~not (~or = in))) ... (~datum =) expr:expr)
#:with [pat:%pat ...] #'(maybe-pat ...))))
(define-syntax (% stx)
- (syntax-parse stx #:literals (= →)
- [(_ :%assignment ... (~optional (~literal →)) . body)
+ (syntax-parse stx #:literals (= in)
+ [(_ :%assignment ... (~optional (~literal in)) . body)
#'(match-let*-values ([(pat.expanded ...) expr] ...) . body)]))
(begin-for-syntax