fork download
copy 
  1. ; a number puzzle
  2.  
  3. (define (split n xs)
  4.   (let loop ((n n) (xs xs) (zs '()))
  5.     (if (or (zero? n) (null? xs))
  6.         (values (reverse zs) xs)
  7.         (loop (- n 1) (cdr xs) (cons (car xs) zs)))))
  8.  
  9. (define (filter pred? xs)
  10.   (let loop ((xs xs) (ys '()))
  11.     (cond ((null? xs) (reverse ys))
  12.           ((pred? (car xs))
  13.             (loop (cdr xs) (cons (car xs) ys)))
  14.           (else (loop (cdr xs) ys)))))
  15.  
  16. (define (digits n . args)
  17.   (let ((b (if (null? args) 10 (car args))))
  18.     (let loop ((n n) (d '()))
  19.       (if (zero? n) d
  20.           (loop (quotient n b)
  21.                 (cons (modulo n b) d))))))
  22.  
  23. (define (undigits ds . args)
  24.   (let ((b (if (null? args) 10 (car args))))
  25.     (let loop ((ds ds) (n 0))
  26.       (if (null? ds) n
  27.           (loop (cdr ds) (+ (* n b) (car ds)))))))
  28.  
  29. (define (but-last xs) (reverse (cdr (reverse xs))))
  30.  
  31. (define (permutations xs)
  32.   (define (rev xs n ys)
  33.     (if (zero? n) ys
  34.       (rev (cdr xs) (- n 1) (cons (car xs) ys))))
  35.   (let ((xs xs) (perms (list xs)))
  36.     (define (perm n)
  37.       (if (> n 1)
  38.           (do ((j (- n 1) (- j 1)))
  39.               ((zero? j) (perm (- n 1)))
  40.             (perm (- n 1))
  41.             (set! xs (rev xs n (list-tail xs n)))
  42.             (set! perms (cons xs perms)))))
  43.     (perm (length xs))
  44.     perms))
  45.  
  46. (define (check? digits)
  47.   (let loop ((digits digits) (n (length digits)))
  48.     (if (= n 1) #t
  49.       (if (not (zero? (modulo (undigits digits) n))) #f
  50.         (loop (but-last digits) (- n 1))))))
  51.  
  52. (define (puzzle)
  53.   (define (insert5 ds)
  54.     (call-with-values
  55.       (lambda () (split 4 ds))
  56.       (lambda (f b) (append f (list 5) b))))
  57.     (filter check?
  58.       (map insert5
  59.         (permutations
  60.           '(1 2 3 4 6 7 8 9)))))
  61.  
  62. (display (puzzle))
Success #stdin #stdout 4.39s 18888KB
comments (?)
stdin
copy 
Standard input is empty
stdout
copy 
((3 8 1 6 5 4 7 2 9))
https://ideone.com/cRsTSp
language:
()
created:
9 years ago
visibility:
secret

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!