; sorting by frequency

(import (rnrs sorting (6)))
(import (rnrs hashtables (6)))

(define (add1 x) (+ x 1))

(define (mappend f . xss) (apply append (apply map f xss)))

(define (uniq-c eql? xs)
  (if (null? xs) xs
    (let loop ((xs (cdr xs)) (prev (car xs)) (k 1) (result '()))
      (cond ((null? xs) (reverse (cons (cons prev k) result)))
            ((eql? (car xs) prev) (loop (cdr xs) prev (+ k 1) result))
            (else (loop (cdr xs) (car xs) 1 (cons (cons prev k) result)))))))

(define (eql? lt?)
  (lambda (a b)
    (not (or (lt? a b) (lt? b a)))))

(define (freq-lt? lt?)
  (lambda (a b)
    (or (< (cdr b) (cdr a))
        (and (not (< (cdr a) (cdr b)))
             (lt? (car a) (car b))))))

(define (sort-by-freq lt? xs)
  (mappend (lambda (x) (make-list (cdr x) (car x)))
    (list-sort (freq-lt? lt?)
      (uniq-c (eql? lt?)
        (list-sort lt? xs)))))
       
(display (sort-by-freq < '(2 3 5 3 7 9 5 3 7))) (newline)

(define (sort-by-freq lt? xs)
  (let ((ht (make-eq-hashtable)))
    (do ((xs xs (cdr xs))) ((null? xs))
      (hashtable-update! ht (car xs) add1 0))
    (call-with-values
      (lambda () (hashtable-entries ht))
      (lambda (keys values)
        (mappend (lambda (x) (make-list (cdr x) (car x)))
          (list-sort (freq-lt? lt?)
            (map cons (vector->list keys)
                      (vector->list values))))))))
       
(display (sort-by-freq < '(2 3 5 3 7 9 5 3 7))) (newline)