fork download
copy 
  1. ; highly composite numbers
  2.  
  3. (define (add1 n) (+ n 1))
  4.  
  5. (define (fold-right op base xs)
  6.   (if (null? xs)
  7.       base
  8.       (op (car xs) (fold-right op base (cdr xs)))))
  9.  
  10. (define pq-empty '())
  11. (define pq-empty? null?)
  12.  
  13. (define (pq-first pq)
  14.   (if (null? pq)
  15.       (error 'pq-first "can't extract minimum from null queue")
  16.       (car pq)))
  17.  
  18. (define (pq-merge p1 p2)
  19.   (cond ((null? p1) p2)
  20.         ((null? p2) p1)
  21.         ((< (car p2) (car p1))
  22.           (cons (car p2) (cons p1 (cdr p2))))
  23.         (else (cons (car p1) (cons p2 (cdr p1))))))
  24.  
  25. (define (pq-insert x pq) (pq-merge (list x) pq))
  26.  
  27. (define (pq-merge-pairs ps)
  28.   (cond ((null? ps) '())
  29.         ((null? (cdr ps)) (car ps))
  30.         (else (pq-merge (pq-merge (car ps) (cadr ps))
  31.                         (pq-merge-pairs (cddr ps))))))
  32.  
  33. (define (pq-rest pq)
  34.   (if (null? pq)
  35.       (error 'pq-rest "can't delete minimum from null queue")
  36.       (pq-merge-pairs (cdr pq))))
  37.  
  38. (define (pq-insert-all xs pq) (fold-right pq-insert pq xs))
  39.  
  40. (define-syntax while
  41.   (syntax-rules ()
  42.     ((while pred? body ...)
  43.       (do () ((not pred?)) body ...))))
  44.  
  45. (define (identity x) x)
  46.  
  47. (define-syntax define-generator
  48.   (lambda (x)
  49.     (syntax-case x (lambda)
  50.       ((stx name (lambda formals e0 e1 ...))
  51.          (with-syntax ((yield (datum->syntax (syntax stx) 'yield)))
  52.            (syntax (define name
  53.              (lambda formals
  54.                (let ((resume #f) (return #f))
  55.                  (define yield
  56.                    (lambda args
  57.                      (call-with-current-continuation
  58.                       (lambda (cont)
  59.                         (set! resume cont)
  60.                         (apply return args)))))
  61.                  (lambda ()
  62.                    (call-with-current-continuation
  63.                     (lambda (cont)
  64.                       (set! return cont)
  65.                       (cond (resume (resume))
  66.                       (else (let () e0 e1 ...)
  67.                             (error 'name "unexpected return"))))))))))))
  68.         ((stx (name . formals) e0 e1 ...)
  69.           (syntax (stx name (lambda formals e0 e1 ...)))))))
  70.  
  71. (define-generator (primegen)
  72.   (yield 2) (yield 3)
  73.   (let* ((ps (primegen))
  74.          (p (and (ps) (ps)))
  75.          (q (* p p))
  76.          (d (make-hash-table)))
  77.     (define (add x s)
  78.       (while (hash-ref d x)
  79.         (set! x (+ x s)))
  80.       (hash-set! d x s))
  81.     (do ((c (+ p 2) (+ c 2))) (#f)
  82.       (cond ((hash-ref d c)
  83.               (let ((s (hash-ref d c #f)))
  84.                 (hash-remove! d c)
  85.                 (add (+ c s) s)))
  86.             ((< c q) (yield c))
  87.             (else (add (+ c p p) (+ p p))
  88.                   (set! p (ps))
  89.                   (set! q (* p p)))))))
  90.  
  91. (define (powers n)
  92.   (let ((ps (primegen)))
  93.     (let loop1 ((n n) (p (ps)) (pows (list)))
  94.       (if (= n 1) (reverse pows)
  95.         (let loop2 ((n n) (k 0))
  96.           (if (zero? (modulo n p))
  97.               (loop2 (/ n p) (+ k 1))
  98.               (loop1 n (ps) (cons k pows))))))))
  99.  
  100. (define (prod xs)
  101.   (let ((ps (primegen)))
  102.     (let loop ((xs xs) (p (ps)) (n 1))
  103.       (if (null? xs) n
  104.         (loop (cdr xs) (ps) (* n (expt p (car xs))))))))
  105.  
  106. (define (next n)
  107.   (let loop ((front (list)) (back (powers n)) (xs (list)))
  108.     (cond ((null? back)
  109.             (map prod (cons (reverse (cons 1 front)) xs)))
  110.           ((null? front)
  111.             (loop (cons (car back) front) (cdr back)
  112.                   (cons (cons (+ (car back) 1) (cdr back)) xs)))
  113.           ((< (car back) (car front))
  114.             (loop (cons (car back) front) (cdr back)
  115.                   (cons (append (reverse (cons (+ (car back) 1) front))
  116.                                 (cdr back))
  117.                         xs)))
  118.           (else (loop (cons (car back) front) (cdr back) xs)))))
  119.  
  120. (define (hcn limit)
  121.   (let loop ((k 1) (n 1) (pq (pq-insert 1 pq-empty)) (record 0))
  122.     (when (<= k limit)
  123.       (let ((divs (apply * (map add1 (powers n)))))
  124.         (cond ((< record divs)
  125.                 (display k) (display " ") (display (powers n))
  126.                 (display " ") (display n) (newline)
  127.                 (loop (+ k 1) (pq-first pq)
  128.                       (pq-insert-all (next n) (pq-rest pq))
  129.                       divs))
  130.               (else (loop k (pq-first pq)
  131.                           (pq-insert-all (next n) (pq-rest pq))
  132.                           record)))))))
  133.  
  134. (hcn 15)
Success #stdin #stdout 2.99s 10360KB
comments (?)
stdin
copy 
Standard input is empty
stdout
copy 
1 () 1
2 (1) 2
3 (2) 4
4 (1 1) 6
5 (2 1) 12
6 (3 1) 24
7 (2 2) 36
8 (4 1) 48
9 (2 1 1) 60
10 (3 1 1) 120
11 (2 2 1) 180
12 (4 1 1) 240
13 (3 2 1) 360
14 (4 2 1) 720
15 (3 1 1 1) 840
https://ideone.com/A9ewx3
language:
Scheme (guile 2.2.4)
created:
8 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!