; highly composite numbers, revisited

(define (add1 n) (+ n 1))

; priority queue -- pairing heaps
 
(define pq-empty (list))
 
(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 lt? p1 p2)
  (cond ((null? p1) p2)
        ((null? p2) p1)
        ((lt? (car p2) (car p1))
          (cons (car p2) (cons p1 (cdr p2))))
        (else (cons (car p1) (cons p2 (cdr p1))))))
 
(define (pq-insert lt? x pq)
  (pq-merge lt? (list x) pq))
 
(define (pq-merge-pairs lt? ps)
  (cond ((null? ps) '())
        ((null? (cdr ps)) (car ps))
        (else (pq-merge lt? (pq-merge lt? (car ps) (cadr ps))
                            (pq-merge-pairs lt? (cddr ps))))))
 
(define (pq-rest lt? pq)
  (if (null? pq)
      (error 'pq-rest "can't delete minimum from null queue")
      (pq-merge-pairs lt? (cdr pq))))
 
(define (list->pq lt? xs)
  (let loop ((xs xs) (pq pq-empty))
    (if (null? xs) pq
      (loop (cdr xs) (pq-insert lt? (car xs) pq)))))
 
(define (pq->list lt? pq)
  (let loop ((pq pq) (xs '()))
    (if (pq-empty? pq) (reverse xs)
      (loop (pq-rest lt? pq) (cons (pq-first pq) xs)))))
 
; binary search tree
 
(define bst-empty (list))
 
(define bst-empty? null?)
 
(define (bst-member? lt? item bst)
  (cond ((bst-empty? bst) #f)
        ((lt? item (car bst))
          (bst-member? lt? item (cadr bst)))
        ((lt? (car bst) item)
          (bst-member? lt? item (caddr bst)))
        (else #t)))
 
(define (bst-insert lt? item bst)
  (cond ((bst-empty? bst)
          (list item (list) (list)))
        ((lt? item (car bst))
          (list (car bst)
                (bst-insert lt? item (cadr bst))
                (caddr bst)))
        ((lt? (car bst) item)
          (list (car bst)
                (cadr bst)
                (bst-insert lt? item (caddr bst))))
        (else bst)))
 
(define (bst-successor bst)
  (cond ((bst-empty? bst) bst-empty)
        ((bst-empty? (cadr bst)) bst)
        (else (bst-successor (cadr bst)))))
 
(define (bst-delete-root lt? bst)
  (cond ((and (bst-empty? (cadr bst))
          (bst-empty? (caddr bst))) bst-empty)
        ((bst-empty? (cadr bst)) (caddr bst))
        ((bst-empty? (caddr bst)) (cadr bst))
        (else (let ((new-root (car (bst-successor (caddr bst)))))
                (list new-root (cadr bst)
                      (bst-delete lt? new-root (caddr bst)))))))
 
(define (bst-delete lt? item bst)
  (cond ((bst-empty? bst) bst)
        ((lt? item (car bst))
          (list (car bst)
                (bst-delete lt? item (cadr bst))
                (caddr bst)))
        ((lt? (car bst) item)
          (list (car bst)
                (cadr bst)
                (bst-delete lt? item (caddr bst))))
        (else (bst-delete-root lt? bst))))
 
; distinct priority queue
 
(define (make-dpq lt?) (list lt? pq-empty bst-empty))
 
(define (dpq-empty? dpq) (pq-empty? (cadr dpq)))
 
(define (dpq-first dpq)
  (if (dpq-empty? dpq)
      (error 'dpq-first "can't extract minimum from null queue")
      (pq-first (cadr dpq))))
 
(define (dpq-insert item dpq)
  (if (bst-member? (car dpq) item (caddr dpq))
      dpq
      (list (car dpq)
            (pq-insert (car dpq) item (cadr dpq))
            (bst-insert (car dpq) item (caddr dpq)))))
 
(define (dpq-rest dpq)
  (if (dpq-empty? dpq)
      (error 'dpq-rest "can't delete minimum from null queue")
      (list (car dpq)
            (pq-rest (car dpq) (cadr dpq))
            (bst-delete (car dpq) (dpq-first dpq) (caddr dpq)))))
 
(define (dpq-enlist dpq) (pq->list (car dpq) (cadr dpq)))

; prime numbers

(define (primes n) ; list of primes not exceeding n
  (let* ((len (quotient (- n 1) 2)) (bits (make-vector len #t)))
    (let loop ((i 0) (p 3) (ps (list 2)))
      (cond ((< n (* p p))
              (do ((i i (+ i 1)) (p p (+ p 2))
                   (ps ps (if (vector-ref bits i) (cons p ps) ps)))
                  ((= i len) (reverse ps))))
            ((vector-ref bits i)
              (do ((j (+ (* 2 i i) (* 6 i) 3) (+ j p)))
                  ((<= len j) (loop (+ i 1) (+ p 2) (cons p ps)))
                (vector-set! bits j #f)))
            (else (loop (+ i 1) (+ p 2) ps))))))

(define ps (primes 10000))

(define (next ndxs)
  (let loop ((front (list)) (back (cddr ndxs)) (xs (list)))
    (cond ((null? back)
            (map (lambda (x)
                   (cons (do ((x x (cdr x))
                              (ps ps (cdr ps))
                              (p 1 (* p (expt (car ps) (car x)))))
                             ((null? x) p))
                         (cons (apply * (map add1 x))
                               x)))
                 (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)
  (let ((dpq (make-dpq (lambda (xs ys) (< (car xs) (car ys)))))
        (ctr 0) (record 0))
    (let loop1 ((dpq (dpq-insert (list 1 1) dpq)))
      (let* ((candidate (dpq-first dpq)) (dpq (dpq-rest dpq)))
        (when (< record (cadr candidate))
          (set! ctr (+ ctr 1)) (set! record (cadr candidate))
          (display ctr) (display " ") (display candidate) (newline))
        (let loop2 ((xs (next candidate)) (dpq dpq))
          (cond ((null? xs) (loop1 dpq))
                ((< record (cadar xs))
                  (loop2 (cdr xs) (dpq-insert (car xs) dpq)))
                (else (loop2 (cdr xs) dpq))))))))

(hcn)