[ create a new paste ] login | about

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

programmingpraxis - Scheme, pasted on May 26:
; streaming median

(define pq-empty '())
(define pq-empty? null?)

(define (pq-first pq)
  (if (null? pq)
      (error 'pq-first "can't extract minimum from null queue")
      (car pq)))

(define (pq-merge lt? p1 p2)
  (cond ((null? p1) p2)
        ((null? p2) p1)
        ((lt? (car p2) (car p1))
          (cons (car p2) (cons p1 (cdr p2))))
        (else (cons (car p1) (cons p2 (cdr p1))))))

(define (pq-insert lt? x pq)
  (pq-merge lt? (list x) pq))

(define (pq-merge-pairs lt? ps)
  (cond ((null? ps) '())
        ((null? (cdr ps)) (car ps))
        (else (pq-merge lt? (pq-merge lt? (car ps) (cadr ps))
                            (pq-merge-pairs lt? (cddr ps))))))

(define (pq-rest lt? pq)
  (if (null? pq)
      (error 'pq-rest "can't delete minimum from null queue")
      (pq-merge-pairs lt? (cdr pq))))

(define (streaming-medians xs)
  (define (median left lcount right rcount)
    (cond ((< lcount rcount) (pq-first right))
          ((< rcount lcount) (pq-first left))
          (else (/ (+ (pq-first left) (pq-first right)) 2))))
  (if (null? xs) xs
    (let loop ((xs (cdr xs))
               (left (pq-insert < (car xs) pq-empty))
               (lcount 1) (right pq-empty) (rcount 0)
               (ms (list (car xs))))
      (cond ((null? xs) (reverse ms))
            ((< (car xs) (pq-first left))
              (set! left (pq-insert > (car xs) left))
              (set! lcount (+ lcount 1))
              (when (< 1 (- lcount rcount))
                (set! right (pq-insert < (pq-first left) right))
                (set! left (pq-rest > left))
                (set! rcount (+ rcount 1))
                (set! lcount (- lcount 1)))
              (loop (cdr xs) left lcount right rcount
                (cons (median left lcount right rcount) ms)))
            (else
              (set! right (pq-insert < (car xs) right))
              (set! rcount (+ rcount 1))
              (when (< 1 (- rcount lcount))
                (set! left (pq-insert > (pq-first right) left))
                (set! right (pq-rest < right))
                (set! lcount (+ lcount 1))
                (set! rcount (- rcount 1)))
              (loop (cdr xs) left lcount right rcount
                (cons (median left lcount right rcount) ms)))))))

(display (streaming-medians '(3 7 4 1 2 6 5))) (newline)


Output:
1
(3 5 4 7/2 3 7/2 4)


Create a new paste based on this one


Comments: