Haskell Quiz/SimFrost/Solution Dolio

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)
                                   >>= mapM_ output . zip [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 }

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