fork download
copy 
  1. ; square digit chains
  2.  
  3. (define-syntax fold-of
  4.   (syntax-rules (range in is)
  5.     ((_ "z" f b e) (set! b (f b e)))
  6.     ((_ "z" f b e (v range fst pst stp) c ...)
  7.       (let* ((x fst) (p pst) (s stp)
  8.              (le? (if (positive? s) =)))
  9.         (do ((v x (+ v s))) ((le? p v) b)
  10.           (fold-of "z" f b e c ...))))
  11.     ((_ "z" f b e (v range fst pst) c ...)
  12.       (let* ((x fst) (p pst) (s (if (< x p) 1 -1)))
  13.         (fold-of "z" f b e (v range x p s) c ...)))
  14.     ((_ "z" f b e (v range pst) c ...)
  15.       (fold-of "z" f b e (v range 0 pst) c ...))
  16.     ((_ "z" f b e (x in xs) c ...)
  17.       (do ((t xs (cdr t))) ((null? t) b)
  18.         (let ((x (car t)))
  19.           (fold-of "z" f b e c ...))))
  20.     ((_ "z" f b e (x is y) c ...)
  21.       (let ((x y)) (fold-of "z" f b e c ...)))
  22.     ((_ "z" f b e p? c ...)
  23.       (if p? (fold-of "z" f b e c ...)))
  24.     ((_ f i e c ...)
  25.       (let ((b i)) (fold-of "z" f b e c ...)))))
  26.  
  27. (define (range . args)
  28.   (case (length args)
  29.     ((1) (range 0 (car args) (if (negative? (car args)) -1 1)))
  30.     ((2) (range (car args) (cadr args) (if (< (car args) (cadr args)) 1 -1)))
  31.     ((3) (let ((le? (if (negative? (caddr args)) >= <=)))
  32.            (let loop ((x(car args)) (xs '()))
  33.              (if (le? (cadr args) x)
  34.                  (reverse xs)
  35.                  (loop (+ x (caddr args)) (cons x xs))))))
  36.     (else (error 'range "unrecognized arguments"))))
  37.  
  38. (define (square x) (* x x))
  39.  
  40. (define (sum xs) (apply + xs))
  41.  
  42. (define (digits n . args)
  43.   (let ((b (if (null? args) 10 (car args))))
  44.     (let loop ((n n) (d '()))
  45.       (if (zero? n) d
  46.           (loop (quotient n b)
  47.                 (cons (modulo n b) d))))))
  48.  
  49. (define (undigits ds . args)
  50.   (let ((b (if (null? args) 10 (car args))))
  51.     (let loop ((ds ds) (n 0))
  52.       (if (null? ds) n
  53.           (loop (cdr ds) (+ (* n b) (car ds)))))))
  54.  
  55. (define (uniq-c eql? xs)
  56.   (if (null? xs) xs
  57.     (let loop ((xs (cdr xs)) (prev (car xs)) (k 1) (result '()))
  58.       (cond ((null? xs) (reverse (cons (cons prev k) result)))
  59.             ((eql? (car xs) prev) (loop (cdr xs) prev (+ k 1) result))
  60.             (else (loop (cdr xs) (car xs) 1 (cons (cons prev k) result)))))))
  61.  
  62. (define (sdc n)
  63.   (cond ((member n '(1 89)) n)
  64.   (else (display n) (display #\space)
  65.         (sdc (sum (map square (digits n)))))))
  66.  
  67. (display (sdc 44)) (newline)
  68. (display (sdc 145)) (newline)
  69.  
  70. (define (euler92)
  71.   (define (sdc n)
  72.     (if (member n '(0 1 89)) n
  73.       (sdc (sum (map square (digits n))))))
  74.   (define (perms xs)
  75.     (define (fact n) (apply * (range n 0)))
  76.     (let loop ((p (fact (length xs))) (freq (uniq-c = xs)))
  77.       (if (null? freq) p
  78.         (loop (/ p (fact (cdar freq))) (cdr freq)))))
  79.   (fold-of + 0 p
  80.     (a range 0 10)
  81.     (b range a 10)
  82.     (c range b 10)
  83.     (d range c 10)
  84.     (e range d 10)
  85.     (f range e 10)
  86.     (g range f 10)
  87.     (n is (list a b c d e f g))
  88.     (= (sdc (undigits n)) 89)
  89.     (p is (perms n))))
  90.  
  91. (display (euler92)) (newline)
Success #stdin #stdout 9.09s 52992KB
comments (?)
stdin
copy 
Standard input is empty
stdout
copy 
44 32 13 10 1
145 42 20 4 16 37 58 89
8581146
https://ideone.com/w1QtD8
language:
Scheme (guile 2.2.4)
created:
5 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!