fannkuch.mlish (1854B)
1 #lang s-exp "../../mlish.rkt" 2 (require "../rackunit-typechecking.rkt") 3 4 (define (fannkuch [n : Int] -> Int) 5 (let ([pi (list->vector 6 (for/list ([i (in-range n)]) i))] 7 [tmp (make-vector n)] 8 [count (make-vector n)]) 9 (let loop : Int ([flips 0] [perms 0] [r n]) 10 #;(when (< perms 30) 11 (for ([x (in-vector pi)]) 12 (display (add1 x))) 13 (newline)) 14 (for ([i (in-range r)]) 15 (vector-set! count i (add1 i))) 16 (let ((flips2 (max (count-flips pi tmp) flips))) 17 (let loop2 : Int ([r 1]) 18 (if (= r n) 19 flips2 20 (let ((perm0 (vector-ref pi 0))) 21 (for ([i (in-range r)]) 22 (vector-set! pi i (vector-ref pi (add1 i)))) 23 (vector-set! pi r perm0) 24 (vector-set! count r (sub1 (vector-ref count r))) 25 (cond 26 [(<= (vector-ref count r) 0) 27 (loop2 (add1 r))] 28 [else (loop flips2 (add1 perms) r)])))))))) 29 30 (define (count-flips [pi : (Vector Int)] [rho : (Vector Int)] -> Int) 31 (vector-copy! rho 0 pi) 32 (let loop : Int ([i 0]) 33 (if (= (vector-ref rho 0) 0) 34 i 35 (begin 36 (vector-reverse-slice! rho 0 (add1 (vector-ref rho 0))) 37 (loop (add1 i)))))) 38 39 (define (vector-reverse-slice! [v : (Vector X)] [i : Int] [j : Int] -> Unit) 40 (let loop : Unit ([i i] [j (sub1 j)]) 41 (when (> j i) 42 (vector-swap! v i j) 43 (loop (add1 i) (sub1 j))))) 44 45 (define (vector-swap! [v : (Vector X)] [i : Int] [j : Int] -> Unit) 46 (let ((t (vector-ref v i))) 47 (vector-set! v i (vector-ref v j)) 48 (vector-set! v j t))) 49 50 (check-type (fannkuch 5) : Int -> 7) 51 (check-type (fannkuch 6) : Int -> 10) 52 (check-type (fannkuch 7) : Int -> 16) 53 (check-type (fannkuch 8) : Int -> 22) 54 (check-type (fannkuch 9) : Int -> 30)