Personal tools

Haskell Quiz/SimFrost/Solution Dolio

From HaskellWiki

< Haskell Quiz | SimFrost(Difference between revisions)
Jump to: navigation, search
(ppm image creation)
m
 
(5 intermediate revisions by one user not shown)
Line 3: Line 3:
 
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.
 
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.
+
The text 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 [[New monads/MonadRandom|random monad]].
+
The default output of this program is a number of PPM images of each step in the process. They are called frostNNN.ppm, where NNN starts from 100.
   
<haskell>
+
This code makes use of the [[New monads/MonadRandom|random monad]] and the [[New monads/MonadRandomSplittable|splittable random monad]].
{-# OPTIONS -fno-monomorphism-restriction -fglasgow-exts #-}
 
   
  +
<haskell>
 
module Main where
 
module Main where
   
Line 19: Line 20:
 
import System
 
import System
 
import System.Random
 
import System.Random
  +
import System.Console.GetOpt
   
 
import MonadRandom
 
import MonadRandom
import PPImage
+
import PPImage hiding (width, height)
   
 
data Content = Frost | Vapor | Vacuum deriving (Eq, Bounded, Enum)
 
data Content = Frost | Vapor | Vacuum deriving (Eq, Bounded, Enum)
Line 57: Line 59:
 
part = unfoldr (fmap (first z) . splitAtM 2) . map (unfoldr $ splitAtM 2)
 
part = unfoldr (fmap (first z) . splitAtM 2) . map (unfoldr $ splitAtM 2)
 
where
 
where
z [x, y] = zipWith (\a b -> [a, b]) x y
+
z = foldr (zipWith (:)) (repeat [])
   
 
unpart :: [[Region a]] -> [[a]]
 
unpart :: [[Region a]] -> [[a]]
Line 73: Line 75:
 
frosty = anyR (== Frost)
 
frosty = anyR (== Frost)
   
randomRegion :: (MonadRandom m) => Int -> Int -> m (Region Content)
+
randomRegion :: (MonadRandom m) => Double -> Int -> Int -> m (Region Content)
randomRegion n m = do r <- replicateM (n - 1) rv
+
randomRegion d n m = do r <- replicateM (n - 1) rv
rs <- replicateM (m - 1) (replicateM n rv)
+
rs <- replicateM (m - 1) (replicateM n rv)
return $ insert (div m 2) (insert (div n 2) Frost r) rs
+
return $ insert (div m 2) (insert (div n 2) Frost r) rs
 
where
 
where
 
insert n e l = let (h, t) = splitAt n l in h ++ e : t
 
insert n e l = let (h, t) = splitAt n l in h ++ e : t
rv = getRandomR (Vapor, Vacuum)
+
rv = tr `liftM` getRandomR (0.0, 1.0)
  +
tr r = if r < d then Vapor else Vacuum
   
 
update, update' :: (MonadRandom m) => Region Content -> m (Region Content)
 
update, update' :: (MonadRandom m) => Region Content -> m (Region Content)
Line 90: Line 92:
 
unodd = unshift . map (unshift)
 
unodd = unshift . map (unshift)
   
process :: (MonadRandom m) => Region Content -> m [Region Content]
+
process :: (MonadRandomSplittable m) => Region Content -> m [Region Content]
 
process r = liftM (r:) $ step r
 
process r = liftM (r:) $ step r
 
where
 
where
 
stepper g f r
 
stepper g f r
| not (vaporous r) = return []
+
| not (vaporous r) = return [r]
| otherwise = do r' <- g r
+
| otherwise = (r:) `liftM` (g r >>= splitRandom . f)
rs <- f r'
 
return (r':rs)
 
 
step = stepper update step'
 
step = stepper update step'
 
step' = stepper update' step
 
step' = stepper update' step
   
main = do [n, m] <- fmap (map read) getArgs
+
output :: Integer -> PPM -> IO ()
if odd n || odd m
+
output n ppm = writeFile ("frost" ++ show n ++ ".ppm") (show ppm)
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 :: Region Content -> String
Line 106: Line 108:
   
 
ppmRegion :: Region Content -> PPM
 
ppmRegion :: Region Content -> PPM
ppmRegion r = PPM pix h w 255
+
ppmRegion r = PPM pix w h 255
 
where
 
where
 
pix = map (map f) r
 
pix = map (map f) r
Line 114: Line 116:
 
f Frost = white
 
f Frost = white
 
f Vapor = blue
 
f Vapor = blue
  +
  +
main = do (fs, nonOpts, msgs) <- getOpt Permute options `fmap` getArgs
  +
let (P n m d) = foldr ($) defaultParms fs
  +
if odd n || odd m
  +
then putStrLn "Dimensions must be even."
  +
else evalRandIO (randomRegion d n m >>= process)
  +
>>= zipWithM_ output [100..]
  +
. map ppmRegion
  +
  +
data Parms = P { width :: Int, height :: Int, percent :: Double }
  +
  +
defaultParms = P 200 200 0.5
  +
  +
options :: [OptDescr (Parms -> Parms)]
  +
options =
  +
[ Option "w" ["width"] (ReqArg w "WIDTH") "Width of the canvas."
  +
, Option "h" ["height"] (ReqArg h "HEIGHT") "Height of the canvas."
  +
, Option "p" ["percent"] (ReqArg p "PERCENT") "Percentage of vapor."
  +
]
  +
where
  +
w arg opt = opt { width = read arg }
  +
h arg opt = opt { height = read arg }
  +
p arg opt = opt { percent = read arg }
 
</haskell>
 
</haskell>
   
Line 141: Line 166:
 
data PPM = PPM {
 
data PPM = PPM {
 
pixels :: [[Color]],
 
pixels :: [[Color]],
height :: Int,
 
 
width :: Int,
 
width :: Int,
  +
height :: Int,
 
depth :: Int
 
depth :: Int
 
}
 
}
Line 151: Line 176:
 
instance Show PPM where
 
instance Show PPM where
 
show pg = "P3\n"
 
show pg = "P3\n"
++ show h ++ " " ++ show w ++ "\n"
+
++ show w ++ " " ++ show h ++ "\n"
 
++ show d ++ "\n"
 
++ show d ++ "\n"
 
++ (unlines . map unlines . map (map show) . pixels $ pg) ++ "\n"
 
++ (unlines . map unlines . map (map show) . pixels $ pg) ++ "\n"
Line 167: Line 192:
 
white = Color 255 255 255
 
white = Color 255 255 255
   
pixelate n m d (x0, x1) (y0, y1) i = PPM pixels m n d
+
pixelate n m d (x0, x1) (y0, y1) i = PPM pixels n m d
 
where
 
where
 
pixels = [ i (x, y) | x <- px, y <- py ]
 
pixels = [ i (x, y) | x <- px, y <- py ]

Latest revision as of 08:12, 13 December 2009


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

The default output of this program is a number of PPM images of each step in the process. They are called frostNNN.ppm, where NNN starts from 100.

This code makes use of the random monad and the splittable random monad.

module Main where
 
import Data.List
 
import Control.Arrow
import Control.Monad
import Control.Monad.Instances
 
import System
import System.Random
import System.Console.GetOpt
 
import MonadRandom
import PPImage hiding (width, height)
 
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 = foldr (zipWith (:)) (repeat [])
 
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) => Double -> Int -> Int -> m (Region Content)
randomRegion d 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 = tr `liftM` getRandomR (0.0, 1.0)
 tr r = if r < d then Vapor else 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 :: (MonadRandomSplittable m) => Region Content -> m [Region Content]
process r = liftM (r:) $ step r
 where
 stepper g f r
    | not (vaporous r) = return [r]
    | otherwise        = (r:) `liftM` (g r >>= splitRandom . f)
 step  = stepper update step'
 step' = stepper update' step
 
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 w h 255
 where
 pix = map (map f) r
 h   = length r
 w   = head . map length $ r
 f Vacuum = black
 f Frost  = white
 f Vapor  = blue
 
main = do (fs, nonOpts, msgs) <- getOpt Permute options `fmap` getArgs
          let (P n m d) = foldr ($) defaultParms fs
          if odd n || odd m
             then putStrLn "Dimensions must be even."
             else evalRandIO (randomRegion d n m >>= process)
                                   >>= zipWithM_ output [100..]
                                                    . map ppmRegion
 
data Parms = P { width :: Int, height :: Int, percent :: Double }
 
defaultParms = P 200 200 0.5
 
options :: [OptDescr (Parms -> Parms)]
options =
    [ Option "w" ["width"]  (ReqArg w "WIDTH")  "Width of the canvas."
    , Option "h" ["height"] (ReqArg h "HEIGHT") "Height of the canvas."
    , Option "p" ["percent"] (ReqArg p "PERCENT") "Percentage of vapor."
    ]
 where
 w arg opt = opt { width = read arg }
 h arg opt = opt { height = read arg }
 p arg opt = opt { percent = read arg }

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]],
                width :: Int,
                height :: 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 w ++ " " ++ show h ++ "\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 n m 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