September Morn Update

Task/Percolation-Mean-cluster-density/Factor/percolation-mean-cluster-density.factor

@@ -0,0 +1,42 @@
+USING: combinators formatting generalizations kernel math
+math.matrices random sequences ;
+IN: rosetta-code.mean-cluster-density
+
+CONSTANT: p 0.5
+CONSTANT: iterations 5
+
+: rand-bit-matrix ( n probability -- matrix )
+    dupd [ random-unit > 1 0 ? ] curry make-matrix ;
+
+: flood-fill ( x y matrix -- )
+    3dup ?nth ?nth 1 = [
+        [ [ -1 ] 3dip nth set-nth ] [
+            {
+                [ [ 1 + ] 2dip ]
+                [ [ 1 - ] 2dip ]
+                [ [ 1 + ] dip ]
+                [ [ 1 - ] dip ]
+            } [ flood-fill ] map-compose 3cleave
+        ] 3bi
+    ] [ 3drop ] if ;
+
+: count-clusters ( matrix -- Cn )
+    0 swap dup dim matrix-coordinates flip concat [
+        first2 rot 3dup ?nth ?nth 1 = [ flood-fill 1 + ]
+        [ 3drop ] if
+    ] with each ;
+
+: mean-cluster-density ( matrix -- mcd )
+    [ count-clusters ] [ dim first sq / ] bi ;
+
+: simulate ( n -- avg-mcd )
+    iterations swap [ p rand-bit-matrix mean-cluster-density ]
+    curry replicate sum iterations / ;
+
+: main ( -- )
+    { 4 64 256 1024 4096 } [
+        [ iterations p ] dip dup simulate
+        "iterations = %d p = %.1f n = %4d sim = %.5f\n" printf
+    ] each ;
+
+MAIN: main

Task/Percolation-Mean-cluster-density/Perl/percolation-mean-cluster-density.pl

@@ -0,0 +1,72 @@
+$fill = 'x';
+$D{$_} = $i++ for qw<DeadEnd Up Right Down Left>;
+
+sub deq { defined $_[0] && $_[0] eq $_[1] }
+
+sub perctest {
+    my($grid) = @_;
+    generate($grid);
+    my $block = 1;
+    for my $y (0..$grid-1) {
+        for my $x (0..$grid-1) {
+            fill($x, $y, $block++) if $perc[$y][$x] eq $fill
+        }
+    }
+    ($block - 1) / $grid**2;
+}
+
+sub generate {
+    my($grid) = @_;
+    for my $y (0..$grid-1) {
+        for my $x (0..$grid-1) {
+            $perc[$y][$x] = rand() < .5 ? '.' : $fill;
+        }
+    }
+}
+
+sub fill {
+    my($x, $y, $block) = @_;
+    $perc[$y][$x] = $block;
+    my @stack;
+    while (1) {
+        if (my $dir = direction( $x, $y )) {
+            push @stack, [$x, $y];
+            ($x,$y) = move($dir, $x, $y, $block)
+        } else {
+            return unless @stack;
+            ($x,$y) = @{pop @stack};
+        }
+    }
+}
+
+sub direction {
+    my($x, $y) = @_;
+    return $D{Down}  if deq($perc[$y+1][$x  ], $fill);
+    return $D{Left}  if deq($perc[$y  ][$x-1], $fill);
+    return $D{Right} if deq($perc[$y  ][$x+1], $fill);
+    return $D{Up}    if deq($perc[$y-1][$x  ], $fill);
+    return $D{DeadEnd};
+}
+
+sub move {
+    my($dir,$x,$y,$block) = @_;
+    $perc[--$y][   $x] = $block if $dir == $D{Up};
+    $perc[++$y][   $x] = $block if $dir == $D{Down};
+    $perc[  $y][ --$x] = $block if $dir == $D{Left};
+    $perc[  $y][ ++$x] = $block if $dir == $D{Right};
+    ($x, $y)
+}
+
+my $K = perctest(15);
+for my $row (@perc) {
+    printf "%3s", $_ for @$row;
+    print "\n";
+}
+printf  "𝘱 = 0.5, 𝘕 = 15, 𝘒 = %.4f\n\n", $K;
+
+$trials = 5;
+for $N (10, 30, 100, 300, 1000) {
+    my $total = 0;
+    $total += perctest($N) for 1..$trials;
+    printf "𝘱 = 0.5, trials = $trials, 𝘕 = %4d, 𝘒 = %.4f\n", $N, $total / $trials;
+}

Task/Percolation-Mean-cluster-density/Phix/percolation-mean-cluster-density.phix

@@ -0,0 +1,66 @@
+sequence grid
+integer w, ww
+
+procedure make_grid(atom p)
+    ww = w*w
+    grid = repeat(0,ww)
+    for i=1 to ww do
+        grid[i] = -(rnd()<p)
+    end for
+end procedure
+
+constant alpha = "+.ABCDEFGHIJKLMNOPQRSTUVWXYZ"&
+                   "abcdefghijklmnopqrstuvwxyz"
+
+procedure show_cluster()
+    for i=1 to ww do
+        integer gi = grid[i]+2
+        grid[i] = iff(gi<=length(alpha)?alpha[gi]:'?')
+    end for
+    puts(1,join_by(grid,w,w,""))
+end procedure
+
+procedure recur(integer x, v)
+    if x>=1 and x<=ww and grid[x]==-1 then
+        grid[x] = v
+        recur(x-w, v)
+        recur(x-1, v)
+        recur(x+1, v)
+        recur(x+w, v)
+    end if
+end procedure
+
+function count_clusters()
+    integer cls = 0
+    for i=1 to ww do
+        if grid[i]=-1 then
+            cls += 1
+            recur(i, cls)
+        end if
+    end for
+    return cls
+end function
+
+function tests(int n, atom p)
+    atom k = 0
+    for i=1 to n do
+        make_grid(p)
+        k += count_clusters()/ww
+    end for
+    return k / n
+end function
+
+procedure main()
+    w = 15
+    make_grid(0.5)
+    printf(1,"width=15, p=0.5, %d clusters:\n", count_clusters())
+    show_cluster()
+
+    printf(1,"\np=0.5, iter=5:\n")
+    w = 4
+    while w<=4096 do
+        printf(1,"%5d %9.6f\n", {w, tests(5,0.5)})
+        w *= 4
+    end while
+end procedure
+main()