; distinct words (define (make-dict lt?) (define-syntax define-generator (lambda (x) (syntax-case x (lambda) ((stx name (lambda formals e0 e1 ...)) (with-syntax ((yield (datum->syntax (syntax stx) 'yield))) (syntax (define name (lambda formals (let ((resume #f) (return #f)) (define yield (lambda args (call-with-current-continuation (lambda (cont) (set! resume cont) (apply return args))))) (lambda () (call-with-current-continuation (lambda (cont) (set! return cont) (cond (resume (resume)) (else (let () e0 e1 ...) (error 'name "unexpected return")))))))))))) ((stx (name . formals) e0 e1 ...) (syntax (stx name (lambda formals e0 e1 ...))))))) (define (tree k v l r) (vector k v l r (+ (max (ht l) (ht r)) 1) (+ (size l) (size r) 1))) (define (key t) (vector-ref t 0)) (define (val t) (vector-ref t 1)) (define (lkid t) (vector-ref t 2)) (define (rkid t) (vector-ref t 3)) (define (ht t) (vector-ref t 4)) (define (size t) (vector-ref t 5)) (define (bal t) (- (ht (lkid t)) (ht (rkid t)))) (define nil (vector 'nil 'nil 'nil 'nil 0 0)) (define (nil? t) (eq? t nil)) (define (rot-left t) (if (nil? t) t (tree (key (rkid t)) (val (rkid t)) (tree (key t) (val t) (lkid t) (lkid (rkid t))) (rkid (rkid t))))) (define (rot-right t) (if (nil? t) t (tree (key (lkid t)) (val (lkid t)) (lkid (lkid t)) (tree (key t) (val t) (rkid (lkid t)) (rkid t))))) (define (balance t) (let ((b (bal t))) (cond ((< (abs b) 2) t) ((positive? b) (if (< -1 (bal (lkid t))) (rot-right t) (rot-right (tree (key t) (val t) (rot-left (lkid t)) (rkid t))))) ((negative? b) (if (< (bal (rkid t)) 1) (rot-left t) (rot-left (tree (key t) (val t) (lkid t) (rot-right (rkid t))))))))) (define (lookup t k) (cond ((nil? t) #f) ((lt? k (key t)) (lookup (lkid t) k)) ((lt? (key t) k) (lookup (rkid t) k)) (else (cons k (val t))))) (define (insert t k v) (cond ((nil? t) (tree k v nil nil)) ((lt? k (key t)) (balance (tree (key t) (val t) (insert (lkid t) k v) (rkid t)))) ((lt? (key t) k) (balance (tree (key t) (val t) (lkid t) (insert (rkid t) k v)))) (else (tree k v (lkid t) (rkid t))))) (define (update t f k v) (cond ((nil? t) (tree k v nil nil)) ((lt? k (key t)) (balance (tree (key t) (val t) (update (lkid t) f k v) (rkid t)))) ((lt? (key t) k) (balance (tree (key t) (val t) (lkid t) (update (rkid t) f k v)))) (else (tree k (f k (val t)) (lkid t) (rkid t))))) (define (delete-successor t) (if (nil? (lkid t)) (values (rkid t) (key t) (val t)) (call-with-values (lambda () (delete-successor (lkid t))) (lambda (l k v) (values (balance (tree (key t) (val t) l (rkid t))) k v))))) (define (delete t k) (cond ((nil? t) nil) ((lt? k (key t)) (balance (tree (key t) (val t) (delete (lkid t) k) (rkid t)))) ((lt? (key t) k) (balance (tree (key t) (val t) (lkid t) (delete (rkid t) k)))) ((nil? (lkid t)) (rkid t)) ((nil? (rkid t)) (lkid t)) (else (call-with-values (lambda () (delete-successor (rkid t))) (lambda (r k v) (balance (tree k v (lkid t) r))))))) (define (nth t n) (if (negative? n) (error 'nth "must be non-negative") (let ((s (size (lkid t)))) (cond ((< n s) (nth (lkid t) n)) ((< s n) (nth (rkid t) (- n s 1))) ((nil? t) #f) (else (cons (key t) (val t))))))) (define (rank t k) (let loop ((t t) (s (size (lkid t)))) (cond ((nil? t) #f) ((lt? k (key t)) (loop (lkid t) (size (lkid (lkid t))))) ((lt? (key t) k) (loop (rkid t) (+ s (size (lkid (rkid t))) 1))) (else s)))) (define (avl-map proc t) ; (proc key value) (if (nil? t) nil (tree (key t) (proc (key t) (val t)) (avl-map proc (lkid t)) (avl-map proc (rkid t))))) (define (avl-fold proc base t) ; (proc key value base) (if (nil? t) base (avl-fold proc (proc (key t) (val t) (avl-fold proc base (lkid t))) (rkid t)))) (define (avl-for-each proc t) ; (proc key value) (unless (nil? t) (avl-for-each proc (lkid t)) (proc (key t) (val t)) (avl-for-each proc (rkid t)))) (define (to-list t) (cond ((nil? t) (list)) ((and (nil? (lkid t)) (nil? (rkid t))) (list (cons (key t) (val t)))) (else (append (to-list (lkid t)) (list (cons (key t) (val t))) (to-list (rkid t)))))) (define (from-list t xs) (let loop ((xs xs) (t t)) (if (null? xs) t (loop (cdr xs) (insert t (caar xs) (cdar xs)))))) (define-generator (make-gen t) (avl-for-each (lambda (k v) (yield (cons k v))) t) (do () (#f) (yield #f))) (define (new dict) (lambda (message . args) (dispatch dict message args))) (define (dispatch dict message args) (define (arity n) (if (not (= (length args) n)) (error 'dict "incorrect arity"))) (case message ((empty? nil?) (arity 0) (nil? dict)) ((lookup fetch get) (arity 1) (apply lookup dict args)) ((insert store put) (arity 2) (new (apply insert dict args))) ((update) (arity 3) (new (apply update dict args))) ((delete remove) (arity 1) (new (apply delete dict args))) ((size count length) (arity 0) (size dict)) ((nth) (arity 1) (apply nth dict args)) ((rank) (arity 1) (apply rank dict args)) ((map) (arity 1) (new (avl-map (car args) dict))) ((fold) (arity 2) (avl-fold (car args) (cadr args) dict)) ((for-each) (arity 1) (avl-for-each (car args) dict)) ((to-list enlist) (arity 0) (to-list dict)) ((from-list) (arity 1) (new (apply from-list dict args))) ((make-gen gen) (arity 0) (make-gen dict)) (else (error 'dict "invalid message")))) (vector-set! nil 2 nil) (vector-set! nil 3 nil) (new nil)) (define (read-line . port) (define (eat p c) (if (and (not (eof-object? (peek-char p))) (char=? (peek-char p) c)) (read-char p))) (let ((p (if (null? port) (current-input-port) (car port)))) (let loop ((c (read-char p)) (line '())) (cond ((eof-object? c) (if (null? line) c (list->string (reverse line)))) ((char=? #\newline c) (eat p #\return) (list->string (reverse line))) ((char=? #\return c) (eat p #\newline) (list->string (reverse line))) (else (loop (read-char p) (cons c line))))))) (define (sort-unique) (let ((words (make-dict string