[ create a new paste ] login | about

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

programmingpraxis - Scheme, pasted on Jan 21:
; splay heaps

(define (range . args)
  (case (length args)
    ((1) (range 0 (car args) (if (negative? (car args)) -1 1)))
    ((2) (range (car args) (cadr args) (if (< (car args) (cadr args)) 1 -1)))
    ((3) (let ((le? (if (negative? (caddr args)) >= <=)))
           (let loop ((x(car args)) (xs '()))
             (if (le? (cadr args) x)
                 (reverse xs)
                 (loop (+ x (caddr args)) (cons x xs))))))
    (else (error 'range "unrecognized arguments"))))

(define rand #f)
(define randint #f)
(let ((two31 #x80000000) (a (make-vector 56 -1)) (fptr #f))
  (define (mod-diff x y) (modulo (- x y) two31)) ; generic version
  ; (define (mod-diff x y) (logand (- x y) #x7FFFFFFF)) ; fast version
  (define (flip-cycle)
    (do ((ii 1 (+ ii 1)) (jj 32 (+ jj 1))) ((< 55 jj))
      (vector-set! a ii (mod-diff (vector-ref a ii) (vector-ref a jj))))
    (do ((ii 25 (+ ii 1)) (jj 1 (+ jj 1))) ((< 55 ii))
      (vector-set! a ii (mod-diff (vector-ref a ii) (vector-ref a jj))))
    (set! fptr 54) (vector-ref a 55))
  (define (init-rand seed)
    (let* ((seed (mod-diff seed 0)) (prev seed) (next 1))
      (vector-set! a 55 prev)
      (do ((i 21 (modulo (+ i 21) 55))) ((zero? i))
        (vector-set! a i next) (set! next (mod-diff prev next))
        (set! seed (+ (quotient seed 2) (if (odd? seed) #x40000000 0)))
        (set! next (mod-diff next seed)) (set! prev (vector-ref a i)))
      (flip-cycle) (flip-cycle) (flip-cycle) (flip-cycle) (flip-cycle)))
  (define (next-rand)
    (if (negative? (vector-ref a fptr)) (flip-cycle)
      (let ((next (vector-ref a fptr))) (set! fptr (- fptr 1)) next)))
  (define (unif-rand m)
    (let ((t (- two31 (modulo two31 m))))
      (let loop ((r (next-rand)))
        (if (<= t r) (loop (next-rand)) (modulo r m)))))
  (init-rand 19380110) ; happy birthday donald e knuth
  (set! rand (lambda seed
    (cond ((null? seed) (/ (next-rand) two31))
          ((eq? (car seed) 'get) (cons fptr (vector->list a)))
          ((eq? (car seed) 'set) (set! fptr (caadr seed))
                                 (set! a (list->vector (cdadr seed))))
          (else (/ (init-rand (modulo (numerator
                  (inexact->exact (car seed))) two31)) two31)))))
  (set! randint (lambda args
    (cond ((null? (cdr args))
            (if (< (car args) two31) (unif-rand (car args))
              (floor (* (next-rand) (car args)))))
          ((< (car args) (cadr args))
            (let ((span (- (cadr args) (car args))))
              (+ (car args)
                 (if (< span two31) (unif-rand span)
                   (floor (* (next-rand) span))))))
          (else (let ((span (- (car args) (cadr args))))
                  (- (car args)
                     (if (< span two31) (unif-rand span)
                       (floor (* (next-rand) span))))))))))

(define (shuffle x)
  (do ((v (list->vector x)) (n (length x) (- n 1)))
      ((zero? n) (vector->list v))
    (let* ((r (randint n)) (t (vector-ref v r)))
      (vector-set! v r (vector-ref v (- n 1)))
      (vector-set! v (- n 1) t))))

(define heap vector) ; lkid item rkid

(define (lkid h) (vector-ref h 0))
(define (item h) (vector-ref h 1))
(define (rkid h) (vector-ref h 2))

(define empty (heap 'empty 'empty 'empty))
(vector-set! empty 1 empty)
(vector-set! empty 2 empty)
(define (empty? h) (eqv? h empty))

(define (partition lt? pivot h)
  (if (empty? h) (values h h)
    (if (lt? (item h) pivot)
        (if (empty? (rkid h))
            (values h empty)
            (if (lt? (item (rkid h)) pivot)
                (call-with-values
                  (lambda ()
                    (partition lt? pivot (rkid (rkid h))))
                  (lambda (small big)
                    (values (heap (heap (lkid h) (item h)
                                        (lkid (rkid h)))
                                  (item (rkid h)) small)
                            big)))
                (call-with-values
                  (lambda ()
                    (partition lt? pivot (lkid (rkid h))))
                  (lambda (small big)
                    (values (heap (lkid h) (item h) small)
                            (heap big (item (rkid h))
                                  (rkid (rkid h))))))))
        (if (empty? (lkid h))
            (values empty h)
            (if (lt? (item (lkid h)) pivot)
                (call-with-values
                  (lambda ()
                    (partition lt? pivot (rkid (lkid h))))
                  (lambda (small big)
                    (values (heap (lkid (lkid h))
                                  (item (lkid h)) small)
                            (heap big (item h) (rkid h)))))
                (call-with-values
                  (lambda ()
                    (partition lt? pivot (lkid (lkid h))))
                  (lambda (small big)
                    (values small
                            (heap big (item (lkid h))
                                  (heap (rkid (lkid h))
                                        (item h) (rkid h)))))))))))

(define (insert lt? x h)
  (call-with-values
    (lambda () (partition lt? x h))
    (lambda (a b) (heap a x b))))

(define (first lt? h)
  (cond ((empty? h) (error 'first "empty queue"))
        ((empty? (lkid h)) (item h))
        (else (first lt? (lkid h)))))

(define (rest lt? h)
  (cond ((empty? h) (error 'rest "empty queue"))
        ((empty? (lkid h)) (rkid h))
        ((empty? (lkid (lkid h)))
          (heap (rkid (lkid h)) (item h) (rkid h)))
        (else (heap (rest lt? (lkid (lkid h)))
                    (item (lkid h))
                    (heap (rkid (lkid h)) (item h) (rkid h))))))

(define (heap-sort lt? xs)
  (let loop ((xs xs) (h empty))
    (if (pair? xs)
        (loop (cdr xs) (insert lt? (car xs) h))
        (let loop ((h h) (zs (list)))
          (if (empty? h)
              (reverse zs)
              (loop (rest lt? h) (cons (first lt? h) zs)))))))

(display (heap-sort < (range 25))) (newline)
(display (heap-sort > (range 25))) (newline)
(display (heap-sort < (shuffle (range 25)))) (newline)


Output:
1
2
3
(0 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24)
(24 23 22 21 20 19 18 17 16 15 14 13 12 11 10 9 8 7 6 5 4 3 2 1 0)
(0 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24)


Create a new paste based on this one


Comments: