Percolation/Mean cluster density: Difference between revisions
Percolation/Mean cluster density (view source)
Revision as of 08:25, 20 September 2013
, 10 years ago→{{header|Racket}}
(=={{header|Racket}}== stub added... code comes in a moment.) |
|||
Line 247:
=={{header|Racket}}==
<lang racket>#lang racket
(require srfi/14) ; character sets
; much faster than safe fixnum functions
(require
racket/require ; for fancy require clause below
(filtered-in
(lambda (name) (regexp-replace #rx"unsafe-" name ""))
racket/unsafe/ops)
; these aren't in racket/unsafe/ops
(only-in racket/fixnum for/fxvector fxvector-copy))
; ...(but less safe). if in doubt use this rather than the one above
; (require racket/fixnum)
(define t (make-parameter 5))
(define (build-random-grid p M N)
(define p-num (numerator p))
(define p-den (denominator p))
(for/fxvector #:length (fx* M N) ((_ (in-range (* M N))))
(if (< (random p-den) p-num) 1 0)))
(define letters
(sort (char-set->list (char-set-intersection
char-set:letter
; char-set:ascii
)) char<?))
(define n-letters (length letters))
(define cell->char
(match-lambda
(0 #\space) (1 #\.)
(c (list-ref letters (modulo (- c 2) n-letters)))))
(define (draw-percol-grid M N . gs)
(for ((r N))
(for ((g gs))
(define row-str
(list->string
(for/list ((idx (in-range (* r M) (* (+ r 1) M))))
(cell->char (fxvector-ref g idx)))))
(printf "|~a| " row-str))
(newline)))
(define (count-clusters! M N g)
(define (gather-cluster! k c)
(when (fx= 1 (fxvector-ref g k))
(define k-r (fxquotient k M))
(define k-c (fxremainder k M))
(fxvector-set! g k c)
(define-syntax-rule (gather-surrounds range? k+)
(let ((idx k+))
(when (and range? (fx= 1 (fxvector-ref g idx)))
(gather-cluster! idx c))))
(gather-surrounds (fx> k-r 0) (fx- k M))
(gather-surrounds (fx> k-c 0) (fx- k 1))
(gather-surrounds (fx< k-c (fx- M 1)) (fx+ k 1))
(gather-surrounds (fx< k-r (fx- N 1)) (fx+ k M))))
(define-values (rv _c)
(for/fold ((rv 0) (c 2))
((pos (in-range (fx* M N)))
#:when (fx= 1 (fxvector-ref g pos)))
(gather-cluster! pos c)
(values (fx+ rv 1) (fx+ c 1))))
rv)
(define (display-sample-clustering p)
(printf "Percolation cluster sample: p=~a~%" p)
(define g (build-random-grid p 15 15))
(define g+ (fxvector-copy g))
(define g-count (count-clusters! 15 15 g+))
(draw-percol-grid 15 15 g g+)
(printf "~a clusters~%" g-count))
(define (experiment p n t)
(printf "Experiment: ~a ~a ~a\t" p n t) (flush-output)
(define sum-Cn
(for/sum ((run (in-range t)))
(printf "[~a" run) (flush-output)
(define g (build-random-grid p n n))
(printf "*") (flush-output)
(define Cn (count-clusters! n n g))
(printf "]") (flush-output)
Cn))
(printf "\tmean K(p) = ~a~%" (real->decimal-string (/ sum-Cn t (sqr n)) 6)))
(module+ main
(t 10)
(for ((n (in-list '(4000 1000 750 500 400 300 200 100 15))))
(experiment 1/2 n (t))))
(module+ test
(display-sample-clustering 1/2))</lang>
{{out}}
Run from DrRacket, which runs the test and main modules. From the command line, you'll
want two commands: ``racket percolation_m_c_d.rkt`` and ``raco test percolation_m_c_d.rkt``
for the same result.
<pre>
Experiment: 1/2 4000 10 [0*][1*][2*][3*][4*][5*][6*][7*][8*][9*] mean K(p) = 0.065860
Experiment: 1/2 1000 10 [0*][1*][2*][3*][4*][5*][6*][7*][8*][9*] mean K(p) = 0.066130
Experiment: 1/2 750 10 [0*][1*][2*][3*][4*][5*][6*][7*][8*][9*] mean K(p) = 0.066195
Experiment: 1/2 500 10 [0*][1*][2*][3*][4*][5*][6*][7*][8*][9*] mean K(p) = 0.066522
Experiment: 1/2 400 10 [0*][1*][2*][3*][4*][5*][6*][7*][8*][9*] mean K(p) = 0.066778
Experiment: 1/2 300 10 [0*][1*][2*][3*][4*][5*][6*][7*][8*][9*] mean K(p) = 0.066813
Experiment: 1/2 200 10 [0*][1*][2*][3*][4*][5*][6*][7*][8*][9*] mean K(p) = 0.067908
Experiment: 1/2 100 10 [0*][1*][2*][3*][4*][5*][6*][7*][8*][9*] mean K(p) = 0.069980
Experiment: 1/2 15 10 [0*][1*][2*][3*][4*][5*][6*][7*][8*][9*] mean K(p) = 0.089778
Percolation cluster sample: p=1/2
|. ... . . | |A BBB A A |
|... .. .... | |AAA AA AAAA |
|. . .... ... | |A A AAAA AAA |
|. . . .........| |A A C AAAAAAAAA|
| ... .. ....| | AAA AA AAAA|
|.. ......... ..| |AA AAAAAAAAA AA|
| . ... | | A AAA |
|. .. .. | |D AA AA |
| .. ... . .. | | AA AAA E AA |
|. .. .. . . | |F AA AA A A |
|. ........ . ..| |F AAAAAAAA A AA|
|.. . .... ... | |FF A AAAA AAA |
| . . . .... | | F G A AAAA |
|.... .. .. . .| |FFFF HH AA A A|
| . .. .....| | F HH AAAAA|
8 clusters</pre>
| |||