fork download
copy 
  1. ; words on a telephone keypad
  2.  
  3. (define (make-hash hash eql? oops size)
  4.   (let ((table (make-vector size '())))
  5.     (lambda (message . args)
  6.       (if (eq? message 'enlist)
  7.           (let loop ((k 0) (result '()))
  8.             (if (= size k)
  9.                 result
  10.                 (loop (+ k 1) (append (vector-ref table k) result))))
  11.           (let* ((key (car args))
  12.                  (index (modulo (hash key) size))
  13.                  (bucket (vector-ref table index)))
  14.             (case message
  15.               ((lookup fetch get ref recall)
  16.                 (let loop ((bucket bucket))
  17.                   (cond ((null? bucket) oops)
  18.                         ((eql? (caar bucket) key) (cdar bucket))
  19.                         (else (loop (cdr bucket))))))
  20.               ((insert insert! ins ins! set set! store store! install install!)
  21.                 (vector-set! table index
  22.                   (let loop ((bucket bucket))
  23.                     (cond ((null? bucket)
  24.                             (list (cons key (cadr args))))
  25.                           ((eql? (caar bucket) key)
  26.                             (cons (cons key (cadr args)) (cdr bucket)))
  27.                           (else (cons (car bucket) (loop (cdr bucket))))))))
  28.               ((delete delete! del del! remove remove!)
  29.                 (vector-set! table index
  30.                   (let loop ((bucket bucket))
  31.                     (cond ((null? bucket) '())
  32.                           ((eql? (caar bucket) key)
  33.                             (cdr bucket))
  34.                           (else (cons (car bucket) (loop (cdr bucket))))))))
  35.               ((update update!)
  36.                 (vector-set! table index
  37.                   (let loop ((bucket bucket))
  38.                     (cond ((null? bucket)
  39.                             (list (cons key (caddr args))))
  40.                           ((eql? (caar bucket) key)
  41.                             (cons (cons key ((cadr args) key (cdar bucket))) (cdr bucket)))
  42.                           (else (cons (car bucket) (loop (cdr bucket))))))))
  43.               (else (error 'hash-table "unrecognized message")) ))))))
  44.  
  45. (define (undigits ds . args)
  46.   (let ((b (if (null? args) 10 (car args))))
  47.     (let loop ((ds ds) (n 0))
  48.       (if (null? ds) n
  49.           (loop (cdr ds) (+ (* n b) (car ds)))))))
  50.  
  51. ; READ-LINE [PORT]
  52. (define (read-line . port)
  53.   (define (eat p c)
  54.     (if (and (not (eof-object? (peek-char p)))
  55.              (char=? (peek-char p) c))
  56.         (read-char p)))
  57.   (let ((p (if (null? port) (current-input-port) (car port))))
  58.     (let loop ((c (read-char p)) (line '()))
  59.       (cond ((eof-object? c) (if (null? line) c (list->string (reverse line))))
  60.             ((char=? #\newline c) (eat p #\return) (list->string (reverse line)))
  61.             ((char=? #\return c) (eat p #\newline) (list->string (reverse line)))
  62.             (else (loop (read-char p) (cons c line)))))))
  63.  
  64. ; FOR-EACH-PORT READER PROC [PORT]
  65. (define (for-each-port reader proc . port)
  66.   (let ((p (if (null? port) (current-input-port) (car port))))
  67.     (let loop ((item (reader p)))
  68.       (if (not (eof-object? item))
  69.         (begin (proc item) (loop (reader p)))))))
  70.  
  71. (define (sign str)
  72.   ; 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
  73.   (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))
  74.   (define (lookup c) (vector-ref keys (- (char->integer c) 65)))
  75.   (undigits (map lookup (filter char-alphabetic? (string->list (string-upcase str))))))
  76.  
  77. (define table (make-hash (lambda (x) x) = (list) 997))
  78.  
  79. (define (insert word)
  80.   (table 'update! (sign word) (lambda (key words) (cons word words)) (list word)))
  81.  
  82. (define (lookup signature) (sort (table 'lookup signature) string<?))
  83.  
  84. (for-each-port read-line insert)
  85.  
  86. (display (lookup 228)) (newline)
  87. (display (lookup 2268)) (newline)
  88. (display (lookup 772947)) (newline)
  89. (display (lookup 12345)) (newline)
Success #stdin #stdout 0.02s 8952KB
comments (?)
stdin
copy 
"act"
"bat"
"cat"
"can't"
"PRAXIS"
stdout
copy 
("act" "bat" "cat")
("can't")
("PRAXIS")
()
https://ideone.com/JiwqfI
language:
Scheme (guile 2.2.4)
created:
7 years ago
visibility:
public

Share or Embed source code

Discover > Sphere Engine API

The brand new service which powers Ideone!

Discover > IDE Widget

Widget for compiling and running the source code in a web browser!