1 2(define allperms 3 (lambda (n) 4 (if (= n 1) '((1)) 5 (letrec 6 ((allpos (list-n n)) 7 (insert 8 (lambda (pos el l) 9 (if (= pos 1) 10 (cons el l) 11 (cons (car l) 12 (insert (- pos 1) el (cdr l)))))) 13 (result '())) 14 (for-each 15 (lambda (p) 16 (for-each 17 (lambda (pos) 18 (set! 19 result 20 (cons 21 (insert pos n p) result))) 22 allpos)) 23 (allperms (- n 1))) 24 result)))) 25 26 27(define make-cmp 28 (lambda () 29 (let ((count 0)) 30 (lambda (what . args) 31 (case what 32 ((count) count) 33 ((cmp) 34 (begin 35 (set! count (+ 1 count)) 36 (< (car args) (cadr args))))))))) 37 38(define qsort 39 (lambda (perm compare) 40 (if (null? perm) '() 41 (if (null? (cdr perm)) perm 42 (letrec 43 ((pivot (car perm)) 44 (left '()) (leftend '()) 45 (right '()) (rightend '()) 46 (split 47 (lambda (l) 48 (if (compare 'cmp (car l) pivot) 49 (if (null? leftend) 50 (begin 51 (set! left (list (car l))) 52 (set! leftend left)) 53 (begin 54 (set-cdr! leftend (list (car l))) 55 (set! leftend (cdr leftend)))) 56 (if (null? rightend) 57 (begin 58 (set! right (list (car l))) 59 (set! rightend right)) 60 (begin 61 (set-cdr! rightend (list (car l))) 62 (set! rightend (cdr rightend))))) 63 (if (not (null? (cdr l))) (split (cdr l)))))) 64 (split (cdr perm)) 65 (append 66 (qsort left compare) 67 (list pivot) 68 (qsort right compare))))))) 69 70(define qsort-stats 71 (lambda (n) 72 (map 73 (lambda (p) 74 (let ((c (make-cmp))) 75 (qsort p c) 76 (c 'count))) 77 (allperms n)))) 78 79(define ints2hist 80 (lambda (l) 81 (let* ((minv (apply min l)) 82 (maxv (apply max l)) 83 (v (make-vector (+ 1 (- maxv minv)) 0))) 84 (letrec 85 ((iter 86 (lambda (l) 87 (if (not (null? l)) 88 (begin 89 (vector-set! 90 v (- (car l) minv) 91 (+ 1 (vector-ref v (- (car l) minv)))) 92 (iter (cdr l))))))) 93 (iter l) 94 (map 95 (lambda (pos) 96 (cons pos (vector-ref v (- pos minv)))) 97 (make-range minv maxv)))))) 98 99(define drawhist 100 (lambda (h) 101 (letrec 102 ((len (length h)) (total (* 1.0 (apply + (map cdr h)))) 103 (mx (apply max (map cdr h))) (scale 400) 104 (colors 105 (list->vector 106 '((0 0 255) (0 255 0) (0 255 255) 107 (255 0 0) (255 0 255) (255 255 0)))) 108 (bars 109 (lambda (pos h) 110 (let ((frac (/ (cdar h) total))) 111 (apply draw-color (vector-ref colors (remainder pos 6))) 112 (draw-move (* pos 40) 0) 113 (fill-rect 30 (* scale frac)) 114 (if (not (null? (cdr h))) 115 (bars (+ 1 pos) (cdr h)))))) 116 (labels 117 (lambda (pos h) 118 (draw-move (* pos 40) -20) 119 (draw-string (format "~a" (caar h))) 120 (if (not (null? (cdr h))) 121 (labels (+ 1 pos) (cdr h))))) 122 (values 123 (lambda (pos h) 124 (let ((frac (/ (cdar h) total))) 125 (draw-move (* pos 40) (+ 10 (* scale frac))) 126 (draw-string (format "~a" (cdar h))) 127 (if (not (null? (cdr h))) 128 (values (+ 1 pos) (cdr h))))))) 129 (bars 0 h) 130 (draw-color 0 0 0) 131 (labels 0 h) 132 (values 0 h) 133 (draw-move -40 0) (draw-line (* (+ 1 len) 40) 0) 134 (draw-move -20 -20) (draw-line -20 (* scale (/ mx total)))))) 135 136(define qhist 137 (lambda (n) 138 (drawhist (ints2hist (qsort-stats n))))) 139 140(qhist 6) 141 142 143 144