time for crab
You can not select more than 25 topics Topics must start with a letter or number, can include dashes ('-') and can be up to 35 characters long.
 
 
 

109 lines
4.0 KiB

  1. #lang racket
  2. (require "iputil.rkt")
  3. (provide make-rt rt-update! rt-lookup rt-dump)
  4. (struct rt-node [edge0 edge1 data] #:transparent #:mutable)
  5. (struct rt-edge [label target] #:transparent)
  6. (define empty-node-data (gensym 'MEOW))
  7. (define (make-rt)
  8. (rt-node #f #f empty-node-data))
  9. ;; Helper functions for rt-node struct access based on whether the edge is 1 or 0
  10. (define (rt-getter bit) (if bit rt-node-edge1 rt-node-edge0))
  11. (define (rt-setter bit) (if bit set-rt-node-edge1! set-rt-node-edge0!))
  12. (define (bl-common-len bl1 bl2)
  13. (for/sum ([b1 (in-list bl1)]
  14. [b2 (in-list bl2)])
  15. #:break (not (equal? b1 b2))
  16. 1))
  17. (define (rt-partial-iterate node key [visited '()])
  18. (cond
  19. [(empty? key) (list 'exact node)]
  20. [else
  21. (let* ([bit (first key)]
  22. [getter (rt-getter bit)]
  23. [next-edge (getter node)]
  24. [next-label (and next-edge (rt-edge-label next-edge))]
  25. [next-target (and next-edge (rt-edge-target next-edge))]
  26. [next-common-len (and next-label (bl-common-len next-label key))])
  27. (cond
  28. [(and next-edge (= next-common-len (length next-label)))
  29. (rt-partial-iterate next-target (drop key next-common-len) (cons node visited))]
  30. [next-edge (list 'partial node next-edge next-common-len key (cons node visited))]
  31. [else (list 'no-match node key (cons node visited))]))]))
  32. (define (rt-update! node key updater failure-result)
  33. (define (insert-node! node key)
  34. (let* ([bit (first key)]
  35. [setter! (rt-setter bit)])
  36. (setter! node (rt-edge key (rt-node #f #f (updater (failure-result)))))))
  37. (define (split-node! node key orig-edge prefix-len)
  38. (let* ([bit (first key)]
  39. [setter! (rt-setter bit)]
  40. [orig-label (rt-edge-label orig-edge)]
  41. [orig-target (rt-edge-target orig-edge)]
  42. [new-orig-edge (rt-edge (drop orig-label prefix-len) orig-target)]
  43. [new-insert-edge (rt-edge (drop key prefix-len)
  44. (rt-node #f #f (updater (failure-result))))]
  45. [diff-bit (list-ref key prefix-len)]
  46. [common-node (rt-node (if diff-bit new-orig-edge new-insert-edge)
  47. (if diff-bit new-insert-edge new-orig-edge)
  48. empty-node-data)]
  49. [common-edge (rt-edge (take key prefix-len) common-node)])
  50. (setter! node common-edge)))
  51. (match (rt-partial-iterate node key)
  52. [(list 'exact node)
  53. (set-rt-node-data!
  54. node
  55. (let ([d (rt-node-data node)])
  56. (updater
  57. (if (eq? d empty-node-data) (failure-result) d))))]
  58. [(list 'partial node orig-edge prefix-len partial-key visited)
  59. (split-node! node partial-key orig-edge prefix-len)]
  60. [(list 'no-match node partial-key visited)
  61. (insert-node! node partial-key)]))
  62. (define (rt-lookup node key failure-result)
  63. (define (find-first-with-data nodes)
  64. (or (for/first ([node (in-list nodes)]
  65. #:when (not (eq? empty-node-data (rt-node-data node))))
  66. (rt-node-data node))
  67. (failure-result)))
  68. (find-first-with-data
  69. (match (rt-partial-iterate node key)
  70. [(list 'exact node)
  71. (list node)]
  72. [(list _ ... visited)
  73. visited])))
  74. ; (define test (make-rt))
  75. ; (define (test-insert! x)
  76. ; (rt-update!
  77. ; test
  78. ; (map (curry equal? #\1) (string->list x))
  79. ; (lambda (_) x)
  80. ; (lambda () x)))
  81. ; (test-insert! "0001")
  82. ; ; (test-insert! "1000")
  83. ; ; (test-insert! "1010")
  84. ; (test-insert! "0011")
  85. ; (test-insert! "0000")
  86. (define (rt-dump node [prefix ""])
  87. (displayln (format "~a node ~a" prefix (rt-node-data node)))
  88. (define edge0 (rt-node-edge0 node))
  89. (define edge1 (rt-node-edge1 node))
  90. (when edge0
  91. (displayln (format "~a edge0 ~a" prefix (rt-edge-label edge0)))
  92. (rt-dump (rt-edge-target edge0) (string-append prefix " ")))
  93. (when edge1
  94. (displayln (format "~a edge1 ~a" prefix (rt-edge-label edge1)))
  95. (rt-dump (rt-edge-target edge1) (string-append prefix " "))))
  96. ;(rt-dump test)