justin/loop
1
0
Fork 0
Code Issues Pull Requests 1 Packages Projects Releases Wiki Activity

Work on textures and lighting

Browse Source
This commit is contained in:
justin
2023-03-23 21:17:24 +00:00
parent 1a2fc7c715
commit 1abfaa3cd0
25 changed files with 641 additions and 710 deletions
Download Patch File Download Diff File Expand all files Collapse all files
src/Data/Preload/Render.hs
-4
View File
@@ -21,8 +21,6 @@ data RenderData = RenderData
, _shadowWallShader :: Shader
, _shadowLightShader :: (Shader,VBO)
, _shadowCombineShader :: (Shader,VBO)
--, _positionalBlankShader :: (Shader,VBO)
, _wallBlankShader :: Shader
, _windowShader :: Shader
, _fullscreenShader :: Shader
, _bloomBlurShader :: Shader
@@ -53,8 +51,6 @@ data RenderData = RenderData
, _vboShapes :: VBO
, _floorVBO :: VBO
, _floorShader :: Shader
, _texaNormalMaps :: TO
, _texaDiffuse :: TO
, _wallVBO :: VBO
, _wallShader :: Shader
, _cloudVBO :: VBO
src/Dodge/Creature/HandPos.hs
+30 -30
View File
@@ -49,12 +49,12 @@ translateToRightHand cr = translateToRightHand' cr -- . mirrorSPxz
translateToRightHand' :: Creature -> SPic -> SPic
translateToRightHand' cr
| oneH cr = shoulderSP . translateSPf 11 (-3) . rotateSP (-0.5) -- . scaleSH (V3 1 1.5 1)
| twists cr = shoulderSP . translateSPf 0 5 . rotateSP (-1) . translateSPf 4 (-10)
| twoFlat cr = waistSP . translateSPf 4 (-8)
| oneH cr = shoulderSP . translateSPxy 11 (-3) . rotateSP (-0.5) -- . scaleSH (V3 1 1.5 1)
| twists cr = shoulderSP . translateSPxy 0 5 . rotateSP (-1) . translateSPxy 4 (-10)
| twoFlat cr = waistSP . translateSPxy 4 (-8)
| otherwise = case cr ^? crStance . carriage of
Just (Walking sa LeftForward) -> waistSP . translateSPf (- f sa) (- off)
_ -> waistSP . translateSPf 0 (- off)
Just (Walking sa LeftForward) -> waistSP . translateSPxy (- f sa) (- off)
_ -> waistSP . translateSPxy 0 (- off)
where
off = 8
sLen = _strideLength $ _crStance cr
@@ -65,12 +65,12 @@ translateToRightWrist cr = translateToRightWrist' cr -- . mirrorSPxz
translateToRightWrist' :: Creature -> SPic -> SPic
translateToRightWrist' cr
| oneH cr = shoulderSP . translateSPf 11 (-3) . rotateSP (-0.5) . offTrans -- . scaleSH (V3 1 1.5 1)
| twists cr = shoulderSP . translateSPf 0 5 . rotateSP (-1) . translateSPf 4 (-10) . offTrans
| twoFlat cr = waistSP . translateSPf 4 (-8) . offTrans
| oneH cr = shoulderSP . translateSPxy 11 (-3) . rotateSP (-0.5) . offTrans -- . scaleSH (V3 1 1.5 1)
| twists cr = shoulderSP . translateSPxy 0 5 . rotateSP (-1) . translateSPxy 4 (-10) . offTrans
| twoFlat cr = waistSP . translateSPxy 4 (-8) . offTrans
| otherwise = case cr ^? crStance . carriage of
Just (Walking sa LeftForward) -> waistSP . translateSPf (- f sa) (- off) . offTrans
_ -> waistSP . translateSPf 0 (- off) . offTrans
Just (Walking sa LeftForward) -> waistSP . translateSPxy (- f sa) (- off) . offTrans
_ -> waistSP . translateSPxy 0 (- off) . offTrans
where
offTrans = translateSP (V3 0 4 (-4))
off = 8
@@ -92,12 +92,12 @@ translatePointToLeftHand cr
translateToLeftHand :: Creature -> SPic -> SPic
translateToLeftHand cr
| oneH cr = waistSP . rotateSP 0.4 . translateSPf 0 off
| twists cr = shoulderSP . translateSPf 0 5 . rotateSP (-1) . translateSPf 12 4
| twoFlat cr = waistSP . translateSPf 4 8
| oneH cr = waistSP . rotateSP 0.4 . translateSPxy 0 off
| twists cr = shoulderSP . translateSPxy 0 5 . rotateSP (-1) . translateSPxy 12 4
| twoFlat cr = waistSP . translateSPxy 4 8
| otherwise = case cr ^? crStance . carriage of
Just (Walking sa RightForward) -> waistSP . translateSPf (- f sa) off
_ -> waistSP . translateSPf 0 off
Just (Walking sa RightForward) -> waistSP . translateSPxy (- f sa) off
_ -> waistSP . translateSPxy 0 off
where
off = 8
sLen = _strideLength $ _crStance cr
@@ -105,12 +105,12 @@ translateToLeftHand cr
translateToLeftWrist :: Creature -> SPic -> SPic
translateToLeftWrist cr
| oneH cr = waistSP . rotateSP 0.4 . translateSPf 0 off . offTrans
| twists cr = shoulderSP . translateSPf 0 5 . rotateSP (-1) . translateSPf 12 4 . offTrans
| twoFlat cr = waistSP . translateSPf 4 8 . offTrans
| oneH cr = waistSP . rotateSP 0.4 . translateSPxy 0 off . offTrans
| twists cr = shoulderSP . translateSPxy 0 5 . rotateSP (-1) . translateSPxy 12 4 . offTrans
| twoFlat cr = waistSP . translateSPxy 4 8 . offTrans
| otherwise = case cr ^? crStance . carriage of
Just (Walking sa RightForward) -> waistSP . translateSPf (- f sa) off . offTrans
_ -> waistSP . translateSPf 0 off . offTrans
Just (Walking sa RightForward) -> waistSP . translateSPxy (- f sa) off . offTrans
_ -> waistSP . translateSPxy 0 off . offTrans
where
offTrans = translateSP (V3 0 4 (-4))
off = 8
@@ -120,9 +120,9 @@ translateToLeftWrist cr
translateToLeftLeg :: Creature -> SPic -> SPic
translateToLeftLeg cr =
rotateSP (_crMvDir cr - _crDir cr) . case cr ^? crStance . carriage of
Just (Walking sa LeftForward) -> translateSPf (f sa) off
Just (Walking sa RightForward) -> translateSPf (- f sa) off
_ -> translateSPf 0 off
Just (Walking sa LeftForward) -> translateSPxy (f sa) off
Just (Walking sa RightForward) -> translateSPxy (- f sa) off
_ -> translateSPxy 0 off
where
off = 5
sLen = _strideLength $ _crStance cr
@@ -131,9 +131,9 @@ translateToLeftLeg cr =
translateToRightLeg :: Creature -> SPic -> SPic
translateToRightLeg cr =
rotateSP (_crMvDir cr - _crDir cr) . case cr ^? crStance . carriage of
Just (Walking sa LeftForward) -> translateSPf (- f sa) (- off)
Just (Walking sa RightForward) -> translateSPf (f sa) (- off)
_ -> translateSPf 0 (- off)
Just (Walking sa LeftForward) -> translateSPxy (- f sa) (- off)
Just (Walking sa RightForward) -> translateSPxy (f sa) (- off)
_ -> translateSPxy 0 (- off)
where
off = 5
sLen = _strideLength $ _crStance cr
@@ -142,12 +142,12 @@ translateToRightLeg cr =
translateToHead :: Creature -> SPic -> SPic
translateToHead cr
| twists cr =
translateSPz 20 . translateSPf 0 5 . rotateSP (-1) . translateSPf (negate 2.5) 0.25
translateSPz 20 . translateSPxy 0 5 . rotateSP (-1) . translateSPxy (negate 2.5) 0.25
. rotateSP 1
| oneH cr =
translateSPz 20 . rotateSP 0.5 . translateSPf 2.5 0
translateSPz 20 . rotateSP 0.5 . translateSPxy 2.5 0
. rotateSP (negate 0.5)
| otherwise = translateSPz 20 . translateSPf 2.5 0
| otherwise = translateSPz 20 . translateSPxy 2.5 0
translatePointToHead :: Creature -> Point3 -> Point3
translatePointToHead cr
@@ -162,7 +162,7 @@ translatePointToHead cr
translateToChest :: Creature -> SPic -> SPic
translateToChest cr
| oneH cr = rotateSP 0.5
-- | twists cr = translateSPf 0 5 . rotateSP (-1)
-- | twists cr = translateSPxy 0 5 . rotateSP (-1)
| twists cr = rotateSP (-1)
| otherwise = id
src/Dodge/Creature/Picture.hs
+1 -1
View File
@@ -23,7 +23,7 @@ import qualified Quaternion as Q
import ShapePicture
basicCrPict :: Creature -> SPic
basicCrPict cr = uncurryV translateSPf (_crPos cr) (rotateSP (_crDir cr) $ drawEquipment cr)
basicCrPict cr = uncurryV translateSPxy (_crPos cr) (rotateSP (_crDir cr) $ drawEquipment cr)
<> (basicCrShape cr, mempty)
--testShape :: Shape
src/Dodge/Data/Config.hs
+4 -3
View File
@@ -39,7 +39,7 @@ data Configuration = Configuration
, _volume_sound :: Float
, _volume_music :: Float
, _graphics_cloud_shadows :: Bool
, _graphics_object_shadows :: ObjectShadows
, _graphics_object_shadows :: ShadowRendering
, _graphics_resolution_factor :: ResFactor
, _graphics_num_shadow_casters :: NumShadowCasters
, _windowX :: Float
@@ -84,7 +84,8 @@ data DebugBool
data ResFactor = FullRes | HalfRes | QuarterRes
deriving (Show, Eq, Ord, Enum, Bounded)
data ObjectShadows = GeoObjShads
data ShadowRendering
= GeoObjShads
| InstancingShads
| NoObjShads
| NoShadows
@@ -125,7 +126,7 @@ debugOn db = S.member db . _debug_booleans
makeLenses ''Configuration
deriveJSON defaultOptions ''NumShadowCasters
deriveJSON defaultOptions ''ResFactor
deriveJSON defaultOptions ''ObjectShadows
deriveJSON defaultOptions ''ShadowRendering
deriveJSON defaultOptions ''RoomClipping
deriveJSON defaultOptions ''DebugBool
deriveJSON defaultOptions ''Configuration
src/Dodge/HeldUse.hs
+1 -1
View File
@@ -353,7 +353,7 @@ useMod hm = case hm of
moddelay x = itUse . heldConsumption . laAmmoType . amBullet . buDelayFraction .~ x
modcrpos x cr =
cr & crDir %~ tweenAngles x (_crOldDir cr)
& crPos %~ tweenPoints x (_crOldPos cr)
& crPos %~ alongSegBy x (_crOldPos cr)
mcUseHeld :: HeldItemType -> Item -> Machine -> World -> World
mcUseHeld hit = case hit of
src/Dodge/Projectile/Draw.hs
+1 -1
View File
@@ -34,7 +34,7 @@ drawRemoteShell pj
| t > (-99) = green
| otherwise = red
t = _prjTimer pj
doposition = translateSPz 18 . uncurryV translateSPf (_prjPos pj) . rotateSP (_prjDir pj)
doposition = translateSPz 18 . uncurryV translateSPxy (_prjPos pj) . rotateSP (_prjDir pj)
remoteShellShape :: Color -> SPic
remoteShellShape col =
src/Dodge/Prop/Draw.hs
+1 -1
View File
@@ -22,7 +22,7 @@ drawProp pd = case pd of
PropDrawToggle pd' -> propDrawToggle pd'
PropDrawGib x -> noPic . drawGib x
PropDrawFlatTranslate x -> \pr ->
uncurryV translateSPf (_prPos pr) $ rotateSP (_prRot pr) $ drawProp x pr
uncurryV translateSPxy (_prPos pr) $ rotateSP (_prRot pr) $ drawProp x pr
drawGib :: Float -> Prop -> Shape
drawGib x pr = flesh <> skin
src/Dodge/Render.hs
+16 -15
View File
@@ -5,6 +5,7 @@ module Dodge.Render (
--import qualified Data.Vector as V
import Dodge.DownscaleSize
import Data.List (sortOn)
import Shader.Poke.Cloud
import GLHelp
@@ -187,14 +188,14 @@ doDrawing' win pdata u = do
--draw lightmap into its own buffer
createLightMap
cfig
pdata
lightPoints
(u ^. uvConfig . graphics_object_shadows)
nWalls
nSilIndices
nIndices
(u ^. uvConfig . graphics_object_shadows)
(pdata ^. fboBase . _2 . _2)
(pdata ^. fboBase . _2 . _3)
lightPoints
pdata
glColorMask GL_TRUE GL_TRUE GL_TRUE GL_TRUE
--apply lightmap to base buffer
glBindFramebuffer GL_FRAMEBUFFER (pdata ^. fboBase . _1 . unFBO)
@@ -221,13 +222,14 @@ doDrawing' win pdata u = do
glDepthMask GL_TRUE
renderLayer BloomLayer shadV layerCounts
--setup downscale viewport for blurring bloom
setViewportSize (round winx `div` (2 * resFact)) (round winy `div` (2 * resFact))
--setViewportSize (round winx `div` (2 * resFact)) (round winy `div` (2 * resFact))
setViewportSize (round winx `div` downSize) (round winy `div` downSize)
glBindFramebuffer GL_FRAMEBUFFER (_unFBO (fst (_fboHalf1 pdata)))
glDepthFunc GL_ALWAYS
glBindTextureUnit 0 (pdata ^. fboBloom . _2 . unTO)
glDisable GL_BLEND
drawShader (_bloomBlurShader pdata) 4
replicateM_ 9 $ pingPongBetween (_fboHalf1 pdata) (_fboHalf2 pdata) (_bloomBlurShader pdata)
replicateM_ 2 $ pingPongBetween (_fboHalf1 pdata) (_fboHalf2 pdata) (_bloomBlurShader pdata)
glEnable GL_BLEND
setViewportSize (round winx `div` resFact) (round winy `div` resFact)
--draw clouds onto cloud buffer
@@ -302,21 +304,21 @@ doDrawing' win pdata u = do
glBindFramebuffer GL_FRAMEBUFFER (_unFBO (fst (_fboLighting pdata)))
createLightMap
cfig
pdata
lightPoints
(_graphics_object_shadows $ _uvConfig u)
nWalls
nSilIndices
nIndices
(_graphics_object_shadows $ _uvConfig u)
(pdata ^. fboPos . _2)
(pdata ^. fboCloud . _2 . _3)
lightPoints
pdata
glInvalidateBufferData (pdata ^. vboShapes . vboName)
--apply lightmap to cloud buffer
glBindFramebuffer GL_FRAMEBUFFER (_unFBO (fst (_fboCloud pdata)))
glDepthMask GL_FALSE
withArray [GL_COLOR_ATTACHMENT0, GL_NONE] $ \ptr -> glDrawBuffers 2 ptr
glDepthFunc GL_ALWAYS
glBindTexture GL_TEXTURE_2D (_unTO . snd $ _fboLighting pdata)
glBindTextureUnit 0 (_unTO . snd $ _fboLighting pdata)
glEnable GL_BLEND
glBlendFuncSeparate GL_ZERO GL_ONE_MINUS_SRC_COLOR GL_ZERO GL_ONE
drawShader (_fullscreenShader pdata) 4
@@ -326,20 +328,21 @@ doDrawing' win pdata u = do
--Draw blurred bloom onto base buffer
glEnable GL_BLEND
glBlendFunc GL_SRC_ALPHA GL_ONE
glBindTexture GL_TEXTURE_2D (_unTO . snd $ _fboHalf1 pdata)
glBindTextureUnit 0 (_unTO . snd $ _fboHalf1 pdata)
drawShader (_fullscreenShader pdata) 4
glBlendFunc GL_SRC_ALPHA GL_ONE_MINUS_SRC_ALPHA
--draw shadowed clouds onto base buffer
glBindTexture GL_TEXTURE_2D (pdata ^. fboCloud . _2 . _1 . unTO)
glBindTextureUnit 0 (pdata ^. fboCloud . _2 . _1 . unTO)
drawShader (_fullscreenShader pdata) 4
--set viewport for radial distortion
setViewportSize (round winx) (round winy)
glDepthFunc GL_ALWAYS
glBlendFunc GL_ONE GL_ZERO
-- perform any radial distortion
-- this is hideous
case w ^. cWorld . lWorld . distortions of
[] -> do
bindTO $ pdata ^. fboBase . _2 . _1
glBindTextureUnit 0 $ pdata ^. fboBase . _2 . _1 . unTO
glBindFramebuffer GL_FRAMEBUFFER 0
drawShader (_fullscreenShader pdata) 4
rds -> do
@@ -352,10 +355,8 @@ doDrawing' win pdata u = do
take (length rds - 1) (concat (repeat [fst $ _fbo2 pdata, fst $ _fbo3 pdata]))
++ [FBO 0]
toList = (pdata ^. fboBase . _2 . _1) : concat (repeat [snd $ _fbo2 pdata, snd $ _fbo3 pdata])
bindings = zipWith (>>) (map bindFBO fboList) (map bindTO toList)
glActiveTexture GL_TEXTURE1
bindings = zipWith (>>) (map bindFBO fboList) (map (glBindTextureUnit 1 . _unTO) toList)
zipWithM_ (>>) bindings $ map bindDrawDist rds
glActiveTexture GL_TEXTURE1
glDepthFunc GL_ALWAYS
glEnable GL_BLEND
glBlendFunc GL_SRC_ALPHA GL_ONE_MINUS_SRC_ALPHA
src/Dodge/Render/ShapePicture.hs
+14 -21
View File
@@ -2,8 +2,6 @@ module Dodge.Render.ShapePicture (
worldSPic,
) where
import Dodge.Render.Picture
import Dodge.Data.Universe
import Control.Lens
import Control.Monad (guard)
import Data.Foldable
@@ -14,6 +12,7 @@ import qualified Data.Set as Set
import Dodge.Base
import Dodge.Creature.Picture
import Dodge.Creature.Picture.Awareness
import Dodge.Data.Universe
import Dodge.Debug.Picture
import Dodge.Draw
import Dodge.Flare
@@ -25,6 +24,7 @@ import Dodge.RadarBlip
import Dodge.Render.InfoBox
import Dodge.Render.Label
import Dodge.Render.List
import Dodge.Render.Picture
import Dodge.ShortShow
import Dodge.SoundLogic.LoadSound
import Dodge.Viewpoints
@@ -36,7 +36,7 @@ import Geometry.ConvexPoly
import qualified IntMapHelp as IM
import Padding
import Picture
import Polyhedra
import Shape
import ShapePicture
import ShortShow
import Sound.Data
@@ -108,21 +108,14 @@ drawCreature cr = case _crType cr of
]
)
cr
Lampoid{_lampHeight = h} -> picAtCrPosNoRot1 (lampCrPic h) cr
Lampoid{_lampHeight = h} -> uncurryV translateSPxy (_crPos cr) $ lampCrSPic h
NonDrawnCreature -> mempty
lampCrPic :: Float -> Picture
lampCrPic h =
pictures
[ setLayer BloomLayer (setDepth h . color white $ circleSolid 3)
, foldMap (polyToTris . map f) $ boxXYZnobase 5 5 (h -1)
]
where
f pos = Verx (pos -.-.- V3 2.5 2.5 0) blue [] BottomLayer polyNum
picAtCrPosNoRot1 :: Picture -> Creature -> SPic
--{-# INLINE picAtCrPos #-}
picAtCrPosNoRot1 thePic cr = (,) mempty $ uncurryV translate (_crPos cr) thePic
lampCrSPic :: Float -> SPic
lampCrSPic h =
( colorSH blue . upperBox h $ rectWH 5 5
, setLayer BloomLayer (setDepth h . color white $ circleSolid 3)
)
picAtCrPos1 :: Picture -> Creature -> SPic
--{-# INLINE picAtCrPos #-}
@@ -130,13 +123,13 @@ picAtCrPos1 thePic cr = (,) mempty $ tranRot (_crPos cr) (_crDir cr) thePic
shiftDraw :: (a -> Point2) -> (a -> Float) -> (a -> a -> SPic) -> a -> SPic
shiftDraw fpos fdir fdraw x =
uncurryV translateSPf (fpos x)
uncurryV translateSPxy (fpos x)
. rotateSP (fdir x)
$ fdraw x x
shiftDraw' :: (a -> Point2) -> (a -> Float) -> (a -> SPic) -> a -> SPic
shiftDraw' fpos fdir fdraw x =
uncurryV translateSPf (fpos x)
uncurryV translateSPxy (fpos x)
. rotateSP (fdir x)
$ fdraw x
@@ -366,17 +359,17 @@ ppDraw c = uncurryV translate (_ppPos c) $ rotate (_ppRot c) (_ppPict c)
floorItemSPic :: FloorItem -> SPic
floorItemSPic flit =
uncurryV translateSPf (_flItPos flit) $
uncurryV translateSPxy (_flItPos flit) $
rotateSP (_flItRot flit) (itemSPic (_flIt flit))
btSPic :: Button -> SPic
btSPic bt =
uncurryV translateSPf (_btPos bt) $
uncurryV translateSPxy (_btPos bt) $
rotateSP (_btRot bt) (drawButton (_btPict bt) bt)
mcSPic :: Machine -> SPic
mcSPic mc =
uncurryV translateSPf (_mcPos mc) $
uncurryV translateSPxy (_mcPos mc) $
rotateSP (_mcDir mc) (drawMachine mc)
soundPic :: Configuration -> World -> Sound -> Picture
src/Framebuffer/Update.hs
+2 -1
View File
@@ -7,6 +7,7 @@ module Framebuffer.Update (
sizeFBOs,
) where
import Dodge.DownscaleSize
import Shader.Data
import Framebuffer.Check
import Control.Lens
@@ -45,7 +46,7 @@ sizeFBOs xsize ysize xfull yfull rdata = do
[fbo2, fbo3]
rdata4 <-
foldM
(updateFBOTO (xsize `div` 2) (ysize `div` 2) GL_LINEAR_MIPMAP_LINEAR GL_LINEAR GL_RGBA16F)
(updateFBOTO (xfull `div` downSize) (yfull `div` downSize) GL_LINEAR_MIPMAP_LINEAR GL_LINEAR GL_RGBA16F)
rdata'''
[fboHalf1, fboHalf2, fboHalf3]
newShadowFBO <- resizeShadowFBO (rdata ^. fboShadow) xsize ysize
src/Geometry.hs
+228 -187
View File
@@ -1,345 +1,386 @@
{-# LANGUAGE BangPatterns #-}
{-|
{- |
Module : Geometry
Description : Geometry helpers
This module provides geometry functions that manipulate pairs of floats.
Conventions:
Conventions:
Seg refers to a segment, typically defined by two points, and will typically not extend beyond either of these points.
Line refers to a line defined by two points, and extends beyond the two points.
-}
module Geometry
( module Geometry
, module Geometry.Data
, module Geometry.Intersect
, module Geometry.Bezier
, module Geometry.Vector
, module Geometry.Vector3D
, module Geometry.LHS
, module Geometry.Polygon
, loopPairs
) where
import Geometry.Data
import Geometry.Polygon
import Geometry.Intersect
import Geometry.Bezier
import Geometry.Vector
import Geometry.Vector3D
import Geometry.LHS
import ListHelp
--import Geometry.ConvexPoly
module Geometry (
module Geometry,
module Geometry.Data,
module Geometry.Intersect,
module Geometry.Bezier,
module Geometry.Vector,
module Geometry.Vector3D,
module Geometry.LHS,
module Geometry.Polygon,
module Geometry.Triangulate,
loopPairs,
) where
import qualified Data.Set as S
import Geometry.Bezier
import Geometry.Data
import Geometry.Intersect
import Geometry.LHS
import Geometry.Polygon
import Geometry.Triangulate
import Geometry.Vector
import Geometry.Vector3D
import ListHelp
--import Data.Maybe
--import Data.List
-- | Return a point a distance away from a first point towards a second point.
-- Does not go past the second point.
{- | Return a point a distance away from a first point towards a second point.
Does not go past the second point.
No check is made for a negative distance, so can go past the first point.
-}
alongSegBy :: Float -> Point2 -> Point2 -> Point2
alongSegBy !x !a !b = a +.+ y *.* normalizeV (b -.- a)
where
y = min x $ dist a b
tweenPoints :: Float -> Point2 -> Point2 -> Point2
tweenPoints = alongSegBy
-- | Debug version of 'pointInPolygon'.
errorPointInPolygon :: Int -> Point2 -> [Point2] -> Bool
errorPointInPolygon !i !p xs
errorPointInPolygon !i !p xs
| length xs == 1 = error "one point polygon"
| length xs == 2 = error "two point polygon"
| nub xs == xs = pointInPolygon p xs
| otherwise = error $ "errorPointInPolygon "++ show i
| otherwise = error $ "errorPointInPolygon " ++ show i
-- | Debug version of 'normalizeV'.
errorNormalizeV :: Int -> Point2 -> Point2
errorNormalizeV !i (V2 0 0) = error $ "problem with function: errorNormalizeV "++show i
errorNormalizeV !i (V2 0 0) = error $ "problem with function: errorNormalizeV " ++ show i
errorNormalizeV _ !p = normalizeV p
-- | Debug version of 'angleVV'.
errorAngleVV :: Int -> Point2 -> Point2 -> Float
errorAngleVV !i (V2 0 0) _ = error $ "problem with function: errorAngleVV "++show i
errorAngleVV !i _ (V2 0 0) = error $ "problem with function: errorAngleVV "++show i
errorAngleVV _ !p !p' = angleVV p p'
errorAngleVV !i (V2 0 0) _ = error $ "problem with function: errorAngleVV " ++ show i
errorAngleVV !i _ (V2 0 0) = error $ "problem with function: errorAngleVV " ++ show i
errorAngleVV _ !p !p' = angleVV p p'
-- | Debug version of 'isLHS'.
errorIsLHS :: Int -> Point2 -> Point2 -> Point2 -> Bool
errorIsLHS !i !x !y
| x == y = error $ "problem with function: errorIsLHS " ++show i
errorIsLHS !i !x !y
| x == y = error $ "problem with function: errorIsLHS " ++ show i
| otherwise = isLHS x y
-- | Debug version of 'closestPointOnLine'
errorClosestPointOnLine :: Int -> Point2 -> Point2 -> Point2 -> Point2
errorClosestPointOnLine !i !x !y
| x == y = error $ "problem with function: errorClosestPointOnLine " ++show i
errorClosestPointOnLine !i !x !y
| x == y = error $ "problem with function: errorClosestPointOnLine " ++ show i
| otherwise = closestPointOnLine x y
-- | Debug version of 'closestPointOnLineParam'
errorClosestPointOnLineParam :: Int -> Point2 -> Point2 -> Point2 -> Float
errorClosestPointOnLineParam _ !x !y !z
| x == y = dist x z
errorClosestPointOnLineParam _ !x !y !z
| x == y = dist x z
| otherwise = closestPointOnLineParam x y z
-- | Return midpoint between two points.
midPoint :: Point2 -> Point2 -> Point2
midPoint !a !b = 0.5 *.* (a +.+ b)
-- | Test whether a circle is on a segment by intersecting a new normal segment through the
-- center of the circle with the segment itself.
-- Returns False if the circle center is beyond the endpoints of the
-- segment.
{- | Test whether a circle is on a segment by intersecting a new normal segment through the
center of the circle with the segment itself.
Returns False if the circle center is beyond the endpoints of the
segment.
-}
circOnSegNoEndpoints :: Point2 -> Point2 -> Point2 -> Float -> Bool
{-# INLINE circOnSegNoEndpoints #-}
circOnSegNoEndpoints !p1 !p2 !c !rad = intersectSegSegTest p1 p2 (c -.- thenormal) (c +.+ thenormal)
where
thenormal = rad *.* vNormal (normalizeV $ p1 -.- p2)
-- | Test whether a circle is on a segment by intersecting a normal and testing
-- the distance to the endpoints of the segment.
-- Perhaps a better order of arguments.
circOnSeg :: Point2 -> Float -> Point2 -> Point2 -> Bool
{-# INLINE circOnSeg #-}
circOnSeg !c !rad !p1 !p2 = magV (p1 -.- c) <= rad
|| magV (p2 -.- c) <= rad
|| intersectSegSegTest p1 p2 (c -.- thenormal) (c +.+ thenormal)
where
where
thenormal = rad *.* vNormal (normalizeV $ p1 -.- p2)
-- | Test whether a segment intersects a circle by intersecting a normal and testing
-- the distance to the endpoints of the segment.
{- | Test whether a circle is on a segment by intersecting a normal and testing
the distance to the endpoints of the segment.
Perhaps a better order of arguments.
-}
circOnSeg :: Point2 -> Float -> Point2 -> Point2 -> Bool
{-# INLINE circOnSeg #-}
circOnSeg !c !rad !p1 !p2 =
magV (p1 -.- c) <= rad
|| magV (p2 -.- c) <= rad
|| intersectSegSegTest p1 p2 (c -.- thenormal) (c +.+ thenormal)
where
thenormal = rad *.* vNormal (normalizeV $ p1 -.- p2)
{- | Test whether a segment intersects a circle by intersecting a normal and testing
the distance to the endpoints of the segment.
-}
segOnCirc :: Point2 -> Point2 -> Point2 -> Float -> Bool
{-# INLINE segOnCirc #-}
segOnCirc !p1 !p2 !c !rad = magV (p1 -.- c) <= rad
|| magV (p2 -.- c) <= rad
|| intersectSegSegTest p1 p2 (c -.- thenormal) (c +.+ thenormal)
where
segOnCirc !p1 !p2 !c !rad =
magV (p1 -.- c) <= rad
|| magV (p2 -.- c) <= rad
|| intersectSegSegTest p1 p2 (c -.- thenormal) (c +.+ thenormal)
where
thenormal = rad *.* vNormal (normalizeV $ p1 -.- p2)
cylinderOnSeg :: Point3 -> Point3 -> Point3 -> Float -> Bool
{-# INLINE cylinderOnSeg #-}
cylinderOnSeg = undefined
-- | Find the difference between two Nums.
difference :: (Ord a, Num a) => a -> a -> a
{-# INLINE difference #-}
difference x y
| x > y = x - y
difference x y
| x > y = x - y
| otherwise = y - x
-- | Given vector line direction and a vector movement,
-- reflects the movement according to the line.
{- | Given vector line direction and a vector movement,
reflects the movement according to the line.
-}
reflectIn :: Point2 -> Point2 -> Point2
reflectIn line vec = rotateV (2 * angleBetween line vec) vec
-- | Find angle between two points.
-- Not normalised, ranges from -2*pi to 2*pi.
{- | Find angle between two points.
Not normalised, ranges from -2*pi to 2*pi.
-}
angleBetween :: Point2 -> Point2 -> Float
angleBetween v1 v2 = argV v1 - argV v2
-- | Return a list containing two copies of a pair.
doublePair :: (a,a) -> [(a,a)]
doublePair (x,y) = [(x,y),(y,x)]
doublePair :: (a, a) -> [(a, a)]
doublePair (x, y) = [(x, y), (y, x)]
-- this shouldn't be here
doublePairSet :: Ord a => (a,a) -> S.Set (a,a)
doublePairSet (x,y) = S.fromList [(x,y),(y,x)]
doublePairSet :: Ord a => (a, a) -> S.Set (a, a)
doublePairSet (x, y) = S.fromList [(x, y), (y, x)]
doubleV2 :: V2 a -> [V2 a]
doubleV2 (V2 x y) = [V2 x y,V2 y x]
-- split a list into triples, forms triangles from a polygon
polyToTris'' :: [s] -> [s]
polyToTris'' (a:as) = go a as
where
go !x (y:z:ys) = x : y : z : go x (z:ys)
go _ _ = []
polyToTris'' _ = []
doubleV2 (V2 x y) = [V2 x y, V2 y x]
polyToTris :: [s] -> [s]
{-# INLINABLE polyToTris #-}
--polyToTris (x:xs) = foldr (f x) [] $ foldPairs xs
polyToTris (x:xs) = foldl' (flip $ f x) [] $ zip xs $ tail xs
--polyToTris (x:xs) = foldr (f x) [] $ zip xs $ tail xs
where
f a (b,c) ls = a:b:c:ls
polyToTris _ = []
polyToTris' :: [s] -> [s]
{-# INLINE polyToTris' #-}
polyToTris' [] = []
polyToTris' (a:as) = prependTwo a as
polyToTris' (a : as) = prependTwo a as
prependTwo :: a -> [a] -> [a]
prependTwo sep (x:y:xs) = sep : x : y : prependTwo sep (y:xs)
prependTwo sep (x : y : xs) = sep : x : y : prependTwo sep (y : xs)
prependTwo _ _ = []
-- | Return n equidistant points on a circle with a radius of 600.
nRays :: Int -> [Point2]
nRays n = nRaysRad n 600
-- | Return n equidistant points on a circle with a radius of x.
nRaysRad :: Int -> Float -> [Point2]
nRaysRad n x = take n $ iterate (rotateV (2*pi/fromIntegral n)) (V2 x 0)
-- | Test whether an angle is to the left of another angle, according to the
-- smallest change in rotation between them.
-- This appears to sometimes fail if the angles are not normalized.
nRaysRad n x = take n $ iterate (rotateV (2 * pi / fromIntegral n)) (V2 x 0)
{- | Test whether an angle is to the left of another angle, according to the
smallest change in rotation between them.
This appears to sometimes fail if the angles are not normalized.
-}
isLeftOfA :: Float -> Float -> Bool
--isLeftOfA angle1 angle2 = (angle1 - angle2 < pi && angle1 > angle2)
-- || (angle2 - angle1 > pi && angle2 > angle1)
isLeftOfA angle1 angle2 = normalizeAngle (angle1 - angle2) < pi
-- | Test whether a vector is to the left of another, according to the smallest
-- change of rotation between them.
{- | Test whether a vector is to the left of another, according to the smallest
change of rotation between them.
-}
isLeftOf :: Point2 -> Point2 -> Bool
isLeftOf x y = isLeftOfA (argV x) (argV y)
-- | Find the difference between two angles.
-- Possibly not correct...
-- TODO write tests
{- | Find the difference between two angles.
Possibly not correct...
TODO write tests
-}
diffAngles :: Float -> Float -> Float
diffAngles x y
| diff > pi = diffAngles (x - 2*pi) y
| diff >= 0 = diff
| diff > -pi = -diff
| otherwise = diffAngles (x + 2*pi) y
where
diff = x-y
diffAngles x y
| diff > pi = diffAngles (x - 2 * pi) y
| diff >= 0 = diff
| diff > - pi = - diff
| otherwise = diffAngles (x + 2 * pi) y
where
diff = x - y
mixAngles :: Float -> Float -> Float -> Float
mixAngles frac a1 a2
| abs (a1 - a2) <= pi = normalizeAngle $ frac * a1 + (1 - frac) * a2
| a1 > a2 = mixAngles frac (a1 - 2*pi) a2
| otherwise = mixAngles frac (a1 + 2*pi) a2
| a1 > a2 = mixAngles frac (a1 - 2 * pi) a2
| otherwise = mixAngles frac (a1 + 2 * pi) a2
-- | Return Just a point if it is inside a circle, Nothing otherwise.
pointInCircle :: Point2 -> Float -> Point2 -> Maybe Point2
pointInCircle p r c
pointInCircle p r c
| p == c = Just p
| magV (p -.- c) < r = Just p
| otherwise = Nothing
-- | Finds the height of a triangle using herons formula.
-- The base is the line between the first two points.
{- | Finds the height of a triangle using herons formula.
The base is the line between the first two points.
-}
heron :: Point2 -> Point2 -> Point2 -> Float
heron x y z
heron x y z
| x == y = 0
| otherwise =
| otherwise =
let a = magV $ x -.- y
b = magV $ y -.- z
c = magV $ z -.- x
s = (a+b+c)/2
area = sqrt(s*(s-a)*(s-b)*(s-c))
in 2*area/a
s = (a + b + c) / 2
area = sqrt (s * (s - a) * (s - b) * (s - c))
in 2 * area / a
-- | Multiplies reflection in normal by factor.
reflectInParam :: Float -> Point2 -> Point2 -> Point2
reflectInParam x line vec =
reflectInParam x line vec =
let angle = 2 * angleBetween line vec
rAng = rotateV angle vec
p = x *.* errorClosestPointOnLine 3 (V2 0 0) (vNormal line) rAng
in rAng -.- p
in rAng -.- p
isOnSeg :: Point2 -> Point2 -> Point2 -> Bool
isOnSeg l1 l2 p =
isOnSeg l1 l2 p =
errorClosestPointOnLineParam 10 l1 (l1 +.+ vNormal (l2 -.- l1)) p == 0
&& errorClosestPointOnLineParam 11 l1 l2 p <= 1
&& errorClosestPointOnLineParam 12 l1 l2 p >= 0
-- | Divide a segment into a list of points with a maximal distance between
-- them.
-- the take 5000 here is a hack, otherwise divideLine seems to sometimes
-- generate an infinite list, and I don't know why
&& errorClosestPointOnLineParam 11 l1 l2 p <= 1
&& errorClosestPointOnLineParam 12 l1 l2 p >= 0
{- | Divide a segment into a list of points with a maximal distance between
them.
the take 5000 here is a hack, otherwise divideLine seems to sometimes
generate an infinite list, and I don't know why
-}
divideLine :: Float -> Point2 -> Point2 -> [Point2]
--divideLine x a b = map (\i -> a +.+ (i / (fromIntegral numPoints)) *.* (b -.- a))
divideLine x a b = take 5000
$ map (\i -> a +.+ (fromIntegral i / fromIntegral numPoints *.* (b -.- a)) )
ns
where
--divideLine x a b = map (\i -> a +.+ (i / (fromIntegral numPoints)) *.* (b -.- a))
divideLine x a b =
take 5000 $
map
(\i -> a +.+ (fromIntegral i / fromIntegral numPoints *.* (b -.- a)))
ns
where
d = dist a b
numPoints = max 1 $ ceiling $ d / x
ns = [0 :: Int .. numPoints]
-- | As 'divideLine', but must return an odd number of points.
divideLineOddNumPoints :: Float -> Point2 -> Point2 -> [Point2]
--divideLine x a b = map (\i -> a +.+ (i / (fromIntegral numPoints)) *.* (b -.- a))
divideLineOddNumPoints x a b = take 5000
$ map (\i -> a +.+ (fromIntegral i / fromIntegral numPoints *.* (b -.- a)) )
ns
where
--divideLine x a b = map (\i -> a +.+ (i / (fromIntegral numPoints)) *.* (b -.- a))
divideLineOddNumPoints x a b =
take 5000 $
map
(\i -> a +.+ (fromIntegral i / fromIntegral numPoints *.* (b -.- a)))
ns
where
d = dist a b
numPoints' = max 1 $ ceiling $ d / x
numPoints
| even numPoints' = numPoints'
| otherwise = numPoints' + 1
| otherwise = numPoints' + 1
ns = [0 .. numPoints] :: [Int]
divideLineExact :: Float -> Point2 -> Point2 -> [Point2]
divideLineExact x a b = map ( (a +.+ ) . ( *.* v) ) [0 , x .. d]
where
divideLineExact x a b = map ((a +.+) . (*.* v)) [0, x .. d]
where
d = dist a b
v = normalizeV $ b -.- a
-- | Given two pairs of Ints, returns a list of pairs of Ints that form
-- a digital line between them.
digitalLine :: (Int,Int) -> (Int,Int) -> [(Int,Int)]
{- | Given two pairs of Ints, returns a list of pairs of Ints that form
a digital line between them.
-}
digitalLine :: (Int, Int) -> (Int, Int) -> [(Int, Int)]
--{-# INLINE digitalLine #-}
digitalLine (x1,y1) (x2,y2)
| abs (x1-x2) > abs (y1-y2) =
[ (x,( (y1-y2) * x + x1*y2 - x2*y1) `rdiv` (x1-x2) )
| x <- intervalList x1 x2
digitalLine (x1, y1) (x2, y2)
| abs (x1 - x2) > abs (y1 - y2) =
[ (x, ((y1 - y2) * x + x1 * y2 - x2 * y1) `rdiv` (x1 - x2))
| x <- intervalList x1 x2
]
| otherwise =
[ ( ((x1-x2) * y + y1*x2 - y2*x1) `rdiv` (y1-y2) , y)
| y <- intervalList y1 y2
| otherwise =
[ (((x1 - x2) * y + y1 * x2 - y2 * x1) `rdiv` (y1 - y2), y)
| y <- intervalList y1 y2
]
where
where
rdiv a b = round $ fromIntegral a / (fromIntegral b :: Float)
-- | Given two pairs of 'Int's, create a list of pairs of 'Int's that form a
-- rectangle between them.
digitalRect :: (Int,Int) -> (Int,Int) -> [(Int,Int)]
{- | Given two pairs of 'Int's, create a list of pairs of 'Int's that form a
rectangle between them.
-}
digitalRect :: (Int, Int) -> (Int, Int) -> [(Int, Int)]
{-# INLINE digitalRect #-}
digitalRect (a,b) (c,d) = [(s,t) | s <- [minx .. maxx] , t <- [miny .. maxy]]
digitalRect (a, b) (c, d) = [(s, t) | s <- [minx .. maxx], t <- [miny .. maxy]]
where
maxx = max a c
minx = min a c
maxy = max b d
miny = min b d
-- | Given two Ints, creates the list of Ints between these.
intervalList :: Int -> Int -> [Int]
{-# INLINE intervalList #-}
intervalList x y
intervalList x y
| y > x = [x .. y]
| otherwise = reverse [y..x]
-- | Create points on the circumference of a circle with maximal distance
-- between them.
| otherwise = reverse [y .. x]
{- | Create points on the circumference of a circle with maximal distance
between them.
-}
divideCircle :: Float -> Point2 -> Float -> [Point2]
divideCircle x cen rad = map (cen +.+) $ nRaysRad n rad
where
where
n = ceiling $ rad * 2 * pi / x
arcStepwise
:: Float -- ^ Maximum distance between points
-> Float -- ^ Angle to travel
-> Point2 -- ^ Center
-> Point2 -- ^ Start vector from center
-> [Point2]
arcStepwise ::
-- | Maximum distance between points
Float ->
-- | Angle to travel
Float ->
-- | Center
Point2 ->
-- | Start vector from center
Point2 ->
[Point2]
arcStepwise ssize a c v
| a < 0 = reverse $ arcStepwisePositive ssize (negate a) c (rotateV a v)
| otherwise = arcStepwisePositive ssize a c v
arcStepwisePositive
:: Float -- ^ Maximum distance between points
-> Float -- ^ Angle to travel, assumed to be positive
-> Point2 -- ^ Center
-> Point2 -- ^ Start vector from center
-> [Point2]
arcStepwisePositive ::
-- | Maximum distance between points
Float ->
-- | Angle to travel, assumed to be positive
Float ->
-- | Center
Point2 ->
-- | Start vector from center
Point2 ->
[Point2]
arcStepwisePositive ssize a cen v = (cen +.+) . (`rotateV` v) <$> rots
where
rots :: [Float]
rots = map ((a*) . (/ fromIntegral n ) . fromIntegral) [0 .. n]
rots = map ((a *) . (/ fromIntegral n) . fromIntegral) [0 .. n]
n :: Int
n = ceiling (a * magV v / ssize)
-- | Given a list of points, returns pairs of points linking the points into a
-- loop.
chainPairs :: [Point2] -> [(Point2,Point2)]
{- | Given a list of points, returns pairs of points linking the points into a
loop.
-}
chainPairs :: [Point2] -> [(Point2, Point2)]
chainPairs [] = error "tried to make chain with empty list of points"
chainPairs [_] = error "tried to make chain with singleton list of points"
chainPairs xs = zip xs $ tail xs
-- | Given a list of points, returns pairs of points linking the points into a
-- loop.
--loopPairs :: [a] -> [(a,a)]
--loopPairs [] = error "tried to make loop with empty list of elements"
--loopPairs [_] = error "tried to make loop with singleton list of elements"
--loopPairs (x:xs) = zip (x:xs) (xs ++ [x])
-- | Test whether a point is in a cone.
-- Note the pair is ordered.
-- Doesn't work for obtuse angles.
pointIsInCone
:: Point2 -- ^ Cone point.
-> (Point2,Point2) -- ^ Points delimiting the left and right boundaries of the cone.
-> Point2 -- ^ Point to test.
-> Bool
pointIsInCone c (rightp,leftp) p = isLHS c rightp p && isLHS leftp c p
{- | Given a list of points, returns pairs of points linking the points into a
loop.
loopPairs :: [a] -> [(a,a)]
loopPairs [] = error "tried to make loop with empty list of elements"
loopPairs [_] = error "tried to make loop with singleton list of elements"
loopPairs (x:xs) = zip (x:xs) (xs ++ [x])
| Test whether a point is in a cone.
Note the pair is ordered.
Doesn't work for obtuse angles.
-}
pointIsInCone ::
-- | Cone point.
Point2 ->
-- | Points delimiting the left and right boundaries of the cone.
(Point2, Point2) ->
-- | Point to test.
Point2 ->
Bool
pointIsInCone c (rightp, leftp) p = isLHS c rightp p && isLHS leftp c p
src/Preload/Render.hs
+13 -18
View File
@@ -127,15 +127,15 @@ preloadRender = do
poke (shadVBOptr shadowlightshader) 1
-- 2D draw shaders
bslist <- makeShader "dualTwoD/basic" [vert, frag] [3, 4] pmTriangles
bslista <- makeShader4 "shape/basic" [vert, frag] shapeVerxSizes nShapeVerxComp pmTriangles shVBO
bslist <- makeShaderVBO "dualTwoD/basic" [vert, frag] [3, 4] pmTriangles
bslista <- makeShaderUsingVBO "shape/basic" [vert, frag] shapeVerxSizes nShapeVerxComp pmTriangles shVBO
glVertexArrayElementBuffer (bslista ^. shaderVAO . vaoName) (shEBO' ^. eboName)
--glVertexArrayElementBuffer (bslista ^. shaderVAO . vaoName) shEBOname
aslist <- makeShader "dualTwoD/arc" [vert, frag] [3, 4, 3] pmTriangles
eslist <- makeShader "dualTwoD/ellipse" [vert, geom, frag] [3, 4] pmTriangles
aslist <- makeShaderVBO "dualTwoD/arc" [vert, frag] [3, 4, 3] pmTriangles
eslist <- makeShaderVBO "dualTwoD/ellipse" [vert, geom, frag] [3, 4] pmTriangles
cslist <-
makeShader "picture/charArray" [vert, frag] [3, 4, 4] pmTriangles
addBindTextureArray 50 "data/texture/charMapVert.png" 2 16 32 95 GL_NEAREST_MIPMAP_LINEAR GL_LINEAR
makeShaderVBO "picture/charArray" [vert, frag] [3, 4, 4] pmTriangles
initTexture2DArray 50 "data/texture/charMapVert.png" 2 16 32 95 GL_NEAREST_MIPMAP_LINEAR GL_LINEAR
screentexturevbo <- mglCreate glCreateBuffers
withArray (concat cornerList) $ \ptr ->
@@ -145,26 +145,24 @@ preloadRender = do
ptr
0
screentexturevao <- setupVAOvbo' [2,2] 4 screentexturevbo
alphadivideshader <- makeShader4UsingVAO "texture2D/alphaDivide" [vert,frag] pmTriangleStrip screentexturevao
fsShad <- makeShader4UsingVAO "texture/simple" [vert, frag] pmTriangleStrip screentexturevao
alphadivideshader <- makeShaderUsingVAO "texture2D/alphaDivide" [vert,frag] pmTriangleStrip screentexturevao
fsShad <- makeShaderUsingVAO "texture/simple" [vert, frag] pmTriangleStrip screentexturevao
bloomBlurShad <- makeShaderUsingVAO "texture/bloomBlur" [vert, frag] pmTriangleStrip screentexturevao
colorBlurShad <- makeShaderUsingVAO "texture/colorBlur" [vert, frag] pmTriangleStrip screentexturevao
grayscaleShad <- makeShaderUsingVAO "texture/grayscale" [vert, frag] pmTriangleStrip screentexturevao
lightingTextureShad <-
makeShaderUsingVAO "lighting/texture" [vert, frag] pmTriangleStrip screentexturevao
barrelShad <- makeShader "texture/barrel" [vert, geom, frag] [2, 2, 2, 1] pmPoints
barrelShad <- makeShaderVBO "texture/barrel" [vert, geom, frag] [2, 2, 2, 1] pmPoints
-- blank wallShader
wallBlankShad <- makeShaderUsingVAO "wall/blank" [vert, geom, frag] pmPoints wpColVAO
let wallverxstrd = 8
wallvbo <- setupVBO wallverxstrd
wallshader <- makeShader4 "wall/basic" [vert,geom,frag] [4,4] wallverxstrd pmPoints wallvbo
wallshader <- makeShaderUsingVBO "wall/basic" [vert,geom,frag] [4,4] wallverxstrd pmPoints wallvbo
let floorverxstrd = 8
floorvbo <- setupVBOStatic floorverxstrd
floorshader <- makeShader4 "floor/arrayPos" [vert, frag] [4,4] floorverxstrd pmTriangles floorvbo
todiffusemap <- initTexture2DArray 3 GL_LINEAR_MIPMAP_LINEAR GL_LINEAR "data/normalMaps/diffuseArray.png"
tonormalmap <- initTexture2DArray 3 GL_LINEAR_MIPMAP_LINEAR GL_LINEAR "data/normalMaps/normalArray.png"
glBindTextureUnit 40 (todiffusemap ^. unTO)
glBindTextureUnit 41 (tonormalmap ^. unTO)
floorshader <- makeShaderUsingVBO "floor/arrayPos" [vert, frag] [4,4] floorverxstrd pmTriangles floorvbo
initTexture2DArraySquare 40 3 GL_LINEAR_MIPMAP_LINEAR GL_LINEAR "data/normalMaps/diffuseArray.png"
initTexture2DArraySquare 41 3 GL_LINEAR_MIPMAP_LINEAR GL_LINEAR "data/normalMaps/normalArray.png"
let cloudverxsizes = [4,4,4,4]
cloudvbo <- setupVBO (sum cloudverxsizes)
@@ -220,7 +218,6 @@ preloadRender = do
, _shadowWallShader = shadowwallshader
, _shadowLightShader = shadowlightshader
, _shadowCombineShader = shadowcombineshader
, _wallBlankShader = wallBlankShad
, _windowShader = wallBlankShad{_shaderVAO = winColVAO}
, _fullscreenShader = fsShad
, _alphaDivideShader = alphadivideshader
@@ -249,8 +246,6 @@ preloadRender = do
, _vboShapes = shVBO
, _floorVBO = floorvbo
, _floorShader = floorshader
, _texaNormalMaps = tonormalmap
, _texaDiffuse = todiffusemap
, _wallVBO = wallvbo
, _wallShader = wallshader
, _cloudVBO = cloudvbo
src/Render.hs
+190 -183
View File
@@ -2,7 +2,6 @@ module Render (
createLightMap,
renderLayer,
pingPongBetween,
bindTO,
bindFBO,
) where
@@ -28,8 +27,7 @@ import Shader.Data
-}
createLightMap ::
Configuration ->
RenderData ->
[(Point3, Float, Point3)] -> -- Lights
ShadowRendering ->
-- | number of walls
Int ->
@@ -37,173 +35,188 @@ createLightMap ::
Int ->
-- | number of "caps" to attempt to draw
Int ->
-- | whether to draw object shadows or not
ObjectShadows ->
-- | the texture object giving positions
TO ->
-- | the texture object giving normals
TO ->
[(Point3, Float, Point3)] -> -- Lights
RenderData ->
IO ()
createLightMap cfig pdata lightPoints nWalls nSils nCaps shadsdrawtype
positiontexture
normaltexture
= case shadsdrawtype of
InstancingShads -> instanceLightMap cfig pdata lightPoints nWalls nSils nCaps positiontexture
NoShadows -> do
glBindFramebuffer GL_FRAMEBUFFER (_unFBO (fst (_fboLighting pdata)))
let ltextShad = _lightingTextureShader pdata
-- we assume that the renderbuffer's depth has been correctly set elsewhere
-- we will not be changing that here
glDepthMask GL_FALSE
-- clearColor is specified differently in preloadRender
-- the colors are inverted
withArray [1,1,1,1] $ \ptr -> glClearNamedFramebufferfv
createLightMap cfig shadrendertype = case shadrendertype of
InstancingShads -> instanceLightMap cfig
NoShadows -> const . const . const renderLightingNoShadows
NoLighting -> const . const . const . const . const . const renderFlatLighting
_ -> renderShadows shadrendertype
renderLightingNoShadows ::
TO ->
TO ->
[(V3 GLfloat, GLfloat, V3 GLfloat)] ->
RenderData ->
IO ()
renderLightingNoShadows positiontexture normaltexture lightPoints pdata = do
glBindFramebuffer GL_FRAMEBUFFER (_unFBO (fst (_fboLighting pdata)))
let ltextShad = _lightingTextureShader pdata
-- we assume that the renderbuffer's depth has been correctly set elsewhere
-- we will not be changing that here
glDepthMask GL_FALSE
-- clearColor is specified differently in preloadRender
-- the colors are inverted
withArray [1, 1, 1, 1] $ \ptr ->
glClearNamedFramebufferfv
(pdata ^. fboLighting . _1 . unFBO)
GL_COLOR
0
ptr
-- for each of the lights:
-- 1. stencil out the shadows from this light's point of view
-- 2. calculate lighting based on each fragment's position
-- to consider: adding normals/a "material" for each fragment
glBlendFunc GL_ZERO GL_ONE_MINUS_SRC_COLOR
glEnable GL_STENCIL_TEST
glStencilOpSeparate GL_FRONT GL_KEEP GL_KEEP GL_INCR_WRAP
glStencilOpSeparate GL_BACK GL_KEEP GL_KEEP GL_DECR_WRAP
flip VFSM.mapM_ (VFSM.fromList lightPoints) $ \(V3 x y z, rad, V3 r g b) -> do
glDepthFunc GL_LESS
-- setup stencil
glColorMask GL_FALSE GL_FALSE GL_FALSE GL_FALSE
with 0 $ \ptr -> glClearNamedFramebufferiv
-- for each of the lights:
-- 1. stencil out the shadows from this light's point of view
-- 2. calculate lighting based on each fragment's position
-- to consider: adding normals/a "material" for each fragment
glBlendFunc GL_ZERO GL_ONE_MINUS_SRC_COLOR
glEnable GL_STENCIL_TEST
glStencilOpSeparate GL_FRONT GL_KEEP GL_KEEP GL_INCR_WRAP
glStencilOpSeparate GL_BACK GL_KEEP GL_KEEP GL_DECR_WRAP
flip VFSM.mapM_ (VFSM.fromList lightPoints) $ \(V3 x y z, rad, V3 r g b) -> do
glDepthFunc GL_LESS
-- setup stencil
glColorMask GL_FALSE GL_FALSE GL_FALSE GL_FALSE
with 0 $ \ptr ->
glClearNamedFramebufferiv
(pdata ^. fboLighting . _1 . unFBO)
GL_STENCIL
0
ptr
glDisable GL_CULL_FACE
glStencilFunc GL_ALWAYS 0 255
--draw lightmap itself
glDepthFunc GL_ALWAYS
-- bind world position texture
glBindTextureUnit 0 (positiontexture ^. unTO)
glColorMask GL_TRUE GL_TRUE GL_TRUE GL_TRUE
glStencilFunc GL_EQUAL 0 255
glUseProgram (ltextShad ^. shaderUINT)
glUniform3f 0 x y z
glUniform4f 1 r g b rad
glBindVertexArray $ ltextShad ^. shaderVAO . vaoName
glDrawArrays
(_unPrimitiveMode (_shaderPrimitive ltextShad))
0
(fromIntegral (4 :: Int))
--cleanup: may not be necessary, depending on what comes after...
ptr
glDisable GL_CULL_FACE
glDisable GL_STENCIL_TEST
NoLighting -> do
glBindFramebuffer GL_FRAMEBUFFER (_unFBO (fst (_fboLighting pdata)))
glBlendFunc GL_ZERO GL_ONE_MINUS_SRC_COLOR
withArray [0,0,0,1] $ \ptr -> glClearNamedFramebufferfv
glStencilFunc GL_ALWAYS 0 255
--draw lightmap itself
glDepthFunc GL_ALWAYS
-- bind world position texture
glBindTextureUnit 0 (positiontexture ^. unTO)
glBindTextureUnit 1 (normaltexture ^. unTO)
glColorMask GL_TRUE GL_TRUE GL_TRUE GL_TRUE
glStencilFunc GL_EQUAL 0 255
glUseProgram (ltextShad ^. shaderUINT)
glUniform3f 0 x y z
glUniform4f 1 r g b rad
glBindVertexArray $ ltextShad ^. shaderVAO . vaoName
glDrawArrays
(_unPrimitiveMode (_shaderPrimitive ltextShad))
0
(fromIntegral (4 :: Int))
--cleanup: may not be necessary, depending on what comes after...
glDisable GL_CULL_FACE
glDisable GL_STENCIL_TEST
renderFlatLighting :: RenderData -> IO ()
renderFlatLighting pdata = do
glBindFramebuffer GL_FRAMEBUFFER (_unFBO (fst (_fboLighting pdata)))
withArray [1, 1, 1, 1] $ \ptr ->
glClearNamedFramebufferfv
(pdata ^. fboLighting . _1 . unFBO)
GL_COLOR
0
ptr
with 1 $ \ptr -> glClearNamedFramebufferfv
with 1 $ \ptr ->
glClearNamedFramebufferfv
(pdata ^. fboLighting . _1 . unFBO)
GL_DEPTH
0
ptr
glDisable GL_CULL_FACE
glBindTextureUnit 0 (positiontexture ^. unTO)
glDepthFunc GL_ALWAYS
glDepthMask GL_FALSE
_ -> do
glBindFramebuffer GL_FRAMEBUFFER (_unFBO (fst (_fboLighting pdata)))
let llinesShad = _lightingLineShadowShader pdata
lcapShad = _lightingCapShader pdata
lwallShad = _lightingWallShadShader pdata
ltextShad = _lightingTextureShader pdata
-- we assume that the renderbuffer's depth has been correctly set elsewhere
-- we will not be changing that here
glDepthMask GL_FALSE
-- clearColor is specified differently in preloadRender
-- the colors are inverted
withArray [1,1,1,1] $ \ptr -> glClearNamedFramebufferfv
(pdata ^. fboLighting . _1 . unFBO)
GL_COLOR
0
ptr
-- for each of the lights:
-- 1. stencil out the shadows from this light's point of view
-- 2. calculate lighting based on each fragment's position
-- to consider: adding normals/a "material" for each fragment
glBlendFunc GL_ZERO GL_ONE_MINUS_SRC_COLOR
glEnable GL_STENCIL_TEST
glStencilOpSeparate GL_FRONT GL_KEEP GL_KEEP GL_INCR_WRAP
glStencilOpSeparate GL_BACK GL_KEEP GL_KEEP GL_DECR_WRAP
flip VFSM.mapM_ (VFSM.fromList lightPoints) $ \(V3 x y z, rad, V3 r g b) -> do
glDepthFunc GL_LESS
-- setup stencil
glColorMask GL_FALSE GL_FALSE GL_FALSE GL_FALSE
with 0 $ \ptr -> glClearNamedFramebufferiv
(pdata ^. fboLighting . _1 . unFBO)
GL_STENCIL
0
ptr
glDisable GL_CULL_FACE
glStencilFunc GL_ALWAYS 0 255
--draw wall shadows
glUseProgram (_shaderUINT lwallShad)
glUniform3f 0 x y z
glUniform1f 1 rad
glBindVertexArray $ lwallShad ^. shaderVAO . vaoName -- Just (_vao $ _shadVAO lwallShad)
glDrawArrays
(_unPrimitiveMode $ _shaderPrimitive lwallShad)
0
(fromIntegral nWalls)
case shadsdrawtype of
GeoObjShads -> do
--draw silhouette shadows
glEnable GL_DEPTH_CLAMP
glUseProgram (_shaderUINT llinesShad)
glUniform3f 0 x y z
glUniform1f 1 rad
glBindVertexArray (_vaoName $ _shaderVAO llinesShad)
glDrawElements
(_unPrimitiveMode $ _shaderPrimitive llinesShad)
(fromIntegral nSils)
GL_UNSIGNED_SHORT
nullPtr
--draw caps on the near plane as required
glEnable GL_CULL_FACE
glCullFace GL_BACK
glCullFace GL_FRONT
glUseProgram (_shaderUINT lcapShad)
glUniform3f 0 x y z
glBindVertexArray $ lcapShad ^. shaderVAO . vaoName --Just (_vao $ _shadVAO lcapShad)
glDrawElements
(_unPrimitiveMode $ _shaderPrimitive lcapShad)
(fromIntegral nCaps)
GL_UNSIGNED_SHORT
nullPtr
glDisable GL_DEPTH_CLAMP
NoObjShads -> return ()
--draw lightmap itself
glDepthFunc GL_ALWAYS
-- bind world position texture
glDisable GL_CULL_FACE
glBindTextureUnit 0 (positiontexture ^. unTO)
glBindTextureUnit 1 (normaltexture ^. unTO)
glColorMask GL_TRUE GL_TRUE GL_TRUE GL_TRUE
glStencilFunc GL_EQUAL 0 255
glUseProgram (ltextShad ^. shaderUINT) --Just (_shadProg ltextShad)
glUniform3f 0 x y z
glUniform4f 1 r g b rad
glBindVertexArray $ ltextShad ^. shaderVAO . vaoName -- Just (_vao $ _shadVAO ltextShad)
glDrawArrays
(_unPrimitiveMode (_shaderPrimitive ltextShad))
0
(fromIntegral (4 :: Int))
--cleanup: may not be necessary, depending on what comes after...
glDisable GL_STENCIL_TEST
glDisable GL_CULL_FACE
glDepthFunc GL_ALWAYS
glDepthMask GL_FALSE
renderShadows shadrendertype nWalls nSils nCaps positiontexture normaltexture lightPoints pdata = do
glBindFramebuffer GL_FRAMEBUFFER (_unFBO (fst (_fboLighting pdata)))
let llinesShad = _lightingLineShadowShader pdata
lcapShad = _lightingCapShader pdata
lwallShad = _lightingWallShadShader pdata
ltextShad = _lightingTextureShader pdata
-- we assume that the renderbuffer's depth has been correctly set elsewhere
-- we will not be changing that here
glDepthMask GL_FALSE
-- clearColor is specified differently in preloadRender
-- the colors are inverted
withArray [1, 1, 1, 1] $ \ptr ->
glClearNamedFramebufferfv
(pdata ^. fboLighting . _1 . unFBO)
GL_COLOR
0
ptr
-- for each of the lights:
-- 1. stencil out the shadows from this light's point of view
-- 2. calculate lighting based on each fragment's position
-- to consider: adding normals/a "material" for each fragment
glBlendFunc GL_ZERO GL_ONE_MINUS_SRC_COLOR
glEnable GL_STENCIL_TEST
glStencilOpSeparate GL_FRONT GL_KEEP GL_KEEP GL_INCR_WRAP
glStencilOpSeparate GL_BACK GL_KEEP GL_KEEP GL_DECR_WRAP
flip VFSM.mapM_ (VFSM.fromList lightPoints) $ \(V3 x y z, rad, V3 r g b) -> do
glDepthFunc GL_LESS
-- setup stencil
glColorMask GL_FALSE GL_FALSE GL_FALSE GL_FALSE
with 0 $ \ptr ->
glClearNamedFramebufferiv
(pdata ^. fboLighting . _1 . unFBO)
GL_STENCIL
0
ptr
glDisable GL_CULL_FACE
glStencilFunc GL_ALWAYS 0 255
--draw wall shadows
glUseProgram (_shaderUINT lwallShad)
glUniform3f 0 x y z
glUniform1f 1 rad
glBindVertexArray $ lwallShad ^. shaderVAO . vaoName -- Just (_vao $ _shadVAO lwallShad)
glDrawArrays
(_unPrimitiveMode $ _shaderPrimitive lwallShad)
0
(fromIntegral nWalls)
case shadrendertype of
GeoObjShads -> do
--draw silhouette shadows
glEnable GL_DEPTH_CLAMP
glUseProgram (_shaderUINT llinesShad)
glUniform3f 0 x y z
glUniform1f 1 rad
glBindVertexArray (_vaoName $ _shaderVAO llinesShad)
glDrawElements
(_unPrimitiveMode $ _shaderPrimitive llinesShad)
(fromIntegral nSils)
GL_UNSIGNED_SHORT
nullPtr
--draw caps on the near plane as required
glEnable GL_CULL_FACE
glCullFace GL_BACK
glCullFace GL_FRONT
glUseProgram (_shaderUINT lcapShad)
glUniform3f 0 x y z
glBindVertexArray $ lcapShad ^. shaderVAO . vaoName --Just (_vao $ _shadVAO lcapShad)
glDrawElements
(_unPrimitiveMode $ _shaderPrimitive lcapShad)
(fromIntegral nCaps)
GL_UNSIGNED_SHORT
nullPtr
glDisable GL_DEPTH_CLAMP
NoObjShads -> return ()
--draw lightmap itself
glDepthFunc GL_ALWAYS
-- bind world position texture
glDisable GL_CULL_FACE
glBindTextureUnit 0 (positiontexture ^. unTO)
glBindTextureUnit 1 (normaltexture ^. unTO)
glColorMask GL_TRUE GL_TRUE GL_TRUE GL_TRUE
glStencilFunc GL_EQUAL 0 255
glUseProgram (ltextShad ^. shaderUINT) --Just (_shadProg ltextShad)
glUniform3f 0 x y z
glUniform4f 1 r g b rad
glBindVertexArray $ ltextShad ^. shaderVAO . vaoName -- Just (_vao $ _shadVAO ltextShad)
glDrawArrays
(_unPrimitiveMode (_shaderPrimitive ltextShad))
0
(fromIntegral (4 :: Int))
--cleanup: may not be necessary, depending on what comes after...
glDisable GL_STENCIL_TEST
lightsToArray :: [(Point3, Float, Point3)] -> [Float]
lightsToArray xs =
@@ -213,11 +226,9 @@ lightsToArray xs =
t (V3 a b c, _, _) = [a, b, c, 1]
s (_, d, V3 e f g) = [e, f, g, d]
instanceLightMap ::
Configuration ->
RenderData ->
[(Point3, Float, Point3)] -> -- Lights
-- | number of walls
Int ->
-- | number of silhoutte lines to draw
@@ -226,8 +237,11 @@ instanceLightMap ::
Int ->
-- | the texture object giving positions
TO ->
TO ->
[(Point3, Float, Point3)] -> -- Lights
RenderData ->
IO ()
instanceLightMap cfig pdata lightPoints nWalls nSils nCaps toPos = do
instanceLightMap cfig nWalls nSils nCaps toPos tanormals lightPoints pdata = do
let lcapShad = _shadowCapShader pdata
(xsize, ysize) = getWindowSize cfig
withArray (lightsToArray lightPoints) $ \ptr ->
@@ -251,16 +265,18 @@ instanceLightMap cfig pdata lightPoints nWalls nSils nCaps toPos = do
1
glBindFramebuffer GL_FRAMEBUFFER $ pdata ^. fboShadow . _1 . unFBO
glDepthMask GL_FALSE
withArray [0,0,0,0] $ \ptr -> glClearNamedFramebufferfv
(pdata ^. fboShadow . _1 . unFBO)
GL_COLOR
0
ptr
with 0 $ \ptr -> glClearNamedFramebufferiv
(pdata ^. fboShadow . _1 . unFBO)
GL_STENCIL
0
ptr
withArray [0, 0, 0, 0] $ \ptr ->
glClearNamedFramebufferfv
(pdata ^. fboShadow . _1 . unFBO)
GL_COLOR
0
ptr
with 0 $ \ptr ->
glClearNamedFramebufferiv
(pdata ^. fboShadow . _1 . unFBO)
GL_STENCIL
0
ptr
-- stencil out the shadows from each light's point of view
-- setup stencil
glEnable GL_STENCIL_TEST
@@ -303,8 +319,7 @@ instanceLightMap cfig pdata lightPoints nWalls nSils nCaps toPos = do
glStencilFunc GL_EQUAL 0 255
glUseProgram (pdata ^. shadowLightShader . _1 . shaderUINT)
-- bind world position texture
bindTO toPos
-- glBindVertexArray $ pdata ^. shadowLightShader . shaderVAO' . vaoName
glBindTextureUnit 0 (toPos ^. unTO)
glDrawArrays
(_unPrimitiveMode $ pdata ^. shadowLightShader . _1 . shaderPrimitive)
0
@@ -313,12 +328,13 @@ instanceLightMap cfig pdata lightPoints nWalls nSils nCaps toPos = do
glDisable GL_STENCIL_TEST
--draw to the lighting framebuffer here
glBindFramebuffer GL_FRAMEBUFFER (_unFBO (fst (_fboLighting pdata)))
withArray [1,1,1,1] $ \ptr -> glClearNamedFramebufferfv
(pdata ^. fboLighting . _1 . unFBO)
GL_COLOR
0
ptr
glBindTexture GL_TEXTURE_2D_ARRAY (pdata ^. fboShadow . _2 . _1 . unTO)
withArray [1, 1, 1, 1] $ \ptr ->
glClearNamedFramebufferfv
(pdata ^. fboLighting . _1 . unFBO)
GL_COLOR
0
ptr
glBindTextureUnit 0 (pdata ^. fboShadow . _2 . _1 . unTO)
glEnable GL_BLEND
glBlendFunc GL_ZERO GL_ONE_MINUS_SRC_COLOR
glUseProgram (pdata ^. shadowCombineShader . _1 . shaderUINT)
@@ -339,20 +355,16 @@ pingPongBetween ::
Shader ->
IO ()
pingPongBetween (fb1, to1) (fb2, to2) fs = do
--bindFramebuffer Framebuffer $= fb2
glBindFramebuffer GL_FRAMEBUFFER (_unFBO fb2)
--textureBinding Texture2D $= Just to1
glBindTexture GL_TEXTURE_2D (_unTO to1)
glBindTextureUnit 0 (_unTO to1)
drawShader fs 4
--bindFramebuffer Framebuffer $= fb1
glBindFramebuffer GL_FRAMEBUFFER (_unFBO fb1)
--textureBinding Texture2D $= Just to2
glBindTexture GL_TEXTURE_2D (_unTO to2)
glBindTextureUnit 0 (_unTO to2)
drawShader fs 4
renderLayer ::
Layer ->
MV.MVector (PrimState IO) (Shader,VBO) ->
MV.MVector (PrimState IO) (Shader, VBO) ->
UMV.MVector (PrimState IO) Int ->
IO ()
renderLayer layer shads counts = do
@@ -361,11 +373,6 @@ renderLayer layer shads counts = do
where
ln = layerNum layer
bindTO :: TO -> IO ()
bindTO t = glBindTexture GL_TEXTURE_2D (_unTO t)
--textureBinding Texture2D $= Just t
bindFBO :: FBO -> IO ()
bindFBO fb =
--bindFramebuffer Framebuffer $= fb
src/Shader.hs
-3
View File
@@ -6,7 +6,6 @@ module Shader (
) where
import Control.Lens
import Control.Monad
import Control.Monad.Primitive
import qualified Data.Vector.Unboxed.Mutable as UMV
import Foreign
@@ -20,7 +19,6 @@ drawShaderLay l countsVector shadIn fs = do
i <- UMV.read countsVector shadIn
glUseProgram (_shaderUINT $ fst fs)
glBindVertexArray $ fs ^. _1 . shaderVAO . vaoName
zipWithM_ (\ti -> glBindTextureUnit ti . _unTO) [0 ..] (fs ^. _1 . shaderTextures)
glDrawArrays
(_unPrimitiveMode $ _shaderPrimitive $ fst fs)
(fromIntegral $ l * numSubElements)
@@ -31,7 +29,6 @@ drawShader :: Shader -> Int -> IO ()
drawShader fs i = do
glUseProgram (_shaderUINT fs)
glBindVertexArray $ fs ^. shaderVAO . vaoName
zipWithM_ (\ti -> glBindTextureUnit ti . _unTO) [0..] (fs ^. shaderTextures)
glDrawArrays
(_unPrimitiveMode $ _shaderPrimitive fs)
0
src/Shader/AuxAddition.hs
+49 -117
View File
@@ -1,128 +1,58 @@
module Shader.AuxAddition
( addSamplerTexture2D
, vaddTextureNoFilter
, addTextureArray
, addBindTextureArray
, initTexture2D
, initTexture2DArray
, tilesToLine
) where
import LensHelp
import Unsafe.Coerce
import Shader.Data
import Data.List.Extra
module Shader.AuxAddition (
initTexture2DArray,
initTexture2DArraySquare,
tilesToLine,
) where
import Codec.Picture
import Data.List.Extra
import qualified Data.Vector.Storable as VS
import Graphics.GL.Core45
import GLHelp
-- I am not sure if this assumes that the shader is constructed directly before
-- the texture is added...
addSamplerTexture2D :: String -> Shader -> IO Shader
addSamplerTexture2D = addTexture2D 3 GL_LINEAR_MIPMAP_LINEAR GL_LINEAR
vaddTextureNoFilter :: String -> Shader -> IO Shader
vaddTextureNoFilter = addTexture2D 1 GL_NEAREST GL_NEAREST
addTexture2D
:: GLint -- number of mipmap levels
-> GLenum -- minfilter
-> GLenum -- magfilter
-> String -- path to image
-> Shader -> IO Shader
addTexture2D nlev minfilt magfilt texpath shad = do
Right cmap <- readImage texpath
let texdata = convertRGBA8 cmap
let wtex = fromIntegral $ imageWidth texdata
htex = fromIntegral $ imageHeight texdata
texname <- mglCreate $ glCreateTextures GL_TEXTURE_2D
glTextureStorage2D texname nlev GL_RGBA8 wtex htex
VS.unsafeWith (imageData texdata) $ \ptr -> do
glTextureSubImage2D texname 0 0 0 wtex htex GL_RGBA GL_UNSIGNED_BYTE ptr
glGenerateTextureMipmap texname
glTextureParameteri texname GL_TEXTURE_MIN_FILTER (unsafeCoerce minfilt)
glTextureParameteri texname GL_TEXTURE_MAG_FILTER (unsafeCoerce magfilt)
return $ shad & shaderTextures .:~ TO texname
-- alloca $ \nameptr -> do
-- glCreateTextures GL_TEXTURE_2D 1 nameptr
-- texname <- peek nameptr
-- glTextureStorage2D texname nlev GL_RGBA8 wtex htex
-- VS.unsafeWith (imageData texdata) $ \ptr -> do
-- glTextureSubImage2D texname 0 0 0 wtex htex GL_RGBA GL_UNSIGNED_BYTE ptr
-- glGenerateTextureMipmap texname
-- glTextureParameteri texname GL_TEXTURE_MIN_FILTER (unsafeCoerce minfilt)
-- glTextureParameteri texname GL_TEXTURE_MAG_FILTER (unsafeCoerce magfilt)
-- return $ shad & shadTex' ?~ ShaderTexture
-- {_textureObject = texname }
initTexture2D
:: GLint -- number of mipmap levels
-> GLenum -- minfilter
-> GLenum -- magfilter
-> String -> IO TO
initTexture2D nlev minfilt magfilt fp = do
Right cmap <- readImage fp
let texdata = convertRGBA8 cmap
let wtex = fromIntegral $ imageWidth texdata
htex = fromIntegral $ imageHeight texdata
texname <- mglCreate $ glCreateTextures GL_TEXTURE_2D
glTextureStorage2D texname nlev GL_RGBA8 wtex htex
VS.unsafeWith (imageData texdata) $ \ptr -> do
glTextureSubImage2D texname 0 0 0 wtex htex GL_RGBA GL_UNSIGNED_BYTE ptr
glGenerateTextureMipmap texname
glTextureParameteri texname GL_TEXTURE_MIN_FILTER (unsafeCoerce minfilt)
glTextureParameteri texname GL_TEXTURE_MAG_FILTER (unsafeCoerce magfilt)
return $ TO texname
import Graphics.GL.Core45
import Unsafe.Coerce
-- assumes the texture slices are squares with sides as long as the input is
-- wide
initTexture2DArray
:: GLint -- number of mipmap levels
-> GLenum -- minfilter
-> GLenum -- magfilter
-> String -> IO TO
initTexture2DArray nlev minfilt magfilt fp = do
initTexture2DArraySquare ::
GLuint -> -- binding point
GLint -> -- number of mipmap levels
GLenum -> -- minfilter
GLenum -> -- magfilter
String ->
IO ()
initTexture2DArraySquare bindpoint nlev minfilt magfilt fp = do
Right cmap <- readImage fp
let texdata = convertRGBA8 cmap
let wtex = fromIntegral $ imageWidth texdata
htex = fromIntegral $ imageHeight texdata
z = htex `div` wtex
texname <- mglCreate $ glCreateTextures GL_TEXTURE_2D_ARRAY
glTextureStorage3D texname nlev GL_RGBA8 wtex wtex z
VS.unsafeWith (imageData texdata) $ \ptr -> do
glTextureSubImage3D texname 0 0 0 0 wtex wtex z GL_RGBA GL_UNSIGNED_BYTE ptr
glGenerateTextureMipmap texname
glTextureParameteri texname GL_TEXTURE_MIN_FILTER (unsafeCoerce minfilt)
glTextureParameteri texname GL_TEXTURE_MAG_FILTER (unsafeCoerce magfilt)
return $ TO texname
let sqside = fromIntegral $ imageWidth texdata
totalh = fromIntegral $ imageHeight texdata
d = totalh `div` sqside
initTexture2DArrayData bindpoint texdata nlev sqside sqside d minfilt magfilt
-- | for transforming a 256x256 image containing 64 tiles of 16x16 pixels into
-- an image that was directly readable by glTexSubImage3D, used the
-- transformation tilesToLine 8 128 on the underlying pixels.
addTextureArray :: String -> (Shader,VBO) -> IO (Shader,VBO)
addTextureArray texturePath (shad,vbo) = do
err <- glGetError
print err
Right cmap <- readImage texturePath
let texdata = convertRGBA8 cmap
texname <- mglCreate $ glCreateTextures GL_TEXTURE_2D_ARRAY
glTextureStorage3D texname 3 GL_RGBA8 32 32 64
VS.unsafeWith (imageData texdata) $ \ptr -> do
glTextureSubImage3D texname 0 0 0 0 32 32 64 GL_RGBA GL_UNSIGNED_BYTE ptr
glGenerateTextureMipmap texname
glTextureParameteri texname GL_TEXTURE_MIN_FILTER (unsafeCoerce GL_LINEAR_MIPMAP_LINEAR)
glTextureParameteri texname GL_TEXTURE_MAG_FILTER (unsafeCoerce GL_LINEAR)
return (shad & shaderTextures .:~ TO texname
, vbo)
addBindTextureArray :: GLuint -> String -> GLsizei -> GLsizei -> GLsizei -> GLsizei -> GLenum -> GLenum
-> IO ()
addBindTextureArray bindpoint fp nlev w h d minfilt magfilt = do
initTexture2DArray ::
GLuint ->
String ->
GLsizei ->
GLsizei ->
GLsizei ->
GLsizei ->
GLenum ->
GLenum ->
IO ()
initTexture2DArray bindpoint fp nlev w h d minfilt magfilt = do
Right cmap <- readImage fp
let texdata = convertRGBA8 cmap
initTexture2DArrayData bindpoint texdata nlev w h d minfilt magfilt
initTexture2DArrayData :: GLuint -> Image PixelRGBA8 -> GLsizei -> GLsizei -> GLsizei -> GLsizei -> GLenum -> GLenum
-> IO ()
initTexture2DArrayData ::
GLuint ->
Image PixelRGBA8 ->
GLsizei ->
GLsizei ->
GLsizei ->
GLsizei ->
GLenum ->
GLenum ->
IO ()
initTexture2DArrayData bindpoint texdata nlev w h d minfilt magfilt = do
texname <- mglCreate $ glCreateTextures GL_TEXTURE_2D_ARRAY
glTextureStorage3D texname nlev GL_RGBA8 w h d
@@ -133,9 +63,11 @@ initTexture2DArrayData bindpoint texdata nlev w h d minfilt magfilt = do
glTextureParameteri texname GL_TEXTURE_MAG_FILTER (unsafeCoerce magfilt)
glBindTextureUnit bindpoint texname
tilesToLine
:: Int -- ^ Parameter a
-> Int -- ^ Parameter b
-> [a]
-> [a]
tilesToLine ::
-- | Parameter a
Int ->
-- | Parameter b
Int ->
[a] ->
[a]
tilesToLine n w = concat . concat . transpose . chunksOf n . chunksOf w
src/Shader/Compile.hs
+60 -79
View File
@@ -2,9 +2,8 @@ module Shader.Compile (
setupVBO,
setupVBOStatic,
makeShaderEBO,
makeShader,
makeShader4,
makeShader4UsingVAO,
makeShaderVBO,
makeShaderUsingVBO,
makeByteStringShaderUsingVAO,
makeShaderSized,
makeShaderUsingVAO,
@@ -25,13 +24,14 @@ import GLHelp
import Graphics.GL.Core45
import Shader.Data
import Shader.Parameters
--import Graphics.GL.Core45
{- |
Compiles a full shader found within the shader directory.
The shader is made up of files begining with the inputted string with extensions .vert, .geom etc.
-}
makeShader ::
makeShaderVBO ::
-- | First part of the name of the shader
String ->
-- | shader types
@@ -39,17 +39,18 @@ makeShader ::
-- | The input vertex sizes
[Int] ->
PrimitiveMode ->
IO (Shader,VBO)
makeShader s shaderlist sizes pm = do
IO (Shader, VBO)
makeShaderVBO s shaderlist sizes pm = do
prog <- makeSourcedShader s shaderlist
(vao,vbo) <- setupVAO sizes
return ( Shader
(vao, vbo) <- setupVAO sizes
return
( Shader
{ _shaderUINT = prog
, _shaderVAO = vao
, _shaderPrimitive = pm
, _shaderTextures = mempty
}
, vbo)
, vbo
)
makeShaderEBO ::
-- | First part of the name of the shader
@@ -68,11 +69,11 @@ makeShaderEBO s shaderlist sizes strd pm vbo = do
vao <- setupVAOvbo sizes strd vbo
ebo <- setupEBO vao
return
( Shader prog pm vao []
( Shader prog pm vao
, ebo
)
makeShader4 ::
makeShaderUsingVBO ::
-- | First part of the name of the shader
String ->
-- | shader types
@@ -84,54 +85,32 @@ makeShader4 ::
PrimitiveMode ->
VBO ->
IO Shader
makeShader4 s shaderlist sizes strd pm vbo = do
prog <- makeSourcedShader s shaderlist
vao <- setupVAOvbo sizes strd vbo
return $ Shader
{ _shaderUINT = prog
, _shaderVAO = vao
, _shaderPrimitive = pm
, _shaderTextures = mempty
}
makeShader4UsingVAO ::
-- | First part of the name of the shader
String ->
-- | shader types
[GLenum] ->
PrimitiveMode ->
VAO ->
IO Shader
makeShader4UsingVAO s shaderlist pm vao = do
prog <- makeSourcedShader s shaderlist
return $ Shader
{ _shaderUINT = prog
, _shaderVAO = vao
, _shaderPrimitive = pm
, _shaderTextures = []
}
makeShaderUsingVBO s shaderlist sizes strd pm vbo = setupVAOvbo sizes strd vbo
>>= makeShaderUsingVAO s shaderlist pm
setupVBO :: Int -> IO VBO
setupVBO vertexsize = do
vboname <- mglCreate glCreateBuffers
thePtr <- mallocArray (vertexsize * numDrawableElements)
-- Allocate space
glNamedBufferData vboname
( fromIntegral $ floatSize * numDrawableElements * vertexsize)
nullPtr
glNamedBufferData
vboname
(fromIntegral $ floatSize * numDrawableElements * vertexsize)
nullPtr
GL_STREAM_DRAW
return VBO {_vboName = vboname, _vboPtr = thePtr, _vboVertexSize = vertexsize}
return VBO{_vboName = vboname, _vboPtr = thePtr, _vboVertexSize = vertexsize}
setupVBOStatic :: Int -> IO VBO
setupVBOStatic vertexsize = do
vboname <- mglCreate glCreateBuffers
thePtr <- mallocArray (vertexsize * numDrawableElements)
-- Allocate space
glNamedBufferData vboname
( fromIntegral $ floatSize * numDrawableElements * vertexsize)
nullPtr
glNamedBufferData
vboname
(fromIntegral $ floatSize * numDrawableElements * vertexsize)
nullPtr
GL_STATIC_DRAW
return VBO {_vboName = vboname, _vboPtr = thePtr, _vboVertexSize = vertexsize}
return VBO{_vboName = vboname, _vboPtr = thePtr, _vboVertexSize = vertexsize}
makeByteStringShaderUsingVAO ::
-- | (Arbitrary) name of the shader
@@ -143,12 +122,11 @@ makeByteStringShaderUsingVAO ::
IO Shader
makeByteStringShaderUsingVAO s shaderlist pm vao = do
prog <- makeShaderProgram s shaderlist
return $
return
Shader
{ _shaderUINT = prog
, _shaderVAO = vao
, _shaderPrimitive = pm
, _shaderTextures = mempty
}
-- | Takes the VAO from elsewhere
@@ -162,12 +140,11 @@ makeShaderUsingVAO ::
IO Shader
makeShaderUsingVAO s shaderlist pm theVAO = do
prog <- makeSourcedShader s shaderlist
return $
return
Shader
{ _shaderUINT = prog
, _shaderVAO = theVAO
, _shaderPrimitive = pm
, _shaderTextures = mempty
}
{- |
@@ -184,17 +161,18 @@ makeShaderSized ::
-- | Number of vertexes that can be poked
Int ->
PrimitiveMode ->
IO (Shader,VBO)
IO (Shader, VBO)
makeShaderSized s shaderlist sizes ndraw pm = do
prog <- makeSourcedShader s shaderlist
(vao,vbo) <- setupVAOSized ndraw sizes
return ( Shader
(vao, vbo) <- setupVAOSized ndraw sizes
return
( Shader
{ _shaderUINT = prog
, _shaderVAO = vao
, _shaderPrimitive = pm
, _shaderTextures = mempty
}
, vbo)
, vbo
)
{- | Compile shader and get its uniform locations.
supposes the shader code is in the shader folder, with the string names
@@ -202,17 +180,17 @@ makeShaderSized s shaderlist sizes ndraw pm = do
-}
makeSourcedShader :: String -> [GLenum] -> IO GLuint
makeSourcedShader s sts = do
sources <- forM sts $ \st -> BS.readFile ("shader/" ++ s ++ shaderTypeExt' st)
sources <- forM sts $ \st -> BS.readFile ("shader/" ++ s ++ shaderTypeExt st)
makeShaderProgram s $ zip sts sources
shaderTypeExt' :: GLenum -> String
shaderTypeExt' GL_VERTEX_SHADER = ".vert"
shaderTypeExt' GL_GEOMETRY_SHADER = ".geom"
shaderTypeExt' GL_FRAGMENT_SHADER = ".frag"
shaderTypeExt' _ = undefined
shaderTypeExt :: GLenum -> String
shaderTypeExt GL_VERTEX_SHADER = ".vert"
shaderTypeExt GL_GEOMETRY_SHADER = ".geom"
shaderTypeExt GL_FRAGMENT_SHADER = ".frag"
shaderTypeExt _ = undefined
-- I think that this requires that the correct shader program is bound?
setupVAO :: [Int] -> IO (VAO,VBO)
setupVAO :: [Int] -> IO (VAO, VBO)
setupVAO = setupVAOSized numDrawableElements
setupVAOvbo' :: [Int] -> Int -> GLuint -> IO VAO
@@ -220,17 +198,18 @@ setupVAOvbo' sizes strd vbo = do
vaoname <- mglCreate glCreateVertexArrays
glBindVertexArray vaoname
setupVertexAttribs' vbo vaoname sizes strd
return $ VAO
return $
VAO
{ _vaoName = vaoname
}
setupVAOvbo :: [Int] -> Int -> VBO -> IO VAO
setupVAOvbo sizes strd vbo = do
vaoname <- mglCreate glCreateVertexArrays
glBindVertexArray vaoname
setupVertexAttribs vbo vaoname sizes strd
return $ VAO
return $
VAO
{ _vaoName = vaoname
}
@@ -238,37 +217,40 @@ setupEBO :: VAO -> IO EBO
setupEBO vao = do
eboptr <- mallocArray numDrawableElements
eboname <- mglCreate glCreateBuffers
glNamedBufferData
glNamedBufferData
eboname
( fromIntegral $ glushortSize * numDrawableElements)
nullPtr
(fromIntegral $ glushortSize * numDrawableElements)
nullPtr
GL_STREAM_DRAW
glVertexArrayElementBuffer (vao ^. vaoName) eboname
return $ EBO eboname eboptr
setupVAOSized :: Int -> [Int] -> IO (VAO,VBO)
setupVAOSized :: Int -> [Int] -> IO (VAO, VBO)
setupVAOSized ndraw sizes = do
vaoname <- mglCreate glCreateVertexArrays
glBindVertexArray vaoname
theVBO <- setupVBOSized ndraw vaoname sizes
return ( VAO
return
( VAO
{ _vaoName = vaoname
}
, theVBO)
, theVBO
)
setupVBOSized :: Int -> GLuint -> [Int] -> IO VBO
setupVBOSized ndraw vao sizes = do
--vboName <- genObjectName
--bindBuffer ArrayBuffer $= Just vboName
vboname <- mglCreate glCreateBuffers
glVertexArrayVertexBuffer vao 0 vboname 0 (fromIntegral $ floatSize * strd)
glVertexArrayVertexBuffer vao 0 vboname 0 (fromIntegral $ floatSize * strd)
forM_ (zip3 [0 ..] sizes offs) $ \(loc, siz, off) -> do
setupVertexAttribPointer vao loc siz off
thePtr <- mallocArray (strd * ndraw)
-- Allocate space
glNamedBufferData vboname
( fromIntegral $ floatSize * ndraw * strd)
nullPtr
glNamedBufferData
vboname
(fromIntegral $ floatSize * ndraw * strd)
nullPtr
GL_STREAM_DRAW
return $
VBO
@@ -282,7 +264,7 @@ setupVBOSized ndraw vao sizes = do
setupVertexAttribs :: VBO -> GLuint -> [Int] -> Int -> IO ()
setupVertexAttribs vbo vao sizes strd = do
glVertexArrayVertexBuffer vao 0 (_vboName vbo) 0 (fromIntegral $ floatSize * strd)
glVertexArrayVertexBuffer vao 0 (_vboName vbo) 0 (fromIntegral $ floatSize * strd)
forM_ (zip3 [0 ..] sizes offs) $ \(loc, siz, off) -> do
setupVertexAttribPointer vao loc siz off
where
@@ -290,7 +272,7 @@ setupVertexAttribs vbo vao sizes strd = do
setupVertexAttribs' :: GLuint -> GLuint -> [Int] -> Int -> IO ()
setupVertexAttribs' vbo vao sizes strd = do
glVertexArrayVertexBuffer vao 0 vbo 0 (fromIntegral $ floatSize * strd)
glVertexArrayVertexBuffer vao 0 vbo 0 (fromIntegral $ floatSize * strd)
forM_ (zip3 [0 ..] sizes offs) $ \(loc, siz, off) -> do
setupVertexAttribPointer vao loc siz off
where
@@ -356,7 +338,7 @@ compileAndCheckShader str (theShaderType, sourceCode) = do
setShaderSource theShader sourceCode
glCompileShader theShader
checkErrorGL
(str ++ shaderTypeExt' theShaderType)
(str ++ shaderTypeExt theShaderType)
glGetShaderiv
glGetShaderInfoLog
theShader
@@ -375,4 +357,3 @@ withByteString :: Num t => BS.ByteString -> (Ptr b -> t -> IO a) -> IO a
withByteString bs act =
BU.unsafeUseAsCStringLen bs $ \(ptr, size) ->
act (castPtr ptr) (fromIntegral size)
src/Shader/Data.hs
-2
View File
@@ -16,7 +16,6 @@ module Shader.Data (
shaderUINT,
shaderPrimitive,
shaderVAO,
shaderTextures,
textureObject,
vboName,
vboPtr,
@@ -51,7 +50,6 @@ data Shader = Shader
{ _shaderUINT :: GLuint -- should be shaderID
, _shaderPrimitive :: PrimitiveMode
, _shaderVAO :: VAO
, _shaderTextures :: [TO]
}
newtype FBO = FBO {_unFBO :: GLuint}
src/Shader/Poke.hs
+4 -4
View File
@@ -10,7 +10,7 @@ module Shader.Poke (
import Geometry.Vector
import Dodge.Data.Wall
import Shader.Poke.Triangulate
import Geometry.Triangulate
import Control.Monad.Primitive
import qualified Data.Vector as V
import qualified Data.Vector.Fusion.Stream.Monadic as VFSM
@@ -257,7 +257,7 @@ pokeIndex nv eiptr ni ioff = do
memoFlatIndices :: V.Vector (UV.Vector Int)
memoFlatIndices =
V.generate 10 $
UV.fromList . concatMap triangulate . boxSurfaces' . (+ 3)
UV.fromList . concatMap polyToTris . boxSurfaces' . (+ 3)
memoTopPrismIndices :: V.Vector (UV.Vector Int)
{-# INLINE memoTopPrismIndices #-}
@@ -313,8 +313,8 @@ boxEdgeIndices n = concatMap f [0 .. n -1]
cylinderIndices :: Int -> [Int]
cylinderIndices n =
cylinderRoundIndices n
++ triangulate [2 * n, 2 * n + 2 .. 4 * n - 1]
++ triangulate [2 * n + 1, 2 * n + 3 .. 4 * n - 1]
++ polyToTris [2 * n, 2 * n + 2 .. 4 * n - 1]
++ polyToTris [2 * n + 1, 2 * n + 3 .. 4 * n - 1]
cylinderRoundIndices :: Int -> [Int]
cylinderRoundIndices n =
src/Shader/Poke/Floor.hs
+10 -11
View File
@@ -1,22 +1,21 @@
module Shader.Poke.Floor
( pokeTile
) where
module Shader.Poke.Floor (
pokeTile,
) where
import Geometry
import Shader.Poke.Triangulate
import Control.Monad
import Tile
import Data.Tile
import Foreign
import Geometry
import Tile
pokeTile :: Ptr Float -> Int -> Tile -> IO Int
pokeTile ptr i t@Tile { _tilePoly = ps } = do
foldM (pokeTileVerx ttan (_tileArrayZ t) ptr) i $ triangulate $ zip ps (tileTexCoords t)
pokeTile ptr i t@Tile{_tilePoly = ps} = do
foldM (pokeTileVerx ttan (_tileArrayZ t) ptr) i $ polyToTris $ zip ps (tileTexCoords t)
where
ttan = _tileTangentPos t - _tileZero t
pokeTileVerx :: Point2 -> Float -> Ptr Float -> Int -> (Point2,Point2) -> IO Int
pokeTileVerx tangent tilez ptr i (V2 x y,V2 s t) = do
pokeTileVerx :: Point2 -> Float -> Ptr Float -> Int -> (Point2, Point2) -> IO Int
pokeTileVerx tangent tilez ptr i (V2 x y, V2 s t) = do
let a = argV tangent
zipWithM_ (\off -> pokeElemOff ptr (i*8 + off)) [0..] [x,y,1,1,s,t,tilez,a]
zipWithM_ (\off -> pokeElemOff ptr (i * 8 + off)) [0 ..] [x, y, 1, 1, s, t, tilez, a]
return $ i + 1
src/Shader/Poke/Triangulate.hs
-15
View File
@@ -1,15 +0,0 @@
module Shader.Poke.Triangulate where
import qualified Data.Vector as V
triangulate :: [a] -> [a]
{-# INLINE triangulate #-}
triangulate is = V.toList . V.backpermute (V.fromList is) . V.fromList $ triangulateIndices (length is)
triangulateIndices :: Int -> [Int]
{-# INLINE triangulateIndices #-}
triangulateIndices i = concatMap f [0 .. i -3]
where
f x
| even x = [0, x + 1, x + 2]
| otherwise = [0, x + 2, x + 1]
src/ShapePicture.hs
+5 -5
View File
@@ -2,7 +2,7 @@
module ShapePicture
( module ShapePicture.Data
, translateSP
, translateSPf
, translateSPxy
, translateSPz
, rotateSP
, noPic
@@ -42,13 +42,13 @@ overPosSP :: (Point3 -> Point3) -> SPic -> SPic
{-# INLINE overPosSP #-}
overPosSP f = bimap (overPosSH f) (picMap $ overPos f)
translateSPf :: Float -> Float -> SPic -> SPic
{-# INLINE translateSPf #-}
translateSPf x y = bimap (translateSH (V3 x y 0)) (translate x y)
translateSPxy :: Float -> Float -> SPic -> SPic
{-# INLINE translateSPxy #-}
translateSPxy x y = translateSP (V3 x y 0)
translateSPz :: Float -> SPic -> SPic
{-# INLINE translateSPz #-}
translateSPz z = bimap (translateSH (V3 0 0 z)) (translate3 (V3 0 0 z))
translateSPz z = translateSP (V3 0 0 z)
translateSP :: Point3 -> SPic -> SPic
{-# INLINE translateSP #-}