Difference between revisions of "Haskell Quiz/SimFrost/Solution Dolio"

This solution is based solely on list processing. The main datatype, Region a, is simply an alias for a. At each step, the region is broken into sub-regions (the 2x2 squares), each is rotated or frozen appropriately, and then the sub-regions are combined back into a single region.

The text output follows the Ruby Quiz convention of ' ' for vacuum, '.' for vapor and '*' for ice. A '|' is added on the left side of each line of the grid to distinguish them from separator lines.

The default output of this program is a number of PPM images of each step in the process. They are called frostNNN.ppm, where NNN starts from 100.

This code makes use of the random monad and the splittable random monad.

module Main where

import Data.List

import Control.Arrow

import System
import System.Random
import System.Console.GetOpt

import PPImage hiding (width, height)

data Content = Frost | Vapor | Vacuum deriving (Eq, Bounded, Enum)
data Direction = L | R deriving (Eq, Bounded, Enum, Show)

instance Random Direction where
random = randomR (minBound, maxBound)

instance Random Content where
random = randomR (minBound, maxBound)

instance Show Content where
show Frost = "*"
show Vapor = "."
show Vacuum = " "

type Region a = [[a]]

shift, unshift :: [a] -> [a]
shift   = liftM2 (:) last init
unshift = liftM2 (++) tail (return . head)

rotateR :: (MonadRandom m) => Region a -> m (Region a)
rotateR = flip liftM getRandom . flip r
where r R = transpose . reverse
r L = reverse . transpose

splitAtM :: (MonadPlus m) => Int -> [a] -> m ([a], [a])
splitAtM _ [] = mzero
splitAtM n xs = return \$ splitAt n xs

part :: Region a -> [[Region a]]
part = unfoldr (fmap (first z) . splitAtM 2) . map (unfoldr \$ splitAtM 2)
where
z = foldr (zipWith (:)) (repeat [])

unpart :: [[Region a]] -> [[a]]
unpart = join . (map \$ foldr1 (zipWith (++)))

freeze :: Region Content -> Region Content
freeze = map (map f)
where f Vacuum = Vacuum ; f _ = Frost

anyR :: (a -> Bool) -> Region a -> Bool
anyR = (or .) . map . any

vaporous, frosty :: Region Content -> Bool
vaporous = anyR (== Vapor)
frosty = anyR (== Frost)

randomRegion :: (MonadRandom m) => Double -> Int -> Int -> m (Region Content)
randomRegion d n m = do r <- replicateM (n - 1) rv
rs <- replicateM (m - 1) (replicateM n rv)
return \$ insert (div m 2) (insert (div n 2) Frost r) rs
where
insert n e l = let (h, t) = splitAt n l in h ++ e : t
rv = tr `liftM` getRandomR (0.0, 1.0)
tr r = if r < d then Vapor else Vacuum

update, update' :: (MonadRandom m) => Region Content -> m (Region Content)
update = liftM unpart . mapM (mapM op) . part
where op r = if frosty r then return \$ freeze r else rotateR r

update' = liftM unodd . update . odd
where
odd = shift . map (shift)
unodd = unshift . map (unshift)

process :: (MonadRandomSplittable m) => Region Content -> m [Region Content]
process r = liftM (r:) \$ step r
where
stepper g f r
| not (vaporous r) = return [r]
| otherwise        = (r:) `liftM` (g r >>= splitRandom . f)
step  = stepper update step'
step' = stepper update' step

output :: Integer -> PPM -> IO ()
output n ppm = writeFile ("frost" ++ show n ++ ".ppm") (show ppm)

showRegion :: Region Content -> String
showRegion = unlines . map ('|':) . map join . map (map show)

ppmRegion :: Region Content -> PPM
ppmRegion r = PPM pix w h 255
where
pix = map (map f) r
h   = length r
w   = head . map length \$ r
f Vacuum = black
f Frost  = white
f Vapor  = blue

main = do (fs, nonOpts, msgs) <- getOpt Permute options `fmap` getArgs
let (P n m d) = foldr (\$) defaultParms fs
if odd n || odd m
then putStrLn "Dimensions must be even."
else evalRandIO (randomRegion d n m >>= process)
>>= zipWithM_ output [100..]
. map ppmRegion

data Parms = P { width :: Int, height :: Int, percent :: Double }

defaultParms = P 200 200 0.5

options :: [OptDescr (Parms -> Parms)]
options =
[ Option "w" ["width"]  (ReqArg w "WIDTH")  "Width of the canvas."
, Option "h" ["height"] (ReqArg h "HEIGHT") "Height of the canvas."
, Option "p" ["percent"] (ReqArg p "PERCENT") "Percentage of vapor."
]
where
w arg opt = opt { width = read arg }
h arg opt = opt { height = read arg }
p arg opt = opt { percent = read arg }

The following is some auxiliary code to output PPM images of the results:

module PPImage ( Point
, Image
, Color(..)
, PPM(..)
, red
, yellow
, green
, cyan
, blue
, magenta
, black
, white
, pixelate )
where

type Point = (Double, Double)
type Image a = Point -> a

data Color = Color { r :: Int, g :: Int, b :: Int }

data PPM = PPM {
pixels :: [[Color]],
width :: Int,
height :: Int,
depth :: Int
}

instance Show Color where
show (Color r g b) = unwords [show r, show g, show b]

instance Show PPM where
show pg =  "P3\n"
++ show w ++ " " ++ show h ++ "\n"
++ show d ++ "\n"
++ (unlines . map unlines . map (map show) . pixels \$ pg) ++ "\n"
where h = height pg
w = width pg
d = depth pg

black   = Color   0   0   0
red     = Color 255   0   0
yellow  = Color 255 255   0
green   = Color   0 255   0
cyan    = Color   0 255 255
blue    = Color   0   0 255
magenta = Color 255   0 255
white   = Color 255 255 255

pixelate n m d (x0, x1) (y0, y1) i = PPM pixels n m d
where
pixels = [ i (x, y) | x <- px, y <- py ]
dx = (x1 - x0) / fromIntegral n
dy = (y0 - y1) / fromIntegral m
px = take n \$ iterate (+dx) x0
py = take m \$ iterate (+dy) y1