diff --git a/miniscm/init.scm b/miniscm/init.scm index 91abe72..1803388 100644 --- a/miniscm/init.scm +++ b/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 <=>) diff --git a/set.scm b/set.scm index 2334c93..c5f4e90 100644 --- a/set.scm +++ b/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)) diff --git a/tests.scm b/tests.scm index a7b4b67..ae93237 100644 --- a/tests.scm +++ b/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) diff --git a/trie.scm b/trie.scm new file mode 100644 index 0000000..1e70e37 --- /dev/null +++ b/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 . + +;;; ;;;;;;;;;;;;;; +;;; 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)))))))))))))) diff --git a/util.scm b/util.scm new file mode 100644 index 0000000..fa361f7 --- /dev/null +++ b/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)))))) +