Cleanup. Start tweaking flares, glares and flashes

appDodge/Main.hs

@@ -1,4 +1,6 @@
-module Main where
+module Main 
+    ( main 
+    ) where
 import Loop
 import Dodge.Data
 import Dodge.Initialisation
@@ -31,6 +33,7 @@ import qualified Data.Map.Strict as M
 
 main :: IO ()
 main = do
+    -- load the config to get the window size and position
     con <- loadDodgeConfig
     let sizex = floor $ _windowX con
         sizey = floor $ _windowY con
@@ -39,22 +42,21 @@ main = do
     setupLoop
         20
         (sizex,sizey)
-        (posx,posy)
+        (Just (posx,posy))
         theCleanup
-        (firstWorldLoad (sizex,sizey))
+        (firstWorldLoad con)
         theUpdateStep
         (flip handleEvent)
 
 theCleanup :: World -> IO ()
 theCleanup w = SDL.cursorVisible $= True >> cleanUpPreload (_preloadData w)
 
-firstWorldLoad :: (Int,Int) -> IO World
+firstWorldLoad :: Configuration -> IO World
-firstWorldLoad (sizex,sizey) = do
+firstWorldLoad theConfig = do
     SDL.cursorVisible $= False
     theKeyConfig <- loadKeyConfig
-    theConfig <- loadDodgeConfig
     pdata <- doPreload >>= applyWorldConfig theConfig
-    w <- fmap (setWindowSize sizex sizey . (keyConfig .~ theKeyConfig) . (config .~ theConfig)) firstWorld
+    w <- fmap ((keyConfig .~ theKeyConfig) . (config .~ theConfig)) firstWorld
     return $ w & preloadData .~ pdata
 
 theUpdateStep :: World -> IO World
@@ -88,25 +90,18 @@ doSideEffects w = do
 
 doPreload :: IO PreloadData
 doPreload = do
+    rData   <- preloadRender
     lChunks <- loadSounds
     lMusic  <- loadMusic
-    let sData = SoundData {_loadedChunks = lChunks}
-        mData = MusicData {_loadedMusic = lMusic}
     Mix.playMusic Mix.Forever (lMusic IM.! 0)
-    rData <- preloadRender
+    return PreloadData 
-    return $ PreloadData 
         { _renderData   = rData 
-        , _soundData    = sData 
+        , _soundData    = SoundData {_loadedChunks = lChunks} 
-        , _musicData    = mData
+        , _musicData    = MusicData {_loadedMusic  = lMusic}
         , _frameTimer   = 0
         }
 
-checkForGlErrors :: IO ()
+--checkForGlErrors :: IO ()
-checkForGlErrors = do
+--checkForGlErrors = do
-    errs <- errors
+--    errs <- errors
-    unless (null errs) $ putStrLn $ "GLerror during doLoop: " ++ unwords (map show errs)
+--    unless (null errs) $ putStrLn $ "GLerror during doLoop: " ++ unwords (map show errs)
-
-setWindowSize :: Int -> Int -> World -> World
-setWindowSize x y w = w 
-    & config . windowX .~ fromIntegral x
-    & config . windowY .~ fromIntegral y

src/Dodge/Item/Weapon/ExtraEffect.hs

@@ -10,7 +10,6 @@ import Dodge.Item.Data
 import Dodge.Item.Weapon.Decoration
 import Dodge.Item.Weapon.UseEffect
 import Dodge.Item.Attachment.Data
-import Dodge.WorldEvent.Flash
 import Dodge.WorldEvent.ThingsHit
 import Dodge.Picture.Layer
 import Dodge.Creature.Test
@@ -52,6 +51,7 @@ bezierRecock = ItInvEffect
                   _          -> it & itAttachment .~ NoItAttachment
 {- |
 Creates a laser scope and recocks the weapon.
+TODO add the laser scope!
  -}
 itemLaserScopeEffect :: ItEffect
 itemLaserScopeEffect 
@@ -63,7 +63,6 @@ itemLaserScopeEffect
         | invid == _crInvSel cr && crIsAiming' cr = w 
             & particles %~ (:) (makeLaserScope sp ep reloadFrac)
             & creatures . ix (_crID cr) . crInv . ix invid . itHammer %~ moveHammerUp
-            & laserScopeTargetGlow col glowPoint 
         | otherwise = w
       where
         p = _crPos cr
@@ -74,14 +73,14 @@ itemLaserScopeEffect
         ep = case listToMaybe $ thingsHitLongLine sp xp w of
                 Just (pos,_) -> pos
                 Nothing -> xp
-        glowPoint = case listToMaybe $ thingsHitLongLine sp xp w of
+        --glowPoint = case listToMaybe $ thingsHitLongLine sp xp w of
-                Just (pos,E3x2 wl) -> pos +.+ 2 *.* wallNormal wl
+        --        Just (pos,E3x2 wl) -> pos +.+ 2 *.* wallNormal wl
-                _ -> ep -.- 2 *.* unitVectorAtAngle d
+        --        _ -> ep -.- 2 *.* unitVectorAtAngle d
         it = (cr ^. crInv) IM.! invid
         reloadFrac 
             | _wpLoadedAmmo it == 0 = 1
             | otherwise = fromIntegral (_wpReloadState it) / fromIntegral (_wpReloadTime it)
-        col = mixColors reloadFrac (1-reloadFrac) red green
+        --col = mixColors reloadFrac (1-reloadFrac) red green
 {- | Automatically send out radar pulses that detect walls.  -}
 autoRadarEffect :: ItEffect
 autoRadarEffect = ItInvEffect {_itInvEffect = f 50 ,_itEffectCounter = 0 }

src/Dodge/Particle/Bullet/HitEffect.hs

@@ -30,7 +30,7 @@ bulHitCr :: Particle -> Point2 -> Creature -> World -> World
 bulHitCr bt p cr w 
     | crIsArmouredFrom p cr
         = createSparkCol 8 colID p1 (argV (p1 -.- p) + d1) . addDamageArmoured $ w
-    | otherwise = addDamage . makeHitSound . flashEff $ w
+    | otherwise = addDamage . makeHitSound $ w
   where
     sp = head $ _btTrail' bt
     bulVel = _btVel' bt
@@ -39,7 +39,6 @@ bulHitCr bt p cr w
     addDamage = creatures . ix cid . crState . crDamage %~ ((Piercing 100 sp p ep : mvDams) ++ )
     addDamageArmoured = creatures . ix cid . crState . crDamage %~ (mvDams ++)
     makeHitSound = soundMultiFrom [CrHitSound 0] p hit1S (Just 10)
-    flashEff = over worldEvents (bloodFlashAt p . )
     cid = _crID cr
     (d1,_)  = randomR (-0.7,0.7) $ _randGen w
     colID = _btColor' bt
@@ -48,7 +47,7 @@ bulHitCr bt p cr w
 bulBounceArmCr' :: Particle -> Point2 -> Creature -> World -> World
 bulBounceArmCr' bt p cr w 
     | crIsArmouredFrom p cr = addBouncer . addDamageArmoured $ w
-    | otherwise = addDamage . makeHitSound . flashEff $ w
+    | otherwise = addDamage . makeHitSound $ w
   where
     sp = head $ _btTrail' bt
     bulVel = _btVel' bt
@@ -57,7 +56,6 @@ bulBounceArmCr' bt p cr w
     addDamage = creatures . ix cid . crState . crDamage %~ ((Piercing 100 sp p ep : mvDams) ++ )
     addDamageArmoured = creatures . ix cid . crState . crDamage %~ (mvDams ++)
     makeHitSound = soundMultiFrom [CrHitSound 0] p hit1S (Just 10)
-    flashEff = over worldEvents ((.) $ bloodFlashAt p)
     cid = _crID cr
     newDir = safeNormalizeV (p -.- _crPos cr)
     pOut = p +.+ 2 *.* newDir

src/Dodge/WorldEvent.hs

@@ -12,19 +12,15 @@ import Dodge.Particle.Bullet.Draw
 import Dodge.Particle.Bullet.Update
 import Dodge.WorldEvent.Flash
 import Dodge.WorldEvent.ThingsHit
---import Dodge.WorldEvent.HelperParticle
 import Dodge.WorldEvent.Cloud
 import Dodge.WorldEvent.HitEffect
 import Dodge.WorldEvent.Explosion
 import Dodge.WorldEvent.SpawnParticle
---import Dodge.WorldEvent.Shockwave
 import Dodge.LightSources.Lamp
 import Dodge.Creature.State.Data
 import Dodge.Data
 import Dodge.Data.DamageType
---import Dodge.Base
 import Geometry
---import Picture
 
 import Control.Lens
 import System.Random

src/Dodge/WorldEvent/Flash.hs

@@ -1,14 +1,20 @@
 {- | Flashes.
 projected naming conventions: three base types of light:
-glare : "low lighting", draws lines around creatures and walls
+glare : Draws color onto surfaces (not done)
-flare : coloured light drawn on top of picture in fixed shapes
+flare : coloured light drawn in space, fixed shapes
-light : removal of shadows
+light : removal of shadows (onto surfaces)
 duration (subject to modification):
 flash   : short, abrupt changes in alpha
 glow    : continuous, potentially long, fading, slow changes in alpha
 flicker : potentially long, moving, abrupt changes in alpha
 -}
 module Dodge.WorldEvent.Flash
+    ( sparkFlashAt
+    , explosionFlashAt
+    , laserGunFlashAt
+    , teslaGunFlashAt
+    , lowLightDirected
+    )
     where
 import Dodge.Data
 --import Dodge.Base
@@ -22,33 +28,13 @@ import Geometry
 import Data.Maybe (maybeToList)
 import Control.Lens
 
-glareAt :: Int -> Float -> Float -> Color -> Int -> Float -> Point2 -> World -> World
-glareAt t len wdth col nrays rad p w = foldr (glareLine' t len wdth col p) w ps
-  where 
-    ps = map (p +.+) $ nRaysRad nrays rad
-
-{- White flash. -}
-sparkFlashAt :: Point2 -> World -> World
-sparkFlashAt =
-    glareAt 2 10 5 (withAlpha 0.05 white) 20 30
-
-{- Red flash. -}
-bloodFlashAt :: Point2 -> World -> World
-bloodFlashAt p = 
-    over particles (flashFlareAt red 0.4 p : )
-    . glareAt 2 10 5 (withAlpha 0.05 red) 20 30 p
-
 {- Cyan flash. -}
 teslaGunFlashAt :: Point2 -> World -> World
-teslaGunFlashAt p = 
+teslaGunFlashAt = flareCircleAt cyan 0.7
-    over particles (flashFlareAt cyan 0.3 p : )
-    . glareAt 2 10 5 (withAlpha 0.1 cyan) 20 30 p
 
 {- Yellow flash. -}
 laserGunFlashAt :: Point2 -> World -> World
-laserGunFlashAt p =
+laserGunFlashAt = flareCircleAt yellow 0.2
-    over particles (flashFlareAt yellow 0.2 p : )
-    . glareAt 2 10 5 (withAlpha 0.05 yellow) 20 30 p
 
 glareLine' :: Int -> Float -> Float -> Color -> Point2 -> Point2 -> World -> World
 glareLine' t len wdth col a b w = w & particles %~ (maybeToList linePt ++)
@@ -77,9 +63,11 @@ lowLightPic len wdth col (a,b) w = case thingsHit a b w of
         _   -> blank
   where setCol = color col . setDepth (-0.5) . setLayer 2
 
-flashFlareAt :: Color -> Float -> Point2 -> Particle
+flareCircleAt :: Color -> Float -> Point2 -> World -> World
-flashFlareAt col alphax (V2 x y) = Particle
+flareCircleAt col alphax (V2 x y) = particles %~ (theFlareCircle :)
-    { _ptDraw = const $ setLayer 2 . setDepth (-0.9) . translate x y 
+  where
+    theFlareCircle = Particle
+        { _ptDraw = const $ setLayer 2 . setDepth 20 . translate x y 
                             $ circleSolidCol (withAlpha 0 col) (withAlpha alphax col) 30
         , _ptUpdate = ptTimer' 1
         }
@@ -91,27 +79,9 @@ explosionFlashAt p =  over tempLightSources ((:) $ tLightTimedIntensity 20 150 i
         | x < 10 = 1 / (10 - fromIntegral x)
         | otherwise = 1
 
-flameGlareAt :: Point2 -> World -> World
-flameGlareAt = glareAt 1 10 5 (withAlpha 0.05 orange) 8 40
-
 lowLightDirected :: Color -> Point2 -> Point2 -> [Float] -> World -> World
 lowLightDirected col a b angles w
     = foldr (\angle w' -> glareLine' 2 10 5 col a (a +.+ rotateV angle b) w') w angles
 
-
+sparkFlashAt :: Point2 -> World -> World
-muzzleFlashAt :: Point2 -> World -> World
+sparkFlashAt _ = id
-muzzleFlashAt p = over particles (muzzleFlashPt p : )
-                . glareAt 2 10 5 (withAlpha 0.5 white) 20 30 p
-
-muzzleFlashPt :: Point2 -> Particle
-muzzleFlashPt (V2 x y) = Particle
-    { _ptDraw = const $ setDepth 0 
-                    . setLayer 2
-                    . translate x y 
-                    $ circleSolidCol (withAlpha 0 white) (withAlpha 0.2 white) 20
-    , _ptUpdate = ptTimer' 1
-    }
-
-laserScopeTargetGlow :: Color -> Point2 -> World -> World
-laserScopeTargetGlow col = glareAt 2 3 1 (withAlpha 0.1 col) 15 5
-

src/Geometry.hs

@@ -15,7 +15,6 @@ module Geometry
     , module Geometry.Bezier
     , module Geometry.Vector
     , module Geometry.LHS
-    --, module Geometry.Zone
     )
     where
 import Geometry.Data
@@ -23,7 +22,6 @@ import Geometry.Intersect
 import Geometry.Bezier
 import Geometry.Vector
 import Geometry.LHS
---import Geometry.Zone
 
 import Data.Maybe
 import Data.List
@@ -236,7 +234,6 @@ prependTwo _   [] = []
 prependTwo _   [_] = []
 prependTwo sep (x:y:xs) = sep : x : y : prependTwo sep (y:xs)
 
-
 -- | Return n equidistant points on a circle with a radius of 600.
 nRays :: Int -> [Point2]
 nRays n = take n $ iterate (rotateV (2*pi/fromIntegral n)) (V2 600 0)
@@ -349,8 +346,6 @@ reflectInParam x line vec =
         rAng = rotateV angle vec
         p = x *.* errorClosestPointOnLine 3 (V2 0 0) (vNormal line) rAng
     in  rAng -.- p
---reflectIn' :: Point2 -> Point2 -> Point2 -> Point2 -> Point2
---reflectIn' l1 l2 v1 v2 = v1 +.+ reflectIn (l1 -.- l2) (v2 -.- v1)
 
 isOnSeg :: Point2 -> Point2 -> Point2 -> Bool
 isOnSeg l1 l2 p = 
@@ -452,17 +447,6 @@ arcStepwisePositive ssize a cen v = (cen +.+) . (`rotateV` v) <$> rots
     n :: Int
     n = ceiling (a * magV v / ssize)
 
---nPointsOnCirc :: Int -> Float -> [Point2]
---nPointsOnCirc n rad = take n $ iterate (rotateV (2*pi/fromIntegral n)) (rad,0)
-
---lineInPolygon :: Point2 -> Point2 -> [Point2] -> Bool
---lineInPolygon a b ps = 
---    pointInPolygon a ps 
---    || pointInPolygon b ps 
---    || any (isJust . uncurry (intersectSegSeg' a b)) pss
---  where 
---    pss = zip ps (tail ps ++ [head ps])
-
 -- | Given a list of points, returns pairs of points linking the points into a
 -- loop.
 makeLoopPairs :: [Point2] -> [(Point2,Point2)]

src/Loop.hs

@@ -19,17 +19,17 @@ import qualified Graphics.Rendering.OpenGL as GL
 setupLoop
     :: Int                  -- ^ Target seconds per frame
     -> (Int,Int)            -- ^ The window size.
-    -> (Int,Int)            -- ^ The window position.
+    -> Maybe (Int,Int)            -- ^ The window position.
     -> (world -> IO ())    -- ^ Function for cleaning up parameters, applied when exiting loop.
     -> IO world             -- ^ Initial simulation state.
     -> (world -> IO world)   -- ^ update, called once per frame. Allows for side effects such as rendering.
     -> (world -> Event -> Maybe world)
                             -- ^ SDL Event handling, once per frame. Evaluating 'Nothing' exits the loop.
     -> IO ()
-setupLoop spf (xSize,ySize) (xPos,yPos) paramCleanup ioStartWorld sideEffects eventFn = do 
+setupLoop spf (xSize,ySize) winpos paramCleanup ioStartWorld sideEffects eventFn = do 
     initializeAll
     bracket 
-        (createWindow (T.pack "Simple Game Loop") (winConfig xSize ySize xPos yPos)) 
+        (createWindow (T.pack "Simple Game Loop") (winConfig xSize ySize winpos)) 
         destroyWindow 
         $ \window -> bracket 
             (glCreateContext window) 
@@ -78,13 +78,17 @@ applyEventIO fn mw e = case eventPayload e of
                         -> GL.viewport $= (GL.Position 0 0,GL.Size x y) >> return (mw >>= \w -> fn w e)
     _                   -> return $ mw >>= flip fn e
 -- | Create an OpenGL SDL window configuration with a given x and y size.
-winConfig :: Int -> Int -> Int -> Int -> WindowConfig
+winConfig :: Int -> Int -> Maybe (Int, Int) -> WindowConfig
-winConfig x y px py = defaultWindow 
+winConfig x y winpos = defaultWindow 
     { windowGraphicsContext = OpenGLContext $ defaultOpenGL 
         { glProfile = Core Normal 4 3
         , glColorPrecision = V4 8 8 8 8
         } 
-    , windowPosition = Absolute (P (V2 (fromIntegral px) (fromIntegral py)))
+    , windowPosition = theWinPos
     , windowInitialSize = V2 (fromIntegral x) (fromIntegral y)
     , windowResizable =True
     }
+  where
+    theWinPos = case winpos of
+        Just (px,py) -> Absolute (P (V2 (fromIntegral px) (fromIntegral py)))
+        Nothing      -> Wherever

src/Polyhedra/Data.hs

@@ -21,6 +21,5 @@ newtype Polyhedra = Polyhedron
 newtype VF a = VF
     { _vertices :: M.Map a (Point3, [[a]])
     }
-
 makeLenses ''Polyhedra
 makeLenses ''VF

src/Polyhedra/Geodesic.hs

@@ -71,9 +71,3 @@ facesToVF faces = foldr f M.empty vs
     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

@@ -15,8 +15,6 @@ import Framebuffer.Setup
 import Data.Preload.Render
 
 import Graphics.Rendering.OpenGL hiding (Point,translate,scale,imageHeight)
---import Graphics.GL.Core43
---import Control.Lens
 import Control.Monad
 import Foreign
 import qualified Data.Vector.Mutable as MV

src/Preload/Update.hs

@@ -39,4 +39,3 @@ renderDataResizeUpdate xsize ysize xfull yfull rdata = do
     bbShad <- makeByteStringShaderUsingVAO "bloomBlur" [(vert,bbVert),(frag,bbFrag')] ETriangleStrip
                 (_fullscreenShader rdata)
     return (rdata' {_bloomBlurShader = bbShad})
-

src/Shader/AuxAddition.hs

@@ -9,14 +9,11 @@ module Shader.AuxAddition
 import Shader.Data
 
 import Data.List.Extra
---import Foreign
 import Codec.Picture
 import qualified Data.Vector.Storable as V
 import Control.Lens
 import Graphics.Rendering.OpenGL hiding (Point,translate,scale,imageHeight)
 import Graphics.GL.Core43
---import Graphics.GL.Groups
---import Text.RawString.QQ
     
 -- I am not sure if this assumes that the shader is constructed directly before
 -- the texture is added...
@@ -45,7 +42,6 @@ vaddTextureNoFilter texturePath shad = do
     let wtex = fromIntegral $ imageWidth  tex
         htex = fromIntegral $ imageHeight tex
     glTexStorage2D GL_TEXTURE_2D 1 GL_RGBA8 wtex htex
-    --withArray texData $ \ptr -> do
     V.unsafeWith (imageData tex) $ \ptr -> do
         glTexSubImage2D GL_TEXTURE_2D 0 0 0 wtex htex GL_RGBA GL_UNSIGNED_BYTE ptr
     return $ shad & shadTex ?~ ShaderTexture {_textureObject = textureOb}

src/Shader/Bind.hs

@@ -5,7 +5,6 @@ module Shader.Bind
     ) where
 import Shader.Data
 import Shader.Parameters
---import Shader.ExtraPrimitive
 
 import Graphics.Rendering.OpenGL hiding (Line,translate,scale,imageHeight,Polygon,Color,T)
 import Foreign hiding (rotate)

src/Shader/ExtraPrimitive.hs

@@ -6,6 +6,7 @@ import Graphics.GL.Types
 import Graphics.GL.Tokens
 
 marshalEPrimitiveMode :: EPrimitiveMode -> GLenum
+{-# INLINABLE marshalEPrimitiveMode #-}
 marshalEPrimitiveMode x = case x of
    EPoints -> GL_POINTS
    ELines -> GL_LINES

src/Shader/Poke.hs

@@ -1,12 +1,9 @@
---{-# LANGUAGE TupleSections #-}
---{-# LANGUAGE BangPatterns #-}
 module Shader.Poke
     ( pokeVerxs
     , pokeLayVerxs
     , pokeArrayOff
     , pokePoint33s
     , pokeShape
-    , pokePoint3s
     , pokeWallsWindowsFloor
     ) where
 import Shader.Data
@@ -23,11 +20,6 @@ import qualified Data.Vector.Unboxed.Mutable as UMV
 import qualified Data.Vector.Mutable as MV
 import qualified Data.Vector.Fusion.Stream.Monadic as VS
 import Control.Monad.Primitive
---import Control.Parallel.Strategies
---import System.Environment
---import Control.Monad.Parallel as MP
---import Control.Monad
---import qualified Data.DList as DL
 
 pokeVerxs 
     :: MV.MVector (PrimState IO) FullShader
@@ -186,16 +178,6 @@ pokeJustV ptr counts sh = do
     V3 a b c    = _svPos sh
     V4 d e f g  = _svCol sh
 
-pokePoint3s :: Ptr Float -> VS.Stream IO Point3 -> IO Int
-pokePoint3s ptr = VS.foldlM' (pokePoint3 ptr) 0
-
-pokePoint3 :: Ptr Float -> Int -> Point3 -> IO Int
-pokePoint3 ptr n (V3 a b c) = do
-    pokeElemOff ptr (n * 3) a
-    pokeElemOff ptr (n * 3 + 1) b
-    pokeElemOff ptr (n * 3 + 2) c
-    return $ n + 1
-
 pokeLayVerxs 
     :: MV.MVector (PrimState IO) FullShader 
     -> UMV.MVector (PrimState IO) Int

src/Shape/Data.hs

@@ -8,10 +8,7 @@ module Shape.Data
 import Geometry.Data
 
 import Control.Lens
---import qualified Data.DList as DL
-
 type Shape = [ShapeObj]
-
 _shVertices :: Shape -> [ShapeV]
 {-# INLINE _shVertices #-}
 _shVertices = concatMap _shVs
@@ -43,5 +40,4 @@ data ShapeV = ShapeV
 pairToSV :: (Point3,Point4) -> ShapeV
 {-# INLINE pairToSV #-}
 pairToSV = uncurry ShapeV
-
 makeLenses ''ShapeV

src/Sound/Data.hs

@@ -8,17 +8,14 @@ import Control.Lens
 import Geometry.Data
 import Data.Word (Word8)
 import Data.Int (Int16)
-
 data SoundStatus 
     = JustStartedPlaying
     | Playing
     | ToStart
     | ToContinueStart
   deriving (Eq,Ord,Show)
-
 newtype SoundID = SoundID { _getSoundID :: Int }
   deriving (Eq,Ord,Show)
-
 newtype SoundData = SoundData
     {_loadedChunks :: IM.IntMap Mix.Chunk
     }
@@ -32,6 +29,5 @@ data Sound = Sound
     , _soundChunkID     :: SoundID
     }
   deriving (Eq,Ord,Show)
-
 makeLenses ''SoundData
 makeLenses ''Sound