Refactor level/room generation modules

app/Main.hs

@@ -14,6 +14,7 @@ import Dodge.Update
 import Dodge.KeyEvents
 import Dodge.Rendering
 import Dodge.Menu
+import Dodge.Floor
 
 import Picture
 import Picture.Render

src/Dodge/Critters.hs

@@ -365,6 +365,7 @@ startCr = basicCreature
                             ,latchkey 0
                             ,frontArmour
                             ,miniGun
+                            ,medkit 50
                             ] 
                             ++ repeat NoItem)) 
                           -- startInv

src/Dodge/Floor.hs

@@ -0,0 +1,92 @@
+module Dodge.Floor
+    ( lev1 
+    , generateLevel
+    )
+    where
+import Geometry
+import Picture
+
+import Dodge.Data
+import Dodge.Rooms
+import Dodge.Base
+import Dodge.Layout
+import Dodge.Critters
+import Dodge.SoundLogic
+import Dodge.RandomHelp
+import Dodge.LightSources
+
+import Data.Tree
+
+import Control.Lens
+import Control.Monad.State
+
+import Control.Monad.Loops
+
+import System.Random
+
+lev1 :: RandomGen g => State g (Tree Room)
+lev1 = do
+    firstWeapon <- takeOne $ [[branchRectWith weaponRoom,blockedCorridor]] ++ replicate 5 [weaponRoom]
+    iterateWhile boundClip $ fmap (shiftRoomTree . expandTreeBy id) 
+            $ sequence $ treePost 
+            (
+            [return $ return $ Right deadEndRoom
+            ]
+            ++ [return $ connectRoom corridor
+               ,return $ connectRoom door]
+            ++ firstWeapon
+            ++ [return $ connectRoom corridor
+               ,return $ connectRoom door]
+            ++ [randomiseLinks =<< pistolerRoom]
+            ++ [return $ connectRoom door]
+             ++ [randomiseLinks =<< shooterRoom]
+             ++ (replicate 3 $ randomiseLinks corridor)
+            ++ [return $ connectRoom (set rmPS [PS (20,40) 0 basicLS] corridor)]
+            ++ [return $ connectRoom corridor]
+             ++ (replicate 3 $ randomiseLinks corridor)
+            ++ [return $ connectRoom corridor]
+            ++[return $ connectRoom corridor,return $ connectRoom door]
+            ++ [shootingRange]
+               ++ (replicate 3 $ randomiseLinks corridor)
+              ++[roomMiniIntro]
+               ++ (replicate 3 $ randomiseLinks corridor)
+              ++ [return $ connectRoom corridor
+                 ,return $ connectRoom door
+                 ,slowDoorRoom]
+            ++ [return $ connectRoom corridor
+               ,spawnerRoom
+               ,return $ connectRoom corridor
+               ]
+            )
+            $ randomiseLinks corridor
+
+roomToLevel2 :: RandomGen g => State g (Tree (Either Room Room))
+roomToLevel2 = join $ takeOne
+    [ portalRoom1
+    ]
+
+portalRoom1 :: RandomGen g => State g (Tree (Either Room Room))
+portalRoom1 = return $ connectRoom $ (roomRect 300 300) { _rmPS = plmnts}
+    where plmnts = [PS (0,0) (0-pi/2) $ PutPressPlate (levelPortalAt (200,120) 1)
+                   ,PS (60,100) pi $ PutCrit autoCrit
+                   ]
+
+generateLevel :: Int -> World -> World
+generateLevel i w = 
+    do haltSound $ ((generateFromTree $ levelTree i) w)
+
+levelTree :: Int -> State StdGen (Tree Room)
+levelTree 1 = lev1
+
+levelPortalAt :: Point2 -> Int -> PressPlate
+levelPortalAt p x 
+    = PressPlate
+        { _ppPict = onLayer PressPlateLayer $ color blue $ circle 10
+        , _ppPos = p
+        , _ppRot = 0
+        , _ppEvent = \pp w -> if dist (_crPos (you w)) (_ppPos pp) < 10
+                                then generateLevel x w
+                                else w
+        , _ppID = -1
+        , _ppText = "Portal to level "++ show x
+        }

src/Dodge/Layout.hs

@@ -1,23 +1,20 @@
-module Dodge.Layout where
+module Dodge.Layout 
+    ( module Dodge.Layout
+    , module Dodge.Layout.Tree
+    )
+    where
 -- imports {{{
 import Dodge.Data
-import Dodge.Weapons
-import Dodge.Critters
 import Dodge.LevelGen
 import Dodge.Base
 import Dodge.RandomHelp
-import Dodge.Prototypes
 import Dodge.Path
+import Dodge.Layout.Tree
 
 import Geometry
---
+
---import Graphics.Gloss
---import Graphics.Gloss.Data.Vector
---import Graphics.Gloss.Geometry.Line
---import Graphics.Gloss.Geometry.Angle
---
 import Control.Monad.State
---import Control.Monad.Loops
+
 import Control.Lens
 import System.Random
 
@@ -35,11 +32,10 @@ import Data.Graph.Inductive.NodeMap
 
 import qualified Data.IntMap.Strict as IM
 -- }}}
-
+-- connects a collection (tree) of rooms together
 generateFromTree :: State StdGen (Tree Room) -> World -> World
 generateFromTree t w = zoning $ placeSpots plmnts 
             $ w {_walls = wallsFromTree tr, _randGen = g
---                           ,_loadedSounds = lSounds
                            ,_pathGraph = path
                            ,_pathGraph' = pairGraph
                            ,_pathPoints = foldr insertPoint IM.empty (labNodes path) 
@@ -47,7 +43,6 @@ generateFromTree t w = zoning $ placeSpots plmnts
     where tr = evalState t $ _randGen w
           plmnts = concatMap _rmPS $ flatten tr
           g = _randGen w
---          lSounds = _loadedSounds w
           path = pairsToGraph dist pairGraph
           pairGraph = makePath tr
           insertPoint  pp@(_,(x,y)) = insertInZoneWith (floorHun x) (floorHun y) (++) [pp]
@@ -66,8 +61,6 @@ makePath = concat . map _rmPath . flatten
 
 wallsFromTree :: Tree Room -> IM.IntMap Wall
 wallsFromTree t = createInnerWalls $ nubWalls $ divideWalls $ foldr cutWalls IM.empty (concatMap _rmPolys $ flatten t)
---wallsFromTree t = checkWalls $ nubWalls $ divideWalls $ foldr cutWalls IM.empty (concatMap _rmPolys $ flatten t)
---wallsFromTree t = divideWalls $ foldr cutWalls IM.empty (concatMap _rmPolys $ flatten t)
 
 divideWall :: Wall -> [Wall]
 divideWall wl
@@ -85,26 +78,11 @@ divideWallIn wl wls =
 
 divideWalls :: IM.IntMap Wall -> IM.IntMap Wall
 divideWalls wls = IM.foldr divideWallIn wls wls
-         
-collapseTree :: Tree (Tree (Either Room Room)) -> Tree (Either Room Room)
-collapseTree = g . expandTreeBy f
-    where f (Node (Right x) xs) = Node (Right (Right x)) $ map f xs
-          f (Node (Left x) xs) = Node (Left (Left x)) $ map f xs
-          g (Node (Right x) []) = Node (Right x) []
-          g (Node (Right x) xs) = Node (Left x) $ map g xs
-          g (Node y ys) = Node y $ map g ys
-
 
 insertInZone :: Int -> Int -> a -> IM.IntMap (IM.IntMap a) -> IM.IntMap (IM.IntMap a)
 insertInZone x y obj = IM.insertWith f x $ IM.singleton y obj
     where f _ = IM.insert y obj
 
-allPairs :: Eq a => [a] -> [(a,a)]
-allPairs xs = [(x,y) | x <- xs, y <- xs, x /= y]
-
-treePost :: [a] -> a -> Tree a
-treePost []     y = Node y []
-treePost (x:xs) y = Node x [treePost xs y]
 
 randomiseLinks :: RandomGen g => Room -> State g (Tree (Either Room Room))
 randomiseLinks r = do
@@ -135,16 +113,9 @@ composeTreeWith f (Node x xs) = paste xs $ f x
     where paste xs (Node (Right y) _) = Node (Left y) (map (composeTreeWith f) xs)
           paste xs (Node (Left y) ys) = Node (Left y) (map (paste xs) ys)
 
-doPolysIntersect :: [Point2] -> [Point2] -> Bool
+-- the old version of this used a version of polysIntersect with intersectSegSeg'
-doPolysIntersect (p:ps) (q:qs)
-    = any isJust $ (\(a,b) (c,d) -> intersectSegSeg' a b c d) <$> pair1s <*> pair2s
-    where pair1s = zip (p:ps) (ps++[p])
-          pair2s = zip (q:qs) (qs++[q])
-doPolysIntersect [] _  = False
-doPolysIntersect _  [] = False
-
 boundClip :: Tree Room -> Bool
-boundClip t = or $ map (uncurry doPolysIntersect) [(x,y) | x<- xs, y<-xs, x>y]
+boundClip t = or $ map (uncurry polysIntersect) [(x,y) | x<- xs, y<-xs, x>y]
                     ++ map f [(ps,qs) | ps <- xs, qs <-xs, ps/=qs]
     where xs = map _rmBound $ flatten t
           f ([],qs) = False
@@ -186,4 +157,3 @@ shiftPSBy (pos,rot) ps = case ps of
                             $ over psRot (+rot)
                             ps
 
-

src/Dodge/Layout/Tree.hs

@@ -0,0 +1,46 @@
+module Dodge.Layout.Tree
+    where
+import Data.Tree
+import Control.Monad.State
+import System.Random
+-- Left elements get new children, Right elements inherit the children from the
+-- mapped over node
+expandTreeBy :: (a -> Tree (Either b b)) -> Tree a -> Tree b
+expandTreeBy f (Node x []) = fmap removeEither (f x)
+    where removeEither (Left y)  = y
+          removeEither (Right y) = y
+expandTreeBy f (Node x xs) = appendAndRemove $ f x
+    where appendAndRemove (Node (Left y)  ys) = Node y (map appendAndRemove ys)
+          appendAndRemove (Node (Right y) _ ) = Node y (map (expandTreeBy f) xs)
+
+expandTreeRand :: RandomGen g => 
+        (a -> State g (Tree (Either b b))) -> Tree a -> State g (Tree b)
+expandTreeRand f (Node x []) = fmap (fmap removeEither) (f x)
+    where removeEither (Left y)  = y
+          removeEither (Right y) = y
+expandTreeRand f (Node x xs) = do
+    root <- f x
+    branches <- sequence $ map (expandTreeRand f) xs
+    return (appendAndRemove branches root)
+        where appendAndRemove :: [Tree a] -> Tree (Either a a) -> Tree a
+              appendAndRemove bran (Node (Left y) ys) = Node y (map (appendAndRemove bran) ys)
+              appendAndRemove bran (Node (Right y) _) = Node y bran
+
+collapseTree :: Tree (Tree (Either a a)) -> Tree (Either a a)
+collapseTree = g . expandTreeBy f
+    where f (Node (Right x) xs) = Node (Right (Right x)) $ map f xs
+          f (Node (Left x) xs) = Node (Left (Left x)) $ map f xs
+          g (Node (Right x) []) = Node (Right x) []
+          g (Node (Right x) xs) = Node (Left x) $ map g xs
+          g (Node y ys) = Node y $ map g ys
+
+treePost :: [a] -> a -> Tree a
+treePost []     y = Node y []
+treePost (x:xs) y = Node x [treePost xs y]
+
+treeTrunk :: [a] -> Tree a -> Tree a
+treeTrunk [] t     = t
+treeTrunk (x:xs) t = Node x [treeTrunk xs t]
+
+applyToRoot :: (a -> a) -> Tree a -> Tree a
+applyToRoot f (Node x xs) = Node (f x) xs

src/Dodge/LevelGen.hs

@@ -14,8 +14,6 @@ module Dodge.LevelGen
 
 import Dodge.Data
 import Dodge.Base
-import Dodge.SoundLogic
-import Dodge.Prototypes
 
 import Dodge.LevelGen.Block
 import Dodge.LevelGen.Pathing
@@ -29,7 +27,6 @@ import Picture
 
 import System.Random
 
-
 import Control.Monad.State
 import Data.List
 import Data.Function
@@ -40,16 +37,7 @@ import qualified Data.IntMap.Strict as IM
 import qualified Data.Set as S
 import qualified Data.Map as M
 
-import Data.Graph.Inductive hiding ((&))
+-- deals with placement of objects within the world
-import Data.Graph.Inductive.NodeMap
-import Data.Tree
-
-treeTrunk :: [a] -> Tree a -> Tree a
-treeTrunk [] t     = t
-treeTrunk (x:xs) t = Node x [treeTrunk xs t]
-
-applyToRoot :: (a -> a) -> Tree a -> Tree a
-applyToRoot f (Node x xs) = Node (f x) xs
 
 placeSpots :: [PlacementSpot] -> World -> World
 placeSpots pss w = foldr placeSpot w basicPlacements
@@ -101,7 +89,8 @@ placeSpot ps w = case ps of
 
     PS {_psPos = p, _psRot = rot, _psType = PutWindow { _pwPoly = ps, _pwColor = c }}
         -> rmCrossPaths $ over walls (addWindow (q:qs) c) w
-                where (q:qs) = translateS p $ rotateS rot ps
+--                where (q:qs) = translateS p $ rotateS rot ps
+                where (q:qs) = map (shiftPointBy (p,rot)) ps
                       rmCrossPaths w = foldr (uncurry removePathsCrossing) w $ zip (q:qs) (qs++[q])
 
     _   -> w
@@ -130,11 +119,6 @@ instance Shiftable PlacementSpot where
     translateS p' (PS p r x) = PS (p +.+ p') r x
     rotateS    r' (PS p r x) = PS (rotateV r' p) (r + r') x
 
-
-          
-
-
-
 putWindowBlock :: Point2 -> Point2 -> World -> World
 putWindowBlock a b w = removePathsCrossing a b $ foldr makeBlockAt w $ zip ps ns
     where d = dist a b
@@ -201,8 +185,6 @@ putWindowBlock a b w = removePathsCrossing a b $ foldr makeBlockAt w $ zip ps ns
                         }
                 f = IM.insert k0 l . IM.insert k1 t . IM.insert k2 r . IM.insert k3 b
             in  over walls f w
-                                    
-
 
 shiftPointBy (pos,rot) p = pos +.+ rotateV rot p
 
@@ -228,29 +210,6 @@ placeFlIt fi p rot w = over floorItems addFI w
 placePressPlate pp p rot w = over pressPlates addPP w
     where addPP pps = IM.insert (newKey pps) (pp {_ppPos = p,_ppRot = rot}) pps
 
--- Left elements get new children, Right elements inherit the children from the
--- mapped over node
-expandTreeBy :: (a -> Tree (Either b b)) -> Tree a -> Tree b
-expandTreeBy f (Node x []) = fmap removeEither (f x)
-    where removeEither (Left y)  = y
-          removeEither (Right y) = y
-expandTreeBy f (Node x xs) = appendAndRemove $ f x
-    where appendAndRemove (Node (Left y)  ys) = Node y (map appendAndRemove ys)
-          appendAndRemove (Node (Right y) _ ) = Node y (map (expandTreeBy f) xs)
-
-expandTreeRand :: RandomGen g => 
-        (a -> State g (Tree (Either b b))) -> Tree a -> State g (Tree b)
-expandTreeRand f (Node x []) = fmap (fmap removeEither) (f x)
-    where removeEither (Left y)  = y
-          removeEither (Right y) = y
-expandTreeRand f (Node x xs) = do
-    root <- f x
-    branches <- sequence $ map (expandTreeRand f) xs
-    return (appendAndRemove branches root)
-        where appendAndRemove :: [Tree a] -> Tree (Either a a) -> Tree a
-              appendAndRemove bran (Node (Left y) ys) = Node y (map (appendAndRemove bran) ys)
-              appendAndRemove bran (Node (Right y) _) = Node y bran
-
 placeCr :: Creature -> Point2 -> Float -> World -> World
 placeCr crF p rot w = over creatures addCr w
     where addCr crs = IM.insert (newKey crs) 

src/Dodge/Menu.hs

@@ -2,6 +2,7 @@ module Dodge.Menu where
 -- imports {{{
 import Dodge.Data
 import Dodge.Rooms
+import Dodge.Floor
 import Dodge.Initialisation
 import Dodge.SoundLogic
 

src/Dodge/RandomHelp.hs

@@ -23,6 +23,7 @@ takeOneWeighted ws xs = state (randomR (0, sum ws))
           i y _ = 0
 
 takeOneMore :: RandomGen g => ([a],[a]) -> State g ([a],[a])
+takeOneMore (xs,[]) = error "trying to takeOneMore from empty list"
 takeOneMore (xs,ys) = do
     i <- state $ randomR (0,length ys - 1)
     let (zs, w:ws) = splitAt i ys

src/Dodge/Rooms.hs

@@ -36,78 +36,7 @@ import Data.Graph.Inductive.NodeMap
 
 import qualified Data.IntMap.Strict as IM
 -- }}}
-
+-- definition of individual rooms
-
-
-lev1 :: RandomGen g => State g (Tree Room)
-lev1 = do
-    firstWeapon <- takeOne $ [[branchRectWith weaponRoom,blockedCorridor]] ++ replicate 5 [weaponRoom]
-    iterateWhile boundClip $ fmap (shiftRoomTree . expandTreeBy id) 
-            $ sequence $ treePost 
-            (
---            [randomiseLinks =<< pistolerRoom] 
-            [return $ return $ Right deadEndRoom
-            ]
-            ++ [slowDoorRoom]
-            ++ [return $ connectRoom corridor
-               ,return $ connectRoom door]
---            ++ [randomiseLinks =<< longRoom]
-            ++ [randomiseLinks =<< pistolerRoom]
---            ++ [randomiseLinks =<< shooterRoom]
-            ++ [return $ connectRoom door]
- --           ++ [return $ connectRoom $ set rmPS [PS (100,100) 0 $ PutCrit explosiveBarrel 
- --                                               ,PS (105,110) 0 $ PutCrit explosiveBarrel
- --                                               ,PS (115,110) 0 $ PutCrit autoCrit
- --                                               ,PS (135,110) 0 $ PutCrit explosiveBarrel
- --                                               ,PS (105,140) 0 $ PutCrit explosiveBarrel
- --                                               ]
- --                                    $ roomRect 300 300]
-             ++ [randomiseLinks =<< shooterRoom]
-             ++ (replicate 3 $ randomiseLinks corridor)
-            ++ [return $ connectRoom (set rmPS [PS (20,40) 0 basicLS] corridor)]
---            ++ [randomiseLinks =<< longRoom]
-            ++ [return $ connectRoom corridor]
-            ++ firstWeapon
-             ++ (replicate 3 $ randomiseLinks corridor)
-            ++ [return $ connectRoom corridor]
-            ++[return $ connectRoom corridor,return $ connectRoom door]
-            ++ [shootingRange]
-               ++ (replicate 3 $ randomiseLinks corridor)
-              ++[roomMiniIntro]
-               ++ (replicate 3 $ randomiseLinks corridor)
-              ++ [return $ connectRoom corridor
-                 ,return $ connectRoom door
-                 ,slowDoorRoom]
-            ++ [return $ connectRoom corridor
-               ,spawnerRoom
-               ,return $ connectRoom corridor
-               ]
-            )
-            $ randomiseLinks corridor
-
-
-
-
-generateLevel :: Int -> World -> World
-generateLevel i w = 
-    do haltSound $ ((generateFromTree $ levelTree i) w)
-
-levelTree :: Int -> State StdGen (Tree Room)
-levelTree 1 = lev1
-
-levelPortalAt :: Point2 -> Int -> PressPlate
-levelPortalAt p x 
-    = PressPlate
-        { _ppPict = onLayer PressPlateLayer $ color blue $ circle 10
-        , _ppPos = p
-        , _ppRot = 0
-        , _ppEvent = \pp w -> if dist (_crPos (you w)) (_ppPos pp) < 10
-                                then generateLevel x w
-                                else w
-        , _ppID = -1
-        , _ppText = "Portal to level "++ show x
-        }
-
 airlockOneWay :: Int -> Room
 airlockOneWay n = Room
     { _rmPolys = [rectNSWE 90 0 0 40]
@@ -497,6 +426,8 @@ roomOctogon = Room
                  ,((-35,55),3*pi/4)
                  ,( (0,40),pi)
                  ]
+allPairs :: Eq a => [a] -> [(a,a)]
+allPairs xs = [(x,y) | x <- xs, y <- xs, x /= y]
 
 randomCorridorFrom :: RandomGen g => [a] -> State g (Tree (Either a a))
 randomCorridorFrom xs = do
@@ -504,13 +435,6 @@ randomCorridorFrom xs = do
     return $ treeTrunk (map Left $ init rooms) (Node (Right (last rooms)) [])
 
 
-
---splitWall :: Float -> Wall -> [[Point]]
---splitWall x wl = 
-
-sWalls g = wallsFromTree $ evalState (iterateWhile boundClip lev1) $ g
-
-
 randFirstWeapon :: State StdGen PSType
 randFirstWeapon = do
     r <- state $ randomR (-pi,pi)
@@ -599,22 +523,6 @@ blockedCorridor = do
     sequence $ treePost (replicate n $ fmap Left $ randLinks corridor) 
                         $ fmap Right $ return $ set rmPS plmnts corridor
 
--- weaponBehindV :: RandomGen g => State g (Tree (Either Room Room))
--- weaponBehindV = do
---       wpPos <- takeOne [(x,y) | x <- [70,-70], y <- [90,230]]
---       (ps,_) <- takeNMore 2 ([], [(x,y) | x <- [60,-60], y <- [100,220]])
---       r <- state $ randomR (0,pi)
---       let crPos1 = ps !! 0 
---       let crPos2 = ps !! 1
---       let d p = argV $ (0,160) -.- p
---       let plmnts = [PS wpPos 0 $ RandPS randFirstWeapon
---                    ,PS crPos1 (d crPos1) $ randC1
---                    ,PS crPos2 (d crPos2) $ randC1
---                    ,PS (0,295) r $ PutBlock [5,5,5] (makeColorI 150 75 0 250) 
---                                             $ reverse $ rectNSWE 10 (-10) (-10) 10
---                    ]
---       return $ connectRoom $ set rmPS plmnts $ roomVs
-
 weaponLongCorridor :: RandomGen g => State g (Tree (Either Room Room))
 weaponLongCorridor = do
     root <- takeOne $ [tEast, tWest]
@@ -662,28 +570,6 @@ roomCCrits = do
                        $ zipWith (+.+) [(x,y) | x<-[110,130,150,170,190], y<- [70,90,110,130,150]] ps
     return $ connectRoom $ over rmPS (++plmnts) $ roomC 200 200
 
--- 
--- roomSwarm :: RandomGen g => State g (Tree (Either Room Room))
--- roomSwarm = do
---     ps <- sequence $ replicate 25 $ randInCirc 200
---     let plmnts = map (\p -> PS ((500,500) +.+ p) 0 $ PutCrit swarmCrit) ps
---     return $ connectRoom $ set rmPS plmnts $ roomRect 1000 1000
---     
-
-
-roomToLevel2 :: RandomGen g => State g (Tree (Either Room Room))
-roomToLevel2 = join $ takeOne
-    [ portalRoom1
-    ]
-
-portalRoom1 :: RandomGen g => State g (Tree (Either Room Room))
-portalRoom1 = return $ connectRoom $ (roomRect 300 300) { _rmPS = plmnts}
-    where plmnts = [PS (0,0) (0-pi/2) $ PutPressPlate (levelPortalAt (200,120) 1)
-                   ,PS (60,100) pi $ PutCrit autoCrit
-                   ]
-
-
-
 branchRectWith :: RandomGen g => State g (Tree (Either Room Room)) ->  State g (Tree (Either Room Room))
 branchRectWith t = do
     x <- state $ randomR (100,200)
@@ -838,7 +724,7 @@ pistolerRoom = do
     f <- takeOne [f2]
     h <- state $ randomR (400,800)
     let w = h
-    i <- takeOne [2,4,6,8]
+    i <- takeOne [4,6,8]
     let j = fromIntegral (i+1)
     -- the 20+etc here is to correct for the pathfinding grid, which matches up to
     -- edges based on the size of doors (i.e. the line next to the wall is 20
@@ -887,7 +773,6 @@ shootingRange = do
                       ,Left $ roomPadCut (rectNSWE 20 (-20) (-80) 80) (0,20)
                       ] 
                       (Right rm3)
-    
 
 spawnerRoom :: RandomGen g => State g (Tree (Either Room Room))
 spawnerRoom = do

src/Dodge/TransparencyEffects.hs

@@ -0,0 +1,4 @@
+module Dodge.TransparencyEffects
+    where
+
+

src/Dodge/Weapons.hs

@@ -18,9 +18,6 @@ import Data.List
 import Data.Char
 import Data.Maybe
 import Data.Function
---import Data.Graph.Inductive.Graph
---import Data.Graph.Inductive.PatriciaTree
---import Codec.BMP
 import qualified Data.ByteString as B
 import Control.Lens
 import Control.Applicative
@@ -2020,11 +2017,6 @@ drawWeapon p cr posInInv
     | _crInvSel cr == posInInv = onLayer PtLayer drawnWep
     | otherwise                = blank
         where drawnWep = uncurry translate (_crRad cr,0) p
---drawWeapon :: Picture -> Creature -> Int -> Maybe (Picture, [Int])
---drawWeapon p cr posInInv 
---    | _crInvSel cr == posInInv = Just (drawnWep, [levLayer PtLayer])
---    | otherwise                = Nothing
---        where drawnWep = uncurry translate (_crRad cr,0) p
 
 medkit :: Int -> Item
 medkit i = basicConsumable
@@ -2157,110 +2149,6 @@ crOrWall p dir w = fromMaybe (E3x3 $ p +.+ rotateV dir (arcLen,0))
           g (E3x1 cr1) = dist p $ _crPos cr1
           (arcLen,_) = randomR (25,50) $ _randGen w
 
--- grapFire :: Int -> World -> World
--- grapFire n w | fireCondition = set (creatures . ix n . crInv . ix itRef . wpFireState)
---                                    (_wpFireRate (_crInv cr IM.! itRef))
---                                   $ over (creatures . ix n . crInv . ix itRef . wpLoadedAmmo)
---                                       (\x -> x - 1)
---                                   $ set randGen g 
---                                   $ over particles (IM.insert i (makeGrapFrom i n pos dir)) w
---              | reloadCondition = let  remAmmo = _crAmmo cr M.! _wpAmmoType item
---                                       (newA,newTotalA) = moveInt (_wpMaxAmmo item) remAmmo
---                                  in   set (pointerToItem . wpReloadState) rTime 
---                                           $ set (pointerToItem . wpLoadedAmmo) newA
---                                           $ over (creatures . ix n . crAmmo ) 
---                                                 (M.insert (_wpAmmoType item) newTotalA) w
---              | emptyCondition = soundOnce 1 w
---              | otherwise = w
---     where i = newParticleKey w
---           cr  = (_creatures w IM.! n)
---           pos = _crPos cr +.+ ((_crRad cr +1) *.* unitVectorAtAngle dir)
---           dir = _crDir cr -- + a
---           (a,g) = randomR (-0.2,0.2::Float) (_randGen w)
---           itRef = _crInvSel cr
---           item = _crInv cr IM.! itRef
---           pointerToItem = creatures . ix n . crInv . ix itRef
---           rTime = _wpReloadTime (_crInv cr IM.! itRef)
---           fireCondition = _wpReloadState (_crInv cr IM.! itRef) == 0
---                             && _wpFireState (_crInv cr IM.! itRef) == 0
---                             && _wpLoadedAmmo (_crInv cr IM.! itRef) > 0
---           reloadCondition = _wpReloadState (_crInv cr IM.! itRef) == 0
---                             && _wpLoadedAmmo (_crInv cr IM.! itRef) == 0
---                             && someJust (_crAmmo cr M.!? PistolBullet)
---           emptyCondition = _wpLoadedAmmo (_crInv cr IM.! itRef) == 0
--- 
--- makeGrapFrom :: Int -> Int -> Point -> Float -> Particle
--- makeGrapFrom i ci pos dir = Particle
---     { _ptPos = pos
---     , _ptStartPos = pos
---     , _ptVel = rotateV dir (10,0)
---     , _ptPict = Line [(0,0)]
---     , _ptID = i
---     , _ptUpdate = moveGrap 50 [pos] ci i
---     }
--- 
--- moveGrap :: Int -> [Point] -> Int -> Int -> World -> World
--- moveGrap x ls ci i w -- 
---     | x < 0 || lineCollide = windGrap' (zipWith (-.-) ls ls5) ci i w
---     | otherwise = case tHit of
---         Just (Left (p,crID)) -> set (particles . ix i . ptUpdate) (windGrap'' i crID ci 
---                                                                     (_crPos (_creatures w IM.! crID))
---                                                                    sCrP)
---                                     w
---         Just (Right (p,sv)) -> set (particles . ix i . ptUpdate) 
---                                    (windGrap sCrP (zipWith (-.-) ls ls5 ++[p]) ci i)
---                         w
---         _ -> set (particles . ix i . ptUpdate) (moveGrap (x-1) ls1 ci i)
---                                   $ set (particles . ix i. ptPos) pNewPos
---                                   $ set (particles . ix i. ptPict) pic
---                                     w
---         where sCr   = _creatures w IM.! ci
---               sCrP  = _crPos sCr
---               pic = thickLine ls1
---               pOldPos = _ptPos (_particles w IM.! i)
---               vel  = _ptVel (_particles w IM.! i)
---               ls1  = zipWith (+.+) ls2 $ zipWith f [1,1-step..] ls ++ [pNewPos]
---               step = 1/ (51 - fromIntegral x)
---               f y p = p +.+ (y) *.* crMv
---               pNewPos = pOldPos +.+ vel
---               crMv = sCrP -.- _crOldPos sCr
---               ls3 = (:) (0,0) $ drop x $ take 48 $ cycle $ 
---                             [lineWidth *.* vNormal vel
---                             ,(0,0)
---                             ,(-lineWidth) *.* vNormal vel
---                             ,(-lineWidth) *.* vNormal vel
---                             ,(0,0)
---                             ,lineWidth *.* vNormal vel 
---                             ]
---               lineWidth = 1
---               lineWidth2 = 0.5
---               ls2 = ls3 ++ repeat (0,0)
---               ls5 = (:) (0,0) $ drop (x+z) $ take (48+z) $ cycle $ 
---                             [lineWidth *.* vNormal vel
---                             ,(0,0)
---                             ,(-lineWidth) *.* vNormal vel
---                             ,(-lineWidth) *.* vNormal vel
---                             ,(0,0)
---                             ,lineWidth *.* vNormal vel 
---                             ]
---                 where z = 2
---               ls6 = (:) (0,0) $ drop (x+z) $ take (48+z) $ cycle $ 
---                             [lineWidth2 *.* vNormal vel
---                             ,(0,0)
---                             ,(-lineWidth2) *.* vNormal vel
---                             ,(-lineWidth2) *.* vNormal vel
---                             ,(0,0)
---                             ,lineWidth2 *.* vNormal vel 
---                             ]
---                 where z = 2
---               hitCr   = collidePointCrsPoint pOldPos pNewPos w
---               hitWl   = collidePointWalls pOldPos pNewPos $ wallsNearPoint pNewPos w
---               tHit    = thingHit' pOldPos hitCr hitWl
---               lineCollide = foldr (||) False $ zipWith 
---                                                 (\a b -> isJust $ collidePointWalls a b 
---                                                                 $ wallsNearPoint b w)
---                                                  ls (tail ls)
-
 thingHit' :: Point2 -> Maybe (Point2,a) -> Maybe (Point2,c) -> Maybe (Either (Point2,a) (Point2,c))
 thingHit' p Nothing Nothing = Nothing
 thingHit' p (Just x) Nothing = Just (Left x)
@@ -2269,74 +2157,10 @@ thingHit' p (Just x@(p1,_)) (Just y@(p2,_))
     | magV (p -.- p1) > magV (p -.- p2) = Just (Right y)
     | otherwise = Just (Left x)
 
--- windGrap :: Point -> [Point] -> Int -> Int -> World -> World
--- windGrap cp (x:y:xs) ci i w
---     | dist (_crPos cr) cp < 5
---         = set (particles . ix i . ptUpdate) (windGrap cNewPos (y:xs) ci i)
---             $ set (particles . ix i . ptPict) (thickLine (y:xs))
---             $ set (creatures . ix ci . crPos) cNewPos
---               w
---     | otherwise = windGrap' (x:y:xs) ci i w
---     where cr = _creatures w IM.! ci
---           cNewPos = y -.- d
---           d  = _crRad cr *.* errorNormalizeV 31 (y -.- x)
--- windGrap _ _ _ i w
---     = over particles (IM.delete i) w
--- 
--- windGrap' :: [Point] -> Int -> Int -> World -> World
--- windGrap' (x:[]) _ i w
---     = over particles (IM.delete i) w
--- windGrap' (x:xs) ci i w
---     = set (particles . ix i . ptUpdate) (windGrap' ys ci i)
---       $ set (particles . ix i . ptPict) (thickLine ys)
---         w
---     where ys = init $ zipWith f [1,1-step..] (x:xs)
---           crMv = sCrP -.- _crOldPos sCr
---           sCr   = _creatures w IM.! ci
---           sCrP  = _crPos sCr
---           f y p = p +.+ (y) *.* crMv
---           step = 1/ (fromIntegral (length xs) + 1)
--- 
--- windGrap'' :: Int -> Int -> Int -> Point -> Point -> World -> World
--- windGrap'' pti ci1 ci2 p1 p2 w
---     | dist cp1 cp2 < r1 + r2 + 1
---         = over particles (IM.delete pti) w
---     | dist cp1 p1 > 5 || dist cp2 p2 > 5
---         = over particles (IM.delete pti) w
---     | otherwise
---         = set (creatures . ix ci1 . crPos) cpn1
---           $ set (creatures . ix ci2 . crPos) cpn2
---           $ set (particles . ix pti . ptPict) (thickLine [ cp1, cp2])
---           $ set (particles . ix pti . ptUpdate) (windGrap'' pti ci1 ci2 cpn1 cpn2)
---           w
---     where cr1 = _creatures w IM.! ci1
---           cr2 = _creatures w IM.! ci2
---           cp1 = _crPos cr1
---           cp2 = _crPos cr2
---           r1  = _crRad cr1
---           r2  = _crRad cr2
---           m1  = _crMass cr1 
---           m2  = _crMass cr2
---           v   = errorNormalizeV 32 $ cp2 -.- cp1
---           v1  = 10 * m2 / (m1 + m2) *.* v
---           v2  = (-10 * m1 / (m1 + m2)) *.* v
---           cpn1 = cp1 +.+ v1
---           cpn2 = cp2 +.+ v2
-
 spreadGunSpread,autogunSpread :: Float
 spreadGunSpread = 0.5
 autogunSpread = 0.07
 
-medkit25,pipe,magShield :: Item
-medkit25 = basicConsumable
-    { _itIdentity = Medkit25
-    , _itName = "MEDKIT25"
-    , _itMaxStack = 3
-    , _itAmount = 2
-    , _cnEffect = heal25
-    , _itFloorPict = onLayer FlItLayer $ polygon [(-3,-3),(-3,3),(3,3),(3,-3)]
-    , _itEquipPict = \cr _ -> blank
-    }
 pipe = Craftable
     { _itIdentity = Generic
     , _itName = "PIPE"
@@ -2426,13 +2250,11 @@ latchkeyPic = color yellow $
 -- }}}
 
 heal25 :: Int -> World -> Maybe World
-heal25 n w | _crHP (_creatures w IM.! n) >= 200 = Nothing
+heal25 = heal 25
-           | otherwise = Just $ soundOnce healSound 
-                              $ over (creatures . ix n . crHP) ((\x-> min x 100). (+ 25) ) w
 heal :: Int -> Int -> World -> Maybe World
-heal hp n w | _crHP (_creatures w IM.! n) >= 1000 = Nothing
+heal hp n w | _crHP (_creatures w IM.! n) >= 10000 = Nothing
             | otherwise = Just $ soundOnce healSound 
-                               $ over (creatures . ix n . crHP) ((\x-> min x 1000). (+ hp) ) w
+                               $ over (creatures . ix n . crHP) ((\x-> min x 10000). (+ hp) ) w
 
 forceFieldFire :: Int -> World -> World
 forceFieldFire  cid w = w

src/Geometry.hs

@@ -328,6 +328,8 @@ 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 [] _ = False
+polysIntersect _ [] = False
 
 anyPolyssIntersect :: [[Point2]] -> [[Point2]] -> Bool
 anyPolyssIntersect x y = or $ polysIntersect <$> x <*> y

src/Picture/Preload.hs

@@ -6,13 +6,8 @@ module Picture.Preload
 import Picture.Data
 
 import Graphics.Rendering.OpenGL hiding (Point (..),translate,scale,imageHeight,imageWidth)
-import qualified Graphics.Rendering.OpenGL as GL
-
-import Codec.Picture
-import qualified Data.Vector.Storable as V
 
 import Control.Lens
---import Control.Monad
 
 import Foreign
 import Shader
@@ -20,12 +15,10 @@ import Shader
 import Geometry (Point2)
 
 data RenderData = RenderData
-    { _textures :: [TextureObject]
+    { _lightSourceShader :: FullShader (Float,Float,Float,Float)
-    , _lightSourceShader :: FullShader (Float,Float,Float,Float)
     , _wallShadowShader  :: FullShader (Point2,Point2,Point2,Point2)
     , _backgroundShader  :: FullShader (Point2,Point2,Point2,Point2)
     , _listShaders :: [FullShader RenderType]
-    , _backVAO :: VAO
     , _dummyVBO :: BufferObject
     , _dummyPtr :: Ptr Float
     }
@@ -87,26 +80,12 @@ preloadRender = do
     bindBuffer ArrayBuffer $= Just dummyvbo
     bufferData ArrayBuffer $= (fromIntegral floatSize, dummyptr, StaticDraw)
 
-    Right cmap' <- readImage "data/texture/smudgedDirt.png"
-    let dirt = convertRGBA8 cmap'
-    dirttex <- genObjectName
-    textureBinding Texture2D $= Just dirttex
-    let texData' = V.toList $ imageData dirt
-        wtex' = fromIntegral $ imageWidth  dirt
-        htex' = fromIntegral $ imageHeight dirt
-    withArray texData' $ \ptr -> do
-        texImage2D Texture2D NoProxy 0 RGBA8 (TextureSize2D wtex' htex') 0 
-                        (PixelData RGBA UnsignedByte ptr)
-    generateMipmap' Texture2D
-    textureFilter Texture2D $= ((Linear',Just Linear') , Nearest)
-
 -- input a list of (attribute location, attrib length) pairs
 -- these will have buffers and pointers created
     backgroundvao <- setupVAO [(0,4),(1,2)]
     
     return $ RenderData
-        { _textures = [dirttex,dirttex]
+        { _listShaders = [bslist,lslist,cslist,aslist,eslist]
-        , _listShaders = [bslist,lslist,cslist,aslist,eslist]
         , _dummyVBO = dummyvbo
         , _dummyPtr = dummyptr
         , _lightSourceShader = lsShad

src/Picture/Render.hs

@@ -1,7 +1,8 @@
 --{-# LANGUAGE Strict #-}
 {-# LANGUAGE DeriveFoldable, StandaloneDeriving #-}
 module Picture.Render
-    ( module Picture.Render
+    ( renderPicture'
+    , renderFoldable
     , picToLTree
     )
     where
@@ -13,45 +14,22 @@ import Control.Monad
 
 import qualified Control.Foldl as F
 
-import Data.Bifunctor
+import Picture.Preload
-
 import Picture.Data
 import Picture.Tree
 import Geometry
 
-import Picture.Preload
-
 import Foreign hiding (rotate)
 
 import Graphics.Rendering.OpenGL hiding (Line,translate,scale,imageHeight,imageWidth,Polygon,Color,T)
 
 import Data.Foldable
-import Data.List
 import Data.Maybe (fromJust)
 
 import qualified Data.IntMap.Strict as IM
 
 import qualified SDL as SDL
 
-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
-    pokeElemOff ptr (4*n+2) z
-    pokeElemOff ptr (4*n+3) w
-
 renderPicture' :: RenderData -> Float -> Float -> (Float,Float) -> (Float,Float) ->
                     [(Point2,Point2,Point2,Point2)] -> [Point4] -> Picture -> IO (Word32,Word32)
 renderPicture' pdata rot zoom (tranx,trany) (winx,winy) wallPoints lightPoints pic = do
@@ -71,7 +49,6 @@ renderPicture' pdata rot zoom (tranx,trany) (winx,winy) wallPoints lightPoints p
         )
 
 -- draw lightmap
-
     nWalls <- F.foldM (pokeShader (_wallShadowShader pdata)) wallPoints
     bindShaderBuffers [_wallShadowShader pdata] [nWalls]
 
@@ -141,8 +118,7 @@ renderPicture' pdata rot zoom (tranx,trany) (winx,winy) wallPoints lightPoints p
     --return (ticksAfterL, ticks2 + ticks3 + ticks4)
     return (ticksAfterL, wallPokeEnd - wallPokeStart)
 
-bufferOffset :: Integral a => a -> Ptr b
+----------------end renderPicture'
-bufferOffset = plusPtr nullPtr . fromIntegral
 
 renderFoldable :: Foldable f => RenderData -> Float -> Float -> (Float,Float) -> (Float,Float)
                     -> f RenderType -> IO Word32
@@ -163,3 +139,23 @@ renderFoldable pdata rot zoom (tranx,trany) (winx,winy) tree = do
     
     pokeEndTicks <- SDL.ticks
     return $ pokeEndTicks - pokeStartTicks
+
+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
+    pokeElemOff ptr (4*n+2) z
+    pokeElemOff ptr (4*n+3) w
+

src/Preload.hs

@@ -0,0 +1,47 @@
+{-# LANGUAGE TemplateHaskell #-}
+module Preload
+    where
+import Picture.Preload
+import Sound.Preload
+import Control.Lens
+
+import GHC.Word (Word32)
+
+data PreloadData a = PreloadData
+    { _renderData :: RenderData
+    , _soundData :: SoundData a
+    , _currentTime :: Word32
+    , _renderTime :: Word32
+    , _renderLighting :: Word32
+    , _renderPicture :: Word32
+    , _simTime :: Word32
+    , _mixerTime :: Word32
+    , _idleTime :: Word32
+    , _gcTime :: Word32
+    , _pokeTime :: Word32
+    }
+
+makeLenses ''PreloadData
+
+doPreload :: IO (PreloadData a)
+doPreload = do
+    sData <- preloadSound
+    rData <- preloadRender
+    return $ PreloadData rData sData 0 0 0 0 0 0 0 0 0
+
+cleanUpPreload :: PreloadData a -> IO ()
+cleanUpPreload pd = do
+    cleanUpRenderPreload $ _renderData pd
+    cleanUpSoundPreload $ _soundData pd
+
+showTiming :: PreloadData a -> IO ()
+showTiming pd = do
+    putStrLn $ "Time rendering: " ++ show (_renderTime pd)
+    putStrLn $ "Time renderingLighting: " ++ show (_renderLighting pd)
+    putStrLn $ "Time renderingPicture: " ++ show (_renderPicture pd)
+    putStrLn $ "Time sim-ing: " ++ show (_simTime pd)
+    putStrLn $ "Time mixing: " ++ show (_mixerTime pd)
+    putStrLn $ "Time idle: " ++ show (_idleTime pd)
+    putStrLn $ "Time gc: " ++ show (_gcTime pd)
+    putStrLn $ "Time pokeing: " ++ show (_pokeTime pd)
+

src/Shader.hs

@@ -0,0 +1,279 @@
+{-# LANGUAGE QuasiQuotes #-}
+module Shader
+    ( makeShader
+    , makeTextureShader
+    , makeShaderCustomUnis
+    , pokeShaders
+    , pokeShader
+    , bindArrayBuffers
+    , bindShaderBuffers
+    , makeSourcedShader
+    , setupVAO
+    , floatSize
+    , numDrawableElements
+    , drawShader
+    , drawShaders
+    , setShaderUniforms
+    , resetShaderUniforms
+    , extractProgAndUnis 
+    , freeShaderPointers
+    , module Shader.Data
+    )
+    where
+import Shader.Data
+
+import Foreign
+import Codec.Picture
+
+import qualified Data.Vector.Storable as V
+
+import Control.Monad (when, forM, zipWithM_, forM_, foldM)
+
+import qualified Control.Foldl as F
+
+import Graphics.Rendering.OpenGL hiding (Point (..),translate,scale,imageHeight,imageWidth)
+--import Text.RawString.QQ
+import qualified Data.ByteString as BS
+
+import Linear.Matrix
+import Linear.V4
+
+import Geometry
+
+extractProgAndUnis :: FullShader a -> (Program,[UniformLocation])
+extractProgAndUnis s = (_shaderProgram s, _shaderUniforms s)
+
+pokeShaders :: [FullShader a] -> F.FoldM IO a [Int]
+pokeShaders fss = traverse pokeShader fss
+
+pokeShader :: FullShader a -> F.FoldM IO a Int
+pokeShader fs = F.FoldM (pokeRender fls (zip ptrs nAtss))  (return 0) return
+  where vao = _shaderVAO fs
+        (_,ptrs,nAtss) = unzip3 $ _vaoBufferTargets $ vao
+        fls = _shaderPokeStrategy fs
+
+pokeRender :: (a -> [[[Float]]])
+                -> [(Ptr Float,Int)] -> Int -> a -> IO Int
+pokeRender toFs ptrs n rt = pokeList ptrs n (toFs rt)
+
+pokeList :: [(Ptr Float,Int)] -> Int -> [[[Float]]] -> IO Int
+pokeList ptrs n fsss = foldM (pokePtrs ptrs) n fsss
+
+pokePtrs :: [(Ptr Float,Int)] -> Int -> [[Float]] -> IO Int
+pokePtrs ptrIs n fss = do
+    zipWithM_ f ptrIs fss
+    return $ n + 1
+        where f (ptr,i) fs = pokeArrayOff ptr (i*n) fs
+
+pokeArrayOff :: Storable a => Ptr a -> Int -> [a] -> IO ()
+pokeArrayOff ptr i xs =
+    zipWithM_ (pokeElemOff ptr) [i..] xs
+
+
+bindArrayBuffers :: Int -> [(BufferObject,Ptr Float,Int)] -> IO ()
+{-# INLINE bindArrayBuffers #-}
+bindArrayBuffers numVs ps = do
+    forM_ ps $ \(bo,ptr,i) -> do
+        bindBuffer ArrayBuffer $= Just bo
+        bufferData ArrayBuffer $= (fromIntegral $ floatSize * numVs * i, ptr, StreamDraw)
+
+bindShaderBuffers :: [FullShader a] -> [Int] -> IO ()
+bindShaderBuffers fss is =
+    zipWithM_ f fss is
+        where f fs i = bindArrayBuffers i $ _vaoBufferTargets $ _shaderVAO fs
+
+drawShaders :: [FullShader a] -> [Int] -> IO ()
+drawShaders fss is =
+    zipWithM_ drawShader fss is
+
+drawShader :: FullShader a -> Int -> IO ()
+{-# INLINE drawShader #-}
+drawShader fs i = do 
+    currentProgram $= Just (_shaderProgram fs)
+    bindVertexArrayObject $= (Just (_vao $ _shaderVAO fs))
+    case _shaderTexture fs of 
+        Just (ShaderTexture {_textureObject = to})
+            -> textureBinding Texture2D $= Just to
+        _   -> return ()
+    drawArrays (_shaderDrawPrimitive fs) 0 (fromIntegral i)
+
+makeTextureShader :: String -> [ShaderType] -> [(GLuint,Int)] 
+            -> PrimitiveMode -> (a -> [[[Float]]]) 
+            -> String
+            -> IO (FullShader a)
+makeTextureShader s shaderlist alocs pm renStrat texturePath = do
+    (prog,unis)  <- makeSourcedShader s shaderlist
+
+    Right cmap <- readImage texturePath
+    let tex = convertRGBA8 cmap
+    textureOb <- genObjectName
+    textureBinding Texture2D $= Just textureOb
+    let texData = V.toList $ imageData tex
+        wtex = fromIntegral $ imageWidth  tex
+        htex = fromIntegral $ imageHeight tex
+    withArray texData $ \ptr -> do
+        texImage2D Texture2D NoProxy 0 RGBA8 (TextureSize2D wtex htex) 0 
+                        (PixelData RGBA UnsignedByte ptr)
+    generateMipmap' Texture2D
+    textureFilter Texture2D $= ((Linear',Just Linear') , Nearest)
+
+    vao        <- setupVAO alocs
+
+    return $ FullShader { _shaderProgram = prog
+                        , _shaderUniforms = unis
+                        , _shaderVAO = vao
+                        , _shaderPokeStrategy = renStrat
+                        , _shaderDrawPrimitive = pm
+                        , _shaderTexture = Just $ ShaderTexture {_textureObject = textureOb}
+                        , _shaderCustomUnis = Nothing
+                        }
+
+makeShaderCustomUnis :: String -> [ShaderType] -> [(GLuint,Int)] -> PrimitiveMode -> (a -> [[[Float]]]) 
+                -> [String] -> IO (FullShader a)
+makeShaderCustomUnis s shaderlist alocs pm renStrat uniStrings = do
+    (prog,unis,unis')  <- makeSourcedShaderCustomUnis s shaderlist uniStrings
+    vao        <- setupVAO alocs
+    return $ FullShader { _shaderProgram = prog
+                        , _shaderUniforms = unis
+                        , _shaderVAO = vao
+                        , _shaderPokeStrategy = renStrat
+                        , _shaderDrawPrimitive = pm
+                        , _shaderTexture = Nothing
+                        , _shaderCustomUnis = Just unis'
+                        }
+
+makeShader :: String -> [ShaderType] -> [(GLuint,Int)] -> PrimitiveMode -> (a -> [[[Float]]]) -> IO (FullShader a)
+makeShader s shaderlist alocs pm renStrat = do
+    (prog,unis)  <- makeSourcedShader s shaderlist
+    vao        <- setupVAO alocs
+    return $ FullShader { _shaderProgram = prog
+                        , _shaderUniforms = unis
+                        , _shaderVAO = vao
+                        , _shaderPokeStrategy = renStrat
+                        , _shaderDrawPrimitive = pm
+                        , _shaderTexture = Nothing
+                        , _shaderCustomUnis = Nothing
+                        }
+
+floatSize = sizeOf (0.5 :: GLfloat)
+{-# INLINE floatSize #-}
+
+bufferOffset :: Integral a => a -> Ptr b
+bufferOffset = plusPtr nullPtr . fromIntegral
+
+numDrawableElements :: Int
+{-# INLINE numDrawableElements #-}
+numDrawableElements = 50000
+
+setupVAO :: [(GLuint,Int)] -> IO VAO
+setupVAO ps = do
+    theVAO <- genObjectName
+    bindVertexArrayObject $= Just theVAO
+    vbos <- forM ps setupArrayBuffer
+    ptrs <- forM (zip vbos $ map snd ps) setupVBOPointers
+    return $ VAO theVAO ptrs
+
+setupVBOPointers :: (BufferObject,Int) -> IO (BufferObject,Ptr Float,Int)
+setupVBOPointers (vbo,vsize) = do
+    thePtr <- mallocArray (vsize * numDrawableElements)
+    return (vbo,thePtr,vsize)
+
+setupArrayBuffer :: (GLuint,Int) -> IO BufferObject
+setupArrayBuffer (aloc,i) = do
+    vbo <- genObjectName
+    bindBuffer ArrayBuffer $= Just vbo
+    vertexAttribPointer (AttribLocation aloc) $=
+        ( ToFloat
+        , VertexArrayDescriptor (fromIntegral i) 
+                                Float 
+                                (fromIntegral $ floatSize * i) 
+                                (bufferOffset 0)
+        )
+    vertexAttribArray (AttribLocation aloc) $= Enabled
+    return vbo
+
+-- compile shader and get its uniform locations
+-- supposes the shader code is in the shader folder, with the string names
+-- followed by .vert/.geom/.frag
+makeSourcedShader :: String -> [ShaderType] -> IO (Program, [UniformLocation])
+makeSourcedShader s sts = do
+    sources <- forM sts $ \st -> BS.readFile ("shader/" ++ s ++ shaderTypeExt st)
+    prog <- makeShaderProgram s $ zip sts sources
+    uniformLocations <- forM ["winSize","zoom","rotation","translation","worldMat"]
+                    $ \uniString -> uniformLocation prog uniString
+    return (prog,uniformLocations)
+
+makeSourcedShaderCustomUnis :: String -> [ShaderType] -> [String] 
+                -> IO (Program, [UniformLocation], [UniformLocation])
+makeSourcedShaderCustomUnis s shadTypes uniStrings = do
+    (prog,unis0) <- makeSourcedShader s shadTypes
+    unis <- mapM (uniformLocation prog) uniStrings
+    return (prog,unis0,unis)
+
+shaderTypeExt :: ShaderType -> String
+shaderTypeExt VertexShader   = ".vert"
+shaderTypeExt GeometryShader = ".geom"
+shaderTypeExt FragmentShader = ".frag"
+
+makeShaderProgram :: String -> [(ShaderType,BS.ByteString)] -> IO Program
+makeShaderProgram str sources = do
+    shaderProgram <- createProgram
+    shaders <- mapM (compileAndCheckShader str) sources
+    mapM_ (attachShader shaderProgram) shaders
+
+    linkProgram shaderProgram
+    linkingSuccess <- linkStatus shaderProgram
+    when (not linkingSuccess) $ do
+        infoLog <- get (programInfoLog shaderProgram)
+        putStrLn $ str ++ ": Program Linking" ++ infoLog
+
+    return shaderProgram
+
+compileAndCheckShader :: String -> (ShaderType,BS.ByteString) -> IO Shader
+compileAndCheckShader str (shaderType,sourceCode) = do
+    theShader <- createShader shaderType
+    shaderSourceBS theShader $= sourceCode
+    compileShader theShader
+    success <- compileStatus theShader
+    when (not success) $ do
+        infoLog <- get (shaderInfoLog theShader)
+        putStrLn $ str ++ ": Shader compile: " ++ show shaderType ++ " : " ++ show infoLog
+    return theShader
+
+resetShaderUniforms = setShaderUniforms 0 1 (0,0) (2,2)
+{-# INLINE resetShaderUniforms #-}
+
+setShaderUniforms :: Float -> Float -> Point2 -> Point2 -> [(Program,[UniformLocation])] -> IO ()
+{-# INLINE setShaderUniforms #-}
+setShaderUniforms rot zoom (tranx,trany) (winx,winy) fss = do
+    let scalMat = Linear.Matrix.transpose $
+            V4 (V4 (2*zoom/winx) 0             0 (0::GLfloat))
+                (V4 0             (2*zoom/winy) 0 0)
+                (V4 0             0             1 0)
+                (V4 0             0             0 1)
+    let rotMat = Linear.Matrix.transpose $
+            V4 (V4 (cos rot) (sin (-rot)) 0 0)
+                (V4 (sin rot) (cos rot)    0 0)
+                (V4 0             0        1 0)
+                (V4 0             0        0 1)
+    let tranMat = Linear.Matrix.transpose $
+            V4 (V4 1        0        0 0)
+                (V4 0        1        0 0)
+                (V4 0        0        1 0)
+                (V4 (-tranx) (-trany) 0 1)
+    let wmat = scalMat !*! rotMat !*! tranMat
+        vToL (V4 a b c d) = [a,b,c,d]
+    wmata <- (newMatrix RowMajor $ concatMap vToL $ vToL wmat) :: IO (GLmatrix GLfloat)
+-- set common uniforms
+    forM_ fss $ \shad -> do
+        currentProgram $= Just (fst shad)
+        uniform (snd shad !! 0) $= Vector2 winx winy
+        uniform (snd shad !! 1) $= zoom
+        uniform (snd shad !! 2) $= rot
+        uniform (snd shad !! 3) $= Vector2 tranx trany
+        uniform (snd shad !! 4) $= wmata
+
+freeShaderPointers :: FullShader a -> IO ()
+freeShaderPointers fs = do
+    forM_ (_vaoBufferTargets $ _shaderVAO fs) $ \(_,ptr,_) ->
+        free ptr

src/Shader/Data.hs

@@ -0,0 +1,25 @@
+{-# LANGUAGE TemplateHaskell #-}
+module Shader.Data
+    where
+import Graphics.Rendering.OpenGL
+import Foreign
+import Control.Lens
+
+data VAO = VAO
+    { _vao :: VertexArrayObject
+    , _vaoBufferTargets :: [(BufferObject,Ptr Float,Int)]
+    }
+data FullShader a = FullShader
+    { _shaderProgram :: Program
+    , _shaderUniforms :: [UniformLocation]
+    , _shaderVAO :: VAO
+    , _shaderPokeStrategy :: a -> [[[Float]]]-- -> F.FoldM IO RenderType Int
+    , _shaderDrawPrimitive :: PrimitiveMode
+    , _shaderTexture :: Maybe ShaderTexture
+    , _shaderCustomUnis :: Maybe [UniformLocation]
+    }
+data ShaderTexture = ShaderTexture
+    { _textureObject :: TextureObject }
+
+makeLenses ''VAO
+makeLenses ''FullShader