; pandigital squares, faster and smaller (define range (case-lambda ((stop) (range 0 stop (if (negative? stop) -1 1))) ((start stop) (range start stop (if (< start stop) 1 -1))) ((start stop step) (let ((le? (if (negative? step) >= <=))) (let loop ((x start) (xs (list))) (if (le? stop x) (reverse xs) (loop (+ x step) (cons x xs)))))) (else (error 'range "too many arguments")))) (define-syntax fold-of (syntax-rules (range in is) ((_ "z" f b e) (set! b (f b e))) ((_ "z" f b e (v range fst pst stp) c ...) (let* ((x fst) (p pst) (s stp) (le? (if (positive? s) <= >=))) (do ((v x (+ v s))) ((le? p v) b) (fold-of "z" f b e c ...)))) ((_ "z" f b e (v range fst pst) c ...) (let* ((x fst) (p pst) (s (if (< x p) 1 -1))) (fold-of "z" f b e (v range x p s) c ...))) ((_ "z" f b e (v range pst) c ...) (fold-of "z" f b e (v range 0 pst) c ...)) ((_ "z" f b e (x in xs) c ...) (do ((t xs (cdr t))) ((null? t) b) (let ((x (car t))) (fold-of "z" f b e c ...)))) ((_ "z" f b e (x is y) c ...) (let ((x y)) (fold-of "z" f b e c ...))) ((_ "z" f b e p? c ...) (if p? (fold-of "z" f b e c ...))) ((_ f i e c ...) (let ((b i)) (fold-of "z" f b e c ...))))) (define-syntax list-of (syntax-rules () ((_ arg ...) (reverse (fold-of (lambda (d a) (cons a d)) '() arg ...))))) (define sort #f) (define merge #f) (let () (define dosort (lambda (pred? ls n) (if (= n 1) (list (car ls)) (let ((i (quotient n 2))) (domerge pred? (dosort pred? ls i) (dosort pred? (list-tail ls i) (- n i))))))) (define domerge (lambda (pred? l1 l2) (cond ((null? l1) l2) ((null? l2) l1) ((pred? (car l2) (car l1)) (cons (car l2) (domerge pred? l1 (cdr l2)))) (else (cons (car l1) (domerge pred? (cdr l1) l2)))))) (set! sort (lambda (pred? l) (if (null? l) l (dosort pred? l (length l))))) (set! merge (lambda (pred? l1 l2) (domerge pred? l1 l2)))) (define (digits n . args) (let ((b (if (null? args) 10 (car args)))) (let loop ((n n) (d '())) (if (zero? n) d (loop (quotient n b) (cons (modulo n b) d)))))) (define (ash int cnt) (if (negative? cnt) (let ((n (expt 2 (- cnt)))) (if (negative? int) (+ -1 (quotient (+ 1 int) n)) (quotient int n))) (* (expt 2 cnt) int))) (define (pop-count n) (let ((count n)) (set! count (- count (bitwise-and (ash n -1) #o33333333333))) (set! count (- count (bitwise-and (ash n -2) #o11111111111))) (set! count (bitwise-and (+ count (ash count -3)) #o30707070707)) (modulo count 63))) (define (pandigital? n) (equal? (sort < (digits n)) (range 10))) (define (ps1) (list-of (list n n2) (n range 10000 100000) (n2 is (* n n)) (pandigital? n2))) (define (ps2) (list-of (list n n2) (n range 31623 100000) (n2 is (* n n)) (pandigital? n2))) (define (ps3) (list-of (list n n2) (n range 31623 100000) (n2 is (* n n)) (zero? (modulo n2 9)) (pandigital? n2))) (define (ps4) (list-of (list n n2) (n range 31623 100000) (n2 is (* n n)) (zero? (modulo n2 9)) (equal? (sort < (digits n2)) (range 10)))) (define ps5 (let ((ds (range 10))) (lambda () (list-of (list n n2) (n range 31623 100000) (n2 is (* n n)) (zero? (modulo n2 9)) (equal? (sort < (digits n2)) ds))))) (define (ps6) (list-of (list n n2) (n range 31623 100000) (n2 is (* n n)) (zero? (modulo n2 9)) (do ((ds (digits n2) (cdr ds)) (bits 0 (bitwise-ior bits (ash 1 (car ds))))) ((null? ds) (= (pop-count bits) 10))))) (define (ps7) (list-of (list n n2) (n range 31623 100000) (n2 is (* n n)) (zero? (modulo n2 9)) (let loop ((n2 n2) (bits 0)) (if (zero? n2) (= (pop-count bits) 10) (loop (quotient n2 10) (bitwise-ior bits (ash 1 (remainder n2 10)))))))) (time (begin (display (length (ps1))) (newline))) (time (begin (display (length (ps2))) (newline))) (time (begin (display (length (ps3))) (newline))) (time (begin (display (length (ps4))) (newline))) (time (begin (display (length (ps5))) (newline))) (time (begin (display (length (ps6))) (newline))) (time (begin (display (length (ps7))) (newline)))