Add tank furniture, stop autorotate when aiming

src/Dodge/Data.hs

@@ -554,16 +554,8 @@ data Wall
         , _wlSeen :: Bool
         , _wlIsSeeThrough :: Bool
         , _wlPathable :: Bool
-        }
+        , _wlDraw :: Bool
-    | BlockAutoDoor 
+        , _wlRotateTo :: Bool
-        { _wlLine :: (Point2,Point2) 
-        , _wlID :: Int 
-        , _doorMech :: World -> World
-        , _wlColor :: Color
-        , _wlSeen :: Bool
-        , _blIDs :: [Int]
-        , _blHP :: Int
-        , _wlIsSeeThrough :: Bool
         }
     | Block 
         { _wlLine :: (Point2,Point2)
@@ -576,6 +568,8 @@ data Wall
         , _blVisible :: Bool
         , _blDegrades :: [Int]
         , _blShadows :: [Int]
+        , _wlDraw :: Bool
+        , _wlRotateTo :: Bool
         }
 data ForceField = FF 
     { _ffLine :: [Point2] , _ffID :: Int 

src/Dodge/Default/Wall.hs

@@ -12,10 +12,28 @@ defaultWall = Wall
     , _wlSeen = False
     , _wlIsSeeThrough = False
     , _wlPathable = False
+    , _wlDraw = True
+    , _wlRotateTo = True
     }
+defaultBlock :: Wall
+defaultBlock = Block
+    { _wlLine = (V2 0 0,V2 50 0)
+    , _wlID = 0
+    , _wlColor = greyN 0.5
+    , _wlSeen = False
+    , _blIDs = []
+    , _blHP = 5
+    , _wlIsSeeThrough = False
+    , _blVisible = True
+    , _blShadows = []
+    , _blDegrades = [20,20]
+    , _wlDraw = True
+    , _wlRotateTo = True
+    }
+
 {- Indestructible see-through wall.  -}
 defaultCrystalWall :: Wall
-defaultCrystalWall = Wall 
+defaultCrystalWall = defaultWall 
     { _wlLine = (V2 0 0,V2 50 0)
     , _wlID = 0
     , _wlColor = withAlpha 0.5 aquamarine

src/Dodge/Floor.hs

@@ -81,8 +81,8 @@ initialRoomTree = do
 ---                    ,[DoorNumAno 0,AirlockAno]] 
 ---                    ]
 ---            ,[FirstWeapon]
-            ,[CorridorDebug]
+---            ,[CorridorDebug]
-            ,[SpecificRoom $ fmap (pure . Right) randomFourCornerRoom]
+---            ,[SpecificRoom $ fmap (pure . Right) randomFourCornerRoom]
             ,[Corridor]
             ,[OrAno 
                 [[SpecificRoom $ branchRectWith $ fmap (fmap Left) armouredChasers]

src/Dodge/Item/Weapon.hs

@@ -430,12 +430,10 @@ miniGun = defaultAutoGun
 miniGunPictItem :: Item -> SPic
 miniGunPictItem it = miniGunPict spin (loadedAmmo it)
   where
-    spin = 10 * _wpLoadedAmmo it + _wpCurWarmUp it
+    spin = (-10) * _wpLoadedAmmo it + _wpCurWarmUp it
-
 
 miniGunPict :: Int -> Int -> SPic
 miniGunPict spin am = 
-    --(   ( rotateSHx a .translateSH (V3 5 0 (-9)) .  colorSH red $ upperPrismPoly 18 $ rectNESW 9 7 (-9) (-5))
     (   colorSH red (rotateSHx a barrels)
         <> colorSH red (upperPrismPoly 5 $ rectNESW 8 8 (-8) 4)
         <> colorSH red (prismPoly 
@@ -452,7 +450,7 @@ miniGunPict spin am =
         (map (addZ 0) $ rectNESW 4 12 (-4) (-5))
     barrels = concatMap (\an -> aBarrel & rotateSHx an) [0,0.5* pi, pi, 1.5*pi]
     a = fromIntegral spin / 100
-    x = fromIntegral am / 20
+    x = fromIntegral am / 10
     clip y z = translateSH (V3 0 (-1) z) (rotateSHx (negate $ pi/4) 
         . upperPrismPoly 2 
         $ rectNESW (negate $ 3 + 0.25 * x) y 3 (y-5))

src/Dodge/LevelGen/Block.hs

@@ -122,6 +122,8 @@ addBlock (p:ps) hp col isSeeThrough degradability w
             , _blVisible = True
             , _blShadows = []
             , _blDegrades = degradability
+            , _wlDraw = True
+            , _wlRotateTo = True
             }
         ) is lns
     wallInZone wl 

src/Dodge/LevelGen/TriggerDoor.hs

@@ -8,6 +8,7 @@ module Dodge.LevelGen.TriggerDoor
 import Dodge.Data
 import Dodge.Base
 import Dodge.Zone
+import Dodge.Default.Wall
 import Dodge.LevelGen.Switch
 import Dodge.LevelGen.Pathing
 import Dodge.LevelGen.MoveDoor
@@ -66,7 +67,7 @@ putDoor col cond pss w = (drid, addWalls w & doors %~ addDoor)
     wlids = take 4 [IM.newKey $ _walls w ..]
     wlps' = uncurry (rectanglePairs 9) $ head pss
     addWalls w' = foldl' addWall w' $ zip wlids wlps'
-    addWall w' (wlid, wlps) = w' & walls %~ IM.insert wlid Wall
+    addWall w' (wlid, wlps) = w' & walls %~ IM.insert wlid defaultWall
         { _wlLine = wlps
         , _wlID = wlid
         , _wlColor = col
@@ -142,7 +143,7 @@ putSingleDoor isPathable col cond a b speed w = (drid, addWalls w
         , _drMech   = doorMechanism drid speed (zip3 wlids shiftedPairs pairs)
         }
     addWalls w' = foldl' addWall w' $ zip wlids pairs
-    addWall w' (wlid, wlps) = w' & walls %~ IM.insert wlid Wall
+    addWall w' (wlid, wlps) = w' & walls %~ IM.insert wlid defaultWall
         { _wlLine = wlps
         , _wlID = wlid
         , _wlColor = col

src/Dodge/LightSources/Fitting.hs

@@ -7,23 +7,23 @@ import Geometry
 
 mountedLight :: Point2 -> Point3 -> Placement
 mountedLight wallPos lampPos@(V3 x y z) 
-    = Placement (PS (V2 0 0) 0 $ PutForeground $ thinHighBar (z+5) wallPos pout)
+    = ps0j (PutForeground $ thinHighBar (z+5) wallPos pout)
-    $ \_ -> Just $ sPS (V2 0 0) 0 $ PutLS (colorLightAt 0.75 lampPos 0)
+    $ sps0 $ PutLS (colorLightAt 0.75 lampPos 0)
   where
     pout = V2 x y +.+ safeNormalizeV (V2 x y -.- wallPos)
 
-wallMountL :: Point2 -> Point3 -> Placement
+mountLightL :: Point2 -> Point3 -> Placement
-wallMountL wallpos lamppos@(V3 x y z)
+mountLightL wallpos lamppos@(V3 x y z)
-    = ps0 (PutLS $ colorLightAt 0.75 lamppos 0)
+    = ps0j (PutLS $ colorLightAt 0.75 lamppos 0)
-    $ \_ -> jsps0 $ PutForeground $ thinHighBar (z + 5) wallposUp (turnpos `extendAway` wallposUp)
+    $ sps0 $ PutForeground $ thinHighBar (z + 5) wallposUp (turnpos `extendAway` wallposUp)
         <> thinHighBar (z + 5) turnpos (V2 x y `extendAway` turnpos)
   where
     n = vNormal (wallpos -.- V2 x y)
     wallposUp = wallpos +.+ n
     turnpos = V2 x y +.+ n
 
-wallMountJ :: Point2 -> Point3 -> Placement
+mountedLightJ :: Point2 -> Point3 -> Placement
-wallMountJ wallpos lamppos@(V3 x y z)
+mountedLightJ wallpos lamppos@(V3 x y z)
     = ps0 (PutLS $ colorLightAt 0.75 lamppos 0)
     $ \_ -> jsps0 $ PutForeground $ thinHighBar (z + 5) wallposUp turn1
         <> thinHighBar (z + 5) turn1 turn2
@@ -46,13 +46,19 @@ wallMountl wallpos lamppos@(V3 x y z)
     wallposUp = wallpos +.+ n
     turnpos = V2 x y +.+ n
 
-wallMountA :: Point2 -> Point3 -> Placement
+mountLightA :: Point2 -> Point3 -> Placement
-wallMountA wallpos lamppos@(V3 x y z)
+mountLightA wallpos lamppos@(V3 x y z)
     = ps0 (PutLS $ colorLightAt 0.75 lamppos 0)
     $ \_ -> jsps0 $ PutForeground $ girder (z+10) 20 10 pout wallpos
   where
     pout = V2 x y -.- 2 *.* safeNormalizeV (V2 x y -.- wallpos)
 
+mountColLightI :: Point3 -> Float -> Point2 -> Point2 -> Placement
+mountColLightI col h a b = ps0j (PutLS $ colorLightAt col (V3 x y h) 0)
+    $ sps0 $ PutForeground $ highPipe (h + 5) a b
+  where
+    V2 x y = 0.5 *.* (a +.+ b)
+
 mountedLightI :: Float -> Point2 -> Point2 -> Placement
 mountedLightI h a b = ps0j (PutLS $ lightAt (V3 x y h) 0)
     $ sps0 $ PutForeground $ highPipe (h + 5) a b

src/Dodge/Render/Picture.hs

@@ -259,7 +259,7 @@ wallsAndWindows w
     = (map f wls, map f $ filter (fromMaybe True . (^? blVisible)) wins)
   where
     f wl = (_wlLine wl, _wlColor wl)
-    (wins,wls) = partition _wlIsSeeThrough . IM.elems $ wallsDoubleScreen w
+    (wins,wls) = partition _wlIsSeeThrough . IM.elems . IM.filter _wlDraw $ wallsDoubleScreen w
     --(wins,wls) = partition _wlIsSeeThrough . IM.elems $ wallsOnScreen w
 
 wallsToList :: [((Point2,Point2),Point4)] -> [Float]

src/Dodge/Room/Boss.hs

@@ -5,6 +5,7 @@ module Dodge.Room.Boss
   where
 import Dodge.Data
 import Dodge.Default.Room
+import Dodge.LightSources.Fitting
 import Dodge.Room.Data
 import Dodge.Room.Procedural
 import Dodge.Room.Placement
@@ -97,10 +98,8 @@ roomCross x y = defaultRoom
         ]
     , _rmPath  = []
     , _rmPS = 
-        [sPS (V2  x  0) 0 putLamp
+        [ mountedLightI 70 (V2 (x+5) x) (V2 (x+5) (-x))
-        ,sPS (-V2 x  0) 0 putLamp
+        , mountedLightI 70 (V2 (-x-5) x) (V2 (-x-5) (-x))
-        ,sPS (V2  0  x) 0 putLamp
-        ,sPS (V2  0 (-x)) 0 putLamp
         ]
     , _rmBound = 
         [rectNSWE y (-y) (-x) x
@@ -123,7 +122,7 @@ roomShuriken x y =
             { _rmPolys  = ps
             , _rmLinks  = [(V2 (x-1) (y-20),negate $ pi/2)]
             , _rmPath   = []
-            , _rmPS     = [sPS (V2 (x/2) (x/2)) 0 putLamp]
+            , _rmPS     = [mountedLight (V2 x x) (V3 (x-20) x 70)]
             , _rmBound  = ps
             }
     in foldr1 combineRooms $ map (\r -> shiftRoomBy (V2 0 0, r) corner) [0,pi/2,pi,3*pi/2]
@@ -147,7 +146,7 @@ roomTwistCross x y z =
             { _rmPolys  = ps
             , _rmLinks  = [(V2 z (y-20), pi/2)]
             , _rmPath   = []
-            , _rmPS     = [sPS (V2 (x/2) (x/2)) 0 putLamp]
+            , _rmPS     = [mountedLight (V2 x x) (V3 (x-20) (x-20) 70)]
             , _rmBound  = ps
             }
     in foldr1 combineRooms $ map (\r -> shiftRoomBy (V2 0 0, r) corner) [0,pi/2,pi,3*pi/2]

src/Dodge/Room/Foreground.hs

@@ -127,3 +127,19 @@ girder h d w x y = colorSH red $ mconcat $
     yt = y -.- n
     ps = divideLineExact d xb yb
     qs = divideLineExact d xt yt
+
+robotArm :: Shape
+robotArm = undefined
+
+pipePP :: Float -> Point3 -> Point3 -> Shape
+pipePP w a b = prismPoly
+    (map ((+.+.+ a) . addZ 0) $ polyCirc 4 w)
+    (map ((+.+.+ b) . addZ 0) $ polyCirc 4 w)
+
+tankTopPipe :: Shape
+tankTopPipe = colorSH orange $ 
+    upperPrismPoly 31 (polyCirc 4 20)
+    <> prismPoly 
+        (map (addZ 41) $ polyCirc 4 5)
+        (map (addZ 31) $ polyCirc 4 20)
+--    <> pipePP 5 (V3 0 0 51) (V3 0 0 41)

src/Dodge/Room/Furniture.hs

@@ -0,0 +1,97 @@
+module Dodge.Room.Furniture
+    where
+import Dodge.Data
+import Dodge.LevelGen
+import Dodge.LevelGen.Data
+import Dodge.Room.Foreground
+import Dodge.Default.Wall
+import Geometry
+import Shape
+import Color
+
+roundTankTopRail :: Color -> Float -> Float -> Placement
+roundTankTopRail col x y = shiftPlacement (V2 x y,0) $ ps0j 
+    (PutForeground $ colorSH col $ 
+        upperPrismPoly 31 thecircle
+        <> foldMap toprail ( take 8 [0,pi/4..]) 
+    )
+    $ sps0 $ PutWall thecircle defaultWall {_wlDraw = False, _wlColor = col, _wlRotateTo = False}
+  where
+    toprail a = rotateSH a $ thinHighBar 31 (V2 0 20) (rotateV (pi/4) $ V2 0 20)
+    thecircle = polyCirc 4 20
+
+roundTankCross :: Color -> Float -> Float -> Placement
+roundTankCross col x y = shiftPlacement (V2 x y,0) $ ps0j 
+    (PutForeground $ colorSH col $ 
+        upperPrismPoly 31 thecircle
+        <> thinHighBar 31 (V2 20 0) (V2 (-20) 0)
+        <> thinHighBar 31 (V2 0 20) (V2 0 (-20))
+    )
+    $ sps0 $ PutWall thecircle defaultWall {_wlDraw = False, _wlColor = col, _wlRotateTo = False}
+  where
+    thecircle = polyCirc 4 20
+
+tankRectCross :: Float -> Float -> Color -> Float -> Float -> Placement
+tankRectCross w h col x y = shiftPlacement (V2 x y,0) $ ps0j
+    (PutForeground $ colorSH col $
+        upperPrismPoly 31 therect
+        <> thinHighBar 31 (V2 w 0) (V2 (-w) 0)
+        <> thinHighBar 31 (V2 0 h) (V2 0 (-h))
+    )
+    $ sps0 $ PutWall therect defaultWall {_wlDraw = False, _wlColor = col, _wlRotateTo = False}
+  where
+    therect = rectWH w h
+
+tankSquareCross :: Color -> Float -> Float -> Placement
+tankSquareCross = tankRectCross 20 20
+
+tankRect :: Float -> Float -> Color -> Float -> Float -> Placement
+tankRect w h col x y = shiftPlacement (V2 x y,0) $ ps0j
+    (PutForeground $ colorSH col $
+        upperPrismPoly 31 therect
+        <> foldMap f [(w',-w',h',h'),(w',-w',-h',-h'),(w',w',h',-h'),(-w',-w',h',-h')]
+    )
+    $ sps0 $ PutWall therect defaultWall {_wlDraw = False, _wlColor = col, _wlRotateTo = False}
+  where
+    therect = rectWH w h
+    w' = w - 1.5
+    h' = h - 1.5
+    f (a,b,c,d) = thinHighBar 31 (V2 a b) (V2 c d)
+
+tankSquare :: Color -> Float -> Float -> Placement
+tankSquare = tankRect 20 20
+
+tankRectEmboss :: Float -> Float -> Color -> Float -> Float -> Placement
+tankRectEmboss w h col x y = shiftPlacement (V2 x y,0) $ ps0j
+    (PutForeground $ colorSH col $
+        upperPrismPoly 31 therect
+        <> embossingR
+        <> rotateSH pi embossingR
+        <> thinHighBar 38 (V2 (-0.3*w) 0) (V2 (0.3*w) 0)
+    )
+    $ sps0 $ PutWall therect defaultWall {_wlDraw = False, _wlColor = col, _wlRotateTo = False}
+  where
+    w' = 0.3 * w
+    therect = rectWH w h
+    embossingR = prismPoly 
+        [V3 w h 31,V3 w (0.3*h) 41,V3 w (-0.3*h) 41,V3 w (-h) 31]
+        [V3 w' h 31,V3 w' (0.3*h) 41,V3 w' (-0.3*h) 41,V3 w' (-h) 31]
+
+
+tankSquareEmboss :: Color -> Float -> Float -> Placement
+tankSquareEmboss = tankRectEmboss 20 20
+
+tankRectEmboss4 :: Float -> Float -> Color -> Float -> Float -> Placement
+tankRectEmboss4 w h col x y = shiftPlacement (V2 x y,0) $ ps0j
+    (PutForeground $ colorSH col $
+        upperPrismPoly 31 therect
+        <> foldMap f [(w,h),(-w,h),(w,-h),(-w,-h)]
+    )
+    $ sps0 $ PutWall therect defaultWall {_wlDraw = False, _wlColor = col, _wlRotateTo = False}
+  where
+    therect = rectWH w h
+    f (a,b) = translateSH (V3 (a/2) (b/2) 31) embossing
+    embossing = upperPrismPolyHalf 10 $ rectNSEW (h/2) (-h/2) (w/2) (-w/2)
+
+tankSquareEmboss4 :: Color -> Float -> Float -> Placement
+tankSquareEmboss4 = tankRectEmboss4 20 20

src/Dodge/Room/Placement.hs

@@ -91,7 +91,7 @@ windowLineType :: Point2 -> Point2 -> PSType
 windowLineType = PutLineBlock baseWindowPane 8 8
 
 baseBlockPane :: Wall
-baseBlockPane = Block
+baseBlockPane = defaultBlock
     { _wlLine = (V2 0 0,V2 50 0)
     , _wlID = 0
     , _wlColor = greyN 0.5
@@ -102,9 +102,10 @@ baseBlockPane = Block
     , _blVisible = True
     , _blShadows = []
     , _blDegrades = [20,20]
+    , _wlDraw = True
     }
 baseWindowPane :: Wall
-baseWindowPane = Block
+baseWindowPane = defaultBlock
     { _wlLine = (V2 0 0,V2 50 0)
     , _wlID = 0
     , _wlColor = withAlpha 0.2 cyan
@@ -115,6 +116,7 @@ baseWindowPane = Block
     , _blVisible = True
     , _blShadows = []
     , _blDegrades = [5,5]
+    , _wlDraw = True
     }
 {- Replaces instances of a given 'PutID' with 'PSType's drawn from a list.  -}
 replacePutID 

src/Dodge/Room/Procedural.hs

@@ -48,7 +48,7 @@ roomRect x y xn yn = defaultRoom
     { _rmPolys = [rectNSWE  y 0 0 x ]
     , _rmLinks = lnks
     , _rmPath  = concatMap doublePair pth
-    , _rmPS    = [wallMountL (V2 (x/2) 0) (V3 (x/2) 40 50)]
+    , _rmPS    = [mountLightA (V2 (x/2) 0) (V3 (x/2) 40 50)]
     , _rmBound = [rectNSWE (y+5) (-5) (-5) (x+5)]
     , _rmFloor = [Tile 
             { _tilePoly = rectNSWE y 0 0 x

src/Dodge/Room/RoadBlock.hs

@@ -43,6 +43,7 @@ litCorridor90 = do
             ]
         , _rmPS    = 
             [ sPS (V2 20 (h-5)) 0     putLamp
+            , mountedLightI 70 (V2 0 (0.4*h)) (V2 40 (0.4*h))
             , windowLine (V2 0 (h-20)) (V2 40 (h-20))
             , sPS (V2 (-50) (h-85)) 0   putLamp
             , windowLine (V2 (-40) (h-60)) (V2 (-40) (h-100))

src/Dodge/Room/Start.hs

@@ -4,13 +4,13 @@ import Dodge.Room.Data
 import Dodge.Room.Door
 import Dodge.Room.Link
 import Dodge.Room.Procedural
---import Dodge.Room.Placement
 import Dodge.Room.Foreground
+import Dodge.Room.Furniture
 import Dodge.Layout.Tree.Polymorphic
 import Dodge.LevelGen.Data
 import Dodge.LightSources.Fitting
---import Picture
 import Geometry.Data
+import Color
 
 import Data.Tree
 import Control.Monad.State
@@ -18,7 +18,8 @@ import Control.Lens
 import System.Random
 
 rezBox :: Room
-rezBox = shiftRoomBy (V2 (-20) (-10),0) $ roomRect 40 20 1 1 & rmPS .~ []
+rezBox = shiftRoomBy (V2 (-20) (-10),0) $ roomRect 40 20 1 1 
+    & rmPS .~ [ mountColLightI (V3 0 0.7 0.2) 70 (V2 0 10) (V2 40 10) ]
 
 startRoom :: RandomGen g => State g (Tree (Either Room Room))
 startRoom = do
@@ -32,6 +33,8 @@ startRoom = do
         <$> randomiseOutLinks (shiftRoomBy (V2 (-20) (-20),0) 
                 $ roomRectAutoLinks w h & rmPS .~ 
             [ fground
-            , wallMountJ (V2 0 (h/3)) (V3 40 (h/3) 70)
+            , mountedLightJ (V2 0 (h/3)) (V3 40 (h/3) 70)
+            , tankSquareEmboss4 (dim orange) 50 (h-60)
+            , tankSquareEmboss4 (dim orange) 50 50
             ]
             )

src/Dodge/Room/Treasure.hs

@@ -9,6 +9,7 @@ import Dodge.Room.Data
 import Dodge.Room.Placement
 import Dodge.Default.Room
 import Dodge.LevelGen.Data
+import Dodge.LightSources.Fitting
 import Geometry
 
 --import Data.List
@@ -32,9 +33,7 @@ triLootRoom w h = pure $ defaultRoom
         [sPS (V2 (15-w)    15 )  0 $ PutID 0
         ,sPS (V2 (w-15)    15 ) pi $ PutID 0
         ,sPS (V2     0  (h-35))  0 $ PutID 2
-        ,sPS (V2 (  -5) (h-10))  0 putLamp
+        ,mountedLightV (V2 0 (h-20)) (V3 0 (h-80) 70)
-        ,sPS (V2     5  (h-10))  0 putLamp
-        ,sPS (V2     0  (h-15))  0 putLamp
         ,sPS (V2     0  ( -60))  0 putLamp
         ]
     , _rmBound  = [tri , base]

src/Dodge/Update.hs

@@ -25,6 +25,7 @@ import Dodge.Floor
 import Geometry
 import Geometry.Vector3D
 
+import SDL (MouseButton (..))
 import Data.List
 import Data.Maybe
 import Data.Function
@@ -251,7 +252,8 @@ crCrSpring c1 c2 w
 
 ifConfigWallRotate :: World -> World
 ifConfigWallRotate w
-    | _rotate_to_wall $ _config w = rotateToOverlappingWall w
+    | (_rotate_to_wall $ _config w ) && not (ButtonRight `S.member` _mouseButtons w)
+        = rotateToOverlappingWall w
     | otherwise = w
 
 rotateToOverlappingWall :: World -> World
@@ -269,7 +271,7 @@ rotateToOverlappingWall w = case theWall of
         b' = fromIntegral (round b :: Int)
     cr = you w
     p = _crPos cr
-    theWall = overlapCircWallsReturnWall p (_crRad cr + 5) (wallsNearPoint p w)
+    theWall = overlapCircWallsReturnWall p (_crRad cr + 5) (IM.filter _wlRotateTo $ wallsNearPoint p w)
 
 {-
 Finds the IDs of visible walls from a point to another point.  -}