[ create a new paste ] login | about

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

programmingpraxis - Scheme, pasted on Aug 19:
; marriage sort

(define (isqrt n)
  (if (not (and (positive? n) (integer? n)))
      (error 'isqrt "must be positive integer")
      (let loop ((x n))
        (let ((y (quotient (+ x (quotient n x)) 2)))
          (if (< y x) (loop y) x)))))

(define-syntax when
  (syntax-rules ()
    ((when pred? expr ...)
      (if pred? (begin expr ...)))))

(define-syntax while
  (syntax-rules ()
    ((while pred? body ...)
      (do () ((not pred?)) body ...))))

(define (isort! lt? vec) ; insertion sort
  (define (v i) (vector-ref vec i))
  (define (v! i x) (vector-set! vec i x))
  (define (swap! i j) (let ((t (v i))) (v! i (v j)) (v! j t)))
  (let ((n (vector-length vec)))
    (do ((i 0 (+ i 1))) ((= i n))
      (do ((j i (- j 1)))
          ((or (<= j 0) (< (v (- j 1)) (v j))))
        (swap! (- j 1) j)))))

(define (msort! lt? vec) ; marriage sort
  (define (v i) (vector-ref vec i))
  (define (v! i x) (vector-set! vec i x))
  (define (swap! i j) (let ((t (v i))) (v! i (v j)) (v! j t)))
  (let* ((end (- (vector-length vec) 1))
         (skip (if (positive? end) (isqrt end) -1)))
    (while (<= 0 skip)
      (let ((vbest 0) (i 1))
        (while (< i skip)
          (when (lt? (v vbest) (v i)) (set! vbest i))
          (set! i (+ i 1)))
        (while (< i end)
          (if (lt? (v vbest) (v i))
              (begin (swap! i end) (set! end (- end 1)))
              (set! i (+ i 1))))
        (swap! vbest end)
        (set! end (- end 1))
        (set! skip (if (positive? end) (isqrt end) -1)))))
  (isort! lt? vec))

(define v (vector 5 7 8 10 3 2 9 4 6 1))
(msort! < v)
(display v)


Output:
1
#(1 2 3 4 5 6 7 8 9 10)


Create a new paste based on this one


Comments: