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

appDodge/Main.hs

@@ -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
+--    w <- generateWorldFromSeed 0
-    return $ Universe 
+    return $ startNewGame $ Universe 
-        {_uvWorld = w
+        {_uvWorld = initialWorld
         ,_config    = theConfig
         ,_preloadData = pdata
         ,_menuLayers = []

package.yaml

@@ -53,6 +53,7 @@ dependencies:
 - repa
 - monad-parallel
 - parallel
+- Clipboard
 
 library:
   source-dirs: src

src/Dodge/Creature/HandPos.hs

@@ -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
+-- the position of a weapon handle
-crHandPos _ = V3 0 0 20
+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

@@ -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,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
+    | isSelected && _posture (_crStance cr) == Aiming =
-                = shoulderD twistWep
+        shoulderD $ translateSPf (aimingWeaponZeroPos cr theIt) 0 p'
-    | isSelected && _posture (_crStance cr) == Aiming && isOneHand
-                = shoulderD oneHandWep
-    | isSelected && _posture (_crStance cr) == Aiming && isTwoHandFlat
-                = shoulderD drawnWep
     | 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

@@ -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

@@ -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

@@ -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

@@ -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

@@ -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
+--import System.Random
-
-pauseMenu :: ScreenLayer
-pauseMenu = slTitleOptionsEff "PAUSED" pauseMenuOptions (return . unpause)
 
 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,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.LoadSound
-import Dodge.SoundLogic
+--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 :) )
+            -- massive hack
-            . soundContinue (MachineSound mcid) mcpos tone440sawtoothquietS (Just 1)
+            = _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

@@ -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

@@ -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