; square digit chains
(define-syntax fold-of
(syntax-rules (range in is)
((_ "z" f b e) (set! b (f b e)))
((_ "z" f b e (v range fst pst stp) c ...)
(let* ((x fst) (p pst) (s stp)
(le? (if (positive? s) =)))
(do ((v x (+ v s))) ((le? p v) b)
(fold-of "z" f b e c ...))))
((_ "z" f b e (v range fst pst) c ...)
(let* ((x fst) (p pst) (s (if (< x p) 1 -1)))
(fold-of "z" f b e (v range x p s) c ...)))
((_ "z" f b e (v range pst) c ...)
(fold-of "z" f b e (v range 0 pst) c ...))
((_ "z" f b e (x in xs) c ...)
(do ((t xs (cdr t))) ((null? t) b)
(let ((x (car t)))
(fold-of "z" f b e c ...))))
((_ "z" f b e (x is y) c ...)
(let ((x y)) (fold-of "z" f b e c ...)))
((_ "z" f b e p? c ...)
(if p? (fold-of "z" f b e c ...)))
((_ f i e c ...)
(let ((b i)) (fold-of "z" f b e c ...)))))
(define (range . args)
(case (length args)
((1) (range 0 (car args) (if (negative? (car args)) -1 1)))
((2) (range (car args) (cadr args) (if (< (car args) (cadr args)) 1 -1)))
((3) (let ((le? (if (negative? (caddr args)) >= <=)))
(let loop ((x(car args)) (xs '()))
(if (le? (cadr args) x)
(reverse xs)
(loop (+ x (caddr args)) (cons x xs))))))
(else (error 'range "unrecognized arguments"))))
(define (square x) (* x x))
(define (sum xs) (apply + xs))
(define (digits n . args)
(let ((b (if (null? args) 10 (car args))))
(let loop ((n n) (d '()))
(if (zero? n) d
(loop (quotient n b)
(cons (modulo n b) d))))))
(define (undigits ds . args)
(let ((b (if (null? args) 10 (car args))))
(let loop ((ds ds) (n 0))
(if (null? ds) n
(loop (cdr ds) (+ (* n b) (car ds)))))))
(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 (sdc n)
(cond ((member n '(1 89)) n)
(else (display n) (display #\space)
(sdc (sum (map square (digits n)))))))
(display (sdc 44)) (newline)
(display (sdc 145)) (newline)
(define (euler92)
(define (sdc n)
(if (member n '(0 1 89)) n
(sdc (sum (map square (digits n))))))
(define (perms xs)
(define (fact n) (apply * (range n 0)))
(let loop ((p (fact (length xs))) (freq (uniq-c = xs)))
(if (null? freq) p
(loop (/ p (fact (cdar freq))) (cdr freq)))))
(fold-of + 0 p
(a range 0 10)
(b range a 10)
(c range b 10)
(d range c 10)
(e range d 10)
(f range e 10)
(g range f 10)
(n is (list a b c d e f g))
(= (sdc (undigits n)) 89)
(p is (perms n))))
(display (euler92)) (newline)