fork download
copy 
  1. ; multi-way merge
  2.  
  3. (define pq-empty '())
  4. (define pq-empty? null?)
  5.  
  6. (define (pq-first pq)
  7.   (if (null? pq)
  8.       (error 'pq-first "can't extract minimum from null queue")
  9.       (car pq)))
  10.  
  11. (define (pq-merge lt? p1 p2)
  12.   (cond ((null? p1) p2)
  13.         ((null? p2) p1)
  14.         ((lt? (car p2) (car p1))
  15.           (cons (car p2) (cons p1 (cdr p2))))
  16.         (else (cons (car p1) (cons p2 (cdr p1))))))
  17.  
  18. (define (pq-insert lt? x pq)
  19.   (pq-merge lt? (list x) pq))
  20.  
  21. (define (pq-merge-pairs lt? ps)
  22.   (cond ((null? ps) '())
  23.         ((null? (cdr ps)) (car ps))
  24.         (else (pq-merge lt? (pq-merge lt? (car ps) (cadr ps))
  25.                             (pq-merge-pairs lt? (cddr ps))))))
  26.  
  27. (define (pq-rest lt? pq)
  28.   (if (null? pq)
  29.       (error 'pq-rest "can't delete minimum from null queue")
  30.       (pq-merge-pairs lt? (cdr pq))))
  31.  
  32. (define list1 '(2 4 6 8 10 12 14 16 18 20))
  33. (define list2 '(3 6 9 12 15 18 21 24 27 30))
  34. (define list3 '(5 10 15 20 25 30 35 40 45))
  35. (define list4 '(7 14 21 28 35 42 49 56 63))
  36. (define list5 '(11 22 33 44 55 66 77 88 99))
  37.  
  38. (define (merge2 lt? xs ys) ; merge 2 lists
  39.   (let loop ((xs xs) (ys ys) (zs (list)))
  40.     (cond ((and (null? xs) (null? ys))
  41.             (reverse zs))
  42.           ((null? xs)
  43.             (loop xs (cdr ys) (cons (car ys) zs)))
  44.           ((null? ys)
  45.             (loop (cdr xs) ys (cons (car xs) zs)))
  46.           ((lt? (car xs) (car ys))
  47.             (loop (cdr xs) ys (cons (car xs) zs)))
  48.           ((lt? (car ys) (car xs))
  49.             (loop xs (cdr ys) (cons (car ys) zs)))
  50.           (else
  51.             (loop (cdr xs) ys (cons (car xs) zs))))))
  52.  
  53. (display (merge2 < list1 list2)) (newline)
  54.  
  55. (define (k-merge1 lt? . xss) ; brute force 
  56.   (let loop ((xss xss) (zs (list)))
  57.     (if (null? xss) zs
  58.       (loop (cdr xss) (merge2 lt? (car xss) zs)))))
  59.  
  60. (display (k-merge1 < list1 list2 list3 list4 list5)) (newline)
  61.  
  62. (define (k-merge2 lt? . xss) ; tournament of pairs
  63.   (if (null? xss) (list) (if (null? (cdr xss)) (car xss)
  64.     (let loop ((xss xss) (zss (list)))
  65.       (cond ((null? xss)
  66.               (apply k-merge2 lt? zss))
  67.             ((null? (cdr xss))
  68.               (apply k-merge2 lt? (cons (car xss) zss)))
  69.             (else (loop (cddr xss)
  70.                         (cons (merge2 lt? (car xss) (cadr xss))
  71.                               zss))))))))
  72.  
  73. (display (k-merge2 < list1 list2 list3 list4 list5)) (newline)
  74.  
  75. (define (k-merge3 lt? . xss) ; priority queue
  76.   (define (less? xs ys) (lt? (car xs) (car ys)))
  77.   (let loop ((xss xss) (pq pq-empty))
  78.     (if (and (pair? xss) (pair? (car xss)))
  79.         (loop (cdr xss) (pq-insert less? (car xss) pq))
  80.         (let loop ((pq pq) (zs (list)))
  81.           (if (pq-empty? pq) (reverse zs)
  82.             (let ((z (car (pq-first pq)))
  83.                   (xs (cdr (pq-first pq))))
  84.               (if (pair? xs)
  85.                   (loop (pq-insert less? xs (pq-rest less? pq))
  86.                         (cons z zs))
  87.                   (loop (pq-rest less? pq) (cons z zs)))))))))
  88.  
  89. (display (k-merge3 < list1 list2 list3 list4 list5)) (newline)
Success #stdin #stdout 0.07s 8744KB
comments (?)
stdin
copy 
Standard input is empty
stdout
copy 
(2 3 4 6 6 8 9 10 12 12 14 15 16 18 18 20 21 24 27 30)
(2 3 4 5 6 6 7 8 9 10 10 11 12 12 14 14 15 15 16 18 18 20 20 21 21 22 24 25 27 28 30 30 33 35 35 40 42 44 45 49 55 56 63 66 77 88 99)
(2 3 4 5 6 6 7 8 9 10 10 11 12 12 14 14 15 15 16 18 18 20 20 21 21 22 24 25 27 28 30 30 33 35 35 40 42 44 45 49 55 56 63 66 77 88 99)
(2 3 4 5 6 6 7 8 9 10 10 11 12 12 14 14 15 15 16 18 18 20 20 21 21 22 24 25 27 28 30 30 33 35 35 40 42 44 45 49 55 56 63 66 77 88 99)
https://ideone.com/o2iUf8
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!