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, unless, void) import Control.Monad.IO.Class (liftIO) import Data.Map.Strict as Map import qualified Data.Set as S import qualified Data.Text as T import Data.Matrix as M import Data.Ecstasy as E import Data.Maybe import NanoVG hiding (V2(..)) import Types import Floorplan import Linear import Foreign.C.Types (CFloat(..)) import Debug.Trace -- internal imports import Interior import Util loadMap :: Affection UserData () loadMap = do ud <- getAffection let fc = FloorConfig (20, 20) [] -- [(5,5), (35, 35)] (50,75) (Subsystems _ m) = subsystems ud (matrix, gr) <- liftIO $ buildHallFloorIO fc inter <- liftIO $ placeInteriorIO matrix (convertTileToImg matrix) gr (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 , imgMat = inter , initCoords = (0, 500) } , uuid = [uu] } 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 dt <- getDelta (_, playerPos) <- yieldSystemT (worldState ud) $ do efor $ \_ -> do with player pos' <- E.get pos pure pos' let V2 pr pc = head playerPos matrix = imgMat (stateData ud) ctx = nano ud cols = fromIntegral (ncols matrix) rows = fromIntegral (nrows matrix) tileWidth = 64 :: Double tileHeight = 32 :: Double x = realToFrac $ 640 + ((1 - pc) + (1 - pr)) * (tileWidth / 2) y = realToFrac $ 360 + ((1 - pr) - (1 - pc)) * (tileHeight / 2) liftIO $ do beginPath ctx moveTo ctx x y lineTo ctx (x + cols * (realToFrac tileWidth / 2)) (y - realToFrac tileHeight / 2 * cols) lineTo ctx (x + realToFrac tileWidth / 2 * (cols + rows)) (y + (rows - cols) * (realToFrac tileHeight / 2)) lineTo ctx (x + realToFrac tileWidth / 2 * rows) (y + realToFrac tileHeight / 2 * rows) closePath ctx fillColor ctx (rgb 255 255 255) fill ctx mapM_ (\(i, ls) -> mapM_ (\(j, t) -> drawTile (assetImages ud) ctx pr pc i j t) (reverse $ zip [1..] ls)) (zip [1..] (toLists matrix)) fontSize ctx 20 fontFace ctx (assetFonts ud Map.! FontBedstead) textAlign ctx (S.fromList [AlignCenter,AlignTop]) fillColor ctx (rgb 255 128 0) textBox ctx 0 0 200 ("FPS: " `T.append` (T.pack $ Prelude.take 5 $ show (1/dt))) 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 = defEntity' { pos = Set $ Prelude.foldl (checkBoundsCollision pos') npos (imgObstacle (imgMat (stateData ud) M.! (floor nr, floor nc))) } return ent putAffection ud { worldState = nws } drawTile :: Map ImgId Image -> Context -> Double -> Double -> Int -> Int -> Maybe ImgId -> IO () drawTile ai ctx pr pc row col img = do save ctx if (isNothing img) then drawPlayer else do if (Prelude.null mb) then do drawImage drawPlayer else do if any (\minr -> pr <= fromIntegral (floor pr) + minr) minrs && any (\minc -> pc >= fromIntegral (floor pc) + minc) mincs then do drawPlayer drawImage else do drawImage drawPlayer restore ctx where tileWidth = 64 :: Double tileHeight = 32 :: Double minrs = Prelude.map (fst . matmin) mb maxrs = Prelude.map (fst . matmax) mb mincs = Prelude.map (snd . matmin) mb maxcs = Prelude.map (snd . matmax) mb x = realToFrac $ 640 + ((fromIntegral col - pc) + (fromIntegral row - pr)) * (tileWidth / 2) y = realToFrac $ 360 - (tileHeight / 2) + ((fromIntegral row - pr) - (fromIntegral col - pc)) * (tileHeight / 2) dist = distance (V2 (fromIntegral row) (fromIntegral col)) (V2 (realToFrac pr - 1) (realToFrac pc)) / 4 fact = if (pr <= fromIntegral row + maximum minrs && pc >= fromIntegral col + minimum mincs) && isWall (fromJust img) then min 1 dist else 1 mb = imgObstacle img drawImage = do beginPath ctx paint <- imagePattern ctx x (y - (74 * fact - realToFrac tileHeight)) (realToFrac tileWidth) 74 0 (ai Map.! fromJust img) fact if fact < 1 then do moveTo ctx x (y + (realToFrac tileHeight - 74 * fact)) lineTo ctx (x + realToFrac tileWidth) (y + (realToFrac tileHeight - 74 * fact)) lineTo ctx (x + realToFrac tileWidth) (y + realToFrac tileHeight / 2) lineTo ctx (x + realToFrac tileWidth / 2) (y + realToFrac tileHeight) lineTo ctx x (y + realToFrac tileHeight / 2) closePath ctx else rect ctx x (y - (74 - realToFrac tileHeight)) (realToFrac tileWidth) 74 fillPaint ctx paint fill ctx drawPlayer = do 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 checkBoundsCollision :: V2 Double -> V2 Double -> Boundaries Double -> V2 Double checkBoundsCollision pos'@(V2 or oc) acc@(V2 fr fc) (Boundaries (minr, minc) (maxr, maxc)) | (fr - fromIntegral (floor fr) >= minr && fr - fromIntegral (floor fr) <= maxr) && (fc - fromIntegral (floor fc) >= minc && fc - fromIntegral (floor fc) <= maxc) && (or - fromIntegral (floor or) < minr || or - fromIntegral (floor or) > maxr) = (V2 or fc) | (fr - fromIntegral (floor fr) >= minr && fr - fromIntegral (floor fr) <= maxr) && (fc - fromIntegral (floor fc) >= minc && fc - fromIntegral (floor fc) <= maxc) && (oc - fromIntegral (floor oc) < minc || oc - fromIntegral (floor oc) > maxc) = (V2 fr oc) | (fr - fromIntegral (floor fr) < minr || fr - fromIntegral (floor fr) > maxr) && (fc - fromIntegral (floor fc) < minc || fc - fromIntegral (floor fc) > maxc) = acc | (fr - fromIntegral (floor fr) < minr || fr - fromIntegral (floor fr) > maxr) && (fc - fromIntegral (floor fc) >= minc && fc - fromIntegral (floor fc) <= maxc) = acc | (fr - fromIntegral (floor fr) >= minr && fr - fromIntegral (floor fr) <= maxr) && (fc - fromIntegral (floor fc) < minc || fc - fromIntegral (floor fc) > maxc) = acc | otherwise = pos'