; highly composite numbers (define (add1 n) (+ n 1)) (define (fold-right op base xs) (if (null? xs) base (op (car xs) (fold-right op base (cdr xs))))) (define pq-empty '()) (define pq-empty? null?) (define (pq-first pq) (if (null? pq) (error 'pq-first "can't extract minimum from null queue") (car pq))) (define (pq-merge p1 p2) (cond ((null? p1) p2) ((null? p2) p1) ((< (car p2) (car p1)) (cons (car p2) (cons p1 (cdr p2)))) (else (cons (car p1) (cons p2 (cdr p1)))))) (define (pq-insert x pq) (pq-merge (list x) pq)) (define (pq-merge-pairs ps) (cond ((null? ps) '()) ((null? (cdr ps)) (car ps)) (else (pq-merge (pq-merge (car ps) (cadr ps)) (pq-merge-pairs (cddr ps)))))) (define (pq-rest pq) (if (null? pq) (error 'pq-rest "can't delete minimum from null queue") (pq-merge-pairs (cdr pq)))) (define (pq-insert-all xs pq) (fold-right pq-insert pq xs)) (define-syntax while (syntax-rules () ((while pred? body ...) (do () ((not pred?)) body ...)))) (define (identity x) x) (define-syntax define-generator (lambda (x) (syntax-case x (lambda) ((stx name (lambda formals e0 e1 ...)) (with-syntax ((yield (datum->syntax (syntax stx) 'yield))) (syntax (define name (lambda formals (let ((resume #f) (return #f)) (define yield (lambda args (call-with-current-continuation (lambda (cont) (set! resume cont) (apply return args))))) (lambda () (call-with-current-continuation (lambda (cont) (set! return cont) (cond (resume (resume)) (else (let () e0 e1 ...) (error 'name "unexpected return")))))))))))) ((stx (name . formals) e0 e1 ...) (syntax (stx name (lambda formals e0 e1 ...))))))) (define-generator (primegen) (yield 2) (yield 3) (let* ((ps (primegen)) (p (and (ps) (ps))) (q (* p p)) (d (make-hash-table))) (define (add x s) (while (hash-ref d x) (set! x (+ x s))) (hash-set! d x s)) (do ((c (+ p 2) (+ c 2))) (#f) (cond ((hash-ref d c) (let ((s (hash-ref d c #f))) (hash-remove! d c) (add (+ c s) s))) ((< c q) (yield c)) (else (add (+ c p p) (+ p p)) (set! p (ps)) (set! q (* p p))))))) (define (powers n) (let ((ps (primegen))) (let loop1 ((n n) (p (ps)) (pows (list))) (if (= n 1) (reverse pows) (let loop2 ((n n) (k 0)) (if (zero? (modulo n p)) (loop2 (/ n p) (+ k 1)) (loop1 n (ps) (cons k pows)))))))) (define (prod xs) (let ((ps (primegen))) (let loop ((xs xs) (p (ps)) (n 1)) (if (null? xs) n (loop (cdr xs) (ps) (* n (expt p (car xs)))))))) (define (next n) (let loop ((front (list)) (back (powers n)) (xs (list))) (cond ((null? back) (map prod (cons (reverse (cons 1 front)) xs))) ((null? front) (loop (cons (car back) front) (cdr back) (cons (cons (+ (car back) 1) (cdr back)) xs))) ((< (car back) (car front)) (loop (cons (car back) front) (cdr back) (cons (append (reverse (cons (+ (car back) 1) front)) (cdr back)) xs))) (else (loop (cons (car back) front) (cdr back) xs))))) (define (hcn limit) (let loop ((k 1) (n 1) (pq (pq-insert 1 pq-empty)) (record 0)) (when (<= k limit) (let ((divs (apply * (map add1 (powers n))))) (cond ((< record divs) (display k) (display " ") (display (powers n)) (display " ") (display n) (newline) (loop (+ k 1) (pq-first pq) (pq-insert-all (next n) (pq-rest pq)) divs)) (else (loop k (pq-first pq) (pq-insert-all (next n) (pq-rest pq)) record))))))) (hcn 15)