# Haskell Quiz/SimFrost/Solution Dolio

### From HaskellWiki

m (description) |
m (splittable random monad) |

## Revision as of 11:31, 18 March 2007

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.

{-# OPTIONS -fno-monomorphism-restriction -fglasgow-exts #-} module Main where import Data.List import Control.Arrow import Control.Monad import Control.Monad.Instances import System import System.Random import MonadRandom import PPImage 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) randomR = (first toEnum .) . randomR . (fromEnum *** fromEnum) instance Random Content where random = randomR (minBound, maxBound) randomR = (first toEnum .) . randomR . (fromEnum *** fromEnum) 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 [x, y] = zipWith (\a b -> [a, b]) x y 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) => Int -> Int -> m (Region Content) randomRegion 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 = getRandomR (Vapor, 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 [] | otherwise = do r' <- g r rs <- splitRandom $ f r' -- This is key. Allows the generations to be lazily generated. return (r':rs) step = stepper update step' step' = stepper update' step main = do [n, m] <- fmap (map read) getArgs if odd n || odd m then putStrLn "Dimensions must be even." else randomRegion n m >>= process >>= mapM_ output . zip [100..] . map ppmRegion 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 h w 255 where pix = map (map f) r h = length r w = head . map length $ r f Vacuum = black f Frost = white f Vapor = blue

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]], height :: Int, width :: 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 h ++ " " ++ show w ++ "\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 m n 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