; 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)