module Test where import Affection as A hiding (get) import SDL (get, ($=)) import qualified SDL import qualified Graphics.Rendering.OpenGL as GL hiding (get) import Control.Monad (when, void) import Control.Monad.IO.Class (liftIO) import Data.Map.Strict as Map import Data.Matrix as M (toLists, (!), Matrix, safeGet) import Data.Ecstasy as E import NanoVG hiding (V2(..)) import Types import Floorplan import Linear import Foreign.C.Types (CFloat(..)) import Debug.Trace loadMap :: Affection UserData () loadMap = do ud <- getAffection let fc = FloorConfig (20, 20) [(5,5), (45, 75)] (80,40) (Subsystems _ m) = subsystems ud matrix <- liftIO $ buildHallFloorIO fc (nws, _) <- yieldSystemT (worldState ud) $ do void $ newEntity $ defEntity { pos = Just (V2 20.5 20.5) , vel = Just (V2 0 0) , player = Just True } uu <- partSubscribe m movePlayer putAffection ud { worldState = nws , stateData = MenuData { mapMat = matrix , initCoords = (0, 500) } , uuid = [uu] } relativizeMouseCoords :: V2 Int32 -> IO (V2 Double) relativizeMouseCoords (V2 ix iy) = do (GL.Position vx vy, GL.Size vw vh) <- SDL.get GL.viewport let rx = ix - vx ry = iy - vy hx = fromIntegral vw / 2 hy = fromIntegral vh / 2 dx = fromIntegral rx - hx dy = fromIntegral ry - hy return $ V2 (dx / hx) (dy / hy) mouseToPlayer :: V2 Int32 -> Affection UserData () mouseToPlayer mv2 = do ud <- getAffection rela@(V2 rx ry) <- liftIO $ relativizeMouseCoords mv2 let dr = (ry / sin (atan (1/2)) / 2) + rx dc = rx - (ry / sin (atan (1/2)) / 2) (nws, _) <- yieldSystemT (worldState ud) $ do emap $ do with player pos' <- E.get pos pure $ defEntity' { vel = Set $ V2 dr dc } putAffection ud { worldState = nws } movePlayer :: MouseMessage -> Affection UserData () movePlayer (MsgMouseMotion _ _ _ [SDL.ButtonLeft] m _) = mouseToPlayer m movePlayer (MsgMouseButton _ _ SDL.Pressed _ SDL.ButtonLeft _ m) = mouseToPlayer m movePlayer (MsgMouseButton _ _ SDL.Released _ SDL.ButtonLeft _ m) = do ud <- getAffection (nws, _) <- yieldSystemT (worldState ud) $ do emap $ do with player pure $ defEntity' { vel = Set $ V2 0 0 } putAffection ud { worldState = nws } movePlayer _ = return () drawMap :: Affection UserData () drawMap = do ud <- getAffection let matrix = mapMat (stateData ud) mapM_ (\(i, ls) -> mapM_ (uncurry $ drawTile i) (reverse $ zip [1..] ls)) (zip [1..] (toLists matrix)) updateMap :: Double -> Affection UserData () updateMap dt = do ud <- getAffection let matrix = mapMat $ stateData ud (nws, _) <- yieldSystemT (worldState ud) $ do emap $ do with vel with pos pos'@(V2 or oc) <- E.get pos vel' <- E.get vel let npos@(V2 nr nc) = pos' + fmap (* (4 * dt)) vel' let ent | Wall /= matrix M.! (floor nr, floor nc) = defEntity' { pos = Set npos } | Wall /= matrix M.! (floor nr, floor oc) = defEntity' { pos = Set (V2 nr oc) } | Wall /= matrix M.! (floor or, floor nc) = defEntity' { pos = Set (V2 or nc) } | otherwise = defEntity' return ent putAffection ud { worldState = nws } neighWalls :: Int -> Int -> Matrix TileState -> Int neighWalls row col mat = Prelude.foldl (\acc (ir, ic) -> if M.safeGet (row + ir) (col + ic) mat == Just Wall || M.safeGet (row + ir) (col + ic) mat == Just Door then acc + 1 else acc ) 0 [ (0, -1) , (-1, 0) , (0, 1) , (1, 0) ] drawTile :: Int -> Int -> TileState -> Affection UserData () drawTile row col tile = do ud <- getAffection (_, playerPos) <- yieldSystemT (worldState ud) $ do efor $ \_ -> do with player pos' <- E.get pos pure pos' let V2 pr pc = head playerPos ctx = nano ud (xinit, yinit) = initCoords $ stateData ud tileWidth = 64 :: Double tileHeight = 32 :: Double liftIO $ do save ctx beginPath ctx let x = realToFrac $ 640 + ((fromIntegral col - pc) + (fromIntegral row - pr)) * (tileWidth / 2) y = realToFrac $ 360 - (tileHeight / 2) + ((fromIntegral row - pr) - (fromIntegral col - pc)) * (tileHeight / 2) fillColor ctx (case tile of Wall -> rgba 128 128 128 255 Door -> rgba 255 128 128 255 Hall -> rgba 255 255 255 255 Offi -> rgba 0 255 0 255 Toil -> rgba 0 0 255 255 Kitc -> rgba 255 0 0 255 Elev -> rgba 0 0 0 255 _ -> rgba 255 255 0 255 ) moveTo ctx x (y + realToFrac tileHeight / 2) lineTo ctx (x + realToFrac tileWidth / 2) (y + realToFrac tileHeight) lineTo ctx (x + realToFrac tileWidth) (y + realToFrac tileHeight / 2) lineTo ctx (x + realToFrac tileWidth / 2) y closePath ctx fill ctx when (tile == Wall) $ do let img = case neighWalls row col mat of 4 -> assetImages ud Map.! ImgWallCross 3 | M.safeGet (row + 1) col mat /= Just Wall && M.safeGet (row + 1) col mat /= Just Door -> assetImages ud Map.! ImgWallTNW | M.safeGet row (col + 1) mat /= Just Wall && M.safeGet row (col + 1) mat /= Just Door -> assetImages ud Map.! ImgWallTSW | M.safeGet (row - 1) col mat /= Just Wall && M.safeGet (row - 1) col mat /= Just Door -> assetImages ud Map.! ImgWallTSE | otherwise -> assetImages ud Map.! ImgWallTNE 2 | (M.safeGet (row + 1) col mat == Just Wall || M.safeGet (row + 1) col mat == Just Door) && (M.safeGet (row - 1) col mat == Just Wall || M.safeGet (row - 1) col mat == Just Door) -> assetImages ud Map.! ImgWallDesc | (M.safeGet row (col + 1) mat == Just Wall || M.safeGet row (col + 1) mat == Just Door) && (M.safeGet row (col - 1) mat == Just Wall || M.safeGet row (col - 1) mat == Just Door) -> assetImages ud Map.! ImgWallAsc | (M.safeGet (row - 1) col mat == Just Wall || M.safeGet (row - 1) col mat == Just Door) && (M.safeGet row (col - 1) mat == Just Wall || M.safeGet row (col - 1) mat == Just Door) -> assetImages ud Map.! ImgWallCornerW | (M.safeGet row (col - 1) mat == Just Wall || M.safeGet row (col - 1) mat == Just Door) && (M.safeGet (row + 1) col mat == Just Wall || M.safeGet (row + 1) col mat == Just Door) -> assetImages ud Map.! ImgWallCornerS | (M.safeGet (row + 1) col mat == Just Wall || M.safeGet (row + 1) col mat == Just Door) && (M.safeGet row (col + 1) mat == Just Wall || M.safeGet row (col + 1) mat == Just Door) -> assetImages ud Map.! ImgWallCornerE | otherwise -> assetImages ud Map.! ImgWallCornerN 1 | M.safeGet (row - 1) col mat == Just Wall || M.safeGet (row - 1) col mat == Just Door -> assetImages ud Map.! ImgWallDesc | M.safeGet (row + 1) col mat == Just Wall || M.safeGet (row + 1) col mat == Just Door -> assetImages ud Map.! ImgWallDesc | M.safeGet row (col + 1) mat == Just Wall || M.safeGet row (col + 1) mat == Just Door -> assetImages ud Map.! ImgWallAsc | otherwise -> assetImages ud Map.! ImgWallAsc 0 -> assetImages ud Map.! ImgWallCross _ -> error "unexpected number if neighbouring walls" mat = mapMat (stateData ud) paint <- imagePattern ctx x (y - (74 - realToFrac tileHeight)) 64 74 0 img 1 beginPath ctx rect ctx x (y - (74 - realToFrac tileHeight)) 64 74 fillPaint ctx paint fill ctx when (floor pr == row && floor pc == col) $ do beginPath ctx circle ctx 640 360 5 closePath ctx fillColor ctx (rgba 0 255 255 255) fill ctx restore ctx