# 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 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.

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 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_ putStrLn . map showRegion showRegion :: Region Content -> String showRegion = unlines . map ('|':) . map join . map (map show)