suzanne.soy/scribble-enhanced
1
0
Fork 0
Code Issues 1 Pull Requests 1 Actions Packages Projects Releases Wiki Activity

Added #:roots option to graph.lp2.rkt, for returning multiple (possibly disconnected) roots.

Browse Source
This commit is contained in:
Georges Dupéron 2016-03-24 18:16:23 +01:00
parent e6ff012973
commit fd654fa36d
6 changed files with 125 additions and 28 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

39
graph-lib/graph/fold-queues.lp2.rkt
View File

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

30
graph-lib/graph/graph-test.rkt
View File

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

60
graph-lib/graph/graph.lp2.rkt
View File

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

5
graph-lib/graph/remember.rkt
View File

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

8
graph-lib/lib/low/in.rkt Normal file
View File

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

11
graph-lib/lib/low/percent.rkt
View File

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