Difference between revisions of "Haskell Quiz/SimFrost/Solution Dolio"
< Haskell Quiz | SimFrost
Jump to navigation
Jump to search
m (solutions) |
(ppm image creation) |
||
Line 22: | Line 22: | ||
import MonadRandom |
import MonadRandom |
||
+ | import PPImage |
||
data Content = Frost | Vapor | Vacuum deriving (Eq, Bounded, Enum) |
data Content = Frost | Vapor | Vacuum deriving (Eq, Bounded, Enum) |
||
Line 105: | Line 106: | ||
then putStrLn "Dimensions must be even." |
then putStrLn "Dimensions must be even." |
||
else randomRegion n m >>= process |
else randomRegion n m >>= process |
||
− | >>= mapM_ |
+ | >>= 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 :: Region Content -> String |
||
showRegion = unlines . map ('|':) . map join . map (map show) |
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 |
||
+ | </haskell> |
||
+ | |||
+ | The following is some auxiliary code to output PPM images of the results: |
||
+ | |||
+ | <haskell> |
||
+ | 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 |
||
</haskell> |
</haskell> |
Revision as of 10:48, 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 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
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