{-# 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")]