justin/loop
1
0
Fork 0
Code Issues Pull Requests 1 Packages Projects Releases Wiki Activity

Linting, haddocking

Browse Source
This commit is contained in:
jgk
2021-04-29 15:31:07 +02:00
parent 750a67ea6e
commit 6a38950501
34 changed files with 506 additions and 441 deletions
Download Patch File Download Diff File Expand all files Collapse all files
app/Main.hs
+5 -6
View File
@@ -39,7 +39,7 @@ main = do
dodgeConfig <- loadDodgeConfig
setupLoop
(sizex,sizey)
(SDL.cursorVisible $= False >> doPreload' dodgeConfig >>= resizeSpareFBO sizex sizey)
(SDL.cursorVisible $= False >> doPreload >>= applyWorldConfig dodgeConfig)
(\x -> (SDL.cursorVisible $= True) >> cleanUpPreload x)
(fmap (setWindowSize sizex sizey keyConfig . (config .~ dodgeConfig)) firstWorld)
doSideEffects
@@ -64,14 +64,13 @@ doSideEffects preData w = do
foldr (=<<) (return (preData & soundData . playingSounds .~ newPlayingSounds
& frameTimer .~ endTicks)) (_doneSideEffects w)
doPreload' :: Dodge.Config.Data.Configuration -> IO (PreloadData a)
doPreload' config = do
doPreload :: IO (PreloadData a)
doPreload = do
lChunks <- loadSounds
lMusic <- loadMusic
let sData = SoundData {_loadedChunks = lChunks, _playingSounds = M.empty}
mData = MusicData {_loadedMusic = lMusic}
Mix.playMusic Mix.Forever (lMusic IM.! 0)
setVolume config
rData <- preloadRender
return $ PreloadData
{ _renderData = rData
@@ -87,6 +86,6 @@ checkForGlErrors = do
setWindowSize :: Int -> Int -> KeyConfigSDL-> World -> World
setWindowSize x y z w = w
& windowX .~ fromIntegral x
& windowY .~ fromIntegral y
& config . windowX .~ fromIntegral x
& config . windowY .~ fromIntegral y
& keyConfig .~ z
src/Dodge/Base.hs
+12 -8
View File
@@ -3,6 +3,7 @@
module Dodge.Base where
-- imports {{{
import Dodge.Data
import Dodge.Config.Data
import Geometry
import Picture
@@ -52,8 +53,11 @@ yourItem w = _crInv (you w) IM.! _crInvSel (you w)
yourItemRef w = (creatures . ix (_yourID w) . crInv . ix (_crInvSel (you w)))
halfWidth,halfHeight :: World -> Float
halfWidth w = _windowX w / 2
halfHeight w = _windowY w / 2
halfWidth w = getWindowX w / 2
halfHeight w = getWindowY w / 2
getWindowX = _windowX . _config
getWindowY = _windowY . _config
hasLOS :: Point2 -> Point2 -> World -> Bool
{-# INLINE hasLOS #-}
@@ -317,7 +321,7 @@ zoneOfScreen w = [(a,b) | a <- [x - n .. x + n]
]
where (x,y) = zoneOfPoint $ _cameraCenter w
n = ceiling $ wh / (_cameraZoom w * zoneSize)
wh = max (_windowX w) (_windowY w)
wh = max (getWindowX w) (getWindowY w)
zoneOfDoubleScreen :: World -> [(Int,Int)]
zoneOfDoubleScreen w = [(a,b) | a <- [x - n .. x + n]
@@ -325,7 +329,7 @@ zoneOfDoubleScreen w = [(a,b) | a <- [x - n .. x + n]
]
where (x,y) = zoneOfPoint $ _cameraCenter w
n = (ceiling $ wh / (_cameraZoom w * zoneSize)) * 2
wh = max (_windowX w) (_windowY w)
wh = max (getWindowX w) (getWindowY w)
zoneOfSight :: World -> [(Int,Int)]
zoneOfSight w = [(a,b) | a <- [minimum xs .. maximum xs]
@@ -786,8 +790,8 @@ worldPosToScreen w = doWindowScale . doRotate . doZoom . doTranslate
doTranslate p = p -.- _cameraCenter w
doZoom p = _cameraZoom w *.* p
doRotate p = rotateV (0 - _cameraRot w) p
doWindowScale (x,y) = ( x * 2 / _windowX w
, y * 2 / _windowY w
doWindowScale (x,y) = ( x * 2 / getWindowX w
, y * 2 / getWindowY w
)
{- | Transform coordinates from the map position to normalised screen
@@ -799,8 +803,8 @@ cartePosToScreen w = doWindowScale . doRotate . doZoom . doTranslate
doTranslate p = p -.- _carteCenter w
doZoom p = _carteZoom w *.* p
doRotate p = rotateV (0 - _carteRot w) p
doWindowScale (x,y) = ( x * 2 / _windowX w
, y * 2 / _windowY w
doWindowScale (x,y) = ( x * 2 / getWindowX w
, y * 2 / getWindowY w
)
{- | The mouse position in world coordinates.
src/Dodge/Config/Data.hs
+16 -10
View File
@@ -9,6 +9,8 @@ module Dodge.Config.Data (
, volume_music
, wall_textured
, shadow_resolution
, windowX
, windowY
) where
import Data.Aeson
@@ -20,11 +22,13 @@ import System.Directory
import Control.Lens
data Configuration = Configuration
{ _volume_master :: Float
, _volume_sound :: Float
, _volume_music :: Float
, _wall_textured :: Bool
, _shadow_resolution :: Int -- ^ Higher values divide the screen size, i.e. make the resolution worse
{ _volume_master :: Float
, _volume_sound :: Float
, _volume_music :: Float
, _wall_textured :: Bool
, _shadow_resolution :: Int -- ^ Higher values divide screen size, i.e. make the resolution worse
, _windowX :: Float
, _windowY :: Float
}
deriving (Generic, Show)
@@ -36,10 +40,12 @@ instance ToJSON Configuration where
instance FromJSON Configuration
defaultConfig = Configuration
{ _volume_master = 1
, _volume_sound = 1
, _volume_music = 1
, _wall_textured = False
, _shadow_resolution = 1
{ _volume_master = 1
, _volume_sound = 1
, _volume_music = 1
, _wall_textured = False
, _shadow_resolution = 1
, _windowX = 800
, _windowY = 600
}
src/Dodge/Config/Update.hs
+23 -6
View File
@@ -7,22 +7,39 @@ import Dodge.Data.SoundOrigin
import Dodge.Config.Data
import Sound
import Preload.Data
import Preload.Update
import Data.Aeson (encodeFile)
import Control.Monad (when)
{- |
Write the current world configuration to disk as a json file.
-}
saveConfig :: Configuration -> PreloadData SoundOrigin -> IO (PreloadData SoundOrigin)
saveConfig cfig d = do
putStrLn "Saving config to data/dodge.config.json"
encodeFile "data/dodge.config.json" cfig
return d
setVolume :: Configuration -> IO ()
setVolume cfig = do
setSoundVolume ( _volume_master cfig * _volume_sound cfig)
setMusicVolume ( _volume_master cfig * _volume_music cfig)
{- |
Apply the volume settings from the world configuration to the running game.
-}
setVol :: Configuration -> PreloadData SoundOrigin -> IO (PreloadData SoundOrigin)
setVol cfig d = do
setVolume cfig
setSoundVolume ( _volume_master cfig * _volume_sound cfig)
setMusicVolume ( _volume_master cfig * _volume_music cfig)
return d
{- |
Apply /all/ of the values in the world configuration to the running game.
-}
applyWorldConfig
:: Configuration
-> PreloadData SoundOrigin
-> IO (PreloadData SoundOrigin)
applyWorldConfig cfig pdata = do
setVol cfig pdata >>= resizeSpareFBO (x `div` divRes) (y `div` divRes)
where
x = round $ _windowX cfig
y = round $ _windowY cfig
divRes = _shadow_resolution cfig
src/Dodge/Creature/YourControl.hs
+2 -3
View File
@@ -1,22 +1,21 @@
module Dodge.Creature.YourControl
where
import Dodge.Data
import Dodge.Base
import Dodge.Creature.Action
import Dodge.Creature.State
import Dodge.Update.UsingInput
import Dodge.Config.KeyConfig
import Dodge.Item.Attachment.Data
import Geometry
import Control.Lens
import qualified SDL
import Data.Maybe
import qualified Data.Set as S
import qualified Data.IntMap.Strict as IM
import System.Random
import Data.Maybe
yourControl :: World -> (World -> World,StdGen) -> Creature -> ((World -> World,StdGen), Maybe Creature)
src/Dodge/Data.hs
+1 -15
View File
@@ -24,6 +24,7 @@ import Dodge.Data.SoundOrigin
import Dodge.Data.DamageType
import Dodge.Config.Data
import Dodge.Config.KeyConfig
import Dodge.Item.Attachment.Data
import Preload.Data
import Picture.Data
import Geometry.Data
@@ -82,8 +83,6 @@ data World = World
, _menuLayers :: [MenuLayer]
, _worldState :: M.Map WorldState Bool
, _worldTriggers :: S.Set WorldTrigger
, _windowX :: !Float
, _windowY :: !Float
, _carteDisplay :: !Bool
, _carteCenter :: !Point2
, _carteZoom :: !Float
@@ -303,18 +302,6 @@ data Item
}
| NoItem
data ItAttachment
= ItScope
{_scopePos :: Point2
,_scopeZoomChange :: Int
,_scopeZoom :: Float
,_scopeIsCamera :: Bool
}
| ItFuse {_itFuseTime :: Int}
| ItPhaseV {_itPhaseV :: Float}
| ItMode {_itMode :: Int}
| ItTargetPos { _itTargetPos :: Point2 }
data ItEffect = NoItEffect
| ItInvEffect
{_itInvEffect :: Creature -> Int -> World -> World
@@ -496,7 +483,6 @@ makeLenses ''Stance
makeLenses ''Item
makeLenses ''ItemPos
makeLenses ''ItEffect
makeLenses ''ItAttachment
makeLenses ''ItZoom
makeLenses ''FloorItem
makeLenses ''Projectile
src/Dodge/Data/Menu.hs
+1 -1
View File
@@ -8,6 +8,6 @@ data MenuLayer
| OptionMenu
| SoundOptionMenu
| GraphicsOptionMenu
| ConfigSaveScreen
| ControlList
| WaitMessage String
deriving (Eq,Ord)
src/Dodge/Default.hs
-2
View File
@@ -234,8 +234,6 @@ defaultWorld = World
, _pathGraph' = []
, _pathPoints = IM.empty
, _pathInc = M.empty
, _windowX = 800
, _windowY = 600
, _carteDisplay = False
, _carteCenter = (0,0)
, _carteZoom = 0.5
src/Dodge/Event.hs
+4 -4
View File
@@ -47,8 +47,8 @@ handleEvent' e = case eventPayload e of
handleMouseMotionEvent :: MouseMotionEventData -> World -> Maybe World
handleMouseMotionEvent mmev w
= Just $ w & mousePos .~ (fromIntegral x - 0.5*_windowX w
,0.5*_windowY w - fromIntegral y
= Just $ w & mousePos .~ (fromIntegral x - 0.5*getWindowX w
,0.5*getWindowY w - fromIntegral y
)
where P (V2 x y) = mouseMotionEventPos mmev
@@ -72,8 +72,8 @@ Resets the world window size, and resizes the fbo that gets the light map drawn
-}
handleResizeEvent :: WindowSizeChangedEventData -> World -> Maybe World
handleResizeEvent sev w = Just
. set windowX (fromIntegral x)
. set windowY (fromIntegral y)
. set (config . windowX) (fromIntegral x)
. set (config . windowY) (fromIntegral y)
$ over sideEffects ( resizeSpareFBO (fromIntegral x `div` divRes) (fromIntegral y `div` divRes) : )
w
where
src/Dodge/Event/Menu.hs
+4 -3
View File
@@ -3,6 +3,7 @@ module Dodge.Event.Menu
) where
import Dodge.Data
import Dodge.Data.Menu
import Dodge.Base
import Dodge.Floor
import Dodge.Initialisation
import Dodge.SoundLogic
@@ -67,14 +68,14 @@ handlePressedKeyInMenu mState scode w = case mState of
startNewGame = Just $ generateFromList levx
$ initialWorld
& randGen .~ _randGen w
& windowX .~ _windowX w
& windowY .~ _windowY w
& config . windowX .~ getWindowX w
& config . windowY .~ getWindowY w
updateFramebufferSize :: World -> World
updateFramebufferSize w = w & sideEffects
%~ (resizeSpareFBO (ceiling x `div` divRes) (ceiling y `div` divRes) : )
where
(x,y) = (_windowX w, _windowY w)
(x,y) = (getWindowX w, getWindowY w)
divRes = w ^. config . shadow_resolution
cycleResolution 1 = 2
src/Dodge/Floor.hs
+1 -1
View File
@@ -41,7 +41,7 @@ roomTreex = do
let t' = padCorridors struct
t = treeFromTrunk
[[StartRoom]
,[Corridor]
,[DoorAno]
,[SpecificRoom $ fmap (pure . Right) $ randomiseAllLinks =<< centerVaultRoom 1 200 200 50]
,[SpecificRoom blockedCorridor]
,[OrAno [[DoorAno]
src/Dodge/Initialisation.hs
-2
View File
@@ -51,8 +51,6 @@ initialWorld = defaultWorld
, _storedLevel = Nothing
, _menuLayers = [LevelMenu 1]
, _worldState = M.empty
, _windowX = 800
, _windowY = 600
}
src/Dodge/Item/Attachment.hs
+2
View File
@@ -0,0 +1,2 @@
module Dodge.Item.Attachment
where
src/Dodge/Item/Attachment/Data.hs
+26
View File
@@ -0,0 +1,26 @@
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE StrictData #-}
module Dodge.Item.Attachment.Data
where
import Geometry.Data
import Control.Lens
data ItAttachment
= ItScope
{_scopePos :: Point2
,_scopeZoomChange :: Int
,_scopeZoom :: Float
,_scopeIsCamera :: Bool
}
| ItFuse {_itFuseTime :: Int}
| ItPhaseV {_itPhaseV :: Float}
| ItMode {_itMode :: Int}
| ItCharMode
{_itCharMode :: Char
,_itUpChar :: Char -> Char
,_itDownChar :: Char -> Char
}
| ItTargetPos { _itTargetPos :: Point2 }
makeLenses ''ItAttachment
src/Dodge/Item/Weapon.hs
+1
View File
@@ -21,6 +21,7 @@ import Dodge.Item.Weapon.Bullet
import Dodge.Item.Weapon.InventoryDisplay
import Dodge.Item.Weapon.TriggerType
import Dodge.Item.Weapon.Recock
import Dodge.Item.Attachment.Data
import Geometry
import Picture
src/Dodge/Item/Weapon/InventoryDisplay.hs
+17 -6
View File
@@ -1,15 +1,26 @@
{- |
Display of weapon strings in the inventory.
-}
module Dodge.Item.Weapon.InventoryDisplay
where
import Dodge.Data
import Dodge.Base
import Dodge.Item.Attachment.Data
import Control.Lens
import Control.Monad
-- MODES SHOULD BE MADE UNIFORM
basicWeaponDisplay :: Item -> String
basicWeaponDisplay it = midPadL 10 ' ' (_itName it) (' ' : aIfLoaded)
where
availableAmmo = show $ _wpMaxAmmo it
aIfLoaded = case (_wpReloadState it) of
0 -> show $ _wpLoadedAmmo it
x -> "R" ++ show x
basicWeaponDisplay it = case it ^? itAttachment . _Just . itCharMode of
Just c -> midPadL 10 ' ' (_itName it) (' ' : aIfLoaded) ++ [' ',c]
otherwise -> midPadL 10 ' ' (_itName it) (' ' : aIfLoaded)
where
availableAmmo = show $ _wpMaxAmmo it
aIfLoaded = case (_wpReloadState it) of
0 -> show $ _wpLoadedAmmo it
x -> "R" ++ show x
displayAutoGun :: Item -> String
displayAutoGun it@(Weapon {_itAttachment = mayMode})
src/Dodge/Item/Weapon/Recock.hs
+27 -19
View File
@@ -1,28 +1,36 @@
{-# LANGUAGE BangPatterns #-}
{- |
Controls for continuous and non-continuous fire.
-}
module Dodge.Item.Weapon.Recock
where
import Dodge.Data
import Control.Lens
import qualified Data.IntMap.Strict as IM
{- |
Controls resetting a weapon, allows for non-continuous fire needing a button release. -}
wpRecock :: ItEffect
wpRecock = ItInvEffect {_itInvEffect = f
,_itEffectCounter = 0
}
where f cr i = creatures . ix (_crID cr) . crInv
%~ IM.adjust fOnIt i
moveHammerUp !HammerDown = HammerReleased
moveHammerUp !HammerReleased = HammerUp
moveHammerUp !HammerUp = HammerUp
fOnIt it = it & itHammer %~ moveHammerUp
wpRecock = ItInvEffect
{_itInvEffect = f
,_itEffectCounter = 0
}
where
f cr i = creatures . ix (_crID cr) . crInv %~ IM.adjust fOnIt i
moveHammerUp HammerDown = HammerReleased
moveHammerUp HammerReleased = HammerUp
moveHammerUp HammerUp = HammerUp
fOnIt it = it & itHammer %~ moveHammerUp
{- |
Special recock for the bezier gun.
Not sure of its purpose at this time... -}
bezierRecock :: ItEffect
bezierRecock = ItInvEffect {_itInvEffect = f
,_itEffectCounter = 0
}
where f cr i = creatures . ix (_crID cr) . crInv
%~ IM.adjust fOnIt i
fOnIt it = case _itHammer it of
HammerDown -> it & itHammer .~ HammerUp
_ -> it & itAttachment .~ Nothing
bezierRecock = ItInvEffect
{_itInvEffect = f
,_itEffectCounter = 0
}
where
f cr i = creatures . ix (_crID cr) . crInv %~ IM.adjust fOnIt i
fOnIt it = case _itHammer it of
HammerDown -> it & itHammer .~ HammerUp
_ -> it & itAttachment .~ Nothing
src/Dodge/Item/Weapon/TriggerType.hs
+82 -79
View File
@@ -1,6 +1,5 @@
{-
Weapon effects when pulling the trigger.
-}
{- |
Weapon effects when pulling the trigger. -}
module Dodge.Item.Weapon.TriggerType
where
import Dodge.Data
@@ -10,6 +9,7 @@ import Dodge.WorldEvent (muzzleFlashAt,tempLightForAt)
import Dodge.WorldEvent.Cloud
import Dodge.RandomHelp
import Dodge.Item.Weapon.Bullet
import Dodge.Item.Attachment.Data
import Geometry
import System.Random
@@ -23,28 +23,27 @@ withThinSmoke
-> Int -- ^ Creature id
-> World
-> World
withThinSmoke eff cid w = eff cid . foldr makeThinSmokeAt w $ map (+.+ pos) ps
where
cr = _creatures w IM.! cid
dir = _crDir cr
pos = _crPos cr +.+ ((_crRad cr +0.5) *.* unitVectorAtAngle dir)
ps = (sequence . replicate 5 . randInCirc) 8 & evalState $ _randGen w
withThinSmoke eff cid w = eff cid $ foldr (makeThinSmokeAt . (+.+ pos)) w ps
where
cr = _creatures w IM.! cid
dir = _crDir cr
pos = _crPos cr +.+ (_crRad cr +0.5) *.* unitVectorAtAngle dir
ps = (replicateM 5 . randInCirc) 8 & evalState $ _randGen w
withThickSmoke
:: (Int -> World -> World) -- ^ Underlying effect
-> Int -- ^ Creature id
-> World
-> World
withThickSmoke eff cid w = eff cid . foldr makeThickSmokeAt w $ map (+.+ pos) ps
where
cr = _creatures w IM.! cid
dir = _crDir cr
pos = _crPos cr +.+ ((_crRad cr +15) *.* unitVectorAtAngle dir)
ps = (sequence . replicate 20 . randInCirc) 8 & evalState $ _randGen w
{- Shoot a weapon rapidly after a warm up.
Applies ammo check as well.
-}
withThickSmoke eff cid w = eff cid $ foldr (makeThickSmokeAt . (+.+ pos)) w ps
where
cr = _creatures w IM.! cid
dir = _crDir cr
pos = _crPos cr +.+ (_crRad cr + 15) *.* unitVectorAtAngle dir
ps = (replicateM 20 . randInCirc) 8 & evalState $ _randGen w
{- |
Shoot a weapon rapidly after a warm up.
Applies ammo check as well. -}
withWarmUp
:: Int -- ^ Warm up time (in frames)
-> (Int -> World -> World)
@@ -79,9 +78,9 @@ withWarmUp t f cid w
fState = _wpFireState item
fRate = _wpFireRate item
reloadCondition = _wpLoadedAmmo item == 0
{- Adds a sound to a creature based world effect.
The sound is emitted from the creature's position. -}
{- |
Adds a sound to a creature based world effect.
The sound is emitted from the creature's position. -}
withSound
:: Int -- ^ Sound id
-> (Int -> World -> World) -- ^ Underlying effect
@@ -97,7 +96,7 @@ withRecoil
-- ^ Underlying world effect, takes creature id as input
-> Int -- ^ Creature id
-> World -> World
withRecoil recoilAmount eff cid w = eff cid . over (creatures . ix cid) pushback $ w
withRecoil recoilAmount eff cid = eff cid . over (creatures . ix cid) pushback
where
pushback cr = over crPos (+.+ rotateV (_crDir cr) ((-recoilAmount) / _crMass cr ,0)) cr
@@ -109,12 +108,10 @@ withSidePush
-> World -> World
withSidePush maxSide eff cid w = eff cid . over (creatures . ix cid) push $ w
where
push cr = over crPos (+.+ rotateV (_crDir cr) (0,(pushAmount) / _crMass cr)) cr
push cr = over crPos (+.+ rotateV (_crDir cr) (0,pushAmount / _crMass cr)) cr
(pushAmount, _) = randomR (-maxSide,maxSide) $ _randGen w
{-
Applies a world effect and sound effect after an ammo check.
-}
{- |
Applies a world effect and sound effect after an ammo check. -}
shootWithSound
:: Int -- ^ Sound identifier
-> (Int -> World -> World)
@@ -129,7 +126,7 @@ shootWithSound soundid f cid w
| reloadCondition = fromMaybe w $ reloadWeapon cid w
| otherwise = w
where
cr = (_creatures w IM.! cid)
cr = _creatures w IM.! cid
itRef = _crInvSel cr
item = _crInv cr IM.! itRef
pointerToItem = creatures . ix cid . crInv . ix itRef
@@ -137,36 +134,42 @@ shootWithSound soundid f cid w
&& _wpFireState item == 0
&& _wpLoadedAmmo item > 0
reloadCondition = _wpLoadedAmmo item == 0
{- Applies a world effect after an ammo check. -}
{- | Applies a world effect after an ammo check. -}
shoot
:: (Int -> World -> World)
-- ^ Underlying effect, takes creature id as input
-> Int -- ^ Creature id
-> World -> World
shoot f cid w | fireCondition = over (pointerToItem . wpLoadedAmmo) (\ammo -> ammo-1)
$ set (pointerToItem . wpFireState) (_wpFireRate item)
$ f cid w
| reloadCondition = fromMaybe w $ reloadWeapon cid w
| otherwise = w
shoot f cid w
| fireCondition = over (pointerToItem . wpLoadedAmmo) (\ammo -> ammo-1)
$ set (pointerToItem . wpFireState) (_wpFireRate item)
$ f cid w
| reloadCondition = fromMaybe w $ reloadWeapon cid w
| otherwise = w
where
cr = (_creatures w IM.! cid)
cr = _creatures w IM.! cid
itRef = _crInvSel cr
item = _crInv cr IM.! itRef
pointerToItem = creatures . ix cid . crInv . ix itRef
fireCondition = _wpReloadState item == 0
&& _wpFireState item == 0
&& _wpLoadedAmmo item > 0
&& _wpFireState item == 0
&& _wpLoadedAmmo item > 0
reloadCondition = _wpLoadedAmmo item == 0
withMuzFlare :: (Int -> World -> World) -> Int -> World -> World
withMuzFlare
:: (Int -> World -> World) -- ^ Underlying effect
-> Int -- ^ Creature id
-> World
-> World
withMuzFlare f cid w = tempLightForAt 3 pos
. muzzleFlashAt pos2 $ f cid w
where cr = _creatures w IM.! cid
dir = _crDir cr
pos = _crPos cr +.+ _crRad cr *.* unitVectorAtAngle (_crDir cr)
pos2 = _crPos cr +.+ (2 * _crRad cr) *.* unitVectorAtAngle (_crDir cr)
where
cr = _creatures w IM.! cid
dir = _crDir cr
pos = _crPos cr +.+ _crRad cr *.* unitVectorAtAngle (_crDir cr)
pos2 = _crPos cr +.+ (2 * _crRad cr) *.* unitVectorAtAngle (_crDir cr)
{-
{- |
Rotates the creature randomly, applies the effect, rotates the creature back.
-}
withRandomDir
@@ -182,7 +185,7 @@ withRandomDir acc f cid w = over (creatures . ix cid . crDir) (\d -> d - a)
$ set randGen g
w
where (a, g) = randomR (-acc,acc) $ _randGen w
{- Creates a bullet with a given velocity, width, and 'HitEffect'
{- | Creates a bullet with a given velocity, width, and 'HitEffect'
-}
withVelWthHiteff
:: Point2 -- ^ Velocity, x direction is forward with respect to the creature
@@ -200,7 +203,7 @@ withVelWthHiteff vel width hiteff cid w
dir = _crDir cr
pos = _crPos cr +.+ _crRad cr *.* unitVectorAtAngle (_crDir cr)
pos2 = _crPos cr +.+ (2 * _crRad cr) *.* unitVectorAtAngle (_crDir cr)
{- Translate the creature sideways a random amount, apply the effect, translate back. -}
{- | Translate the creature sideways a random amount, apply the effect, translate back. -}
withRandomOffset
:: Float -- ^ Max possible translate
-> (Int -> World -> World)
@@ -229,36 +232,37 @@ torqueBeforeForced
-> World
-> World
torqueBeforeForced torque feff cid w
| cid == 0 = feff cid $ set randGen g $ over (creatures . ix cid . crDir) (+rot')
$ over cameraRot (+rot') w
| cid == 0 = feff cid $ w
& randGen .~ g
& creatures . ix cid . crDir +~ rot'
& cameraRot +~ rot'
| otherwise = feff cid $ set randGen g $ over (creatures . ix cid . crDir) (+rot') w
where
(rot, g) = randomR (-torque,torque) $ _randGen w
rot' | rot < 0 = rot - 0.1
| otherwise = rot + 0.1
-- | Rotates the player creature before applying an effect, other creatures after.
-- | Rotates the player creature before applying an effect.
-- Note this currently (29/4/2021) rotates other creatures /after/ applying the effect.
torqueBefore
:: Float -- ^ Max possible rotation
-> (Int -> World -> World)
-- ^ Underlying effect
-> Int
-- ^ Creature id
:: Float -- ^ Max possible rotation
-> (Int -> World -> World) -- ^ Underlying effect
-> Int -- ^ Creature id
-> World
-> World
torqueBefore torque feff cid w
| cid == 0 = feff cid $ set randGen g $ over (creatures . ix cid . crDir) (+rot)
$ over cameraRot (+rot) w
| otherwise = feff cid $ set randGen g $ over (creatures . ix cid . crDir) (+rot) w
| cid == 0 = feff cid $ w
& randGen .~ g
& creatures . ix cid . crDir +~ rot
& cameraRot +~ rot
| otherwise = set randGen g $ over (creatures . ix cid . crDir) (+rot) $ feff cid w
where
(rot, g) = randomR (-torque,torque) $ _randGen w
-- | Rotate a randomly creature after applying an effect.
torqueAfter
:: Float -- ^ Max possible rotation
-> (Int -> World -> World)
-- ^ Underlying effect
-> Int
-- ^ Creature id
:: Float -- ^ Max possible rotation
-> (Int -> World -> World) -- ^ Underlying effect
-> Int -- ^ Creature id
-> World
-> World
torqueAfter torque feff cid w
@@ -268,7 +272,8 @@ torqueAfter torque feff cid w
(rot, g) = randomR (-torque,torque) $ _randGen w
rotateScope w = w & creatures . ix 0 . crInv . ix (_crInvSel (_creatures w IM.! 0))
. itAttachment . _Just . scopePos %~ rotateV rot
{- Create multiple bullets with a given spread, a given amount, given velocity,
{- |
Create multiple bullets with a given spread, a given amount, given velocity,
given width and given 'HitEffect'.
-}
spreadNumVelWthHiteff
@@ -280,21 +285,20 @@ spreadNumVelWthHiteff
-> Int -- ^ Creature id
-> World
-> World
spreadNumVelWthHiteff spread num vel wth eff cid w
= over particles (newbuls ++) w
spreadNumVelWthHiteff spread num vel wth eff cid w = over particles (newbuls ++) w
where
cr = _creatures w IM.! cid
newbuls = zipWith3 (\pos d colid -> aGenBulAt' (Just cid) (numColor colid)
pos (rotateV d vel) eff wth
) poss dirs colids
newbuls = zipWith3
(\pos d colid -> aGenBulAt' (Just cid) (numColor colid) pos (rotateV d vel) eff wth)
poss dirs colids
poss = map ((+.+) $ _crPos cr +.+ _crRad cr *.* unitVectorAtAngle (_crDir cr))
$ evalState ((sequence . take num . repeat . randInCirc) 5) $ _randGen w
$ (replicateM num . randInCirc) 5 & evalState $ _randGen w
dirs = map ((+) (_crDir cr))
$ zipWith (+) [-spread,-spread+(2*spread/(fromIntegral num))..]
$ zipWith (+) [-spread,-spread+(2*spread/fromIntegral num)..]
$ randomRs (0,spread/5) (_randGen w)
colids = take num $ randomRs (0,11) (_randGen w)
{- Create a number of bullets side by side with a given velocity,
{- |
Create a number of bullets side by side with a given velocity,
given width and given 'HitEffect'.
-}
numVelWthHitEff
@@ -305,16 +309,15 @@ numVelWthHitEff
-> Int -- ^ Creature id
-> World
-> World
numVelWthHitEff num vel wth eff cid w
= over particles (newbuls ++) w
numVelWthHitEff num vel wth eff cid w = over particles (newbuls ++) w
where
cr = _creatures w IM.! cid
newbuls = zipWith (\pos colid -> aGenBulAt' (Just cid) (numColor colid)
pos (rotateV d vel) eff wth
)
poss colids
newbuls = zipWith
(\pos colid -> aGenBulAt' (Just cid) (numColor colid) pos (rotateV d vel) eff wth)
poss
colids
d = _crDir cr
poss = map (\o -> o +.+ pos) offsets
poss = map (+.+ pos) offsets
maxOffset = fromIntegral num * 2.5 - 2.5
offsets = map (\y -> rotateV d (0,y)) [-maxOffset,5-maxOffset..]
colids = take num $ randomRs (0,11) (_randGen w)
src/Dodge/Layout/Tree/Annotate.hs
+16 -10
View File
@@ -1,4 +1,4 @@
{-
{- |
Annotating tree structures with desired properties for rooms.
-}
module Dodge.Layout.Tree.Annotate
@@ -43,38 +43,44 @@ addLock i t = do
(beforeLock, afterLock) <- splitTrunk t
newBefore <- applyToRandomNode (Key i :) beforeLock
return $ addToTrunk newBefore [Node [Lock i] afterLock]
{- |
Add one corridor between each parent-child link of a tree of annotations.
-}
padCorridors :: Tree [Annotation g] -> Tree [Annotation g]
padCorridors (Node x xs) = Node [Corridor] [Node x (map padCorridors xs)]
{-
Add one to three corridors between each parent-child link of a tree of annotations.
-}
randomPadCorridors :: RandomGen g => Tree [Annotation g] -> State g (Tree [Annotation g])
randomPadCorridors (Node x xs) = do
n <- state $ randomR (1, 3)
xs' <- mapM randomPadCorridors xs
return $ treeFromTrunk (replicate n [Corridor]) (Node x xs')
{- |
Add a corridor to a random out-link of a room.
-}
roomThenCorridor :: RandomGen g => Room -> State g (Tree (Either Room Room))
roomThenCorridor theRoom = fmap (\r -> Node (Left theRoom) [(pure . Right) r])
(randomiseOutLinks corridor)
{- |
Create a random room tree structure from a list of annotations.
-}
annoToRoomTree :: RandomGen g => [Annotation g] -> State g (Tree (Either Room Room))
annoToRoomTree [OrAno as] = do
a <- takeOne as
annoToRoomTree a
annoToRoomTree [Corridor] = fmap (pure . Right) $ randomiseOutLinks corridor
annoToRoomTree [Corridor] = pure . Right <$> randomiseOutLinks corridor
annoToRoomTree [DoorAno] = roomThenCorridor door
annoToRoomTree [DoorNumAno i,AirlockAno] = roomThenCorridor (airlock i)
annoToRoomTree [FirstWeapon] = do
branchWP <- branchRectWith weaponRoom
blockedC <- longBlockedCorridor
firstWeapon <- takeOne $ [return $ appendEitherTree branchWP [blockedC]] ++ replicate 5 weaponRoom
firstWeapon
join $ takeOne $ (return $ appendEitherTree branchWP [blockedC]) : replicate 5 weaponRoom
annoToRoomTree [EndRoom] = fmap (pure . Right) (telRoomLev 1)
annoToRoomTree [StartRoom] = do
w <- state $ randomR (100,400)
h <- state $ randomR (200,400)
fmap (pure . Right) $ randomiseOutLinks (shiftRoomBy ((-20,-20),0) $ roomRectAutoLinks w h)
pure . Right <$> randomiseOutLinks (shiftRoomBy ((-20,-20),0) $ roomRectAutoLinks w h)
annoToRoomTree (SpecificRoom rt:_) = rt
annoToRoomTree (BossAno cr : _) = branchRectWith . fmap (pure . Left) $ bossRoom cr
annoToRoomTree (TreasureAno crs loot : _) =
src/Dodge/Layout/Tree/Either.hs
+3 -5
View File
@@ -28,22 +28,20 @@ appendEitherTree
:: Tree (Either a a) -- ^ The first tree
-> [Tree (Either a a)] -- ^ The forest to append
-> Tree (Either a a)
appendEitherTree (Node (Left x) ts) ts' = Node (Left x) $ map (flip appendEitherTree ts') ts
appendEitherTree (Node (Left x) ts) ts' = Node (Left x) $ map (`appendEitherTree` ts') ts
appendEitherTree (Node (Right x) ts) ts' = Node (Left x) ts'
removeEither (Left y) = y
removeEither (Right y) = y
{-
{- |
Make a singleton connection of an Either Tree.
-}
connectRoom :: a -> Tree (Either a a)
connectRoom r = Node (Right r) []
{-
{- |
Make a singleton dead end of an Either Tree.
-}
deadRoom :: a -> Tree (Either a a)
deadRoom r = Node (Left r) []
src/Dodge/Layout/Tree/Polymorphic.hs
+22 -19
View File
@@ -15,7 +15,7 @@ import Data.Tree
import Control.Monad.State
import System.Random
{-
{- |
Creates a linear tree.
Safe.
-}
@@ -23,7 +23,7 @@ treeFromPost :: [a] -> a -> Tree a
treeFromPost [] y = Node y []
treeFromPost (x:xs) y = Node x [treeFromPost xs y]
{-
{- |
Creates a tree with one trunk branch,
input as a list, that ends in another tree.
-}
@@ -34,7 +34,7 @@ treeFromTrunk
treeFromTrunk [] t = t
treeFromTrunk (x:xs) t = Node x [treeFromTrunk xs t]
{-
{- |
Applies a function to the root of a tree.
-}
applyToRoot :: (a -> a) -> Tree a -> Tree a
@@ -42,7 +42,7 @@ applyToRoot f (Node t ts) = Node (f t) ts
treeSize = length . flatten
{-
{- |
Applies a function to a specific node determined by a list of indices.
Unsafe (partial function).
-}
@@ -52,7 +52,7 @@ applyToNode (i:is) f (Node x xs) = Node x (ys ++ [applyToNode is f z] ++ zs)
where
(ys, z:zs) = splitAt i xs
{-
{- |
Applies a function to the first node along a trunk that satisfies a given property.
-}
applyToSubTrunkBy :: (a -> Bool) -> (Tree a -> Tree a) -> Tree a -> Tree a
@@ -64,62 +64,65 @@ applyToSubTrunkBy _ _ t = t
zipTree :: Tree a -> Tree b -> Tree (a,b)
zipTree (Node x xs) (Node y ys) = Node (x,y) $ zipWith zipTree xs ys
{-
{- |
Makes each node into its child number, i.e. the index it has
in the list of children of its parent.
-}
treeChildNums :: Tree a -> Tree Int
treeChildNums t = setRoot 0 t
treeChildNums = setRoot 0
where
setRoot :: Int -> Tree a -> Tree Int
setRoot i (Node x xs) = Node i (zipWith setRoot [0..] xs)
{-
{- |
Makes each node into its path, i.e. the list of indices that,
when followed from the root, lead to the node.
-}
treePaths :: Tree a -> Tree [a]
treePaths (Node x xs) = fmap (x :) $ Node [] (map treePaths xs)
treePaths (Node x xs) = (x :) <$> Node [] (map treePaths xs)
{-
{- |
Picks a random path in the tree.
Uniform probability that the path leads to any specific node.
-}
randomPath :: RandomGen g => Tree a -> State g [Int]
randomPath = takeOne . flatten . treePaths . treeChildNums
{-
Apply a function to a node picked uniformly at random.
{- |
Apply a function to the value of a node;
the node is picked uniformly at random.
-}
applyToRandomNode :: RandomGen g => (a -> a) -> Tree a -> State g (Tree a)
applyToRandomNode f t = do
p <- randomPath t
return $ applyToNode p f t
{-
{- |
Add a forest to the end of a tree (along the trunk).
-}
addToTrunk :: Tree a -> [Tree a] -> Tree a
addToTrunk (Node x []) f = Node x f
addToTrunk (Node x (t:ts)) f = Node x (addToTrunk t f : ts)
{-
{- |
Find the depth of a tree along the trunk.
-}
trunkDepth :: Tree a -> Int
trunkDepth (Node _ []) = 0
trunkDepth (Node _ (x:xs)) = trunkDepth x + 1
{-
{- |
Split a tree at a given point along its trunk.
-}
splitTrunkAt :: Int -> Tree a -> (Tree a, [Tree a])
splitTrunkAt
:: Int -- ^ Split depth
-> Tree a -> (Tree a, [Tree a])
splitTrunkAt 0 (Node x xs) = (Node x [],xs)
splitTrunkAt i (Node y (x:xs)) =
let (t, ts) = (splitTrunkAt (i-1) x)
in (Node y (t : xs) , ts)
let (t, ts) = splitTrunkAt (i-1) x
in (Node y (t : xs) , ts)
{-
{- |
Split a tree at a random point along its trunk.
-}
splitTrunk :: RandomGen g => Tree a -> State g (Tree a, [Tree a])
src/Dodge/Layout/Tree/Shift.hs
+23 -19
View File
@@ -1,3 +1,8 @@
{- |
Given a tree of rooms, tries to shift them into place in such a way that their
links connect and that none of them clip.
Returns a list; after this step the structure is determined by the actual positions of rooms.
-}
module Dodge.Layout.Tree.Shift
where
import Dodge.Room.Data
@@ -11,21 +16,13 @@ import Data.List (delete)
import Data.Maybe (listToMaybe)
import Control.Lens hiding (Empty, (<|) , (|>))
shiftRoomTreeConstruct :: [[Point2]] -> Tree Room -> Maybe (Tree Room)
shiftRoomTreeConstruct bs (Node t ts)
| roomIsClipping = Nothing
| otherwise = case children of
Nothing -> Nothing
Just ts' -> Just $ Node t ts'
where
roomIsClipping = any (polysIntersect (_rmBound t)) bs
children = sequence
$ zipWith (\l -> shiftRoomTreeConstruct (_rmBound t : bs)
. applyToRoot (shiftRoomToLink l))
(_rmLinks t)
ts
shiftRoomTreeSearch :: [[Point2]] -> Seq (Tree Room) -> Maybe [Room]
{- |
Helper: Depth first search of trees of rooms, maybe produces a list rooms that are not clipping.
-}
shiftRoomTreeSearch
:: [[Point2]] -- ^ Clipping bounds
-> Seq (Tree Room) -- ^ Rooms to be added
-> Maybe [Room]
shiftRoomTreeSearch _ Empty = Just []
shiftRoomTreeSearch bs (Node r ts :<| ts')
| roomIsClipping = Nothing
@@ -36,13 +33,18 @@ shiftRoomTreeSearch bs (Node r ts :<| ts')
children = fromList $ zipWith (\l -> applyToRoot (shiftRoomToLink l))
(_rmLinks r)
ts
shiftRoomTreeSearchAll :: [[Point2]] -> Seq (Tree Room) -> [[Room]]
{- |
All: Depth first search of trees of rooms, produces a list of lists of rooms that are not clipping.
-}
shiftRoomTreeSearchAll
:: [[Point2]] -- ^ Clipping bounds
-> Seq (Tree Room) -- ^ Rooms to be added
-> [[Room]]
shiftRoomTreeSearchAll _ Empty = [[]]
shiftRoomTreeSearchAll bs (Node r ts :<| ts')
| roomIsClipping = [] -- this is called too often, but whatever
| otherwise = case ts of
[] -> (r :) <$> (shiftRoomTreeSearchAll newBounds $ ts')
[] -> (r :) <$> (shiftRoomTreeSearchAll newBounds ts')
(s:ss) -> concatMap (\l -> shiftRoomTreeSearchAll bs (Node (rm l) ss <| (ts' |> f l s))) ls
where
ls = init $ _rmLinks r
@@ -50,6 +52,8 @@ shiftRoomTreeSearchAll bs (Node r ts :<| ts')
roomIsClipping = any (polysOverlap (_rmBound r)) bs
rm l = r & rmLinks %~ delete l
f l = applyToRoot (shiftRoomToLink l)
{- |
Depth first search of trees of rooms, maybe produces a list rooms that are not clipping.
-}
shiftExpandTree :: Tree Room -> Maybe [Room]
shiftExpandTree = listToMaybe . shiftRoomTreeSearchAll [] . singleton
src/Dodge/LevelGen/AutoDoor.hs
+63 -48
View File
@@ -1,68 +1,87 @@
{-
Creation of doors that open when creatures approach them.
-}
{-# LANGUAGE BangPatterns #-}
module Dodge.LevelGen.AutoDoor
where
import Dodge.Data
import Dodge.Base
import Dodge.SoundLogic
import Dodge.Creature.Property
import Geometry
import Picture
import Data.List
import Data.Maybe
import qualified Data.IntMap.Strict as IM
import Control.Lens
import Control.DeepSeq (deepseq)
addAutoDoor :: Point2 -> Point2 -> World -> World
addAutoDoor
:: Point2 -- ^ Left point
-> Point2 -- ^ Right point (though the two points should be symmetric)
-> World
-> World
addAutoDoor a b = over walls (autoDoorAt a b)
autoDoorAt :: Point2 -> Point2 -> IM.IntMap Wall -> IM.IntMap Wall
autoDoorAt
:: Point2 -- ^ Left point
-> Point2 -- ^ Right point (though the two points should be symmetric)
-> IM.IntMap Wall
-> IM.IntMap Wall
autoDoorAt a b wls = IM.union wls $ IM.fromList $ zip is $ mkAutoDoor a b is
where i = newKey wls
is = [i..]
where
i = newKey wls
is = [i..]
mkAutoDoor :: Point2 -> Point2 -> [Int] -> [Wall]
mkAutoDoor
:: Point2 -- ^ Left point
-> Point2 -- ^ Right point (though the two points should be symmetric)
-> [Int] -- ^ Wall ids
-> [Wall]
mkAutoDoor pl pr xs = addSound $ zipWith3 (autoDoorPane (pl,pr))
xs
(lDoorClosed ++ rDoorClosed)
(map shiftL lDoorClosed ++ map shiftR rDoorClosed)
where lDoorClosed = [ [pld,hwd]
, [hwd,hwu]
, [hwu,plu]
]
rDoorClosed = [ [pru,hwu]
, [hwu,hwd]
, [hwd,prd]
]
norm = 10 *.* errorNormalizeV 49 ( vNormal (pr -.- pl))
hw = 0.5 *.* (pl +.+ pr)
parallel = 0.5 *.* (pl -.- pr)
plu = pl +.+ norm
pld = pl -.- norm
pru = pr +.+ norm
prd = pr -.- norm
hwu = hw +.+ norm
hwd = hw -.- norm
shiftL = map $ (+.+ parallel) . (-.- normalizeV parallel)
shiftR = map $ (-.- parallel) . (+.+ normalizeV parallel)
where
lDoorClosed = [ [pld,hwd]
, [hwd,hwu]
, [hwu,plu]
]
rDoorClosed = [ [pru,hwu]
, [hwu,hwd]
, [hwd,prd]
]
norm = 10 *.* errorNormalizeV 49 ( vNormal (pr -.- pl))
hw = 0.5 *.* (pl +.+ pr)
parallel = 0.5 *.* (pl -.- pr)
plu = pl +.+ norm
pld = pl -.- norm
pru = pr +.+ norm
prd = pr -.- norm
hwu = hw +.+ norm
hwd = hw -.- norm
shiftL = map $ (+.+ parallel) . (-.- normalizeV parallel)
shiftR = map $ (-.- parallel) . (+.+ normalizeV parallel)
addSound (x:xs) = f x : xs
f wl = over doorMech g wl
g dm w | dist wp pld > 1 && dist wp hwd > 1
= soundFrom (WallSound (head xs)) (fromIntegral doorSound) 1 0 $ dm w
| otherwise = dm w
where wp = (_wlLine $ _walls w IM.! (head xs)) !! 1
addSound (x:xs) = f x : xs
f wl = over doorMech g wl
g dm w | dist wp pld > 2 && dist wp hwd > 2
= soundFrom (WallSound (head xs)) (fromIntegral doorSound) 1 0 $ dm w
| otherwise = dm w
where wp = (_wlLine $ _walls w IM.! (head xs)) !! 1
autoDoorPane :: (Point2,Point2) -> Int -> [Point2] -> [Point2] -> Wall
autoDoorPane
:: (Point2,Point2) -- ^ Trigger line
-> Int -- ^ Wall id
-> [Point2] -- ^ Closed position
-> [Point2] -- ^ Open position
-> Wall
autoDoorPane (trigx,trigy) n closedPos openPos = Door
{ _wlLine = closedPos
, _wlID = n
, _doorMech = dm
, _wlColor = dim $ yellow
, _wlColor = dim yellow
, _wlSeen = False
, _wlIsSeeThrough = False
, _doorPathable = True
@@ -70,22 +89,18 @@ autoDoorPane (trigx,trigy) n closedPos openPos = Door
where
a = closedPos !! 0
b = closedPos !! 1
dm w | any (crNearSeg 40 trigx trigy) $ IM.filter (_crIsAnimate . _crState) $ _creatures w
-- crsNearLine 40 trigL w
= flip (foldr changeZonedWall) zoneps
$ over walls (IM.adjust openDoor n) w
| otherwise = flip (foldr changeZonedWall') zoneps
$ over walls (IM.adjust closeDoor n) w
dm w
| any (crNearSeg 40 trigx trigy) $ IM.filter (_crIsAnimate . _crState) $ _creatures w
= flip (foldr changeZonedWall) zoneps $ over walls (IM.adjust openDoor n) w
| otherwise
= flip (foldr changeZonedWall') zoneps $ over walls (IM.adjust closeDoor n) w
mvP !ep !p = mvPointTowardAtSpeed 2 ep p
moveToward :: [Point2] -> Wall -> Wall
moveToward !ps w = let !newPs = zipWith mvP ps $ _wlLine w
in deepseq newPs $ w {_wlLine = newPs}
--deepseq ps $ w & wlLine %~ zipWith mvP ps
openDoor = moveToward openPos
in deepseq newPs $ w {_wlLine = newPs}
openDoor = moveToward openPos
closeDoor = moveToward closedPos
zoneps | dist a b <= 2 * zoneSize = [zoneOfPoint $ pHalf a b]
| otherwise = map zoneOfPoint $ divideLine (2*zoneSize) a b
changeZonedWall (!x,!y)
= over wallsZone $ adjustIMZone openDoor x y n
changeZonedWall' (!x,!y)
= over wallsZone $ adjustIMZone closeDoor x y n
changeZonedWall (!x,!y) = over wallsZone $ adjustIMZone openDoor x y n
changeZonedWall' (!x,!y) = over wallsZone $ adjustIMZone closeDoor x y n
src/Dodge/LevelGen/Block.hs
+95 -114
View File
@@ -1,149 +1,130 @@
{-# LANGUAGE BangPatterns #-}
{-
Creation, update and descruction of destructible walls.
-}
module Dodge.LevelGen.Block where
import Dodge.Data
import Dodge.Base
import Dodge.SoundLogic
import Dodge.WorldEvent.Sound
import Dodge.LevelGen.Pathing
import Geometry
import Picture.Data
import Control.Lens
import Control.Monad.State
import Data.List
import Data.Function
import qualified Data.IntMap.Strict as IM
import System.Random
import Control.Monad.State
updateBlocks :: World -> World
updateBlocks w = (\w' -> seq (_wallsZone w') w') $ flip (foldr removeFromZone) deadPanes
$ over walls (\wls -> wls `seq` IM.filter (not . blockIsDead) wls)
degradeBlocks
-- w
where degradeBlocks = deadBlocks `seq` foldr killBlock w deadBlocks
removeFromZone :: Wall -> World -> World
removeFromZone bl = over (wallsZone . ix x . ix y) (IM.delete (_wlID bl))
where (x,y) = zoneOfPoint $ pHalf (_wlLine bl !! 0) (_wlLine bl !! 1)
deadPanes = filter blockIsDead (IM.elems $ _walls w)
deadBlocks = nubBy ((==) `on` _blIDs) deadPanes
blockIsDead wl = case wl ^? blHP of Just x -> x <= 0
Nothing -> False
where
degradeBlocks = deadBlocks `seq` foldr killBlock w deadBlocks
removeFromZone :: Wall -> World -> World
removeFromZone bl = over (wallsZone . ix x . ix y) (IM.delete (_wlID bl))
where
(x,y) = zoneOfPoint $ pHalf (_wlLine bl !! 0) (_wlLine bl !! 1)
deadPanes = filter blockIsDead (IM.elems $ _walls w)
deadBlocks = nubBy ((==) `on` _blIDs) deadPanes
blockIsDead wl = case wl ^? blHP of
Just x -> x <= 0
Nothing -> False
killBlock :: Wall -> World -> World
killBlock bl w = f bl .
flip (foldr unshadow)
(_blShadows bl)
$ w
where
f bl@(Block {_blDegrades = (x:xs)}) = degradeBlock bl . hitSound bl
f bl = hitSound' bl
pos = _wlLine bl !! 0
hitSound bl | _wlIsSeeThrough bl = mkSoundBreakGlass pos
| otherwise = soundMultiFrom sos soundid 25 0
hitSound' bl | _wlIsSeeThrough bl = mkSoundSplinterGlass pos
| otherwise = soundMultiFrom sos soundid 25 0
sos = [BlockDegradeSound 0,BlockDegradeSound 1]
(soundid,_) = randomR (29,32) $ _randGen w
unshadow :: Int -> World -> World
unshadow bid w = case w ^? walls . ix bid of
Just b -> let (x,y) = zoneOfPoint $ pHalf (_wlLine b !! 0) (_wlLine b !! 1)
in w & wallsZone . ix x . ix y . ix bid . blVisible %~ (\_ -> True)
& walls . ix bid . blVisible %~ \_ -> True
Nothing -> w
killBlock bl w = f bl . flip (foldr unshadow) (_blShadows bl) $ w
where
f bl@(Block {_blDegrades = (x:xs)}) = degradeBlock bl . hitSound bl
f bl = hitSound' bl
pos = _wlLine bl !! 0
hitSound bl
| _wlIsSeeThrough bl = mkSoundBreakGlass pos
| otherwise = soundMultiFrom sos soundid 25 0
hitSound' bl
| _wlIsSeeThrough bl = mkSoundSplinterGlass pos
| otherwise = soundMultiFrom sos soundid 25 0
sos = [BlockDegradeSound 0,BlockDegradeSound 1]
(soundid,_) = randomR (29,32) $ _randGen w
unshadow :: Int -> World -> World
unshadow bid w = case w ^? walls . ix bid of
Just b ->
let (x,y) = zoneOfPoint $ pHalf (_wlLine b !! 0) (_wlLine b !! 1)
in w & wallsZone . ix x . ix y . ix bid . blVisible %~ const True
& walls . ix bid . blVisible %~ const True
Nothing -> w
degradeBlock :: Wall -> World -> World
degradeBlock bl w = let blid = _wlID bl
bls = map (\i -> _walls w IM.! i) (_blIDs $ _walls w IM.! blid)
ps = reverse $ orderPolygon $ nub $ concatMap _wlLine bls
(newPs,g) = runState (shrinkPolygon 0.5 ps) $ _randGen w
(x:xs) = _blDegrades bl
in addBlock newPs (x + _blHP bl) (_wlColor bl) (_wlIsSeeThrough bl) xs $ set randGen g w
degradeBlock bl w =
let blid = _wlID bl
bls = map (\i -> _walls w IM.! i) (_blIDs $ _walls w IM.! blid)
ps = reverse $ orderPolygon $ nub $ concatMap _wlLine bls
(newPs,g) = runState (shrinkPolygon 0.5 ps) $ _randGen w
(x:xs) = _blDegrades bl
in addBlock newPs (x + _blHP bl) (_wlColor bl) (_wlIsSeeThrough bl) xs $ set randGen g w
pushPointTowardsBy :: RandomGen g => Float -> Point2 -> [Point2] -> State g Point2
{-
This does not have clear behaviour in my mind, and should probably be replaced with something more obvious...
-}
pushPointTowardsBy
:: RandomGen g
=> Float
-> Point2
-> [Point2]
-> State g Point2
pushPointTowardsBy x p ps = do
xs <- sequence $ take (length ps) $ repeat $ state $ randomR (0, x / (fromIntegral $ length ps))
xs <- replicateM (length ps) $ state $ randomR (0, x / fromIntegral (length ps))
let toAdd p' y = y *.* (p' -.- p)
return $ p +.+ foldr1 (+.+) (zipWith toAdd ps xs)
shrinkPolygon :: RandomGen g => Float -> [Point2] -> State g [Point2]
shrinkPolygon x ps = sequence $ map (flip (pushPointTowardsBy x) ps) ps
shrinkPolygon
:: RandomGen g
=> Float -- ^ Shrink parameter
-> [Point2]
-> State g [Point2]
shrinkPolygon x ps = mapM (flip (pushPointTowardsBy x) ps) ps
addBlockNoShadow :: [Point2] -> Int -> Color -> Bool -> [Int] -> Bool -> World -> World
addBlockNoShadow (p:ps) hp col isSeeThrough degradability hasAllShadows w
| hp <= 0 && degradability == [] = w
| hp <= 0 = addBlock (p:ps) (head degradability + hp) col isSeeThrough (tail degradability) w
| otherwise = over wallsZone (flip (IM.foldr wallInZone) blocks)
$ over walls (IM.union blocks) w
where
shadowList | hasAllShadows = repeat True
| otherwise = concat $ repeat [False,True]
lines = zip (p:ps) (ps ++ [p])
i = newKey $ _walls w
is = [i.. i + length lines-1]
blocks = IM.fromList $ zip is
$ zipWith3 (\j (a,b) bool
-> Block { _wlLine = [a,b]
, _wlID = j
-- , _wlColor = greyN 0.5
, _wlColor = col
, _wlSeen = False
, _blIDs = is
, _blHP = hp
, _wlIsSeeThrough = isSeeThrough
, _blVisible = True
, _blShadows = []
, _blDegrades = degradability
}
) is lines shadowList
wallInZone wl | dist (_wlLine wl !! 0) (_wlLine wl !! 1) <= 2*zoneSize
= insertIMInZone x y wlid wl
| otherwise = flip (foldr (\(a,b) -> insertIMInZone a b wlid wl)) ips
where (x,y) = zoneOfPoint $ (pHalf (_wlLine wl !! 0) (_wlLine wl !! 1))
wlid = _wlID wl
ips = map zoneOfPoint $ divideLine (2*zoneSize) (_wlLine wl !! 0) (_wlLine wl !! 1)
addBlock :: [Point2] -> Int -> Color -> Bool -> [Int] -> World -> World
addBlock
:: [Point2] -- ^ Block polygon
-> Int -- ^ First layer of health
-> Color
-> Bool -- ^ Is the block see through?
-> [Int] -- ^ Extra layers of health
-> World
-> World
addBlock (p:ps) hp col isSeeThrough degradability w
| hp <= 0 && degradability == [] = w
| hp <= 0 && null degradability = w
| hp <= 0 = addBlock (p:ps) (head degradability + hp) col isSeeThrough (tail degradability) w
| otherwise = over wallsZone (flip (IM.foldr wallInZone) blocks)
$ over walls (IM.union blocks) w
--addBlock (p:p':ps) w = over walls (IM.insert i b) w
where
lines = zip (p:ps) (ps ++ [p])
i = newKey $ _walls w
is = [i.. i + length lines-1]
blocks = IM.fromList $ zip is
$ zipWith (\j (a,b) -> Block { _wlLine = [a,b]
, _wlID = j
-- , _wlColor = greyN 0.5
, _wlColor = col
, _wlSeen = False
, _blIDs = is
, _blHP = hp
, _wlIsSeeThrough = isSeeThrough
, _blVisible = True
, _blShadows = []
, _blDegrades = degradability
}
) is lines
wallInZone wl | dist (_wlLine wl !! 0) (_wlLine wl !! 1) <= 2*zoneSize
= insertIMInZone x y wlid wl
| otherwise = flip (foldr (\(a,b) -> insertIMInZone a b wlid wl)) ips
where (x,y) = zoneOfPoint $ (pHalf (_wlLine wl !! 0) (_wlLine wl !! 1))
wlid = _wlID wl
ips = map zoneOfPoint $ divideLine (2*zoneSize) (_wlLine wl !! 0) (_wlLine wl !! 1)
| otherwise = w
& wallsZone %~ flip (IM.foldr wallInZone) panes
& walls %~ IM.union panes
where
lines = zip (p:ps) (ps ++ [p])
i = newKey $ _walls w
is = [i.. i + length lines-1]
panes = IM.fromList $ zip is
$ zipWith (\j (a,b) -> Block { _wlLine = [a,b]
, _wlID = j
, _wlColor = col
, _wlSeen = False
, _blIDs = is
, _blHP = hp
, _wlIsSeeThrough = isSeeThrough
, _blVisible = True
, _blShadows = []
, _blDegrades = degradability
}
) is lines
wallInZone wl
| dist (_wlLine wl !! 0) (_wlLine wl !! 1) <= 2*zoneSize
= insertIMInZone x y wlid wl
| otherwise = flip (foldr (\(a,b) -> insertIMInZone a b wlid wl)) ips
where
(x,y) = zoneOfPoint $ pHalf (_wlLine wl !! 0) (_wlLine wl !! 1)
wlid = _wlID wl
ips = map zoneOfPoint $ divideLine (2*zoneSize) (_wlLine wl !! 0) (_wlLine wl !! 1)
putBlockWallPart :: [Point2] -> Int -> Color -> Bool -> [Int] -> World -> World
putBlockWallPart (p:ps) i c b is w = foldr (uncurry removePathsCrossing) wWithBlock pairs
where pairs = zip (p:ps) (ps ++ [p])
wWithBlock = addBlockNoShadow (p:ps) i c b is False w
putBlock :: [Point2] -> Int -> Color -> Bool -> [Int] -> World -> World
putBlock (p:ps) i c b is w = foldr (uncurry removePathsCrossing) wWithBlock pairs
where pairs = zip (p:ps) (ps ++ [p])
src/Dodge/Render.hs
+2 -2
View File
@@ -31,7 +31,7 @@ import qualified Data.Set as S
import Graphics.Rendering.OpenGL hiding (color,scale,translate,rotate)
import qualified SDL
halfwindow = over windowX ( / 2) . over windowY ( / 2)
halfwindow = over (config . windowX) ( / 2) . over (config . windowY) ( / 2)
doDrawing :: RenderData -> World -> IO (Word32)
doDrawing pdata w = do
@@ -40,7 +40,7 @@ doDrawing pdata w = do
let rot = _cameraRot w
zoom = _cameraZoom w
trans@(tranx,trany) = _cameraCenter w
wins@(winx,winy) = (_windowX w,_windowY w)
wins@(winx,winy) = (getWindowX w,getWindowY w)
wallPointsCol = wallsPointsAndCols w
windowPoints = wallsWindows w
lightPoints = lightsForGloom' w
src/Dodge/Render/HUD.hs
+10 -10
View File
@@ -23,7 +23,7 @@ hudDrawings w = setLayer 1 . setDepth (-0.5) . pictures $
selectionText = if _carteDisplay w
then drawLocations w
else drawInventory w
scaler = scale (2 / _windowX w) (2 / _windowY w)
scaler = scale (2 / getWindowX w) (2 / getWindowY w)
drawInventory :: World -> [Picture]
drawInventory w =
@@ -42,7 +42,7 @@ displayListTopLeft scols w =
( map (\x -> halfHeight w - (20 * (fromIntegral x+1))) [0..] )
( map (\(s,col) -> scale 0.1 0.1 . dShadCol col $ text s) scols )
where
scaler = scale (2 / _windowX w) (2 / _windowY w)
scaler = scale (2 / getWindowX w) (2 / getWindowY w)
displayInv :: Int -> World -> [Picture]
displayInv n w = displayListTopLeft scols w
@@ -78,14 +78,14 @@ displayListCoords :: World -> [Point2]
displayListCoords w = map (g . f) [1..]
where
f i = ( 15 - halfWidth w , halfHeight w - (20 * fromIntegral i) )
g (x,y) = (2*x / _windowX w, 2*y / _windowY w)
g (x,y) = (2*x / getWindowX w, 2*y / getWindowY w)
displayListEndCoords :: World -> [String] -> [Point2]
displayListEndCoords w ss = map g $ zipWith h ss $ map f [1..]
where
f :: Int -> Point2
f i = ( 15 - halfWidth w , 2.5 + halfHeight w - (20 * fromIntegral i) )
g (x,y) = (2*x / _windowX w, 2*y / _windowY w)
g (x,y) = (2*x / getWindowX w, 2*y / getWindowY w)
h :: String -> Point2 -> Point2
h s (x,y) = (x + 9 * fromIntegral (length s), y)
@@ -107,16 +107,16 @@ mapWall w wl =
(x:y:_) = _wlLine wl
c = _wlColor wl
{- Pictures of popup text for items close to your position.-}
{- | Pictures of popup text for items close to your position.-}
closeObjectTexts :: World -> Picture
closeObjectTexts w = pictures $ zipWith renderList [0..] (map colAndText $ _closeActiveObjects w)
++ maybeToList maybeLine
where
colAndText (Left x) = (_itInvColor $ _flIt x, _itName $ _flIt x)
colAndText (Right x) = (white, _btText x)
renderList i (c,t) = scale (2/_windowX w) (2/_windowY w)
renderList i (c,t) = scale (2/getWindowX w) (2/getWindowY w)
. tran
. translate (xtran i) (0 - 20 * fromIntegral i)
. translate (xtran i) (negate (20 * fromIntegral i))
. scale 0.1 0.1
. color c
$ text t
@@ -135,7 +135,7 @@ closeObjectTexts w = pictures $ zipWith renderList [0..] (map colAndText $ _clos
objPos obj = case obj of Left flit -> _flItPos flit
Right bt -> _btPos bt
mayScreenPos = mayObj >>= (\theObj -> Just (worldPosToScreen w $ objPos theObj))
sc (x, y) = (x*2/_windowX w, y*2/_windowY w)
sc (x, y) = (x*2/getWindowX w, y*2/getWindowY w)
maybeLine = do
itScreenPos <- mayScreenPos
theText <- fmap (snd . colAndText) mayObj
@@ -153,7 +153,7 @@ closeObjectTexts w = pictures $ zipWith renderList [0..] (map colAndText $ _clos
,(sc p , col)
]
{- Add coloured drop shadow. -}
{- | Add coloured drop shadow. -}
dShadCol :: Color -> Picture -> Picture
dShadCol c p = pictures
[ color black $ uncurry translate (1.2,-1.2) p
@@ -161,7 +161,7 @@ dShadCol c p = pictures
]
drawListCursor :: Color -> Int -> World -> Picture
drawListCursor c iPos w = scale (2 / _windowX w) (2 / _windowY w)
drawListCursor c iPos w = scale (2 / getWindowX w) (2 / getWindowY w)
. translate (105-halfWidth w) (halfHeight w - (20* fromIntegral iPos) - 20)
$ lineCol [(( 100,12.5) ,withAlpha 0 c)
,((-100,12.5) ,c)
src/Dodge/Render/MenuScreen.hs
+4 -4
View File
@@ -50,13 +50,13 @@ menuScreen cfig hw hh mLays = case mLays of
,tst (-100) 100 0.4 "CONTROLS"
,controlsList
]
(ConfigSaveScreen : _) -> optionsList hw hh "SAVING..." []
(WaitMessage s : _) -> optionsList hw hh s []
_ -> blank
where
tst x y sc t = translate x y $ scale sc sc $ color white $ text t
mavol = f $ _volume_master $ cfig
snvol = f $ _volume_sound $ cfig
muvol = f $ _volume_music $ cfig
mavol = f $ _volume_master cfig
snvol = f $ _volume_sound cfig
muvol = f $ _volume_music cfig
f x = show $ round $ 10 * x
showShadRes i = "1/"++ show i
src/Dodge/Render/Picture.hs
+2 -2
View File
@@ -34,12 +34,12 @@ fixedCoordPictures w = pictures
, customMouseCursor w
]
where
scaler = setDepth (-1) . scale (2 / _windowX w) (2 / _windowY w)
scaler = setDepth (-1) . scale (2 / getWindowX w) (2 / getWindowY w)
customMouseCursor :: World -> Picture
customMouseCursor w =
setDepth (-1)
. scale (2 /_windowX w) (2/ _windowY w)
. scale (2 /getWindowX w) (2/ getWindowY w)
. uncurry translate (_mousePos w)
$ pictures [ line [(-5,0),(5,0)] , line [(0,-5),(0,5)] ]
src/Dodge/Room/RoadBlock.hs
+6 -7
View File
@@ -43,7 +43,7 @@ litCorridor90 = do
[ PS (20,h-5) 0 putLamp
, windowLine (0,h-20) (40,h-20)
, PS (-50,h-85) 0 putLamp
, windowLine (0-40,h-60) (0-40,h-100)
, windowLine (-40,h-60) (-40,h-100)
, PS ( 20,h-40) 0 $ PutID 0
, PS (-20,h-80) 0 $ PutID 2
]
@@ -61,10 +61,10 @@ longBlockedCorridor = do
n <- state $ randomR (0,3)
let plmnts = [PS (20,40) r $ PutBlock [5,5,5] (150/256, 75/256, 0, 250/256)
$ reverse $ rectNSWE 10 (-10) (-10) 10
,PS (20,15) 0 $ putLamp
,PS (20,15) 0 putLamp
]
sequence $ treeFromPost (replicate n $ fmap Left $ randomiseOutLinks corridor)
$ fmap Right $ return $ set rmPS plmnts corridor
sequence $ treeFromPost (replicate n $ Left <$> randomiseOutLinks corridor)
$ return $ Right $ set rmPS plmnts corridor
-- | A single corridor with a descrutible block blocking it.
blockedCorridor :: RandomGen g => State g (Tree (Either Room Room))
@@ -72,7 +72,6 @@ blockedCorridor = do
r <- state $ randomR (0,pi)
let plmnts = [PS (20,40) r $ PutBlock [5,5,5] (150/256, 75/256, 0, 250/256)
$ reverse $ rectNSWE 10 (-10) (-10) 10
,PS (20,15) 0 $ putLamp
,PS (20,15) 0 putLamp
]
sequence $ treeFromPost []
$ fmap Right $ return $ set rmPS plmnts corridor
sequence $ treeFromPost [] $ return $ Right $ set rmPS plmnts corridor
src/Dodge/Update.hs
+16 -16
View File
@@ -7,6 +7,8 @@ module Dodge.Update
) where
import Dodge.Data
import Dodge.Data.Menu
import Dodge.Config.Data
import Dodge.Data.Menu
import Dodge.Base
import Dodge.WallCreatureCollisions
import Dodge.LevelGen.Block
@@ -40,7 +42,7 @@ In such menus, the only way to change the world is using event handling.
-}
update' :: World -> World
update' w = case _menuLayers w of
(ConfigSaveScreen : ls) -> w & menuLayers .~ ls
(WaitMessage _ : ls) -> w & menuLayers .~ ls
(_ : _) -> w
[] -> let w1 = updateParticles
. updateProjectiles
@@ -53,13 +55,13 @@ update' w = case _menuLayers w of
. updateSoundQueue
$ updateCloseObjects w
in checkEndGame
. triggerUpdate
. updateTriggers
. ppEvents
. updateCamera
. colCrsWalls
. simpleCrSprings
. zoneCreatures
. wallEvents
. updateWalls
. set worldEvents id
$ _worldEvents w1 w1
where
@@ -72,16 +74,15 @@ update' w = case _menuLayers w of
where (x,y) = zoneOfPoint $ _clPos cr
cid = _clID cr
triggerUpdate :: World -> World
triggerUpdate w
updateTriggers :: World -> World
updateTriggers w
| ResetLevel 1 `S.member` _worldTriggers w
= generateFromList levx
$ initialWorld
& randGen .~ _randGen w
& windowX .~ _windowX w
& windowY .~ _windowY w
& menuLayers .~ []
& creatures . ix 0 .~ (_creatures w IM.! 0 & crPos .~ (0,0))
& randGen .~ _randGen w
& config .~ _config w
& menuLayers .~ []
& creatures . ix 0 . crPos .~ (0,0)
| otherwise = w
updateSoundQueue = set soundQueue [] . set sounds M.empty
@@ -107,12 +108,11 @@ updateCreatures w = f $ set randGen newG $ set creatures (IM.mapMaybe id crs) w
((f,newG),crs) = IM.mapAccum (\g' cr -> _crUpdate cr w g' cr) (id,_randGen w)
$ _creatures w
wallEvents :: World -> World
wallEvents w = IM.foldr (_doorMech) w ( IM.filter (\d -> case d of
Door {} -> True
BlockAutoDoor {} -> True
_ -> False) ( _walls w))
{- |
Apply door mechanisms.
-}
updateWalls :: World -> World
updateWalls w = IM.foldr (maybe id id . (^? doorMech)) w (_walls w)
ppEvents :: World -> World
ppEvents w = IM.foldr (\pp w -> _ppEvent pp pp w) w $ _pressPlates w
src/Dodge/Update/Camera.hs
+2 -2
View File
@@ -1,8 +1,7 @@
{-
Functions controlling the movement of the screen camera:
'_cameraCenter', '_cameraZoom', _cameraRot';
and the position that the character sees from: '_cameraViewFrom'.
-}
and the position that the character sees from: '_cameraViewFrom'. -}
module Dodge.Update.Camera
( updateCamera
)
@@ -10,6 +9,7 @@ module Dodge.Update.Camera
import Dodge.Data
import Dodge.Base
import Dodge.Config.KeyConfig
import Dodge.Item.Attachment.Data
import Geometry
import Control.Lens
src/Picture/Preload.hs
+11 -11
View File
@@ -18,17 +18,17 @@ import Foreign
import qualified Control.Foldl as F
data RenderData = RenderData
{ _lightingFloorShader :: FullShader (Float,Float,Float,Float)
, _lightingOccludeShader :: FullShader (Point2,Point2)
, _lightingWallShader :: FullShader (Point2,Point2)
, _wallBlankShader :: FullShader ((Point2,Point2),Point4)
, _wallTextureShader :: FullShader ((Point2,Point2),Point4)
, _backgroundShader :: FullShader (Point2,Point2,Point2,Point2)
, _fullscreenShader :: FullShader ()
, _pictureShaders :: [FullShader RenderType]
, _spareFBO :: FramebufferObject
, _fboTexture :: TextureObject
, _fboRenderbufferObject :: RenderbufferObject
{ _lightingFloorShader :: FullShader (Float,Float,Float,Float)
, _lightingOccludeShader :: FullShader (Point2,Point2)
, _lightingWallShader :: FullShader (Point2,Point2)
, _wallBlankShader :: FullShader ((Point2,Point2),Point4)
, _wallTextureShader :: FullShader ((Point2,Point2),Point4)
, _backgroundShader :: FullShader (Point2,Point2,Point2,Point2)
, _fullscreenShader :: FullShader ()
, _pictureShaders :: [FullShader RenderType]
, _spareFBO :: FramebufferObject
, _fboTexture :: TextureObject
, _fboRenderbufferObject :: RenderbufferObject
}
makeLenses ''RenderData
src/Preload/Update.hs
+2 -2
View File
@@ -18,8 +18,8 @@ resizeSpareFBO xsize ysize pdata = do
fboName = _spareFBO rdata
fboTO = _fboTexture rdata
fboRBO = _fboRenderbufferObject rdata
xsize' = fromIntegral $ xsize
ysize' = fromIntegral $ ysize
xsize' = fromIntegral xsize
ysize' = fromIntegral ysize
bindFramebuffer Framebuffer $= fboName
textureBinding Texture2D $= Just fboTO
texImage2D Texture2D NoProxy 0 RGBA8 (TextureSize2D xsize' ysize') 0 (PixelData RGBA UnsignedByte nullPtr)
src/Shader/Data.hs
+5 -5
View File
@@ -1,12 +1,12 @@
{-# LANGUAGE TemplateHaskell #-}
{-
{- |
Datatypes used to setup and pass data to shaders.
-}
module Shader.Data
( VAO (..)
, FullShader (..)
, ShaderTexture (..)
-- lens functions
-- | Lens functions
, vao
, vaoBufferTargets
@@ -23,14 +23,14 @@ module Shader.Data
import Graphics.Rendering.OpenGL
import Foreign
import Control.Lens
{- Vertex array object: contains the reference to the object,
{- | Vertex array object: contains the reference to the object,
and its buffer targets.
-}
data VAO = VAO
{ _vao :: VertexArrayObject
, _vaoBufferTargets :: [(BufferObject,Ptr Float,Int)]
}
{-
{- |
Datatype containing the necessary information for a single shader.
-}
data FullShader a = FullShader
@@ -42,7 +42,7 @@ data FullShader a = FullShader
, _shaderTexture :: Maybe ShaderTexture
, _shaderCustomUnis :: Maybe [UniformLocation]
}
{-
{- |
Datatype containing the reference to a texture object.
-}
newtype ShaderTexture = ShaderTexture