; perfect power predicate
(define (iroot k n)
(let loop ((u n))
(let* ((s u)
(t (+ (* (- k 1) s)
(quotient n (expt s (- k 1)))))
(u (quotient t k)))
(if (< u s) (loop u) s))))
(define (ilog b n)
(let loop1 ((lo 0) (b^lo 1) (hi 1) (b^hi b))
(if (< b^hi n) (loop1 hi b^hi (* hi 2) (* b^hi b^hi))
(let loop2 ((lo lo) (b^lo b^lo) (hi hi) (b^hi b^hi))
(if (<= (- hi lo) 1) (if (= b^hi n) hi lo)
(let* ((mid (quotient (+ lo hi) 2))
(b^mid (* b^lo (expt b (- mid lo)))))
(cond ((< n b^mid) (loop2 lo b^lo mid b^mid))
((< b^mid n) (loop2 mid b^mid hi b^hi))
(else mid))))))))
(define (primes n)
(let* ((len (quotient (- n 1) 2)) (bits (make-vector len #t)))
(let loop ((i 0) (p 3) (ps (list 2)))
(cond ((< n (* p p))
(do ((i i (+ i 1)) (p p (+ p 2))
(ps ps (if (vector-ref bits i) (cons p ps) ps)))
((= i len) (reverse ps))))
((vector-ref bits i)
(do ((j (+ (* 2 i i) (* 6 i) 3) (+ j p)))
((<= len j) (loop (+ i 1) (+ p 2) (cons p ps)))
(vector-set! bits j #f)))
(else (loop (+ i 1) (+ p 2) ps))))))
(define (perfect-power? n)
(if (not (and (integer? n) (positive? n)))
(error 'perfect-power? "must be positive integer")
(let loop ((ps (primes (ilog 2 n))))
(if (null? ps) #f
(let ((x (iroot (car ps) n)))
(if (= (expt x (car ps)) n) x
(loop (cdr ps))))))))
(display (map perfect-power? '(32768 205442259656281392806087233013 213)))