├── repa ├── Setup.hs ├── Paths_falling_turnip.hs ├── QC.hs ├── falling-turnip.cabal ├── Main.hs ├── Gravity.hs ├── Alchemy.hs └── Step.hs ├── tooltips ├── oil.png ├── erase.png ├── fire.png ├── lava.png ├── metal.png ├── plant.png ├── salt.png ├── sand.png ├── spout.png ├── stone.png ├── torch.png ├── turnip.png ├── wall.png └── water.png ├── .gitignore ├── Makefile ├── accelerate ├── Gravity.hs ├── Alchemy.hs ├── World.hs ├── Main.hs └── Step.hs ├── LICENSE ├── random └── Array.hs ├── common ├── Event.hs ├── Draw.hs └── World.hs └── README.md /repa/Setup.hs: -------------------------------------------------------------------------------- 1 | import Distribution.Simple 2 | main = defaultMain 3 | -------------------------------------------------------------------------------- /tooltips/oil.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/tranma/falling-sand-game/HEAD/tooltips/oil.png -------------------------------------------------------------------------------- /tooltips/erase.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/tranma/falling-sand-game/HEAD/tooltips/erase.png -------------------------------------------------------------------------------- /tooltips/fire.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/tranma/falling-sand-game/HEAD/tooltips/fire.png -------------------------------------------------------------------------------- /tooltips/lava.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/tranma/falling-sand-game/HEAD/tooltips/lava.png -------------------------------------------------------------------------------- /tooltips/metal.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/tranma/falling-sand-game/HEAD/tooltips/metal.png -------------------------------------------------------------------------------- /tooltips/plant.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/tranma/falling-sand-game/HEAD/tooltips/plant.png -------------------------------------------------------------------------------- /tooltips/salt.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/tranma/falling-sand-game/HEAD/tooltips/salt.png -------------------------------------------------------------------------------- /tooltips/sand.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/tranma/falling-sand-game/HEAD/tooltips/sand.png -------------------------------------------------------------------------------- /tooltips/spout.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/tranma/falling-sand-game/HEAD/tooltips/spout.png -------------------------------------------------------------------------------- /tooltips/stone.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/tranma/falling-sand-game/HEAD/tooltips/stone.png -------------------------------------------------------------------------------- /tooltips/torch.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/tranma/falling-sand-game/HEAD/tooltips/torch.png -------------------------------------------------------------------------------- /tooltips/turnip.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/tranma/falling-sand-game/HEAD/tooltips/turnip.png -------------------------------------------------------------------------------- /tooltips/wall.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/tranma/falling-sand-game/HEAD/tooltips/wall.png -------------------------------------------------------------------------------- /tooltips/water.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/tranma/falling-sand-game/HEAD/tooltips/water.png -------------------------------------------------------------------------------- /.gitignore: -------------------------------------------------------------------------------- 1 | dist 2 | cabal-dev 3 | *.o 4 | *.hi 5 | *.chi 6 | *.chs.h 7 | accelerate/Main 8 | repa/Main 9 | *.swp 10 | /Main 11 | 12 | .hs.swp -------------------------------------------------------------------------------- /repa/Paths_falling_turnip.hs: -------------------------------------------------------------------------------- 1 | module Repa.Paths_falling_turnip where 2 | 3 | getDataFileName :: String -> IO String 4 | getDataFileName x = return x 5 | -------------------------------------------------------------------------------- /repa/QC.hs: -------------------------------------------------------------------------------- 1 | module QC where 2 | 3 | import Test.QuickCheck 4 | 5 | import Step 6 | import World 7 | import Data.List 8 | import Control.Applicative 9 | 10 | 11 | elems = [nothing, steam_water] ++ [fire .. fire_end] ++ [oil, water, salt_water, sand, salt, stone, wall ] 12 | 13 | environments = combine <$> ( (,,,) <$> elements elems <*> elements elems <*> elements elems <*> elements elems ) 14 | 15 | conservation :: Property 16 | conservation 17 | = forAll environments $ \env -> sort [weigh (env, 0), weigh (env, 1), weigh (env, 2), weigh (env, 3)] == [0,1,2,3] -------------------------------------------------------------------------------- /Makefile: -------------------------------------------------------------------------------- 1 | PROGNAME=turnip 2 | 3 | GHC_OPTS := \ 4 | -threaded \ 5 | -O3 \ 6 | -Odph \ 7 | -rtsopts \ 8 | -fno-liberate-case \ 9 | -funfolding-use-threshold1000 \ 10 | -funfolding-keeness-factor1000 \ 11 | -fllvm \ 12 | -optlo-O3 \ 13 | -fsimpl-tick-factor=200 14 | 15 | GHC_WARNINGS := \ 16 | -Werror \ 17 | -fwarn-deprecations \ 18 | -fwarn-duplicate-exports \ 19 | -fwarn-hi-shadowing \ 20 | -fwarn-missing-fields \ 21 | -fwarn-overlapping-patterns \ 22 | -fwarn-type-defaults \ 23 | -fwarn-unused-binds \ 24 | -fwarn-unused-imports \ 25 | -fno-warn-missing-methods 26 | 27 | accelerate: accelerate/Main.hs 28 | ghc $(GHC_OPTS) $(GHC_WARNINGS) --make accelerate/Main.hs 29 | 30 | repa: repa/Main.hs 31 | ghc $(GHC_OPTS) $(GHC_WARNINGS) --make repa/Main.hs 32 | 33 | clean: 34 | rm -f accelerate/*.{hi,o} repa/*.{hi,o} accelerate/Main repa/Main 35 | .PHONY: repa accelerate clean 36 | -------------------------------------------------------------------------------- /accelerate/Gravity.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE QuasiQuotes, ViewPatterns #-} 2 | module Accelerate.Gravity 3 | (applyGravity) 4 | where 5 | 6 | import Data.Array.Accelerate as A 7 | import Prelude as P 8 | import Common.World 9 | import Repa.Gravity(applyGravity') 10 | 11 | -- Black magic for gravity 12 | -- Possible values: 13 | -- 14 | -- L liquid C0 15 | -- L liq, focus C1 16 | -- ~ liq, space 40 17 | -- ~ liqspace f 41 18 | -- 19 | -- * non-focused 80 20 | -- * focused 81 21 | -- ~ non-focused 00 22 | -- ~ focused 01 23 | -- 24 | 25 | {-# INLINE applyGravity #-} 26 | applyGravity :: Exp WeightEnv -> Exp MargPos -> Exp MargPos 27 | applyGravity x n = let (a,b,c,d) = A.unlift $ gravityArray A.!! (A.fromIntegral x) 28 | in (n ==* 0) ? (a , (n ==* 1) ? (b, (n ==* 2) ? (c,d))) 29 | 30 | gravityArray :: Acc (Array DIM1 (MargPos, MargPos, MargPos, MargPos)) 31 | gravityArray = A.use $ fromList (Z :. 255) $ P.map applyGravity' [0..255] 32 | 33 | -------------------------------------------------------------------------------- /accelerate/Alchemy.hs: -------------------------------------------------------------------------------- 1 | module Accelerate.Alchemy where 2 | 3 | import Prelude as P 4 | import Data.Array.Accelerate as A 5 | import Repa.Alchemy(applyAlchemy') 6 | import Accelerate.World 7 | 8 | mkExp2 9 | :: (Elt a, Elt v) 10 | => (Exp v, Exp v) -- input elements 11 | -> (Exp v -> Exp Bool, Exp v -> Exp Bool) -- predicates on input elements 12 | -> Exp a -> Exp a -> Exp a -- if then else expression 13 | mkExp2 (v1,v2) (p1,p2) = P.curry ((p1 v1 &&* p2 v2) ?) 14 | 15 | alchemyTable :: Acc (Array DIM2 (Int, (Element, Element), (Element, Element))) 16 | alchemyTable = use $ A.fromList (Z :. P.fromIntegral wall + 1 :. P.fromIntegral wall + 1) 17 | [ case applyAlchemy' x y 18 | of Left (a,b) -> (0,(a,b),(a,b)) 19 | Right x -> x 20 | | x <- [0..wall] 21 | , y <- [0..wall] 22 | ] 23 | 24 | 25 | 26 | applyAlchemy :: Exp Int -> Exp Element -> Exp Element -> Exp (Element, Element) 27 | applyAlchemy r x y = let (i, t, e) = unlift $ alchemyTable ! lift (Z :. A.fromIntegral x :. A.fromIntegral y) 28 | in (r <* i) ? (t , e) 29 | 30 | 31 | 32 | -------------------------------------------------------------------------------- /LICENSE: -------------------------------------------------------------------------------- 1 | Copyright (c) 2012, Tran Ma 2 | 3 | All rights reserved. 4 | 5 | Redistribution and use in source and binary forms, with or without 6 | modification, are permitted provided that the following conditions are met: 7 | 8 | * Redistributions of source code must retain the above copyright 9 | notice, this list of conditions and the following disclaimer. 10 | 11 | * Redistributions in binary form must reproduce the above 12 | copyright notice, this list of conditions and the following 13 | disclaimer in the documentation and/or other materials provided 14 | with the distribution. 15 | 16 | * Neither the name of Tran Ma nor the names of other 17 | contributors may be used to endorse or promote products derived 18 | from this software without specific prior written permission. 19 | 20 | THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS 21 | "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT 22 | LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR 23 | A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT 24 | OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, 25 | SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT 26 | LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, 27 | DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY 28 | THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT 29 | (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE 30 | OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. 31 | -------------------------------------------------------------------------------- /accelerate/World.hs: -------------------------------------------------------------------------------- 1 | module Accelerate.World 2 | ( isFluid, isWall, isFire 3 | , weight, age 4 | , res 5 | , module Common.World) 6 | where 7 | 8 | import Data.Array.Accelerate (Acc, Array, Exp, DIM1, Z(..), (:.)(..), (?), (>=*), (<=*), (<*), (&&*), (||*), (==*)) 9 | import qualified Data.Array.Accelerate as A 10 | 11 | import Common.World hiding (isFluid, isWall, isFire, weight, age) 12 | import qualified Common.World as C 13 | import Data.Word 14 | 15 | res = A.index2 (A.lift resY) (A.lift resX) 16 | 17 | -- Elements and properties ----------------------------------------------------- 18 | 19 | {-# INLINE isWall #-} 20 | isWall :: Exp Element -> Exp Bool 21 | isWall x = (x >=* 23 &&* x <=* 26) ||* x ==* 127 22 | 23 | {-# INLINE isFire #-} 24 | isFire :: Exp Element -> Exp Bool 25 | isFire x = x >=* A.lift fire &&* x <=* A.lift fire_end 26 | 27 | fluidArray :: Acc (Array DIM1 Word8) 28 | fluidArray = A.use $ A.fromList (Z:. fromIntegral wall + 1) $ map C.isFluid [0..wall] 29 | 30 | isFluid :: Exp Element -> Exp Weight 31 | isFluid x = fluidArray A.!! A.fromIntegral x 32 | 33 | 34 | weightArray :: Acc (Array DIM1 Weight) 35 | weightArray = A.use $ A.fromList (Z:. fromIntegral wall + 1) $ map C.weight [0..wall] 36 | 37 | {-# INLINE weight #-} 38 | weight :: Exp Element -> Exp Weight 39 | weight x = weightArray A.!! A.fromIntegral x 40 | 41 | 42 | ageArray :: Acc (Array DIM1 (Int, Element, Element)) 43 | ageArray = A.use $ A.fromList (Z :. fromIntegral wall + 1) $ map age' [0..wall] 44 | 45 | {-# INLINE age #-} 46 | age :: Exp Int -> Exp Element -> Exp Element 47 | age r x = let (i,t,e) = A.unlift $ ageArray A.!! A.fromIntegral x 48 | in (r <* i) ? (t,e) 49 | -------------------------------------------------------------------------------- /repa/falling-turnip.cabal: -------------------------------------------------------------------------------- 1 | -- Initial falling-turnip.cabal generated by cabal init. For further 2 | -- documentation, see http://haskell.org/cabal/users-guide/ 3 | 4 | name: falling-turnip 5 | version: 0.1.0.0 6 | synopsis: Falling sand game/cellular automata simulation using regular parallel arrays. 7 | description: 8 | Falling Turnip is an interactive particle simulation. Like others in the same genre (typically dubbed "falling sand games"), it has some degree of approximation for gravity, fluid flow and alchemical reactions. Unlike the others, it is based entirely on cellular automata and runs in parallel. 9 | . 10 | A short demo video is available here: 11 | . 12 | http://youtu.be/hlL9yi2hGx0 13 | . 14 | homepage: http://github.com/tranma/falling-turnip 15 | license: BSD3 16 | license-file: LICENSE 17 | author: Tran Ma 18 | maintainer: ma.ngoc.tran@gmail.com 19 | -- copyright: 20 | category: Game 21 | build-type: Simple 22 | cabal-version: >=1.8 23 | data-files: tooltips/*.png 24 | source-repository head 25 | type: git 26 | location: https://github.com/tranma/falling-turnip.git 27 | executable falling-turnip 28 | main-is: Main.hs 29 | other-modules: Alchemy, Draw, Gravity, Step, World 30 | build-depends: base >= 4.0 && < 5.0 31 | , repa >= 3.2 32 | , vector >= 0.9 33 | , gloss >= 1.7 34 | , gloss-raster >= 1.7 35 | , JuicyPixels-repa >= 0.6 36 | , random >= 1.0 37 | , binary-literal-qq >= 1.0 38 | , QuickCheck >= 2.4 39 | , repa-algorithms >= 3.2 40 | ghc-options: 41 | -threaded -O3 -Odph -rtsopts -fno-liberate-case -funfolding-use-threshold1000 -funfolding-keeness-factor1000 -fllvm -optlo-O3 -with-rtsopts=-N -with-rtsopts=-qa -with-rtsopts=-qg -fsimpl-tick-factor=200 42 | -------------------------------------------------------------------------------- /accelerate/Main.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE QuasiQuotes #-} 2 | 3 | import Data.Array.Repa (Z (..), (:.) (..)) -- , D, DIM2, Array) 4 | import qualified Data.Array.Repa as R 5 | import qualified Data.Array.Repa.Repr.Vector as R 6 | 7 | import Data.Array.Accelerate.IO 8 | import qualified Data.Array.Accelerate.CUDA as C 9 | 10 | import Graphics.Gloss 11 | import Graphics.Gloss.Raster.Array 12 | 13 | import System.Random 14 | 15 | import Common.Draw 16 | import Accelerate.World 17 | import Common.Event 18 | import Accelerate.Step 19 | 20 | main :: IO () 21 | main = do 22 | tooltips <- mapM loadTooltip tooltipFiles 23 | playArrayIO 24 | (InWindow "Falling Turnip" (winX * round factor, winY * round factor) (pos, pos)) 25 | (round factor, round factor) 26 | frameRate 27 | (World { array = computeAccS $ R.fromFunction (Z :. resY :. resX) bareWorld 28 | , currentElem = nothing 29 | , currGravityMask = margMaskEven 30 | , nextGravityMask = margMaskOdd 31 | , mouseDown = False 32 | , mousePos = (0,0) 33 | , mousePrevPos = (0,0) 34 | , tooltipLeft = blankTooltip 35 | , tooltipRight = blankTooltip 36 | }) 37 | ( return . render) 38 | ((return .) . handleInput) 39 | (stepWorld tooltips) 40 | where frameRate = 10 41 | pos = 300 42 | bareWorld = const nothing 43 | 44 | stepWorld :: [(Element, R.Array R.V R.DIM2 Color)] -> Float -> WorldA -> IO WorldA 45 | stepWorld tooltips time world 46 | = let curr = mousePos world 47 | world' = if outOfWorld curr 48 | then handleUI tooltips curr world 49 | else world { tooltipRight = blankTooltip } 50 | step' int acc = step int (currGravityMask world') acc 51 | in do int <- randomRIO (0,100) 52 | drawn <- if mouseDown world 53 | then drawLineA (mousePrevPos world') curr 54 | (currentElem world') (array world') 55 | else return $ array world' 56 | return $ world' { array = toRepa $ C.run1 (step' int) (fromRepa drawn) 57 | , currGravityMask = nextGravityMask world' 58 | , nextGravityMask = currGravityMask world' } 59 | 60 | -------------------------------------------------------------------------------- /repa/Main.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE QuasiQuotes, ScopedTypeVariables, TupleSections, FlexibleContexts #-} 2 | 3 | -- Repa 4 | import Data.Array.Repa (Z (..), (:.) (..)) 5 | import qualified Data.Array.Repa as R 6 | import qualified Data.Array.Repa.Repr.Vector as R 7 | 8 | -- Gloss 9 | import Graphics.Gloss 10 | import Graphics.Gloss.Raster.Array 11 | 12 | -- base 13 | import Control.Monad 14 | import System.Random 15 | 16 | -- friends 17 | import Repa.Step 18 | 19 | import Common.Draw 20 | import Common.World 21 | import Common.Event 22 | 23 | main :: IO () 24 | main = do 25 | tooltips <- mapM loadTooltip tooltipFiles 26 | playArrayIO 27 | (InWindow "Falling Turnip" (winX * round factor, winY * round factor) (pos, pos)) 28 | (round factor, round factor) 29 | frameRate 30 | (World { array = (R.computeS $ R.fromFunction (Z :. resY :. resX) bareWorld) :: R.Array R.U R.DIM2 Cell 31 | , currentElem = nothing 32 | , currGravityMask = margMaskEven 33 | , nextGravityMask = margMaskOdd 34 | , mouseDown = False 35 | , mousePos = (0,0) 36 | , mousePrevPos = (0,0) 37 | , tooltipLeft = blankTooltip 38 | , tooltipRight = blankTooltip 39 | }) 40 | ( return . render) 41 | ((return .) . handleInput) 42 | (stepWorld tooltips) 43 | where frameRate = 30 44 | pos = 300 45 | bareWorld = const nothing 46 | 47 | stepWorld :: [(Element, R.Array R.V R.DIM2 Color)] -> Float -> WorldR -> IO WorldR 48 | stepWorld tooltips time world 49 | = let curr = mousePos world 50 | world' = if outOfWorld curr then handleUI tooltips curr world else world { tooltipRight = blankTooltip } 51 | in do int <- randomRIO (0,100) 52 | stepped <- if mouseDown world 53 | then liftM (step int $ currGravityMask world') 54 | $ drawLineU (mousePrevPos world') curr 55 | (currentElem world') (array world') 56 | else return $ step int (currGravityMask world') 57 | $ array world' 58 | array' <- R.computeP stepped 59 | return $ world' { array = array' 60 | , currGravityMask = nextGravityMask world' 61 | , nextGravityMask = currGravityMask world' } 62 | 63 | -------------------------------------------------------------------------------- /repa/Gravity.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE QuasiQuotes, ViewPatterns #-} 2 | module Repa.Gravity 3 | (applyGravity 4 | ,applyGravity') 5 | where 6 | 7 | import Data.Bits 8 | import Common.World 9 | import Language.Literals.Binary 10 | 11 | -- Black magic for gravity 12 | -- Possible values: 13 | -- 14 | -- L liquid C0 15 | -- L liq, focus C1 16 | -- ~ liq, space 40 17 | -- ~ liqspace f 41 18 | -- 19 | -- * non-focused 80 20 | -- * focused 81 21 | -- ~ non-focused 00 22 | -- ~ focused 01 23 | -- 24 | 25 | applyGravity :: WeightEnv -> MargPos -> MargPos 26 | applyGravity x n = let (a,b,c,d) = applyGravity' x 27 | in case n of 0 -> a; 1 -> b; 2 -> c; 3 -> d 28 | 29 | {-# INLINE ignoreL #-} 30 | ignoreL :: MargPos -> WeightEnv -> WeightEnv 31 | ignoreL 0 x = x .&. [b|11 11 11 01|] 32 | ignoreL 1 x = x .&. [b|11 11 01 11|] 33 | ignoreL 2 x = x .&. [b|11 01 11 11|] 34 | ignoreL 3 x = x .&. [b|01 11 11 11|] 35 | 36 | {-# INLINE applyGravity' #-} 37 | applyGravity' :: WeightEnv -> (MargPos, MargPos, MargPos, MargPos) 38 | applyGravity' wenv = case wenv of 39 | -- L L --> L L 40 | -- L ~ ~ L 41 | (ignoreL 3 -> [b|00 11 11 11|]) -> (0,1,3,2) 42 | -- L L --> L L 43 | -- ~ L L ~ 44 | (ignoreL 2 -> [b|11 00 11 11|]) -> (0,1,3,2) 45 | -- L ~ --> ~ L 46 | -- * * * * 47 | (ignoreL 1 . ignoreL 2 . ignoreL 3 -> [b|01 01 00 11|]) -> (1,0,2,3) 48 | -- ~ L --> L ~ 49 | -- * * * * 50 | (ignoreL 0 . ignoreL 2 . ignoreL 3 -> [b|01 01 11 00|]) -> (1,0,2,3) 51 | -- ~ ~ --> ~ ~ 52 | -- L ~ ~ L 53 | (ignoreL 0 . ignoreL 1 . ignoreL 3 -> [b|00 11 00 00|]) -> (0,1,3,2) 54 | -- ~ ~ --> ~ ~ 55 | -- ~ L L ~ 56 | (ignoreL 0 . ignoreL 1 . ignoreL 2 -> [b|11 00 00 00|]) -> (0,1,3,2) 57 | 58 | _ -> case (wenv .&. [b|01010101|]) of 59 | -- * ~ --> ~ ~ 60 | -- ~ ~ * ~ 61 | [b|00 00 00 01|] -> (2,1,0,3) 62 | -- * * --> * ~ 63 | -- * ~ * * 64 | [b|00 01 01 01|] -> (0,3,2,1) 65 | -- * * --> ~ ~ 66 | -- ~ ~ * * 67 | [b|00 00 01 01|] -> (2,3,0,1) 68 | -- ~ * --> ~ ~ 69 | -- * ~ * * 70 | [b|00 01 01 00|] -> (0,3,2,1) 71 | -- ~ * --> ~ ~ 72 | -- ~ ~ ~ * 73 | [b|00 00 01 00|] -> (0,3,2,1) 74 | -- * * --> ~ * 75 | -- ~ * * * 76 | [b|01 00 01 01|] -> (2,1,0,3) 77 | -- * ~ --> ~ ~ 78 | -- ~ * * * 79 | [b|01 00 00 01|] -> (2,1,0,3) 80 | -- * ~ --> ~ ~ 81 | -- * ~ * * 82 | [b|00 01 00 01|] -> (3,1,2,0) 83 | -- ~ * --> ~ ~ 84 | -- ~ * * * 85 | [b|01 00 01 00|] -> (0,2,1,3) 86 | _ -> (0,1,2,3) 87 | 88 | -------------------------------------------------------------------------------- /random/Array.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE RankNTypes #-} 2 | {-# LANGUAGE TypeOperators #-} 3 | -- thank you Trevor https://github.com/AccelerateHS/accelerate-examples/blob/master/lib/Random/Array.hs 4 | module Random.Array ( 5 | 6 | (:~>), 7 | uniform, uniformR, 8 | randomArray, randomArrayWithSeed, randomArrayWithSystemRandom, 9 | 10 | ) where 11 | 12 | import Control.Monad.ST 13 | import System.Random.MWC hiding ( uniform, uniformR ) 14 | import qualified System.Random.MWC as R 15 | 16 | import Data.Array.Accelerate as A 17 | import Data.Array.Accelerate.Array.Data as A 18 | import Data.Array.Accelerate.Array.Sugar as Sugar 19 | 20 | 21 | -- | A PNRG from indices to variates 22 | -- 23 | type sh :~> e = forall s. sh -> GenST s -> ST s e 24 | 25 | 26 | -- | Uniformly distributed random variates. 27 | -- 28 | uniform :: (Shape sh, Elt e, Variate e) => sh :~> e 29 | uniform _ = R.uniform 30 | 31 | -- | Uniformly distributed random variates in a given range. 32 | -- 33 | uniformR :: (Shape sh, Elt e, Variate e) => (e, e) -> sh :~> e 34 | uniformR bounds _ = R.uniformR bounds 35 | 36 | 37 | -- | Generate an array of random values using the supplied generator function. 38 | -- The generator for variates is initialised with a fixed seed. 39 | -- 40 | randomArray :: (Shape sh, Elt e) => sh :~> e -> sh -> Array sh e 41 | randomArray f sh 42 | = let 43 | (adata, _) = runArrayData $ do 44 | gen <- create 45 | arr <- runRandomArray f sh gen 46 | return (arr, undefined) 47 | in 48 | adata `seq` Array (fromElt sh) adata 49 | 50 | 51 | -- | Generate an array of random values using a supplied generator function and 52 | -- seed value. 53 | -- 54 | randomArrayWithSeed :: (Shape sh, Elt e) => Seed -> sh :~> e -> sh -> Array sh e 55 | randomArrayWithSeed seed f sh 56 | = let 57 | (adata, _) = runArrayData $ do 58 | gen <- restore seed 59 | arr <- runRandomArray f sh gen 60 | return (arr, undefined) 61 | in 62 | adata `seq` Array (fromElt sh) adata 63 | 64 | 65 | -- | Generate an array of random values using a supplied generator function, 66 | -- initialised with the system's source of pseudo-random numbers. 67 | -- 68 | -- TODO: find a way to do this directly, without going via save/restore. 69 | -- 70 | randomArrayWithSystemRandom :: forall sh e. (Shape sh, Elt e) => sh :~> e -> sh -> IO (Array sh e) 71 | randomArrayWithSystemRandom f sh 72 | = do 73 | seed <- withSystemRandom (asGenIO save) 74 | return $! randomArrayWithSeed seed f sh 75 | 76 | 77 | -- Common function to create a mutable array and fill it with random values 78 | -- 79 | runRandomArray :: (Shape sh, Elt e) => sh :~> e -> sh -> GenST s -> ST s (MutableArrayData s (EltRepr e)) 80 | runRandomArray f sh gen 81 | = let 82 | n = Sugar.size sh 83 | in do 84 | arr <- newArrayData n 85 | let write ix = unsafeWriteArrayData arr (Sugar.toIndex sh ix) 86 | . fromElt =<< f ix gen 87 | 88 | iter sh write (>>) (return ()) 89 | return arr 90 | 91 | -------------------------------------------------------------------------------- /common/Event.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE TupleSections, FlexibleContexts #-} 2 | module Common.Event where 3 | 4 | -- Repa 5 | import Data.Array.Repa (Z (..), (:.) (..)) 6 | import qualified Data.Array.Repa as R 7 | import qualified Data.Array.Repa.Repr.Vector as R 8 | 9 | -- Gloss 10 | import Graphics.Gloss 11 | import Graphics.Gloss.Interface.Pure.Game 12 | 13 | -- JuicyPixels-repa 14 | import qualified Codec.Picture.Repa as J 15 | 16 | -- base 17 | import Control.Monad 18 | import Data.Maybe 19 | import Data.Word 20 | 21 | -- friends 22 | import Repa.Paths_falling_turnip 23 | 24 | import Common.World 25 | 26 | loadTooltip :: (Element, FilePath) -> IO (Element, R.Array R.V R.DIM2 Color) 27 | loadTooltip (e, p) = getDataFileName p >>= \p' -> liftM ((e,) . either (error) fromJuicy) $ J.readImageRGBA p' 28 | where toF :: Word8 -> Float 29 | toF x = fromIntegral x / 255 30 | fromJuicy :: J.Collapsable a (Word8, Word8, Word8, Word8) => J.Img a -> R.Array R.V R.DIM2 Color 31 | fromJuicy = (R.computeS . flip . R.map (\(a,b,c,d) -> makeColor (toF b) (toF c) (toF d) (toF a) ) . J.collapseColorChannel) 32 | flip = R.backpermute (Z :. 15 :. 160) (\(Z:. y :. x) -> Z :. (14 - y) :. x ) 33 | 34 | handleInput :: Event -> World r -> World r 35 | handleInput e w = handleInput' (w {mousePrevPos = mousePos w}) 36 | where handleInput' world = case e of 37 | EventKey (MouseButton LeftButton) Down _ (x,y) -> world { mouseDown = True, mousePos = (x/factor, y/factor - palletteH) } 38 | EventKey (MouseButton LeftButton) Up _ (x,y) -> world { mouseDown = False, mousePos = (x/factor, y/factor - palletteH) } 39 | EventKey (Char 'e') Down _ _ -> world { currentElem = steam_water } 40 | EventKey (Char 'f') Down _ _ -> world { currentElem = fire } 41 | EventKey (Char 'o') Down _ _ -> world { currentElem = oil } 42 | EventKey (Char 'w') Down _ _ -> world { currentElem = water } 43 | EventKey (Char 'l') Down _ _ -> world { currentElem = salt_water } 44 | EventKey (Char 's') Down _ _ -> world { currentElem = sand } 45 | EventKey (Char 'n') Down _ _ -> world { currentElem = salt } 46 | EventKey (Char 't') Down _ _ -> world { currentElem = stone } 47 | EventKey (Char 'r') Down _ _ -> world { currentElem = torch } 48 | EventKey (Char 'a') Down _ _ -> world { currentElem = wall } 49 | EventKey (Char 'p') Down _ _ -> world { currentElem = plant } 50 | EventKey (Char 'u') Down _ _ -> world { currentElem = spout } 51 | EventKey (Char 'm') Down _ _ -> world { currentElem = metal } 52 | EventMotion (x,y) -> world { mousePos = (x/factor, y/factor - palletteH) } 53 | _ -> world 54 | 55 | blankTooltip :: R.Array R.V R.DIM2 Color 56 | blankTooltip = R.computeS $ R.fromFunction (Z :. 15 :. 160) (const black) 57 | 58 | handleUI :: [(Element, R.Array R.V R.DIM2 Color)] -> GlossCoord -> World r -> World r 59 | handleUI t p w = let tooltip = fromMaybe blankTooltip $ flip lookup t $ elemOf p 60 | in if mouseDown w then 61 | w {currentElem = elemOf p, tooltipLeft = tooltip 62 | , tooltipRight = tooltip } 63 | else w { tooltipRight = tooltip } 64 | 65 | -------------------------------------------------------------------------------- /common/Draw.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE PatternGuards #-} 2 | module Common.Draw 3 | (drawLineU, drawLineA) 4 | where 5 | 6 | -- Repa 7 | import Data.Array.Repa (Z (..), (:.) (..), U, DIM2, Array) 8 | import qualified Data.Array.Repa as R 9 | 10 | -- Acc 11 | import Data.Array.Accelerate.IO 12 | 13 | -- base 14 | import Control.Monad 15 | import Control.Monad.ST 16 | import qualified Data.STRef 17 | import qualified Data.Vector.Unboxed as UV 18 | import qualified Data.Vector.Generic.Mutable as MV 19 | 20 | import Common.World 21 | 22 | 23 | -- | Draw a line onto the Repa array 24 | drawLineU :: GlossCoord -> GlossCoord -> Cell -> Array U DIM2 Cell -> IO (Array U DIM2 Cell) 25 | drawLineU (xa, ya) (xb, yb) new array 26 | | sh@(Z :. _ :. width) <- R.extent array 27 | , (x0, y0, x1, y1) <- ( round xa + resWidth, round ya + resHeight 28 | , round xb + resWidth, round yb + resHeight ) 29 | , x0 < resX - 2, x1 < resX - 2, y0 < resY - 2, y1 < resY - 2, x0 > 2, y0 > 2, x1 > 2, y1 > 2 30 | = do raw <- UV.unsafeThaw $ R.toUnboxed array 31 | stToIO $ bresenham raw (\(x,y)-> y * width + x) new (x0, y0) (x1, y1) 32 | raw' <- UV.unsafeFreeze raw 33 | return $ R.fromUnboxed sh raw' 34 | | otherwise = return array 35 | 36 | -- | Draw a line onto the Repa array backed by Accelerate 37 | drawLineA :: GlossCoord -> GlossCoord -> Cell -> Array A DIM2 Cell -> IO (Array A DIM2 Cell) 38 | drawLineA (xa, ya) (xb, yb) new array 39 | -- FIXME input check here as well, maybe faster 40 | = R.copyP array >>= drawLineU (xa, ya) (xb, yb) new >>= R.copyP 41 | 42 | -- Bresenham's line drawing, copypasted from 43 | -- http://rosettacode.org/wiki/Bitmap/Bresenham's_line_algorithm 44 | -- only destructively updating the array is fast enough 45 | bresenham vec ix val (xa, ya) (xb, yb) 46 | = do yV <- var y1 47 | errorV <- var $ deltax `div` 2 48 | forM_ [x1 .. x2] (\x -> do 49 | y <- get yV 50 | drawCirc $ if steep then (y, x) else (x, y) 51 | mutate errorV $ subtract deltay 52 | error <- get errorV 53 | when (error < 0) (do 54 | mutate yV (+ ystep) 55 | mutate errorV (+ deltax))) 56 | where steep = abs (yb - ya) > abs (xb - xa) 57 | (xa', ya', xb', yb') 58 | = if steep 59 | then (ya, xa, yb, xb) 60 | else (xa, ya, xb, yb) 61 | (x1, y1, x2, y2) 62 | = if xa' > xb' 63 | then (xb', yb', xa', ya') 64 | else (xa', ya', xb', yb') 65 | deltax = x2 - x1 66 | deltay = abs $ y2 - y1 67 | ystep = if y1 < y2 then 1 else -1 68 | var = Data.STRef.newSTRef 69 | get = Data.STRef.readSTRef 70 | mutate = Data.STRef.modifySTRef 71 | drawCirc (x,y) = do MV.write vec (ix (x,y)) val -- me 72 | MV.write vec (ix (x,y+1)) val -- top 73 | MV.write vec (ix (x+1,y+1)) val -- top right 74 | MV.write vec (ix (x+1,y)) val -- right 75 | MV.write vec (ix (x+1,y-1)) val -- down right 76 | MV.write vec (ix (x,y-1)) val -- down 77 | MV.write vec (ix (x-1,y-1)) val -- down left 78 | MV.write vec (ix (x-1,y)) val -- left 79 | MV.write vec (ix (x-1,y+1)) val -- top left 80 | MV.write vec (ix (x,y+2)) val -- top top 81 | MV.write vec (ix (x+2,y)) val -- right right 82 | MV.write vec (ix (x-2,y)) val -- left left 83 | MV.write vec (ix (x,y-2)) val -- down down 84 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | Falling Turnip is an interactive particle simulation. Like others in the same genre (typically dubbed "falling sand games"), it has some degree of approximation for gravity, fluid flow and alchemical reactions. Unlike the others, it is based entirely on cellular automata and runs in parallel. 2 | 3 | A short demo video is available [here](http://youtu.be/hlL9yi2hGx0). 4 | 5 | In our simulation, each pixel is a cellular automation and all physical reactions are phrased as cellular automata rules. This approach enables us to take advantage of the massively distributed/parallel nature of cellular automata, however expressing gravity and fluid behaviour as automata rules has proven challenging. 6 | 7 | Background 8 | ========== 9 | 10 | Block Automaton 11 | --------------- 12 | 13 | Physical phenomena in the game usually affect more than a single cell simultaneously, for example gravity might cause a cell to swap with the one below it. The rules for such effects are best expressed with a block cellular automaton, since they make it relatively simple to write simulation rules that respect conservation. 14 | 15 | We partition the 2D lattice into 2x2 blocks that shift along each axis on alternate timesteps - i.e. Margolus neighbourhoods. Each neighbourhood is then transformed based on a pre-computed set of rules that define gravitational and fluid behaviour in the system. The shifting nature of the Margolus neighbourhoods effectively allows more scenarios to be encoded in a much smaller set of rules. 16 | 17 | Stencil Convolution 18 | ------------------- 19 | 20 | Parallelism in our simulation is achieved with parallel arrays provided by Repa - a Haskell library for data parallelism. 21 | 22 | The 2D world is represented as a Repa array and transformations are done with stencil convolutions. A stencil provides a cursored focus into one cell in the array and the cells immediately adjacent to it, and thus can be easily made parallel (we are not concerned with how this is done under the hood). In `Step.hs`, `margStencil` defines how all cell values in the Margolus neighbourhood corresponding to the current focus are combined into a single value and placed in the focused cell. This value is used to compute the next state of the focus as affected by gravity, fluids, etc. 23 | 24 | Simulation 25 | ========== 26 | 27 | Gravity and Fluid Behaviour 28 | --------------------------- 29 | 30 | The core of the gravitational simulation is based on the block automata rules specified in [3], adapted to fall straight down rather then diagonally. In [3], however, the authors are only concerned with heavy particles and light particles, and the displacement of light particles by falling heavy particles. Our simulation, on the other hand, has many more than two discrete levels of weight --- for example, oil falls through air, but floats above water. In order to accommodate this complication, we apply the gravity rules multiple times: First, the heaviest particle in the Margolus neighbourhood is considered to be "heavy" while all other particles are considered "light". Then, the second-heaviest particle is also considered "heavy" and so on. 31 | 32 | As empty space is simply represented as another type of particle, objects that defy gravity (for example steam and fire) can be considered "lighter" than empty space, which causes the empty space to displace them, forcing them upward. 33 | 34 | These rules provide behaviour similar to falling grains of sand, however liquids must behave differently. Rather than form piles, liquids should expand to fill any containing vessel. We emulate this physical behaviour by adding additional rules that prevent liquid particles from forming piles. Combined with these rules, the ordinary gravity rules provide convincing fluid-like behaviour. 35 | 36 | Alchemical Interactions 37 | ----------------------- 38 | 39 | Compared to gravity and fluid flow, interaction among elements is straightforward. The alchemical rules are expressed as a binary relation with some probability of succeeding. This randomised behaviour adds some realism to the simulation in the absence of accurate heat and pressure models. 40 | 41 | Performance 42 | =========== 43 | 44 | The novelty of our simulation lies with the use of cellular automata --- a highly distributed/parallel structure to model physics. In this implementation we use data parallelism to take advantage of this property, however it is not difficult to translate the logic to fit in a distributed scenario. 45 | 46 | This project also serves as a testament to the effectiveness of data parallelism in general and the Repa library in particular. Adding more processing cores improves performance without any added effort on the part of the programmer. 47 | 48 | 49 | Notes 50 | ===== 51 | 52 | Assuming you have GHC and cabal installed (if not, get the Haskell platform [here](http://www.haskell.org/platform/)), to build `falling-turnip` simply go `cabal configure && cabal build`. Alternatively, use `make`: 53 | 54 | cabal update 55 | cabal install gloss gloss-raster repa-3.2 vector random JuicyPixels-repa 56 | make 57 | 58 | Use the following run-time options for optimal performance: 59 | 60 | +RTS -N -qa -qg 61 | 62 | For example: 63 | 64 | ./Main +RTS -N7 -qa -qg 65 | 66 | The name "Falling Turnip" comes from Repa, which stands for Regular Parallel Arrays, and also means "turnip" in Russian. 67 | 68 | Bibliography 69 | ============ 70 | [1] J. L. Schiff, Cellular Automata: A Discrete View of the World (Wiley Series in Discrete Mathematics and Optimization). 71 | 72 | [2] T. Toffoli and N. Margolus, Cellular automata machines: a new environment for modeling. Cambridge, MA, USA: MIT Press, 1987. 73 | 74 | [3] F. Gruau and J. T. Tromp, “Cellular gravity,” CWI (Centre for Mathematics and Computer Science), Amsterdam, The Netherlands, The Netherlands, 1999. 75 | 76 | [4] G. Keller, M. M. T. Chakravarty, R. Leshchinskiy, S. Peyton Jones, and B. Lippmeier, “Regular, shape-polymorphic, parallel arrays in Haskell,” presented at the Proceedings of the 15th ACM SIGPLAN international conference on Functional programming, New York, NY, USA, 2010, pp. 261–272. 77 | 78 | [5] B. Lippmeier and G. Keller, “Efficient parallel stencil convolution in Haskell,” presented at the Proceedings of the 4th ACM symposium on Haskell, New York, NY, USA, 2011, pp. 59–70. 79 | 80 | [6] B. Lippmeier, M. Chakravarty, G. Keller, and S. Peyton Jones, “Guiding parallel array fusion with indexed types,” presented at the Proceedings of the 2012 symposium on Haskell symposium, New York, NY, USA, 2012, pp. 25–36. 81 | 82 | -------------------------------------------------------------------------------- /repa/Alchemy.hs: -------------------------------------------------------------------------------- 1 | module Repa.Alchemy where 2 | 3 | import Common.World 4 | 5 | {-# INLINE applyAlchemy #-} 6 | applyAlchemy :: Int -> Element -> Element -> (Element, Element) 7 | -- water + salt = salt_water + nothing 8 | applyAlchemy _ 7 10 = (salt_water, nothing) 9 | applyAlchemy _ 10 7 = (nothing, salt_water) 10 | 11 | -- steam condenses: + steam = + condensed steam 12 | applyAlchemy _ w 1 | isWall w = (wall, steam_condensed) 13 | applyAlchemy _ 1 w | isWall w = (steam_condensed, wall) 14 | 15 | -- water evaporates: water/salt_water + = steam + nothing 16 | applyAlchemy _ 7 f | isFire f = (steam_water, nothing) 17 | applyAlchemy _ f 7 | isFire f = (nothing, steam_water) 18 | applyAlchemy _ f 8 | isFire f = (steam_water, salt) 19 | applyAlchemy _ 8 f | isFire f = (steam_water, salt) 20 | 21 | -- oil catches fire: oil + = 2 x new fire 22 | applyAlchemy _ 6 f | isFire f = (fire, fire) 23 | applyAlchemy _ f 6 | isFire f = (fire, fire) 24 | 25 | -- torch generates fire: torch + nothing = torch + fire 26 | applyAlchemy _ 0 23 = (fire, torch) 27 | applyAlchemy _ 23 0 = (torch, fire) 28 | 29 | -- spout generates water: spout + nothing = spout + water 30 | applyAlchemy _ 25 0 = (spout, water) 31 | applyAlchemy _ 0 25 = (water, spout) 32 | 33 | -- fire burns plant: + plant = new fire + sand 34 | applyAlchemy r f 24 | isFire f = if r < 20 then (sand, fire) else (fire, fire) 35 | applyAlchemy r 24 f | isFire f = if r < 20 then (fire, sand) else (fire, fire) 36 | 37 | -- water grows plant: water + plant = 2 x plant 38 | applyAlchemy _ 7 24 = (plant, plant) 39 | applyAlchemy _ 24 7 = (plant, plant) 40 | 41 | -- water eroses metal: water/salt_water + metal = water/salt_water + sand 42 | applyAlchemy r 26 7 = if r < 1 then (sand, water) else (metal, water) 43 | applyAlchemy r 7 26 = if r < 1 then (water, sand) else (water, metal) 44 | applyAlchemy r 26 8 = if r < 3 then (sand, salt_water) else (metal, salt_water) 45 | applyAlchemy r 8 26 = if r < 3 then (salt_water, sand) else (salt_water, metal) 46 | 47 | -- lava + stone = 2 x lava 48 | applyAlchemy r 27 11 = if r < 5 then (lava, lava) else (lava, stone) 49 | applyAlchemy r 11 27 = if r < 5 then (lava, lava) else (stone, lava) 50 | 51 | -- lava + metal/sand/salt = 2 x lava 52 | applyAlchemy r 27 26 = if r < 1 then (lava, lava) else (lava, metal) 53 | applyAlchemy r 26 27 = if r < 1 then (lava, lava) else (metal, lava) 54 | applyAlchemy r 27 9 = if r < 50 then (lava, lava) else (lava, sand) 55 | applyAlchemy r 9 27 = if r < 50 then (lava, lava) else (sand, lava) 56 | applyAlchemy r 27 10 = if r < 50 then (lava, lava) else (lava, salt) 57 | applyAlchemy r 10 27 = if r < 50 then (lava, lava) else (salt, lava) 58 | 59 | -- lava + oil/plant = lava + fire 60 | applyAlchemy r 27 6 = if r < 80 then (lava, fire) else (lava, oil) 61 | applyAlchemy r 6 27 = if r < 80 then (fire, lava) else (oil, lava) 62 | applyAlchemy r 27 24 = if r < 80 then (lava, fire) else (lava, plant) 63 | applyAlchemy r 24 27 = if r < 80 then (fire, lava) else (plant, lava) 64 | 65 | -- water + lava = steam + stone 66 | applyAlchemy _ 7 27 = (steam_water, stone) 67 | applyAlchemy _ 27 7 = (stone, steam_water) 68 | 69 | -- salt_water + lava = steam + stone OR steam + salt 70 | applyAlchemy r 8 27 = if r < 20 then (steam_water, salt) else (steam_water, stone) 71 | applyAlchemy r 27 8 = if r < 20 then (salt, steam_water) else (stone, steam_water) 72 | 73 | 74 | applyAlchemy _ a b = (a, b) 75 | 76 | 77 | applyAlchemy' :: Element -> Element -> Either (Element, Element) 78 | (Int, (Element, Element), (Element, Element)) 79 | -- water + salt = salt_water + nothing 80 | applyAlchemy' 7 10 = Left (salt_water, nothing) 81 | applyAlchemy' 10 7 = Left (nothing, salt_water) 82 | 83 | -- steam condenses: + steam = + condensed steam 84 | applyAlchemy' w 1 | isWall w = Left (wall, steam_condensed) 85 | applyAlchemy' 1 w | isWall w = Left (steam_condensed, wall) 86 | 87 | -- water evaporates: water/salt_water + = steam + nothing 88 | applyAlchemy' 7 f | isFire f = Left (steam_water, nothing) 89 | applyAlchemy' f 7 | isFire f = Left (nothing, steam_water) 90 | applyAlchemy' f 8 | isFire f = Left (steam_water, salt) 91 | applyAlchemy' 8 f | isFire f = Left (steam_water, salt) 92 | 93 | -- oil catches fire: oil + = 2 x new fire 94 | applyAlchemy' 6 f | isFire f = Left (fire, fire) 95 | applyAlchemy' f 6 | isFire f = Left (fire, fire) 96 | 97 | -- torch generates fire: torch + nothing = torch + fire 98 | applyAlchemy' 0 23 = Left (fire, torch) 99 | applyAlchemy' 23 0 = Left (torch, fire) 100 | 101 | -- spout generates water: spout + nothing = spout + water 102 | applyAlchemy' 25 0 = Left (spout, water) 103 | applyAlchemy' 0 25 = Left (water, spout) 104 | 105 | -- fire burns plant: + plant = new fire + sand 106 | applyAlchemy' f 24 | isFire f = Right (20 , (sand, fire) , (fire, fire)) 107 | applyAlchemy' 24 f | isFire f = Right (20 , (fire, sand) , (fire, fire)) 108 | 109 | -- water grows plant: water + plant = 2 x plant 110 | applyAlchemy' 7 24 = Left (plant, plant) 111 | applyAlchemy' 24 7 = Left (plant, plant) 112 | 113 | -- water eroses metal: water/salt_water + metal = water/salt_water + sand 114 | applyAlchemy' 26 7 = Right (1 , (sand, water) , (metal, water)) 115 | applyAlchemy' 7 26 = Right (1 , (water, sand) , (water, metal)) 116 | applyAlchemy' 26 8 = Right (3 , (sand, salt_water) , (metal, salt_water)) 117 | applyAlchemy' 8 26 = Right (3 , (salt_water, sand) , (salt_water, metal)) 118 | 119 | -- lava + stone = 2 x lava 120 | applyAlchemy' 27 11 = Right (5 , (lava, lava) , (lava, stone)) 121 | applyAlchemy' 11 27 = Right (5 , (lava, lava) , (stone, lava)) 122 | 123 | -- lava + metal/sand/salt = 2 x lava 124 | applyAlchemy' 27 26 = Right ( 1 , (lava, lava) , (lava, metal)) 125 | applyAlchemy' 26 27 = Right ( 1 , (lava, lava) , (metal, lava)) 126 | applyAlchemy' 27 9 = Right ( 50 , (lava, lava) , (lava, sand)) 127 | applyAlchemy' 9 27 = Right ( 50 , (lava, lava) , (sand, lava)) 128 | applyAlchemy' 27 10 = Right ( 50 , (lava, lava) , (lava, salt)) 129 | applyAlchemy' 10 27 = Right ( 50 , (lava, lava) , (salt, lava)) 130 | 131 | -- lava + oil/plant = lava + fire 132 | applyAlchemy' 27 6 = Right ( 80 , (lava, fire) , (lava, oil)) 133 | applyAlchemy' 6 27 = Right ( 80 , (fire, lava) , (oil, lava)) 134 | applyAlchemy' 27 24 = Right ( 80 , (lava, fire) , (lava, plant)) 135 | applyAlchemy' 24 27 = Right ( 80 , (fire, lava) , (plant, lava)) 136 | 137 | -- water + lava = steam + stone 138 | applyAlchemy' 7 27 = Left (steam_water, stone) 139 | applyAlchemy' 27 7 = Left (stone, steam_water) 140 | 141 | -- salt_water + lava = steam + stone OR steam + salt 142 | applyAlchemy' 8 27 = Right (20, (steam_water, salt) , (steam_water, stone)) 143 | applyAlchemy' 27 8 = Right (20, (salt, steam_water) , (stone, steam_water)) 144 | 145 | 146 | applyAlchemy' a b = Left (a, b) 147 | 148 | 149 | -------------------------------------------------------------------------------- /repa/Step.hs: -------------------------------------------------------------------------------- 1 | module Repa.Step 2 | ( step 3 | , margMaskEven, margMaskOdd, weigh, combine ) 4 | where 5 | 6 | -- Repa 7 | import Data.Array.Repa (Z (..), (:.) (..), U, D, DIM2, Array) 8 | import Data.Array.Repa.Stencil 9 | import qualified Data.Array.Repa as R 10 | import qualified Data.Array.Repa.Repr.Unboxed as R 11 | import qualified Data.Array.Repa.Stencil.Dim2 as R 12 | import Data.Array.Repa.Algorithms.Randomish as R 13 | 14 | -- base 15 | import Data.Bits 16 | 17 | 18 | -- friends 19 | import Common.World 20 | import Repa.Gravity 21 | import Repa.Alchemy 22 | 23 | {-# INLINE step #-} 24 | step :: Int -> Array U DIM2 MargPos -> Array U DIM2 Cell -> Array D DIM2 Cell 25 | step gen mask array 26 | = let randomish = R.randomishIntArray (Z :. resY :. resX) 0 100 gen 27 | envs = R.zipWith (\a (b,c) -> (alchemy a b, c)) randomish 28 | $ R.mapStencil2 (BoundFixed (nothing, 0)) margStencil 29 | $ R.zip array mask 30 | in R.zipWith age randomish 31 | $ R.zipWith mkCell envs 32 | $ R.map weigh envs 33 | where -- Swap cell at position 'p' in the margolus block 'env' with 34 | -- the cell at 'pos' in the same block 35 | mkCell (env,_) pos = margQuadrant pos env 36 | 37 | 38 | -- | Mask to extract cell at quadrant 'pos' 39 | {-# INLINE margQuadrant #-} 40 | margQuadrant :: MargPos -> Env -> Cell 41 | margQuadrant pos = flip shiftR (8 * pos) . (.&. shiftL 0xff (8 * pos)) 42 | 43 | 44 | -- | Break up the environment into its four components 45 | {-# INLINE split #-} 46 | split :: Env -> (Cell, Cell, Cell, Cell) 47 | split env 48 | = let ul = (env .&. eight1) 49 | ur = (flip shiftR 8 $ env .&. eight2) 50 | dl = (flip shiftR 16 $ env .&. eight3) 51 | dr = (flip shiftR 24 $ env .&. eight4) 52 | in (ul, ur, dl, dr) 53 | where -- Masks for extracting 8-bit slices 54 | eight1 = 0xff 55 | eight2 = shiftL eight1 8 56 | eight3 = shiftL eight2 8 57 | eight4 = shiftL eight3 8 58 | 59 | -- | Combine the lighter/heavier state of all 4 cells into an env 60 | -- 32bits: | DR | DL | UR | UL | 61 | {-# INLINE combine #-} 62 | combine :: (Cell, Cell, Cell, Cell) -> Env 63 | combine (ul, ur, dl, dr) 64 | = ul .|. (shiftL ur 8) .|. (shiftL dl 16) .|. (shiftL dr 24) 65 | 66 | {-# INLINE combine' #-} 67 | combine' :: (Weight, Weight, Weight, Weight) -> WeightEnv 68 | combine' (ul, ur, dl, dr) 69 | = ul .|. (shiftL ur 2) .|. (shiftL dl 4) .|. (shiftL dr 6) 70 | 71 | 72 | -- | Apply gravity to the cell at quadrant 'pos' in 'env' 73 | -- returning the quadrant it should swap with 74 | {-# INLINE weigh #-} 75 | weigh :: (Env, MargPos) -> MargPos 76 | weigh (env, pos) 77 | = let current = margQuadrant pos env 78 | (ul', ur', dl', dr') = split env 79 | 80 | -- The heaviest item in the environment 81 | heaviest = max (max (weight ul') (weight ur')) 82 | (max (weight dl') (weight dr')) 83 | 84 | 85 | -- Compare each cell with the heaviest, lowest bit set if >= 86 | ul, ur, dl, dr :: Weight 87 | ul = (if (weight ul' >= heaviest) then 1 else 0) .|. isFluid ul' 88 | ur = (if (weight ur' >= heaviest) then 1 else 0) .|. isFluid ur' 89 | dl = (if (weight dl' >= heaviest) then 1 else 0) .|. isFluid dl' 90 | dr = (if (weight dr' >= heaviest) then 1 else 0) .|. isFluid dr' 91 | weighed1 = combine' (ul, ur, dl, dr) 92 | 93 | -- Apply gravity with respect to the heaviest 94 | x' = applyGravity weighed1 pos -- .|. shiftL 1 (8 * pos)) 95 | 96 | x = if isWall (margQuadrant x' env) then pos else x' 97 | 98 | -- The second heaviest item 99 | remainingWeights 100 | = filter (/= heaviest) 101 | [weight ul', weight ur', weight dl', weight dr'] 102 | nextHeaviest = maximum $ remainingWeights 103 | 104 | -- Compare each cell with the second heaviest, lowest bit set if >= 105 | ul2, ur2, dl2, dr2 :: Weight 106 | ul2 = (if (weight ul' >= nextHeaviest) then 1 else 0) .|. isFluid ul' 107 | ur2 = (if (weight ur' >= nextHeaviest) then 1 else 0) .|. isFluid ur' 108 | dl2 = (if (weight dl' >= nextHeaviest) then 1 else 0) .|. isFluid dl' 109 | dr2 = (if (weight dr' >= nextHeaviest) then 1 else 0) .|. isFluid dr' 110 | weighed2 = combine' (ul2, ur2, dl2, dr2) 111 | 112 | -- Apply gravity with respect to the second heaviest 113 | y' = applyGravity weighed2 pos 114 | y = if isWall (margQuadrant y' env) then pos else y' 115 | 116 | -- Compose the two gravity passes 117 | ydest' = applyGravity (weighed1) y 118 | ydest = if isWall (margQuadrant ydest' env) then y else ydest' 119 | 120 | in if (ul' == ur' && ur' == dl' && dl' == dr') then pos 121 | else if (isWall current) then pos 122 | else if x /= pos || (length remainingWeights <= 1) then x 123 | else if ydest == y then y 124 | else x 125 | 126 | 127 | -- | Perform alchemy on a margolus block, with randomised probability of succeeding 128 | {-# INLINE alchemy #-} 129 | alchemy :: Int -> Env -> Env 130 | alchemy i env 131 | = let (ul0, ur0, dl0, dr0) = split env 132 | -- Apply interaction among the components 133 | (ul1, ur1) = applyAlchemy i ul0 ur0 134 | (ur , dr2) = applyAlchemy i ur1 dr0 135 | (dr , dl3) = applyAlchemy i dr2 dl0 136 | (dl , ul ) = applyAlchemy i dl3 ul1 137 | in if (ul0 == ur0 && ur0 == dl0 && dl0 == dr0) 138 | then env 139 | else combine (ul, ur, dl, dr) 140 | 141 | 142 | -- Margolus block -------------------------------------------------------------- 143 | 144 | -- | Position of cells in a block automaton 145 | -- 0 1 0 1 .... 146 | -- 2 3 2 3 .... 147 | -- ... 148 | {-# INLINE margMaskEven #-} 149 | margMaskEven :: Array U DIM2 MargPos 150 | margMaskEven 151 | = R.computeS $ R.fromFunction (Z:. resY :. resX) 152 | $ \(Z:. y :. x) -> x `mod` 2 .|. shiftL (y `mod` 2) 1 153 | 154 | {-# INLINE margMaskOdd #-} 155 | margMaskOdd :: Array U DIM2 MargPos 156 | margMaskOdd = R.computeS $ R.map (flip subtract 3) margMaskEven 157 | 158 | -- | Given a Moore neighbourhood (3x3), find the Margolus neighbourhood (2x2) 159 | -- and encode it as a number, combined with the Margolus position for each cell 160 | -- 161 | {-# INLINE margStencil #-} 162 | margStencil :: Stencil DIM2 (Env, MargPos) 163 | margStencil = StencilStatic (Z :. 3 :. 3) (0, -1) mkBlock 164 | where mkBlock :: DIM2 -> (Element, MargPos) -> (Env, MargPos) -> (Env, MargPos) 165 | mkBlock (Z :. 1 :. -1) (n,0) (acc, p) = (acc .|. n, p) 166 | mkBlock (Z :. 1 :. 0) (n,0) (acc, p) = (acc .|. n, p) 167 | mkBlock (Z :. 0 :. -1) (n,0) (acc, p) = (acc .|. n, p) 168 | mkBlock (Z :. 0 :. 0) (n,0) (acc, p) = (acc .|. n, 0) 169 | mkBlock (Z :. 1 :. 0) (n,1) (acc, p) = (acc .|. shiftL n 8, p) 170 | mkBlock (Z :. 1 :. 1) (n,1) (acc, p) = (acc .|. shiftL n 8, p) 171 | mkBlock (Z :. 0 :. 0) (n,1) (acc, p) = (acc .|. shiftL n 8, 1) 172 | mkBlock (Z :. 0 :. 1) (n,1) (acc, p) = (acc .|. shiftL n 8, p) 173 | mkBlock (Z :. 0 :. -1) (n,2) (acc, p) = (acc .|. shiftL n 16, p) 174 | mkBlock (Z :. 0 :. 0) (n,2) (acc, p) = (acc .|. shiftL n 16, 2) 175 | mkBlock (Z :. -1 :. -1) (n,2) (acc, p) = (acc .|. shiftL n 16, p) 176 | mkBlock (Z :. -1 :. 0) (n,2) (acc, p) = (acc .|. shiftL n 16, p) 177 | mkBlock (Z :. 0 :. 0) (n,3) (acc, p) = (acc .|. shiftL n 24, 3) 178 | mkBlock (Z :. 0 :. 1) (n,3) (acc, p) = (acc .|. shiftL n 24, p) 179 | mkBlock (Z :. -1 :. 0) (n,3) (acc, p) = (acc .|. shiftL n 24, p) 180 | mkBlock (Z :. -1 :. 1) (n,3) (acc, p) = (acc .|. shiftL n 24, p) 181 | mkBlock _ _ acc = acc 182 | -------------------------------------------------------------------------------- /accelerate/Step.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE ViewPatterns #-} 2 | module Accelerate.Step 3 | ( step 4 | , margMaskEven, margMaskOdd, weigh, combine ) 5 | where 6 | 7 | -- Acc 8 | import Data.Array.Accelerate (Acc, Exp, Z(..), (:.)(..), (?), (>=*), (&&*), (||*), (==*), (/=*)) 9 | import qualified Data.Array.Accelerate as A 10 | 11 | -- base 12 | import Data.Bits 13 | 14 | -- friends 15 | import Accelerate.World 16 | import Accelerate.Gravity 17 | import Accelerate.Alchemy 18 | --import Accelerate.World 19 | import Random.Array 20 | 21 | type Env4 = (Cell, Cell, Cell, Cell) 22 | 23 | step :: Int -> Acc (Matrix MargPos) -> Acc (Matrix Cell) -> Acc (Matrix Cell) 24 | step gen mask array 25 | = let randomish = A.use $ randomArray (uniformR (0, 100)) (Z:.resY:.resX) 26 | envs = A.zipWith (\a x -> A.lift (alchemy a $ A.fst x, A.snd x)) randomish 27 | $ A.stencil margStencil A.Clamp 28 | $ A.zip array mask 29 | in A.zipWith age randomish 30 | $ A.zipWith mkCell envs 31 | $ A.map weigh envs 32 | where -- Swap cell at position 'p' in the margolus block 'env' with 33 | -- the cell at 'pos' in the same block 34 | mkCell :: Exp (Env4, MargPos) -> Exp MargPos -> Exp Cell 35 | mkCell x pos = margQuadrant pos $ A.fst x 36 | 37 | 38 | -- | Mask to extract cell at quadrant 'pos' 39 | 40 | margQuadrant :: Exp MargPos -> Exp (Cell, Cell, Cell, Cell) -> Exp Cell 41 | margQuadrant p (A.unlift -> (x0,x1,x2,x3)) = (p ==* 0) ? (x0 42 | , (p ==* 1) ? (x1 43 | , (p ==* 2) ? (x2 44 | , x3))) 45 | 46 | 47 | -- | Break up the environment into its four components 48 | {- 49 | split :: Exp Env -> (Exp Cell, Exp Cell, Exp Cell, Exp Cell) 50 | split env 51 | = let ul = (env .&. eight1) 52 | ur = (flip A.shiftR 8 $ env .&. eight2) 53 | dl = (flip A.shiftR 16 $ env .&. eight3) 54 | dr = (flip A.shiftR 24 $ env .&. eight4) 55 | in (ul, ur, dl, dr) 56 | where -- Masks for extracting 8-bit slices 57 | eight1 = 0xff 58 | eight2 = A.shiftL eight1 8 59 | eight3 = A.shiftL eight2 8 60 | eight4 = A.shiftL eight3 8 61 | -} 62 | -- | Combine the lighter/heavier state of all 4 cells into an env 63 | -- 32bits: | DR | DL | UR | UL | 64 | 65 | combine :: (Exp Cell, Exp Cell, Exp Cell, Exp Cell) -> Exp Env 66 | combine (ul, ur, dl, dr) 67 | = ul .|. (A.shiftL ur 8) .|. (A.shiftL dl 16) .|. (A.shiftL dr 24) 68 | 69 | 70 | combine' :: (Exp Weight, Exp Weight, Exp Weight, Exp Weight) -> Exp WeightEnv 71 | combine' (ul, ur, dl, dr) 72 | = ul .|. (A.shiftL ur 2) .|. (A.shiftL dl 4) .|. (A.shiftL dr 6) 73 | 74 | 75 | -- | Apply gravity to the cell at quadrant 'pos' in 'env' 76 | -- returning the quadrant it should swap with 77 | 78 | weigh :: Exp (Env4, MargPos) -> Exp MargPos 79 | weigh (A.unlift -> (env, pos)) 80 | = let current = margQuadrant pos env 81 | (ul', ur', dl', dr') = A.unlift env 82 | 83 | -- The heaviest item in the environment 84 | heaviest = A.max (A.max (weight ul') (weight ur')) 85 | (A.max (weight dl') (weight dr')) 86 | 87 | 88 | -- Compare each cell with the heaviest, lowest bit set if >= 89 | ul, ur, dl, dr :: Exp Weight 90 | ul = ((weight ul' >=* heaviest) ? (1 , 0)) .|. isFluid ul' 91 | ur = ((weight ur' >=* heaviest) ? (1 , 0)) .|. isFluid ur' 92 | dl = ((weight dl' >=* heaviest) ? (1 , 0)) .|. isFluid dl' 93 | dr = ((weight dr' >=* heaviest) ? (1 , 0)) .|. isFluid dr' 94 | weighed1 = combine' (ul, ur, dl, dr) 95 | 96 | -- Apply gravity with respect to the heaviest 97 | x' = applyGravity weighed1 pos 98 | 99 | x = isWall (margQuadrant x' env) ? (pos, x') 100 | 101 | nextHeaviest4 :: (Exp Weight, Exp Weight, Exp Weight, Exp Weight) 102 | -> (Exp Weight, Exp Weight, Exp Weight) 103 | nextHeaviest4 (a,b,c,d) = A.unlift ((a ==* heaviest) ? (A.lift (b,c,d) 104 | , (b ==* heaviest) ? (A.lift (a,c,d) 105 | , (c ==* heaviest) ? (A.lift (a,b,d) 106 | , A.lift (a,b,c))))) 107 | next3 = nextHeaviest4 (weight ul',weight ur',weight dl',weight dr') 108 | maxOf3 (a,b,c) = A.max (A.max a b) c 109 | nextHeaviest' = maxOf3 next3 110 | 111 | nextHeaviest3 (a,b,c) = A.unlift ((a ==* nextHeaviest') ? (A.lift (b,c) 112 | , (b ==* nextHeaviest') ? (A.lift (a,c) 113 | , A.lift (a,b)))) 114 | 115 | nextHeaviest = (nextHeaviest' ==* heaviest) 116 | ? (uncurry (A.max) (nextHeaviest3 next3), nextHeaviest') 117 | 118 | -- Compare each cell with the second heaviest, lowest bit set if >= 119 | ul2, ur2, dl2, dr2 :: Exp Weight 120 | ul2 = ((weight ul' >=* nextHeaviest) ? ( 1 , 0)) .|. isFluid ul' 121 | ur2 = ((weight ur' >=* nextHeaviest) ? ( 1 , 0)) .|. isFluid ur' 122 | dl2 = ((weight dl' >=* nextHeaviest) ? ( 1 , 0)) .|. isFluid dl' 123 | dr2 = ((weight dr' >=* nextHeaviest) ? ( 1 , 0)) .|. isFluid dr' 124 | weighed2 = combine' (ul2, ur2, dl2, dr2) 125 | 126 | -- Apply gravity with respect to the second heaviest 127 | y' = applyGravity weighed2 pos 128 | y = isWall (margQuadrant y' env) ? (pos , y') 129 | 130 | -- Compose the two gravity passes 131 | ydest' = applyGravity (weighed1) y 132 | ydest = isWall (margQuadrant ydest' env) ? (y , ydest') 133 | 134 | in (ul' ==* ur' &&* ur' ==* dl' &&* dl' ==* dr') ? ( pos 135 | , (isWall current) ? ( pos 136 | , (x /=* pos ||* nextHeaviest ==* heaviest) ? ( x 137 | , (ydest ==* y ) ? ( y 138 | , x)))) 139 | 140 | -- | Perform alchemy on a margolus block, with randomised probability of succeeding 141 | 142 | alchemy :: Exp Int -> Exp Env4 -> Exp Env4 143 | alchemy i env 144 | = let (ul0, ur0, dl0, dr0) = A.unlift env 145 | -- Apply interaction among the components 146 | (ul1, ur1) = unlift' $ applyAlchemy i ul0 ur0 147 | (ur , dr2) = unlift' $ applyAlchemy i ur1 dr0 148 | (dr , dl3) = unlift' $ applyAlchemy i dr2 dl0 149 | (dl , ul ) = unlift' $ applyAlchemy i dl3 ul1 150 | in (ul0 ==* ur0 &&* ur0 ==* dl0 &&* dl0 ==* dr0) 151 | ? ( env 152 | , A.lift (ul, ur, dl, dr) 153 | ) 154 | where unlift' :: Exp (Cell, Cell) -> (Exp Cell, Exp Cell) 155 | unlift' = A.unlift 156 | 157 | -- Margolus block -------------------------------------------------------------- 158 | 159 | -- | Position of cells in a block automaton 160 | -- 0 1 0 1 .... 161 | -- 2 3 2 3 .... 162 | -- ... 163 | 164 | margMaskEven :: Acc (Matrix MargPos) 165 | margMaskEven 166 | = A.generate res 167 | $ \ix -> let (Z:.y:.x) = A.unlift ix in x `mod` 2 .|. shiftL (y `mod` 2) 1 168 | 169 | 170 | margMaskOdd :: Acc (Matrix MargPos) 171 | margMaskOdd 172 | = A.map (flip subtract 3) margMaskEven 173 | 174 | -- | Given a Moore neighbourhood (3x3), find the Margolus neighbourhood (2x2) 175 | -- and encode it as a number, combined with the Margolus position for each cell 176 | -- 177 | 178 | margStencil :: A.Stencil3x3 (Cell, MargPos) -> Exp ((Cell, Cell, Cell, Cell), MargPos) 179 | margStencil ((y0x0,y0x1,y0x2) 180 | ,(y1x0,y1x1,y1x2) 181 | ,(y2x0,y2x1,y2x2)) 182 | = A.lift $ flip (,) (A.snd y1x1) $ 183 | ( (A.snd y1x1 A.==* 0) A.? (A.lift (A.fst y1x1, A.fst y1x2, A.fst y2x1, A.fst y2x2) 184 | , (A.snd y1x1 A.==* 1) A.? (A.lift (A.fst y1x0, A.fst y1x1, A.fst y2x0, A.fst y2x1) 185 | , (A.snd y1x1 A.==* 2) A.? (A.lift (A.fst y0x1, A.fst y0x2, A.fst y1x1, A.fst y1x2) 186 | , (A.lift (A.fst y0x0, A.fst y0x1, A.fst y1x0, A.fst y1x1)))))) 187 | 188 | 189 | 190 | -------------------------------------------------------------------------------- /common/World.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE TypeFamilies, ViewPatterns, PatternGuards, FlexibleContexts #-} 2 | module Common.World 3 | ( Matrix 4 | , Element (..), Cell (..) 5 | , Env (..) 6 | , Weight (..), WeightEnv (..) 7 | 8 | , elems 9 | , nothing, turnip, steam_water, steam_condensed, fire, fire_end, oil 10 | , water, salt_water, sand, salt, stone, torch, plant, spout, metal, wall, lava 11 | 12 | , isFluid, isWall, isFire 13 | , weight, age, age' 14 | 15 | , MargPos (..) 16 | , GlossCoord (..), World (..), WorldA, WorldR 17 | , resX, resY, winX, winY, resWidth, resHeight, palletteH 18 | , factor 19 | , render, outOfWorld, elemOf, tooltipFiles ) 20 | where 21 | 22 | import Graphics.Gloss 23 | import Data.Word 24 | import Data.Array.Repa (Z (..), (:.) (..), D, U, DIM2) 25 | import Data.Array.Repa.Repr.Vector 26 | import qualified Data.Array.Repa.Eval as R 27 | import qualified Data.Array.Repa as R 28 | 29 | import Data.Array.Accelerate.IO 30 | import Data.Array.Accelerate (Acc) 31 | import qualified Data.Array.Accelerate as A 32 | 33 | 34 | import Data.List 35 | 36 | 37 | -- Basic constructs ------------------------------------------------------------ 38 | 39 | type Matrix x = A.Array A.DIM2 x 40 | 41 | type Element = Word32 42 | type Cell = Word32 43 | type Env = Word32 44 | type Weight = Word8 45 | type WeightEnv = Word8 46 | 47 | -- | Positions in a Margolus neighbourhood 48 | type MargPos = Int 49 | 50 | -- | Coordinates in a Gloss window, origin at center 51 | type GlossCoord = (Float, Float) 52 | 53 | -- | Gravity mask 54 | type family GravMask arr 55 | type instance GravMask A = Acc (Matrix MargPos) 56 | type instance GravMask U = Array U DIM2 MargPos 57 | 58 | data World r = World { array :: Array r DIM2 Cell 59 | , currentElem :: Element 60 | , mouseDown :: Bool 61 | , mousePos :: GlossCoord 62 | , mousePrevPos :: GlossCoord 63 | , currGravityMask :: GravMask r 64 | , nextGravityMask :: GravMask r 65 | , tooltipLeft :: Array V DIM2 Color 66 | , tooltipRight :: Array V DIM2 Color } 67 | 68 | type WorldA = World A 69 | type WorldR = World U 70 | 71 | -- Elements and properties ----------------------------------------------------- 72 | 73 | {-# INLINE nothing #-} 74 | -- Must match on direct values for efficiency 75 | nothing = 0 76 | steam_water = 1 77 | steam_condensed = 2 78 | oil = 6 79 | water = 7 80 | salt_water = 8 81 | sand = 9 82 | salt = 10 83 | stone = 11 84 | fire = 12 85 | fire_end = 22 86 | torch = 23 87 | plant = 24 88 | spout = 25 89 | metal = 26 90 | lava = 27 91 | turnip = 28 92 | wall = 29 93 | 94 | {-# INLINE elems #-} 95 | elems :: [Element] 96 | elems = [ nothing 97 | , steam_water 98 | , steam_condensed 99 | , oil 100 | , water 101 | , salt_water 102 | , sand 103 | , salt 104 | , stone 105 | , fire 106 | , fire_end 107 | , torch 108 | , plant 109 | , spout 110 | , metal 111 | , lava 112 | , turnip ] 113 | 114 | {-# INLINE isWall #-} 115 | isWall :: Element -> Bool 116 | isWall 23 = True -- torch 117 | isWall 24 = True -- plant 118 | isWall 25 = True -- spout 119 | isWall 26 = True -- metal 120 | isWall 29 = True -- wall 121 | isWall _ = False 122 | 123 | {-# INLINE isFire #-} 124 | isFire :: Element -> Bool 125 | isFire x = x >= fire && x <= fire_end 126 | 127 | {-# INLINE isFluid #-} 128 | isFluid :: Element -> Weight 129 | isFluid 0 = 0 -- nothing 130 | isFluid 1 = 2 131 | isFluid 2 = 2 132 | isFluid 6 = 2 -- oil 133 | isFluid 7 = 2 -- water 134 | isFluid 8 = 2 -- salt water 135 | isFluid 27 = 2 -- lav 136 | isFluid _ = 0 137 | 138 | {-# INLINE weight #-} 139 | weight :: Element -> Weight 140 | weight 0 = 2 -- nothing 141 | weight 1 = 0 -- steam water 142 | weight 2 = 0 -- steam water 143 | weight 9 = fromIntegral $ salt -- sand == salt 144 | weight 27 = fromIntegral $ water -- lava == water 145 | weight x | isFire x = 0 146 | | otherwise = fromIntegral x 147 | 148 | {-# INLINE age #-} 149 | age :: Int -> Element -> Element 150 | age r x 151 | -- fire eventually goes out 152 | | x == fire_end = nothing 153 | | isFire x = if r < 50 then x + 1 else x 154 | -- steam eventually condenses 155 | | x == steam_water = if r < 1 then water else steam_water 156 | | x == steam_condensed = if r < 5 then water else steam_condensed 157 | -- turnip being turnip 158 | | x == turnip = elems !! ((r * length elems) `div` 110) 159 | | otherwise = x 160 | 161 | {-# INLINE age' #-} 162 | age' :: Element -> (Int, Element, Element) 163 | age' x 164 | -- fire eventually goes out 165 | | x == fire_end = (0, nothing, nothing) 166 | | isFire x = (50, x + 1, x) 167 | -- steam eventually condenses 168 | | x == steam_water = (1, water, steam_water) 169 | | x == steam_condensed = (5, water, steam_condensed) 170 | -- turnip being turnip 171 | | x == turnip = (50, water, fire) -- FIXME 172 | | otherwise = (0,x,x) 173 | 174 | -- Drawing --------------------------------------------------------------------- 175 | {-# INLINE render #-} 176 | render :: R.Source r Cell => World r -> Array D DIM2 Color 177 | render world 178 | = R.transpose $ (R.transpose $ tooltipLeft world R.++ R.map (dim . dim) (tooltipRight world)) 179 | R.++ (R.transpose buttons) 180 | R.++ (R.transpose $ R.map colour $ array world) 181 | 182 | 183 | {-# INLINE brown #-} 184 | brown :: Color 185 | brown = makeColor (129/255) (49/255) (29/255) 1 186 | 187 | {-# INLINE colour #-} 188 | colour :: Element -> Color 189 | colour 0 = black -- nothing 190 | colour 1 = bright $ light $ light $ light blue -- steam 191 | colour 2 = bright $ light $ light $ light blue -- steam condensed 192 | colour 6 = brown -- oil 193 | colour 7 = bright $ bright $ light blue -- water 194 | colour 8 = bright $ bright $ light $ light blue -- salt water 195 | colour 9 = dim yellow -- sand 196 | colour 10 = greyN 0.95 -- salt 197 | colour 11 = greyN 0.7 -- stone 198 | colour 23 = bright $ orange -- torch 199 | colour 24 = dim $ green -- plant 200 | colour 25 = blue -- spout 201 | colour 26 = mixColors (0.2) (0.8) blue (greyN 0.5) -- metal 202 | colour 27 = bright red -- lava 203 | colour 28 = violet -- turnip 204 | colour 29 = greyN 0.4 -- wall 205 | colour x -- fire 206 | | isFire x = mixColors (1.0 * fromIntegral (x - fire)) 207 | (1.0 * fromIntegral (fire_end - x)) 208 | red yellow 209 | | otherwise = error "render: element doesn't exist" 210 | 211 | 212 | {-# INLINE buttons #-} 213 | buttons :: Array V DIM2 Color 214 | buttons = R.fromList (Z :. buttonH + paddingH :. resX) 215 | $ hPadding ++ hPadding2 216 | ++ (concat $ map oneLine [1..buttonH]) 217 | ++ hPadding2 ++ hPadding 218 | where -- background 219 | bgUI = black 220 | -- gap between buttons 221 | gap = replicate gapSize bgUI 222 | -- gap from left and right edges of the window 223 | side = replicate sideSize bgUI 224 | -- gap from top and bottom of the palette 225 | hPadding = replicate resX white 226 | hPadding2 = replicate resX bgUI 227 | -- one button 228 | oneBox e = oneBox' $ colour e 229 | oneBox' c = replicate buttonW c 230 | -- one line = fire + rest of elements 231 | oneLine x 232 | = let col = mixColors (fromIntegral x / fromIntegral buttonH) 233 | (1.0 - fromIntegral x / fromIntegral buttonH) 234 | red yellow 235 | in side ++ (concat $ intersperse gap $ oneBox' col : map oneBox selectableElems) ++ side 236 | 237 | 238 | {-# INLINE selectableElems #-} 239 | selectableElems :: [Element] 240 | selectableElems 241 | = [ torch, water, spout, plant, stone, metal, lava, oil, salt, sand, nothing, wall, turnip ] 242 | 243 | {-# INLINE elemOf #-} 244 | elemOf :: GlossCoord -> Element 245 | elemOf ((subtract 5) . (+ resWidth) . round -> x, _) 246 | | x < buttonW = fire 247 | | x < gapSize + 2 * buttonW = torch 248 | | x < 2 * gapSize + 3 * buttonW = water 249 | | x < 3 * gapSize + 4 * buttonW = spout 250 | | x < 4 * gapSize + 5 * buttonW = plant 251 | | x < 5 * gapSize + 6 * buttonW = stone 252 | | x < 6 * gapSize + 7 * buttonW = metal 253 | | x < 7 * gapSize + 8 * buttonW = lava 254 | | x < 8 * gapSize + 9 * buttonW = oil 255 | | x < 9 * gapSize + 10 * buttonW = salt 256 | | x < 10 * gapSize + 11 * buttonW = sand 257 | | x < 11 * gapSize + 12 * buttonW = nothing 258 | | x < 12 * gapSize + 13 * buttonW = wall 259 | | otherwise = turnip 260 | 261 | 262 | {-# INLINE resX #-} 263 | {-# INLINE resY #-} 264 | {-# INLINE resWidth #-} 265 | {-# INLINE resHeight #-} 266 | {-# INLINE paddingH #-} 267 | {-# INLINE tooltipH #-} 268 | {-# INLINE gapSize #-} 269 | {-# INLINE sideSize #-} 270 | {-# INLINE buttonW #-} 271 | {-# INLINE buttonH #-} 272 | resX, resY, resWidth, resHeight, paddingH, tooltipH, gapSize, sideSize, buttonW, buttonH :: Int 273 | -- size of the world 274 | resX = 320 275 | resY = 240 276 | -- size of window = size of world + size of palette + size of tooltip area 277 | winX = resX 278 | winY = resY + buttonH + paddingH + tooltipH 279 | -- gloss origin is at center, while repa origin is bottom left, so shifting needed 280 | resWidth = resX `div` 2 281 | resHeight = resY `div` 2 282 | -- 2 (top & bottom) * number of hPadding's 283 | paddingH = 4 284 | -- size of buttons, tooltips and gaps 285 | tooltipH = 15 286 | gapSize = 2 287 | sideSize 288 | = let n = 1 + length selectableElems 289 | in (resX - n * buttonW - (n - 1) * gapSize) `div` 2 290 | buttonW 291 | = let n = 1 + length selectableElems 292 | in (resX - (n-1)*gapSize) `div` n 293 | buttonH = 15 294 | 295 | {-# INLINE factor #-} 296 | {-# INLINE palletteH #-} 297 | factor, palletteH :: Float 298 | factor = 2 299 | palletteH = (fromIntegral buttonH + fromIntegral paddingH + fromIntegral tooltipH)/2 300 | 301 | {-# INLINE outOfWorld #-} 302 | outOfWorld :: GlossCoord -> Bool 303 | outOfWorld (_, y) = round y + resHeight < 0 304 | 305 | {-# INLINE tooltipFiles #-} 306 | tooltipFiles =[(fire , "tooltips/fire.png"), 307 | (wall , "tooltips/wall.png"), 308 | (nothing , "tooltips/erase.png"), 309 | (oil , "tooltips/oil.png"), 310 | (water , "tooltips/water.png"), 311 | (sand , "tooltips/sand.png"), 312 | (salt , "tooltips/salt.png"), 313 | (stone , "tooltips/stone.png"), 314 | (torch , "tooltips/torch.png"), 315 | (plant , "tooltips/plant.png"), 316 | (spout , "tooltips/spout.png"), 317 | (metal , "tooltips/metal.png"), 318 | (lava , "tooltips/lava.png"), 319 | (turnip , "tooltips/turnip.png")] 320 | --------------------------------------------------------------------------------