simplify radix-tree to map keys to lists of data

private/radix-tree.rkt

@@ -2,14 +2,13 @@
 
 (require "iputil.rkt")
 
-(provide make-rt rt-update! rt-lookup rt-dump rt-flatten)
+(provide make-rt rt-add! rt-del! rt-lookup rt-dump rt-flatten)
 
 ;; Radix tree implementation for efficient routing lookups
 ;; This module provides a radix tree type indexed by bit-lists (lists of booleans representing IP
-;; address bits), which supports arbitary node data at any tree depth. Lookup always find the most
+;; address bits), which supports arbitary node data at any tree depth. Lookup finds all the matches.
-;; specific match.
 
-;; An RT is a (rt-node RTedge RTedge Any)
+;; An RT is a (rt-node RTedge RTedge [Listof Any])
 ;; An RTkey is a [Listof Bool]
 ;; An RTedge is a (rt-edge RTkey RT)
 (struct rt-node [edge0 edge1 data] #:transparent #:mutable)
@@ -17,13 +16,10 @@
 ;; (represented by whether this was an edge0 or edge1 in the parent node)
 (struct rt-edge [label target] #:transparent)
 
-;; A unique symbol representing no data associated with a certain node
-(define empty-node-data '()) ;(gensym 'MEOW)
-
 ;; -> RT
 ;; Creates a new empty RT
 (define (make-rt)
-  (rt-node #f #f empty-node-data))
+  (rt-node #f #f '()))
 
 ;; Helper functions for rt-node struct access based on whether the edge is 1 or 0
 (define (rt-getter bit) (if bit rt-node-edge1 rt-node-edge0))
@@ -64,14 +60,13 @@
          [next-edge (list 'partial node next-edge next-common-len key (cons node visited))]
          [else (list 'no-match node key (cons node visited))]))]))
 
-;; RT RTkey (Any -> Any) (-> Any)
+;; RT RTkey Any -> Void
-;; Updates the radix tree for the given key, using updater and failure-result like the standard
+;; Updates the radix tree for the given key, adding the elem to the data at that key.
-;; racket -update! abstraction
+(define (rt-add! node key elem)
-(define (rt-update! node key updater failure-result)
   (define (insert-node! node key)
     (let* ([bit (first key)]
            [setter! (rt-setter bit)])
-      (setter! node (rt-edge key (rt-node #f #f (updater (failure-result)))))))
+      (setter! node (rt-edge key (rt-node #f #f (list elem))))))
   (define (split-node! node key orig-edge prefix-len)
     (let* ([bit (first key)]
            [setter! (rt-setter bit)]
@@ -82,54 +77,52 @@
         (let* ([next-bit (list-ref orig-label prefix-len)]
                [common-node (rt-node (if next-bit #f new-orig-edge)
                                      (if next-bit new-orig-edge #f)
-                                     (updater (failure-result)))]
+                                     (list elem))]
                [common-edge (rt-edge (take key prefix-len) common-node)])
           (setter! node common-edge))
         (let* ([new-insert-edge (rt-edge (drop key prefix-len)
-                                         (rt-node #f #f (updater (failure-result))))]
+                                         (rt-node #f #f (list elem)))]
                [diff-bit (list-ref key prefix-len)]
                [common-node (rt-node (if diff-bit new-orig-edge new-insert-edge)
                                      (if diff-bit new-insert-edge new-orig-edge)
-                                     empty-node-data)]
+                                     '())]
                [common-edge (rt-edge (take key prefix-len) common-node)])
           (setter! node common-edge)))))
   (match (rt-partial-iterate node key)
     [(list 'exact node)
-     (set-rt-node-data!
+     (set-rt-node-data! node
-       node
+                        (cons elem (rt-node-data node)))]
-       (let ([d (rt-node-data node)])
-         (updater
-           (if (eq? d empty-node-data) (failure-result) d))))]
     [(list 'partial node orig-edge prefix-len partial-key visited)
      (split-node! node partial-key orig-edge prefix-len)]
     [(list 'no-match node partial-key visited)
      (insert-node! node partial-key)]))
 
-;; RT RTkey (-> Any) -> Any
+;; RT RTKey (Any -> Boolean) -> Void
-;; Looks up the most specific match for the given key in the tree, using failure-result if nothing
+;; Delete all entries under the given key
-;; was found
+(define (rt-del! node key del?)
-(define (rt-lookup node key failure-result)
+  (for ([node (in-list (match (rt-partial-iterate node key)
-  (define (find-first-with-data nodes)
+                         [(list 'exact node) (list node)]
-    (or (for/first ([node (in-list nodes)]
+                         [(list _ ... visited) visited]))])
-                    #:when (not (eq? empty-node-data (rt-node-data node))))
+    (set-rt-node-data! node
-          (rt-node-data node))
+                       (filter (negate del?)
-        (failure-result)))
+                               (rt-node-data node)))))
-  (find-first-with-data
+
-   (match (rt-partial-iterate node key)
+;; RT RTkey -> [Listof Any]
-     [(list 'exact node)
+;; Looks up all the matches for the given key in the tree, ordered from most-specific to
-      (list node)]
+;; least-specific.
-     [(list _ ... visited)
+(define (rt-lookup node key)
-      visited])))
+  (match (rt-partial-iterate node key)
+    [(list 'exact node) (rt-node-data node)]
+    [(list _ ... visited) (append-map rt-node-data visited)]))
 
 ;; RT -> [Listof Any]
 ;; Converts the tree into a flat list of all contained node data
 (define (rt-flatten node)
-  (define (flatten-edge e) (if e (rt-flatten (rt-edge-target e)) '()))
+  (define (flatten-edge e)
-  (let* ([e1 (rt-node-edge0 node)]
+    (if e (rt-flatten (rt-edge-target e)) '()))
-         [e2 (rt-node-edge1 node)]
+  (append (rt-node-data node)
-         [data (rt-node-data node)]
+          (flatten-edge (rt-node-edge0 node))
-         [rst (apply append (map flatten-edge (list e1 e2)))])
+          (flatten-edge (rt-node-edge1 node))))
-    (if (equal? data empty-node-data) rst (cons data rst))))
 
 ;; RT [Str] ->
 ;; Debug print function that dumps the tree to current-output-port in a vaguely human-readable
@@ -145,27 +138,30 @@
     (displayln (format "~a  edge1 ~a" prefix (rt-edge-label edge1)))
     (rt-dump (rt-edge-target edge1) (string-append prefix "  "))))
 
-(define test (make-rt))
-(define (str->bl x)
-    (map (curry equal? #\1) (string->list x)))
-(define (test-insert! x)
-  (rt-update!
-    test
-    (str->bl x)
-    (lambda (_) x)
-    (lambda () x)))
-; (test-insert! "0001")
-; (test-insert! "")
-; (rt-dump test)
-; (test-insert! "0001")
-; (test-insert! "000")
-; (test-insert! "0")
-; (rt-dump test)
-; (rt-partial-iterate test (str->bl "0001"))
-; (rt-lookup test (str->bl "0000") (lambda () (error "bad")))
 
-; (test-insert! "0001")
+(module+ test
-; (test-insert! "1000")
+
-; (test-insert! "1010")
+  (define (str->bl x)
-; (test-insert! "0011")
+    (map (curry equal? #\1) (string->list x)))
-; (test-insert! "0000")
+
+  (define test (make-rt))
+
+  (define (test-insert! x)
+    (rt-add! test (str->bl x) x))
+
+  (test-insert! "0001")
+  (test-insert! "")
+  (rt-dump test)
+  (test-insert! "0001")
+  (test-insert! "000")
+  (test-insert! "0")
+  (rt-dump test)
+  (rt-partial-iterate test (str->bl "0001"))
+  (rt-lookup test (str->bl "0000"))
+
+  ; (test-insert! "0001")
+  ; (test-insert! "1000")
+  ; (test-insert! "1010")
+  ; (test-insert! "0011")
+  ; (test-insert! "0000")
+  )

router

@@ -34,30 +34,25 @@
   (define flipped-net (subnet-flip-last (route-subnet r)))
   (define flipped-bl (subnet->bl flipped-net))
   (define flipped-route (struct-copy route r [subnet flipped-net]))
-  (define aggregate-route (rt-lookup rt flipped-bl (lambda () '())))
   (cond
-    [(member (cons peer flipped-route) aggregate-route)
+    [(member (cons peer flipped-route)
-     (define new-aggregate-route (remove (cons peer flipped-route) aggregate-route))
+             (rt-lookup rt flipped-bl))
-     (rt-update! rt flipped-bl (lambda (_) new-aggregate-route) (lambda () '()))
+     (define r* (struct-copy route r [subnet (subnet-drop-last (route-subnet r))]))
-     (router-add! rt (struct-copy route r [subnet (subnet-drop-last (route-subnet r))]) peer)]
+     (rt-del! rt flipped-bl (curry equal? (cons peer flipped-route)))
-    [else (rt-update! rt
+     (router-add! rt r* peer)]
-                      (subnet->bl (route-subnet r))
+    [else
-                      (lambda (rst) (cons (cons peer r) rst))
+     (rt-add! rt
-                      (lambda () '()))]))
+              (subnet->bl (route-subnet r))
+              (cons peer r))]))
 
 ;; Router Route Peer -> Void
 ;; Tries to find the given route and removes it from the routing database
 (define (router-revoke! rt subnet peer)
-  ;; [Listof [Cons Peer Route]] -> [Listof [Cons Peer Route]]
+  (rt-del! rt
-  ;; Removes route r from the given list, if present
+           (subnet->bl subnet)
-  (define (remove-route routes)
+           (lambda (el)
-    (filter (lambda (el) (not (and (equal? (car el) peer)
+             (and (equal? (car el) peer)
-                                   (equal? (route-subnet (cdr el)) subnet))))
+                  (equal? (route-subnet (cdr el)) subnet)))))
-            routes))
-  (rt-update! rt
-              (subnet->bl subnet)
-              (lambda (lst) (remove-route lst))
-              (lambda () '())))
 
 ;; IP -> IP
 ;; Calculates our local IP on the subnet with peer p
@@ -83,6 +78,7 @@
               [y2 (mapper r2)])
             (cond [(< x2 y2) (meow #t)]
                   [(> x2 y2) (meow #f)])))
+      (cmp (compose - subnet-mask route-subnet))
       (cmp (compose - route-pref))
       (cmp (lambda (x) (if (route-self-origin? x) 0 1)))
       (cmp (compose length route-as-path))
@@ -93,24 +89,19 @@
 ;; Router IP -> (U Peer #f)
 ;; Finds the most specific route for the given IP
 (define (router-find-best rt src-ip)
-  (match (sort (rt-lookup rt
+  (match (sort (rt-lookup rt (ip->bl src-ip))
-                        (ip->bl src-ip)
+               route<
-                        (λ () '()))
+               #:key cdr)
-             route<
-             #:key cdr)
     [(list* (cons peer _) _) peer]
     [_ #f]))
 
 ;; Router -> Msg
 ;; Creates a table message with a dump of the current routing table
 (define (router-dump rt src dst)
-  (define routing-table (rt-flatten rt))
   (msg:table (peer-ip->own-ip src) src
-             (for/fold ([entries '()]) ([routes (in-list routing-table)])
+             (for/list ([el (in-list (rt-flatten rt))])
-               (append entries (map (lambda (route)
+               (list (route-subnet (cdr el))
-                                      (list (route-subnet (cdr route))
+                     (route-nexthop (cdr el))))))
-                                            (route-nexthop (cdr route))))
-                                    routes)))))
 
 ;; Peer Route Int -> Msg
 ;; Creates an update message based on a received update message r that we can forward to other