## Chez Scheme Setup

### October 3, 2017

; avl.ss (define (make-avl-tree 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) (- s (size (lkid (lkid t))) 1))) ((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))

Advertisements

My apologies; the formatting got really messed up. I’ll work on fixing through the day today.

I think the pairing heap implementation will not scale to beyond stack limits since it uses non-tail recursion. An easy fix would be to replace the recursive calls in pq-merge-pairs with a fold of pq-merge on pre-paired arguments.

[…] There are several pattern-matching libraries available for Scheme, but they are rather heavy (the one I use, by Friedman, Hilsdale and Dybvig, is over six hundred lines of code). Our Standard Prelude has a […]