diff --git a/src/Dodge/Combine.hs b/src/Dodge/Combine.hs index 65895578d..f66d3d3e3 100644 --- a/src/Dodge/Combine.hs +++ b/src/Dodge/Combine.hs @@ -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 diff --git a/src/Dodge/Creature.hs b/src/Dodge/Creature.hs index 340e1ac68..d4110f03e 100644 --- a/src/Dodge/Creature.hs +++ b/src/Dodge/Creature.hs @@ -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 diff --git a/src/Dodge/Creature/Impulse/UseItem.hs b/src/Dodge/Creature/Impulse/UseItem.hs index 90b99dea7..f90d7572c 100644 --- a/src/Dodge/Creature/Impulse/UseItem.hs +++ b/src/Dodge/Creature/Impulse/UseItem.hs @@ -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 diff --git a/src/Dodge/Creature/Picture.hs b/src/Dodge/Creature/Picture.hs index e037ee881..e89a36565 100644 --- a/src/Dodge/Creature/Picture.hs +++ b/src/Dodge/Creature/Picture.hs @@ -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 diff --git a/src/Dodge/Inventory.hs b/src/Dodge/Inventory.hs index 9418e8951..eaff6ff15 100644 --- a/src/Dodge/Inventory.hs +++ b/src/Dodge/Inventory.hs @@ -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) diff --git a/src/Dodge/Inventory/Add.hs b/src/Dodge/Inventory/Add.hs index 017d72953..c2d731ada 100644 --- a/src/Dodge/Inventory/Add.hs +++ b/src/Dodge/Inventory/Add.hs @@ -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 diff --git a/src/Dodge/Item/Weapon/BulletGuns.hs b/src/Dodge/Item/Weapon/BulletGuns.hs index cb5af1dfd..07eef9cee 100644 --- a/src/Dodge/Item/Weapon/BulletGuns.hs +++ b/src/Dodge/Item/Weapon/BulletGuns.hs @@ -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] diff --git a/src/Dodge/Item/Weapon/InventoryDisplay.hs b/src/Dodge/Item/Weapon/InventoryDisplay.hs index 1baf06eee..91a7b6815 100644 --- a/src/Dodge/Item/Weapon/InventoryDisplay.hs +++ b/src/Dodge/Item/Weapon/InventoryDisplay.hs @@ -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 diff --git a/src/Dodge/Item/Weapon/Launcher.hs b/src/Dodge/Item/Weapon/Launcher.hs index 151c38e28..0ed63525e 100644 --- a/src/Dodge/Item/Weapon/Launcher.hs +++ b/src/Dodge/Item/Weapon/Launcher.hs @@ -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 diff --git a/src/Dodge/Item/Weapon/TriggerType.hs b/src/Dodge/Item/Weapon/TriggerType.hs index 63e13afb3..975eba81c 100644 --- a/src/Dodge/Item/Weapon/TriggerType.hs +++ b/src/Dodge/Item/Weapon/TriggerType.hs @@ -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) diff --git a/src/Dodge/Render/HUD.hs b/src/Dodge/Render/HUD.hs index e53712ea6..c52e11d2b 100644 --- a/src/Dodge/Render/HUD.hs +++ b/src/Dodge/Render/HUD.hs @@ -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) diff --git a/src/Dodge/Render/List.hs b/src/Dodge/Render/List.hs index f1530f977..2d95d83cd 100644 --- a/src/Dodge/Render/List.hs +++ b/src/Dodge/Render/List.hs @@ -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 diff --git a/src/Dodge/Tweak.hs b/src/Dodge/Tweak.hs new file mode 100644 index 000000000..69ac89e5f --- /dev/null +++ b/src/Dodge/Tweak.hs @@ -0,0 +1 @@ +module Dodge.Tweak where diff --git a/src/Multiset.hs b/src/Multiset.hs index 418c53def..93dd16542 100644 --- a/src/Multiset.hs +++ b/src/Multiset.hs @@ -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