Rosetta Code

Percolation/Site percolation: Difference between revisions

Page Discussion

Percolation/Site percolation (view source)

Revision as of 20:41, 19 May 2017

122 bytes added ,  7 years ago
simplified and sped up haskell version
m (→‎{{header|Perl 6}}: Minor efficiency tweaks, rearrange slightly, clean up superfluous semicolons)
(simplified and sped up haskell version)
Line 674:
p=1.00, 1.0000
</pre>
 
=={{header|Haskell}}==
<lang haskell>{-# LANGUAGE OverloadedStrings #-}
import Control.Monad
{-# LANGUAGE OverloadedStrings #-}
import Control.Monad.Random
import ControlData.MonadArray.RandomUnboxed
import Data.Array.UnboxedList
import Data.ListFormatting
import Formatting
 
type Field = UArray (Int, Int) Char
 
-- Start percolating some seepage through a field.
-- Recurse to continue percolation with spreadingnew seepage.
percolateR :: [(Int, Int)] -> Field -> (Field, [(Int,Int)])
percolateR [] f = (f, [])
percolateR seep f = percolateR
let ((rLoxLo,cLoyLo),(rHixHi,cHiyHi)) = bounds f▼
(concat $ fmap neighbors validSeep) ▼
validSeep = filter (\p@(x,y) -> x (f // map (\p ->= (p,'.')) validSeep)xLo where
c <= cHi && x <= xHi ▼
neighbors p@(r,c) = [(r-1,c), (r+1,c), (r, c-1), (r, c+1)]▼
f!p == ' ') $&& nuby $>= sortyLo seep▼
▲ ((rLo,cLo),(rHi,cHi)) = bounds f
else '#') && y <= yHi ▼
validSeep = filter (\p@(r,c) -> r >= rLo &&
r <= rHi && f!p == ' ') $ nub $ sort seep
c >= cLo &&
▲ neighbors p@(rx,cy) = [(rx,y-1,c), (rx,y+1,c), (r, cx-1,y), (r, cx+1,y)]
▲ c <= cHi &&
▲ f!p == ' ') $ nub $ sort seep
 
in percolateR
-- Percolate a field; Return the percolated field.▼
▲ (concat $ fmapconcatMap neighbors validSeep)
(f // map (\p -> (p,'.')) validSeep)
▲-- Percolate a field;. Return the percolated field.
percolate :: Field -> Field
percolate start =
let ((_,_),(_xHi,cHi_)) = bounds start
(final, _) = percolateR [(0x,c0) | cx <- [0..cHixHi]] start
in final
 
-- Generate a random field.
randomFieldinitField :: Int -> Int -> Double -> Rand StdGen Field
randomFieldinitField rowsw colsh threshold = do
frnd <- fmap (\rv -> if rv<threshold then ' ' else '#') <$> getRandoms
rnd <- replicateM rows (replicateM cols $ getRandomR (0.0, 1.0))
return $ arraylistArray ((0,0), (rowsw-1, colsh-1)) frnd
[((r,c), if rnd !! r !! c < threshold then ' '
-- Get a list of "leaks" from the bottom of a field.
▲ else '#')
leakyleaks :: Field -> [Bool]▼
| r <- [0..rows-1], c <- [0..cols-1] ] ▼
leaks f =
 
let ((xLo,_,cLo),(rHixHi,cHiyHi)) = bounds f▼
-- Assess whether or not percolation reached bottom of field.
in [f!(x,yHi)=='.'| x <- [xLo..xHi]]
▲leaky :: Field -> Bool
leaky f = '.' `elem` [f!(rHi,c) | c <- [cLo..cHi]] where
▲ ((_,cLo),(rHi,cHi)) = bounds f
 
-- Run test once; Return bool indicating success or failure.
oneTest :: Int -> Int -> Double -> Rand StdGen Bool
oneTest rowsw colsh threshold =
leaky <$> or.leaks.percolate <$> randomFieldinitField rowsw colsh threshold
 
-- Run test multple times; Return the number of tests that pass.
multiTest :: Int -> Int -> Int -> Double -> Rand StdGen Double
multiTest repeatstestCount rowsw colsh threshold = do
xresults <- replicateM repeatstestCount $ oneTest rowsw colsh threshold
let leakyCount = length $ filter (==True)id xresults
return $ fromIntegral leakyCount / fromIntegral repeatstestCount
 
-- Display a field with walls and leaks.
showField :: Field -> IO ()
showField a = do
showField a = mapM_ print [ [ a!(r,c) | c <- [cLo..cHi]] | r <- [rLo..rHi]]▼
wherelet ((rLoxLo,cLoyLo),(rHixHi,cHiyHi)) = bounds a
▲showField a = mapM_ print [ [ a!(rx,cy) | cx <- [cLoxLo..cHixHi]] | ry <- [rLoyLo..rHiyHi]]
 
main :: IO ()
main = do
g <- getStdGen
let dw = 1015▼
let (startField, g2) = runRand (randomField 15 15 0.6) g▼
h = 15
putStrLn "Unpercolated field with 0.6 threshold."▼
threshold = 0.6
▲ let (startField, g2) = runRand (randomFieldinitField 15w 15h 0.6threshold) g
 
▲ putStrLn ("Unpercolated field with 0.6" ++ show threshold ++ " threshold.")
putStrLn ""
showField startField
 
putStrLn ""
putStrLn "Same field after percolation."
Line 751 ⟶ 756:
showField $ percolate startField
 
let testCount = 10000
densityCount = 10
putStrLn ""
putStrLn ( "Results of running percolation test 10000" times++ withshow thresholdstestCount ranging from 0.0 to 1.0 ."
++ " times with thresholds ranging from 0/" ++ show densityCount
▲ let d = 10
++ " to " ++ show densityCount ++ "/" ++ show densityCount ++ " .")
let ns = [0..10]
 
let tests = sequence [multiTest 10000 15 15 v ▼
let densities = [0..densityCount]
| n <- ns,
▲ let tests = sequence [multiTest 10000testCount 15w 15h v
let v = fromIntegral n / fromIntegral d ]▼
▲ | r <- [0..rows-1], c | density <- [0..cols-1] ] densities,
let results = zip ns (evalRand tests g2)▼
▲ let v = fromIntegral ndensity / fromIntegral ddensityCount ]
mapM_ print [format ("p=" % int % "/" % int % " -> " % fixed 4) n d r | (n,r) <- results]▼
▲ let results = zip nsdensities (evalRand tests g2)
</lang>
▲ mapM_ print [format ("p=" % int % "/" % int % " -> " % fixed 4) ndensity ddensityCount rx | (ndensity,rx) <- results]</lang>
 
{{out}}
<pre style="font-size:80%">
Unpercolated field with 0.6 threshold.
 
"# ### # # # ## "
" ### # ## # # "
"# ## # ## # # ##"
"# # ## # ## "
"### # # # "
" ## # ### ## "
" ## # # ### ##"
"# # ## # # # #"
"# # ### # # ##"
"## ## ## ## # "
" ## # ##"
"## # ## # ## ## #"
" #### ## ## "
"#### # # # # # #"
" # # # # # "
 
Same field after percolation.
 
"#..###.#..#.#..##."
" ### #..##..#...#.."
"..# ##.#.#..#..#.##"
"# #....#..##..#..."
"### #.#........#.."
" ## #....###.##....."
" ### #.#.....###.##"
"# # ##.#...#..#.#"
"# # ###...#.#..##"
"## ## ##.##.#......"
" ## #......##"
"## # # #.#.#.###.#"
" #### ##..## ...."
"#### # #..# # .# #"
" # #....## "
 
Results of running percolation test 10000 times with thresholds ranging from 0.0/10 to 1.010/10 .
"p=0/10 -> 0.0000"
"p=1/10 -> 0.0000"
"p=2/10 -> 0.0000"
"p=3/10 -> 0.0000"
"p=4/10 -> 0.00300028"
"p=5/10 -> 0.09080910"
"p=6/10 -> 0.56485684"
"p=7/10 -> 0.95579572"
"p=8/10 -> 0.99969997"
"p=9/10 -> 1.0000"
"p=10/10 -> 1.0000"
</pre>
 
=={{header|J}}==
 
Retrieved from "https://rosettacode.org/wiki/Special:MobileDiff/234211"