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

Refactor window size, update selection cursor on new screen

Browse Source
This commit is contained in:
justin
2023-03-25 09:27:27 +00:00
parent 20c05be23f
commit ea0c942887
57 changed files with 346 additions and 310 deletions
Download Patch File Download Diff File Expand all files Collapse all files
appDodge/Main.hs
+2 -2
View File
@@ -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'
bench/Bench.hs
+1 -1
View File
@@ -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
data/texture/charMapVertBig.png
BIN
View File
Binary file not shown.
Side by Side Swipe Overlay

Before

Width:  |  Height:  |  Size: 12 KiB

After

Width:  |  Height:  |  Size: 12 KiB

src/Data/Preload/Render.hs
+1 -1
View File
@@ -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
src/Dodge/Base.hs
-2
View File
@@ -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
src/Dodge/Base/Collide.hs
+1 -1
View File
@@ -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 ->
src/Dodge/Base/Coordinate.hs
+2 -4
View File
@@ -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
src/Dodge/Base/WinScale.hs
-12
View File
@@ -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)
src/Dodge/Base/Window.hs
+2 -2
View File
@@ -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]
src/Dodge/Bullet.hs
+1 -1
View File
@@ -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)
src/Dodge/Config/Update.hs
+1 -1
View File
@@ -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
src/Dodge/Creature/Action/Blink.hs
+3 -3
View File
@@ -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
src/Dodge/Creature/Picture/Awareness.hs
+2 -2
View File
@@ -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
src/Dodge/Creature/YourControl.hs
+5 -5
View File
@@ -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
src/Dodge/Data/CWorld.hs
+1 -1
View File
@@ -24,7 +24,7 @@ import Data.Graph.Inductive
data CWorld = CWorld
{ _lWorld :: LWorld
, _camPos :: CamPos
, _cwCamPos :: CamPos
, _cwGen :: CWGen
, _cClock :: Int
, _pastWorlds :: [LWorld]
src/Dodge/Data/Config.hs
+24 -10
View File
@@ -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 =
src/Dodge/Data/Input.hs
+1 -1
View File
@@ -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
src/Dodge/Data/Universe.hs
+1
View File
@@ -66,6 +66,7 @@ data ScreenLayer
, _scSelectionList :: SelectionList (Universe -> Universe,Universe->Universe)
, _scAvailableLines :: Int
, _scListDisplayParams :: ListDisplayParams
, _scDisplayTime :: Int
}
| InputScreen
{ _scInput :: String
src/Dodge/Debug/Picture.hs
+6 -6
View File
@@ -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)
src/Dodge/Default/World.hs
+1 -1
View File
@@ -77,7 +77,7 @@ defaultCWCam =
defaultCWorld :: CWorld
defaultCWorld =
CWorld
{ _camPos = defaultCWCam
{ _cwCamPos = defaultCWCam
, _lWorld = defaultLWorld
, _cwGen = defaultCWGen
, _cClock = 0
src/Dodge/Event.hs
+3 -7
View File
@@ -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
src/Dodge/Event/Input.hs
+2 -2
View File
@@ -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
src/Dodge/HeldUse.hs
+2 -2
View File
@@ -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 $
src/Dodge/Initialisation.hs
+1 -1
View File
@@ -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]]
src/Dodge/Item/Weapon/BatteryGuns.hs
+2 -2
View File
@@ -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
src/Dodge/Item/Weapon/TriggerType.hs
+6 -6
View File
@@ -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)
src/Dodge/Layout.hs
+1 -1
View File
@@ -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
src/Dodge/Luse.hs
+1 -1
View File
@@ -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 ::
src/Dodge/Menu/Loading.hs
+1
View File
@@ -14,4 +14,5 @@ loadingScreen str = OptionScreen
, _scSelectionList = defaultSelectionList
, _scAvailableLines = 0
, _scListDisplayParams = optionListDisplayParams
, _scDisplayTime = 0
}
src/Dodge/Menu/Option.hs
+19 -14
View File
@@ -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
src/Dodge/Picture/SizeInvariant.hs
+4 -4
View File
@@ -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
src/Dodge/Projectile/Update.hs
+1 -1
View File
@@ -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
src/Dodge/Render.hs
+9 -8
View File
@@ -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
src/Dodge/Render/HUD.hs
+11 -14
View File
@@ -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)
src/Dodge/Render/InfoBox.hs
+1 -1
View File
@@ -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
src/Dodge/Render/Label.hs
+12 -15
View File
@@ -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
src/Dodge/Render/List.hs
+16 -19
View File
@@ -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
src/Dodge/Render/MenuScreen.hs
+2 -3
View File
@@ -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
src/Dodge/Render/Picture.hs
+39 -18
View File
@@ -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]]
src/Dodge/Render/ShapePicture.hs
+34 -39
View File
@@ -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
src/Dodge/SelectionList.hs
+1 -1
View File
@@ -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]
src/Dodge/SoundLogic.hs
+2 -2
View File
@@ -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.
src/Dodge/Targeting.hs
+4 -4
View File
@@ -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
src/Dodge/Targeting/Draw.hs
+8 -12
View File
@@ -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 =
src/Dodge/TestString.hs
+14 -1
View File
@@ -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]
src/Dodge/Update.hs
+1 -1
View File
@@ -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
src/Dodge/Update/Camera.hs
+12 -12
View File
@@ -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
src/Dodge/Update/Input/ScreenLayer.hs
+16 -13
View File
@@ -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
src/Dodge/Update/Scroll.hs
+1 -1
View File
@@ -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}
src/Dodge/WindowSize.hs
+2 -2
View File
@@ -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)
src/Dodge/WorldEffect.hs
+1 -1
View File
@@ -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
src/Dodge/WorldEvent/Cloud.hs
+1 -1
View File
@@ -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)
src/Dodge/Zone/Size.hs
-6
View File
@@ -1,10 +1,4 @@
module Dodge.Zone.Size where
--pnZoneSize :: Float
--pnZoneSize = 100
clZoneSize :: Float
clZoneSize = 20
--peZoneSize :: Float
--peZoneSize = 50
src/Framebuffer/Update.hs
+41 -26
View File
@@ -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)
src/MatrixHelper.hs
+4
View File
@@ -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)
src/Picture/Base.hs
+12 -7
View File
@@ -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' #-}
src/Preload/Render.hs
+4 -6
View File
@@ -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