fork download
copy 
  1. ; pandigital squares, faster and smaller
  2.  
  3. (define range
  4.   (case-lambda
  5.     ((stop) (range 0 stop (if (negative? stop) -1 1)))
  6.     ((start stop) (range start stop (if (< start stop) 1 -1)))
  7.     ((start stop step)
  8.       (let ((le? (if (negative? step) >= <=)))
  9.         (let loop ((x start) (xs (list)))
  10.           (if (le? stop x) (reverse xs)
  11.             (loop (+ x step) (cons x xs))))))
  12.     (else (error 'range "too many arguments"))))
  13.  
  14. (define-syntax fold-of
  15.   (syntax-rules (range in is)
  16.     ((_ "z" f b e) (set! b (f b e)))
  17.     ((_ "z" f b e (v range fst pst stp) c ...)
  18.       (let* ((x fst) (p pst) (s stp)
  19.              (le? (if (positive? s) <= >=)))
  20.         (do ((v x (+ v s))) ((le? p v) b)
  21.           (fold-of "z" f b e c ...))))
  22.     ((_ "z" f b e (v range fst pst) c ...)
  23.       (let* ((x fst) (p pst) (s (if (< x p) 1 -1)))
  24.         (fold-of "z" f b e (v range x p s) c ...)))
  25.     ((_ "z" f b e (v range pst) c ...)
  26.       (fold-of "z" f b e (v range 0 pst) c ...))
  27.     ((_ "z" f b e (x in xs) c ...)
  28.       (do ((t xs (cdr t))) ((null? t) b)
  29.         (let ((x (car t)))
  30.           (fold-of "z" f b e c ...))))
  31.     ((_ "z" f b e (x is y) c ...)
  32.       (let ((x y)) (fold-of "z" f b e c ...)))
  33.     ((_ "z" f b e p? c ...)
  34.       (if p? (fold-of "z" f b e c ...)))
  35.     ((_ f i e c ...)
  36.       (let ((b i)) (fold-of "z" f b e c ...)))))
  37.  
  38. (define-syntax list-of (syntax-rules ()
  39.   ((_ arg ...) (reverse (fold-of
  40.     (lambda (d a) (cons a d)) '() arg ...)))))
  41.  
  42. (define sort #f)
  43. (define merge #f)
  44. (let ()
  45.   (define dosort
  46.     (lambda (pred? ls n)
  47.       (if (= n 1)
  48.           (list (car ls))
  49.           (let ((i (quotient n 2)))
  50.             (domerge pred?
  51.                      (dosort pred? ls i)
  52.                      (dosort pred? (list-tail ls i) (- n i)))))))
  53.   (define domerge
  54.     (lambda (pred? l1 l2)
  55.       (cond
  56.         ((null? l1) l2)
  57.         ((null? l2) l1)
  58.         ((pred? (car l2) (car l1))
  59.          (cons (car l2) (domerge pred? l1 (cdr l2))))
  60.         (else (cons (car l1) (domerge pred? (cdr l1) l2))))))
  61.   (set! sort
  62.     (lambda (pred? l)
  63.       (if (null? l) l (dosort pred? l (length l)))))
  64.   (set! merge
  65.     (lambda (pred? l1 l2)
  66.       (domerge pred? l1 l2))))
  67.  
  68. (define (digits n . args)
  69.   (let ((b (if (null? args) 10 (car args))))
  70.     (let loop ((n n) (d '()))
  71.       (if (zero? n) d
  72.           (loop (quotient n b)
  73.                 (cons (modulo n b) d))))))
  74.  
  75. (define (ash int cnt)
  76.   (if (negative? cnt)
  77.       (let ((n (expt 2 (- cnt))))
  78.            (if (negative? int)
  79.                (+ -1 (quotient (+ 1 int) n))
  80.                (quotient int n)))
  81.       (* (expt 2 cnt) int)))
  82.  
  83. (define (pop-count n)
  84.   (let ((count n))
  85.     (set! count (- count (bitwise-and (ash n -1) #o33333333333)))
  86.     (set! count (- count (bitwise-and (ash n -2) #o11111111111)))
  87.     (set! count (bitwise-and (+ count (ash count -3)) #o30707070707))
  88.     (modulo count 63)))
  89.  
  90. (define (pandigital? n)
  91.   (equal? (sort < (digits n)) (range 10)))
  92.  
  93. (define (ps1)
  94.   (list-of (list n n2)
  95.     (n range 10000 100000)
  96.     (n2 is (* n n))
  97.     (pandigital? n2)))
  98.  
  99. (define (ps2)
  100.   (list-of (list n n2)
  101.     (n range 31623 100000)
  102.     (n2 is (* n n))
  103.     (pandigital? n2)))
  104.  
  105. (define (ps3)
  106.   (list-of (list n n2)
  107.     (n range 31623 100000)
  108.     (n2 is (* n n))
  109.     (zero? (modulo n2 9))
  110.     (pandigital? n2)))
  111.  
  112. (define (ps4)
  113.   (list-of (list n n2)
  114.     (n range 31623 100000)
  115.     (n2 is (* n n))
  116.     (zero? (modulo n2 9))
  117.     (equal? (sort < (digits n2)) (range 10))))
  118.  
  119. (define ps5
  120.   (let ((ds (range 10)))
  121.     (lambda ()
  122.       (list-of (list n n2)
  123.         (n range 31623 100000)
  124.         (n2 is (* n n))
  125.         (zero? (modulo n2 9))
  126.         (equal? (sort < (digits n2)) ds)))))
  127.  
  128. (define (ps6)
  129.   (list-of (list n n2)
  130.     (n range 31623 100000)
  131.     (n2 is (* n n))
  132.     (zero? (modulo n2 9))
  133.     (do ((ds (digits n2) (cdr ds))
  134.          (bits 0 (bitwise-ior bits (ash 1 (car ds)))))
  135.         ((null? ds) (= (pop-count bits) 10)))))
  136.  
  137. (define (ps7)
  138.   (list-of (list n n2)
  139.     (n range 31623 100000)
  140.     (n2 is (* n n))
  141.     (zero? (modulo n2 9))
  142.     (let loop ((n2 n2) (bits 0))
  143.       (if (zero? n2)
  144.           (= (pop-count bits) 10)
  145.           (loop (quotient n2 10)
  146.                 (bitwise-ior bits (ash 1 (remainder n2 10))))))))
  147.  
  148. (time (begin (display (length (ps1))) (newline)))
  149. (time (begin (display (length (ps2))) (newline)))
  150. (time (begin (display (length (ps3))) (newline)))
  151. (time (begin (display (length (ps4))) (newline)))
  152. (time (begin (display (length (ps5))) (newline)))
  153. (time (begin (display (length (ps6))) (newline)))
  154. (time (begin (display (length (ps7))) (newline)))
Success #stdin #stdout #stderr 10.47s 13812KB
comments (?)
stdin
copy 
Standard input is empty
stdout
copy 
87
87
87
87
87
87
87
stderr
copy 
3.808s CPU time, 0.108s GC time (major), 1080538/2627 mutations (total/tracked), 76/35694 GCs (major/minor), maximum live heap: 559.45 KiB
2.844s CPU time, 0.044s GC time (major), 821062/1985 mutations (total/tracked), 48/27770 GCs (major/minor), maximum live heap: 559.05 KiB
1.04s CPU time, 0.028s GC time (major), 274054/732 mutations (total/tracked), 19/9633 GCs (major/minor), maximum live heap: 558.84 KiB
1.024s CPU time, 0.048s GC time (major), 274054/700 mutations (total/tracked), 19/9618 GCs (major/minor), maximum live heap: 559.05 KiB
0.82s CPU time, 0.008s GC time (major), 137296/411 mutations (total/tracked), 10/7945 GCs (major/minor), maximum live heap: 558.77 KiB
0.488s CPU time, 0.008s GC time (major), 274054/755 mutations (total/tracked), 10/4818 GCs (major/minor), maximum live heap: 558.55 KiB
0.416s CPU time, 0.004s GC time (major), 137296/466 mutations (total/tracked), 8/3495 GCs (major/minor), maximum live heap: 558.59 KiB
https://ideone.com/tyoNwc
language:
Scheme (chicken 4.13)
created:
2 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!