This commit is contained in:
2025-09-19 20:39:17 +01:00
parent d4f2cdd3fd
commit b837e6a798
9 changed files with 268 additions and 345 deletions
+2 -35
View File
@@ -1,5 +1,4 @@
module Dodge.Base.Coordinate (
cartePosToScreen,
worldPosToScreen,
screenToWorldPos,
mouseWorldPos,
@@ -7,18 +6,9 @@ module Dodge.Base.Coordinate (
import Control.Lens
import Dodge.Data.Camera
import Dodge.Data.HUD
import Dodge.Data.Input
import Geometry
---- | Transform coordinates from world position to screen coordinates.
--worldPosToScreenNorm :: Config -> World -> Point2 -> Point2
--worldPosToScreenNorm cfig w = doWindowScale cfig . doRotate . doZoom . doTranslate
-- where
-- doTranslate p = p -.- (w ^. cWorld . lWorld . wCam . cwcCenter)
-- doZoom p = (w ^. cWorld . lWorld . wCam . cwcZoom) *.* p
-- doRotate p = rotateV (negate (w ^. cWorld . lWorld . wCam . cwcRot)) p
{- | Transform world coordinates to scaled screen coordinates.
- These have to be scaled according to the size of the window to get actual screen positions.
- This allows for line thicknesses etc to correspond to pixel sizes.
@@ -31,33 +21,10 @@ worldPosToScreen cam =
. ((cam ^. camZoom) *.*)
. (-.- (cam ^. camCenter))
{- | Transform coordinates from the map position to screen
coordinates.
-}
cartePosToScreen :: HUD -> Point2 -> Point2
cartePosToScreen thehud = doRotate . doZoom . doTranslate
where
doTranslate p = p - (thehud ^. carteCenter) -- _carteCenter (_hud (_cWorld w))
doZoom p = (thehud ^. carteZoom) *.* p
doRotate p = rotateV (negate $ thehud ^. carteRot) p
--crToMousePosOffset :: Creature -> World -> (Point2, Float)
--crToMousePosOffset cr w = (mouseWorldPos w -.- _crPos cr, 0)
-- | The mouse position in world coordinates.
mouseWorldPos :: Input -> Camera -> Point2
mouseWorldPos inp cam = screenToWorldPos cam (inp ^. mousePos)
screenToWorldPos :: Camera -> Point2 -> Point2
screenToWorldPos cam p =
(cam ^. camCenter)
+ (1 / (cam ^. camZoom)) *.* rotateV (cam ^. camRot) p
---- | The mouse position in map coordinates
--mouseCartePos :: World -> Point2
--mouseCartePos w = (thehud ^. carteCenter)
-- +.+
-- (1 / (thehud ^. carteZoom))
-- *.* rotateV (thehud ^. carteRot) (_mousePos w)
-- where
-- thehud = w ^. cWorld . lWorld . hud
screenToWorldPos cam p =
(cam ^. camCenter) + (1 / (cam ^. camZoom)) *.* rotateV (cam ^. camRot) p
-3
View File
@@ -34,9 +34,6 @@ data HUD = HUD
, _diSelection :: Maybe Selection
, _diInvFilter :: Maybe String
, _diCloseFilter :: Maybe String
, _carteCenter :: Point2
, _carteZoom :: Float
, _carteRot :: Float
, _closeItems :: [NewInt ItmInt]
, _closeButtons :: [Int]
}
+2 -2
View File
@@ -17,7 +17,7 @@ data ListDisplayParams = ListDisplayParams
}
data CursorDisplay
= BoundaryCursor {_cursSides :: [CardinalPoint]}
= BoundaryCursor [CardinalPoint]
| BackdropCursor
data SectionCursor = SectionCursor
@@ -53,4 +53,4 @@ makeLenses ''ListDisplayParams
makeLenses ''SelectionItem
makeLenses ''SelSection
makeLenses ''SectionCursor
makeLenses ''CursorDisplay
makePrisms ''CursorDisplay
-3
View File
@@ -164,9 +164,6 @@ defaultHUD =
, _diSelection = Just (Sel 1 0 mempty)
, _diInvFilter = mempty
, _diCloseFilter = mempty
, _carteCenter = V2 0 0
, _carteZoom = 0.5
, _carteRot = 0
, _closeItems = mempty
, _closeButtons = mempty
}
+9 -15
View File
@@ -11,29 +11,23 @@ import Dodge.Render.List
import Dodge.ScreenPos
import Picture
drawMenuScreen :: Config -> Maybe Int -> ScreenLayer -> Picture
drawMenuScreen cf mi = \case
OptionScreen{_scTitle = s, _scSelectionList = l} -> drawOptions cf s mi l
InputScreen inputstr -> drawInputMenu cf ('>' : inputstr)
drawMenuScreen :: Maybe Int -> ScreenLayer -> Config -> Picture
drawMenuScreen mi = \case
OptionScreen{_scTitle = s, _scSelectionList = l} -> drawOptions s mi l
InputScreen inputstr -> drawInputMenu ('>' : inputstr)
drawInputMenu :: Config -> String -> Picture
drawInputMenu cf s = darkenBackground cf <> drawTitle cf s
drawInputMenu :: String -> Config -> Picture
drawInputMenu s cf = darkenBackground cf <> drawTitle cf s
drawOptions :: Config -> String -> Maybe Int -> [SelectionItem a] -> Picture
drawOptions cf title msel sl =
drawOptions :: String -> Maybe Int -> [SelectionItem a] -> Config -> Picture
drawOptions title msel sl cf =
darkenBackground cf
<> drawTitle cf title
<> drawSelectionList menuLDP cf sl
<> translateScreenPos
cf
(menuLDP ^. ldpPos)
( drawCursorAt
msel
sl
menuLDP
50
(BoundaryCursor [North, South])
)
(drawCursorAt msel sl menuLDP 50 (BoundaryCursor [North, South]))
darkenBackground :: Config -> Picture
darkenBackground = color (withAlpha 0.5 black) . polygon . reverse . screenBox
+36 -44
View File
@@ -1,7 +1,6 @@
{-# LANGUAGE LambdaCase #-}
module Dodge.Render.Picture (
fixedCoordPictures,
) where
module Dodge.Render.Picture (fixedCoordPictures) where
import Control.Lens
import Data.Maybe
@@ -62,18 +61,18 @@ fpsText x = color col . text $ "ms/frame " ++ show x
| otherwise = red
drawMenuOrHUD :: Config -> Universe -> Picture
drawMenuOrHUD cfig u = case u ^. uvScreenLayers of
drawMenuOrHUD cf u = case u ^. uvScreenLayers of
[] -> drawHUD (u ^. uvConfig) (u ^. uvWorld)
(x : _) -> drawMenuScreen cfig (u ^? uvWorld . input . mouseContext . mcoMenuClick) x
(x : _) -> drawMenuScreen (u ^? uvWorld . input . mouseContext . mcoMenuClick) x cf
drawConcurrentMessage :: Universe -> Picture
drawConcurrentMessage u =
translate 0 (50 - halfHeight cfig)
translate 0 (50 - halfHeight cf)
. stackPicturesAt
. map (centerText . f)
$ u ^.. uvSideEffects . each
where
cfig = _uvConfig u
cf = _uvConfig u
f (RunningSideEffect ce) = ce ++ " IN PROGRESS"
f x = _ceString x ++ " QUEUED"
@@ -131,43 +130,32 @@ drawCursorByTerminalStatus = \case
_ -> drawEmptySet 5
drawQuitTerminal :: Float -> Picture
drawQuitTerminal x = fold
[ line [V2 x x, V2 (- x) (- x)]
, line [V2 x (-x), V2 (- x) x]
, polygonWire (square x)
]
drawQuitTerminal x =
line [V2 x x, V2 (- x) (- x)]
<> line [V2 x (- x), V2 (- x) x]
<> polygonWire (square x)
drawEmptySet :: Float -> Picture
drawEmptySet x =
fold
[ line [V2 x x, V2 (- x) (- x)]
, circle x
]
drawEmptySet x = line [V2 x x, V2 (- x) (- x)] <> circle x
drawReturn :: Float -> Picture
drawReturn x =
fold
[ line [V2 0 0, V2 y y]
, line [V2 0 0, V2 y (- y)]
, line [V2 0 0, V2 (2 * y) 0]
, line [V2 (2 * y) 0, V2 (2 * y) (2 * x)]
]
line [V2 0 0, V2 y y]
<> line [V2 0 0, V2 y (- y)]
<> line [V2 0 0, V2 (2 * y) 0]
<> line [V2 (2 * y) 0, V2 (2 * y) (2 * x)]
where
y = 0.7 * x
--drawReturn = scale 0.1 0.1 . translate (-50) (-100) $ text [toEnum 153]
drawPlus :: Float -> Picture
drawPlus x = fold [line [V2 (- x) 0, V2 x 0], line [V2 0 (- x), V2 0 x]]
drawMenuClick :: Float -> Picture
drawMenuClick z =
fold
[ line [V2 y 0, V2 x 0]
, line [V2 ny 0, V2 nx 0]
, line [V2 0 ny, V2 0 nx]
, line [V2 0 y, V2 0 x]
]
line [V2 y 0, V2 x 0]
<> line [V2 ny 0, V2 nx 0]
<> line [V2 0 ny, V2 0 nx]
<> line [V2 0 y, V2 0 x]
where
x = 0.5 * z
y = x + z
@@ -176,12 +164,10 @@ drawMenuClick z =
drawMenuCursor :: Float -> Picture
drawMenuCursor z =
fold
[ line [V2 y 0, V2 x 0]
, line [V2 ny 0, V2 nx 0]
, line [V2 0 ny, V2 0 nx]
, line [V2 0 y, V2 0 x]
]
line [V2 y 0, V2 x 0]
<> line [V2 ny 0, V2 nx 0]
<> line [V2 0 ny, V2 0 nx]
<> line [V2 0 y, V2 0 x]
where
x = z
y = x + z
@@ -278,12 +264,10 @@ drawCombFilter x =
drawGapPlus :: Float -> Picture
drawGapPlus x =
fold
[ line [V2 (-1.5 * x) 0, V2 (-0.5 * x) 0]
, line [V2 (0.5 * x) 0, V2 (1.5 * x) 0]
, line [V2 (0.5 * x) (- x), V2 (0.5 * x) x]
, line [V2 (-0.5 * x) (- x), V2 (-0.5 * x) x]
]
line [V2 (-1.5 * x) 0, V2 (-0.5 * x) 0]
<> line [V2 (0.5 * x) 0, V2 (1.5 * x) 0]
<> line [V2 (0.5 * x) (- x), V2 (0.5 * x) x]
<> line [V2 (-0.5 * x) (- x), V2 (-0.5 * x) x]
aimDelaySweep :: Universe -> Picture
aimDelaySweep u = fold $ do
@@ -297,7 +281,15 @@ drawAimSweep cr w = fold $ do
a <- safeArgV (mwp -.- p)
return $
uncurryV translate (worldPosToScreen campos p) $
arcFull (a - rot) 10 white (a + diffAngles cdir a - rot) 1 white (5 + dist mwp p * campos ^. camZoom) white
arcFull
(a - rot)
10
white
(a + diffAngles cdir a - rot)
1
white
(5 + dist mwp p * campos ^. camZoom)
white
where
cdir = _crDir cr
rot = campos ^. camRot
+8 -31
View File
@@ -1,10 +1,4 @@
--{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE LambdaCase #-}
{- |
Module : Dodge.Update
Description : Simulation update
-}
module Dodge.Update (updateUniverse) where
import Color
@@ -37,7 +31,6 @@ import Dodge.Laser.Update
import Dodge.LinearShockwave.Update
import Dodge.ListDisplayParams
import Dodge.Machine.Update
--import Dodge.Menu
import Dodge.ModificationEffect
import Dodge.PressPlate
import Dodge.Projectile.Update
@@ -161,18 +154,14 @@ updateUniverseLast u =
updateUniverseMid :: Universe -> Universe
updateUniverseMid u = case _uvScreenLayers u of
(OptionScreen{_scOptionFlag = LoadingScreen} : _) -> u
-- (sl@OptionScreen{_scOptionFlag = GameOverOptions} : _) -> u & updateUseInputOnScreen sl
(sl : _) -> u & uvWorld . unpauseClock .~ 0 & updateUseInputOnScreen sl
[] ->
(uvWorld . unpauseClock +~ 1)
. timeFlowUpdate
. updateUseInputInGame
. over
uvWorld
(updateMouseInGame (u ^. uvConfig))
$ over
uvWorld
(updateCamera (u ^. uvConfig))
(updateMouseInGame (u ^. uvConfig) . (updateCamera (u ^. uvConfig)))
u
timeFlowUpdate :: Universe -> Universe
@@ -184,12 +173,11 @@ timeFlowUpdate u = case u ^. uvWorld . timeFlow of
over uvWorld (doTimeScroll smoothing) u
CameraScrollTimeFlow{} -> u
RewindLeftClick 0 _ -> u & uvWorld . timeFlow .~ NormalTimeFlow
RewindLeftClick _ _ -> over uvWorld scrollTimeBack u -- & uvWorld . cWorld . timeFlow .~ NormalTimeFlow
RewindLeftClick _ _ -> over uvWorld scrollTimeBack u
RespawnDelay{} -> functionalUpdate u
PausedTimeFlow _ itmloc -> over uvWorld (pauseTime itmloc) u
pauseTime :: NewInt ItmInt -> World -> World
--pauseTime itmloc w
pauseTime _ w
-- | justPressedButtonLeft || outofcharge = w & timeFlow .~ NormalTimeFlow
| justPressedButtonLeft = w & timeFlow .~ NormalTimeFlow
@@ -228,16 +216,10 @@ scrollTimeBack w = case w ^? pastWorlds . _head of
& mupdateitem x
_ -> w
where
--mupdateitem x = fromMaybe id $ do
mupdateitem _ = fromMaybe id $ do
--i <- w ^? timeFlow . scrollItemID . unNInt
_ <- w ^? timeFlow . scrollItemID . unNInt
-- let pointituse = pointerToItemLocation (w ^?! cWorld . lWorld . itemLocations . ix i) . itUse
return id
-- (pointituse . leftConsumption . wpCharge .~ (x -1))
-- . (pointituse . leftHammer .~ HammerDown)
scrollTimeForward :: World -> World
scrollTimeForward w = case w ^? timeFlow . futureWorlds . _head of
Nothing -> w
@@ -250,9 +232,8 @@ scrollTimeForward w = case w ^? timeFlow . futureWorlds . _head of
where
ramount = (w ^?! timeFlow . reverseAmount) + 1
mupdateitem = fromMaybe id $ do
--i <- w ^? timeFlow . scrollItemID . unNInt
_ <- w ^? timeFlow . scrollItemID . unNInt
return id -- pointerToItemLocation (w ^?! cWorld . lWorld . itemLocations . ix i) . itUse . leftConsumption . wpCharge .~ ramount
return id
-- | The update step.
functionalUpdate :: Universe -> Universe
@@ -477,7 +458,8 @@ pbFlicker pt =
d = 4 * fromIntegral (10 + abs ((_pbTimer pt `mod` 20) - 10))
zoneClouds :: World -> World
zoneClouds w = w & clZoning .~ foldl' (flip zoneCloud) mempty (w ^. cWorld . lWorld . clouds)
zoneClouds w = w
& clZoning .~ foldl' (flip zoneCloud) mempty (w ^. cWorld . lWorld . clouds)
zoneDusts :: World -> World
zoneDusts w = w & dsZoning .~ foldl' (flip zoneDust) mempty (w ^. cWorld . lWorld . dusts)
@@ -533,13 +515,9 @@ updateCreatureSoundPositions w =
updateIMl :: (World -> IM.IntMap a) -> (a -> a -> World -> World) -> World -> World
updateIMl fim fup w = alaf Endo foldMap (dbArg fup) (fim w) w
--updateIMl fim fup w = foldl' (flip $ dbArg fup) w (fim w)
updateIMl' :: (World -> IM.IntMap a) -> (a -> World -> World) -> World -> World
updateIMl' fim fup w = alaf Endo foldMap fup (fim w) w
--updateIMl' fim fup w = foldl' (flip fup) w (fim w)
updateCreatureGroups :: World -> World
updateCreatureGroups w =
w & cWorld . lWorld . creatureGroups
@@ -867,13 +845,12 @@ dustSpringVel a v b
radDist = 10
simpleCrSprings :: World -> World
simpleCrSprings w = IM.foldl' (flip crSpring) w $ IM.filter (\cr -> _crZ cr >= 0) $ w ^. cWorld . lWorld . creatures
simpleCrSprings w = IM.foldl' (flip crSpring) w
$ IM.filter (\cr -> _crZ cr >= 0) $ w ^. cWorld . lWorld . creatures
-- note that this may in rare cases not push creatures away from each other
crSpring :: Creature -> World -> World
crSpring c w = foldl' (flip $ crCrSpring c) w cs
where
cs = crsNearPoint (_crPos c) w
crSpring c w = foldl' (flip $ crCrSpring c) w $ crsNearPoint (_crPos c) w
crCrSpring :: Creature -> Creature -> World -> World
crCrSpring c1 c2
+46 -39
View File
@@ -43,27 +43,25 @@ import NewInt
import SDL
updateUseInputInGame :: Universe -> Universe
updateUseInputInGame u = updateFunctionKeys $ case u ^. uvWorld . hud of
HUD{_subInventory = si, _diSelection = disel} -> case si of
DisplayTerminal tmid -> updateKeysInTerminal tmid u
CombineInventory{_ciSections = sss, _ciSelection = msel@(Just (Sel (-1) _ _))} ->
updateUseInputInGame u = updateFunctionKeys $ case u ^. uvWorld . hud . subInventory of
DisplayTerminal tmid -> updateKeysInTerminal tmid u
CombineInventory{_ciSections = sss, _ciSelection = msel@(Just (Sel (-1) _ _))} ->
u
& tohud . subInventory %~ docombineregexinput sss msel
& uvWorld . worldEventFlags . at CombineInventoryChange ?~ ()
_ | disel == Just (-1) ->
u
& tohud . subInventory %~ docombineregexinput sss msel
& uvWorld . worldEventFlags . at CombineInventoryChange ?~ ()
_
| disel ^? _Just . slSec == Just (-1) ->
u
& tohud %~ dodisplayregexinput diInvFilter diInvFilter (-1)
& uvWorld . worldEventFlags . at InventoryChange ?~ ()
& uvWorld %~ setInvPosFromSS
_
| disel ^? _Just . slSec == Just 2 ->
u
& tohud %~ dodisplayregexinput diCloseFilter diCloseFilter 2
& uvWorld . worldEventFlags . at InventoryChange ?~ ()
& uvWorld %~ setInvPosFromSS
_ -> updateKeysInGame u
& tohud %~ dodisplayregexinput diInvFilter diInvFilter (-1)
& uvWorld . worldEventFlags . at InventoryChange ?~ ()
& uvWorld %~ setInvPosFromSS
_ | disel == Just 2 ->
u
& tohud %~ dodisplayregexinput diCloseFilter diCloseFilter 2
& uvWorld . worldEventFlags . at InventoryChange ?~ ()
& uvWorld %~ setInvPosFromSS
_ -> updateKeysInGame u
where
disel = u ^? uvWorld . hud . diSelection . _Just . slSec
tohud = uvWorld . hud
dodisplayregexinput filterprism filterlens x di = fromMaybe di $ do
sss <- di ^? diSections
@@ -97,21 +95,22 @@ updateMouseInGame cfig w
updateMouseHeldInGame :: Config -> World -> World
updateMouseHeldInGame cfig w = case w ^. input . mouseContext of
OverInvDragSelect{} | ButtonRight `M.member` (w ^. input . mouseButtons) ->
OverInvDragSelect{}
| ButtonRight `M.member` (w ^. input . mouseButtons) ->
w & input . mouseContext .~ MouseGameRotate
OverInvDragSelect (Just sstart) _ ->
let sss = w ^. hud . diSections
msel = inverseSelNumPos cfig invDP (w ^. input . mousePos) sss
in case msel of
Nothing -> w & input . mouseContext . mcoSelEnd .~ Nothing
Just (i, j)
| i == fst sstart -> w & input . mouseContext . mcoSelEnd ?~ j
| i < fst sstart -> w & input . mouseContext . mcoSelEnd ?~ 0
| otherwise ->
w & input . mouseContext . mcoSelEnd
.~ fmap
fst
(IM.lookupMax =<< sss ^? ix (fst sstart) . ssItems)
in case msel of
Nothing -> w & input . mouseContext . mcoSelEnd .~ Nothing
Just (i, j)
| i == fst sstart -> w & input . mouseContext . mcoSelEnd ?~ j
| i < fst sstart -> w & input . mouseContext . mcoSelEnd ?~ 0
| otherwise ->
w & input . mouseContext . mcoSelEnd
.~ fmap
fst
(IM.lookupMax =<< sss ^? ix (fst sstart) . ssItems)
-- not sure how the above performs when filtering...
OverInvDragSelect Nothing _ -> fromMaybe w $ do
sss <- w ^? hud . diSections
@@ -275,9 +274,9 @@ endCombineRegex w = ssSetCursor (ssLookupDown 0 j) sss
where
sss = w ^. hud . subInventory . ciSections
j = fromMaybe 0 $ do
itms <- sss ^? ix 0 . ssItems
(k, _) <- IM.lookupMin itms
return (k -1)
itms <- sss ^? ix 0 . ssItems
(k, _) <- IM.lookupMin itms
return (k -1)
startDrag :: (Int, Int) -> World -> World
startDrag (a, b) w = setcontext $ case w ^? hud . diSelection . _Just of
@@ -387,8 +386,7 @@ updateKeysInTerminal tmid u = fromMaybe deactivate $ do
x <- u ^? uvWorld . cWorld . lWorld . buttons . ix (tm ^. tmButtonID) . btPos
y <- u ^? uvWorld . cWorld . lWorld . creatures . ix 0 . crPos
case tm ^. tmStatus of
_
| dist x y > 40 || not (hasButtonLOS x y (u ^. uvWorld)) -> Nothing
_ | dist x y > 40 || not (hasButtonLOS x y (u ^. uvWorld)) -> Nothing
TerminalDeactivated -> Nothing
TerminalTextInput{} -> Just $ updateKeysTextInputTerminal tmid u
TerminalPressTo{} -> Just $ updateKeyContinueTerminal tmid u
@@ -398,6 +396,7 @@ updateKeysInTerminal tmid u = fromMaybe deactivate $ do
updateKeyContinueTerminal :: Int -> Universe -> Universe
updateKeyContinueTerminal tmid u
| isJust (u ^. uvWorld . input . pressedKeys . at ScancodeEscape) = u
| elem 0 $ u ^. uvWorld . input . pressedKeys = u & uvWorld %~ continueTerminal tmid
| otherwise = u
@@ -417,7 +416,7 @@ updateKeysTextInputTerminal tmid u =
uvWorld %~ terminalReturnEffect tmid
| otherwise = id
tryTabComplete
| u ^. uvWorld . input . pressedKeys . at ScancodeTab == Just 0 =
| u ^. uvWorld . input . pressedKeys . at ScancodeTab == Just 0 =
uvWorld . cWorld . lWorld . terminals . ix tmid %~ tabComplete (u ^. uvWorld)
| otherwise = id
@@ -536,7 +535,8 @@ getCloseObj :: World -> Maybe (Either (NewInt ItmInt) Button)
getCloseObj w = getSelectedCloseObj w <|> topcitem <|> topcbut
where
topcitem = do
k <- (w ^? hud . diSections . ix 3 . ssItems)
k <-
(w ^? hud . diSections . ix 3 . ssItems)
>>= (fmap fst . IM.lookupMin)
Left <$> w ^? hud . closeItems . ix k
topcbut = do
@@ -545,8 +545,15 @@ getCloseObj w = getSelectedCloseObj w <|> topcitem <|> topcbut
tryCombine :: (Int, Int) -> World -> World
tryCombine (i, j) w = fromMaybe w $ do
CombItem is it <- w ^? hud . subInventory
. ciSections . ix i . ssItems . ix j . siPayload . _Just
CombItem is it <-
w
^? hud . subInventory
. ciSections
. ix i
. ssItems
. ix j
. siPayload
. _Just
p <- w ^? cWorld . lWorld . creatures . ix 0 . crPos
return $
createItemYou it (foldr (destroyInvItem 0 . NInt) w (sort is))