code.delx.au - gnu-emacs/blob - lisp/emacs-lisp/radix-tree.el

   1 ;;; radix-tree.el --- A simple library of radix trees  -*- lexical-binding: t; -*-
   2
   3 ;; Copyright (C) 2016  Free Software Foundation, Inc.
   4
   5 ;; Author: Stefan Monnier <monnier@iro.umontreal.ca>
   6 ;; Keywords:
   7
   8 ;; This file is part of GNU Emacs.
   9
  10 ;; GNU Emacs is free software: you can redistribute it and/or modify
  11 ;; it under the terms of the GNU General Public License as published by
  12 ;; the Free Software Foundation, either version 3 of the License, or
  13 ;; (at your option) any later version.
  14
  15 ;; GNU Emacs is distributed in the hope that it will be useful,
  16 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  17 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  18 ;; GNU General Public License for more details.
  19
  20 ;; You should have received a copy of the GNU General Public License
  21 ;; along with GNU Emacs.  If not, see <http://www.gnu.org/licenses/>.
  22
  23 ;;; Commentary:
  24
  25 ;; There are many different options for how to represent radix trees
  26 ;; in Elisp.  Here I chose a very simple one.  A radix-tree can be either:
  27 ;; - a node, of the form ((PREFIX . PTREE) . RTREE) where PREFIX is a string
  28 ;;   meaning that everything that starts with PREFIX is in PTREE,
  29 ;;   and everything else in RTREE.  It also has the property that
  30 ;;   everything that starts with the first letter of PREFIX but not with
  31 ;;   that whole PREFIX is not in RTREE (i.e. is not in the tree at all).
  32 ;; - anything else is taken as the value to associate with the empty string.
  33 ;; So every node is basically an (improper) alist where each mapping applies
  34 ;; to a different leading letter.
  35 ;;
  36 ;; The main downside of this representation is that the lookup operation
  37 ;; is slower because each level of the tree is an alist rather than some kind
  38 ;; of array, so every level's lookup is O(N) rather than O(1).  We could easily
  39 ;; solve this by using char-tables instead of alists, but that would make every
  40 ;; level take up a lot more memory, and it would make the resulting
  41 ;; datastructure harder to read (by a human) when printed out.
  42
  43 ;;; Code:
  44
  45 (defun radix-tree--insert (tree key val i)
  46   (pcase tree
  47     (`((,prefix . ,ptree) . ,rtree)
  48      (let* ((ni (+ i (length prefix)))
  49             (cmp (compare-strings prefix nil nil key i ni)))
  50        (if (eq t cmp)
  51            (let ((nptree (radix-tree--insert ptree key val ni)))
  52              `((,prefix . ,nptree) . ,rtree))
  53          (let ((n (if (< cmp 0) (- -1 cmp) (- cmp 1))))
  54            (if (zerop n)
  55                (let ((nrtree (radix-tree--insert rtree key val i)))
  56                  `((,prefix . ,ptree) . ,nrtree))
  57              (let* ((nprefix (substring prefix 0 n))
  58                     (kprefix (substring key (+ i n)))
  59                     (pprefix (substring prefix n))
  60                     (ktree (if (equal kprefix "") val
  61                              `((,kprefix . ,val)))))
  62                `((,nprefix
  63                   . ((,pprefix . ,ptree) . ,ktree))
  64                  . ,rtree)))))))
  65     (_
  66      (if (= (length key) i) val
  67        (let ((prefix (substring key i)))
  68          `((,prefix . ,val) . ,tree))))))
  69
  70 (defun radix-tree--remove (tree key i)
  71   (pcase tree
  72     (`((,prefix . ,ptree) . ,rtree)
  73      (let* ((ni (+ i (length prefix)))
  74             (cmp (compare-strings prefix nil nil key i ni)))
  75        (if (eq t cmp)
  76            (pcase (radix-tree--remove ptree key ni)
  77              (`nil rtree)
  78              (`((,pprefix . ,pptree))
  79               `((,(concat prefix pprefix) . ,pptree) . ,rtree))
  80              (nptree `((,prefix . ,nptree) . ,rtree)))
  81          (let ((n (if (< cmp 0) (- -1 cmp) (- cmp 1))))
  82            (if (zerop n)
  83                (let ((nrtree (radix-tree--remove rtree key i)))
  84                  `((,prefix . ,ptree) . ,nrtree))
  85              tree)))))
  86     (_
  87      (if (= (length key) i) nil tree))))
  88
  89
  90 (defun radix-tree--lookup (tree string i)
  91   (pcase tree
  92     (`((,prefix . ,ptree) . ,rtree)
  93      (let* ((ni (+ i (length prefix)))
  94             (cmp (compare-strings prefix nil nil string i ni)))
  95        (if (eq t cmp)
  96            (radix-tree--lookup ptree string ni)
  97          (let ((n (if (< cmp 0) (- -1 cmp) (- cmp 1))))
  98            (if (zerop n)
  99                (radix-tree--lookup rtree string i)
 100              (+ i n))))))
 101     (val
 102      (if (and val (equal (length string) i))
 103          (if (integerp val) `(t . ,val) val)
 104        i))))
 105
 106 (defun radix-tree--subtree (tree string i)
 107   (if (equal (length string) i) tree
 108     (pcase tree
 109       (`((,prefix . ,ptree) . ,rtree)
 110        (let* ((ni (+ i (length prefix)))
 111               (cmp (compare-strings prefix nil nil string i ni)))
 112          (if (eq t cmp)
 113              (radix-tree--subtree ptree string ni)
 114            (let ((n (if (< cmp 0) (- -1 cmp) (- cmp 1))))
 115              (cond
 116               ((zerop n) (radix-tree--subtree rtree string i))
 117               ((equal (+ n i) (length string))
 118                (let ((nprefix (substring prefix n)))
 119                  `((,nprefix . ,ptree))))
 120               (t nil))))))
 121       (_ nil))))
 122
 123 ;;; Entry points
 124
 125 (defconst radix-tree-empty nil
 126   "The empty radix-tree.")
 127
 128 (defun radix-tree-insert (tree key val)
 129   "Insert a mapping from KEY to VAL in radix TREE."
 130   (when (consp val) (setq val `(t . ,val)))
 131   (if val (radix-tree--insert tree key val 0)
 132     (radix-tree--remove tree key 0)))
 133
 134 (defun radix-tree-lookup (tree key)
 135   "Return the value associated to KEY in radix TREE.
 136 If not found, return nil."
 137   (pcase (radix-tree--lookup tree key 0)
 138     (`(t . ,val) val)
 139     ((pred numberp) nil)
 140     (val val)))
 141
 142 (defun radix-tree-subtree (tree string)
 143   "Return the subtree of TREE rooted at the prefix STRING."
 144   (radix-tree--subtree tree string 0))
 145
 146 (eval-and-compile
 147   (pcase-defmacro radix-tree-leaf (vpat)
 148     ;; FIXME: We'd like to use a negative pattern (not consp), but pcase
 149     ;; doesn't support it.  Using `atom' works but generates sub-optimal code.
 150     `(or `(t . ,,vpat) (and (pred atom) ,vpat))))
 151
 152 (defun radix-tree-iter-subtrees (tree fun)
 153   "Apply FUN to every immediate subtree of radix TREE.
 154 FUN is called with two arguments: PREFIX and SUBTREE.
 155 You can test if SUBTREE is a leaf (and extract its value) with the
 156 pcase pattern (radix-tree-leaf PAT)."
 157   (while tree
 158     (pcase tree
 159       (`((,prefix . ,ptree) . ,rtree)
 160        (funcall fun prefix ptree)
 161        (setq tree rtree))
 162       (_ (funcall fun "" tree)
 163          (setq tree nil)))))
 164
 165 (defun radix-tree-iter-mappings (tree fun &optional prefix)
 166   "Apply FUN to every mapping in TREE.
 167 FUN is called with two arguments: KEY and VAL.
 168 PREFIX is only used internally."
 169   (radix-tree-iter-subtrees
 170    tree
 171    (lambda (p s)
 172      (let ((nprefix (concat prefix p)))
 173        (pcase s
 174          ((radix-tree-leaf v) (funcall fun nprefix v))
 175          (_ (radix-tree-iter-mappings s fun nprefix)))))))
 176
 177 ;; (defun radix-tree->alist (tree)
 178 ;;   (let ((al nil))
 179 ;;     (radix-tree-iter-mappings tree (lambda (p v) (push (cons p v) al)))
 180 ;;     al))
 181
 182 (defun radix-tree-count (tree)
 183   (let ((i 0))
 184     (radix-tree-iter-mappings tree (lambda (_ _) (setq i (1+ i))))
 185     i))
 186
 187 (provide 'radix-tree)
 188 ;;; radix-tree.el ends here