; telephone lookup
(define (range . args)
(case (length args)
((1) (range 0 (car args) (if (negative? (car args)) -1 1)))
((2) (range (car args) (cadr args) (if (< (car args) (cadr args)) 1 -1)))
((3) (let ((le? (if (negative? (caddr args)) >= <=)))
(let loop ((x(car args)) (xs '()))
(if (le? (cadr args) x)
(reverse xs)
(loop (+ x (caddr args)) (cons x xs))))))
(else (error 'range "unrecognized arguments"))))
(define (string-upcase str)
(list->string
(map char-upcase
(string->list str))))
; dynamic hash tables
; based on Per-Ake Larson, CACM 4/1988
(define (make-hash . args)
; (make-hash . hash eql?) -- return a newly-allocated empty hash table;
; the hash and eql? functions are optional, but if either is provided
; both must be; defaults are a universal hash function and equal?
; a hash table h is a function that takes a message and zero or more
; arguments; the insert, delete and update messages return a new function,
; so (set! h (h 'message args)) updates hash table h as requested
; (h 'lookup key) -- retrieves from hash table h the (cons key value)
; pair with the given key, or null
; (h 'insert key value) -- inserts a (cons key value) pair in hash table
; h, overwriting any previous value associated with the key
; (h 'delete key) -- removes from hash table h the (cons key value) pair
; with the given key, if it exists
; (h 'update key proc default) -- proc is a function that takes a key and
; value as arguments and returns a new value; if the key is present in
; hash table h, update calls proc with the key and its associated value
; and stores the value returned by proc in place of the original value,;
; otherwise update inserts a new (cons key default) pair in hash table h
; (h 'enlist) -- returns the (cons key value) pairs in hash table h as a list
; (h 'size) -- returns the number of (cons key value) pairs in hash table h
(define (uhash x) ; universal hash function
(define (mod n) (modulo n 4294967296))
(cond ((boolean? x) (if x 357913941 460175067))
((symbol? x) (uhash (symbol->string x)))
((char? x) (char->integer x))
((integer? x) (mod x))
((real? x)
(let* ((r (inexact->exact x))
(n (numerator r))
(d (denominator r)))
(mod (+ n (* 37 d)))))
((rational? x) (mod (+ (numerator x) (* 37 (denominator x)))))
((complex? x)
(mod (+ (uhash (real-part x)) (* 37 (uhash (imag-part x))))))
((null? x) 477338855)
((pair? x)
(let loop ((x x) (s 0))
(if (null? x) s
(loop (cdr x) (mod (+ (* 31 s) (uhash (car x))))))))
((vector? x)
(let loop ((i (- (vector-length x) 1)) (s 0))
(if (negative? i) s
(loop (- i 1) (mod (+ (* 31 s) (uhash (vector-ref x i))))))))
((string? x)
(let loop ((i (- (string-length x) 1)) (s 0))
(if (negative? i) s
(loop (- i 1) (mod (+ (* 31 s) (uhash (string-ref x i))))))))
((procedure? x) (error 'uhash "can't hash procedure"))
((port? x) (error 'uhash "can't hash port"))
(else (error 'uhash "don't know how to hash object"))))
(define (scramble h) ; ensure minimum 20 bit result from hash function
(if (< h 4096) (* h 1048573) (if (< h 1048576) (* h 4093) h)))
(define (empty) (vector (make-vector w (list)) (list) (list)))
(define (vect t) (vector-ref t 0))
(define (lkid t) (vector-ref t 1))
(define (rkid t) (vector-ref t 2))
(define (get t i) ; fetch value from bucket i of tree t
(if (<= u i) (error 'get "out of bounds")
(let loop ((t t) (q (+ (quotient i w) 1)))
(if (= q 1) (vector-ref (vect t) (modulo i w))
(loop (if (even? (modulo q w)) (lkid t) (rkid t))
(quotient q 2))))))
(define (put t i v) ; store value v in bucket i, return new t
(cond ((< u i) (error 'put "out of bounds"))
((< i u) ; replace current value
(let loop ((t t) (q (+ (quotient i w) 1)))
(cond ((= q 1) (let ((x (vect t)))
(vector-set! x (modulo i w) v)
(vector x (lkid t) (rkid t))))
((even? q) (vector (vect t)
(loop (lkid t) (quotient q 2)) (rkid t)))
(else (vector (vect t)
(lkid t) (loop (rkid t) (quotient q 2)))))))
((zero? (modulo u w)) (set! u (+ u 1)) ; add new segment
(let loop ((t t) (q (+ (quotient i w) 1)))
(cond ((= q 1) (let ((x (make-vector w (list))))
(vector-set! x 0 v) (vector x (list) (list))))
((even? q) (vector (vect t)
(loop (lkid t) (quotient q 2)) (rkid t)))
(else (vector (vect t)
(lkid t) (loop (rkid t) (quotient q 2)))))))
(else (set! u (+ u 1)) ; expand within current segment
(let loop ((t t) (q (+ (quotient i w) 1)))
(cond ((= q 1) (let ((x (vect t)))
(vector-set! x (modulo i w) v)
(vector x (lkid t) (rkid t))))
((even? q) (vector (vect t)
(loop (lkid t) (quotient q 2)) (rkid t)))
(else (vector (vect t)
(lkid t) (loop (rkid t) (quotient q 2)))))))))
(define (hirem t) ; remove last bucket from t, return new t
(if (zero? u) (error 'hirem "out of bounds"))
(set! u (- u 1))
(if (zero? (modulo u w))
(let loop ((t t) (q (+ (quotient u w) 1))) ; remove last segment
(cond ((= q 1) (list))
((even? q) (vector (vect t)
(loop (lkid t) (quotient q 2)) (rkid t)))
(else (vector (vect t)
(lkid t) (loop (rkid t) (quotient q 2))))))
(let loop ((t t) (q (+ (quotient u w) 1)))
; remove last bucket within last segment
(cond ((= q 1) (let ((x (vect t)))
(vector-set! x (modulo u w) (list))
(vector x (lkid t) (rkid t))))
((even? q) (vector (vect t)
(loop (lkid t) (quotient q 2)) (rkid t)))
(else (vector (vect t)
(lkid t) (loop (rkid t) (quotient q 2))))))))
(define (index k) ; index of bucket, whether before or after split
(let* ((h (scramble (hash k))) (h-mod-m (modulo h m)))
(if (< h-mod-m p) (modulo h (+ m m)) h-mod-m)))
(define (grow t) ; split bucket, move some keys to new bucket
(let ((old p) (new (+ p m)))
(set! p (+ p 1))
(when (= p m) (set! m (* 2 m)) (set! p 0))
(let loop ((xs (get t old)) (ys (list)) (zs (list)))
(cond ((null? xs)
(set! t (put t old ys))
(set! t (put t new zs)))
((= (index (caar xs)) new)
(loop (cdr xs) ys (cons (car xs) zs)))
(else (loop (cdr xs) (cons (car xs) ys) zs))))
t))
(define (shrink t) ; coalesce last bucket, move all keys
(set! p (- p 1))
(when (< p 0) (set! m (quotient m 2)) (set! p (- m 1)))
(set! t (put t p (append (get t p) (get t (- u 1)))))
(set! t (hirem t))
t)
(define (lookup t k) ; return key/value pair, or null
(let loop ((bs (get t (index k))))
(cond ((null? bs) (list)) ; not found
((eql? (caar bs) k) (car bs)) ; found
(else (loop (cdr bs)))))) ; keep looking
(define (enlist t) ; return all key/value pairs in a list
(do ((i 0 (+ i 1)) (xs (list) (append (get t i) xs))) ((= i u) xs)))
(define (insert t k v) ; insert new key/value pair, or replace value
(if (and (positive? u) (< hi (/ s u))) (set! t (grow t)))
(let ((b (index k)))
(let loop ((bs (get t b)) (xs (list)))
(cond ((null? bs) ; insert new key/value pair
(set! s (+ s 1)) (set! t (put t b (cons (cons k v) xs))) t)
((eql? (caar bs) k) ; replace existing value
(set! t (put t b (cons (cons k v) (append (cdr bs) xs)))) t)
(else (loop (cdr bs) (cons (car bs) xs))))))) ; keep looking
(define (delete t k) ; delete key/value pair if key exists
(if (and (< n u) (< (/ s u) lo)) (set! t (shrink t)))
(let ((b (index k)))
(let loop ((bs (get t b)) (xs (list)))
(cond ((null? bs) xs) ; not in table, nothing to do
((eql? (caar bs) k) ; in table, delete
(set! s (- s 1)) (set! t (put t b (append (cdr bs) xs))) t)
(else (loop (cdr bs) (cons (car bs) xs))))))) ; keep looking
(define (update t k p v) ; update value, or add new key/value pair
(if (and (positive? u) (< hi (/ s u))) (set! t (grow t)))
(let ((b (index k)))
(let loop ((bs (get t b)) (xs (list)))
(cond ((null? bs) ; not in table, insert
(set! s (+ s 1)) (set! t (put t b (cons (cons k v) xs))) t)
((eql? (caar bs) k) ; in table, update
(set! t (put t b (cons (cons k (p k (cdar bs)))
(append (cdr bs) xs)))) t)
(else (loop (cdr bs) (cons (car bs) xs))))))) ; keep looking
(define (new t) (lambda (message . args) (dispatch t message args)))
(define (dispatch t message args) ; perform requested function
(define (arity n)
(if (not (= (length args) n)) (error 'dispatch "incorrect arity")))
(case message ; includes synonymns for some messages
((display debug) ; for debugging
(display "u = ") (display u)
(display "; m = ") (display m)
(display "; p = ") (display p)
(display "; s = ") (display s) (newline)
(do ((i 0 (+ i 1))) ((= i u))
(display i) (display ": ")
(display (get t i)) (newline)))
((lookup fetch get) (arity 1) (apply lookup t args))
((insert store put insert! store! put!)
(arity 2) (new (apply insert t args)))
((delete remove delete! remove!)
(arity 1) (new (apply delete t args)))
((update update!)
(arity 3) (new (apply update t args)))
((size count length) (arity 0) s)
((enlist to-list) (arity 0) (enlist t))))
(define w 64) ; width of a segment of the growable array
(define u 64) ; number of buckets currently in use
(define n 64) ; minimum number of buckets in hash table
(define m 64) ; current maximum number of buckets (Larson's maxp = n * 2^l)
; initialize u, n and m to w; 64 or 256 are good values to use
(define p 0) ; pointer to next bucket to be split 0 .. m-1
(define s 0) ; number of key/value pairs currently in table
(define lo 1) ; minimum load factor (average chain length is 2)
(define hi 3) ; maximum load factor (average chain length is 2)
; (/ hi lo) must be strictly greater than 2
; set hash and eql? based on arguments or default
(define hash #f) (define eql? #f) ; placeholders
(cond ((= (length args) 2) (set! hash (car args)) (set! eql? (cadr args)))
(else (set! hash uhash) (set! eql? equal?)))
(new (empty))) ; main function
(define surnames (map list (map string-upcase (map symbol->string '(
; http://names.mongabay.com/most_common_surnames.htm
SMITH JOHNSON WILLIAMS JONES BROWN
DAVIS MILLER WILSON MOORE TAYLOR
ANDERSON THOMAS JACKSON WHITE HARRIS
MARTIN THOMPSON GARCIA MARTINEZ ROBINSON
CLARK RODRIGUEZ LEWIS LEE WALKER
HALL ALLEN YOUNG HERNANDEZ KING
WRIGHT LOPEZ HILL SCOTT GREEN
ADAMS BAKER GONZALEZ NELSON CARTER
MITCHELL PEREZ ROBERTS TURNER PHILLIPS
CAMPBELL PARKER EVANS EDWARDS COLLINS
STEWART SANCHEZ MORRIS ROGERS REED
COOK MORGAN BELL MURPHY BAILEY
RIVERA COOPER RICHARDSON COX HOWARD
WARD TORRES PETERSON GRAY RAMIREZ
JAMES WATSON BROOKS KELLY SANDERS
PRICE BENNETT WOOD BARNES ROSS
HENDERSON COLEMAN JENKINS PERRY POWELL
LONG PATTERSON HUGHES FLORES WASHINGTON
BUTLER SIMMONS FOSTER GONZALES BRYANT
ALEXANDER RUSSELL GRIFFIN DIAZ HAYES
MYERS FORD HAMILTON GRAHAM SULLIVAN
WALLACE WOODS COLE WEST JORDAN
OWENS REYNOLDS FISHER ELLIS HARRISON
GIBSON MCDONALD CRUZ MARSHALL ORTIZ
GOMEZ MURRAY FREEMAN WELLS WEBB
SIMPSON STEVENS TUCKER PORTER HUNTER
HICKS CRAWFORD HENRY BOYD MASON
MORALES KENNEDY WARREN DIXON RAMOS
REYES BURNS GORDON SHAW HOLMES
RICE ROBERTSON HUNT BLACK DANIELS
PALMER MILLS NICHOLS GRANT KNIGHT
FERGUSON ROSE STONE HAWKINS DUNN
PERKINS HUDSON SPENCER GARDNER STEPHENS
PAYNE PIERCE BERRY MATTHEWS ARNOLD
WAGNER WILLIS RAY WATKINS OLSON
CARROLL DUNCAN SNYDER HART CUNNINGHAM
BRADLEY LANE ANDREWS RUIZ HARPER
FOX RILEY ARMSTRONG CARPENTER WEAVER
GREENE LAWRENCE ELLIOTT CHAVEZ SIMS
AUSTIN PETERS KELLEY FRANKLIN LAWSON
FIELDS GUTIERREZ RYAN SCHMIDT CARR
VASQUEZ CASTILLO WHEELER CHAPMAN OLIVER
MONTGOMERY RICHARDS WILLIAMSON JOHNSTON BANKS
MEYER BISHOP MCCOY HOWELL ALVAREZ
MORRISON HANSEN FERNANDEZ GARZA HARVEY
LITTLE BURTON STANLEY NGUYEN GEORGE
JACOBS REID KIM FULLER LYNCH
DEAN GILBERT GARRETT ROMERO WELCH
LARSON FRAZIER BURKE HANSON DAY
MENDOZA MORENO BOWMAN MEDINA FOWLER
BREWER HOFFMAN CARLSON SILVA PEARSON
HOLLAND DOUGLAS FLEMING JENSEN VARGAS
BYRD DAVIDSON HOPKINS MAY TERRY
HERRERA WADE SOTO WALTERS CURTIS
NEAL CALDWELL LOWE JENNINGS BARNETT
GRAVES JIMENEZ HORTON SHELTON BARRETT
OBRIEN CASTRO SUTTON GREGORY MCKINNEY
LUCAS MILES CRAIG RODRIQUEZ CHAMBERS
HOLT LAMBERT FLETCHER WATTS BATES
HALE RHODES PENA BECK NEWMAN
HAYNES MCDANIEL MENDEZ BUSH VAUGHN
PARKS DAWSON SANTIAGO NORRIS HARDY
LOVE STEELE CURRY POWERS SCHULTZ
BARKER GUZMAN PAGE MUNOZ BALL
KELLER CHANDLER WEBER LEONARD WALSH
LYONS RAMSEY WOLFE SCHNEIDER MULLINS
BENSON SHARP BOWEN DANIEL BARBER
CUMMINGS HINES BALDWIN GRIFFITH VALDEZ
HUBBARD SALAZAR REEVES WARNER STEVENSON
BURGESS SANTOS TATE CROSS GARNER
MANN MACK MOSS THORNTON DENNIS
MCGEE FARMER DELGADO AGUILAR VEGA
GLOVER MANNING COHEN HARMON RODGERS
ROBBINS NEWTON TODD BLAIR HIGGINS
INGRAM REESE CANNON STRICKLAND TOWNSEND
POTTER GOODWIN WALTON ROWE HAMPTON
ORTEGA PATTON SWANSON JOSEPH FRANCIS
GOODMAN MALDONADO YATES BECKER ERICKSON
HODGES RIOS CONNER ADKINS WEBSTER
NORMAN MALONE HAMMOND FLOWERS COBB
MOODY QUINN BLAKE MAXWELL POPE
FLOYD OSBORNE PAUL MCCARTHY GUERRERO
LINDSEY ESTRADA SANDOVAL GIBBS TYLER
GROSS FITZGERALD STOKES DOYLE SHERMAN
SAUNDERS WISE COLON GILL ALVARADO
GREER PADILLA SIMON WATERS NUNEZ
BALLARD SCHWARTZ MCBRIDE HOUSTON CHRISTENSEN
KLEIN PRATT BRIGGS PARSONS MCLAUGHLIN
ZIMMERMAN FRENCH BUCHANAN MORAN COPELAND
ROY PITTMAN BRADY MCCORMICK HOLLOWAY
BROCK POOLE FRANK LOGAN OWEN
BASS MARSH DRAKE WONG JEFFERSON
PARK MORTON ABBOTT SPARKS PATRICK
NORTON HUFF CLAYTON MASSEY LLOYD
FIGUEROA CARSON BOWERS ROBERSON BARTON
TRAN LAMB HARRINGTON CASEY BOONE
CORTEZ CLARKE MATHIS SINGLETON WILKINS
CAIN BRYAN UNDERWOOD HOGAN MCKENZIE
COLLIER LUNA PHELPS MCGUIRE ALLISON
BRIDGES WILKERSON NASH SUMMERS ATKINS
WILCOX PITTS CONLEY MARQUEZ BURNETT
RICHARD COCHRAN CHASE DAVENPORT HOOD
GATES CLAY AYALA SAWYER ROMAN
VAZQUEZ DICKERSON HODGE ACOSTA FLYNN
ESPINOZA NICHOLSON MONROE WOLF MORROW
KIRK RANDALL ANTHONY WHITAKER OCONNOR
SKINNER WARE MOLINA KIRBY HUFFMAN
BRADFORD CHARLES GILMORE DOMINGUEZ ONEAL
BRUCE LANG COMBS KRAMER HEATH
HANCOCK GALLAGHER GAINES SHAFFER SHORT
WIGGINS MATHEWS MCCLAIN FISCHER WALL
SMALL MELTON HENSLEY BOND DYER
CAMERON GRIMES CONTRERAS CHRISTIAN WYATT
BAXTER SNOW MOSLEY SHEPHERD LARSEN
HOOVER BEASLEY GLENN PETERSEN WHITEHEAD
MEYERS KEITH GARRISON VINCENT SHIELDS
HORN SAVAGE OLSEN SCHROEDER HARTMAN
WOODARD MUELLER KEMP DELEON BOOTH
PATEL CALHOUN WILEY EATON CLINE
NAVARRO HARRELL LESTER HUMPHREY PARRISH
DURAN HUTCHINSON HESS DORSEY BULLOCK
ROBLES BEARD DALTON AVILA VANCE
RICH BLACKWELL YORK JOHNS BLANKENSHIP
TREVINO SALINAS CAMPOS PRUITT MOSES
CALLAHAN GOLDEN MONTOYA HARDIN GUERRA
MCDOWELL CAREY STAFFORD GALLEGOS HENSON
WILKINSON BOOKER MERRITT MIRANDA ATKINSON
ORR DECKER HOBBS PRESTON TANNER
KNOX PACHECO STEPHENSON GLASS ROJAS
SERRANO MARKS HICKMAN ENGLISH SWEENEY
STRONG PRINCE MCCLURE CONWAY WALTER
ROTH MAYNARD FARRELL LOWERY HURST
NIXON WEISS TRUJILLO ELLISON SLOAN
JUAREZ WINTERS MCLEAN RANDOLPH LEON
BOYER VILLARREAL MCCALL GENTRY CARRILLO
KENT AYERS LARA SHANNON SEXTON
PACE HULL LEBLANC BROWNING VELASQUEZ
LEACH CHANG HOUSE SELLERS HERRING
NOBLE FOLEY BARTLETT MERCADO LANDRY
DURHAM WALLS BARR MCKEE BAUER
RIVERS EVERETT BRADSHAW PUGH VELEZ
RUSH ESTES DODSON MORSE SHEPPARD
WEEKS CAMACHO BEAN BARRON LIVINGSTON
MIDDLETON SPEARS BRANCH BLEVINS CHEN
KERR MCCONNELL HATFIELD HARDING ASHLEY
SOLIS HERMAN FROST GILES BLACKBURN
WILLIAM PENNINGTON WOODWARD FINLEY MCINTOSH
KOCH BEST SOLOMON MCCULLOUGH DUDLEY
NOLAN BLANCHARD RIVAS BRENNAN MEJIA
KANE BENTON JOYCE BUCKLEY HALEY
VALENTINE MADDOX RUSSO MCKNIGHT BUCK
MOON MCMILLAN CROSBY BERG DOTSON
MAYS ROACH CHURCH CHAN RICHMOND
MEADOWS FAULKNER ONEILL KNAPP KLINE
BARRY OCHOA JACOBSON GAY AVERY
HENDRICKS HORNE SHEPARD HEBERT CHERRY
CARDENAS MCINTYRE WHITNEY WALLER HOLMAN
DONALDSON CANTU TERRELL MORIN GILLESPIE
FUENTES TILLMAN SANFORD BENTLEY PECK
KEY SALAS ROLLINS GAMBLE DICKSON
BATTLE SANTANA CABRERA CERVANTES HOWE
HINTON HURLEY SPENCE ZAMORA YANG
MCNEIL SUAREZ CASE PETTY GOULD
MCFARLAND SAMPSON CARVER BRAY ROSARIO
MACDONALD STOUT HESTER MELENDEZ DILLON
FARLEY HOPPER GALLOWAY POTTS BERNARD
JOYNER STEIN AGUIRRE OSBORN MERCER
BENDER FRANCO ROWLAND SYKES BENJAMIN
TRAVIS PICKETT CRANE SEARS MAYO
DUNLAP HAYDEN WILDER MCKAY COFFEY
MCCARTY EWING COOLEY VAUGHAN BONNER
COTTON HOLDER STARK FERRELL CANTRELL
FULTON LYNN LOTT CALDERON ROSA
POLLARD HOOPER BURCH MULLEN FRY
RIDDLE LEVY DAVID DUKE ODONNELL
GUY MICHAEL BRITT FREDERICK DAUGHERTY
BERGER DILLARD ALSTON JARVIS FRYE
RIGGS CHANEY ODOM DUFFY FITZPATRICK
VALENZUELA MERRILL MAYER ALFORD MCPHERSON
ACEVEDO DONOVAN BARRERA ALBERT COTE
REILLY COMPTON RAYMOND MOONEY MCGOWAN
CRAFT CLEVELAND CLEMONS WYNN NIELSEN
BAIRD STANTON SNIDER ROSALES BRIGHT
WITT STUART HAYS HOLDEN RUTLEDGE
KINNEY CLEMENTS CASTANEDA SLATER HAHN
EMERSON CONRAD BURKS DELANEY PATE
LANCASTER SWEET JUSTICE TYSON SHARPE
WHITFIELD TALLEY MACIAS IRWIN BURRIS
RATLIFF MCCRAY MADDEN KAUFMAN BEACH
GOFF CASH BOLTON MCFADDEN LEVINE
GOOD BYERS KIRKLAND KIDD WORKMAN
CARNEY DALE MCLEOD HOLCOMB ENGLAND
FINCH HEAD BURT HENDRIX SOSA
HANEY FRANKS SARGENT NIEVES DOWNS
RASMUSSEN BIRD HEWITT LINDSAY LE
FOREMAN VALENCIA ONEIL DELACRUZ VINSON
DEJESUS HYDE FORBES GILLIAM GUTHRIE
WOOTEN HUBER BARLOW BOYLE MCMAHON
BUCKNER ROCHA PUCKETT LANGLEY KNOWLES
COOKE VELAZQUEZ WHITLEY NOEL VANG
))) (range 1 1001)))
(define (sign name)
; telephone keyboard A B C D E F G H I J K L M N O P Q R S T U V W X Y Z
(define keys (vector 2 2 2 3 3 3 4 4 4 5 5 5 6 6 6 7 7 7 7 8 8 8 9 9 9 9))
(define (lookup c) (vector-ref keys (- (char->integer c) 65)))
(map lookup (string->list name)))
(define t (make-hash))
(do ((ss surnames (cdr ss))) ((null? ss))
(set! t (t 'update (sign (caar ss))
(lambda (k v) (cons (car ss) v))
(list (car ss)))))
(define (lookup name)
(cdr (t 'lookup (sign name))))
(display (lookup "WILLIAMS")) (newline)
(display (lookup "CARR")) (newline)
programmingpraxis
-
Scheme,
pasted
on Jul 23: