[ create a new paste ] login | about

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

programmingpraxis - Scheme, pasted on Apr 11:
; booth's algorithm

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

(define (last-pair xs)
  (if (null? (cdr xs)) xs
    (last-pair (cdr xs))))

(define (cycle . xs) (set-cdr! (last-pair xs) xs) xs)

(define (len xs)
  (let loop ((ys (cdr xs)) (n 1))
    (if (eq? xs ys) n (loop (cdr ys) (+ n 1)))))

(define (booth lt? xs)
  (define (eq? a b)
    (and (not (lt? a b)) (not (lt? b a))))
  (let* ((n (len xs)) ; length of cycle
         (xv (make-vector (+ n n))) ; elements of cycle, repeated
         (fv (make-vector (+ n n) -1)) ; failure function
         (k 0)) ; current minimum rotation
    (do ((i 0 (+ i 1)) (xs xs (cdr xs))) ((= n i))
      (vector-set! xv i (car xs))
      (vector-set! xv (+ i n) (car xs)))
    (do ((j 1 (+ j 1))) ((= (+ n n) j))
      (let ((i (vector-ref fv (- j k 1))))
        (while (and (not (= i -1))
                    (not (eq? (vector-ref xv j)
                              (vector-ref xv (+ k i 1)))))
          (if (lt? (vector-ref xv j) (vector-ref xv (+ k i 1)))
            (set! k (- j i 1)))
          (set! i (vector-ref fv i)))
        (if (and (= i -1)
                 (not (eq? (vector-ref xv j)
                           (vector-ref xv (+ k i 1)))))
            (begin
              (if (lt? (vector-ref xv j) (vector-ref xv (+ k i 1)))
                (set! k j))
              (vector-set! fv (- j k) -1))
            (vector-set! fv (- j k) (+ i 1)))))
    (let loop ((i 0) (zs (list)))
      (if (= i n) (reverse zs)
        (loop (+ i 1) (cons (vector-ref xv (+ i k)) zs))))))

(define (ceq? lt? xs ys)
  (and (= (len xs) (len ys))
       (equal? (booth lt? xs) (booth lt? ys))))

(display (ceq? < (cycle 1 2 3 4) (cycle 1 2 3 4))) (newline) ; #t
(display (ceq? < (cycle 1 2 3 4) (cycle 2 3 4 1))) (newline) ; #t
(display (ceq? < (cycle 1 2 3 4) (cycle 3 4 1 2))) (newline) ; #t
(display (ceq? < (cycle 1 2 3 4) (cycle 4 1 2 3))) (newline) ; #t
(display (ceq? < (cycle 1 2 3 4) (cycle 1 2 3 5))) (newline) ; #f
(display (ceq? < (cycle 1 1 1 1) (cycle 1 1 1 1))) (newline) ; #t
(display (ceq? < (cycle 1 1 1 1) (cycle 1 1 1 2))) (newline) ; #f
(display (ceq? < (cycle 1 1 1 1) (cycle 1 1 1))) (newline) ; #f


Output:
1
2
3
4
5
6
7
8
#t
#t
#t
#t
#f
#t
#f
#f


Create a new paste based on this one


Comments: