1. ; hidden squares
2.
3. (define (take n xs)
4. (let loop ((n n) (xs xs) (ys '()))
5. (if (or (zero? n) (null? xs))
6. (reverse ys)
7. (loop (- n 1) (cdr xs)
8. (cons (car xs) ys)))))
9.
10. (define (digits n . args)
11. (let ((b (if (null? args) 10 (car args))))
12. (let loop ((n n) (d '()))
13. (if (zero? n) d
14. (loop (quotient n b)
15. (cons (modulo n b) d))))))
16.
17. (define (undigits ds . args)
18. (let ((b (if (null? args) 10 (car args))))
19. (let loop ((ds ds) (n 0))
20. (if (null? ds) n
21. (loop (cdr ds) (+ (* n b) (car ds)))))))
22.
23. (define (isqrt n)
24. (if (not (and (positive? n) (integer? n)))
25. (error 'isqrt "must be positive integer")
26. (let loop ((x n))
27. (let ((y (quotient (+ x (quotient n x)) 2)))
28. (if (< y x) (loop y) x)))))
29.
30. (define (unique eql? xs)
31. (cond ((null? xs) '())
32. ((null? (cdr xs)) xs)
33. ((eql? (car xs) (cadr xs))
34. (unique eql? (cdr xs)))
35. (else (cons (car xs) (unique eql? (cdr xs))))))
36.
37. (define (square? n)
38. (let ((s (isqrt n)))
39. (= n (* s s))))
40.
41. (define (k-squares k ds)
42. (if (< (length ds) k) (list)
43. (let ((n (undigits (take k ds))))
44. (if (square? n)
45. (cons n (k-squares k (cdr ds)))
46. (k-squares k (cdr ds))))))
47.
48. (define (hidden-squares n)
49. (let* ((ds (digits n)) (len (length ds)))
50. (let loop ((k 1) (hs (list)))
51. (if (< len k) (unique = (sort hs <))
52. (loop (+ k 1) (append (k-squares k ds) hs))))))
53.
54. (display (hidden-squares 1625649)) (newline)
Success #stdin #stdout 0s 8044KB
stdin
Standard input is empty
stdout
(1 4 9 16 25 49 64 256 625)