fork(2) download 
  1. (define pq-empty '())
  2. (define pq-empty? null?)
  3.  
  4. (define (pq-first pq)
  5.   (if (null? pq)
  6.       (error 'pq-first "can't extract minimum from null queue")
  7.       (car pq)))
  8.  
  9. (define (pq-merge lt? p1 p2)
  10.   (cond ((null? p1) p2)
  11.         ((null? p2) p1)
  12.         ((lt? (car p2) (car p1))
  13.           (cons (car p2) (cons p1 (cdr p2))))
  14.         (else (cons (car p1) (cons p2 (cdr p1))))))
  15.  
  16. (define (pq-insert lt? x pq)
  17.   (pq-merge lt? (list x) pq))
  18.  
  19. (define (pq-merge-pairs lt? ps)
  20.   (cond ((null? ps) '())
  21.         ((null? (cdr ps)) (car ps))
  22.         (else (pq-merge lt? (pq-merge lt? (car ps) (cadr ps))
  23.                             (pq-merge-pairs lt? (cddr ps))))))
  24.  
  25. (define (pq-rest lt? pq)
  26.   (if (null? pq)
  27.       (error 'pq-rest "can't delete minimum from null queue")
  28.       (pq-merge-pairs lt? (cdr pq))))
  29.  
  30. (define (update lt? pq ps)
  31.   (let loop ((ps ps) (pq pq))
  32.     (if (null? ps) (pq-rest lt? pq)
  33.       (loop (cdr ps) (pq-insert lt? (* (pq-first pq) (car ps)) pq)))))
  34.  
  35. (define (f ps n)
  36.   (let loop ((n n) (p 0) (pq (pq-insert < 1 pq-empty)) (xs (list)))
  37.     (cond ((zero? n) (reverse xs))
  38.           ((= (pq-first pq) p) (loop n p (pq-rest < pq) xs))
  39.           (else (loop (- n 1) (pq-first pq) (update < pq ps)
  40.                       (cons (pq-first pq) xs))))))
  41.  
  42. (display (f '(2 5) 20)) (newline)
  43. (display (f '(2 3 5) 20)) (newline)
Success #stdin #stdout 0.03s 4176KB
comments (?)
stdin 
Standard input is empty
stdout 
(1 2 4 5 8 10 16 20 25 32 40 50 64 80 100 125 128 160 200 250)
(1 2 3 4 5 6 8 9 10 12 15 16 18 20 24 25 27 30 32 36)
https://ideone.com/sA1nn
language:
Scheme (guile 2.2.4)
created:
12 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!