fork download
copy 
  1. ; bigger to the right
  2.  
  3. (define (make-avl 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) (- s (size (rkid (lkid t))) 1)))
  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.       ((root) dict) ; for debugging
  190.       (else (error 'dict "invalid message"))))
  191.  
  192.   (vector-set! nil 2 nil) (vector-set! nil 3 nil) (new nil))
  193.  
  194. (define (f1 xs)
  195.   (define (gt? x) (lambda (y) (< x y)))
  196.   (let loop ((xs xs) (zs (list)))
  197.     (if (null? xs) (reverse zs)
  198.       (loop (cdr xs) (cons (length (filter (gt? (car xs)) (cdr xs))) zs)))))
  199.  
  200. (define (f2 xs)
  201.   (let loop ((xs (reverse xs)) (zs (list)) (t (make-avl <)))
  202.     (if (null? xs) zs
  203.       (let* ((t (t 'insert (car xs) (car xs)))
  204.              (z (- (length zs) (t 'rank (car xs)))))
  205.         (loop (cdr xs) (cons z zs) t)))))
  206.  
  207. (display (f1 '(10 12 8 17 3 24 19))) (newline)
  208. (display (f2 '(10 12 8 17 3 24 19))) (newline)
Runtime error #stdin #stdout #stderr 0.01s 7728KB
comments (?)
stdin
copy 
Standard input is empty
stdout
copy 
Standard output is empty
stderr
copy 
Error: during expansion of (lambda ...) - in `lambda' - pair expected: (lambda)

	Call history:

	<syntax>	  (define (make-avl lt?) (define-syntax define-generator (lambda (x) (syntax-case x (lambda) ((stx nam...
	<syntax>	  (##core#set! make-avl (##core#lambda (lt?) (define-syntax define-generator (lambda (x) (syntax-case ...
	<syntax>	  (##core#lambda (lt?) (define-syntax define-generator (lambda (x) (syntax-case x (lambda) ((stx name ...
	<syntax>	  [make-avl] (##core#begin (##core#letrec-syntax ((define-generator (lambda (x) (syntax-case x (lambda) ((stx nam...
	<syntax>	  [make-avl] (##core#letrec-syntax ((define-generator (lambda (x) (syntax-case x (lambda) ((stx name (lambda form...
	<syntax>	  (lambda (x) (syntax-case x (lambda) ((stx name (lambda formals e0 e1 ...)) (with-syntax ((yield (dat...
	<syntax>	  (##core#lambda (x) (syntax-case x (lambda) ((stx name (lambda formals e0 e1 ...)) (with-syntax ((yie...
	<syntax>	  (##core#begin (syntax-case x (lambda) ((stx name (lambda formals e0 e1 ...)) (with-syntax ((yield (d...
	<syntax>	  (syntax-case x (lambda) ((stx name (lambda formals e0 e1 ...)) (with-syntax ((yield (datum->syntax (...
	<syntax>	  (lambda)	<--
https://ideone.com/CoCl4p
language:
Scheme (chicken 4.13)
created:
2 years ago
visibility:
secret

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!