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

Cleanup creature picture

Browse Source
This commit is contained in:
justin
2021-09-04 14:53:05 +01:00
parent 1ab3f1773c
commit 215a3dda36
13 changed files with 318 additions and 307 deletions
Download Patch File Download Diff File Expand all files Collapse all files
src/Dodge/Config/Data.hs
+1 -4
View File
@@ -18,7 +18,6 @@ import Data.Aeson
import GHC.Generics import GHC.Generics
--import System.Directory --import System.Directory
import Control.Lens import Control.Lens
data Configuration = Configuration data Configuration = Configuration
{ _volume_master :: Float { _volume_master :: Float
, _volume_sound :: Float , _volume_sound :: Float
@@ -30,7 +29,6 @@ data Configuration = Configuration
, _windowY :: Float , _windowY :: Float
} }
deriving (Generic, Show) deriving (Generic, Show)
makeLenses ''Configuration makeLenses ''Configuration
instance ToJSON Configuration where instance ToJSON Configuration where
@@ -43,10 +41,9 @@ defaultConfig = Configuration
{ _volume_master = 1 { _volume_master = 1
, _volume_sound = 1 , _volume_sound = 1
, _volume_music = 1 , _volume_music = 1
, _wall_textured = False , _wall_textured = True
, _cloud_shadows = True , _cloud_shadows = True
, _resolution_factor = 1 , _resolution_factor = 1
, _windowX = 800 , _windowX = 800
, _windowY = 600 , _windowY = 600
} }
src/Dodge/Creature/Picture.hs
+89 -76
View File
@@ -15,10 +15,9 @@ import Dodge.Creature.Test
--import Dodge.Creature.AlertLevel.Data --import Dodge.Creature.AlertLevel.Data
--import Dodge.Picture.Layer --import Dodge.Picture.Layer
import Dodge.Item.Data import Dodge.Item.Data
import Dodge.Base.Window
import Picture import Picture
import Geometry import Geometry
import Geometry.Vector3D --import Geometry.Vector3D
import Control.Lens import Control.Lens
import Data.List import Data.List
@@ -28,24 +27,28 @@ basicCrPict
-> Creature -> Creature
-> World -> World
-> Picture -> Picture
basicCrPict col cr w basicCrPict col cr w = setLayer 0 $ pictures $
| dist (_crPos cr) (_cameraCenter w) > 1.5 * max (getWindowX w) (getWindowY w) = blank targetingPic ++
| otherwise = setLayer 0 $ pictures $ [ tr . dm . rotdir $ scalp cr
targetingPic ++ , tr . dm . rotdir $ upperBody col cr
[ tr . setDepth 0 $ color yellow $ circleSolid 10 , tr . dm . rotmdir $ feet cr
, tr . piercingMod $ bluntScale $ naked col cr , tr . rotdir $ drawEquipment cr
, tr $ torso (light4 col) (V2 0 (-crad)) (V2 0 crad) ]
, trFeet $ feet cr
, tr $ arms col cr
, tr $ drawEquipment cr
]
where where
crad = _crRad cr dm = damageMod cr
targetingPic = IM.elems $ IM.mapMaybeWithKey f $ _crInv cr targetingPic = IM.elems $ IM.mapMaybeWithKey f $ _crInv cr
f invid it = fmap ((\g -> g invid it cr w) . snd) (it ^? itTargeting . _Just) f invid it = fmap ((\g -> g invid it cr w) . snd) (it ^? itTargeting . _Just)
tr = uncurryV translate (_crPos cr) . rotate (_crDir cr) tr = uncurryV translate (_crPos cr)
trFeet = uncurryV translate (_crPos cr) . rotate (_crMvDir cr) rotdir = rotate (_crDir cr)
rotmdir = rotate (_crMvDir cr)
. setDepth 1
. color (greyN 0.3)
damageMod :: Creature -> Picture -> Picture
damageMod cr pic = piercingMod $ bluntScale pic
where
cdir = _crDir cr cdir = _crDir cr
pastDams = _crPastDamage $ _crState cr
bluntDam :: Maybe Point2 bluntDam :: Maybe Point2
bluntDam = find isBluntDam (concat pastDams) >>= (\dm -> (-.-) <$> dm ^? dmFrom <*> dm ^? dmTo) bluntDam = find isBluntDam (concat pastDams) >>= (\dm -> (-.-) <$> dm ^? dmFrom <*> dm ^? dmTo)
bluntScale = case fmap argV bluntDam of bluntScale = case fmap argV bluntDam of
@@ -59,94 +62,104 @@ basicCrPict col cr w
piercingMod = case fmap argV piercingDam of piercingMod = case fmap argV piercingDam of
Just a -> rotate (a + cdir) . scale 0.8 1.2 . rotate (negate $ cdir + a) Just a -> rotate (a + cdir) . scale 0.8 1.2 . rotate (negate $ cdir + a)
_ -> id _ -> id
pastDams = _crPastDamage $ _crState cr
feet :: Creature -> Picture feet :: Creature -> Picture
feet cr = case cr ^? crStance . carriage of feet cr = case cr ^? crStance . carriage of
Just (Walking sa LeftForward) -> setL Just (Walking sa LeftForward) -> pictures
[ translate (f sa) off $ circleSolid 5 [ translate ( f sa) off aFoot
, translate (-f sa) (-off) $ circleSolid 5 , translate (-f sa) (-off) aFoot
] ]
Just (Walking sa RightForward) -> setL Just (Walking sa RightForward) -> pictures
[ translate (-f sa) off $ circleSolid 5 [ translate (-f sa) off aFoot
, translate (f sa) (-off) $ circleSolid 5 , translate ( f sa) (-off) aFoot
] ]
_ -> setL _ -> pictures
[ translate 0 off $ circleSolid 5 [ translate 0 off aFoot
, translate 0 (-off) $ circleSolid 5 , translate 0 (-off) aFoot
] ]
where where
--setL = onLayerL [levLayer CrLayer, -5] . color (greyN 0.3) . pictures aFoot = circleSolid 4
setL = setDepth 1 . color (greyN 0.3) . pictures
off = 5 off = 5
sLen = _strideLength $ _crStance cr sLen = _strideLength $ _crStance cr
f i = 6 * fromIntegral (sLen - i) / fromIntegral sLen f i = 6 * fromIntegral (sLen - i) / fromIntegral sLen
arms :: Color -> Creature -> Picture arms :: Creature -> Picture
arms col cr arms cr
| aimingTwist = blank | oneH cr = shoulderH . translate 11 (-3) . rotate (-0.5) $ scale 1 1.5 aHand
| twists cr = shoulderH . translate 0 (0.5* crad) . rotate (-1) $ pictures
[ translate 12 4 aHand
, translate 4 (-10) aHand
]
| otherwise = case cr ^? crStance . carriage of | otherwise = case cr ^? crStance . carriage of
Just (Walking sa LeftForward) -> setL Just (Walking sa LeftForward) -> waistH $ translate (-f sa) (-off) aHand
[ translate (-f sa) (-off) . sc $ circleSolid 4 Just (Walking sa RightForward) -> waistH $ translate (-f sa) off aHand
]
Just (Walking sa RightForward) -> setL
[ translate (-f sa) off . sc $ circleSolid 4
]
_ -> blank _ -> blank
where where
sc = scale 1 1 aHand = circleSolid 4
--setL = onLayerL [levLayer CrLayer, -4] . color (light4 col) . pictures crad = _crRad cr
setL = setDepth 20 . color (light4 col) . pictures
off = 8 off = 8
sLen = _strideLength $ _crStance cr sLen = _strideLength $ _crStance cr
f i = negate 2 + negate 6 * fromIntegral (sLen - i) / fromIntegral sLen f i = negate 2 + negate 6 * fromIntegral (sLen - i) / fromIntegral sLen
aimingTwist = crIsAiming' cr -- && crIt ^? itAimStance == Just TwoHandTwist
--crIt = _crInv cr IM.! _crInvSel cr
torso :: Color -> Point2 -> Point2 -> Picture scalp :: Creature -> Picture
torso col x y = color col $ pictures scalp cr
[ poly3 [addZ 20 x, addZ 12 v, addZ 12 (V2 0 0 -.- v), addZ 20 y] | twists cr = translate 0 (0.5*crad) . rotate (-1) $ translate (negate 0.25 * crad) 0.25 fhead
, setDepth 12 . rotate a . scale 1 1 $ circleSolid $ magV v | oneH cr = rotate 0.5 $ translate (0.25 * crad) 0 fhead
] | otherwise = translate (0.25 * crad) 0 fhead
where where
v = 0.25 *.* (x -.- y) fhead = setDepth 22 $ circleSolid $ crad * 0.5
a = argV v crad = _crRad cr
oneH :: Creature -> Bool
oneH cr = crIsAiming' cr && crIt ^? itAimStance == Just OneHand
where
crIt = _crInv cr IM.! _crInvSel cr
twists :: Creature -> Bool
twists cr = crIsAiming' cr && crIt ^? itAimStance == Just TwoHandTwist
where
crIt = _crInv cr IM.! _crInvSel cr
torso :: Creature -> Picture
torso cr
| oneH cr = rotate 0.5 $ pictures
[ translate 0 3 . rotate (negate 0.2) $ aShoulder
, translate 0 (negate 3) . rotate 0.2 $ aShoulder
]
| twists cr = translate 0 (0.5* crad) . rotate (-1) $ pictures
[ rotate (negate 0.2) . translate 2 3 . rotate (negate 0.4) $ aShoulder
, rotate (negate 0.2) . translate 0 (negate 3) . rotate 0.2 $ aShoulder
]
| otherwise = pictures
[ translate 0 3 . rotate (negate 0.2) $ aShoulder
, translate 0 (negate 3) . rotate 0.2 $ aShoulder
]
where
aShoulder = scale 0.5 1 $ circleSolid crad
crad = _crRad cr
upperBody :: Color -> Creature -> Picture
upperBody col cr = color (light4 col) $ pictures
[ arms cr
, shoulderH $ torso cr
]
naked :: Color -> Creature -> Picture naked :: Color -> Creature -> Picture
naked col cr naked _ cr
| strikeMelee = shoulderH . color white $ circleSolid $ _crRad cr | strikeMelee = shoulderH . color white $ circleSolid $ _crRad cr
| pdam > 200 = shoulderH . color red $ circleSolid $ _crRad cr | pdam > 200 = shoulderH . color red $ circleSolid $ _crRad cr
| pdam > 99 = shoulderH . color white $ circleSolid $ _crRad cr | pdam > 99 = shoulderH . color white $ circleSolid $ _crRad cr
| aimingOneHand = rotate (negate twistA * 0.5) $ pictures | otherwise = []
[ translate (0.25 * crad) 0 fhead
, shoulderH . translate 8 (-8) . color col' $ circleSolid 4
, translate 0 3 . rotate (negate 0.2) . scale 0.5 1 $ color col' $ circleSolid $ _crRad cr
, translate 0 (negate 3) . rotate 0.2 . scale 0.5 1 $ color col' $ circleSolid $ _crRad cr
]
| aimingTwist = translate 0 (0.5* crad) . rotate twistA $ pictures
[ translate (negate 0.25 * crad) 0.25 fhead
, shoulderH . translate 12 4 . color col' $ circleSolid 4
, shoulderH . translate 4 (-10) . color col' $ circleSolid 4
, shoulderH . rotate (negate 0.2) . translate 2 3 . rotate (negate 0.4) . scale 0.5 1 $ color col' $ circleSolid $ _crRad cr
, shoulderH . rotate (negate 0.2) . translate 0 (negate 3) . rotate 0.2 . scale 0.5 1 $ color col' $ circleSolid $ _crRad cr
]
| otherwise = pictures
[ translate (0.25 * crad) 0 fhead
, shoulderH . translate 0 3 . rotate (negate 0.2) . scale 0.5 1 $ color col' $ circleSolid $ _crRad cr
, shoulderH . translate 0 (negate 3) . rotate 0.2 . scale 0.5 1 $ color col' $ circleSolid $ _crRad cr
]
where where
fhead = setDepth 22 $ circleSolid $ crad * 0.5
shoulderH = setDepth 20
twistA = negate 1
aimingOneHand = crIsAiming' cr && crIt ^? itAimStance == Just OneHand
aimingTwist = crIsAiming' cr && crIt ^? itAimStance == Just TwoHandTwist
crIt = _crInv cr IM.! _crInvSel cr
strikeMelee = _crMeleeCooldown cr > 5 strikeMelee = _crMeleeCooldown cr > 5
pdam = sum $ concatMap (map _dmAmount) pastDams pdam = sum $ concatMap (map _dmAmount) pastDams
crad = _crRad cr
pastDams = _crPastDamage $ _crState cr pastDams = _crPastDamage $ _crState cr
col' = light . light . light $ light col
shoulderH :: Picture -> Picture
shoulderH = setDepth 20
waistH :: Picture -> Picture
waistH = setDepth 10
light4 :: Color -> Color light4 :: Color -> Color
light4 = light . light . light . light light4 = light . light . light . light
src/Dodge/Data.hs
+35 -2
View File
@@ -19,7 +19,6 @@ import Dodge.Creature.State.Data
import Dodge.Creature.Stance.Data import Dodge.Creature.Stance.Data
import Dodge.Creature.AlertLevel.Data import Dodge.Creature.AlertLevel.Data
import Dodge.Debug.Flag.Data import Dodge.Debug.Flag.Data
import Dodge.Data.Menu
import Dodge.Data.SoundOrigin import Dodge.Data.SoundOrigin
import Dodge.Data.DamageType import Dodge.Data.DamageType
import Dodge.Config.Data import Dodge.Config.Data
@@ -88,7 +87,7 @@ data World = World
, _pathPoints :: ~(IM.IntMap (IM.IntMap [(Int,Point2)])) , _pathPoints :: ~(IM.IntMap (IM.IntMap [(Int,Point2)]))
, _pathInc :: ~(M.Map Point2 [Point2]) , _pathInc :: ~(M.Map Point2 [Point2])
, _storedLevel :: Maybe World , _storedLevel :: Maybe World
, _menuLayers :: [MenuLayer] , _menuLayers :: [ScreenLayer]
, _worldState :: M.Map WorldState Bool , _worldState :: M.Map WorldState Bool
, _worldTriggers :: S.Set WorldTrigger , _worldTriggers :: S.Set WorldTrigger
, _carteDisplay :: !Bool , _carteDisplay :: !Bool
@@ -110,6 +109,40 @@ data World = World
, _radDistortion :: [(Point2,Point2,Point2,Float)] , _radDistortion :: [(Point2,Point2,Point2,Float)]
, _gameRooms :: [GameRoom] , _gameRooms :: [GameRoom]
} }
data OptionScreenFlag = NormalOptions | GameOverOptions
data ScreenLayer
= OptionScreen
{ _scTitle :: World -> String
, _scOptions :: [MenuOption]
, _scDefaultEff :: World -> Maybe World
, _scOptionFlag :: OptionScreenFlag
}
| InputScreen String
| TerminalScreen Int [(Int,String)]
| WaitScreen
{ _scWaitMessage :: World -> String
, _scWaitTime :: Int
}
| DisplayScreen
{ _scDisplay :: World -> Picture
}
data MenuOption
= Toggle
{ _moKey :: Scancode
, _moEff :: World -> Maybe World
, _moString :: World -> String
}
| Toggle2
{ _moKey1 :: Scancode
, _moEff1 :: World -> Maybe World
, _moKey2 :: Scancode
, _moEff2 :: World -> Maybe World
, _moString :: World -> String
}
| InvisibleToggle
{ _moKey :: Scancode
, _moEff :: World -> Maybe World
}
data InventoryMode data InventoryMode
= TopInventory = TopInventory
| TweakInventory | TweakInventory
src/Dodge/Data/Menu.hs
-15
View File
@@ -1,15 +0,0 @@
{-# LANGUAGE StrictData #-}
module Dodge.Data.Menu
where
data MenuLayer
= LevelMenu Int
| PauseMenu
| GameOverMenu
| OptionMenu
| SoundOptionMenu
| GraphicsOptionMenu
| ControlList
| WaitMessage String Int
| Terminal String
| TerminalMessage Int [(Int,String)]
deriving (Eq,Ord)
src/Dodge/Default/World.hs
+3 -2
View File
@@ -1,12 +1,12 @@
module Dodge.Default.World module Dodge.Default.World
where where
import Dodge.Data import Dodge.Data
import Dodge.Data.Menu
import Dodge.Base import Dodge.Base
import Dodge.Debug.Flag.Data import Dodge.Debug.Flag.Data
import Dodge.Config.Data import Dodge.Config.Data
import Dodge.Config.KeyConfig import Dodge.Config.KeyConfig
import Dodge.Item.Data import Dodge.Item.Data
--import Dodge.Menu
--import Picture --import Picture
import Geometry.Data import Geometry.Data
--import Picture.Texture --import Picture.Texture
@@ -52,7 +52,8 @@ defaultWorld = World
, _corpses = IM.empty , _corpses = IM.empty
, _decorations = IM.empty , _decorations = IM.empty
, _storedLevel = Nothing , _storedLevel = Nothing
, _menuLayers = [LevelMenu 1] --, _menuLayers = [levelMenu 1]
, _menuLayers = []
, _worldState = M.empty , _worldState = M.empty
, _worldTriggers = S.empty , _worldTriggers = S.empty
, _clickMousePos = V2 0 0 , _clickMousePos = V2 0 0
src/Dodge/Event/Keyboard.hs
+6 -10
View File
@@ -6,7 +6,7 @@ module Dodge.Event.Keyboard
) )
where where
import Dodge.Data import Dodge.Data
import Dodge.Data.Menu --import Dodge.Data.Menu
import Dodge.Picture.Layer import Dodge.Picture.Layer
import Dodge.Base import Dodge.Base
import Dodge.Creature.Action import Dodge.Creature.Action
@@ -18,6 +18,7 @@ import Dodge.Creature.Inanimate
import qualified Data.IntMap.Strict as IM import qualified Data.IntMap.Strict as IM
import Dodge.Event.Test import Dodge.Event.Test
import Dodge.Event.Menu import Dodge.Event.Menu
import Dodge.Menu
import SDL import SDL
import Data.Maybe import Data.Maybe
@@ -39,7 +40,7 @@ handleKeyboardEvent kev w = case keyboardEventKeyMotion kev of
handlePressedKey :: Bool -> Scancode -> World -> Maybe World handlePressedKey :: Bool -> Scancode -> World -> Maybe World
handlePressedKey True _ w = Just w handlePressedKey True _ w = Just w
handlePressedKey _ ScancodeSemicolon w | not (inTerminal w) = Just $ gotoTerminal w handlePressedKey _ ScancodeSemicolon w = Just $ gotoTerminal w
handlePressedKey _ scode w handlePressedKey _ scode w
| null (_menuLayers w) = handlePressedKeyInGame scode w | null (_menuLayers w) = handlePressedKeyInGame scode w
| otherwise = handlePressedKeyInMenu (head $ _menuLayers w) scode w | otherwise = handlePressedKeyInMenu (head $ _menuLayers w) scode w
@@ -67,15 +68,10 @@ toggleInv x y
| x == y = TopInventory | x == y = TopInventory
| otherwise = x | otherwise = x
inTerminal :: World -> Bool
inTerminal w = case _menuLayers w of
(Terminal _ : _) -> True
_ -> False
gotoTerminal :: World -> World gotoTerminal :: World -> World
gotoTerminal w = case _menuLayers w of gotoTerminal w = case _menuLayers w of
(Terminal _ : _ ) -> w (InputScreen _ : _ ) -> w
_ -> w & menuLayers %~ (Terminal [] :) _ -> w & menuLayers %~ (InputScreen [] :)
spaceAction :: World -> World spaceAction :: World -> World
spaceAction w = if _carteDisplay w spaceAction w = if _carteDisplay w
@@ -89,7 +85,7 @@ spaceAction w = if _carteDisplay w
updateTopCloseObject i w' = w' & closeActiveObjects %~ ( Right (_buttons w' IM.! i) : ) . tail updateTopCloseObject i w' = w' & closeActiveObjects %~ ( Right (_buttons w' IM.! i) : ) . tail
pauseGame :: World -> World pauseGame :: World -> World
pauseGame w = w {_menuLayers = [PauseMenu]} pauseGame w = w {_menuLayers = [pauseMenu]}
toggleMap :: World -> World toggleMap :: World -> World
toggleMap w = w & carteDisplay %~ not toggleMap w = w & carteDisplay %~ not
src/Dodge/Event/Menu.hs
+20 -49
View File
@@ -2,63 +2,39 @@ module Dodge.Event.Menu
( handlePressedKeyInMenu ( handlePressedKeyInMenu
) where ) where
import Dodge.Data import Dodge.Data
import Dodge.Data.Menu
--import Dodge.Base.Window
--import Dodge.Floor
--import Dodge.Initialisation
import Dodge.SoundLogic
--import Dodge.Config.Data
import Dodge.Config.Update
--import Dodge.Layout
--import Preload.Update
import Dodge.Debug.Terminal import Dodge.Debug.Terminal
import Dodge.Menu import Dodge.Menu
--import Data.Maybe import Control.Monad
--import Data.Foldable
--import qualified Data.Set as S
import Control.Lens import Control.Lens
import SDL import SDL
--import SDL.Internal.Numbered
handlePressedKeyInMenu :: MenuLayer -> Scancode -> World -> Maybe World handlePressedKeyInMenu :: ScreenLayer -> Scancode -> World -> Maybe World
handlePressedKeyInMenu mState scode w = case mState of handlePressedKeyInMenu mState scode = case mState of
TerminalMessage 0 _ -> popMenu w OptionScreen { _scOptions = mos, _scDefaultEff = defeff}
TerminalMessage _ m -> Just $ w & menuLayers %~ ((TerminalMessage 0 m : ) . tail) -> optionListToEffects mos defeff scode
Terminal s -> case scode of DisplayScreen {} -> popScreen
ScancodeEscape -> popMenu w WaitScreen {} -> Just
ScancodeReturn -> popMenu $ applyTerminalString s w TerminalScreen 0 _ -> popScreen
ScancodeBackspace -> popMenu w >>= pushMenu (Terminal $ dropLast s) TerminalScreen _ m -> Just . ( menuLayers %~ ( (TerminalScreen 0 m : ) . tail) )
_ -> popMenu w >>= pushMenu (Terminal $ s ++ [scodeToChar scode]) InputScreen s -> case scode of
LevelMenu _ -> optionListToEffects levelMenuOptions startLevel scode w ScancodeEscape -> popScreen
PauseMenu -> optionListToEffects pauseMenuOptions unpause scode w ScancodeReturn -> popScreen . applyTerminalString s
GameOverMenu -> optionListToEffects pauseMenuOptions pure scode w ScancodeBackspace
OptionMenu -> optionListToEffects optionsOptions popMenu scode w -> popScreen >=> pushScreen (InputScreen $ dropLast s)
SoundOptionMenu -> optionListToEffects _ -> popScreen >=> pushScreen (InputScreen $ s ++ [scodeToChar scode])
soundMenuOptions
( popMenu . writeConfig )
scode
w
GraphicsOptionMenu -> optionListToEffects graphicsMenuOptions (popMenu . writeConfig) scode w
ControlList -> Just $ w & menuLayers %~ tail
_ -> Just w
where where
writeConfig = sideEffects %~ (saveConfig (_config w) :)
unpause w' = Just . resumeSound $ w' {_menuLayers = []}
startLevel = unpause . storeLevel
popMenu w' = Just $ w' & menuLayers %~ tail
dropLast (x:xs) = init (x:xs) dropLast (x:xs) = init (x:xs)
dropLast _ = [] dropLast _ = []
optionListToEffects :: [MenuOption] -> (World -> Maybe World) -> Scancode -> World -> Maybe World optionListToEffects :: [MenuOption] -> (World -> Maybe World) -> Scancode -> World -> Maybe World
optionListToEffects mos eff sc w = case lookup sc listEffects of optionListToEffects mos defaulteff sc w = case lookup sc listEffects of
Nothing -> eff w Nothing -> defaulteff w
Just eff' -> eff' w Just eff -> eff w
where where
listEffects = concatMap menuOptionToEffects mos listEffects = concatMap menuOptionToEffects mos
menuOptionToEffects :: MenuOption -> [(Scancode,World -> Maybe World)] menuOptionToEffects :: MenuOption -> [(Scancode,World -> Maybe World)]
menuOptionToEffects Toggle {_moKey = k, _moEff = eff} = [(k,eff)] menuOptionToEffects Toggle {_moKey = k, _moEff = eff} = [(k,eff)]
menuOptionToEffects InvisibleToggle {_moKey = k, _moEff = eff} = [(k,eff)] menuOptionToEffects InvisibleToggle {_moKey = k, _moEff = eff} = [(k,eff)]
menuOptionToEffects Toggle2 menuOptionToEffects Toggle2
{ _moKey1 = k1 { _moKey1 = k1
@@ -66,8 +42,3 @@ menuOptionToEffects Toggle2
, _moKey2 = k2 , _moKey2 = k2
, _moEff2 = eff2 , _moEff2 = eff2
} = [(k1,eff1) , (k2,eff2)] } = [(k1,eff1) , (k2,eff2)]
storeLevel :: World -> World
storeLevel w = case _storedLevel w of
Nothing -> w & storedLevel ?~ w
_ -> w
src/Dodge/Initialisation.hs
+1 -2
View File
@@ -1,7 +1,6 @@
module Dodge.Initialisation where module Dodge.Initialisation where
import Dodge.Default.World import Dodge.Default.World
import Dodge.Data import Dodge.Data
import Dodge.Data.Menu
import Dodge.Creature import Dodge.Creature
--import Dodge.Base --import Dodge.Base
import Dodge.Floor import Dodge.Floor
@@ -49,7 +48,7 @@ initialWorld = defaultWorld
, _sounds = M.empty , _sounds = M.empty
, _decorations = IM.empty , _decorations = IM.empty
, _storedLevel = Nothing , _storedLevel = Nothing
, _menuLayers = [TerminalMessage 300 rezText'] , _menuLayers = [TerminalScreen 300 rezText']
, _worldState = M.empty , _worldState = M.empty
} }
testStringInit :: World -> [String] testStringInit :: World -> [String]
src/Dodge/Menu.hs
+107 -29
View File
@@ -1,7 +1,6 @@
module Dodge.Menu module Dodge.Menu
where where
import Dodge.Data import Dodge.Data
import Dodge.Data.Menu
import Dodge.Config.Data import Dodge.Config.Data
import Dodge.Config.Update import Dodge.Config.Update
import SDL import SDL
@@ -11,38 +10,37 @@ import Dodge.Floor
import Dodge.Initialisation import Dodge.Initialisation
import Preload.Update import Preload.Update
import Dodge.Base.Window import Dodge.Base.Window
import Dodge.SoundLogic
import Picture
import Geometry
import Control.Lens import Control.Lens
import Data.Maybe import Data.Maybe
optionMenu :: ScreenLayer
data MenuOption optionMenu = OptionScreen
= Toggle { _scTitle = const "OPTIONS"
{ _moKey :: Scancode , _scOptions = optionsOptions
, _moEff :: World -> Maybe World , _scDefaultEff = popScreen
, _moString :: World -> String , _scOptionFlag = NormalOptions
} }
| Toggle2
{ _moKey1 :: Scancode
, _moEff1 :: World -> Maybe World
, _moKey2 :: Scancode
, _moEff2 :: World -> Maybe World
, _moString :: World -> String
}
| InvisibleToggle
{ _moKey :: Scancode
, _moEff :: World -> Maybe World
}
optionsOptions :: [MenuOption] optionsOptions :: [MenuOption]
optionsOptions = optionsOptions =
[ Toggle ScancodeV (pushMenu SoundOptionMenu) (const "VOLUME") [ Toggle ScancodeV (pushScreen soundMenu) (const "VOLUME")
, Toggle ScancodeG (pushMenu GraphicsOptionMenu) (const "GRAPHICS") , Toggle ScancodeG (pushScreen graphicsMenu) (const "GRAPHICS")
] ]
levelMenuOptions :: [MenuOption] levelMenuOptions :: [MenuOption]
levelMenuOptions = levelMenuOptions =
[ InvisibleToggle ScancodeEscape (const Nothing) [ InvisibleToggle ScancodeEscape (const Nothing)
, InvisibleToggle ScancodeO (pushMenu OptionMenu) , InvisibleToggle ScancodeO (pushScreen optionMenu)
, InvisibleToggle ScancodeC (pushMenu ControlList) , InvisibleToggle ScancodeC (pushScreen displayControls)
] ]
soundMenu :: ScreenLayer
soundMenu = OptionScreen
{ _scTitle = const "OPTIONS:VOLUME"
, _scOptions = soundMenuOptions
, _scDefaultEff = popScreen . writeConfig
, _scOptionFlag = NormalOptions
}
soundMenuOptions :: [MenuOption] soundMenuOptions :: [MenuOption]
soundMenuOptions = soundMenuOptions =
[ Toggle2 ScancodeY (master dec . sw) [ Toggle2 ScancodeY (master dec . sw)
@@ -65,9 +63,22 @@ soundMenuOptions =
muvol w = f $ _volume_music $ cfig w muvol w = f $ _volume_music $ cfig w
f x = show (round $ 10 * x :: Int) f x = show (round $ 10 * x :: Int)
pushMenu :: MenuLayer -> World -> Maybe World pushScreen :: ScreenLayer -> World -> Maybe World
pushMenu ml w' = Just $ w' & menuLayers %~ (ml :) pushScreen ml w = Just $ w & menuLayers %~ (ml :)
popScreen :: World -> Maybe World
popScreen = Just . (menuLayers %~ tail)
writeConfig :: World -> World
writeConfig w = w & sideEffects %~ (saveConfig (_config w) :)
graphicsMenu :: ScreenLayer
graphicsMenu = OptionScreen
{ _scTitle = const "OPTIONS:GRAPHICS"
, _scOptions = graphicsMenuOptions
, _scDefaultEff = popScreen . writeConfig
, _scOptionFlag = NormalOptions
}
graphicsMenuOptions :: [MenuOption] graphicsMenuOptions :: [MenuOption]
graphicsMenuOptions = graphicsMenuOptions =
[ Toggle ScancodeW (Just . (config . wall_textured %~ not)) wtextstring [ Toggle ScancodeW (Just . (config . wall_textured %~ not)) wtextstring
@@ -86,18 +97,32 @@ cycleResolution 2 = 4
cycleResolution 4 = 1 cycleResolution 4 = 1
cycleResolution _ = 1 cycleResolution _ = 1
gameOverMenu :: ScreenLayer
gameOverMenu = OptionScreen
{ _scTitle = const "GAME OVER"
, _scOptions = pauseMenuOptions
, _scDefaultEff = Just
, _scOptionFlag = GameOverOptions
}
pauseMenu :: ScreenLayer
pauseMenu = OptionScreen
{ _scTitle = const "PAUSED"
, _scOptions = pauseMenuOptions
, _scDefaultEff = unpause
, _scOptionFlag = NormalOptions
}
pauseMenuOptions :: [MenuOption] pauseMenuOptions :: [MenuOption]
pauseMenuOptions = pauseMenuOptions =
[ Toggle ScancodeN startNewGame (const "NEW LEVEL") [ Toggle ScancodeN startNewGame (const "NEW LEVEL")
, Toggle ScancodeR (\w -> return $ fromMaybe w $ _storedLevel w) (const "RESTART") , Toggle ScancodeR (\w -> return $ fromMaybe w $ _storedLevel w) (const "RESTART")
, Toggle ScancodeO (pushMenu OptionMenu ) (const "OPTIONS") , Toggle ScancodeO (pushScreen optionMenu ) (const "OPTIONS")
, Toggle ScancodeC (pushMenu ControlList) (const "CONTROLS") , Toggle ScancodeC (pushScreen displayControls) (const "CONTROLS")
, InvisibleToggle ScancodeEscape (const Nothing) , InvisibleToggle ScancodeEscape (const Nothing)
] ]
startNewGame :: World -> Maybe World startNewGame :: World -> Maybe World
startNewGame w = Just $ w startNewGame w = Just $ w
& menuLayers .~ [WaitMessage "GENERATING..." 1] & menuLayers .~ [WaitScreen (const "GENERATING...") 1]
& worldEvents .~ const aNewGame & worldEvents .~ const aNewGame
where where
aNewGame :: World aNewGame :: World
@@ -118,3 +143,56 @@ updateFramebufferSize w = w & sideEffects
where where
(x,y) = (round $ getWindowX w, round $ getWindowY w) (x,y) = (round $ getWindowX w, round $ getWindowY w)
divRes = w ^. config . resolution_factor divRes = w ^. config . resolution_factor
levelMenu :: Int -> ScreenLayer
levelMenu x = OptionScreen
{ _scTitle = const $ "LEVEL "++ show x
, _scOptions = levelMenuOptions
, _scDefaultEff = unpause . storeLevel
, _scOptionFlag = NormalOptions
}
unpause :: World -> Maybe World
unpause w = Just . resumeSound $ w {_menuLayers = []}
storeLevel :: World -> World
storeLevel w = case _storedLevel w of
Nothing -> w & storedLevel ?~ w
_ -> w
displayControls :: ScreenLayer
displayControls = DisplayScreen
{_scDisplay = \w -> pictures
[color (withAlpha 0.5 black) $ polygon $ screenBox w
,tst (-100) 100 0.4 "CONTROLS"
,controlsList
]
}
where
tst x y sc t = translate x y $ scale sc sc $ color white $ text t
controlsList :: Picture
controlsList = pictures $ concat $ zipWith butAndEff
[("wasd", "movement")
,("[rmb]", "aim")
,("[rmb+lmb]", "shoot or use item")
,("[wheelscroll]" , "select item" )
,("[space]" , "pickup item" )
,("m" , "display map" )
,("f" , "drop item" )
,("c[esc]" , "pause" )
,("qe" , "rotate camera")
]
[60,30..]
where
butAndEff (btext,etext) y =
[translate (-250) y $ scale 0.15 0.15 $ color white $ text btext
,translate 0 y $ scale 0.15 0.15 $ color white $ text etext
]
screenBox
:: World
-> [Point2]
screenBox w = rectNSEW hh (-hh) hw (-hw)
where
hw = halfWidth w
hh = halfHeight w
src/Dodge/Render.hs
+15 -17
View File
@@ -121,7 +121,7 @@ doDrawing pdata w = do
textureBinding Texture2D $= Just (snd $ _fboBloom pdata) textureBinding Texture2D $= Just (snd $ _fboBloom pdata)
blend $= Disabled blend $= Disabled
drawShader (_bloomBlurShader pdata) 4 drawShader (_bloomBlurShader pdata) 4
replicateM_ 5 $ pingPongBetween (_fboHalf1 pdata) (_fboHalf2 pdata) (_bloomBlurShader pdata) replicateM_ 9 $ pingPongBetween (_fboHalf1 pdata) (_fboHalf2 pdata) (_bloomBlurShader pdata)
blend $= Enabled blend $= Enabled
setViewportSize (round winx `div` resFact) (round winy `div` resFact) setViewportSize (round winx `div` resFact) (round winy `div` resFact)
--draw clouds --draw clouds
@@ -137,22 +137,20 @@ doDrawing pdata w = do
clear [ColorBuffer] clear [ColorBuffer]
renderLayer 2 shadV layerCounts renderLayer 2 shadV layerCounts
renderWindows pdata windowPoints renderWindows pdata windowPoints
if (_cloud_shadows $ _config w) when (_cloud_shadows $ _config w) $ do
then do ----render transparency depths
----render transparency depths depthMask $= Enabled
depthMask $= Enabled blend $= Disabled
blend $= Disabled drawBuffers $= [NoBuffers,FBOColorAttachment 1]
drawBuffers $= [NoBuffers,FBOColorAttachment 1] renderLayer 2 shadV layerCounts
renderLayer 2 shadV layerCounts renderWindows pdata windowPoints
renderWindows pdata windowPoints ----draw lightmap for cloud buffer
----draw lightmap for cloud buffer depthMask $= Disabled
depthMask $= Disabled blend $= Enabled
blend $= Enabled bindFramebuffer Framebuffer $= fst (_fboLighting pdata)
bindFramebuffer Framebuffer $= fst (_fboLighting pdata) createLightMap pdata lightPoints nWalls nSils nCaps (snd $ snd $ _fboCloud pdata)
createLightMap pdata lightPoints nWalls nSils nCaps (snd $ snd $ _fboCloud pdata) colorMask $= Color4 Enabled Enabled Enabled Enabled
colorMask $= Color4 Enabled Enabled Enabled Enabled clearColor $= Color4 0 0 0 0
clearColor $= Color4 0 0 0 0
else return ()
--apply lightmap to cloud buffer --apply lightmap to cloud buffer
clearColor $= Color4 0 0 0 0 clearColor $= Color4 0 0 0 0
bindFramebuffer Framebuffer $= fst (_fboCloud pdata) bindFramebuffer Framebuffer $= fst (_fboCloud pdata)
src/Dodge/Render/MenuScreen.hs
+24 -81
View File
@@ -5,56 +5,41 @@ module Dodge.Render.MenuScreen
( menuScreen ( menuScreen
) )
where where
import Dodge.Data.Menu
import Dodge.Data import Dodge.Data
--import Dodge.Config.Update --import Dodge.Config.Update
--import Dodge.Config.Data --import Dodge.Config.Data
import Dodge.Base.Window import Dodge.Base.Window
import Picture import Picture
import Geometry
import Dodge.Menu import Dodge.Menu
--import Geometry.Data
menuScreen menuScreen
:: World :: World
-> [MenuLayer] -> ScreenLayer
-> Picture -> Picture
menuScreen w mLays = case mLays of menuScreen w screen = case screen of
(LevelMenu x:_) -> optionsFromList w ("LEVEL"++show x) levelMenuOptions OptionScreen {_scTitle = titf, _scOptions = mos}
(PauseMenu : _) -> optionsFromList w "PAUSED" pauseMenuOptions -> drawOptions w (titf w) mos
(GameOverMenu : _) -> optionsFromList w "GAME OVER" pauseMenuOptions (WaitScreen sf _) -> drawOptions w (sf w) []
(OptionMenu : _) -> optionsFromList w "OPTIONS" optionsOptions (InputScreen s) -> drawOptions w ('>':s) []
(SoundOptionMenu : _) -> optionsFromList w "OPTIONS:VOLUME" soundMenuOptions (TerminalScreen t xs ) -> displayStringList w $ map snd $ filter (( > t) . fst) xs
(GraphicsOptionMenu : _) -> optionsFromList w "OPTIONS:GRAPHICS" graphicsMenuOptions (DisplayScreen sd ) -> sd w
(ControlList : _) -> pictures
[color (withAlpha 0.5 black) $ polygon $ screenBox hw hh
,tst (-100) 100 0.4 "CONTROLS"
,controlsList
]
(WaitMessage s _ : _) -> optionsList hw hh s []
(Terminal s : _) -> optionsList hw hh "SCANCODE INPUT" ['>':s ++ "_"]
(TerminalMessage t xs : _) -> displayStringList hw hh $ map snd $ filter (( > t) . fst) xs
_ -> blank
where
tst x y sc t = translate x y $ scale sc sc $ color white $ text t
hh = halfHeight w
hw = halfWidth w
displayStringList :: Float -> Float -> [String] -> Picture displayStringList :: World -> [String] -> Picture
displayStringList hw hh ss = pictures displayStringList w ss = pictures
( polygon (rectNSEW hh (-hh) hw (-hw)) ( polygon (screenBox w)
: zipWith f ys ss : zipWith f ys ss
) )
where where
hw = halfWidth w
ys = [0,22..] ys = [0,22..]
f y s = translate (10-hw) y . scale 0.15 0.15 $ text s f y s = translate (10-hw) y . scale 0.15 0.15 $ text s
optionsFromList drawOptions
:: World :: World
-> String -- ^ Title -> String -- ^ Title
-> [MenuOption] -- ^ Options -> [MenuOption] -- ^ Options
-> Picture -> Picture
optionsFromList w title ops = pictures $ drawOptions w title ops = pictures $
[darkenBackground [darkenBackground
,theTitle] ,theTitle]
++ ++
@@ -64,59 +49,17 @@ optionsFromList w title ops = pictures $
notInvisible InvisibleToggle {} = False notInvisible InvisibleToggle {} = False
notInvisible _ = True notInvisible _ = True
placeString x y sc t = translate x y $ scale sc sc $ color white $ text t placeString x y sc t = translate x y $ scale sc sc $ color white $ text t
darkenBackground = color (withAlpha 0.5 black) $ polygon $ screenBox hw hh darkenBackground = color (withAlpha 0.5 black) $ polygon $ screenBox w
theTitle = placeString (-hw + 30) (hh - 50) 0.4 title theTitle = placeString (-hw + 30) (hh - 50) 0.4 title
hh = halfHeight w hh = halfHeight w
hw = halfWidth w hw = halfWidth w
menuOptionToString :: World -> MenuOption -> String menuOptionToString :: World -> MenuOption -> String
menuOptionToString w mo@(Toggle{}) menuOptionToString w mo = theKeys ++ _moString mo w
= (scodeToChar $ _moKey mo) : ':' : _moString mo w
menuOptionToString w mo@(Toggle2{})
= (scodeToChar $ _moKey1 mo) : '/' : (scodeToChar $ _moKey2 mo) : ':' : _moString mo w
menuOptionToString _ _ = "undefined option string"
optionsList
:: Float -- ^ Half screen width
-> Float -- ^ Half screen height
-> String -- ^ Title
-> [String] -- ^ Options
-> Picture
optionsList hw hh tit ops = pictures $
[color (withAlpha 0.5 black) $ polygon $ screenBox hw hh
,placeString (-hw + 30) (hh - 50) 0.4 tit]
++
zipWith (\ s vpos -> placeString (-hw + 50) vpos 0.2 s) ops [hh-100,hh-150 ..]
where where
placeString x y sc t = translate x y $ scale sc sc $ color white $ text t theKeys :: String
theKeys = case mo of
controlsList :: Picture Toggle {_moKey = k} -> stc k : ":"
controlsList = pictures $ concat $ zipWith butAndEff Toggle2 {_moKey1 = k1, _moKey2 = k2} -> stc k1 : '/' : stc k2 : ":"
[("wasd", "movement") _ -> undefined
,("[rmb]", "aim") stc = scodeToChar
,("[rmb+lmb]", "shoot or use item")
,("[wheelscroll]" , "select item" )
,("[space]" , "pickup item" )
,("m" , "display map" )
,("f" , "drop item" )
,("c[esc]" , "pause" )
,("qe" , "rotate camera")
]
[60,30..]
where
butAndEff (btext,etext) y =
[translate (-250) y $ scale 0.15 0.15 $ color white $ text btext
,translate 0 y $ scale 0.15 0.15 $ color white $ text etext
]
screenBox
:: Float -- ^ Half screen width
-> Float -- ^ Half screen height
-> [Point2]
screenBox halfW halfH = map toV2
[ (halfW, halfH)
, (-halfW, halfH)
, (-halfW,-halfH)
, ( halfW,-halfH)
]
src/Dodge/Render/Picture.hs
+11 -14
View File
@@ -1,4 +1,4 @@
{-# LANGUAGE TupleSections #-} --{-# LANGUAGE TupleSections #-}
module Dodge.Render.Picture module Dodge.Render.Picture
where where
import Dodge.Data import Dodge.Data
@@ -8,29 +8,21 @@ import Dodge.Base.Zone
import Dodge.Picture import Dodge.Picture
import Dodge.Picture.Layer import Dodge.Picture.Layer
import Dodge.Render.HUD import Dodge.Render.HUD
--import Dodge.Render.List
import Dodge.Render.MenuScreen import Dodge.Render.MenuScreen
--import Dodge.GameRoom
--import Dodge.Debug
import Geometry import Geometry
--import Geometry.Zone
--import Geometry.Data
import Picture import Picture
import Polyhedra.Data import Polyhedra.Data
--import Dodge.Creature.YourControl
import Control.Lens import Control.Lens
import Data.Maybe import Data.Maybe
import Data.List (partition) import Data.List (partition)
import qualified Data.IntMap.Lazy as IM import qualified Data.IntMap.Lazy as IM
--import qualified Data.Vector.Fusion.Stream.Monadic as VS
worldPictures :: World -> Picture worldPictures :: World -> Picture
worldPictures w = pictures worldPictures w = pictures
[pictures (_decorations w) [pictures (_decorations w)
,concatMapPic (dbArg _pjDraw) $ _projectiles w ,concatMapPic (dbArg _pjDraw) $ _projectiles w
,concatMapPic (crDraw w) $ _creatures w ,concatMapPic (crDraw w) . IM.filter crIsClose $ _creatures w
,concatMapPic (dbArg _ptDraw) $ _particles w ,concatMapPic (dbArg _ptDraw) $ _particles w
,testPic w ,testPic w
,concatMapPic drawItem $ _floorItems w ,concatMapPic drawItem $ _floorItems w
@@ -40,6 +32,10 @@ worldPictures w = pictures
,concatMapPic btDraw $ _buttons w ,concatMapPic btDraw $ _buttons w
,concatMapPic drawWallFloor $ wallFloorsToDraw w ,concatMapPic drawWallFloor $ wallFloorsToDraw w
] ]
where
crIsClose cr = dist (_crPos cr) camCen < winSize
winSize = 30 + max (getWindowX w) (getWindowY w)
camCen = _cameraCenter w
foregroundPics :: World -> [Polyhedra] foregroundPics :: World -> [Polyhedra]
foregroundPics = _foregroundDecorations foregroundPics = _foregroundDecorations
@@ -50,7 +46,7 @@ fixedCoordPictures w = case _menuLayers w of
[ hudDrawings w [ hudDrawings w
, customMouseCursor w , customMouseCursor w
] ]
lays -> scaler . onLayer MenuDepth $ menuScreen w lays (lay:_) -> scaler . onLayer MenuDepth $ menuScreen w lay
where where
scaler = setDepth (-1) . scale (2 / getWindowX w) (2 / getWindowY w) scaler = setDepth (-1) . scale (2 / getWindowX w) (2 / getWindowY w)
@@ -121,9 +117,10 @@ outsideScreenPolygon w = [tr,tl,bl,br]
bl = scTran $ scRot $ scZoom $ V2 (- (3*halfWidth w)) (- (3* halfHeight w)) bl = scTran $ scRot $ scZoom $ V2 (- (3*halfWidth w)) (- (3* halfHeight w))
wallShadowsToDraw :: World -> [Wall] wallShadowsToDraw :: World -> [Wall]
wallShadowsToDraw w = filter (fromMaybe True . (^? blVisible)) wallShadowsToDraw w
. IM.elems = filter (fromMaybe True . (^? blVisible))
$ wallsNearZones (zoneOfSight w) w . IM.elems
$ wallsNearZones (zoneOfSight w) w
-- cannot only test if walls are on screen, but also if they are on the cone -- cannot only test if walls are on screen, but also if they are on the cone
-- towards the center of sight -- towards the center of sight
src/Dodge/Update.hs
+6 -6
View File
@@ -6,7 +6,7 @@ module Dodge.Update
( update ( update
) where ) where
import Dodge.Data import Dodge.Data
import Dodge.Data.Menu import Dodge.Menu
import Dodge.World.Trigger.Data import Dodge.World.Trigger.Data
--import Dodge.Config.Data --import Dodge.Config.Data
import Dodge.Base import Dodge.Base
@@ -45,11 +45,11 @@ pushSideEffects w = w
For most menus the only way to change the world is using event handling. -} For most menus the only way to change the world is using event handling. -}
functionalUpdate :: World -> World functionalUpdate :: World -> World
functionalUpdate w = case _menuLayers w of functionalUpdate w = case _menuLayers w of
(TerminalMessage t xs:mls) -> w & menuLayers .~ (TerminalMessage (max (t-1) 0) xs:mls) (TerminalScreen t xs:mls) -> w & menuLayers .~ (TerminalScreen (max (t-1) 0) xs:mls)
(WaitMessage s i: _) (WaitScreen s i : _)
| i < 1 -> w & dbArg _worldEvents | i < 1 -> w & dbArg _worldEvents
| otherwise -> w & menuLayers %~ ( (WaitMessage s (i-1) :) . tail ) | otherwise -> w & menuLayers %~ ( (WaitScreen s (i-1) :) . tail )
(GameOverMenu : _) -> updateParticles (OptionScreen {_scOptionFlag = GameOverOptions} : _) -> updateParticles
. updateProjectiles . updateProjectiles
. updateLightSources . updateLightSources
. updateClouds . updateClouds
@@ -164,7 +164,7 @@ updateSeenWalls w = foldl' (flip markSeen) w wallsToUpdate
checkEndGame :: World -> World checkEndGame :: World -> World
checkEndGame w checkEndGame w
| _crHP (you w) < 1 = haltSound $ w {_menuLayers = [GameOverMenu]} | _crHP (you w) < 1 = haltSound $ w {_menuLayers = [gameOverMenu]}
| otherwise = w | otherwise = w
--updateClouds :: World -> World --updateClouds :: World -> World