Personal tools

Haskell Quiz/SimFrost/Solution Dolio

From HaskellWiki

< Haskell Quiz | SimFrost(Difference between revisions)
Jump to: navigation, 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_ putStrLn . map showRegion
+
                                   >>= 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