fork(1) download
copy 
  1. ; an array exercise
  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 (lkid (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.       (else (error 'dict "invalid message"))))
  190.  
  191.   (vector-set! nil 2 nil) (vector-set! nil 3 nil) (new nil))
  192.  
  193. (define (rank vec)
  194.   (let ((dict (make-avl <)))
  195.     (do ((i 0 (+ i 1))) ((= i (vector-length vec)))
  196.       (set! dict (dict 'insert (vector-ref vec i) (vector-ref vec i))))
  197.     (do ((i 0 (+ i 1))) ((= i (vector-length vec)) vec)
  198.       (vector-set! vec i (+ 1 (dict 'rank (vector-ref vec i)))))))
  199.  
  200. (display (rank '#(10 8 15 12 6 20 1))) (newline)
Success #stdin #stdout 0.07s 9112KB
comments (?)
stdin
copy 
Standard input is empty
stdout
copy 
#(4 3 6 5 2 7 1)
https://ideone.com/tF9m40
language:
Scheme (guile 2.2.4)
created:
5 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!