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

Move configuration from world to universe

Browse Source
This commit is contained in:
justin
2021-11-28 22:30:47 +00:00
parent 45ba120796
commit 8c5777a1af
29 changed files with 343 additions and 300 deletions
Download Patch File Download Diff File Expand all files Collapse all files
appDodge/Main.hs
+2 -2
View File
@@ -58,7 +58,7 @@ firstWorldLoad theConfig = do
w <- generateWorldFromSeed 0 w <- generateWorldFromSeed 0
return $ Universe return $ Universe
{_uvWorld = w {_uvWorld = w
& config .~ theConfig ,_config = theConfig
,_preloadData = pdata ,_preloadData = pdata
,_menuLayers = [] ,_menuLayers = []
,_savedWorlds = M.empty ,_savedWorlds = M.empty
@@ -90,7 +90,7 @@ doSideEffects u = do
u' <- _sideEffects w u u' <- _sideEffects w u
endTicks <- SDL.ticks endTicks <- SDL.ticks
let lastFrameTicks = _frameTimer preData let lastFrameTicks = _frameTimer preData
when (_debug_seconds_frame $ _config w) $ void $ renderFoldable when (_debug_seconds_frame $ _config u) $ void $ renderFoldable
(_pictureShaders $ _renderData preData) (_pictureShaders $ _renderData preData)
(setDepth (-1) (setDepth (-1)
. translate (-0.5) (-0.8) . scale 0.0005 0.0005 . translate (-0.5) (-0.8) . scale 0.0005 0.0005
src/Dodge/Base.hs
+8 -8
View File
@@ -451,15 +451,15 @@ crInPolygon :: Creature -> [Point2] -> Bool
crInPolygon cr = pointInPolygon (_crPos cr) crInPolygon cr = pointInPolygon (_crPos cr)
{- | Transform coordinates from world position to screen coordinates. -} {- | Transform coordinates from world position to screen coordinates. -}
worldPosToScreenNorm :: World -> Point2 -> Point2 worldPosToScreenNorm :: Configuration -> World -> Point2 -> Point2
worldPosToScreenNorm w = doWindowScale . doRotate . doZoom . doTranslate worldPosToScreenNorm cfig w = doWindowScale . doRotate . doZoom . doTranslate
where where
doTranslate p = p -.- _cameraCenter w doTranslate p = p -.- _cameraCenter w
doZoom p = _cameraZoom w *.* p doZoom p = _cameraZoom w *.* p
doRotate p = rotateV (negate $ _cameraRot w) p doRotate p = rotateV (negate $ _cameraRot w) p
doWindowScale (V2 x y) = V2 doWindowScale (V2 x y) = V2
( x * 2 / getWindowX w) ( x * 2 / getWindowX cfig)
( y * 2 / getWindowY w) ( y * 2 / getWindowY cfig)
{- | Transform world coordinates to scaled screen coordinates. {- | Transform world coordinates to scaled screen coordinates.
- These have to be according to the size of the window to get actual screen positions. - These have to be according to the size of the window to get actual screen positions.
- This allows for line thicknesses etc to correspond to pixel sizes.-} - This allows for line thicknesses etc to correspond to pixel sizes.-}
@@ -471,15 +471,15 @@ worldPosToScreen w = doRotate . doZoom . doTranslate
doRotate p = rotateV (negate $ _cameraRot w) p doRotate p = rotateV (negate $ _cameraRot w) p
{- | Transform coordinates from the map position to screen {- | Transform coordinates from the map position to screen
coordinates. -} coordinates. -}
cartePosToScreen :: World -> Point2 -> Point2 cartePosToScreen :: Configuration -> World -> Point2 -> Point2
cartePosToScreen w = doWindowScale . doRotate . doZoom . doTranslate cartePosToScreen cfig w = doWindowScale . doRotate . doZoom . doTranslate
where where
doTranslate p = p -.- _carteCenter w doTranslate p = p -.- _carteCenter w
doZoom p = _carteZoom w *.* p doZoom p = _carteZoom w *.* p
doRotate p = rotateV (negate $ _carteRot w) p doRotate p = rotateV (negate $ _carteRot w) p
doWindowScale (V2 x y) = V2 doWindowScale (V2 x y) = V2
( x * 2 / getWindowX w) ( x * 2 / getWindowX cfig)
( y * 2 / getWindowY w) ( y * 2 / getWindowY cfig)
{- | The mouse position in world coordinates. -} {- | The mouse position in world coordinates. -}
mouseWorldPos :: World -> Point2 mouseWorldPos :: World -> Point2
mouseWorldPos w = _cameraCenter w +.+ (1/_cameraZoom w) *.* rotateV (_cameraRot w) (_mousePos w) mouseWorldPos w = _cameraCenter w +.+ (1/_cameraZoom w) *.* rotateV (_cameraRot w) (_mousePos w)
src/Dodge/Base/Window.hs
+11 -10
View File
@@ -13,8 +13,8 @@ import Dodge.Data
import Geometry import Geometry
-- | A box covering the screen in world coordinates -- | A box covering the screen in world coordinates
screenPolygon :: World -> [Point2] screenPolygon :: Configuration -> World -> [Point2]
screenPolygon w = map (scTran . scRot . scZoom) $ screenBox w screenPolygon cfig w = map (scTran . scRot . scZoom) $ screenBox cfig
-- [tr,tl,bl,br] -- [tr,tl,bl,br]
where where
scRot = rotateV (_cameraRot w) scRot = rotateV (_cameraRot w)
@@ -30,12 +30,13 @@ screenPolygon w = map (scTran . scRot . scZoom) $ screenBox w
screenPolygonBord screenPolygonBord
:: Float -- ^ X border :: Float -- ^ X border
-> Float -- ^ Y border -> Float -- ^ Y border
-> Configuration
-> World -> World
-> [Point2] -> [Point2]
screenPolygonBord xbord ybord w = [tr,tl,bl,br] screenPolygonBord xbord ybord cfig w = [tr,tl,bl,br]
where where
hw = halfWidth w - xbord hw = halfWidth cfig - xbord
hh = halfHeight w - ybord hh = halfHeight cfig - ybord
scZoom p | _cameraZoom w /= 0 = (1/_cameraZoom w) *.* p scZoom p | _cameraZoom w /= 0 = (1/_cameraZoom w) *.* p
| otherwise = p | otherwise = p
theTransform = (+.+ _cameraCenter w) . rotateV (_cameraRot w) . scZoom theTransform = (+.+ _cameraCenter w) . rotateV (_cameraRot w) . scZoom
@@ -44,15 +45,15 @@ screenPolygonBord xbord ybord w = [tr,tl,bl,br]
br = theTransform (V2 hw (-hh)) br = theTransform (V2 hw (-hh))
bl = theTransform (V2 (-hw) (-hh)) bl = theTransform (V2 (-hw) (-hh))
halfWidth,halfHeight :: World -> Float halfWidth,halfHeight :: Configuration -> Float
halfWidth w = getWindowX w / 2 halfWidth w = getWindowX w / 2
halfHeight w = getWindowY w / 2 halfHeight w = getWindowY w / 2
getWindowX ,getWindowY :: World -> Float getWindowX ,getWindowY :: Configuration -> Float
getWindowX = _windowX . _config getWindowX = _windowX
getWindowY = _windowY . _config getWindowY = _windowY
-- | A box of the size of the screen in screen centered coordinates -- | A box of the size of the screen in screen centered coordinates
screenBox :: World -> [Point2] screenBox :: Configuration -> [Point2]
screenBox w = rectNSEW hh (-hh) hw (-hw) screenBox w = rectNSEW hh (-hh) hw (-hw)
where where
hw = halfWidth w hw = halfWidth w
src/Dodge/Clock.hs
+1 -1
View File
@@ -10,5 +10,5 @@ clockCycle :: Int -> V.Vector a -> World -> a
clockCycle tPeriod xs w = xs V.! i clockCycle tPeriod xs w = xs V.! i
where where
l = V.length xs l = V.length xs
t = _frameClock w `mod` (l * tPeriod) t = _worldClock w `mod` (l * tPeriod)
i = t `div` tPeriod i = t `div` tPeriod
src/Dodge/Creature/Action.hs
+1 -1
View File
@@ -285,7 +285,7 @@ sizeSelf x cr w
) )
| otherwise = Nothing | otherwise = Nothing
where where
cr1 = colCrWall w (cr {_crRad = 10* x}) cr1 = colCrWall' w (cr {_crRad = 10* x})
--cr2 = colCrWall w cr1 --cr2 = colCrWall w cr1
distR = 120 distR = 120
distortionBulge distortionBulge
src/Dodge/Creature/Picture.hs
+12 -11
View File
@@ -27,11 +27,12 @@ import qualified Data.Vector as V
basicCrPict basicCrPict
:: Color -- ^ Creature color :: Color -- ^ Creature color
-> Creature -> Creature
-> Configuration
-> World -> World
-> SPic -> SPic
basicCrPict col cr w = (,) (basicCrShape col cr) $ pictures $ basicCrPict col cr cfig w = (,) (basicCrShape col cr) $ pictures $
targetingPic ++ targetingPic ++
[ creatureDisplayText w cr [ creatureDisplayText cfig w cr
, tr . rotdir $ _spPicture $ drawEquipment cr , tr . rotdir $ _spPicture $ drawEquipment cr
] ]
where where
@@ -40,8 +41,8 @@ basicCrPict col cr w = (,) (basicCrShape col cr) $ pictures $
tr = uncurryV translate (_crPos cr) tr = uncurryV translate (_crPos cr)
rotdir = rotate (_crDir cr) rotdir = rotate (_crDir cr)
shapeAtCrPos :: Shape -> Creature -> World -> SPic shapeAtCrPos :: Shape -> Creature -> Configuration -> World -> SPic
shapeAtCrPos sh cr _ = shapeAtCrPos sh cr _ _ =
( uncurryV translateSHf (_crPos cr) $ rotateSH (_crDir cr) sh ( uncurryV translateSHf (_crPos cr) $ rotateSH (_crDir cr) sh
, mempty , mempty
) )
@@ -64,9 +65,9 @@ basicCrShape col cr = tr . scaleSH (V3 crsize crsize crsize) $ mconcat
rotmdir = rotateSH (_crMvDir cr) rotmdir = rotateSH (_crMvDir cr)
. colorSH (greyN 0.3) . colorSH (greyN 0.3)
creatureDisplayText :: World -> Creature -> Picture creatureDisplayText :: Configuration -> World -> Creature -> Picture
creatureDisplayText w cr creatureDisplayText cfig w cr
| not (_debug_cr_status $ _config w) = [] | not (_debug_cr_status cfig) = []
| otherwise | otherwise
= setLayer 4 = setLayer 4
. setDepth 50 . setDepth 50
@@ -256,10 +257,10 @@ drawEquipment cr = mconcat $ map f $ IM.toList (_crInv cr)
circLine :: Float -> Picture circLine :: Float -> Picture
circLine x = line [V2 0 0,V2 x 0] circLine x = line [V2 0 0,V2 x 0]
picAtCrPos :: Picture -> Creature -> World -> SPic picAtCrPos :: Picture -> Creature -> Configuration -> World -> SPic
--{-# INLINE picAtCrPos #-} --{-# INLINE picAtCrPos #-}
picAtCrPos thePic cr _ = (,) emptySH $ tranRot (_crPos cr) (_crDir cr) thePic picAtCrPos thePic cr _ _ = (,) emptySH $ tranRot (_crPos cr) (_crDir cr) thePic
picAtCrPosNoRot :: Picture -> Creature -> World -> SPic picAtCrPosNoRot :: Picture -> Creature -> Configuration -> World -> SPic
--{-# INLINE picAtCrPos #-} --{-# INLINE picAtCrPos #-}
picAtCrPosNoRot thePic cr _ = (,) emptySH $ uncurryV translate (_crPos cr) thePic picAtCrPosNoRot thePic cr _ _ = (,) emptySH $ uncurryV translate (_crPos cr) thePic
src/Dodge/Data.hs
+5 -4
View File
@@ -58,6 +58,7 @@ data Universe = Universe
, _menuLayers :: [ScreenLayer] , _menuLayers :: [ScreenLayer]
, _savedWorlds :: M.Map SaveSlot World , _savedWorlds :: M.Map SaveSlot World
, _keyConfig :: KeyConfigSDL , _keyConfig :: KeyConfigSDL
, _config :: Configuration
} }
data World = World data World = World
{ _keys :: !(S.Set Scancode) { _keys :: !(S.Set Scancode)
@@ -116,12 +117,13 @@ data World = World
, _distortions :: [Distortion] , _distortions :: [Distortion]
, _worldBounds :: Bounds , _worldBounds :: Bounds
, _gameRooms :: [GameRoom] -- consider using and IntMap , _gameRooms :: [GameRoom] -- consider using and IntMap
, _config :: Configuration
, _rewindWorlds :: [World] , _rewindWorlds :: [World]
, _rewinding :: Bool , _rewinding :: Bool
, _frameClock :: Int , _worldClock :: Int
, _lSelHammerPosition :: HammerPosition , _lSelHammerPosition :: HammerPosition
, _worldTerminal :: Maybe' WorldTerminal
} }
data WorldTerminal = WorldTerminal Int [(Int,String)]
data SaveSlot = QuicksaveSlot | LevelStartSlot data SaveSlot = QuicksaveSlot | LevelStartSlot
deriving (Eq,Ord) deriving (Eq,Ord)
@@ -136,7 +138,6 @@ data ScreenLayer
} }
| ColumnsScreen String [(String,String)] | ColumnsScreen String [(String,String)]
| InputScreen String | InputScreen String
| TerminalScreen Int [(Int,String)]
| WaitScreen | WaitScreen
{ _scWaitMessage :: Universe -> String { _scWaitMessage :: Universe -> String
, _scWaitTime :: Int , _scWaitTime :: Int
@@ -216,7 +217,7 @@ data Creature = Creature
, _crOldDir :: Float , _crOldDir :: Float
, _crMvDir :: Float , _crMvDir :: Float
, _crID :: Int , _crID :: Int
, _crPict :: Creature -> World -> SPic , _crPict :: Creature -> Configuration -> World -> SPic
, _crUpdate :: Creature -> World -> (Endo World, Maybe Creature) , _crUpdate :: Creature -> World -> (Endo World, Maybe Creature)
, _crRad :: Float , _crRad :: Float
, _crMass :: Float , _crMass :: Float
src/Dodge/Debug/Picture.hs
+22 -20
View File
@@ -15,55 +15,57 @@ printRotPoint r p = color white
. uncurryV translate p . uncurryV translate p
$ pictures [circle 3 , rotate (negate r) $ scale 0.1 0.1 $ text (show p)] $ pictures [circle 3 , rotate (negate r) $ scale 0.1 0.1 $ text (show p)]
outsideScreenPolygon :: World -> [Point2] outsideScreenPolygon :: Configuration -> World -> [Point2]
outsideScreenPolygon w = [tr,tl,bl,br] outsideScreenPolygon cfig w = [tr,tl,bl,br]
where where
scRot = rotateV (_cameraRot w) scRot = rotateV (_cameraRot w)
scZoom p | _cameraZoom w /= 0 = (1/_cameraZoom w) *.* p scZoom p | _cameraZoom w /= 0 = (1/_cameraZoom w) *.* p
| otherwise = error "Trying to set screen zoom to zero" | otherwise = error "Trying to set screen zoom to zero"
scTran p = p +.+ _cameraCenter w scTran p = p +.+ _cameraCenter w
tr = scTran $ scRot $ scZoom $ V2 ( 3*halfWidth w ) ( 3* halfHeight w) tr = f 3 3
tl = scTran $ scRot $ scZoom $ V2 (- (3*halfWidth w)) ( 3* halfHeight w) tl = f (-3) 3
br = scTran $ scRot $ scZoom $ V2 ( 3*halfWidth w ) (- (3* halfHeight w)) br = f 3 (-3)
bl = scTran $ scRot $ scZoom $ V2 (- (3*halfWidth w)) (- (3* halfHeight w)) bl = f (-3) (-3)
f a b = scTran $ scRot $ scZoom $ V2 (a*halfWidth cfig) (b* halfHeight cfig)
-- cannot only test if walls are on screen, but also if they are on the cone -- cannot only test if walls are on screen, but also if they are on the cone
-- towards the center of sight -- towards the center of sight
lineOnScreenCone :: World -> Point2 -> Point2 -> Bool lineOnScreenCone :: Configuration -> World -> Point2 -> Point2 -> Bool
lineOnScreenCone w p1 p2 = pointInPolygon p1 sp lineOnScreenCone cfig w p1 p2 = pointInPolygon p1 sp
|| pointInPolygon p2 sp || pointInPolygon p2 sp
|| any (isJust . uncurry (intersectSegSeg p1 p2)) sps || any (isJust . uncurry (intersectSegSeg p1 p2)) sps
where where
sp' = screenPolygon w sp' = screenPolygon cfig w
vp = _cameraViewFrom w vp = _cameraViewFrom w
sp | pointInPolygon vp sp' = sp' sp | pointInPolygon vp sp' = sp'
| otherwise = orderPolygon (_cameraViewFrom w : sp') | otherwise = orderPolygon (_cameraViewFrom w : sp')
sps = zip sp (tail sp ++ [head sp]) sps = zip sp (tail sp ++ [head sp])
drawWallFace :: World -> Wall -> Picture drawWallFace :: Configuration -> World -> Wall -> Picture
drawWallFace w wall drawWallFace cfig w wall
| isRHS sightFrom x y || _wlOpacity wall /= Opaque = blank | isRHS sightFrom x y || _wlOpacity wall /= Opaque = blank
| otherwise = setDepth (-1) . color (withAlpha 0 black) . polygon $ points | otherwise = setDepth (-1) . color (withAlpha 0 black) . polygon $ points
where where
(x,y) = _wlLine wall (x,y) = _wlLine wall
points = extendConeToScreenEdge w sightFrom (x,y) points = extendConeToScreenEdge cfig w sightFrom (x,y)
sightFrom = _cameraViewFrom w sightFrom = _cameraViewFrom w
extendConeToScreenEdge :: World -> Point2 -> (Point2,Point2) -> [Point2] extendConeToScreenEdge :: Configuration -> World -> Point2 -> (Point2,Point2) -> [Point2]
extendConeToScreenEdge w c (x,y) = orderPolygon $ wallScreenIntersect ++ [x,y] ++ borderPs ++ cornerPs extendConeToScreenEdge cfig w c (x,y) = orderPolygon $ wallScreenIntersect ++ [x,y] ++ borderPs ++ cornerPs
where where
borderPs = mapMaybe (intersectLinefromScreen w c) [x,y] borderPs = mapMaybe (intersectLinefromScreen cfig w c) [x,y]
cornerPs = filter (pointIsInCone c (x,y)) $ screenPolygon w scpoly = screenPolygon cfig w
cornerPs = filter (pointIsInCone c (x,y)) scpoly
wallScreenIntersect = mapMaybe (uncurry $ intersectSegSeg y ((2*.*y) -.- x)) wallScreenIntersect = mapMaybe (uncurry $ intersectSegSeg y ((2*.*y) -.- x))
. loopPairs $ screenPolygon w . loopPairs $ scpoly
-- the following assumes that the point a is inside the screen -- the following assumes that the point a is inside the screen
-- it still works otherwise, but it might intersect two points: -- it still works otherwise, but it might intersect two points:
-- it is not obvious which will be returned -- it is not obvious which will be returned
intersectLinefromScreen :: World -> Point2 -> Point2 -> Maybe Point2 intersectLinefromScreen :: Configuration -> World -> Point2 -> Point2 -> Maybe Point2
intersectLinefromScreen w a b = listToMaybe intersectLinefromScreen cfig w a b = listToMaybe
. mapMaybe (\(x,y) -> intersectSegLineFrom x y b (b +.+ b -.- a)) . mapMaybe (\(x,y) -> intersectSegLineFrom x y b (b +.+ b -.- a))
. loopPairs . loopPairs
$ screenPolygon w $ screenPolygon cfig w
src/Dodge/Debug/Terminal.hs
+3 -3
View File
@@ -5,10 +5,10 @@ import Dodge.Creature
import Control.Lens import Control.Lens
applyTerminalString :: String -> World -> World applyTerminalString :: String -> Universe -> Universe
applyTerminalString "NOCLIP" w = w & config . debug_noclip %~ not applyTerminalString "NOCLIP" w = w & config . debug_noclip %~ not
applyTerminalString "LOADME" w = w & creatures . ix 0 . crInv .~ stackedInventory applyTerminalString "LOADME" w = w & uvWorld . creatures . ix 0 . crInv .~ stackedInventory
applyTerminalString "LM" w = w & creatures . ix 0 . crInv .~ stackedInventory applyTerminalString "LM" w = applyTerminalString "LOADME" w
applyTerminalString _ w = w applyTerminalString _ w = w
loadme :: a loadme :: a
src/Dodge/Default.hs
+1 -1
View File
@@ -29,7 +29,7 @@ defaultCreature = Creature
, _crOldDir = 0 , _crOldDir = 0
, _crMvDir = 0 , _crMvDir = 0
, _crID = 1 , _crID = 1
, _crPict = \_ _ -> (,) mempty blank , _crPict = \_ _ _ -> (,) mempty blank
, _crUpdate = \cr _ -> (Endo id , Just cr) , _crUpdate = \cr _ -> (Endo id , Just cr)
, _crRad = 10 , _crRad = 10
, _crMass = 10 , _crMass = 10
src/Dodge/Default/World.hs
+3 -3
View File
@@ -74,18 +74,18 @@ defaultWorld = World
] ]
, _selLocation = 0 , _selLocation = 0
--, _keyConfig = defaultKeyConfigSDL --, _keyConfig = defaultKeyConfigSDL
, _config = defaultConfig -- , _config = defaultConfig
, _sideEffects = return , _sideEffects = return
, _inventoryMode = TopInventory , _inventoryMode = TopInventory
, _foregroundShape = mempty , _foregroundShape = mempty
, _distortions = [] , _distortions = []
, _gameRooms = [] , _gameRooms = []
-- , _preloadData = DummyPdata -- hack TODO remove this , _worldClock = 0
, _frameClock = 0
, _worldBounds = defaultBounds , _worldBounds = defaultBounds
, _rewindWorlds = [] , _rewindWorlds = []
, _rewinding = False , _rewinding = False
, _lSelHammerPosition = HammerUp , _lSelHammerPosition = HammerUp
, _worldTerminal = Nothing'
} }
youLight :: TempLightSource youLight :: TempLightSource
youLight = youLight =
src/Dodge/Event.hs
+8 -7
View File
@@ -51,9 +51,10 @@ handleEvent e = case eventPayload e of
handleMouseMotionEvent :: MouseMotionEventData -> Universe -> Maybe Universe handleMouseMotionEvent :: MouseMotionEventData -> Universe -> Maybe Universe
handleMouseMotionEvent mmev u = Just $ u & uvWorld . mousePos .~ V2 handleMouseMotionEvent mmev u = Just $ u & uvWorld . mousePos .~ V2
(fromIntegral x - 0.5*getWindowX w) (fromIntegral x - 0.5*getWindowX cfig)
(0.5*getWindowY w - fromIntegral y) (0.5*getWindowY cfig - fromIntegral y)
where where
cfig = _config u
w = _uvWorld u w = _uvWorld u
P (V2 x y) = mouseMotionEventPos mmev P (V2 x y) = mouseMotionEventPos mmev
@@ -68,23 +69,23 @@ handleMouseButtonEvent mbev u = case mouseButtonEventMotion mbev of
{- | Sets window position in config. -} {- | Sets window position in config. -}
handleWindowMoveEvent :: WindowMovedEventData -> Universe -> Maybe Universe handleWindowMoveEvent :: WindowMovedEventData -> Universe -> Maybe Universe
handleWindowMoveEvent mev u = Just $ u handleWindowMoveEvent mev u = Just $ u
& uvWorld . config . windowPosX .~ fromIntegral x & config . windowPosX .~ fromIntegral x
& uvWorld . config . windowPosY .~ fromIntegral y & config . windowPosY .~ fromIntegral y
where where
P (V2 x y) = windowMovedEventPosition mev P (V2 x y) = windowMovedEventPosition mev
{- | Resets the world window size, and resizes the fbo that gets the light map drawn into it. -} {- | Resets the world window size, and resizes the fbo that gets the light map drawn into it. -}
handleResizeEvent :: WindowSizeChangedEventData -> Universe -> Maybe Universe handleResizeEvent :: WindowSizeChangedEventData -> Universe -> Maybe Universe
handleResizeEvent sev u = Just $ u handleResizeEvent sev u = Just $ u
& uvWorld . config . windowX .~ fromIntegral x & config . windowX .~ fromIntegral x
& uvWorld . config . windowY .~ fromIntegral y & config . windowY .~ fromIntegral y
& uvWorld . sideEffects %~ sideEffectUpdatePreload divRes x y & uvWorld . sideEffects %~ sideEffectUpdatePreload divRes x y
where where
w = _uvWorld u w = _uvWorld u
x = fromIntegral x' x = fromIntegral x'
y = fromIntegral y' y = fromIntegral y'
V2 x' y' = windowSizeChangedEventSize sev V2 x' y' = windowSizeChangedEventSize sev
divRes = w ^. config . resolution_factor divRes = u ^. config . resolution_factor
handlePressedMouseButton :: MouseButton -> Universe -> Maybe Universe handlePressedMouseButton :: MouseButton -> Universe -> Maybe Universe
handlePressedMouseButton but w handlePressedMouseButton but w
src/Dodge/Event/Menu.hs
+1 -3
View File
@@ -17,11 +17,9 @@ handlePressedKeyInMenu mState scode = case mState of
DisplayScreen {} -> popScreen DisplayScreen {} -> popScreen
ColumnsScreen {} -> popScreen ColumnsScreen {} -> popScreen
WaitScreen {} -> Just WaitScreen {} -> Just
TerminalScreen 0 _ -> popScreen
TerminalScreen _ m -> Just . (menuLayers %~ ( (TerminalScreen 0 m : ) . tail) )
InputScreen s -> case scode of InputScreen s -> case scode of
ScancodeEscape -> popScreen ScancodeEscape -> popScreen
ScancodeReturn -> popScreen . over uvWorld (applyTerminalString s) ScancodeReturn -> popScreen . applyTerminalString s
ScancodeBackspace ScancodeBackspace
-> popScreen >=> pushScreen (InputScreen $ dropLast s) -> popScreen >=> pushScreen (InputScreen $ dropLast s)
_ -> popScreen >=> pushScreen (InputScreen $ s ++ [scodeToChar scode]) _ -> popScreen >=> pushScreen (InputScreen $ s ++ [scodeToChar scode])
src/Dodge/Item/Weapon/TriggerType.hs
+1 -1
View File
@@ -299,7 +299,7 @@ withTempLight time rad col eff item cr = eff item cr
modClock :: Int -> ChainEffect -> ChainEffect modClock :: Int -> ChainEffect -> ChainEffect
modClock n chainEff eff it cr w modClock n chainEff eff it cr w
| _frameClock w `mod` n == 0 = chainEff eff it cr w | _worldClock w `mod` n == 0 = chainEff eff it cr w
| otherwise = eff it cr w | otherwise = eff it cr w
withMuzFlareI :: ChainEffect withMuzFlareI :: ChainEffect
src/Dodge/Menu.hs
+32 -29
View File
@@ -40,7 +40,7 @@ debugMenu :: ScreenLayer
debugMenu = OptionScreen debugMenu = OptionScreen
{ _scTitle = const "OPTIONS:GAMEPLAY" { _scTitle = const "OPTIONS:GAMEPLAY"
, _scOptions = debugMenuOptions , _scOptions = debugMenuOptions
, _scDefaultEff = popScreen . over uvWorld writeConfig , _scDefaultEff = popScreen . writeConfig
, _scOptionFlag = NormalOptions , _scOptionFlag = NormalOptions
} }
debugMenuOptions :: [MenuOption] debugMenuOptions :: [MenuOption]
@@ -53,12 +53,12 @@ debugMenuOptions =
] ]
where where
doption scode l t rec doption scode l t rec
= Toggle scode (Just . (uvWorld . config . l %~ not)) (\w -> t ++ ":" ++ show (rec $ _config (_uvWorld w))) = Toggle scode (Just . (config . l %~ not)) (\w -> t ++ ":" ++ show (rec $ _config w))
gameplayMenu :: ScreenLayer gameplayMenu :: ScreenLayer
gameplayMenu = OptionScreen gameplayMenu = OptionScreen
{ _scTitle = const "OPTIONS:GAMEPLAY" { _scTitle = const "OPTIONS:GAMEPLAY"
, _scOptions = gameplayMenuOptions , _scOptions = gameplayMenuOptions
, _scDefaultEff = popScreen . over uvWorld writeConfig , _scDefaultEff = popScreen . writeConfig
, _scOptionFlag = NormalOptions , _scOptionFlag = NormalOptions
} }
gameplayMenuOptions :: [MenuOption] gameplayMenuOptions :: [MenuOption]
@@ -67,33 +67,33 @@ gameplayMenuOptions =
, option ScancodeS show_sound "SHOW VISUAL SOUNDS" _show_sound , option ScancodeS show_sound "SHOW VISUAL SOUNDS" _show_sound
] ]
where where
option scode l t rec = Toggle scode (Just . (uvWorld . config . l %~ not)) option scode l t rec = Toggle scode (Just . (config . l %~ not))
(\w -> t ++ ":" ++ show (rec $ _config (_uvWorld w))) (\w -> t ++ ":" ++ show (rec $ _config w))
soundMenu :: ScreenLayer soundMenu :: ScreenLayer
soundMenu = OptionScreen soundMenu = OptionScreen
{ _scTitle = const "OPTIONS:VOLUME" { _scTitle = const "OPTIONS:VOLUME"
, _scOptions = soundMenuOptions , _scOptions = soundMenuOptions
, _scDefaultEff = popScreen . over uvWorld writeConfig , _scDefaultEff = popScreen . writeConfig
, _scOptionFlag = NormalOptions , _scOptionFlag = NormalOptions
} }
soundMenuOptions :: [MenuOption] soundMenuOptions :: [MenuOption]
soundMenuOptions = soundMenuOptions =
[ Toggle2 ScancodeY (master dec . sw) [ Toggle2 ScancodeY (master dec . sw)
ScancodeU (master inc . sw) (\w -> "MASTER VOLUME:" ++ mavol (_uvWorld w)) ScancodeU (master inc . sw) (\w -> "MASTER VOLUME:" ++ mavol w)
, Toggle2 ScancodeH (soundEffs dec . sw) , Toggle2 ScancodeH (soundEffs dec . sw)
ScancodeJ (soundEffs inc . sw) (\w -> "EFFECTS VOLUME:" ++ snvol (_uvWorld w)) ScancodeJ (soundEffs inc . sw) (\w -> "EFFECTS VOLUME:" ++ snvol w)
, Toggle2 ScancodeN (music dec . sw) , Toggle2 ScancodeN (music dec . sw)
ScancodeM (music inc . sw) (\w -> "MUSIC VOLUME:" ++ muvol (_uvWorld w)) ScancodeM (music inc . sw) (\w -> "MUSIC VOLUME:" ++ muvol w)
] ]
where where
dec x = max 0 (x - 0.1) dec x = max 0 (x - 0.1)
inc x = min 1 (x + 0.1) inc x = min 1 (x + 0.1)
--sw w = w & sideEffects %~ (setVol (_config w) : ) --sw w = w & sideEffects %~ (setVol (_config w) : )
sw w = w & uvWorld . sideEffects %~ setVolThen (_config (_uvWorld w)) sw w = w & uvWorld . sideEffects %~ setVolThen (_config w)
master g = Just . (uvWorld . config . volume_master %~ g) master g = Just . (config . volume_master %~ g)
soundEffs g = Just . (uvWorld . config . volume_sound %~ g) soundEffs g = Just . (config . volume_sound %~ g)
music g = Just . (uvWorld . config . volume_music %~ g) music g = Just . (config . volume_music %~ g)
cfig w = _config w cfig w = _config w
mavol w = f $ _volume_master $ cfig w mavol w = f $ _volume_master $ cfig w
snvol w = f $ _volume_sound $ cfig w snvol w = f $ _volume_sound $ cfig w
@@ -106,27 +106,27 @@ pushScreen ml w = Just $ w & menuLayers %~ (ml :)
popScreen :: Universe -> Maybe Universe popScreen :: Universe -> Maybe Universe
popScreen = Just . (menuLayers %~ tail) popScreen = Just . (menuLayers %~ tail)
writeConfig :: World -> World writeConfig :: Universe -> Universe
writeConfig w = w & sideEffects %~ saveConfig (_config w) writeConfig w = w & uvWorld . sideEffects %~ saveConfig (_config w)
graphicsMenu :: ScreenLayer graphicsMenu :: ScreenLayer
graphicsMenu = OptionScreen graphicsMenu = OptionScreen
{ _scTitle = const "OPTIONS:GRAPHICS" { _scTitle = const "OPTIONS:GRAPHICS"
, _scOptions = graphicsMenuOptions , _scOptions = graphicsMenuOptions
, _scDefaultEff = popScreen . over uvWorld writeConfig , _scDefaultEff = popScreen . writeConfig
, _scOptionFlag = NormalOptions , _scOptionFlag = NormalOptions
} }
graphicsMenuOptions :: [MenuOption] graphicsMenuOptions :: [MenuOption]
graphicsMenuOptions = graphicsMenuOptions =
[ Toggle ScancodeW (Just . (uvWorld . config . wall_textured %~ not)) wtextstring [ Toggle ScancodeW (Just . (config . wall_textured %~ not)) wtextstring
, Toggle ScancodeS upf resostring , Toggle ScancodeS upf resostring
, Toggle ScancodeD (Just . (uvWorld . config . cloud_shadows %~ not)) cshadstring , Toggle ScancodeD (Just . (config . cloud_shadows %~ not)) cshadstring
] ]
where where
wtextstring w = "WALL TEXTURES:" ++ show (_wall_textured $ _config (_uvWorld w)) wtextstring w = "WALL TEXTURES:" ++ show (_wall_textured $ _config w)
resostring w = "RESOLUTION: 1/" ++ show (_resolution_factor $ _config (_uvWorld w)) resostring w = "RESOLUTION: 1/" ++ show (_resolution_factor $ _config w)
upf w = Just $ over uvWorld updateFramebufferSize $ w & uvWorld . config . resolution_factor %~ cycleResolution upf w = Just $ updateFramebufferSize $ w & config . resolution_factor %~ cycleResolution
cshadstring w = "CLOUD SHADOWS:" ++ show (_cloud_shadows $ _config (_uvWorld w)) cshadstring w = "CLOUD SHADOWS:" ++ show (_cloud_shadows $ _config w)
cycleResolution :: (Eq a, Num a, Num p) => a -> p cycleResolution :: (Eq a, Num a, Num p) => a -> p
cycleResolution 1 = 2 cycleResolution 1 = 2
@@ -160,12 +160,14 @@ pauseMenuOptions =
startNewGame :: Universe -> Maybe Universe startNewGame :: Universe -> Maybe Universe
startNewGame w = Just $ w startNewGame w = Just $ w
& menuLayers .~ [WaitScreen (const "GENERATING...") 1] & menuLayers .~ [WaitScreen (const "GENERATING...") 1]
& uvWorld . sideEffects .~ uvWorld (uvWorldSideEffects i (_uvWorld w)) & uvWorld . sideEffects .~ \u -> do
w' <- generateWorldFromSeed i
return (u & uvWorld .~ w')
where where
i = fst $ random (_randGen (_uvWorld w)) i = fst $ random (_randGen (_uvWorld w))
uvWorldSideEffects :: Int -> World -> b -> IO World --uvWorldSideEffects :: Int -> Universe -> b -> IO Universe
uvWorldSideEffects i w = const (generateWorldFromSeed i <&> config .~ _config w) --uvWorldSideEffects i w = const (generateWorldFromSeed i <&> config .~ _config w)
-- | hacky -- | hacky
@@ -175,11 +177,12 @@ scodeToChar = toEnum . (+ 61) . fromIntegral . toNumber
--charToScode :: Char -> Scancode --charToScode :: Char -> Scancode
--charToScode = Scancode . fromIntegral . (\x -> x - 61) . fromEnum --charToScode = Scancode . fromIntegral . (\x -> x - 61) . fromEnum
updateFramebufferSize :: World -> World updateFramebufferSize :: Universe -> Universe
updateFramebufferSize w = w & sideEffects %~ sideEffectUpdatePreload divRes x y updateFramebufferSize u = u & uvWorld . sideEffects %~ sideEffectUpdatePreload divRes x y
where where
(x,y) = (round $ getWindowX w, round $ getWindowY w) (x,y) = (round $ getWindowX cfig, round $ getWindowY cfig)
divRes = w ^. config . resolution_factor cfig = _config u
divRes = u ^. config . resolution_factor
--levelMenu :: Int -> ScreenLayer --levelMenu :: Int -> ScreenLayer
--levelMenu x = OptionScreen --levelMenu x = OptionScreen
src/Dodge/Picture/SizeInvariant.hs
+8 -6
View File
@@ -30,9 +30,10 @@ fixedSizePicClamp
-> Int -- ^ vertical border -> Int -- ^ vertical border
-> Picture -> Picture
-> Point2 -> Point2
-> Configuration
-> World -> World
-> Picture -> Picture
fixedSizePicClamp xbord ybord pic p w fixedSizePicClamp xbord ybord pic p cfig w
= setLayer 4 = setLayer 4
-- . setDepth 50 -- . setDepth 50
. translate x y . translate x y
@@ -46,23 +47,24 @@ fixedSizePicClamp xbord ybord pic p w
theScale = 1 / _cameraZoom w theScale = 1 / _cameraZoom w
(V2 x y) = campos +.+ rotateV (negate r) (V2 xr' yr') (V2 x y) = campos +.+ rotateV (negate r) (V2 xr' yr')
(V2 xr yr) = rotateV r v (V2 xr yr) = rotateV r v
xr' = absClamp ((halfWidth w - fromIntegral xbord) / z) xr xr' = absClamp ((halfWidth cfig - fromIntegral xbord) / z) xr
yr' = absClamp ((halfHeight w - fromIntegral ybord) / z) yr yr' = absClamp ((halfHeight cfig - fromIntegral ybord) / z) yr
fixedSizePicClampArrow fixedSizePicClampArrow
:: Float -- ^ horizontal border :: Float -- ^ horizontal border
-> Float -- ^ vertical border -> Float -- ^ vertical border
-> Picture -> Picture
-> Point2 -> Point2
-> Configuration
-> World -> World
-> Picture -> Picture
fixedSizePicClampArrow xbord ybord pic p w = pictures fixedSizePicClampArrow xbord ybord pic p cfig w = pictures
[ setLayer 4 . translate x y . scale theScale theScale $ pic [ setLayer 4 . translate x y . scale theScale theScale $ pic
, setLayer 4 . color white . setDepth 20 $ arrowPic , setLayer 4 . color white . setDepth 20 $ arrowPic
] ]
where where
winps = screenPolygon w winps = screenPolygon cfig w
bords = screenPolygonBord xbord ybord w bords = screenPolygonBord xbord ybord cfig w
borderPoint = intersectSegPolyFirst campos p bords borderPoint = intersectSegPolyFirst campos p bords
windowPoint = intersectSegPolyFirst campos p winps windowPoint = intersectSegPolyFirst campos p winps
arrowPic = case borderPoint of arrowPic = case borderPoint of
src/Dodge/Render.hs
+7 -6
View File
@@ -33,13 +33,14 @@ import Graphics.GL.Core43
doDrawing :: RenderData -> Universe -> IO Word32 doDrawing :: RenderData -> Universe -> IO Word32
doDrawing pdata u = do doDrawing pdata u = do
let w = _uvWorld u let w = _uvWorld u
cfig = _config u
sTicks <- SDL.ticks sTicks <- SDL.ticks
let rot = _cameraRot w let rot = _cameraRot w
camzoom = _cameraZoom w camzoom = _cameraZoom w
trans = _cameraCenter w trans = _cameraCenter w
wins@(V2 winx winy) = V2 (getWindowX w) (getWindowY w) wins@(V2 winx winy) = V2 (_windowX cfig) (_windowY cfig)
resFact = w ^. config . resolution_factor resFact = cfig ^. resolution_factor
(wallPointsCol,windowPoints) = wallsAndWindows w (wallPointsCol,windowPoints) = wallsAndWindows cfig w
lightPoints = lightsForGloom w lightPoints = lightsForGloom w
viewFroms@(V2 vfx vfy) = _cameraViewFrom w viewFroms@(V2 vfx vfy) = _cameraViewFrom w
viewFrom3d = Vector3 vfx vfy 20 viewFrom3d = Vector3 vfx vfy 20
@@ -51,7 +52,7 @@ doDrawing pdata u = do
shapeCounts <- UMV.replicate 3 (0 :: Int) shapeCounts <- UMV.replicate 3 (0 :: Int)
wlwiflCounts <- UMV.replicate 3 (0 :: Int) wlwiflCounts <- UMV.replicate 3 (0 :: Int)
-- attempt to poke in parallel -- attempt to poke in parallel
let (ws,wp) = worldSPic w let (ws,wp) = worldSPic cfig w
MP.bindM3 (\ _ _ _ -> return ()) MP.bindM3 (\ _ _ _ -> return ())
( pokeBindFoldableLayer shadV layerCounts wp) ( pokeBindFoldableLayer shadV layerCounts wp)
( pokeWallsWindowsFloor ( pokeWallsWindowsFloor
@@ -113,7 +114,7 @@ doDrawing pdata u = do
0 0
(fromIntegral nWalls) (fromIntegral nWalls)
--draw walls onto base buffer --draw walls onto base buffer
if w ^. config . wall_textured if cfig ^. wall_textured
then renderTextureWalls pdata nWalls then renderTextureWalls pdata nWalls
else renderBlankWalls pdata nWalls else renderBlankWalls pdata nWalls
--draw object pictures onto base buffer --draw object pictures onto base buffer
@@ -175,7 +176,7 @@ doDrawing pdata u = do
renderLayer 2 shadV layerCounts renderLayer 2 shadV layerCounts
--renderWindows pdata windowPoints --renderWindows pdata windowPoints
drawShader (_windowShader pdata) nWins drawShader (_windowShader pdata) nWins
when (_cloud_shadows $ _config w) $ do when (_cloud_shadows cfig) $ do
----render transparency depths ----render transparency depths
depthMask $= Enabled depthMask $= Enabled
blend $= Disabled blend $= Disabled
src/Dodge/Render/HUD.hs
+71 -71
View File
@@ -20,74 +20,74 @@ import Control.Lens
import SDL (MouseButton (..)) import SDL (MouseButton (..))
--import Data.Bifunctor --import Data.Bifunctor
hudDrawings :: World -> Picture hudDrawings :: Configuration -> World -> Picture
hudDrawings w = pictures hudDrawings cfig w = pictures
[ winScale w . dShadCol white $ displayHP 0 w [ winScale cfig . dShadCol white $ displayHP 0 cfig w
, renderListAt (halfWidth w) 0 w $ map (,white) (_testString w w) , renderListAt (halfWidth cfig) 0 cfig w $ map (,white) (_testString w w)
, selectionText , selectionText
] ]
where where
selectionText = if _carteDisplay w selectionText = if _carteDisplay w
then drawLocations w then drawLocations cfig w
else drawInventory w else drawInventory cfig w
drawInventory :: World -> Picture drawInventory :: Configuration -> World -> Picture
drawInventory w = subInventoryDisplay w `appendPic` displayInv 0 w drawInventory cfig w = subInventoryDisplay cfig w `appendPic` displayInv 0 cfig w
subInventoryDisplay :: World -> Picture subInventoryDisplay :: Configuration -> World -> Picture
subInventoryDisplay w = case _inventoryMode w of subInventoryDisplay cfig w = case _inventoryMode w of
LockedInventory -> topInvCursor col iPos w LockedInventory -> topInvCursor col iPos cfig w
TopInventory -> pictures TopInventory -> pictures
[ closeObjectTexts w [ closeObjectTexts cfig w
, topInvCursor col iPos w , topInvCursor col iPos cfig w
] ]
TweakInventory -> pictures TweakInventory -> pictures
[ mCurs it w [ mCurs it cfig w
, cursorAt 120 col 5 0 iPos w , cursorAt 120 col 5 0 iPos cfig
, cursorsZ w iPos it , cursorsZ cfig w iPos it
, displayMidList w (ammoTweakStrings it) "TWEAK" , displayMidList cfig w (ammoTweakStrings it) "TWEAK"
] ]
CombineInventory -> invHead w "COMBINE" CombineInventory -> invHead cfig w "COMBINE"
InspectInventory -> invHead w "INSPECT" InspectInventory -> invHead cfig w "INSPECT"
where where
itCol = fromMaybe (greyN 0.5) . (^? itInvColor) itCol = fromMaybe (greyN 0.5) . (^? itInvColor)
iPos = _crInvSel $ _creatures w IM.! _yourID w iPos = _crInvSel $ _creatures w IM.! _yourID w
it = yourItem w it = yourItem w
col = itCol it col = itCol it
cursorsZ :: World -> Int -> Item -> Picture cursorsZ :: Configuration -> World -> Int -> Item -> Picture
cursorsZ w ipos it = case it ^? wpAmmo . aoType . amParamSel of cursorsZ cfig w ipos it = case it ^? wpAmmo . aoType . amParamSel of
Nothing -> f $ zConnect sp (V2 (155- hw) ( hh - 77.5)) Nothing -> f $ zConnect sp (V2 (155- hw) ( hh - 77.5))
Just jpos -> f $ zConnect sp (V2 (155 - hw) ( hh - (20 * fromIntegral jpos + 77.5))) Just jpos -> f $ zConnect sp (V2 (155 - hw) ( hh - (20 * fromIntegral jpos + 77.5)))
where where
f = winScale w . color white f = winScale cfig . color white
hh = halfHeight w hh = halfHeight cfig
hw = halfWidth w hw = halfWidth cfig
sp = V2 (125 - hw) ( hh - (20 * fromIntegral ipos + 17.5)) sp = V2 (125 - hw) ( hh - (20 * fromIntegral ipos + 17.5))
topInvCursor :: Color -> Int -> World -> Picture topInvCursor :: Color -> Int -> Configuration -> World -> Picture
topInvCursor col iPos w topInvCursor col iPos cfig w
| ButtonRight `S.member` _mouseButtons w = | ButtonRight `S.member` _mouseButtons w =
cursorAt 100 col 5 0 iPos w cursorAt 100 col 5 0 iPos cfig
`appendPic` openCursorAt 20 col 105 0 iPos w `appendPic` openCursorAt 20 col 105 0 iPos cfig
| otherwise = mainListCursor col iPos w | otherwise = mainListCursor col iPos cfig
ammoTweakStrings :: Item -> [String] ammoTweakStrings :: Item -> [String]
ammoTweakStrings it = case it ^? wpAmmo . aoType . amPjParams of ammoTweakStrings it = case it ^? wpAmmo . aoType . amPjParams of
Just l -> map pjTweakString l Just l -> map pjTweakString l
_ -> ["NOT TWEAKABLE"] _ -> ["NOT TWEAKABLE"]
mCurs :: Item -> World -> Picture mCurs :: Item -> Configuration -> World -> Picture
mCurs it w = case it ^? wpAmmo . aoType . amParamSel of mCurs it cfig w = case it ^? wpAmmo . aoType . amParamSel of
Nothing -> [] Nothing -> []
Just i Just i
| ButtonRight `S.member` _mouseButtons w -> | ButtonRight `S.member` _mouseButtons w ->
pictures pictures
[cursorAt x white y 60 i w [cursorAt x white y 60 i cfig
,openCursorAt 20 white (x+y) 60 i w ,openCursorAt 20 white (x+y) 60 i cfig
] ]
| otherwise -> openCursorAt 140 white 155 60 i w | otherwise -> openCursorAt 140 white 155 60 i cfig
where where
x = 117.5 x = 117.5
y = 155 y = 155
@@ -95,40 +95,40 @@ mCurs it w = case it ^? wpAmmo . aoType . amParamSel of
pjTweakString :: PjParam -> String pjTweakString :: PjParam -> String
pjTweakString pj = _pjDisplayParam pj $ _pjIntParam pj pjTweakString pj = _pjDisplayParam pj $ _pjIntParam pj
displayMidList :: World -> [String] -> String -> Picture displayMidList :: Configuration -> World -> [String] -> String -> Picture
displayMidList w strs s = displayMidList cfig w strs s =
invHead w s invHead cfig w s
`appendPic` renderListAt 150 (-60) w (map (,white) strs) `appendPic` renderListAt 150 (-60) cfig w (map (,white) strs)
invHead :: World -> String -> Picture invHead :: Configuration -> World -> String -> Picture
invHead w s = winScale w . translate (-130) (halfHeight w - 40) . dShadCol white . scale 0.4 0.4 $ text s invHead cfig w s = winScale cfig . translate (-130) (halfHeight cfig - 40) . dShadCol white . scale 0.4 0.4 $ text s
renderItemMapAt :: Float -> Float -> World -> IM.IntMap Item -> Picture renderItemMapAt :: Float -> Float -> Configuration -> IM.IntMap Item -> Picture
{-# INLINE renderItemMapAt #-} {-# INLINE renderItemMapAt #-}
renderItemMapAt tx ty w = concatMapPic (uncurry $ listItemAt tx ty w) . IM.toList renderItemMapAt tx ty w = concatMapPic (uncurry $ listItemAt tx ty w) . IM.toList
displayInv :: Int -> World -> Picture displayInv :: Int -> Configuration -> World -> Picture
displayInv n w = renderItemMapAt 0 0 w (_crInv cr) displayInv n cfig w = renderItemMapAt 0 0 cfig (_crInv cr)
<> equipcursor <> equipcursor
where where
equipcursor = case _crLeftInvSel cr of equipcursor = case _crLeftInvSel cr of
Nothing -> mempty Nothing -> mempty
Just invid -> openCursorAt 20 yellow 105 0 invid w Just invid -> openCursorAt 20 yellow 105 0 invid cfig
cr = _creatures w IM.! n cr = _creatures w IM.! n
drawLocations :: World -> Picture drawLocations :: Configuration -> World -> Picture
drawLocations w = pictures $ drawLocations cfig w = pictures $
renderListAt 0 0 w locs renderListAt 0 0 cfig w locs
: zipWith bConnect (displayListEndCoords w locTexts) locPoss : zipWith bConnect (displayListEndCoords cfig locTexts) locPoss
++ mapOverlay w ++ mapOverlay cfig w
++ [mainListCursor white iPos w] ++ [mainListCursor white iPos cfig]
where where
iPos = _selLocation w iPos = _selLocation w
locs = map (\(_,s) -> (s,white)) . IM.elems . _seenLocations $ w locs = map (\(_,s) -> (s,white)) . IM.elems . _seenLocations $ w
locPoss = map (cartePosToScreen w . ($ w) . fst) . IM.elems . _seenLocations $ w locPoss = map (cartePosToScreen cfig w . ($ w) . fst) . IM.elems . _seenLocations $ w
locTexts = map fst locs locTexts = map fst locs
displayListEndCoords :: World -> [String] -> [Point2] displayListEndCoords :: Configuration -> [String] -> [Point2]
displayListEndCoords w ss = map g $ zipWith h ss $ map f [1..] displayListEndCoords w ss = map g $ zipWith h ss $ map f [1..]
where where
f :: Int -> Point2 f :: Int -> Point2
@@ -138,14 +138,14 @@ displayListEndCoords w ss = map g $ zipWith h ss $ map f [1..]
h s (V2 x y) = V2 (x + 9 * fromIntegral (length s)) y h s (V2 x y) = V2 (x + 9 * fromIntegral (length s)) y
mapOverlay :: World -> [Picture] mapOverlay :: Configuration -> World -> [Picture]
mapOverlay w = (color (withAlpha 0.5 black) . polygon $ rectNSEW 1 (-1) (-1) 1) : mapOverlay cfig w = (color (withAlpha 0.5 black) . polygon $ rectNSEW 1 (-1) (-1) 1) :
(mapMaybe (mapWall w) . IM.elems $ _walls w) (mapMaybe (mapWall cfig w) . IM.elems $ _walls w)
mapWall :: World -> Wall -> Maybe Picture mapWall :: Configuration -> World -> Wall -> Maybe Picture
mapWall w wl = mapWall cfig w wl =
if _wlSeen wl if _wlSeen wl
then Just . color c . polygon $ map (cartePosToScreen w) [x,x +.+ n2,y +.+ n2, y] then Just . color c . polygon $ map (cartePosToScreen cfig w) [x,x +.+ n2,y +.+ n2, y]
else Nothing else Nothing
where where
t = normalizeV (y -.- x) t = normalizeV (y -.- x)
@@ -153,10 +153,10 @@ mapWall w wl =
(x,y) = _wlLine wl (x,y) = _wlLine wl
c = _wlColor wl c = _wlColor wl
{- | Pictures of popup text for items close to your position.-} {- | Pictures of popup text for items close to your position.-}
closeObjectTexts :: World -> Picture closeObjectTexts :: Configuration -> World -> Picture
closeObjectTexts w = pictures $ closeObjectTexts cfig w = pictures $
renderListAt pushout (negate 20 * fromIntegral invPos) renderListAt pushout (negate 20 * fromIntegral invPos)
w (map colAndText $ _closeObjects w) cfig w (map colAndText $ _closeObjects w)
: maybeToList maybeLine : maybeToList maybeLine
where where
colAndText (Left x) = ( _itName $ _flIt x, _itInvColor $ _flIt x) colAndText (Left x) = ( _itName $ _flIt x, _itInvColor $ _flIt x)
@@ -177,17 +177,17 @@ closeObjectTexts w = pictures $
itScreenPos <- mayScreenPos itScreenPos <- mayScreenPos
(theText,col) <- fmap colAndText mayObj (theText,col) <- fmap colAndText mayObj
let textWidth = 9 * fromIntegral (length theText) let textWidth = 9 * fromIntegral (length theText)
let p = V2 (textWidth + 15 + pushout - halfWidth w) let p = V2 (textWidth + 15 + pushout - halfWidth cfig)
( halfHeight w - 20* (fromIntegral invPos +1) + 2.5) ( halfHeight cfig - 20* (fromIntegral invPos +1) + 2.5)
return . winScale w . color col $ lConnect p itScreenPos return . winScale cfig . color col $ lConnect p itScreenPos
mainListCursor :: Color -> Int -> World -> Picture mainListCursor :: Color -> Int -> Configuration -> Picture
mainListCursor c = openCursorAt 120 c 5 0 mainListCursor c = openCursorAt 120 c 5 0
listItemAt listItemAt
:: Float -- ^ x offset :: Float -- ^ x offset
-> Float -- ^ y offset -> Float -- ^ y offset
-> World -> Configuration
-> Int -- ^ y offset (discrete) -> Int -- ^ y offset (discrete)
-> Item -- ^ The item -> Item -- ^ The item
-> Picture -> Picture
@@ -220,7 +220,7 @@ openCursorAt
-> Float -- ^ x offset -> Float -- ^ x offset
-> Float -- ^ y offset -> Float -- ^ y offset
-> Int -- ^ y offset (discrete) -> Int -- ^ y offset (discrete)
-> World -> Configuration
-> Picture -> Picture
openCursorAt wth col xoff yoff yint w = winScale w openCursorAt wth col xoff yoff yint w = winScale w
. translate (xoff-halfWidth w) (halfHeight w - (20* fromIntegral yint + yoff) - 20) . translate (xoff-halfWidth w) (halfHeight w - (20* fromIntegral yint + yoff) - 20)
@@ -236,7 +236,7 @@ cursorAt
-> Float -- ^ x offset -> Float -- ^ x offset
-> Float -- ^ y offset -> Float -- ^ y offset
-> Int -- ^ y offset (discrete) -> Int -- ^ y offset (discrete)
-> World -> Configuration
-> Picture -> Picture
cursorAt wth col xoff yoff yint w = winScale w cursorAt wth col xoff yoff yint w = winScale w
. translate (xoff-halfWidth w) (halfHeight w - (20* fromIntegral yint + yoff) - 20) . translate (xoff-halfWidth w) (halfHeight w - (20* fromIntegral yint + yoff) - 20)
@@ -249,11 +249,11 @@ cursorAt wth col xoff yoff yint w = winScale w
,V2 wth 12.5 ,V2 wth 12.5
] ]
displayHP :: Int -> World -> Picture displayHP :: Int -> Configuration -> World -> Picture
displayHP n w = translate (halfWidth w-80) (halfHeight w-20) displayHP cid cfig w = translate (halfWidth cfig-80) (halfHeight cfig-20)
. scale 0.2 0.2 . scale 0.2 0.2
. text . text
. leftPad 5 ' ' . leftPad 5 ' '
. show . show
. _crHP . _crHP
$ _creatures w IM.! n $ _creatures w IM.! cid
src/Dodge/Render/List.hs
+7 -8
View File
@@ -6,22 +6,24 @@ module Dodge.Render.List
where where
import Dodge.Data import Dodge.Data
import Dodge.Base.Window import Dodge.Base.Window
import Dodge.WinScale
import Picture import Picture
renderListAt :: Float -> Float -> World -> [(String,Color)] -> Picture renderListAt :: Float -> Float -> Configuration -> World -> [(String,Color)] -> Picture
renderListAt tx ty w = renderListAt tx ty cfig w =
concatMapPic (winScale w) . zipWith (listPairAt tx ty w) [0..] concatMapPic (winScale cfig) . zipWith (listPairAt tx ty cfig w) [0..]
listPairAt listPairAt
:: Float -- ^ x offset :: Float -- ^ x offset
-> Float -- ^ y offset -> Float -- ^ y offset
-> Configuration
-> World -> World
-> Int -- ^ y offset (discrete) -> Int -- ^ y offset (discrete)
-> (String,Color) -- ^ The text item -> (String,Color) -- ^ The text item
-> Picture -> Picture
{-# INLINE listPairAt #-} {-# INLINE listPairAt #-}
listPairAt xoff yoff w yint (s,col) listPairAt xoff yoff cfig w yint (s,col)
= translate (xoff + 15 - halfWidth w) (yoff + halfHeight w - (20 * (fromIntegral yint+1))) = translate (xoff + 15 - halfWidth cfig) (yoff + halfHeight cfig - (20 * (fromIntegral yint+1)))
. scale 0.1 0.1 . scale 0.1 0.1
. dShadCol col . dShadCol col
$ text s $ text s
@@ -33,6 +35,3 @@ dShadCol c p = pictures
[ color black $ translate 1.2 (-1.2) p [ color black $ translate 1.2 (-1.2) p
, color c p , color c p
] ]
winScale :: World -> Picture -> Picture
{-# INLINE winScale #-}
winScale w = scale (2 / getWindowX w) (2 / getWindowY w)
src/Dodge/Render/MenuScreen.hs
+31 -34
View File
@@ -15,47 +15,43 @@ menuScreen w screen = case screen of
-> drawOptions w (titf w) mos -> drawOptions w (titf w) mos
(WaitScreen sf _) -> drawOptions w (sf w) [] (WaitScreen sf _) -> drawOptions w (sf w) []
(InputScreen s) -> drawOptions w ('>':s) [] (InputScreen s) -> drawOptions w ('>':s) []
(TerminalScreen t xs ) -> displayStringList (_uvWorld w) $ map snd $ filter (( > t) . fst) xs
(DisplayScreen sd ) -> sd w (DisplayScreen sd ) -> sd w
(ColumnsScreen title pairs) -> drawTwoColumnsScreen (_uvWorld w) title pairs (ColumnsScreen title pairs) -> drawTwoColumnsScreen (_config w) (_uvWorld w) title pairs
displayStringList :: World -> [String] -> Picture --displayStringList :: World -> [String] -> Picture
displayStringList w ss = pictures --displayStringList w ss = pictures
( polygon (screenBox w) -- ( polygon (screenBox w)
: zipWith f ys ss -- : zipWith f ys ss
) -- )
where -- where
hw = halfWidth w -- hw = halfWidth w
ys = [0,22..] -- ys = [0,22..]
f y s = translate (10-hw) y . scale 0.15 0.15 $ text s -- f y s = translate (10-hw) y . scale 0.15 0.15 $ text s
drawTwoColumnsScreen drawTwoColumnsScreen :: Configuration -> World -> String -> [(String,String)] -> Picture
:: World drawTwoColumnsScreen cfig w title lps = pictures
-> String [darkenBackground cfig
-> [(String,String)] ,drawTitle cfig w title
-> Picture ,drawTwoColumns cfig w lps
drawTwoColumnsScreen w title lps = pictures
[darkenBackground w
,drawTitle w title
,drawTwoColumns w lps
] ]
drawTwoColumns :: World -> [(String,String)] -> Picture drawTwoColumns :: Configuration -> World -> [(String,String)] -> Picture
drawTwoColumns w lps = pictures $ zipWith f [hh-100,hh-130..] lps drawTwoColumns cfig w lps = pictures $ zipWith f [hh-100,hh-130..] lps
where where
f y (s1,s2) = translate (50-hw) y $ sc $ rightPad ln '.' s1 ++ s2 f y (s1,s2) = translate (50-hw) y $ sc $ rightPad ln '.' s1 ++ s2
sc = scale 0.15 0.15 . color white . text sc = scale 0.15 0.15 . color white . text
hh = halfHeight w hh = halfHeight cfig
hw = halfWidth w hw = halfWidth cfig
ln = maximum (map (length . fst) lps) + 3 ln = maximum (map (length . fst) lps) + 3
drawOptions :: Universe drawOptions
:: Universe
-> String -- ^ Title -> String -- ^ Title
-> [MenuOption] -- ^ Options -> [MenuOption] -- ^ Options
-> Picture -> Picture
drawOptions w title ops = pictures $ drawOptions w title ops = pictures $
[darkenBackground (_uvWorld w) [darkenBackground (_config w)
,drawTitle (_uvWorld w) title] ,drawTitle (_config w) (_uvWorld w) title]
++ ++
zipWith (\ s vpos -> placeString (-hw + 50) vpos 0.2 s) (map (menuOptionToString w) ops') [hh-100,hh-150 ..] zipWith (\ s vpos -> placeString (-hw + 50) vpos 0.2 s) (map (menuOptionToString w) ops') [hh-100,hh-150 ..]
where where
@@ -63,18 +59,19 @@ drawOptions w title ops = pictures $
notInvisible InvisibleToggle {} = False notInvisible InvisibleToggle {} = False
notInvisible _ = True notInvisible _ = True
placeString x y sc t = translate x y $ scale sc sc $ color white $ text t placeString x y sc t = translate x y $ scale sc sc $ color white $ text t
hh = halfHeight (_uvWorld w) hh = halfHeight cfig
hw = halfWidth (_uvWorld w) hw = halfWidth cfig
cfig = _config w
darkenBackground :: World -> Picture darkenBackground :: Configuration -> Picture
darkenBackground = color (withAlpha 0.5 black) . polygon . screenBox darkenBackground = color (withAlpha 0.5 black) . polygon . screenBox
drawTitle :: World -> String -> Picture drawTitle :: Configuration -> World -> String -> Picture
drawTitle w = placeString (-hw + 30) (hh - 50) 0.4 drawTitle cfig w = placeString (-hw + 30) (hh - 50) 0.4
where where
placeString x y sc t = translate x y $ scale sc sc $ color white $ text t placeString x y sc t = translate x y $ scale sc sc $ color white $ text t
hh = halfHeight w hh = halfHeight cfig
hw = halfWidth w hw = halfWidth cfig
menuOptionToString :: Universe -> MenuOption -> String menuOptionToString :: Universe -> MenuOption -> String
menuOptionToString w mo = theKeys ++ _moString mo w menuOptionToString w mo = theKeys ++ _moString mo w
src/Dodge/Render/Picture.hs
+8 -6
View File
@@ -4,6 +4,7 @@ module Dodge.Render.Picture
) where ) where
import Dodge.Data import Dodge.Data
import Dodge.Base.Window import Dodge.Base.Window
import Dodge.WinScale
import Dodge.Picture.Layer import Dodge.Picture.Layer
import Dodge.Render.HUD import Dodge.Render.HUD
import Dodge.Render.MenuScreen import Dodge.Render.MenuScreen
@@ -13,16 +14,17 @@ import Picture
fixedCoordPictures :: Universe -> Picture fixedCoordPictures :: Universe -> Picture
fixedCoordPictures w = case _menuLayers w of fixedCoordPictures w = case _menuLayers w of
[] -> pictures [] -> pictures
[ hudDrawings (_uvWorld w) [ hudDrawings (_config w) (_uvWorld w)
, customMouseCursor (_uvWorld w) , customMouseCursor (_config w) (_uvWorld w)
] ]
(lay:_) -> scaler . onLayer MenuDepth $ menuScreen w lay (lay:_) -> scaler . onLayer MenuDepth $ menuScreen w lay
where where
scaler = setDepth (-1) . scale (2 / getWindowX (_uvWorld w)) (2 / getWindowY (_uvWorld w)) scaler = setDepth (-1) . scale (2 / getWindowX cfig) (2 / getWindowY cfig)
cfig = _config w
customMouseCursor :: World -> Picture customMouseCursor :: Configuration -> World -> Picture
customMouseCursor w = customMouseCursor cfig w =
scale (2 /getWindowX w) (2/ getWindowY w) winScale cfig
. uncurryV translate (_mousePos w) . uncurryV translate (_mousePos w)
. color white . color white
$ pictures [ line [V2 (-5) 0,V2 5 0] , line [V2 0 (-5),V2 0 5] ] $ pictures [ line [V2 (-5) 0,V2 5 0] , line [V2 0 (-5),V2 0 5] ]
src/Dodge/Render/ShapePicture.hs
+21 -21
View File
@@ -24,33 +24,33 @@ import qualified Data.Map.Strict as M
--import Control.Lens --import Control.Lens
--import Data.Maybe --import Data.Maybe
worldSPic :: World -> SPic worldSPic :: Configuration -> World -> SPic
worldSPic w = worldSPic cfig w =
(extraShapes w, extraPics w) (extraShapes w, extraPics cfig w)
<> foldMap (dbArg _prDraw) (filtOn _pjPos _props) <> foldMap (dbArg _prDraw) (filtOn _pjPos _props)
<> foldMap (($ w) . dbArg _crPict) (filtOn _crPos _creatures) <> foldMap ((($ w) . ($ cfig)) . dbArg _crPict) (filtOn _crPos _creatures)
<> foldMap floorItemSPic (filtOn _flItPos _floorItems) <> foldMap floorItemSPic (filtOn _flItPos _floorItems)
<> foldMap btSPic (filtOn _btPos _buttons) <> foldMap btSPic (filtOn _btPos _buttons)
<> foldMap mcSPic (filtOn _mcPos _machines) <> foldMap mcSPic (filtOn _mcPos _machines)
where where
filtOn f g = IM.filter (pointIsClose . f) (g w) filtOn f g = IM.filter (pointIsClose . f) (g w)
pointIsClose p = dist camCen p < winSize pointIsClose p = dist camCen p < winSize
winSize = 30 + max (getWindowX w) (getWindowY w) winSize = 30 + max (getWindowX cfig) (getWindowY cfig)
camCen = _cameraCenter w camCen = _cameraCenter w
extraShapes :: World -> Shape extraShapes :: World -> Shape
extraShapes = _foregroundShape extraShapes = _foregroundShape
extraPics :: World -> Picture extraPics :: Configuration -> World -> Picture
extraPics w = pictures (_decorations w) extraPics cfig w = pictures (_decorations w)
<> concatMapPic (dbArg _ptDraw) (_particles w) <> concatMapPic (dbArg _ptDraw) (_particles w)
<> concatMapPic (dbArg _lsPict) (_lightSources w) <> concatMapPic (dbArg _lsPict) (_lightSources w)
<> testPic w <> testPic w
<> concatMapPic clDraw (_clouds w ) <> concatMapPic clDraw (_clouds w )
<> concatMapPic ppDraw (_pressPlates w ) <> concatMapPic ppDraw (_pressPlates w )
<> soundPics w <> soundPics cfig w
<> viewBoundaries w <> viewBoundaries cfig w
<> drawPathing w <> drawPathing cfig w
-- TODO remove duplicate! -- TODO remove duplicate!
testPic :: World -> Picture testPic :: World -> Picture
@@ -71,13 +71,13 @@ mcSPic :: Machine -> SPic
mcSPic bt = uncurryV translateSPf (_mcPos bt) mcSPic bt = uncurryV translateSPf (_mcPos bt)
$ rotateSP (_mcDir bt) (_mcDraw bt bt) $ rotateSP (_mcDir bt) (_mcDraw bt bt)
soundPics :: World -> Picture soundPics :: Configuration -> World -> Picture
soundPics w soundPics cfig w
| _show_sound (_config w) = pictures $ M.map (soundPic w) $ _playingSounds w | _show_sound cfig = pictures $ M.map (soundPic cfig w) $ _playingSounds w
| otherwise = [] | otherwise = []
soundPic :: World -> Sound -> Picture soundPic :: Configuration -> World -> Sound -> Picture
soundPic w s = fixedSizePicClampArrow 50 50 thePic p w soundPic cfig w s = fixedSizePicClampArrow 50 50 thePic p cfig w
where where
p = _soundPos s p = _soundPos s
thePic thePic
@@ -89,9 +89,9 @@ soundPic w s = fixedSizePicClampArrow 50 50 thePic p w
theScale = 0.15 * f (_soundVolume s * 0.0001) theScale = 0.15 * f (_soundVolume s * 0.0001)
f x = 1 - 0.5 * (1 - x) f x = 1 - 0.5 * (1 - x)
drawPathing :: World -> Picture drawPathing :: Configuration -> World -> Picture
drawPathing w drawPathing cfig w
| _debug_pathing (_config w) | _debug_pathing cfig
= -- setLayer 5 $ = -- setLayer 5 $
(color green . pictures . map (flip thickLine 5 . tflat2) $ graphToEdges gr) (color green . pictures . map (flip thickLine 5 . tflat2) $ graphToEdges gr)
<> concatMap dispInc (graphToIncidence gr) <> concatMap dispInc (graphToIncidence gr)
@@ -99,9 +99,9 @@ drawPathing w
where where
dispInc (p,n) = setDepth 2 . uncurryV translate p . scale 0.1 0.1 $ text $ show n dispInc (p,n) = setDepth 2 . uncurryV translate p . scale 0.1 0.1 $ text $ show n
gr = _pathGraph w gr = _pathGraph w
viewBoundaries :: World -> Picture viewBoundaries :: Configuration -> World -> Picture
viewBoundaries w viewBoundaries cfig w
| _debug_view_boundaries (_config w) | _debug_view_boundaries cfig
= setLayer 5 $ color green (concatMap (polygonWire . _grBound) grs) = setLayer 5 $ color green (concatMap (polygonWire . _grBound) grs)
<> color yellow (concatMap (\q -> line [p,q]) $ farWallPoints p w) <> color yellow (concatMap (\q -> line [p,q]) $ farWallPoints p w)
| otherwise = [] | otherwise = []
src/Dodge/Render/Walls.hs
+4 -3
View File
@@ -8,12 +8,13 @@ import Geometry
import Data.List import Data.List
import qualified Data.IntMap.Strict as IM import qualified Data.IntMap.Strict as IM
wallsAndWindows wallsAndWindows
:: World :: Configuration
-> World
-> ( [((Point2,Point2),Point4)] ,[((Point2,Point2),Point4)] ) -> ( [((Point2,Point2),Point4)] ,[((Point2,Point2),Point4)] )
wallsAndWindows w wallsAndWindows cfig w
= (map f wls, map f wins) = (map f wls, map f wins)
where where
f wl = (_wlLine wl, _wlColor wl) f wl = (_wlLine wl, _wlColor wl)
(wins,wls) = partition theTest . IM.elems . IM.filter _wlDraw $ wallsDoubleScreen w (wins,wls) = partition theTest . IM.elems . IM.filter _wlDraw $ wallsDoubleScreen cfig w
theTest wl = _wlOpacity wl /= Opaque theTest wl = _wlOpacity wl /= Opaque
src/Dodge/Update.hs
+9 -11
View File
@@ -3,8 +3,7 @@ Module : Dodge.Update
Description : Simulation update Description : Simulation update
-} -}
module Dodge.Update module Dodge.Update
(update ( updateUniverse
,updateUniverse
) where ) where
import Dodge.Data import Dodge.Data
import Dodge.Hammer import Dodge.Hammer
@@ -31,7 +30,7 @@ import System.Random
updateUniverse :: Universe -> Universe updateUniverse :: Universe -> Universe
updateUniverse w = case _menuLayers w of updateUniverse w = case _menuLayers w of
(TerminalScreen t xs:mls) -> w & menuLayers .~ (TerminalScreen (max (t-1) 0) xs:mls) -- (TerminalScreen t xs:mls) -> w & menuLayers .~ (TerminalScreen (max (t-1) 0) xs:mls)
(WaitScreen s i : _) (WaitScreen s i : _)
| i < 1 -> w & over uvWorld (dbArg _worldEvents) | i < 1 -> w & over uvWorld (dbArg _worldEvents)
| otherwise -> w & menuLayers %~ ( (WaitScreen s (i-1) :) . tail ) | otherwise -> w & menuLayers %~ ( (WaitScreen s (i-1) :) . tail )
@@ -42,19 +41,18 @@ updateUniverse w = case _menuLayers w of
-- $ updateClouds -- $ updateClouds
w w
(_ : _) -> w (_ : _) -> w
[] -> over uvWorld update w [] -> over uvWorld (functionalUpdate (_config w)) w
update :: World -> World
update = (frameClock +~ 1) . functionalUpdate
{- | The update step. {- | The update step.
For most menus the only way to change the world is using event handling. -} For most menus the only way to change the world is using event handling. -}
functionalUpdate :: World -> World functionalUpdate :: Configuration -> World -> World
functionalUpdate w = checkEndGame functionalUpdate cfig w = checkEndGame
. (worldClock +~ 1)
. updateDistortions . updateDistortions
. updateCreatureSoundPositions . updateCreatureSoundPositions
. ppEvents . ppEvents
. updateCamera . updateCamera cfig
. colCrsWalls . colCrsWalls cfig
-- . ifConfigWallRotate -- . ifConfigWallRotate
. simpleCrSprings . simpleCrSprings
. zoneCreatures . zoneCreatures
src/Dodge/Update/Camera.hs
+16 -16
View File
@@ -28,8 +28,8 @@ import qualified SDL
--import qualified Control.Foldl as L --import qualified Control.Foldl as L
{- Update the screen camera rotation and position, including any in rold scope/remote camera modifiers; {- Update the screen camera rotation and position, including any in rold scope/remote camera modifiers;
update where your avatar's view is from. -} update where your avatar's view is from. -}
updateCamera :: World -> World updateCamera :: Configuration -> World -> World
updateCamera = rotateCamera . autoZoomCamera . moveCamera . updateScopeZoom updateCamera cfig = rotateCamera cfig . autoZoomCamera cfig . moveCamera . updateScopeZoom
{- Updte the center of the screen camera center and where your avatar's view is from in world. -} {- Updte the center of the screen camera center and where your avatar's view is from in world. -}
moveCamera :: World -> World moveCamera :: World -> World
moveCamera w = w moveCamera w = w
@@ -99,9 +99,9 @@ zoomOutLongGun w
wp = _crInv (_creatures w IM.! 0) IM.! _crInvSel (_creatures w IM.! 0) wp = _crInv (_creatures w IM.! 0) IM.! _crInvSel (_creatures w IM.! 0)
Just currentZoom = wp ^? itAttachment . scopeZoom Just currentZoom = wp ^? itAttachment . scopeZoom
ifConfigWallRotate :: World -> World ifConfigWallRotate :: Configuration -> World -> World
ifConfigWallRotate w ifConfigWallRotate cfig w
| _rotate_to_wall (_config w) && not (SDL.ButtonRight `S.member` _mouseButtons w) | _rotate_to_wall cfig && not (SDL.ButtonRight `S.member` _mouseButtons w)
= rotateToOverlappingWall w = rotateToOverlappingWall w
| otherwise = w | otherwise = w
@@ -128,12 +128,12 @@ rotateCameraBy x w = w
& creatures . ix 0 . crInv . ix (_crInvSel (_creatures w IM.! 0)) & creatures . ix 0 . crInv . ix (_crInvSel (_creatures w IM.! 0))
. itAttachment . scopePos %~ rotateV x . itAttachment . scopePos %~ rotateV x
rotateCamera :: World -> World rotateCamera :: Configuration -> World -> World
rotateCamera w rotateCamera cfig w
| keyl && keyr = w | keyl && keyr = w
| keyl = rotateCameraBy 0.025 w | keyl = rotateCameraBy 0.025 w
| keyr = rotateCameraBy (-0.025) w | keyr = rotateCameraBy (-0.025) w
| otherwise = ifConfigWallRotate w | otherwise = ifConfigWallRotate cfig w
where where
keyl = SDL.ScancodeQ `S.member` _keys w keyl = SDL.ScancodeQ `S.member` _keys w
keyr = SDL.ScancodeE `S.member` _keys w keyr = SDL.ScancodeE `S.member` _keys w
@@ -152,8 +152,8 @@ zoomNoItem
-> Float -> Float
zoomNoItem = min 20 . max 0.2 zoomNoItem = min 20 . max 0.2
{- Automatically sets the zoom of the camera according to the surrounding walls. -} {- Automatically sets the zoom of the camera according to the surrounding walls. -}
autoZoomCamera :: World -> World autoZoomCamera :: Configuration -> World -> World
autoZoomCamera w autoZoomCamera cfig w
-- | zoomInKey (_keyConfig w) `S.member` _keys w -- | zoomInKey (_keyConfig w) `S.member` _keys w
-- = zoomCamBy 0.01 w -- = zoomCamBy 0.01 w
-- | zoomOutKey (_keyConfig w) `S.member` _keys w -- | zoomOutKey (_keyConfig w) `S.member` _keys w
@@ -161,7 +161,7 @@ autoZoomCamera w
= w & cameraZoom %~ changeZoom = w & cameraZoom %~ changeZoom
where where
camPos = _cameraViewFrom w camPos = _cameraViewFrom w
wallZoom = farWallDist camPos w wallZoom = farWallDist camPos cfig w
idealZoom idealZoom
| SDL.ButtonRight `S.member` _mouseButtons w | SDL.ButtonRight `S.member` _mouseButtons w
= theScopeZoom * maybe zoomNoItem zoomFromItem (yourItem w ^? itUse . useAim . aimZoom) wallZoom = theScopeZoom * maybe zoomNoItem zoomFromItem (yourItem w ^? itUse . useAim . aimZoom) wallZoom
@@ -176,16 +176,16 @@ autoZoomCamera w
zoomOutSpeed = 15 zoomOutSpeed = 15
theScopeZoom = fromMaybe 1 $ yourItem w ^? itAttachment . scopeZoom theScopeZoom = fromMaybe 1 $ yourItem w ^? itAttachment . scopeZoom
farWallDist :: Point2 -> World -> Float farWallDist :: Point2 -> Configuration -> World -> Float
farWallDist p w = (winFac /) . min maxViewDistance $ ssfold (> maxViewDistance) findMax 1 vps farWallDist p cfig w = (winFac /) . min maxViewDistance $ ssfold (> maxViewDistance) findMax 1 vps
where where
findMax curMax pout = max curMax $ dist p $ collidePointUpToIndirectMinDist p pout curMax wos findMax curMax pout = max curMax $ dist p $ collidePointUpToIndirectMinDist p pout curMax wos
hw = halfWidth w hw = halfWidth cfig
hh = halfHeight w hh = halfHeight cfig
winFac = min hw hh winFac = min hw hh
vps = concatMap _grViewpoints grs ++ extendedViewPoints p grs vps = concatMap _grViewpoints grs ++ extendedViewPoints p grs
grs = filter (pointInOrOnPolygon p . _grBound) (_gameRooms w) grs = filter (pointInOrOnPolygon p . _grBound) (_gameRooms w)
wos = wallsOnScreen w wos = wallsOnScreen cfig w
extendedViewPoints :: Point2 -> [GameRoom] -> [Point2] extendedViewPoints :: Point2 -> [GameRoom] -> [Point2]
extendedViewPoints p grs = map extend extendedViewPoints p grs = map extend
src/Dodge/WallCreatureCollisions.hs
+25 -5
View File
@@ -2,6 +2,7 @@
module Dodge.WallCreatureCollisions module Dodge.WallCreatureCollisions
( colCrsWalls ( colCrsWalls
, colCrWall , colCrWall
, colCrWall'
, pushCreatureOutFromWalls , pushCreatureOutFromWalls
, crOnWall , crOnWall
) where ) where
@@ -18,11 +19,11 @@ import Data.Function
import Control.Lens import Control.Lens
import qualified Data.IntMap.Strict as IM import qualified Data.IntMap.Strict as IM
colCrsWalls :: World -> World colCrsWalls :: Configuration -> World -> World
colCrsWalls w = w & creatures %~ fmap (colCrWall w) colCrsWalls cfig w = w & creatures %~ fmap (colCrWall cfig w)
colCrWall :: World -> Creature -> Creature colCrWall :: Configuration -> World -> Creature -> Creature
colCrWall w c colCrWall cfig w c
| noclipIsOn && _crID c == 0 = c -- for noclip | noclipIsOn && _crID c == 0 = c -- for noclip
| p1 == p2 = pushOrCrush ls c | p1 == p2 = pushOrCrush ls c
-- | _crPos c' == _crPos c'' = c' -- | _crPos c' == _crPos c'' = c'
@@ -40,7 +41,26 @@ colCrWall w c
ls = IM.elems $ _wlLine <$> wls ls = IM.elems $ _wlLine <$> wls
wls = IM.filter (not . _wlWalkable) $ wallsNearPoint p2 w wls = IM.filter (not . _wlWalkable) $ wallsNearPoint p2 w
--wallPoints = map fst ls --wallPoints = map fst ls
noclipIsOn = _debug_noclip $ _config w noclipIsOn = _debug_noclip cfig
colCrWall' :: World -> Creature -> Creature
colCrWall' w c
| p1 == p2 = pushOrCrush ls c
-- | _crPos c' == _crPos c'' = c'
-- | otherwise = c & crPos .~ _crOldPos c
| otherwise = c'
where
-- c'' = c' & crPos %~ pushOutFromWalls rad ls
--c' = c & crPos %~ pushOutFromWalls' rad (reverse ls)
c' = c & crPos %~ pushOutFromCorners rad ls
. pushOutFromWalls rad ls
. flip (collidePointWalls p1) wls -- check push throughs
rad = _crRad c + wallBuffer
p1 = _crOldPos c
p2 = _crPos c
ls = IM.elems $ _wlLine <$> wls
wls = IM.filter (not . _wlWalkable) $ wallsNearPoint p2 w
--wallPoints = map fst ls
-- the amount to push creatures out from walls, extra to their radius -- the amount to push creatures out from walls, extra to their radius
wallBuffer :: Float wallBuffer :: Float
src/Dodge/WinScale.hs
+7
View File
@@ -0,0 +1,7 @@
module Dodge.WinScale where
import Dodge.Config.Data
import Picture
winScale :: Configuration -> Picture -> Picture
{-# INLINE winScale #-}
winScale cfig = scale (2 / _windowX cfig) (2 / _windowY cfig)
src/Dodge/Zone.hs
+9 -9
View File
@@ -76,17 +76,17 @@ zoneOfLineIntMap = ddaExt zoneSize
zoneOfCircle :: Point2 -> Float -> [(Int,Int)] zoneOfCircle :: Point2 -> Float -> [(Int,Int)]
zoneOfCircle p r = concatMap zoneNearPoint $ divideCircle (1.5 * zoneSize) p r zoneOfCircle p r = concatMap zoneNearPoint $ divideCircle (1.5 * zoneSize) p r
zoneOfSight :: World -> [(Int,Int)] zoneOfSight :: Configuration -> World -> [(Int,Int)]
zoneOfSight w = zoneOfSight cfig w =
[(a,b) [(a,b)
| a <- [minimum xs .. maximum xs] | a <- [minimum xs .. maximum xs]
, b <- [minimum ys .. maximum ys] , b <- [minimum ys .. maximum ys]
] ]
where where
(xs,ys) = unzip $ map zoneOfPoint $ screenPolygon w ++ [_cameraViewFrom w] (xs,ys) = unzip $ map zoneOfPoint $ screenPolygon cfig w ++ [_cameraViewFrom w]
wallsDoubleScreen :: World -> IM.IntMap Wall wallsDoubleScreen :: Configuration -> World -> IM.IntMap Wall
wallsDoubleScreen w wallsDoubleScreen cfig w
-- = foldl' (flip $ IM.union . \i -> innerFold (f i (_znObjects $ _wallsZone w))) IM.empty xs -- = foldl' (flip $ IM.union . \i -> innerFold (f i (_znObjects $ _wallsZone w))) IM.empty xs
-- for some reason (TODO diagnose) the foldl' version causes errors -- for some reason (TODO diagnose) the foldl' version causes errors
= foldr (IM.union . \i -> innerFold (f i (_znObjects $ _wallsZone w))) IM.empty xs = foldr (IM.union . \i -> innerFold (f i (_znObjects $ _wallsZone w))) IM.empty xs
@@ -97,13 +97,13 @@ wallsDoubleScreen w
_ -> IM.empty _ -> IM.empty
(x,y) = zoneOfPoint $ _cameraCenter w (x,y) = zoneOfPoint $ _cameraCenter w
n = ceiling (wh / (_cameraZoom w * zoneSize)) * 2 n = ceiling (wh / (_cameraZoom w * zoneSize)) * 2
wh = max (getWindowX w) (getWindowY w) wh = max (getWindowX cfig) (getWindowY cfig)
xs = [x - n .. x + n] xs = [x - n .. x + n]
ys = [y - n .. y + n] ys = [y - n .. y + n]
wallsOnScreen :: World -> IM.IntMap Wall wallsOnScreen :: Configuration -> World -> IM.IntMap Wall
{-# INLINABLE wallsOnScreen #-} {-# INLINABLE wallsOnScreen #-}
wallsOnScreen w wallsOnScreen cfig w
-- = foldl' (flip $ IM.union . \i -> innerFold (f i (_znObjects $ _wallsZone w))) IM.empty xs -- = foldl' (flip $ IM.union . \i -> innerFold (f i (_znObjects $ _wallsZone w))) IM.empty xs
= foldr (IM.union . \i -> innerFold (f i (_znObjects $ _wallsZone w))) IM.empty xs = foldr (IM.union . \i -> innerFold (f i (_znObjects $ _wallsZone w))) IM.empty xs
where where
@@ -114,7 +114,7 @@ wallsOnScreen w
_ -> IM.empty _ -> IM.empty
(x,y) = zoneOfPoint $ _cameraCenter w (x,y) = zoneOfPoint $ _cameraCenter w
n = ceiling (wh / (_cameraZoom w * zoneSize)) n = ceiling (wh / (_cameraZoom w * zoneSize))
wh = max (getWindowX w) (getWindowY w) wh = max (getWindowX cfig) (getWindowY cfig)
xs = [x - n .. x + n] xs = [x - n .. x + n]
ys = [y - n .. y + n] ys = [y - n .. y + n]
src/LensHelp.hs
+9
View File
@@ -0,0 +1,9 @@
module LensHelp
( module Control.Lens
, (.:~)
) where
import Control.Lens
infixr 4 .:~
(.:~) :: ASetter s t [a] [a] -> a -> s -> t
(.:~) m x = m %~ (x :)