[ create a new paste ] login | about

Project: programmingpraxis
Link: http://programmingpraxis.codepad.org/rsJImeg0    [ raw code | output | fork ]

programmingpraxis - Scheme, pasted on Jun 27:
; sliding median

(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-object (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 seed 20120629)

(define (next)
  (let ((x seed))
    (set! seed (modulo (* 69069 seed) 2147483647)) x))

(define (sliding-median k next n)
  (let ((window (make-vector k)) (xs (make-dict <)))
    (do ((i 0 (+ i 1))) ((= i k))
      (let ((x (next)))
        (vector-set! window i x)
        (set! xs (xs 'insert x x))))
    (do ((i 0 (+ i 1))) ((= i n))
      (let ((x (next)))
        (display
          (if (odd? k)
              (car (xs 'nth (quotient k 2)))
              (/ (+ (car (xs 'nth (quotient k 2)))
                    (car (xs 'nth (+ (quotient k 2) 1))))
                 2)))
        (newline)
        (set! xs (xs 'delete (vector-ref window (modulo i k))))
        (set! xs (xs 'insert x x))
        (vector-set! window (modulo i k) x)))))

(sliding-median 5 next 10)


Output:
1
2
3
4
5
6
7
8
9
10
244351652
244351652
244351652
244351652
830271843
1498204365
1498204365
1236106396
1236106396
1272795192


Create a new paste based on this one


Comments: