; 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)