; 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