# Haskell Quiz/SimFrost/Solution Dolio

### From HaskellWiki

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.

{-# 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 :: (MonadRandom 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 <- f r' 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