From b46adf9898c28caa312fda0282ab2cb954af1955 Mon Sep 17 00:00:00 2001 From: jgk Date: Fri, 26 Mar 2021 03:13:18 +0100 Subject: [PATCH] Refactor map, add location arrows --- app/Main.hs | 4 +- src/Dodge/Base.hs | 20 ++++++ src/Dodge/Data.hs | 97 +++++++++++++++-------------- src/Dodge/Event.hs | 17 ++--- src/Dodge/Event/Keyboard.hs | 4 +- src/Dodge/Prototypes.hs | 12 ++-- src/Dodge/Rendering.hs | 61 +++++------------- src/Dodge/Rendering/HUD.hs | 121 +++++++++++++++++++++++++----------- 8 files changed, 192 insertions(+), 144 deletions(-) diff --git a/app/Main.hs b/app/Main.hs index 6fc3f02bf..92ad4ed5a 100644 --- a/app/Main.hs +++ b/app/Main.hs @@ -65,8 +65,8 @@ main = do let lastFrameTicks = _frameTimer preData renderFoldable (_renderData preData) (picToLTree Nothing . setLayer 1 . setDepth (-1) - . translate 0 (-0.8) . scale 0.0005 0.0005 - . text $ show (endTicks - lastFrameTicks)) + . translate (-0.5) (-0.8) . scale 0.0005 0.0005 + . text $ "ms/frame " ++ show (endTicks - lastFrameTicks)) return $ preData & soundData .~ newSoundData & frameTimer .~ endTicks ) diff --git a/src/Dodge/Base.hs b/src/Dodge/Base.hs index 01acaf4b7..6f59f3d7f 100644 --- a/src/Dodge/Base.hs +++ b/src/Dodge/Base.hs @@ -728,6 +728,26 @@ levLayer LabelLayer = 80 levLayer InvLayer = 85 levLayer MenuLayer = 90 +worldPosToScreen :: World -> Point2 -> Point2 +worldPosToScreen w = doWindowScale . doRotate . doZoom . doTranslate + where + doTranslate p = p -.- _cameraPos w + doZoom p = _cameraZoom w *.* p + doRotate p = rotateV (0 - _cameraRot w) p + doWindowScale (x,y) = ( x * 2 / _windowX w + , y * 2 / _windowY w + ) + +cartePosToScreen :: World -> Point2 -> Point2 +cartePosToScreen w = doWindowScale . doRotate . doZoom . doTranslate + where + doTranslate p = p -.- _carteCenter w + doZoom p = _carteZoom w *.* p + doRotate p = rotateV (0 - _cameraRot w) p + doWindowScale (x,y) = ( x * 2 / _windowX w + , y * 2 / _windowY w + ) + mouseWorldPos :: World -> Point2 mouseWorldPos w = _cameraPos w +.+ (1/_cameraZoom w) *.* rotateV (_cameraRot w) (_mousePos w) diff --git a/src/Dodge/Data.hs b/src/Dodge/Data.hs index b1ea83cba..c549d3d12 100644 --- a/src/Dodge/Data.hs +++ b/src/Dodge/Data.hs @@ -36,53 +36,56 @@ import qualified Data.DList as DL --}}} -- datatypes {{{ data World = World - { _keys :: !(S.Set Scancode) - , _mouseButtons :: !(S.Set MouseButton) - , _cameraPos :: !Point2 - , _cameraAimTime :: Int - , _cameraRot :: !Float - , _cameraZoom :: !Float - , _cameraCenter :: !Point2 - , _creatures :: IM.IntMap Creature - , _creaturesZone :: IM.IntMap (IM.IntMap (IM.IntMap Creature)) - , _itemPositions :: IM.IntMap ItemPos - , _clouds :: IM.IntMap Cloud - , _cloudsZone :: IM.IntMap (IM.IntMap (IM.IntMap Cloud)) - , _projectiles :: IM.IntMap Projectile - , _particles' :: ![Particle'] - , _walls :: !(IM.IntMap Wall) - , _wallsZone :: (IM.IntMap (IM.IntMap (IM.IntMap Wall))) - , _forceFields :: IM.IntMap ForceField - , _floorItems :: IM.IntMap FloorItem - , _randGen :: StdGen - , _mousePos :: !(Float,Float) - , _testString :: String - , _yourID :: !Int - , _worldEvents :: !(World -> World) - , _pressPlates :: IM.IntMap PressPlate - , _buttons :: IM.IntMap Button - , _soundQueue :: [Int] - , _sounds :: M.Map SoundOrigin Sound - , _decorations :: IM.IntMap Picture - , _corpses :: IM.IntMap (IM.IntMap [Corpse]) - , _lbClickMousePos :: (Float,Float) - , _lbRotation :: Float - , _pathGraph :: ~(Gr Point2 Float) - , _pathGraph' :: ~[(Point2,Point2)] - , _pathPoints :: ~(IM.IntMap (IM.IntMap [(Int,Point2)])) - , _pathInc :: ~(M.Map Point2 [Point2]) - , _storedLevel :: Maybe World - , _menuState :: MenuState - , _worldState :: M.Map WorldState Bool - , _windowX :: Float - , _windowY :: Float - , _mapDisplay :: (Bool, Float) - , _lightSources :: !(IM.IntMap LightSource) - , _tempLightSources :: ![TempLightSource] - , _closeActiveObjects :: [Either FloorItem Button] - , _seenLocations :: IM.IntMap (World -> Point2,String) --- , _remap :: Keycode -> Keycode - } + { _keys :: !(S.Set Scancode) + , _mouseButtons :: !(S.Set MouseButton) + , _cameraPos :: !Point2 + , _cameraAimTime :: Int + , _cameraRot :: !Float + , _cameraZoom :: !Float + , _cameraCenter :: !Point2 + , _creatures :: IM.IntMap Creature + , _creaturesZone :: IM.IntMap (IM.IntMap (IM.IntMap Creature)) + , _itemPositions :: IM.IntMap ItemPos + , _clouds :: IM.IntMap Cloud + , _cloudsZone :: IM.IntMap (IM.IntMap (IM.IntMap Cloud)) + , _projectiles :: IM.IntMap Projectile + , _particles' :: ![Particle'] + , _walls :: !(IM.IntMap Wall) + , _wallsZone :: (IM.IntMap (IM.IntMap (IM.IntMap Wall))) + , _forceFields :: IM.IntMap ForceField + , _floorItems :: IM.IntMap FloorItem + , _randGen :: StdGen + , _mousePos :: !(Float,Float) + , _testString :: String + , _yourID :: !Int + , _worldEvents :: !(World -> World) + , _pressPlates :: IM.IntMap PressPlate + , _buttons :: IM.IntMap Button + , _soundQueue :: [Int] + , _sounds :: M.Map SoundOrigin Sound + , _decorations :: IM.IntMap Picture + , _corpses :: IM.IntMap (IM.IntMap [Corpse]) + , _lbClickMousePos :: (Float,Float) + , _lbRotation :: Float + , _pathGraph :: ~(Gr Point2 Float) + , _pathGraph' :: ~[(Point2,Point2)] + , _pathPoints :: ~(IM.IntMap (IM.IntMap [(Int,Point2)])) + , _pathInc :: ~(M.Map Point2 [Point2]) + , _storedLevel :: Maybe World + , _menuState :: MenuState + , _worldState :: M.Map WorldState Bool + , _windowX :: !Float + , _windowY :: !Float + , _carteDisplay :: !Bool + , _carteCenter :: !Point2 + , _carteZoom :: !Float + , _carteRot :: !Float + , _lightSources :: !(IM.IntMap LightSource) + , _tempLightSources :: ![TempLightSource] + , _closeActiveObjects :: [Either FloorItem Button] + , _seenLocations :: IM.IntMap (World -> Point2,String) +-- , _remap :: Keycode -> Keycode + } data Corpse = Corpse { _cpPos :: Point2 diff --git a/src/Dodge/Event.hs b/src/Dodge/Event.hs index c3c37cc2d..bcaa007c7 100644 --- a/src/Dodge/Event.hs +++ b/src/Dodge/Event.hs @@ -56,8 +56,8 @@ handlePressedMouseButton ButtonMiddle w = Just $ set lbClickMousePos (_mousePos handlePressedMouseButton _ w = Just w wheelUpEvent :: World -> World -wheelUpEvent w = case _mapDisplay w of - (True,z) -> w & mapDisplay . _2 .~ min 0.3 (z+(0.1*z)) +wheelUpEvent w = case _carteDisplay w of + True -> w & carteZoom .~ min 0.5 (z+(0.1*z)) _ | rbPressed -> fromMaybe (closeObjScrollUp w) $ (yourItem w ^? itScrollUp) <*> pure (_crInvSel (you w)) @@ -68,18 +68,21 @@ wheelUpEvent w = case _mapDisplay w of lbPressed = ButtonLeft `S.member` mbs rbPressed = ButtonRight `S.member` mbs mbs = _mouseButtons w + z = _carteZoom w wheelDownEvent :: World -> World -wheelDownEvent w = case _mapDisplay w of - (True,z) -> w & mapDisplay . _2 .~ max 0.05 (z-(0.1*z)) +wheelDownEvent w = case _carteDisplay w of + True -> w & carteZoom .~ max 0.05 (z-(0.1*z)) _ | rbPressed -> fromMaybe (closeObjScrollDown w) $ (yourItem w ^? itScrollDown) <*> pure (_crInvSel (you w)) <*> pure w | lbPressed -> w {_cameraZoom = max (_cameraZoom w - 0.1) 0.01} | otherwise -> downInvPos w - where lbPressed = ButtonLeft `S.member` mbs - rbPressed = ButtonRight `S.member` mbs - mbs = _mouseButtons w + where + lbPressed = ButtonLeft `S.member` mbs + rbPressed = ButtonRight `S.member` mbs + mbs = _mouseButtons w + z = _carteZoom w upInvPos :: World -> World upInvPos w = stopSoundFrom (CrReloadSound 0) $ set (creatures . ix (_yourID w) . crInvSel) x w diff --git a/src/Dodge/Event/Keyboard.hs b/src/Dodge/Event/Keyboard.hs index 7052a2258..1fc9e8c34 100644 --- a/src/Dodge/Event/Keyboard.hs +++ b/src/Dodge/Event/Keyboard.hs @@ -47,8 +47,8 @@ testEvent w = w pauseGame :: World -> World pauseGame w = w {_menuState = PauseMenu} -toggleMap w = w & mapDisplay . _1 %~ not -escapeMap w = w & mapDisplay . _1 .~ False +toggleMap w = w & carteDisplay %~ not +escapeMap w = w & carteDisplay .~ False -- Basic key remapping for a dvorak key layout keyremap :: Keycode -> Keycode diff --git a/src/Dodge/Prototypes.hs b/src/Dodge/Prototypes.hs index e039abef5..01a6e8fd4 100644 --- a/src/Dodge/Prototypes.hs +++ b/src/Dodge/Prototypes.hs @@ -204,7 +204,6 @@ basicWorld = World , _pressPlates = IM.empty , _buttons = IM.empty , _soundQueue = [] --- , _loadedSounds = IM.empty , _sounds = M.empty , _corpses = IM.empty , _decorations = IM.empty @@ -219,12 +218,17 @@ basicWorld = World , _pathInc = M.empty , _windowX = 800 , _windowY = 840 - , _mapDisplay = (False, 0.2) + , _carteDisplay = False + , _carteCenter = (0,0) + , _carteZoom = 0.5 + , _carteRot = 0 , _lightSources = IM.empty , _tempLightSources = [youLight] , _closeActiveObjects = [] - , _seenLocations = IM.fromList [(0, (_crPos . you, "YOURPOS"))] --- , _remap = keyremapDefault + , _seenLocations = IM.fromList + [(0, (_crPos . you, "CURRENT POSITION")) + ,(1, (const (0,0) , "START POSITION")) + ] } youLight = -- LS {_lsEff = \w _ p -> (logistic 1 1 1 (d p w * 0.01) ) diff --git a/src/Dodge/Rendering.hs b/src/Dodge/Rendering.hs index ce36e428e..f1c250ac8 100644 --- a/src/Dodge/Rendering.hs +++ b/src/Dodge/Rendering.hs @@ -26,43 +26,25 @@ import qualified Data.Map as M import qualified Data.Set as S worldPictures :: World -> Picture -worldPictures w - = pictures $ concat [ IM.elems $ _decorations w - , map _ptPict . IM.elems $ _projectiles w - , map drawItem . IM.elems $ _floorItems w - , map crDraw . IM.elems $ _creatures w - , map clDraw . IM.elems $ _clouds w - , map btDraw (IM.elems (_buttons w)) - , map (\pt -> _ptDraw pt pt) $ _particles' w - , map drawWallFloor (wallFloorsToDraw w) - , testPic w - , mapOverlay w - ] +worldPictures w = pictures $ concat + [ IM.elems $ _decorations w + , map _ptPict . IM.elems $ _projectiles w + , map drawItem . IM.elems $ _floorItems w + , map crDraw . IM.elems $ _creatures w + , map clDraw . IM.elems $ _clouds w + , map btDraw (IM.elems (_buttons w)) + , map (\pt -> _ptDraw pt pt) $ _particles' w + , map drawWallFloor (wallFloorsToDraw w) + , testPic w + ] fixedCoordPictures :: World -> Picture fixedCoordPictures w = pictures - [ scaler $ hudDrawings w - , scaler . onLayer MenuLayer $ menuScreen w - , setDepth (-1) $ closeObjectTexts w - ] - where scaler = setDepth (-1) . scale (2 / _windowX w) (2 / _windowY w) - -mapOverlay :: World -> [Picture] -mapOverlay w = case _mapDisplay w of - (True,mapZoom) -> (setLayer 1 . setDepth (-1) . color (withAlpha 0.5 black) - . polygon $ screenPolygon w) - : - (map ( setLayer 1 . setDepth (-1) . doZoom ) - . mapMaybe mapWall - . IM.elems - $ _walls w - ) - where - doZoom = uncurry translate (_cameraPos w) - . scale zoom zoom - . uncurry translate ((0,0) -.- _cameraPos w) - zoom = 2 * mapZoom / _cameraZoom w - _ -> [] + [ hudDrawings w + , scaler . onLayer MenuLayer $ menuScreen w + ] + where + scaler = setDepth (-1) . scale (2 / _windowX w) (2 / _windowY w) testPic :: World -> [Picture] testPic w = [blank] @@ -78,17 +60,6 @@ clDraw :: Cloud -> Picture clDraw c = uncurry translate (_clPos c) $ (_clPict c c) -mapWall :: Wall -> Maybe Picture -mapWall wl = - case _wlSeen wl of - False -> Nothing - True -> Just $ color c $ polygon [x,x +.+ n2,y +.+ n2, y] - where t = 5 *.* errorNormalizeV 68 (y -.- x) - n = vNormal t - n2 = 4 *.* n - (x:y:_) = _wlLine wl - c = _wlColor wl - wallFloorsToDraw :: World -> [Wall] wallFloorsToDraw w = filter isVisible $ IM.elems $ wallsOnScreen w where onScreen wall = lineOnScreen w (_wlLine wall) diff --git a/src/Dodge/Rendering/HUD.hs b/src/Dodge/Rendering/HUD.hs index 52a12a1fe..a2eac3852 100644 --- a/src/Dodge/Rendering/HUD.hs +++ b/src/Dodge/Rendering/HUD.hs @@ -14,47 +14,100 @@ import qualified Data.IntMap as IM import Control.Lens hudDrawings :: World -> Picture -hudDrawings w = case _mapDisplay w of - (True,_) -> drawLocations w - _ -> drawInventory w +hudDrawings w = setLayer 1 . setDepth (-1) . pictures $ + [ scaler . dShadCol white $ displayHP 0 w + , scaler . translate (-390) 20 . scale 0.05 0.05 . dShadCol white $ text (_testString w) + ] + ++ selectionText + where + selectionText = if _carteDisplay w + then drawLocations w + else drawInventory w + scaler = scale (2 / _windowX w) (2 / _windowY w) -drawInventory :: World -> Picture -drawInventory w = - setLayer 1 $ (onLayer InvLayer) - $ pictures - [ displayInv 0 w - , dShadCol white $ displayHP 0 w - , drawCursor (itCol (yourItem w)) w - , translate (-390) 20 - $ scale 0.05 0.05 $ dShadCol white $ text (_testString w) - ] - where itCol = fromMaybe (greyN 0.5) . (^? itInvColor) +drawInventory :: World -> [Picture] +drawInventory w = + [ closeObjectTexts w + , scaler $ drawCursor (itCol (yourItem w)) w + ] + ++ displayInv 0 w + where + itCol = fromMaybe (greyN 0.5) . (^? itInvColor) + scaler = scale (2 / _windowX w) (2 / _windowY w) -drawLocations w = displayListTopLeft locs w - where locs = map (\(_,s) -> (s,white)) . IM.elems . _seenLocations $ w +displayListTopLeft :: [(String,Color)] -> World -> [Picture] +displayListTopLeft scols w = + map scaler $ zipWith + (translate (15-halfWidth w)) + ( map (\x -> halfHeight w - (20 * (fromIntegral x+1))) [0..] ) + ( map (\(s,col) -> scale 0.1 0.1 . dShadCol col $ text s) scols ) + where + scaler = scale (2 / _windowX w) (2 / _windowY w) -displayListTopLeft :: [(String,Color)] -> World -> Picture -displayListTopLeft scols w = pictures $ zipWith (translate (15-halfWidth w)) - ( map (\x -> halfHeight w - (20 * (fromIntegral x+1))) [0..] ) - ( map (\(s,col) -> scale 0.1 0.1 . dShadCol col $ text s) scols ) - -displayInv :: Int -> World -> Picture +displayInv :: Int -> World -> [Picture] displayInv n w = displayListTopLeft scols w - where scols = map itemStringCol . IM.elems . _crInv $ _creatures w IM.! n - ---displayInv :: Int -> World -> Picture ---displayInv n w = pictures $ zipWith (translate (15-halfWidth w)) --- (map (\x-> halfHeight w-(20*(fromIntegral x+1))) ns) $ map dItem' is --- where (ns,is) = unzip $ IM.toList $ _crInv $ _creatures w IM.! n + where + scols = map itemStringCol . IM.elems . _crInv $ _creatures w IM.! n itemStringCol :: Item -> (String,Color) -itemStringCol NoItem = ("----", greyN 0.5) -itemStringCol itm = (_itInvDisplay itm itm, _itInvColor itm) +itemStringCol NoItem = ("----", greyN 0.5) +itemStringCol itm = (_itInvDisplay itm itm, _itInvColor itm) dItem' NoItem = scale 0.1 0.1 $ dShadCol (greyN 0.5) $ text "----" dItem' i = scale 0.1 0.1 $ dShadCol (_itInvColor i) t where t = text $ _itInvDisplay i i +drawLocations :: World -> [Picture] +drawLocations w = displayListTopLeft locs w + ++ zipWith bFunc (displayListEndCoords w locTexts) locPoss + ++ mapOverlay w + where + locs = map (\(_,s) -> (s,white)) . IM.elems . _seenLocations $ w + locPoss = map (cartePosToScreen w . ($ w) . fst) . IM.elems . _seenLocations $ w + zoom = _carteZoom w + locTexts = fst . unzip $ locs + bFunc (x,y) (z,w) = pictures + --[ bezierQuad (withAlpha 0.2 white) (withAlpha 0.2 white) 0.01 0.01 (x,y) (0,y) (z,w) + --, bezierQuad (withAlpha 0.5 white) (withAlpha 0.5 white) 0.005 0.005 (x,y) (0,y) (z,w) + --, bezierQuad (withAlpha 0.5 white) (withAlpha 0.5 white) 0.002 0.002 (x,y) (0,y) (z,w) + [ bezierQuad (withAlpha 0.0 white) (withAlpha 0.2 white) 0.050 0.010 (x,y) (0,y) (z,w) + , bezierQuad (withAlpha 0.0 white) (withAlpha 0.5 white) 0.045 0.005 (x,y) (0,y) (z,w) + , bezierQuad (withAlpha 0.0 white) (withAlpha 0.5 white) 0.035 0.002 (x,y) (0,y) (z,w) + ] --cheapo antialiasing + +displayListCoords :: World -> [Point2] +displayListCoords w = map (g . f) [1..] + where + f i = ( 15 - halfWidth w , halfHeight w - (20 * fromIntegral i) ) + g (x,y) = (2*x / _windowX w, 2*y / _windowY w) + +displayListEndCoords :: World -> [String] -> [Point2] +displayListEndCoords w ss = map g $ zipWith h ss $ map f [1..] + where + f :: Int -> Point2 + f i = ( 15 - halfWidth w , 2.5 + halfHeight w - (20 * fromIntegral i) ) + g (x,y) = (2*x / _windowX w, 2*y / _windowY w) + h :: String -> Point2 -> Point2 + h s (x,y) = (x + 9 * fromIntegral (length s), y) + +--bezierQuad :: Color -> Color -> Float -> Float -> Point2 -> Point2 -> Point2 -> Picture + +mapOverlay :: World -> [Picture] +mapOverlay w = (color (withAlpha 0.5 black) . polygon $ rectNSEW 1 (-1) (-1) 1) : + (mapMaybe (mapWall w) . IM.elems $ _walls w) + +mapWall :: World -> Wall -> Maybe Picture +mapWall w wl = + if _wlSeen wl + then Just . color c . polygon $ map (cartePosToScreen w) [x,x +.+ n2,y +.+ n2, y] + else Nothing + where + t = normalizeV (y -.- x) + n2 = 20 *.* vNormal t + (x:y:_) = (_wlLine wl) + c = _wlColor wl + + closeObjectTexts :: World -> Picture closeObjectTexts w = pictures $ (zipWith renderList [0..] $ map colAndText $ _closeActiveObjects w) ++ maybeToList maybeLine @@ -80,13 +133,7 @@ closeObjectTexts w = pictures $ (zipWith renderList [0..] $ map colAndText $ _cl xtran _ = 0 objPos obj = case obj of Left flit -> _flItPos flit Right bt -> _btPos bt - mayScreenPos = mayObj >>= (\theObj -> - Just (sc $ rotateV (0 - _cameraRot w) - $ _cameraZoom w *.* (objPos theObj - -.- _cameraPos w - ) - ) - ) + mayScreenPos = mayObj >>= (\theObj -> Just (worldPosToScreen w $ objPos theObj)) sc (x, y) = (x*2/_windowX w, y*2/_windowY w) maybeLine = do itScreenPos <- mayScreenPos