From fd654fa36d65156017bb0fdeef0831e29bd33fb8 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Georges=20Dup=C3=A9ron?= Date: Thu, 24 Mar 2016 18:16:23 +0100 Subject: [PATCH] Added #:roots option to graph.lp2.rkt, for returning multiple (possibly disconnected) roots. --- graph-lib/graph/fold-queues.lp2.rkt | 39 ++++++++++++++----- graph-lib/graph/graph-test.rkt | 30 ++++++++++++--- graph-lib/graph/graph.lp2.rkt | 60 ++++++++++++++++++++++++----- graph-lib/graph/remember.rkt | 5 +++ graph-lib/lib/low/in.rkt | 8 ++++ graph-lib/lib/low/percent.rkt | 11 +++--- 6 files changed, 125 insertions(+), 28 deletions(-) create mode 100644 graph-lib/lib/low/in.rkt 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 (~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[ (case→ (→ 'name @@ -36,7 +33,8 @@ @chunk[ (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[ (∀ (Δ-Queues-Type-Name) @@ -56,7 +54,7 @@ … <Δ-hash2-definitions> <Δ-results-definitions> - )#|)|#)] + ))] @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[ (% 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[ (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) - ) + (cond + [(eq? queue-name 'node/placeholder-queue) + (second-value )] + …)) - )))] + + + )))] 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 ) … - (node/with-indices→with-promises (vector-ref node/database 0))))) + (% (node/database …) = (fq 'node/placeholder-queue + (node/make-placeholder param …)) + (begin ) … + (node/with-indices→with-promises (vector-ref node/database 0))))) …] +@chunk[ + (: name/multi-constructor (→ (Listof (List param-type …)) + … + (List (Listof node/promise-type) …))) + (define (name/multi-constructor node/multi-rest …) + (% (node/multi-indices …) (node/database …) = + in + (begin ) … + (list (map (λ ([idx : Index]) + (node/with-indices→with-promises + (vector-ref node/database idx))) + node/multi-indices) + …)))] + +@chunk[ + (fold-queues + ([node/placeholder-queue + (map (λ ([args : (List param-type …)]) + (apply node/make-placeholder args)) + node/multi-rest)] + …) + [(node/placeholder-queue [e : ] + [Δ-queues : Δ-Queues] + enqueue) + : + ] + …)] + @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 #:root queue-name - placeholder + (fold-queues ([node/placeholder-queue (list placeholder)]) [(node/placeholder-queue [e : ] [Δ-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