justin/loop
1
0
Fork 0
Code Issues Pull Requests 1 Packages Projects Releases Wiki Activity

Refactor map, add location arrows

Browse Source
This commit is contained in:
justin
2021-03-26 03:13:18 +01:00
parent d79a8a862e
commit b46adf9898
8 changed files with 192 additions and 144 deletions
Download Patch File Download Diff File Expand all files Collapse all files
app/Main.hs
+2 -2
View File
@@ -65,8 +65,8 @@ main = do
let lastFrameTicks = _frameTimer preData let lastFrameTicks = _frameTimer preData
renderFoldable (_renderData preData) renderFoldable (_renderData preData)
(picToLTree Nothing . setLayer 1 . setDepth (-1) (picToLTree Nothing . setLayer 1 . setDepth (-1)
. translate 0 (-0.8) . scale 0.0005 0.0005 . translate (-0.5) (-0.8) . scale 0.0005 0.0005
. text $ show (endTicks - lastFrameTicks)) . text $ "ms/frame " ++ show (endTicks - lastFrameTicks))
return $ preData & soundData .~ newSoundData return $ preData & soundData .~ newSoundData
& frameTimer .~ endTicks & frameTimer .~ endTicks
) )
src/Dodge/Base.hs
+20
View File
@@ -728,6 +728,26 @@ levLayer LabelLayer = 80
levLayer InvLayer = 85 levLayer InvLayer = 85
levLayer MenuLayer = 90 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 :: World -> Point2
mouseWorldPos w = _cameraPos w +.+ (1/_cameraZoom w) *.* rotateV (_cameraRot w) (_mousePos w) mouseWorldPos w = _cameraPos w +.+ (1/_cameraZoom w) *.* rotateV (_cameraRot w) (_mousePos w)
src/Dodge/Data.hs
+50 -47
View File
@@ -36,53 +36,56 @@ import qualified Data.DList as DL
--}}} --}}}
-- datatypes {{{ -- datatypes {{{
data World = World data World = World
{ _keys :: !(S.Set Scancode) { _keys :: !(S.Set Scancode)
, _mouseButtons :: !(S.Set MouseButton) , _mouseButtons :: !(S.Set MouseButton)
, _cameraPos :: !Point2 , _cameraPos :: !Point2
, _cameraAimTime :: Int , _cameraAimTime :: Int
, _cameraRot :: !Float , _cameraRot :: !Float
, _cameraZoom :: !Float , _cameraZoom :: !Float
, _cameraCenter :: !Point2 , _cameraCenter :: !Point2
, _creatures :: IM.IntMap Creature , _creatures :: IM.IntMap Creature
, _creaturesZone :: IM.IntMap (IM.IntMap (IM.IntMap Creature)) , _creaturesZone :: IM.IntMap (IM.IntMap (IM.IntMap Creature))
, _itemPositions :: IM.IntMap ItemPos , _itemPositions :: IM.IntMap ItemPos
, _clouds :: IM.IntMap Cloud , _clouds :: IM.IntMap Cloud
, _cloudsZone :: IM.IntMap (IM.IntMap (IM.IntMap Cloud)) , _cloudsZone :: IM.IntMap (IM.IntMap (IM.IntMap Cloud))
, _projectiles :: IM.IntMap Projectile , _projectiles :: IM.IntMap Projectile
, _particles' :: ![Particle'] , _particles' :: ![Particle']
, _walls :: !(IM.IntMap Wall) , _walls :: !(IM.IntMap Wall)
, _wallsZone :: (IM.IntMap (IM.IntMap (IM.IntMap Wall))) , _wallsZone :: (IM.IntMap (IM.IntMap (IM.IntMap Wall)))
, _forceFields :: IM.IntMap ForceField , _forceFields :: IM.IntMap ForceField
, _floorItems :: IM.IntMap FloorItem , _floorItems :: IM.IntMap FloorItem
, _randGen :: StdGen , _randGen :: StdGen
, _mousePos :: !(Float,Float) , _mousePos :: !(Float,Float)
, _testString :: String , _testString :: String
, _yourID :: !Int , _yourID :: !Int
, _worldEvents :: !(World -> World) , _worldEvents :: !(World -> World)
, _pressPlates :: IM.IntMap PressPlate , _pressPlates :: IM.IntMap PressPlate
, _buttons :: IM.IntMap Button , _buttons :: IM.IntMap Button
, _soundQueue :: [Int] , _soundQueue :: [Int]
, _sounds :: M.Map SoundOrigin Sound , _sounds :: M.Map SoundOrigin Sound
, _decorations :: IM.IntMap Picture , _decorations :: IM.IntMap Picture
, _corpses :: IM.IntMap (IM.IntMap [Corpse]) , _corpses :: IM.IntMap (IM.IntMap [Corpse])
, _lbClickMousePos :: (Float,Float) , _lbClickMousePos :: (Float,Float)
, _lbRotation :: Float , _lbRotation :: Float
, _pathGraph :: ~(Gr Point2 Float) , _pathGraph :: ~(Gr Point2 Float)
, _pathGraph' :: ~[(Point2,Point2)] , _pathGraph' :: ~[(Point2,Point2)]
, _pathPoints :: ~(IM.IntMap (IM.IntMap [(Int,Point2)])) , _pathPoints :: ~(IM.IntMap (IM.IntMap [(Int,Point2)]))
, _pathInc :: ~(M.Map Point2 [Point2]) , _pathInc :: ~(M.Map Point2 [Point2])
, _storedLevel :: Maybe World , _storedLevel :: Maybe World
, _menuState :: MenuState , _menuState :: MenuState
, _worldState :: M.Map WorldState Bool , _worldState :: M.Map WorldState Bool
, _windowX :: Float , _windowX :: !Float
, _windowY :: Float , _windowY :: !Float
, _mapDisplay :: (Bool, Float) , _carteDisplay :: !Bool
, _lightSources :: !(IM.IntMap LightSource) , _carteCenter :: !Point2
, _tempLightSources :: ![TempLightSource] , _carteZoom :: !Float
, _closeActiveObjects :: [Either FloorItem Button] , _carteRot :: !Float
, _seenLocations :: IM.IntMap (World -> Point2,String) , _lightSources :: !(IM.IntMap LightSource)
-- , _remap :: Keycode -> Keycode , _tempLightSources :: ![TempLightSource]
} , _closeActiveObjects :: [Either FloorItem Button]
, _seenLocations :: IM.IntMap (World -> Point2,String)
-- , _remap :: Keycode -> Keycode
}
data Corpse = Corpse data Corpse = Corpse
{ _cpPos :: Point2 { _cpPos :: Point2
src/Dodge/Event.hs
+10 -7
View File
@@ -56,8 +56,8 @@ handlePressedMouseButton ButtonMiddle w = Just $ set lbClickMousePos (_mousePos
handlePressedMouseButton _ w = Just w handlePressedMouseButton _ w = Just w
wheelUpEvent :: World -> World wheelUpEvent :: World -> World
wheelUpEvent w = case _mapDisplay w of wheelUpEvent w = case _carteDisplay w of
(True,z) -> w & mapDisplay . _2 .~ min 0.3 (z+(0.1*z)) True -> w & carteZoom .~ min 0.5 (z+(0.1*z))
_ | rbPressed -> fromMaybe (closeObjScrollUp w) _ | rbPressed -> fromMaybe (closeObjScrollUp w)
$ (yourItem w ^? itScrollUp) $ (yourItem w ^? itScrollUp)
<*> pure (_crInvSel (you w)) <*> pure (_crInvSel (you w))
@@ -68,18 +68,21 @@ wheelUpEvent w = case _mapDisplay w of
lbPressed = ButtonLeft `S.member` mbs lbPressed = ButtonLeft `S.member` mbs
rbPressed = ButtonRight `S.member` mbs rbPressed = ButtonRight `S.member` mbs
mbs = _mouseButtons w mbs = _mouseButtons w
z = _carteZoom w
wheelDownEvent :: World -> World wheelDownEvent :: World -> World
wheelDownEvent w = case _mapDisplay w of wheelDownEvent w = case _carteDisplay w of
(True,z) -> w & mapDisplay . _2 .~ max 0.05 (z-(0.1*z)) True -> w & carteZoom .~ max 0.05 (z-(0.1*z))
_ | rbPressed -> fromMaybe (closeObjScrollDown w) _ | rbPressed -> fromMaybe (closeObjScrollDown w)
$ (yourItem w ^? itScrollDown) $ (yourItem w ^? itScrollDown)
<*> pure (_crInvSel (you w)) <*> pure (_crInvSel (you w))
<*> pure w <*> pure w
| lbPressed -> w {_cameraZoom = max (_cameraZoom w - 0.1) 0.01} | lbPressed -> w {_cameraZoom = max (_cameraZoom w - 0.1) 0.01}
| otherwise -> downInvPos w | otherwise -> downInvPos w
where lbPressed = ButtonLeft `S.member` mbs where
rbPressed = ButtonRight `S.member` mbs lbPressed = ButtonLeft `S.member` mbs
mbs = _mouseButtons w rbPressed = ButtonRight `S.member` mbs
mbs = _mouseButtons w
z = _carteZoom w
upInvPos :: World -> World upInvPos :: World -> World
upInvPos w = stopSoundFrom (CrReloadSound 0) $ set (creatures . ix (_yourID w) . crInvSel) x w upInvPos w = stopSoundFrom (CrReloadSound 0) $ set (creatures . ix (_yourID w) . crInvSel) x w
src/Dodge/Event/Keyboard.hs
+2 -2
View File
@@ -47,8 +47,8 @@ testEvent w = w
pauseGame :: World -> World pauseGame :: World -> World
pauseGame w = w {_menuState = PauseMenu} pauseGame w = w {_menuState = PauseMenu}
toggleMap w = w & mapDisplay . _1 %~ not toggleMap w = w & carteDisplay %~ not
escapeMap w = w & mapDisplay . _1 .~ False escapeMap w = w & carteDisplay .~ False
-- Basic key remapping for a dvorak key layout -- Basic key remapping for a dvorak key layout
keyremap :: Keycode -> Keycode keyremap :: Keycode -> Keycode
src/Dodge/Prototypes.hs
+8 -4
View File
@@ -204,7 +204,6 @@ basicWorld = World
, _pressPlates = IM.empty , _pressPlates = IM.empty
, _buttons = IM.empty , _buttons = IM.empty
, _soundQueue = [] , _soundQueue = []
-- , _loadedSounds = IM.empty
, _sounds = M.empty , _sounds = M.empty
, _corpses = IM.empty , _corpses = IM.empty
, _decorations = IM.empty , _decorations = IM.empty
@@ -219,12 +218,17 @@ basicWorld = World
, _pathInc = M.empty , _pathInc = M.empty
, _windowX = 800 , _windowX = 800
, _windowY = 840 , _windowY = 840
, _mapDisplay = (False, 0.2) , _carteDisplay = False
, _carteCenter = (0,0)
, _carteZoom = 0.5
, _carteRot = 0
, _lightSources = IM.empty , _lightSources = IM.empty
, _tempLightSources = [youLight] , _tempLightSources = [youLight]
, _closeActiveObjects = [] , _closeActiveObjects = []
, _seenLocations = IM.fromList [(0, (_crPos . you, "YOURPOS"))] , _seenLocations = IM.fromList
-- , _remap = keyremapDefault [(0, (_crPos . you, "CURRENT POSITION"))
,(1, (const (0,0) , "START POSITION"))
]
} }
youLight = youLight =
-- LS {_lsEff = \w _ p -> (logistic 1 1 1 (d p w * 0.01) ) -- LS {_lsEff = \w _ p -> (logistic 1 1 1 (d p w * 0.01) )
src/Dodge/Rendering.hs
+16 -45
View File
@@ -26,43 +26,25 @@ import qualified Data.Map as M
import qualified Data.Set as S import qualified Data.Set as S
worldPictures :: World -> Picture worldPictures :: World -> Picture
worldPictures w worldPictures w = pictures $ concat
= pictures $ concat [ IM.elems $ _decorations w [ IM.elems $ _decorations w
, map _ptPict . IM.elems $ _projectiles w , map _ptPict . IM.elems $ _projectiles w
, map drawItem . IM.elems $ _floorItems w , map drawItem . IM.elems $ _floorItems w
, map crDraw . IM.elems $ _creatures w , map crDraw . IM.elems $ _creatures w
, map clDraw . IM.elems $ _clouds w , map clDraw . IM.elems $ _clouds w
, map btDraw (IM.elems (_buttons w)) , map btDraw (IM.elems (_buttons w))
, map (\pt -> _ptDraw pt pt) $ _particles' w , map (\pt -> _ptDraw pt pt) $ _particles' w
, map drawWallFloor (wallFloorsToDraw w) , map drawWallFloor (wallFloorsToDraw w)
, testPic w , testPic w
, mapOverlay w ]
]
fixedCoordPictures :: World -> Picture fixedCoordPictures :: World -> Picture
fixedCoordPictures w = pictures fixedCoordPictures w = pictures
[ scaler $ hudDrawings w [ hudDrawings w
, scaler . onLayer MenuLayer $ menuScreen w , scaler . onLayer MenuLayer $ menuScreen w
, setDepth (-1) $ closeObjectTexts w ]
] where
where scaler = setDepth (-1) . scale (2 / _windowX w) (2 / _windowY w) 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
_ -> []
testPic :: World -> [Picture] testPic :: World -> [Picture]
testPic w = [blank] testPic w = [blank]
@@ -78,17 +60,6 @@ clDraw :: Cloud -> Picture
clDraw c = uncurry translate (_clPos c) $ (_clPict c c) 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 :: World -> [Wall]
wallFloorsToDraw w = filter isVisible $ IM.elems $ wallsOnScreen w wallFloorsToDraw w = filter isVisible $ IM.elems $ wallsOnScreen w
where onScreen wall = lineOnScreen w (_wlLine wall) where onScreen wall = lineOnScreen w (_wlLine wall)
src/Dodge/Rendering/HUD.hs
+83 -36
View File
@@ -14,47 +14,100 @@ import qualified Data.IntMap as IM
import Control.Lens import Control.Lens
hudDrawings :: World -> Picture hudDrawings :: World -> Picture
hudDrawings w = case _mapDisplay w of hudDrawings w = setLayer 1 . setDepth (-1) . pictures $
(True,_) -> drawLocations w [ scaler . dShadCol white $ displayHP 0 w
_ -> drawInventory 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 :: World -> [Picture]
drawInventory w = drawInventory w =
setLayer 1 $ (onLayer InvLayer) [ closeObjectTexts w
$ pictures , scaler $ drawCursor (itCol (yourItem w)) w
[ displayInv 0 w ]
, dShadCol white $ displayHP 0 w ++ displayInv 0 w
, drawCursor (itCol (yourItem w)) w where
, translate (-390) 20 itCol = fromMaybe (greyN 0.5) . (^? itInvColor)
$ scale 0.05 0.05 $ dShadCol white $ text (_testString w) scaler = scale (2 / _windowX w) (2 / _windowY w)
]
where itCol = fromMaybe (greyN 0.5) . (^? itInvColor)
drawLocations w = displayListTopLeft locs w displayListTopLeft :: [(String,Color)] -> World -> [Picture]
where locs = map (\(_,s) -> (s,white)) . IM.elems . _seenLocations $ w 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 displayInv :: Int -> 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 n w = displayListTopLeft scols w displayInv n w = displayListTopLeft scols w
where scols = map itemStringCol . IM.elems . _crInv $ _creatures w IM.! n 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
itemStringCol :: Item -> (String,Color) itemStringCol :: Item -> (String,Color)
itemStringCol NoItem = ("----", greyN 0.5) itemStringCol NoItem = ("----", greyN 0.5)
itemStringCol itm = (_itInvDisplay itm itm, _itInvColor itm) itemStringCol itm = (_itInvDisplay itm itm, _itInvColor itm)
dItem' NoItem = scale 0.1 0.1 $ dShadCol (greyN 0.5) $ text "----" dItem' NoItem = scale 0.1 0.1 $ dShadCol (greyN 0.5) $ text "----"
dItem' i = scale 0.1 0.1 $ dShadCol (_itInvColor i) t dItem' i = scale 0.1 0.1 $ dShadCol (_itInvColor i) t
where t = text $ _itInvDisplay i i 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 :: World -> Picture
closeObjectTexts w = pictures $ (zipWith renderList [0..] $ map colAndText $ _closeActiveObjects w) closeObjectTexts w = pictures $ (zipWith renderList [0..] $ map colAndText $ _closeActiveObjects w)
++ maybeToList maybeLine ++ maybeToList maybeLine
@@ -80,13 +133,7 @@ closeObjectTexts w = pictures $ (zipWith renderList [0..] $ map colAndText $ _cl
xtran _ = 0 xtran _ = 0
objPos obj = case obj of Left flit -> _flItPos flit objPos obj = case obj of Left flit -> _flItPos flit
Right bt -> _btPos bt Right bt -> _btPos bt
mayScreenPos = mayObj >>= (\theObj -> mayScreenPos = mayObj >>= (\theObj -> Just (worldPosToScreen w $ objPos theObj))
Just (sc $ rotateV (0 - _cameraRot w)
$ _cameraZoom w *.* (objPos theObj
-.- _cameraPos w
)
)
)
sc (x, y) = (x*2/_windowX w, y*2/_windowY w) sc (x, y) = (x*2/_windowX w, y*2/_windowY w)
maybeLine = do maybeLine = do
itScreenPos <- mayScreenPos itScreenPos <- mayScreenPos