fork download
copy 
  1. ; distinct words
  2.  
  3. (define (make-dict lt?)
  4.  
  5.   (define-syntax define-generator
  6.     (lambda (x)
  7.       (syntax-case x (lambda)
  8.         ((stx name (lambda formals e0 e1 ...))
  9.            (with-syntax ((yield (datum->syntax (syntax stx) 'yield)))
  10.              (syntax (define name
  11.                (lambda formals
  12.                  (let ((resume #f) (return #f))
  13.                    (define yield
  14.                      (lambda args
  15.                        (call-with-current-continuation
  16.                         (lambda (cont)
  17.                           (set! resume cont)
  18.                           (apply return args)))))
  19.                    (lambda ()
  20.                      (call-with-current-continuation
  21.                       (lambda (cont)
  22.                         (set! return cont)
  23.                         (cond (resume (resume))
  24.                         (else (let () e0 e1 ...)
  25.                               (error 'name "unexpected return"))))))))))))
  26.           ((stx (name . formals) e0 e1 ...)
  27.             (syntax (stx name (lambda formals e0 e1 ...)))))))
  28.  
  29.   (define (tree k v l r)
  30.     (vector k v l r (+ (max (ht l) (ht r)) 1)
  31.                     (+ (size l) (size r) 1)))
  32.   (define (key t) (vector-ref t 0))
  33.   (define (val t) (vector-ref t 1))
  34.   (define (lkid t) (vector-ref t 2))
  35.   (define (rkid t) (vector-ref t 3))
  36.   (define (ht t) (vector-ref t 4))
  37.   (define (size t) (vector-ref t 5))
  38.   (define (bal t) (- (ht (lkid t)) (ht (rkid t))))
  39.   (define nil (vector 'nil 'nil 'nil 'nil 0 0))
  40.   (define (nil? t) (eq? t nil))
  41.  
  42.   (define (rot-left t)
  43.     (if (nil? t) t
  44.       (tree (key (rkid t))
  45.             (val (rkid t))
  46.             (tree (key t) (val t) (lkid t) (lkid (rkid t)))
  47.             (rkid (rkid t)))))
  48.  
  49.   (define (rot-right t)
  50.     (if (nil? t) t
  51.       (tree (key (lkid t))
  52.             (val (lkid t))
  53.             (lkid (lkid t))
  54.             (tree (key t) (val t) (rkid (lkid t)) (rkid t)))))
  55.  
  56.   (define (balance t)
  57.     (let ((b (bal t)))
  58.       (cond ((< (abs b) 2) t)
  59.             ((positive? b)
  60.               (if (< -1 (bal (lkid t))) (rot-right t)
  61.                 (rot-right (tree (key t) (val t)
  62.                   (rot-left (lkid t)) (rkid t)))))
  63.             ((negative? b)
  64.               (if (< (bal (rkid t)) 1) (rot-left t)
  65.                 (rot-left (tree (key t) (val t)
  66.                   (lkid t) (rot-right (rkid t)))))))))
  67.  
  68.   (define (lookup t k)
  69.     (cond ((nil? t) #f)
  70.           ((lt? k (key t)) (lookup (lkid t) k))
  71.           ((lt? (key t) k) (lookup (rkid t) k))
  72.           (else (cons k (val t)))))
  73.  
  74.   (define (insert t k v)
  75.     (cond ((nil? t) (tree k v nil nil))
  76.           ((lt? k (key t))
  77.             (balance (tree (key t) (val t)
  78.               (insert (lkid t) k v) (rkid t))))
  79.           ((lt? (key t) k)
  80.             (balance (tree (key t) (val t)
  81.               (lkid t) (insert (rkid t) k v))))
  82.           (else (tree k v (lkid t) (rkid t)))))
  83.  
  84.   (define (update t f k v)
  85.     (cond ((nil? t) (tree k v nil nil))
  86.           ((lt? k (key t))
  87.             (balance (tree (key t) (val t)
  88.               (update (lkid t) f k v) (rkid t))))
  89.           ((lt? (key t) k)
  90.             (balance (tree (key t) (val t)
  91.               (lkid t) (update (rkid t) f k v))))
  92.           (else (tree k (f k (val t)) (lkid t) (rkid t)))))
  93.  
  94.   (define (delete-successor t)
  95.     (if (nil? (lkid t)) (values (rkid t) (key t) (val t))
  96.       (call-with-values
  97.         (lambda () (delete-successor (lkid t)))
  98.         (lambda (l k v)
  99.           (values (balance (tree (key t) (val t) l (rkid t))) k v)))))
  100.  
  101.   (define (delete t k)
  102.     (cond ((nil? t) nil)
  103.           ((lt? k (key t))
  104.             (balance (tree (key t) (val t)
  105.               (delete (lkid t) k) (rkid t))))
  106.           ((lt? (key t) k)
  107.             (balance (tree (key t) (val t)
  108.               (lkid t) (delete (rkid t) k))))
  109.           ((nil? (lkid t)) (rkid t))
  110.           ((nil? (rkid t)) (lkid t))
  111.           (else (call-with-values
  112.                   (lambda () (delete-successor (rkid t)))
  113.                   (lambda (r k v) (balance (tree k v (lkid t) r)))))))
  114.  
  115.   (define (nth t n)
  116.     (if (negative? n) (error 'nth "must be non-negative")
  117.       (let ((s (size (lkid t))))
  118.         (cond ((< n s) (nth (lkid t) n))
  119.               ((< s n) (nth (rkid t) (- n s 1)))
  120.               ((nil? t) #f)
  121.               (else (cons (key t) (val t)))))))
  122.  
  123.   (define (rank t k)
  124.     (let loop ((t t) (s (size (lkid t))))
  125.       (cond ((nil? t) #f)
  126.             ((lt? k (key t))
  127.               (loop (lkid t) (size (lkid (lkid t)))))
  128.             ((lt? (key t) k)
  129.               (loop (rkid t) (+ s (size (lkid (rkid t))) 1)))
  130.             (else s))))
  131.  
  132.   (define (avl-map proc t) ; (proc key value)
  133.     (if (nil? t) nil
  134.       (tree (key t) (proc (key t) (val t))
  135.             (avl-map proc (lkid t))
  136.             (avl-map proc (rkid t)))))
  137.  
  138.   (define (avl-fold proc base t) ; (proc key value base)
  139.     (if (nil? t) base
  140.       (avl-fold proc
  141.                 (proc (key t) (val t)
  142.                       (avl-fold proc base (lkid t)))
  143.                 (rkid t))))
  144.  
  145.   (define (avl-for-each proc t) ; (proc key value)
  146.     (unless (nil? t)
  147.       (avl-for-each proc (lkid t))
  148.       (proc (key t) (val t))
  149.       (avl-for-each proc (rkid t))))
  150.  
  151.   (define (to-list t)
  152.     (cond ((nil? t) (list))
  153.           ((and (nil? (lkid t)) (nil? (rkid t)))
  154.             (list (cons (key t) (val t))))
  155.           (else (append (to-list (lkid t))
  156.                         (list (cons (key t) (val t)))
  157.                         (to-list (rkid t))))))
  158.  
  159.   (define (from-list t xs)
  160.     (let loop ((xs xs) (t t))
  161.       (if (null? xs) t
  162.         (loop (cdr xs) (insert t (caar xs) (cdar xs))))))
  163.  
  164.   (define-generator (make-gen t)
  165.     (avl-for-each (lambda (k v) (yield (cons k v))) t)
  166.     (do () (#f) (yield #f)))
  167.  
  168.   (define (new dict)
  169.     (lambda (message . args) (dispatch dict message args)))
  170.  
  171.   (define (dispatch dict message args)
  172.     (define (arity n)
  173.       (if (not (= (length args) n)) (error 'dict "incorrect arity")))
  174.     (case message
  175.       ((empty? nil?) (arity 0) (nil? dict))
  176.       ((lookup fetch get) (arity 1) (apply lookup dict args))
  177.       ((insert store put) (arity 2) (new (apply insert dict args)))
  178.       ((update) (arity 3) (new (apply update dict args)))
  179.       ((delete remove) (arity 1) (new (apply delete dict args)))
  180.       ((size count length) (arity 0) (size dict))
  181.       ((nth) (arity 1) (apply nth dict args))
  182.       ((rank) (arity 1) (apply rank dict args))
  183.       ((map) (arity 1) (new (avl-map (car args) dict)))
  184.       ((fold) (arity 2) (avl-fold (car args) (cadr args) dict))
  185.       ((for-each) (arity 1) (avl-for-each (car args) dict))
  186.       ((to-list enlist) (arity 0) (to-list dict))
  187.       ((from-list) (arity 1) (new (apply from-list dict args)))
  188.       ((make-gen gen) (arity 0) (make-gen dict))
  189.       (else (error 'dict "invalid message"))))
  190.  
  191.   (vector-set! nil 2 nil) (vector-set! nil 3 nil) (new nil))
  192.  
  193. (define (read-line . port)
  194.   (define (eat p c)
  195.     (if (and (not (eof-object? (peek-char p)))
  196.              (char=? (peek-char p) c))
  197.         (read-char p)))
  198.   (let ((p (if (null? port) (current-input-port) (car port))))
  199.     (let loop ((c (read-char p)) (line '()))
  200.       (cond ((eof-object? c) (if (null? line) c (list->string (reverse line))))
  201.             ((char=? #\newline c) (eat p #\return) (list->string (reverse line)))
  202.             ((char=? #\return c) (eat p #\newline) (list->string (reverse line)))
  203.             (else (loop (read-char p) (cons c line)))))))
  204.  
  205. (define (sort-unique)
  206.     (let ((words (make-dict string<?)))
  207.       (do ((word (read-line) (read-line)))
  208.           ((eof-object? word)
  209.             (for-each
  210.               (lambda (word)
  211.                 (display word) (newline))
  212.               (map car (words 'to-list))))
  213.         (set! words
  214.           (words 'update (lambda (k v) (+ v 1))
  215.                  word 1)))))
  216.  
  217. (sort-unique)
Success #stdin #stdout 0.03s 9128KB
comments (?)
stdin
copy 
bravo
alfa
charlie
echo
delta
charlie
delta
alfa
bravo
alfa
delta
bravo
delta
alfa
alfa
stdout
copy 
alfa
bravo
charlie
delta
echo
https://ideone.com/ogxnFq
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!