fork download
copy 
  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
comments (?)
stdin
copy 
Standard input is empty
stdout
copy 
Standard output is empty
https://ideone.com/0nirN1
language:
Scheme (guile 2.2.4)
created:
6 years ago
visibility:
public

Share or Embed source code

Discover > Sphere Engine API

The brand new service which powers Ideone!

Discover > IDE Widget

Widget for compiling and running the source code in a web browser!