ray+linear.hs

{-#LANGUAGE LinearTypes#-}
{-#LANGUAGE ScopedTypeVariables#-}
{-#LANGUAGE BlockArguments#-}
{-#LANGUAGE ViewPatterns#-}
{-#OPTIONS_GHC -Wno-unused-top-binds#-}
module Main where

import qualified Data.IntMap as IM
import qualified Data.IntMap.Linear as IML
import qualified Data.Array.Mutable.Linear as AML
import qualified Data.Monoid.Linear as L
import qualified Data.Tuple.Linear as L
import Prelude.Linear (Consumable(consume), Movable, Ur (Ur))

import Linear (V2 (V2))
import Data.Bool (bool)
import Raylib.Core.Shapes (drawRectangle)
import Raylib.Types (Color(Color))
import Raylib.Core (windowShouldClose, initWindow, clearBackground, beginDrawing, endDrawing, closeWindow)



data Entity = Trooper { trooper'position :: V2 Int
                      }
            | Enemy { enemy'position :: V2 Int
                    }


entity'position :: Entity -> V2 Int
entity'position (Trooper pos) = pos
entity'position (Enemy pos) = pos



data Tile = Floor
          | Wall
          deriving(Eq, Show)



data GameState = GameState { gameState'entities :: IM.IntMap Entity
                           }


addEntity :: Int -> Entity -> GameState -> GameState
addEntity i ent gs =
  gs { gameState'entities = IM.insert i ent (gameState'entities gs) }



data Board = Board { board'tileArray :: AML.Array Tile
                   , board'entityIdArray :: AML.Array (Maybe Int)
                   , board'width :: Ur Int
                   , board'height :: Ur Int
                   , board'lastGameState :: Ur (Maybe GameState)
                   }


instance Consumable Board where
  consume :: Board %1 -> ()
  consume (Board a0 a1 (Ur _) (Ur _) (Ur _)) = consume a0 L.<> consume a1


allocBoard :: Movable b => Int -> Int -> (Board %1 -> b) -> b
allocBoard width height f = 
  AML.alloc (width * height) Floor 
  (\ tiles -> AML.alloc (width * height) Nothing
              (\ entDist -> f (Board tiles entDist (Ur width) (Ur height) (Ur Nothing)) ) )


lookupBoard :: V2 Int -> Board %1 -> (Ur (Tile, Maybe Int), Board)
lookupBoard (V2 x y) (Board tiles0 entities0 (Ur w) (Ur h) urmgs) =
  let !_ = bool (error "") () (x >= 0 && y >= 0 && x < w && y < h)
      !(Ur t, tiles1) = AML.get (x * w + y) tiles0
      !(Ur mi, entities1) = AML.get (x * w + y) entities0
   in (Ur (t, mi), Board tiles1 entities1 (Ur w) (Ur h) urmgs)


putWallOnBoard :: V2 Int -> Board %1 -> Board
putWallOnBoard (V2 x y) (Board tiles0 entities0 (Ur w) (Ur h) urmgs) =
  let !_ = bool (error "") () (x >= 0 && y >= 0 && x < w && y < h)
      tiles1 = AML.set (x * w + y) Wall tiles0
   in (Board tiles1 entities0 (Ur w) (Ur h) urmgs)

 
updateBoard :: GameState -> Board %1 -> Board
updateBoard gs b = 
  let !(Board ts es urw urh (Ur _)) = IML.foldlWithKeyOnLinear f b (gameState'entities gs)
   in Board ts es urw urh (Ur (Just gs))

  where
    f :: Board %1 -> Int -> Entity -> Board
    f (Board tiles0 entids0 (Ur w) urh (Ur mgs)) entid ent =
      let moldent = gameState'entities <$> mgs >>= IM.lookup entid
          %1 entids1 = resetOnEntids moldent w entids0
          V2 x y = entity'position ent
          %1 entids2 = AML.set (x * w + y) (Just entid) entids1
       in (Board tiles0 entids2 (Ur w) urh (Ur mgs))

    resetOnEntids :: Maybe Entity -> Int -> AML.Array (Maybe Int) %1 -> AML.Array (Maybe Int)
    resetOnEntids Nothing _ a' = a'
    resetOnEntids (Just ent) w a0 = 
      let V2 x y = entity'position ent
          a1 = AML.set (x * w + y) Nothing a0
       in a1


drawBoard :: Board %1 -> (Ur (IO ()), Board)
drawBoard (Board ts es (Ur w) (Ur h) (Ur mgs)) = 
  d (Board ts es (Ur w) (Ur h) (Ur mgs)) (pure ()) 0 0

  where
    d :: Board %1 -> IO () -> Int -> Int -> (Ur (IO ()), Board)
    d b io _ ((< h) -> False) = (Ur io, b)
    d b io ((< w) -> False) y = d b (pure () >> io) 0 (y + 1)
    d (Board ts0 es0 urw urh urmgs) io0 x y = 
      let !(Ur t, ts1) = AML.get (x * w + y) ts0
          !(Ur eid, es1) = AML.get (x * w + y) es0
          io1 = do
            io0
            drawRectangle (x * 16) (y * 16) 16 16 (tileColor t)
            maybe (pure ()) (drawRectangle (x * 16 + 4) (x * 16 + 4) 8 8) (eid >>= entColor)
       in d (Board ts1 es1 urw urh urmgs) io1 (x + 1) y

    tileColor Floor = (Color 80 80 80 255)
    tileColor Wall = (Color 200 200 200 255)

    entColor i = do
      GameState m <- mgs
      e <- IM.lookup i m
      case e of
        Enemy _ -> Just $ Color 200 100 100 255
        Trooper _ -> Just $ Color 100 100 200 255



main :: IO ()
main = do
  w <- initWindow 800 600 "title"
  let (Ur boarddrawing) = allocBoard 10 10 onBoard
  loop boarddrawing
  closeWindow (Just w)

  where
    loop :: IO () -> IO ()
    loop boarddrawing = do
      b <- windowShouldClose
      beginDrawing
      clearBackground (Color 120 120 120 255)
      boarddrawing
      endDrawing
      if b then pure () else loop boarddrawing


onBoard :: Board %1 -> (Ur (IO ()))
onBoard b0 =
  let gs = GameState (IM.fromList [(0, Trooper (V2 0 0)), (1, Enemy (V2 1 1))])
      b1 = updateBoard gs b0
      b2 = putWallOnBoard (V2 5 5) b1
      b3 = drawBoard b2
   in L.fst b3