Improve control over floor items and buttons

app/Main.hs

@@ -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

src/Dodge/Data.hs

@@ -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

src/Dodge/KeyEvents.hs

@@ -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

src/Dodge/Prototypes.hs

@@ -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) ) 

src/Dodge/Rendering.hs

@@ -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)
+                            , lineCol [(p         , withAlpha 0 white)
-                                   ,(0.5,0.5)
+                                      ,((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) $
+displayHP n w = translate (halfWidth w-80) (halfHeight w-20) $
-                    scale 0.2 0.2 $ text $ show
+                    scale 0.2 0.2 $ text $ reverse $ take 5 $ (++ repeat ' ') $ reverse $ show
                     $ _crHP $ _creatures w IM.! n
 
 testPic w = blank

src/Dodge/Update.hs

@@ -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 

src/Loop.hs

@@ -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
                  )