Add files

src/Dodge/Barreloid.hs

@@ -37,7 +37,8 @@ updateExpBarrel ps cr w = case cr ^. crHP of
     damages = cr ^. crDamage
     hiss
         | null ps = id
-        | otherwise = soundContinue (BarrelHiss (_crID cr)) (_crPos cr) foamSprayLoopS (Just 1)
+        | otherwise = soundContinue 
+            (BarrelHiss (_crID cr)) (_crPos cr) foamSprayLoopS (Just 1)
 
 updateBarrel :: Creature -> World -> World
 updateBarrel cr = case cr ^. crHP of

src/Dodge/Bullet/Draw.hs

@@ -1,14 +0,0 @@
-module Dodge.Bullet.Draw (
-    drawBullet,
-) where
-
-import Dodge.Data.Bullet
-import Linear
-import Picture
-
-drawBullet :: Bullet -> Picture
-drawBullet pt =
-    setLayer BloomLayer
-        . setDepth 20
-        . color (V4 200 200 200 2)
-        $ thickLine 2 [_buOldPos pt, _buPos pt]

src/Dodge/Config.hs

@@ -0,0 +1,61 @@
+{- |
+IO actions that apply config side effects and save configuration settings to disk.
+-}
+module Dodge.Config (
+    saveConfig,
+    applyWorldConfig,
+    setVol,
+    loadDodgeConfig,
+) where
+
+import Data.Aeson
+import qualified Data.Aeson.Encode.Pretty as AEP
+import qualified Data.ByteString.Lazy as BS
+import Data.Preload
+import Dodge.Data.Config
+import Preload.Update
+import Sound
+import System.Directory
+
+{- |
+Write the current world configuration to disk as a json file.
+-}
+saveConfig :: Config -> (a -> IO a) -> a -> IO a
+saveConfig cfig f x = do
+    createDirectoryIfMissing True "generated"
+    BS.writeFile "generated/config.json" $
+        AEP.encodePretty' (AEP.Config (AEP.Spaces 2) compare AEP.Generic False) cfig
+    f x
+
+loadDodgeConfig :: IO Config
+loadDodgeConfig = do
+    fExists <- doesFileExist "generated/config.json"
+    if fExists
+        then do
+            mconfig <- decodeFileStrict "generated/config.json"
+            maybe
+                (failstr "invalid generate/config.json, loading defaults")
+                return
+                mconfig
+        else failstr "No generated/config.json found, loading defaults"
+  where
+    failstr s = putStrLn s >> return defaultConfig
+
+{- |
+Apply the volume settings from the world configuration to the running game.
+-}
+setVol :: Config -> IO ()
+setVol cfig = do
+    setSoundVolume (_volume_master cfig * _volume_sound cfig)
+    setMusicVolume (_volume_master cfig * _volume_music cfig)
+
+{- |
+Apply /all/ of the values in the world configuration to the running game.
+-}
+applyWorldConfig ::
+    Config ->
+    PreloadData ->
+    IO PreloadData
+applyWorldConfig cfig pdata = do
+    setVol cfig
+    renderData (renderDataResizeUpdate cfig) pdata

src/Dodge/Corpse/Make.hs

@@ -1,42 +1,25 @@
 module Dodge.Corpse.Make (makeCorpse) where
 
-import Dodge.Creature.Radius
-import Dodge.Creature.Shape
 import Control.Lens
 import Dodge.Creature.Picture
+import Dodge.Creature.Radius
+import Dodge.Creature.Shape
 --import Dodge.Data.Corpse
 import Dodge.Data.Creature
 import Geometry
 import Shape
 import ShapePicture
 
---makeCorpse :: Creature -> Corpse
 makeCorpse :: Creature -> SPic
 makeCorpse cr =
---    defaultCorpse
---        & cpPos .~ _crPos cr
---        & cpDir .~ _crDir cr
---        & cpSPic
---            .~ 
-        noPic
-                ( scaleSH (V3 crsize crsize crsize) $
-                    mconcat
-                        [ colorSH (_skinHead cskin) $ deadScalp cr
-                        , colorSH (_skinUpper cskin) $ deadUpperBody cr
-                        , rotmdir $ colorSH (_skinLower cskin) $ deadFeet cr
-                        ]
-                )
+    noPic
+        . scaleSH (V3 crsize crsize crsize)
+        $ mconcat
+            [ colorSH (_skinHead cskin) $ deadScalp cr
+            , colorSH (_skinUpper cskin) $ deadUpperBody cr
+            , rotmdir $ colorSH (_skinLower cskin) $ deadFeet cr
+            ]
   where
     cskin = crShape $ _crType cr -- this should be fixed
     crsize = 0.1 * crRad (cr ^. crType)
     rotmdir = rotateSH (_crMvDir cr - _crDir cr)
-
---defaultCorpse :: Corpse
---defaultCorpse =
---    Corpse
---        { _cpID = 0
---        , _cpPos = 0
---        , _cpDir = 0
---        , _cpSPic = mempty
---        , _cpRes = NoResurrection
---        }

src/Dodge/Creature/State.hs

@@ -238,11 +238,12 @@ shineTorch :: Creature -> LocationDT OItem -> World -> World
 shineTorch cr loc = fromMaybe id $ do
     mag <- find (isammolink . (^. dtValue . _2)) (itmtree ^. dtLeft)
     i <- mag ^. dtValue . _1 . itConsumables
-    guard $ crIsAiming cr
+--    guard $ crIsAiming cr
     guard $ i >= x
     itid <- mag ^? dtValue . _1 . itID . unNInt
     return $
-        (cWorld . lWorld . lights .:~ LSParam pos 250 0.7)
+        (cWorld . lWorld . lights .:~ LSParam pos 150 0.3)
+           . (cWorld . lWorld . lights .:~ LSParam (pos + V3 0 0 15) 50 0.3)
             . (cWorld . lWorld . items . ix itid . itConsumables . _Just -~ x)
   where
     itmtree = loc ^. locDT
@@ -250,7 +251,7 @@ shineTorch cr loc = fromMaybe id $ do
     x = 10
     isammolink AmmoMagSF{} = True
     isammolink _ = False
-    pos = _crPos cr `v2z` 0 + rotate3 cdir (p + Q.rotate q (V3 8 0 1.5))
+    pos = _crPos cr `v2z` 0 + rotate3 cdir (p + Q.rotate q (V3 5 0 1.5))
     cdir = _crDir cr
 
 -- this probably needs to be set to null when dropped as well?

src/Dodge/Data/LWorld.hs

@@ -134,8 +134,7 @@ data LWorld = LWorld
     , _delayedEvents :: [(Int, WdWd)]
     , _pressPlates :: IM.IntMap PressPlate
     , _buttons :: IM.IntMap Button
-    , _foregroundShapes :: IM.IntMap ForegroundShape
---    , _corpses :: IM.IntMap Corpse
+    , _foreShapes :: IM.IntMap ForegroundShape
     , _lightSources :: IM.IntMap LightSource
     , _lights :: [LSParam]
     , _seenLocations :: IM.IntMap (WdP2, String)

src/Dodge/Default/World.hs

@@ -144,7 +144,7 @@ defaultLWorld =
                 , (1, (WdP2Const (V2 0 0), "START POSITION"))
                 ]
         , _selLocation = 0
-        , _foregroundShapes = mempty
+        , _foreShapes = mempty
         , _distortions = []
         , _lClock = 0
         , _lTestString = []

src/Dodge/Draw.hs

@@ -5,7 +5,6 @@ module Dodge.Draw (
     module Dodge.Beam.Draw,
     module Dodge.Block.Draw,
     module Dodge.Item.Draw,
-    module Dodge.Bullet.Draw,
     module Dodge.Button.Draw,
     module Dodge.EnergyBall.Draw,
     module Dodge.Flame.Draw,
@@ -25,7 +24,6 @@ module Dodge.Draw (
 import Dodge.Beam.Draw
 import Dodge.Item.Draw
 import Dodge.Block.Draw
-import Dodge.Bullet.Draw
 import Dodge.Button.Draw
 import Dodge.EnergyBall.Draw
 import Dodge.Flame.Draw

src/Dodge/Item/Draw/SPic.hs

@@ -274,7 +274,7 @@ heldItemSPic ht it = case ht of
     KEYCARD _ -> noShape (setDepth 0 $ translate (-5) (-5) $ rotate (pi / 2.5) keyPic)
 
 torchShape :: Shape
-torchShape = colorSH blue $ upperPrismPolySE 3 $ rectWH 3 3
+torchShape = colorSH blue $ upperBox Small Essential 3 $ rectWH 3 3
 --    side = upperPrismPolySE 3 $ rectXH 10 0.5
 
 --    colorSH blue $

src/Dodge/Item/Draw/SPicTree.hs

@@ -0,0 +1,21 @@
+module Dodge.Item.Draw.SPicTree (itemTreeSPic) where
+
+import Dodge.Item.Draw.SPic
+import Dodge.Data.ComposedItem
+import Dodge.Data.DoubleTree
+import Dodge.Data.Item
+import Dodge.Item.Orientation
+import LensHelp
+import qualified Linear.Quaternion as Q
+--import qualified Linear.Quaternion as Q
+import ShapePicture
+
+itemTreeSPic :: DTree CItem -> SPic
+itemTreeSPic (DT (itm, _) l r) = itemSPic itm <> foldMap (itemRotTreeSPic itm) (l <> r)
+
+itemRotTreeSPic :: Item -> DTree CItem -> SPic
+itemRotTreeSPic par t = translateSP p . overPosSP (Q.rotate q) $ itemTreeSPic t
+  where
+    (p, q) = orientAttachment par itm
+    itm = t ^. dtValue
+

src/Dodge/Item/Orientation.hs

@@ -3,6 +3,7 @@ module Dodge.Item.Orientation (
     propagateOrientation,
 ) where
 
+import Dodge.Data.AmmoType
 import Shape.Data
 import Control.Lens
 import Linear
@@ -17,7 +18,9 @@ import qualified Quaternion as Q
 orientChild :: Item -> Point3Q
 orientChild itm = case _itType itm of
     --HELD LED -> (V3 0 5 0, Q.qID)
-    HELD LED -> (V3 (-x) (y-1) 0, Q.qID)
+    HELD LED -> (V3 (-x) 0 0, Q.qID)
+    AMMOMAG BATTERY -> (V3 0 0 1, Q.qID)
+    AMMOMAG {} -> (V3 0 (2-itemShapeMax _y itm) 0, Q.qID)
     --HELD LASER -> (V3 15 (-5) 0, Q.qID)
     LASER -> (V3 15 (-5) 0, Q.qID)
     ATTACH UNDERBARRELSLOT -> (V3 10 (-8) 0, r)
@@ -25,29 +28,42 @@ orientChild itm = case _itType itm of
   where
     --r = Q.axisAngle (V3 0 0 1) (-pi/4)
     r = Q.qID
-    y = itemShapeY itm
-    x = itemShapeX itm
+--    y = itemShapeMin _y itm
+    x = itemShapeMaxX itm
 
 orientByParentChSF :: Item -> ItemSF -> Point3Q
 orientByParentChSF itm lt = case (_itType itm, lt) of
     (HELD FLAMETHROWER, AmmoMagSF{}) -> (V3 4 (-6) 0, Q.qID)
-    (HELD _, AmmoMagSF{}) -> (V3 7 (-4) 0, Q.qID)
+    (HELD _, AmmoMagSF{_amsfType = ElectricalAmmo}) -> (V3 0 0 z, Q.qID)
+    (HELD _, AmmoMagSF{}) -> (V3 7 (itemShapeMin _y itm) 0, Q.qID)
     (HELD _, WeaponScopeSF) -> (V3 5 0 5, Q.qID)
-    (HELD _, TorchSF) -> (V3 x y 5, Q.qID)
+    (HELD _, TorchSF) -> (V3 x y 0, Q.qID)
     _ -> (0, Q.qID)
   where
-    x = itemShapeX itm
-    y = itemShapeY itm
+    x = itemShapeMaxX itm
+    y = itemShapeMaxY itm
+    z = itemShapeMaxZ itm
 
-itemShapeX :: Item -> Float
-itemShapeX = f . (^. _1) . itemSPic
-  where
-    f = maximum . fmap (\sf -> maximum $ fmap (^. _1) (sf ^. sfVs))
+itemShapeMaxX :: Item -> Float
+itemShapeMaxX = itemShapeMax _1
 
-itemShapeY :: Item -> Float
-itemShapeY = f . (^. _1) . itemSPic
+itemShapeMaxY :: Item -> Float
+itemShapeMaxY = itemShapeMax _2
+
+itemShapeMaxZ :: Item -> Float
+itemShapeMaxZ = itemShapeMax _3
+
+itemShapeMax 
+    :: ((Float -> Const Float Float) -> Point3 -> Const Float Point3) -> Item -> Float
+itemShapeMax g = f . (^. _1) . itemSPic
   where
-    f = maximum . fmap (\sf -> maximum $ fmap (^. _2) (sf ^. sfVs))
+    f = maximum . fmap (\sf -> maximum $ fmap (^. g) (sf ^. sfVs))
+
+itemShapeMin 
+    :: ((Float -> Const Float Float) -> Point3 -> Const Float Point3) -> Item -> Float
+itemShapeMin g = f . (^. _1) . itemSPic
+  where
+    f = minimum . fmap (\sf -> minimum $ fmap (^. g) (sf ^. sfVs))
 
 orientAttachment :: Item -> CItem -> Point3Q
 orientAttachment par (ch,chsf) = case (_itType par, chsf) of

src/Dodge/Lampoid.hs

@@ -13,15 +13,17 @@ updateLampoid :: Creature -> World -> World
 updateLampoid cr w = case cr ^?! crType . lampLSID of
     Nothing ->
         let i = IM.newKey (w ^. cWorld . lWorld . lightSources)
-         in w & cWorld . lWorld . lightSources %~ IM.insert i (lsColPosID lcol (addZ h cpos) i)
+         in w & cWorld . lWorld . lightSources . at i ?~ lsColPosID lcol (addZ h cpos) i
                 & cWorld . lWorld . creatures . ix (_crID cr) . crType . lampLSID ?~ i
     Just i
         | cr ^?! crHP . _HP < 0 ->
             w
-                -- & cWorld . lWorld . tempLightSources .:~ tlsTimeRadFunPos 20 150 (TLSFade 1 10) (addZ 20 cpos)
-                & cWorld . lWorld . worldEvents .:~ MakeTempLight 
-                    (LSParam (addZ 20 cpos) 150 1) 20
-                & soundOriginsIDsAt [MaterialSound Glass n | n <- [0, 1, 2]] (destroyMatS Glass) cpos
+                & cWorld . lWorld . worldEvents
+                    .:~ MakeTempLight
+                        (LSParam (addZ 20 cpos) 150 1)
+                        20
+                & soundOriginsIDsAt [MaterialSound Glass n | n <- [0, 1, 2]] 
+                    (destroyMatS Glass) cpos
                 & cWorld . lWorld . lightSources . at i .~ Nothing
                 & cWorld . lWorld . creatures . at cid .~ Nothing
         | otherwise ->

src/Dodge/Placement/PlaceSpot.hs

@@ -120,7 +120,7 @@ placeSpotID rid ps pt w = case pt of
     PutCrit cr -> plNewUpID (gwWorld . cWorld . lWorld . creatures) crID (mvCr p rot cr) w
     PutForeground fs ->
         plNewUpID
-            (gwWorld . cWorld . lWorld . foregroundShapes)
+            (gwWorld . cWorld . lWorld . foreShapes)
             fsID
             (mvFS p rot fs)
             w

src/Dodge/Render/ShapePicture.hs

@@ -1,8 +1,5 @@
-module Dodge.Render.ShapePicture (
-    worldSPic,
-) where
+module Dodge.Render.ShapePicture (worldSPic) where
 
-import Dodge.Item.Draw.SPic
 import Control.Lens
 import Data.Foldable
 import Data.Strict.Tuple
@@ -10,14 +7,15 @@ import Dodge.Creature.Picture
 import Dodge.Data.Universe
 import Dodge.Debug.Picture
 import Dodge.Draw
+import Dodge.Item.Draw.SPic
 import Dodge.RadarBlip
 import Dodge.Render.Picture
 import Geometry
 import qualified IntMapHelp as IM
+import Linear.V3
 import Picture
 import Shape
 import ShapePicture
-import Linear.V3
 
 worldSPic :: Config -> Universe -> SPic
 worldSPic cfig u =
@@ -27,36 +25,44 @@ worldSPic cfig u =
         <> foldup drawProjectile (filtOn (^. pjPos . _xy) _projectiles)
         <> foldup drawPulseBall (filtOn _pbPos _pulseBalls)
         <> foldup (shiftDraw _blPos _blDir (drawBlock . _blDraw)) (filtOn _blPos _blocks)
-        <> foldup (shiftDraw _fsPos _fsDir (const _fsSPic)) (filtOn _fsPos _foregroundShapes)
-        <> foldup (drawCreature (u ^. uvWorld . cWorld . lWorld . items)) 
-                (filtOn _crPos _creatures)
-        <> foldup (Prelude.uncurry floorItemSPic) (IM.intersectionWith (,) (u^.uvWorld.cWorld.lWorld.items) (filtOn _flItPos _floorItems))
+        <> foldup (shiftDraw _fsPos _fsDir (const _fsSPic)) (filtOn _fsPos _foreShapes)
+        <> foldup (drawCreature (lw ^. items)) (filtOn _crPos _creatures)
+        <> foldup
+            (Prelude.uncurry floorItemSPic)
+            ( IM.intersectionWith
+                (,)
+                (lw ^. items)
+                (filtOn _flItPos _floorItems)
+            )
         <> foldup btSPic (filtOn _btPos _buttons)
-        <> foldup (mcSPic (u ^. uvWorld . cWorld)) (filtOn _mcPos _machines)
-        <> foldMap' drawChasm (u ^. uvWorld . cWorld . chasms)
+        <> foldup (mcSPic (w ^. cWorld)) (filtOn _mcPos _machines)
+        <> foldMap' drawChasm (w ^. cWorld . chasms)
   where
-    w = _uvWorld u
+    w = u ^. uvWorld
+    lw = w ^. cWorld . lWorld
     foldup = foldMap'
-    filtOn f g = IM.filter (pointIsClose . f) (g (_lWorld (_cWorld w)))
-    filtOn' f g = filter (pointIsClose . f) (g (_lWorld (_cWorld w)))
+    filtOn f g = IM.filter (pointIsClose . f) (g lw)
+    filtOn' f g = filter (pointIsClose . f) (g lw)
     pointIsClose = cullPoint cfig w
 
 drawChasm :: [Point2] -> SPic
 drawChasm = foldMap (Prelude.uncurry drawCliff) . loopPairs
 
 drawCliff :: Point2 -> Point2 -> SPic
-drawCliff x y = noPic 
-    . translateSHz (-500.01)
-    . colorSH (dark orange)
-    $ upperPrismPoly Large Important 500 [x,0.5 *(x+y) + normalizeV (vNormal (y - x)),y]
+drawCliff x y =
+    noPic
+        . translateSHz (-500.01)
+        . colorSH (dark orange)
+        $ upperPrismPoly Large Important 500 
+            [x, 0.5 * (x + y) + normalizeV (vNormal (y - x)), y]
 
 drawPulseBall :: PulseBall -> SPic
 drawPulseBall pb =
-    translateSPz 20 
-    . uncurryV translateSPxy (pb ^. pbPos)
-    . noShape 
-    . setLayer BloomLayer
-    $ circleSolidCol green white 10
+    translateSPz 20
+        . uncurryV translateSPxy (pb ^. pbPos)
+        . noShape
+        . setLayer BloomLayer
+        $ circleSolidCol green white 10
 
 drawCreature :: IM.IntMap Item -> Creature -> SPic
 drawCreature m cr = translateSPz (_crZ cr) . uncurryV translateSPxy (_crPos cr) . rotateSP (_crDir cr) $
@@ -130,3 +136,10 @@ mcSPic :: CWorld -> Machine -> SPic
 mcSPic cw mc =
     uncurryV translateSPxy (_mcPos mc) $
         rotateSP (_mcDir mc) (drawMachine cw mc)
+
+drawBullet :: Bullet -> Picture
+drawBullet pt =
+    setLayer BloomLayer
+        . setDepth 20
+        . color (V4 200 200 200 2)
+        $ thickLine 2 [_buOldPos pt, _buPos pt]