falling-turnip (empty) → 0.1.0.0
raw patch · 23 files changed
+948/−0 lines, 23 filesdep +JuicyPixels-repadep +QuickCheckdep +basesetup-changedbinary-added
Dependencies added: JuicyPixels-repa, QuickCheck, base, gloss, gloss-raster, random, repa, repa-algorithms, vector
Files
- Alchemy.hs +73/−0
- Draw.hs +74/−0
- Gravity.hs +159/−0
- LICENSE +30/−0
- Main.hs +105/−0
- Setup.hs +2/−0
- Step.hs +174/−0
- World.hs +291/−0
- falling-turnip.cabal +40/−0
- tooltips/erase.png binary
- tooltips/fire.png binary
- tooltips/lava.png binary
- tooltips/metal.png binary
- tooltips/oil.png binary
- tooltips/plant.png binary
- tooltips/salt.png binary
- tooltips/sand.png binary
- tooltips/spout.png binary
- tooltips/stone.png binary
- tooltips/torch.png binary
- tooltips/turnip.png binary
- tooltips/wall.png binary
- tooltips/water.png binary
+ Alchemy.hs view
@@ -0,0 +1,73 @@+module Alchemy where++import World++applyAlchemy :: Int -> Element -> Element -> (Element, Element)+-- water + salt = salt_water + nothing+applyAlchemy _ 7 10 = (salt_water, nothing)+applyAlchemy _ 10 7 = (nothing, salt_water)++-- steam condenses: <some wall> + steam = <wall> + condensed steam+applyAlchemy _ w 1 | isWall w = (wall, steam_condensed)+applyAlchemy _ 1 w | isWall w = (steam_condensed, wall)++-- water evaporates: water/salt_water + <some fire> = steam + nothing+applyAlchemy _ 7 f | isFire f = (steam_water, nothing)+applyAlchemy _ f 7 | isFire f = (nothing, steam_water) +applyAlchemy _ f 8 | isFire f = (steam_water, salt)+applyAlchemy _ 8 f | isFire f = (steam_water, salt)++-- oil catches fire: oil + <some fire> = 2 x new fire+applyAlchemy _ 6 f | isFire f = (fire, fire)+applyAlchemy _ f 6 | isFire f = (fire, fire)++-- torch generates fire: torch + nothing = torch + fire+applyAlchemy _ 0 23 = (fire, torch)+applyAlchemy _ 23 0 = (torch, fire)++-- spout generates water: spout + nothing = spout + water+applyAlchemy _ 25 0 = (spout, water)+applyAlchemy _ 0 25 = (water, spout)++-- fire burns plant: <some fire> + plant = new fire + sand+applyAlchemy r f 24 | isFire f = if r < 20 then (sand, fire) else (fire, fire)+applyAlchemy r 24 f | isFire f = if r < 20 then (fire, sand) else (fire, fire)++-- water grows plant: water + plant = 2 x plant+applyAlchemy _ 7 24 = (plant, plant)+applyAlchemy _ 24 7 = (plant, plant)++-- water eroses metal: water/salt_water + metal = water/salt_water + sand+applyAlchemy r 26 7 = if r < 1 then (sand, water) else (metal, water)+applyAlchemy r 7 26 = if r < 1 then (water, sand) else (water, metal)+applyAlchemy r 26 8 = if r < 3 then (sand, salt_water) else (metal, salt_water)+applyAlchemy r 8 26 = if r < 3 then (salt_water, sand) else (salt_water, metal)++-- lava + stone = 2 x lava+applyAlchemy r 27 11 = if r < 5 then (lava, lava) else (lava, stone)+applyAlchemy r 11 27 = if r < 5 then (lava, lava) else (stone, lava)++-- lava + metal/sand/salt = 2 x lava+applyAlchemy r 27 26 = if r < 1 then (lava, lava) else (lava, metal)+applyAlchemy r 26 27 = if r < 1 then (lava, lava) else (metal, lava)+applyAlchemy r 27 9 = if r < 50 then (lava, lava) else (lava, sand)+applyAlchemy r 9 27 = if r < 50 then (lava, lava) else (sand, lava)+applyAlchemy r 27 10 = if r < 50 then (lava, lava) else (lava, salt)+applyAlchemy r 10 27 = if r < 50 then (lava, lava) else (salt, lava)++-- lava + oil/plant = lava + fire+applyAlchemy r 27 6 = if r < 80 then (lava, fire) else (lava, oil)+applyAlchemy r 6 27 = if r < 80 then (fire, lava) else (oil, lava)+applyAlchemy r 27 24 = if r < 80 then (lava, fire) else (lava, plant)+applyAlchemy r 24 27 = if r < 80 then (fire, lava) else (plant, lava)++-- water + lava = steam + stone+applyAlchemy _ 7 27 = (steam_water, stone)+applyAlchemy _ 27 7 = (stone, steam_water)++-- salt_water + lava = steam + stone OR steam + salt+applyAlchemy r 8 27 = if r < 20 then (steam_water, salt) else (steam_water, stone)+applyAlchemy r 27 8 = if r < 20 then (salt, steam_water) else (stone, steam_water)+++applyAlchemy _ a b = (a, b)
+ Draw.hs view
@@ -0,0 +1,74 @@+{-# LANGUAGE PatternGuards #-}+module Draw+ (drawLine)+where++-- Repa+import Data.Array.Repa (Z (..), (:.) (..), U, DIM2, Array)+import qualified Data.Array.Repa as R++-- base+import Control.Monad+import Control.Monad.ST+import qualified Data.STRef+import qualified Data.Vector.Unboxed as UV+import qualified Data.Vector.Generic.Mutable as MV++import World+++-- | Draw a line onto the Repa array+drawLine :: GlossCoord -> GlossCoord -> Cell -> Array U DIM2 Cell -> IO (Array U DIM2 Cell)+drawLine (xa, ya) (xb, yb) new array+ | sh@(Z :. _ :. width) <- R.extent array + , (x0, y0, x1, y1) <- ( round xa + resWidth, round ya + resHeight+ , round xb + resWidth, round yb + resHeight )+ , x0 < resX - 2, x1 < resX - 2, y0 < resY - 2, y1 < resY - 2, x0 > 2, y0 > 2, x1 > 2, y1 > 2+ = do raw <- UV.unsafeThaw $ R.toUnboxed array+ stToIO $ bresenham raw (\(x,y)-> y * width + x) new (x0, y0) (x1, y1)+ raw' <- UV.unsafeFreeze raw+ return $ R.fromUnboxed sh raw'+ | otherwise = return array++-- Bresenham's line drawing, copypasted from+-- http://rosettacode.org/wiki/Bitmap/Bresenham's_line_algorithm+-- only destructively updating the array is fast enough+bresenham vec ix val (xa, ya) (xb, yb)+ = do yV <- var y1+ errorV <- var $ deltax `div` 2+ forM_ [x1 .. x2] (\x -> do+ y <- get yV+ drawCirc $ if steep then (y, x) else (x, y)+ mutate errorV $ subtract deltay+ error <- get errorV+ when (error < 0) (do+ mutate yV (+ ystep)+ mutate errorV (+ deltax)))+ where steep = abs (yb - ya) > abs (xb - xa)+ (xa', ya', xb', yb') + = if steep + then (ya, xa, yb, xb)+ else (xa, ya, xb, yb)+ (x1, y1, x2, y2)+ = if xa' > xb' + then (xb', yb', xa', ya')+ else (xa', ya', xb', yb')+ deltax = x2 - x1+ deltay = abs $ y2 - y1+ ystep = if y1 < y2 then 1 else -1+ var = Data.STRef.newSTRef+ get = Data.STRef.readSTRef+ mutate = Data.STRef.modifySTRef+ drawCirc (x,y) = do MV.write vec (ix (x,y)) val -- me+ MV.write vec (ix (x,y+1)) val -- top+ MV.write vec (ix (x+1,y+1)) val -- top right+ MV.write vec (ix (x+1,y)) val -- right+ MV.write vec (ix (x+1,y-1)) val -- down right+ MV.write vec (ix (x,y-1)) val -- down+ MV.write vec (ix (x-1,y-1)) val -- down left+ MV.write vec (ix (x-1,y)) val -- left+ MV.write vec (ix (x-1,y+1)) val -- top left+ MV.write vec (ix (x,y+2)) val -- top top+ MV.write vec (ix (x+2,y)) val -- right right+ MV.write vec (ix (x-2,y)) val -- left left+ MV.write vec (ix (x,y-2)) val -- down down
+ Gravity.hs view
@@ -0,0 +1,159 @@+module Gravity + (applyGravity)+where++import Data.Bits+import World++-- Black magic for gravity+-- Possible values:+-- +-- L liquid C0+-- L liq, focus C1+-- ~ liq, space 40+-- ~ liqspace f 41+--+-- * non-focused 80+-- * focused 81+-- ~ non-focused 00+-- ~ focused 01+applyGravity :: WeightEnv -> MargPos+applyGravity wenv = case wenv of + -- L L --> L L+ -- L ~ ~ L+ 0x01C0C0C0 -> 2+ 0x00C1C0C0 -> 3+ 0x41C0C0C0 -> 2+ 0x40C1C0C0 -> 3+ 0x40C0C1C0 -> 1+ 0x00C0C1C0 -> 1+ 0x40C0C0C1 -> 0+ 0x00C0C0C1 -> 0 + -- L L --> L L+ -- ~ L L ~+ 0xC001C0C0 -> 3+ 0xC100C0C0 -> 2+ 0xC041C0C0 -> 3+ 0xC140C0C0 -> 2+ 0xC040C1C0 -> 1+ 0xC000C1C0 -> 1+ 0xC040C0C1 -> 0+ 0xC000C0C1 -> 0 + -- L ~ --> ~ L+ -- * * * *+ 0x808000C1 -> 1+ 0x808001C0 -> 0+ 0x808040C1 -> 1+ 0x808041C0 -> 0+ 0x80C000C1 -> 1+ 0x80C001C0 -> 0+ 0x80C040C1 -> 1+ 0x80C041C0 -> 0+ 0xC08000C1 -> 1+ 0xC08001C0 -> 0+ 0xC08040C1 -> 1+ 0xC08041C0 -> 0+ 0xC0C000C1 -> 1+ 0xC0C001C0 -> 0+ 0xC0C040C1 -> 1+ 0xC0C041C0 -> 0 + -- ~ L --> L ~+ -- * * * *+ 0x8080C100 -> 0+ 0x8080C001 -> 1+ 0x8080C140 -> 0+ 0x8080C041 -> 1+ 0x80C0C100 -> 0+ 0x80C0C001 -> 1+ 0x80C0C140 -> 0+ 0x80C0C041 -> 1+ 0xC080C100 -> 0+ 0xC080C001 -> 1+ 0xC080C140 -> 0+ 0xC080C041 -> 1+ 0xC0C0C100 -> 0+ 0xC0C0C001 -> 1+ 0xC0C0C140 -> 0+ 0xC0C0C041 -> 1 + -- ~ ~ --> ~ ~+ -- L ~ ~ L+ 0x00C10000 -> 3+ 0x01C00000 -> 2+ 0x40C10000 -> 3+ 0x41C00000 -> 2 + 0x00C14000 -> 3+ 0x01C04000 -> 2 + 0x40C14000 -> 3+ 0x41C04000 -> 2+ 0x00C10040 -> 3+ 0x01C00040 -> 2+ 0x40C10040 -> 3+ 0x41C00040 -> 2+ 0x00C14040 -> 3+ 0x01C04040 -> 2+ 0x40C14040 -> 3+ 0x41C04040 -> 2+ -- ~ ~ --> ~ ~+ -- ~ L L ~+ 0xC1000000 -> 2+ 0xC0010000 -> 3+ 0xC1400000 -> 2+ 0xC0410000 -> 3+ 0xC1004000 -> 2+ 0xC0014000 -> 3+ 0xC1404000 -> 2+ 0xC0414000 -> 3+ 0xC1000040 -> 2+ 0xC0010040 -> 3+ 0xC1400040 -> 2+ 0xC0410040 -> 3+ 0xC1004040 -> 2+ 0xC0014040 -> 3+ 0xC1404040 -> 2+ 0xC0414040 -> 3 + _ -> case (wenv .&. 0x81818181) of+ -- * ~ --> ~ ~+ -- ~ ~ * ~+ 0x00000081 -> 2+ 0x00010080 -> 0+ -- * * --> * ~+ -- * ~ * *+ 0x00808180 -> 3+ 0x01808080 -> 1+ -- * * --> ~ ~+ -- ~ ~ * *+ 0x00008081 -> 2+ 0x00008180 -> 3+ 0x00018080 -> 0+ 0x01008080 -> 1+ -- ~ * --> ~ ~+ -- * ~ * *+ 0x00808100 -> 3+ 0x01808000 -> 1+ -- ~ * --> ~ ~+ -- ~ ~ ~ *+ 0x00008100 -> 3+ 0x01008000 -> 1+ -- * * --> ~ *+ -- ~ * * *+ 0x80008081 -> 2+ 0x80018080 -> 0+ -- * ~ --> ~ ~+ -- ~ * * *+ 0x80000081 -> 2+ 0x80010080 -> 0+ -- * ~ --> ~ ~+ -- * ~ * *+ 0x00800081 -> 3+ 0x01800080 -> 0+ -- ~ * --> ~ ~+ -- ~ * * *+ 0x80008100 -> 2+ 0x80018000 -> 1++ x -> case x .&. 0x01010101 of+ 0x01000000 -> 3+ 0x00010000 -> 2+ 0x00000100 -> 1+ 0x00000001 -> 0+
+ LICENSE view
@@ -0,0 +1,30 @@+Copyright (c) 2012, Tran Ma++All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions are met:++ * Redistributions of source code must retain the above copyright+ notice, this list of conditions and the following disclaimer.++ * Redistributions in binary form must reproduce the above+ copyright notice, this list of conditions and the following+ disclaimer in the documentation and/or other materials provided+ with the distribution.++ * Neither the name of Tran Ma nor the names of other+ contributors may be used to endorse or promote products derived+ from this software without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR+A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT+OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT+LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,+DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY+THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+ Main.hs view
@@ -0,0 +1,105 @@+{-# LANGUAGE QuasiQuotes, ScopedTypeVariables, TupleSections, FlexibleContexts #-}++-- Repa+import Data.Array.Repa (Z (..), (:.) (..))+import qualified Data.Array.Repa as R+import qualified Data.Array.Repa.Repr.Vector as R+-- Gloss+import Graphics.Gloss +import Graphics.Gloss.Raster.Array +import Graphics.Gloss.Interface.Pure.Game ++-- JuicyPixels-repa+import qualified Codec.Picture.Repa as J++-- base+import Control.Monad+import System.Random+import Data.Maybe++-- friends+import World+import Step+import Draw+import Paths_falling_turnip+import Data.Word++main :: IO () +main = do + tooltips <- mapM loadTooltip tooltipFiles+ playArrayIO+ (InWindow "Falling Turnip" (winX * round factor, winY * round factor) (pos, pos))+ (round factor, round factor)+ frameRate+ (World { array = R.computeS $ R.fromFunction (Z :. resY :. resX) bareWorld+ , currentElem = nothing+ , currGravityMask = margMaskEven+ , nextGravityMask = margMaskOdd+ , mouseDown = False+ , mousePos = (0,0) + , mousePrevPos = (0,0) + , tooltipLeft = blankTooltip + , tooltipRight = blankTooltip + }) + ( return . render)+ ((return .) . handleInput)+ (stepWorld tooltips)+ where frameRate = 30+ pos = 300+ bareWorld = const nothing++loadTooltip :: (Element, FilePath) -> IO (Element, R.Array R.V R.DIM2 Color)+loadTooltip (e, p) = getDataFileName p >>= \p' -> liftM ((e,) . either (error) fromJuicy) $ J.readImageRGBA p'+ where toF :: Word8 -> Float+ toF x = fromIntegral x / 255+ fromJuicy :: J.Collapsable a (Word8, Word8, Word8, Word8) => J.Img a -> R.Array R.V R.DIM2 Color+ fromJuicy = (R.computeS . flip . R.map (\(a,b,c,d) -> makeColor (toF b) (toF c) (toF d) (toF a) ) . J.collapseColorChannel)+ flip = R.backpermute (Z :. 15 :. 160) (\(Z:. y :. x) -> Z :. (14 - y) :. x ) ++handleInput :: Event -> World -> World+handleInput e w = handleInput' (w {mousePrevPos = mousePos w})+ where handleInput' world = case e of+ EventKey (MouseButton LeftButton) Down _ (x,y) -> world { mouseDown = True, mousePos = (x/factor, y/factor - palletteH) }+ EventKey (MouseButton LeftButton) Up _ (x,y) -> world { mouseDown = False, mousePos = (x/factor, y/factor - palletteH) }+ EventKey (Char 'e') Down _ _ -> world { currentElem = steam_water }+ EventKey (Char 'f') Down _ _ -> world { currentElem = fire }+ EventKey (Char 'o') Down _ _ -> world { currentElem = oil }+ EventKey (Char 'w') Down _ _ -> world { currentElem = water }+ EventKey (Char 'l') Down _ _ -> world { currentElem = salt_water }+ EventKey (Char 's') Down _ _ -> world { currentElem = sand }+ EventKey (Char 'n') Down _ _ -> world { currentElem = salt }+ EventKey (Char 't') Down _ _ -> world { currentElem = stone }+ EventKey (Char 'r') Down _ _ -> world { currentElem = torch }+ EventKey (Char 'a') Down _ _ -> world { currentElem = wall }+ EventKey (Char 'p') Down _ _ -> world { currentElem = plant }+ EventKey (Char 'u') Down _ _ -> world { currentElem = spout }+ EventKey (Char 'm') Down _ _ -> world { currentElem = metal }+ EventMotion (x,y) -> world { mousePos = (x/factor, y/factor - palletteH) }+ _ -> world++blankTooltip :: R.Array R.V R.DIM2 Color+blankTooltip = R.computeS $ R.fromFunction (Z :. 15 :. 160) (const black)++handleUI :: [(Element, R.Array R.V R.DIM2 Color)] -> GlossCoord -> World -> World+handleUI t p w = let tooltip = fromMaybe blankTooltip $ flip lookup t $ elemOf p+ in if mouseDown w then + w {currentElem = elemOf p, tooltipLeft = tooltip+ , tooltipRight = tooltip }+ else w { tooltipRight = tooltip }++stepWorld :: [(Element, R.Array R.V R.DIM2 Color)] -> Float -> World -> IO World+stepWorld tooltips time world+ = let curr = mousePos world+ world' = if outOfWorld curr then handleUI tooltips curr world else world { tooltipRight = blankTooltip }+ in do int <- randomRIO (0,100) + stepped <- if mouseDown world + then liftM (step int $ currGravityMask world')+ $ drawLine (mousePrevPos world') curr+ (currentElem world') (array world')+ else return $ step int (currGravityMask world') + $ array world'+ array' <- R.computeP stepped+ return $ world' { array = array'+ , currGravityMask = nextGravityMask world'+ , nextGravityMask = currGravityMask world' } +
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ Step.hs view
@@ -0,0 +1,174 @@+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
+ World.hs view
@@ -0,0 +1,291 @@+{-# LANGUAGE ViewPatterns, PatternGuards #-}+module World + ( Element (..), Cell (..)+ , Env (..)+ , Weight (..), WeightEnv (..)+ + , nothing, turnip, steam_water, steam_condensed, fire, fire_end, oil+ , water, salt_water, sand, salt, stone, torch, plant, spout, metal, wall, lava++ , isFluid, isWall, isFire + , weight, age++ , MargPos (..)+ , GlossCoord (..), World (..)+ , resX, resY, winX, winY, resWidth, resHeight, palletteH+ , factor+ , render, outOfWorld, elemOf, tooltipFiles ) +where++import Graphics.Gloss +import Data.Word+import Data.Array.Repa (Z (..), (:.) (..), D, U, DIM2)+import Data.Array.Repa.Repr.Vector+import qualified Data.Array.Repa.Eval as R+import qualified Data.Array.Repa as R++import Data.List+++-- Basic constructs ------------------------------------------------------------++type Element = Word32+type Cell = Word32+type Env = Word32+type Weight = Word32+type WeightEnv = Word32++-- | Positions in a Margolus neighbourhood+type MargPos = Int++-- | Coordinates in a Gloss window, origin at center+type GlossCoord = (Float, Float)++data World = World { array :: Array U DIM2 Cell+ , currentElem :: Element+ , mouseDown :: Bool + , mousePos :: GlossCoord + , mousePrevPos :: GlossCoord + , currGravityMask :: Array U DIM2 MargPos+ , nextGravityMask :: Array U DIM2 MargPos + , tooltipLeft :: Array V DIM2 Color + , tooltipRight :: Array V DIM2 Color }+++-- Elements and properties -----------------------------------------------------++{-# INLINE nothing #-}+-- Must match on direct values for efficiency+nothing = 0+steam_water = 1+steam_condensed = 2+oil = 6 +water = 7+salt_water = 8+sand = 9+salt = 10+stone = 11+fire = 12+fire_end = 22+torch = 23+plant = 24+spout = 25+metal = 26+lava = 27+turnip = 126+wall = 127++{-# INLINE elems #-}+elems :: [Element]+elems = [ nothing + , steam_water + , steam_condensed+ , oil + , water + , salt_water + , sand + , salt + , stone + , fire + , fire_end + , torch + , plant + , spout + , metal + , lava + , turnip ] ++{-# INLINE isWall #-}+isWall :: Element -> Bool+isWall 23 = True -- torch+isWall 24 = True -- plant+isWall 25 = True -- spout+isWall 26 = True -- metal+isWall 127 = True -- wall+isWall _ = False++{-# INLINE isFire #-}+isFire :: Element -> Bool+isFire x = x >= fire && x <= fire_end++{-# INLINE isFluid #-}+isFluid :: Element -> Element+isFluid 0 = 0 -- nothing+isFluid 1 = 0x40 -- steam+isFluid 2 = 0x40 +isFluid 6 = 0x40 -- oil+isFluid 7 = 0x40 -- water+isFluid 8 = 0x40 -- salt water+isFluid 27 = 0x40 -- lav+isFluid _ = 0++{-# INLINE weight #-}+weight :: Element -> Weight+weight 0 = 2 -- nothing+weight 1 = 0 -- steam water+weight 2 = 0 -- steam water+weight 9 = salt -- sand == salt+weight 27 = water -- lava == water+weight x | isFire x = 0+ | otherwise = fromIntegral x++{-# INLINE age #-}+age :: Int -> Element -> Element+age r x + -- fire eventually goes out+ | x == fire_end = nothing+ | isFire x = if r < 50 then x + 1 else x+ -- steam eventually condenses+ | x == steam_water = if r < 1 then water else steam_water+ | x == steam_condensed = if r < 5 then water else steam_condensed+ -- turnip being turnip+ | x == turnip = elems !! ((r * length elems) `div` 110)+ | otherwise = x+++-- Drawing ---------------------------------------------------------------------+{-# INLINE render #-}+render :: World -> Array D DIM2 Color+render world + = R.transpose $ (R.transpose $ tooltipLeft world R.++ R.map (dim . dim) (tooltipRight world)) + R.++ (R.transpose buttons)+ R.++ (R.transpose $ R.map colour $ array world) + ++{-# INLINE brown #-}+brown :: Color+brown = makeColor (129/255) (49/255) (29/255) 1++{-# INLINE colour #-}+colour :: Element -> Color+colour 0 = black -- nothing+colour 1 = bright $ light $ light $ light blue -- steam +colour 2 = bright $ light $ light $ light blue -- steam condensed +colour 6 = brown -- oil +colour 7 = bright $ bright $ light blue -- water +colour 8 = bright $ bright $ light $ light blue -- salt water+colour 9 = dim yellow -- sand +colour 10 = greyN 0.95 -- salt +colour 11 = greyN 0.7 -- stone +colour 23 = bright $ orange -- torch+colour 24 = dim $ green -- plant+colour 25 = blue -- spout+colour 26 = mixColors (0.2) (0.8) blue (greyN 0.5) -- metal+colour 27 = bright red -- lava+colour 126 = violet -- turnip+colour 127 = greyN 0.4 -- wall +colour x -- fire+ | isFire x = mixColors (1.0 * fromIntegral (x - fire)) + (1.0 * fromIntegral (fire_end - x)) + red yellow + | otherwise = error "render: element doesn't exist"+++{-# INLINE buttons #-}+buttons :: Array V DIM2 Color+buttons = R.fromList (Z :. buttonH + paddingH :. resX) + $ hPadding ++ hPadding2+ ++ (concat $ map oneLine [1..buttonH])+ ++ hPadding2 ++ hPadding+ where -- background+ bgUI = black+ -- gap between buttons+ gap = replicate gapSize bgUI + -- gap from left and right edges of the window+ side = replicate sideSize bgUI+ -- gap from top and bottom of the palette+ hPadding = replicate resX white+ hPadding2 = replicate resX bgUI+ -- one button+ oneBox e = oneBox' $ colour e+ oneBox' c = replicate buttonW c+ -- one line = fire + rest of elements+ oneLine x + = let col = mixColors (fromIntegral x / fromIntegral buttonH) + (1.0 - fromIntegral x / fromIntegral buttonH)+ red yellow+ in side ++ (concat $ intersperse gap $ oneBox' col : map oneBox selectableElems) ++ side+++{-# INLINE selectableElems #-}+selectableElems :: [Element]+selectableElems+ = [ torch, water, spout, plant, stone, metal, lava, oil, salt, sand, nothing, wall, turnip ]++{-# INLINE elemOf #-}+elemOf :: GlossCoord -> Element+elemOf ((subtract 5) . (+ resWidth) . round -> x, _)+ | x < buttonW = fire+ | x < gapSize + 2 * buttonW = torch+ | x < 2 * gapSize + 3 * buttonW = water+ | x < 3 * gapSize + 4 * buttonW = spout+ | x < 4 * gapSize + 5 * buttonW = plant+ | x < 5 * gapSize + 6 * buttonW = stone+ | x < 6 * gapSize + 7 * buttonW = metal+ | x < 7 * gapSize + 8 * buttonW = lava+ | x < 8 * gapSize + 9 * buttonW = oil+ | x < 9 * gapSize + 10 * buttonW = salt+ | x < 10 * gapSize + 11 * buttonW = sand+ | x < 11 * gapSize + 12 * buttonW = nothing+ | x < 12 * gapSize + 13 * buttonW = wall+ | otherwise = turnip+++{-# INLINE resX #-}+{-# INLINE resY #-}+{-# INLINE resWidth #-}+{-# INLINE resHeight #-}+{-# INLINE paddingH #-}+{-# INLINE tooltipH #-}+{-# INLINE gapSize #-}+{-# INLINE sideSize #-}+{-# INLINE buttonW #-}+{-# INLINE buttonH #-}+resX, resY, resWidth, resHeight, paddingH, tooltipH, gapSize, sideSize, buttonW, buttonH :: Int+-- size of the world+resX = 320+resY = 240+-- size of window = size of world + size of palette + size of tooltip area+winX = resX+winY = resY + buttonH + paddingH + tooltipH+-- gloss origin is at center, while repa origin is bottom left, so shifting needed+resWidth = resX `div` 2+resHeight = resY `div` 2+-- 2 (top & bottom) * number of hPadding's+paddingH = 4+-- size of buttons, tooltips and gaps+tooltipH = 15+gapSize = 2 +sideSize + = let n = 1 + length selectableElems+ in (resX - n * buttonW - (n - 1) * gapSize) `div` 2+buttonW + = let n = 1 + length selectableElems+ in (resX - (n-1)*gapSize) `div` n+buttonH = 15++{-# INLINE factor #-}+{-# INLINE palletteH #-}+factor, palletteH :: Float+factor = 2+palletteH = (fromIntegral buttonH + fromIntegral paddingH + fromIntegral tooltipH)/2++{-# INLINE outOfWorld #-}+outOfWorld :: GlossCoord -> Bool+outOfWorld (_, y) = round y + resHeight < 0++{-# INLINE tooltipFiles #-}+tooltipFiles =[(fire , "tooltips/fire.png"),+ (wall , "tooltips/wall.png"),+ (nothing , "tooltips/erase.png"),+ (oil , "tooltips/oil.png"),+ (water , "tooltips/water.png"),+ (sand , "tooltips/sand.png"),+ (salt , "tooltips/salt.png"),+ (stone , "tooltips/stone.png"),+ (torch , "tooltips/torch.png"),+ (plant , "tooltips/plant.png"),+ (spout , "tooltips/spout.png"),+ (metal , "tooltips/metal.png"),+ (lava , "tooltips/lava.png"),+ (turnip , "tooltips/turnip.png")]
+ falling-turnip.cabal view
@@ -0,0 +1,40 @@+-- Initial falling-turnip.cabal generated by cabal init. For further +-- documentation, see http://haskell.org/cabal/users-guide/++name: falling-turnip+version: 0.1.0.0+synopsis: Falling sand game/cellular automata simulation using regular parallel arrays.+description: + 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.+ .+ A short demo video is available here:+ .+ http://youtu.be/hlL9yi2hGx0+ .+homepage: http://github.com/tranma/falling-turnip+license: BSD3+license-file: LICENSE+author: Tran Ma+maintainer: ma.ngoc.tran@gmail.com+-- copyright: +category: Game+build-type: Simple+cabal-version: >=1.8+data-files: tooltips/*.png +source-repository head+ type: git+ location: https://github.com/tranma/falling-turnip.git+executable falling-turnip+ main-is: Main.hs + other-modules: Alchemy, Draw, Gravity, Step, World + build-depends: base >= 4.0 && < 5.0+ , repa >= 3.2+ , vector >= 0.9+ , gloss >= 1.7+ , gloss-raster >= 1.7+ , JuicyPixels-repa >= 0.6+ , random >= 1.0+ , QuickCheck >= 2.4+ , repa-algorithms >= 3.2+ ghc-options:+ -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
+ tooltips/erase.png view
binary file changed (absent → 325 bytes)
+ tooltips/fire.png view
binary file changed (absent → 315 bytes)
+ tooltips/lava.png view
binary file changed (absent → 199 bytes)
+ tooltips/metal.png view
binary file changed (absent → 328 bytes)
+ tooltips/oil.png view
binary file changed (absent → 291 bytes)
+ tooltips/plant.png view
binary file changed (absent → 313 bytes)
+ tooltips/salt.png view
binary file changed (absent → 319 bytes)
+ tooltips/sand.png view
binary file changed (absent → 318 bytes)
+ tooltips/spout.png view
binary file changed (absent → 328 bytes)
+ tooltips/stone.png view
binary file changed (absent → 325 bytes)
+ tooltips/torch.png view
binary file changed (absent → 312 bytes)
+ tooltips/turnip.png view
binary file changed (absent → 195 bytes)
+ tooltips/wall.png view
binary file changed (absent → 307 bytes)
+ tooltips/water.png view
binary file changed (absent → 325 bytes)