fork download
copy 
  1. ; maximum k items out of n
  2.  
  3. (define (take n xs)
  4.   (let loop ((n n) (xs xs) (ys '()))
  5.     (if (or (zero? n) (null? xs))
  6.         (reverse ys)
  7.         (loop (- n 1) (cdr xs)
  8.               (cons (car xs) ys)))))
  9.  
  10. (define (split n xs)
  11.   (let loop ((n n) (xs xs) (zs '()))
  12.     (if (or (zero? n) (null? xs))
  13.         (values (reverse zs) xs)
  14.         (loop (- n 1) (cdr xs) (cons (car xs) zs)))))
  15.  
  16. (define sort #f)
  17. (define merge #f)
  18. (let ()
  19.   (define dosort
  20.     (lambda (pred? ls n)
  21.       (if (= n 1)
  22.           (list (car ls))
  23.           (let ((i (quotient n 2)))
  24.             (domerge pred?
  25.                      (dosort pred? ls i)
  26.                      (dosort pred? (list-tail ls i) (- n i)))))))
  27.   (define domerge
  28.     (lambda (pred? l1 l2)
  29.       (cond
  30.         ((null? l1) l2)
  31.         ((null? l2) l1)
  32.         ((pred? (car l2) (car l1))
  33.          (cons (car l2) (domerge pred? l1 (cdr l2))))
  34.         (else (cons (car l1) (domerge pred? (cdr l1) l2))))))
  35.   (set! sort
  36.     (lambda (pred? l)
  37.       (if (null? l) l (dosort pred? l (length l)))))
  38.   (set! merge
  39.     (lambda (pred? l1 l2)
  40.       (domerge pred? l1 l2))))
  41.  
  42. (define (max-k k xs) (take k (sort > xs)))
  43.  
  44. (display (max-k 5 '(3 9 6 1 5 6 4 2 8 7 6))) (newline)
  45.  
  46. (define pq-empty '())
  47. (define pq-empty? null?)
  48.  
  49. (define (pq-first pq)
  50.   (if (null? pq)
  51.       (error 'pq-first "can't extract minimum from null queue")
  52.       (car pq)))
  53.  
  54. (define (pq-merge lt? p1 p2)
  55.   (cond ((null? p1) p2)
  56.         ((null? p2) p1)
  57.         ((lt? (car p2) (car p1))
  58.           (cons (car p2) (cons p1 (cdr p2))))
  59.         (else (cons (car p1) (cons p2 (cdr p1))))))
  60.  
  61. (define (pq-insert lt? x pq)
  62.   (pq-merge lt? (list x) pq))
  63.  
  64. (define (pq-merge-pairs lt? ps)
  65.   (cond ((null? ps) '())
  66.         ((null? (cdr ps)) (car ps))
  67.         (else (pq-merge lt? (pq-merge lt? (car ps) (cadr ps))
  68.                             (pq-merge-pairs lt? (cddr ps))))))
  69.  
  70. (define (pq-rest lt? pq)
  71.   (if (null? pq)
  72.       (error 'pq-rest "can't delete minimum from null queue")
  73.       (pq-merge-pairs lt? (cdr pq))))
  74.  
  75. (define (kth-largest-heap k xs)
  76.   (let loop ((xs xs) (k k) (pq pq-empty))
  77.     (if (positive? k)
  78.         (loop (cdr xs) (- k 1) (pq-insert < (car xs) pq))
  79.         (let loop ((xs xs) (pq pq))
  80.           (if (pair? xs)
  81.               (if (< (car xs) (pq-first pq))
  82.                   (loop (cdr xs) pq)
  83.                   (loop (cdr xs) (pq-insert < (car xs) (pq-rest < pq))))
  84.               (let loop ((pq pq) (zs (list)))
  85.                 (if (pq-empty? pq) zs
  86.                   (loop (pq-rest < pq) (cons (pq-first pq) zs)))))))))
  87.  
  88. (display (kth-largest-heap 5 '(3 9 6 1 5 6 4 2 8 7 6))) (newline)
  89.  
  90. (define (partition lt? xs x)
  91.   (let loop ((xs xs) (lt (list)) (eq (list)) (gt (list)))
  92.     (cond ((null? xs) (values lt eq gt))
  93.           ((lt? (car xs) x) (loop (cdr xs) (cons (car xs) lt) eq gt))
  94.           ((lt? x (car xs)) (loop (cdr xs) lt eq (cons (car xs) gt)))
  95.           (else (loop (cdr xs) lt (cons (car xs) eq) gt)))))
  96.  
  97. (define (split5 xs)
  98.   (let loop ((xs xs) (xss (list)))
  99.     (if (null? xs) (reverse xss)
  100.       (call-with-values
  101.         (lambda () (split 5 xs))
  102.         (lambda (head tail)
  103.           (loop tail (cons head xss)))))))
  104.  
  105. (define (select lt? xs k)
  106.   (define (median5 xs)
  107.     (select lt? xs (quotient (+ (length xs) 1) 2)))
  108.   (let ((len (length xs)))
  109.     (if (< len 10) (list-ref (sort lt? xs) (- k 1))
  110.       (let* ((ts (map median5 (split5 xs)))
  111.              (m (select lt? ts (quotient len 10))))
  112.         (call-with-values
  113.           (lambda () (partition lt? xs m))
  114.           (lambda (lt eq gt)
  115.             (let ((lt-len (length lt)) (eq-len (length eq)))
  116.               (cond ((<= k lt-len)
  117.                       (select lt? lt k))
  118.                     ((< (+ lt-len eq-len) k)
  119.                       (select lt? gt (- k lt-len eq-len)))
  120.                     (else m)))))))))
  121.  
  122. (define (k-largest k xs)
  123.   (let ((t (select > xs k)))
  124.     (let ((zs (filter (lambda (x) (> x t)) xs)))
  125.       (let ((len (length zs)))
  126.         (append zs (make-list (- k len) t))))))
  127.  
  128. (display (k-largest 5 '(3 9 6 1 5 6 4 2 8 7 6))) (newline); your code goes here
Success #stdin #stdout 0.02s 8976KB
comments (?)
stdin
copy 
Standard input is empty
stdout
copy 
(9 8 7 6 6)
(9 8 7 6 6)
(9 8 7 6 6)
https://ideone.com/o1mKIJ
language:
Scheme (guile 2.2.4)
created:
7 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!