From bb05bcaaf1649e24344e8edb77da06ea109f0669 Mon Sep 17 00:00:00 2001 From: jgk Date: Sun, 28 Feb 2021 21:26:20 +0100 Subject: [PATCH] Commit before picture change --- app/Main.hs | 2 +- package.yaml | 1 + shader/wallShadow.geom | 8 +- src/Picture/Data.hs | 12 +++ src/Picture/Render.hs | 164 +++++++++++++++++++++++++++++++---------- 5 files changed, 143 insertions(+), 44 deletions(-) diff --git a/app/Main.hs b/app/Main.hs index 54e405ab5..3b274a2fc 100644 --- a/app/Main.hs +++ b/app/Main.hs @@ -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) diff --git a/package.yaml b/package.yaml index bee679f58..e92e4577d 100644 --- a/package.yaml +++ b/package.yaml @@ -56,6 +56,7 @@ executables: - -O2 - -rtsopts - -with-rtsopts=-N + - -flate-dmd-anal - -fno-liberate-case - -fno-state-hack - -funfolding-use-threshold1000 diff --git a/shader/wallShadow.geom b/shader/wallShadow.geom index ad45cf30b..1dfe654a8 100644 --- a/shader/wallShadow.geom +++ b/shader/wallShadow.geom @@ -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(); } diff --git a/src/Picture/Data.hs b/src/Picture/Data.hs index 64fd6e87d..dbe3682c2 100644 --- a/src/Picture/Data.hs +++ b/src/Picture/Data.hs @@ -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] diff --git a/src/Picture/Render.hs b/src/Picture/Render.hs index c862d8403..042fe6629 100644 --- a/src/Picture/Render.hs +++ b/src/Picture/Render.hs @@ -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)