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