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

Add link types to attachment tree

Browse Source
This commit is contained in:
justin
2024-09-11 11:33:08 +01:00
parent c80217a970
commit 60c399935e
6 changed files with 128 additions and 61 deletions
Download Patch File Download Diff File Expand all files Collapse all files
src/Dodge/Data/ComposedItem.hs
+2
View File
@@ -9,6 +9,8 @@ import Control.Lens
import Data.Aeson
import Data.Aeson.TH
data ComposeLinkType = AmmoInLink
| AmmoModLink
data ComposedItem = WeaponCI
| WeaponScopeCI
src/Dodge/Data/DoubleTree.hs
+8
View File
@@ -8,13 +8,21 @@ module Dodge.Data.DoubleTree
import Control.Lens
import Data.Aeson
import Data.Aeson.TH
import Data.Bifunctor
data DoubleTree a = DT {_dtValue :: a,_dtLeft :: [DoubleTree a],_dtRight :: [DoubleTree a]}
deriving (Eq,Ord,Show,Read)
data LabelDoubleTree b a = LDT {_ldtValue :: a, _ldtLeft :: [(b,LabelDoubleTree b a)]
,_ldtRight :: [(b,LabelDoubleTree b a)]}
deriving (Eq,Ord,Show,Read)
instance Functor DoubleTree where
fmap f (DT x l r) = DT (f x) (fmap (fmap f) l) (fmap (fmap f) r)
instance Functor (LabelDoubleTree b) where
fmap f (LDT x l r) = LDT (f x) (fmap (second $ fmap f) l) (fmap (second $ fmap f) r)
makeLenses ''DoubleTree
deriveJSON defaultOptions ''DoubleTree
src/Dodge/Item/Grammar.hs
+66 -27
View File
@@ -1,5 +1,9 @@
module Dodge.Item.Grammar
-- (invTree
-- , indentInv
-- )
where
import Control.Applicative
import Data.Maybe
import ListHelp
import Dodge.Data.Item
@@ -13,9 +17,16 @@ type PCI = (ComposedItem, [ComposedItem], [ComposedItem])
type PCI' = (Item,ComposedItem,[ComposedItem], [ComposedItem])
type PCI'' = (Item,ComposedItem,[(ComposeLinkType,ComposedItem)], [(ComposeLinkType,ComposedItem)])
type CIL = (ComposedItem,[(ComposeLinkType,ComposedItem)], [(ComposeLinkType,ComposedItem)])
singleDT :: a -> DoubleTree a
singleDT x = DT x [] []
singleLDT :: a -> LabelDoubleTree b a
singleLDT x = LDT x [] []
baseComposedItem :: ItemBaseType -> PCI
baseComposedItem ibt = case ibt of
HELD BURSTRIFLE -> (WeaponCI, [BulletAmmoCI], [])
@@ -24,10 +35,56 @@ baseComposedItem ibt = case ibt of
ATTACH BULLETSYNTHESIZER -> (AmmoModifierCI, [], [])
_ -> (UncomposableCI, [], [])
baseComposedItem' :: ItemBaseType -> CIL
baseComposedItem' ibt = case ibt of
HELD BURSTRIFLE -> (WeaponCI, [(AmmoInLink,BulletAmmoCI)], [])
AMMOMAG TINMAG -> (BulletAmmoCI, [(AmmoModLink,AmmoModifierCI)], [])
AMMOMAG DRUMMAG -> (BulletAmmoCI, [(AmmoModLink,AmmoModifierCI)], [])
ATTACH BULLETSYNTHESIZER -> (AmmoModifierCI, [], [])
_ -> (UncomposableCI, [], [])
basePCI :: Item -> PCI''
basePCI itm = let (a,b,c) = baseComposedItem' (itm ^. itType . iyBase)
in (itm, a, b, c)
baseCI :: Item -> PCI'
baseCI itm = let (a,b,c) = baseComposedItem (itm ^. itType . iyBase)
in (itm, a, b, c)
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)
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 PCI'' 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 PCI'' 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'
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]))
@@ -41,33 +98,6 @@ joinItems t@(DT (itm,px,lc',rc') ls' rs') s@(DT (_,py,_,_) _ _)
| pa `elem` lc = Just (DT (itm2,pb, delete pa lc,rc) (a:ls) rs)
| otherwise = Nothing
--joinItems' :: DoubleTree PCI -> DoubleTree PCI -> Maybe (DoubleTree PCI)
--joinItems' t@(DT (px,cx) ls' rs') s@(DT (py,_) _ _)
-- | py `elem` cx = Just (DT (px, delete py cx) 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:ls) rs
-- checktop a@(DT (pa,_) _ _) (DT (pb,cb) ls rs)
-- | pa `elem` cb = Just (DT (pb, delete pa cb) (a:ls) rs)
-- | otherwise = Nothing
--
--joinItems'' :: Tree PCI -> Tree PCI -> Maybe (Tree PCI)
--joinItems'' t@(Node (px,cx) xs) s@(Node (py,_) _)
---- | fst y `elem` cx = Just (Node (px, delete y cx) (xs ++ [s]))
-- | py `elem` cx = Just (Node (px, delete py cx) (xs ++ [s]))
-- | otherwise = checkdepth t s
-- where
-- checkdepth a a'@(Node b cs) = fromMaybe (checktop a a') $ do
-- c <- safeHead cs
-- d <- checkdepth a c
-- return $ Just $ Node b (d:cs)
-- checktop a@(Node (pa,_) _) (Node (pb,cb) bs)
-- | pa `elem` cb = Just (Node (pb, delete pa cb) (a:bs))
-- | otherwise = Nothing
joinItemsInList :: (a -> a -> Maybe a) -> [a] -> [a]
joinItemsInList f xs = snd $ h (xs,[])
where
@@ -113,6 +143,10 @@ prettyDT :: (a -> String) -> DoubleTree a -> [String]
prettyDT f (DT x l r) = concatMap (map ('/':) . prettyDT f) r
++ (f x : concatMap (map ('\\':) . prettyDT f) l)
prettyLDT :: (a -> String) -> LabelDoubleTree b a -> [String]
prettyLDT f (LDT x l r) = concatMap (map ('/':) . prettyLDT f . snd) r
++ (f x : concatMap (map ('\\':) . prettyLDT f . snd) l)
invTree :: IM.IntMap Item -> [String]
invTree = concatMap (prettyDT (\(itm,_,_,_) -> show (_itType itm))) .
joinItemsInList joinItems . IM.elems . fmap (singleDT . baseCI)
@@ -122,6 +156,11 @@ indentInv = IM.fromList . zip [0..] .
reverse . concatMap (flattenDT .indentDoubleTreeWith (' ':) ('|':) ('+':) . fmap (const "")) .
joinItemsInList joinItems . IM.elems . fmap (singleDT . baseCI)
--invLDT :: IM.IntMap Item -> [LabelDoubleTree ComposeLinkType PCI'']
invLDT :: IM.IntMap Item -> [LabelDoubleTree ComposeLinkType PCI'']
invLDT = joinItemsInList (leftRightCombine leftIsParentCombine rightIsParentCombine) . IM.elems .
fmap (singleLDT . basePCI)
--indentInv :: IM.IntMap Item -> [String]
--indentInv = concat . fmap (flattenDT . indentDoubleTreeWith (' ':) ('|':) ('+':) . fmap const "")
-- . joinItemsInList joinItems
src/Dodge/TestString.hs
+6 -1
View File
@@ -1,6 +1,7 @@
{-# OPTIONS_GHC -Wno-unused-imports #-}
module Dodge.TestString where
import Dodge.Data.DoubleTree
import Dodge.Item.Grammar
import Dodge.Item.Display
import AesonHelp
@@ -20,7 +21,11 @@ import Dodge.Data.Universe
--import qualified Data.Map.Strict as M
import qualified IntMapHelp as IM
testStringInit :: Universe -> [String]
testStringInit u = maybe [] invTree (u ^? uvWorld . cWorld . lWorld . creatures . ix 0 . crInv)
testStringInit u = fromMaybe mempty $ do
inv <- fmap invLDT $ u ^? uvWorld . cWorld . lWorld . creatures . ix 0 . crInv
return $ concatMap (prettyLDT (\(x,_,_,_) -> take 5 (show $ x ^. itType . iyBase))) inv
--testStringInit u = maybe [] invTree (u ^? uvWorld . cWorld . lWorld . creatures . ix 0 . crInv)
-- [fromMaybe "" $ do
-- cr <- u ^? uvWorld . cWorld . lWorld . creatures . ix 0
-- i <- cr ^? crManipulation . manObject . inInventory . ispItem