From 5829c665270f92ce0aa3881f41a37e9e97216e57 Mon Sep 17 00:00:00 2001 From: jgk Date: Fri, 13 Aug 2021 12:28:17 +0200 Subject: [PATCH] Add new files --- src/Control/Foldl/JGK.hs | 9 +++ src/Dodge/Base/Collide.hs | 15 ---- src/Dodge/Creature/Boid.hs | 1 + src/Dodge/Layout/Tree/Shift.hs | 26 ++----- src/Dodge/LevelGen/SwarmPlacement.hs | 3 +- src/Dodge/Render.hs | 9 +-- src/Dodge/SoundLogic.hs | 1 - src/FoldableHelp.hs | 14 ++++ src/Geometry.hs | 82 ++++++++------------ src/Geometry/ConvexPoly.hs | 77 +++++++++++++++++++ src/Geometry/Intersect.hs | 8 +- src/Geometry/LHS.hs | 44 +++++++++++ src/Geometry/Vector.hs | 5 +- src/Hetris/Base.hs | 24 ++++++ src/Picture/Data.hs | 28 +------ src/PolyPic.hs | 29 ++++++++ src/Preload/Render.hs | 1 + src/Render.hs | 59 +++------------ src/Shader.hs | 100 +++++++------------------ src/Shader/Bind.hs | 53 +++++++++++++ src/Shader/Poke.hs | 107 +++++++++------------------ 21 files changed, 377 insertions(+), 318 deletions(-) create mode 100644 src/Control/Foldl/JGK.hs create mode 100644 src/Geometry/ConvexPoly.hs create mode 100644 src/Geometry/LHS.hs create mode 100644 src/Hetris/Base.hs create mode 100644 src/PolyPic.hs create mode 100644 src/Shader/Bind.hs diff --git a/src/Control/Foldl/JGK.hs b/src/Control/Foldl/JGK.hs new file mode 100644 index 000000000..7f3b46118 --- /dev/null +++ b/src/Control/Foldl/JGK.hs @@ -0,0 +1,9 @@ +module Control.Foldl.JGK + ( module Control.Foldl + ) where +import Control.Foldl + +--minimumOn :: Ord b => (a -> b) -> Fold a (Maybe a) +--minimumOn f = _Fold1 min' +-- where +-- min' x y diff --git a/src/Dodge/Base/Collide.hs b/src/Dodge/Base/Collide.hs index bcf95e77a..24e33a9f3 100644 --- a/src/Dodge/Base/Collide.hs +++ b/src/Dodge/Base/Collide.hs @@ -12,21 +12,6 @@ import Data.Maybe import qualified Data.IntMap.Strict as IM import Control.Lens --- | A version of 'minimum' where the comparison is done on some extracted value. --- Returns Nothing if the list is empty. Only calls the function once per element. --- --- > safeMinimumOn id [] == Nothing --- > safeMinimumOn length ["test","extra","a"] == Just "a" -safeMinimumOn' :: (Ord b) => (a -> b) -> [a] -> Maybe a -safeMinimumOn' _ [] = Nothing -safeMinimumOn' f (x:xs) = g x (f x) xs - where - g v _ [] = Just v - g v mv (y:ys) | my < mv = g y my ys - | otherwise = g v mv ys - where my = f y - - hasLOS :: Point2 -> Point2 -> World -> Bool {-# INLINE hasLOS #-} hasLOS p1 p2 w = not $ pointHitsWalls p1 p2 $ wallsAlongLine p1 p2 w diff --git a/src/Dodge/Creature/Boid.hs b/src/Dodge/Creature/Boid.hs index 5c33abbde..319c23050 100644 --- a/src/Dodge/Creature/Boid.hs +++ b/src/Dodge/Creature/Boid.hs @@ -5,6 +5,7 @@ import Dodge.Base import Dodge.Creature.State.Data import Dodge.Creature.ImpulseRat import Geometry +import Geometry.ConvexPoly import Control.Monad.Reader import Control.Lens diff --git a/src/Dodge/Layout/Tree/Shift.hs b/src/Dodge/Layout/Tree/Shift.hs index cda74cafa..0b1935726 100644 --- a/src/Dodge/Layout/Tree/Shift.hs +++ b/src/Dodge/Layout/Tree/Shift.hs @@ -4,11 +4,14 @@ links connect and that none of them clip. Returns a list; after this step the structure is determined by the actual positions of rooms. -} module Dodge.Layout.Tree.Shift - where + ( shiftRoomTreeSearchAll + , shiftExpandTree + ) where import Dodge.Room.Data import Dodge.Room.Link import Dodge.Layout.Tree.Polymorphic import Geometry +import Geometry.ConvexPoly --import Geometry.Data import Data.Tree @@ -16,25 +19,7 @@ import Data.Sequence hiding (zipWith) import Data.List (delete) import Data.Maybe (listToMaybe) import Control.Lens hiding (Empty, (<|) , (|>)) - -{- | -Helper: Depth first search of trees of rooms, maybe produces a list rooms that are not clipping. - -} -shiftRoomTreeSearch - :: [[Point2]] -- ^ Clipping bounds - -> Seq (Tree Room) -- ^ Rooms to be added - -> Maybe [Room] -shiftRoomTreeSearch _ Empty = Just [] -shiftRoomTreeSearch bs (Node r ts :<| ts') - | roomIsClipping = Nothing - | otherwise = fmap (r :) . shiftRoomTreeSearch newBounds $ ts' >< chldren - where - roomIsClipping = or (polysIntersect <$> _rmBound r <*> bs) - newBounds = _rmBound r ++ bs - chldren = fromList $ zipWith (applyToRoot . shiftRoomToLink) (_rmLinks r) ts -{- | -All: Depth first search of trees of rooms, produces a list of lists of rooms that are not clipping. - -} +{- | All: Depth first search of trees of rooms, produces a list of lists of rooms that are not clipping. -} shiftRoomTreeSearchAll :: [[Point2]] -- ^ Clipping bounds -> Seq (Tree Room) -- ^ Rooms to be added @@ -46,6 +31,7 @@ shiftRoomTreeSearchAll bs (Node r ts :<| ts') [] -> (r :) <$> shiftRoomTreeSearchAll newBounds ts' (s:ss) -> concatMap (\l -> shiftRoomTreeSearchAll bs (Node (rm l) ss <| (ts' |> f l s))) ls where + convexBounds = map pointsToPoly $ _rmBound r ls = init $ _rmLinks r newBounds = _rmBound r ++ bs roomIsClipping = or (polysOverlap <$> _rmBound r <*> bs) diff --git a/src/Dodge/LevelGen/SwarmPlacement.hs b/src/Dodge/LevelGen/SwarmPlacement.hs index f980a2940..36762a768 100644 --- a/src/Dodge/LevelGen/SwarmPlacement.hs +++ b/src/Dodge/LevelGen/SwarmPlacement.hs @@ -5,7 +5,8 @@ module Dodge.LevelGen.SwarmPlacement import Dodge.Data import Dodge.LevelGen.Data import Dodge.Creature.State.Data -import Geometry +--import Geometry +import Geometry.ConvexPoly import qualified IntMapHelp as IM import Data.List diff --git a/src/Dodge/Render.hs b/src/Dodge/Render.hs index 9f8b76e78..a93022d4a 100644 --- a/src/Dodge/Render.hs +++ b/src/Dodge/Render.hs @@ -7,17 +7,13 @@ module Dodge.Render import Dodge.Data import Dodge.Config.Data import Dodge.Base.Window ---import Dodge.Render.HUD ---import Dodge.Render.MenuScreen import Dodge.Render.Picture ---import Dodge.Render.PerspectiveMatrix import Geometry ---import Geometry.Data ---import Picture import Render import Data.Preload.Render import Shader import Shader.Poke +import Shader.Bind import Shader.Data import MatrixHelper --import Polyhedra.Data @@ -50,6 +46,7 @@ doDrawing pdata w = do (wallPointsCol,windowPoints) = wallsAndWindows w lightPoints = lightsForGloom w viewFroms = _cameraViewFrom w + shadV = _pictureShaders pdata -- bind as much data into vbos as feasible at this point -- poke wall points and colors nWalls <- poke224s (shadVBOptr $ _wallTextureShader pdata) wallPointsCol @@ -60,7 +57,6 @@ doDrawing pdata w = do nsurfVs <- pokePoint3s (shadVBOptr $ _lightingSurfaceShader pdata) $ polyToTris (map addC $ screenPolygon w) ++ concatMap polyToGeoRender (foregroundPics w) - -- bind wall points, silhouette data, surface geometry uncurry bindShaderBuffers $ unzip [ ( _wallTextureShader pdata, nWalls) @@ -77,7 +73,6 @@ doDrawing pdata w = do then renderTextureWalls pdata nWalls else renderBlankWalls pdata nWalls - let shadV = _pictureShaders pdata renderFoldable shadV $ polysToPic $ foregroundPics w layerCounts <- UMV.replicate (6*6) 0 diff --git a/src/Dodge/SoundLogic.hs b/src/Dodge/SoundLogic.hs index f41706347..45ef433fe 100644 --- a/src/Dodge/SoundLogic.hs +++ b/src/Dodge/SoundLogic.hs @@ -23,7 +23,6 @@ module Dodge.SoundLogic ( import Dodge.Data import Sound.Data (SoundStatus (..)) import Geometry.Vector -import Geometry (dist) import Control.Lens import qualified Data.Map as M diff --git a/src/FoldableHelp.hs b/src/FoldableHelp.hs index 2ff9ad7f0..b0ba71c84 100644 --- a/src/FoldableHelp.hs +++ b/src/FoldableHelp.hs @@ -5,6 +5,12 @@ module FoldableHelp where import Data.Foldable +-- TODO check up whether and how it is necessary to specialise this +-- | A version of 'minimum' where the comparison is done on some extracted value. +-- Returns Nothing if the list is empty. Only calls the function once per element. +-- +-- > safeMinimumOn id [] == Nothing +-- > safeMinimumOn length ["test","extra","a"] == Just "a" safeMinimumOn :: (Foldable t,Ord b) => (a -> b) -> t a -> Maybe a safeMinimumOn f = foldl' g Nothing where @@ -12,3 +18,11 @@ safeMinimumOn f = foldl' g Nothing | f x < f y = Just x | otherwise = Just y g Nothing y = Just y +--{- | Partial. -} +--minimumOn :: Ord b => (a -> b) -> [a] -> a +--minimumOn f [] = error "tried to take minimumOn of empty list" +--minimumOn f (x:xs) = go x xs +-- where +-- go x (y:xs) | f x < f y = go x xs +-- | otherwise = go y xs +-- go x [] = x diff --git a/src/Geometry.hs b/src/Geometry.hs index c7d5d638c..c884c8869 100644 --- a/src/Geometry.hs +++ b/src/Geometry.hs @@ -14,12 +14,14 @@ module Geometry , module Geometry.Intersect , module Geometry.Bezier , module Geometry.Vector + , module Geometry.LHS ) where import Geometry.Data import Geometry.Intersect import Geometry.Bezier import Geometry.Vector +import Geometry.LHS --import Data.Function import Data.List @@ -105,44 +107,6 @@ errorClosestPointOnLineParam :: Int -> Point2 -> Point2 -> Point2 -> Float errorClosestPointOnLineParam _ !x! y! z | x == y = dist x z | otherwise = closestPointOnLineParam x y z --- | Test whether a point is on the LHS of a line. --- Returns False if the line is of zero length. -isLHS - :: Point2 -- ^ First line point. - -> Point2 -- ^ Second line point. - -> Point2 -- ^ Point not on line. - -> Bool -{-# INLINE isLHS #-} -isLHS - (V2 x y) - (V2 x' y') - (V2 x'' y'') - | (x,y) == (x',y') = False - | otherwise = a1 * b2 - a2 * b1 > 0 - where - a1 = x' - x - a2 = y' - y - b1 = x'' - x - b2 = y'' - y --- | Test whether a point is on the LHS of a line. --- Returns False if the line is of zero length. -isRHS - :: Point2 -- ^ First line point. - -> Point2 -- ^ Second line point. - -> Point2 -- ^ Point not on line. - -> Bool -{-# INLINE isRHS #-} -isRHS - (V2 x y) - (V2 x' y') - (V2 x'' y'') - | (x,y) == (x',y') = False - | otherwise = a1 * b2 - a2 * b1 < 0 - where - a1 = x' - x - a2 = y' - y - b1 = x'' - x - b2 = y'' - y orderPolygonAround :: Point2 -- ^ point to order around -> [Point2] @@ -182,10 +146,6 @@ grahamEliminate (x:y:z:xs) | isRHS x y z = grahamEliminate (x:z:xs) grahamEliminate xs = xs --- | Return distance between two points. -dist :: Point2 -> Point2 -> Float -{-# INLINE dist #-} -dist !p1 !p2 = magV (p2 -.- p1) -- | Return midpoint between two points. pHalf :: Point2 -> Point2 -> Point2 pHalf !a !b = 0.5 *.* (a +.+ b) @@ -234,18 +194,39 @@ doubleV2 (V2 x y) = [V2 x y,V2 y x] -- | Test whether two polygons intersect by testing the intersection of each -- consecutive pair of points. +--polysIntersect :: [Point2] -> [Point2] -> Bool +--{-# INLINE polysIntersect #-} +--polysIntersect (p:ps) (q:qs) +-- -- = any isJust $ (\(V2 a b) (V2 c d) -> myIntersectSegSeg a b c d) <$> pairs1 <*> pairs2 +-- = or $ (\(V2 a b) (V2 c d) -> isJust $ myIntersectSegSeg a b c d) <$> pairs1 <*> pairs2 +-- where +-- pairs1 = zipWith V2 (p:ps) (ps++[p]) +-- pairs2 = zipWith V2 (q:qs) (qs++[q]) +--polysIntersect _ _ = False + polysIntersect :: [Point2] -> [Point2] -> Bool -polysIntersect (p:ps) (q:qs) - = any isJust $ (\(a,b) (c,d) -> myIntersectSegSeg a b c d) <$> pairs1 <*> pairs2 - where - pairs1 = zip (p:ps) (ps++[p]) - pairs2 = zip (q:qs) (qs++[q]) +polysIntersect (a:b:xs) ps = go a (a:b:xs) ps + where + go x' (a':b':xs') ps' = pairPolyIntersect a' b' ps' || go x' (b':xs') ps' + go b' (a':[]) ps' = pairPolyIntersect a' b' ps' + go _ _ _ = False polysIntersect _ _ = False + +pairPolyIntersect :: Point2 -> Point2 -> [Point2] -> Bool +pairPolyIntersect a' b' (c':d':xs') = go c' a' b' (c':d':xs') + where + go x a b (c:d:xs) + | isJust $ myIntersectSegSeg a b c d = True + | otherwise = go x a b (d:xs) + go d a b (c:[]) = isJust $ myIntersectSegSeg a b c d + go _ _ _ _ = False +pairPolyIntersect _ _ _ = False + -- | Test whether two polygons intersect or if one is contained in the other. polysOverlap :: [Point2] -> [Point2] -> Bool -polysOverlap (p:ps) (q:qs) = polysIntersect (p:ps) (q:qs) - || pointInPolygon p (q:qs) +polysOverlap (p:ps) (q:qs) = pointInPolygon p (q:qs) || pointInPolygon q (p:ps) + || polysIntersect (p:ps) (q:qs) polysOverlap _ _ = False -- | Test whether any polygons from a first list intersect with any polygons from -- a second list. @@ -499,6 +480,3 @@ pointIsInCone -> Point2 -- ^ Point to test. -> Bool pointIsInCone c (rightp,leftp) p = isLHS c rightp p && isLHS leftp c p --- | TODO: implement using Control.Foldl -centroid :: Foldable t => t Point2 -> Point2 -centroid xs = 1 / fromIntegral (length xs) *.* foldl' (+.+) (V2 0 0) xs diff --git a/src/Geometry/ConvexPoly.hs b/src/Geometry/ConvexPoly.hs new file mode 100644 index 000000000..88bd4238e --- /dev/null +++ b/src/Geometry/ConvexPoly.hs @@ -0,0 +1,77 @@ +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE BangPatterns #-} +module Geometry.ConvexPoly + ( ConvexPoly (..) + , cpPoints + , cpCen + , cpRad + , centroid + , pointsToPoly + , convexPolysOverlap + ) where +import Geometry.Data +import Geometry.Vector +import Geometry.LHS +import Geometry.Intersect + +import Data.Maybe +import Control.Lens +import qualified Control.Foldl as L +data ConvexPoly = ConvexPoly + { _cpPoints :: [Point2] + , _cpCen :: Point2 + , _cpRad :: Float + } +pointsToPoly :: [Point2] -> ConvexPoly +pointsToPoly xs = ConvexPoly + { _cpPoints = xs + , _cpCen = cen + , _cpRad = minimum $ map (dist cen) xs + } + where + cen = centroid xs + +-- | Test whether two polygons intersect or if one is contained in the other. +convexPolysOverlap :: ConvexPoly -> ConvexPoly -> Bool +convexPolysOverlap cp1 cp2 = dist (_cpCen cp1) (_cpCen cp2) < _cpRad cp1 + _cpRad cp2 + && polyPointsOverlap (_cpPoints cp1) (_cpPoints cp2) + +--pointInConvexPoly :: Point2 -> ConvexPoly -> Bool +--pointInConvexPoly p cp = dist p (_cpCen cp) < _cpRad cp +-- && pointInPolyPoints p (_cpPoints cp) + +-- | Test whether two polygons intersect or if one is contained in the other. +polyPointsOverlap :: [Point2] -> [Point2] -> Bool +polyPointsOverlap (p:ps) (q:qs) = pointInPolyPoints p (q:qs) + || pointInPolyPoints q (p:ps) + || polyPointsIntersect (p:ps) (q:qs) +polyPointsOverlap _ _ = False + +-- | Test whether a point is strictly inside a polygon. +-- Supposes the points in the polygon are listed in anticlockwise order. +pointInPolyPoints :: Point2 -> [Point2] -> Bool +pointInPolyPoints !p (x:xs) = all (\l -> uncurry isLHS l p) $ zip (x:xs) (xs ++ [x]) +pointInPolyPoints _ [] = False + +polyPointsIntersect :: [Point2] -> [Point2] -> Bool +polyPointsIntersect (a:b:xs) ps = go a (a:b:xs) ps + where + go x' (a':b':xs') ps' = pairPolyPointsIntersect a' b' ps' || go x' (b':xs') ps' + go b' (a':[]) ps' = pairPolyPointsIntersect a' b' ps' + go _ _ _ = False +polyPointsIntersect _ _ = False + +pairPolyPointsIntersect :: Point2 -> Point2 -> [Point2] -> Bool +pairPolyPointsIntersect a' b' (c':d':xs') = go c' a' b' (c':d':xs') + where + go x a b (c:d:xs) + | isJust $ myIntersectSegSeg a b c d = True + | otherwise = go x a b (d:xs) + go d a b (c:[]) = isJust $ myIntersectSegSeg a b c d + go _ _ _ _ = False +pairPolyPointsIntersect _ _ _ = False + +centroid :: Foldable t => t Point2 -> Point2 +centroid = L.fold $ (/) <$> L.Fold (+.+) (V2 0 0) id <*> L.genericLength + +makeLenses ''ConvexPoly diff --git a/src/Geometry/Intersect.hs b/src/Geometry/Intersect.hs index c7d9338c8..84a3ab19d 100644 --- a/src/Geometry/Intersect.hs +++ b/src/Geometry/Intersect.hs @@ -87,6 +87,7 @@ myIntersectSegSeg -> Point2 -> Point2 -> Maybe Point2 +{-# INLINE myIntersectSegSeg #-} myIntersectSegSeg a@(V2 ax ay) b@(V2 bx by) c@(V2 cx cy) d@(V2 dx dy) = case ratIntersectLineLine a b c d of Nothing -> Nothing Just (V2 x y) -> if inbetween x && inbetween' y @@ -99,6 +100,7 @@ myIntersectSegSeg a@(V2 ax ay) b@(V2 bx by) c@(V2 cx cy) d@(V2 dx dy) = case rat && ((cy <= y && y <= dy) || (dy <= y && y <= cy)) -- | Polymorphic intersection of fractional line points. myIntersectLineLine :: (Eq a,Fractional a) => V2 a -> V2 a -> V2 a -> V2 a -> Maybe (V2 a) +{-# INLINE myIntersectLineLine #-} myIntersectLineLine a@(V2 ax _) b c@(V2 cx _) d | isNothing (linGrad a b) = V2 ax <$> axisInt (c *-* V2 ax 0) (d *-* V2 ax 0) | isNothing (linGrad c d) = V2 cx <$> axisInt (a *-* V2 cx 0) (b *-* V2 cx 0) @@ -115,6 +117,7 @@ myIntersectLineLine a@(V2 ax _) b c@(V2 cx _) d (*-*) (V2 ax' ay) (V2 bx by) = V2 (ax'-bx) (ay-by) -- | Transforms floating points to rationals then performs line intersection. ratIntersectLineLine :: Point2 -> Point2 -> Point2 -> Point2 -> Maybe Point2 +{-# INLINE ratIntersectLineLine #-} ratIntersectLineLine a b c d = toNumPoint2 <$> myIntersectLineLine (toRatPoint2 a) (toRatPoint2 b) (toRatPoint2 c) (toRatPoint2 d) where @@ -131,18 +134,19 @@ but is symmetric around 0: >>> roundPoint2 (0.5,-0.5) (0.0,0.0) - -} roundPoint2 :: Point2 -> Point2 roundPoint2 (V2 x y) = V2 (fromIntegral (round x :: Int)) (fromIntegral (round y :: Int)) -- | Given two points, finds the linear gradient if it is non-infinite. linGrad :: (Eq a,Fractional a) => V2 a -> V2 a -> Maybe a +{-# INLINE linGrad #-} linGrad (V2 x y) (V2 a b) | x-a == 0 = Nothing | otherwise = Just $ (y-b)/(x-a) -- | Given two points, finds the intersection with the y axis if it exists. axisInt :: (Eq a,Fractional a) => V2 a -> V2 a -> Maybe a -axisInt p (V2 a b) = (\lg -> b - (a*lg)) <$> linGrad p (V2 a b) +{-# INLINE axisInt #-} +axisInt p (V2 a b) = (\lg -> b - (a*lg)) <$> linGrad p (V2 a b) -- | Placeholder, undefined. intersectSegsSeg :: [Point2] -> Point2 -> Point2 -> Maybe Point2 intersectSegsSeg = undefined diff --git a/src/Geometry/LHS.hs b/src/Geometry/LHS.hs new file mode 100644 index 000000000..c282c768b --- /dev/null +++ b/src/Geometry/LHS.hs @@ -0,0 +1,44 @@ +module Geometry.LHS + ( isLHS + , isRHS + ) where +import Geometry.Data +import Geometry.Vector +-- | Test whether a point is on the LHS of a line. +-- Returns False if the line is of zero length. +isLHS + :: Point2 -- ^ First line point. + -> Point2 -- ^ Second line point. + -> Point2 -- ^ Point not on line. + -> Bool +{-# INLINE isLHS #-} +isLHS + (V2 x y) + (V2 x' y') + (V2 x'' y'') + | (x,y) == (x',y') = False + | otherwise = a1 * b2 - a2 * b1 > 0 + where + a1 = x' - x + a2 = y' - y + b1 = x'' - x + b2 = y'' - y +-- | Test whether a point is on the LHS of a line. +-- Returns False if the line is of zero length. +isRHS + :: Point2 -- ^ First line point. + -> Point2 -- ^ Second line point. + -> Point2 -- ^ Point not on line. + -> Bool +{-# INLINE isRHS #-} +isRHS + (V2 x y) + (V2 x' y') + (V2 x'' y'') + | (x,y) == (x',y') = False + | otherwise = a1 * b2 - a2 * b1 < 0 + where + a1 = x' - x + a2 = y' - y + b1 = x'' - x + b2 = y'' - y diff --git a/src/Geometry/Vector.hs b/src/Geometry/Vector.hs index 86025db88..8e8bc46e5 100644 --- a/src/Geometry/Vector.hs +++ b/src/Geometry/Vector.hs @@ -122,4 +122,7 @@ projV fromv onv | otherwise = (fromv `dotV` onv) / den *.* onv where den = onv `dotV` onv - +-- | Return distance between two points. +dist :: Point2 -> Point2 -> Float +{-# INLINE dist #-} +dist !p1 !p2 = magV (p2 -.- p1) diff --git a/src/Hetris/Base.hs b/src/Hetris/Base.hs new file mode 100644 index 000000000..3a42e70ce --- /dev/null +++ b/src/Hetris/Base.hs @@ -0,0 +1,24 @@ +module Hetris.Base + where +import Shader.Data +import Shader.Compile + +--import qualified Data.Vector.Unboxed.Mutable as MV +--import Control.Monad.Primitive +--import qualified Data.Array.Repa as R +import Linear.V2 + +data World = World + { _placedBlocks :: [[V2 Float]] + , _polyShader :: FullShader + } + +initWorld :: IO World +initWorld = do + let pb = replicate 20 [0,0,0,0,0,1,1,1,1,1] + theShader <- makeShader "twoD/basic" [vert,frag] [3,4] ETriangles + return $ World + {_placedBlocks = pb + ,_polyShader = theShader + } + diff --git a/src/Picture/Data.hs b/src/Picture/Data.hs index 4bf908a4b..2f8f16b52 100644 --- a/src/Picture/Data.hs +++ b/src/Picture/Data.hs @@ -1,22 +1,9 @@ {-# LANGUAGE TemplateHaskell #-} ---{-# LANGUAGE Strict #-} module Picture.Data where import Geometry.Data import Control.Lens ---import GHC.Generics (Generic) ---import Control.DeepSeq ---import Data.Foldable ---import qualified Data.List as L ---import Data.Monoid ---import Data.Traversable ---import qualified Data.Foldable as F ---import qualified Data.Sequence as Se ---import qualified Data.DList as DL ---import qualified Data.Vector as V ---import Control.Monad - data Verx = Verx { _vxPos :: !Point3 , _vxCol :: !Point4 @@ -24,16 +11,7 @@ data Verx = Verx , _vxLayer :: !Int , _vxShadNum :: !ShadNum } -data VertexType - = PolyV - | PolyzV !Float - | BezV !Point4 - | TextV !Point2 - | ArcV !Point3 - | EllV - newtype ShadNum = ShadNum { _unShadNum :: Int } - polyNum, polyzNum, bezNum, textNum, arcNum, ellNum :: ShadNum polyNum = ShadNum 0 polyzNum = ShadNum 1 @@ -41,10 +19,9 @@ bezNum = ShadNum 2 textNum = ShadNum 3 arcNum = ShadNum 4 ellNum = ShadNum 5 - +type Picture = [Verx] type RGBA = Point4 type Color = Point4 - flat2 :: V2 a -> [a] flat2 (V2 x y) = [x,y] flat3 :: V3 a -> [a] @@ -63,7 +40,4 @@ tflat4 (x,y,z,w) = [x,y,z,w] {-# INLINE tflat2 #-} {-# INLINE tflat3 #-} {-# INLINE tflat4 #-} - -type Picture = [Verx] - makeLenses ''Verx diff --git a/src/PolyPic.hs b/src/PolyPic.hs new file mode 100644 index 000000000..511eb2701 --- /dev/null +++ b/src/PolyPic.hs @@ -0,0 +1,29 @@ +{-# LANGUAGE TemplateHaskell #-} +module PolyPic + where +--import Linear.V3 +import Linear.V4 +import Geometry +import Picture + +import Control.Lens + +data Vert = Vert + {_vtPos :: !(V2 Float) + ,_vtCol :: !(V4 Float) + } +makeLenses ''Vert + +type Pic2d = [Vert] + +polygon2d :: [Point2] -> Pic2d +polygon2d = map f . polyToTris + where + f p = Vert p black + +color2d :: RGBA -> Pic2d -> Pic2d +color2d = map . set vtCol + +translate2d :: Float -> Float -> Pic2d -> Pic2d +translate2d x y = map $ over vtPos (+.+ V2 x y) + diff --git a/src/Preload/Render.hs b/src/Preload/Render.hs index 83c521e2f..1dd35cbe0 100644 --- a/src/Preload/Render.hs +++ b/src/Preload/Render.hs @@ -10,6 +10,7 @@ import Shader.Data import Shader.Compile import Shader.AuxAddition import Shader.Parameters +import Shader.Bind import Data.Preload.Render import Graphics.Rendering.OpenGL hiding (Point,translate,scale,imageHeight) diff --git a/src/Render.hs b/src/Render.hs index 92bdf387b..ff20521f8 100644 --- a/src/Render.hs +++ b/src/Render.hs @@ -1,32 +1,20 @@ ---{-# LANGUAGE TupleSections #-} module Render where import Shader import Shader.Data -import Shader.Poke ---import MatrixHelper +--import Shader.Poke import Data.Preload.Render import Picture.Data ---import Picture.Tree ---import Geometry import Geometry.Data ---import Polyhedra.Data ---import Polyhedra ---import Layers import Data.Foldable ---import Control.Lens ---import Control.Monad ---import qualified Control.Foldl as F import Foreign hiding (rotate) import Graphics.Rendering.OpenGL hiding (Line,translate,scale,imageHeight,Polygon,Color,T) ---import Data.Foldable ---import Data.Tuple.Extra ---import qualified Data.IntMap.Strict as IM import qualified SDL import qualified Data.Vector.Unboxed.Mutable as UMV import qualified Data.Vector.Mutable as MV import Control.Monad.Primitive +--import qualified Data.Vector.Fusion.Stream.Monadic as VS divideSize :: Int -> Size -> Size divideSize i (Size x y) = Size (div x $ fromIntegral i) (div y $ fromIntegral i) @@ -44,15 +32,15 @@ createLightMap -> IO () createLightMap pdata lightPoints nWalls nSils nsurfVs = do depthFunc $= Just Less --- clear buffer to full alpha and furthest depth --- clearColor is specified in preloadRender + -- clear buffer to full alpha and furthest depth + -- clearColor is specified in preloadRender clearColor $= Color4 0 0 0 1 clear [ColorBuffer,DepthBuffer] --colorMask $= Color4 Disabled Disabled Disabled Disabled cullFace $= Just Back --- draw walls from your point of view in order to set z buffer + -- draw walls from your point of view in order to set z buffer drawShader (_lightingWallShader pdata) nWalls - ---- draw foreground elements to set z buffer + -- draw foreground elements to set z buffer drawShader (_lightingSurfaceShader pdata) nsurfVs -- for each of the lights: -- stencil out the walls from this light's point of view @@ -62,6 +50,7 @@ createLightMap pdata lightPoints nWalls nSils nsurfVs = do blendFunc $= (Zero, OneMinusSrcAlpha) stencilTest $= Enabled depthFunc $= Just Lequal + --flip VS.mapM_ (VS.fromList lightPoints) $ \(V3 x y z,r,lum) -> do forM_ lightPoints $ \(V3 x y z,r,lum) -> do -- stencil out shadows colorMask $= Color4 Disabled Disabled Disabled Disabled @@ -85,7 +74,6 @@ createLightMap pdata lightPoints nWalls nSils nsurfVs = do currentProgram $= Just (_shaderProgram $ _lightingLineShadowShader pdata) drawShader (_lightingLineShadowShader pdata) nSils - --depthFunc $= Just Lequal -- draw geometry surfaces cullFace $= Just Back colorMask $= Color4 Disabled Disabled Disabled Enabled @@ -105,11 +93,8 @@ createLightMap pdata lightPoints nWalls nSils nsurfVs = do drawShader (_lightingWallShader pdata) nWalls cullFace $= Nothing stencilTest $= Disabled - --blend $= Disabled -{- | -Blur between two framebuffers. -Assumes no depth testing is done - -} +{- | Blur between two framebuffers. +Assumes no depth testing is done -} pingPongBlur :: RenderData -> IO () pingPongBlur pdata = do bindFramebuffer Framebuffer $= fst (_fbo3 pdata) @@ -119,7 +104,6 @@ pingPongBlur pdata = do bindFramebuffer Framebuffer $= fst (_fbo2 pdata) textureBinding Texture2D $= Just (snd $ _fbo3 pdata) drawShader (_bloomBlurShader pdata) 4 - -- assumes that vertices have already been sent to the shader pingPongBetween :: (FramebufferObject,TextureObject) @@ -145,24 +129,6 @@ drawTextureOnFramebuffer fs fbo to = do textureBinding Texture2D $= Just to drawShader fs 4 -pokeBindFoldable - :: MV.MVector (PrimState IO) FullShader - -> UMV.MVector (PrimState IO) Int - -> [Verx] - -> IO () -pokeBindFoldable shadV counts m = do - pokeVerxs shadV counts m - bindShader shadV counts - -pokeBindFoldableLayer - :: MV.MVector (PrimState IO) FullShader - -> UMV.MVector (PrimState IO) Int - -> Picture - -> IO () -pokeBindFoldableLayer shadV counts m = do - pokeLayVerxs shadV counts m - bindShaderLayers shadV counts - renderFoldable :: MV.MVector (PrimState IO) FullShader -> [Verx] @@ -170,7 +136,7 @@ renderFoldable renderFoldable shadV struct = do counts <- UMV.replicate 6 0 pokeBindFoldable shadV counts struct - MV.imapM_ (drawShaderLay' 0 counts) shadV + MV.imapM_ (drawShaderLay 0 counts) shadV renderFoldableTimed :: MV.MVector (PrimState IO) FullShader @@ -180,11 +146,10 @@ renderFoldableTimed shadV struct = do pokeStartTicks <- SDL.ticks counts <- UMV.replicate 6 0 pokeBindFoldable shadV counts struct - MV.imapM_ (drawShaderLay' 0 counts) shadV + MV.imapM_ (drawShaderLay 0 counts) shadV pokeEndTicks <- SDL.ticks return $ pokeEndTicks - pokeStartTicks ------------------------------end renderFoldable - renderLayer :: Int -> MV.MVector (PrimState IO) FullShader @@ -192,7 +157,7 @@ renderLayer -> IO () renderLayer layer shads counts = do let layerCounts = UMV.slice (layer * 6) 6 counts - MV.imapM_ (drawShaderLay' layer layerCounts) shads + MV.imapM_ (drawShaderLay layer layerCounts) shads pokeTwoOff :: Ptr Float diff --git a/src/Shader.hs b/src/Shader.hs index cae5e93ff..32f443d65 100644 --- a/src/Shader.hs +++ b/src/Shader.hs @@ -1,91 +1,28 @@ module Shader - ( bindShaderLayers - , bindShaderBuffers - , bindShader - , drawShader - , freeShaderPointers + ( freeShaderPointers , drawShaderLay - , drawShaderLay' , shadVBOptr + , drawShader + , pokeBindFoldable + , pokeBindFoldableLayer ) where ---import Geometry.Data import Shader.Data import Shader.Parameters import Shader.ExtraPrimitive ---import Shader.Poke ---import Layers ---import MatrixHelper +import Shader.Poke +import Shader.Bind +import Picture.Data import qualified Data.Vector.Unboxed.Mutable as UMV import qualified Data.Vector.Mutable as MV import Control.Monad.Primitive import Foreign -import Control.Monad import Graphics.Rendering.OpenGL hiding (Point,translate,scale,imageHeight) import Graphics.GL.Core43 ---import qualified Data.IntMap.Strict as IM ---import Data.Bifunctor ---import Text.RawString.QQ ---import Linear.Matrix ---import Linear.V4 ---import qualified Data.Vector.Unboxed.Mutable as MV ---import Control.Monad.Primitive -bindArrayBuffers :: Int -> VBO -> IO () -bindArrayBuffers numVs theVBO = do - bindBuffer ArrayBuffer $= Just (_vbo theVBO) - bufferSubData - ArrayBuffer - WriteToBuffer - 0 - (fromIntegral $ floatSize * numVs * sum (_vboAttribSizes theVBO)) - (_vboPtr theVBO) - -bindShaderLayers :: MV.MVector (PrimState IO) FullShader -> UMV.MVector (PrimState IO) Int -> IO () -bindShaderLayers shads counts = MV.imapM_ f shads - where - f i shad = do - let theVBO = _vaoVBO $ _shaderVAO shad - stride = sum $ _vboAttribSizes theVBO - bindBuffer ArrayBuffer $= (Just . _vbo $ theVBO) - mapM_ (g stride theVBO) [0..5] - where - g stride theVBO lay = do - numVs <- UMV.unsafeRead counts $ lay * 6 + i - bufferSubData - ArrayBuffer - WriteToBuffer - (fromIntegral $ floatSize * stride * numSubElements * lay) - (fromIntegral $ floatSize * numVs * stride) - (_vboPtr theVBO `plusPtr` (floatSize * stride * numSubElements * lay)) - - - -bindShader :: MV.MVector (PrimState IO) FullShader -> UMV.MVector (PrimState IO) Int -> IO () -bindShader shads counts = MV.imapM_ f shads - where - f i shad = UMV.read counts i >>= flip bindArrayBuffers (_vaoVBO . _shaderVAO $ shad) - - -bindShaderBuffers :: [FullShader] -> [Int] -> IO () -bindShaderBuffers = zipWithM_ f - where - f fs i = bindArrayBuffers i $ _vaoVBO $ _shaderVAO fs - -drawShaderLay :: Int -> FullShader -> Int -> IO () +drawShaderLay :: Int -> UMV.MVector (PrimState IO) Int -> Int -> FullShader -> IO () {-# INLINE drawShaderLay #-} -drawShaderLay l fs i = do - currentProgram $= Just (_shaderProgram fs) - bindVertexArrayObject $= Just (_vao $ _shaderVAO fs) - case _shaderTexture fs of - Just ShaderTexture{_textureObject = txo} - -> textureBinding Texture2D $= Just txo - _ -> return () - glDrawArrays (marshalEPrimitiveMode $ _shaderDrawPrimitive fs) (fromIntegral $ l*numSubElements) (fromIntegral i) - -drawShaderLay' :: Int -> UMV.MVector (PrimState IO) Int -> Int -> FullShader -> IO () -{-# INLINE drawShaderLay' #-} -drawShaderLay' l countsVector shadIn fs = do +drawShaderLay l countsVector shadIn fs = do i <- UMV.read countsVector shadIn currentProgram $= Just (_shaderProgram fs) bindVertexArrayObject $= Just (_vao $ _shaderVAO fs) @@ -109,5 +46,24 @@ drawShader fs i = do freeShaderPointers :: FullShader -> IO () freeShaderPointers fs = free $ _vboPtr $ _vaoVBO $ _shaderVAO fs +pokeBindFoldable + :: MV.MVector (PrimState IO) FullShader + -> UMV.MVector (PrimState IO) Int + -> Picture + -> IO () +pokeBindFoldable shadV counts m = do + pokeVerxs shadV counts m + bindShader shadV counts + +pokeBindFoldableLayer + :: MV.MVector (PrimState IO) FullShader + -> UMV.MVector (PrimState IO) Int + -> Picture + -> IO () +pokeBindFoldableLayer shadV counts m = do + pokeLayVerxs shadV counts m + bindShaderLayers shadV counts + shadVBOptr :: FullShader -> Ptr Float +{-# INLINE shadVBOptr #-} shadVBOptr = _vboPtr . _vaoVBO . _shaderVAO diff --git a/src/Shader/Bind.hs b/src/Shader/Bind.hs new file mode 100644 index 000000000..9bbe01cf8 --- /dev/null +++ b/src/Shader/Bind.hs @@ -0,0 +1,53 @@ +module Shader.Bind + ( bindShaderLayers + , bindShaderBuffers + , bindShader + ) where +import Shader.Data +import Shader.Parameters +--import Shader.ExtraPrimitive + +import Graphics.Rendering.OpenGL hiding (Line,translate,scale,imageHeight,Polygon,Color,T) +import Foreign hiding (rotate) +import qualified Data.Vector.Unboxed.Mutable as UMV +import qualified Data.Vector.Mutable as MV +import Control.Monad.Primitive +import Control.Monad + +bindArrayBuffers :: Int -> VBO -> IO () +bindArrayBuffers numVs theVBO = do + bindBuffer ArrayBuffer $= Just (_vbo theVBO) + bufferSubData + ArrayBuffer + WriteToBuffer + 0 + (fromIntegral $ floatSize * numVs * sum (_vboAttribSizes theVBO)) + (_vboPtr theVBO) + +bindShaderLayers :: MV.MVector (PrimState IO) FullShader -> UMV.MVector (PrimState IO) Int -> IO () +bindShaderLayers shads counts = MV.imapM_ f shads + where + f i shad = do + let theVBO = _vaoVBO $ _shaderVAO shad + stride = sum $ _vboAttribSizes theVBO + bindBuffer ArrayBuffer $= (Just . _vbo $ theVBO) + mapM_ (g stride theVBO) [0..5] + where + g stride theVBO lay = do + numVs <- UMV.unsafeRead counts $ lay * 6 + i + bufferSubData + ArrayBuffer + WriteToBuffer + (fromIntegral $ floatSize * stride * numSubElements * lay) + (fromIntegral $ floatSize * numVs * stride) + (_vboPtr theVBO `plusPtr` (floatSize * stride * numSubElements * lay)) + +bindShader :: MV.MVector (PrimState IO) FullShader -> UMV.MVector (PrimState IO) Int -> IO () +bindShader shads counts = MV.imapM_ f shads + where + f i shad = UMV.read counts i >>= flip bindArrayBuffers (_vaoVBO . _shaderVAO $ shad) + +bindShaderBuffers :: [FullShader] -> [Int] -> IO () +bindShaderBuffers = zipWithM_ f + where + f fs i = bindArrayBuffers i $ _vaoVBO $ _shaderVAO fs diff --git a/src/Shader/Poke.hs b/src/Shader/Poke.hs index 1ed2ffa02..103839e81 100644 --- a/src/Shader/Poke.hs +++ b/src/Shader/Poke.hs @@ -13,14 +13,7 @@ import Shader.Parameters import Picture.Data import Geometry.Data ---import qualified Streaming.Prelude as SP ---import Data.Maybe ---import Data.List import Foreign ---import Control.Monad ---import qualified Control.Foldl as F ---import qualified Data.IntMap.Strict as IM ---import Control.Lens import qualified Data.Vector.Unboxed.Mutable as UMV import qualified Data.Vector.Mutable as MV import qualified Data.Vector.Fusion.Stream.Monadic as VS @@ -44,37 +37,40 @@ pokeVerx vbos offsets Verx{_vxPos=thePos,_vxCol=theCol,_vxExt=ext,_vxShadNum=the where sn = _unShadNum theShadNum ---vToPicShad :: UMV.MVector (PrimState IO) Int -> IO (PicShads Int) ---{-# INLINE vToPicShad #-} ---vToPicShad mv = mapM (UMV.unsafeRead mv) $ PicShads 0 1 2 3 4 5 --- ---vToPicShadMV :: MV.MVector (PrimState IO) Int -> IO (PicShads Int) ---{-# INLINE vToPicShadMV #-} ---vToPicShadMV mv = mapM (MV.unsafeRead mv) $ PicShads 0 1 2 3 4 5 --- ---picShadToUMV :: PicShads Int -> IO (UMV.MVector (PrimState IO) Int) ---{-# INLINE picShadToUMV #-} ---picShadToUMV (PicShads a b c d e f) = do --- theVec <- UMV.new 6 --- UMV.write theVec 0 a --- UMV.write theVec 1 b --- UMV.write theVec 2 c --- UMV.write theVec 3 d --- UMV.write theVec 4 e --- UMV.write theVec 5 f --- return theVec --- ---picShadToMV :: PicShads a -> IO (MV.MVector (PrimState IO) a) ---{-# INLINE picShadToMV #-} ---picShadToMV (PicShads a b c d e f) = do --- theVec <- MV.new 6 --- MV.write theVec 0 a --- MV.write theVec 1 b --- MV.write theVec 2 c --- MV.write theVec 3 d --- MV.write theVec 4 e --- MV.write theVec 5 f --- return theVec +pokeLayVerxs + :: MV.MVector (PrimState IO) FullShader + -> UMV.MVector (PrimState IO) Int + -> [Verx] + -> IO () +pokeLayVerxs vbos counts vxs = VS.mapM_ (pokeLayVerx vbos counts) $ VS.fromList vxs + +pokeLayVerx :: MV.MVector (PrimState IO) FullShader -> UMV.MVector (PrimState IO) Int -> Verx -> IO () +--{-# INLINE pokeLayVerx #-} +pokeLayVerx vbos counts vx = do + theOff <- UMV.unsafeRead counts vecPos + basePtr <- _vboPtr . _vaoVBO . _shaderVAO <$> MV.unsafeRead vbos sn + let thePtr = plusPtr basePtr ((theOff + layOff) * theStride * floatSize) + poke34 thePtr thePos theCol + pokeArrayOff thePtr 7 (_vxExt vx) + UMV.unsafeModify counts (+ 1) vecPos + where + sn = _unShadNum (_vxShadNum vx) + vecPos = theLayer * 6 + sn + theLayer = _vxLayer vx + thePos = _vxPos vx + theCol = _vxCol vx + layOff = theLayer * numSubElements + theStride = pokeStride sn + +pokeStride :: Int -> Int +{-# INLINE pokeStride #-} +pokeStride 0 = 7 +pokeStride 1 = 8 +pokeStride 2 = 11 +pokeStride 3 = 9 +pokeStride 4 = 10 +pokeStride 5 = 7 +pokeStride _ = undefined poke34 :: Ptr Float -> Point3 -> Point4 -> IO () @@ -119,41 +115,6 @@ pokePoint3s ptr vals0 = go vals0 0 where off i = n*3 + i -pokeLayVerxs - :: MV.MVector (PrimState IO) FullShader - -> UMV.MVector (PrimState IO) Int - -> [Verx] - -> IO () -pokeLayVerxs vbos counts vxs = VS.mapM_ (pokeLayVerx vbos counts) $ VS.fromList vxs - -pokeLayVerx :: MV.MVector (PrimState IO) FullShader -> UMV.MVector (PrimState IO) Int -> Verx -> IO () ---{-# INLINE pokeLayVerx #-} -pokeLayVerx vbos counts vx = do - theOff <- UMV.unsafeRead counts vecPos - basePtr <- _vboPtr . _vaoVBO . _shaderVAO <$> MV.unsafeRead vbos sn - let thePtr = plusPtr basePtr ((theOff + layOff) * theStride * floatSize) - poke34 thePtr thePos theCol - pokeArrayOff thePtr 7 (_vxExt vx) - UMV.unsafeModify counts (+ 1) vecPos - where - sn = _unShadNum (_vxShadNum vx) - vecPos = theLayer * 6 + sn - theLayer = _vxLayer vx - thePos = _vxPos vx - theCol = _vxCol vx - layOff = theLayer * numSubElements - theStride = pokeStride sn - -pokeStride :: Int -> Int -{-# INLINE pokeStride #-} -pokeStride 0 = 7 -pokeStride 1 = 8 -pokeStride 2 = 11 -pokeStride 3 = 9 -pokeStride 4 = 10 -pokeStride 5 = 7 -pokeStride _ = undefined - poke224s :: Ptr Float -> [((Point2,Point2),Point4)] -> IO Int poke224s ptr vals0 = go vals0 0 where