public
Last active

  • Download Gist
trie-tests.ss
Scheme
1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89
#! /bin/sh
#| Hey Emacs, this is -*-scheme-*- code!
#$Id: v4-script-template.ss 5887 2008-12-30 18:12:50Z erich $
exec mzscheme -l errortrace --require "$0" --main -- ${1+"$@"}
|#
 
#lang scheme
 
(require "trie.ss"
(planet schematics/schemeunit:3)
(planet schematics/schemeunit:3/text-ui))
 
(define snarf-dictionary
(match-lambda
 
[(? string? inp)
(snarf-dictionary (build-path inp))]
 
[(? path? inp)
(fprintf (current-error-port) "Reading dictionary ~s ... " inp)
 
(let ((dict (call-with-input-file inp snarf-dictionary)))
 
(fprintf (current-error-port) "done; ~s words~%"
(dict-count dict))
dict)]
 
[(? input-port? inp)
(for/fold ([dict (make-immutable-trie)])
([word (in-lines inp)])
(dict-set dict word word ))]))
 
(define dict-tests
(test-suite
"dictionary"
(let ((d (snarf-dictionary "/usr/share/dict/words")))
(check-not-false (dict-ref d "dog"))
(check-false (dict-ref d "I bet this word isn't in the dictionary"))
(printf "Hey: ~a~%"
(for/list ((w (in-list '("sam" "Sam" "snord" "flutter" "butter" "smith" "Smith"))))
(cons w (dict-ref d w))))
)))
 
(define trie-tests
 
(test-suite
"top"
(test-case
"tries"
(let ((t (make-immutable-trie)))
(check-true (trie? t))
(check-equal? (dict-count t) 0)
(let ((t (dict-set t "c" "The letter 'c'")))
(check-equal? (dict-count t) 1)
(check-equal? (dict-ref t "c") "The letter 'c'")
 
(let* ((exp "The furry 'cat'")
(t (dict-set t "cat" exp)))
(check-false (dict-ref t "ca" #f))
(check-equal? (dict-count t) 2)
(check-equal? (dict-ref t "cat") exp)
 
))
)
 
(let ((t (make-immutable-trie)))
(check-true (dict? t))
(check-false (dict-ref t "cat" #f))
(check-equal? (dict-count t) 0)
(let ((t (dict-set t "c" 'plurgh)))
(check-equal? (dict-ref t "c" #f) 'plurgh)
(check-equal? (dict-count t) 1)
(let ((t (dict-set t "cat" "hat")))
(check-equal? (dict-ref t "cat" #f) "hat")
(let ((t (dict-set t "cats" "mats")))
(check-equal? (dict-ref t "cat" #f) "hat")
(check-equal? (dict-ref t "cats" #f) "mats")
(check-equal? (dict-count t) 3))
)
)))
dict-tests))
 
(provide main)
(define (main . args)
(exit (run-tests
trie-tests
'verbose)))
trie.ss
Scheme
1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85
#lang scheme
 
(require mzlib/trace)
 
(define (ref t key [failure-result #f])
(define (ref-inner t chars)
(if (null? chars)
(if (box? (trie-value t))
(unbox (trie-value t))
failure-result)
(let ((probe (dict-ref (trie-alist t) (car chars) #f)))
(cond
((not probe)
failure-result)
((box? probe)
(unbox probe))
(#t
(ref-inner probe
(cdr chars)))))))
;; (trace ref-inner)
(ref-inner t (string->list key)))
;; (trace ref)
 
(define (set t key value)
 
(define (set-inner t chars value)
;; chars: () => set the box
;; chars: (ch . rest) => lookup ch => old value; (set-inner oldvalue (cdr chars) value)
(let ((new (make-trie '() (box-immutable value))))
(if (null? chars)
new
(let ((probe (dict-ref (trie-alist t) (car chars) (make-trie '() #f))))
(make-trie
(dict-set (trie-alist t) (car chars)
(set-inner probe (cdr chars) value))
(trie-value t))))))
;; (trace set-inner)
(set-inner t (string->list key) value))
 
;; (trace set)
 
(define (count t)
(foldl +
(if (box? (trie-value t))
1
0)
(map (compose count cdr) (trie-alist t))))
 
;; (trace count)
 
(define (iterate-first t)
(and (not (null? t))
0))
;; (trace iterate-first)
 
(define (iterate-next t pos)
(if (= pos (sub1 (length t)))
#f
(add1 pos)))
;; (trace iterate-next)
 
(define (iterate-key t pos)
(car (list-ref t pos)))
;; (trace iterate-key)
 
(define (iterate-value t pos)
(cdr (list-ref t pos)))
;; (trace iterate-value)
 
(define-struct trie
(alist
value ;;either #f or a box
)
#:property prop:dict (vector
ref
#f set
#f remove
count
iterate-first iterate-next
iterate-key iterate-value)
#:transparent)
 
(provide make-immutable-trie trie?)
(define (make-immutable-trie)
(make-trie '() #f))

Please sign in to comment on this gist.

Something went wrong with that request. Please try again.