example-root.scm

(define +root+
  (make-node #f
    (list
     (make-edge "r"
       (make-node #f
         (list
          (make-edge "om"
            (make-node #f
              (list
               (make-edge "an"
                 (make-node #f
                   (list
                    (make-edge "e"
                      (make-node 1 '()))
                    (make-edge "us"
                      (make-node 2 '())))))
               (make-edge "ulus"
                 (make-node 3 '())))))
          (make-edge "ub"
            (make-node #f
              (list
               (make-edge "e"
                 (make-node #f
                   (list
                    (make-edge "ns"
                      (make-node 4 '()))
                    (make-edge "r"
                      (make-node 5 '())))))
               (make-edge "ic"
                 (make-node #f
                   (list
                    (make-edge "on"
                      (make-node 6 '()))
                    (make-edge "undus"
                      (make-node 7 '()))))))))))))))

radix.scm

(import (chicken format)
        (srfi 13)
        matchable)

;; model

(define-record-type node
  (make-node value edges)
  node?
  ;; any
  (value node-value (setter node-value))
  ;; '(edge ...)
  (edges node-edges (setter node-edges)))

(define-record-printer (node n out)
  (fprintf out "#,(node ~s ~s)" (node-value n) (node-edges n)))

(define-record-type edge
  (make-edge label node)
  edge?
  ;; string
  (label edge-label (setter edge-label))
  ;; node
  (node edge-node (setter edge-node)))

(define-record-printer (edge e out)
  (fprintf out "#,(edge ~s ~s)" (edge-label e) (edge-node e)))

;; api

(define (node-search suffix node)
  (if (= 0 (string-length suffix))
    ;; empty suffix; no edges could possibly match
    (values node suffix 0 #f)
    ;; search edges
    (let loop ((edges (node-edges node)))
      (match edges
        (()
         ;; none of the edges matched
         (values node suffix 0 #f))
        ((edge . rest)
         (call/cc
          (lambda (return)
            (edge-match return suffix edge node)
            (loop rest))))))))

(define (edge-match return key edge parent-node)
  (let* ((label (edge-label edge))
         (prefix-length (string-prefix-length label key))
         (suffix (substring/shared key prefix-length)))
    (print "l " label " " key " " prefix-length)
    (cond
     ((= prefix-length (string-length label))
      ;; complete match; continue to next node
      (call-with-values (lambda () (node-search suffix (edge-node edge)))
        return))
     ((< 0 prefix-length)
      ;; incomplete match; no better matches are possible
      (return parent-node suffix prefix-length edge))
     (else
      ;; no match; there might be a better match
      #f))))

(define (node-insert root key value)
  (let-values (((parent-node new-suffix prefix-length common-edge) (node-search key root)))
    (cond
     (common-edge
      ;; this is a partial match with a common edge
      (let ((common-prefix (substring (edge-label common-edge) 0 prefix-length))
            (old-suffix (substring (edge-label common-edge) prefix-length))
            (old-node (edge-node common-edge)))
        (set! (edge-node common-edge)
          (make-node #f
            (list
             (make-edge new-suffix
               (make-node value '()))
             (make-edge old-suffix
               old-node))))
        (set! (edge-label common-edge) common-prefix)))
     ;; this parent-node is the same node as this key
     ((= 0 (string-length new-suffix))
      (set! (node-value parent-node) value))
     ;; this is a new edge for this parent-node
     (else
      (set! (node-edges parent-node)
        (cons
         (make-edge new-suffix
           (make-node value '()))
         (node-edges parent-node)))))))