peter
/
UNSLISP
1
0
Fork 0
Code Issues Pull Requests Packages Projects Releases Wiki Activity

trie: add with test

This commit is contained in:
Peter McGoron 2024-09-04 02:16:10 -04:00
parent 40b03b5714
commit c510054119
5 changed files with 171 additions and 3 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

1
miniscm/init.scm
View File

@ -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 <=>)

6
set.scm
View File

@ -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))

7
tests.scm
View File

@ -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)

125
trie.scm Normal file
View File

@ -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))))))))))))))

35
util.scm Normal file
View File

@ -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))))))