Work on textures and lighting

src/Dodge/Render/ShapePicture.hs

@@ -2,8 +2,6 @@ module Dodge.Render.ShapePicture (
     worldSPic,
 ) where
 
-import Dodge.Render.Picture
-import Dodge.Data.Universe
 import Control.Lens
 import Control.Monad (guard)
 import Data.Foldable
@@ -14,6 +12,7 @@ import qualified Data.Set as Set
 import Dodge.Base
 import Dodge.Creature.Picture
 import Dodge.Creature.Picture.Awareness
+import Dodge.Data.Universe
 import Dodge.Debug.Picture
 import Dodge.Draw
 import Dodge.Flare
@@ -25,6 +24,7 @@ import Dodge.RadarBlip
 import Dodge.Render.InfoBox
 import Dodge.Render.Label
 import Dodge.Render.List
+import Dodge.Render.Picture
 import Dodge.ShortShow
 import Dodge.SoundLogic.LoadSound
 import Dodge.Viewpoints
@@ -36,7 +36,7 @@ import Geometry.ConvexPoly
 import qualified IntMapHelp as IM
 import Padding
 import Picture
-import Polyhedra
+import Shape
 import ShapePicture
 import ShortShow
 import Sound.Data
@@ -108,21 +108,14 @@ drawCreature cr = case _crType cr of
                     ]
             )
             cr
-    Lampoid{_lampHeight = h} -> picAtCrPosNoRot1 (lampCrPic h) cr
+    Lampoid{_lampHeight = h} -> uncurryV translateSPxy (_crPos cr) $ lampCrSPic h
     NonDrawnCreature -> mempty
 
-lampCrPic :: Float -> Picture
-lampCrPic h =
-    pictures
-        [ setLayer BloomLayer (setDepth h . color white $ circleSolid 3)
-        , foldMap (polyToTris . map f) $ boxXYZnobase 5 5 (h -1)
-        ]
-  where
-    f pos = Verx (pos -.-.- V3 2.5 2.5 0) blue [] BottomLayer polyNum
-
-picAtCrPosNoRot1 :: Picture -> Creature -> SPic
---{-# INLINE picAtCrPos #-}
-picAtCrPosNoRot1 thePic cr = (,) mempty $ uncurryV translate (_crPos cr) thePic
+lampCrSPic :: Float -> SPic
+lampCrSPic h =
+    ( colorSH blue . upperBox h $ rectWH 5 5
+    , setLayer BloomLayer (setDepth h . color white $ circleSolid 3)
+    )
 
 picAtCrPos1 :: Picture -> Creature -> SPic
 --{-# INLINE picAtCrPos #-}
@@ -130,13 +123,13 @@ picAtCrPos1 thePic cr = (,) mempty $ tranRot (_crPos cr) (_crDir cr) thePic
 
 shiftDraw :: (a -> Point2) -> (a -> Float) -> (a -> a -> SPic) -> a -> SPic
 shiftDraw fpos fdir fdraw x =
-    uncurryV translateSPf (fpos x)
+    uncurryV translateSPxy (fpos x)
         . rotateSP (fdir x)
         $ fdraw x x
 
 shiftDraw' :: (a -> Point2) -> (a -> Float) -> (a -> SPic) -> a -> SPic
 shiftDraw' fpos fdir fdraw x =
-    uncurryV translateSPf (fpos x)
+    uncurryV translateSPxy (fpos x)
         . rotateSP (fdir x)
         $ fdraw x
 
@@ -366,17 +359,17 @@ ppDraw c = uncurryV translate (_ppPos c) $ rotate (_ppRot c) (_ppPict c)
 
 floorItemSPic :: FloorItem -> SPic
 floorItemSPic flit =
-    uncurryV translateSPf (_flItPos flit) $
+    uncurryV translateSPxy (_flItPos flit) $
         rotateSP (_flItRot flit) (itemSPic (_flIt flit))
 
 btSPic :: Button -> SPic
 btSPic bt =
-    uncurryV translateSPf (_btPos bt) $
+    uncurryV translateSPxy (_btPos bt) $
         rotateSP (_btRot bt) (drawButton (_btPict bt) bt)
 
 mcSPic :: Machine -> SPic
 mcSPic mc =
-    uncurryV translateSPf (_mcPos mc) $
+    uncurryV translateSPxy (_mcPos mc) $
         rotateSP (_mcDir mc) (drawMachine mc)
 
 soundPic :: Configuration -> World -> Sound -> Picture