Working (but slow) shadow shapes

shader/lighting/cap.geom

@@ -3,6 +3,7 @@ layout (triangles) in;
 layout (triangle_strip, max_vertices = 3) out;
 layout (std140, binding = 0) uniform TheMat { mat4 theMat; } ;
 uniform vec3 lightPos;
+// this code is duplicated in lineShadow.geom, should not be changed on its own
 vec4 projNear (vec4 pos)
 {
     // note we project to a specific height

shader/lighting/lineShadow.geom

@@ -4,7 +4,7 @@ layout (triangle_strip, max_vertices = 4) out;
 layout (std140, binding = 0) uniform TheMat { mat4 theMat; } ;
 uniform vec3 lightPos;
 vec4 shift (vec4 p) { return (vec4 (p.xyz + (100000*(p.xyz-lightPos)), 1));}
-// copied from lighting/cap.geom
+// copied from lighting/cap.geom, should not be changed on its own
 vec4 projNear (vec4 pos)
 {
     // note we project to a specific height
@@ -21,13 +21,16 @@ vec4 shiftNear (vec4 pos)
     else
     { return sp ; }
 }
-
 vec4 f (vec4 p) {return (theMat * p);}
 void main()
 {
     vec4 p0 = gl_in[0].gl_Position;
-    vec3 n0 = gl_in[2].gl_Position.xyz;
+    vec4 p1 = gl_in[1].gl_Position;
-    vec3 n1 = gl_in[3].gl_Position.xyz;
+    vec3 n0a = gl_in[2].gl_Position.xyz;
+    vec3 n1a = gl_in[3].gl_Position.xyz;
+    vec3 n0 = cross(p1.xyz - p0.xyz, n0a - p0.xyz) ;
+    vec3 n1 = cross(p0.xyz - p1.xyz, n1a - p1.xyz) ;
+    
     //vec3 n2 = n0 + n1; // assumes the summands are normalized
     vec3 lightDir = p0.xyz - lightPos.xyz;
     // first test if the edge is part of the silhouette
@@ -35,7 +38,6 @@ void main()
     // "different directions" wrt the light direction
     if ( dot(n0 , lightDir) * dot(n1 , lightDir) < 0 )
     {
-        vec4 p1 = gl_in[1].gl_Position;
         vec4 p2 = shiftNear(p0);
         vec4 p3 = shiftNear(p1);
         if ( dot(n0 , lightDir) > 0)

src/Dodge/Creature.hs

@@ -27,7 +27,6 @@ import Dodge.Creature.SpreadGunCrit
 import Dodge.Creature.AutoCrit
 import Dodge.Creature.ChaseCrit
 import Dodge.Creature.ArmourChase
-import Dodge.Creature.Silhouette
 import Dodge.Data
 import Dodge.Default
 import Dodge.Item.Weapon
@@ -149,7 +148,6 @@ startCr = defaultCreature
     , _crMvDir  = pi/2
     , _crID = 0
     , _crPict = basicCrPict black
-    , _crSilhouette = basicCrSilhouette
     , _crUpdate = stateUpdate yourControl
     , _crRad = 10
     , _crMass = 10

src/Dodge/Creature/Picture.hs

@@ -22,6 +22,8 @@ import Dodge.Item.Data
 import Dodge.Clock
 import Picture
 import Geometry
+import Shape
+import ShapePicture
 --import Geometry.Vector3D
 
 import Control.Lens
@@ -32,11 +34,10 @@ basicCrPict
     :: Color    -- ^ Creature color
     -> Creature 
     -> World
-    -> Picture
+    -> SPic
-basicCrPict col cr w = pictures $
+basicCrPict col cr w = SPic (basicCrShape col cr w) $ pictures $
     targetingPic ++
-    [ tr . dm . rotdir $ scalp cr
+    [ tr . dm . rotdir $ upperBody col cr
-    , tr . dm . rotdir $ upperBody col cr
     , tr . dm . rotmdir $ feet cr
     , tr . rotdir $ drawEquipment cr
     , creatureDisplayText w cr
@@ -51,6 +52,24 @@ basicCrPict col cr w = pictures $
         . setDepth 1 
         . color (greyN 0.3)
 
+basicCrShape 
+    :: Color    -- ^ Creature color
+    -> Creature 
+    -> World
+    -> Shape
+basicCrShape col cr w = mconcat
+    [ tr . translateSHz 25 . dm . rotdir $ scalp cr
+    ]
+  where 
+    dm = damageModSH cr
+    targetingPic = IM.elems $ IM.mapMaybeWithKey f $ _crInv cr
+    f invid it = fmap ((\g -> g invid it cr w) . snd) (it ^? itTargeting . _Just)
+    tr = uncurryV translateSHf (_crPos cr)
+    rotdir = rotateSH (_crDir cr)
+    rotmdir = rotate (_crMvDir cr)
+        . setDepth 1 
+        . color (greyN 0.3)
+
 creatureDisplayText :: World -> Creature -> Picture
 creatureDisplayText w cr 
     = setLayer 4 
@@ -109,6 +128,8 @@ damageMod cr pic = piercingMod $ bluntScale pic
     piercingMod = case fmap argV piercingDam of
         Just a -> rotate (a + cdir) . scale 0.8 1.2 . rotate (negate $ cdir + a)
         _   -> id
+damageModSH :: Creature -> Shape -> Shape
+damageModSH cr = id
 
 feet :: Creature -> Picture
 feet cr = case cr ^? crStance . carriage of
@@ -148,14 +169,14 @@ arms cr
     sLen = _strideLength $ _crStance cr
     f i = negate 2 + negate 6 * fromIntegral (sLen - i) / fromIntegral sLen
 
-scalp :: Creature -> Picture
+scalp :: Creature -> Shape
 scalp cr
-    | twists cr = translate 0 (0.5*crad) . rotate (-1) $ translate (negate 0.25 * crad) 0.25 fhead
+    | twists cr = translateSHf 0 (0.5*crad) . rotateSH (-1) $ translateSHf (negate 0.25 * crad) 0.25 fhead
-    | oneH   cr = rotate 0.5 $ translate (0.25 * crad) 0 fhead
+    | oneH   cr = rotateSH 0.5 $ translateSHf (0.25 * crad) 0 fhead
-    | otherwise = translate (0.25 * crad) 0 fhead
+    | otherwise = translateSHf (0.25 * crad) 0 fhead
     
   where
-    fhead = setDepth 22 $ circleSolid $ crad * 0.5
+    fhead = colorSH (greyN 0.9) . prismPoly 5 . polyCirc $ crad * 0.5
     crad = _crRad cr
 
 oneH :: Creature -> Bool
@@ -232,10 +253,10 @@ drawEquipment cr = pictures $ map f $ IM.toList (_crInv cr)
 circLine :: Float -> Picture
 circLine x = line [V2 0 0,V2 x 0]
 
-picAtCrPos :: Picture -> Creature -> World -> Picture
+picAtCrPos :: Picture -> Creature -> World -> SPic
 --{-# INLINE picAtCrPos #-}
-picAtCrPos thePic cr _ = tranRot (_crPos cr) (_crDir cr) thePic
+picAtCrPos thePic cr _ = SPic empty $ tranRot (_crPos cr) (_crDir cr) thePic
 
-picAtCrPosNoRot :: Picture -> Creature -> World -> Picture
+picAtCrPosNoRot :: Picture -> Creature -> World -> SPic
 --{-# INLINE picAtCrPos #-}
-picAtCrPosNoRot thePic cr _ = uncurryV translate (_crPos cr) thePic
+picAtCrPosNoRot thePic cr _ = SPic empty $ uncurryV translate (_crPos cr) thePic

src/Dodge/Creature/Silhouette.hs

@@ -1,21 +0,0 @@
-module Dodge.Creature.Silhouette
-    ( creatureSilhouettes
-    , basicCrSilhouette
-    )
-    where
-import Dodge.Data
-import Polyhedra
-import Geometry
-
-import qualified Data.IntMap as IM
-
-creatureSilhouettes :: World -> [Point3]
-creatureSilhouettes w = concatMap f . IM.elems $ _creatures w
-  where
-    f cr = _crSilhouette cr cr
-
-basicCrSilhouette :: Creature -> [Point3]
-basicCrSilhouette cr = constructEdgesList . map (map f . polyToTris) $ boxXYZ 12 12 15
-  where
-    f = (+ V3 (x-6) (y-6) 0)
-    V2 x y = _crPos cr

src/Dodge/Data.hs

@@ -25,6 +25,7 @@ import Dodge.World.Trigger.Data
 import Dodge.Bounds
 import Data.Preload
 import Picture.Data
+import ShapePicture
 import Geometry.Data
 import Polyhedra.Data
 import Sound.Data
@@ -193,8 +194,7 @@ data Creature = Creature
     , _crOldDir         :: Float
     , _crMvDir          :: Float
     , _crID             :: Int
-    , _crPict           :: Creature -> World -> Picture
+    , _crPict           :: Creature -> World -> SPic
-    , _crSilhouette     :: Creature -> [Point3]
     , _crUpdate     
         :: Creature 
         -> World 

src/Dodge/Default.hs

@@ -19,6 +19,8 @@ import Dodge.SoundLogic.LoadSound
 import Dodge.Picture.Layer
 import Geometry
 import Picture
+import ShapePicture
+import Shape
 
 import Control.Lens
 import qualified Data.IntMap.Strict as IM
@@ -34,8 +36,7 @@ defaultCreature = Creature
     , _crOldDir = 0
     , _crMvDir  = 0
     , _crID     = 1
-    , _crPict   = \_ _ -> setLayer 0 $ onLayer CrLayer $ circleSolid 10
+    , _crPict   = \_ _ -> SPic (flatCirc 10) blank
-    , _crSilhouette = const []
     , _crUpdate = \cr _ -> (Endo id , Just cr)
     , _crRad    = 10
     , _crMass   = 10

src/Dodge/Initialisation.hs

@@ -13,6 +13,8 @@ import Dodge.SoundLogic
 import Dodge.SoundLogic.LoadSound
 --import Dodge.Creature.Perception
 import Geometry.Data
+--import Shape.Data
+--import Dodge.Render.Shape
 --import Picture
 --import Dodge.GameRoom
 --import Geometry

src/Dodge/Render.hs

@@ -9,7 +9,6 @@ import Dodge.Config.Data
 import Dodge.Base.Window
 import Dodge.Render.Picture
 --import Dodge.Creature.ShadowBox
-import Dodge.Creature.Silhouette
 import Dodge.Render.Shape
 import Geometry
 import Render
@@ -57,11 +56,12 @@ doDrawing pdata w = do
     -- poke wall points and colors
     nWalls <- poke224s (shadVBOptr $ _wallTextureShader pdata) wallPointsCol
     nSils <- pokePoint3s (shadVBOptr $ _lightingLineShadowShader pdata) 
-        $ creatureSilhouettes w
+        $ (_shEdges $ worldShape w)
         ++ _foregroundEdgeVerx w
     -- poke foreground geometry for caps
     nCaps <- pokePoint3s (shadVBOptr $ _lightingCapShader pdata)
         $ concatMap polyToGeoRender (foregroundPics w)
+            ++ map _svPos (_shVertices $ worldShape w)
     -- bind wall points, silhouette data, surface geometry
     uncurry bindShaderBuffers $ unzip
         [ ( _wallTextureShader pdata, nWalls)

src/Dodge/Render/Picture.hs

@@ -15,6 +15,7 @@ import Sound.Data
 import Geometry
 import Picture
 import Polyhedra.Data
+import ShapePicture
 
 import Control.Lens
 import Data.Maybe
@@ -88,7 +89,7 @@ soundPic w s = fixedSizePicClampArrow 50 50 thePic p w
     f x = 1 - 0.5 * (1 - x)
 
 crDraw :: World -> Creature -> Picture
-crDraw w c = _crPict c c w
+crDraw w c = _spPicture $ _crPict c c w
 ppDraw :: PressPlate -> Picture
 ppDraw c = uncurryV translate (_ppPos c) $ rotate (_ppRot c) (_ppPict c)
 btDraw :: Button -> Picture

src/Dodge/Render/Shape.hs

@@ -4,6 +4,11 @@ import Dodge.Data
 import Shape
 import Geometry
 import Color
+import ShapePicture
 
+import qualified Data.IntMap as IM
 worldShape :: World -> Shape
-worldShape _ = colorSh green . translateSh (V3 (-20) 200 50) . flatPoly $ rectNSWE 20 0 0 20
+worldShape w = mconcat (map (crShape w) (IM.elems (_creatures w)))
+
+crShape :: World -> Creature -> Shape
+crShape w c = _spShape $ _crPict c c w

src/Polyhedra.hs

@@ -1,4 +1,14 @@
 module Polyhedra
+    ( translateXY
+    , rotateXY
+    , polyToEdges
+    , constructEdgesList
+    , boxXYZ
+    , boxABC
+    , boxXYZnobase
+    , polyToGeoRender
+    , polysToPic
+    )
     where
 import Geometry
 --import Geometry.Data
@@ -129,7 +139,14 @@ polysToPic :: [Polyhedra] -> Picture
 polysToPic = pictures . concatMap polyToPics
 
 polyToEdges :: Polyhedra -> [(Point3,Point3,Point3,Point3)]
-polyToEdges = constructEdges . map (map fst) . _pyFaces
+polyToEdges = map denormalEdges . constructEdges . map (map fst) . _pyFaces
+
+denormalEdges :: (Point3,Point3,Point3,Point3) -> (Point3,Point3,Point3,Point3)
+denormalEdges (a,b,n,m) = (a,b,a - x, b - y)
+  where
+    x = crossProd (b - a) n
+    y = crossProd (a - b) m
+    
 
 polyToGeoRender :: Polyhedra -> [Point3]
 polyToGeoRender = concatMap (polyToTris . map fst) . _pyFaces

src/Shape.hs

@@ -5,7 +5,8 @@ module Shape
     )
   where
 import Geometry
---import Geometry.Vector3D
+import Geometry.Vector3D
+import Geometry.ConvexPoly
 import Shape.Data
 import Color
 
@@ -13,6 +14,39 @@ empty :: Shape
 {-# INLINE empty #-}
 empty = Shape [] []
 
+flatCirc :: Float -> Shape
+flatCirc = flatPoly . polyCirc
+
+polyCirc :: Float -> [Point2]
+{-# INLINE polyCirc #-}
+polyCirc x = map (\a -> rotateV a (V2 x 0)) $ take 8 [0,pi/4..]
+
+prismPoly 
+    :: Float    -- ^ height, expected to be strictly positive
+    -> [Point2] 
+    -> Shape
+{-# INLINE prismPoly #-}
+prismPoly h ps = Shape
+    { _shVertices = topFace ++ bottomFace ++ sideFaces
+    , _shEdges = topEdges ++ bottomEdges ++ sideEdges
+    }
+  where
+    topFace = polyToTris $ map f' ps
+    f' (V2 x y) = ShapeV {_svPos = V3 x y h, _svCol = black }
+    f (V2 x y) = ShapeV {_svPos = V3 x y 0, _svCol = black }
+    bottomFace = polyToTris $ map f $ reverse ps
+    sideFaces = map addCol $ concat 
+        $ zipWith (\a b -> polyToTris (extendSide a b)) ps (tail ps ++ [head ps])
+    addCol x = ShapeV {_svPos = x, _svCol = black}
+    extendSide (V2 x y) (V2 x' y') = [V3 x y 0, V3 x' y' 0, V3 x' y' h, V3 x y h]
+    topEdges = concat $ zipWith makeTopEdge ps (tail ps ++ [head ps])
+    makeTopEdge (V2 x y) (V2 x' y') = [V3 x y h,V3 x' y' h,V3 x y 0,V3 xcen ycen h]
+    V2 xcen ycen = centroid ps
+    bottomEdges = concat $ zipWith makeBottomEdge ps (tail ps ++ [head ps])
+    makeBottomEdge (V2 x' y') (V2 x y) = [V3 x y 0,V3 x' y' 0,V3 x y h,V3 xcen ycen 0]
+    sideEdges = concat $ zipWith3 makeSideEdge ps (tail ps ++ [head ps]) (drop 2 ps ++ take 2 ps)
+    makeSideEdge (V2 xl yl) (V2 x y) (V2 xr yr) = [V3 x y 0, V3 x y h, V3 xr yr 0, V3 xl yl h]
+
 flatPoly :: [Point2] -> Shape
 flatPoly ps = Shape
     { _shVertices = polyToTris $ map f ps
@@ -23,12 +57,16 @@ flatPoly ps = Shape
     g (V2 x y) (V2 a b) =
         [ V3 x y   0
         , V3 a b   0
-        , V3 x y (-1)
+        , V3 x y 0 - n
-        , V3 a b   1
+        , V3 a b 0 - n
         ]
+      where
+        n = addZ 0 $ vNormal (V2 (a-x) (b-y))
+--  where
+    --n = 
 
-colorSh :: Color -> Shape -> Shape
+colorSH :: Color -> Shape -> Shape
-colorSh col = overCol $ const col
+colorSH col = overCol $ const col
 
 overCol :: (Point4 -> Point4) -> Shape -> Shape
 overCol f Shape{_shVertices=vs,_shEdges=es} = Shape 
@@ -42,11 +80,20 @@ overPos f Shape{_shVertices=vs,_shEdges=es} = Shape
     ,_shEdges    = map f es
     }
 
-translateSh :: Point3 -> Shape -> Shape
+translateSH :: Point3 -> Shape -> Shape
-translateSh !p = overPos (+p)
+translateSH !p = overPos (+p)
 
-scale :: Point3 -> Shape -> Shape
+translateSHf :: Float -> Float -> Shape -> Shape
-scale !p = overPos (*p)
+translateSHf x y = translateSH (V3 x y 0)
+
+translateSHz :: Float -> Shape -> Shape
+translateSHz z = translateSH (V3 0 0 z)
+
+rotateSH :: Float -> Shape -> Shape
+rotateSH a = overPos (rotate3 a)
+
+scaleSH :: Point3 -> Shape -> Shape
+scaleSH !p = overPos (*p)
 
 overColVertex :: (Point4 -> Point4) -> ShapeV -> ShapeV
 overColVertex f ShapeV{_svPos=pos,_svCol=col} = ShapeV
@@ -59,4 +106,3 @@ overPosVertex f ShapeV{_svPos=pos,_svCol=col} = ShapeV
     {_svPos = f pos
     ,_svCol = col
     }
-

src/Shape/Data.hs

@@ -4,10 +4,16 @@ module Shape.Data
     where
 import Geometry.Data
 import Control.Lens
+--import Data.Monoid
 data Shape = Shape
     { _shVertices :: [ShapeV]
     , _shEdges    :: [Point3]
     }
+instance Semigroup Shape where
+    (<>) (Shape sv1 se1) (Shape sv2 se2) = Shape (sv1 ++ sv2) (se1 ++ se2)
+instance Monoid Shape where
+    mempty = Shape [] []
+
 -- edges are given by four consecutive points
 data ShapeV = ShapeV
     { _svPos :: Point3

src/ShapePicture.hs

@@ -0,0 +1,17 @@
+module ShapePicture
+    ( module ShapePicture
+    , module ShapePicture.Data
+    )
+    where
+import Shape
+import ShapePicture.Data
+import Picture
+import Geometry
+
+emptyBlank :: SPic
+emptyBlank = SPic empty blank
+
+translateSP :: Float -> Float -> SPic -> SPic
+translateSP x y (SPic sh pic) = SPic
+    (translateSH (V3 x y 0) sh)
+    (translate x y pic)

src/ShapePicture/Data.hs

@@ -0,0 +1,11 @@
+{-# LANGUAGE StrictData #-}
+{-# LANGUAGE TemplateHaskell #-}
+module ShapePicture.Data
+    where
+import Shape
+import Picture
+data SPic = SPic 
+    { _spShape :: Shape 
+    , _spPicture :: Picture
+    }
+