{-# LANGUAGE GeneralizedNewtypeDeriving #-}
module Game.LambdaHack.Client.UI.ItemSlot
( SlotChar(..), ItemSlots(..), SingleItemSlots
, allSlots, intSlots, slotLabel
, assignSlot, partyItemSet, sortSlotMap, mergeItemSlots
) where
import Prelude ()
import Game.LambdaHack.Core.Prelude
import Data.Binary
import Data.Bits (unsafeShiftL, unsafeShiftR)
import Data.Char
import qualified Data.EnumMap.Strict as EM
import qualified Data.EnumSet as ES
import Data.Function
import Data.Ord (comparing)
import qualified Data.Text as T
import Game.LambdaHack.Common.Actor
import Game.LambdaHack.Common.ActorState
import Game.LambdaHack.Common.Item
import Game.LambdaHack.Common.State
import Game.LambdaHack.Common.Types
import qualified Game.LambdaHack.Content.ItemKind as IK
import Game.LambdaHack.Definition.Defs
data SlotChar = SlotChar {SlotChar -> Int
slotPrefix :: Int, SlotChar -> Char
slotChar :: Char}
deriving (Int -> SlotChar -> ShowS
[SlotChar] -> ShowS
SlotChar -> String
(Int -> SlotChar -> ShowS)
-> (SlotChar -> String) -> ([SlotChar] -> ShowS) -> Show SlotChar
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [SlotChar] -> ShowS
$cshowList :: [SlotChar] -> ShowS
show :: SlotChar -> String
$cshow :: SlotChar -> String
showsPrec :: Int -> SlotChar -> ShowS
$cshowsPrec :: Int -> SlotChar -> ShowS
Show, SlotChar -> SlotChar -> Bool
(SlotChar -> SlotChar -> Bool)
-> (SlotChar -> SlotChar -> Bool) -> Eq SlotChar
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: SlotChar -> SlotChar -> Bool
$c/= :: SlotChar -> SlotChar -> Bool
== :: SlotChar -> SlotChar -> Bool
$c== :: SlotChar -> SlotChar -> Bool
Eq)
instance Ord SlotChar where
compare :: SlotChar -> SlotChar -> Ordering
compare = (SlotChar -> Int) -> SlotChar -> SlotChar -> Ordering
forall a b. Ord a => (b -> a) -> b -> b -> Ordering
comparing SlotChar -> Int
forall a. Enum a => a -> Int
fromEnum
instance Binary SlotChar where
put :: SlotChar -> Put
put = Int -> Put
forall t. Binary t => t -> Put
put (Int -> Put) -> (SlotChar -> Int) -> SlotChar -> Put
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SlotChar -> Int
forall a. Enum a => a -> Int
fromEnum
get :: Get SlotChar
get = (Int -> SlotChar) -> Get Int -> Get SlotChar
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Int -> SlotChar
forall a. Enum a => Int -> a
toEnum Get Int
forall t. Binary t => Get t
get
instance Enum SlotChar where
fromEnum :: SlotChar -> Int
fromEnum (SlotChar n :: Int
n c :: Char
c) =
Int -> Int -> Int
forall a. Bits a => a -> Int -> a
unsafeShiftL Int
n 8 Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Char -> Int
ord Char
c Int -> Int -> Int
forall a. Num a => a -> a -> a
+ (if Char -> Bool
isUpper Char
c then 100 else 0)
toEnum :: Int -> SlotChar
toEnum e :: Int
e =
let n :: Int
n = Int -> Int -> Int
forall a. Bits a => a -> Int -> a
unsafeShiftR Int
e 8
c0 :: Int
c0 = Int
e Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int -> Int -> Int
forall a. Bits a => a -> Int -> a
unsafeShiftL Int
n 8
c100 :: Int
c100 = Int
c0 Int -> Int -> Int
forall a. Num a => a -> a -> a
- if Int
c0 Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> 150 then 100 else 0
in Int -> Char -> SlotChar
SlotChar Int
n (Int -> Char
chr Int
c100)
type SingleItemSlots = EM.EnumMap SlotChar ItemId
newtype ItemSlots = ItemSlots (EM.EnumMap SLore SingleItemSlots)
deriving (Int -> ItemSlots -> ShowS
[ItemSlots] -> ShowS
ItemSlots -> String
(Int -> ItemSlots -> ShowS)
-> (ItemSlots -> String)
-> ([ItemSlots] -> ShowS)
-> Show ItemSlots
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [ItemSlots] -> ShowS
$cshowList :: [ItemSlots] -> ShowS
show :: ItemSlots -> String
$cshow :: ItemSlots -> String
showsPrec :: Int -> ItemSlots -> ShowS
$cshowsPrec :: Int -> ItemSlots -> ShowS
Show, Get ItemSlots
[ItemSlots] -> Put
ItemSlots -> Put
(ItemSlots -> Put)
-> Get ItemSlots -> ([ItemSlots] -> Put) -> Binary ItemSlots
forall t. (t -> Put) -> Get t -> ([t] -> Put) -> Binary t
putList :: [ItemSlots] -> Put
$cputList :: [ItemSlots] -> Put
get :: Get ItemSlots
$cget :: Get ItemSlots
put :: ItemSlots -> Put
$cput :: ItemSlots -> Put
Binary)
allChars :: [Char]
allChars :: String
allChars = ['a'..'z'] String -> ShowS
forall a. [a] -> [a] -> [a]
++ ['A'..'Z']
allSlots :: [SlotChar]
allSlots :: [SlotChar]
allSlots = (Int -> [SlotChar]) -> [Int] -> [SlotChar]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (\n :: Int
n -> (Char -> SlotChar) -> String -> [SlotChar]
forall a b. (a -> b) -> [a] -> [b]
map (Int -> Char -> SlotChar
SlotChar Int
n) String
allChars) [0..]
intSlots :: [SlotChar]
intSlots :: [SlotChar]
intSlots = (Int -> SlotChar) -> [Int] -> [SlotChar]
forall a b. (a -> b) -> [a] -> [b]
map ((Int -> Char -> SlotChar) -> Char -> Int -> SlotChar
forall a b c. (a -> b -> c) -> b -> a -> c
flip Int -> Char -> SlotChar
SlotChar 'a') [0..]
slotLabel :: SlotChar -> Text
slotLabel :: SlotChar -> Text
slotLabel x :: SlotChar
x =
Text -> Char -> Text
T.snoc (if SlotChar -> Int
slotPrefix SlotChar
x Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== 0 then Text
T.empty else Int -> Text
forall a. Show a => a -> Text
tshow (Int -> Text) -> Int -> Text
forall a b. (a -> b) -> a -> b
$ SlotChar -> Int
slotPrefix SlotChar
x)
(SlotChar -> Char
slotChar SlotChar
x)
Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> ")"
assignSlot :: SingleItemSlots -> SlotChar
assignSlot :: SingleItemSlots -> SlotChar
assignSlot lSlots :: SingleItemSlots
lSlots =
let maxPrefix :: Int
maxPrefix = case SingleItemSlots -> Maybe ((SlotChar, ItemId), SingleItemSlots)
forall k a. Enum k => EnumMap k a -> Maybe ((k, a), EnumMap k a)
EM.maxViewWithKey SingleItemSlots
lSlots of
Just ((lm :: SlotChar
lm, _), _) -> SlotChar -> Int
slotPrefix SlotChar
lm
Nothing -> 0
in Int -> Char -> SlotChar
SlotChar (Int
maxPrefix Int -> Int -> Int
forall a. Num a => a -> a -> a
+ 1) 'x'
partyItemSet :: SLore -> FactionId -> Maybe Actor -> State -> ES.EnumSet ItemId
partyItemSet :: SLore -> FactionId -> Maybe Actor -> State -> EnumSet ItemId
partyItemSet slore :: SLore
slore fid :: FactionId
fid mbody :: Maybe Actor
mbody s :: State
s =
let onPersons :: ItemBag
onPersons = SLore -> FactionId -> State -> ItemBag
combinedFromLore SLore
slore FactionId
fid State
s
onGround :: ItemBag
onGround = ItemBag -> (Actor -> ItemBag) -> Maybe Actor -> ItemBag
forall b a. b -> (a -> b) -> Maybe a -> b
maybe ItemBag
forall k a. EnumMap k a
EM.empty
(\b :: Actor
b -> LevelId -> Point -> State -> ItemBag
getFloorBag (Actor -> LevelId
blid Actor
b) (Actor -> Point
bpos Actor
b) State
s)
Maybe Actor
mbody
in [EnumSet ItemId] -> EnumSet ItemId
forall k. [EnumSet k] -> EnumSet k
ES.unions ([EnumSet ItemId] -> EnumSet ItemId)
-> [EnumSet ItemId] -> EnumSet ItemId
forall a b. (a -> b) -> a -> b
$ (ItemBag -> EnumSet ItemId) -> [ItemBag] -> [EnumSet ItemId]
forall a b. (a -> b) -> [a] -> [b]
map ItemBag -> EnumSet ItemId
forall k a. Enum k => EnumMap k a -> EnumSet k
EM.keysSet ([ItemBag] -> [EnumSet ItemId]) -> [ItemBag] -> [EnumSet ItemId]
forall a b. (a -> b) -> a -> b
$ ItemBag
onPersons ItemBag -> [ItemBag] -> [ItemBag]
forall a. a -> [a] -> [a]
: [ItemBag
onGround | SLore
slore SLore -> SLore -> Bool
forall a. Eq a => a -> a -> Bool
== SLore
SItem]
compareItemFull :: ItemFull -> ItemFull -> Ordering
compareItemFull :: ItemFull -> ItemFull -> Ordering
compareItemFull itemFull1 :: ItemFull
itemFull1 itemFull2 :: ItemFull
itemFull2 =
let kindAndAppearance :: ItemFull
-> (Bool, ContentId ItemKind, ItemDisco, Char, Text, Flavour,
Maybe FactionId)
kindAndAppearance ItemFull{itemBase :: ItemFull -> Item
itemBase=Item{..}, ..} =
( Bool -> Bool
not Bool
itemSuspect, ContentId ItemKind
itemKindId, ItemDisco
itemDisco
, ItemKind -> Char
IK.isymbol ItemKind
itemKind, ItemKind -> Text
IK.iname ItemKind
itemKind
, Flavour
jflavour, Maybe FactionId
jfid )
in (ItemFull
-> (Bool, ContentId ItemKind, ItemDisco, Char, Text, Flavour,
Maybe FactionId))
-> ItemFull -> ItemFull -> Ordering
forall a b. Ord a => (b -> a) -> b -> b -> Ordering
comparing ItemFull
-> (Bool, ContentId ItemKind, ItemDisco, Char, Text, Flavour,
Maybe FactionId)
kindAndAppearance ItemFull
itemFull1 ItemFull
itemFull2
sortSlotMap :: (ItemId -> ItemFull) -> SingleItemSlots -> SingleItemSlots
sortSlotMap :: (ItemId -> ItemFull) -> SingleItemSlots -> SingleItemSlots
sortSlotMap itemToF :: ItemId -> ItemFull
itemToF em :: SingleItemSlots
em =
let f :: ItemId -> (ItemId, ItemFull)
f iid :: ItemId
iid = (ItemId
iid, ItemId -> ItemFull
itemToF ItemId
iid)
sortItemIds :: [ItemId] -> [ItemId]
sortItemIds l :: [ItemId]
l = ((ItemId, ItemFull) -> ItemId) -> [(ItemId, ItemFull)] -> [ItemId]
forall a b. (a -> b) -> [a] -> [b]
map (ItemId, ItemFull) -> ItemId
forall a b. (a, b) -> a
fst ([(ItemId, ItemFull)] -> [ItemId])
-> [(ItemId, ItemFull)] -> [ItemId]
forall a b. (a -> b) -> a -> b
$ ((ItemId, ItemFull) -> (ItemId, ItemFull) -> Ordering)
-> [(ItemId, ItemFull)] -> [(ItemId, ItemFull)]
forall a. (a -> a -> Ordering) -> [a] -> [a]
sortBy (ItemFull -> ItemFull -> Ordering
compareItemFull (ItemFull -> ItemFull -> Ordering)
-> ((ItemId, ItemFull) -> ItemFull)
-> (ItemId, ItemFull)
-> (ItemId, ItemFull)
-> Ordering
forall b c a. (b -> b -> c) -> (a -> b) -> a -> a -> c
`on` (ItemId, ItemFull) -> ItemFull
forall a b. (a, b) -> b
snd)
([(ItemId, ItemFull)] -> [(ItemId, ItemFull)])
-> [(ItemId, ItemFull)] -> [(ItemId, ItemFull)]
forall a b. (a -> b) -> a -> b
$ (ItemId -> (ItemId, ItemFull)) -> [ItemId] -> [(ItemId, ItemFull)]
forall a b. (a -> b) -> [a] -> [b]
map ItemId -> (ItemId, ItemFull)
f [ItemId]
l
in [(SlotChar, ItemId)] -> SingleItemSlots
forall k a. Enum k => [(k, a)] -> EnumMap k a
EM.fromDistinctAscList ([(SlotChar, ItemId)] -> SingleItemSlots)
-> [(SlotChar, ItemId)] -> SingleItemSlots
forall a b. (a -> b) -> a -> b
$ [SlotChar] -> [ItemId] -> [(SlotChar, ItemId)]
forall a b. [a] -> [b] -> [(a, b)]
zip [SlotChar]
allSlots ([ItemId] -> [(SlotChar, ItemId)])
-> [ItemId] -> [(SlotChar, ItemId)]
forall a b. (a -> b) -> a -> b
$ [ItemId] -> [ItemId]
sortItemIds ([ItemId] -> [ItemId]) -> [ItemId] -> [ItemId]
forall a b. (a -> b) -> a -> b
$ SingleItemSlots -> [ItemId]
forall k a. EnumMap k a -> [a]
EM.elems SingleItemSlots
em
mergeItemSlots :: (ItemId -> ItemFull) -> [SingleItemSlots] -> SingleItemSlots
mergeItemSlots :: (ItemId -> ItemFull) -> [SingleItemSlots] -> SingleItemSlots
mergeItemSlots itemToF :: ItemId -> ItemFull
itemToF ems :: [SingleItemSlots]
ems =
let renumberSlot :: Int -> SlotChar -> SlotChar
renumberSlot n :: Int
n SlotChar{Int
slotPrefix :: Int
slotPrefix :: SlotChar -> Int
slotPrefix, Char
slotChar :: Char
slotChar :: SlotChar -> Char
slotChar} =
$WSlotChar :: Int -> Char -> SlotChar
SlotChar{slotPrefix :: Int
slotPrefix = Int
slotPrefix Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
n Int -> Int -> Int
forall a. Num a => a -> a -> a
* 1000000, Char
slotChar :: Char
slotChar :: Char
slotChar}
renumberMap :: Int -> EnumMap SlotChar a -> EnumMap SlotChar a
renumberMap n :: Int
n = (SlotChar -> SlotChar) -> EnumMap SlotChar a -> EnumMap SlotChar a
forall k a. Enum k => (k -> k) -> EnumMap k a -> EnumMap k a
EM.mapKeys (Int -> SlotChar -> SlotChar
renumberSlot Int
n)
rms :: [SingleItemSlots]
rms = (Int -> SingleItemSlots -> SingleItemSlots)
-> [Int] -> [SingleItemSlots] -> [SingleItemSlots]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith Int -> SingleItemSlots -> SingleItemSlots
forall a. Int -> EnumMap SlotChar a -> EnumMap SlotChar a
renumberMap [0..] [SingleItemSlots]
ems
em :: SingleItemSlots
em = (ItemId -> ItemId -> ItemId)
-> [SingleItemSlots] -> SingleItemSlots
forall a k. (a -> a -> a) -> [EnumMap k a] -> EnumMap k a
EM.unionsWith (\_ _ -> String -> ItemId
forall a. HasCallStack => String -> a
error "mergeItemSlots: duplicate keys") [SingleItemSlots]
rms
in (ItemId -> ItemFull) -> SingleItemSlots -> SingleItemSlots
sortSlotMap ItemId -> ItemFull
itemToF SingleItemSlots
em