Allow tweaking z buffer when rendering polygon, improve explosion render

shader/twoD/basicTweakZ.frag

@@ -0,0 +1,7 @@
+#version 430 core
+in vec4 vColor;
+out vec4 fColor;
+void main()
+{
+  fColor = vColor;
+}

shader/twoD/basicTweakZ.vert

@@ -0,0 +1,12 @@
+#version 430 core
+layout (location = 0) in vec4 position;
+layout (location = 1) in vec4 color;
+layout (std140, binding = 0) uniform TheMat { mat4 theMat; } ;
+out vec4 vColor;
+void main()
+{
+  vec4 posxy = theMat * vec4(position.xyz,1);
+  vec4 posz  = theMat * vec4(position.xyw,1);
+  gl_Position = vec4(posxy.xy,posz.z,1);
+  vColor = color;
+}

src/Dodge/Creature.hs

@@ -171,7 +171,7 @@ startInventory = IM.fromList (zip [0..20]
     ,boosterGun
     ,remoteLauncher
     ,grenade
-    ,spawnGun lamp
+    ,spawnGun (lamp 20)
     ,lasGun
     ,flamer
     ,poisonSprayer

src/Dodge/Creature/Inanimate.hs

@@ -26,29 +26,29 @@ import Control.Lens
 defaultInanimate :: Creature
 defaultInanimate = defaultCreature & crActionPlan .~ Inanimate
 
-lamp :: Creature
+lamp :: Float -> Creature
-lamp = defaultInanimate
+lamp h = defaultInanimate
-    { _crUpdate = initialiseLamp
+    { _crUpdate = initialiseLamp h
     , _crHP = 100
-    , _crPict = picAtCrPos lampPic
+    , _crPict = picAtCrPos (lampPic h)
     , _crRad = 3
     , _crMass = 3
     }
-lampPic :: Picture
+lampPic :: Float -> Picture
-lampPic = pictures
+lampPic h = pictures
-    [ pictures . map (Poly3D 0 . map ((, blue) . (-.-.- (2.5,2.5,0)))) $ boxXYZ 5 5 99
+    [ pictures . map (Poly3D 0 . map ((, blue) . (-.-.- (2.5,2.5,0)))) $ boxXYZ 5 5 (h-1)
-    , setDepth (100) $ color white $ circleSolid 3
+    , setDepth h $ color white $ circleSolid 3
     ]
 
-initialiseLamp :: CRUpdate
+initialiseLamp :: Float -> CRUpdate
-initialiseLamp w (f,g) cr = ( (addLS . f , g), Just $ cr & crUpdate .~ updateLamp i)
+initialiseLamp h w (f,g) cr = ( (addLS . f , g), Just $ cr & crUpdate .~ updateLamp h i)
   where
     i = IM.newKey $ _lightSources $ f w -- to give different lights different keys
-    addLS = over lightSources (IM.insert i (lightAt (x,y,20) i))
+    addLS = over lightSources (IM.insert i (lightAt (x,y,h) i))
     (x,y) = _crPos cr
 
-updateLamp :: Int -> CRUpdate
+updateLamp :: Float -> Int -> CRUpdate
-updateLamp i = unrandUpdate handleLS internalUpdate
+updateLamp h i = unrandUpdate handleLS internalUpdate
   where
     handleLS cr w 
         | _crHP cr < 0 = explosionFlashAt cPos 
@@ -56,7 +56,7 @@ updateLamp i = unrandUpdate handleLS internalUpdate
         | otherwise    = w & lightSources . ix i . lsPos .~ f cPos
       where
         cPos = _crPos cr
-        f (x,y) = (x,y,120)
+        f (x,y) = (x,y,h)
     internalUpdate cr 
         | _crHP cr < 0 = Nothing
         | otherwise    = Just $ doDamage cr

src/Dodge/Creature/Picture.hs

@@ -16,6 +16,7 @@ import Dodge.Creature.Test
 import Dodge.Item.Data
 import Picture
 import Geometry
+import Geometry.Vector3D
 
 import Control.Lens
 import Data.List
@@ -29,12 +30,13 @@ basicCrPict col cr w = pictures $
     targetingPic ++
     [ tr . setDepth 0 $ color yellow $ circleSolid 10
     , tr . piercingMod $ bluntScale $ naked col cr
-    , tr $ waist col
+    , tr $ torso (light4 col) (0,-crad) (0,crad)
     , trFeet $ feet cr
     , tr $ arms col cr
     , tr $ drawEquipment cr
     ]
   where 
+    crad = _crRad cr
     targetingPic = IM.elems $ IM.mapMaybeWithKey f $ _crInv cr
     f invid it = fmap ((\g -> g invid it cr w) . snd) (it ^? itTargeting . _Just)
     tr = uncurry translate (_crPos cr) . rotate (_crDir cr)
@@ -55,9 +57,6 @@ basicCrPict col cr w = pictures $
         _   -> id
     pastDams = _crPastDamage $ _crState cr
 
-waist :: Color -> Picture
-waist col = setDepth 10 . color (light4 col) . scale 0.5 1 $ circleSolid 8
-
 feet :: Creature -> Picture
 feet cr = case cr ^? crStance . carriage of
     Just (Walking sa LeftForward)  -> setL
@@ -100,6 +99,14 @@ arms col cr
     aimingTwist = crIsAiming' cr -- && crIt ^? itAimStance == Just TwoHandTwist
     --crIt = _crInv cr IM.! _crInvSel cr
 
+torso :: Color -> Point2 -> Point2 -> Picture
+torso col x y = color col $ pictures
+    [ poly3 [addZ 20 x, addZ 12 v, addZ 12 ((0,0) -.- v), addZ 20 y]
+    , setDepth 12 . rotate a . scale 1 1 $ circleSolid $ magV v
+    ]
+  where
+    v = 0.25 *.* (x -.- y)
+    a = argV v
 
 naked :: Color -> Creature -> Picture
 naked col cr
@@ -125,7 +132,7 @@ naked col cr
         , shoulderH . translate 0 (negate 3) . rotate 0.2 . scale 0.5 1 $ color col' $ circleSolid $ _crRad cr
         ]
   where
-    fhead = setDepth 30 $ circleSolid $ crad * 0.5
+    fhead = setDepth 22 $ circleSolid $ crad * 0.5
     shoulderH = setDepth 20
     twistA = negate 1
     aimingOneHand = crIsAiming' cr && crIt ^? itAimStance == Just OneHand

src/Dodge/Creature/State.hs

@@ -93,6 +93,7 @@ movementSideEff cr w
             Just (Boosting v) 
                 -> makeFlameletTimed 
                             (oldPos +.+ (_crRad cr + 3) *.* unitVectorAtAngle (_crDir cr + pi))
+                            20
                             (momentum +.+ 1 *.* rotateV randDir (vInverse v)) 
                             Nothing
                             1

src/Dodge/Data.hs

@@ -355,6 +355,18 @@ data Particle
         , _btTimer' :: Int
         , _btHitEffect' :: HitEffect
         }
+    | PtZ  
+        { _ptDraw :: Particle -> Picture
+        , _ptUpdate' :: World -> Particle -> (World, Maybe Particle)
+        , _btVel' :: Point2
+        , _btColor' :: Color
+        , _btPos' :: Point2
+        , _btPassThrough' :: Maybe Int
+        , _btWidth' :: Float 
+        , _btTimer' :: Int
+        , _btHitEffect' :: HitEffect
+        , _ptZ :: Float
+        }
     | Pt'  
         { _ptDraw :: Particle -> Picture
         , _ptUpdate' :: World -> Particle -> (World, Maybe Particle)

src/Dodge/Event/Keyboard.hs

@@ -105,6 +105,6 @@ dropLight w = placeLS ls dec pos 0 w
     dec = onLayer PtLayer $ color white $ circleSolid 8
 
 dropLight' :: World -> World
-dropLight' w = placeCr lamp pos 0 w
+dropLight' w = placeCr (lamp 30) pos 0 w
   where
     pos = _crPos(you w)

src/Dodge/Item/Draw.hs

@@ -27,8 +27,8 @@ pictureWeaponOnAim p cr posInInv
                 = handD holsteredWep
     | otherwise = blank
   where 
-    shoulderD = setDepth $ negate 0.005
+    shoulderD = setDepth 20.5
-    handD = setDepth 0.01
+    handD = setDepth 15
     isSelected = _crInvSel cr == posInInv 
     drawnWep = uncurry translate (_crRad cr,0) p
     twistWep = uncurry translate (0.5 * _crRad cr,0) p

src/Dodge/Item/Weapon.hs

@@ -546,10 +546,10 @@ remoteShellPic
     :: Int -- ^ Timer
     -> Picture
 remoteShellPic t 
-    | rem (t+200) 20 < 9 = polygon [(-6,4),(-6,-4),(6,-4),(8,0),(6,4)]
+    | rem (t+200) 20 < 9 = setDepth 20 $ polygon [(-6,4),(-6,-4),(6,-4),(8,0),(6,4)]
     | otherwise = pictures 
-        [ onLayer UPtLayer $ polygon [(-6,4),(-6,-4),(6,-4),(8,0),(6,4)]
+        [ setDepth 20 $ polygon [(-6,4),(-6,-4),(6,-4),(8,0),(6,4)]
-        , setLayer 1 $ onLayer HPtLayer $ color col $ circleSolid 3
+        , setLayer 1 . setDepth 20.5 . color col $ circleSolid 3
         ]
   where 
     col | t > (-99) = green
@@ -797,7 +797,7 @@ moveRemoteShell cid itid pj w
                 )
             & soundFromPos (ShellSound i) newPos (fromIntegral smokeTrailSound) 1 250
             & smokeGen
-            & makeFlameletTimed oldPos (0.5 *.* rotateV (pi+sparkD) accel) Nothing 3 10
+            & makeFlameletTimed oldPos 20 (0.5 *.* rotateV (pi+sparkD) accel) Nothing 3 10
     | time > -200 = case thingHit of
         Just _  -> doExplosion $ stopSoundFrom (ShellSound i) w
         Nothing -> w

src/Dodge/Item/Weapon/Laser.hs

@@ -3,7 +3,7 @@ module Dodge.Item.Weapon.Laser
     where
 import Dodge.Data
 import Dodge.Picture
-import Dodge.Picture.Layer
+--import Dodge.Picture.Layer
 import Dodge.Item.Attachment.Data
 --import Dodge.Base
 import Dodge.SoundLogic
@@ -56,7 +56,7 @@ moveLaser
     -> (World, Maybe Particle)
 moveLaser phaseV pos dir w pt
     = ( set randGen g $ hitEffect w
-      , Just pt {_ptDraw = const $ onLayer PtLayer pic ,_ptUpdate' = ptTimer' 0 }
+      , Just pt {_ptDraw = const pic ,_ptUpdate' = ptTimer' 0 }
       )
   where 
     xp = pos +.+ 800 *.* unitVectorAtAngle dir
@@ -106,7 +106,7 @@ moveLaser phaseV pos dir w pt
           Just (p,E3x2 wl) -> createSpark 8 colID (p +.+ safeNormalizeV (pos -.- p))
                                                       (reflectDir wl) Nothing
           _   -> id
-    pic = pictures 
+    pic = setDepth 20 $ pictures 
         [ fadeLine pos (head ps) 0.2 40 yellow
         , setLayer 1 $ color (withAlpha 0.9 white) $ vThickLine (pos:ps)
         , setLayer 1 $ color (withAlpha 0.5 yellow) $ vvThickLine (pos:ps)

src/Dodge/Item/Weapon/Launcher.hs

@@ -98,7 +98,7 @@ doThrust pj w = w
     & randGen .~ g
     & projectiles . ix i . pjVel    %~ (\v -> accel +.+ frict *.* v)
     & soundFromPos (ShellSound i) newPos (fromIntegral smokeTrailSound) 1 250
-    & makeFlameletTimed (oldPos -.- vel) (vel +.+ rotateV (pi+sparkD) accel) Nothing 3 10
+    & makeFlameletTimed (oldPos -.- vel) 0 (vel +.+ rotateV (pi+sparkD) accel) Nothing 3 10
     & smokeGen
   where
     accel = _pjAcc pj
@@ -172,16 +172,11 @@ reduceSpinBy :: Float -> Projectile -> World -> World
 reduceSpinBy x pj = projectiles . ix (_pjID pj) .  pjSpin *~ x
 
 shellPic :: Projectile -> Picture
-shellPic pj
+shellPic pj = setDepth 20 . uncurry translate pos $ rotate (argV accel) basePic
-    | t > 40    =  onLayerL [levLayer CrLayer - 2] 
-        $ uncurry translate pos $ rotate (argV accel) basePic 
-    | otherwise = onLayer PtLayer $ uncurry translate pos $ rotate (argV accel) basePic
   where
     basePic = color black $ polygon [(-6,4),(-6,-4),(6,-4),(8,0),(6,4)]
     accel = _pjAcc pj
     pos = _pjPos pj
-    t = _pjTimer pj
-
 
 pjEffTimeRange
     :: (Int,Int)

src/Dodge/LightSources.hs

@@ -14,7 +14,7 @@ lightAt (x,y,z) i =
     LS {_lsID = i
        ,_lsPos = (x,y,z)
        ,_lsDir = 0
-       ,_lsRad = 500
+       ,_lsRad = 700
        ,_lsIntensity = 0.75
        }
 basicLS :: PSType

src/Dodge/Particle/Bullet/Draw.hs

@@ -5,6 +5,6 @@ import Dodge.Data
 import Picture
 
 drawBul :: Particle -> Picture
-drawBul pt = setLayer 1 . color thecolor $ thickLine (take 2 $ _btTrail' pt) (_btWidth' pt)
+drawBul pt = setLayer 1 . setDepth 20 . color thecolor $ thickLine (take 2 $ _btTrail' pt) (_btWidth' pt)
   where
     thecolor = _btColor' pt

src/Dodge/Particle/Bullet/HitEffect.hs

@@ -118,7 +118,7 @@ bulIncCr' bt p cr w
     sp = head $ _btTrail' bt
     ep = sp +.+ _btVel' bt
     v = evalState (randInCirc 1) $ _randGen w
-    incFlamelets = over worldEvents $ (.) (makeFlameletTimed p v Nothing 3 20)
+    incFlamelets = over worldEvents $ (.) (makeFlameletTimed p 20 v Nothing 3 20)
 {- | Creates a shockwave when hitting a creature.  -}
 bulConCr' :: Particle -> Point2 -> Creature -> World -> World
 bulConCr' bt p cr w 
@@ -172,7 +172,7 @@ bulIncWall' bt p wl w =  damageBlocksBy 5 wl $ incFlamelets w
     pOut = p +.+ safeNormalizeV (sp -.- p)
     wallV = uncurry (-.-) (_wlLine wl)
     reflectVel = safeNormalizeV $ reflectIn wallV (_btVel' bt)
-    incFlamelets = over worldEvents $ (.) (makeFlameletTimed pOut reflectVel Nothing 3 20)
+    incFlamelets = over worldEvents $ (.) (makeFlameletTimed pOut 20 reflectVel Nothing 3 20)
 {- | Create a shockwave on wall-}
 bulConWall'
     :: Particle 

src/Dodge/Particle/Bullet/Spawn.hs

@@ -11,7 +11,7 @@ import Control.Lens
 aGenBulAt
     :: Maybe Int -- ^ Pass-through creature id
     -> Point2   -- ^ Start position
-     -> Point2  -- ^ Velocity
+    -> Point2  -- ^ Velocity
     -> HitEffect 
     -> Float    -- ^ Bullet width
     -> Particle

src/Dodge/Picture.hs

@@ -43,7 +43,7 @@ wedgeOfThickness t x y
     n a b = (t*0.5) *.* errorNormalizeV 4200 (vNormal (a -.- b))
 
 verticalPipe :: Float -> Color -> Point2 -> Float -> Float -> Picture
-verticalPipe w col (xx,xy) za zb = pictures $ map (poly3D . f) ps
+verticalPipe w col (xx,xy) za zb = pictures $ map (poly3Col . f) ps
   where
     x = (xx,xy,0)
     xs = map (\(a,b) -> x +.+.+ (a,b,za)) [(w,0),(0,w),(-w,0),(0,-w)]

src/Dodge/RandomHelp.hs

@@ -3,6 +3,7 @@ Helpers for random generation.
 -}
 module Dodge.RandomHelp where
 import Geometry
+import Geometry.Vector3D
 import Geometry.Data
 
 import System.Random
@@ -68,6 +69,26 @@ randInCirc maxRad = do rad <- state $ randomR (0,maxRad)
                        ang <- state $ randomR (0,2*pi)
                        return $ rad *.* unitVectorAtAngle ang
 
+randOnUnitSphere :: RandomGen g => State g Point3
+randOnUnitSphere = do
+    z <- state $ randomR (negate 1,1)
+    longitude <- state $ randomR (0, 2*pi)
+    let (x,y) = sqrt (1 - z^(2::Int)) *.* unitVectorAtAngle longitude
+    return (x,y,z)
+
+randOnHemisphere :: RandomGen g => State g Point3
+randOnHemisphere = do
+    z <- state $ randomR (0,1)
+    longitude <- state $ randomR (0, 2*pi)
+    let (x,y) = sqrt (1 - z^(2::Int)) *.* unitVectorAtAngle longitude
+    return (x,y,z)
+
+randInHemisphere :: RandomGen g => State g Point3
+randInHemisphere = do
+    p <- randOnHemisphere
+    r <- state $ randomR (0,1)
+    return $ r *.*.* p
+
 randInRect :: RandomGen g => Float -> Float -> State g Point2
 randInRect w h = do x <- state $ randomR (0,w)
                     y <- state $ randomR (0,h)

src/Dodge/Render.hs

@@ -64,7 +64,7 @@ doDrawing pdata w = do
     depthFunc $= Just Less
     let scPol = screenPolygon w
     -- draw the lightmap. Probably changes the bound framebufferObject
-    createLightMap pdata (w ^. config . shadow_resolution) wallPoints lightPoints viewFroms
+    createLightMap pdata (w ^. config . shadow_resolution) wallPoints lightPoints
         (foregroundPics w) scPol
     clear [DepthBuffer]
     
@@ -95,6 +95,11 @@ doDrawing pdata w = do
     blendFuncSeparate $= ((SrcAlpha,OneMinusSrcAlpha) , (Zero,One))
     depthFunc $= Just Lequal
     _ <- renderFoldable pdata $ picToLTree (Just 1) pic
+    depthMask $= Disabled
+    _ <- renderFoldable pdata $ picToLTree (Just 3) pic
+    _ <- renderFoldable pdata $ picToLTree (Just 4) pic
+    _ <- renderFoldable pdata $ picToLTree (Just 5) pic
+    depthMask $= Enabled
     -- reset blend so that light map applies again
     -- allows us to be certain these elements are drawn on top of those before,
     -- in case we want transparency effects

src/Dodge/Room/Placement.hs

@@ -13,7 +13,7 @@ import Data.List
 import Control.Lens
 
 putLamp :: PSType
-putLamp = PutCrit lamp
+putLamp = PutCrit (lamp 90)
 
 singleBlock :: Point2 -> [Placement]
 singleBlock a = 

src/Dodge/WorldEvent/Cloud.hs

@@ -26,7 +26,7 @@ makeCloudAt rad t drawFunc p w = w & clouds %~ IM.insert i theCloud
 drawCloudWith :: Float -> Float -> Color -> Cloud -> Picture
 drawCloudWith radMult fadet col cl 
     = setLayer 2 
-    . setDepth (-0.02)
+    . setDepth 25
     $ circleSolidCol (withAlpha 0 col) (withAlpha a col) (radMult * _clRad cl)
   where 
     a = min 1 $ fromIntegral (_clTimer cl) / fadet

src/Dodge/WorldEvent/Explosion.hs

@@ -12,6 +12,7 @@ import Dodge.SoundLogic
 import Dodge.SoundLogic.Synonyms
 import Dodge.WorldEvent.Shockwave
 import Geometry
+import Geometry.Vector3D
 import Picture
 
 import Control.Monad.State
@@ -71,14 +72,16 @@ makeExplosionAt p w
     $ makeShockwaveAt [] p 50 10 1 white w
   where 
     fVs  = replicateM 75 (randInCirc 1)  & evalState $ _randGen w
-    fPs' = replicateM 75 (randInCirc 15) & evalState $ _randGen w
+    fPs'' = replicateM 75 (fmap (15 *.*.*) randInHemisphere) & evalState $ _randGen w
+    (fPs',zs) = let (a,b,c) = unzip3 fPs''
+                in (zip a b, c)
     fPs  = map (pushAgainstWalls . (+.+) p . (*.*) 0.5) fPs'
     inversePushOut v = (15 - magV v) * 0.01 *.* v
     fVs' = zipWith (+.+) fVs $ map inversePushOut fPs'
     sizes = randomRs (2,6) $ _randGen w
     times = randomRs (20,25) $ _randGen w
-    mF q v size time = makeFlameletTimed q v Nothing size time
+    mF q z v size time = makeFlameletTimed q z v Nothing size time
-    newFs = zipWith4 mF fPs (fmap (3 *.*) fVs') sizes times
+    newFs = zipWith5 mF fPs zs (fmap (3 *.*) fVs') sizes times
     addFlames w' = foldr ($) w' newFs
     pushAgainstWalls q = maybe q (uncurry (+.+)) $ reflectPointWalls p q $ wallsNearPoint q w
 

src/Dodge/WorldEvent/Shockwave.hs

@@ -49,7 +49,7 @@ Shockwave picture.
 drawShockwave :: Particle -> Picture
 drawShockwave pt = pic 
   where
-    pic = onLayer PtLayer $ uncurry translate p 
+    pic = setDepth 20 . uncurry translate p 
                           $ color (_btColor' pt) $ thickCircle rad thickness
     p    = _btPos' pt
     r    = _btRad' pt

src/Dodge/WorldEvent/SpawnParticle.hs

@@ -20,6 +20,7 @@ import Dodge.RandomHelp
 --import Dodge.Debug
 import Picture
 import Geometry
+--import Geometry.Data
 import qualified IntMapHelp as IM
 
 import Control.Lens
@@ -56,9 +57,9 @@ drawFlame rotd pt = thePic
     ep = _btPos' pt
     thePic = pictures 
         [ glow 
-        , aPic prot2 0.002998 (scaleChange + 1,2) red
+        , aPic prot2 18 (scaleChange + 1,2) red
-        , aPic prot  0.002996 (scaleChange + 0.5,1.5) orange
+        , aPic prot  19 (scaleChange + 0.5,1.5) orange
-        , aPic prot3 0.002994 (scaleChange,1) white
+        , aPic prot3 20 (scaleChange,1) white
         ]
     aPic :: (Point2 -> Point2) -> Float -> Point2 -> Color -> Picture
     aPic offset depth (scalex,scaley) col
@@ -121,31 +122,80 @@ moveFlame rotd w pt
         +.+ (0.2 *.* vel)
     smokeCol = fst $ randomR (0.2,0.5) (_randGen w)
     smokeGen = makeFlamerSmokeAt smokeCol ep
+
 makeFlameletTimed 
     :: Point2       -- ^ Position
+    -> Float        -- ^ z position
     -> Point2       -- ^ Velocity
     -> Maybe Int    -- ^ Creature id
     -> Float        -- ^ Size
     -> Int          -- ^ Timer
     -> World 
     -> World
-makeFlameletTimed  pos vel maycid size time w = w
+makeFlameletTimed (x,y) z vel maycid size time w = w
     & randGen   .~ g 
     & particles %~ (theFlamelet :)
   where   
-    theFlamelet = Pt' 
+    theFlamelet = PtZ 
-        { _ptDraw         = drawFlamelet rot
+        { _ptDraw         = drawFlameletZ rot
         , _ptUpdate'      = moveFlamelet
         , _btVel'         = vel
         , _btColor'       = red
-        , _btPos'         = pos
+        , _btPos'         = (x,y)
         , _btPassThrough' = maycid
         , _btWidth'       = size
         , _btTimer'       = time
         , _btHitEffect'   = destroyOnImpact (doFlameDam 1) noEff noEff
+        , _ptZ = z
         }
     (rot ,g) = randomR (0,3) $ _randGen w
 
+drawFlameletZ
+    :: Float    -- ^ Rotation
+    -> Particle
+    -> Picture
+drawFlameletZ rot pt = pictures 
+    [ setLayer 5 pic 
+    , setLayer 4 pi2 
+    , setLayer 3 piu 
+    , setLayer 1 glow
+    ]
+  where
+    z = _ptZ pt
+    sp = _btPos' pt
+    vel = _btVel' pt
+    ep = sp +.+ vel
+    size = _btWidth' pt
+    siz2 = size + 0.2
+    time = _btTimer' pt
+    glow = setDepth 19 $ uncurry translate ep
+                $ circleSolidCol (withAlpha 0 red) (withAlpha 0.05 red) 30
+    piu = setDepth (z + 20)
+        .  uncurry translate ep 
+        . color (dark red) 
+        . rotate (negate (rot - 0.1 * fromIntegral time))
+        . scale s1 s1
+        $ polygon (rectNSWE siz2 (-siz2) (-siz2) siz2)
+    pi2 = setDepth (z + 20)
+        . uncurry translate ep
+        . color (mixColors (fromIntegral (max 0 (time-2))) (10-fromIntegral time) 
+                           orange                          (dark red)
+                   )
+        . rotate (negate (rot + 0.2 * fromIntegral time))
+        . scale s2 s2
+        $ polygon (rectNSWE siz2 (-siz2) (-siz2) siz2)
+    pic = setDepth (z + 20)
+        . uncurry translate ep
+        . color (mixColors (fromIntegral (max 0 (time-2))) (10-fromIntegral time) 
+                           white                           (dark red)
+                )
+        . rotate (negate ( 0.1 * fromIntegral time + rot))
+        . scale sc sc
+        $ polygon [(-size,-size),(size,-size),(size,size),(-size,size)]
+    sc = (*) 2 $ log $ 1 + fromIntegral time / 20
+    s1 = (*) 2 $ log $ 2 + fromIntegral time / 40
+    s2 = 0.5 * (sc + s1)
+
 drawFlamelet 
     :: Float    -- ^ Rotation
     -> Particle
@@ -158,16 +208,16 @@ drawFlamelet rot pt = setLayer 1 $ pictures [pic , piu , pi2 , glow]
     size = _btWidth' pt
     siz2 = size + 0.2
     time = _btTimer' pt
-    glow = setDepth 0.336 $ uncurry translate ep
+    glow = setDepth 19 $ uncurry translate ep
                 $ circleSolidCol (withAlpha 0 red) (withAlpha 0.05 red) 30
-    piu = setDepth 0.334 
+    piu = setDepth 20
         .  uncurry translate ep 
         . color (dark red) 
         . rotate (negate (rot - 0.1 * fromIntegral time))
         . scale s1 s1
         . polygon 
         $ rectNSWE siz2 (-siz2) (-siz2) siz2
-    pi2 = setDepth 0.332 
+    pi2 = setDepth 20.2
         . uncurry translate ep
         . color (mixColors (fromIntegral (max 0 (time-2))) (10-fromIntegral time) 
                            orange                          (dark red)
@@ -176,7 +226,7 @@ drawFlamelet rot pt = setLayer 1 $ pictures [pic , piu , pi2 , glow]
         . scale s2 s2
         . polygon 
         $ rectNSWE siz2 (-siz2) (-siz2) siz2
-    pic = setDepth 0.33 
+    pic = setDepth 20.4
         . uncurry translate ep
         . color (mixColors (fromIntegral (max 0 (time-2))) (10-fromIntegral time) 
                            white                           (dark red)
@@ -251,10 +301,10 @@ drawTeslaArc pt = pic
   where
     ps' = _ptPoints pt
     pic = setLayer 1 $ pictures 
-             [ onLayer PtLayer $ color (_ptColor pt) $ line ps'
+             [ setDepth 20.5 $ color (_ptColor pt) $ line ps'
-             , onLayer UPtLayer $ color (withAlpha 0.02 cyan) $ lineOfThickness 20 ps'
+             , setDepth 20 $ color (withAlpha 0.02 cyan) $ lineOfThickness 20 ps'
-             , onLayer UPtLayer $ color (withAlpha 0.02 cyan) $ lineOfThickness 25 ps'
+             , setDepth 20 $ color (withAlpha 0.02 cyan) $ lineOfThickness 25 ps'
-             , onLayer UPtLayer $ color (withAlpha 0.02 cyan) $ lineOfThickness 30 ps'
+             , setDepth 20 $ color (withAlpha 0.02 cyan) $ lineOfThickness 30 ps'
              ]
 -- todo: fix electrical damage location
 moveTeslaArc 

src/Geometry/Vector.hs

@@ -115,12 +115,10 @@ Identical to detV.  -}
 crossV :: Point2 -> Point2 -> Float
 crossV (ax,ay) (bx,by) = ax*by - ay*bx
 {- | TO CHECK Orthographic projection of one vector onto another. -}
-projV 
+projV :: Point2 -> Point2 -> Point2
-    :: Point2
-    -> Point2
-    -> Point2
 projV fromv onv 
     | den == 0  = error "tried projecting onto zero vector"
     | otherwise = (fromv `dotV` onv) / den *.* onv
   where
     den = onv `dotV` onv
+

src/Geometry/Vector3D.hs

@@ -4,6 +4,8 @@ module Geometry.Vector3D
 import Geometry.Vector
 import Geometry.Data
 
+import Data.List
+
 infixl 6 +.+.+, -.-.-
 infixl 7 *.*.*
 
@@ -56,3 +58,33 @@ magV3 (x,y,z) = sqrt $ x^i + y^i + z^i
 normalizeV3 :: Point3 -> Point3
 normalizeV3 (0,0,0) = (0,0,0)
 normalizeV3 p = (1 / magV3 p) *.*.* p
+
+addZ :: Float -> Point2 -> Point3
+addZ z (x,y) = (x,y,z)
+
+orderAround3
+    :: Point3 -- ^ Vector to order around
+    -> [Point3]
+    -> [Point3]
+orderAround3 v ps = sortOn (argV . prj) ps
+  where
+    xdir = crossProd v (head ps)
+    ydir = crossProd v xdir
+    prj p = (dotV3 xdir p, dotV3 ydir p)
+
+vCen3 :: [Point3] -> Point3
+vCen3 ps = (1 / fromIntegral (length ps)) *.*.* foldr (+.+.+) (0,0,0) ps 
+
+dotV3
+    :: Point3
+    -> Point3
+    -> Float
+dotV3 (x,y,z) (a,b,c) = x*a + y*b + z*c
+
+projV3
+    :: Point3
+    -> Point3
+    -> Point3
+projV3 = undefined
+
+

src/Picture.hs

@@ -1,8 +1,11 @@
+{-# LANGUAGE TupleSections #-}
 module Picture
     ( module Picture.Data
     , polygon
+    , polygonZ
     , polygonCol
-    , poly3D
+    , poly3
+    , poly3Col
     , bezierQuad
     , arc
     , arcSolid
@@ -63,13 +66,21 @@ polygon :: [Point2] -> Picture
 {-# INLINE polygon #-}
 polygon = Polygon 0
 
+polygonZ :: [Point2] -> Float -> Picture
+{-# INLINE polygonZ #-}
+polygonZ = PolygonZ 0
+
 polygonCol :: [(Point2,RGBA)] -> Picture
 {-# INLINE polygonCol #-}
 polygonCol = PolygonCol 0
 
-poly3D :: [(Point3,RGBA)] -> Picture
+poly3 :: [Point3] -> Picture
-{-# INLINE poly3D #-}
+{-# INLINE poly3 #-}
-poly3D = Poly3D 0
+poly3 = poly3Col . map (, black)
+
+poly3Col :: [(Point3,RGBA)] -> Picture
+{-# INLINE poly3Col #-}
+poly3Col = Poly3D 0
 
 -- note that much of work computing the width of the bezier curve is done here
 bezierQuad :: Color -> Color -> Float -> Float -> Point2 -> Point2 -> Point2 -> Picture

src/Picture/Data.hs

@@ -14,11 +14,12 @@ import Geometry.Data
 --import Control.Monad 
 
 data RenderType
-    = RenderPoly [(Point3,Point4)]
+    = RenderPoly  [(Point3,Point4)]
-    | RenderBezQ [(Point3,Point4,Point4)]
+    | RenderPolyZ [(Point3,Point4,Float)]
-    | RenderText [(Point3,Point4,Point2)]
+    | RenderBezQ  [(Point3,Point4,Point4)]
-    | RenderArc  [(Point3,Point4,Point3)]
+    | RenderText  [(Point3,Point4,Point2)]
-    | RenderLine [(Point3,Point4)]
+    | RenderArc   [(Point3,Point4,Point3)]
+    | RenderLine  [(Point3,Point4)]
     | RenderEllipse [(Point3,Point4)]
     | Render3 [Point3]
     | RenderConst
@@ -79,6 +80,7 @@ data Picture
     = Blank
     | Text Int String
     | Polygon Int [Point2]
+    | PolygonZ Int [Point2] Float
     | BezierQuad Int [(Point2,RGBA,Point2,Point2)]
     | PolygonCol Int [(Point2,RGBA)]
     | Poly3D Int [(Point3,RGBA)]

src/Picture/Tree.hs

@@ -21,6 +21,8 @@ picToLTree
 {-# INLINE picToLTree #-}
 picToLTree mx (Polygon i ps)
     = filtB mx i $ LLeaf $ RenderPoly $ zip (map zeroZ $ polyToTris ps) $ repeat black
+picToLTree mx (PolygonZ i ps z)
+    = filtB mx i $ LLeaf $ RenderPolyZ $ zip3 (map zeroZ $ polyToTris ps) (repeat black) (repeat z)
 picToLTree mx (PolygonCol i vs)
     = filtB mx i $ LLeaf $ RenderPoly $ zip (map zeroZ $ polyToTris ps) $ polyToTris cs
   where 
@@ -85,6 +87,7 @@ overPos f (RenderText vs) = RenderText $ map (\(a,b,c) -> (f a,b,c)) vs
 overPos f (RenderBezQ vs) = RenderBezQ $ map (\(a,b,c) -> (f a,b,c)) vs
 overPos f (RenderEllipse vs) = RenderEllipse $ map (first f) vs
 overPos f (RenderArc vs)  = RenderArc $ map (\(a,b,c) -> (f a,b,c)) vs
+overPos f (RenderPolyZ vs) = RenderPolyZ $ map (\(a,b,c) -> (f a,b,c)) vs
 overPos _ _ = undefined
 
 overCol :: (Point4 -> Point4) -> RenderType -> RenderType
@@ -95,6 +98,7 @@ overCol f (RenderEllipse vs)  = RenderEllipse $ map (second f) vs
 overCol f (RenderText vs)     = RenderText    $ map (\(a,b,c) -> (a,f b,c)) vs
 overCol f (RenderBezQ vs)     = RenderBezQ    $ map (\(a,b,c) -> (a,f b,c)) vs
 overCol f (RenderArc vs)      = RenderArc     $ map (\(a,b,c) -> (a,f b,c)) vs
+overCol f (RenderPolyZ vs)    = RenderPolyZ   $ map (\(a,b,c) -> (a,f b,c)) vs
 overCol _ _ = undefined
 
 stringToList :: String -> [(Point3,Point4,Point2)]

src/Polyhedra/Data.hs

@@ -5,6 +5,8 @@ module Polyhedra.Data
 import Geometry.Data
 
 import Control.Lens
+import qualified Data.Map as M
+--import qualified Data.IntSet as IS
 -- | Polyhedra are represented as a list of faces.
 -- Each face is a list of points (and colours) that are assumed to lie on a plane, and be
 -- ordered to form an anticlockwise convex polygon within that plane.
@@ -12,4 +14,14 @@ data Polyhedra = Polyhedron
     { _pyFaces :: [[(Point3,Point4)]]
     }
 
+-- | Describe a polygon as a map from vertex indices to a positiong and list of faces.
+-- The list of faces is assumed to be ordered in clockwise direction around the vertex.
+-- The vertices of the faces are assumed to start with a point adjacent to the
+-- key vertex and to be listed anticlockwise around the center of the face.
+-- The key vertex is not included in the list.
+data VF a = VF
+    { _vertices :: M.Map a (Point3, [[a]])
+    }
+
 makeLenses ''Polyhedra
+makeLenses ''VF

src/Polyhedra/Geodesic.hs

@@ -0,0 +1,79 @@
+{-# LANGUAGE TupleSections #-}
+module Polyhedra.Geodesic
+    where
+import Geometry.Data
+import Geometry.Vector3D
+import Polyhedra.Data
+
+import Data.List
+import qualified Data.Map as M
+
+icosahedronPoints :: [Point3]
+icosahedronPoints = concat
+    [ [(0,one,gr),(one, gr, 0),(gr, 0, one)]
+    | one <- [-1,1]
+    , gr  <- [negate (1 + sqrt 5)/2, (1 + sqrt 5)/2 ]
+    ]
+
+icosohedronFaces :: [[Point3]]
+icosohedronFaces = map orderFace $
+    rectEdgeFaces ++ map (map rotTrip) rectEdgeFaces ++ map (map (rotTrip . rotTrip)) rectEdgeFaces
+    ++ addSym negFst (addSym negSnd $ addSym negThd rectCornFace)
+  where
+    rectEdgeFaces = addSym negThd $ addSym negFst rectEdgeFace
+    rectEdgeFace = [[ (gr,1,0) , (gr,negate 1,0) , (1,0,gr) ]]
+    rectCornFace = [[ (gr,1,0) , (0,gr,1) , (1,0,gr) ]]
+    addSym f faces = map (map f) faces ++ faces
+    negFst (x,y,z) = (negate x,y,z)
+    negSnd (x,y,z) = (x,negate y,z)
+    negThd (x,y,z) = (x,y,negate z)
+    rotTrip (x,y,z) = (z,x,y)
+    gr = (1 + sqrt 5) / 2 :: Float
+    orderFace ps = undefined orderAround3 ps
+
+-- | Assuming that this works, note that it relies heavily on the ordering of
+-- faces adjacent to a vertex (clockwise around the vertex) 
+-- and vertices on faces (anticlockwise around center of face).
+truncate :: Ord a => VF a -> VF (a,a) 
+truncate vf = VF
+    { _vertices = M.fromList . concatMap f $ M.toList vmap
+    }
+  where
+    vmap = _vertices vf
+    f (i, (pos, faces)) = map (g i pos faces) faces
+    g i pos faces (j:_) = 
+        ((i,j) 
+        ,   (0.5 *.*.* (pos +.+.+ fst (vmap M.! j))
+            ,truncFaces i j faces
+            )
+        )
+    g _ _ _ _ = undefined
+
+truncFaces :: Eq a => a -> a -> [[a]] -> [[(a,a)]]
+truncFaces v n vss = 
+    [ reverse $ map ((v,) . head) (f1:fs) 
+    , g (n:f0) ++ [(n,v)]
+    , (n,v) : g (f1 ++ [v])
+    ]
+  where
+    (f0:f1:fs) = rotateTo ((== n) . head) vss
+    g (x:y:xs) = [(x,y),(y,x)] ++ g (y:xs)
+    g _ = []
+
+rotateTo :: (a -> Bool) -> [a] -> [a]
+rotateTo p xs = ys ++ zs
+  where
+    (zs,ys) = break p xs
+
+facesToVF :: Ord a => [[a]] -> M.Map a [[a]]
+facesToVF faces = foldr f M.empty vs
+  where
+    vs = nub $ concat faces
+    f v = M.insert v (g v)
+    g v = map (tail . rotateTo (== v)) $ filter (elem v) faces
+
+--triPyramid :: VF
+--triPyramid = VF
+
+--dual :: VF a -> VF [a]
+--dual vf = 

src/Preload/Render.hs

@@ -45,6 +45,7 @@ preloadRender = do
     bezierQuadShader <- makeShader "twoD/bezierQuad" [vert,frag] [3,4,4]  ETriangleStrip pokeBezQStrat
     cslist <- makeShader "twoD/character" [vert,frag] [3,4,2] ETriangles pokeCharStrat
                   >>= addTexture "data/texture/charMap.png"
+    basicTweakZShad <- makeShader "twoD/basicTweakZ" [vert,frag] [4,4] ETriangles pokeTriTweakZ
 -- texture shaders, no textures attached
     fsShad <- makeShader "texture/simple" [vert,frag] [2,2] ETriangleStrip $ const cornerList
     -- note we directly poke the shader vertex data here
@@ -75,7 +76,8 @@ preloadRender = do
     clearColor $= Color4 0 0 0 1
 
     return $ RenderData
-        { _pictureShaders           = [bslist,lslist,cslist,aslist,eslist,bezierQuadShader]
+        { _pictureShaders           = 
+            [bslist,lslist,cslist,aslist,eslist,bezierQuadShader,basicTweakZShad]
         , _lightingSurfaceShader    = lightingSurfaceShad
         , _lightingLineShadowShader = lightingLineShadowShad
         , _lightingOccludeShader    = wsShad
@@ -160,6 +162,11 @@ pokeBezQStrat (RenderBezQ vs) = fmap (\((x,y,z),(r,g,b,a),(s,t,u,v)) -> [x,y,z,r
                                      vs
 pokeBezQStrat _ = []
 
+
+pokeTriTweakZ :: RenderType -> [[Float]]
+pokeTriTweakZ (RenderPolyZ vs) = fmap (\(p,co,z) -> flat3 p ++ [z] ++ flat4 co) vs
+pokeTriTweakZ _ = []
+
 {-# INLINE pokeTriStrat #-}
 pokeTriStrat,pokeCharStrat,pokeArcStrat,pokeLineStrat,pokeEllStrat :: RenderType -> [[Float]]
 pokeTriStrat (RenderPoly vs) = fmap (\(p,co) -> flat3 p ++ flat4 co) vs

src/Render.hs

@@ -55,11 +55,10 @@ createLightMap
     -> Int                  -- Resolution division
     -> [(Point2,Point2)]    -- Wall pairs
     -> [(Point3,Float,Float)]             -- Lights
-    -> (Float,Float)        -- View from position
     -> [Polyhedra]          -- foreground geometry
     -> [Point2]
     -> IO ()
-createLightMap pdata resDiv wallPoints lightPoints (viewFromx,viewFromy) fpics scPol = do
+createLightMap pdata resDiv wallPoints lightPoints fpics scPol = do
     -- get viewport size so we can reset it later
     (vppos,vpsize) <- get viewport
     -- set the viewport size to that of the render buffer