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



