Cleanup

src/Dodge/Creature/Picture.hs

@@ -1,16 +1,9 @@
---{-# LANGUAGE TupleSections #-}
-
 {- |
 Drawing of creatures.
 Takes into account damage etc.
 -}
 module Dodge.Creature.Picture (
     basicCrPict,
-    drawCrEquipment,
-    circLine,
-    picAtCrPos,
-    shapeAtCrPos,
-    picAtCrPosNoRot,
     deadScalp,
     deadUpperBody,
     deadFeet,
@@ -29,16 +22,8 @@ import Shape
 import ShapePicture
 
 basicCrPict :: Creature -> SPic
-basicCrPict cr = drawCrEquipment cr <> (basicCrShape cr, mempty)
+basicCrPict cr = uncurryV translateSPf (_crPos cr) (rotateSP (_crDir cr) $ drawEquipment cr) 
-
+    <> (basicCrShape cr, mempty)
-drawCrEquipment :: Creature -> SPic
-drawCrEquipment cr = uncurryV translateSPf (_crPos cr) (rotateSP (_crDir cr) $ drawEquipment cr)
-
-shapeAtCrPos :: Shape -> Creature -> SPic
-shapeAtCrPos sh cr =
-    ( uncurryV translateSHf (_crPos cr) $ rotateSH (_crDir cr) sh
-    , mempty
-    )
 
 basicCrShape ::
     Creature ->
@@ -48,8 +33,7 @@ basicCrShape cr
     | otherwise =
         tr . scaleSH (V3 crsize crsize crsize) $
             mconcat
-                [ --rotdir . _spShape $ drawEquipment cr
+                [ rotdir . colorSH (_skinHead cskin) . translateSHz 20 $ scalp cr
-                  rotdir . colorSH (_skinHead cskin) . translateSHz 20 $ scalp cr
                 , rotdir $ colorSH (_skinUpper cskin) $ upperBody cr
                 , rotmdir $ colorSH (_skinLower cskin) $ feet cr
                 ]
@@ -60,25 +44,6 @@ basicCrShape cr
     rotdir = rotateSH (_crDir cr)
     rotmdir = rotateSH (_crMvDir cr)
 
---damageMod :: Creature -> Picture -> Picture
---damageMod cr pic = piercingMod $ bluntScale pic
---  where
---    cdir = _crDir cr
---    pastDams = _crPastDamage $ _crState cr
---    bluntDam :: Maybe Point2
---    bluntDam = find isBluntDam (concat pastDams) >>= (\dm -> (-.-) <$> dm ^? dmFrom <*> dm ^? dmTo)
---    bluntScale = case fmap argV bluntDam of
---        Just a -> rotate (a + cdir) . scale 0.8 1.2 . rotate (negate $ cdir + a)
---        _   -> id
---    isBluntDam Blunt{} = True
---    isBluntDam _ = False
---    piercingDam = find isPiercingDam (concat pastDams) >>= (\dm -> (-.-) <$> dm ^? dmFrom <*> dm ^? dmTo)
---    isPiercingDam Piercing{} = True
---    isPiercingDam _ = False
---    piercingMod = case fmap argV piercingDam of
---        Just a -> rotate (a + cdir) . scale 0.8 1.2 . rotate (negate $ cdir + a)
---        _   -> id
-
 feet :: Creature -> Shape
 {-# INLINE feet #-}
 feet cr = case cr ^? crStance . carriage of
@@ -136,26 +101,8 @@ arms cr =
         translateToRightHand cr aHand
             <> translateToLeftHand cr aHand
   where
-    --arms cr
-    --    | oneH cr = shoulderSH . translateSHf 11 (-3) . rotateSH (-0.5) $ scaleSH (V3 1 1.5 1) aHand
-    --    | twists cr = shoulderSH . translateSHf 0 5 . rotateSH (-1) $ mconcat
-    --        [ translateSHf 12 4    aHand
-    --        , translateSHf 4 (-10) aHand
-    --        ]
-    --    | twoFlat cr = waistSH $ translateSHf 4 8 aHand
-    --        <> translateSHf 4 (-8) aHand
-    --    | otherwise = case cr ^? crStance . carriage of
-    --        Just (Walking sa LeftForward)  -> waistSH $ translateSHf (-f sa) (-off) aHand
-    --        Just (Walking sa RightForward) -> waistSH $ translateSHf (-f sa) off    aHand
-    --        _ -> emptySH
-
-    aHand :: SPic
     aHand = noPic $ translateSHz (-4) . upperPrismPolyHalf 4 $ polyCirc 3 4
 
---    off = 8
---    sLen = _strideLength $ _crStance cr
---    f i = negate 2 + negate 6 * fromIntegral (sLen - i) / fromIntegral sLen
-
 deadScalp :: Creature -> Shape
 deadScalp cr = deadRot cr . translateSHz 10 . scalp $ cr
 
@@ -177,11 +124,6 @@ scalp cr
   where
     fhead = colorSH (greyN 0.9) . upperPrismPolyHalf 5 $ polyCirc 4 5
 
---hasAmmo :: Creature -> Bool
---hasAmmo cr = case cr ^? crInv . ix (_crInvSel cr) . itConsumption . ammoLoaded of
---    Just x -> x > 0
---    _ -> False
-
 torso :: Creature -> Shape
 {-# INLINE torso #-}
 torso cr
@@ -203,7 +145,6 @@ torso cr
             , translateSHf 0 (negate 3) . rotateSH 0.2 $ aShoulder
             ]
   where
-    --aShoulder = translateSHz (-10) . scaleSH (V3 0.5 1 1) . upperPrismPoly 10 $ polyCirc 3 crad
     aShoulder = scaleSH (V3 10 10 1) baseShoulder
 
 deadUpperBody :: Creature -> Shape
@@ -215,7 +156,6 @@ baseShoulder = translateSHz (-10) . scaleSH (V3 0.5 1 1) . upperPrismPolyHalf 10
 
 upperBody :: Creature -> Shape
 {-# INLINE upperBody #-}
---upperBody col cr = colorSH (light4 col) $ mconcat
 upperBody cr =
     mconcat
         [ arms cr
@@ -225,33 +165,6 @@ upperBody cr =
 shoulderSH :: Shape -> Shape
 shoulderSH = translateSHz 20
 
---waistSH :: Shape -> Shape
---waistSH = translateSHz 10
-
---drawAwakeLevel
---    :: Creature
---    -> Picture
---drawAwakeLevel cr = case cr ^? crAttentionDir of
---    Just (AttentiveTo [0]) -> setPos . color red $ circleSolid 5
---    _        -> setPos . color blue $ circleSolid 5
---  where
---    setPos = translate 0 (_crRad cr)
-
 drawEquipment :: Creature -> SPic
 {-# INLINE drawEquipment #-}
 drawEquipment cr = foldMap (itemEquipPict cr) (_crInv cr)
-
---drawEquipment cr = foldMap f (_crInv cr)
---  where
---    f itm = _itEquipPict itm cr itm
-
-circLine :: Float -> Picture
-circLine x = line [V2 0 0, V2 x 0]
-
-picAtCrPos :: Picture -> Creature -> SPic
---{-# INLINE picAtCrPos #-}
-picAtCrPos thePic cr = (,) emptySH $ tranRot (_crPos cr) (_crDir cr) thePic
-
-picAtCrPosNoRot :: Picture -> Creature -> SPic
---{-# INLINE picAtCrPos #-}
-picAtCrPosNoRot thePic cr = (,) emptySH $ uncurryV translate (_crPos cr) thePic

src/Dodge/Data/Machine.hs

@@ -26,43 +26,41 @@ import Dodge.Data.ObjectType
 import Geometry.Data
 import Sound.Data
 
-data MachineDraw
-    = MachineDrawMempty
-    | MachineDrawTerminal
-    | MachineDrawTurret
-    | MachineDrawDamageSensor Float (PaletteColor, DecorationShape)
-    deriving (Eq, Show, Read)
-
 data Machine = Machine
     { _mcID :: Int
     , _mcWallIDs :: IS.IntSet
-    , _mcDraw :: MachineDraw
     , _mcMaterial :: Material
     , _mcPos :: Point2
     , _mcDir :: Float
     , _mcColor :: Color
     , _mcHP :: Int
-    , _mcSensor :: Sensor
     , _mcDamage :: [Damage]
     , _mcType :: MachineType
     , _mcMounts :: M.Map ObjectType Int
     , _mcName :: String
     , _mcCloseSound :: Maybe SoundID
+    , _mcWidth :: Float
     }
     deriving (Eq, Show, Read)
 
 data MachineType
-    = StaticMachine
+    = McStatic
-    | Turret
+    | McTerminal
-        { _tuWeapon :: Item
+    | McSensor Sensor
-        , _tuTurnSpeed :: Float
+    | McTurret Turret
-        , _tuFireTime :: Int
+    deriving (Eq, Show, Read)
-        , _tuMCrID :: Maybe Int
+
-        }
+data Turret = Turret
+    { _tuWeapon :: Item
+    , _tuTurnSpeed :: Float
+    , _tuFireTime :: Int
+    , _tuDir :: Float
+    }
     deriving (Eq, Show, Read)
 
 makeLenses ''Machine
-makeLenses ''MachineType
+makeLenses ''Turret
-deriveJSON defaultOptions ''MachineDraw
+makePrisms ''MachineType
 deriveJSON defaultOptions ''Machine
 deriveJSON defaultOptions ''MachineType
+deriveJSON defaultOptions ''Turret

src/Dodge/Data/Machine/Sensor.hs

@@ -3,6 +3,8 @@
 
 module Dodge.Data.Machine.Sensor where
 
+import Dodge.Data.GenParams
+import Color
 import Control.Lens
 import Data.Aeson
 import Data.Aeson.TH
@@ -10,11 +12,11 @@ import Dodge.Data.Item.Combine
 import Dodge.Data.Damage.Type
 
 data Sensor
-    = NoSensor
+    = DamageSensor
-    | DamageSensor
         { _sensToggle :: Bool
         , _sensAmount :: Int
         , _sensType :: DamageType
+        , _sensDraw :: (PaletteColor, DecorationShape)
         }
     | ProximitySensor
         { _proxStatus :: CloseToggle

src/Dodge/Default.hs

@@ -40,18 +40,17 @@ defaultMachine =
     Machine
         { _mcID = 0
         , _mcWallIDs = mempty
-        , _mcDraw = MachineDrawMempty
         , _mcColor = white
         , _mcPos = V2 0 0
         , _mcDir = 0
         , _mcHP = 1000
-        , _mcSensor = NoSensor
         , _mcMaterial = Electronics
         , _mcDamage = []
-        , _mcType = StaticMachine
+        , _mcType = McStatic
         , _mcName = ""
         , _mcMounts = mempty
         , _mcCloseSound = Nothing
+        , _mcWidth = 10
         }
 
 defaultButton :: Button

src/Dodge/Floor.hs

@@ -21,6 +21,7 @@ initialAnoTree =
         intersperse
             (AnTree corDoor)
             [ IntAnno $ AnTree . startRoom
+            , IntAnno $ AnTree . lasSensorTurretTest
             , --    , AnRoom $ tanksRoom [] [] <&> rmPmnts .~ []
               --    , AnRoom $ tanksRoom [] []
               --    , AnRoom $ roomCCrits 0

src/Dodge/HeldUse.hs

@@ -355,6 +355,12 @@ useMod hm = case hm of
         cr & crDir %~ tweenAngles x (_crOldDir cr)
             & crPos %~ tweenPoints x (_crOldPos cr)
 
+
+mcUseHeld :: HeldItemType -> Item -> Machine -> World -> World
+mcUseHeld hit = case hit of
+    LASGUN -> mcShootLaser
+    _ -> \_ _ -> id
+
 useHeld :: HeldUse -> Item -> Creature -> World -> World
 useHeld hu = case hu of
     HeldDoNothing -> const $ const id
@@ -480,3 +486,11 @@ coneRandItemParams = do
             { _muzVel = muzv
             , _rifling = rifl
             }
+
+mcShootLaser :: Item -> Machine -> World -> World
+mcShootLaser it mc = cWorld . lasers .:~ lasRayAt (_lasColor $ _itParams it) dam phasev pos dir
+  where
+    pos = _mcPos mc
+    dir = mc ^?! mcType . _McTurret . tuDir
+    phasev = _phaseV . _itParams $ it
+    dam = _lasDamage $ _itParams it

src/Dodge/Item/Draw.hs

@@ -1,6 +1,4 @@
 module Dodge.Item.Draw (
-    pictureWeaponOnAim,
-    pictureWeaponAim,
     twoFlatHRot,
     itemSPic,
     itemEquipPict,
@@ -12,72 +10,11 @@ import Dodge.Data.Creature
 import Dodge.Item.Draw.SPic
 import Dodge.Item.Equipment.Shape
 import Dodge.Item.HeldOffset
-import qualified IntMapHelp as IM
 import ShapePicture
 
 itemEquipPict :: Creature -> Item -> SPic
-itemEquipPict cr it = case it ^?! itUse of
+itemEquipPict cr it = case it ^. itUse of
-    HeldUse{} -> pictureWeaponOnAim cr it
+    HeldUse{} | _itIsHeld it -> overPosSP (heldItemOffset it cr) (itemSPic it)
     ituse -> case ituse ^? equipEffect of
         Just _ -> pictureOnEquip (itemSPic it) cr it
         Nothing -> mempty
-
-pictureWeaponOnAim ::
-    Creature ->
-    Item ->
-    SPic
-pictureWeaponOnAim = pictureWeaponAim itemSPic
-
-pictureWeaponAim ::
-    (Item -> SPic) ->
-    Creature ->
-    Item ->
-    SPic
-pictureWeaponAim f cr itm = case _itLocation itm of
-    InInv _ i -> pictureWeaponOnAimItem (f itm) cr i
-    _ -> mempty
-
--- | Places an item picture onto a creature when the item is selected.
-pictureWeaponOnAimItem ::
-    SPic ->
-    Creature ->
-    -- | Position of item in inventory
-    Int ->
-    SPic
-pictureWeaponOnAimItem p' cr posInInv
-    | _itIsHeld theIt = overPosSP (heldItemOffset theIt cr) p'
-    | otherwise = mempty
-  where
-    --    | isSelected && _posture (_crStance cr) == Aiming =
-    --        shoulderD $ translateSPf (aimingWeaponZeroPos cr theIt) 0 p'
-    --    | isSelected && isTwoHandFlat
-    --                = handD holsteredTwoFlat
-    --    | isSelected && isOneHand
-    --                = handD holsteredOneHandWep
-    --    | isSelected
-    --                = handD holsteredWep
-    --    | otherwise = mempty
-
-    --    shoulderD = translateSPz 18
-    --    handD = translateSPz 15
-    --    isSelected = crSel cr == posInInv
-    --    twistWep        = translateSPf (-5) 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)
-    --    holsteredOneHandWep = translateSPf (_crRad cr * 0.7 + handPos) (_crRad cr * negate 0.7)
-    --        (translateSPf (-2) 0 p)
-    --    handPos = case cr^? crStance . carriage of
-    --        Just (Walking x LeftForward) -> f x * 50
-    --        _ -> 0
-    theIt = _crInv cr IM.! posInInv
-
---    p = fromMaybe p' $ do
---        x <- theIt ^? itUse . useAim . aimHandlePos
---        return $translateSPf (-x) 0 p'
---    isOneHand       = theIt ^? itUseAimStance == Just OneHand
---                        || isNothing (theIt ^? itUseAimStance)
---    isTwoHandFlat   = theIt ^? itUseAimStance == Just TwoHandFlat
---    itUseAimStance = itUse . useAim . aimStance
---    f i = 0.1 * fromIntegral (sLen - i) / fromIntegral sLen
---    sLen = _strideLength $ _crStance cr

src/Dodge/Item/Weapon/BatteryGuns.hs

@@ -142,6 +142,7 @@ shootTeslaArc it cr w =
     pos = _crPos cr +.+ aimingMuzzlePos cr it *.* unitVectorAtAngle dir
     dir = _crDir cr
 
+
 shootLaser :: Item -> Creature -> World -> World
 shootLaser it cr = cWorld . lasers .:~ lasRayAt (_lasColor $ _itParams it) dam phasev pos dir
   where

src/Dodge/Machine/Draw.hs

@@ -1,19 +1,25 @@
 module Dodge.Machine.Draw
     where
-import Dodge.Placement.Instance.Sensor
+import Dodge.Placement.TopDecoration
-import Dodge.Placement.Instance.Turret
+--import Dodge.Placement.Instance.Turret
 import Shape
 import Picture
 import Geometry
 import Dodge.Data.Machine
 import ShapePicture
 
-drawMachine :: MachineDraw -> Machine -> SPic
+drawMachine :: Machine -> SPic
-drawMachine md = case md of
+drawMachine mc = case _mcType mc of
-    MachineDrawMempty -> const mempty
+    McStatic -> mempty
-    MachineDrawTerminal -> terminalSPic
+    McTerminal -> terminalSPic mc
-    MachineDrawTurret   -> drawTurret
+    McTurret tu -> drawTurret tu mc
-    MachineDrawDamageSensor w pcds -> sensorSPic w pcds
+    McSensor se -> drawSensor se mc
+
+drawSensor :: Sensor -> Machine -> SPic
+drawSensor sens = case sens of
+    DamageSensor {_sensDraw = pcds} -> sensorSPic pcds
+    ProximitySensor {} -> const mempty
+
 terminalSPic :: Machine -> SPic
 terminalSPic = noPic . terminalShape
 
@@ -31,3 +37,19 @@ terminalShape mc = colorSH col (prismPoly
   where
     col = _mcColor mc
 
+drawTurret :: Turret -> Machine -> SPic
+drawTurret _ mc =
+    ( rotateSH (- _mcDir mc) . colorSH (_mcColor mc) $ upperPrismPoly 20 (square w)
+    , mempty -- setLayer 5 $ scale 0.5 0.5 $ text $ show $ _mcDir mc )
+    )
+  where
+    w = _mcWidth mc
+
+sensorSPic :: (PaletteColor, DecorationShape) -> Machine -> SPic
+sensorSPic (pc, ds) mc =
+    noPic $
+        colorSH (_mcColor mc) (upperPrismPoly 25 (square w))
+            <> decorationToShape ds w w 25 col col
+  where
+    col = paletteToColor pc
+    w = _mcWidth mc

src/Dodge/Machine/Update.hs

@@ -1,13 +1,13 @@
 module Dodge.Machine.Update where
 
-import Dodge.Item.Held.BatteryGuns
 import Data.List (partition)
 import Data.Maybe
 import Dodge.Base.Collide
 import Dodge.Base.You
 import Dodge.Data.World
-import Dodge.Default
 import Dodge.FloorItem
+import Dodge.HeldUse
+import Dodge.Item.Held.BatteryGuns
 import Dodge.Machine.Destroy
 import Dodge.Movement.Turn
 import Dodge.SoundLogic
@@ -28,8 +28,8 @@ updateMachine mc
             . mcSensorUpdate mc
 
 mcTurretUpdate :: Machine -> World -> World
-mcTurretUpdate mc = case _mcType mc of
+mcTurretUpdate mc = case mc ^? mcType . _McTurret of
-    mt@Turret{} -> updateTurret (_tuTurnSpeed mt) mc
+    Just tu -> updateTurret (_tuTurnSpeed tu) mc
     _ -> id
 
 -- this needs a major cleanup
@@ -40,40 +40,12 @@ updateTurret rotSpeed mc w
             & deleteWallIDs (_mcWallIDs mc)
             & makeExplosionAt mcpos
             & copyItemToFloor mcpos lasGun
-            & deleteHomonculus
     | otherwise =
         w
-            & initHomonculus
             & dodamage
-            & maybeFire
+            & mcUseItem mc
             & elecDamBranch
   where
-    deleteHomonculus = case _tuMCrID (_mcType mc) of
-        Nothing -> id
-        Just cid -> cWorld . creatures . at cid .~ Nothing
-    initHomonculus w' = case w' ^? cWorld . machines . ix mcid . mcType . tuMCrID . _Just of
-        Nothing ->
-            w' & cWorld . machines . ix mcid . mcType . tuMCrID ?~ cid
-                & cWorld . creatures . at cid ?~ thecreature
-          where
-            cid = IM.newKey (_creatures (_cWorld w'))
-            thecreature =
-                defaultCreature
-                    & crID .~ cid
-                    & crInv . at 0
-                        ?~ ( _tuWeapon (_mcType mc) & itUse . heldAim . aimHandlePos -~ 10
-                                & itUse . heldConsumption . laLoaded .~ 1
-                           )
-                    & crPos .~ mcpos
-                    & crOldPos .~ mcpos
-                    & crRad .~ 1
-                    & crDir .~ mcdir
-                    & crStance . posture .~ Aiming
-                    & crMaterial .~ Crystal
-        Just cid ->
-            w'
-                & cWorld . creatures . ix cid . crPos .~ mcpos
-                & cWorld . creatures . ix cid . crDir .~ mcdir
     dodamage =
         cWorld . machines . ix mcid
             %~ ( (mcDamage .~ [Damage ELECTRICAL (min 2500 $ max 0 (elecDam - 10)) 0 0 0 NoDamageEffect])
@@ -82,16 +54,10 @@ updateTurret rotSpeed mc w
     elecDamBranch
         | elecDam < 10 = updateFiringStatus . doTurn
         | otherwise = id
-    maybeFire
-        | _tuFireTime (_mcType mc) > 0 =
-            fromMaybe id $ do
-                cid <- _tuMCrID (_mcType mc)
-                return $ cWorld . creatures . ix cid . crActionPlan . apImpulse .~ [UseItem]
-        | otherwise = id
     mcid = _mcID mc
     ypos = _crPos $ you w
     mcpos = _mcPos mc
-    mcdir = _mcDir mc
+    --mcdir = _mcDir mc
     seesYou = hasLOSIndirect mcpos ypos w
     (elecDams, dams) = partition isElectrical $ _mcDamage mc
     dam = sum $ map _dmAmount dams
@@ -101,8 +67,21 @@ updateTurret rotSpeed mc w
         | otherwise = id
     closeFireAngle = seesYou -- && angleVV (ypos -.- mcpos) (unitVectorAtAngle mcdir) < 1
     updateFiringStatus
-        | closeFireAngle = cWorld . machines . ix mcid . mcType . tuFireTime .~ 20
+        | closeFireAngle = cWorld . machines . ix mcid . mcType . _McTurret . tuFireTime .~ 20
-        | otherwise = cWorld . machines . ix mcid . mcType . tuFireTime %~ (max 0 . subtract 1)
+        | otherwise = cWorld . machines . ix mcid . mcType . _McTurret . tuFireTime %~ (max 0 . subtract 1)
+
+mcUseItem :: Machine -> World -> World
+mcUseItem mc = fromMaybe id $ do
+    tu <- mc ^? mcType . _McTurret
+    let it = tu ^. tuWeapon
+    hit <- it ^? itType . iyBase . ibtHeld
+    return $ mcUseHeld hit it mc
+
+--    maybeFire
+--        | _tuFireTime (_mcType mc) > 0 =
+--            fromMaybe id $ do
+--                return $ tuUseItem
+--        | otherwise = id
 
 mcSensorTriggerUpdate :: Machine -> World -> World
 mcSensorTriggerUpdate mc = fromMaybe id $ do
@@ -111,10 +90,10 @@ mcSensorTriggerUpdate mc = fromMaybe id $ do
     return $ cWorld . triggers . ix trid .~ bval
 
 mcTriggerVal :: Machine -> Maybe Bool
-mcTriggerVal mc = case mc ^. mcSensor of
+mcTriggerVal mc = case mc ^? mcType . _McSensor of
-    NoSensor -> Nothing
+    Nothing -> Nothing
-    s@ProximitySensor{} -> s ^? sensToggle
+    Just s@ProximitySensor{} -> s ^? sensToggle
-    s@DamageSensor{} -> Just $ _sensAmount s > 900
+    Just s@DamageSensor{} -> Just $ _sensAmount s > 900
 
 mcPlaySound :: Machine -> World -> World
 mcPlaySound mc w = case _mcCloseSound mc of
@@ -127,17 +106,17 @@ mcPlaySound mc w = case _mcCloseSound mc of
     mid = _mcID mc
 
 mcApplyDamage :: [Damage] -> Machine -> World -> World
-mcApplyDamage ds mc = case _mcSensor mc of
+mcApplyDamage ds mc = case mc ^? mcType . _McSensor of
-    NoSensor ->
+    Nothing ->
         cWorld . machines . ix (_mcID mc)
             %~ ((mcDamage .~ []) . (mcHP -~ sum (map _dmAmount ds)))
     _ -> id
 
 mcSensorUpdate :: Machine -> World -> World
-mcSensorUpdate mc w = case _mcSensor mc of
+mcSensorUpdate mc w = case mc ^? mcType . _McSensor of
-    NoSensor -> w
+    Nothing -> w
-    s@DamageSensor{} -> senseDamage (_sensType s) mc w
+    Just s@DamageSensor{} -> senseDamage (_sensType s) mc w
-    ProximitySensor{} -> mcProximitySensorUpdate mc w
+    Just ProximitySensor{} -> mcProximitySensorUpdate mc w
 
 mcProximitySensorUpdate :: Machine -> World -> World
 mcProximitySensorUpdate mc w = case ( _proxStatus sens
@@ -148,21 +127,21 @@ mcProximitySensorUpdate mc w = case ( _proxStatus sens
     (_, True, _, _) -> w
     (_, False, True, True) ->
         w
-            & cWorld . machines . ix (_mcID mc) . mcSensor . sensToggle .~ True
+            & cWorld . machines . ix (_mcID mc) . mcType . _McSensor . sensToggle .~ True
             & playsound dedaS
-            & cWorld . machines . ix (_mcID mc) . mcSensor . proxStatus .~ IsClose
+            & cWorld . machines . ix (_mcID mc) . mcType . _McSensor . proxStatus .~ IsClose
     (NotClose, _, False, True) ->
         w & playsound dedumS
-            & cWorld . machines . ix (_mcID mc) . mcSensor . proxStatus .~ IsClose
+            & cWorld . machines . ix (_mcID mc) . mcType . _McSensor . proxStatus .~ IsClose
-    (_, _, _, False) -> w & cWorld . machines . ix (_mcID mc) . mcSensor . proxStatus .~ NotClose
+    (_, _, _, False) -> w & cWorld . machines . ix (_mcID mc) . mcType . _McSensor . proxStatus .~ NotClose
     _ -> w
   where
     playsound sid = soundContinue (MachineAltSound (_mcID mc)) (_mcPos mc) sid Nothing
     ycr = you w
-    sens = _mcSensor mc
+    sens = mc ^?! mcType . _McSensor
 
 mcProxTest :: Machine -> World -> Bool
-mcProxTest mc w = case mc ^? mcSensor . proxRequirement of
+mcProxTest mc w = case mc ^? mcType . _McSensor . proxRequirement of
     Just (RequireHealth x) -> _crHP cr >= x
     Just (RequireEquipment ct) -> any (\itm -> _iyBase (_itType itm) == ct) (_crInv cr)
     _ -> False
@@ -174,10 +153,10 @@ senseDamage dt mc =
     (cWorld . machines . ix mcid %~ upmc)
         . updatels
   where
-    upmc = mcSensor . sensAmount %~ min 1000 . max 0 . (+ (newsense - 5))
+    upmc = mcType . _McSensor . sensAmount %~ min 1000 . max 0 . (+ (newsense - 5))
     mcid = _mcID mc
     newsense = sum . map _dmAmount $ filter ((== dt) . _dmType) (_mcDamage mc)
-    ni = fromIntegral (_sensAmount $ _mcSensor mc) / 1000
+    ni = fromIntegral (mc ^?! mcType . _McSensor . sensAmount) / 1000
     updatels = fromMaybe id $ do
         lsid <- mc ^? mcMounts . ix ObLightSource
         return $ cWorld . lightSources . ix lsid . lsParam . lsCol .~ V3 ni ni ni

src/Dodge/Placement/Instance/Analyser.hs

@@ -27,9 +27,9 @@ analyser proxreq pslight psmc = extTrigLitPos pslight $ \tp ->
     themachine =
         defaultMachine & mcColor .~ aquamarine
             --        & mcUpdate .~ mcProximitySensorUpdate
-            & mcDraw .~ MachineDrawTerminal
+            & mcType .~ McTerminal
             & mcHP .~ 100
-            & mcSensor .~ defaultProximitySensor{_proxRequirement = proxreq}
+            & mcType . _McSensor .~ defaultProximitySensor{_proxRequirement = proxreq}
 
 --this can probably be deleted
 --mcProximitySensorUpdate :: Machine -> World -> World

src/Dodge/Placement/Instance/Sensor.hs

@@ -1,7 +1,6 @@
 module Dodge.Placement.Instance.Sensor (
     lightSensor,
     damageSensor,
-    sensorSPic, -- this should be moved
 ) where
 
 import Color
@@ -11,10 +10,7 @@ import Dodge.Data.GenWorld
 import Dodge.Default
 import Dodge.LevelGen.Data
 import Dodge.LightSource
-import Dodge.Placement.TopDecoration
 import Geometry
-import Shape
-import ShapePicture
 
 damageSensor ::
     DamageType ->
@@ -34,8 +30,7 @@ damageSensor dt wdth mtrid ps = pContID ps (PutLS $ lsPosCol (V3 0 0 30) 0.1) $
                                 & mcColor .~ yellow
                                 & mcMounts . at ObTrigger .~ mtrid
                                 & mcMounts . at ObLightSource ?~ lsid
-                                & mcDraw .~ MachineDrawDamageSensor wdth (_sensorCoding (_genParams (_cWorld gw)) M.! dt)
+                                & mcType . _McSensor .~ DamageSensor False 0 dt (_sensorCoding (_genParams (_cWorld gw)) M.! dt)
-                                & mcSensor .~ DamageSensor False 0 dt
                             )
                             defaultSensorWall
 
@@ -46,10 +41,3 @@ lightSensor ::
     Placement
 lightSensor = damageSensor LASERING
 
-sensorSPic :: Float -> (PaletteColor, DecorationShape) -> Machine -> SPic
-sensorSPic wdth (pc, ds) mc =
-    noPic $
-        colorSH (_mcColor mc) (upperPrismPoly 25 (square wdth))
-            <> decorationToShape ds wdth wdth 25 col col
-  where
-    col = paletteToColor pc

src/Dodge/Placement/Instance/Terminal.hs

@@ -45,7 +45,7 @@ putMessageTerminal col =
     putTerminal $
         defaultMachine
             & mcColor .~ col
-            & mcDraw .~ MachineDrawTerminal --terminalSPic
+            & mcType .~ McTerminal
             & mcHP .~ 100
 
 termButton :: Button

src/Dodge/Placement/Instance/Turret.hs

@@ -2,126 +2,30 @@ module Dodge.Placement.Instance.Turret where
 
 import Dodge.Item.Held.BatteryGuns
 import Color
-import Data.List
-import Data.Maybe
-import Dodge.Base
 import Dodge.Data.GenWorld
 import Dodge.Default
-import Dodge.FloorItem
 import Dodge.LevelGen.Data
-import Dodge.Movement.Turn
-import Dodge.Wall.Delete
-import Dodge.WorldEvent.Explosion
 import Geometry
-import qualified IntMapHelp as IM
 import LensHelp
-import Shape
-import ShapePicture
 
 putLasTurret :: Float -> Placement
 putLasTurret rotSpeed =
     sps0 $
         PutMachine
-            (reverse $ square wdth)
+            (reverse $ square 10)
             ( defaultMachine
                 & mcColor .~ blue
-                & mcDraw .~ MachineDrawTurret
+                & mcType .~ (lasTurret & _McTurret . tuTurnSpeed .~ rotSpeed)
-                & mcType .~ (lasTurret & tuTurnSpeed .~ rotSpeed)
                 & mcHP .~ 50000
             )
             defaultMachineWall
 
 lasTurret :: MachineType
-lasTurret =
+lasTurret = McTurret $
     Turret
         { _tuWeapon = lasGun
         , --    { _tuWeapon = autoRifle
           _tuTurnSpeed = 0.1
         , _tuFireTime = 0
-        , _tuMCrID = Nothing
+        , _tuDir = 0
         }
-
--- this needs a major cleanup
-updateTurret :: Float -> Machine -> World -> World
-updateTurret rotSpeed mc w
-    | _mcHP mc < 1 =
-        w & cWorld . machines %~ IM.delete mcid
-            & deleteWallIDs (_mcWallIDs mc)
-            & makeExplosionAt mcpos
-            & copyItemToFloor mcpos lasGun
-            & deleteHomonculus
-    | otherwise =
-        w
-            & initHomonculus
-            & dodamage
-            & maybeFire
-            & elecDamBranch
-  where
-    deleteHomonculus = case _tuMCrID (_mcType mc) of
-        Nothing -> id
-        Just cid -> cWorld . creatures . at cid .~ Nothing
-    initHomonculus w' = case w' ^? cWorld . machines . ix mcid . mcType . tuMCrID . _Just of
-        Nothing ->
-            w' & cWorld . machines . ix mcid . mcType . tuMCrID ?~ cid
-                & cWorld . creatures . at cid ?~ thecreature
-          where
-            cid = IM.newKey (_creatures (_cWorld w'))
-            thecreature =
-                defaultCreature
-                    & crID .~ cid
-                    & crInv . at 0
-                        ?~ ( _tuWeapon (_mcType mc) & itUse . heldAim . aimHandlePos -~ 10
-                                & itUse . heldConsumption . laLoaded .~ 1
-                           )
-                    & crPos .~ mcpos
-                    & crOldPos .~ mcpos
-                    & crRad .~ 1
-                    & crDir .~ mcdir
-                    & crStance . posture .~ Aiming
-                    & crMaterial .~ Crystal
-        Just cid ->
-            w'
-                & cWorld . creatures . ix cid . crPos .~ mcpos
-                & cWorld . creatures . ix cid . crDir .~ mcdir
-    dodamage =
-        cWorld . machines . ix mcid
-            %~ ( (mcDamage .~ [Damage ELECTRICAL (min 2500 $ max 0 (elecDam - 10)) 0 0 0 NoDamageEffect])
-                    . (mcHP -~ dam)
-               )
-    elecDamBranch
-        | elecDam < 10 = updateFiringStatus . doTurn
-        | otherwise = id
-    maybeFire
-        | _tuFireTime (_mcType mc) > 0 =
-            fromMaybe id $ do
-                cid <- _tuMCrID (_mcType mc)
-                return $ cWorld . creatures . ix cid . crActionPlan . apImpulse .~ [UseItem]
-        | otherwise = id
-    mcid = _mcID mc
-    ypos = _crPos $ you w
-    mcpos = _mcPos mc
-    mcdir = _mcDir mc
-    seesYou = hasLOSIndirect mcpos ypos w
-    (elecDams, dams) = partition isElectrical $ _mcDamage mc
-    dam = sum $ map _dmAmount dams
-    elecDam = sum $ map _dmAmount elecDams
-    doTurn
-        | seesYou = cWorld . machines . ix mcid . mcDir %~ turnTo rotSpeed mcpos ypos
-        | otherwise = id
-    closeFireAngle = seesYou -- && angleVV (ypos -.- mcpos) (unitVectorAtAngle mcdir) < 1
-    updateFiringStatus
-        | closeFireAngle = cWorld . machines . ix mcid . mcType . tuFireTime .~ 20
-        | otherwise = cWorld . machines . ix mcid . mcType . tuFireTime %~ (max 0 . subtract 1)
-
-drawTurret :: Machine -> SPic
-drawTurret mc =
-    ( rotateSH (- _mcDir mc) . colorSH (_mcColor mc) $ upperPrismPoly 20 (square wdth)
-    , mempty -- setLayer 5 $ scale 0.5 0.5 $ text $ show $ _mcDir mc )
-    )
-
---    <> translateSPz 20 (itSPic it)
---  where
---    it = _tuWeapon $ _mcType mc
-
-wdth :: Float
-wdth = 10

src/Dodge/Render/ShapePicture.hs

@@ -321,8 +321,8 @@ btSPic :: Button -> SPic
 btSPic bt = uncurryV translateSPf (_btPos bt)
     $ rotateSP (_btRot bt) (drawButton (_btPict bt) bt)
 mcSPic :: Machine -> SPic
-mcSPic bt = uncurryV translateSPf (_mcPos bt)
+mcSPic mc = uncurryV translateSPf (_mcPos mc)
-    $ rotateSP (_mcDir bt) (drawMachine (_mcDraw bt) bt)
+    $ rotateSP (_mcDir mc) (drawMachine mc)
 
 soundPic :: Configuration -> World -> Sound -> Picture
 soundPic cfig w s = fixedSizePicClampArrow 50 50 thePic p cfig w

src/Dodge/Terminal.hs

@@ -186,7 +186,7 @@ getSensor f tm w =
     maybe
         []
         (makeTermPara . map toUpper . show . f)
-        (w ^? cWorld . machines . ix (_tmMachineID tm) . mcSensor)
+        (w ^? cWorld . machines . ix (_tmMachineID tm) . mcType . _McSensor)
 
 toggleCommand :: TerminalCommand
 toggleCommand =