182 lines
3.9 KiB
Scheme
182 lines
3.9 KiB
Scheme
|
|
(define fact
|
|
(lambda (n)
|
|
(if (zero? n) 1
|
|
(* n (fact (- n 1))))))
|
|
|
|
(define allperms
|
|
(lambda (n)
|
|
(let ((f (fact n))
|
|
(res '()) (rm -1) (perm '()))
|
|
(letrec
|
|
((remove
|
|
(lambda (l pos)
|
|
(if (zero? pos)
|
|
(begin
|
|
(set! rm (car l))
|
|
(remove (cdr l) (- pos 1)))
|
|
(if (null? l) l
|
|
(cons (car l) (remove (cdr l) (- pos 1)))))))
|
|
(process
|
|
(lambda (v m dst src)
|
|
(if (zero? m)
|
|
(set! perm dst)
|
|
(let ((src1 (remove src (remainder v m))))
|
|
(process
|
|
(quotient v m)
|
|
(- m 1)
|
|
src1
|
|
(cons dst rm))))))
|
|
(iter
|
|
(lambda (v)
|
|
(if (< v f)
|
|
(begin
|
|
(process v n '() (make-range 1 n))
|
|
(set! res (cons perm res))
|
|
(iter (+ v 1)))))))
|
|
(iter 0) res))))
|
|
|
|
|
|
(define allperms
|
|
(lambda (n)
|
|
(if (= n 1) '((1))
|
|
(letrec
|
|
((allpos (list-n n))
|
|
(insert
|
|
(lambda (pos el l)
|
|
(if (= pos 1)
|
|
(cons el l)
|
|
(cons (car l)
|
|
(insert (- pos 1) el (cdr l))))))
|
|
(result '()))
|
|
(for-each
|
|
(lambda (p)
|
|
(for-each
|
|
(lambda (pos)
|
|
(set!
|
|
result
|
|
(cons
|
|
(insert pos n p) result)))
|
|
allpos))
|
|
(allperms (- n 1)))
|
|
result))))
|
|
|
|
|
|
(define make-cmp
|
|
(lambda ()
|
|
(let ((count 0))
|
|
(lambda (what . args)
|
|
(case what
|
|
((count) count)
|
|
((cmp)
|
|
(begin
|
|
(set! count (+ 1 count))
|
|
(< (car args) (cadr args)))))))))
|
|
|
|
(define qsort
|
|
(lambda (perm compare)
|
|
(if (null? perm) '()
|
|
(if (null? (cdr perm)) perm
|
|
(letrec
|
|
((pivot (car perm))
|
|
(left '()) (leftend '())
|
|
(right '()) (rightend '())
|
|
(split
|
|
(lambda (l)
|
|
(if (compare 'cmp (car l) pivot)
|
|
(if (null? leftend)
|
|
(begin
|
|
(set! left (list (car l)))
|
|
(set! leftend left))
|
|
(begin
|
|
(set-cdr! leftend (list (car l)))
|
|
(set! leftend (cdr leftend))))
|
|
(if (null? rightend)
|
|
(begin
|
|
(set! right (list (car l)))
|
|
(set! rightend right))
|
|
(begin
|
|
(set-cdr! rightend (list (car l)))
|
|
(set! rightend (cdr rightend)))))
|
|
(if (not (null? (cdr l))) (split (cdr l))))))
|
|
(split (cdr perm))
|
|
(append
|
|
(qsort left compare)
|
|
(list pivot)
|
|
(qsort right compare)))))))
|
|
|
|
(define qsort-stats
|
|
(lambda (n)
|
|
(map
|
|
(lambda (p)
|
|
(let ((c (make-cmp)))
|
|
(qsort p c)
|
|
(c 'count)))
|
|
(allperms n))))
|
|
|
|
(define ints2hist
|
|
(lambda (l)
|
|
(let* ((minv (apply min l))
|
|
(maxv (apply max l))
|
|
(v (make-vector (+ 1 (- maxv minv)) 0)))
|
|
(letrec
|
|
((iter
|
|
(lambda (l)
|
|
(if (not (null? l))
|
|
(begin
|
|
(vector-set!
|
|
v (- (car l) minv)
|
|
(+ 1 (vector-ref v (- (car l) minv))))
|
|
(iter (cdr l)))))))
|
|
(iter l)
|
|
(map
|
|
(lambda (pos)
|
|
(cons pos (vector-ref v (- pos minv))))
|
|
(make-range minv maxv))))))
|
|
|
|
(define drawhist
|
|
(lambda (h)
|
|
(letrec
|
|
((len (length h)) (total (* 1.0 (apply + (map cdr h))))
|
|
(mx (apply max (map cdr h))) (scale 400)
|
|
(colors
|
|
(list->vector
|
|
'((0 0 255) (0 255 0) (0 255 255)
|
|
(255 0 0) (255 0 255) (255 255 0))))
|
|
(bars
|
|
(lambda (pos h)
|
|
(let ((frac (/ (cdar h) total)))
|
|
(apply draw-color (vector-ref colors (remainder pos 6)))
|
|
(draw-move (* pos 40) 0)
|
|
(fill-rect 30 (* scale frac))
|
|
(if (not (null? (cdr h)))
|
|
(bars (+ 1 pos) (cdr h))))))
|
|
(labels
|
|
(lambda (pos h)
|
|
(draw-move (* pos 40) -20)
|
|
(draw-string (format "~a" (caar h)))
|
|
(if (not (null? (cdr h)))
|
|
(labels (+ 1 pos) (cdr h)))))
|
|
(values
|
|
(lambda (pos h)
|
|
(let ((frac (/ (cdar h) total)))
|
|
(draw-move (* pos 40) (+ 10 (* scale frac)))
|
|
(draw-string (format "~a" (cdar h)))
|
|
(if (not (null? (cdr h)))
|
|
(values (+ 1 pos) (cdr h)))))))
|
|
(bars 0 h)
|
|
(draw-color 0 0 0)
|
|
(labels 0 h)
|
|
(values 0 h)
|
|
(draw-move -40 0) (draw-line (* (+ 1 len) 40) 0)
|
|
(draw-move -20 -20) (draw-line -20 (* scale (/ mx total))))))
|
|
|
|
(define qhist
|
|
(lambda (n)
|
|
(drawhist (ints2hist (qsort-stats n)))))
|
|
|
|
(qhist 6)
|
|
|
|
|
|
|