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

Add menu option to start new game from seed, uses system clipboard

Browse Source
This commit is contained in:
justin
2021-12-09 14:36:26 +00:00
parent eeda4f3e39
commit 24a0cc289f
13 changed files with 101 additions and 54 deletions
Download Patch File Download Diff File Expand all files Collapse all files
appDodge/Main.hs
+6 -4
View File
@@ -3,7 +3,9 @@ module Main
) where
import Loop
import Dodge.Data
import Dodge.LevelGen
import Dodge.StartNewGame
import Dodge.Initialisation
--import Dodge.LevelGen
import Dodge.Update
import Dodge.Event
import Dodge.Render
@@ -55,9 +57,9 @@ firstWorldLoad theConfig = do
SDL.cursorVisible $= False
theKeyConfig <- loadKeyConfig
pdata <- doPreload >>= applyWorldConfig theConfig
w <- generateWorldFromSeed 0
return $ Universe
{_uvWorld = w
-- w <- generateWorldFromSeed 0
return $ startNewGame $ Universe
{_uvWorld = initialWorld
,_config = theConfig
,_preloadData = pdata
,_menuLayers = []
package.yaml
+1
View File
@@ -53,6 +53,7 @@ dependencies:
- repa
- monad-parallel
- parallel
- Clipboard
library:
source-dirs: src
src/Dodge/Creature/HandPos.hs
+17 -3
View File
@@ -1,6 +1,20 @@
module Dodge.Creature.HandPos where
import Dodge.Data
import Geometry
--import Geometry
import Control.Lens
import Data.Maybe
crHandPos :: Creature -> Point3
crHandPos _ = V3 0 0 20
-- the position of a weapon handle
aimingWeaponHandlePos :: Creature -> Item -> Float
aimingWeaponHandlePos cr it = case it ^? itUse. useAim . aimStance of
Just TwoHandTwist -> -5
Just OneHand -> 14
Just TwoHandFlat -> 1.2 * _crRad cr
Just LeaveHolstered -> 0
Nothing -> 0
aimingWeaponZeroPos :: Creature -> Item -> Float
aimingWeaponZeroPos cr it = aimingWeaponHandlePos cr it
- fromMaybe 0 (it ^? itDimension . dimPortage . handlePos)
aimingMuzzlePos :: Creature -> Item -> Float
aimingMuzzlePos cr it = aimingWeaponZeroPos cr it
+ fromMaybe 0 (it ^? itDimension . dimPortage . muzPos)
src/Dodge/Initialisation.hs
+2 -2
View File
@@ -1,7 +1,7 @@
module Dodge.Initialisation where
import Dodge.Default.World
import Dodge.Base
import Dodge.Save
--import Dodge.Save
import Dodge.Data
import Dodge.Creature
--import Dodge.Story
@@ -28,7 +28,7 @@ initialWorld = defaultWorld
, _mousePos = V2 0 0
, _testString = testStringInit
, _yourID = 0
, _sideEffects = return .saveWorldInEmptySlot LevelStartSlot
, _sideEffects = return
, _worldEvents = soundStart BackgroundSound (V2 0 0) foamSprayFadeOutS Nothing
. foldr ((.) . makeStartCloudAt) id [V3 x y 5 | x <- [-5,-4..5] , y <- [-5,-4..5]]
, _pressPlates = IM.empty
src/Dodge/Item/Draw.hs
+4 -9
View File
@@ -4,6 +4,7 @@ import Dodge.Data
--import Picture
--import Shape
import ShapePicture
import Dodge.Creature.HandPos
import qualified Data.IntMap.Strict as IM
import Control.Lens
@@ -44,12 +45,8 @@ pictureWeaponOnAimItem
-> Int -- ^ Position of item in inventory
-> SPic
pictureWeaponOnAimItem p' cr posInInv
| isSelected && _posture (_crStance cr) == Aiming && isTwisting
= shoulderD twistWep
| isSelected && _posture (_crStance cr) == Aiming && isOneHand
= shoulderD oneHandWep
| isSelected && _posture (_crStance cr) == Aiming && isTwoHandFlat
= shoulderD drawnWep
| isSelected && _posture (_crStance cr) == Aiming =
shoulderD $ translateSPf (aimingWeaponZeroPos cr theIt) 0 p'
| isSelected && isTwoHandFlat
= handD holsteredTwoFlat
| isSelected && isOneHand
@@ -61,9 +58,7 @@ pictureWeaponOnAimItem p' cr posInInv
shoulderD = translateSPz 18
handD = translateSPz 15
isSelected = _crInvSel cr == posInInv
drawnWep = translateSPf (1.2 * _crRad cr) 0 p
twistWep = translateSPf (-5) 0 p
oneHandWep = translateSPf 14 0 p
holsteredWep = translateSPf (_crRad cr) 0
(rotateSP (strideRot cr + 1.2) (translateSPf (-5) 0 twistWep))
holsteredTwoFlat = translateSPf (_crRad cr) 0 (rotateSP (twoFlatHRot cr) p)
@@ -76,13 +71,13 @@ pictureWeaponOnAimItem p' cr posInInv
p = fromMaybe p' $ do
x <- theIt ^? itDimension . dimPortage . handlePos
return $translateSPf (-x) 0 p'
isTwisting = theIt ^? itUseAimStance == Just TwoHandTwist
isOneHand = theIt ^? itUseAimStance == Just OneHand
isTwoHandFlat = theIt ^? itUseAimStance == Just TwoHandFlat
itUseAimStance = itUse . useAim . aimStance
f i = 0.1 * fromIntegral (sLen - i) / fromIntegral sLen
sLen = _strideLength $ _crStance cr
strideRot :: Creature -> Float
strideRot cr = case cr ^? crStance . carriage of
Just (Walking x LeftForward) -> f x
src/Dodge/Item/Weapon/AmmoParams.hs
+4 -2
View File
@@ -8,6 +8,7 @@ module Dodge.Item.Weapon.AmmoParams
) where
import Dodge.Data
import Dodge.Particle.Bullet.Spawn
import Dodge.Creature.HandPos
import Geometry
import LensHelp
@@ -33,14 +34,15 @@ defaultAimParams = AimParams
}
useAmmoParams :: Item -> Creature -> World -> World
useAmmoParams it = withVelWthHiteff
useAmmoParams it cr = withVelWthHiteff
(muzvel *.* _amBulVel b)
(_rifling $ _itParams it)
(_amBulWth b)
muzlength
(_amBulEff b)
cr
where
muzlength = 20
muzlength = aimingMuzzlePos cr it
muzvel = _muzVel $ _itParams it
b = _aoType $ _itConsumption it
src/Dodge/Item/Weapon/BulletGun/Cane.hs
+1 -1
View File
@@ -67,7 +67,7 @@ bangCane = defaultGun
, _dimCenter = V3 5 0 0
, _dimPortage = HeldItem
{_handlePos = 5
,_muzPos = 20
,_muzPos = 15
}
, _dimSPic = \it -> noPic $ baseCaneShape
<> makeSingleClipAt (V3 5 0 3) it
src/Dodge/LevelGen.hs
+2 -1
View File
@@ -3,6 +3,7 @@
module Dodge.LevelGen where
import Dodge.Data
import Dodge.Floor
import Dodge.Save
import Dodge.Layout
import Dodge.Initialisation
--import Dodge.RandomHelp
@@ -19,7 +20,7 @@ import qualified Data.IntMap.Strict as IM
generateWorldFromSeed :: Int -> IO World
generateWorldFromSeed i = do
roomList <- layoutLevelFromSeed 0 i
return $ _gWorld $ generateLevelFromRoomList roomList
return $ saveLevelStartSlot $ _gWorld $ generateLevelFromRoomList roomList
initialWorld{_randGen=mkStdGen i}
layoutLevelFromSeed :: Int -> Int -> IO (IM.IntMap Room)
src/Dodge/Magnet.hs
+4 -2
View File
@@ -16,8 +16,9 @@ curveLeftField mg pt = case pt of
curveAroundField :: Magnet -> Particle -> Particle
curveAroundField mg pt = case pt of
BulletPt{} | dist btpos mgpos < 500 -> pt & btVel' %~ rotateToCircle
BulletPt{} | thedist < 400 -> pt & btVel' %~ rotateToCircle
where
thedist = dist btpos mgpos
mgpos = _mgPos mg
btpos = head $ _btTrail' pt
rotateToCircle vel
@@ -25,5 +26,6 @@ curveAroundField mg pt = case pt of
|| (isRHS mgpos btpos (btpos +.+ vel) && isLHS mgpos btpos (mgpos +.+ vNormal vel) )
= rotateV rot vel
| otherwise = rotateV (negate rot) vel
rot = 0.5
rot | thedist < 100 = 0.5
| otherwise = 0.5 - ((thedist - 100) / 600)
_ -> pt
src/Dodge/Menu.hs
+27 -24
View File
@@ -5,22 +5,22 @@ module Dodge.Menu
) where
import LensHelp
import Dodge.Menu.OptionType
import Dodge.StartNewGame
import Dodge.Menu.PushPop
import Dodge.Data
import Dodge.PreloadData
import Dodge.Save
import Dodge.Config.Update
import SDL
--import SDL.Internal.Numbered
--import Preload.Update
import Dodge.SoundLogic
import Dodge.LevelGen
--import Dodge.LevelGen
import Text.Read
import SDL
import System.Clipboard
--import Control.Lens
import System.Random
pauseMenu :: ScreenLayer
pauseMenu = slTitleOptionsEff "PAUSED" pauseMenuOptions (return . unpause)
--import System.Random
slTitleOptionsEff :: String -> [MenuOption] -> (Universe -> IO (Maybe Universe)) -> ScreenLayer
slTitleOptionsEff title ops eff = OptionScreen
@@ -29,15 +29,34 @@ slTitleOptionsEff title ops eff = OptionScreen
, _scDefaultEff = eff
, _scOptionFlag = NormalOptions
}
pauseMenu :: ScreenLayer
pauseMenu = slTitleOptionsEff "PAUSED" pauseMenuOptions (return . unpause)
pauseMenuOptions :: [MenuOption]
pauseMenuOptions =
[ Toggle ScancodeN (return . startNewGame) (const "NEW LEVEL")
[ Toggle ScancodeN (return . Just . startNewGame) (const "NEW LEVEL")
, Toggle ScancodeR (return . Just . loadSaveSlot LevelStartSlot) (const "RESTART")
, Toggle ScancodeS (pushScreen $ seedStartMenu "START FROM SEED") (const "START FROM SEED")
, Toggle ScancodeO (pushScreen optionMenu ) (const "OPTIONS")
, Toggle ScancodeC (pushScreen displayControls) (const "CONTROLS")
, InvisibleToggle ScancodeEscape (return . const Nothing)
]
seedStartMenu :: String -> ScreenLayer
seedStartMenu str = slTitleOptionsEff str seedStartOptions popScreen
seedStartOptions :: [MenuOption]
seedStartOptions =
[ Toggle ScancodeP trySeedFromClipboard (const "PASTE NUMBER FROM CLIPBOARD")
-- , Toggle ScancodeI (return . Just . loadSaveSlot LevelStartSlot) (const "INSERT NUMBER")
]
trySeedFromClipboard :: Universe -> IO (Maybe Universe)
trySeedFromClipboard u = do
mcstr <- getClipboardString
case mcstr of
Nothing -> pushScreen (seedStartMenu "INPUT UNUSABLE") (u & menuLayers %~ tail)
Just str -> do
case readMaybe str of
Nothing -> pushScreen (seedStartMenu "INPUT UNUSABLE") (u & menuLayers %~ tail)
Just i -> return . Just $ startSeedGame i u
slTitleOptions :: String -> [MenuOption] -> ScreenLayer
slTitleOptions title ops = slTitleOptionsEff title ops (popScreen . writeConfig)
@@ -122,22 +141,6 @@ gameOverMenu = OptionScreen
, _scOptionFlag = GameOverOptions
}
--startNewGame' :: Universe -> IO (Maybe Universe)
--startNewGame' u = do
-- w <- generateWorldFromSeed i
-- return $ Just (u & uvWorld .~ w)
-- where
-- i = fst $ random (_randGen (_uvWorld u))
startNewGame :: Universe -> Maybe Universe
startNewGame u = Just $ u
& menuLayers .~ [WaitScreen (const "GENERATING...") 1]
& uvWorld . sideEffects .~ \_ -> do
w <- generateWorldFromSeed i
return (u & menuLayers .~ [] & uvWorld .~ w)
where
i = fst $ random (_randGen (_uvWorld u))
-- | hacky
scodeToChar :: Scancode -> Char
scodeToChar = toEnum . (+ 61) . fromIntegral . unwrapScancode
src/Dodge/Placement/Instance/Turret.hs
+8 -5
View File
@@ -8,17 +8,17 @@ import Dodge.Wall.Delete
import Dodge.WorldEvent.Explosion
import Dodge.Item.Weapon.BatteryGuns
import Dodge.Item.Weapon.BulletGun.Cane
import Dodge.SoundLogic.LoadSound
import Dodge.SoundLogic
--import Dodge.SoundLogic.LoadSound
--import Dodge.SoundLogic
import Dodge.Item.Draw
import Geometry
import ShapePicture
import Shape
import Dodge.Base
import Dodge.Base.Collide
import LensHelp
import Data.List
import Control.Lens
import qualified Data.IntMap.Strict as IM
putLasTurret :: Float -> Placement
@@ -52,10 +52,13 @@ updateTurret rotSpeed mc w
| elecDam < 10 = updateFiringStatus . doTurn
| otherwise = id
-- TODO make this use the same function as the lasgun
it = _tuWeapon (_mcType mc)
maybeFire
| _tuFireTime (_mcType mc) > 0
= ( particles %~ (makeLaserAt 5 (mcpos + 15 *.* unitVectorAtAngle mcdir) mcdir :) )
. soundContinue (MachineSound mcid) mcpos tone440sawtoothquietS (Just 1)
-- massive hack
= _rUse (_itUse it) it (defaultCreature {_crPos = mcpos,_crDir = mcdir})
-- = ( particles .:~ makeLaserAt 5 (mcpos + 15 *.* unitVectorAtAngle mcdir) mcdir )
-- . soundContinue (MachineSound mcid) mcpos tone440sawtoothquietS (Just 1)
| otherwise = id
mcid = _mcID mc
ypos = _crPos $ you w
src/Dodge/Save.hs
+7 -1
View File
@@ -2,6 +2,7 @@ module Dodge.Save
( saveWorldInEmptySlot
, loadSaveSlot
, doQuicksave
, saveLevelStartSlot
) where
import Dodge.Data
@@ -16,7 +17,7 @@ saveWorldInEmptySlot slot w = case M.lookup slot $ _savedWorlds w of
_ -> w
saveWorldInSlot :: SaveSlot -> Universe -> Universe
saveWorldInSlot slot w = w & savedWorlds %~ M.insert slot (clearKeys (_uvWorld w))
saveWorldInSlot slot u = u & savedWorlds %~ M.insert slot (clearKeys (_uvWorld u))
loadSaveSlot :: SaveSlot -> Universe -> Universe
loadSaveSlot slot u = maybe u
@@ -28,3 +29,8 @@ doQuicksave = saveWorldInSlot QuicksaveSlot
clearKeys :: World -> World
clearKeys = (keys .~ S.empty) . (mouseButtons .~ S.empty)
saveLevelStartSlot :: World -> World
--saveLevelStartSlot = id
saveLevelStartSlot = sideEffects %~ (fmap (saveWorldInSlot LevelStartSlot) . )
--saveLevelStartSlot = sideEffects %~ (fmap (undefined) . )
src/Dodge/StartNewGame.hs
+18
View File
@@ -0,0 +1,18 @@
module Dodge.StartNewGame where
import Dodge.Data
import Dodge.LevelGen
import Control.Lens
import System.Random
startNewGame :: Universe -> Universe
startNewGame u = startSeedGame i u
where
i = fst $ random (_randGen (_uvWorld u))
startSeedGame :: Int -> Universe -> Universe
startSeedGame i u = u
& menuLayers .~ [WaitScreen (const "GENERATING...") 1]
& uvWorld . sideEffects .~ \_ -> do
w <- generateWorldFromSeed i
return $ u & menuLayers .~ [] & uvWorld .~ w
& savedWorlds . at LevelStartSlot ?~ w