fork download
  1. ; prime chains
  2.  
  3. (define (range . args)
  4. (case (length args)
  5. ((1) (range 0 (car args) (if (negative? (car args)) -1 1)))
  6. ((2) (range (car args) (cadr args) (if (< (car args) (cadr args)) 1 -1)))
  7. ((3) (let ((le? (if (negative? (caddr args)) >= <=)))
  8. (let loop ((x(car args)) (xs '()))
  9. (if (le? (cadr args) x)
  10. (reverse xs)
  11. (loop (+ x (caddr args)) (cons x xs))))))
  12. (else (error 'range "unrecognized arguments"))))
  13.  
  14. (define (remove x xs)
  15. (let loop ((xs xs) (zs '()))
  16. (cond ((null? xs) (reverse zs))
  17. ((equal? (car xs) x) (loop (cdr xs) zs))
  18. (else (loop (cdr xs) (cons (car xs) zs))))))
  19.  
  20. (define (digits n . args)
  21. (let ((b (if (null? args) 10 (car args))))
  22. (let loop ((n n) (d '()))
  23. (if (zero? n) d
  24. (loop (quotient n b)
  25. (cons (modulo n b) d))))))
  26.  
  27. (define (undigits ds . args)
  28. (let ((b (if (null? args) 10 (car args))))
  29. (let loop ((ds ds) (n 0))
  30. (if (null? ds) n
  31. (loop (cdr ds) (+ (* n b) (car ds)))))))
  32.  
  33. (define (prime? n)
  34. (let ((wheel '#(1 2 2 4 2 4 2 4 6 2 6)))
  35. (let loop ((f 2) (w 0))
  36. (if (< n (* f f)) #t
  37. (if (zero? (modulo n f)) #f
  38. (loop (+ f (vector-ref wheel w))
  39. (if (= w 10) 3 (+ w 1))))))))
  40.  
  41. (define (neighbors n)
  42. (let ((ds (digits n)))
  43. (let outer ((prefix (list)) (digit (car ds)) (suffix (cdr ds)) (ns (list)))
  44. (if (null? suffix)
  45. (let inner ((rs (remove digit (range (if (pair? prefix) 0 1) 10))) (xs (list)))
  46. (if (null? rs) (append xs ns)
  47. (inner (cdr rs) (cons (undigits (append prefix (list (car rs)))) xs))))
  48. (let inner ((rs (remove digit (range (if (pair? prefix) 0 1) 10))) (xs (list)))
  49. (if (null? rs) (outer (append prefix (list digit)) (car suffix) (cdr suffix) (append xs ns))
  50. (inner (cdr rs) (cons (undigits (append prefix (list (car rs)) suffix)) xs))))))))
  51.  
  52. (define (extend chains)
  53. (let loop ((chains chains) (xss (list)))
  54. (if (null? chains) xss
  55. (loop (cdr chains)
  56. (append (map (lambda (n) (cons n (car chains)))
  57. (filter prime? (neighbors (caar chains))))
  58. xss)))))
  59.  
  60. (define (chains start target)
  61. (let loop ((chains (list (list start))))
  62. (let ((xss (extend chains)))
  63. (let ((zss (filter (lambda (xs) (= (car xs) target)) xss)))
  64. (if (pair? zss) (map reverse zss) (loop xss))))))
  65.  
  66. (display (chains 7459 1873)) (newline)
Time limit exceeded #stdin #stdout 15s 46416KB
stdin
Standard input is empty
stdout

Standard output is empty