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

Make combine and tweak menus servicable

Browse Source
This commit is contained in:
justin
2021-12-04 00:27:22 +00:00
parent ecbc8eab35
commit 0114a2f9f2
14 changed files with 208 additions and 175 deletions
Download Patch File Download Diff File Expand all files Collapse all files
src/Dodge/Combine.hs
+12 -5
View File
@@ -1,4 +1,4 @@
{-# LANGUAGE TupleSections #-}
--{-# LANGUAGE TupleSections #-}
module Dodge.Combine where
import Dodge.Base.You
import Dodge.Data
@@ -13,6 +13,7 @@ import qualified Data.IntMap.Strict as IM
--import qualified Data.IntSet as IS
import qualified Data.Map.Strict as M
import Data.Maybe
import Data.List (scanl')
itemCombinations :: [ (M.Map CombineType Int, Item) ]
itemCombinations = map (first toMultiset) $
@@ -53,8 +54,8 @@ combineItemList m = mapMaybe (pushoutmaybe . second combineToItem)
itemsMultisets :: [(Int,Item)] -> [([Int],M.Map CombineType Int)]
itemsMultisets = map mconcat . mapM itemMultisets
-- individual items can produce multiple multisets if they are a stack of more
-- than one item
-- "individual" items can produce multiple multisets if they are in fact
-- a stack of more than one item
itemMultisets :: (Int,Item) -> [([Int],M.Map CombineType Int)]
itemMultisets (i,it) = case it ^? itConsumption . itAmount' of
Nothing -> [ ([i], M.singleton thetype 1 ) ]
@@ -66,7 +67,7 @@ itemMultisets (i,it) = case it ^? itConsumption . itAmount' of
itemTypeAmounts :: Item -> [[CombineType]]
itemTypeAmounts it = case it ^? itConsumption . itAmount' of
Nothing -> [[thetype]]
Just i -> map (flip replicate thetype) [1 .. i]
Just i -> map (`replicate` thetype) [1 .. i]
where
thetype = _itCombineType it
@@ -84,7 +85,13 @@ toggleCombineInv w = case _inventoryMode w of
enterCombineInv :: World -> World
enterCombineInv w = w & inventoryMode .~ CombineInventory mi
where
mi = const 0 <$> listToMaybe (combineListYou w)
mi = 0 <$ listToMaybe (combineListYou w)
combine :: M.Map CombineType Int -> Maybe CombineType
combine m = lookup m combinations
combineSizes :: World -> [Int]
combineSizes = map (ceiling . _itInvSize . snd) . combineItemListYou
combinePoss :: World -> [Int]
combinePoss = scanl' (+) 0 . combineSizes
src/Dodge/Creature.hs
+1 -2
View File
@@ -164,8 +164,7 @@ startCr = defaultCreature
{- | Items you start with. -}
startInvList :: [Item]
startInvList =
[ miniGun
, hvAutoGun
[
]
startInventory :: IM.IntMap Item
startInventory = IM.fromList $ zip [0..] startInvList
src/Dodge/Creature/Impulse/UseItem.hs
+1 -8
View File
@@ -38,20 +38,13 @@ itemEffect cr it w = case it ^? itUse of
--this is ugly
useLeftItem :: Int -> World -> World
useLeftItem cid w = case _crInv cr IM.! crinvsel ^? itUse . lUse of
useLeftItem cid w = case cr ^? crInv . ix crinvsel . itUse . lUse of
Just f -> f cr crinvsel (w & creatures . ix cid . crLeftInvSel ?~ crinvsel)
Nothing -> case _crLeftInvSel cr of
Just invid -> case _itUse $ _crInv cr IM.! invid of
LeftUse {_lUse = f} -> f cr invid w
_ -> w & creatures . ix cid . crLeftInvSel .~ Nothing
Nothing -> w
-- Nothing -> case luse of
-- Nothing -> w
-- Just (invid, f) -> f cr invid w & creatures . ix cid . crLeftInvSel ?~ invid
where
crinvsel = _crInvSel cr
cr = _creatures w IM.! cid
-- luses = IM.mapMaybe (^? itUse . lUse) (_crInv cr)
-- luse = listToMaybe $ IM.toList luses
--the old code automatically selected the first unused item in the list: not
--sure if I want this behaviour, can probably set it as an option later
src/Dodge/Creature/Picture.hs
+8 -13
View File
@@ -166,7 +166,6 @@ arms cr
Just (Walking sa RightForward) -> waistSH $ translateSHf (-f sa) off aHand
_ -> emptySH
where
--crIt = _crInv cr IM.! _crInvSel cr
aHand :: Shape
aHand = translateSHz (-4) . upperPrismPolyHalf 4 $ polyCirc 3 4
off = 8
@@ -182,20 +181,18 @@ scalp cr
where
fhead = colorSH (greyN 0.9) . upperPrismPolyHalf 5 $ polyCirc 4 5
crInStance :: AimStance -> Creature -> Bool
crInStance as cr = crIsAiming' cr
&& cr ^? crInv . ix (_crInvSel cr) . itUse . useAim . aimStance == Just as
oneH :: Creature -> Bool
oneH cr = crIsAiming' cr && crIt ^? itUse . useAim . aimStance == Just OneHand
where
crIt = _crInv cr IM.! _crInvSel cr
oneH = crInStance OneHand
twoFlat :: Creature -> Bool
twoFlat cr = crIsAiming' cr && crIt ^? itUse . useAim . aimStance == Just TwoHandFlat
where
crIt = _crInv cr IM.! _crInvSel cr
twoFlat = crInStance TwoHandFlat
twists :: Creature -> Bool
twists cr = crIsAiming' cr && crIt ^? itUse . useAim . aimStance == Just TwoHandTwist
where
crIt = _crInv cr IM.! _crInvSel cr
twists = crInStance TwoHandTwist
torso :: Creature -> Shape
{-# INLINE torso #-}
@@ -244,9 +241,7 @@ light4 = light . light . light . light
-- where
-- setPos = translate 0 (_crRad cr)
drawEquipment
:: Creature
-> SPic
drawEquipment :: Creature -> SPic
{-# INLINE drawEquipment #-}
drawEquipment cr = mconcat $ map f $ IM.toList (_crInv cr)
where
src/Dodge/Inventory.hs
+28 -4
View File
@@ -1,13 +1,18 @@
{-# LANGUAGE TupleSections #-}
module Dodge.Inventory
( checkInvSlotsYou
, rmSelectedInvItem
, invSelPos
, invSelSize
, selNumPos
, selNumCol
, selNumSlots
, selNumMidHeight
, augmentedInvSizes
, rmInvItem
, updateCloseObjects
, closeObjScrollDir
, closeObjectCol
-- , swapInvDir
, changeInvSel
, changeSwapInvSel
@@ -22,12 +27,14 @@ import Dodge.Inventory.CloseObject
import Dodge.Inventory.CheckSlots
import Dodge.Inventory.ItemSpace
import Dodge.Base
import Dodge.Base.Window
import Dodge.Base.Collide
import Geometry
--import FoldableHelp
import Padding
import qualified IntMapHelp as IM
import ListHelp
import Color
import Data.Maybe
--import Data.List
@@ -69,7 +76,13 @@ closeObjectSize :: Either FloorItem Button -> Int
closeObjectSize e = case e of
Left flit -> itSlotsTaken $ _flIt flit
Right _ -> 1
closeObjectCol :: Either FloorItem Button -> Color
closeObjectCol e = case e of
Left flit -> _itInvColor $ _flIt flit
Right _ -> yellow
selNumSlots :: Int -> World -> Int
selNumSlots i w = fromMaybe 1 $ augmentedInvSizes w IM.!? i
selNumPos :: Int -> World -> Int
selNumPos i w = splitgap + (foldl' (+) 0 . fst $ IM.split i (augmentedInvSizes w))
@@ -78,6 +91,17 @@ selNumPos i w = splitgap + (foldl' (+) 0 . fst $ IM.split i (augmentedInvSizes w
| i < length (yourInv w) = 0
| otherwise = 1
selNumMidHeight :: Configuration -> World -> Int -> Point2
selNumMidHeight cfig w i = V2 (150 - hw) ( hh + bump - (20 * fromIntegral ipos + 7.5))
where
hh = halfHeight cfig
hw = halfWidth cfig
ipos = selNumPos i w
bump = negate $ 10 * fromIntegral (selNumSlots i w)
selNumCol :: Int -> World -> Color
selNumCol i w = fromMaybe white $ bimapAugmentInv _itInvColor closeObjectCol w IM.!? i
invSelPos :: World -> Int
invSelPos w = splitgap + (foldl' (+) 0 . fst $ IM.split invsel (augmentedInvSizes w))
where
@@ -156,12 +180,12 @@ bestCloseObjectIndex w = findIndex f $ _closeObjects w
selectedCloseObject :: World -> Maybe (Int,Either FloorItem Button)
selectedCloseObject w
| invsel >= length inv = Just $ selectNthCloseObject w (invsel - length inv)
| otherwise = selectNthCloseObject w <$> bestCloseObjectIndex w
| invsel >= length inv = selectNthCloseObject w (invsel - length inv)
| otherwise = selectNthCloseObject w =<< bestCloseObjectIndex w
where
invsel = _crInvSel cr
cr = you w
inv = _crInv cr
selectNthCloseObject :: World -> Int -> (Int,Either FloorItem Button)
selectNthCloseObject w n = (length (yourInv w) + n, _closeObjects w !! n)
selectNthCloseObject :: World -> Int -> Maybe (Int,Either FloorItem Button)
selectNthCloseObject w n = (length (yourInv w) + n,) <$> (_closeObjects w !? n)
src/Dodge/Inventory/Add.hs
+1 -1
View File
@@ -11,7 +11,7 @@ putItemInInvID cid flid w = fromMaybe w
$ tryPutItemInInv cid (_floorItems w IM.! flid) w
putItemInInvSlot :: Int -> Item -> IM.IntMap Item -> IM.IntMap Item
putItemInInvSlot invsel it = IM.insertWith (const $ itConsumption . itAmount' +~ 1) invsel it
putItemInInvSlot = IM.insertWith (const $ itConsumption . itAmount' +~ 1)
{- | Pick up a specific item. -}
tryPutItemInInv :: Int -> FloorItem -> World -> Maybe World
src/Dodge/Item/Weapon/BulletGuns.hs
+8 -7
View File
@@ -126,6 +126,7 @@ bangStick i = defaultGun
}
}
, _itTweaks = defaultBulletSelTweak
, _itInvSize = fromIntegral i / 3
}
bangCane,bangRod :: Item
bangCane = defaultGun
@@ -225,9 +226,9 @@ hvAutoGun = defaultAutoGun
& useDelay .~ VariableRate {_rateMax = 25, _rateMaxMax = 24, _rateMinMax = 7, _rateTime = 0}
, _itFloorPict = hvAutoGunPic
, _itInvSize = 3
, _itInvDisplay = \it -> basicItemDisplay it ++
["* FRATE: *"
,"* " ++ fromMaybe " " (maybeRateStatus it) ++ " *"
, _itInvDisplay = \it -> head (basicItemDisplay it) :
["* FIRERATE: *"
,"* " ++ fromMaybe " " (maybeRateStatus it) ++ " *"
]
}
hvAutoGunPic :: Item -> SPic
@@ -340,10 +341,10 @@ miniGun = defaultAutoGun
, _itEquipPict = pictureWeaponAim miniGunPictItem
, _itTweaks = defaultBulletSelTweak
, _itInvSize = 4
, _itInvDisplay = \it -> basicItemDisplay it ++
["*" ++ replicate 8 ' ' ++ "*"
,"* " ++ fromMaybe " " (maybeWarmupStatus it) ++ " *"
,"*" ++ replicate 8 ' ' ++ "*" ]
, _itInvDisplay = \it -> head (basicItemDisplay it) :
["*" ++ replicate 13 ' ' ++ "*"
,"* " ++ fromMaybe " " (maybeWarmupStatus it) ++ " *"
,"*" ++ replicate 13 ' ' ++ "*" ]
-- [" " ++ replicate 8 ch
-- ," " ++ replicate 2 ch ++ fromMaybe " " (maybeWarmupStatus it) ++ replicate 2 ch
-- ," " ++ replicate 8 ch]
src/Dodge/Item/Weapon/InventoryDisplay.hs
+2 -2
View File
@@ -16,8 +16,8 @@ import Control.Lens
{- | Displays the item name, ammo if loaded, and any selected '_itCharMode'. -}
basicItemDisplay :: Item -> [String]
basicItemDisplay it = Prelude.take (itSlotsTaken it) $
[midPadL 15 ' ' thename (' ' : thenumber) ++ theparam]
++ repeat "*"
(midPadL 15 ' ' thename (' ' : thenumber) ++ theparam)
: repeat "*"
where
thename = _itName it
thenumber = case it ^? itConsumption of
src/Dodge/Item/Weapon/Launcher.hs
+1 -5
View File
@@ -69,12 +69,8 @@ launcher = defaultGun
, _tweakParams = basicAmPjMoves
}
, _itInvSize = 3
, _itInvDisplay = \it -> basicItemDisplay it ++
["!" ++ replicate 8 ch ++ "!"
,"!" ++ replicate 8 ch ++ "!"]
, _itInvDisplay = basicItemDisplay
}
where
ch = ' '
defaultShellAmmo :: AmmoType
defaultShellAmmo = ProjectileAmmo
src/Dodge/Item/Weapon/TriggerType.hs
+2 -2
View File
@@ -402,13 +402,13 @@ spreadLoaded :: ChainEffect
spreadLoaded eff item cr w = foldr f w dirs
where
cd = 0.5 * spread * fromIntegral (numBulLoaded -1)
ds = (subtract cd . (spread *) . fromIntegral) <$> [0 .. numBulLoaded - 1]
ds = subtract cd . (spread *) . fromIntegral <$> [0 .. numBulLoaded - 1]
-- dirs = ds
dirs = zipWith (+)
ds
(randomRs (-spread,spread) (_randGen w))
f dir = eff item (cr & crDir +~ dir)
spread = (_spreadAngle . _brlSpread . _gunBarrels $ _itParams item)
spread = _spreadAngle . _brlSpread . _gunBarrels $ _itParams item
-- numBarrels = _brlNum . _gunBarrels $ _itParams item
-- spread = (_spreadAngle . _brlSpread . _gunBarrels $ _itParams item) * loadedSpreadParam
-- loadedSpreadParam = 0.5 * (fromIntegral (numBulLoaded - numBarrels) + 1)
src/Dodge/Render/HUD.hs
+108 -108
View File
@@ -1,4 +1,4 @@
{-# LANGUAGE TupleSections #-}
--{-# LANGUAGE TupleSections #-}
module Dodge.Render.HUD
( hudDrawings
) where
@@ -27,77 +27,133 @@ import SDL (MouseButton (..))
--import Data.Bifunctor
hudDrawings :: Configuration -> World -> Picture
hudDrawings cfig w = pictures
hudDrawings cfig w = if _carteDisplay w
then drawCarte cfig w
else drawInGameHUD cfig w
drawInGameHUD :: Configuration -> World -> Picture
drawInGameHUD cfig w = pictures
[ winScale cfig . dShadCol white $ displayHP 0 cfig w
, renderListAt (halfWidth cfig) 0 cfig $ map (,white) (_testString w w)
, if _carteDisplay w
then drawLocations cfig w
else subInventoryDisplay cfig w `appendPic` displayInv 0 cfig w
, listTextPicturesAt (halfWidth cfig) 0 cfig $ map text (_testString w w)
, inventoryDisplay cfig w
, subInventoryDisplay cfig w
]
inventoryDisplay :: Configuration -> World -> Picture
inventoryDisplay cfig w = listTextPicturesAt 0 0 cfig invlist
<> equipcursor
where
cr = you w
inv = _crInv cr
invlist = concatMap itemText (IM.elems inv)
++ displayFreeSlots
++ map floorItemsColor (concatMap (closeObjectToTextPictures nfreeslots) (_closeObjects w))
floorItemsColor
| _inventoryMode w == TopInventory = id
| otherwise = color invDimColor
nfreeslots = crNumFreeSlots cr
displayFreeSlots = case nfreeslots of
0 -> [color invDimColor . text $ " INVENTORY FULL"]
1 -> [color invDimColor . text $ " +1 FREE SLOT"]
x -> [color invDimColor . text $ " +" ++ show x ++ " FREE SLOTS"]
equipcursor = case _crLeftInvSel cr of
Nothing -> mempty
Just invid -> listCursorNES 0 0 cfig (selNumPos invid w) yellow topInvW
(selNumSlots invid w)
subInventoryDisplay :: Configuration -> World -> Picture
subInventoryDisplay cfig w = case _inventoryMode w of
LockedInventory -> mempty -- topInvCursor col cursPos cfig w
TopInventory -> pictures
[ --closeObjectTexts cfig w
selcursor
[ selcursor
, closeobjectcursor
]
TweakInventory -> pictures
[ mCurs it cfig w
, cursorAt 120 col 5 0 cursPos cfig
, cursorsZ cfig cursPos it
, displayMidList cfig (ammoTweakStrings it) "TWEAK"
--[ mCurs it cfig w
[ selcursor' listCursorNESW
-- , cursorsZ cfig curpos it
, fromMaybe mempty $ do
tweaki <- it ^? _Just . itTweaks . tweakSel
-- consider moving this functionality out into a tweaks module
showtweak <- it ^? _Just . itTweaks . tweakParams . ix tweaki . showTweak
tweakname <- it ^? _Just . itTweaks . tweakParams . ix tweaki . nameTweak
tweakstring <- showtweak <$> (it ^? _Just . itTweaks . tweakParams . ix tweaki . curTweak)
return $ lnkMidInvSel cfig w curpos tweaki
<> listCursorNSW subInvX 60 cfig tweaki white (length $ tweakstring ++ tweakname) 1
, invHead cfig "TWEAK"
, listTextPicturesAt subInvX 60 cfig $ map text (ammoTweakStrings it)
]
CombineInventory mi -> pictures
[ invHead cfig "COMBINE"
, listTextPicturesAt 150 60 cfig $ map text $ combineListStrings w
, listTextPicturesAt subInvX 60 cfig $ combineListStringPictures w
, fromMaybe mempty $ do
i <- mi
return $ listCursorAt 150 60 cfig i white 10 1
cpos <- combinePoss w !? i
csize <- combineSizes w !? i
col <- (combineItemListYou w !? i) <&> _itInvColor . snd
return $ listCursorNSW subInvX 60 cfig cpos col 15 csize
, fromMaybe mempty $ do
i <- mi
lnks <- combineListLnks w !? i
return $ uncurry (lnkMidPosInvSels cfig w) lnks
return $ uncurry (lnkMidPosInvSels cfig w) lnks
<> foldMap (cursorAtInvSel listCursorNESW cfig w) (snd lnks)
]
InspectInventory -> invHead cfig "INSPECT"
where
itCol = fromMaybe (greyN 0.5) . (^? _Just . itInvColor)
closeobjectcursor = case selectedCloseObject w of
Nothing -> mempty
Just (i,co) -> listCursorNS clObjFloatIn 0 cfig (selNumPos i w) (closeObjectCol co) topInvW (invSelSize i w)
itcol = fromMaybe (greyN 0.5) (it ^? _Just . itInvColor)
--cr = you w
it = yourItem w
col = itCol it
cursPos = invSelPos w
selcursor
| IM.null inv && null (_closeObjects w) = mempty
| otherwise = listCursorAt 0 0 cfig curpos white curx cury
inv = _crInv cr
selcursor' ct = fromMaybe mempty $ ct 0 0 cfig curpos itcol topInvW cury <$ it
selcursor = selcursor' selcursortype
selcursortype
| ButtonRight `S.member` _mouseButtons w = listCursorNESW
| otherwise = listCursorNSW
curpos = invSelPos w
curx = 10
cury = fromMaybe 1 $ augmentedInvSizes w IM.!? _crInvSel (you w)
cr = _creatures w IM.! 0
topInvW :: Int
topInvW = 15
subInvX :: Float
subInvX = 9 * fromIntegral topInvW + 50
lnkMidInvSel :: Configuration -> World -> Int -> Int -> Picture
lnkMidInvSel cfig w lefti midi = winScale cfig
. color white
. zConnect rp $ selNumMidHeight cfig w lefti
where
-- lp ipos = V2 (150 - hw) ( hh - (20 * fromIntegral ipos + 17.5))
rp = V2 (190 - hw) ( hh - (20 * fromIntegral midi + 77.5))
hh = halfHeight cfig
hw = halfWidth cfig
lnkMidPosInvSels :: Configuration -> World -> Int -> [Int] -> Picture
lnkMidPosInvSels cfig w i is = winScale cfig . color white
. concatMap
(zConnect rp) $ map (lp . flip selNumPos w) is
lnkMidPosInvSels cfig w i = winScale cfig
. color white
. concatMap (zConnect rp . selNumMidHeight cfig w)
where
lp ipos = V2 (125 - hw) ( hh - (20 * fromIntegral ipos + 17.5))
rp = (V2 (155 - hw) ( hh - (20 * fromIntegral i + 77.5)))
-- lp ipos = V2 (150 - hw) ( hh - (20 * fromIntegral ipos + 17.5))
rp = V2 (190 - hw) ( hh - (20 * fromIntegral i + 77.5))
hh = halfHeight cfig
hw = halfWidth cfig
cursorsZ :: Configuration -> Int -> Maybe Item -> Picture
cursorsZ cfig ipos it = case it ^? _Just . itTweaks . tweakSel of
Nothing -> f $ zConnect sp (V2 (155- hw) ( hh - 77.5))
Just jpos -> f $ zConnect sp (V2 (155 - hw) ( hh - (20 * fromIntegral jpos + 77.5)))
where
f = winScale cfig . color white
hh = halfHeight cfig
hw = halfWidth cfig
sp = V2 (125 - hw) ( hh - (20 * fromIntegral ipos + 17.5))
cursorAtInvSel :: (Float -> Float -> Configuration -> Int -> Color -> Int -> Int -> Picture)
-> Configuration -> World -> Int -> Picture
cursorAtInvSel ctype cfig w i
= ctype 0 0 cfig (selNumPos i w) (selNumCol i w) topInvW (selNumSlots i w)
--listSelHeight :: Configuration -> World -> Int -> Float
--listSelHeight
combineListStrings :: World -> [String]
combineListStrings = map (show . snd) . combineListYou
combineListStringPictures :: World -> [Picture]
combineListStringPictures w = case concatMap (itemText . snd) . combineItemListYou $ w of
[] -> [text "NO POSSIBLE COMBINATIONS"]
xs -> xs
combineListLnks :: World -> [(Int,[Int])]
combineListLnks = zip [0..] . map fst . combineListYou
@@ -107,61 +163,16 @@ ammoTweakStrings it = case it ^? _Just . itTweaks . tweakParams of
Just l -> map tweakString $ IM.elems l
_ -> ["NOT TWEAKABLE"]
mCurs :: Maybe Item -> Configuration -> World -> Picture
mCurs it cfig w = case it ^? _Just . itTweaks . tweakSel of
Nothing -> []
Just i
| ButtonRight `S.member` _mouseButtons w ->
pictures
[cursorAt x white y 60 i cfig
,openCursorAt 20 white (x+y) 60 i cfig
]
| otherwise -> openCursorAt 140 white 155 60 i cfig
where
x = 117.5
y = 155
tweakString :: TweakParam -> String
tweakString tp = rightPad 12 ' ' (_nameTweak tp) ++ " " ++ _showTweak tp (_curTweak tp)
displayMidList :: Configuration -> [String] -> String -> Picture
displayMidList cfig strs s = invHead cfig s
`appendPic` renderListAt 150 (-60) cfig (strs <&> (,white))
invHead :: Configuration -> String -> Picture
invHead cfig s = winScale cfig
. translate (-130) (halfHeight cfig - 40)
. translate (-halfWidth cfig + subInvX + 20) (halfHeight cfig - 40)
. dShadCol white
. scale 0.4 0.4
$ text s
--renderItemMapAt :: Float -> Float -> Configuration -> IM.IntMap Item -> Picture
--{-# INLINE renderItemMapAt #-}
--renderItemMapAt tx ty cfig = concatMapPic (uncurry $ listItemAt tx ty cfig) . IM.toList
displayInv :: Int -> Configuration -> World -> Picture
displayInv n cfig w = listTextPicturesAt 0 0 cfig invlist
<> equipcursor
<> closeobjectcursor
where
closeobjectcursor = case selectedCloseObject w of
Nothing -> mempty
Just (i,_) -> listCursorAt 50 0 cfig (selNumPos i w) blue 15 (invSelSize i w)
inv = _crInv cr
invlist = concatMap itemText (IM.elems inv)
++ displayFreeSlots ++ concatMap (closeObjectToTextPictures nfreeslots) (_closeObjects w)
nfreeslots = crNumFreeSlots cr
displayFreeSlots = case nfreeslots of
0 -> [color invDimColor . text $ " INVENTORY FULL"]
1 -> [color invDimColor . text $ " +1 FREE SLOT"]
x -> [color invDimColor . text $ " +" ++ show x ++ " FREE SLOTS"]
--curpos = invSelPos w
--curx = 10
--cury = fromMaybe 1 $ augmentedInvSizes w IM.!? _crInvSel (you w)
equipcursor = case _crLeftInvSel cr of
Nothing -> mempty
Just invid -> openCursorAt 20 yellow 0 0 (selNumPos invid w) cfig
cr = _creatures w IM.! n
invDimColor :: Color
invDimColor = greyN 0.7
closeObjectToTextPictures :: Int -> Either FloorItem Button -> [Picture]
@@ -169,13 +180,19 @@ closeObjectToTextPictures nfreeslots e = case e of
Left flit -> let it = _flIt flit in map (applycolor it . textindent) $ _itInvDisplay it it
Right bt -> [color yellow $ textindent $ _btText bt]
where
textindent = text . (" "++)
textindent = text . (replicate clObjIntIn ' '++)
applycolor it
| nfreeslots >= itSlotsTaken it = color $ _itInvColor it
| otherwise = color invDimColor
drawLocations :: Configuration -> World -> Picture
drawLocations cfig w = pictures $
clObjIntIn :: Int
clObjIntIn = 2
clObjFloatIn :: Float
clObjFloatIn = fromIntegral clObjIntIn * 9
drawCarte :: Configuration -> World -> Picture
drawCarte cfig w = pictures $
renderListAt 0 0 cfig locs
: zipWith bConnect (displayListEndCoords cfig locTexts) locPoss
++ mapOverlay cfig w
@@ -247,12 +264,13 @@ mainListCursor c = openCursorAt 120 c 5 0
itemText :: Item -> [Picture]
{-# INLINE itemText #-}
itemText it = case _itCurseStatus it of
itemText it = f $ case _itCurseStatus it of
UndroppableIdentified -> map (color yellow . text) (_itInvDisplay it it)
-- <> color (withAlpha 0.9 thecolor) (polygon (rectNSEW 110 (-65) 885 (-90)))
_ -> map (color thecolor . text) (_itInvDisplay it it)
where
thecolor = _itInvColor it
f = take (itSlotsTaken it) . (++ replicate 10 (color (_itInvColor it) $ text "*"))
openCursorAt
@@ -271,24 +289,6 @@ openCursorAt wth col xoff yoff yint w = winScale w
,(V2 0 (-7.5),col)
,(V2 wth (-7.5),withAlpha 0 col)
]
cursorAt
:: Float -- ^ Width
-> Color
-> Float -- ^ x offset
-> Float -- ^ y offset
-> Int -- ^ y offset (discrete)
-> Configuration
-> Picture
cursorAt wth col xoff yoff yint cfig = winScale cfig
. translate (xoff-halfWidth cfig) (halfHeight cfig - (20* fromIntegral yint + yoff) - 20)
. color col
$ line
[V2 wth 12.5
,V2 0 12.5
,V2 0 (-7.5)
,V2 wth (-7.5)
,V2 wth 12.5
]
displayHP :: Int -> Configuration -> World -> Picture
displayHP cid cfig w = translate (halfWidth cfig-80) (halfHeight cfig-20)
src/Dodge/Render/List.hs
+34 -17
View File
@@ -4,34 +4,51 @@ import Dodge.Base.Window
import Dodge.WinScale
import Picture
import Geometry
--import Control.Monad
import Data.Maybe
-- given a list of pictures that are each the size of a "text" call, displays them as
-- a list on the screen
listTextPicturesAt :: Float -> Float -> Configuration -> [Picture] -> Picture
listTextPicturesAt tx ty cfig = mconcat . zipWith (listTextPictureAt tx ty cfig) [0..]
-- displays a cursor that should match up to list text pictures
-- the width of a character appears to be 9(?!)
listCursorAt :: Float -> Float -> Configuration -> Int -> Color -> Int -> Int -> Picture
listCursorAt xoff yoff cfig yint col cursxsize cursysize = winScale cfig
. translate (10.5+xoff-halfWidth cfig) (halfHeight cfig - (20* fromIntegral yint + yoff) - 20)
$ lineCol
[(V2 0 12.5 , col)
,(V2 wth 12.5 ,col)
] <>
lineCol
[(V2 0 (12.5 - hgt),col)
,(V2 wth (12.5 - hgt),col)
]
--[(V2 wth 12.5 ,withAlpha 0 col)
--,(V2 0 12.5 ,col)
--,(V2 0 (12.5 - hgt),col)
--,(V2 wth (12.5 - hgt),withAlpha 0 col)
--]
-- this is probably because it is 8 pixels plus one for the border
listCursorChooseBorder :: [Bool] -> Float -> Float -> Configuration -> Int -> Color -> Int -> Int -> Picture
listCursorChooseBorder borders xoff yoff cfig yint col cursxsize cursysize = winScale cfig
. translate (6+xoff-halfWidth cfig)
(halfHeight cfig + 12.5 - (20* fromIntegral yint + yoff + 20 + hgt))
. color col
$ chooseCursorBorders wth hgt borders
where
x = 9
wth = x * fromIntegral cursxsize
wth = x * fromIntegral cursxsize + 9
hgt = 20 * fromIntegral cursysize
-- note we cannot simply scale lines because they are drawn as solid rectangles
chooseCursorBorders :: Float -> Float -> [Bool] -> Picture
chooseCursorBorders wth hgt = concat . catMaybes . zipWith f
[ line [V2 0 hgt , V2 wth hgt ]
, line [V2 wth hgt , V2 wth 0 ]
, line [V2 wth 0 , V2 0 0 ]
, line [V2 0 0 , V2 0 hgt ]
]
where
f _ False = Nothing
f a True = Just a
listCursorNS :: Float -> Float -> Configuration -> Int -> Color -> Int -> Int -> Picture
listCursorNS = listCursorChooseBorder [True,False,True]
listCursorNES :: Float -> Float -> Configuration -> Int -> Color -> Int -> Int -> Picture
listCursorNES = listCursorChooseBorder [True,True,True]
listCursorNESW :: Float -> Float -> Configuration -> Int -> Color -> Int -> Int -> Picture
listCursorNESW = listCursorChooseBorder [True,True,True,True]
listCursorNSW :: Float -> Float -> Configuration -> Int -> Color -> Int -> Int -> Picture
listCursorNSW = listCursorChooseBorder [True,False,True,True]
listTextPictureAt :: Float -> Float -> Configuration -> Int -> Picture -> Picture
listTextPictureAt xoff yoff cfig yint = winScale cfig
src/Dodge/Tweak.hs
+1
View File
@@ -0,0 +1 @@
module Dodge.Tweak where
src/Multiset.hs
+1 -1
View File
@@ -14,4 +14,4 @@ powlist :: [a] -> [[a]]
powlist = filterM (const [True,False])
toMultiset :: Ord a => [a] -> M.Map a Int
toMultiset = foldr (uncurry $ M.insertWith (+)) M.empty . map (,1)
toMultiset = foldr (uncurry (M.insertWith (+)) . (, 1)) M.empty