diff --git a/appDodge/Main.hs b/appDodge/Main.hs index 8298f0b51..db137511e 100644 --- a/appDodge/Main.hs +++ b/appDodge/Main.hs @@ -38,8 +38,8 @@ main :: IO () main = do -- load the config to get the window size and position con <- loadDodgeConfig - let sizex = floor $ _windowX con - sizey = floor $ _windowY con + let sizex = _windowX con + sizey = _windowY con posx = _windowPosX con posy = _windowPosY con setupConLoop' diff --git a/bench/Bench.hs b/bench/Bench.hs index 13a5ac902..3010dba86 100644 --- a/bench/Bench.hs +++ b/bench/Bench.hs @@ -19,7 +19,7 @@ main = do -- fs <- replicateM 500 (randomRIO (1,20)) defaultMain [ bgroup "polyToTris tests" - [ bench "polyToTris 5" $ nf ( polyToTris) ps1 + [ bench "polyToTris 5" $ nf polyToTris ps1 , bench "polyToTris 10" $ nf polyToTris ps2 , bench "polyToTris 50" $ nf polyToTris ps3 --, bench "polyToTris 500" $ nf polyToTris ps4 diff --git a/data/texture/charMapVertBig.png b/data/texture/charMapVertBig.png index c1f0cf27a..69435f382 100644 Binary files a/data/texture/charMapVertBig.png and b/data/texture/charMapVertBig.png differ diff --git a/src/Data/Preload/Render.hs b/src/Data/Preload/Render.hs index cc3199784..1cfa16312 100644 --- a/src/Data/Preload/Render.hs +++ b/src/Data/Preload/Render.hs @@ -45,7 +45,7 @@ data RenderData = RenderData , _fboShadow :: (FBO, (TO, TO)) , _rboBaseBloom :: GLuint -- RenderbufferObject id , _matUBO :: GLuint -- BufferObject id - , _orthonormalMatUBO :: GLuint -- BufferObject id +-- , _orthonormalMatUBO :: GLuint -- BufferObject id , _lightsUBO :: GLuint -- BufferObject id , _vboWindows :: VBO , _vboShapes :: VBO diff --git a/src/Dodge/Base.hs b/src/Dodge/Base.hs index 5bf615339..b2134638d 100644 --- a/src/Dodge/Base.hs +++ b/src/Dodge/Base.hs @@ -8,14 +8,12 @@ module Dodge.Base , module Dodge.Base.Arithmetic , module Dodge.Base.You , module Dodge.Base.NewID - , module Dodge.Base.WinScale , module Dodge.Base.Window , module Dodge.Base.Coordinate , module Dodge.Base.Collide , module Dodge.Base.CardinalPoint , module Dodge.Base.Wall ) where -import Dodge.Base.WinScale import Dodge.Base.Wall import Dodge.Base.Arithmetic import Dodge.Base.NewID diff --git a/src/Dodge/Base/Collide.hs b/src/Dodge/Base/Collide.hs index 49a5a0ea1..c60f12090 100644 --- a/src/Dodge/Base/Collide.hs +++ b/src/Dodge/Base/Collide.hs @@ -132,7 +132,7 @@ allVisibleWalls :: World -> [(Point2, Wall)] {-# INLINE allVisibleWalls #-} allVisibleWalls w = concatMap (flip (visibleWalls vPos) w . (+.+ vPos)) $ nRays 15 where - vPos = w ^. cWorld . camPos . camViewFrom + vPos = w ^. cWorld . cwCamPos . camViewFrom overlapCircWalls :: Point2 -> diff --git a/src/Dodge/Base/Coordinate.hs b/src/Dodge/Base/Coordinate.hs index 270871b00..7e3ffcddb 100644 --- a/src/Dodge/Base/Coordinate.hs +++ b/src/Dodge/Base/Coordinate.hs @@ -5,9 +5,7 @@ module Dodge.Base.Coordinate ( ) where import Control.Lens -import Dodge.Base.WinScale import Dodge.Data.CamPos -import Dodge.Data.Config import Dodge.Data.HUD import Dodge.Data.Input import Geometry @@ -33,8 +31,8 @@ worldPosToScreen cam = {- | Transform coordinates from the map position to screen coordinates. -} -cartePosToScreen :: Configuration -> HUD -> Point2 -> Point2 -cartePosToScreen cfig thehud = doWindowScale cfig . doRotate . doZoom . doTranslate +cartePosToScreen :: HUD -> Point2 -> Point2 +cartePosToScreen thehud = doRotate . doZoom . doTranslate where doTranslate p = p -.- (thehud ^. carteCenter) -- _carteCenter (_hud (_cWorld w)) doZoom p = (thehud ^. carteZoom) *.* p diff --git a/src/Dodge/Base/WinScale.hs b/src/Dodge/Base/WinScale.hs deleted file mode 100644 index f893cffd0..000000000 --- a/src/Dodge/Base/WinScale.hs +++ /dev/null @@ -1,12 +0,0 @@ -module Dodge.Base.WinScale where - -import Dodge.Data.Config -import Geometry -import Picture - -winScale :: Configuration -> Picture -> Picture -{-# INLINE winScale #-} -winScale cfig = scale (1 / _windowX cfig) (1 / _windowY cfig) - -doWindowScale :: Configuration -> Point2 -> Point2 -doWindowScale cfig (V2 x y) = V2 (x / _windowX cfig) (y / _windowY cfig) diff --git a/src/Dodge/Base/Window.hs b/src/Dodge/Base/Window.hs index c90c3f098..bba653eb5 100644 --- a/src/Dodge/Base/Window.hs +++ b/src/Dodge/Base/Window.hs @@ -45,8 +45,8 @@ screenPolygonBord xbord ybord cfig w = [tr, tl, bl, br] bl = theTransform (V2 (- hw) (- hh)) halfWidth, halfHeight :: Configuration -> Float -halfWidth w = _windowX w / 2 -halfHeight w = _windowY w / 2 +halfWidth = (0.5 *) . windowXFloat +halfHeight = (0.5 *) . windowYFloat -- | A box of the size of the screen in screen centered coordinates screenBox :: Configuration -> [Point2] diff --git a/src/Dodge/Bullet.hs b/src/Dodge/Bullet.hs index d992289b7..175ce9bc6 100644 --- a/src/Dodge/Bullet.hs +++ b/src/Dodge/Bullet.hs @@ -82,7 +82,7 @@ useAmmoParams it cr w = return $ FlechetteTrajectory tpos BezierTrajectory{} -> fromMaybe BasicBulletTrajectory $ do tpos <- cr ^? crTargeting . ctPos . _Just - return $ BezierTrajectory sp tpos (mouseWorldPos (w ^. input) (w ^. cWorld . camPos)) + return $ BezierTrajectory sp tpos (mouseWorldPos (w ^. input) (w ^. cWorld . cwCamPos)) bounceDir :: (Point2, Either Creature Wall) -> Maybe Point2 bounceDir (_, Right wl) | _wlBouncy wl = Just $ uncurry (-.-) (_wlLine wl) diff --git a/src/Dodge/Config/Update.hs b/src/Dodge/Config/Update.hs index 0463b136b..41057df35 100644 --- a/src/Dodge/Config/Update.hs +++ b/src/Dodge/Config/Update.hs @@ -19,7 +19,7 @@ Write the current world configuration to disk as a json file. -} saveConfig :: Configuration -> (a -> IO a) -> a -> IO a saveConfig cfig f x = do - putStrLn "Saving config to data/dodge.config.json" +-- putStrLn "Saving config to data/dodge.config.json" BS.writeFile "data/dodge.config.json" $ AEP.encodePretty' (AEP.Config (AEP.Spaces 2) compare AEP.Generic False) cfig f x diff --git a/src/Dodge/Creature/Action/Blink.hs b/src/Dodge/Creature/Action/Blink.hs index a8ec5f6fb..5b6b2328b 100644 --- a/src/Dodge/Creature/Action/Blink.hs +++ b/src/Dodge/Creature/Action/Blink.hs @@ -26,7 +26,7 @@ blinkActionMousePos cr w = & inverseShockwaveAt cpos 40 2 2 where cid = _crID cr - p1 = mouseWorldPos (w ^. input) (w ^. cWorld . camPos) + p1 = mouseWorldPos (w ^. input) (w ^. cWorld . cwCamPos) cpos = _crPos cr --p2 = bouncePoint (const True) 1 cpos p1 w p2 = pushIntoMaybe $ collideCircWalls cpos p1 r (wlsNearSeg cpos p1 w) @@ -70,7 +70,7 @@ unsafeBlinkAction cr w wl <- snd $ collidePointWallsFilter (const True) mwp cpos w return (isLHS mwp `uncurry` _wlLine wl) cid = _crID cr - mwp = mouseWorldPos (w ^. input) (w ^. cWorld . camPos) + mwp = mouseWorldPos (w ^. input) (w ^. cWorld . cwCamPos) cpos = _crPos cr blinkShockwave :: @@ -96,7 +96,7 @@ blinkActionFail cr w = distR = 120 distortionBulge = RadialDistortion cpos (cpos +.+ V2 distR 0) (cpos +.+ V2 0 distR) 1.9 cid = _crID cr - p1 = mouseWorldPos (w ^. input) (w ^. cWorld . camPos) + p1 = mouseWorldPos (w ^. input) (w ^. cWorld . cwCamPos) cpos = _crPos cr p2 = bouncePoint (const True) 1 cpos p1 w r = 1.5 * _crRad cr diff --git a/src/Dodge/Creature/Picture/Awareness.hs b/src/Dodge/Creature/Picture/Awareness.hs index 94fece017..b1d293d95 100644 --- a/src/Dodge/Creature/Picture/Awareness.hs +++ b/src/Dodge/Creature/Picture/Awareness.hs @@ -28,8 +28,8 @@ creatureDisplayText w cr = cr where lw = w ^. cWorld . lWorld - campos = w ^. cWorld . camPos . camViewFrom - theScale = 0.15 / (w ^. cWorld . camPos . camZoom) + campos = w ^. cWorld . cwCamPos . camViewFrom + theScale = 0.15 / (w ^. cWorld . cwCamPos . camZoom) cpos = _crPos cr v = cpos -.- campos (V2 x y) = campos +.+ v +.+ _crRad cr *.* normalizeV v diff --git a/src/Dodge/Creature/YourControl.hs b/src/Dodge/Creature/YourControl.hs index b71e8d032..56cd8a1a3 100644 --- a/src/Dodge/Creature/YourControl.hs +++ b/src/Dodge/Creature/YourControl.hs @@ -75,15 +75,15 @@ wasdWithAiming w speed cr | otherwise = crMvForward speed theTurn cr' = creatureTurnTowardDir (_crMvAim cr') 0.2 cr' movDir = wasdDir w - dir = fmap ((w ^. cWorld . camPos . camRot) +) (safeArgV movDir) - movAbs = rotateV (w ^. cWorld . camPos . camRot) $ normalizeV movDir + dir = fmap ((w ^. cWorld . cwCamPos . camRot) +) (safeArgV movDir) + movAbs = rotateV (w ^. cWorld . cwCamPos . camRot) $ normalizeV movDir isAiming = _posture (_crStance cr) == Aiming mouseDir = fromMaybe - (argV (_mousePos (_input w)) + (w ^. cWorld . camPos . camRot) ) + (argV (_mousePos (_input w)) + (w ^. cWorld . cwCamPos . camRot) ) $ do itRef <- cr ^? crManipulation . manObject . inInventory . ispItem _ <- cr ^? crInv . ix itRef . itScope . scopePos - return . argV $ mouseWorldPos (w ^. input) (w ^. cWorld . camPos) -.- _crPos cr + return . argV $ mouseWorldPos (w ^. input) (w ^. cWorld . cwCamPos) -.- _crPos cr aimTurn :: Float -> Creature -> Creature aimTurn a cr = creatureTurnTowardDir a (x * 0.2) cr @@ -120,7 +120,7 @@ pressedMBEffectsNoInventory pkeys w | isDown SDL.ButtonLeft && isDown SDL.ButtonRight && inTopInv = useItem (you w) w | isDown SDL.ButtonLeft && inTopInv = useLeftItem 0 w | isDown SDL.ButtonMiddle = - w & cWorld . camPos . camRot -~ rotation + w & cWorld . cwCamPos . camRot -~ rotation & input . clickMousePos .~ _mousePos (_input w) | otherwise = w where diff --git a/src/Dodge/Data/CWorld.hs b/src/Dodge/Data/CWorld.hs index fb1737a70..4a8d18b16 100644 --- a/src/Dodge/Data/CWorld.hs +++ b/src/Dodge/Data/CWorld.hs @@ -24,7 +24,7 @@ import Data.Graph.Inductive data CWorld = CWorld { _lWorld :: LWorld - , _camPos :: CamPos + , _cwCamPos :: CamPos , _cwGen :: CWGen , _cClock :: Int , _pastWorlds :: [LWorld] diff --git a/src/Dodge/Data/Config.hs b/src/Dodge/Data/Config.hs index a0974f806..a07986b5e 100644 --- a/src/Dodge/Data/Config.hs +++ b/src/Dodge/Data/Config.hs @@ -46,8 +46,8 @@ data Configuration = Configuration , _graphics_world_resolution :: ResFactor , _graphics_overlay_resolution :: ResFactor , _graphics_num_shadow_casters :: NumShadowCasters - , _windowX :: Float - , _windowY :: Float + , _windowX :: Int + , _windowY :: Int , _windowPosX :: Int , _windowPosY :: Int , _gameplay_rotate_to_wall :: Bool @@ -56,6 +56,11 @@ data Configuration = Configuration } deriving (Show) +windowXFloat :: Configuration -> Float +windowXFloat = fromIntegral . _windowX +windowYFloat :: Configuration -> Float +windowYFloat = fromIntegral . _windowY + data DebugBool = Show_ms_frame | Show_debug @@ -85,7 +90,7 @@ data DebugBool | Show_path_between deriving (Eq, Ord, Bounded, Enum, Show) -data ResFactor = FullRes | HalfRes | QuarterRes | EighthRes | SixteenthRes +data ResFactor = DoubleRes | FullRes | HalfRes | QuarterRes | EighthRes | SixteenthRes deriving (Show, Eq, Ord, Enum, Bounded) data ShadowRendering @@ -99,13 +104,22 @@ data ShadowRendering data RoomClipping = NoRoomClipBoundaries | AllRoomClipBoundaries | IntersectingRoomClipBoundaries deriving (Show, Eq, Ord, Enum, Bounded) -resFactorNum :: ResFactor -> Int -resFactorNum rf = case rf of - FullRes -> 1 - HalfRes -> 2 - QuarterRes -> 4 - EighthRes -> 8 - SixteenthRes -> 16 +applyResFactor :: ResFactor -> Int -> Int +applyResFactor rf = case rf of + DoubleRes -> (2*) + FullRes -> id + HalfRes -> (`div` 2) + QuarterRes -> (`div` 4) + EighthRes -> (`div` 8) + SixteenthRes -> (`div` 16) + +--resFactorNum :: ResFactor -> Int +--resFactorNum rf = case rf of +-- FullRes -> 1 +-- HalfRes -> 2 +-- QuarterRes -> 4 +-- EighthRes -> 8 +-- SixteenthRes -> 16 defaultConfig :: Configuration defaultConfig = diff --git a/src/Dodge/Data/Input.hs b/src/Dodge/Data/Input.hs index 00d4f7ada..280f1e0fc 100644 --- a/src/Dodge/Data/Input.hs +++ b/src/Dodge/Data/Input.hs @@ -14,7 +14,7 @@ data PressType = InitialPress deriving (Eq,Show) data Input = Input - { _mousePos :: Point2 + { _mousePos :: Point2 -- in pixels, from the center of the screen , _mouseMoving :: Bool , _pressedKeys :: M.Map Scancode PressType , _mouseButtons :: M.Map MouseButton Bool -- shortpress False, repeatpress True diff --git a/src/Dodge/Data/Universe.hs b/src/Dodge/Data/Universe.hs index 2d0e478ba..2c9cc8477 100644 --- a/src/Dodge/Data/Universe.hs +++ b/src/Dodge/Data/Universe.hs @@ -66,6 +66,7 @@ data ScreenLayer , _scSelectionList :: SelectionList (Universe -> Universe,Universe->Universe) , _scAvailableLines :: Int , _scListDisplayParams :: ListDisplayParams + , _scDisplayTime :: Int } | InputScreen { _scInput :: String diff --git a/src/Dodge/Debug/Picture.hs b/src/Dodge/Debug/Picture.hs index 7dac46d9b..fe9d92690 100644 --- a/src/Dodge/Debug/Picture.hs +++ b/src/Dodge/Debug/Picture.hs @@ -39,11 +39,11 @@ lineOnScreenCone cfig w p1 p2 = || pointInPolygon p2 sp || any (isJust . uncurry (intersectSegSeg p1 p2)) sps where - sp' = screenPolygon cfig (w ^. cWorld . camPos) - vp = w ^. cWorld . camPos . camViewFrom + sp' = screenPolygon cfig (w ^. cWorld . cwCamPos) + vp = w ^. cWorld . cwCamPos . camViewFrom sp | pointInPolygon vp sp' = sp' - | otherwise = orderPolygon ((w ^. cWorld . camPos . camViewFrom) : sp') + | otherwise = orderPolygon ((w ^. cWorld . cwCamPos . camViewFrom) : sp') sps = zip sp (tail sp ++ [head sp]) pointOnScreen :: Configuration -> CamPos -> Point2 -> Bool @@ -56,13 +56,13 @@ drawWallFace cfig w wall where (x, y) = _wlLine wall points = extendConeToScreenEdge cfig w sightFrom (x, y) - sightFrom = w ^. cWorld . camPos . camViewFrom + sightFrom = w ^. cWorld . cwCamPos . camViewFrom extendConeToScreenEdge :: Configuration -> World -> Point2 -> (Point2, Point2) -> [Point2] extendConeToScreenEdge cfig w c (x, y) = orderPolygon $ wallScreenIntersect ++ [x, y] ++ borderPs ++ cornerPs where borderPs = mapMaybe (intersectLinefromScreen cfig w c) [x, y] - scpoly = reverse $ screenPolygon cfig (w ^. cWorld . camPos) + scpoly = reverse $ screenPolygon cfig (w ^. cWorld . cwCamPos) cornerPs = filter (pointIsInCone c (x, y)) scpoly wallScreenIntersect = mapMaybe (uncurry $ intersectSegSeg y ((2 *.* y) -.- x)) @@ -77,4 +77,4 @@ intersectLinefromScreen cfig w a b = listToMaybe . mapMaybe (\(x, y) -> intersectSegLineFrom x y b (b +.+ b -.- a)) . loopPairs - $ screenPolygon cfig (w ^. cWorld . camPos) + $ screenPolygon cfig (w ^. cWorld . cwCamPos) diff --git a/src/Dodge/Default/World.hs b/src/Dodge/Default/World.hs index 05c5ac1a8..0edccc73c 100644 --- a/src/Dodge/Default/World.hs +++ b/src/Dodge/Default/World.hs @@ -77,7 +77,7 @@ defaultCWCam = defaultCWorld :: CWorld defaultCWorld = CWorld - { _camPos = defaultCWCam + { _cwCamPos = defaultCWCam , _lWorld = defaultLWorld , _cwGen = defaultCWGen , _cClock = 0 diff --git a/src/Dodge/Event.hs b/src/Dodge/Event.hs index 551dd4606..331a3ad11 100644 --- a/src/Dodge/Event.hs +++ b/src/Dodge/Event.hs @@ -20,8 +20,8 @@ import qualified Data.Text as T import Dodge.Concurrent import Dodge.Data.Universe import Dodge.Event.Input -import Preload.Update import LensHelp +import Preload.Update import SDL handleEvent :: Event -> Universe -> Universe @@ -48,14 +48,10 @@ handleWindowMoveEvent mev = where P (V2 x y) = windowMovedEventPosition mev --- | Resets the world window size, and resizes the fbo that gets the light map drawn into it. - -- using a sideeffect here for the io change seems to work better, more testing -- later may be a good idea handleResizeEvent :: WindowSizeChangedEventData -> Universe -> Universe -handleResizeEvent sev u = - u - & uvIOEffects %~ ( (updatePreload . updateconfig) >=>) +handleResizeEvent sev = uvIOEffects %~ ((updatePreload . updateconfig) >=>) where - updateconfig = (uvConfig . windowX .~ fromIntegral x) . (uvConfig . windowY .~ fromIntegral y) + updateconfig = (uvConfig . windowX .~ fromIntegral x) . (uvConfig . windowY .~ fromIntegral y) V2 x y = windowSizeChangedEventSize sev diff --git a/src/Dodge/Event/Input.hs b/src/Dodge/Event/Input.hs index 2c846b696..bd0a54eaf 100644 --- a/src/Dodge/Event/Input.hs +++ b/src/Dodge/Event/Input.hs @@ -36,8 +36,8 @@ handleMouseMotionEvent mmev cfig = P (V2 x y) = mouseMotionEventPos mmev themousepos = V2 - (fromIntegral x - 0.5 * _windowX cfig) - (0.5 * _windowY cfig - fromIntegral y) + (fromIntegral x - 0.5 * windowXFloat cfig) + (0.5 * windowYFloat cfig - fromIntegral y) handleMouseWheelEvent :: MouseWheelEventData -> Input -> Input handleMouseWheelEvent mwev = scrollAmount +~ fromIntegral y diff --git a/src/Dodge/HeldUse.hs b/src/Dodge/HeldUse.hs index 88194c7ce..3621919b1 100644 --- a/src/Dodge/HeldUse.hs +++ b/src/Dodge/HeldUse.hs @@ -349,7 +349,7 @@ useMod hm = case hm of directedTelPos _ cr w = (p, a) where p = fromMaybe (_crPos cr) $ cr ^? crTargeting . ctPos . _Just - a = argV (mouseWorldPos (w ^. input) (w ^. cWorld . camPos) -.- p) + a = argV (mouseWorldPos (w ^. input) (w ^. cWorld . cwCamPos) -.- p) moddelay x = itUse . heldConsumption . laAmmoType . amBullet . buDelayFraction .~ x modcrpos x cr = cr & crDir %~ tweenAngles x (_crOldDir cr) @@ -513,7 +513,7 @@ shootTeslaArc it cr w = useForceFieldGun :: Item -> Creature -> World -> World useForceFieldGun itm cr w = fromMaybe w $ do a <- cr ^? crTargeting . ctPos . _Just - let mwp = mouseWorldPos (w ^. input) (w ^. cWorld . camPos) + let mwp = mouseWorldPos (w ^. input) (w ^. cWorld . cwCamPos) b = if dist a mwp < 100 then mwp else a +.+ 100 *.* normalizeV (mwp -.- a) wlline = (a, b) return $ diff --git a/src/Dodge/Initialisation.hs b/src/Dodge/Initialisation.hs index be74720ea..7b6672a4b 100644 --- a/src/Dodge/Initialisation.hs +++ b/src/Dodge/Initialisation.hs @@ -16,7 +16,7 @@ splashScreen = initialWorld :: World initialWorld = defaultWorld - & cWorld . camPos . camZoom .~ 10 + & cWorld . cwCamPos . camZoom .~ 10 & cWorld . lWorld . creatures .~ IM.fromList [(0, startCr)] & cWorld . lWorld . worldEvents .~ SoundStart BackgroundSound (V2 0 0) foamSprayFadeOutS Nothing : [MakeStartCloudAt (V3 x y 5) | x <- [-5, -4 .. 5], y <- [-5, -4 .. 5]] diff --git a/src/Dodge/Item/Weapon/BatteryGuns.hs b/src/Dodge/Item/Weapon/BatteryGuns.hs index 792b9122f..8368ed458 100644 --- a/src/Dodge/Item/Weapon/BatteryGuns.hs +++ b/src/Dodge/Item/Weapon/BatteryGuns.hs @@ -149,7 +149,7 @@ circleLaser it cr w | otherwise = w where cpos = _crPos cr - mwp = mouseWorldPos (w ^. input) (w ^. cWorld . camPos) + mwp = mouseWorldPos (w ^. input) (w ^. cWorld . cwCamPos) pos = _crPos cr +.+ rotateV dir (V2 0 (max 70 $ dist cpos mwp)) dir = fromIntegral (_lasCycle (_itParams it)) * pi / 1000 phasev = _phaseV . _itParams $ _crInv cr IM.! itRef @@ -169,7 +169,7 @@ shootDualLaser it cr w = gap = _dbGap . _itParams $ it posl = pos +.+ (- gap) *.* vNormal (unitVectorAtAngle dir) posr = pos +.+ gap *.* vNormal (unitVectorAtAngle dir) - mwp = mouseWorldPos (w ^. input) (w ^. cWorld . camPos) + mwp = mouseWorldPos (w ^. input) (w ^. cWorld . cwCamPos) mwp' | dist mwp (_crPos cr) < aimlength + 5 = _crPos cr +.+ (aimlength + 5) *.* unitVectorAtAngle dir | otherwise = mwp diff --git a/src/Dodge/Item/Weapon/TriggerType.hs b/src/Dodge/Item/Weapon/TriggerType.hs index 606147e3a..046c92418 100644 --- a/src/Dodge/Item/Weapon/TriggerType.hs +++ b/src/Dodge/Item/Weapon/TriggerType.hs @@ -589,7 +589,7 @@ torqueBefore torque feff item cr w w & randGen .~ g & cWorld . lWorld . creatures . ix cid . crDir +~ rot - & cWorld . camPos . camRot +~ rot + & cWorld . cwCamPos . camRot +~ rot | otherwise = feff item cr $ set randGen g $ over (cWorld . lWorld . creatures . ix cid . crDir) (+ rot) w where cid = _crID cr @@ -610,7 +610,7 @@ torqueBeforeAtLeast minTorque exTorque feff item cr w w & randGen .~ g & cWorld . lWorld . creatures . ix cid . crDir +~ rot' - & cWorld . camPos . camRot +~ rot' + & cWorld . cwCamPos . camRot +~ rot' | otherwise = feff item cr $ set randGen g $ over (cWorld . lWorld . creatures . ix cid . crDir) (+ rot') w where cid = _crID cr @@ -623,7 +623,7 @@ torqueBeforeAtLeast minTorque exTorque feff item cr w withTorqueAfter :: ChainEffect withTorqueAfter feff item cr w -- | cid == 0 = rotateScope $ set randGen g $ over cameraRot (+rot) $ feff item cr w - | cid == 0 = set randGen g $ over (cWorld . camPos . camRot) (+ rot) $ feff item cr w + | cid == 0 = set randGen g $ over (cWorld . cwCamPos . camRot) (+ rot) $ feff item cr w | otherwise = set randGen g $ over (cWorld . lWorld . creatures . ix cid . crDir) (+ rot) $ feff item cr w where cid = _crID cr @@ -661,7 +661,7 @@ sideEffectOnFrame i sf f it cr w = torqueSideEffect :: Float -> Item -> Creature -> World -> World torqueSideEffect torque _ cr w - | cid == 0 = set randGen g $ over (cWorld . camPos . camRot) (+ rot) w + | cid == 0 = set randGen g $ over (cWorld . cwCamPos . camRot) (+ rot) w | otherwise = set randGen g $ over (cWorld . lWorld . creatures . ix cid . crDir) (+ rot) w where cid = _crID cr @@ -708,12 +708,12 @@ duplicateOffsetsFocus xs eff item cr w = foldr f w poss & crPos %~ (+.+ pos) & crDir .~ thedir pos thedir pos - | dist (mouseWorldPos (w ^. input) (w ^. cWorld . camPos)) (_crPos cr) < aimingMuzzlePos cr item = + | dist (mouseWorldPos (w ^. input) (w ^. cWorld . cwCamPos)) (_crPos cr) < aimingMuzzlePos cr item = argV ( _crPos cr +.+ aimingMuzzlePos cr item *.* unitVectorAtAngle (_crDir cr) -.- (_crPos cr +.+ pos) ) - | otherwise = argV (mouseWorldPos (w ^. input) (w ^. cWorld . camPos) -.- (_crPos cr +.+ pos)) + | otherwise = argV (mouseWorldPos (w ^. input) (w ^. cWorld . cwCamPos) -.- (_crPos cr +.+ pos)) duplicateItem :: (Item -> [Item]) -> ChainEffect duplicateItem fit eff itm cr w = foldr f w (fit itm) diff --git a/src/Dodge/Layout.hs b/src/Dodge/Layout.hs index ad125280b..bef1c3606 100644 --- a/src/Dodge/Layout.hs +++ b/src/Dodge/Layout.hs @@ -57,7 +57,7 @@ generateLevelFromRoomList gr' w = randomCompass :: World -> World -randomCompass w = w & cWorld . camPos . camRot .~ (takeOne [0, 0.5 * pi, pi, 1.5 * pi] & evalState $ _randGen w) +randomCompass w = w & cWorld . cwCamPos . camRot .~ (takeOne [0, 0.5 * pi, pi, 1.5 * pi] & evalState $ _randGen w) -- note the order of traversal of the rooms is important -- hence the reverse diff --git a/src/Dodge/Luse.hs b/src/Dodge/Luse.hs index 1888e9edd..55d829480 100644 --- a/src/Dodge/Luse.hs +++ b/src/Dodge/Luse.hs @@ -113,7 +113,7 @@ boostPoint x cr w = case mayp2 of where cpos = _crPos cr r = 1.5 * _crRad cr - p1 = cpos +.+ x *.* squashNormalizeV (mouseWorldPos (w ^. input) (w ^. cWorld . camPos) -.- cpos) + p1 = cpos +.+ x *.* squashNormalizeV (mouseWorldPos (w ^. input) (w ^. cWorld . cwCamPos) -.- cpos) mayp2 = bouncePoint (const True) 1 cpos p1 w addBoostShockwave :: diff --git a/src/Dodge/Menu/Loading.hs b/src/Dodge/Menu/Loading.hs index 4361d0d17..57f593f54 100644 --- a/src/Dodge/Menu/Loading.hs +++ b/src/Dodge/Menu/Loading.hs @@ -14,4 +14,5 @@ loadingScreen str = OptionScreen , _scSelectionList = defaultSelectionList , _scAvailableLines = 0 , _scListDisplayParams = optionListDisplayParams + , _scDisplayTime = 0 } diff --git a/src/Dodge/Menu/Option.hs b/src/Dodge/Menu/Option.hs index 6d82edc80..5b292af6d 100644 --- a/src/Dodge/Menu/Option.hs +++ b/src/Dodge/Menu/Option.hs @@ -1,14 +1,11 @@ module Dodge.Menu.Option where import Control.Applicative ---import Dodge.ScodeToChar -import Dodge.Default.SelectionList import Data.Maybe ---import Dodge.WindowLayout - import Dodge.Data.CardinalPoint import Dodge.Data.SelectionList import Dodge.Data.Universe +import Dodge.Default.SelectionList import Dodge.SelectionList import LensHelp import Padding @@ -36,6 +33,7 @@ initializeOptionMenu title ops pmo u = , _scSelectionList = makeOptionsSelectionList 10 (Just 0) u ops pmo , _scAvailableLines = getAvailableListLines optionListDisplayParams (u ^. uvConfig) , _scListDisplayParams = optionListDisplayParams + , _scDisplayTime = 0 } -- BO = Bottom Option @@ -62,15 +60,19 @@ makeOptionsSelectionList :: Universe -> [MenuOption] -> PositionedMenuOption -> - SelectionList (Universe -> Universe,Universe -> Universe) + SelectionList (Universe -> Universe, Universe -> Universe) makeOptionsSelectionList maxlines mselpos u mos pmo = defaultSelectionList { _slItems = optionsToSelections maxlines u mos pmo , _slSelPos = mselpos } -optionsToSelections :: Int -> Universe -> [MenuOption] -> PositionedMenuOption - -> [SelectionItem (Universe -> Universe,Universe -> Universe)] +optionsToSelections :: + Int -> + Universe -> + [MenuOption] -> + PositionedMenuOption -> + [SelectionItem (Universe -> Universe, Universe -> Universe)] optionsToSelections maxlines u allops pmo = case pmo of NoPositionedMenuOption -> map (menuOptionToSelectionItem u maxOptionLength) ops TopMenuOption mo -> map (menuOptionToSelectionItem u maxOptionLength) (mo : ops) @@ -106,8 +108,8 @@ colStrToSelItem (col, str) = { _siPictures = [str] , _siHeight = 1 , _siIsSelectable = True - --, _siWidth = length str - , _siColor = col + , --, _siWidth = length str + _siColor = col , _siOffX = 0 , _siPayload = id } @@ -117,17 +119,20 @@ optionValueOffset u mo = case _moString mo u of MODStringOption s _ -> length s _ -> 0 -menuOptionToSelectionItem :: Universe -> Int -> MenuOption - -> SelectionItem (Universe -> Universe,Universe -> Universe) +menuOptionToSelectionItem :: + Universe -> + Int -> + MenuOption -> + SelectionItem (Universe -> Universe, Universe -> Universe) menuOptionToSelectionItem w padAmount mo = SelectionItem { _siPictures = [optionText] , _siHeight = 1 , _siIsSelectable = isselectable - --, _siWidth = length optionText - , _siColor = thecol + , --, _siWidth = length optionText + _siColor = thecol , _siOffX = 0 - , _siPayload = (f,g) + , _siPayload = (f, g) } where isselectable = case _moString mo w of diff --git a/src/Dodge/Picture/SizeInvariant.hs b/src/Dodge/Picture/SizeInvariant.hs index 690244269..735949bc1 100644 --- a/src/Dodge/Picture/SizeInvariant.hs +++ b/src/Dodge/Picture/SizeInvariant.hs @@ -70,16 +70,16 @@ fixedSizePicClampArrow xbord ybord pic p cfig w = , setLayer DebugLayer . color white . setDepth 20 $ arrowPic ] where - winps = screenPolygon cfig (w ^. camPos) - bords = screenPolygonBord xbord ybord cfig (w ^. camPos) + winps = screenPolygon cfig (w ^. cwCamPos) + bords = screenPolygonBord xbord ybord cfig (w ^. cwCamPos) borderPoint = intersectSegPolyFirst campos p bords windowPoint = intersectSegPolyFirst campos p winps arrowPic = case borderPoint of Nothing -> blank Just bp -> thickLine 5 [bp, fromMaybe p windowPoint] (V2 x y) = fromMaybe p borderPoint - campos = w ^. camPos . camCenter - theScale = 1 / (w ^. camPos . camZoom) + campos = w ^. cwCamPos . camCenter + theScale = 1 / (w ^. cwCamPos . camZoom) --absClamp :: -- -- | clamping value, assumed positive diff --git a/src/Dodge/Projectile/Update.hs b/src/Dodge/Projectile/Update.hs index dd476af12..e31ee344d 100644 --- a/src/Dodge/Projectile/Update.hs +++ b/src/Dodge/Projectile/Update.hs @@ -97,7 +97,7 @@ setRemoteDir cid itid pj w = w & cWorld . lWorld . projectiles . ix (_prjID pj) | SDL.ButtonRight `M.member` _mouseButtons (_input w) && w ^? cWorld . lWorld . creatures . ix cid . crManipulation . manObject . inInventory . ispItem == w ^? cWorld . lWorld . itemLocations . ix itid . ipInvID - = (w ^. cWorld . camPos . camRot) + argV (_mousePos (_input w)) + = (w ^. cWorld . cwCamPos . camRot) + argV (_mousePos (_input w)) | otherwise = _prjDir pj doThrust :: Proj -> World -> World diff --git a/src/Dodge/Render.hs b/src/Dodge/Render.hs index c917f5e74..3e1a33058 100644 --- a/src/Dodge/Render.hs +++ b/src/Dodge/Render.hs @@ -48,13 +48,13 @@ doDrawing' win pdata u = do checkGLError let w = _uvWorld u cfig = _uvConfig u - rot = w ^. cWorld . camPos . camRot - camzoom = w ^. cWorld . camPos . camZoom - trans = w ^. cWorld . camPos . camCenter - wins = V2 (_windowX cfig) (_windowY cfig) + rot = w ^. cWorld . cwCamPos . camRot + camzoom = w ^. cWorld . cwCamPos . camZoom + trans = w ^. cWorld . cwCamPos . camCenter + wins = V2 (windowXFloat cfig) (windowYFloat cfig) (windowPoints, wallSPics, wallsToPoke) = wallsToDraw w - lightPoints = lightsToRender cfig (w ^. cWorld . camPos) (w ^. cWorld . lWorld) - viewFroms@(V2 vfx vfy) = w ^. cWorld . camPos . camViewFrom + lightPoints = lightsToRender cfig (w ^. cWorld . cwCamPos) (w ^. cWorld . lWorld) + viewFroms@(V2 vfx vfy) = w ^. cWorld . cwCamPos . camViewFrom shadV = _pictureShaders pdata nFls = w ^. cWorld . numberFloorVerxs -- bind as much data into vbos as feasible at this point @@ -116,10 +116,11 @@ doDrawing' win pdata u = do glEnable GL_BLEND glBlendFunc GL_SRC_ALPHA GL_ONE_MINUS_SRC_ALPHA setViewport _graphics_overlay_resolution cfig - glBindBufferBase GL_UNIFORM_BUFFER 0 (pdata ^. orthonormalMatUBO) + glBindBufferBase GL_UNIFORM_BUFFER 0 (pdata ^. matUBO) + withArray (scaleMatrix (2 / windowXFloat cfig) (2 / windowYFloat cfig)) + $ \ptr -> glNamedBufferSubData (pdata ^. matUBO) 0 64 ptr renderLayer FixedCoordLayer shadV layerCounts -- set the coordinate uniform ready for drawing elements using world coordinates - glBindBufferBase GL_UNIFORM_BUFFER 0 (pdata ^. matUBO) withArray (perspectiveMatrixb rot camzoom trans wins viewFroms) $ \ptr -> glNamedBufferSubData (pdata ^. matUBO) 0 64 ptr renderLayer DebugLayer shadV layerCounts diff --git a/src/Dodge/Render/HUD.hs b/src/Dodge/Render/HUD.hs index 79bbd3853..34e1d0db2 100644 --- a/src/Dodge/Render/HUD.hs +++ b/src/Dodge/Render/HUD.hs @@ -41,7 +41,7 @@ drawHUD cfig w = case w ^. hud . hudElement of <> drawSubInventory subinv cfig w drawHP :: Configuration -> World -> Picture -drawHP cfig w = winScale cfig . dShadCol white $ displayHP 0 cfig w +drawHP cfig w = dShadCol white $ displayHP 0 cfig w drawInventory :: SelectionSections () -> World -> Configuration -> Picture @@ -265,7 +265,7 @@ eqPosText ep = case ep of OnSpecial -> "EQUIPPED" combineCounts :: Configuration -> World -> [Int] -> Picture -combineCounts cfig w = winScale cfig . foldMap f . group +combineCounts cfig w = foldMap f . group where f (i : is) = fromMaybe mempty $ do _ <- yourInv w ^? ix i . itUse . useAmount @@ -277,8 +277,7 @@ combineCounts cfig w = winScale cfig . foldMap f . group lnkMidPosInvSelsCol :: Configuration -> World -> Int -> Color -> [Int] -> Picture lnkMidPosInvSelsCol cfig w i col = - winScale cfig - . foldMap f + foldMap f where f j = fromMaybe mempty $ do sss <- w ^? hud . hudElement . diSections @@ -302,8 +301,7 @@ tweakString tp = rightPad 12 ' ' (show $ _tweakType tp) ++ " " ++ showTweak tp invHead :: Configuration -> String -> Picture invHead cfig = - winScale cfig - . translate (- halfWidth cfig + subInvX + 20) (halfHeight cfig - 40) + translate (- halfWidth cfig + subInvX + 20) (halfHeight cfig - 40) . dShadCol white . scale 0.4 0.4 . text @@ -314,7 +312,7 @@ drawCarte cfig w = renderListAt 0 0 cfig locs : -- zipWith bConnect (displayListEndCoords cfig locTexts) locPoss -- ++ - mapOverlay cfig w + mapOverlay w ++ [mainListCursor white iPos cfig] where iPos = w ^. cWorld . lWorld . selLocation @@ -330,17 +328,17 @@ drawCarte cfig w = -- h :: String -> Point2 -> Point2 -- h s (V2 x y) = V2 (x + 9 * fromIntegral (length s)) y -mapOverlay :: Configuration -> World -> [Picture] -mapOverlay cfig w = +mapOverlay :: World -> [Picture] +mapOverlay w = (color (withAlpha 0.5 black) . polygon $ reverse $ rectNSWE 1 (-1) 1 (-1)) : - [foldMap (drawMapWall cfig (w ^. hud)) $ IM.restrictKeys (lw ^. walls) (w ^. cWorld . seenWalls)] + [foldMap (drawMapWall (w ^. hud)) $ IM.restrictKeys (lw ^. walls) (w ^. cWorld . seenWalls)] where --(mapMaybe (mapWall cfig (w ^. hud)) . IM.elems $ w ^. cWorld . lWorld . walls) lw = w ^. cWorld . lWorld -drawMapWall :: Configuration -> HUD -> Wall -> Picture -drawMapWall cfig thehud wl = color c . polygon $ map (cartePosToScreen cfig thehud) [x, x +.+ n2, y +.+ n2, y] +drawMapWall :: HUD -> Wall -> Picture +drawMapWall thehud wl = color c . polygon $ map (cartePosToScreen thehud) [x, x +.+ n2, y +.+ n2, y] where t = normalizeV (y -.- x) n2 = 20 *.* vNormal t @@ -420,8 +418,7 @@ openCursorAt :: Configuration -> Picture 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) $ lineCol [ (V2 wth 12.5, withAlpha 0 col) , (V2 0 12.5, col) diff --git a/src/Dodge/Render/InfoBox.hs b/src/Dodge/Render/InfoBox.hs index 647320f89..d74c64cda 100644 --- a/src/Dodge/Render/InfoBox.hs +++ b/src/Dodge/Render/InfoBox.hs @@ -14,7 +14,7 @@ import Picture renderInfoListAt :: Float -> Float -> Configuration -> CamPos -> (Point2, [String]) -> Picture renderInfoListAt x y cfig cam (p, ss) = renderListAt x y cfig (zip ss (repeat white)) - <> winScale cfig (color white $ lConnect (V2 (x - hw) (hh -25 - y)) (worldPosToScreen cam p)) + <> color white (lConnect (V2 (x - hw) (hh -25 - y)) (worldPosToScreen cam p)) <> listCursorNSW x y cfig 0 0 white 19 (length ss) where hw = halfWidth cfig diff --git a/src/Dodge/Render/Label.hs b/src/Dodge/Render/Label.hs index aa71df9a1..38819f294 100644 --- a/src/Dodge/Render/Label.hs +++ b/src/Dodge/Render/Label.hs @@ -1,25 +1,22 @@ -module Dodge.Render.Label - where -import Dodge.Base.Coordinate -import Dodge.ShortShow -import Dodge.Base.WinScale -import Picture +module Dodge.Render.Label where + import Dodge.Data.Universe +import Dodge.ShortShow import Geometry +import Picture -drawLabCrossCol :: Configuration -> CamPos -> Color -> Point2 -> Picture -drawLabCrossCol cfig w col p = drawCrossCol col p - <> drawPointLabel cfig w p +drawLabCrossCol :: Color -> Point2 -> Picture +drawLabCrossCol col p = + drawCrossCol col p + <> drawPointLabel p -drawPointLabel :: Configuration -> CamPos -> Point2 -> Picture -drawPointLabel cfig w p = - setLayer FixedCoordLayer . winScale cfig - . uncurryV translate p' +drawPointLabel :: Point2 -> Picture +drawPointLabel p = + setLayer DebugLayer + . uncurryV translate p . scale 0.1 0.1 . text $ shortPoint2 p - where - p' = worldPosToScreen w p drawCrossCol :: Color -> Point2 -> Picture drawCrossCol col p = setLayer DebugLayer . color col . uncurryV translate p $ crossPic 5 diff --git a/src/Dodge/Render/List.hs b/src/Dodge/Render/List.hs index 056114bd5..bd8a2b6d8 100644 --- a/src/Dodge/Render/List.hs +++ b/src/Dodge/Render/List.hs @@ -1,19 +1,20 @@ module Dodge.Render.List where --import Picture.Text -import Dodge.Inventory + --import Data.Foldable -import Dodge.SelectionList + import Data.Maybe -import Dodge.Base.WinScale import Dodge.Base.Window import Dodge.Data.CardinalPoint import Dodge.Data.Config import Dodge.Data.SelectionList +import Dodge.Inventory +import Dodge.SelectionList import Geometry +import LensHelp import ListHelp import Picture -import LensHelp drawSelectionList :: ListDisplayParams -> Configuration -> SelectionList a -> Picture drawSelectionList ldps cfig sl = @@ -31,7 +32,8 @@ makeSelectionListPictures :: SelectionList a -> [Picture] makeSelectionListPictures sl = concatMap f $ getShownItems sl where f si = map (color (_siColor si) . text) $ _siPictures si - --f si = map (textGrad (_siColor si) (withAlpha 0 (_siColor si))) $ _siPictures si + +--f si = map (textGrad (_siColor si) (withAlpha 0 (_siColor si))) $ _siPictures si drawCursorAt :: ListDisplayParams -> Configuration -> Maybe Int -> [SelectionItem a] -> Picture drawCursorAt ldps cfig mi lis = fromMaybe mempty $ do @@ -55,7 +57,7 @@ drawSelectionCursor ldps cfig sl = drawCursorAt ldps cfig (f $ sl ^. slSelPos) ( f = case sl ^. slRegex of _ | sl ^. slRegexInput -> const (Just 0) "" | not (sl ^. slRegexInput) -> id - _ -> fmap (+1) + _ -> fmap (+ 1) -- given a list of pictures that are each the size of a "text" call, displays them as -- a list on the screen @@ -81,7 +83,7 @@ selSecDrawCursor xsize borders cfig ldp sss i j = fromMaybe mempty $ do si <- sss ^? sssSections . ix i . ssItems . ix j return $ listCursorDisplayParams ldp borders cfig yint xint (_siColor si) xsize (length $ _siPictures si) -listCursorDisplayParams :: +listCursorDisplayParams :: ListDisplayParams -> [CardinalPoint] -> Configuration -> @@ -116,10 +118,9 @@ listCursorChooseBorderScale :: Int -> Picture listCursorChooseBorderScale ygap s borders xoff yoff cfig yint xint col cursxsize cursysize = - winScale cfig - . translate - (15 + (9 * s * (fromIntegral xint - 1)) + xoff - halfWidth cfig) - (halfHeight cfig + s * 12.5 - (yoff + (s * 10 + ygap) * (fromIntegral yint + 1))) + translate + (15 + (9 * s * (fromIntegral xint - 1)) + xoff - halfWidth cfig) + (halfHeight cfig + s * 12.5 - (yoff + (s * 10 + ygap) * (fromIntegral yint + 1))) . color col $ chooseCursorBorders (s * wth) (s * hgt) borders where @@ -160,8 +161,7 @@ listCursorNSW = listCursorChooseBorder [North, South, West] fillScreenText :: Configuration -> String -> Picture fillScreenText cfig str = - winScale cfig - . scale wscale hscale + scale wscale hscale . centerText $ str where @@ -172,8 +172,7 @@ fillScreenText cfig str = fillWidthText :: Configuration -> String -> Picture fillWidthText cfig str = - winScale cfig - . scale thescale thescale + scale thescale thescale . centerText $ str where @@ -182,8 +181,7 @@ fillWidthText cfig str = listTextPictureAt :: Float -> Float -> Configuration -> Int -> Picture -> Picture listTextPictureAt xoff yoff cfig yint = - winScale cfig - . translate (xoff + 15 - hw) (negate yoff + hh - (20 * (fromIntegral yint + 1))) + translate (xoff + 15 - hw) (negate yoff + hh - (20 * (fromIntegral yint + 1))) . scale 0.1 0.1 where hw = halfWidth cfig @@ -191,8 +189,7 @@ listTextPictureAt xoff yoff cfig yint = listTextPictureAtScale :: Float -> Float -> Float -> Float -> Configuration -> Int -> Picture -> Picture listTextPictureAtScale ygap s xoff yoff cfig yint = - winScale cfig - . translate (xoff + 15 - hw) (negate yoff + hh - ((s * 10 + ygap) * (fromIntegral yint + 1))) + translate (xoff + 15 - hw) (negate yoff + hh - ((s * 10 + ygap) * (fromIntegral yint + 1))) . scale (s * 0.1) (s * 0.1) where hw = halfWidth cfig diff --git a/src/Dodge/Render/MenuScreen.hs b/src/Dodge/Render/MenuScreen.hs index 56a7ed8f6..1006c6da2 100644 --- a/src/Dodge/Render/MenuScreen.hs +++ b/src/Dodge/Render/MenuScreen.hs @@ -3,7 +3,6 @@ module Dodge.Render.MenuScreen ( drawMenuScreen, ) where -import Dodge.Base.WinScale import Dodge.Data.SelectionList import Dodge.Render.List import Dodge.Base.Window @@ -46,10 +45,10 @@ drawOptions ldps cfig title sl = ] darkenBackground :: Configuration -> Picture -darkenBackground cfig = winScale cfig . color (withAlpha 0.5 black) . polygon . reverse . screenBox $ cfig +darkenBackground = color (withAlpha 0.5 black) . polygon . reverse . screenBox drawTitle :: Configuration -> String -> Picture -drawTitle cfig = winScale cfig . translate (30 - hw) (hh-50) . scale 0.4 0.4 . text +drawTitle cfig = translate (30 - hw) (hh-50) . scale 0.4 0.4 . text where hh = halfHeight cfig hw = halfWidth cfig diff --git a/src/Dodge/Render/Picture.hs b/src/Dodge/Render/Picture.hs index ca6c0ca1b..8d272cb43 100644 --- a/src/Dodge/Render/Picture.hs +++ b/src/Dodge/Render/Picture.hs @@ -3,32 +3,36 @@ module Dodge.Render.Picture ( ) where import Control.Lens -import Dodge.Base.WinScale +import Data.Maybe +import Dodge.Base.Coordinate import Dodge.Base.Window import Dodge.Data.Universe import Dodge.Render.HUD import Dodge.Render.List import Dodge.Render.MenuScreen import Geometry +import HelpNum import Picture fixedCoordPictures :: Universe -> Picture -fixedCoordPictures u = drawMenuOrHUD cfig u - <> drawConcurrentMessage u - <> customMouseCursor cfig (u ^. uvWorld . input) - <> listPicturesAt (halfWidth cfig) 0 cfig (map text (_uvTestString u u)) - <> displayFrameTicks u +fixedCoordPictures u = + drawMenuOrHUD cfig u + <> drawConcurrentMessage u + <> customMouseCursor u + <> listPicturesAt (halfWidth cfig) 0 cfig (map text (_uvTestString u u)) + <> displayFrameTicks u where cfig = _uvConfig u displayFrameTicks :: Universe -> Picture -displayFrameTicks u = if (debugOn Show_ms_frame $ _uvConfig u) then - ( setDepth (-1) - . translate (-0.5) (-0.8) - . scale 0.0005 0.0005 +displayFrameTicks u = + if debugOn Show_ms_frame $ _uvConfig u + then + setDepth (-1) + . translate (-10) (- halfHeight (_uvConfig u) + 6) + . scale 0.2 0.2 $ fpsText (u ^. uvFrameTicks - u ^. uvLastFrameTicks) - ) - else mempty + else mempty fpsText :: (Show a, Ord a, Num a) => a -> Picture fpsText x = color col $ text $ "ms/frame " ++ show x @@ -49,7 +53,7 @@ drawConcurrentMessage :: Universe -> Picture drawConcurrentMessage u = stackPicturesAt (halfWidth cfig) - (_windowY cfig - 50) + (windowYFloat cfig - 50) cfig (map (centerText . f) $ u ^.. uvSideEffects . each) where @@ -57,9 +61,26 @@ drawConcurrentMessage u = f (RunningSideEffect ce) = ce ++ " IN PROGRESS" f x = _ceString x ++ " QUEUED" -customMouseCursor :: Configuration -> Input -> Picture -customMouseCursor cfig inp = - winScale cfig - . uncurryV translate (_mousePos inp) +customMouseCursor :: Universe -> Picture +customMouseCursor u = + uncurryV translate (u ^. uvWorld . input . mousePos) . color white - $ pictures [line [V2 (-5) 0, V2 5 0], line [V2 0 (-5), V2 0 5]] + $ mouseCursorType u + +mouseCursorType :: Universe -> Picture +mouseCursorType u + | null (u ^. uvScreenLayers) = rotate a (drawPlus 5) + | otherwise = mousePlus + where + w = u ^. uvWorld + a = fromMaybe 0 $ do + cpos <- w ^? cWorld . lWorld . creatures . ix 0 . crPos + return . toClosestMultiple (pi / 32) $ + argV (mouseWorldPos (w ^. input) (w ^. cWorld . cwCamPos) -.- cpos) + - w ^. cWorld . cwCamPos . camRot + +mousePlus :: Picture +mousePlus = pictures [line [V2 (-5) 0, V2 5 0], line [V2 0 (-5), V2 0 5]] + +drawPlus :: Float -> Picture +drawPlus x = pictures [line [V2 (- x) 0, V2 x 0], line [V2 0 (- x), V2 0 x]] diff --git a/src/Dodge/Render/ShapePicture.hs b/src/Dodge/Render/ShapePicture.hs index ccee90f22..341868390 100644 --- a/src/Dodge/Render/ShapePicture.hs +++ b/src/Dodge/Render/ShapePicture.hs @@ -53,7 +53,7 @@ worldSPic cfig u = <> foldup floorItemSPic (filtOn _flItPos _floorItems) <> foldup btSPic (filtOn _btPos _buttons) <> foldup mcSPic (filtOn _mcPos _machines) - <> aimDelaySweep cfig w + <> aimDelaySweep w <> anyTargeting cfig w where w = _uvWorld u @@ -61,22 +61,21 @@ worldSPic cfig u = filtOn f g = IM.filter (pointIsClose . f) (g (_lWorld (_cWorld w))) pointIsClose = cullPoint cfig w -aimDelaySweep :: Configuration -> World -> SPic -aimDelaySweep cfig w = fromMaybe mempty $ do +aimDelaySweep :: World -> SPic +aimDelaySweep w = fromMaybe mempty $ do cr <- w ^? cWorld . lWorld . creatures . ix 0 aimstatus <- cr ^? crStance . posture guard (aimstatus == Aiming) - return $ noShape $ drawSweep cr cfig w + return $ noShape $ drawSweep cr w -drawSweep :: Creature -> Configuration -> World -> Picture -drawSweep cr cfig w = fromMaybe mempty $ do +drawSweep :: Creature -> World -> Picture +drawSweep cr w = fromMaybe mempty $ do a <- safeArgV (mwp -.- p) let a' | a - cdir > pi = cdir + 2 * pi | a - cdir < - pi = cdir - 2 * pi | otherwise = cdir return $ - winScale cfig $ setLayer FixedCoordLayer $ uncurryV translate (worldPosToScreen campos p) $ arcFull (a - rot) 10 white (a' - rot) 1 white (5 + dist mwp p * campos ^. camZoom) white @@ -84,7 +83,7 @@ drawSweep cr cfig w = fromMaybe mempty $ do cdir = _crDir cr rot = campos ^. camRot p = _crPos cr - campos = w ^. cWorld . camPos + campos = w ^. cWorld . cwCamPos theinput = w ^. input mwp = mouseWorldPos theinput campos @@ -135,8 +134,8 @@ shiftDraw' fpos fdir fdraw x = cullPoint :: Configuration -> World -> Point2 -> Bool cullPoint cfig w p - | debugOn Close_shape_culling cfig = pointInPolygon p (w ^. cWorld . camPos . camBoundBox) - | otherwise = dist (w ^. cWorld . camPos . camCenter) p < (w ^. cWorld . camPos . camViewDistance) + | debugOn Close_shape_culling cfig = pointInPolygon p (w ^. cWorld . cwCamPos . camBoundBox) + | otherwise = dist (w ^. cWorld . cwCamPos . camCenter) p < (w ^. cWorld . cwCamPos . camViewDistance) extraPics :: Configuration -> Universe -> Picture extraPics cfig u = @@ -199,24 +198,23 @@ debugDraw' cfig w bl = case bl of Cr_awareness -> drawCreatureDisplayTexts w Show_sound -> pictures $ M.map (soundPic cfig w) $ _playingSounds w Cr_status -> drawCrInfo cfig (w ^. cWorld) - Mouse_position -> drawMousePosition cfig w - Walls_info -> drawWlIDs cfig w + Mouse_position -> drawMousePosition w + Walls_info -> drawWlIDs w Pathing -> drawPathing cfig w Show_nodes_near_select -> undefined --drawNodesNearSelect w Show_path_between -> drawPathBetween w - Collision_test -> drawCollisionTest cfig w + Collision_test -> drawCollisionTest w -drawCollisionTest :: Configuration -> World -> Picture -drawCollisionTest cfig w = +drawCollisionTest :: World -> Picture +drawCollisionTest w = setLayer DebugLayer (color orange $ line [a, b]) <> foldMap (drawCross . fst) (crHit a b w) <> foldMap (drawCross . _crPos) (crsNearSeg a b w) <> foldMap (drawZoneCol green crZoneSize . zoneOfPoint crZoneSize) (xIntercepts crZoneSize a b) <> foldMap (drawZoneCol yellow crZoneSize . zoneOfPoint crZoneSize) (yIntercepts' crZoneSize a b) - <> foldMap (drawLabCrossCol cfig cam blue) (xIntercepts crZoneSize a b) + <> foldMap (drawLabCrossCol blue) (xIntercepts crZoneSize a b) where (a, b) = _lrLine (_input w) - cam = w ^. cWorld . camPos drawCreatureDisplayTexts :: World -> Picture drawCreatureDisplayTexts w = foldMap (creatureDisplayText w) (w ^. cWorld . lWorld . creatures) @@ -245,7 +243,7 @@ drawWallsNearYou w = fromMaybe mempty $ do drawWallsNearCursor :: World -> Picture drawWallsNearCursor w = - setLayer DebugLayer $ foldMap f $ wlsNearPoint (mouseWorldPos (_input w) (_camPos $ _cWorld w)) w + setLayer DebugLayer $ foldMap f $ wlsNearPoint (mouseWorldPos (_input w) (_cwCamPos $ _cWorld w)) w where f wl = color rose $ thickLine 3 [a, b] where @@ -309,13 +307,13 @@ drawFarWallDetect w = ) $ getViewpoints p (_cWorld w) where - p = w ^. cWorld . camPos . camViewFrom + p = w ^. cWorld . cwCamPos . camViewFrom drawZoneNearPointCursor :: World -> Picture drawZoneNearPointCursor w = foldMap (drawZoneCol orange 50) ps where - mwp = mouseWorldPos (w ^. input) (w ^. cWorld . camPos) + mwp = mouseWorldPos (w ^. input) (w ^. cWorld . cwCamPos) ps = [zoneOfPoint 50 mwp] drawDDATest :: World -> Picture @@ -323,8 +321,8 @@ drawDDATest w = foldMap (drawZoneCol orange 50) ps <> setLayer DebugLayer (color yellow (line [cvf, mwp])) where - cvf = w ^. cWorld . camPos . camViewFrom - mwp = mouseWorldPos (w ^. input) (w ^. cWorld . camPos) + cvf = w ^. cWorld . cwCamPos . camViewFrom + mwp = mouseWorldPos (w ^. input) (w ^. cWorld . cwCamPos) ps = zoneOfSeg 50 cvf mwp drawZoneCol :: Color -> Float -> V2 Int -> Picture @@ -344,7 +342,7 @@ drawWallSearchRays w = foldMap (f . fst) $ allVisibleWalls w setLayer DebugLayer $ color yellow $ uncurryV translate p (circle 5) - <> line [w ^. cWorld . camPos . camViewFrom, p] + <> line [w ^. cWorld . cwCamPos . camViewFrom, p] testPic :: Configuration -> World -> Picture testPic _ _ = mempty @@ -352,7 +350,7 @@ testPic _ _ = mempty drawBoundingBox :: World -> Picture drawBoundingBox w = setLayer DebugLayer $ color green $ line $ (x : xs) ++ [x] where - (x : xs) = w ^. cWorld . camPos . camBoundBox + (x : xs) = w ^. cWorld . cwCamPos . camBoundBox ppDraw :: PressPlate -> Picture ppDraw c = uncurryV translate (_ppPos c) $ rotate (_ppRot c) (_ppPict c) @@ -377,7 +375,7 @@ soundPic cfig w s = fixedSizePicClampArrow 50 50 thePic p cfig (w ^. cWorld) where p = _soundPos s thePic = - rotate (w ^. cWorld . camPos . camRot) + rotate (w ^. cWorld . cwCamPos . camRot) . scale theScale theScale . centerText . soundToOnomato @@ -385,31 +383,28 @@ soundPic cfig w s = fixedSizePicClampArrow 50 50 thePic p cfig (w ^. cWorld) theScale = 0.15 * f (_soundVolume s * 0.0001) f x = 1 - 0.5 * (1 - x) -drawMousePosition :: Configuration -> World -> Picture -drawMousePosition cfig w = +drawMousePosition :: World -> Picture +drawMousePosition w = setLayer FixedCoordLayer - . winScale cfig - . uncurryV translate p + . uncurryV translate (w ^. input . mousePos) . scale 0.1 0.1 . text $ shortPoint2 mwp where - p = worldPosToScreen (w ^. cWorld . camPos) mwp - mwp = mouseWorldPos (w ^. input) (w ^. cWorld . camPos) + mwp = mouseWorldPos (w ^. input) (w ^. cWorld . cwCamPos) -drawWlIDs :: Configuration -> World -> Picture -drawWlIDs cfig w = setLayer FixedCoordLayer $ foldMap f (w ^. cWorld . lWorld . walls) +drawWlIDs :: World -> Picture +drawWlIDs w = setLayer FixedCoordLayer $ foldMap f (w ^. cWorld . lWorld . walls) where f wl | dist (_crPos $ you w) (fst (_wlLine wl)) > 200 = mempty -- this should be improved with a better "on screen test" | otherwise = - winScale cfig - . uncurryV translate p + uncurryV translate p . scale 0.1 0.1 . text $ show $ _wlID wl where - p = worldPosToScreen (w ^. cWorld . camPos) $ 0.5 *.* uncurry (+.+) (_wlLine wl) + p = worldPosToScreen (w ^. cWorld . cwCamPos) $ 0.5 *.* uncurry (+.+) (_wlLine wl) edgeToPic :: [Point2] -> PathEdge -> Picture edgeToPic poly pe @@ -422,7 +417,7 @@ edgeToPic poly pe drawPathing :: Configuration -> World -> Picture drawPathing cfig w = setLayer DebugLayer $ - foldMap (edgeToPic (screenPolygon cfig (w ^. cWorld . camPos)) . (^?! _3)) (FGL.labEdges gr) + foldMap (edgeToPic (screenPolygon cfig (w ^. cWorld . cwCamPos)) . (^?! _3)) (FGL.labEdges gr) <> foldMap dispInc (graphToIncidence gr) where dispInc (p, n) = setDepth 2 . uncurryV translate p . scale 0.1 0.1 $ text $ show n @@ -459,7 +454,7 @@ drawCrInfo cfig w = renderInfoListsAt (2 * hw - 400) 0 cfig cam $ mapMaybe (crDisplayInfo cfig cam) $ IM.elems $ w ^. lWorld . creatures where - cam = w ^. camPos + cam = w ^. cwCamPos hw = halfWidth cfig viewBoundaries :: CWorld -> Picture @@ -468,7 +463,7 @@ viewBoundaries w = color green (foldMap (polygonWire . _grBound) grs) <> color yellow (foldMap (\q -> line [p, q]) $ getViewpoints p w) where - p = w ^. camPos . camViewFrom + p = w ^. cwCamPos . camViewFrom grs = filter (pointInOrOnPolygon p . _grBound) (_cwgGameRooms $ _cwGen w) viewClipBounds :: Configuration -> World -> Picture diff --git a/src/Dodge/SelectionList.hs b/src/Dodge/SelectionList.hs index 042efbf35..06899f1a1 100644 --- a/src/Dodge/SelectionList.hs +++ b/src/Dodge/SelectionList.hs @@ -12,7 +12,7 @@ getAvailableListLines ldps cfig = floor ((dToBot - vgap) / itmHeight) where vgap = ldps ^. ldpVerticalGap itmHeight = 10 * ldps ^. ldpScale + vgap - dToBot = cfig ^. windowY - (ldps ^. ldpPosY + dFromScreenBot) + dToBot = fromIntegral (cfig ^. windowY) - (ldps ^. ldpPosY + dFromScreenBot) dFromScreenBot = 5 -- fromMaybe 0 $ sl ^? slSizeRestriction . ssrType . ssrFromScreenBottom getShownItems :: SelectionList a -> [SelectionItem a] diff --git a/src/Dodge/SoundLogic.hs b/src/Dodge/SoundLogic.hs index 42e3c6813..c9cd3e75a 100644 --- a/src/Dodge/SoundLogic.hs +++ b/src/Dodge/SoundLogic.hs @@ -163,9 +163,9 @@ soundAngle p w . radToDeg . normalizeAngle . (+ pi) - $ argV (vNormal (p -.- earPos)) - (w ^. cWorld . camPos . camRot) + $ argV (vNormal (p -.- earPos)) - (w ^. cWorld . cwCamPos . camRot) where - earPos = w ^. cWorld . camPos . camViewFrom + earPos = w ^. cWorld . cwCamPos . camViewFrom {- | Uses the first free origin from a list. Does nothing if all origins are already creating sounds. diff --git a/src/Dodge/Targeting.hs b/src/Dodge/Targeting.hs index b87f35b84..a0f356c87 100644 --- a/src/Dodge/Targeting.hs +++ b/src/Dodge/Targeting.hs @@ -49,7 +49,7 @@ targetRBCreatureUp cr w . filter (canseepos . _crPos) $ crsNearCirc mwp 40 w canseepos p = hasLOS (_crPos cr) p w - mwp = mouseWorldPos (w ^. input) (w ^. cWorld . camPos) + mwp = mouseWorldPos (w ^. input) (w ^. cWorld . cwCamPos) updatePos t' = t' & ctPos .~ posFromMaybeID (_ctID t') posFromMaybeID Nothing = Nothing posFromMaybeID (Just i) = w ^? cWorld . lWorld . creatures . ix i . crPos @@ -61,7 +61,7 @@ targetRBCreatureUp cr w targetCursorUpdate :: World -> CreatureTargeting -> CreatureTargeting targetCursorUpdate w ct = ct - & ctPos . _Just .~ mouseWorldPos (w ^. input) (w ^. cWorld . camPos) + & ctPos . _Just .~ mouseWorldPos (w ^. input) (w ^. cWorld . cwCamPos) & ctActive .~ True & ctType ?~ TargetCursor @@ -69,7 +69,7 @@ targetRBPressUpdate :: World -> CreatureTargeting -> CreatureTargeting targetRBPressUpdate w t | SDL.ButtonRight `M.member` _mouseButtons (_input w) = t - & ctPos %~ maybe (Just $ mouseWorldPos (w ^. input) (w ^. cWorld . camPos)) Just + & ctPos %~ maybe (Just $ mouseWorldPos (w ^. input) (w ^. cWorld . cwCamPos)) Just & ctActive .~ True & ctType ?~ TargetRBPress | otherwise = @@ -100,7 +100,7 @@ targetLaserUpdate cr w t where (mp, _) = reflectLaserAlong 0.2 sp ep w sp = _crPos cr +.+ 15 *.* unitVectorAtAngle (_crDir cr) - ep = sp +.+ 5000 *.* normalizeV (mouseWorldPos (w ^. input) (w ^. cWorld . camPos) -.- sp) + ep = sp +.+ 5000 *.* normalizeV (mouseWorldPos (w ^. input) (w ^. cWorld . cwCamPos) -.- sp) addLaserPic = cWorld . lWorld . lasers .:~ LaserStart diff --git a/src/Dodge/Targeting/Draw.hs b/src/Dodge/Targeting/Draw.hs index 9aa042c68..e7e8056ce 100644 --- a/src/Dodge/Targeting/Draw.hs +++ b/src/Dodge/Targeting/Draw.hs @@ -23,31 +23,27 @@ targetSimpleDraw :: Creature -> Configuration -> World -> Picture targetSimpleDraw = targetDraw activeTargetCursorPic targetDistanceDraw :: Creature -> Configuration -> World -> Picture -targetDistanceDraw cr cfig w = fromMaybe mempty $ do +targetDistanceDraw cr _ w = fromMaybe mempty $ do p <- cr ^? crTargeting . ctPos . _Just let p1 = worldPosToScreen cam p - mwp = mouseWorldPos (w ^. input) (w ^. cWorld . camPos) + mwp = mouseWorldPos (w ^. input) (w ^. cWorld . cwCamPos) p2 = worldPosToScreen cam mwp thecol = if dist p mwp > 100 then red else white - return $ - winScale cfig $ + return . setLayer FixedCoordLayer $ color thecol $ line [p1, p2] <> transMidLine p1 p2 (scale 0.1 0.1 . text . shortShow $ dist p mwp) where - cam = w ^. cWorld . camPos + cam = w ^. cWorld . cwCamPos targetDraw :: Picture -> Creature -> Configuration -> World -> Picture -targetDraw f cr cfig w = fromMaybe mempty $ do +targetDraw f cr _ _ = fromMaybe mempty $ do p <- cr ^? crTargeting . ctPos . _Just - return $ - winScale cfig $ - setLayer FixedCoordLayer $ + return . + setLayer DebugLayer $ color white $ - uncurryV translate (worldPosToScreen cam p) f - where - cam = w ^. cWorld . camPos + uncurryV translate p f activeTargetCursorPic :: Picture activeTargetCursorPic = diff --git a/src/Dodge/TestString.hs b/src/Dodge/TestString.hs index b1d8c99d2..ea85fa508 100644 --- a/src/Dodge/TestString.hs +++ b/src/Dodge/TestString.hs @@ -1,5 +1,9 @@ module Dodge.TestString where +import HelpNum +import Dodge.Base.Coordinate +import Geometry.Vector +import Data.Maybe import Dodge.Render.Lights import Data.Aeson (ToJSON) import Data.ByteString.Lazy.Char8 (unpack) @@ -11,12 +15,21 @@ import Dodge.Data.Universe --import qualified Data.Map.Strict as M --import qualified IntMapHelp as IM testStringInit :: Universe -> [String] -testStringInit u = [show $ length $ lightsToRender (u ^. uvConfig) (u ^. uvWorld . cWorld . camPos) +testStringInit u = [show $ length $ lightsToRender (u ^. uvConfig) (u ^. uvWorld . cWorld . cwCamPos) (u ^. uvWorld . cWorld . lWorld) + , show a + , show $ u ^. uvWorld . input . mousePos , show $ u ^. uvConfig . windowX , show $ u ^. uvConfig . windowY , show $ u ^. uvWorld . input . scrollTestInt ] + where + w = u ^. uvWorld + a = fromMaybe 0 $ do + cpos <- w ^? cWorld . lWorld . creatures . ix 0 . crPos + return . toClosestMultiple (pi/ 8) $ argV (mouseWorldPos (w ^. input) (w ^. cWorld . cwCamPos) -.- cpos) + - w ^. cWorld . cwCamPos . camRot + --[show $ u ^? uvWorld . hud . hudElement . diSections . sssExtra . sssSelPos . _Just] -- [show $ fmap IM.keys $ u ^? uvWorld . hud . hudElement . subInventory . ciSections . sssSections] diff --git a/src/Dodge/Update.hs b/src/Dodge/Update.hs index e5a566435..523dcdb9a 100644 --- a/src/Dodge/Update.hs +++ b/src/Dodge/Update.hs @@ -281,7 +281,7 @@ zoneClouds :: World -> World zoneClouds w = w & clZoning .~ foldl' (flip zoneCloud) mempty (w ^. cWorld . lWorld . clouds) updateWorldSelect' :: World -> World -updateWorldSelect' w = over input (updateWorldSelect (w ^. cWorld . camPos)) w +updateWorldSelect' w = over input (updateWorldSelect (w ^. cWorld . cwCamPos)) w updateWorldSelect :: CamPos -> Input -> Input updateWorldSelect cam inp = f . g $ case (inp ^? mouseButtons . ix ButtonLeft, inp ^? mouseButtons . ix ButtonRight) of diff --git a/src/Dodge/Update/Camera.hs b/src/Dodge/Update/Camera.hs index f80a35bc8..8f3b44b98 100644 --- a/src/Dodge/Update/Camera.hs +++ b/src/Dodge/Update/Camera.hs @@ -29,8 +29,8 @@ updateCamera :: Configuration -> World -> World updateCamera cfig w = w & updateBounds cfig - & over (cWorld . camPos) (setViewDistance cfig) - & cWorld . camPos %~ moveZoomCamera cfig (w ^. input) (you w) + & over (cWorld . cwCamPos) (setViewDistance cfig) + & cWorld . cwCamPos %~ moveZoomCamera cfig (w ^. input) (you w) & updateScopeZoom & rotateCamera cfig @@ -98,7 +98,7 @@ updateScopeZoom' i w wppointer = cWorld . lWorld . creatures . ix 0 . crInv . ix i . itScope resetscope (ZoomScope _ _ _ defz bl) = ZoomScope (V2 0 0) 0 defz defz bl resetscope otherAtt = otherAtt - mp = rotateV (w ^. cWorld . camPos . camRot) $ _mousePos (_input w) + mp = rotateV (w ^. cWorld . cwCamPos . camRot) $ _mousePos (_input w) doScopeZoom :: Point2 -> Scope -> Scope doScopeZoom mp sc = case sc ^? scopeZoomChange of @@ -163,11 +163,11 @@ rotateToOverlappingWall w = p = _crPos (you w) doWallRotate :: Wall -> World -> World -doWallRotate wl w = rotateUsing $ (argV . uncurry (-.-) $ _wlLine wl) - (w ^. cWorld . camPos . camRot) +doWallRotate wl w = rotateUsing $ (argV . uncurry (-.-) $ _wlLine wl) - (w ^. cWorld . cwCamPos . camRot) where rotateUsing a - | b - b' > 0.01 = w & cWorld . camPos . camRot +~ 0.01 - | b - b' < negate 0.01 = w & cWorld . camPos . camRot -~ 0.01 + | b - b' > 0.01 = w & cWorld . cwCamPos . camRot +~ 0.01 + | b - b' < negate 0.01 = w & cWorld . cwCamPos . camRot -~ 0.01 | otherwise = w where --b = a * (2 / pi) @@ -177,7 +177,7 @@ doWallRotate wl w = rotateUsing $ (argV . uncurry (-.-) $ _wlLine wl) - (w ^. cW rotateCameraBy :: Float -> CWorld -> CWorld rotateCameraBy x w = w - & camPos . camRot +~ x + & cwCamPos . camRot +~ x & rotateanyscope where rotateanyscope = fromMaybe id $ do @@ -218,7 +218,7 @@ farWallDistDirection p w = boundPoints $ map f $ getViewpoints p (_cWorld w) where - f q = (rotateV (negate (w ^. cWorld . camPos . camRot)) . (-.- p)) (foldl' findPoint q (wls q)) + f q = (rotateV (negate (w ^. cWorld . cwCamPos . camRot)) . (-.- p)) (foldl' findPoint q (wls q)) wls q = filter wlIsOpaque $ wlsNearSeg p q w findPoint q = fromMaybe q . uncurry (intersectSegSeg p q) . _wlLine @@ -226,7 +226,7 @@ findBoundDists :: Configuration -> World -> (Float, Float, Float, Float) findBoundDists cfig w | debugOn Bound_box_screen cfig = (hh, - hh, hw, - hw) -- | otherwise = fromMaybe (0, 0, 0, 0) $ farWallDistDirection (w ^. cWorld . camPos . camCenter) w - | otherwise = fromMaybe (0, 0, 0, 0) $ farWallDistDirection (w ^. cWorld . camPos . camViewFrom) w + | otherwise = fromMaybe (0, 0, 0, 0) $ farWallDistDirection (w ^. cWorld . cwCamPos . camViewFrom) w where hw = halfWidth cfig hh = halfHeight cfig @@ -234,8 +234,8 @@ findBoundDists cfig w updateBounds :: Configuration -> World -> World updateBounds cfig w = w - & cWorld . camPos . camBoundDist .~ bdists - & cWorld . camPos . camBoundBox - .~ map ((+.+ w ^. cWorld . camPos . camCenter) . rotateV (w ^. cWorld . camPos . camRot)) (rectNSWE n s w' e) + & cWorld . cwCamPos . camBoundDist .~ bdists + & cWorld . cwCamPos . camBoundBox + .~ map ((+.+ w ^. cWorld . cwCamPos . camCenter) . rotateV (w ^. cWorld . cwCamPos . camRot)) (rectNSWE n s w' e) where bdists@(n, s, e, w') = findBoundDists cfig w diff --git a/src/Dodge/Update/Input/ScreenLayer.hs b/src/Dodge/Update/Input/ScreenLayer.hs index a93bf52cd..74b85ce41 100644 --- a/src/Dodge/Update/Input/ScreenLayer.hs +++ b/src/Dodge/Update/Input/ScreenLayer.hs @@ -17,8 +17,7 @@ import SDL updateUseInputOnScreen :: ScreenLayer -> Universe -> Universe updateUseInputOnScreen sl = case sl of InputScreen thetext _ -> doInputScreenInput thetext - screen@OptionScreen{_scPositionedMenuOption = mop, _scSelectionList = sellist, _scListDisplayParams = ldps} -> - optionScreenUpdate screen mop ldps sellist + screen -> optionScreenUpdate screen doInputScreenInput :: String -> Universe -> Universe doInputScreenInput s u = @@ -36,19 +35,20 @@ doInputScreenInput s u = optionScreenUpdate :: ScreenLayer -> - PositionedMenuOption -> - ListDisplayParams -> - SelectionList (Universe -> Universe,Universe -> Universe) -> Universe -> Universe -optionScreenUpdate screen mop ldps sl u = - refreshOptionsSelectionList +optionScreenUpdate screen u = + (uvScreenLayers . ix 0 . scDisplayTime +~ 1) + . refreshOptionsSelectionList . optionScreenDefaultEffect mop . mouseClickOptionsList screen - . mouseOverSelectionList ldps sl + . mouseOverSelectionList ldps screen . menuWheelEvents . over (uvScreenLayers . _head) (setSelectionListRestriction (u ^. uvConfig)) $ u + where + mop = _scPositionedMenuOption screen + ldps = _scListDisplayParams screen optionScreenDefaultEffect :: PositionedMenuOption -> Universe -> Universe optionScreenDefaultEffect f u = case u ^. uvWorld . input . pressedKeys . at ScancodeEscape of @@ -71,18 +71,22 @@ mouseClickOptionsList screen u = fromMaybe u $ do return $ f u _ -> u -mouseOverSelectionList :: ListDisplayParams - -> SelectionList a -> Universe -> Universe -mouseOverSelectionList ldps sl u +mouseOverSelectionList :: + ListDisplayParams -> + ScreenLayer -> + Universe -> + Universe +mouseOverSelectionList ldps screen u | x > xl && x < xr && ylower == yupper - && mmoving + && (mmoving || (_scDisplayTime screen == 0)) && ylower >= 0 && ylower < ymax && isselectable = u & uvScreenLayers . _head . scSelectionList . slSelPos ?~ yupper | otherwise = u where + sl = _scSelectionList screen isselectable = fromMaybe False $ u ^? uvScreenLayers . _head . scSelectionList . slItems . ix yupper . siIsSelectable @@ -91,7 +95,6 @@ mouseOverSelectionList ldps sl u ylower = ceiling $ (hh - (75 + y + _ldpPosY ldps)) / 50 yupper = floor $ (hh - (15 + y + _ldpPosY ldps)) / 50 xl = _ldpPosX ldps - hw - --xr = xl + _ldpScale ldps * 15 * 9 xr = xl + _ldpScale ldps * 26 * 9 V2 x y = u ^. uvWorld . input . mousePos cfig = u ^. uvConfig diff --git a/src/Dodge/Update/Scroll.hs b/src/Dodge/Update/Scroll.hs index 9e973986d..07e7421a2 100644 --- a/src/Dodge/Update/Scroll.hs +++ b/src/Dodge/Update/Scroll.hs @@ -30,7 +30,7 @@ updateWheelEvent yi w = case w ^. hud . hudElement of (_, EquipOptions{}) -> w & rbOptions %~ scrollRBOption yi (Nothing, _) -> closeObjScrollDir y w (Just f, _) -> doHeldScroll f y (you w) w - | lbDown -> w & cWorld . camPos . camZoom +~ y + | lbDown -> w & cWorld . cwCamPos . camZoom +~ y | invKeyDown -> changeSwapSel yi w | otherwise -> stopSoundFrom (CrReloadSound 0) $ scrollAugInvSel yi w DisplayInventory {_subInventory = ExamineInventory mi} diff --git a/src/Dodge/WindowSize.hs b/src/Dodge/WindowSize.hs index 643a4b6fa..57a10c562 100644 --- a/src/Dodge/WindowSize.hs +++ b/src/Dodge/WindowSize.hs @@ -3,6 +3,6 @@ module Dodge.WindowSize where import Dodge.Data.Config getWindowSize :: Integral a => (Configuration -> ResFactor) -> Configuration -> (a,a) -getWindowSize f cfig = (g _windowX,g _windowY) +getWindowSize f cfig = (g _windowX, g _windowY) where - g h = fromIntegral $ round (h cfig) `div` resFactorNum (f cfig) + g h = fromIntegral $ applyResFactor (f cfig) (h cfig) diff --git a/src/Dodge/WorldEffect.hs b/src/Dodge/WorldEffect.hs index 20f8b9782..90b2ed0ef 100644 --- a/src/Dodge/WorldEffect.hs +++ b/src/Dodge/WorldEffect.hs @@ -58,7 +58,7 @@ accessTerminal mtmid w = case mtmid of torqueCr :: Float -> Int -> World -> World torqueCr x cid w - | cid == 0 = set randGen g $ over (cWorld . camPos . camRot) (+ rot) w + | cid == 0 = set randGen g $ over (cWorld . cwCamPos . camRot) (+ rot) w | otherwise = set randGen g $ over (cWorld . lWorld . creatures . ix cid . crDir) (+ rot) w where (rot, g) = randomR (- x, x) $ _randGen w diff --git a/src/Dodge/WorldEvent/Cloud.hs b/src/Dodge/WorldEvent/Cloud.hs index 0f5707386..4f99ad6d2 100644 --- a/src/Dodge/WorldEvent/Cloud.hs +++ b/src/Dodge/WorldEvent/Cloud.hs @@ -73,4 +73,4 @@ makeFlamerSmokeAt p w = makeCloudAt (CloudColor 4 300 (greyN x)) 6 200 40 p w spawnSmokeAtCursor :: World -> World spawnSmokeAtCursor w = shellTrailCloud 400 100 (V3 x y 20) w where - V2 x y = mouseWorldPos (w ^. input) (w ^. cWorld . camPos) + V2 x y = mouseWorldPos (w ^. input) (w ^. cWorld . cwCamPos) diff --git a/src/Dodge/Zone/Size.hs b/src/Dodge/Zone/Size.hs index 2fef27f2b..5dd0008c3 100644 --- a/src/Dodge/Zone/Size.hs +++ b/src/Dodge/Zone/Size.hs @@ -1,10 +1,4 @@ module Dodge.Zone.Size where ---pnZoneSize :: Float ---pnZoneSize = 100 - clZoneSize :: Float clZoneSize = 20 - ---peZoneSize :: Float ---peZoneSize = 50 diff --git a/src/Framebuffer/Update.hs b/src/Framebuffer/Update.hs index 25c22d28e..cd241c819 100644 --- a/src/Framebuffer/Update.hs +++ b/src/Framebuffer/Update.hs @@ -7,6 +7,7 @@ module Framebuffer.Update ( sizeFBOs, ) where +import Dodge.WindowSize import Control.Lens import Control.Monad import Data.Preload.Render @@ -31,36 +32,50 @@ sizeFBOs cfig rdata = GL_NEAREST GL_NEAREST GL_RGBA8 - GL_RGBA16F + GL_RGBA16F -- i am not sure if this should not be GL_RGBA32F GL_RGBA16F ) rdata [fboBase, fboCloud] - >>= flip - ( uncurry - updateFBOTO - (getWindowSize _graphics_world_resolution cfig) - GL_NEAREST - GL_NEAREST - GL_RGBA8 - ) - fboLighting - >>= ffoldM - ( uncurry - updateFBOTO - (getWindowSize _graphics_world_resolution cfig) - GL_LINEAR_MIPMAP_LINEAR - GL_LINEAR - GL_RGBA16F - ) + >>= foldUpdateFBOTO + _graphics_world_resolution + GL_NEAREST + GL_NEAREST + GL_RGBA8 + [fboLighting] + >>= foldUpdateFBOTO + _graphics_world_resolution + GL_LINEAR_MIPMAP_LINEAR + GL_LINEAR + GL_RGBA16F [fboBloom, fboPos] - >>= ffoldM - (uncurry updateFBOTO (getWindowSize _graphics_overlay_resolution cfig) GL_LINEAR GL_NEAREST GL_RGBA8) + >>= foldUpdateFBOTO + _graphics_overlay_resolution + GL_LINEAR + GL_NEAREST + GL_RGBA8 [fbo2, fbo3, fboOverlay] - >>= ffoldM - (uncurry updateFBOTO (getWindowSize _graphics_downsize_resolution cfig) GL_LINEAR_MIPMAP_LINEAR GL_LINEAR GL_RGBA16F) + >>= foldUpdateFBOTO + _graphics_downsize_resolution + GL_LINEAR_MIPMAP_LINEAR + GL_LINEAR + GL_RGBA16F [fboHalf1, fboHalf2, fboHalf3] >>= resizeShadowFBO' cfig + where + updateFBOTO' f = + uncurry + updateFBOTO + (getWindowSize f cfig) + foldUpdateFBOTO f minfilt magfilt format l = + ffoldM + ( updateFBOTO' + f + minfilt + magfilt + format + ) + l ffoldM :: (Foldable t, Monad m) => @@ -254,7 +269,7 @@ initializeTexture2DArray fbo attachpoint x y z minfilt magfilt informat = do glNamedFramebufferTexture (_unFBO fbo) attachpoint to1 0 return to1 -getWindowSize :: Integral a => (Configuration -> ResFactor) -> Configuration -> (a, a) -getWindowSize f cfig = (g _windowX, g _windowY) - where - g h = fromIntegral $ round (h cfig) `div` resFactorNum (f cfig) +--getWindowSize :: Integral a => (Configuration -> ResFactor) -> Configuration -> (a, a) +--getWindowSize f cfig = (g _windowX, g _windowY) + -- where + -- g h = fromIntegral $ h cfig `div` resFactorNum (f cfig) diff --git a/src/MatrixHelper.hs b/src/MatrixHelper.hs index 427a50179..3fcd864f2 100644 --- a/src/MatrixHelper.hs +++ b/src/MatrixHelper.hs @@ -1,6 +1,7 @@ module MatrixHelper ( perspectiveMatrixb , isoMatrix + , scaleMatrix ) where import Geometry.Data @@ -52,6 +53,9 @@ perMat x = V4 (V4 0 0 1 0) (V4 0 0 x 1) +scaleMatrix :: Float -> Float -> [V4 Float] +scaleMatrix x = vToL . scaleMat . V2 x + scaleMat :: Point2 -> V4 (V4 Float) scaleMat (V2 x y) = V4 (V4 x 0 0 0) diff --git a/src/Picture/Base.hs b/src/Picture/Base.hs index 42b8ce646..a02e185cd 100644 --- a/src/Picture/Base.hs +++ b/src/Picture/Base.hs @@ -25,6 +25,7 @@ module Picture.Base ( line, lineCol, text, + drawText, centerText, stackText, pictures, @@ -200,10 +201,14 @@ stackText = mconcat . zipWith (\y s -> translate 0 y $ centerText s) [0, 100 ..] text :: String -> Picture {-# INLINE text #-} -text = map f . stringToList +text = translate (-50) (-100) . drawText (-10) + +drawText :: Float -> String -> [Verx] +drawText gap = map f . stringToList gap where f (pos, col, V3 a b c) = Verx pos col [a, b, c, 1] BottomLayer textNum + line :: [Point2] -> Picture {-# INLINE line #-} line = thickLine 1 @@ -291,18 +296,18 @@ overCol :: (Point4 -> Point4) -> Verx -> Verx overCol f vx = vx{_vxCol = f (_vxCol vx)} -- no premature optimisation, consider changing to use texture arrays -stringToList :: String -> [(Point3, Point4, Point3)] +stringToList :: Float -> String -> [(Point3, Point4, Point3)] {-# INLINE stringToList #-} -stringToList = concatMap (uncurry charToTuple) . zip [0, 0.9 * dimText ..] - where - dimText = 100 +stringToList gap = concatMap (uncurry charToTuple) . zip [0, 100 + gap ..] charToTuple :: Float -> Char -> [(Point3, Point4, Point3)] {-# INLINE charToTuple #-} charToTuple xoff c = [f 0 0, f 1 0, f 1 1, f 0 0, f 1 1, f 0 1] where - f x y = (V3 (xoff - 50 + x * 100) (100 - y * 200) 0, white, V3 x y offset) - offset = fromIntegral (fromEnum c) - 32 + f x y = (V3 (xoff + x * 100) (y * 200) 0, white, V3 x (1 - y) charnum) + -- textures in opengl have origins at the lower left, my char array has its + -- origin at the upper left + charnum = fromIntegral (fromEnum c) - 32 --charToTuple' :: Float -> Char -> [(Point3, Point4, Point3)] --{-# INLINE charToTuple' #-} diff --git a/src/Preload/Render.hs b/src/Preload/Render.hs index ef0c53e42..846d0c0fc 100644 --- a/src/Preload/Render.hs +++ b/src/Preload/Render.hs @@ -7,8 +7,6 @@ module Preload.Render ( import Shader.AuxAddition import Shape.Data -import Geometry.Data -import MatrixHelper import GLHelp import Control.Lens import Control.Monad @@ -36,9 +34,9 @@ preloadRender = do glNamedBufferData theUBO 64 nullPtr GL_STREAM_DRAW glBindBufferBase GL_UNIFORM_BUFFER 0 theUBO - orthonormalUBO <- mglCreate glCreateBuffers - withArray (isoMatrix 0 1 (V2 0 0) (V2 1 1)) $ \ptr -> - glNamedBufferStorage orthonormalUBO 64 ptr 0 +-- orthonormalUBO <- mglCreate glCreateBuffers +-- withArray idMat $ \ptr -> +-- glNamedBufferStorage orthonormalUBO 64 ptr 0 lightsubo <- mglCreate glCreateBuffers glNamedBufferData lightsubo 640 nullPtr GL_STREAM_DRAW @@ -190,7 +188,7 @@ preloadRender = do , _fboOverlay = fbooverlay , _rboBaseBloom = rboBaseBloomName , _matUBO = theUBO - , _orthonormalMatUBO = orthonormalUBO +-- , _orthonormalMatUBO = orthonormalUBO , _lightsUBO = lightsubo , _vboWindows = winvbo , _vboShapes = shVBO