[ create a new paste ] login | about

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

programmingpraxis - Scheme, pasted on Feb 19:
; sliding window minimum

(define (take n xs)
  (let loop ((n n) (xs xs) (ys '()))
    (if (or (zero? n) (null? xs))
        (reverse ys)
        (loop (- n 1) (cdr xs)
              (cons (car xs) ys)))))

(define (drop n xs)
  (let loop ((n n) (xs xs))
    (if (or (zero? n) (null? xs)) xs
      (loop (- n 1) (cdr xs)))))

(define (filter pred? xs)
  (let loop ((xs xs) (ys '()))
    (cond ((null? xs) (reverse ys))
          ((pred? (car xs))
            (loop (cdr xs) (cons (car xs) ys)))
          (else (loop (cdr xs) ys)))))

(define (make-list n x)
  (let loop ((n n) (xs '()))
    (if (zero? n) xs
      (loop (- n 1) (cons x xs)))))

(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-syntax assert
  (syntax-rules ()
    ((assert expr result)
      (if (not (equal? expr result))
          (for-each display `(
            #\newline "failed assertion:" #\newline
            expr #\newline "expected: " ,result
            #\newline "returned: " ,expr #\newline))))))

(define (make-sequence len symb)
  (map (lambda (x) (randint symb)) (make-list len #f)))

(define (slow-swm k vs)
  (let loop ((vs vs) (len (- (length vs) k -1)) (zs '()))
    (if (zero? len) (reverse zs)
      (loop (cdr vs) (- len 1)
        (cons (apply min (take k vs)) zs)))))

(define (right-most v vs)
  (let loop ((pos (- (length vs) 1)) (vs (reverse vs)))
    (if (= v (car vs)) pos
      (loop (- pos 1) (cdr vs)))))

(define (init k vs)
  (let loop ((ws (take k vs)) (as '()))
    (if (null? ws) (reverse as)
      (let* ((m (apply min ws)) (j (right-most m ws)))
        (loop (drop (+ j 1) ws)
              (cons (list m (+ k k (- (length ws)) j)) as))))))

(define (update j k v as)
  (let ((new-as (append (filter (lambda (z) (< (car z) v)) as)
                        (list (list v (+ j k))))))
    ;(display new-as) (newline)
    (if (< j (cadar new-as)) new-as (cdr new-as))))

(define (fast-swm k vs)
  (let loop ((j k) (vs (drop k vs)) (as (init k vs)) (rs '()))
    ;(display j) (display " ") (display vs) (display " ")
    ;(display as) (display " ") (display rs) (display " | ")
    (if (null? vs) (reverse (cons (caar as) rs))
      (let ((new-as (update j k (car vs) as)))
        ;(display new-as) (newline)
        (loop (+ j 1) (cdr vs) new-as (cons (caar as) rs))))))

(define (swm-test n)
  (do ((i 0 (+ i 1))) ((= i n))
    (let ((vs (make-sequence (randint 100 1000) (randint 10 500)))
          (k (randint 5 50)))
      (assert (slow-swm k vs) (fast-swm k vs)))))

(display (slow-swm 3 '(4 3 2 1 5 7 6 8 9))) (newline)
(display (fast-swm 3 '(4 3 2 1 5 7 6 8 9))) (newline)
(swm-test 100)


Output:
1
2
(2 1 1 1 5 6 6)
(2 1 1 1 5 6 6)


Create a new paste based on this one


Comments: