182 lines
7.2 KiB
Haskell
182 lines
7.2 KiB
Haskell
module Dodge.Item.Grammar
|
|
-- (invTree
|
|
-- , indentInv
|
|
-- )
|
|
where
|
|
import Control.Applicative
|
|
import Data.Maybe
|
|
import ListHelp
|
|
import Dodge.Data.Item
|
|
import Dodge.Data.DoubleTree
|
|
import Dodge.Data.ComposedItem
|
|
--import TreeHelp
|
|
import qualified Data.IntMap.Strict as IM
|
|
import Control.Lens
|
|
import Dodge.DoubleTree
|
|
|
|
type ComposedItemStructure
|
|
= (Item,ComposedItem,[(ComposeLinkType,ComposedItem)], [(ComposeLinkType,ComposedItem)])
|
|
|
|
type CIL = (ComposedItem,[(ComposeLinkType,ComposedItem)], [(ComposeLinkType,ComposedItem)])
|
|
|
|
cisToItem :: ComposedItemStructure -> Item
|
|
cisToItem (x,_,_,_) = x
|
|
|
|
singleDT :: a -> DoubleTree a
|
|
singleDT x = DT x [] []
|
|
|
|
singleLDT :: a -> LabelDoubleTree b a
|
|
singleLDT x = LDT x [] []
|
|
|
|
baseComposedItem :: ItemBaseType -> Item -> CIL
|
|
baseComposedItem ibt itm = case ibt of
|
|
HELD _ -> heldComposedItem itm
|
|
AMMOMAG _ -> ammoComposedItem itm
|
|
ATTACH BULLETSYNTHESIZER -> (AmmoModifierCI BulletAmmo, [], [])
|
|
_ -> (UncomposableCI, [], [])
|
|
|
|
heldComposedItem :: Item -> CIL
|
|
heldComposedItem itm = (WeaponCI, map f ats, [])
|
|
where
|
|
ats = itm ^.. itUse . heldAmmoTypes . traverse
|
|
f atype = (AmmoInLink atype,AmmoCI atype)
|
|
|
|
ammoComposedItem :: Item -> CIL
|
|
ammoComposedItem itm = fromMaybe (error "in ammoComposedItem, wrong item") $ do
|
|
atype <- itm ^? itUse . amagType
|
|
return (AmmoCI atype, [(AmmoModLink,AmmoModifierCI atype)], [])
|
|
|
|
baseCIS :: Item -> ComposedItemStructure
|
|
baseCIS itm = let (a,b,c) = baseComposedItem (itm ^. itType . iyBase) itm
|
|
in (itm, a, b, c)
|
|
|
|
type LDTTest a b = LabelDoubleTree b a -> LabelDoubleTree b a -> Maybe b
|
|
type LDTCombine a b = LabelDoubleTree b a -> LabelDoubleTree b a -> b -> LabelDoubleTree b a
|
|
|
|
type LDTComb a b = LabelDoubleTree b a -> LabelDoubleTree b a -> Maybe (LabelDoubleTree b a)
|
|
|
|
-- the following imposes a strict ordering on the possible attachments
|
|
leftIsParentCombine :: LDTComb ComposedItemStructure ComposeLinkType
|
|
leftIsParentCombine (LDT (itm,p,lc,rc) lt rt) t'@(LDT (_,p',_,_) _ _) = do
|
|
let f (_,x) = p' == x
|
|
(_,ys) = break f rc
|
|
(linktype,_) <- safeHead ys
|
|
return $ LDT (itm,p,lc,tail ys) lt (rt ++ [(linktype,t')])
|
|
|
|
rightIsParentCombine :: LDTComb ComposedItemStructure ComposeLinkType
|
|
rightIsParentCombine t'@(LDT (_,p',_,_) _ _) (LDT (itm,p,lc,rc) lt rt) = do
|
|
let f (_,x) = p' == x
|
|
(_,ys) = break f lc
|
|
(linktype,_) <- safeHead ys
|
|
return $ LDT (itm,p,tail ys,rc) ((linktype,t'):lt) rt
|
|
|
|
leftRightCombine :: LDTComb a b -> LDTComb a b
|
|
-> LabelDoubleTree b a -> LabelDoubleTree b a -> Maybe (LabelDoubleTree b a)
|
|
leftRightCombine f f' t1 t2 = f t1 t2
|
|
<|> checkdepth t1 t2
|
|
where
|
|
checkdepth t t'@(LDT x ls rs) = fromMaybe (checktop t t') $ do
|
|
(lab,t'') <- safeHead ls
|
|
tx <- checkdepth t t''
|
|
return $ Just $ LDT x ((lab,tx):tail ls) rs
|
|
checktop t t' = f' t t'
|
|
|
|
joinItemsInList :: (a -> a -> Maybe a) -> [a] -> [a]
|
|
joinItemsInList f xs = snd $ h (xs,[])
|
|
where
|
|
h ([],zs) = ([],zs)
|
|
h ((y:ys), []) = h (ys, [y])
|
|
h ((y:ys),(z:zs)) = case f y z of
|
|
Nothing -> h (ys, (y:z:zs))
|
|
Just w -> h ((w:ys),zs)
|
|
|
|
invLDT :: IM.IntMap Item -> [LabelDoubleTree ComposeLinkType ComposedItemStructure]
|
|
invLDT = joinItemsInList (leftRightCombine leftIsParentCombine rightIsParentCombine) . IM.elems .
|
|
fmap (singleLDT . baseCIS)
|
|
|
|
invAdj :: IM.IntMap Item -> IM.IntMap ([Int],[Int])
|
|
invAdj = IM.unions . fmap (dtToUpDownAdj getid . ldtToDT) . invLDT
|
|
where
|
|
getid (itm, _,_,_) = fromMaybe (error "invAdj attempt to find item not in inventory") $
|
|
itm ^? itLocation . ipInvID
|
|
|
|
invIndentIM :: IM.IntMap Item -> IM.IntMap (Item,Int, LabelDoubleTreeNodeType ComposeLinkType )
|
|
invIndentIM = IM.fromAscList . zip [0..] . reverse . map (over _1 cisToItem) . concatMap ldtToIndentList . invLDT
|
|
|
|
--invTrees :: IM.IntMap Item -> [(LabelDoubleTree ComposeLinkType Item)]
|
|
invTrees :: IM.IntMap Item -> IM.IntMap (LabelDoubleTree ComposeLinkType Item)
|
|
--invTrees = map (ldtToIM getindex) . map (fmap cisToItem) . invLDT
|
|
--invTrees = map (ldtToIM getindex) . map (fmap cisToItem) . invLDT
|
|
invTrees = IM.unions . map (ldtToIM getindex) . map (fmap cisToItem) . invLDT
|
|
where
|
|
getindex :: Item -> Int
|
|
getindex i = fromMaybe (error "in invTrees try to get non-inventory item tree") $
|
|
i ^? itLocation . ipInvID
|
|
|
|
--indentInv :: IM.IntMap Item -> [String]
|
|
--indentInv = concat . fmap (flattenDT . indentDoubleTreeWith (' ':) ('|':) ('+':) . fmap const "")
|
|
-- . joinItemsInList joinItems
|
|
-- . IM.toList . fmap (singleDT . baseComposedItem)
|
|
--
|
|
--type PCI = (ComposedItem, [ComposedItem], [ComposedItem])
|
|
--
|
|
--type PCI' = (Item,ComposedItem,[ComposedItem], [ComposedItem])
|
|
|
|
--baseComposedItem :: ItemBaseType -> PCI
|
|
--baseComposedItem ibt = case ibt of
|
|
-- HELD BURSTRIFLE -> (WeaponCI, [BulletAmmoCI], [])
|
|
-- AMMOMAG TINMAG -> (BulletAmmoCI, [AmmoModifierCI], [])
|
|
-- AMMOMAG DRUMMAG -> (BulletAmmoCI, [AmmoModifierCI], [])
|
|
-- ATTACH BULLETSYNTHESIZER -> (AmmoModifierCI, [], [])
|
|
-- _ -> (UncomposableCI, [], [])
|
|
--
|
|
--baseCI :: Item -> PCI'
|
|
--baseCI itm = let (a,b,c) = baseComposedItem (itm ^. itType . iyBase)
|
|
-- in (itm, a, b, c)
|
|
--
|
|
--joinItems :: DoubleTree PCI' -> DoubleTree PCI' -> Maybe (DoubleTree PCI')
|
|
--joinItems t@(DT (itm,px,lc',rc') ls' rs') s@(DT (_,py,_,_) _ _)
|
|
-- | py `elem` rc' = Just (DT (itm,px,lc', delete py rc') ls' (rs' ++ [s]))
|
|
-- | otherwise = checkdepth t s
|
|
-- where
|
|
-- checkdepth a a'@(DT b ls rs) = fromMaybe (checktop a a') $ do
|
|
-- c <- safeHead ls
|
|
-- d <- checkdepth a c
|
|
-- return $ Just $ DT b (d:tail ls) rs
|
|
-- checktop a@(DT (_,pa,_,_) _ _) (DT (itm2,pb,lc,rc) ls rs)
|
|
-- | pa `elem` lc = Just (DT (itm2,pb, delete pa lc,rc) (a:ls) rs)
|
|
-- | otherwise = Nothing
|
|
--
|
|
--invTree :: IM.IntMap Item -> [String]
|
|
--invTree = concatMap (prettyDT (\(itm,_,_,_) -> show (_itType itm))) .
|
|
-- joinItemsInList joinItems . IM.elems . fmap (singleDT . baseCI)
|
|
|
|
--indentInv :: IM.IntMap Item -> IM.IntMap String
|
|
--indentInv = IM.fromList . zip [0..] .
|
|
-- reverse . concatMap (flattenDT .indentDoubleTreeWith (' ':) ('|':) ('+':) . fmap (const "")) .
|
|
-- joinItemsInList joinItems . IM.elems . fmap (singleDT . baseCI)
|
|
--
|
|
--indentDoubleTreeWith :: (a -> a) -> (a -> a) -> (a -> a) -> DoubleTree a -> DoubleTree a
|
|
--indentDoubleTreeWith f g h (DT x l r) = DT x
|
|
-- (headMap (iDTL f g h) (iDTboth f g h) l)
|
|
-- (lastMap (iDTR f g h) (iDTboth f g h) r)
|
|
--
|
|
--iDTL :: (a -> a) -> (a -> a) -> (a -> a) -> DoubleTree a -> DoubleTree a
|
|
--iDTL fspace fline flink (DT x l r) = DT (flink x)
|
|
-- (map (fmap fspace . indentDoubleTreeWith fspace fline flink) l)
|
|
-- (map (fmap fline . indentDoubleTreeWith fspace fline flink) r)
|
|
--
|
|
--iDTR :: (a -> a) -> (a -> a) -> (a -> a) -> DoubleTree a -> DoubleTree a
|
|
--iDTR fspace fline flink (DT x l r) = DT (flink x)
|
|
-- (map (fmap fline . indentDoubleTreeWith fspace fline flink) l)
|
|
-- (map (fmap fspace . indentDoubleTreeWith fspace fline flink) r)
|
|
--
|
|
--iDTboth :: (a -> a) -> (a -> a) -> (a -> a) -> DoubleTree a -> DoubleTree a
|
|
--iDTboth fspace fline flink (DT x l r) = DT (flink x)
|
|
-- (map (fmap fline . indentDoubleTreeWith fspace fline flink) l)
|
|
-- (map (fmap fline . indentDoubleTreeWith fspace fline flink) r)
|
|
|
|
--combineMaybe :: (a -> a -> Maybe b) -> (a -> a -> b -> a) -> a -> a -> Maybe a
|
|
--combineMaybe t f x y = fmap (f x y) (t x y)
|
|
|