# Haskell Quiz/SimFrost/Solution Dolio

(diff) ← Older revision | Latest revision (diff) | Newer revision → (diff)
Jump to: navigation, search

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)```