Haskell Quiz/SimFrost/Solution Dolio
< Haskell Quiz | SimFrost
Jump to navigation
Jump to 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)