Seems to work but there is a problem with Promise: Type Checker: Street/with-promises-type is not bound as a type in: (force (car (second g))). See graph/__DEBUG_graph__.rkt .
This commit is contained in:
Georges Dupéron
parent
04ddaf308c
commit
191ae7f50e
9
graph/graph/__DEBUG_graph__.rkt
Normal file
9
graph/graph/__DEBUG_graph__.rkt
Normal file
|
|
@ -0,0 +1,9 @@
|
|||
#lang typed/racket
|
||||
|
||||
(require (submod "graph3.lp2.rkt" test))
|
||||
(require racket/list)
|
||||
|
||||
(force (car (second g)))
|
||||
;(map force (second g))
|
||||
|
||||
;(map force (third g))
|
||||
|
|
@ -48,18 +48,15 @@
|
|||
(define-syntax/parse <fold-queues-signature>
|
||||
;<define-queues-type>
|
||||
<define-ids>
|
||||
((λ (x) (pretty-write (syntax->datum x)) x)
|
||||
#'(let ()
|
||||
(begin
|
||||
(: name/process-element <process-element-type>)
|
||||
(define (name/process-element element Δ-queues enqueue) . body))
|
||||
…
|
||||
<Δ-hash2-definitions>
|
||||
<Δ-results-definitions>
|
||||
<process-queues>
|
||||
;((ann (λ _ (error "fold-queues: Not implemented yet"))
|
||||
; (→ (List (Vectorof Result-Type) …))))
|
||||
)))]
|
||||
#|((λ (x) (pretty-write (syntax->datum x)) x)|#
|
||||
#'(let ()
|
||||
(begin
|
||||
(: name/process-element <process-element-type>)
|
||||
(define (name/process-element element Δ-queues enqueue) . body))
|
||||
…
|
||||
<Δ-hash2-definitions>
|
||||
<Δ-results-definitions>
|
||||
<process-queues>)#|)|#)]
|
||||
|
||||
@subsection{Representation of the queues}
|
||||
|
||||
|
|
@ -82,7 +79,8 @@ which tracks the length of the list (i.e. the first unallocated result index):
|
|||
|
||||
@chunk[<Δ-hash2-queue-type>
|
||||
(List (HashTable Element-Type Index)
|
||||
(Listof Element-Type)
|
||||
(Listof Element-Type) ; Reversed stack
|
||||
(Listof Element-Type) ; Stack
|
||||
Index)]
|
||||
|
||||
@chunk[<Δ-hash2-type>
|
||||
|
|
@ -112,14 +110,14 @@ database type opaque, and use an accessor with signature
|
|||
(if (hash-has-key? (car name/queue) elt)
|
||||
(values (hash-ref (car name/queue) elt)
|
||||
qs)
|
||||
(match-let ([(list h l i) name/queue])
|
||||
(match-let ([(list h rs s i) name/queue])
|
||||
(let* ([new-h (hash-set h elt i)]
|
||||
[new-l (cons elt l)] ;; whoops, should append, not cons!
|
||||
[new-s (cons elt s)]
|
||||
[new-i (+ i 1)]
|
||||
[new-i-index (if (index? new-i)
|
||||
new-i
|
||||
(error "Too many elements"))]
|
||||
[name/queue (list new-h new-l new-i-index)])
|
||||
[name/queue (list new-h rs new-s new-i-index)])
|
||||
(values i
|
||||
(list name/queue …)))))]
|
||||
…)))]
|
||||
|
|
@ -128,22 +126,25 @@ database type opaque, and use an accessor with signature
|
|||
|
||||
@chunk[<Δ-hash2-dequeue>
|
||||
(: Δ-hash2-dequeue (case→ (→ (List (HashTable Element-Type Index)
|
||||
(Pairof Element-Type
|
||||
(Listof Element-Type))
|
||||
(Listof Element-Type) ;; TODO: (P (L))
|
||||
(Listof Element-Type) ;; TODO: (P (L))
|
||||
Index)
|
||||
(values Element-Type
|
||||
<Δ-hash2-queue-type>))
|
||||
…))
|
||||
(define (Δ-hash2-dequeue q)
|
||||
(match-let* ([(list h (cons e rest-l) i) q])
|
||||
(values e
|
||||
(list h rest-l (assert (- i 1) index?)))))]
|
||||
(match q
|
||||
[(list h (cons e rest-rs) s i)
|
||||
(values e
|
||||
(list h rest-rs s (assert (- i 1) index?)))]
|
||||
[(list h '() s i)
|
||||
(Δ-hash2-dequeue (list h (reverse s) '() i))]))]
|
||||
|
||||
@subsubsection{Constructor for the queues}
|
||||
|
||||
@chunk[<Δ-hash2-empty>
|
||||
(define Δ-hash2-empty
|
||||
(list (list ((inst hash Element-Type Index)) '() 0)
|
||||
(list (list ((inst hash Element-Type Index)) '() '() 0)
|
||||
…))]
|
||||
|
||||
@subsection{Result lists}
|
||||
|
|
@ -188,7 +189,8 @@ position in the vector equal to the index associated to it in the hash table:
|
|||
(: Δ-results-to-vectors (→ Δ-results-type
|
||||
(List (Vectorof Result-Type) …)))
|
||||
(define (Δ-results-to-vectors Δ-results)
|
||||
(match-let ([(list name/queue …) (ann Δ-results (List (Listof Result-Type) …))])
|
||||
(match-let ([(list name/queue …)
|
||||
(ann Δ-results (List (Listof Result-Type) …))])
|
||||
(list (vector->immutable-vector
|
||||
(ann (list->vector name/queue)
|
||||
(Vectorof Result-Type)))
|
||||
|
|
@ -204,7 +206,8 @@ position in the vector equal to the index associated to it in the hash table:
|
|||
[results : Δ-results-type])
|
||||
: (List (Vectorof Result-Type) …)
|
||||
(match-let ([(list name/queue …) queues])
|
||||
(cond [(not (empty? (cadr name/queue)))
|
||||
(cond [(or (not (empty? (cadr name/queue)))
|
||||
(not (empty? (caddr name/queue))))
|
||||
<process-queue>]
|
||||
…
|
||||
[else (Δ-results-to-vectors results)])))
|
||||
|
|
|
|||
|
|
@ -63,8 +63,8 @@ street names @tc[c], and calls for each element the @tc[m-street] and
|
|||
@; typecheck (yet).
|
||||
@chunk[<m-city>
|
||||
[(m-city [c : (Listof (Pairof String String))])
|
||||
(City (remove-duplicates (map (curry m-street c) (cars c)))
|
||||
(remove-duplicates (map m-person (cdrs c))))]]
|
||||
(City (remove-duplicates (map (curry m-street c) (cdrs c)))
|
||||
(remove-duplicates (map m-person (cars c))))]]
|
||||
|
||||
@subsubsection{More mappings}
|
||||
|
||||
|
|
@ -526,8 +526,7 @@ closes over.
|
|||
(define f (tmpl-fold-instance (List <field-with-indices-type> …)
|
||||
Void
|
||||
<index→promise-clause> …))
|
||||
(cons 'node/with-promises-tag
|
||||
(first-value (f (cdr n) (void)))))]
|
||||
(apply node/make-with-promises (first-value (f (cdr n) (void)))))]
|
||||
|
||||
Where @tc[<field-with-indices-type>] is the @tc[field-type] in which node types
|
||||
are replaced by tagged indices:
|
||||
|
|
@ -579,27 +578,27 @@ are replaced by tagged indices:
|
|||
@chunk[<make-graph-constructor>
|
||||
(define-syntax/parse <signature>
|
||||
<define-ids>
|
||||
((λ (x) (pretty-write (syntax->datum x)) x)
|
||||
(template
|
||||
(let ()
|
||||
(begin <define-placeholder-type>) …
|
||||
(begin <define-make-placeholder>) …
|
||||
(begin <define-with-indices>) …
|
||||
(begin <define-with-promises>) …
|
||||
(begin <define-incomplete>) …
|
||||
(begin <define-mapping-function>) …
|
||||
(let*-values ([(rs) <fold-queues>]
|
||||
[(node/database rs)
|
||||
(values (ann (car rs)
|
||||
(Vectorof node/with-indices-type))
|
||||
(cdr rs))]
|
||||
…
|
||||
[(_) (ann rs Null)])
|
||||
(begin <define-with-indices→with-promises>) …
|
||||
(list node/with-indices→with-promises …)
|
||||
(ann (root/with-indices→with-promises
|
||||
(vector-ref root/database 0))
|
||||
root/with-promises-type))))))]
|
||||
#|((λ (x) (pretty-write (syntax->datum x)) x)|#
|
||||
(template
|
||||
(let ()
|
||||
(begin <define-placeholder-type>) …
|
||||
(begin <define-make-placeholder>) …
|
||||
(begin <define-with-indices>) …
|
||||
(begin <define-with-promises>) …
|
||||
(begin <define-incomplete>) …
|
||||
(begin <define-mapping-function>) …
|
||||
(let*-values ([(rs) <fold-queues>]
|
||||
[(node/database rs)
|
||||
(values (ann (car rs)
|
||||
(Vectorof node/with-indices-type))
|
||||
(cdr rs))]
|
||||
…
|
||||
[(_) (ann rs Null)])
|
||||
(begin <define-with-indices→with-promises>) …
|
||||
(list node/with-indices→with-promises …)
|
||||
(ann (root/with-indices→with-promises
|
||||
(vector-ref root/database 0))
|
||||
root/with-promises-type))))#|)|#)]
|
||||
|
||||
@section{Conclusion}
|
||||
|
||||
|
|
@ -635,34 +634,9 @@ are replaced by tagged indices:
|
|||
|
||||
<use-example>
|
||||
|
||||
(provide g)
|
||||
g
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
(require (submod ".." doc)))]
|
||||
|
||||
@chunk[<*>
|
||||
|
|
|
|||
Loading…
Reference in New Issue
Block a user