; climb to a prime
(define (flatten xs)
(cond ((null? xs) xs)
((pair? xs)
(append (flatten (car xs))
(flatten (cdr xs))))
(else (list xs))))
(define (uniq-c eql? xs)
(if (null? xs) xs
(let loop ((xs (cdr xs)) (prev (car xs)) (k 1) (result '()))
(cond ((null? xs) (reverse (cons (cons prev k) result)))
((eql? (car xs) prev) (loop (cdr xs) prev (+ k 1) result))
(else (loop (cdr xs) (car xs) 1 (cons (cons prev k) result)))))))
(define (factors n)
(define (wheel w) (vector-ref '#(1 2 2 4 2 4 2 4 6 2 6) w))
(let loop ((n n) (f 2) (fs (list)) (w 0))
(if (< n (* f f)) (reverse (cons n fs))
(if (zero? (modulo n f)) (loop (/ n f) f (cons f fs) w)
(if (< w 11) (loop n (+ f (wheel w)) fs (+ w 1))
(loop n (+ f (wheel 3)) fs 4))))))
(define (bring-down-powers fs)
(string->number
(apply string-append
(map number->string
(filter (lambda (n) (not (= n 1)))
(flatten
(uniq-c = fs)))))))
(define (climb-to-a-prime n)
(let loop ((n n))
(let ((fs (factors n)))
(display fs) (newline)
(when (pair? (cdr fs))
(loop (bring-down-powers fs))))))
(climb-to-a-prime 90) (newline)
(climb-to-a-prime 234) (newline)
(climb-to-a-prime 13532385396179) (newline)