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

Commit before picture change

Browse Source
This commit is contained in:
jgk
2021-02-28 21:26:20 +01:00
parent 4a85177522
commit bb05bcaaf1
5 changed files with 143 additions and 44 deletions
Download Patch File Download Diff File Expand all files Collapse all files
app/Main.hs
+1 -1
View File
@@ -65,7 +65,7 @@ main = do
blendFunc $= (SrcAlpha,OneMinusSrcAlpha)
renderTree (_renderData preData) (_cameraRot w) (_cameraZoom w) (_cameraPos w)
(_windowX w,_windowY w)
(picToList 1 $ fixedCoordPictures w)
(picToLTree 1 $ fixedCoordPictures w)
endRenderTicks <- SDL.ticks
playSoundQueue (_soundData preData) (_soundQueue w)
newSoundData <- playAndUpdate (_sounds w) (_soundData preData)
package.yaml
+1
View File
@@ -56,6 +56,7 @@ executables:
- -O2
- -rtsopts
- -with-rtsopts=-N
- -flate-dmd-anal
- -fno-liberate-case
- -fno-state-hack
- -funfolding-use-threshold1000
shader/wallShadow.geom
+4 -4
View File
@@ -16,14 +16,14 @@ void main()
// vec2 posc = vBackPoss[0].xy;
// vec2 posd = vBackPoss[0].zw;
gl_Position = vec4 (posa, 0 , 1);
EmitVertex();
gl_Position = vec4 (posa + (200 * (posa - lightPos)), 0 , 1);
EmitVertex();
gl_Position = vec4 (posb, 0 , 1);
EmitVertex();
gl_Position = vec4 (posb + (200 * (posb - lightPos)), 0 , 1);
EmitVertex();
gl_Position = vec4 (posa, 0 , 1);
EmitVertex();
gl_Position = vec4 (posa + (200 * (posa - lightPos)), 0 , 1);
EmitVertex();
EndPrimitive();
}
src/Picture/Data.hs
+12
View File
@@ -25,6 +25,18 @@ instance Foldable FTree where
foldMap g (FLeaf x) = g x
{-# INLINE foldMap #-}
data LTree a
= LBranches [LTree a]
| LLeaf a
instance Foldable LTree where
foldMap g (LBranches ts) = mconcat $ map (foldMap g) ts
foldMap g (LLeaf a) = g a
{-# INLINE foldMap #-}
instance Functor LTree where
fmap f (LBranches ts) = LBranches $ (fmap (fmap f)) ts
fmap f (LLeaf x) = LLeaf (f x)
flat2 (x,y) = [x,y]
flat3 (x,y,z) = [x,y,z]
flat4 (x,y,z,w) = [x,y,z,w]
src/Picture/Render.hs
+125 -39
View File
@@ -4,6 +4,8 @@ module Picture.Render
where
import Control.Lens
import Control.Monad
import qualified Control.Applicative as Ap
--import Control.Monad.Trans.State
--
--
@@ -31,6 +33,7 @@ import Data.Foldable
import Data.List
import qualified Data.Vector.Storable as V
import qualified Data.IntMap as IM
import qualified Data.DList as DL
import Control.DeepSeq
@@ -57,6 +60,7 @@ scaleT :: Float -> (Point3,Point4,Point2) -> (Point3,Point4,Point2)
scaleT x (a,b,(o,s)) = (a,b,(o,s*x))
overPos :: (Point3 -> Point3) -> RenderType -> RenderType
{-# INLINE overPos #-}
overPos f (RenderPoly vs) = RenderPoly $ map (first $ f) vs
overPos f (RenderLine vs) = RenderLine $ map (first $ f) vs
overPos f (RenderText vs) = RenderText $ map (\(a,b,c) -> (f a,b,c)) vs
@@ -65,6 +69,7 @@ overPos f (RenderArc (a,b,c)) = RenderArc (f a,b,c)
overPos _ RenderBlank = RenderBlank
overCol :: (Point4 -> Point4) -> RenderType -> RenderType
{-# INLINE overCol #-}
overCol f (RenderPoly vs) = RenderPoly $ map (second $ f) vs
overCol f (RenderLine vs) = RenderLine $ map (second $ f) vs
overCol f (RenderText vs) = RenderText $ map (\(a,b,c) -> (a,f b,c)) vs
@@ -102,8 +107,38 @@ charToTuple :: Char -> (Point3,Point4,Point2)
charToTuple c = ((0,0,0),white,(offset,100))
where offset = fromIntegral (fromEnum c) - 32
picToAlt :: (Ap.Alternative f, Monoid (f RenderType)) => Int -> Picture -> f RenderType
{-# INLINE picToAlt #-}
picToAlt x (Polygon i ps)
| i == x = Ap.pure $ RenderPoly $ zip (map zeroZ $ polyToTris ps) $ repeat black
| otherwise = Ap.empty
picToAlt x (PolygonCol i vs)
| i /= x = Ap.empty
| otherwise =
let (ps,cs) = unzip vs
in Ap.pure $ RenderPoly $ zip (map zeroZ $ polyToTris ps) $ polyToTris cs
picToAlt x (Circle i r)
| i == x = Ap.pure $ RenderCirc $ ((0,0,0),black,r)
| otherwise = Ap.empty
picToAlt x (ThickArc i startA endA rad wdth)
| i == x = Ap.pure $ RenderArc $ ((0,0,0),black,(startA,endA,rad,wdth))
| otherwise = Ap.empty
picToAlt x (Line i ps)
| i == x = Ap.pure $ RenderLine $ zip (map zeroZ $ doubleLine ps) $ repeat white
| otherwise = Ap.empty
picToAlt x (Text i s)
| i == x = Ap.pure $ RenderText $ stringToList s
| otherwise = Ap.empty
picToAlt j Blank = Ap.empty
picToAlt j (Scale x y pic) = fmap (scaleRen x y) $ picToAlt j pic
picToAlt j (Translate x y pic) = fmap (translateRen x y) $ picToAlt j pic
picToAlt j (Rotate a pic) = fmap (rotateRen a) $ picToAlt j pic
picToAlt j (SetDepth a pic) = fmap (setDepthRen a) $ picToAlt j pic
picToAlt j (Color c pic) = fmap (colorRen c) $ picToAlt j pic
picToAlt j (Pictures pics) = mconcat $ fmap (picToAlt j) pics
picToList :: Int -> Picture -> [RenderType]
--{-# INLINE picToList #-}
{-# INLINE picToList #-}
picToList x (Polygon i ps)
| i == x = [RenderPoly $ zip (map zeroZ $ polyToTris ps) $ repeat black]
| otherwise = []
@@ -132,40 +167,70 @@ picToList j (SetDepth a pic) = fmap (setDepthRen a) $ picToList j pic
picToList j (Color c pic) = fmap (colorRen c) $ picToList j pic
picToList j (Pictures pics) = concatMap (picToList j) pics
picToFTree :: Int -> Picture -> FTree RenderType
--{-# INLINE picToFTree #-}
picToFTree x (Polygon i ps)
| i == x = FLeaf $ RenderPoly $ zip (map zeroZ $ polyToTris ps) $ repeat black
| otherwise = FLeaf RenderBlank
picToFTree x (PolygonCol i vs)
| i /= x = FLeaf RenderBlank
| otherwise =
let (ps,cs) = unzip vs
in FLeaf $ RenderPoly $ zip (map zeroZ $ polyToTris ps) $ polyToTris cs
picToFTree x (Circle i r)
| i == x = FLeaf $ RenderCirc $ ((0,0,0),black,r)
| otherwise = FLeaf RenderBlank
picToFTree x (ThickArc i startA endA rad wdth)
| i == x = FLeaf $ RenderArc $ ((0,0,0),black,(startA,endA,rad,wdth))
| otherwise = FLeaf RenderBlank
picToFTree x (Line i ps)
| i == x = FLeaf $ RenderLine $ zip (map zeroZ $ doubleLine ps) $ repeat white
| otherwise = FLeaf RenderBlank
picToFTree x (Text i s)
| i == x = FLeaf $ RenderText $ stringToList s
| otherwise = FLeaf RenderBlank
picToFTree j Blank = FLeaf RenderBlank
picToFTree j (Scale x y pic) = collapseBranch (scaleRen x y) $ picToFTree j pic
picToFTree j (Translate x y pic) = collapseBranch (translateRen x y) $ picToFTree j pic
picToFTree j (Rotate a pic) = collapseBranch (rotateRen a) $ picToFTree j pic
picToFTree j (SetDepth a pic) = collapseBranch (setDepthRen a) $ picToFTree j pic
picToFTree j (Color c pic) = collapseBranch (colorRen c) $ picToFTree j pic
picToFTree j (Pictures pics) = FBranches $ map (picToFTree j) pics
-- picToFTree :: Int -> Picture -> FTree RenderType
-- {-# INLINE picToFTree #-}
-- picToFTree x (Polygon i ps)
-- | i == x = FLeaf $ RenderPoly $ zip (map zeroZ $ polyToTris ps) $ repeat black
-- | otherwise = FLeaf RenderBlank
-- picToFTree x (PolygonCol i vs)
-- | i /= x = FLeaf RenderBlank
-- | otherwise =
-- let (ps,cs) = unzip vs
-- in FLeaf $ RenderPoly $ zip (map zeroZ $ polyToTris ps) $ polyToTris cs
-- picToFTree x (Circle i r)
-- | i == x = FLeaf $ RenderCirc $ ((0,0,0),black,r)
-- | otherwise = FLeaf RenderBlank
-- picToFTree x (ThickArc i startA endA rad wdth)
-- | i == x = FLeaf $ RenderArc $ ((0,0,0),black,(startA,endA,rad,wdth))
-- | otherwise = FLeaf RenderBlank
-- picToFTree x (Line i ps)
-- | i == x = FLeaf $ RenderLine $ zip (map zeroZ $ doubleLine ps) $ repeat white
-- | otherwise = FLeaf RenderBlank
-- picToFTree x (Text i s)
-- | i == x = FLeaf $ RenderText $ stringToList s
-- | otherwise = FLeaf RenderBlank
-- picToFTree j Blank = FLeaf RenderBlank
-- picToFTree j (Scale x y pic) = collapseBranch (scaleRen x y) $ picToFTree j pic
-- picToFTree j (Translate x y pic) = collapseBranch (translateRen x y) $ picToFTree j pic
-- picToFTree j (Rotate a pic) = collapseBranch (rotateRen a) $ picToFTree j pic
-- picToFTree j (SetDepth a pic) = collapseBranch (setDepthRen a) $ picToFTree j pic
-- picToFTree j (Color c pic) = collapseBranch (colorRen c) $ picToFTree j pic
-- picToFTree j (Pictures pics) = FBranches $ map (picToFTree j) pics
collapseBranch :: (RenderType -> RenderType) -> FTree RenderType -> FTree RenderType
collapseBranch f (FBranch g t) = FBranch (f . g) t
collapseBranch f (FBranches ts) = FBranches $ map (collapseBranch f) ts
collapseBranch f t = FBranch f t
collapseBranch f (FLeaf x) = FLeaf (f x)
picToLTree :: Int -> Picture -> LTree RenderType
{-# INLINE picToLTree #-}
picToLTree x (Polygon i ps)
| i == x = LLeaf $ RenderPoly $ zip (map zeroZ $ polyToTris ps) $ repeat black
| otherwise = LLeaf RenderBlank
picToLTree x (PolygonCol i vs)
| i /= x = LLeaf RenderBlank
| otherwise =
let (ps,cs) = unzip vs
in LLeaf $ RenderPoly $ zip (map zeroZ $ polyToTris ps) $ polyToTris cs
picToLTree x (Circle i r)
| i == x = LLeaf $ RenderCirc $ ((0,0,0),black,r)
| otherwise = LLeaf RenderBlank
picToLTree x (ThickArc i startA endA rad wdth)
| i == x = LLeaf $ RenderArc $ ((0,0,0),black,(startA,endA,rad,wdth))
| otherwise = LLeaf RenderBlank
picToLTree x (Line i ps)
| i == x = LLeaf $ RenderLine $ zip (map zeroZ $ doubleLine ps) $ repeat white
| otherwise = LLeaf RenderBlank
picToLTree x (Text i s)
| i == x = LLeaf $ RenderText $ stringToList s
| otherwise = LLeaf RenderBlank
picToLTree j Blank = LLeaf RenderBlank
picToLTree j (Scale x y pic) = fmap (scaleRen x y) $ picToLTree j pic
picToLTree j (Translate x y pic) = fmap (translateRen x y) $ picToLTree j pic
picToLTree j (Rotate a pic) = fmap (rotateRen a) $ picToLTree j pic
picToLTree j (SetDepth a pic) = fmap (setDepthRen a) $ picToLTree j pic
picToLTree j (Color c pic) = fmap (colorRen c) $ picToLTree j pic
picToLTree j (Pictures pics) = LBranches $ map (picToLTree j) pics
doubleLine :: [Point2] -> [Point2]
doubleLine (x:y:xs) = concat $ zipWith (:) (init (x:y:xs)) $ map (\a -> [a]) (y:xs)
@@ -190,12 +255,15 @@ type TwoPtrs = (Ptr Float,Ptr Float)
pokeThreePtrsWith :: (ThreePtrs -> Int -> RenderType -> IO Int)
-> ThreePtrs -> F.FoldM IO RenderType Int
{-# INLINE pokeThreePtrsWith #-}
pokeThreePtrsWith pokeF ptrs = F.FoldM (pokeF ptrs) (return 0) return
pokeTwoPtrsWith :: (TwoPtrs -> Int -> RenderType -> IO Int)
-> TwoPtrs -> F.FoldM IO RenderType Int
{-# INLINE pokeTwoPtrsWith #-}
pokeTwoPtrsWith pokeF ptrs = F.FoldM (pokeF ptrs) (return 0) return
pokeArc:: ThreePtrs -> Int -> RenderType -> IO Int
{-# INLINE pokeArc #-}
pokeArc (pa,pb,pc) n (RenderArc (p,c,s))
| n > 20000 * 2 = return n
| otherwise = do
@@ -206,15 +274,18 @@ pokeArc (pa,pb,pc) n (RenderArc (p,c,s))
pokeArc _ n _ = return n
pokeTwoOff :: Ptr Float -> Int -> (Float,Float) -> IO ()
{-# INLINE pokeTwoOff #-}
pokeTwoOff ptr n (x,y) = do
pokeElemOff ptr (2*n+0) x
pokeElemOff ptr (2*n+1) y
pokeThreeOff :: Ptr Float -> Int -> (Float,Float,Float) -> IO ()
{-# INLINE pokeThreeOff #-}
pokeThreeOff ptr n (x,y,z) = do
pokeElemOff ptr (3*n+0) x
pokeElemOff ptr (3*n+1) y
pokeElemOff ptr (3*n+2) z
pokeFourOff :: Ptr Float -> Int -> (Float,Float,Float,Float) -> IO ()
{-# INLINE pokeFourOff #-}
pokeFourOff ptr n (x,y,z,w) = do
pokeElemOff ptr (4*n+0) x
pokeElemOff ptr (4*n+1) y
@@ -223,10 +294,12 @@ pokeFourOff ptr n (x,y,z,w) = do
pokeLine :: TwoPtrs -> Int -> RenderType -> IO Int
{-# INLINE pokeLine #-}
pokeLine (pa,pb) n (RenderLine vs) = foldM (pokeLineVert pa pb) n vs
pokeLine _ n _ = return n
pokeLineVert :: Ptr Float -> Ptr Float -> Int -> (Point3, Point4) -> IO Int
{-# INLINE pokeLineVert #-}
pokeLineVert pa pb n (p,c)
| n > 20000 * 2 = return n
| otherwise = do
@@ -235,6 +308,7 @@ pokeLineVert pa pb n (p,c)
return (n+1)
pokeCirc :: ThreePtrs -> Int -> RenderType -> IO Int
{-# INLINE pokeCirc #-}
pokeCirc (pa,pb,pc) n (RenderCirc (p,c,s))
| n > 20000 * 2 = return n
| otherwise = do
@@ -245,10 +319,12 @@ pokeCirc (pa,pb,pc) n (RenderCirc (p,c,s))
pokeCirc _ n _ = return n
pokeText :: (Ptr Float, Ptr Float, Ptr Float) -> Int -> RenderType -> IO Int
{-# INLINE pokeText #-}
pokeText (pa,pb,pc) n (RenderText vs) = foldM (pokeTextVert pa pb pc) n vs
pokeText _ n _ = return n
pokeTextVert :: Ptr Float -> Ptr Float -> Ptr Float -> Int -> (Point3, Point4, Point2) -> IO Int
{-# INLINE pokeTextVert #-}
pokeTextVert pa pb pc n (p,c,t)
| n > 20000 * 2 = return n
| otherwise = do
@@ -258,10 +334,12 @@ pokeTextVert pa pb pc n (p,c,t)
return (n+1)
pokePoly :: TwoPtrs -> Int -> RenderType -> IO Int
{-# INLINE pokePoly #-}
pokePoly (pa,pb) n (RenderPoly vs) = foldM (pokeVert pa pb) n vs
pokePoly _ n _ = return n
pokeVert :: Ptr Float -> Ptr Float -> Int -> (Point3, Point4) -> IO Int
{-# INLINE pokeVert #-}
pokeVert pa pb n (p,c)
| n > 20000 * 2 = return n
| otherwise = do
@@ -289,9 +367,11 @@ bindArrayBuffers numVs ps = do
bufferData ArrayBuffer $= (fromIntegral $ fSize * numVs * i, ptr, StreamDraw)
twoPtrsVAO :: VAO -> (Ptr Float, Ptr Float)
{-# INLINE twoPtrsVAO #-}
twoPtrsVAO vao = case (\(_,ps,_) -> ps) $ unzip3 $ _vaoBufferTargets vao of
(a:b:_) -> (a,b)
threePtrsVAO :: VAO -> (Ptr Float, Ptr Float,Ptr Float)
{-# INLINE threePtrsVAO #-}
threePtrsVAO vao = case (\(_,ps,_) -> ps) $ unzip3 $ _vaoBufferTargets vao of
(a:b:c:_) -> (a,b,c)
@@ -299,11 +379,9 @@ threePtrsVAO vao = case (\(_,ps,_) -> ps) $ unzip3 $ _vaoBufferTargets vao of
renderPicture' :: RenderData -> Float -> Float -> (Float,Float) -> (Float,Float) ->
[(Point2,Point2)] -> [Point4] -> Picture -> IO (Word32,Word32)
renderPicture' pdata rot zoom (tranx,trany) (winx,winy) wallPoints lightPoints pic = do
ticksAfterL <- SDL.ticks
startWallTicks <- SDL.ticks
depthFunc $= Just Lequal
aticks <- SDL.ticks
-- calculate world transformation matrix
let scalMat = Linear.Matrix.transpose $
V4 (V4 (2*zoom/winx) 0 0 (0::GLfloat))
@@ -339,10 +417,10 @@ renderPicture' pdata rot zoom (tranx,trany) (winx,winy) wallPoints lightPoints p
uniform (snd shad !! 2) $= rot
uniform (snd shad !! 3) $= Vector2 tranx trany
uniform (snd shad !! 4) $= wmata
bticks <- SDL.ticks
-- draw lightmap
bindVertexArrayObject $= Just (_vao $ _wallVAO pdata)
wallPokeStart <- SDL.ticks
let wallPtr = (\(_,x,_) -> x) $ head $ _vaoBufferTargets $ _wallVAO pdata
-- wallPtr2 = (\(_,x,_) -> x) $ (_vaoBufferTargets $ _wallVAO pdata) !! 1
foldWalls n ((x,y),(z,w)) = do
@@ -350,6 +428,7 @@ renderPicture' pdata rot zoom (tranx,trany) (winx,winy) wallPoints lightPoints p
-- pokeFourOff wallPtr2 n (a,b,c,d)
return $ n+1
nWalls <- foldM foldWalls 0 wallPoints
wallPokeEnd <- SDL.ticks
forM_ lightPoints $ \(x,y,r,lum) -> do
cullFace $= Just Front
@@ -370,18 +449,23 @@ renderPicture' pdata rot zoom (tranx,trany) (winx,winy) wallPoints lightPoints p
drawArrays Points (fromIntegral 0) (fromIntegral 1)
-- ticksAfterL <- SDL.ticks
endWallTicks <- SDL.ticks
ticksS <- SDL.ticks
ticksAfterL <- SDL.ticks
-- draw picture
-- set drawing for on top
blendFuncSeparate $= ((SrcAlphaSaturate, OneMinusSrcAlpha), (Zero,One))
clear [DepthBuffer]
-- draw layer 0
ticks2 <- renderTree pdata rot zoom (tranx,trany) (winx,winy) (picToFTree 0 pic)
ticks2 <- renderTree pdata rot zoom (tranx,trany) (winx,winy) $ picToLTree 0 pic
--((picToAlt 0 pic) :: [RenderType])
-- reset blend so that light map doesn't apply
blendFunc $= (SrcAlpha,OneMinusSrcAlpha)
ticks3 <- renderTree pdata rot zoom (tranx,trany) (winx,winy) $ picToFTree 1 pic
ticks3 <- renderTree pdata rot zoom (tranx,trany) (winx,winy) $ picToLTree 1 pic
-- set drawing for on top
aticks <- SDL.ticks
blendFuncSeparate $= ((SrcAlphaSaturate, OneMinusSrcAlpha), (Zero,One))
ticks4 <- renderTree pdata rot zoom (tranx,trany) (winx,winy) $ picToFTree 2 pic
ticks4 <- renderTree pdata rot zoom (tranx,trany) (winx,winy) $ picToLTree 2 pic
bticks <- SDL.ticks
-- reset uniforms (hacky for now)
idmat <- (newMatrix RowMajor [1,0,0,0
,0,1,0,0
@@ -404,7 +488,9 @@ renderPicture' pdata rot zoom (tranx,trany) (winx,winy) wallPoints lightPoints p
uniform (snd shad !! 3) $= Vector2 (0::Float) 0
uniform (snd shad !! 4) $= idmat
--return (ticksAfterL, ticks2+ticks3+ticks4, endWallTicks - startWallTicks)
return (ticksAfterL, endWallTicks - startWallTicks)
ticksE <- SDL.ticks
--return (ticksAfterL, ticksE - ticksS)
return (ticksAfterL, ticks2 + ticks3 + ticks4)
bufferOffset :: Integral a => a -> Ptr b
bufferOffset = plusPtr nullPtr . fromIntegral
@@ -427,8 +513,8 @@ renderTree pdata rot zoom (tranx,trany) (winx,winy) tree = do
(twoPtrsVAO $ _lineVAO pdata)
(threePtrsVAO $ _arcVAO pdata)
) $ tree
pokeEndTicks <-SDL.ticks
pokeEndTicks <-SDL.ticks
depthFunc $= Just Less
currentProgram $= Just (fst $ _backShader pdata)