Make buttons without labels inactive

2021-03-08 17:03:58 +01:00
parent 70f8914767
commit 9f58066dba
4 changed files with 52 additions and 89 deletions
@@ -5,6 +5,7 @@ import Dodge.Data
 import Dodge.Base
 import Dodge.SoundLogic
 import Dodge.WorldActions
+import Dodge.Inventory

 import Geometry
 import Picture
@@ -244,39 +245,6 @@ useItem2 n (Weapon {_wpFire=eff}) w = eff n w
 useItem2 n (Throwable {_twFire = eff}) w = eff n w
 useItem2 _ _ w = w

-rmInvItem :: Int -> World -> World
-rmInvItem n w = 
-    let i = _crInvSel (_creatures w IM.! n)
-        item = _crInv (_creatures w IM.! n) IM.! i
-        itRef = creatures . ix n . crInv . ix i
-    in  case item of
-            Consumable {_itAmount = 1} -> set itRef NoItem w    
-            Craftable {_itAmount = 1} -> set itRef NoItem w    
-            Equipment {_itAmount = 1} -> set itRef NoItem w    
-            Throwable {_itAmount = 1} -> set itRef NoItem w    
-            Consumable {_itAmount = x} -> over (itRef . itAmount) (\y-> y-1) w    
-            Craftable {_itAmount = x} -> over (itRef . itAmount)  (\y-> y-1) w    
-            Equipment {_itAmount = x} -> over (itRef . itAmount)  (\y-> y-1) w    
-            Throwable {_itAmount = x} -> over (itRef . itAmount)  (\y-> y-1) w    
-            _ -> set itRef NoItem w
-
-dropItem :: World -> World
-dropItem w = case yourItem w of
-    NoItem -> w
-    it -> rmInvItem (_yourID w) $ over floorItems (IM.insert flid theflit)
-                            $ updateLocation
-                            $ soundOnce putDownSound 
-                            $ set randGen g w
-      where (rot, g) = randomR (-pi,pi) $ _randGen w
-            offset = _crRad (you w) *.* unitVectorAtAngle rot
-            updateLocation w = case it ^? itID of
-                                  Just (Just i)  -> w & itemPositions . ix i .~ OnFloor flid
-                                  _ -> w
-            flid = newKey $ _floorItems w
-            theflit = FlIt {_flIt = set itAmount 1 it
-                            ,_flItPos = offset +.+ _crPos (you w)
-                            ,_flItRot = rot
-                            ,_flItID = flid}

 useItemAmmoCheck :: Int -> World -> World
 useItemAmmoCheck n w 
@@ -292,40 +260,6 @@ useItemAmmoCheck n w
                             _         -> False


-closestItem :: World -> Maybe Int
-closestItem w = fmap fst $ listToMaybe $ sortBy cf $ IM.toList 
-                    $ fmap (dist yourP . _flItPos) $ _floorItems w
-    where yourP = _crPos $ you w
-          cf (_,x) (_,y) = compare x y
-
-pickUpItem' :: FloorItem -> World -> World
-pickUpItem' flit w = case maybeInvSlot of
-    Nothing -> w
-    Just i  -> soundOnce pickUpSound
-               $ updateItLocation i
-               $ w & floorItems %~ IM.delete (_flItID flit)
-                   & creatures . ix 0 . crInv . ix i %~ addItem' it
-    where 
-        it = _flIt flit
-        maybeInvSlot = checkInvSlots it (_crInv (_creatures w IM.! 0))
-        updateItLocation invid w' 
-            = case _itID it of Nothing -> w'
-                               Just j  -> w' & itemPositions . ix j .~ InInv 0 invid
-
-checkInvSlots :: Item -> IM.IntMap Item -> Maybe Int
-checkInvSlots it its = fmap fst $ find cond $ IM.toList its
-    where cond (_,NoItem) = True
-          cond (_,it'   ) = itNotFull it' && _itName it == _itName it'
-
-addItem' :: Item -> Item -> Item
-addItem' it NoItem = it
-addItem' it it'    = it' & itAmount +~ 1
-
-numInventorySlots :: Int 
-numInventorySlots = 9
-
-itNotFull :: Item -> Bool
-itNotFull it = _itMaxStack it > _itAmount it

 createItemAt :: Point2 -> FloorItem -> World -> World
 createItemAt p it w = over floorItems (IM.insert i (set flItPos p 
@@ -360,3 +294,36 @@ reverseDir n = over (creatures . ix n . crDir) (+ pi)

 turnBy :: Float -> Int -> World -> World
 turnBy a n = over (creatures . ix n . crDir) (+ a)
+
+dropItem :: World -> World
+dropItem w = case yourItem w of
+    NoItem -> w
+    it -> rmInvItem (_yourID w) $ over floorItems (IM.insert flid theflit)
+                            $ updateLocation
+                            $ soundOnce putDownSound 
+                            $ set randGen g w
+      where (rot, g) = randomR (-pi,pi) $ _randGen w
+            offset = _crRad (you w) *.* unitVectorAtAngle rot
+            updateLocation w = case it ^? itID of
+                                  Just (Just i)  -> w & itemPositions . ix i .~ OnFloor flid
+                                  _ -> w
+            flid = newKey $ _floorItems w
+            theflit = FlIt {_flIt = set itAmount 1 it
+                            ,_flItPos = offset +.+ _crPos (you w)
+                            ,_flItRot = rot
+                            ,_flItID = flid}
+
+pickUpItem' :: FloorItem -> World -> World
+pickUpItem' flit w = case maybeInvSlot of
+    Nothing -> w
+    Just i  -> soundOnce pickUpSound
+               $ updateItLocation i
+               $ w & floorItems %~ IM.delete (_flItID flit)
+                   & creatures . ix 0 . crInv . ix i %~ addItem it
+    where 
+        it = _flIt flit
+        maybeInvSlot = checkInvSlots it (_crInv (_creatures w IM.! 0))
+        updateItLocation invid w' 
+            = case _itID it of Nothing -> w'
+                               Just j  -> w' & itemPositions . ix j .~ InInv 0 invid
+
@@ -4,6 +4,7 @@ import Dodge.Data
 import Dodge.Base
 import Dodge.CreatureActions
 import Dodge.SoundLogic
+import Dodge.Inventory

 import Geometry

@@ -170,15 +171,6 @@ mouseActionsWorld keys w
          ---theItem   = _crInv (you w) IM.! _crInvSel (you w)
          rotation  = angleBetween (_mousePos w) (_lbClickMousePos w)

-- for now, left are floor items, right are buttons
-closestActiveObject :: World -> Maybe (Either FloorItem Button)
-closestActiveObject w = listToMaybe $ sortBy (compare `on` dist ypos . pos) $ actObjs
-    where ypos = _crPos $ you w
-          actObjs = filter (\obj -> dist ypos (pos obj) < 40 && hasLOS ypos (pos obj) w) 
-                        $ map Left (IM.elems $ _floorItems w) ++ map Right (IM.elems $ _buttons w)
-          pos (Right x) = _btPos x
-          pos (Left x)  = _flItPos x
-
 spaceAction :: World -> World
 spaceAction w = case closestActiveObject w of
    Just (Left flit) -> pickUpItem' flit w
@@ -2,6 +2,8 @@ module Dodge.Rendering where
 -- imports {{{
 import Dodge.Data
 import Dodge.Base
+import Dodge.Inventory
+
 import Geometry
 import Picture

@@ -27,6 +29,7 @@ fixedCoordPictures w = pictures
 --             [ scaler $ onLayer LabelLayer $ pictures [ppLabels, btLabels]
             [ scaler $ hudDrawings w
             , scaler $ onLayer MenuLayer menuScreen
+             , onLayer InvLayer $ activeObjectText w
             ]
    where scaler = scale (2 / _windowX w) (2 / _windowY w)
          menuScreen :: Picture
@@ -52,6 +55,18 @@ fixedCoordPictures w = pictures
                                    ]
                where tst x y sc t = translate x y $ scale sc sc $ color white $ text t

+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)
+                                    $ scale 0.1 0.1 $ text $ _btText bt
+                            , line [ (0,0),(0.5,0.5)]
+                            ]
+        where btp = _btPos bt
+    Just (Left flit) -> blank
+
 worldPictures :: World -> Picture
 worldPictures w
    = pictures $ concat [ decPicts 
@@ -86,9 +101,6 @@ worldPictures w
          yourPos = _crPos $ you w
          yourRot = _crDir $ you w
          yourRad = _crRad $ you w
-         -- itFloorPicts = zipWith (uncurry translate) (map _flItPos (IM.elems (_floorItems w)))
-         --                                       (map (_itFloorPict . _flIt) (IM.elems (_floorItems w)))
-         --
          scaler = onLayer LabelLayer . setLayer 1
          itLabels     = map (scaler . drawItemName w) (IM.elems (_floorItems w))
          ppLabels     = map (scaler . drawPPText w) (IM.elems (_pressPlates w))
@@ -378,21 +390,12 @@ drawButText w bt | magV (_crPos (you w) -.- _btPos bt) < 100
                                    , tranItPos' $ line [(-8,10),(-15,10),(-15,-10),(-8,-10)]
                                    , tranItPos' $ line [( 8,10),( 15,10),( 15,-10),( 8,-10)]
                                    ]
--                                = t $ rotate (_cameraRot w)
--                                    $ pictures $ [ scLine [(-8,10),(-15,10),(-15,-10),(-8,-10)]
--                                                 , scLine [( 8,10),( 15,10),( 15,-10),( 8,-10)]
--                                                 ,translate (-15) (-10*sqrt zoom - 5) $ dShadCol white 
--                                                 $ scale 0.1 0.1 $ text $ _btText bt
--                                                 ]
                 | otherwise = blank
    where tranItPos' = uncurry translate (_btPos bt) . rotate (_cameraRot w)
          t = rotate (0 - (_cameraRot w)) 
                . uncurry translate (zoom *.* (_btPos bt -.- _cameraPos w))
                . rotate (_cameraRot w)
          zoom = _cameraZoom w
--    where t = rotate (0 - (_cameraRot w)) . uncurry translate (zoom *.* (_btPos bt -.- _cameraPos w))
--          zoom = _cameraZoom w
--          scLine = dShadCol white . line . fmap (sqrt zoom *.*)

 drawPPText :: World -> PressPlate -> Picture
 drawPPText w pp | magV (_crPos (you w) -.- _ppPos pp) < 100