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:
jgk
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
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
)
src/Dodge/Base.hs
+20
View File
@@ -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)
src/Dodge/Data.hs
+50 -47
View File
@@ -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
src/Dodge/Event.hs
+10 -7
View File
@@ -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
src/Dodge/Event/Keyboard.hs
+2 -2
View File
@@ -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
src/Dodge/Prototypes.hs
+8 -4
View File
@@ -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) )
src/Dodge/Rendering.hs
+16 -45
View File
@@ -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)
src/Dodge/Rendering/HUD.hs
+84 -37
View File
@@ -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