Skip to content
Browse files

cleanup

  • Loading branch information...
1 parent 5d7c58a commit db60d4e414acf3c04e52e4e509dbb6d696376f67 @tranma committed Nov 11, 2012
Showing with 136 additions and 90 deletions.
  1. +25 −4 Alchemy.hs
  2. +1 −0 Gravity.hs
  3. +1 −0 Main.hs
  4. +6 −4 Makefile
  5. +2 −3 QC.hs
  6. +48 −36 Step.hs
  7. +53 −43 World.hs
View
29 Alchemy.hs
@@ -6,20 +6,41 @@ applyAlchemy :: Int -> Element -> Element -> (Element, Element)
-- water + salt = salt_water + nothing
applyAlchemy _ 7 10 = (salt_water, nothing)
applyAlchemy _ 10 7 = (nothing, salt_water)
-applyAlchemy _ w 1 | isWall w = (wall, steam_cndns)
-applyAlchemy _ 1 w | isWall w = (steam_cndns, wall)
+
+-- 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)
-applyAlchemy _ 25 0 = (spout, water)
-applyAlchemy _ 0 25 = (water, spout)
+
+-- 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)
+
applyAlchemy _ a b = (a, b)
View
1 Gravity.hs
@@ -5,6 +5,7 @@ where
import Data.Bits
import World
+-- Black magic for gravity
-- Possible values:
--
-- L liquid C0
View
1 Main.hs
@@ -55,6 +55,7 @@ handleInput e w = handleInput' (w {mousePrevPos = mousePos w})
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) }
_ -> world
View
10 Makefile
@@ -1,13 +1,15 @@
-PROGNAME=psand
+PROGNAME=turnip
GHC_OPTS := \
-threaded \
-O2 \
-Odph \
-rtsopts \
-fno-liberate-case \
- -funfolding-use-threshold1000 \
- -funfolding-keeness-factor1000 \
+# -funfolding-use-threshold1000 \
+# -funfolding-keeness-factor1000 \
+ -funfolding-use-threshold500 \
+ -funfolding-keeness-factor500 \
-fllvm \
-optlo-O3
@@ -19,7 +21,7 @@ GHC_WARNINGS := \
-fwarn-missing-fields \
-fwarn-overlapping-patterns \
-fwarn-type-defaults \
- -fwarn-unused-binds \
+# -fwarn-unused-binds \
-fwarn-unused-imports \
-fno-warn-missing-methods
View
5 QC.hs
@@ -10,9 +10,8 @@ import Control.Applicative
elems = [nothing, steam_water] ++ [fire .. fire_end] ++ [oil, water, salt_water, sand, salt, stone, wall ]
-
-
environments = combine <$> ( (,,,) <$> elements elems <*> elements elems <*> elements elems <*> elements elems )
conservation :: Property
-conservation = forAll environments $ \env -> sort [weigh (env, 0), weigh (env, 1), weigh (env, 2), weigh (env, 3)] == [0,1,2,3]
+conservation
+ = forAll environments $ \env -> sort [weigh (env, 0), weigh (env, 1), weigh (env, 2), weigh (env, 3)] == [0,1,2,3]
View
84 Step.hs
@@ -28,19 +28,20 @@ step gen mask array
$ R.mapStencil2 (BoundFixed (nothing, 0)) margStencil
$ R.zip array mask
in R.zipWith age randomish
- $ R.zipWith mkCell envs $ R.map (weigh) envs
+ $ 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,p) pos
- = margQuadrant pos env
+ mkCell (env,_) pos = margQuadrant pos env
--- Mask to extract cell at quadrant 'pos'
+-- | 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
+
+-- | Break up the environment into its four components
{-# INLINE split #-}
split :: Env -> (Cell, Cell, Cell, Cell)
split env
@@ -55,57 +56,66 @@ split env
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 the lighter/heavier state of all 4 cells into an env
+-- 32bits: | DR | DL | UR | UL |
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
weigh :: (Env, MargPos) -> MargPos
weigh (env, pos)
- = let (ul', ur', dl', dr') = split env
- -- Determine the heaviest item in the environment
+ = 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'))
- current = margQuadrant pos env
+
-- 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'
-
- combined = combine (ul, ur, dl, dr)
- x' = applyGravity (combined .|. shiftL 1 (8 * pos))
- -- Mark the current one and look it up
- x = if isWall (margQuadrant x' env) then pos else x'
- remainingWeights = filter (/= heaviest) [weight ul', weight ur', weight dl', weight dr']
- nextheavy = maximum $ remainingWeights
- ul2, ur2, dl2, dr2 :: Weight
- ul2 = (0x80 .&. (nextheavy - 1 - weight ul')) .|. isFluid ul'
- ur2 = (0x80 .&. (nextheavy - 1 - weight ur')) .|. isFluid ur'
- dl2 = (0x80 .&. (nextheavy - 1 - weight dl')) .|. isFluid dl'
- dr2 = (0x80 .&. (nextheavy - 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'
- y' = applyGravity (combine (ul2, ur2, dl2, dr2) .|. shiftL 1 (8 * pos))
+ -- The second heaviest item
+ remainingWeights
+ = filter (/= heaviest)
+ [weight ul', weight ur', weight dl', weight dr']
+ nextHeaviest = maximum $ remainingWeights
- y = if isWall (margQuadrant y' env) then pos else y'
- ydest' = applyGravity (combined .|. shiftL 1 (8 * y))
+ -- 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
+
+ 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
alchemy :: Int -> Env -> Env
alchemy i env
= let (ul0, ur0, dl0, dr0) = split env
@@ -114,7 +124,9 @@ alchemy i env
(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)
+ in if (ul0 == ur0 && ur0 == dl0 && dl0 == dr0)
+ then env
+ else combine (ul, ur, dl, dr)
-- Margolus block --------------------------------------------------------------
View
96 World.hs
@@ -2,7 +2,10 @@ module World
( Element (..), Cell (..)
, Env (..)
, Weight (..), WeightEnv (..)
- , nothing, steam_water, steam_cndns, fire, fire_end, oil, water, salt_water, sand, salt, stone, torch, plant, spout, wall
+
+ , nothing, steam_water, steam_condensed, fire, fire_end, oil
+ , water, salt_water, sand, salt, stone, torch, plant, spout, metal, wall
+
, isFluid, isWall, isFire
, weight, age
@@ -12,12 +15,13 @@ module World
, render )
where
+import Graphics.Gloss
+import Data.Word
import Data.Array.Repa (D, U, DIM2, Array)
import qualified Data.Array.Repa as R
-import Graphics.Gloss
-import Data.Word
+-- Basic constructs ------------------------------------------------------------
type Element = Word32
type Cell = Word32
@@ -40,32 +44,36 @@ data World = World { array :: Array U DIM2 Cell
, nextGravityMask :: Array U DIM2 MargPos }
--- Must match on direct values for efficiency
+-- Elements and properties -----------------------------------------------------
+
{-# INLINE nothing #-}
-nothing, steam_water, steam_cndns, fire, fire_end, oil, water, salt_water, sand, salt, stone, torch, plant, spout, wall :: Element
-nothing = 0
-steam_water = 1
-steam_cndns = 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
-wall = 100
+-- Must match on direct values for efficiency
+nothing, steam_water, steam_condensed, fire, fire_end, oil, water, salt_water, sand, salt, stone, torch, plant, spout, metal, wall :: Element
+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
+wall = 100
{-# INLINE isWall #-}
isWall :: Element -> Bool
-isWall 100 = True
-isWall 25 = True
-isWall 24 = True
-isWall 23 = True
+isWall 23 = True -- torch
+isWall 24 = True -- plant
+isWall 25 = True -- spout
+isWall 26 = True -- metal
+isWall 100 = True -- wall
isWall _ = False
{-# INLINE isFire #-}
@@ -97,32 +105,34 @@ age gen x
| x == fire_end = nothing
| isFire x = if gen < 50 then x + 1 else x
| x == steam_water = if gen < 1 then water else steam_water
- | x == steam_cndns = if gen < 5 then water else steam_cndns
+ | x == steam_condensed = if gen < 5 then water else steam_condensed
| otherwise = x
+-- Drawing ---------------------------------------------------------------------
render :: World -> Array D DIM2 Color
render world = R.map color $ array world
where color :: Element -> Color
- color 0 = black -- nothing
- color 1 = bright $ light $ light $ light blue -- steam water
- color 2 = bright $ light $ light $ light blue -- steam water
- color 6 = dark $ dim $ dim orange -- oil
- color 7 = bright $ bright $ light blue -- water
- color 8 = bright $ bright $ light $ light blue -- salt water
- color 9 = dim yellow -- sand
- color 10 = greyN 0.95 -- salt
- color 11 = greyN 0.7 -- stone
- color 100 = greyN 0.4 -- wall
- color 23 = bright $ orange -- torch
- color 24 = dim $ green -- plant
- color 25 = blue -- spout
- color x | isFire x = mixColors (1.0 * fromIntegral (x - fire)) (1.0 * fromIntegral (fire_end - x)) red yellow
-
--- iterate (addColors $ dark $ dim yellow) (dark $ bright red) !! fromIntegral (x - fire)-- fire
- color _ = error "render: element doesn't exist"
-
+ color 0 = black -- nothing
+ color 1 = bright $ light $ light $ light blue -- steam water
+ color 2 = bright $ light $ light $ light blue -- steam water
+ color 6 = dark $ dim $ dim orange -- oil
+ color 7 = bright $ bright $ light blue -- water
+ color 8 = bright $ bright $ light $ light blue -- salt water
+ color 9 = dim yellow -- sand
+ color 10 = greyN 0.95 -- salt
+ color 11 = greyN 0.7 -- stone
+ color 100 = greyN 0.4 -- wall
+ color 23 = bright $ orange -- torch
+ color 24 = dim $ green -- plant
+ color 25 = blue -- spout
+ color 26 = mixColors (0.2) (0.8) blue (greyN 0.5) -- metal
+ color 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"
resX, resY :: Int
resX = 320

0 comments on commit db60d4e

Please sign in to comment.
Something went wrong with that request. Please try again.