September 2017 Update
This commit is contained in:
Ingy döt Net
parent
bba7bfd280
commit
ba8067c3b7
14570 changed files with 153136 additions and 63871 deletions
|
|
@ -0,0 +1,121 @@
|
|||
{-# LANGUAGE OverloadedStrings #-}
|
||||
import Control.Monad
|
||||
import Control.Monad.Random
|
||||
import Data.Array.Unboxed
|
||||
import Data.List
|
||||
import Formatting
|
||||
|
||||
data Field = Field { f :: UArray (Int, Int) Char
|
||||
, hWall :: UArray (Int, Int) Bool
|
||||
, vWall :: UArray (Int, Int) Bool
|
||||
}
|
||||
|
||||
-- Start percolating some seepage through a field.
|
||||
-- Recurse to continue percolation with new seepage.
|
||||
percolateR :: [(Int, Int)] -> Field -> (Field, [(Int,Int)])
|
||||
percolateR [] (Field f h v) = (Field f h v, [])
|
||||
percolateR seep (Field f h v) =
|
||||
let ((xLo,yLo),(xHi,yHi)) = bounds f
|
||||
validSeep = filter (\p@(x,y) -> x >= xLo
|
||||
&& x <= xHi
|
||||
&& y >= yLo
|
||||
&& y <= yHi
|
||||
&& f!p == ' ') $ nub $ sort seep
|
||||
|
||||
north (x,y) = if v ! (x ,y ) then [] else [(x ,y-1)]
|
||||
south (x,y) = if v ! (x ,y+1) then [] else [(x ,y+1)]
|
||||
west (x,y) = if h ! (x ,y ) then [] else [(x-1,y )]
|
||||
east (x,y) = if h ! (x+1,y ) then [] else [(x+1,y )]
|
||||
neighbors (x,y) = north(x,y) ++ south(x,y) ++ west(x,y) ++ east(x,y)
|
||||
|
||||
in percolateR
|
||||
(concatMap neighbors validSeep)
|
||||
(Field (f // map (\p -> (p,'.')) validSeep) h v)
|
||||
|
||||
-- Percolate a field; Return the percolated field.
|
||||
percolate :: Field -> Field
|
||||
percolate start@(Field f _ _) =
|
||||
let ((_,_),(xHi,_)) = bounds f
|
||||
(final, _) = percolateR [(x,0) | x <- [0..xHi]] start
|
||||
in final
|
||||
|
||||
-- Generate a random field.
|
||||
initField :: Int -> Int -> Double -> Rand StdGen Field
|
||||
initField width height threshold = do
|
||||
let f = listArray ((0,0), (width-1, height-1)) $ repeat ' '
|
||||
|
||||
hrnd <- fmap (<threshold) <$> getRandoms
|
||||
let h0 = listArray ((0,0),(width, height-1)) hrnd
|
||||
h1 = h0 // [((0,y), True) | y <- [0..height-1]] -- close left
|
||||
h2 = h1 // [((width,y), True) | y <- [0..height-1]] -- close right
|
||||
|
||||
vrnd <- fmap (<threshold) <$> getRandoms
|
||||
let v0 = listArray ((0,0),(width-1, height)) vrnd
|
||||
v1 = v0 // [((x,0), True) | x <- [0..width-1]] -- close top
|
||||
|
||||
return $ Field f h2 v1
|
||||
|
||||
-- Assess whether or not percolation reached bottom of field.
|
||||
leaks :: Field -> [Bool]
|
||||
leaks (Field f _ v) =
|
||||
let ((xLo,_),(xHi,yHi)) = bounds f
|
||||
in [f!(x,yHi)=='.' && not (v!(x,yHi+1)) | x <- [xLo..xHi]]
|
||||
|
||||
-- Run test once; Return bool indicating success or failure.
|
||||
oneTest :: Int -> Int -> Double -> Rand StdGen Bool
|
||||
oneTest width height threshold =
|
||||
or.leaks.percolate <$> initField width height threshold
|
||||
|
||||
-- Run test multple times; Return the number of tests that pass.
|
||||
multiTest :: Int -> Int -> Int -> Double -> Rand StdGen Double
|
||||
multiTest testCount width height threshold = do
|
||||
results <- replicateM testCount $ oneTest width height threshold
|
||||
let leakyCount = length $ filter id results
|
||||
return $ fromIntegral leakyCount / fromIntegral testCount
|
||||
|
||||
-- Helper function for display
|
||||
alternate :: [a] -> [a] -> [a]
|
||||
alternate [] _ = []
|
||||
alternate (a:as) bs = a : alternate bs as
|
||||
|
||||
-- Display a field with walls and leaks.
|
||||
showField :: Field -> IO ()
|
||||
showField field@(Field a h v) = do
|
||||
let ((xLo,yLo),(xHi,yHi)) = bounds a
|
||||
fLines = [ [ a!(x,y) | x <- [xLo..xHi]] | y <- [yLo..yHi]]
|
||||
hLines = [ [ if h!(x,y) then '|' else ' ' | x <- [xLo..xHi+1]] | y <- [yLo..yHi]]
|
||||
vLines = [ [ if v!(x,y) then '-' else ' ' | x <- [xLo..xHi]] | y <- [yLo..yHi+1]]
|
||||
lattice = [ [ '+' | x <- [xLo..xHi+1]] | y <- [yLo..yHi+1]]
|
||||
|
||||
hDrawn = zipWith alternate hLines fLines
|
||||
vDrawn = zipWith alternate lattice vLines
|
||||
mapM_ putStrLn $ alternate vDrawn hDrawn
|
||||
|
||||
let leakLine = [ if l then '.' else ' ' | l <- leaks field]
|
||||
putStrLn $ alternate (repeat ' ') leakLine
|
||||
|
||||
main :: IO ()
|
||||
main = do
|
||||
g <- getStdGen
|
||||
let threshold = 0.45
|
||||
(startField, g2) = runRand (initField 10 10 threshold) g
|
||||
|
||||
putStrLn ("Unpercolated field with " ++ show threshold ++ " threshold.")
|
||||
putStrLn ""
|
||||
showField startField
|
||||
|
||||
putStrLn ""
|
||||
putStrLn "Same field after percolation."
|
||||
putStrLn ""
|
||||
showField $ percolate startField
|
||||
|
||||
let testCount = 10000
|
||||
densityCount = 10
|
||||
putStrLn ""
|
||||
putStrLn ("Results of running percolation test " ++ show testCount ++ " times with thresholds ranging from 0/" ++ show densityCount ++ " to " ++ show densityCount ++ "/" ++ show densityCount ++ " .")
|
||||
let densities = [0..densityCount]
|
||||
let tests = sequence [multiTest testCount 10 10 v
|
||||
| density <- densities,
|
||||
let v = fromIntegral density / fromIntegral densityCount ]
|
||||
let results = zip densities (evalRand tests g2)
|
||||
mapM_ print [format ("p=" % int % "/" % int % " -> " % fixed 4) density densityCount x | (density,x) <- results]
|
||||
|
|
@ -0,0 +1,72 @@
|
|||
my @bond;
|
||||
my $grid = 10;
|
||||
my $geom = $grid - 1;
|
||||
my $water = '▒';
|
||||
|
||||
enum Direction <DeadEnd Up Right Down Left>;
|
||||
|
||||
say 'Sample percolation at .6';
|
||||
percolate .6;
|
||||
.join.say for @bond;
|
||||
say "\n";
|
||||
|
||||
my $tests = 100;
|
||||
say "Doing $tests trials at each porosity:";
|
||||
for .1, .2 ... 1 -> $p {
|
||||
printf "p = %0.1f: %0.2f\n", $p, (sum percolate($p) xx $tests) / $tests
|
||||
}
|
||||
|
||||
sub percolate ( $prob ) {
|
||||
generate $prob;
|
||||
my @stack;
|
||||
my $current = [1;0];
|
||||
$current.&fill;
|
||||
|
||||
loop {
|
||||
if my $dir = direction( $current ) {
|
||||
@stack.push: $current;
|
||||
$current = move $dir, $current
|
||||
}
|
||||
else {
|
||||
return 0 unless @stack;
|
||||
$current = @stack.pop
|
||||
}
|
||||
return 1 if $current[1] == +@bond - 1
|
||||
}
|
||||
|
||||
sub direction( [$x, $y] ) {
|
||||
( Down if @bond[$y + 1][$x].contains: ' ' ) ||
|
||||
( Left if @bond[$y][$x - 1].contains: ' ' ) ||
|
||||
( Right if @bond[$y][$x + 1].contains: ' ' ) ||
|
||||
( Up if @bond[$y - 1][$x].defined && @bond[$y - 1][$x].contains: ' ' ) ||
|
||||
DeadEnd
|
||||
}
|
||||
|
||||
sub move ( $dir, @cur ) {
|
||||
my ( $x, $y ) = @cur;
|
||||
given $dir {
|
||||
when Up { [$x,--$y].&fill xx 2 }
|
||||
when Down { [$x,++$y].&fill xx 2 }
|
||||
when Left { [--$x,$y].&fill xx 2 }
|
||||
when Right { [++$x,$y].&fill xx 2 }
|
||||
}
|
||||
[$x, $y]
|
||||
}
|
||||
|
||||
sub fill ( [$x, $y] ) { @bond[$y;$x].=subst(' ', $water, :g) }
|
||||
}
|
||||
|
||||
sub generate ( $prob = .5 ) {
|
||||
@bond = ();
|
||||
my $sp = ' ';
|
||||
append @bond, [flat '│', ($sp, ' ') xx $geom, $sp, '│'],
|
||||
[flat '├', (h(), '┬') xx $geom, h(), '┤'];
|
||||
append @bond, [flat '│', ($sp, v()) xx $geom, $sp, '│'],
|
||||
[flat '├', (h(), '┼') xx $geom, h(), '┤'] for ^$geom;
|
||||
append @bond, [flat '│', ($sp, v()) xx $geom, $sp, '│'],
|
||||
[flat '├', (h(), '┴') xx $geom, h(), '┤'],
|
||||
[flat '│', ($sp, ' ') xx $geom, $sp, '│'];
|
||||
|
||||
sub h () { rand < $prob ?? $sp !! '───' }
|
||||
sub v () { rand < $prob ?? ' ' !! '│' }
|
||||
}
|
||||
|
|
@ -0,0 +1,46 @@
|
|||
// cell states
|
||||
const FILLED=1; // and odd
|
||||
const RWALL =2; // right wall
|
||||
const BWALL =4; // bottom wall
|
||||
fcn P(p,wall){ (0.0).random(1)<p and wall or 0 }
|
||||
|
||||
fcn makeGrid(m,n,p){
|
||||
// Allocate two addition rows to avoid checking bounds.
|
||||
// Bottom row is also required by drippage
|
||||
grid:=Data(m*(n+2));
|
||||
do(m){ grid.write(BWALL + RWALL); } // grid is topped with walls
|
||||
do(n){
|
||||
do(m-1){ grid.write( P(p,BWALL) + P(p,RWALL) ) }
|
||||
grid.write(RWALL + P(p,BWALL)); // right border is all right wall, as is left border
|
||||
}
|
||||
do(m){ grid.write(0); } // for drips off the bottom of grid
|
||||
grid
|
||||
}
|
||||
fcn show(grid,m,n){ n+=1;
|
||||
println("+--"*m,"+");
|
||||
foreach i in ([1..n]){ y:=i*m;
|
||||
print(i==n and " " or "|"); // bottom row is special, otherwise always have left wall
|
||||
foreach j in (m){ c:=grid[y + j];
|
||||
print(c.bitAnd(FILLED) and "**" or " ", c.bitAnd(RWALL)and"|"or" ");
|
||||
}
|
||||
println();
|
||||
|
||||
if(i==n) return(); // nothing under the bottom row
|
||||
|
||||
foreach j in (m){ print((grid[y + j].bitAnd(BWALL)) and "+--" or "+ "); }
|
||||
println("+");
|
||||
}
|
||||
}
|
||||
fcn fill(grid,x,m){
|
||||
if(grid[x].isOdd) return(False); // aka .bitAnd(FILLED) aka already been here
|
||||
grid[x]+=FILLED;
|
||||
if(x+m>=grid.len()) return(True); // success: reached bottom row
|
||||
return(( not grid[x] .bitAnd(BWALL) and fill(grid,x + m,m) ) or // down
|
||||
( not grid[x] .bitAnd(RWALL) and fill(grid,x + 1,m) ) or // right
|
||||
( not grid[x - 1].bitAnd(RWALL) and fill(grid,x - 1,m) ) or // left
|
||||
( not grid[x - m].bitAnd(BWALL) and fill(grid,x - m,m) )); // up
|
||||
}
|
||||
fcn percolate(grid,m){
|
||||
i:=0; while(i<m and not fill(grid,i+m,m)){ i+=1; } // pour juice on top row
|
||||
return(i<m); // percolated through the grid?
|
||||
}
|
||||
|
|
@ -0,0 +1,8 @@
|
|||
grid:=makeGrid(10,10,0.40);
|
||||
println("Did liquid percolate: ",percolate(grid,10)); show(grid,10,10);
|
||||
|
||||
println("Running 10,000 tests for each case:");
|
||||
foreach p in ([0.0 .. 1.0, 0.1]){
|
||||
cnt:=0.0; do(10000){ cnt+=percolate(makeGrid(10,10,p),10); }
|
||||
"p=%.1f: %.4f".fmt(p, cnt/10000).println();
|
||||
}
|
||||
Loading…
Add table
Add a link
Reference in a new issue