Модуль трехмерного клеточного автомата, который симулирует огонь а-ля демо 90-х годов.

Принцип очень простой, мы берем исходное состояние клеточного автомата (в каждой клетке целое число 0-255) и применяем к нему ассиметричный фильтр. Фильтр вытянут книзу и симметричен по отношению к вертикальной оси, значит, обработанное им изображение будет стремиться вверх.

Небольшое количество случайных клеток в основании огня придадут ему дополнительное очарование.

-- |Cell.hs
-- Cellular automata to simulate fire.
--
-- It will be more efficient for cells to scatter itself to neighbours.
-- But I cannot think a good way to implement it.

module Cell where

import Control.Monad
import Data.Bits
import Data.List
import qualified Data.Map as Map
import qualified Data.Set as Set
import System.Random

cellFireMax = 255

type Coord = (Int,Int,Int)

cellBaseCoord :: Coord
cellBaseCoord = (0,0,0)

data Cell = Cell (Map.Map Coord Int)
	deriving Show

fireCellBase :: Cell -> IO Cell
fireCellBase (Cell cells) = do
	rndG <- newStdGen
	let rs = randomRs (-3,3) rndG
	return $ Cell $ Map.unions [cells,constantBase,randomBase Map.empty 5 rs]
	where
		constantBase = Map.singleton cellBaseCoord cellFireMax
		randomBase rBase 0 _ = rBase
		randomBase rBase n (x:y:z:rs) =
			randomBase (Map.insert (x*3,y*3,z*3) cellFireMax rBase) (n-1) rs

startCell :: IO Cell
startCell = do
	fireCellBase (Cell Map.empty)

updateCell :: Cell -> IO Cell
updateCell (Cell cells) = do
	fireCellBase $ Cell updatedMap
	where
		-- 2D fire uses the following filter:
		--     111  for point p and neighbours  lpr
		--	1                                d
		-- The sum of weights for 2D fire is 4, which is 2**2,
		-- which is handy.
		--
		-- 3D fire will have to deal with two additional
		-- points, front and back. So we cannot have the luxury
		-- of 2**N for identical unit weights. We will use
		-- weights that add up to 256.

		updatedMap :: Map.Map Coord Int
		updatedMap = Map.fromList $
			filter ((> 0) . snd) $
			map (\c -> (c,calcWeight c)) neighbours
		neighbours :: [Coord]
		neighbours = Set.toList $ Set.unions $
			map scatter $ Map.keys cells
		scatter (x,y,z) = Set.fromList
			[(x',y',z')
			| x' <- [x-1..x+1]
			, y' <- [y-1..y+1]
			, z' <- [z-1..z+1]]

		-- z is up, y is away from us, x is to the right.
		calcWeight :: Coord -> Int
		calcWeight point@(x,y,z) = (flip shiftR) 8 $
			cw w1 point + cw w1 down +
			cw w0 front + cw w0 left +
			cw w0 right + cw w0 back
			where
				w0,w1 :: Int
				w0 = 42
				w1 = 44
				front = (x,y-1,z)
				left  = (x-1,y,z)
				back  = (x,y+1,z)
				right = (x+1,y,z)
				down  = (x,y,z-1)
				cw w p = w * Map.findWithDefault 0 p cells

test n = do
	c <- startCell
	c'@(Cell cells) <- foldM (\c _ -> updateCell c) c [1..n]
	print $ Map.size cells