Fix bug when forming convex hull of game room bounds

src/Dodge/Creature/Inanimate.hs

@@ -21,6 +21,7 @@ import Geometry
 --import Geometry.Data
 import Geometry.Vector3D
 import Polyhedra
+import Shape
 
 import Control.Lens
 import qualified Control.Foldl as L
@@ -119,11 +120,10 @@ explosiveBarrel :: Creature
 explosiveBarrel = defaultInanimate
     { _crUpdate = updateExpBarrel
     , _crHP = 400
-    , _crPict = picAtCrPos $ pictures 
-        [ color red $ circleSolid 8
-        , setDepth 0.049 . color (greyN 0.5) $ circleSolid 10
-        , color orange $ circleSolid 10
-        ]
+    , _crPict = shapeAtCrPos
+        . colorSH orange
+        . upperPrismPoly 20
+        $ polyCirc 4 10
     , _crState = defaultState 
         {_crSpState = Barrel []
         }

src/Dodge/Creature/Picture.hs

@@ -6,6 +6,7 @@ module Dodge.Creature.Picture
     ( basicCrPict
     , circLine
     , picAtCrPos
+    , shapeAtCrPos
     , picAtCrPosNoRot
     ) where
 import Dodge.Data
@@ -47,6 +48,12 @@ basicCrPict col cr w = (,) (basicCrShape col cr) $ pictures $
     tr = uncurryV translate (_crPos cr) 
     rotdir = rotate (_crDir cr)
 
+shapeAtCrPos :: Shape -> Creature -> World -> SPic
+shapeAtCrPos sh cr _ = 
+    ( uncurryV translateSHf (_crPos cr) $ rotateSH (_crDir cr) sh
+    , mempty
+    )
+
 basicCrShape 
     :: Color    -- ^ Creature color
     -> Creature 

src/Dodge/Default/Room.hs

@@ -13,4 +13,5 @@ defaultRoom = Room
     , _rmFloor  = []
     , _rmName   = "defaultRoom"
     , _rmShift  = (V2 0 0 , 0)
+    , _rmViewpoints = []
     }

src/Dodge/Item/Weapon/AutoGun.hs

@@ -66,7 +66,7 @@ autoGun = defaultAutoGun
 autoGunPic :: SPic
 autoGunPic =
     ( colorSH red $ prismPoly 
-        (map (addZ 5) $ rectNESW 2 12 (-2) (-12))
+        (map (addZ 5) $ rectNESW 2 12 (-2) (-8))
         (map (addZ 0) $ rectNESW 4 12 (-4) (-12))
     , mempty
     )

src/Dodge/Layout.hs

@@ -25,6 +25,7 @@ import Tile
 import Polyhedra
 import Polyhedra.Data
 
+import Data.List (nub)
 import Control.Monad.State
 import Control.Lens
 import System.Random
@@ -120,9 +121,9 @@ gameRoomsFromRooms :: [Room] -> [GameRoom]
 gameRoomsFromRooms = map f
   where
     f rm = GameRoom
-        { _grViewpoints = map fst . foldl' (flip cutWalls) [] $ _rmPolys rm
+        { _grViewpoints = _rmViewpoints rm ++ (map fst . foldl' (flip cutWalls) [] $ _rmPolys rm)
         , _grViewpointsEx = map fst (_rmLinks rm)
-        , _grBound = expandPolyByFixed 100 $ orderPolygon $ convexHullSafe $ concat $ _rmBound rm ++ _rmPolys rm
+        , _grBound = expandPolyByFixed 100 . convexHullSafe . nub . concat $ _rmBound rm ++ _rmPolys rm
         , _grDir   = snd . last $ _rmLinks rm
         , _grName  = _rmName rm
         }

src/Dodge/LevelGen.hs

@@ -124,7 +124,7 @@ placeProp pr p a w = (i, w & props %~ addProp)
   where 
     i = IM.newKey $ _props w
     addProp prs = IM.insert i (f pr) prs
-    f = (pjRot +~ a) . (pjPos %~ ( (p +.+) . (rotateV a) )) . (pjID .~ i)
+    f = (pjRot +~ a) . (pjPos %~ ( (p +.+) . rotateV a )) . (pjID .~ i)
 
 placeBt 
     :: Button
@@ -136,7 +136,7 @@ placeBt bt p a w = (i , over buttons addBT w)
   where 
     i = IM.newKey $ _buttons w
     addBT xs = IM.insert i (f bt) xs
-    f = (btRot +~ a) . (btPos %~ ( (p +.+) . (rotateV a) )) . (btID .~ i)
+    f = (btRot +~ a) . (btPos %~ ( (p +.+) . rotateV a )) . (btID .~ i)
     --addBT bts = IM.insert (IM.newKey bts) (bt {_btPos = p, _btRot = rot, _btID = IM.newKey bts}) bts
 {- Creates a floor item at a given point.
 Assigns an id correctly.  -}

src/Dodge/Render.hs

@@ -232,6 +232,7 @@ doDrawing pdata w = do
             activeTexture $= TextureUnit 1
             zipWithM_ (>>) bindings $ map bindDrawDist rds
             activeTexture $= TextureUnit 0
+    renderLayer 5 shadV layerCounts
     -- draw overlay
     depthFunc $= Just Always
     depthMask $= Disabled

src/Dodge/Render/Picture.hs

@@ -2,6 +2,8 @@
 module Dodge.Render.Picture
   where
 import Dodge.Data
+import Dodge.Update.Camera
+import Dodge.GameRoom
 import Dodge.Base
 import Dodge.Base.Window
 import Dodge.Zone
@@ -62,10 +64,11 @@ customMouseCursor w =
     $ pictures [ line [V2 (-5) 0,V2 5 0] , line [V2 0 (-5),V2 0 5] ]
 
 testPic :: World -> Picture
-testPic _ = pictures 
-    [
---    , fixedSizePicClampArrow 10 50 thepic (mouseWorldPos w) w
-    ]
+testPic w = setLayer 5 $ color green (concatMap (polygonWire . _grBound) grs)
+    <> color yellow (concatMap (\q -> line [p,q]) $ farWallPoints p w)
+  where
+    p = _crPos $ you w
+    grs = filter (pointInOrOnPolygon p . _grBound) (_gameRooms w)
 --  where
 --    thepic = setDepth 20 . color green . polygon $ rectNSEW 5 (-5) (-5) (5)
 --testPic _ = blank

src/Dodge/Room/Data.hs

@@ -25,5 +25,6 @@ data Room = Room
     , _rmFloor  :: [Tile]
     , _rmName   :: String
     , _rmShift  :: (Point2, Float)
+    , _rmViewpoints :: [Point2]
     }
 makeLenses ''Room

src/Dodge/Room/Link.hs

@@ -76,6 +76,7 @@ shiftRoomBy shift r = r
         . (tileZero %~ shiftPointBy shift    )
         . (tileX    %~ shiftPointBy shift         )
         )
+    & rmViewpoints %~ map (shiftPointBy shift)
 
 shiftLinkBy 
     :: (Point2,Float) 

src/Dodge/Room/LongDoor.hs

@@ -48,6 +48,7 @@ twinSlowDoorRoom w h x = defaultRoom
         ]
     , _rmBound  = ps
     , _rmName   = "twinSlowDoorRoom"
+    , _rmViewpoints = [V2 0 h]
     }
   where
     wlSpeed = 0.5
@@ -62,7 +63,7 @@ twinSlowDoorRoom w h x = defaultRoom
         [rectNSWE h    0 (-w) w
         ,rectNSWE 20 (-h) (negate x) x
         ]
-    cond' btid w' = (_btState $ _buttons w' IM.! btid) == BtOn
+    cond' btid w' = _btState (_buttons w' IM.! btid) == BtOn
     col = dim $ dim $ bright red
 
 twinSlowDoorChasers 

src/Dodge/Update/Camera.hs

@@ -4,6 +4,7 @@ Functions controlling the movement of the screen camera:
 and the position that the character sees from: '_cameraViewFrom'.  -}
 module Dodge.Update.Camera 
     ( updateCamera
+    , farWallPoints
     ) 
     where
 import Dodge.Data
@@ -176,6 +177,14 @@ farWallDist p w = (winFac /) . min maxViewDistance $ ssfold (> maxViewDistance)
     grs = filter (pointInOrOnPolygon p . _grBound) (_gameRooms w)
     wos = wallsOnScreen w
 
+farWallPoints :: Point2 -> World -> [Point2]
+farWallPoints p w = concatMap _grViewpoints grs ++ linkvps
+  where
+    grs = filter (pointInOrOnPolygon p . _grBound) (_gameRooms w)
+    linkvps = map extend (concatMap _grViewpointsEx grs)
+    extend :: Point2 -> Point2
+    extend outp = p +.+ maxViewDistance *.* safeNormalizeV (outp -.- p)
+
 --farWallDist :: Point2 -> World -> Float
 --farWallDist p w = (winFac /) $ fromMaybe maxViewDistance 
 --    $ L.fold (L.premap (dist p) L.maximum) vdists

src/Geometry.hs

@@ -121,6 +121,10 @@ orderPolygonAround
 orderPolygonAround _ [] = []
 orderPolygonAround cen ps = sortOn (\p -> argV (p -.- cen)) ps
 
+orderAroundFirstReverse :: [Point2] -> [Point2]
+orderAroundFirstReverse [] = []
+orderAroundFirstReverse (a:as) = a : reverse (orderPolygonAround a as)
+
 orderAroundFirst :: [Point2] -> [Point2]
 orderAroundFirst [] = []
 orderAroundFirst (a:as) = a : orderPolygonAround a as
@@ -141,8 +145,9 @@ convexHull :: [Point2] -> [Point2]
 convexHull (x:y:z:xs) = grahamScan $ orderAroundFirst $ sortOn (\(V2 a b) -> (b,a)) (x:y:z:xs)
 convexHull _ = error "Tried to create the convex hull of two or fewer points"
 -- | Creates the convex hull of a set of points.
--- it appears that the output may NOT be ordered
+-- assumes no repetition of points: try nubbing!
 convexHullSafe :: [Point2] -> [Point2]
+--convexHullSafe (x:y:z:xs) = grahamScan $ orderAroundFirst $ sortOn (\(V2 a b) -> (b,a)) (x:y:z:xs)
 convexHullSafe (x:y:z:xs) = grahamScan $ orderAroundFirst $ sortOn (\(V2 a b) -> (b,a)) (x:y:z:xs)
 convexHullSafe _ = []
 

src/Picture.hs

@@ -5,6 +5,7 @@ module Picture
     , module Color
     , blank
     , polygon
+    , polygonWire
     , polygonZ
     , polygonCol
     , poly3
@@ -56,6 +57,10 @@ blank :: Picture
 {-# INLINE blank #-}
 blank = []
 
+polygonWire :: [Point2] -> Picture
+{-# INLINE polygonWire #-}
+polygonWire ps = line (ps ++ [head ps])
+
 polygon :: [Point2] -> Picture
 {-# INLINE polygon #-}
 polygon ps = map f $ polyToTris ps