fork download
copy 
  1. ; k-factorials and factorions
  2.  
  3. (define (digits n . args)
  4.   (let ((b (if (null? args) 10 (car args))))
  5.     (let loop ((n n) (d '()))
  6.       (if (zero? n) d
  7.           (loop (quotient n b)
  8.                 (cons (modulo n b) d))))))
  9.  
  10. (define (sum xs) (apply + xs))
  11.  
  12. (define (factorion? n k b)
  13.   (let ((ks (make-vector 10 1)))
  14.     ; (vector-set! ks 0 0)
  15.     (do ((d 2 (+ d 1))) ((= d 10))
  16.       (do ((i 1 (+ i 1))) ((< d i))
  17.         (if (= (modulo d k) (modulo i k))
  18.           (vector-set! ks d (* i (vector-ref ks d))))))
  19.     (let loop ((ds (digits n b)) (f 0))
  20.       (if (null? ds) (= f n)
  21.         (loop (cdr ds) (+ f (vector-ref ks (car ds))))))))
  22.  
  23. (display (factorion? 145 1 10)) (newline)
  24. (display (factorion? 81 3 10)) (newline)
  25.  
  26. (define (factorions k b)
  27.   (let ((ks (make-vector b 1)))
  28.     (do ((d 2 (+ d 1))) ((= d b))
  29.       (do ((i 1 (+ i 1))) ((< d i))
  30.         (when (= (modulo d k) (modulo i k))
  31.           (vector-set! ks d (* i (vector-ref ks d))))))
  32.     (do ((n 1 (+ n 1))) (#f)
  33.       (when (= n (sum (map (lambda (d) (vector-ref ks d)) (digits n b))))
  34.         (display n) (newline)))))
  35.  
  36. ; (factorions 1 6)
  37.  
  38. (do ((n 1 (+ n 1))) ((< 50 n))
  39.   (when (factorion? n 1 6)
  40.     (display n) (newline)))
Success #stdin #stdout 0.02s 7368KB
comments (?)
stdin
copy 
Standard input is empty
stdout
copy 
#t
#t
1
2
25
26
https://ideone.com/gL8Nl3
language:
Scheme (chicken 4.13)
created:
8 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!