Add new files

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 

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

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

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, (<|) , (|>))
-
+{- | All: Depth first search of trees of rooms, produces a list of lists of rooms that are not clipping.  -}
-{- |
-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.
- -}
 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)

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

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

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

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

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) 
+polysIntersect (a:b:xs) ps = go a (a:b:xs) ps
-    = any isJust $ (\(a,b) (c,d) -> myIntersectSegSeg a b c d) <$> pairs1 <*> pairs2
   where
-    pairs1 = zip (p:ps) (ps++[p])
+    go x' (a':b':xs') ps' = pairPolyIntersect a' b' ps' || go x' (b':xs') ps'
-    pairs2 = zip (q:qs) (qs++[q])
+    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) 
+polysOverlap (p:ps) (q:qs) = pointInPolygon p (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

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

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

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

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)

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
+        }
+

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

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)
+

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)

src/Render.hs

@@ -1,32 +1,20 @@
---{-# LANGUAGE TupleSections #-}
 module Render
     where
 import Shader
 import Shader.Data
-import Shader.Poke
+--import Shader.Poke
---import MatrixHelper
 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
+    -- clear buffer to full alpha and furthest depth
--- clearColor is specified in preloadRender
+    -- 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 

src/Shader.hs

@@ -1,91 +1,28 @@
 module Shader
-    ( bindShaderLayers
+    ( freeShaderPointers
-    , bindShaderBuffers
-    , bindShader
-    , drawShader
-    , freeShaderPointers
     , drawShaderLay
-    , drawShaderLay'
     , shadVBOptr
+    , drawShader
+    , pokeBindFoldable
+    , pokeBindFoldableLayer
     ) where
---import Geometry.Data
 import Shader.Data
 import Shader.Parameters
 import Shader.ExtraPrimitive
---import Shader.Poke
+import Shader.Poke
---import Layers
+import Shader.Bind
---import MatrixHelper
+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 ()
+drawShaderLay :: Int -> UMV.MVector (PrimState IO) Int -> Int -> FullShader -> 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 ()
 {-# INLINE drawShaderLay #-}
-drawShaderLay l fs i = do 
+drawShaderLay l countsVector shadIn fs = 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 
     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

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

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)
+pokeLayVerxs 
---{-# INLINE vToPicShad #-}
+    :: MV.MVector (PrimState IO) FullShader 
---vToPicShad mv = mapM (UMV.unsafeRead mv) $ PicShads 0 1 2 3 4 5
+    -> UMV.MVector (PrimState IO) Int
---
+    -> [Verx] 
---vToPicShadMV :: MV.MVector (PrimState IO) Int -> IO (PicShads Int)
+    -> IO ()
---{-# INLINE vToPicShadMV #-}
+pokeLayVerxs vbos counts vxs = VS.mapM_ (pokeLayVerx vbos counts) $ VS.fromList vxs
---vToPicShadMV mv = mapM (MV.unsafeRead mv) $ PicShads 0 1 2 3 4 5
+
---
+pokeLayVerx :: MV.MVector (PrimState IO) FullShader -> UMV.MVector (PrimState IO) Int -> Verx -> IO ()
---picShadToUMV :: PicShads Int -> IO (UMV.MVector (PrimState IO) Int)
+--{-# INLINE pokeLayVerx #-}
---{-# INLINE picShadToUMV #-}
+pokeLayVerx vbos counts vx = do
---picShadToUMV (PicShads a b c d e f) = do
+    theOff <- UMV.unsafeRead counts vecPos
---    theVec <- UMV.new 6
+    basePtr <- _vboPtr . _vaoVBO . _shaderVAO <$> MV.unsafeRead vbos sn
---    UMV.write theVec 0 a
+    let thePtr = plusPtr basePtr ((theOff + layOff) * theStride * floatSize)
---    UMV.write theVec 1 b
+    poke34 thePtr thePos theCol
---    UMV.write theVec 2 c
+    pokeArrayOff thePtr 7 (_vxExt vx)
---    UMV.write theVec 3 d
+    UMV.unsafeModify counts (+ 1) vecPos
---    UMV.write theVec 4 e
+  where
---    UMV.write theVec 5 f
+    sn = _unShadNum (_vxShadNum vx)
---    return theVec
+    vecPos = theLayer * 6 + sn
---
+    theLayer = _vxLayer vx
---picShadToMV :: PicShads a -> IO (MV.MVector (PrimState IO) a)
+    thePos = _vxPos vx
---{-# INLINE picShadToMV #-}
+    theCol = _vxCol vx
---picShadToMV (PicShads a b c d e f) = do
+    layOff = theLayer * numSubElements
---    theVec <- MV.new 6
+    theStride = pokeStride sn
---    MV.write theVec 0 a
+
---    MV.write theVec 1 b
+pokeStride :: Int -> Int
---    MV.write theVec 2 c
+{-# INLINE pokeStride #-}
---    MV.write theVec 3 d
+pokeStride 0 = 7
---    MV.write theVec 4 e
+pokeStride 1 = 8
---    MV.write theVec 5 f
+pokeStride 2 = 11
---    return theVec
+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