# Haskell Quiz/SimFrost/Solution Dolio

### From HaskellWiki

m (solutions) |
m |
||

(6 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 hiding (width, height) |
||

data Content = Frost | Vapor | Vacuum deriving (Eq, Bounded, Enum) |
data Content = Frost | Vapor | Vacuum deriving (Eq, Bounded, Enum) |
||

Line 56: | 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 72: | 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 89: | 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_ putStrLn . map showRegion |
||

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 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 } |
||

+ | </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]], |
||

+ | 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 |
||

</haskell> |
</haskell> |

## 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