This file contains bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters.
Learn more about bidirectional Unicode characters
#! /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))) |
This file contains bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters.
Learn more about bidirectional Unicode characters
#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)) |
Sign up for free
to join this conversation on GitHub.
Already have an account?
Sign in to comment