trie: add with test

miniscm/init.scm

@@ -93,6 +93,7 @@
 (define string-ref list-ref)
 (define string-set! list-set!)
 (define string list)
+(define (string->list x) x)
 
 (define list<=>
   (lambda (x y <=>)

set.scm

@@ -176,7 +176,7 @@
 
 ;;; (SET:IN <=>) generates a search function for comparison function <=>.
 ;;; (SEARCH TREE DATA) searches TREE for a node that matches DATA.
-;;; It will return the node that contains the matched DATA, or #F.
+;;; It will return the node that contains the matched DATA, or '().
 (define set:in
   (lambda (<=>)
     (lambda (tree data)
@@ -184,7 +184,7 @@
           ((loop
             (lambda (tree)
               (if (null? tree)
-                  #f
+                  '()
                   (let ((dir (<=> (set:get tree '=) data)))
                     (if (eq? dir '=)
                         tree
@@ -434,7 +434,7 @@
                 (let ((tree (car insert-return)))
                   (let ((found (smap:search tree (string #\a))))
                     (cond
-                      ((not found) "string not in tree")
+                      ((null? found) "string not in tree")
                       ((not (equal? (map:key tree) (string #\a)))
                        "returned key not equal to a")
                       ((not (equal? (map:val tree) 5))

tests.scm

@@ -18,6 +18,8 @@
 ;;; 
 ;;; TODO: Return test results as a list.
 
+(load "util.scm")
+
 (define verbose? #t)
 
 (define run-tests
@@ -67,3 +69,8 @@
 (display "running string BST-AVL tests")
 (newline)
 (report-tests %set:tests)
+
+(load "trie.scm")
+(display "char trie")
+(newline)
+(report-tests %trie:tests)

trie.scm

@@ -0,0 +1,125 @@
+;;; Copyright (C) Peter McGoron 2024
+;;; This program is free software: you can redistribute it and/or modify
+;;; it under the terms of the GNU General Public License as published by
+;;; the Free Software Foundation, version 3 of the License.
+;;; 
+;;; This program is distributed in the hope that it will be useful,
+;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+;;; GNU General Public License for more details.
+;;; 
+;;; You should have received a copy of the GNU General Public License
+;;; along with this program.  If not, see <https://www.gnu.org/licenses/>.
+
+;;; ;;;;;;;;;;;;;;
+;;; Character maps
+;;; ;;;;;;;;;;;;;;
+
+(define char<=>
+  (lambda (x y)
+    (let ((x (char->integer x))
+          (y (char->integer y)))
+      (cond
+        ((< x y) '<)
+        ((= x y) '=)
+        (else '>)))))
+
+
+(define %charmap:<=> (set:<=>-to-map char<=>))
+(define %charmap:update (set:update %charmap:<=>))
+
+(define charmap:update (map:update %charmap:update))
+(define charmap:insert (map:insert %charmap:update))
+(define charmap:search (map:search %charmap:<=>))
+
+;;; ;;;;;;;;;;
+;;; Char tries
+;;; ;;;;;;;;;;
+
+(define trie:new cons)
+(define trie:empty (trie:new #f '()))
+(define trie:function
+  (lambda (node)
+    (if (null? node)
+        #f
+        (car node))))
+(define %trie:set
+  (lambda (node)
+    (if (null? node)
+        '()
+        (cdr node))))
+
+;;; Insert STRING-AS-LIST into NODE with value FUNCTION.
+(define trie:insert
+  (lambda (node string-as-list function)
+    (if (null? string-as-list)
+        (trie:new function (%trie:set node))
+        (let ((ch (car string-as-list))
+              (string-as-list (cdr string-as-list)))
+          (let ((newtree (charmap:update (%trie:set node) ch
+                                         (lambda (node oldnode)
+                                           (if oldnode
+                                               (map:node-new-val
+                                                oldnode
+                                                ch
+                                                (trie:insert (map:val oldnode)
+                                                             string-as-list
+                                                             function))
+                                               (map:empty-node ch
+                                                               (trie:insert
+                                                                trie:empty
+                                                                string-as-list
+                                                                function)))))))
+            (trie:new (trie:function node) newtree))))))
+
+(define trie:insert-many
+  (lambda (node lst)
+    (fold (lambda (pair node)
+            (trie:insert node (string->list (car pair)) (cdr pair)))
+          node lst)))
+
+;;; Search for CH in NODE.
+(define trie:search-single
+  (lambda (ch node)
+    (if (null? node)
+        '()
+        (let ((node (charmap:search (%trie:set node) ch)))
+          (if (null? node)
+              '()
+              (map:val node))))))
+
+(define trie:search
+  (lambda (node str)
+    (fold trie:search-single node (string->list str))))
+
+;;; ;;;;;
+;;; Tests
+;;; ;;;;;
+
+(define %trie:tests
+  (list
+   (cons "insert with prefixes"
+         (lambda ()
+           (let ((trie
+                  (trie:insert-many trie:empty
+                                    (list
+                                     (cons (string #\a #\b #\c #\d) 10)
+                                     (cons (string #\a #\b #\c) 20)
+                                     (cons (string #\a #\b #\c #\d #\e) 30)
+                                     (cons (string #\b) 40)
+                                     (cons (string #\b #\e #\g) 50))))
+                 (t '()))
+             (set! t (trie:search trie (string #\a #\b #\c)))
+             (if (not (= (trie:function t) 20))
+                 "abc not found"
+                 (let ((t (trie:search-single #\d t)))
+                   (if (not (= (trie:function t) 10))
+                       "abcd not found"
+                       (let ((t (trie:search-single #\e t)))
+                         (if (not (= (trie:function t) 30))
+                             "abcde not found"
+                             (let ((t (trie:search-single #\b trie)))
+                               (if (not (= (trie:function t) 40))
+                                   "b not found"
+                                   (let ((t (trie:search t (string #\e #\g))))
+                                     (= (trie:function t) 50))))))))))))))

util.scm

@@ -0,0 +1,35 @@
+;;; Utilities.
+
+;;; ;;;;;;;;;;;;;;;;
+;;; Versions of FOLD
+;;; ;;;;;;;;;;;;;;;;
+
+(define fold
+  (lambda (f init lst)
+    (if (null? lst)
+        init
+        (fold f (f (car lst) init) (cdr lst)))))
+
+(define fold-vector
+  (lambda (f init vec)
+    (if (list? vec)                    ; Support MiniScheme
+        (fold f init vec)
+        (letrec
+            ((loop
+              (lambda (i val)
+                (if (= i (vector-length vec))
+                    val
+                    (loop (+ i 1) (f (vector-ref vec i) val))))))
+          (loop 0 init)))))
+
+;;; ;;;;;;;;;;;;;;;;;;;;
+;;; Misc. list functions
+;;; ;;;;;;;;;;;;;;;;;;;;
+
+(define all
+  (lambda (f lst)
+    (cond
+      ((null? lst) #t)
+      ((not (f (car lst))) #f)
+      (else (all f (cdr lst))))))
+