Cleanup

src/Dodge/Default.hs

@@ -10,154 +10,23 @@ module Dodge.Default
     , module Dodge.Default.LightSource
     , module Dodge.Default.Weapon
     , module Dodge.Default.Wall
+    , module Dodge.Default.Creature
     ) where
 import Dodge.Default.Wall
+import Dodge.Default.Creature
 import Dodge.Default.Weapon
 import Dodge.Default.LightSource
 import Dodge.Default.Item
 import Dodge.Data
 import Dodge.SoundLogic
-import Dodge.Creature.Damage
-import Dodge.Creature.Picture
 import Geometry
 import Picture
 import ShapePicture
 import Shape
 
 import Control.Lens
-import qualified Data.IntMap.Strict as IM
 import qualified Data.Text as T
 import qualified Data.Map.Strict as M
---import qualified Data.Vector as V
---import Data.Monoid
-defaultCreature :: Creature
-defaultCreature = Creature
-    { _crPos    = V2 0 0
-    , _crOldPos = V2 0 0
-    , _crVel    = V2 0 0
-    , _crDir    = 0
-    , _crOldDir = 0
-    , _crMvDir  = 0
-    , _crTwist  = 0
-    , _crID     = 1
---    , _crPict   = basicCrPict
-    , _crType = defaultCreatureSkin
-    , _crUpdate = const id
-    , _crRad    = 10
-    , _crMass   = 10
-    , _crHP     = 100
-    , _crMaxHP  = 150
-    , _crInv    = IM.empty
-    , _crInvSel = InvSel 0 NoInvSelAction
-    , _crInvCapacity = 25
-    , _crInvLock = False
-    , _crInvEquipped = mempty
-    , _crLeftInvSel = Nothing
-    , _crState  = defaultState
-    , _crCorpse = basicCrCorpse
-    , _crApplyDamage = defaultApplyDamage
-    , _crPastDamage = 0
-    , _crEquipment = M.empty
-    , _crStance = Stance 
-        {_carriage=Walking 0 WasLeftForward
-        ,_posture=AtEase
-        ,_strideLength = yourDefaultStrideLength
-        }
-    , _crVocalization = Mute
-    , _crActionPlan = ActionPlan [] [] (StrategyActions WatchAndWait [StartSentinelPost]) [LiveLongAndProsper]
-    , _crPerception = defaultPerceptionState
-    , _crMemory     = defaultCreatureMemory
-    , _crMeleeCooldown = 0
-    , _crFaction = NoFaction
-    , _crIntention = defaultIntention
-    , _crGroup   = LoneWolf
-    , _crMvType  = defaultAimMvType
-    , _crHammerPosition = HammerUp
-    , _crName = "DEFAULTCRNAME"
-    , _crStatistics = CreatureStatistics 10 10 10
-    , _crCamouflage = FullyVisible
-    }
-defaultCreatureSkin :: CreatureType
-defaultCreatureSkin = Humanoid (greyN 0.9) (light4 green) (greyN 0.3)
-
-defaultInanimate :: Creature
-defaultInanimate = defaultCreature & crActionPlan .~ Inanimate
-
-defaultCreatureMemory :: Memory
-defaultCreatureMemory = Memory 
-    { _soundsToInvestigate = [] 
-    , _nodesSearched = []
-    }
-
-defaultInvSize :: Int
-defaultInvSize = 20
-
-defaultPerceptionState :: Perception
-defaultPerceptionState = Perception
-    { _cpVigilance      = Lethargic
-    , _cpAttention      = AttentiveTo IM.empty
-    , _cpAwareness      = IM.empty
-    , _cpVision         = defaultVision
-    , _cpAudition       = defaultAudition
-    }
-defaultVision :: Vision
-defaultVision = Eyes
-    { _viFOV = f
-    , _viDist = g
-    }
-  where
-    f x | abs x < 0.5 * pi = 1
-        | otherwise        = 0
-    g x | x > 500 = 0
-        | otherwise = 1
-defaultAudition :: Audition
-defaultAudition = Ears
-    { _auDist = id
-    }
-defaultIntention :: Intention
-defaultIntention = Intention
-    { _targetCr     = Nothing
-    , _mvToPoint    = Nothing
-    , _viewPoint    = Nothing
-    }
-defaultChaseMvType :: CrMvType
-defaultChaseMvType = CrMvType
-    { _mvSpeed = 2
-    , _mvTurnRad = f
-    , _mvTurnJit = 0.2
-    , _mvAimSpeed   = g
-    }
-  where
-    g x | x > pi/8  = 0.2
-        | otherwise = 0.01
-    f x | x > pi / 4 = 0.2
-        | otherwise  = 0.05
-defaultAimMvType :: CrMvType
-defaultAimMvType = CrMvType
-    { _mvSpeed      = 3
-    , _mvTurnRad    = const 0.2
-    , _mvTurnJit    = 0.05
-    , _mvAimSpeed   = f
-    }
-  where
-    f x | x > pi/8  = 0.2
-        | otherwise = 0.01
-defaultAimingCrit :: Creature
-defaultAimingCrit = defaultCreature { _crMvType = defaultAimMvType }
-
-yourDefaultSpeed :: Float
-yourDefaultSpeed = 3
-
-yourDefaultStrideLength :: Int
-yourDefaultStrideLength = 40
-
-defaultState :: CreatureState
-defaultState = CrSt 
-    { _csDamage = []
---    , _crPastDamage = V.fromList $ replicate 20 []
-    , _csSpState = GenCr
-    , _csDropsOnDeath = DropAll
-    }
 
 defaultEquipment :: Item
 defaultEquipment = defaultItem

src/Dodge/Default/Creature.hs

@@ -0,0 +1,139 @@
+module Dodge.Default.Creature where
+import Dodge.Data
+import Dodge.Creature.Picture
+import Dodge.Creature.Damage
+import Geometry.Data
+import Picture
+
+import qualified Data.IntMap.Strict as IM
+import qualified Data.Map.Strict as M
+
+import Control.Lens
+defaultCreature :: Creature
+defaultCreature = Creature
+    { _crPos    = V2 0 0
+    , _crOldPos = V2 0 0
+    , _crVel    = V2 0 0
+    , _crDir    = 0
+    , _crOldDir = 0
+    , _crMvDir  = 0
+    , _crTwist  = 0
+    , _crID     = 1
+--    , _crPict   = basicCrPict
+    , _crType = defaultCreatureSkin
+    , _crUpdate = const id
+    , _crRad    = 10
+    , _crMass   = 10
+    , _crHP     = 100
+    , _crMaxHP  = 150
+    , _crInv    = IM.empty
+    , _crInvSel = InvSel 0 NoInvSelAction
+    , _crInvCapacity = 25
+    , _crInvLock = False
+    , _crInvEquipped = mempty
+    , _crLeftInvSel = Nothing
+    , _crState  = defaultState
+    , _crCorpse = basicCrCorpse
+    , _crApplyDamage = defaultApplyDamage
+    , _crPastDamage = 0
+    , _crEquipment = M.empty
+    , _crStance = Stance 
+        {_carriage=Walking 0 WasLeftForward
+        ,_posture=AtEase
+        ,_strideLength = yourDefaultStrideLength
+        }
+    , _crVocalization = Mute
+    , _crActionPlan = ActionPlan [] [] (StrategyActions WatchAndWait [StartSentinelPost]) [LiveLongAndProsper]
+    , _crPerception = defaultPerceptionState
+    , _crMemory     = defaultCreatureMemory
+    , _crMeleeCooldown = 0
+    , _crFaction = NoFaction
+    , _crIntention = defaultIntention
+    , _crGroup   = LoneWolf
+    , _crMvType  = defaultAimMvType
+    , _crHammerPosition = HammerUp
+    , _crName = "DEFAULTCRNAME"
+    , _crStatistics = CreatureStatistics 10 10 10
+    , _crCamouflage = FullyVisible
+    }
+defaultCreatureSkin :: CreatureType
+defaultCreatureSkin = Humanoid (greyN 0.9) (light4 green) (greyN 0.3)
+
+defaultInanimate :: Creature
+defaultInanimate = defaultCreature & crActionPlan .~ Inanimate
+
+defaultCreatureMemory :: Memory
+defaultCreatureMemory = Memory 
+    { _soundsToInvestigate = [] 
+    , _nodesSearched = []
+    }
+
+defaultInvSize :: Int
+defaultInvSize = 20
+
+defaultPerceptionState :: Perception
+defaultPerceptionState = Perception
+    { _cpVigilance      = Lethargic
+    , _cpAttention      = AttentiveTo IM.empty
+    , _cpAwareness      = IM.empty
+    , _cpVision         = defaultVision
+    , _cpAudition       = defaultAudition
+    }
+defaultVision :: Vision
+defaultVision = Eyes
+    { _viFOV = f
+    , _viDist = g
+    }
+  where
+    f x | abs x < 0.5 * pi = 1
+        | otherwise        = 0
+    g x | x > 500 = 0
+        | otherwise = 1
+defaultAudition :: Audition
+defaultAudition = Ears
+    { _auDist = id
+    }
+defaultIntention :: Intention
+defaultIntention = Intention
+    { _targetCr     = Nothing
+    , _mvToPoint    = Nothing
+    , _viewPoint    = Nothing
+    }
+defaultChaseMvType :: CrMvType
+defaultChaseMvType = CrMvType
+    { _mvSpeed = 2
+    , _mvTurnRad = f
+    , _mvTurnJit = 0.2
+    , _mvAimSpeed   = g
+    }
+  where
+    g x | x > pi/8  = 0.2
+        | otherwise = 0.01
+    f x | x > pi / 4 = 0.2
+        | otherwise  = 0.05
+defaultAimMvType :: CrMvType
+defaultAimMvType = CrMvType
+    { _mvSpeed      = 3
+    , _mvTurnRad    = const 0.2
+    , _mvTurnJit    = 0.05
+    , _mvAimSpeed   = f
+    }
+  where
+    f x | x > pi/8  = 0.2
+        | otherwise = 0.01
+defaultAimingCrit :: Creature
+defaultAimingCrit = defaultCreature { _crMvType = defaultAimMvType }
+
+yourDefaultSpeed :: Float
+yourDefaultSpeed = 3
+
+yourDefaultStrideLength :: Int
+yourDefaultStrideLength = 40
+
+defaultState :: CreatureState
+defaultState = CrSt 
+    { _csDamage = []
+--    , _crPastDamage = V.fromList $ replicate 20 []
+    , _csSpState = GenCr
+    , _csDropsOnDeath = DropAll
+    }

src/Dodge/Floor.hs

@@ -62,7 +62,7 @@ initialAnoTree = OnwardList
     , IntAnno $ PassthroughLockKeyLists
         [(sensorRoomRunPast ELECTRICAL, takeOne [CRAFT STATICMODULE,HELD SPARKGUN] )] itemRooms
     , IntAnno $ PassthroughLockKeyLists keyCardRunPastRand itemRooms
-    , IntAnno $ AnTree . warningRooms
+    , IntAnno $ AnTree . warningRooms "INVISIBLE CREATURE AHEAD"
     , AnTree $ rToOnward "chaseCrit+armourChaseCrit rectRoom"
         $ return . cleatOnward $ roomRectAutoLinks 400 400 & rmPmnts .++~ 
             [ spNoID anyUnusedSpot (PutCrit invisibleChaseCrit)

src/Dodge/Machine/Update.hs

@@ -111,14 +111,15 @@ mcTriggerVal :: Machine -> Maybe Bool
 mcTriggerVal mc = case mc ^. mcSensor of
     NoSensor -> Nothing
     s@ProximitySensor{} -> s ^? sensToggle
-    s@SensorToggleAmount{} -> Just $ (_sensAmount s) > 900
+    s@SensorToggleAmount{} -> Just $ _sensAmount s > 900
     
 mcPlaySound :: Machine -> World -> World
 mcPlaySound mc w = case _mcCloseSound mc of
-    Just sid | d < 200 -> soundContinueVol (1-0.01*max 0 (d-100)) (MachineSound mid) (_mcPos mc) sid (Just 2) w
+    Just sid | d < 100 
-    _ -> w
+        -> soundContinueVol (1-0.01*d) (MachineSound mid) (_mcPos mc) sid (Just 2) w
+    _   -> w
   where
-    d = dist (_crPos $ you w) (_mcPos mc)
+    d = max 0 (dist (_crPos $ you w) (_mcPos mc) - 100)
     mid = _mcID mc
 
 mcApplyDamage :: [Damage] -> Machine -> World -> World
@@ -130,7 +131,7 @@ mcApplyDamage ds mc = case _mcSensor mc of
 mcSensorUpdate :: Machine -> World -> World
 mcSensorUpdate mc w = case _mcSensor mc of
     NoSensor -> w
-    SensorToggleAmount{} -> foldr (flip sensorUpdate mc) w (map _dmType $ _mcDamage mc)
+    SensorToggleAmount{} -> foldr (flip sensorUpdate mc . _dmType) w (_mcDamage mc)
     ProximitySensor{} -> mcProximitySensorUpdate mc w
 
 mcProximitySensorUpdate :: Machine -> World -> World

src/Dodge/Placement/Instance/Analyser.hs

@@ -44,7 +44,7 @@ analyser
     -> PlacementSpot
     -> Placement
 analyser proxreq pslight psmc = extTrigLitPos pslight $ \tp ->
-    Just $ plSpot .~ psmc $ putTerminal''
+    Just $ plSpot .~ psmc $ putTerminal
         (themachine & mcMounts . at ObTrigger .~ _plMID tp)
         tparams -- (linksensortotrigger tp)
   where

src/Dodge/Placement/Instance/Terminal.hs

@@ -1,8 +1,7 @@
 --{-# LANGUAGE TupleSections #-}
 module Dodge.Placement.Instance.Terminal 
-    ( putTerminal
+    ( putMessageTerminal
-    , putTerminal'
+    , putTerminal
-    , putTerminal''
     , simpleTermMessage
     , terminalColor
     , terminalSPic
@@ -23,19 +22,15 @@ import Shape
 
 import Data.Maybe
 
-putTerminal''
+putTerminal :: Machine -> Terminal -> Placement
-    :: Machine
+putTerminal mc tm 
-    -> Terminal
---    -> (Int -> Machine -> World -> World)  -- | machine update, takes button id as input
-    -> Placement
-putTerminal'' mc tm --mcf 
     = ps0PushPS (PutTerminal tm) 
     $ \tmpl -> Just $ ps0PushPS (PutButton termButton)
-    $ \btpl -> Just $ pt0 (PutMachine (reverse $ square 10)
+    $ \btpl -> Just $ pt0 
-        (mc -- & mcUpdate %~ (\fmu mc' -> mcf (fromJust $ _plMID btpl) mc' . fmu mc') . machineAddSound fridgeHumS
+        (PutMachine (reverse $ square 10)
-            & mcMounts . at ObButton ?~ fromJust (_plMID btpl)
+            (mc & mcMounts . at ObButton ?~ fromJust (_plMID btpl)
-            & mcCloseSound ?~ fridgeHumS
+                & mcCloseSound ?~ fridgeHumS)       
-        )       )
+        )
     $ \mcpl -> Just $ sps0 $ PutWorldUpdate $ const (setids tmpl btpl mcpl) 
   where
     setids tmpl btpl mcpl w = w
@@ -48,25 +43,11 @@ putTerminal'' mc tm --mcf
         btid = fromJust (_plMID btpl)
         mcid = fromJust (_plMID mcpl)
 
-putTerminal' 
+putMessageTerminal :: Color -> Terminal -> Placement
-    :: Color
+putMessageTerminal col = putTerminal $ defaultMachine
-    -> Terminal
+    & mcColor .~ col
---    -> (Int -> Machine -> World -> World)  -- | machine update, takes button id as input
+    & mcDraw .~ terminalSPic
-    -> Placement
+    & mcHP .~ 100
-putTerminal' col = putTerminal'' (defaultMachine 
-        & mcColor .~ col)
-    { _mcDraw = noPic . terminalShape
-    , _mcHP = 100
-    , _mcSensor = defaultProximitySensor
-    }
-
-putTerminal :: Color -> Terminal -> Placement
-putTerminal col f = putTerminal'' (mc & mcColor .~ col) f -- (\_ -> basicMachineUpdate $ const id)
-  where
-    mc = defaultMachine
-        { _mcDraw = terminalSPic
-        , _mcHP = 100
-        }
 
 termButton :: Button
 termButton = Button
@@ -86,11 +67,9 @@ terminalColor :: Color
 terminalColor = dark magenta
 
 terminalSPic :: Machine -> SPic
---terminalShape _ = upperPrismPoly 15 $ square 10
 terminalSPic = noPic . terminalShape
 
 terminalShape :: Machine -> Shape
---terminalShape _ = upperPrismPoly 15 $ square 10
 terminalShape mc = colorSH col (prismPoly
     [V3 10 10 20, V3 (-10) 10 20, V3 (-10) (-10) 10, V3 10 (-10) 10]
     [V3 10 10  0, V3 (-10) 10  0, V3 (-10) (-10)  0, V3 10 (-10)  0]

src/Dodge/Room/LasTurret.hs

@@ -40,10 +40,7 @@ lightSensInsideDoor outplid rm = rm
         , psPt atFstLnkOut (PutForeground $ floorWire (V2 0 (-100)) (V2 20 (-100)))
         , psPt atFstLnkOut (PutForeground $ verticalWire (V2 20 0) 0 80)
         ]
-    & rmOutPmnt .~ [OutPlacement (lasSensLightAboveDoor 10 (atFstLnkOutShiftInward 100)) outplid]
+    & rmOutPmnt .~ [OutPlacement (sensAboveDoor LASERING 10 (atFstLnkOutShiftInward 100)) outplid]
-
-lasSensLightAboveDoor :: Float -> PlacementSpot -> Placement
-lasSensLightAboveDoor = sensAboveDoor LASERING
 
 lightSensByDoor :: Int -> Room -> Room
 lightSensByDoor outplid rm = rm
@@ -52,7 +49,7 @@ lightSensByDoor outplid rm = rm
         , heightWallPS (atNthLnkOutShiftInward 1 100) 30 covershape
         , heightWallPS (atFstLnkOutShiftInward 100)   30 covershape
         ]
-    & rmOutPmnt .~ [OutPlacement (lasSensLightAboveDoor 20 (atFstLnkOutShiftBy sensorshift)) outplid]
+    & rmOutPmnt .~ [OutPlacement (sensAboveDoor LASERING 20 (atFstLnkOutShiftBy sensorshift)) outplid]
   where
     covershape = rectNSWE 10 (-10) (-20) 20
     sensorshift (p,a) = (p +.+ rotateV a (V2 60 (-20)), a)

src/Dodge/Room/LongDoor.hs

@@ -98,7 +98,7 @@ addButtonSlowDoor x h rm = do
         & rmPmnts .++~ [butDoor , theterminal]
         & rmBound .:~ openDoorBound
   where
-    theterminal = putTerminal terminalColor (simpleTermMessage themessage)
+    theterminal = putMessageTerminal terminalColor (simpleTermMessage themessage)
         & plSpot .~ rprBoolShift (isUnusedLnkType InLink) (shiftByV2 (V2 0 (-10)))
     themessage = 
         ["WARNING:"

src/Dodge/Room/SensorDoor.hs

@@ -67,7 +67,7 @@ sensInsideDoor senseType outplid rm = rm
         [ psPt atFstLnkOut . PutForeground $ floorWire (V2 20 0) (V2 20 (-100))
         , psPt atFstLnkOut . PutForeground $ floorWire (V2 0 (-100)) (V2 20 (-100))
         , psPt atFstLnkOut . PutForeground $ verticalWire (V2 20 0) 0 80
-        , putTerminal terminalColor (basicTerminal & tmScrollCommands .:~ damageCodeCommand)
+        , putMessageTerminal terminalColor (basicTerminal & tmScrollCommands .:~ damageCodeCommand)
             & plSpot .~ rprBoolShift isUnusedLnk (shiftInBy 10)
         ]
     & rmOutPmnt .~ [OutPlacement (sensAboveDoor senseType 10 (atFstLnkOutShiftInward 100)) outplid]

src/Dodge/Room/Warning.hs

@@ -38,21 +38,21 @@ import qualified Data.Map.Strict as M
 --import qualified Data.Text as T
 
 
-warningRooms :: RandomGen g => Int -> State g (MetaTree Room String)
+warningRooms :: RandomGen g => String -> Int -> State g (MetaTree Room String)
-warningRooms n = do
+warningRooms str n = do
     rm <- do
         tr <- tanksRoom [] []
         takeOne [roomNgon 8 200, roomRectAutoLinks 200 200,tr]
-    cenroom <- shuffleLinks $ addWarningTerminal n rm
+    cenroom <- shuffleLinks $ addWarningTerminal str n rm
     rToOnward "warningRooms" $ treePost [ door, cenroom, triggerDoorRoom n, cleatOnward door]
 
-addWarningTerminal :: Int -> Room -> Room
+addWarningTerminal :: String -> Int -> Room -> Room
-addWarningTerminal outplid = (rmName .++~ "warningTerm-")
+addWarningTerminal str outplid = (rmName .++~ "warningTerm-")
     . (rmOutPmnt .~ [OutPlacement outplace outplid])
   where
     outplace = extTrigLitPos
         (atFstLnkOutShiftBy (\(p,a) -> (p +.+ rotateV a (V2 18.5 (-2.5)), a)))
-        (Just . set plSpot (rprShift moveToSideFirstOutLink) . putTerminal terminalColor . termMessages)
+        (Just . set plSpot (rprShift moveToSideFirstOutLink) . putMessageTerminal terminalColor . termMessages)
     termMessages trpl = basicTerminal & tmScrollCommands .:~ toggleCommand
         & tmToggles .~ M.fromList 
             [("DOOR",TerminalToggle (fromJust $ _plMID trpl) (const (const True)))]