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

Move towards serializing saves/loads faster

Browse Source
This commit is contained in:
justin
2022-08-19 11:12:43 +01:00
parent c74d3b04bf
commit 9df0fa8692
38 changed files with 542 additions and 384 deletions
Download Patch File Download Diff File Expand all files Collapse all files
src/Dodge/Base/Collide.hs
+1 -1
View File
@@ -178,7 +178,7 @@ allVisibleWalls :: World -> [(Point2, Wall)]
{-# INLINE allVisibleWalls #-}
allVisibleWalls w = concatMap (flip (visibleWalls vPos) w . (+.+ vPos)) $ nRays 20
where
vPos = _cameraViewFrom $ _cWorld w
vPos = w ^. cWorld . cwCam . cwcViewFrom
--allVisibleWalls :: World -> StreamOf (Point2,Wall)
--{-# INLINE allVisibleWalls #-}
src/Dodge/Base/Coordinate.hs
+9 -8
View File
@@ -3,14 +3,15 @@ module Dodge.Base.Coordinate where
import Dodge.Base.WinScale
import Dodge.Data.Universe
import Geometry
import Control.Lens
-- | Transform coordinates from world position to screen coordinates.
worldPosToScreenNorm :: Configuration -> World -> Point2 -> Point2
worldPosToScreenNorm cfig w = doWindowScale cfig . doRotate . doZoom . doTranslate
where
doTranslate p = p -.- _cameraCenter (_cWorld w)
doZoom p = _cameraZoom (_cWorld w) *.* p
doRotate p = rotateV (negate $ _cameraRot (_cWorld w)) p
doTranslate p = p -.- (w ^. cWorld . cwCam . cwcCenter)
doZoom p = (w ^. cWorld . cwCam . cwcZoom) *.* p
doRotate p = rotateV (negate (w ^. cWorld . cwCam . cwcRot)) p
{- | Transform world coordinates to scaled screen coordinates.
- These have to be scaled according to the size of the window to get actual screen positions.
@@ -18,9 +19,9 @@ worldPosToScreenNorm cfig w = doWindowScale cfig . doRotate . doZoom . doTransla
-}
worldPosToScreen :: World -> Point2 -> Point2
worldPosToScreen w =
rotateV (negate $ _cameraRot (_cWorld w))
. (_cameraZoom (_cWorld w) *.*)
. (-.- _cameraCenter (_cWorld w))
rotateV (negate $ w ^. cWorld . cwCam . cwcRot)
. ((w ^. cWorld . cwCam . cwcZoom) *.*)
. (-.- (w ^. cWorld . cwCam . cwcCenter))
{- | Transform coordinates from the map position to screen
coordinates.
@@ -38,8 +39,8 @@ crToMousePosOffset cr w = (mouseWorldPos w -.- _crPos cr, 0)
-- | The mouse position in world coordinates.
mouseWorldPos :: World -> Point2
mouseWorldPos w =
_cameraCenter (_cWorld w)
+.+ (1 / _cameraZoom (_cWorld w)) *.* rotateV (_cameraRot (_cWorld w)) (_mousePos w)
(w ^. cWorld . cwCam . cwcCenter)
+.+ (1 / (w ^. cWorld . cwCam . cwcZoom)) *.* rotateV (w ^. cWorld . cwCam . cwcRot) (_mousePos w)
-- | The mouse position in map coordinates
mouseCartePos :: World -> Point2
src/Dodge/Base/Window.hs
+6 -7
View File
@@ -9,18 +9,17 @@ module Dodge.Base.Window (
import Dodge.Data.Universe
import Geometry
import Control.Lens
-- | A box covering the screen in world coordinates
screenPolygon :: Configuration -> World -> [Point2]
screenPolygon cfig w = map (scTran . scRot . scZoom) $ screenBox cfig
where
-- [tr,tl,bl,br]
scRot = rotateV (_cameraRot (_cWorld w))
scRot = rotateV (w ^. cWorld . cwCam . cwcRot)
scZoom p
| _cameraZoom (_cWorld w) /= 0 = (1 / _cameraZoom (_cWorld w)) *.* p
| (w ^. cWorld . cwCam . cwcZoom) /= 0 = (1 / (w ^. cWorld . cwCam . cwcZoom)) *.* p
| otherwise = p
scTran p = p +.+ _cameraCenter (_cWorld w)
scTran p = p +.+ (w ^. cWorld . cwCam . cwcCenter)
-- tr = scTran $ scRot $ scZoom (V2 ( halfWidth w) ( halfHeight w))
-- tl = scTran $ scRot $ scZoom (V2 (-halfWidth w) ( halfHeight w))
@@ -41,9 +40,9 @@ screenPolygonBord xbord ybord cfig w = [tr, tl, bl, br]
hw = halfWidth cfig - xbord
hh = halfHeight cfig - ybord
scZoom p
| _cameraZoom (_cWorld w) /= 0 = (1 / _cameraZoom (_cWorld w)) *.* p
| (w ^. cWorld . cwCam . cwcZoom) /= 0 = (1 / (w ^. cWorld . cwCam . cwcZoom)) *.* p
| otherwise = p
theTransform = (+.+ _cameraCenter (_cWorld w)) . rotateV (_cameraRot (_cWorld w)) . scZoom
theTransform = (+.+ (w ^. cWorld . cwCam . cwcCenter)) . rotateV (w ^. cWorld . cwCam . cwcRot) . scZoom
tr = theTransform (V2 hw hh)
tl = theTransform (V2 (- hw) hh)
br = theTransform (V2 hw (- hh))
src/Dodge/Creature/Picture/Awareness.hs
+3 -2
View File
@@ -5,6 +5,7 @@ import Dodge.Clock
import Dodge.Data.World
import Geometry
import Picture
import Control.Lens
creatureDisplayText :: World -> Creature -> Picture
creatureDisplayText w cr =
@@ -26,8 +27,8 @@ creatureDisplayText w cr =
w
cr
where
campos = _cameraViewFrom (_cWorld w)
theScale = 0.15 / _cameraZoom (_cWorld w)
campos = w ^. cWorld . cwCam . cwcViewFrom
theScale = 0.15 / (w ^. cWorld . cwCam . cwcZoom)
cpos = _crPos cr
v = cpos -.- campos
(V2 x y) = campos +.+ v +.+ _crRad cr *.* normalizeV v
src/Dodge/Creature/YourControl.hs
+3 -3
View File
@@ -56,12 +56,12 @@ wasdWithAiming w speed cr
| otherwise = crMvAbsolute (speed *.* movAbs) . set crMvDir dir
theTurn cr' = creatureTurnTowardDir (_crMvDir cr') 0.2 cr'
movDir = wasdDir w
dir = _cameraRot (_cWorld w) + argV movDir
movAbs = rotateV (_cameraRot (_cWorld w)) $ normalizeV movDir
dir = (w ^. cWorld . cwCam . cwcRot) + argV movDir
movAbs = rotateV (w ^. cWorld . cwCam . cwcRot) $ normalizeV movDir
isAiming = _posture (_crStance cr) == Aiming
mouseDir = case cr ^? crInv . ix (crSel cr) . itScope . scopePos of
Just _ -> argV $ mouseWorldPos w -.- _crPos cr
_ -> argV (_mousePos w) + _cameraRot (_cWorld w)
_ -> argV (_mousePos w) + (w ^. cWorld . cwCam . cwcRot)
wasdM :: SDL.Scancode -> Point2
wasdM scancode = case scancode of
src/Dodge/CullBox.hs
+4 -3
View File
@@ -12,7 +12,7 @@ import Geometry
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 (_cameraCenter (_cWorld w)) w
| otherwise = fromMaybe (0, 0, 0, 0) $ farWallDistDirection ((w ^. cWorld . cwCam . cwcCenter)) w
where
hw = halfWidth cfig
hh = halfHeight cfig
@@ -20,8 +20,9 @@ findBoundDists cfig w
updateBounds :: Universe -> Universe
updateBounds uv =
uv
& uvWorld . cWorld . boundDist .~ bdists
& uvWorld . cWorld . boundBox .~ map ((+.+ _cameraCenter (_cWorld w)) . rotateV (_cameraRot (_cWorld w))) (rectNSWE n s w' e)
& uvWorld . cWorld . cwCam . cwcBoundDist .~ bdists
& uvWorld . cWorld . cwCam . cwcBoundBox
.~ map ((+.+ w ^. cWorld . cwCam . cwcCenter) . rotateV (w ^. cWorld . cwCam . cwcRot)) (rectNSWE n s w' e)
where
w = _uvWorld uv
cfig = _uvConfig uv
src/Dodge/Data/CWorld.hs
+38 -9
View File
@@ -1,5 +1,6 @@
{-# LANGUAGE StrictData #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE ScopedTypeVariables #-}
module Dodge.Data.CWorld (
module Dodge.Data.CWorld,
@@ -46,6 +47,8 @@ module Dodge.Data.CWorld (
module Dodge.Data.WorldEffect,
) where
import TH.Derive
import Data.Store
import Control.Lens
import Data.Aeson
import Data.Aeson.TH
@@ -99,16 +102,29 @@ import qualified IntMapHelp as IM
import MaybeHelp
import Picture.Data
data CWCam = CWCam
{ _cwcCenter :: Point2
, _cwcRot :: Float
, _cwcZoom :: Float -- smaller values zoom out
, _cwcItemZoom :: Float
, _cwcDefaultZoom :: Float
, _cwcViewFrom :: Point2
, _cwcViewDistance :: Float
, _cwcBoundBox :: [Point2]
, _cwcBoundDist :: (Float, Float, Float, Float) -- NSEW, S and W negative
}
data CWorld = CWorld
{ _cameraCenter :: Point2
, _cameraRot :: Float
, _cameraZoom :: Float -- smaller values zoom out
, _itemZoom :: Float
, _defaultZoom :: Float
, _cameraViewFrom :: Point2
, _viewDistance :: Float
, _boundBox :: [Point2]
, _boundDist :: (Float, Float, Float, Float) -- NSEW, S and W negative
--{ _cameraCenter :: Point2
--, _cameraRot :: Float
--, _cameraZoom :: Float -- smaller values zoom out
--, _itemZoom :: Float
--, _defaultZoom :: Float
--, _cameraViewFrom :: Point2
--, _viewDistance :: Float
--, _boundBox :: [Point2]
--, _boundDist :: (Float, Float, Float, Float) -- NSEW, S and W negative
{ _cwCam :: CWCam
, _creatures :: IM.IntMap Creature
, _crZoning :: IM.IntMap (IM.IntMap IS.IntSet)
, _creatureGroups :: IM.IntMap CrGroupParams
@@ -176,6 +192,14 @@ data CWorld = CWorld
, _worldClock :: Int
, _genParams :: GenParams
, _deathDelay :: Maybe Int
, _cwSeed :: Int
}
data CWGen = CWGen
{ _cwgParams :: GenParams
, _cwgWorldBounds :: Bounds
, _cwgGameRooms :: [GameRoom] -- consider using an IntMap
, _cwgRoomClipping :: [ConvexPoly]
}
data WorldBeams = WorldBeams
@@ -188,5 +212,10 @@ data WorldBeams = WorldBeams
deriveJSON defaultOptions ''CWorld
deriveJSON defaultOptions ''WorldBeams
deriveJSON defaultOptions ''CWCam
makeLenses ''CWorld
makeLenses ''WorldBeams
makeLenses ''CWCam
-- $($(derive [d|
-- instance Deriving (Store CWorld)
-- |]))
src/Dodge/Data/Universe.hs
+9 -2
View File
@@ -27,6 +27,8 @@ data Universe = Universe
, _uvConcEffects :: ConcEffect
, _uvConfig :: Configuration
, _uvTestString :: Universe -> [String]
, _uvCanContinue :: Bool
, _uvMSeed :: Maybe Int
}
data ConcEffect = NoConcEffect
@@ -62,10 +64,14 @@ data ScreenLayer
-- { _scDisplay :: Universe -> Picture
-- }
data MenuOptionDisplay = MODString {_modString :: String}
| MODBlockedString {_modString :: String}
| MODStringOption {_modString :: String,_modOption :: String}
data MenuOption
= Toggle
{ _moEff :: Universe -> IO (Maybe Universe)
, _moString :: Universe -> Either String (String, String)
, _moString :: Universe -> MenuOptionDisplay
, _moKey :: Scancode
}
| Toggle2
@@ -73,7 +79,7 @@ data MenuOption
, _moEff1 :: Universe -> IO (Maybe Universe)
, _moKey2 :: Scancode
, _moEff2 :: Universe -> IO (Maybe Universe)
, _moString :: Universe -> Either String (String, String)
, _moString :: Universe -> MenuOptionDisplay
}
| InvisibleToggle
{ _moKey :: Scancode
@@ -85,3 +91,4 @@ data IntID a = IntID Int a
makeLenses ''Universe
makeLenses ''ScreenLayer
makeLenses ''ConcEffect
makeLenses ''MenuOptionDisplay
src/Dodge/Debug/Picture.hs
+7 -6
View File
@@ -1,5 +1,6 @@
module Dodge.Debug.Picture where
import Control.Lens
import Data.Maybe
import Dodge.Base.Wall
import Dodge.Base.Window
@@ -19,11 +20,11 @@ printRotPoint r p =
outsideScreenPolygon :: Configuration -> World -> [Point2]
outsideScreenPolygon cfig w = [tr, tl, bl, br]
where
scRot = rotateV (_cameraRot (_cWorld w))
scRot = rotateV (w ^. cWorld . cwCam . cwcRot)
scZoom p
| _cameraZoom (_cWorld w) /= 0 = (1 / _cameraZoom (_cWorld w)) *.* p
| (w ^. cWorld . cwCam . cwcZoom) /= 0 = (1 / (w ^. cWorld . cwCam . cwcZoom)) *.* p
| otherwise = error "Trying to set screen zoom to zero"
scTran p = p +.+ _cameraCenter (_cWorld w)
scTran p = p +.+ (w ^. cWorld . cwCam . cwcCenter)
tr = f 3 3
tl = f (-3) 3
br = f 3 (-3)
@@ -39,10 +40,10 @@ lineOnScreenCone cfig w p1 p2 =
|| any (isJust . uncurry (intersectSegSeg p1 p2)) sps
where
sp' = screenPolygon cfig w
vp = _cameraViewFrom (_cWorld w)
vp = w ^. cWorld . cwCam . cwcViewFrom
sp
| pointInPolygon vp sp' = sp'
| otherwise = orderPolygon (_cameraViewFrom (_cWorld w) : sp')
| otherwise = orderPolygon ((w ^. cWorld . cwCam . cwcViewFrom) : sp')
sps = zip sp (tail sp ++ [head sp])
pointOnScreen :: Configuration -> World -> Point2 -> Bool
@@ -55,7 +56,7 @@ drawWallFace cfig w wall
where
(x, y) = _wlLine wall
points = extendConeToScreenEdge cfig w sightFrom (x, y)
sightFrom = _cameraViewFrom (_cWorld w)
sightFrom = w ^. cWorld . cwCam . cwcViewFrom
extendConeToScreenEdge :: Configuration -> World -> Point2 -> (Point2, Point2) -> [Point2]
extendConeToScreenEdge cfig w c (x, y) = orderPolygon $ wallScreenIntersect ++ [x, y] ++ borderPs ++ cornerPs
src/Dodge/Default/World.hs
+18 -15
View File
@@ -33,17 +33,25 @@ defaultWorld =
, _rbOptions = NoRightButtonOptions
}
defaultCWCam :: CWCam
defaultCWCam = CWCam
{ _cwcCenter = V2 0 0
, _cwcRot = 0
, _cwcZoom = 1
, _cwcDefaultZoom = 1
, _cwcViewFrom = V2 0 0
, _cwcViewDistance = 1000
, _cwcItemZoom = 1
, _cwcBoundBox = square 100
, _cwcBoundDist = (100, -100, 100, -100)
}
defaultCWorld :: CWorld
defaultCWorld =
CWorld
{ _cameraCenter = V2 0 0
, _cameraRot = 0
, _cameraZoom = 1
{ _cwCam = defaultCWCam
, _magnets = IM.empty
, _itemZoom = 1
, _defaultZoom = 1
, _cameraViewFrom = V2 0 0
, _viewDistance = 1000
, _modifications = IM.empty
, _creatures = IM.empty
, _crZoning = mempty --Zoning IM.empty crZoneSize zoneOfCreature
@@ -57,9 +65,7 @@ defaultCWorld =
, _projectiles = IM.empty
, _instantBullets = []
, _bullets = []
, -- , _instantParticles = []
-- , _particles = []
_flames = []
, _flames = []
, _radarSweeps = []
, _sparks = []
, _posEvents = []
@@ -121,11 +127,8 @@ defaultCWorld =
, _maybeWorld = Nothing'
, _rewindWorlds = []
, _genParams = GenParams M.empty
, -- , _genPlacements = IM.empty
-- , _genRooms = IM.empty
_deathDelay = Nothing
, _boundBox = square 100
, _boundDist = (100, -100, 100, -100)
, _deathDelay = Nothing
, _cwSeed = 0
}
defaultWorldHammers :: M.Map WorldHammer HammerPosition
src/Dodge/Event.hs
+1 -1
View File
@@ -108,7 +108,7 @@ wheelEvent y w = case _hudElement $ _hud (_cWorld w) of
(_, EquipOptions{}) -> scrollRBOption y w
(Nothing, _) -> closeObjScrollDir y w
(Just f, _) -> w & cWorld . creatures . ix 0 . crInv . ix (crSel $ you w) %~ doHeldScroll f y (you w)
| lbDown -> w & cWorld . cameraZoom +~ y
| lbDown -> w & cWorld . cwCam . cwcZoom +~ y
| invKeyDown -> changeSwapInvSel yi w
| otherwise -> stopSoundFrom (CrReloadSound 0) $ changeAugInvSel yi w
DisplayInventory (TweakInventory mi)
src/Dodge/Initialisation.hs
+1 -1
View File
@@ -16,7 +16,7 @@ splashScreen =
initialWorld :: World
initialWorld =
defaultWorld
& cWorld . cameraZoom .~ 10
& cWorld . cwCam . cwcZoom .~ 10
& cWorld . creatures .~ IM.fromList [(0, startCr)]
& cWorld . 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/TriggerType.hs
+4 -4
View File
@@ -579,7 +579,7 @@ torqueBefore torque feff item cr w
w
& randGen .~ g
& cWorld . creatures . ix cid . crDir +~ rot
& cWorld . cameraRot +~ rot
& cWorld . cwCam . cwcRot +~ rot
| otherwise = feff item cr $ set randGen g $ over (cWorld . creatures . ix cid . crDir) (+ rot) w
where
cid = _crID cr
@@ -600,7 +600,7 @@ torqueBeforeAtLeast minTorque exTorque feff item cr w
w
& randGen .~ g
& cWorld . creatures . ix cid . crDir +~ rot'
& cWorld . cameraRot +~ rot'
& cWorld . cwCam . cwcRot +~ rot'
| otherwise = feff item cr $ set randGen g $ over (cWorld . creatures . ix cid . crDir) (+ rot') w
where
cid = _crID cr
@@ -613,7 +613,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 . cameraRot) (+ rot) $ feff item cr w
| cid == 0 = set randGen g $ over (cWorld . cwCam . cwcRot) (+ rot) $ feff item cr w
| otherwise = set randGen g $ over (cWorld . creatures . ix cid . crDir) (+ rot) $ feff item cr w
where
cid = _crID cr
@@ -651,7 +651,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 . cameraRot) (+ rot) w
| cid == 0 = set randGen g $ over (cWorld . cwCam . cwcRot) (+ rot) w
| otherwise = set randGen g $ over (cWorld . creatures . ix cid . crDir) (+ rot) w
where
cid = _crID cr
src/Dodge/Layout.hs
+1 -1
View File
@@ -56,7 +56,7 @@ generateLevelFromRoomList gr' w =
randomCompass :: World -> World
randomCompass w = w & cWorld . cameraRot .~ (takeOne [0, 0.5 * pi, pi, 1.5 * pi] & evalState $ _randGen w)
randomCompass w = w & cWorld . cwCam . cwcRot .~ (takeOne [0, 0.5 * pi, pi, 1.5 * pi] & evalState $ _randGen w)
putFloorTiles :: GenWorld -> GenWorld
putFloorTiles gw = gw & gwWorld . cWorld . floorTiles .~ floorsFromGenWorld gw
src/Dodge/LevelGen.hs
+1
View File
@@ -28,6 +28,7 @@ generateWorldFromSeed i = do
postGenerationProcessing $
_gwWorld (generateLevelFromRoomList roomList initialWorld{_randGen = mkStdGen i})
& cWorld . roomClipping .~ bounds
& cWorld . cwSeed .~ i
postGenerationProcessing :: World -> World
postGenerationProcessing w = foldl' assignPushDoors w (_doors (_cWorld w))
src/Dodge/LoadSeed.hs
+16
View File
@@ -0,0 +1,16 @@
module Dodge.LoadSeed
where
import System.Directory
import Text.Read
loadSeed :: IO (Maybe Int)
loadSeed = maybeReadFile "saveSlot/seed" >>= (return . (>>= readMaybe))
maybeReadFile :: String -> IO (Maybe String)
maybeReadFile fpath = do
fexists <- doesFileExist fpath
if fexists
then do
str <- readFile fpath
return (Just str)
else return Nothing
src/Dodge/Menu.hs
+19 -14
View File
@@ -21,6 +21,7 @@ import Padding
import SDL
import System.Clipboard
import Text.Read
import Data.Maybe
splashMenu :: ScreenLayer
splashMenu =
@@ -30,17 +31,21 @@ splashMenu =
splashMenuOptions :: [MenuOption]
splashMenuOptions =
basicKeyOptions
[ Toggle (return . Just . loadSaveSlot (SaveSlotNum 0)) (opText "CONTINUE")
, Toggle (return . Just . startNewGameInSlot 0) (opText "NEW GAME")
, Toggle (return . Just . reloadLevelStart) (opText "RESTART")
, Toggle (pushScreen $ seedStartMenu "START FROM SEED") (opText "NEW FROM SEED")
[ Toggle (return . Just . loadSaveSlot (SaveSlotNum 0)) displaycontinue
, Toggle (return . Just . startNewGameInSlot 0) (opText "NEW WITH RANDOM SEED")
, Toggle (return . Just . reloadLevelStart) (displaywhenseed "NEW WITH LAST SEED")
, Toggle (pushScreen $ seedStartMenu "START FROM SEED") (opText "NEW WITH SPECIFIC SEED")
, Toggle (pushScreen optionMenu) (opText "OPTIONS")
, Toggle (pushScreen displayControls) (opText "VIEW CONTROLS")
, Toggle (return . Just) (opText "VIEW CURRENT SEED")
, Toggle (return . Just) (displaywhenseed "VIEW LAST SEED")
, Toggle (return . const Nothing) (opText "QUIT")
]
where
opText = const . Left
opText = const . MODString
displaycontinue u | _uvCanContinue u = MODString "CONTINUE"
| otherwise = MODBlockedString "CONTINUE"
displaywhenseed str u | isNothing (_uvMSeed u) = MODBlockedString str
| otherwise = MODString str
pauseMenu :: ScreenLayer
pauseMenu = slTitleOptionsEff "PAUSED" pauseMenuOptions (return . unpause)
@@ -60,7 +65,7 @@ pauseMenuOptions =
++ [ InvisibleToggle ScancodeEscape (return . const Nothing)
]
where
opText = const . Left
opText = const . MODString
saveQuit :: Universe -> IO (Maybe Universe)
saveQuit u =
@@ -78,7 +83,7 @@ seedStartMenu str = slTitleOptionsEff str seedStartOptions popScreen
seedStartOptions :: [MenuOption]
seedStartOptions =
[ Toggle trySeedFromClipboard (const $ Left "PASTE NUMBER FROM CLIPBOARD") ScancodeA
[ Toggle trySeedFromClipboard (const $ MODString "PASTE NUMBER FROM CLIPBOARD") ScancodeA
-- , Toggle ScancodeI (return . Just . loadSaveSlot LevelStartSlot) (const "INSERT NUMBER")
]
@@ -101,10 +106,10 @@ optionMenu = slTitleOptionsEff "OPTIONS" optionsOptions popScreen
optionsOptions :: [MenuOption]
optionsOptions =
basicKeyOptions
[ makeSubmenuOption soundMenu $ Left "VOLUME"
, makeSubmenuOption graphicsMenu $ Left "GRAPHICS"
, makeSubmenuOption gameplayMenu $ Left "GAMEPLAY"
, makeSubmenuOption debugMenu $ Left "DEBUG OPTIONS"
[ makeSubmenuOption soundMenu $ MODString "VOLUME"
, makeSubmenuOption graphicsMenu $ MODString "GRAPHICS"
, makeSubmenuOption gameplayMenu $ MODString "GAMEPLAY"
, makeSubmenuOption debugMenu $ MODString "DEBUG OPTIONS"
]
debugMenu :: ScreenLayer
@@ -124,7 +129,7 @@ debugMenuOptions =
f bd =
Toggle
(return . Just . (uvConfig . debug_booleans . at bd %~ toggleJust))
(Right . g bd . (^? uvConfig . debug_booleans . ix bd))
(uncurry MODStringOption . g bd . (^? uvConfig . debug_booleans . ix bd))
g bd Nothing = (show bd, "False")
g bd _ = (show bd, "True")
@@ -176,7 +181,7 @@ soundMenuOptions =
(change dec stype)
scod2
(change inc stype)
(\w -> Right (str, leftPad 2 '.' $ show (round $ 10 * voltype (_uvConfig w) :: Int)))
(\w -> MODStringOption str (leftPad 2 '.' $ show (round $ 10 * voltype (_uvConfig w) :: Int)))
change g vt uv = sw uv >> return (Just $ uv & uvConfig . vt %~ g)
dec x = max 0 (x - 0.1)
inc x = min 1 (x + 0.1)
src/Dodge/Menu/OptionType.hs
+2 -2
View File
@@ -8,12 +8,12 @@ import Dodge.Menu.PushPop
makeBoolOption lns t =
Toggle
(return . Just . (uvConfig . lns #%~ not))
(\u -> Right (t, show (u ^# uvConfig . lns)))
(\u -> MODStringOption t (show (u ^# uvConfig . lns)))
makeEnumOption lns str sideeff =
Toggle
(\u -> Just <$> sideeff (u & uvConfig . lns #%~ cycleEnum))
(\u -> Right (str, show (u ^# uvConfig . lns)))
(\u -> MODStringOption str (show (u ^# uvConfig . lns)))
makeSubmenuOption submenu t = Toggle (pushScreen submenu) (const t)
src/Dodge/Picture/SizeInvariant.hs
+9 -8
View File
@@ -1,5 +1,6 @@
module Dodge.Picture.SizeInvariant where
import Control.Lens
import Data.Maybe
import Dodge.Base.Window
import Dodge.Data.Universe
@@ -18,9 +19,9 @@ fixedSizePicAt pic p w =
. scale theScale theScale
$ pic
where
campos = _cameraViewFrom (_cWorld w)
campos = w ^. cWorld . cwCam . cwcViewFrom
v = p -.- campos
theScale = 1 / _cameraZoom (_cWorld w)
theScale = 1 / (w ^. cWorld . cwCam . cwcZoom)
(V2 x y) = campos +.+ v
fixedSizePicClamp ::
@@ -40,11 +41,11 @@ fixedSizePicClamp xbord ybord pic p cfig w =
. scale theScale theScale
$ pic
where
r = negate $ _cameraRot (_cWorld w)
z = _cameraZoom (_cWorld w)
campos = _cameraViewFrom (_cWorld w)
r = negate $ w ^. cWorld . cwCam . cwcRot
z = w ^. cWorld . cwCam . cwcZoom
campos = w ^. cWorld . cwCam . cwcViewFrom
v = p -.- campos
theScale = 1 / _cameraZoom (_cWorld w)
theScale = 1 / (w ^. cWorld . cwCam . cwcZoom)
(V2 x y) = campos +.+ rotateV (negate r) (V2 xr' yr')
(V2 xr yr) = rotateV r v
xr' = absClamp ((halfWidth cfig - fromIntegral xbord) / z) xr
@@ -74,8 +75,8 @@ fixedSizePicClampArrow xbord ybord pic p cfig w =
Nothing -> blank
Just bp -> thickLine 5 [bp, fromMaybe p windowPoint]
(V2 x y) = fromMaybe p borderPoint
campos = _cameraCenter (_cWorld w)
theScale = 1 / _cameraZoom (_cWorld w)
campos = w ^. cWorld . cwCam . cwcCenter
theScale = 1 / (w ^. cWorld . cwCam . cwcZoom)
absClamp ::
-- | clamping value, assumed positive
src/Dodge/Projectile/Update.hs
+1 -1
View File
@@ -99,7 +99,7 @@ setRemoteDir cid itid pj w = w & cWorld . projectiles . ix (_prjID pj) . prjAcc
| SDL.ButtonRight `M.member` _mouseButtons w
&& w ^? cWorld . creatures . ix cid . crInvSel . iselPos
== w ^? cWorld . itemLocations . ix itid . ipInvID
= _cameraRot (_cWorld w) + argV (_mousePos w)
= (w ^. cWorld . cwCam . cwcRot) + argV (_mousePos w)
| otherwise = _prjDir pj
doThrust :: Proj -> World -> World
src/Dodge/Render.hs
+4 -4
View File
@@ -32,14 +32,14 @@ doDrawing pdata u = do
sTicks <- SDL.ticks
let w = _uvWorld u
cfig = _uvConfig u
rot = _cameraRot (_cWorld w)
camzoom = _cameraZoom (_cWorld w)
trans = _cameraCenter (_cWorld w)
rot = w ^. cWorld . cwCam . cwcRot
camzoom = w ^. cWorld . cwCam . cwcZoom
trans = w ^. cWorld . cwCam . cwcCenter
wins@(V2 winx winy) = V2 (_windowX cfig) (_windowY cfig)
resFact = resFactorNum $ cfig ^. graphics_resolution_factor
(wallPointsCol, windowPoints, wallSPics) = wallsToDraw w
lightPoints = lightsToRender cfig w
viewFroms@(V2 vfx vfy) = _cameraViewFrom (_cWorld w)
viewFroms@(V2 vfx vfy) = w ^. cWorld . cwCam . cwcViewFrom
viewFrom3d = Vector3 vfx vfy 20
shadV = _pictureShaders pdata
lwShad = _lightingWallShadShader pdata
src/Dodge/Render/Lights.hs
+3 -2
View File
@@ -6,6 +6,7 @@ import Data.Maybe
import Dodge.Data.Universe
import Geometry
import qualified IntMapHelp as IM
import Control.Lens
lightsToRender :: Configuration -> World -> [(Point3, Float, Point3)]
lightsToRender cfig w =
@@ -14,8 +15,8 @@ lightsToRender cfig w =
where
getLS = getlsparam . _lsParam
getTLS = getlsparam . _tlsParam
cbox = _boundBox (_cWorld w)
cpos = _cameraCenter (_cWorld w)
cbox = w ^. cWorld . cwCam . cwcBoundBox
cpos = w ^. cWorld . cwCam . cwcCenter
getlsparam ls
| not (pointInPolygon lpos cbox) && extraculltest = Nothing
| otherwise = Just (_lsPos ls, rad ^ (2 :: Int), _lsCol ls)
src/Dodge/Render/List.hs
+23
View File
@@ -59,6 +59,29 @@ listCursorNESW = listCursorChooseBorder [True, True, True, True]
listCursorNSW :: Float -> Float -> Configuration -> Int -> Color -> Int -> Int -> Picture
listCursorNSW = listCursorChooseBorder [True, False, True, True]
fillScreenText :: Configuration -> String -> Picture
fillScreenText cfig str =
winScale cfig
. scale wscale hscale
. centerText
$ str
where
wscale = hw*0.02/fromIntegral (length str)
hscale = hh*0.01
hw = halfWidth cfig
hh = halfHeight cfig
fillWidthText :: Configuration -> String -> Picture
fillWidthText cfig str =
winScale cfig
. scale thescale thescale
. centerText
$ str
where
thescale = hw*0.02/fromIntegral (length str)
hw = halfWidth cfig
listTextPictureAt :: Float -> Float -> Configuration -> Int -> Picture -> Picture
listTextPictureAt xoff yoff cfig yint =
winScale cfig
src/Dodge/Render/MenuScreen.hs
+22 -8
View File
@@ -64,7 +64,7 @@ drawOptions u title ops off footer =
, drawFooterText cfig red footer
]
++ zipWith
(\s vpos -> placeString (- hw + 50) vpos 0.2 s)
(\s vpos -> placeColorString (- hw + 50) vpos 0.2 s)
ops''
[hh -100, hh -150 ..]
where
@@ -77,7 +77,7 @@ drawOptions u title ops off footer =
x | x < length ops -> take (availableMenuLines cfig) (drop off visibleops)
_ -> visibleops
ops'' = case availableMenuLines cfig of
x | x < length ops -> map (menuOptionToString u maxOptionLength) ops' ++ ["SPACE: MORE OPTIONS"]
x | x < length ops -> map (menuOptionToString u maxOptionLength) ops' ++ [(white,"SPACE: MORE OPTIONS")]
_ -> map (menuOptionToString u maxOptionLength) ops'
visibleops = filter notInvisible ops
notInvisible InvisibleToggle{} = False
@@ -88,8 +88,8 @@ drawOptions u title ops off footer =
optionValueOffset :: Universe -> MenuOption -> Int
optionValueOffset u mo = case _moString mo u of
Left _ -> 0
Right (s, _) -> length s
MODStringOption s _ -> length s
_ -> 0
darkenBackground :: Configuration -> Picture
darkenBackground = color (withAlpha 0.5 black) . polygon . reverse . screenBox
@@ -111,18 +111,32 @@ placeString ::
Picture
placeString x y sc = color white . translate x y . scale sc sc . text
placeColorString ::
-- | x distance from center
Float ->
-- | y distance from center
Float ->
-- | scale
Float ->
(Color,String) ->
Picture
placeColorString x y sc (col,str) = color col . translate x y . scale sc sc . text $ str
drawFooterText :: Configuration -> Color -> String -> Picture
drawFooterText cfig col = color col . placeString (- hw + 30) (- hh + 10) 0.1
where
hh = halfHeight cfig
hw = halfWidth cfig
menuOptionToString :: Universe -> Int -> MenuOption -> String
menuOptionToString w padAmount mo = theKeys ++ optionText
menuOptionToString :: Universe -> Int -> MenuOption -> (Color,String)
menuOptionToString w padAmount mo = (thecol,theKeys ++ optionText)
where
thecol = case _moString mo w of
MODBlockedString {} -> greyN 0.5
_ -> white
optionText = case _moString mo w of
Left s -> s
Right (s, t) -> rightPad padAmount '.' s ++ t
MODStringOption s t -> rightPad padAmount '.' s ++ t
x -> _modString x
theKeys = case mo of
Toggle{_moKey = k} -> stc k : ":"
Toggle2{_moKey1 = k1, _moKey2 = k2} -> stc k1 : '/' : stc k2 : ":"
src/Dodge/Render/Outline.hs
+14
View File
@@ -0,0 +1,14 @@
module Dodge.Render.Outline
where
import Picture
hackOutline :: Color -> Float -> Picture -> Picture
hackOutline col x pic = pictures
(map (color col)
[ translate x 0 pic
, translate (-x) 0 pic
, translate 0 x pic
, translate 0 (-x) pic
]
) <> pic
src/Dodge/Render/Picture.hs
+13 -11
View File
@@ -2,6 +2,7 @@ module Dodge.Render.Picture (
fixedCoordPictures,
) where
import Control.Lens
import Dodge.Base.WinScale
import Dodge.Base.Window
import Dodge.Data.Universe
@@ -10,7 +11,6 @@ import Dodge.Render.List
import Dodge.Render.MenuScreen
import Geometry
import Picture
import Control.Lens
fixedCoordPictures :: Universe -> Picture
fixedCoordPictures u =
@@ -27,16 +27,18 @@ fixedCoordPictures u =
drawConcurrentMessage :: Universe -> Picture
drawConcurrentMessage u = case u ^. uvConcEffects of
BlockingConcEffect str -> listPicturesAt
(halfWidth cfig)
(halfHeight cfig)
cfig
[text str]
BackgroundConcEffect str -> listPicturesAt
(halfWidth cfig)
(_windowY cfig - 50)
cfig
[text str]
BlockingConcEffect str -> fillWidthText cfig str
--listPicturesAt
--(halfWidth cfig)
--(halfHeight cfig)
--cfig
--[centerText str]
BackgroundConcEffect str ->
listPicturesAt
(halfWidth cfig)
(_windowY cfig - 50)
cfig
[centerText str]
_ -> mempty
where
cfig = _uvConfig u
src/Dodge/Render/ShapePicture.hs
+15 -7
View File
@@ -118,8 +118,8 @@ shiftDraw' fpos fdir fdraw x =
cullPoint :: Configuration -> World -> Point2 -> Bool
cullPoint cfig w p
| debugOn Close_shape_culling cfig = pointInPolygon p (_boundBox (_cWorld w))
| otherwise = dist (_cameraCenter (_cWorld w)) p < _viewDistance (_cWorld w)
| debugOn Close_shape_culling cfig = pointInPolygon p (w ^. cWorld . cwCam . cwcBoundBox)
| otherwise = dist (w ^. cWorld . cwCam . cwcCenter) p < (w ^. cWorld . cwCam . cwcViewDistance)
extraPics :: Configuration -> World -> Picture
extraPics cfig w =
@@ -277,7 +277,7 @@ drawFarWallDetect w =
)
$ runIdentity $ S.toList_ $ streamViewpoints p w
where
p = _cameraViewFrom (_cWorld w)
p = w ^. cWorld . cwCam . cwcViewFrom
drawDDATest :: World -> Picture
drawDDATest w =
@@ -288,7 +288,7 @@ drawDDATest w =
-- <> color blue (runIdentity (S.foldMap_ drawCross qs'))
<> setLayer DebugLayer (color yellow (line [cvf, mwp]))
where
cvf = _cameraViewFrom (_cWorld w)
cvf = w ^. cWorld . cwCam . cwcViewFrom
mwp = mouseWorldPos w
--ps = ddaStreamX 50 cvf mwp
ps = zoneOfSeg' 50 cvf mwp
@@ -315,15 +315,23 @@ drawWallSearchRays w = foldMap (f . fst) $ allVisibleWalls w
setLayer DebugLayer $
color yellow $
uncurryV translate p (circle 5)
<> line [_cameraViewFrom (_cWorld w), p]
<> line [w ^. cWorld . cwCam . cwcViewFrom , p]
testPic :: Configuration -> World -> Picture
testPic _ _ = mempty
--testPic cfig _ = setLayer FixedCoordLayer $ listPicturesAt 100 100 cfig $ map centerText
-- ["A"
-- ,"AA"
-- ,"AAA"
-- ,"AAAA"
-- ,"AAAAA"
-- ,"AAAAAA"
-- ]
drawBoundingBox :: World -> Picture
drawBoundingBox w = setLayer DebugLayer $ color green $ line $ (x : xs) ++ [x]
where
(x : xs) = _boundBox (_cWorld w)
(x : xs) = w ^. cWorld . cwCam . cwcBoundBox
clDraw :: Cloud -> Picture
clDraw c = translate3 (_clPos c) (drawCloud (_clPict c) c)
@@ -351,7 +359,7 @@ soundPic cfig w s = fixedSizePicClampArrow 50 50 thePic p cfig w
where
p = _soundPos s
thePic =
rotate (_cameraRot (_cWorld w))
rotate (w ^. cWorld . cwCam . cwcRot)
. scale theScale theScale
. centerText
. soundToOnomato
src/Dodge/Save.hs
+1 -1
View File
@@ -47,7 +47,7 @@ saveSlotPath QuicksaveSlot = "saveSlot/QuickSave"
saveSlotPath (LevelStartSlot i) = "saveSlot/LevelStart" ++ show i
saveWorldInSlot :: SaveSlot -> Universe -> Universe
saveWorldInSlot slot u = tryConcEffect False "ASDF" (writeSaveSlot slot u) u
saveWorldInSlot slot u = tryConcEffect False "SAVING" (writeSaveSlot slot u) u
reloadLevelStart :: Universe -> Universe
reloadLevelStart = loadSaveSlot (LevelStartSlot 0)
src/Dodge/SoundLogic.hs
+2 -2
View File
@@ -212,9 +212,9 @@ soundAngle p w
. radToDeg
. normalizeAngle
. (+ pi)
$ argV (vNormal (p -.- earPos)) - _cameraRot (_cWorld w)
$ argV (vNormal (p -.- earPos)) - _cwcRot (_cwCam (_cWorld w))
where
earPos = _cameraViewFrom (_cWorld w)
earPos = w ^. cWorld . cwCam . cwcViewFrom
{- | Uses the first free origin from a list.
Does nothing if all origins are already creating sounds.
src/Dodge/StartNewGame.hs
+2 -1
View File
@@ -22,7 +22,8 @@ startSeedGame _ i = tryConcEffect True "GENERATING" (startSeedGameConc i)
startSeedGameConc :: Int -> IO (Universe -> Maybe Universe)
startSeedGameConc seed = do
w <- generateWorldFromSeed seed
return $ Just
writeFile "saveSlot/seed" $ show seed
return $ Just
. saveWorldInSlot (LevelStartSlot 0)
. (uvScreenLayers .~ [])
. (uvWorld .~ w)
src/Dodge/Update/Camera.hs
+17 -17
View File
@@ -45,11 +45,11 @@ updateCamera uv =
moveZoomCamera :: Universe -> Universe
moveZoomCamera uv =
uv
& uvWorld . cWorld . cameraCenter .~ newcen
& uvWorld . cWorld . cameraViewFrom .~ newvf
& uvWorld . cWorld . cameraZoom .~ newzoom
& uvWorld . cWorld . defaultZoom .~ newDefaultZoom
& uvWorld . cWorld . itemZoom .~ newItemZoom
& uvWorld . cWorld . cwCam . cwcCenter .~ newcen
& uvWorld . cWorld . cwCam . cwcViewFrom .~ newvf
& uvWorld . cWorld . cwCam . cwcZoom .~ newzoom
& uvWorld . cWorld . cwCam . cwcDefaultZoom .~ newDefaultZoom
& uvWorld . cWorld . cwCam . cwcItemZoom .~ newItemZoom
where
cfig = _uvConfig uv
w = _uvWorld uv
@@ -64,7 +64,7 @@ moveZoomCamera uv =
guard (SDL.ButtonRight `M.member` _mouseButtons w)
yourItem w ^? _Just . itScope . scopePos
newcen = cpos +.+ fromMaybe (V2 0 0) mscopeoffset +.+ offset
offset = rotateV (_cameraRot (_cWorld w)) $ ((newzoom - newDefaultZoom) / (newDefaultZoom * newzoom)) *.* _mousePos w
offset = rotateV (w ^. cWorld . cwCam . cwcRot) $ ((newzoom - newDefaultZoom) / (newDefaultZoom * newzoom)) *.* _mousePos w
--newzoom = changeZoom (_cameraZoom w) idealZoom'
newzoom = case yourItem w ^? _Just . itScope of
Just zs@ZoomScope{} -> _scopeZoom zs
@@ -72,17 +72,17 @@ moveZoomCamera uv =
idealDefaultZoom = clipZoom wallZoom
newDefaultZoom = case yourItem w ^? _Just . itScope of
Just zs@ZoomScope{} -> _scopeZoom zs
_ -> changeZoom (_defaultZoom (_cWorld w)) idealDefaultZoom
_ -> changeZoom (w ^. cWorld . cwCam . cwcDefaultZoom) idealDefaultZoom
idealItemZoom = fromMaybe 1 $ do
guard $ crIsAiming (you w)
zoomFromItem' <$> (yourItem w ^? _Just . itUse . heldAim . aimZoom)
newItemZoom = changeZoom (_itemZoom (_cWorld w)) idealItemZoom
newItemZoom = changeZoom (w ^. cWorld . cwCam . cwcItemZoom) idealItemZoom
changeZoom curZoom idealZoom
| curZoom > idealZoom + 0.01 = ((zoomOutSpeed -1) * curZoom + idealZoom) / zoomOutSpeed
| curZoom < idealZoom - 0.01 = ((zoomInSpeed -1) * curZoom + idealZoom) / zoomInSpeed
| otherwise = idealZoom
--wallZoom = farWallDist newvf cfig w
wallZoom = min4 (_boundDist (_cWorld w))
wallZoom = min4 (w ^. cWorld . cwCam . cwcBoundDist)
min4 (a, b, c, d) = minimum [hh / maxd a, hh / maxd (- b), hw / maxd c, hw / maxd (- d)]
maxd = max distFromEqmnt
distFromEqmnt = foldr max 1 $ IM.mapMaybe (_eeViewDist . _equipEffect . _itUse) $ getCrEquipment $ you w
@@ -135,7 +135,7 @@ zoomInLongGun w
wp = _crInv (_creatures (_cWorld w) IM.! 0) IM.! crSel (_creatures (_cWorld w) IM.! 0)
Just currentZoom = wp ^? itScope . scopeZoom
newzoom = (wp ^?! itScope . scopeZoom) / zoomSpeed
mousep = rotateV (_cameraRot (_cWorld w)) $ _mousePos w
mousep = rotateV (w ^. cWorld . cwCam . cwcRot) $ _mousePos w
zoomOutLongGun :: World -> World
zoomOutLongGun w
@@ -171,11 +171,11 @@ rotateToOverlappingWall w =
p = _crPos (you w)
doWallRotate :: Wall -> World -> World
doWallRotate wl' w = rotateUsing $ (argV . uncurry (-.-) $ _wlLine wl') - _cameraRot (_cWorld w)
doWallRotate wl' w = rotateUsing $ (argV . uncurry (-.-) $ _wlLine wl') - (w ^. cWorld . cwCam . cwcRot)
where
rotateUsing a
| b - b' > 0.01 = w & cWorld . cameraRot +~ 0.01
| b - b' < negate 0.01 = w & cWorld . cameraRot -~ 0.01
| b - b' > 0.01 = w & cWorld . cwCam . cwcRot +~ 0.01
| b - b' < negate 0.01 = w & cWorld . cwCam . cwcRot -~ 0.01
| otherwise = w
where
--b = a * (2 / pi)
@@ -185,7 +185,7 @@ doWallRotate wl' w = rotateUsing $ (argV . uncurry (-.-) $ _wlLine wl') - _camer
rotateCameraBy :: Float -> World -> World
rotateCameraBy x w =
w
& cWorld . cameraRot +~ x
& cWorld . cwCam . cwcRot +~ x
& cWorld . creatures . ix 0 . crInv . ix (crSel (_creatures (_cWorld w) IM.! 0))
. itScope
. scopePos
@@ -221,8 +221,8 @@ clipZoom = min 20 . max 0.2
setViewDistance :: Configuration -> World -> World
setViewDistance cfig w =
w & cWorld . viewDistance
.~ sqrt (halfWidth cfig ** 2 + halfHeight cfig ** 2) / _cameraZoom (_cWorld w)
w & cWorld . cwCam . cwcViewDistance
.~ sqrt (halfWidth cfig ** 2 + halfHeight cfig ** 2) / (w ^. cWorld . cwCam . cwcZoom)
-- .~ max (halfWidth cfig) (halfHeight cfig) / _cameraZoom w
@@ -245,7 +245,7 @@ farWallDistDirection p w =
boundPoints $
S.map f vps
where
f q = (rotateV (negate $ _cameraRot (_cWorld w)) . (-.- p)) (foldl' findPoint q (wls q))
f q = (rotateV (negate $ (w ^. cWorld . cwCam . cwcRot)) . (-.- p)) (foldl' findPoint q (wls q))
wls q = filter wlIsOpaque $ wlsNearSeg p q w
findPoint q = fromMaybe q . uncurry (intersectSegSeg p q) . _wlLine
vps = streamViewpoints p w
src/Dodge/Update/UsingInput.hs
+1 -1
View File
@@ -60,7 +60,7 @@ updatePressedButtons' pkeys w
w & hammers . ix DoubleMouseHam .~ HammerDown
| isDown ButtonRight && inTopInv = w
| isDown ButtonMiddle =
w & cWorld . cameraRot -~ rotation
w & cWorld . cwCam . cwcRot -~ rotation
& cWorld . clickMousePos .~ _mousePos w
| isDown ButtonLeft = w & hammers . ix DoubleMouseHam .~ HammerDown
| otherwise = w
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 . cameraRot) (+ rot) w
| cid == 0 = set randGen g $ over (cWorld . cwCam . cwcRot) (+ rot) w
| otherwise = set randGen g $ over (cWorld . creatures . ix cid . crDir) (+ rot) w
where
(rot, g) = randomR (- x, x) $ _randGen w
src/Dodge/Zone.hs
+1 -1
View File
@@ -56,7 +56,7 @@ zoneOfSight x' w = S.each
]
where
--(xs,ys) = unzip $ map zoneOfPoint $ screenPolygon cfig w -- ++ [_cameraViewFrom w]
(xs,ys) = unzip $ map (sizeZoneOfPoint x') $ _boundBox $ _cWorld w -- ++ [_cameraViewFrom w]
(xs,ys) = unzip $ map (sizeZoneOfPoint x') $ w ^. cWorld . cwCam . cwcBoundBox
sizeZoneOfPoint s (V2 x y) = (f x, f y)
where
f = floor . (/ s)
src/Dodge/Zoning/World.hs
+2 -1
View File
@@ -2,6 +2,7 @@ module Dodge.Zoning.World where
import Dodge.Data.World
import Geometry.Data
import Control.Lens
zoneOfSight' :: Float -> World -> [Int2]
zoneOfSight' s w =
@@ -10,7 +11,7 @@ zoneOfSight' s w =
, b <- [minimum ys .. maximum ys]
]
where
(xs, ys) = unzip $ map sizeZoneOfPoint $ _boundBox (_cWorld w) -- ++ [_cameraViewFrom w]
(xs, ys) = unzip $ map sizeZoneOfPoint $ w ^. cWorld . cwCam . cwcBoundBox
sizeZoneOfPoint (V2 x y) = (f x, f y)
where
f = floor . (/ s)
src/Picture/Base.hs
+179 -165
View File
@@ -1,56 +1,56 @@
{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE TupleSections #-}
{-# LANGUAGE BangPatterns #-}
module Picture.Base
( module Picture.Data
, module Color
, blank
, polygon
, polygonWire
, polygonZ
, polygonCol
, poly3
, poly3Col
, bezierQuad
, arc
, arcSolid
, thickArc
, thickCircle
, thickLine
, lineThick
, thickLineCol
, circleSolid
, circleSolidCol
, circle
, line
, lineCol
, text
, centerText
, stackText
, pictures
, concatMapPic
, appendPic
, tranRot
, translate
, translate3
, rotate
, scale
, color
, zeroZ
, setDepth
, addDepth
, setLayer
, mirroryz
, mirrorxz
, overPos
, picMap
)
where
import Geometry
import Picture.Data
import Color
module Picture.Base (
module Picture.Data,
module Color,
blank,
polygon,
polygonWire,
polygonZ,
polygonCol,
poly3,
poly3Col,
bezierQuad,
arc,
arcSolid,
thickArc,
thickCircle,
thickLine,
lineThick,
thickLineCol,
circleSolid,
circleSolidCol,
circle,
line,
lineCol,
text,
centerText,
stackText,
pictures,
concatMapPic,
appendPic,
tranRot,
translate,
translate3,
rotate,
scale,
color,
zeroZ,
setDepth,
addDepth,
setLayer,
mirroryz,
mirrorxz,
overPos,
picMap,
) where
import Color
--import qualified Streaming.Prelude as S
import Data.Foldable
import Geometry
import Picture.Data
blank :: Picture
{-# INLINE blank #-}
@@ -74,60 +74,61 @@ polygon = picFormat . map f . polyToTris
where
f (V2 x y) = Verx (V3 x y 0) black [] BottomLayer polyNum
polygonZ :: [Point2] -> Float -> Picture
{-# INLINE polygonZ #-}
polygonZ ps z = picFormat . map (f . zeroZ) $ polyToTris ps
where
f pos = Verx pos black [z] BottomLayer polyzNum
polygonCol :: [(Point2,RGBA)] -> Picture
polygonCol :: [(Point2, RGBA)] -> Picture
{-# INLINE polygonCol #-}
polygonCol = picFormat . polyToTris . map f
where
f (V2 x y,col) = Verx (V3 x y 0) col [] BottomLayer polyNum
f (V2 x y, col) = Verx (V3 x y 0) col [] BottomLayer polyNum
poly3 :: [Point3] -> Picture
{-# INLINE poly3 #-}
poly3 = poly3Col . map (, black)
poly3 = poly3Col . map (,black)
poly3Col :: [(Point3,RGBA)] -> Picture
poly3Col :: [(Point3, RGBA)] -> Picture
{-# INLINE poly3Col #-}
poly3Col = picFormat . map f . polyToTris
where
f (pos,col) = Verx pos col [] BottomLayer polyNum
f (pos, col) = Verx pos col [] BottomLayer polyNum
-- note that much of work computing the width of the bezier curve is done here
bezierQuad :: Color -> Color -> Float -> Float -> Point2 -> Point2 -> Point2 -> Picture
bezierQuad cola colc ra rc a b c
bezierQuad cola colc ra rc a b c
| a == b && b == c = blank
| a == b || b == c = bezierQuad cola colc ra rc a (0.5 *.* (a +.+ c)) c
| otherwise = bzhelp
[(aIn, cola, V2 (fa aIn) (fc aIn) , V2 1 0 )
,(aIn, cola, V2 (fa aIn) (fc aIn) , V2 1 0 )
,(cIn, colc, V2 (fa cIn) (fc cIn) , V2 0 1 )
,( aX, cola, V2 1 0 , V2 (fa' aX) (fc' aX) )
,( cX, colc, V2 0 1 , V2 (fa' cX) (fc' cX) )
,( bX, colb, V2 0 0 , V2 (fa' bX) (fc' bX) )
,( bX, colb, V2 0 0 , V2 (fa' bX) (fc' bX) )
]
where
| otherwise =
bzhelp
[ (aIn, cola, V2 (fa aIn) (fc aIn), V2 1 0)
, (aIn, cola, V2 (fa aIn) (fc aIn), V2 1 0)
, (cIn, colc, V2 (fa cIn) (fc cIn), V2 0 1)
, (aX, cola, V2 1 0, V2 (fa' aX) (fc' aX))
, (cX, colc, V2 0 1, V2 (fa' cX) (fc' cX))
, (bX, colb, V2 0 0, V2 (fa' bX) (fc' bX))
, (bX, colb, V2 0 0, V2 (fa' bX) (fc' bX))
]
where
colb = mixColors 0.5 0.5 cola colc
b2a | isLHS a b c = a -.- b
| otherwise = b -.- a
b2a
| isLHS a b c = a -.- b
| otherwise = b -.- a
aRadVec = 0.5 * ra *.* normalizeV (vNormal b2a)
aX = a -.- aRadVec
aX = a -.- aRadVec
aIn = a +.+ aRadVec
b2c | isLHS a b c = b -.- c
| otherwise = c -.- b
b2c
| isLHS a b c = b -.- c
| otherwise = c -.- b
cRadVec = 0.5 * rc *.* normalizeV (vNormal b2c)
cX = c -.- cRadVec
cX = c -.- cRadVec
cIn = c +.+ cRadVec
bRadVec = 0.25 * (ra + rc) *.* normalizeV (a +.+ b -.- 2 *.* c)
bX = b +.+ bRadVec
bX = b +.+ bRadVec
bIn = b -.- bRadVec
fa = extrapolate aX cX bX
fa = extrapolate aX cX bX
fc = extrapolate cX aX bX
fa' = extrapolate aIn cIn bIn
fc' = extrapolate cIn aIn bIn
@@ -135,22 +136,21 @@ bezierQuad cola colc ra rc a b c
bzhelp :: [(Point2, Point4, Point2, Point2)] -> Picture
bzhelp = picFormat . map f
where
f (V2 x y,col,V2 a b,V2 c d) = Verx (V3 x y 0) col [a,b,c,d] BottomLayer bezNum
f (V2 x y, col, V2 a b, V2 c d) = Verx (V3 x y 0) col [a, b, c, d] BottomLayer bezNum
-- given a one and two zeros of a linear function over x and y,
-- determine the function
-- so if f(ox,oy) = 1 and f(ax,ay) = f(bx,by) = 0, determines f
extrapolate :: Point2 -> Point2 -> Point2 -> Point2 -> Float
extrapolate (V2 ox oy) (V2 ax ay) (V2 bx by) (V2 x y) =
( x * ( ay - by )
+ y * ( bx - ax )
+ (ax * by - bx * ay)
)
/
( ox * ( ay - by )
+ ax * ( by - oy )
+ bx * ( oy - ay )
extrapolate (V2 ox oy) (V2 ax ay) (V2 bx by) (V2 x y) =
( x * (ay - by)
+ y * (bx - ax)
+ (ax * by - bx * ay)
)
/ ( ox * (ay - by)
+ ax * (by - oy)
+ bx * (oy - ay)
)
color :: RGBA -> Picture -> Picture
{-# INLINE color #-}
@@ -158,7 +158,7 @@ color c = picMap $ overCol (const c)
translateH :: Float -> Float -> Point3 -> Point3
{-# INLINE translateH #-}
translateH !a !b (V3 x y z) = V3 (x+a) (y+b) z
translateH !a !b (V3 x y z) = V3 (x + a) (y + b) z
translate :: Float -> Float -> Picture -> Picture
{-# INLINE translate #-}
@@ -180,18 +180,18 @@ setDepth d = picMap $ overPos (\(V3 x y _) -> V3 x y d)
addDepth :: Float -> Picture -> Picture
{-# INLINE addDepth #-}
--addDepth d = map $ second $ overPos (\(x,y,z) -> (x,y,z+d))
addDepth d = picMap $ overPos (\(V3 x y z) -> V3 x y (z+d))
addDepth d = picMap $ overPos (\(V3 x y z) -> V3 x y (z + d))
-- TODO change the Int here to a dedicated type
setLayer :: Layer -> Picture -> Picture
{-# INLINE setLayer #-}
setLayer i = picMap f
where
f v = v {_vxLayer = i}
f v = v{_vxLayer = i}
scale3 :: Float -> Float -> Point3 -> Point3
{-# INLINE scale3 #-}
scale3 a b (V3 x y z) = V3 (x*a) (y*b) z
scale3 a b (V3 x y z) = V3 (x * a) (y * b) z
scale :: Float -> Float -> Picture -> Picture
{-# INLINE scale #-}
@@ -210,14 +210,14 @@ appendPic :: Picture -> Picture -> Picture
appendPic = (<>)
pictures :: Foldable t => t Picture -> Picture
{-# INLINABLE pictures #-}
{-# INLINEABLE pictures #-}
pictures = fold
makeArc :: Float -> Point2 -> [Point2]
{-# INLINE makeArc #-}
makeArc rad (V2 a b) = map (`rotateV` V2 0 rad) angles
where
angles = [a,a+step.. b]
where
angles = [a, a + step .. b]
step = pi * 0.2
circleSolid :: Float -> Picture
@@ -226,103 +226,115 @@ circleSolid = circleSolidCol white white
circleSolidCol :: Color -> Color -> Float -> Picture
{-# INLINE circleSolidCol #-}
circleSolidCol colC colE r = picFormat $ map f
[(V3 (-r) r 0, colC)
,(V3 (-r) (-r) 0, colE)
,(V3 r (-r) 0, black)
]
circleSolidCol colC colE r =
picFormat $
map
f
[ (V3 (- r) r 0, colC)
, (V3 (- r) (- r) 0, colE)
, (V3 r (- r) 0, black)
]
where
f (pos,col) = Verx pos col [] BottomLayer ellNum
f (pos, col) = Verx pos col [] BottomLayer ellNum
circle :: Float -> Picture
{-# INLINE circle #-}
circle rad = thickArc 0 (2*pi) rad 1
circle rad = thickArc 0 (2 * pi) rad 1
centerText :: String -> Picture
{-# INLINE centerText #-}
centerText s = translate (50 * (negate . fromIntegral $ length s - 1)) 0 $ text s
centerText s = translate (25 + 50 * (negate . fromIntegral $ length s - 1)) 0 $ text s
stackText :: [String] -> Picture
{-# INLINE stackText #-}
stackText = mconcat . zipWith (\y s -> translate 0 y $ centerText s) [0,100..]
stackText = mconcat . zipWith (\y s -> translate 0 y $ centerText s) [0, 100 ..]
text :: String -> Picture
{-# INLINE text #-}
text = picFormat . map f . stringToList
where
f (pos,col,V2 a b) = Verx pos col [a,b] BottomLayer textNum
f (pos, col, V2 a b) = Verx pos col [a, b] BottomLayer textNum
line :: [Point2] -> Picture
{-# INLINE line #-}
line = thickLine 1
lineCol :: [(Point2,RGBA)] -> Picture
lineCol :: [(Point2, RGBA)] -> Picture
{-# INLINE lineCol #-}
lineCol = thickLineCol 1
lineThick :: Float -> [Point2] -> Picture
{-# INLINE lineThick #-}
lineThick t = pictures . f
where
f (x:y:ys)
| x == y = f (x:ys)
| otherwise = polygon [x +.+ n x y, x -.- n x y, y -.- n x y, y +.+ n x y] : f (y:ys)
f _ = []
n a b = (t*0.5) *.* errorNormalizeV 42 (vNormal (a -.- b))
where
f (x : y : ys)
| x == y = f (x : ys)
| otherwise = polygon [x +.+ n x y, x -.- n x y, y -.- n x y, y +.+ n x y] : f (y : ys)
f _ = []
n a b = (t * 0.5) *.* errorNormalizeV 42 (vNormal (a -.- b))
thickLine :: Float -> [Point2] -> Picture
{-# INLINE thickLine #-}
thickLine t = pictures . f
where
f (x:y:ys)
| x == y = f (x:ys)
| otherwise = polygon [x +.+ n, x -.- n, y -.- n, y +.+ n] : f (y:ys)
where
f (x : y : ys)
| x == y = f (x : ys)
| otherwise = polygon [x +.+ n, x -.- n, y -.- n, y +.+ n] : f (y : ys)
where
n = (t*0.5) *.* errorNormalizeV 42 (vNormal (x -.- y))
f _ = []
n = (t * 0.5) *.* errorNormalizeV 42 (vNormal (x -.- y))
f _ = []
thickLineCol :: Float -> [(Point2,RGBA)] -> Picture
thickLineCol :: Float -> [(Point2, RGBA)] -> Picture
{-# INLINE thickLineCol #-}
thickLineCol t = pictures . f
where
f ((x,c):(y,c'):ys)
| x == y = f ((x,c):ys)
| otherwise = polygonCol
[(x +.+ n x y,c)
,(x -.- n x y,c)
,(y -.- n x y,c')
,(y +.+ n x y,c')
] : f ((y,c'):ys)
f _ = []
n a b = (t*0.5) *.* squashNormalizeV (vNormal (a -.- b))
where
f ((x, c) : (y, c') : ys)
| x == y = f ((x, c) : ys)
| otherwise =
polygonCol
[ (x +.+ n x y, c)
, (x -.- n x y, c)
, (y -.- n x y, c')
, (y +.+ n x y, c')
] :
f ((y, c') : ys)
f _ = []
n a b = (t * 0.5) *.* squashNormalizeV (vNormal (a -.- b))
thickCircle :: Float -> Float -> Picture
{-# INLINE thickCircle #-}
thickCircle = thickArc 0 (2*pi)
thickCircle = thickArc 0 (2 * pi)
arcSolid
:: Float -- ^ Start angle
-> Float -- ^ End angle
-> Float -- ^ Radius
-> Picture
arcSolid ::
-- | Start angle
Float ->
-- | End angle
Float ->
-- | Radius
Float ->
Picture
{-# INLINE arcSolid #-}
arcSolid startA endA rad = polygon $ V2 0 0 : makeArc rad (V2 startA endA)
arc
:: Float -- ^ Start angle
-> Float -- ^ End angle
-> Float -- ^ Radius
-> Picture
arc ::
-- | Start angle
Float ->
-- | End angle
Float ->
-- | Radius
Float ->
Picture
arc startA endA rad = thickArc startA endA rad 1
{-# INLINE arc #-}
thickArc :: Float -> Float -> Float -> Float -> Picture
{-# INLINE thickArc #-}
thickArc startA endA rad wdth
| endA - startA > (pi/ 2) = pictures
[ thickArc (startA + pi/2) endA rad wdth
, thickArcHelp startA (startA + pi/2) r w
]
| endA - startA > (pi / 2) =
pictures
[ thickArc (startA + pi / 2) endA rad wdth
, thickArcHelp startA (startA + pi / 2) r w
]
| otherwise = thickArcHelp startA endA r w
where
r = rad + 0.5 * wdth
@@ -330,50 +342,52 @@ thickArc startA endA rad wdth
thickArcHelp :: Float -> Float -> Float -> Float -> Picture
{-# INLINE thickArcHelp #-}
thickArcHelp startA endA rad wdth = picFormat $ map f
[ (V3 0 0 0,black,V3 0 0 wdth)
,(V3 xa ya 0,black,V3 1 0 wdth)
,(V3 xb yb 0,black,V3 1 1 wdth)
, (V3 0 0 0,black,V3 0 0 wdth)
,(V3 xb yb 0,black,V3 1 1 wdth)
,(V3 xc yc 0,black,V3 0 1 wdth)
]
thickArcHelp startA endA rad wdth =
picFormat $
map
f
[ (V3 0 0 0, black, V3 0 0 wdth)
, (V3 xa ya 0, black, V3 1 0 wdth)
, (V3 xb yb 0, black, V3 1 1 wdth)
, (V3 0 0 0, black, V3 0 0 wdth)
, (V3 xb yb 0, black, V3 1 1 wdth)
, (V3 xc yc 0, black, V3 0 1 wdth)
]
where
(V2 xa ya) = rotateV startA (V2 rad 0)
(V2 xb yb) = rotateV (0.5 * (startA + endA)) (V2 (rad * sqrt 2) 0)
--(V2 xb yb) = rotateV (0.5 * (startA + endA)) (V2 (rad * 2) 0)
(V2 xc yc) = rotateV endA (V2 rad 0)
f (pos,col,V3 a b c) = Verx pos col [a,b,c] BottomLayer arcNum
f (pos, col, V3 a b c) = Verx pos col [a, b, c] BottomLayer arcNum
-- Currently the lens version is much slower
overPos :: (Point3 -> Point3) -> Verx -> Verx
{-# INLINE overPos #-}
--overPos = over vxPos
overPos f vx = vx {_vxPos = f (_vxPos vx)}
overPos f vx = vx{_vxPos = f (_vxPos vx)}
overCol :: (Point4 -> Point4) -> Verx -> Verx
{-# INLINE overCol #-}
overCol f vx = vx {_vxCol = f (_vxCol vx)}
overCol f vx = vx{_vxCol = f (_vxCol vx)}
-- no premature optimisation, consider changing to use texture arrays
stringToList :: String -> [(Point3,Point4,Point2)]
stringToList :: String -> [(Point3, Point4, Point2)]
{-# INLINE stringToList #-}
stringToList = concatMap (uncurry charToTuple) . zip [0,0.9*dimText ..]
stringToList = concatMap (uncurry charToTuple) . zip [0, 0.9 * dimText ..]
where
dimText = 100
charToTuple :: Float -> Char -> [(Point3,Point4,Point2)]
charToTuple :: Float -> Char -> [(Point3, Point4, Point2)]
{-# INLINE charToTuple #-}
charToTuple x c =
[(V3 (x-50) (-100) 0, white,V2 offset 1)
,(V3 (x-50) 100 0, white,V2 offset 0)
,(V3 (x+50) 100 0, white,V2 (offset+1) 0)
,(V3 (x-50) (-100) 0, white,V2 offset 1)
,(V3 (x+50) (-100) 0, white,V2 (offset+1) 1)
,(V3 (x+50) 100 0, white,V2 (offset+1) 0)
charToTuple x c =
[ (V3 (x -50) (-100) 0, white, V2 offset 1)
, (V3 (x -50) 100 0, white, V2 offset 0)
, (V3 (x + 50) 100 0, white, V2 (offset + 1) 0)
, (V3 (x -50) (-100) 0, white, V2 offset 1)
, (V3 (x + 50) (-100) 0, white, V2 (offset + 1) 1)
, (V3 (x + 50) 100 0, white, V2 (offset + 1) 0)
]
where
where
offset = fromIntegral (fromEnum c) - 32
mirrorxz :: Picture -> Picture