Improve control over floor items and buttons
This commit is contained in:
@@ -31,7 +31,6 @@ import System.Random
|
||||
import qualified SDL as SDL
|
||||
import qualified SDL.Mixer as Mix
|
||||
import Graphics.Rendering.OpenGL hiding (color,scale,translate,rotate)
|
||||
--Mix.openAudio Mix.defaultAudio 256 >>
|
||||
|
||||
initWorld = initialWorld
|
||||
{ _randGen = mkStdGen 2
|
||||
|
||||
@@ -86,6 +86,7 @@ data World = World
|
||||
, _mapDisplay :: (Bool, Float)
|
||||
, _lightSources :: !(IM.IntMap LightSource)
|
||||
, _tempLightSources :: ![TempLightSource]
|
||||
, _closeActiveObjects :: [Either FloorItem Button]
|
||||
} --deriving (Show)
|
||||
|
||||
type Drawing = Picture
|
||||
|
||||
@@ -104,7 +104,8 @@ wheelUpEvent :: World -> World
|
||||
wheelUpEvent w
|
||||
= case _mapDisplay w of
|
||||
(True,z) -> w & mapDisplay . _2 .~ min 0.3 (z+(0.1*z))
|
||||
_ | rbPressed -> fromMaybe w $ (yourItem w ^? itScrollUp) <*> pure (_crInvSel (you w))
|
||||
_ | rbPressed -> fromMaybe (closeObjScrollUp w)
|
||||
$ (yourItem w ^? itScrollUp) <*> pure (_crInvSel (you w))
|
||||
<*> pure w
|
||||
| lbPressed -> w {_cameraZoom = _cameraZoom w + 0.1}
|
||||
| otherwise -> upInvPos w
|
||||
@@ -115,7 +116,8 @@ wheelDownEvent :: World -> World
|
||||
wheelDownEvent w
|
||||
= case _mapDisplay w of
|
||||
(True,z) -> w & mapDisplay . _2 .~ max 0.05 (z-(0.1*z))
|
||||
_ | rbPressed -> fromMaybe w $ (yourItem w ^? itScrollDown) <*> pure (_crInvSel (you w))
|
||||
_ | rbPressed -> fromMaybe (closeObjScrollDown w)
|
||||
$ (yourItem w ^? itScrollDown) <*> pure (_crInvSel (you w))
|
||||
<*> pure w
|
||||
| lbPressed -> w {_cameraZoom = max (_cameraZoom w - 0.1) 0.01}
|
||||
| otherwise -> downInvPos w
|
||||
@@ -172,7 +174,7 @@ mouseActionsWorld keys w
|
||||
rotation = angleBetween (_mousePos w) (_lbClickMousePos w)
|
||||
|
||||
spaceAction :: World -> World
|
||||
spaceAction w = case closestActiveObject w of
|
||||
spaceAction w = case listToMaybe $ _closeActiveObjects w of
|
||||
Just (Left flit) -> pickUpItem' flit w
|
||||
Just (Right but) -> _btEvent but but w
|
||||
Nothing -> w
|
||||
|
||||
@@ -224,6 +224,7 @@ basicWorld = World
|
||||
, _mapDisplay = (False, 0.2)
|
||||
, _lightSources = IM.empty
|
||||
, _tempLightSources = [youLight]
|
||||
, _closeActiveObjects = []
|
||||
}
|
||||
youLight =
|
||||
-- LS {_lsEff = \w _ p -> (logistic 1 1 1 (d p w * 0.01) )
|
||||
|
||||
+62
-7
@@ -29,7 +29,8 @@ fixedCoordPictures w = pictures
|
||||
-- [ scaler $ onLayer LabelLayer $ pictures [ppLabels, btLabels]
|
||||
[ scaler $ hudDrawings w
|
||||
, scaler $ onLayer MenuLayer menuScreen
|
||||
, onLayer InvLayer $ activeObjectText w
|
||||
--, onLayer InvLayer $ activeObjectText w
|
||||
, onLayer InvLayer $ closeObjectTexts w
|
||||
]
|
||||
where scaler = scale (2 / _windowX w) (2 / _windowY w)
|
||||
menuScreen :: Picture
|
||||
@@ -55,18 +56,72 @@ fixedCoordPictures w = pictures
|
||||
]
|
||||
where tst x y sc t = translate x y $ scale sc sc $ color white $ text t
|
||||
|
||||
closeObjectTexts :: World -> Picture
|
||||
closeObjectTexts w = pictures $ (zipWith ren [0..] $ map toTs $ _closeActiveObjects w)
|
||||
++ maybeToList maybeLine
|
||||
where toTs (Left x) = (_itInvColor $ _flIt x, _itName $ _flIt x)
|
||||
toTs (Right x) = (white, _btText x)
|
||||
ren i (c,t) = scale (2/_windowX w) (2/_windowY w)
|
||||
. tran
|
||||
. translate (xtran i) (0 - 20 * fromIntegral i)
|
||||
. scale 0.1 0.1 $ color c $ text t
|
||||
tran = case freeSlot of
|
||||
Just i -> translate (pushout - halfWidth w) (halfHeight w - 20* (fromIntegral i +1))
|
||||
Nothing -> translate (0.25*_windowX w) (0.25*_windowY w)
|
||||
freeSlot = checkInvSlotsYou' (fmap _flIt mayIt) w
|
||||
mayObj = listToMaybe $ _closeActiveObjects w
|
||||
mayIt = mayObj >>= maybeLeft
|
||||
maybeLeft (Left x) = Just x
|
||||
maybeLeft _ = Nothing
|
||||
pushout = 200
|
||||
xtran 0 = case mayIt of Nothing -> 25
|
||||
_ -> -25
|
||||
xtran _ = 0
|
||||
objPos obj = case obj of Left flit -> _flItPos flit
|
||||
Right bt -> _btPos bt
|
||||
objText obj = case obj of Left flit -> _itName $ _flIt flit
|
||||
Right bt -> _btText bt
|
||||
mayScreenPos = fmap objPos mayObj >>= (\thePos -> Just (sc $ rotateV (0 - _cameraRot w) $ _cameraZoom w *.* (thePos -.- _cameraPos w)))
|
||||
sc (x, y) = (x*2/_windowX w, y*2/_windowY w)
|
||||
maybeLine = do
|
||||
itScreenPos <- mayScreenPos
|
||||
theText <- fmap objText mayObj
|
||||
let textWidth = 9 * fromIntegral (length theText)
|
||||
let col = fromMaybe white $ fmap (_itInvColor . _flIt) mayIt
|
||||
let p = case freeSlot of
|
||||
Just i -> ( pushout - halfWidth w + textWidth
|
||||
, halfHeight w - 20* (fromIntegral i +1) + 2.5
|
||||
)
|
||||
Nothing -> ( 0.25*_windowX w
|
||||
, 0.25*_windowY w
|
||||
)
|
||||
let p' = case freeSlot of
|
||||
Just i -> ( pushout - halfWidth w + 130
|
||||
, halfHeight w - 20* (fromIntegral i +1) + 2.5
|
||||
)
|
||||
Nothing -> ( 0.25*_windowX w
|
||||
, 0.25*_windowY w
|
||||
)
|
||||
return $ lineCol
|
||||
[(itScreenPos, withAlpha 0 col)
|
||||
,(sc p' , col)
|
||||
,(sc p , col)
|
||||
]
|
||||
|
||||
activeObjectText :: World -> Picture
|
||||
activeObjectText w = case closestActiveObject w of
|
||||
Nothing -> Blank
|
||||
Just (Right bt) -> pictures
|
||||
[ scale (2/_windowX w) (2/_windowY w)
|
||||
$ translate (0.25*_windowX w) (0.25*_windowY w)
|
||||
$ translate (0.35*_windowX w) (0.25*_windowY w)
|
||||
$ scale 0.1 0.1 $ text $ _btText bt
|
||||
, line [sc $ rotateV (0 - _cameraRot w) $ _cameraZoom w *.* (_btPos bt -.- _cameraPos w)
|
||||
,(0.5,0.5)
|
||||
]
|
||||
, lineCol [(p , withAlpha 0 white)
|
||||
,((0.5,0.5) , white )
|
||||
,((0.65,0.5), white )
|
||||
]
|
||||
]
|
||||
where sc (x, y) = (x*2/_windowX w, y*2/_windowY w)
|
||||
p = sc $ rotateV (0 - _cameraRot w) $ _cameraZoom w *.* (_btPos bt -.- _cameraPos w)
|
||||
Just (Left flit)
|
||||
-> pictures
|
||||
[ color col $ scale (2/_windowX w) (2/_windowY w)
|
||||
@@ -506,8 +561,8 @@ drawFFShadow w ff
|
||||
, y]
|
||||
|
||||
displayHP :: Int -> World -> Picture
|
||||
displayHP n w = translate (halfWidth w-70) (halfHeight w-40) $
|
||||
scale 0.2 0.2 $ text $ show
|
||||
displayHP n w = translate (halfWidth w-80) (halfHeight w-20) $
|
||||
scale 0.2 0.2 $ text $ reverse $ take 5 $ (++ repeat ' ') $ reverse $ show
|
||||
$ _crHP $ _creatures w IM.! n
|
||||
|
||||
testPic w = blank
|
||||
|
||||
@@ -6,6 +6,7 @@ import Dodge.WallCreatureCollisions
|
||||
import Dodge.LevelGen.Block
|
||||
import Dodge.Camera
|
||||
import Dodge.SoundLogic
|
||||
import Dodge.Inventory
|
||||
|
||||
import Geometry
|
||||
|
||||
@@ -34,6 +35,7 @@ update w
|
||||
$ updateBlocks -- $ zoning
|
||||
$ updateSeenWalls
|
||||
$ updateSoundQueue
|
||||
$ updateCloseObjects
|
||||
w
|
||||
w2 = -- updateWeaponCounters $
|
||||
simpleCrSprings
|
||||
|
||||
@@ -61,6 +61,7 @@ setupLoop wName xSize ySize
|
||||
GL.clearColor $= GL.Color4 0 0.5 0 1
|
||||
GL.clearDepth $= (200)
|
||||
swapInterval $= ImmediateUpdates
|
||||
GL.lineSmooth $= GL.Enabled
|
||||
doLoop setup window startWorld
|
||||
sideEffects eventFn worldFn
|
||||
)
|
||||
|
||||
Reference in New Issue
Block a user