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