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.Matrix (toLists) 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, 95)] (50,100) (Subsystems _ m) = subsystems ud matrix <- liftIO $ buildHallFloorIO fc nworld <- runSystemT (world ud) $ do void $ newEntity $ defEntity { pos = Just (V2 20 20) , vel = Just (V2 0 0) , player = Just True } getWorld uu <- partSubscribe m movePlayer putAffection ud { world = nworld , stateData = MenuData { mapMat = matrix -- , initCoords = (0, 500) -- , playerCoords = (20, 20) } , 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) + (- rx) dc = (- rx) - (- ry) / 2 -- (pr, pc) = playerCoords $ stateData ud nworld <- runSystemT (world ud) $ do emap $ do with player pure $ defEntity' { vel = Set $ V2 dr dc } getWorld putAffection ud { world = nworld -- stateData = (stateData ud) -- { playerCoords = (pr - dr, pc - dc) -- } } movePlayer :: MouseMessage -> Affection UserData () movePlayer (MsgMouseMotion _ _ _ [SDL.ButtonLeft] m _) = mouseToPlayer m movePlayer (MsgMouseButton _ _ SDL.Pressed _ SDL.ButtonLeft _ m) = mouseToPlayer m movePlayer (MsgMouseButton _ _ SDL.Pressed _ SDL.ButtonLeft _ m) = do ud <- getAffection nw <- runSystemT (world ud) $ do emap $ do with player pure $ defEntity' { vel = Set $ V2 0 0 } getWorld putAffection ud { world = nw } movePlayer _ = return () drawMap :: Affection UserData () drawMap = do ud <- getAffection let matrix = mapMat (stateData ud) mapM_ (\(i, ls) -> mapM_ (uncurry $ drawTile i) (reverse $ zip [0..] ls)) (zip [0..] (toLists matrix)) updateMap :: Double -> Affection UserData () updateMap _ = do ud <- getAffection nw <- runSystemT (world ud) $ do emap $ do with player pos' <- E.get pos vel' <- E.get vel pure $ defEntity' { pos = Set $ pos' + vel' } getWorld putAffection ud { world = nw } drawTile :: Int -> Int -> TileState -> Affection UserData () drawTile row col tile = do ud <- getAffection playerPos <- runSystemT (world 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 -- (pr, pc) = playerCoords $ stateData ud tileWidth = 20 :: Double tileHeight = 10 :: Double liftIO $ do save ctx beginPath ctx let x = realToFrac $ 650 + ((fromIntegral col - pc) + (fromIntegral row - pr)) * (tileWidth / 2) y = realToFrac $ 360 + ((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 lineTo ctx (x + realToFrac tileWidth / 2) (y + realToFrac tileHeight / 2) lineTo ctx (x + realToFrac tileWidth) y lineTo ctx (x + realToFrac tileWidth / 2) (y - realToFrac tileHeight / 2) closePath ctx fill ctx when (floor pr + 1 == row && floor pc + 1 == col) $ do beginPath ctx circle ctx 640 360 5 closePath ctx fillColor ctx (rgba 0 255 255 255) fill ctx restore ctx