Initial commit. Improved API to route.rkt (from minimart).
This commit is contained in:
Tony Garnock-Jones
commit
8579ec4151
|
|
@ -0,0 +1 @@
|
|||
compiled/
|
||||
|
|
@ -0,0 +1,16 @@
|
|||
PACKAGENAME=prospect
|
||||
COLLECTS=prospect
|
||||
|
||||
all: setup
|
||||
|
||||
clean:
|
||||
find . -name compiled -type d | xargs rm -rf
|
||||
|
||||
setup:
|
||||
raco setup $(COLLECTS)
|
||||
|
||||
link:
|
||||
raco pkg install --link -n $(PACKAGENAME) $$(pwd)
|
||||
|
||||
unlink:
|
||||
raco pkg remove $(PACKAGENAME)
|
||||
|
|
@ -0,0 +1,47 @@
|
|||
#lang racket/base
|
||||
;; Poor-man's hash consing.
|
||||
|
||||
(provide canonicalize)
|
||||
|
||||
(define canonical-values (make-weak-hash))
|
||||
|
||||
(define sentinel (cons #f #f))
|
||||
|
||||
(define (canonicalize val)
|
||||
(define b (hash-ref canonical-values
|
||||
val
|
||||
(lambda ()
|
||||
(define new-b (make-weak-box val))
|
||||
(hash-set! canonical-values val new-b)
|
||||
#f)))
|
||||
(if (not b)
|
||||
(canonicalize val)
|
||||
(let ((v (weak-box-value b sentinel)))
|
||||
(if (eq? v sentinel) (canonicalize val) v))))
|
||||
|
||||
(module+ test
|
||||
(require rackunit)
|
||||
|
||||
(define v1 (canonicalize (cons 1 2)))
|
||||
|
||||
(let ((v2 (canonicalize (cons 1 2))))
|
||||
(check-eq? v1 v2))
|
||||
|
||||
(collect-garbage)
|
||||
(check-equal? (hash-count canonical-values) 1)
|
||||
|
||||
(let ((v2 (canonicalize (cons 1 2))))
|
||||
(check-eq? v1 v2))
|
||||
|
||||
(set! v1 (canonicalize (cons 1 2)))
|
||||
|
||||
(collect-garbage)
|
||||
(check-equal? (hash-count canonical-values) 1)
|
||||
|
||||
(let ((v2 (canonicalize (cons 1 2))))
|
||||
(check-eq? v1 v2))
|
||||
|
||||
(set! v1 #f)
|
||||
|
||||
(collect-garbage)
|
||||
(check-equal? (hash-count canonical-values) 0))
|
||||
|
|
@ -0,0 +1,194 @@
|
|||
#lang racket/base
|
||||
;; Core implementation of Incremental Network Calculus.
|
||||
|
||||
(provide )
|
||||
|
||||
(require racket/set)
|
||||
(require racket/match)
|
||||
(require (only-in racket/list flatten))
|
||||
(require "functional-queue.rkt")
|
||||
(require "route.rkt")
|
||||
(require "patch.rkt")
|
||||
|
||||
;; Events ⊃ Patches
|
||||
;; Actions ⊃ Events
|
||||
(struct quit () #:prefab)
|
||||
(struct spawn (behavior boot) #:prefab)
|
||||
|
||||
;; Processes (machine states)
|
||||
(struct process (interests behavior state) #:transparent)
|
||||
|
||||
;; A Behavior is a ((Option Event) Any -> Transition): a function
|
||||
;; mapping an Event (or, in the #f case, a poll signal) and a
|
||||
;; Process's current state to a Transition.
|
||||
;;
|
||||
;; A Transition is either
|
||||
;; - #f, a signal from a Process that it is inert and need not be
|
||||
;; scheduled until some Event relevant to it arrives; or,
|
||||
;; - a (transition Any (Constreeof Action)), a new Process state to
|
||||
;; be held by its World and a sequence of Actions for the World
|
||||
;; to take on the transitioning Process's behalf.
|
||||
(struct transition (state actions) #:transparent)
|
||||
|
||||
;; A PID is a Nat.
|
||||
;; A Label is a PID or 'meta.
|
||||
|
||||
;; VM private states
|
||||
(struct world (next-pid ;; PID
|
||||
pending-action-queue ;; (Queueof (Cons Label Action))
|
||||
runnable-pids ;; (Setof PID)
|
||||
routing-table ;; (Matcherof (Setof Label))
|
||||
process-table ;; (HashTable PID Process)
|
||||
environment-interests ;; (Matcherof (set 'meta))
|
||||
) #:transparent)
|
||||
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
|
||||
(define (event? x) (or (patch? x)))
|
||||
(define (action? x) (or (event? x) (spawn? x) (quit? x)))
|
||||
|
||||
(define (meta-label? x) (eq? x 'meta))
|
||||
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
|
||||
(define (ensure-transition v)
|
||||
(if (or (not v) (transition? v))
|
||||
v
|
||||
(raise (exn:fail:contract (format "Expected transition (or #f); got ~v" v)
|
||||
(current-continuation-marks)))))
|
||||
|
||||
(define (clean-transition t)
|
||||
(and t (transition (transition-state t) (clean-actions (transition-actions t)))))
|
||||
|
||||
(define (clean-actions actions)
|
||||
(filter action? (flatten actions)))
|
||||
|
||||
(define (deliver-event e pid p w)
|
||||
(invoke-process pid
|
||||
(lambda () ((process-behavior p) e (process-state p)))
|
||||
(lambda (t) (apply-transition pid t w))
|
||||
(lambda (exn) (kill-process pid exn w))))
|
||||
|
||||
(define (invoke-process pid thunk k-ok k-exn)
|
||||
(define-values (ok? result)
|
||||
(with-handlers ([(lambda (exn) #t) (lambda (exn) (values #f exn))])
|
||||
(values #t (clean-transition
|
||||
(ensure-transition
|
||||
(with-continuation-mark 'minimart-process pid (thunk)))))))
|
||||
(if ok?
|
||||
(k-ok result)
|
||||
(k-exn result)))
|
||||
|
||||
(define (kill-process pid maybe-exn w)
|
||||
(define pt (world-process-table w))
|
||||
(match (hash-ref pt pid)
|
||||
[#f w]
|
||||
[(process interests _ _)
|
||||
(enqueue-actions (struct-copy world w [process-table (hash-remove pt pid)])
|
||||
pid
|
||||
(list (patch (matcher-empty) interests)))]))
|
||||
|
||||
(define (mark-pid-runnable w pid)
|
||||
(struct-copy world w [runnable-pids (set-add (world-runnable-pids w) pid)]))
|
||||
|
||||
(define (apply-transition pid t w)
|
||||
(match t
|
||||
[#f w]
|
||||
[(transition new-state new-actions)
|
||||
(let* ((w (transform-process pid w (lambda (p) (struct-copy process p [state new-state])))))
|
||||
(enqueue-actions (mark-pid-runnable w pid) pid new-actions))]))
|
||||
|
||||
(define (transform-process pid w fp)
|
||||
(define pt (world-process-table w))
|
||||
(match (hash-ref pt pid)
|
||||
[#f w]
|
||||
[p (struct-copy world w [process-table (hash-set pt pid (fp p))])]))
|
||||
|
||||
(define (enqueue-actions w label actions)
|
||||
(struct-copy world w
|
||||
[pending-action-queue
|
||||
(queue-append-list (world-pending-action-queue w)
|
||||
(for/list [(a actions)] (cons label a)))]))
|
||||
|
||||
(define (spawn-world . boot-actions)
|
||||
(spawn world-handle-event
|
||||
(lambda () (transition (world 0
|
||||
(make-queue)
|
||||
(set)
|
||||
(matcher-empty)
|
||||
(hash)
|
||||
(matcher-empty))
|
||||
'()))))
|
||||
|
||||
(define (transition-bind k t0)
|
||||
(match-define (transition state0 actions0) t0)
|
||||
(match (k state0)
|
||||
[#f t0]
|
||||
[(transition state1 actions1) (transition state1 (cons actions0 actions1))]))
|
||||
|
||||
(define (sequence-transitions t0 . steps)
|
||||
(foldl transition-bind t0 steps))
|
||||
|
||||
(define (inert? w)
|
||||
(and (queue-empty? (world-pending-action-queue w))
|
||||
(set-empty? (world-runnable-pids w))))
|
||||
|
||||
(define (world-handle-event e w)
|
||||
(if (or e (not (inert? w)))
|
||||
(sequence-transitions (transition w '())
|
||||
(inject-event e)
|
||||
perform-actions
|
||||
step-children)
|
||||
(step-children w)))
|
||||
|
||||
(define ((inject-event e) w)
|
||||
(match e
|
||||
[#f w]
|
||||
[(? patch? delta)
|
||||
(enqueue-actions w 'meta (list (lift-patch delta)))]))
|
||||
|
||||
(define (perform-actions w)
|
||||
(for/fold ([wt (transition (struct-copy world w [pending-action-queue (make-queue)]) '())])
|
||||
((entry (in-list (queue->list (world-pending-action-queue w)))))
|
||||
(match-define [cons label a] entry)
|
||||
(transition-bind (perform-action label a) wt)))
|
||||
|
||||
(define ((perform-action label a) w)
|
||||
(match a
|
||||
[(spawn behavior boot)
|
||||
(define new-pid (world-next-pid w))
|
||||
(invoke-process new-pid
|
||||
boot
|
||||
(lambda (initial-t)
|
||||
(match-define (transition initial-state initial-actions) initial-t)
|
||||
(define new-p (process (matcher-empty) behavior initial-state))
|
||||
(define new-w
|
||||
(struct-copy world w
|
||||
[next-pid (+ new-pid 1)]
|
||||
[process-table
|
||||
(hash-set (world-process-table w) new-pid new-p)]))
|
||||
(mark-pid-runnable (enqueue-actions new-w new-pid initial-actions)
|
||||
new-pid))
|
||||
(lambda (exn) (kill-process new-pid exn w)))]
|
||||
[(quit) (kill-process label #f w)]
|
||||
[(? patch? delta-orig)
|
||||
(define p (hash-ref (world-process-table w) label))
|
||||
(define old-interests (cond
|
||||
[p (process-interests p)]
|
||||
[(meta-label? label) (world-environment-interests w)]
|
||||
[else (matcher-empty)]))
|
||||
(define old-routing-table (world-routing-table w))
|
||||
(define delta (limit-patch (label-patch delta-orig label) old-interests))
|
||||
(define delta-aggregate (compute-patch-aggregate delta label old-routing-table))
|
||||
(define new-routing-table (apply-patch label old-routing-table delta))
|
||||
(define affected-pids (compute-affected-pids ...
|
||||
|
||||
(define (step-children w)
|
||||
(define runnable-pids (world-runnable-pids w))
|
||||
(if (set-empty? runnable-pids)
|
||||
#f ;; world is inert.
|
||||
(transition (for/fold ([w (struct-copy world w [runnable-pids (set)])])
|
||||
[(pid (in-set runnable-pids))]
|
||||
(define p (hash-ref (world-process-table w) pid (lambda () #f)))
|
||||
(if (not p) w (deliver-event #f pid p w)))
|
||||
'())))
|
||||
|
|
@ -0,0 +1,81 @@
|
|||
#lang racket/base
|
||||
|
||||
(provide make-queue
|
||||
queue?
|
||||
enqueue
|
||||
enqueue-all
|
||||
queue-prepare-for-dequeue
|
||||
dequeue
|
||||
list->queue
|
||||
queue->list
|
||||
queue-length
|
||||
queue-empty?
|
||||
queue-append
|
||||
queue-append-list
|
||||
queue-extract)
|
||||
|
||||
(struct queue (head tail) #:transparent)
|
||||
|
||||
(define (make-queue)
|
||||
(queue '() '()))
|
||||
|
||||
(define (enqueue q v)
|
||||
(queue (queue-head q)
|
||||
(cons v (queue-tail q))))
|
||||
|
||||
(define (enqueue-all q v)
|
||||
(queue (queue-head q)
|
||||
(append (reverse v) (queue-tail q))))
|
||||
|
||||
(define (queue-prepare-for-dequeue q)
|
||||
(if (null? (queue-head q))
|
||||
(queue (reverse (queue-tail q)) '())
|
||||
q))
|
||||
|
||||
(define (dequeue q)
|
||||
(let ((q1 (queue-prepare-for-dequeue q)))
|
||||
(values (car (queue-head q1))
|
||||
(queue (cdr (queue-head q1)) (queue-tail q1)))))
|
||||
|
||||
(define (list->queue xs)
|
||||
(queue xs '()))
|
||||
|
||||
(define (queue->list q)
|
||||
(append (queue-head q) (reverse (queue-tail q))))
|
||||
|
||||
(define (queue-length q)
|
||||
(+ (length (queue-head q))
|
||||
(length (queue-tail q))))
|
||||
|
||||
(define (queue-empty? q)
|
||||
(and (null? (queue-head q))
|
||||
(null? (queue-tail q))))
|
||||
|
||||
(define (queue-append q1 q2)
|
||||
(queue (append (queue-head q1)
|
||||
(reverse (queue-tail q1))
|
||||
(queue-head q2))
|
||||
(queue-tail q2)))
|
||||
|
||||
(define (queue-append-list q1 xs)
|
||||
(queue (queue-head q1)
|
||||
(append (reverse xs) (queue-tail q1))))
|
||||
|
||||
(define (queue-extract q predicate [default-value #f])
|
||||
(let search-head ((head (queue-head q))
|
||||
(rejected-head-rev '()))
|
||||
(cond
|
||||
((null? head) (let search-tail ((tail (reverse (queue-tail q)))
|
||||
(rejected-tail-rev '()))
|
||||
(cond
|
||||
((null? tail) (values default-value q))
|
||||
((predicate (car tail)) (values (car tail)
|
||||
(queue (queue-head q)
|
||||
(append (reverse (cdr tail))
|
||||
rejected-tail-rev))))
|
||||
(else (search-tail (cdr tail) (cons (car tail) rejected-tail-rev))))))
|
||||
((predicate (car head)) (values (car head)
|
||||
(queue (append (reverse rejected-head-rev)
|
||||
(cdr head))
|
||||
(queue-tail q))))
|
||||
(else (search-head (cdr head) (cons (car head) rejected-head-rev))))))
|
||||
|
|
@ -0,0 +1,138 @@
|
|||
#lang racket/base
|
||||
;; Patches to sets of interests
|
||||
|
||||
(provide (struct-out patch)
|
||||
(struct-out observe)
|
||||
(struct-out at-meta)
|
||||
lift-patch
|
||||
drop-patch
|
||||
limit-patch
|
||||
apply-patch
|
||||
compute-patch
|
||||
|
||||
pretty-print-patch)
|
||||
|
||||
(require racket/set)
|
||||
(require racket/match)
|
||||
(require "route.rkt")
|
||||
|
||||
(module+ test (require rackunit))
|
||||
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
|
||||
;; Patches
|
||||
(struct patch (added removed) #:prefab)
|
||||
|
||||
;; Claims, Interests, and Locations
|
||||
(struct observe (pattern) #:prefab)
|
||||
(struct at-meta (claim) #:prefab)
|
||||
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
|
||||
(define (lift-patch p)
|
||||
(match-define (patch in out) p)
|
||||
(patch (pattern->matcher #t (at-meta (embedded-matcher in)))
|
||||
(pattern->matcher #t (at-meta (embedded-matcher out)))))
|
||||
|
||||
(define at-meta-proj (compile-projection (at-meta (?!))))
|
||||
|
||||
(define (drop-interests pi)
|
||||
(matcher-project pi at-meta-proj
|
||||
#:project-success (lambda (v) #t)
|
||||
#:combiner (lambda (v1 v2) #t)))
|
||||
|
||||
(define (drop-patch p)
|
||||
(match-define (patch in out) p)
|
||||
(patch (drop-interests in)
|
||||
(drop-interests out)))
|
||||
|
||||
(define (strip-interests g)
|
||||
(matcher-relabel g (lambda (v) #t)))
|
||||
|
||||
(define (label-interests g label)
|
||||
(matcher-relabel g (lambda (v) label)))
|
||||
|
||||
(define (label-patch p label)
|
||||
(patch (label-interests (patch-added p) label)
|
||||
(label-interests (patch-removed p) label)))
|
||||
|
||||
(define (limit-patch p bound)
|
||||
(match-define (patch in out) p)
|
||||
(patch (matcher-subtract in bound #:combiner (lambda (v1 v2) #f))
|
||||
(matcher-intersect out bound #:combiner (lambda (v1 v2) v1))))
|
||||
|
||||
(define (apply-patch base p)
|
||||
(match-define (patch in out) p)
|
||||
(matcher-union (matcher-subtract base out) in))
|
||||
|
||||
(define (unapply-patch base p)
|
||||
(match-define (patch in out) p)
|
||||
(matcher-union (matcher-subtract base in) out))
|
||||
|
||||
(define (compose-patch p2 p1) ;; p2 after p1
|
||||
(match-define (patch in1 out1) p1)
|
||||
(patch (apply-patch in1 p2)
|
||||
(unapply-patch out1 p2)))
|
||||
|
||||
(define (compute-patch old-base new-base)
|
||||
(patch (matcher-subtract new-base old-base)
|
||||
(matcher-subtract old-base new-base)))
|
||||
|
||||
(define (pretty-print-patch p)
|
||||
(match-define (patch in out) p)
|
||||
(printf "<<<<<<<< Removed:\n")
|
||||
(pretty-print-matcher out)
|
||||
(printf "======== Added:\n")
|
||||
(pretty-print-matcher in)
|
||||
(printf ">>>>>>>>\n"))
|
||||
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
|
||||
(module+ test
|
||||
(define SP (set 'P))
|
||||
(define m0 (matcher-empty))
|
||||
(define ma (pattern->matcher SP 'a))
|
||||
(define mb (pattern->matcher SP 'b))
|
||||
(define mc (pattern->matcher SP 'c))
|
||||
(define mab (matcher-union ma mb))
|
||||
(define mbc (matcher-union mb mc))
|
||||
(define m* (pattern->matcher SP ?))
|
||||
|
||||
(printf "\nmab:\n")
|
||||
(void (pretty-print-matcher mab))
|
||||
|
||||
(printf "\ncompute-patch ma mb:\n")
|
||||
(void (pretty-print-patch (compute-patch ma mb)))
|
||||
|
||||
(printf "\nlimit-patch m*/m0 mab:\n")
|
||||
(void (pretty-print-patch (limit-patch (patch m* m0) mab)))
|
||||
|
||||
(printf "\nlimit-patch m0/m* mab:\n")
|
||||
(void (pretty-print-patch (limit-patch (patch m0 m*) mab)))
|
||||
|
||||
(printf "\napply mb (limit m*/m0 mab):\n")
|
||||
(void (pretty-print-matcher (apply-patch mb (limit-patch (patch m* m0) mab))))
|
||||
|
||||
(printf "\nlimit mbc/ma ma:\n")
|
||||
(void (pretty-print-patch (limit-patch (patch mbc ma) ma)))
|
||||
|
||||
(printf "\nlimit mab/mc ma:\n")
|
||||
(void (pretty-print-patch (limit-patch (patch mab mc) ma)))
|
||||
|
||||
(printf "\nlimit mc/mab ma:\n")
|
||||
(void (pretty-print-patch (limit-patch (patch mc mab) ma)))
|
||||
|
||||
(printf "\nlift mc/mab:\n")
|
||||
(void (pretty-print-patch (lift-patch (patch mc mab))))
|
||||
|
||||
(printf "\ndrop after lift mc/mab:\n")
|
||||
(void (pretty-print-patch (drop-patch (lift-patch (patch mc mab)))))
|
||||
|
||||
(printf "\ncompose mbc/m0 after lift mc/mab:\n")
|
||||
(void (pretty-print-patch (compose-patch (patch mbc m0)
|
||||
(lift-patch (patch mc mab)))))
|
||||
|
||||
(printf "\ndrop (compose mbc/m0 after lift mc/mab):\n")
|
||||
(void (pretty-print-patch (drop-patch (compose-patch (patch mbc m0)
|
||||
(lift-patch (patch mc mab))))))
|
||||
)
|
||||
File diff suppressed because it is too large
Load Diff
|
|
@ -0,0 +1,209 @@
|
|||
#lang racket/base
|
||||
;; Treaps, which have the lovely property of *canonical representation*.
|
||||
;;
|
||||
;; We take care to preserve an additional invariant:
|
||||
;; - if n is a left child of m, then n's priority <= m's priority, and
|
||||
;; - if n is a right child of m, then n's priority < m's priority.
|
||||
;;
|
||||
;; Further, we explicitly canonicalize N instances, so eq? works to compare treaps by value.
|
||||
|
||||
(provide treap?
|
||||
treap-size
|
||||
treap-empty
|
||||
treap-empty?
|
||||
treap-insert
|
||||
treap-delete
|
||||
treap-get
|
||||
treap-keys
|
||||
treap-values
|
||||
treap-to-alist
|
||||
treap-has-key?
|
||||
|
||||
treap-height)
|
||||
|
||||
(require racket/set)
|
||||
(require racket/match)
|
||||
|
||||
(require "canonicalize.rkt")
|
||||
;; (define canonicalize values)
|
||||
|
||||
(struct N (key value priority left right) #:transparent
|
||||
#:methods gen:equal+hash
|
||||
[(define (equal-proc a b =?)
|
||||
(match-define (N ak av ap al ar) a)
|
||||
(match-define (N bk bv bp bl br) b)
|
||||
(and (eq? al bl)
|
||||
(eq? ar br)
|
||||
(= ap bp)
|
||||
(=? ak bk)
|
||||
(=? av bv)))
|
||||
(define (hash-proc a h)
|
||||
(match-define (N ak av ap al ar) a)
|
||||
(+ (eq-hash-code al)
|
||||
(eq-hash-code ar)
|
||||
(h ap)
|
||||
(h ak)
|
||||
(h av)))
|
||||
(define (hash2-proc a h)
|
||||
(match-define (N ak av ap al ar) a)
|
||||
(bitwise-xor (eq-hash-code al)
|
||||
(eq-hash-code ar)
|
||||
(h ap)
|
||||
(h ak)
|
||||
(h av)))])
|
||||
|
||||
(struct L () #:transparent)
|
||||
|
||||
(struct treap (order root size) #:transparent)
|
||||
|
||||
;; The singleton "empty" leaf sentinel
|
||||
(define L0 (L))
|
||||
|
||||
(define (treap-empty o) (treap o L0 0))
|
||||
|
||||
(define (treap-empty? t) (zero? (treap-size t)))
|
||||
|
||||
(define (default-priority key)
|
||||
;; Loosely based on a restriction of murmur32 v3
|
||||
(define c1 #xcc9e2d51)
|
||||
(define c2 #x1b873593)
|
||||
(define r1 15)
|
||||
(define r2 13)
|
||||
(define m 5)
|
||||
(define n #xe6546b64)
|
||||
(define k (* (equal-hash-code key) c1))
|
||||
(define hash0 (* c2 (bitwise-ior (arithmetic-shift k r1) (arithmetic-shift k (- 32 r1)))))
|
||||
(define hash1
|
||||
(+ n (* m (bitwise-ior (arithmetic-shift hash0 r2) (arithmetic-shift hash0 (- 32 r2))))))
|
||||
(define hash2
|
||||
(bitwise-and #xffffffff (* #x85ebca6b (bitwise-xor hash1 (arithmetic-shift hash1 -16)))))
|
||||
(define hash3
|
||||
(bitwise-and #xffffffff (* #xc2b2ae35 (bitwise-xor hash2 (arithmetic-shift hash2 -13)))))
|
||||
(bitwise-xor hash3 (arithmetic-shift hash3 -16)))
|
||||
|
||||
(define (treap-insert t key value [priority (default-priority key)])
|
||||
(match-define (treap order root oldsize) t)
|
||||
(define newsize (+ oldsize 1)) ;; WARNING: mutated below!
|
||||
(define newroot
|
||||
(let walk ((n root))
|
||||
(match n
|
||||
[(L)
|
||||
(canonicalize (N key value priority L0 L0))]
|
||||
[(N k v p left right)
|
||||
(case (order key k)
|
||||
[(<) (match (walk left) [(N K V P l r) (rotate K V P k v p l r right)])]
|
||||
[(>) (match (walk right) [(N K V P l r) (rotate k v p K V P left l r)])]
|
||||
[(=)
|
||||
(set! newsize (- newsize 1)) ;; we are *REPLACING* an existing value
|
||||
(let merge ((left left) (right right))
|
||||
(cond
|
||||
[(priority>= priority left)
|
||||
(if (priority> priority right)
|
||||
(canonicalize (N key value priority left right))
|
||||
(replace-left right (merge left (N-left right))))]
|
||||
[(priority> priority right)
|
||||
(replace-right left (merge (N-right left) right))]
|
||||
[else
|
||||
(if (priority> (N-priority left) right)
|
||||
(replace-right left (merge (N-right left) right))
|
||||
(replace-left right (merge left (N-left right))))]))])])))
|
||||
(canonicalize (treap order newroot newsize)))
|
||||
|
||||
(define (replace-left n x)
|
||||
(canonicalize
|
||||
(match n
|
||||
[(N k v p _ r)
|
||||
(N k v p x r)])))
|
||||
|
||||
(define (replace-right n x)
|
||||
(canonicalize
|
||||
(match n
|
||||
[(N k v p l _)
|
||||
(N k v p l x)])))
|
||||
|
||||
(define (priority> p1 n)
|
||||
(match n
|
||||
[(L) #t]
|
||||
[(N _ _ p2 _ _) (> p1 p2)]))
|
||||
|
||||
(define (priority>= p1 n)
|
||||
(match n
|
||||
[(L) #t]
|
||||
[(N _ _ p2 _ _) (>= p1 p2)]))
|
||||
|
||||
(define (rotate k1 v1 p1 k2 v2 p2 tl tm tr)
|
||||
(if (> p1 p2)
|
||||
(canonicalize (N k1 v1 p1 tl (canonicalize (N k2 v2 p2 tm tr))))
|
||||
(canonicalize (N k2 v2 p2 (canonicalize (N k1 v1 p1 tl tm)) tr))))
|
||||
|
||||
(define (treap-delete t key)
|
||||
(match-define (treap order root oldsize) t)
|
||||
(define newsize oldsize)
|
||||
(define newroot
|
||||
(let walk ((n root))
|
||||
(match n
|
||||
[(L) L0]
|
||||
[(N k v p left right)
|
||||
(case (order key k)
|
||||
[(<) (canonicalize (N k v p (walk left) right))]
|
||||
[(>) (canonicalize (N k v p left (walk right)))]
|
||||
[(=)
|
||||
(set! newsize (- newsize 1)) ;; we found the value to remove
|
||||
(let merge ((left left) (right right))
|
||||
(cond
|
||||
[(L? left) right]
|
||||
[(L? right) left]
|
||||
[else
|
||||
(match-define (N lk lv lp ll lr) left)
|
||||
(match-define (N rk rv rp rl rr) right)
|
||||
(canonicalize
|
||||
(if (< lp rp)
|
||||
(N lk lv lp ll (merge lr right))
|
||||
(N rk rv rp (merge left rl) rr)))]))])])))
|
||||
(canonicalize (treap order newroot newsize)))
|
||||
|
||||
(define (treap-get t key [on-missing (lambda () #f)])
|
||||
(define order (treap-order t))
|
||||
(let walk ((n (treap-root t)))
|
||||
(match n
|
||||
[(L) (on-missing)]
|
||||
[(N k v _ left right)
|
||||
(case (order key k)
|
||||
[(<) (walk left)]
|
||||
[(>) (walk right)]
|
||||
[(=) v])])))
|
||||
|
||||
(define (treap-keys t #:empty-set [empty-set (set)])
|
||||
(let walk ((n (treap-root t)) (acc empty-set))
|
||||
(match n
|
||||
[(L) acc]
|
||||
[(N k _ _ left right) (walk left (walk right (set-add acc k)))])))
|
||||
|
||||
(define (treap-values t)
|
||||
(let walk ((n (treap-root t)) (acc '()))
|
||||
(match n
|
||||
[(L) acc]
|
||||
[(N k _ _ left right) (walk left (cons k (walk right acc)))])))
|
||||
|
||||
(define (treap-to-alist t)
|
||||
(let walk ((n (treap-root t)) (acc '()))
|
||||
(match n
|
||||
[(L) acc]
|
||||
[(N k v _ left right) (walk left (cons (cons k v) (walk right acc)))])))
|
||||
|
||||
(define (treap-has-key? t key)
|
||||
(define order (treap-order t))
|
||||
(let walk ((n (treap-root t)))
|
||||
(match n
|
||||
[(L) #f]
|
||||
[(N k v _ left right)
|
||||
(case (order key k)
|
||||
[(<) (walk left)]
|
||||
[(>) (walk right)]
|
||||
[(=) #t])])))
|
||||
|
||||
(define (treap-height t)
|
||||
(let walk ((n (treap-root t)))
|
||||
(match n
|
||||
[(L) 0]
|
||||
[(N _ _ _ l r) (+ 1 (max (walk l) (walk r)))])))
|
||||
Loading…
Reference in New Issue