module Step
( step
, margMaskEven, margMaskOdd, weigh, combine )
where
-- Repa
import Data.Array.Repa (Z (..), (:.) (..), U, D, DIM2, Array)
import Data.Array.Repa.Stencil
import qualified Data.Array.Repa as R
import qualified Data.Array.Repa.Repr.Unboxed as R
import qualified Data.Array.Repa.Stencil.Dim2 as R
import Data.Array.Repa.Algorithms.Randomish as R
-- base
import Data.Bits
-- friends
import World
import Gravity
import Alchemy
{-# INLINE step #-}
step :: Int -> Array U DIM2 MargPos -> Array U DIM2 Cell -> Array D DIM2 Cell
step gen mask array
= let randomish = R.randomishIntArray (Z :. resY :. resX) 0 100 gen
envs = R.zipWith (\a (b,c) -> (alchemy a b, c)) randomish
$ R.mapStencil2 (BoundFixed (nothing, 0)) margStencil
$ R.zip array mask
in R.zipWith age randomish
$ R.zipWith mkCell envs
$ R.map weigh envs
where -- Swap cell at position 'p' in the margolus block 'env' with
-- the cell at 'pos' in the same block
mkCell (env,_) pos = margQuadrant pos env
-- | Mask to extract cell at quadrant 'pos'
{-# INLINE margQuadrant #-}
margQuadrant :: MargPos -> Env -> Cell
margQuadrant pos = flip shiftR (8 * pos) . (.&. shiftL 0xff (8 * pos))
-- | Break up the environment into its four components
{-# INLINE split #-}
split :: Env -> (Cell, Cell, Cell, Cell)
split env
= let ul = (env .&. eight1)
ur = (flip shiftR 8 $ env .&. eight2)
dl = (flip shiftR 16 $ env .&. eight3)
dr = (flip shiftR 24 $ env .&. eight4)
in (ul, ur, dl, dr)
where -- Masks for extracting 8-bit slices
eight1 = 0xff
eight2 = shiftL eight1 8
eight3 = shiftL eight2 8
eight4 = shiftL eight3 8
-- | Combine the lighter/heavier state of all 4 cells into an env
-- 32bits: | DR | DL | UR | UL |
{-# INLINE combine #-}
combine :: (Cell, Cell, Cell, Cell) -> Env
combine (ul, ur, dl, dr)
= ul .|. (shiftL ur 8) .|. (shiftL dl 16) .|. (shiftL dr 24)
-- | Apply gravity to the cell at quadrant 'pos' in 'env'
-- returning the quadrant it should swap with
{-# INLINE weigh #-}
weigh :: (Env, MargPos) -> MargPos
weigh (env, pos)
= let current = margQuadrant pos env
(ul', ur', dl', dr') = split env
-- The heaviest item in the environment
heaviest = max (max (weight ul') (weight ur'))
(max (weight dl') (weight dr'))
-- Compare each cell with the heaviest, lowest bit set if >=
ul, ur, dl, dr :: Weight
ul = (0x80 .&. (heaviest - 1 - weight ul')) .|. isFluid ul'
ur = (0x80 .&. (heaviest - 1 - weight ur')) .|. isFluid ur'
dl = (0x80 .&. (heaviest - 1 - weight dl')) .|. isFluid dl'
dr = (0x80 .&. (heaviest - 1 - weight dr')) .|. isFluid dr'
weighed1 = combine (ul, ur, dl, dr)
-- Apply gravity with respect to the heaviest
x' = applyGravity (weighed1 .|. shiftL 1 (8 * pos))
x = if isWall (margQuadrant x' env) then pos else x'
-- The second heaviest item
remainingWeights
= filter (/= heaviest)
[weight ul', weight ur', weight dl', weight dr']
nextHeaviest = maximum $ remainingWeights
-- Compare each cell with the second heaviest, lowest bit set if >=
ul2, ur2, dl2, dr2 :: Weight
ul2 = (0x80 .&. (nextHeaviest - 1 - weight ul')) .|. isFluid ul'
ur2 = (0x80 .&. (nextHeaviest - 1 - weight ur')) .|. isFluid ur'
dl2 = (0x80 .&. (nextHeaviest - 1 - weight dl')) .|. isFluid dl'
dr2 = (0x80 .&. (nextHeaviest - 1 - weight dr')) .|. isFluid dr'
weighed2 = combine (ul2, ur2, dl2, dr2)
-- Apply gravity with respect to the second heaviest
y' = applyGravity (weighed2 .|. shiftL 1 (8 * pos))
y = if isWall (margQuadrant y' env) then pos else y'
-- Compose the two gravity passes
ydest' = applyGravity (weighed1 .|. shiftL 1 (8 * y))
ydest = if isWall (margQuadrant ydest' env) then y else ydest'
in if (ul' == ur' && ur' == dl' && dl' == dr') then pos
else if (isWall current) then pos
else if x /= pos || (length remainingWeights <= 1) then x
else if ydest == y then y
else x
-- | Perform alchemy on a margolus block, with randomised probability of succeeding
{-# INLINE alchemy #-}
alchemy :: Int -> Env -> Env
alchemy i env
= let (ul0, ur0, dl0, dr0) = split env
-- Apply interaction among the components
(ul1, ur1) = applyAlchemy i ul0 ur0
(ur , dr2) = applyAlchemy i ur1 dr0
(dr , dl3) = applyAlchemy i dr2 dl0
(dl , ul ) = applyAlchemy i dl3 ul1
in if (ul0 == ur0 && ur0 == dl0 && dl0 == dr0)
then env
else combine (ul, ur, dl, dr)
-- Margolus block --------------------------------------------------------------
-- | Position of cells in a block automaton
-- 0 1 0 1 ....
-- 2 3 2 3 ....
-- ...
{-# INLINE margMaskEven #-}
margMaskEven :: Array U DIM2 MargPos
margMaskEven
= R.computeS $ R.fromFunction (Z:. resY :. resX)
$ \(Z:. y :. x) -> x `mod` 2 .|. shiftL (y `mod` 2) 1
{-# INLINE margMaskOdd #-}
margMaskOdd :: Array U DIM2 MargPos
margMaskOdd = R.computeS $ R.map (flip subtract 3) margMaskEven
-- | Given a Moore neighbourhood (3x3), find the Margolus neighbourhood (2x2)
-- and encode it as a number, combined with the Margolus position for each cell
--
{-# INLINE margStencil #-}
margStencil :: Stencil DIM2 (Env, MargPos)
margStencil = StencilStatic (Z :. 3 :. 3) (0, -1) mkBlock
where mkBlock :: DIM2 -> (Element, MargPos) -> (Env, MargPos) -> (Env, MargPos)
mkBlock (Z :. 1 :. -1) (n,0) (acc, p) = (acc .|. n, p)
mkBlock (Z :. 1 :. 0) (n,0) (acc, p) = (acc .|. n, p)
mkBlock (Z :. 0 :. -1) (n,0) (acc, p) = (acc .|. n, p)
mkBlock (Z :. 0 :. 0) (n,0) (acc, p) = (acc .|. n, 0)
mkBlock (Z :. 1 :. 0) (n,1) (acc, p) = (acc .|. shiftL n 8, p)
mkBlock (Z :. 1 :. 1) (n,1) (acc, p) = (acc .|. shiftL n 8, p)
mkBlock (Z :. 0 :. 0) (n,1) (acc, p) = (acc .|. shiftL n 8, 1)
mkBlock (Z :. 0 :. 1) (n,1) (acc, p) = (acc .|. shiftL n 8, p)
mkBlock (Z :. 0 :. -1) (n,2) (acc, p) = (acc .|. shiftL n 16, p)
mkBlock (Z :. 0 :. 0) (n,2) (acc, p) = (acc .|. shiftL n 16, 2)
mkBlock (Z :. -1 :. -1) (n,2) (acc, p) = (acc .|. shiftL n 16, p)
mkBlock (Z :. -1 :. 0) (n,2) (acc, p) = (acc .|. shiftL n 16, p)
mkBlock (Z :. 0 :. 0) (n,3) (acc, p) = (acc .|. shiftL n 24, 3)
mkBlock (Z :. 0 :. 1) (n,3) (acc, p) = (acc .|. shiftL n 24, p)
mkBlock (Z :. -1 :. 0) (n,3) (acc, p) = (acc .|. shiftL n 24, p)
mkBlock (Z :. -1 :. 1) (n,3) (acc, p) = (acc .|. shiftL n 24, p)
mkBlock _ _ acc = acc