0. (provide insert lookup btree)
1.  
2. (struct Btree (tree = > <) #:transparent)
3. (struct Empty ())
4. (struct Node (key value size left right) #:transparent)
5.  
6. (define (btree = > <)
7.   (Btree (Empty) = > <))
8.  
9. (define (node-size n)
10.   (match n
11.     [(Empty) 0]
12.     [(Node _ _ s _ _) s]))
13.  
14. (define (insert-aux tree k v = > <)
15.   (match tree
16.     [(Node tk tvs ts tl tr)
17.      (cond
18.        [(= tk k) (Node tk (set-add tvs v) ts tl tr)]
19.        [(> tk k) (let* ([new-left (insert-aux tl k v = > <)]
20.                         [new-size (+ 1 (node-size new-left) (node-size tr))])
21.                    (Node tk tvs new-size new-left tr))]
22.        [(< tk k) (let* ([new-right (insert-aux tr k v = > <)]
23.                         [new-size (+ 1 (node-size tl) (node-size new-right))])
24.                    (Node tk tvs new-size tl new-right))])]
25.     [(Empty) (Node k (set v) 1 (Empty) (Empty))]))
26.  
27. (define (insert btree k v)
28.   (match-let ([(Btree tree = > <) btree])
29.     (Btree (insert-aux tree k v = > <) = > <)))
30.  
31. (define (insert*  btree . inits)
32.   (foldl (lambda (x m) (insert m (first x) (second x))) btree inits))
33.  
34.  
35. (define (lookup-aux tree k = > <)
36.   (match tree
37.     [(Node tk tvs ts tl tr)
38.      (cond
39.        [(= tk k) tvs]
40.        [(> tk k) (lookup-aux tl k = > <)]
41.        [(< tk k) (lookup-aux tr k = > <)])]
42.     [(Empty) (set)]))
43.  
44. (define (lookup btree k)
45.   (match-let ([(Btree tree = > <) btree])
46.     (lookup-aux tree k = > <)))
47.  
48. (define (yield-tree yield tree)
49.   (match tree
50.     [(Node tk tvs ts tl tr)
51.      (yield-tree yield tl)
52.      (yield (list tk tvs))
53.      (yield-tree yield tr)]
54.     [(Empty) (void)]))
55.  
56. (define (btree->vector bt)
57.   (let ([i 0]
58.         [buffer (make-vector (node-size (Btree-tree bt)))])
59.     (yield-tree
60.      (lambda (x)
61.        (vector-set! buffer i x)
62.        (set! i (add1 i))
63.        i)
64.      (Btree-tree bt))
65.     buffer))
66.  
67. (define (btree->alist bt)
68.   (vector->list (btree->vector bt)))
69.  
70. (define (alist->btree alist bt)
71.   (match-let ([(Btree tree = > <) bt])
72.       (foldl (lambda (pair tree)
73.                (insert tree (car pair) (cadr pair)))
74.              bt
75.              alist)))
76.  
77. (define (partial-lookup-aux tree k = > <)
78.   (match tree
79.     [(Node tk tvs ts tl tr)
80.      `(cond
81.         [(= ,tk ,k) ,tvs]
82.         [(> ,tk ,k) ,(partial-lookup-aux tl k = > <)]
83.         [(< ,tk ,k) ,(partial-lookup-aux tr k = > <)])]
84.     [(Empty) (set)]))
85.  
86. (define (partial-lookup btree k)
87.   (match-let ([(Btree tree = > <) btree])
88.     (partial-lookup-aux tree k = > <)))
89.  
90.  
91. (define test-cases '((1 a) (2 b) (3 c)))
92. (define tree1 (alist->btree test-cases (btree = > <)))
93. (define pevald #`(lambda (x) #,(partial-lookup tree1 #'x)))
94. (displayln pevald)
95. (define runnable (eval pevald))
96. (displayln (map runnable '(1 2 3)))

=>