Allow to change menu options with rclick, move towards shader experiment

shader/lighting/lineShadow.geom

@@ -3,8 +3,10 @@ layout (lines_adjacency) in;
 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));}
+uniform vec4 lumRad;
-vec4 shift (vec4 p) { return (vec4 (p.xyz + (1000*(p.xyz-lightPos)), 1));}
+//vec4 shift (vec4 p) { return (vec4 (p.xyz + (lumRad.a*normalize(p.xyz-lightPos)), 1));}
+vec4 shift (vec4 p) { return (vec4 (p.xyz + (100000*(p.xyz-lightPos)), 1));}
+//vec4 shift (vec4 p) { return (vec4 (lightPos + (lumRad.a*normalize(p.xyz-lightPos)), 1));}
 // copied from lighting/cap.geom, should not be changed on its own
 vec4 projNear (vec4 pos)
 {
@@ -27,6 +29,7 @@ void main()
 {
     vec4 p0 = gl_in[0].gl_Position;
     vec4 p1 = gl_in[1].gl_Position;
+    vec4 mid = 0.5*(p0 + p1);
     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) ;
@@ -34,6 +37,7 @@ void main()
     
     //vec3 n2 = n0 + n1; // assumes the summands are normalized
     vec3 lightDir = p0.xyz - lightPos.xyz;
+    vec3 lightDir2 = p1.xyz - lightPos.xyz;
     // first test if the edge is part of the silhouette
     // that is, if the normals of the faces connected by the edge point are in
     // "different directions" wrt the light direction

src/Data/Preload/Render.hs

@@ -14,6 +14,7 @@ import Control.Monad.Primitive
 data RenderData = RenderData
     { _lightingWallShadShader   :: FullShader
     , _lightingLineShadowShader :: FullShader
+    , _positionalBlankShader    :: FullShader
     , _lightingCapShader        :: FullShader
     , _wallBlankShader          :: FullShader
     , _windowShader             :: FullShader

src/Dodge/Data/Config.hs

@@ -16,7 +16,7 @@ data Configuration = Configuration
     , _volume_music :: Float
     , _graphics_wall_textured :: Bool
     , _graphics_cloud_shadows :: Bool
-    , _graphics_object_shadows :: Bool
+    , _graphics_object_shadows :: ObjectShadows
     , _graphics_resolution_factor :: ResFactor
     , _windowX :: Float
     , _windowY :: Float
@@ -60,6 +60,9 @@ data DebugBool
 data ResFactor = FullRes | HalfRes | QuarterRes
     deriving (Show, Eq, Ord, Enum, Bounded)
 
+data ObjectShadows = GeoObjShads | CPUObjShads | NoObjShads
+    deriving (Show, Eq, Ord, Enum, Bounded)
+
 data RoomClipping = NoRoomClipBoundaries | AllRoomClipBoundaries | IntersectingRoomClipBoundaries
     deriving (Show, Eq, Ord, Enum, Bounded)
 
@@ -74,10 +77,10 @@ defaultConfig =
     Configuration
         { _volume_master = 1
         , _volume_sound = 1
-        , _volume_music = 1
+        , _volume_music = 0
         , _graphics_wall_textured = True
         , _graphics_cloud_shadows = True
-        , _graphics_object_shadows = True
+        , _graphics_object_shadows = GeoObjShads
         , _graphics_resolution_factor = FullRes
         , _windowX = 800
         , _windowY = 600
@@ -93,6 +96,7 @@ debugOn db = S.member db . _debug_booleans
 
 makeLenses ''Configuration
 deriveJSON defaultOptions ''ResFactor
+deriveJSON defaultOptions ''ObjectShadows
 deriveJSON defaultOptions ''RoomClipping
 deriveJSON defaultOptions ''DebugBool
 deriveJSON defaultOptions ''Configuration

src/Dodge/Data/Universe.hs

@@ -60,7 +60,7 @@ data ScreenLayer
         , _scOffset :: Int
         , _scPositionedMenuOption :: PositionedMenuOption
         , _scOptionFlag :: OptionScreenFlag
-        , _scSelectionList :: SelectionList (Universe -> Universe)
+        , _scSelectionList :: SelectionList (Universe -> Universe,Universe->Universe)
         , _scAvailableLines :: Int
         , _scListDisplayParams :: ListDisplayParams
         }

src/Dodge/Menu.hs

@@ -184,7 +184,7 @@ graphicsMenuOptions :: [MenuOption]
 graphicsMenuOptions =
     [ makeEnumOption graphics_resolution_factor "RESOLUTION" (uvIOEffects .~ updateFramebufferSize)
     , makeBoolOption graphics_wall_textured "WALL TEXTURES"
-    , makeBoolOption graphics_object_shadows "OBJECT SHADOWS"
+    , makeEnumOption graphics_object_shadows "OBJECT SHADOWS" id
     , makeBoolOption graphics_cloud_shadows "CLOUD SHADOWS"
     ]
 

src/Dodge/Menu/Option.hs

@@ -1,5 +1,6 @@
 module Dodge.Menu.Option where
 
+import Control.Applicative
 --import Dodge.ScodeToChar
 import Dodge.Default.SelectionList
 import Data.Maybe
@@ -61,14 +62,15 @@ makeOptionsSelectionList ::
     Universe ->
     [MenuOption] ->
     PositionedMenuOption ->
-    SelectionList (Universe -> Universe)
+    SelectionList (Universe -> Universe,Universe -> Universe)
 makeOptionsSelectionList maxlines mselpos u mos pmo =
     defaultSelectionList
         { _slItems = optionsToSelections maxlines u mos pmo
         , _slSelPos = mselpos
         }
 
-optionsToSelections :: Int -> Universe -> [MenuOption] -> PositionedMenuOption -> [SelectionItem (Universe -> Universe)]
+optionsToSelections :: Int -> Universe -> [MenuOption] -> PositionedMenuOption 
+    -> [SelectionItem (Universe -> Universe,Universe -> Universe)]
 optionsToSelections maxlines u allops pmo = case pmo of
     NoPositionedMenuOption -> map (menuOptionToSelectionItem u maxOptionLength) ops
     TopMenuOption mo -> map (menuOptionToSelectionItem u maxOptionLength) (mo : ops)
@@ -115,7 +117,8 @@ optionValueOffset u mo = case _moString mo u of
     MODStringOption s _ -> length s
     _ -> 0
 
-menuOptionToSelectionItem :: Universe -> Int -> MenuOption -> SelectionItem (Universe -> Universe)
+menuOptionToSelectionItem :: Universe -> Int -> MenuOption 
+    -> SelectionItem (Universe -> Universe,Universe -> Universe)
 menuOptionToSelectionItem w padAmount mo =
     SelectionItem
         { _siPictures = [optionText]
@@ -124,13 +127,14 @@ menuOptionToSelectionItem w padAmount mo =
         --, _siWidth = length optionText
         , _siColor = thecol
         , _siOffX = 0
-        , _siPayload = f
+        , _siPayload = (f,g)
         }
   where
     isselectable = case _moString mo w of
         MODBlockedString{} -> False
         _ -> True
-    f = fromMaybe id $ mo ^? moEff
+    f = fromMaybe id $ mo ^? moEff <|> mo ^? moEff1
+    g = fromMaybe id $ mo ^? moEff2
     thecol = case _moString mo w of
         MODBlockedString{} -> greyN 0.5
         _ -> white

src/Dodge/Update/Input/ScreenLayer.hs

@@ -38,7 +38,7 @@ optionScreenUpdate ::
     ScreenLayer ->
     PositionedMenuOption ->
     ListDisplayParams ->
-    SelectionList (Universe -> Universe) ->
+    SelectionList (Universe -> Universe,Universe -> Universe) ->
     Universe ->
     Universe
 optionScreenUpdate screen mop ldps sl u =
@@ -55,17 +55,24 @@ optionScreenDefaultEffect f u = case u ^. uvWorld . input . pressedKeys . at Sca
     Just InitialPress -> fromMaybe id (f ^? pmoMenuOption . moEff) u
     _ -> u
 
+-- ouch this is not good
 mouseClickOptionsList :: ScreenLayer -> Universe -> Universe
 mouseClickOptionsList screen u = fromMaybe u $ do
     sl <- screen ^? scSelectionList
     Just $ case u ^. uvWorld . input . mouseButtons . at ButtonLeft of
         Just False -> fromMaybe u $ do
             i <- sl ^. slSelPos
-            f <- sl ^? slItems . ix i . siPayload
+            f <- sl ^? slItems . ix i . siPayload . _1
             return $ f u
-        _ -> u
+        _ -> case u ^. uvWorld . input . mouseButtons . at ButtonRight of
+            Just False -> fromMaybe u $ do
+                i <- sl ^. slSelPos
+                f <- sl ^? slItems . ix i . siPayload . _2
+                return $ f u
+            _ -> u
 
-mouseOverSelectionList :: ListDisplayParams -> SelectionList (Universe -> Universe) -> Universe -> Universe
+mouseOverSelectionList :: ListDisplayParams 
+    -> SelectionList a -> Universe -> Universe
 mouseOverSelectionList ldps sl u
     | x > xl && x < xr
         && ylower == yupper

src/Preload/Render.hs

@@ -121,7 +121,10 @@ preloadRender = do
                 >>= addUniforms ["lightPos"]
     lightingLineShadowShad
         <- makeShaderUsingVAO "lighting/lineShadow" [vert,geom,frag] ELinesAdjacency shEdgeVAO
-                >>= addUniforms ["lightPos"]
+                >>= addUniforms ["lightPos","lumRad"]
+-- positional shader
+    positionalBlankShad <- makeShader "positional/blank" [vert,frag] [3] ETriangles 
+    
 -- 2D draw shaders
     bslist <- makeShader "dualTwoD/basic"   [vert,frag] [3,4]   ETriangles 
     bslista <- makeShader "dualTwoD/basic"   [vert,frag] [3,4]   ETriangles 
@@ -199,6 +202,7 @@ preloadRender = do
         , _silhouetteEBO = silEBO
         , _lightingCapShader        = lightingCapShad
         , _lightingLineShadowShader = lightingLineShadowShad
+        , _positionalBlankShader         = positionalBlankShad
         , _lightingWallShadShader    = lightingWallShadShad
         , _wallBlankShader          = wallBlankShad
         , _wallTextureShader        = wallTextureShad

src/Render.hs

@@ -7,6 +7,7 @@ module Render
     , bindTO
     , bindFBO
     ) where
+import Dodge.Data.Config
 import Shader
 import Shader.ExtraPrimitive
 import Shader.Data
@@ -20,7 +21,7 @@ import qualified Data.Vector.Unboxed.Mutable as UMV
 import qualified Data.Vector.Mutable as MV
 import Control.Monad.Primitive
 import Graphics.GL.Core43
-import Control.Monad
+--import Control.Monad
 import qualified Data.Vector.Fusion.Stream.Monadic as VFSM
 
 divideSize :: Int -> Size -> Size
@@ -33,7 +34,7 @@ createLightMap
     -> Int -- ^ number of walls
     -> Int -- ^ number of silhoutte lines to draw
     -> Int -- ^ number of "caps" to attempt to draw
-    -> Bool -- ^ whether to draw object shadows or not
+    -> ObjectShadows -- ^ whether to draw object shadows or not
     -> TextureObject -- ^ the texture object giving positions
     -> IO ()
 createLightMap pdata lightPoints nWalls nSils nCaps drawObjShads toPos = do
@@ -71,28 +72,32 @@ createLightMap pdata lightPoints nWalls nSils nCaps drawObjShads toPos = do
             (marshalEPrimitiveMode $ _shadPrim lwShad) 
             0 
             (fromIntegral nWalls)
-        when drawObjShads $ do
+        case drawObjShads of
-            --draw silhouette shadows
+            GeoObjShads -> do
-            currentProgram $= Just (_shadProg llsShad)
+                --draw silhouette shadows
-            uniform (head $  _shadUnis $ _lightingLineShadowShader pdata)
+                currentProgram $= Just (_shadProg llsShad)
-                $= Vector3 x y z
+                uniform (head $  _shadUnis $ _lightingLineShadowShader pdata)
-            bindVertexArrayObject $= Just (_vao $ _shadVAO llsShad)
+                    $= Vector3 x y z
-            glDrawElements
+                uniform (_shadUnis ltShad !! 1)
-                (marshalEPrimitiveMode $ _shadPrim llsShad) 
+                    $= Vector4 r g b rad
-                (fromIntegral nSils)
+                bindVertexArrayObject $= Just (_vao $ _shadVAO llsShad)
-                GL_UNSIGNED_SHORT
+                glDrawElements
-                nullPtr
+                    (marshalEPrimitiveMode $ _shadPrim llsShad) 
-            cullFace $= Just Back
+                    (fromIntegral nSils)
-            --draw caps on the near plane as required
+                    GL_UNSIGNED_SHORT
-            currentProgram $= Just (_shadProg lcShad)
+                    nullPtr
-            uniform (head $  _shadUnis lcShad)
+                --draw caps on the near plane as required
-                $= Vector3 x y z
+                cullFace $= Just Back
-            bindVertexArrayObject $= Just (_vao $ _shadVAO lcShad)
+                currentProgram $= Just (_shadProg lcShad)
-            glDrawElements
+                uniform (head $  _shadUnis lcShad)
-                (marshalEPrimitiveMode $ _shadPrim lcShad) 
+                    $= Vector3 x y z
-                (fromIntegral nCaps)
+                bindVertexArrayObject $= Just (_vao $ _shadVAO lcShad)
-                GL_UNSIGNED_SHORT
+                glDrawElements
-                nullPtr
+                    (marshalEPrimitiveMode $ _shadPrim lcShad) 
+                    (fromIntegral nCaps)
+                    GL_UNSIGNED_SHORT
+                    nullPtr
+            _ -> return ()
         --draw lightmap itself
         depthFunc $= Just Always
         -- bind world position texture