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

Finished implementing queue with purely functional tag database.

Browse Source
This commit is contained in:
Georges Dupéron 2015-11-16 01:31:11 +01:00
parent 25934fc674
commit 5ed7ddb7c6
1 changed files with 67 additions and 20 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

87
graph/graph/queue.lp2.rkt
View File

@ -161,27 +161,30 @@ as values.
@chunk[<fold-queue-sets> @chunk[<fold-queue-sets>
(: fold-queue-sets (: fold-queue-sets
(∀ (Element Accumulator Result) (∀ (Element Accumulator Result ResultAccumulator)
(→ (Setof Element) (→ (Setof Element)
Accumulator Accumulator
(→ Element Accumulator (→ Element Accumulator
(Values Result Accumulator (Setof Element))) (Values Result Accumulator (Setof Element)))
(values (HashTable Element Result) Accumulator))))] ResultAccumulator
(→ Element Result ResultAccumulator ResultAccumulator)
(values ResultAccumulator Accumulator))))]
@chunk[<inst-fold-queue-sets> @chunk[<inst-fold-queue-sets>
(inst fold-queue (inst fold-queue
(Setof Element) (Setof Element)
Element Element
(List (Setof Element) (HashTable Element Result) Accumulator) (List (Setof Element) ResultAccumulator Accumulator)
(List (HashTable Element Result) Accumulator))] (List ResultAccumulator Accumulator))]
@chunk[<fold-queue-sets> @chunk[<fold-queue-sets>
(define (fold-queue-sets initial-queue accumulator process) (define (fold-queue-sets initial-queue accumulator process
combine-init combine-results)
(apply values (apply values
(<inst-fold-queue-sets> (<inst-fold-queue-sets>
initial-queue initial-queue
(list ((inst set Element)) (list ((inst set Element))
((inst hash Element Result)) combine-init;((inst hash Element Result))
accumulator) accumulator)
cdr cdr
(λ ([s : (Setof Element)]) (values (set-first s) (set-rest s))) (λ ([s : (Setof Element)]) (values (set-first s) (set-rest s)))
@ -190,17 +193,18 @@ as values.
@chunk[<fold-queue-sets-process> @chunk[<fold-queue-sets-process>
(λ (element accumulator rest-queue process-rest) (λ (element accumulator rest-queue process-rest)
(% (past-queue result-hash acc) = accumulator (% (past-queue result-acc acc) = accumulator
result new-acc more-elements = (process element acc) result new-acc more-elements = (process element acc)
(process-rest (process-rest
(set-union rest-queue (set-subtract more-elements past-queue)) (set-union rest-queue (set-subtract more-elements past-queue))
(list (set-add past-queue element) (list (set-add past-queue element)
(if (hash-has-key? result-hash element) (combine-results element result result-acc)
(error (string-append #;(if (hash-has-key? result-hash element)
"Duplicate key in fold-queue-sets." (error (string-append
"Are you using mutable elements?")) "Duplicate key in fold-queue-sets."
(hash-set result-hash element result)) "Are you using mutable elements?"))
(hash-set result-hash element result))
new-acc))))] new-acc))))]
@subsection{Adding tags, using a mutable dictionary} @subsection{Adding tags, using a mutable dictionary}
@ -226,13 +230,16 @@ to the queue).
Accumulator Accumulator
(→ Element Accumulator (Values Tag Accumulator)) (→ Element Accumulator (Values Tag Accumulator))
(values Result Accumulator)) (values Result Accumulator))
(Values (HashTable (Pairof Element Tag) Result) Accumulator))))] (Values (HashTable Element Result)
(HashTable Tag Result)
Accumulator))))]
@chunk[<inst-fold-queue-sets-tags> @chunk[<inst-fold-queue-sets-tags>
(inst fold-queue-sets (inst fold-queue-sets
(Pairof Element Tag) (Pairof Element Tag)
Accumulator Accumulator
Result)] Result
(Pairof (HashTable Element Result) (HashTable Tag Result)))]
@chunk[<fold-queue-sets-tags> @chunk[<fold-queue-sets-tags>
(define (fold-queue-sets-tags initial-queue accumulator make-tag process) (define (fold-queue-sets-tags initial-queue accumulator make-tag process)
@ -244,6 +251,7 @@ to the queue).
accumulator accumulator
(set->list initial-queue)) (set->list initial-queue))
(ht-element . ht-tag) last-accumulator =
(<inst-fold-queue-sets-tags> (<inst-fold-queue-sets-tags>
(list->set initial-tagged-queue) (list->set initial-tagged-queue)
new-accumulator new-accumulator
@ -251,7 +259,13 @@ to the queue).
(let ([new-tagged ((inst set (Pairof Element Tag)))]) (let ([new-tagged ((inst set (Pairof Element Tag)))])
<mutable-get-tag-for> <mutable-get-tag-for>
(% result new-acc = (process (car e) acc get-tag-for) (% result new-acc = (process (car e) acc get-tag-for)
(values result new-acc new-tagged)))))))] (values result new-acc new-tagged))))
(cons ((inst hash Element Result)) ((inst hash Tag Result)))
(λ (e r racc)
(cons (hash-set (car racc) (car e) r)
(hash-set (cdr racc) (cdr e) r))))
(values ht-element ht-tag last-accumulator)))]
@chunk[<mutable-get-tag-for> @chunk[<mutable-get-tag-for>
(define (get-tag-for [x : Element] [acc : Accumulator]) (define (get-tag-for [x : Element] [acc : Accumulator])
@ -274,9 +288,9 @@ the @tc[get-tag] function now returns a tag and the new dictionary.
Accumulator Accumulator
(→ Element Accumulator (Values Tag Accumulator)) (→ Element Accumulator (Values Tag Accumulator))
<fold-queue-sets-immutable-tags-process-type> <fold-queue-sets-immutable-tags-process-type>
(Values (HashTable (Pairof Element Tag) Result) (Values (HashTable Element Result)
(Pairof (HashTable Element Tag) (HashTable Tag Result)
Accumulator)))))] Accumulator))))]
The @tc[process] lambda now takes an element, as well as a purely functional tag The @tc[process] lambda now takes an element, as well as a purely functional tag
provider, which uses an opaque database type @tc[X] to know for which elements provider, which uses an opaque database type @tc[X] to know for which elements
@ -290,7 +304,8 @@ was a tag requested.
(inst fold-queue-sets (inst fold-queue-sets
(Pairof Element Tag) (Pairof Element Tag)
(Pairof (HashTable Element Tag) Accumulator) (Pairof (HashTable Element Tag) Accumulator)
Result)] Result
(Pairof (HashTable Element Result) (HashTable Tag Result)))]
@chunk[<fold-queue-sets-immutable-tags> @chunk[<fold-queue-sets-immutable-tags>
(define (fold-queue-sets-immutable-tags initial-queue (define (fold-queue-sets-immutable-tags initial-queue
@ -305,6 +320,7 @@ was a tag requested.
accumulator accumulator
(set->list initial-queue)) (set->list initial-queue))
(ht-element . ht-tag) (_ . result-acc) =
(<inst-fold-queue-sets-immutable-tags> (<inst-fold-queue-sets-immutable-tags>
(list->set initial-tagged-queue) (list->set initial-tagged-queue)
(cons ((inst hash Element Tag)) new-accumulator) (cons ((inst hash Element Tag)) new-accumulator)
@ -316,7 +332,14 @@ was a tag requested.
(cons h empty-s) (cons h empty-s)
get-tag-for) get-tag-for)
new-h = (hash-set** h (set->list s)) new-h = (hash-set** h (set->list s))
(values r (cons new-h new-acc) s))))))] (values r (cons new-h new-acc) s)))
(cons ((inst hash Element Result)) ((inst hash Tag Result)))
(λ (e r racc)
(cons (hash-set (car racc) (car e) r)
(hash-set (cdr racc) (cdr e) r))))
(values ht-element ht-tag result-acc)))]
@chunk[<immutable-get-tag-for> @chunk[<immutable-get-tag-for>
(define% (get-tag-for [x : Element] (define% (get-tag-for [x : Element]
@ -343,6 +366,13 @@ was a tag requested.
"../lib/low.rkt" "../lib/low.rkt"
racket/set) racket/set)
(provide fold-queue
map-queue
tail-call-reverse-map-queue
fold-queue-sets
fold-queue-sets-tags
fold-queue-sets-immutable-tags)
<fold-queue> <fold-queue>
<map-queue> <map-queue>
<tail-call-reverse-map-queue> <tail-call-reverse-map-queue>
@ -350,6 +380,7 @@ was a tag requested.
<fold-queue-sets-tags> <fold-queue-sets-tags>
<fold-queue-sets-immutable-tags>) <fold-queue-sets-immutable-tags>)
(require typed/racket)
(require 'main) (require 'main)
(provide (all-from-out 'main)) (provide (all-from-out 'main))
@ -357,5 +388,21 @@ was a tag requested.
(require (submod "..") (require (submod "..")
typed/rackunit) typed/rackunit)
((inst fold-queue-sets-immutable-tags
Integer
Void
String
(List 'a Integer String))
(set 10 11 12)
(void)
(λ (e acc) (values (format "{~a}" e) acc))
(λ (e acc x get-tag)
(let*-values ([(t1 acc1 x1) (get-tag (if (even? e)
(floor (/ e 2))
(+ (* 3 e) 1))
acc
x)]
[(t2 acc2 x2) (get-tag 127 acc1 x1)])
(values (list 'a e t1) acc2 x2))))
(require (submod ".." doc))))] (require (submod ".." doc))))]