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

Refactor inventory management, add tweak, combine and inspect modes

Browse Source
This commit is contained in:
jgk
2021-05-26 17:25:46 +02:00
parent f05381be47
commit 0187ae6001
13 changed files with 323 additions and 233 deletions
Download Patch File Download Diff File Expand all files Collapse all files
src/Dodge/Data.hs
+14 -1
View File
@@ -96,7 +96,14 @@ data World = World
, _sideEffects :: [PreloadData SoundOrigin -> IO (PreloadData SoundOrigin)]
, _doneSideEffects :: [PreloadData SoundOrigin -> IO (PreloadData SoundOrigin)]
, _debugFlags :: DebugFlags
, _inventoryMode :: InventoryMode
}
data InventoryMode
= TopInventory
| TweakInventory
| CombineInventory
| InspectInventory
deriving (Eq, Ord, Show)
data CrGroupParams = CrGroupParams
{ _crGroupParamID :: Int
, _crGroupIDs :: IS.IntSet
@@ -390,13 +397,19 @@ data Ammo
= ShellAmmo
{ _amPayload :: Point2 -> World -> World
, _amString :: String
, _amPjMove :: Item -> Creature -> [Projectile -> World -> World]
, _amPjMove :: [PjParam]
, _amPjDraw :: Projectile -> Picture
, _amParamSel :: Int
}
| BulletAmmo
{ _amString :: String
}
| GenericAmmo
data PjParam = PjParam
{ _pjMoveParam :: Int -> Item -> Creature -> Projectile -> World -> World
, _pjIntParam :: Int
, _pjDisplayParam :: Int -> String
}
data Projectile
= Projectile
{ _pjPos :: Point2
src/Dodge/Default.hs
+59 -104
View File
@@ -19,7 +19,6 @@ import Dodge.Config.Data
import Dodge.Config.KeyConfig
import Geometry
import Picture
import qualified DoubleStack as DS
import Control.Lens
import System.Random
@@ -28,50 +27,65 @@ import qualified Data.Map as M
import qualified Data.Set as S
import Data.Graph.Inductive.Graph hiding ((&))
import Data.List
{- Indestructible wall. -}
defaultWall :: Wall
defaultWall = Wall
{ _wlLine = ((0,0),(50,0))
, _wlID = 0
, _wlColor = greyN 0.6
, _wlSeen = False
, _wlIsSeeThrough = False
}
{- Indestructible see-through wall. -}
defaultCrystalWall :: Wall
defaultCrystalWall = Wall
{ _wlLine = ((0,0),(50,0))
, _wlID = 0
, _wlColor = withAlpha 0.5 aquamarine
, _wlSeen = False
, _wlIsSeeThrough = True
}
{- Door that opens on approach.
Pathable. -}
defaultAutoDoor :: Wall
defaultAutoDoor = Door
{ _wlLine = ((0,0),(50,0))
, _wlID = 0
, _doorMech = id
, _wlColor = light $ dim $ dim $ dim yellow
, _wlSeen = False
, _wlIsSeeThrough = False
, _doorPathable = True
, _drPositions = DS.singleton ((0,0),(50,0))
}
{-
Non-pathable door.
-}
defaultDoor :: Wall
defaultDoor = Door
{ _wlLine = ((0,0),(50,0))
, _wlID = 0
, _doorMech = id
, _wlColor = light $ dim $ dim $ dim yellow
, _wlSeen = False
, _wlIsSeeThrough = False
, _doorPathable = False
, _drPositions = DS.singleton ((0,0),(50,0))
defaultWorld :: World
defaultWorld = World
{ _keys = S.empty
, _mouseButtons = S.empty
, _cameraCenter = (0,0)
, _cameraRot = 0
, _cameraZoom = 1
, _cameraViewFrom = (0,0)
, _creatures = IM.empty
, _creaturesZone = IM.empty
, _creatureGroups = IM.empty
, _clouds = IM.empty
, _cloudsZone = IM.empty
, _itemPositions = IM.empty
, _projectiles = IM.empty
, _particles = []
, _staticWalls = []
, _walls = IM.empty
, _wallsZone = IM.empty
, _forceFields = IM.empty
, _floorItems = IM.empty
, _randGen = mkStdGen 2
, _mousePos = (0,0)
, _testString = []
, _yourID = 0
, _worldEvents = id
, _pressPlates = IM.empty
, _buttons = IM.empty
, _soundQueue = []
, _sounds = M.empty
, _corpses = IM.empty
, _decorations = IM.empty
, _storedLevel = Nothing
, _menuLayers = [LevelMenu 1]
, _worldState = M.empty
, _worldTriggers = S.empty
, _clickMousePos = (0,0)
, _pathGraph = Data.Graph.Inductive.Graph.empty
, _pathGraph' = []
, _pathPoints = IM.empty
, _pathInc = M.empty
, _carteDisplay = False
, _carteCenter = (0,0)
, _carteZoom = 0.5
, _carteRot = 0
, _lightSources = IM.empty
, _tempLightSources = [youLight]
, _closeActiveObjects = []
, _seenLocations = IM.fromList
[(0, (_crPos . you, "CURRENT POSITION"))
,(1, (const (0,0) , "START POSITION"))
]
, _selLocation = 0
, _keyConfig = defaultKeyConfigSDL
, _config = defaultConfig
, _sideEffects = []
, _doneSideEffects = []
, _debugFlags = defaultDebugFlags
, _inventoryMode = TopInventory
}
defaultCreature :: Creature
defaultCreature = Creature
@@ -220,65 +234,6 @@ defaultPP = PressPlate
, _ppID = -1
, _ppText = "Pressure plate"
}
defaultWorld :: World
defaultWorld = World
{ _keys = S.empty
, _mouseButtons = S.empty
, _cameraCenter = (0,0)
, _cameraRot = 0
, _cameraZoom = 1
, _cameraViewFrom = (0,0)
, _creatures = IM.empty
, _creaturesZone = IM.empty
, _creatureGroups = IM.empty
, _clouds = IM.empty
, _cloudsZone = IM.empty
, _itemPositions = IM.empty
, _projectiles = IM.empty
, _particles = []
, _staticWalls = []
, _walls = IM.empty
, _wallsZone = IM.empty
, _forceFields = IM.empty
, _floorItems = IM.empty
, _randGen = mkStdGen 2
, _mousePos = (0,0)
, _testString = []
, _yourID = 0
, _worldEvents = id
, _pressPlates = IM.empty
, _buttons = IM.empty
, _soundQueue = []
, _sounds = M.empty
, _corpses = IM.empty
, _decorations = IM.empty
, _storedLevel = Nothing
, _menuLayers = [LevelMenu 1]
, _worldState = M.empty
, _worldTriggers = S.empty
, _clickMousePos = (0,0)
, _pathGraph = Data.Graph.Inductive.Graph.empty
, _pathGraph' = []
, _pathPoints = IM.empty
, _pathInc = M.empty
, _carteDisplay = False
, _carteCenter = (0,0)
, _carteZoom = 0.5
, _carteRot = 0
, _lightSources = IM.empty
, _tempLightSources = [youLight]
, _closeActiveObjects = []
, _seenLocations = IM.fromList
[(0, (_crPos . you, "CURRENT POSITION"))
,(1, (const (0,0) , "START POSITION"))
]
, _selLocation = 0
, _keyConfig = defaultKeyConfigSDL
, _config = defaultConfig
, _sideEffects = []
, _doneSideEffects = []
, _debugFlags = defaultDebugFlags
}
defaultDebugFlags :: DebugFlags
defaultDebugFlags = DebugFlags
{ _noClip = False
src/Dodge/Default/Wall.hs
+50
View File
@@ -0,0 +1,50 @@
module Dodge.Default.Wall
where
import Dodge.Data
import Picture
import qualified DoubleStack as DS
{- Indestructible wall. -}
defaultWall :: Wall
defaultWall = Wall
{ _wlLine = ((0,0),(50,0))
, _wlID = 0
, _wlColor = greyN 0.6
, _wlSeen = False
, _wlIsSeeThrough = False
}
{- Indestructible see-through wall. -}
defaultCrystalWall :: Wall
defaultCrystalWall = Wall
{ _wlLine = ((0,0),(50,0))
, _wlID = 0
, _wlColor = withAlpha 0.5 aquamarine
, _wlSeen = False
, _wlIsSeeThrough = True
}
{- Door that opens on approach.
Pathable. -}
defaultAutoDoor :: Wall
defaultAutoDoor = Door
{ _wlLine = ((0,0),(50,0))
, _wlID = 0
, _doorMech = id
, _wlColor = light $ dim $ dim $ dim yellow
, _wlSeen = False
, _wlIsSeeThrough = False
, _doorPathable = True
, _drPositions = DS.singleton ((0,0),(50,0))
}
{-
Non-pathable door.
-}
defaultDoor :: Wall
defaultDoor = Door
{ _wlLine = ((0,0),(50,0))
, _wlID = 0
, _doorMech = id
, _wlColor = light $ dim $ dim $ dim yellow
, _wlSeen = False
, _wlIsSeeThrough = False
, _doorPathable = False
, _drPositions = DS.singleton ((0,0),(50,0))
}
src/Dodge/Default/Weapon.hs
+9
View File
@@ -43,3 +43,12 @@ defaultAutoGun = defaultGun
, _itScrollDown = const id
, _itInvDisplay = basicWeaponDisplay
}
defaultShellAmmo :: Ammo
defaultShellAmmo = ShellAmmo
{ _amPayload = \_ -> id
, _amString = "Shell"
, _amPjMove = []
, _amPjDraw = \_ -> blank
, _amParamSel = 0
}
src/Dodge/Event.hs
+37 -63
View File
@@ -46,31 +46,21 @@ handleEvent' e = case eventPayload e of
_ -> Just
handleMouseMotionEvent :: MouseMotionEventData -> World -> Maybe World
handleMouseMotionEvent mmev w
= Just $ w & mousePos .~ (fromIntegral x - 0.5*getWindowX w
,0.5*getWindowY w - fromIntegral y
)
where P (V2 x y) = mouseMotionEventPos mmev
handleMouseMotionEvent mmev w = Just $ w & mousePos .~
(fromIntegral x - 0.5*getWindowX w
,0.5*getWindowY w - fromIntegral y
)
where
P (V2 x y) = mouseMotionEventPos mmev
handleMouseButtonEvent :: MouseButtonEventData -> World -> Maybe World
handleMouseButtonEvent mbev w = case mouseButtonEventMotion mbev of
Released -> Just $ over mouseButtons (S.delete but) w
Pressed -> handlePressedMouseButton but
$ over mouseButtons (S.insert but) w
where but = mouseButtonEventButton mbev
Released -> Just $ over mouseButtons (S.delete but) w
Pressed -> handlePressedMouseButton but $ over mouseButtons (S.insert but) w
where
but = mouseButtonEventButton mbev
handleMouseWheelEvent :: MouseWheelEventData -> World -> Maybe World
handleMouseWheelEvent mwev w = case _menuLayers w of
[] -> case mouseWheelEventPos mwev of
V2 _ y
| y > 0 -> Just (wheelUpEvent w)
| y < 0 -> Just (wheelDownEvent w)
| otherwise -> Just w
_ -> Just w
{- |
Resets the world window size, and resizes the fbo that gets the light map drawn into it.
-}
{- | Resets the world window size, and resizes the fbo that gets the light map drawn into it. -}
handleResizeEvent :: WindowSizeChangedEventData -> World -> Maybe World
handleResizeEvent sev w = Just
. set (config . windowX) (fromIntegral x)
@@ -89,57 +79,41 @@ handlePressedMouseButton but w
= Just $ w & clickMousePos .~ _mousePos w
| otherwise = Just w
wheelUpEvent :: World -> World
wheelUpEvent w = case _carteDisplay w of
True
| rbDown -> w & carteZoom .~ min 0.75 (z+(0.1*z))
| otherwise -> w & selLocation %~ (`mod` numLocs) . (\i -> i - 1)
_
| rbDown -> fromMaybe (closeObjScrollUp w)
$ (yourItem w ^? itScrollUp)
handleMouseWheelEvent :: MouseWheelEventData -> World -> Maybe World
handleMouseWheelEvent mwev w = case _menuLayers w of
[] -> case mouseWheelEventPos mwev of
V2 _ y -> Just $ wheelEvent (fromIntegral y) w
_ -> Just w
wheelEvent :: Float -> World -> World
wheelEvent y w = case (_carteDisplay w, _inventoryMode w) of
(True, _)
| rbDown -> w & carteZoom %~ min 0.75 . max 0.05 . ((1+y*0.1) * )
| otherwise -> w & selLocation %~ (`mod` numLocs) . (+ yi)
(_, TopInventory)
| rbDown -> fromMaybe (closeObjScrollDir y w) $ (yourItem w ^? itScrollUp)
<*> pure (_crInvSel (you w))
<*> pure w
| lbDown -> w & cameraZoom +~ 0.1
| invKeyDown -> swapInvUp $ upInvPos w
| otherwise -> upInvPos w
where
| lbDown -> w & cameraZoom +~ y
| invKeyDown -> swapInvDir yi $ dirInvPos yi w
| otherwise -> dirInvPos yi w
(_, TweakInventory) -> w
(_, _) -> w
where
yi = round $ signum y
numLocs = (fst . IM.findMax $ _seenLocations w) + 1
rbDown = ButtonRight `S.member` _mouseButtons w
lbDown = ButtonLeft `S.member` _mouseButtons w
invKeyDown = ScancodeCapsLock `S.member` _keys w
z = _carteZoom w
numLocs = (fst . IM.findMax $ _seenLocations w) + 1
wheelDownEvent :: World -> World
wheelDownEvent w = case _carteDisplay w of
True
| rbDown -> w & carteZoom .~ max 0.05 (z-(0.1*z))
| otherwise -> w & selLocation %~ (`mod` numLocs) . (+ 1)
False
| rbDown -> fromMaybe (closeObjScrollDown w)
$ (yourItem w ^? itScrollDown) <*> pure (_crInvSel (you w)) <*> pure w
| lbDown -> w {_cameraZoom = max (_cameraZoom w - 0.1) 0.01}
| invKeyDown -> downInvPos $ swapInvUp w
| otherwise -> downInvPos w
where
rbDown = ButtonRight `S.member` _mouseButtons w
lbDown = ButtonLeft `S.member` _mouseButtons w
z = _carteZoom w
invKeyDown = ScancodeCapsLock `S.member` _keys w
numLocs = (fst . IM.findMax $ _seenLocations w) + 1
swapInvUp :: World -> World
swapInvUp w = w & creatures . ix (_yourID w) . crInv %~ IM.swapKeys (i `mod` n) ((i + 1) `mod` n)
swapInvDir :: Int -> World -> World
swapInvDir k w = w & creatures . ix (_yourID w) . crInv %~ IM.swapKeys (i `mod` n) ((i + k) `mod` n)
where
i = _crInvSel $ you w
n = length $ IM.keys $ _crInv $ _creatures w IM.! _yourID w
upInvPos :: World -> World
upInvPos w = stopSoundFrom (CrReloadSound 0) $ w
& creatures . ix (_yourID w) . crInvSel %~ (`mod` n) . subtract 1
where
n = length $ IM.keys $ _crInv $ _creatures w IM.! _yourID w
downInvPos :: World -> World
downInvPos w = stopSoundFrom (CrReloadSound 0) $ w
& creatures . ix (_yourID w) . crInvSel %~ (`mod` n) . (+ 1)
dirInvPos :: Int -> World -> World
dirInvPos i w = stopSoundFrom (CrReloadSound 0) $ w
& creatures . ix (_yourID w) . crInvSel %~ (`mod` n) . subtract i
where
n = length $ IM.keys $ _crInv $ _creatures w IM.! _yourID w
src/Dodge/Event/Keyboard.hs
+10 -2
View File
@@ -16,7 +16,7 @@ import Dodge.LightSources
import Dodge.LevelGen
import Dodge.Creature.Inanimate
import qualified Data.IntMap.Strict as IM
import Dodge.Event.Test
--import Dodge.Event.Test
import Dodge.Event.Menu
import SDL
@@ -51,14 +51,22 @@ handlePressedKeyInGame scode w
| scode == dropItemKey (_keyConfig w) = Just $ youDropItem w
| scode == toggleMapKey (_keyConfig w) = Just $ toggleMap w
| scode == reloadKey (_keyConfig w) = Just $ fromMaybe w $ startReloadingWeapon (you w) w
| scode == testEventKey (_keyConfig w) = Just $ testEvent w
-- | scode == testEventKey (_keyConfig w) = Just $ testEvent w
| scode == spaceActionKey (_keyConfig w) = Just $ spaceAction w
| scode == rotateCameraPlusKey (_keyConfig w) = Just $ w & cameraRot +~ 0.01
| scode == rotateCameraMinusKey (_keyConfig w) = Just $ w & cameraRot -~ 0.01
| scode == ScancodeF5 = Just $ dropLight w
| scode == ScancodeF6 = Just $ dropLight' w
| scode == ScancodeT = Just $ w & inventoryMode %~ toggleInv TweakInventory
| scode == ScancodeC = Just $ w & inventoryMode %~ toggleInv CombineInventory
| scode == ScancodeI = Just $ w & inventoryMode %~ toggleInv InspectInventory
handlePressedKeyInGame _ w = Just w
toggleInv :: InventoryMode -> InventoryMode -> InventoryMode
toggleInv x y
| x == y = TopInventory
| otherwise = x
inTerminal :: World -> Bool
inTerminal w = case _menuLayers w of
src/Dodge/Inventory.hs
+6 -10
View File
@@ -10,16 +10,6 @@ import qualified Data.IntMap.Strict as IM
--import System.Random
import Control.Lens
checkInvSlotsYou' :: Maybe Item -> World -> Maybe Int
checkInvSlotsYou' it w = fst <$> find cond invListSelFirst
where
cond (_,NoItem) = True
cond (_,it' ) = itNotFull it' && fmap _itName it == Just (_itName it')
youCr = you w
youSel = _crInvSel youCr
invList = _crInv youCr
invListSelFirst = (youSel , invList IM.! youSel) : IM.toList invList
checkInvSlotsYou :: Item -> World -> Maybe Int
checkInvSlotsYou it w = fst <$> find cond invListSelFirst
where
@@ -93,6 +83,12 @@ updateCloseObjects w = w & closeActiveObjects .~ unionBy eTest oldCloseFiltered
oldClose = filt $ _closeActiveObjects w
oldCloseFiltered = intersectBy eTest oldClose currentClose
closeObjScrollDir :: Float -> World -> World
closeObjScrollDir x
| x > 0 = closeObjScrollUp
| x < 0 = closeObjScrollDown
| otherwise = id
closeObjScrollUp :: World -> World
closeObjScrollUp = over closeActiveObjects rotU
where rotU [] = []
src/Dodge/Item/Weapon/Launcher.hs
+18 -6
View File
@@ -42,7 +42,7 @@ launcher = defaultGun
, _itEquipPict = pictureWeaponOnAim $ color cyan $ polygon $ rectNESW 5 5 (-5) (-5)
, _itHammer = NoHammer
, _itEffect = NoItEffect
, _wpAmmo = ShellAmmo
, _wpAmmo = defaultShellAmmo
{ _amPayload = makeExplosionAt
, _amString = ""
, _amPjMove = basicAmPjMoves
@@ -50,11 +50,23 @@ launcher = defaultGun
}
}
basicAmPjMoves :: Item -> Creature -> [Projectile -> World -> World]
basicAmPjMoves _ cr =
[reduceSpinBy 0.995
,pjEffAtTime 35 $ trySpinByCID (_crID cr)
basicAmPjMoves :: [PjParam]
basicAmPjMoves =
[spinDrag
,spinStart
]
spinDrag :: PjParam
spinDrag = PjParam
{ _pjMoveParam = \_ _ _ -> reduceSpinBy 0.995
, _pjIntParam = 0
, _pjDisplayParam = ("SPIN DRAG:" ++ ) . show
}
spinStart :: PjParam
spinStart = PjParam
{ _pjMoveParam = \_ _ cr -> pjEffAtTime 35 $ trySpinByCID (_crID cr)
, _pjIntParam = 0
, _pjDisplayParam = ("SPIN START:" ++ ) . show
}
flameLauncher :: Item
flameLauncher = launcher & wpAmmo . amPayload .~ makeFlameExplosionAt
@@ -74,7 +86,7 @@ aRocketWithItemParams it cr w = over projectiles (IM.insert i theShell) w
i = IM.newKey $ _projectiles w
pos = _crPos cr +.+ ((_crRad cr +1) *.* unitVectorAtAngle dir)
dir = _crDir cr
ammoMvs pj w' = foldr ($ pj) w' (_amPjMove am it cr)
ammoMvs pj w' = foldr (\pjP -> (_pjMoveParam pjP) (_pjIntParam pjP) it cr pj) w' (_amPjMove am)
theShell = defaultShell
{ _pjPos = pos
, _pjStartPos = pos
src/Dodge/Layout.hs
+1 -1
View File
@@ -9,7 +9,7 @@ import Dodge.Base
import Dodge.Graph
import Dodge.Layout.Tree.Polymorphic (applyToRoot)
import Dodge.Room.Data
import Dodge.Default
import Dodge.Default.Wall
import Geometry
import Dodge.Room.Link
import qualified IntMapHelp as IM
src/Dodge/Render/HUD.hs
+111 -39
View File
@@ -1,3 +1,4 @@
{-# LANGUAGE TupleSections #-}
module Dodge.Render.HUD
where
import Dodge.Data
@@ -8,12 +9,17 @@ import Geometry
import Data.Maybe
import qualified Data.IntMap as IM
import qualified Data.Set as S
import Control.Lens
import SDL (MouseButton (..))
winScale :: World -> Picture -> Picture
winScale w = scale (2 / getWindowX w) (2 / getWindowY w)
hudDrawings :: World -> Picture
hudDrawings w = setLayer 1 . setDepth (-0.5) . pictures $
[ scaler . dShadCol white $ displayHP 0 w
, scaler . translate (-390) 20 . scale 0.05 0.05 . dShadCol white $ text (_testString w)
[ winScale w . dShadCol white $ displayHP 0 w
, winScale w . translate (-390) 20 . scale 0.05 0.05 . dShadCol white $ text (_testString w)
]
++ selectionText
where
@@ -21,26 +27,65 @@ hudDrawings w = setLayer 1 . setDepth (-0.5) . pictures $
if _carteDisplay w
then drawLocations w
else drawInventory w
scaler = scale (2 / getWindowX w) (2 / getWindowY w)
drawInventory :: World -> [Picture]
drawInventory w =
[ closeObjectTexts w
, drawListCursor (itCol (yourItem w)) iPos w
]
++ displayInv 0 w
drawInventory w = case _inventoryMode w of
TopInventory -> [ closeObjectTexts w]
++ topInvCursor col iPos w
++ displayInv 0 w
TweakInventory ->
mCurs it w
++ [cursorAt 120 col 5 iPos w]
++ displayInv 0 w
++ displayMidList w (ammoTweakStrings it) "TWEAK"
++ mCurs it w
CombineInventory -> displayInv 0 w ++ invHead w "COMBINE"
InspectInventory -> displayInv 0 w ++ invHead w "INSPECT"
where
itCol = fromMaybe (greyN 0.5) . (^? itInvColor)
iPos = _crInvSel $ _creatures w IM.! _yourID w
it = yourItem w
col = itCol it
topInvCursor :: Color -> Int -> World -> [Picture]
topInvCursor col iPos w
| ButtonRight `S.member` _mouseButtons w =
[cursorAt 100 col 5 iPos w
,openCursorAt 20 col 105 iPos w]
| otherwise = [ openCursorAt 120 col 5 iPos w ]
ammoTweakStrings :: Item -> [String]
ammoTweakStrings it = case it ^? wpAmmo . amPjMove of
Just l -> map pjTweakString l
_ -> ["NOT TWEAKABLE"]
mCurs :: Item -> World -> [Picture]
mCurs it w = case it ^? wpAmmo . amParamSel of
Nothing -> []
Just i -> [openCursorAt 120 white 200 i w]
pjTweakString :: PjParam -> String
pjTweakString pj = _pjDisplayParam pj $ _pjIntParam pj
displayMidList :: World -> [String] -> String -> [Picture]
displayMidList w strs s =
invHead w s
++ renderListAt (200,0) (map (,white) strs) w
invHead :: World -> String -> [Picture]
invHead w s = [winScale w . translate (-150) (150-halfHeight w)
. dShadCol white . scale 0.5 0.5 $ text s
]
displayListTopLeft :: [(String,Color)] -> World -> [Picture]
displayListTopLeft scols w =
map scaler $ zipWith
(translate (15-halfWidth w))
( map (\x -> halfHeight w - (20 * (fromIntegral x+1))) ([0..]::[Int]) )
displayListTopLeft = renderListAt (0,0)
renderListAt :: Point2 -> [(String,Color)] -> World -> [Picture]
renderListAt (tx,ty) scols w =
map (winScale w) $ zipWith
(translate (tx + 15-halfWidth w))
( map (\x -> ty + halfHeight w - (20 * (fromIntegral x+1))) ([0..]::[Int]) )
( map (\(s,col) -> scale 0.1 0.1 . dShadCol col $ text s) scols )
where
scaler = scale (2 / getWindowX w) (2 / getWindowY w)
displayInv :: Int -> World -> [Picture]
displayInv n w = displayListTopLeft scols w
@@ -60,13 +105,15 @@ drawLocations wrld = displayListTopLeft locs wrld
iPos = _selLocation wrld
locs = map (\(_,s) -> (s,white)) . IM.elems . _seenLocations $ wrld
locPoss = map (cartePosToScreen wrld . ($ wrld) . fst) . IM.elems . _seenLocations $ wrld
--cZoom = _carteZoom w
locTexts = map fst locs
bFunc (x,y) (z,w) = pictures
[ bezierQuad (withAlpha 0.0 white) (withAlpha 0.2 white) 0.050 0.010 (x,y) (0,y) (z,w)
, bezierQuad (withAlpha 0.0 white) (withAlpha 0.5 white) 0.045 0.005 (x,y) (0,y) (z,w)
, bezierQuad (withAlpha 0.0 white) (withAlpha 0.5 white) 0.035 0.002 (x,y) (0,y) (z,w)
[ bline 0.2 0.050 0.010
, bline 0.5 0.045 0.005
, bline 0.5 0.035 0.002
] --cheapo antialiasing
where
bline alph lwidth rwidth
= bezierQuad (withAlpha 0.0 white) (withAlpha alph white) lwidth rwidth (x,y) (0,y) (z,w)
displayListCoords :: World -> [Point2]
displayListCoords w = map (g . f) [(1::Int)..]
@@ -96,24 +143,22 @@ mapWall w wl =
else Nothing
where
t = normalizeV (y -.- x)
-- n2 = 2 *.* vNormal t
n2 = 20 *.* vNormal t
(x,y) = _wlLine wl
c = _wlColor wl
{- | Pictures of popup text for items close to your position.-}
closeObjectTexts :: World -> Picture
closeObjectTexts w = pictures $ zipWith renderList [(0::Int)..] (map colAndText $ _closeActiveObjects w)
++ maybeToList maybeLine
++ maybeToList maybeLine
where
colAndText (Left x) = (_itInvColor $ _flIt x, _itName $ _flIt x)
colAndText (Right x) = (white, _btText x)
renderList i (c,t) = scale (2/getWindowX w) (2/getWindowY w)
. tran
. translate (xtran i) (negate (20 * fromIntegral i))
. scale 0.1 0.1
. color c
$ text t
renderList i (c,t) = winScale w
. tran
. translate (xtran i) (negate (20 * fromIntegral i))
. scale 0.1 0.1
. color c
$ text t
tran = translate (pushout - halfWidth w) (halfHeight w - 20* (fromIntegral invPos +1))
youSel = _crInvSel $ you w
freeSlot = mayIt >>= \it -> checkInvSlotsYou (_flIt it) w
@@ -147,22 +192,49 @@ closeObjectTexts w = pictures $ zipWith renderList [(0::Int)..] (map colAndText
,(sc p' , col)
,(sc p , col)
]
{- | Add coloured drop shadow. -}
{- | Colour picture and add black drop shadow. -}
dShadCol :: Color -> Picture -> Picture
dShadCol c p = pictures
[ color black $ uncurry translate (1.2,-1.2) p
, color c p
]
[ color black $ uncurry translate (1.2,-1.2) p
, color c p
]
drawListCursor :: Color -> Int -> World -> Picture
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)
,((-100,-7.5) ,c)
,(( 100,-7.5) ,withAlpha 0 c)
]
drawListCursor c = openCursorAt 120 c 5
openCursorAt
:: Float -- ^ Width
-> Color
-> Float -- ^ x offset
-> Int -- ^ y offset (discrete)
-> World
-> Picture
openCursorAt wth col xoff yint w = winScale w
. translate (xoff-halfWidth w) (halfHeight w - (20* fromIntegral yint) - 20)
$ lineCol
[(( wth,12.5) ,withAlpha 0 col)
,(( 0,12.5) ,col)
,(( 0,-7.5) ,col)
,(( wth,-7.5) ,withAlpha 0 col)
]
cursorAt
:: Float -- ^ Width
-> Color
-> Float -- ^ x offset
-> Int -- ^ y offset (discrete)
-> World
-> Picture
cursorAt wth col xoff yint w = winScale w
. translate (xoff-halfWidth w) (halfHeight w - (20* fromIntegral yint) - 20)
. color col
$ line
[( wth,12.5)
,( 0,12.5)
,( 0,-7.5)
,( wth,-7.5)
,( wth,12.5)
]
displayHP :: Int -> World -> Picture
displayHP n w = translate (halfWidth w-80) (halfHeight w-20) $
src/Dodge/Render/Picture.hs
+6 -5
View File
@@ -45,11 +45,12 @@ customMouseCursor w =
$ pictures [ line [(-5,0),(5,0)] , line [(0,-5),(0,5)] ]
testPic :: World -> [Picture]
testPic w =
[ setDepth (-1) . translate 0 0.8
. scale 0.001 0.001 . text . show . length . IM.elems
. IM.filter ( (== 3) . _crRad ) $ _creatures w
]
testPic _ = []
--testPic w =
-- [ setDepth (-1) . translate 0 0.8
-- . scale 0.001 0.001 . text . show . length . IM.elems
-- . IM.filter ( (== 3) . _crRad ) $ _creatures w
-- ]
crDraw :: World -> Creature -> Picture
crDraw w c = (_crPict c c w)
src/Dodge/Room.hs
+1 -1
View File
@@ -14,7 +14,7 @@ import Dodge.Creature
import Dodge.LevelGen.Data
--import Dodge.Base
import Dodge.RandomHelp
import Dodge.Default
import Dodge.Default.Wall
--import Dodge.Path
--import Dodge.Layout
import Dodge.Layout.Tree.Polymorphic
src/Dodge/Room/Placement.hs
+1 -1
View File
@@ -2,7 +2,7 @@
module Dodge.Room.Placement
where
import Dodge.Data
import Dodge.Default
import Dodge.Default.Wall
import Dodge.LevelGen.Data
import Dodge.Room.Data
import Dodge.Creature.Inanimate