Refactor level/room generation modules
This commit is contained in:
@@ -14,6 +14,7 @@ import Dodge.Update
|
||||
import Dodge.KeyEvents
|
||||
import Dodge.Rendering
|
||||
import Dodge.Menu
|
||||
import Dodge.Floor
|
||||
|
||||
import Picture
|
||||
import Picture.Render
|
||||
|
||||
@@ -365,6 +365,7 @@ startCr = basicCreature
|
||||
,latchkey 0
|
||||
,frontArmour
|
||||
,miniGun
|
||||
,medkit 50
|
||||
]
|
||||
++ repeat NoItem))
|
||||
-- startInv
|
||||
|
||||
@@ -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
|
||||
}
|
||||
+11
-41
@@ -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
|
||||
@@ -86,25 +79,10 @@ 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
|
||||
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
|
||||
|
||||
-- the old version of this used a version of polysIntersect with intersectSegSeg'
|
||||
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
|
||||
|
||||
|
||||
|
||||
@@ -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
|
||||
+3
-44
@@ -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 ((&))
|
||||
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
|
||||
-- deals with placement of objects within the world
|
||||
|
||||
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
|
||||
@@ -202,8 +186,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
|
||||
|
||||
addWindow :: [Point2] -> Color -> IM.IntMap Wall -> IM.IntMap Wall
|
||||
@@ -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)
|
||||
|
||||
@@ -2,6 +2,7 @@ module Dodge.Menu where
|
||||
-- imports {{{
|
||||
import Dodge.Data
|
||||
import Dodge.Rooms
|
||||
import Dodge.Floor
|
||||
import Dodge.Initialisation
|
||||
import Dodge.SoundLogic
|
||||
|
||||
|
||||
@@ -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
|
||||
|
||||
+4
-119
@@ -36,78 +36,7 @@ import Data.Graph.Inductive.NodeMap
|
||||
|
||||
import qualified Data.IntMap.Strict as IM
|
||||
-- }}}
|
||||
|
||||
|
||||
|
||||
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
|
||||
}
|
||||
|
||||
-- definition of individual rooms
|
||||
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
|
||||
@@ -888,7 +774,6 @@ shootingRange = do
|
||||
]
|
||||
(Right rm3)
|
||||
|
||||
|
||||
spawnerRoom :: RandomGen g => State g (Tree (Either Room Room))
|
||||
spawnerRoom = do
|
||||
x <- state $ randomR (250,300)
|
||||
|
||||
@@ -0,0 +1,4 @@
|
||||
module Dodge.TransparencyEffects
|
||||
where
|
||||
|
||||
|
||||
+3
-181
@@ -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
|
||||
| otherwise = Just $ soundOnce healSound
|
||||
$ over (creatures . ix n . crHP) ((\x-> min x 100). (+ 25) ) w
|
||||
heal25 = heal 25
|
||||
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
|
||||
|
||||
@@ -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
|
||||
|
||||
+2
-23
@@ -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
|
||||
|
||||
+24
-28
@@ -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
|
||||
bufferOffset = plusPtr nullPtr . fromIntegral
|
||||
----------------end renderPicture'
|
||||
|
||||
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
|
||||
|
||||
|
||||
@@ -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)
|
||||
|
||||
+279
@@ -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
|
||||
@@ -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
|
||||
Reference in New Issue
Block a user