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

Refactor, try to limit dependencies

Browse Source
This commit is contained in:
justin
2022-07-28 00:59:56 +01:00
parent 8aa5c17ab9
commit 160560af5f
418 changed files with 15104 additions and 13342 deletions
Download Patch File Download Diff File Expand all files Collapse all files
src/Dodge/Tree/Compose.hs
+60 -59
View File
@@ -1,51 +1,47 @@
{-# LANGUAGE TupleSections #-}
{-| Combining and composing trees of trees. -}
module Dodge.Tree.Compose
( tToBTree
, overwriteLabel
, composeTree
, decomposeTree
, numMetaTree
, numSelfTree
, combineTree
, decomposeSelfTree
, shiftChildren
, attachTree
, toOnward
, attachOnward
, attachOnward'
, showIntsString
, module Dodge.Tree.Compose.Data
) where
import Dodge.Data
import Dodge.Tree.Compose.Data
--import Dodge.RoomCluster.Data
import TreeHelp
--import Dodge.Base
import LensHelp
import Data.List (intersperse)
import Data.Tuple
--import Data.Bifunctor
--import Control.Monad.State
--import Data.Foldable
--import System.Random
import Data.Maybe
-- | Combining and composing trees of trees.
module Dodge.Tree.Compose (
tToBTree,
overwriteLabel,
composeTree,
decomposeTree,
numMetaTree,
numSelfTree,
combineTree,
decomposeSelfTree,
shiftChildren,
attachTree,
toOnward,
attachOnward,
attachOnward',
showIntsString,
module Dodge.Tree.Compose.Data,
) where
import Control.Monad.State
import Data.List (intersperse)
import Data.Maybe
import Data.Tuple
import Dodge.Data.GenWorld
import Dodge.Tree.Compose.Data
import LensHelp
import TreeHelp
overwriteLabel :: Int -> Tree Room -> [Tree Room] -> Tree Room
overwriteLabel i t ts = safeUpdateSingleNode
(\rm -> LabelCluster i `elem` (rm ^?! rmClusterStatus . csLinks))
((branches .~ ts) . (root . rmClusterStatus . csLinks . at (LabelCluster i) .~ Nothing))
t
overwriteLabel i t ts =
safeUpdateSingleNode
(\rm -> LabelCluster i `elem` (rm ^?! rmClusterStatus . csLinks))
((branches .~ ts) . (root . rmClusterStatus . csLinks . at (LabelCluster i) .~ Nothing))
t
attachTree :: (a -> Maybe a) -> Tree a -> Tree ([Tree a],a) -> Tree ([Tree a],a)
attachTree upf t = safeUpdateSingleNode (isJust . upf . snd) ( (root . _2 %~ g) . (root . _1 .:~ t ) )
attachTree :: (a -> Maybe a) -> Tree a -> Tree ([Tree a], a) -> Tree ([Tree a], a)
attachTree upf t = safeUpdateSingleNode (isJust . upf . snd) ((root . _2 %~ g) . (root . _1 .:~ t))
where
g x = fromMaybe x (upf x)
shiftChildren :: Tree ([Tree a],a) -> Tree a
shiftChildren (Node (ts,x) ts') = Node x (ts ++ map shiftChildren ts')
shiftChildren :: Tree ([Tree a], a) -> Tree a
shiftChildren (Node (ts, x) ts') = Node x (ts ++ map shiftChildren ts')
composeTree :: MetaTree a b -> Tree a
composeTree mt = attachList' (composeNode $ _mtTree mt) (_mtBranches mt)
@@ -54,8 +50,9 @@ mtTopLabels :: MetaTree a b -> Tree b
mtTopLabels (MTree lab _ bs) = Node lab (map (mtTopLabels . _mbTree) bs)
mtUnderLabels :: MetaTree a b -> [Tree b]
mtUnderLabels mt = maybe [] decomposeTree (mt ^? mtTree . nodeMetaTree)
++ concatMap (mtUnderLabels . _mbTree) (_mtBranches mt)
mtUnderLabels mt =
maybe [] decomposeTree (mt ^? mtTree . nodeMetaTree)
++ concatMap (mtUnderLabels . _mbTree) (_mtBranches mt)
decomposeTree :: MetaTree a b -> [Tree b]
decomposeTree mt = mtTopLabels mt : mtUnderLabels mt
@@ -68,10 +65,13 @@ decomposeSelfTree st = fmap fst (_unST st) : concatMap (f . snd) (_unST st)
combineTree :: (a -> b) -> MetaTree a b -> SelfTree b
combineTree f mt = case _mtTree mt of
NodeTree t -> ST (Node (_mtLabel mt,Left $ fmap f t) (_unST . combineTree f . _mbTree <$> _mtBranches mt))
NodeTree t -> ST (Node (_mtLabel mt, Left $ fmap f t) (_unST . combineTree f . _mbTree <$> _mtBranches mt))
--NodeTree t -> ST (Node (Left $ fmap f t) _)
NodeMTree mt' -> ST (Node (_mtLabel mt,Right $ combineTree f mt')
$ map (_unST . combineTree f . _mbTree) $ _mtBranches mt)
NodeMTree mt' ->
ST
( Node (_mtLabel mt, Right $ combineTree f mt') $
map (_unST . combineTree f . _mbTree) $ _mtBranches mt
)
composeNode :: MetaNode a b -> Tree a
composeNode (NodeTree t) = t
@@ -80,14 +80,15 @@ composeNode (NodeMTree mt) = composeTree mt
attachList' :: Tree a -> [MetaBranch a b] -> Tree a
attachList' t xs = shiftChildren $ foldr attachBranch (fmap ([],) t) xs
attachBranch :: MetaBranch a b -> Tree ([Tree a],a) -> Tree ([Tree a],a)
attachBranch mb = safeUpdateSingleNode (isJust . upf . snd)
( (root . _2 %~ g) . (root ._1 .:~ composeTree (_mbTree mb)) )
attachBranch :: MetaBranch a b -> Tree ([Tree a], a) -> Tree ([Tree a], a)
attachBranch mb =
safeUpdateSingleNode
(isJust . upf . snd)
((root . _2 %~ g) . (root . _1 .:~ composeTree (_mbTree mb)))
where
upf = _mbAttach mb
g x = fromMaybe x (upf x)
tToBTree :: String -> Tree Room -> MetaTree Room String
tToBTree str t = MTree str (NodeTree t) []
@@ -99,31 +100,31 @@ attachOnward' t1 t2 = MTree (_mtLabel t1) (NodeMTree t1) [MBranch toOnward t2]
toOnward :: Room -> Maybe Room
toOnward rm
| OnwardCluster `elem` rm ^?! rmClusterStatus . csLinks
= Just (rm & rmClusterStatus . csLinks . at OnwardCluster .~ Nothing)
| OnwardCluster `elem` rm ^?! rmClusterStatus . csLinks =
Just (rm & rmClusterStatus . csLinks . at OnwardCluster .~ Nothing)
| otherwise = Nothing
numSelfTree :: SelfTree a -> SelfTree ([Int],a)
numSelfTree :: SelfTree a -> SelfTree ([Int], a)
numSelfTree st = evalState (numSelfTree' st) [0]
numSelfTree' :: SelfTree a -> State [Int] (SelfTree ([Int],a))
numSelfTree' :: SelfTree a -> State [Int] (SelfTree ([Int], a))
numSelfTree' (ST (Node lrt bs)) = do
is <- get
modify (ix 0 +~ 1)
bs' <- mapM (fmap _unST . numSelfTree' . ST) bs
case lrt of
(y,Left t) -> return $ ST (Node ((is,y),Left $ (_1 %~ (:is)) . swap <$> numTraversable t) bs')
(y,Right mt') -> return $ ST (Node ((is,y),Right (evalState (numSelfTree' mt') (0:is))) bs')
(y, Left t) -> return $ ST (Node ((is, y), Left $ (_1 %~ (: is)) . swap <$> numTraversable t) bs')
(y, Right mt') -> return $ ST (Node ((is, y), Right (evalState (numSelfTree' mt') (0 : is))) bs')
numMetaTree :: MetaTree a String -> MetaTree a ([Int],String)
numMetaTree :: MetaTree a String -> MetaTree a ([Int], String)
numMetaTree mt = evalState (numMetaTree' mt) [0]
numMetaTree' :: MetaTree a b -> State [Int] (MetaTree a ([Int],b))
numMetaTree' :: MetaTree a b -> State [Int] (MetaTree a ([Int], b))
numMetaTree' (MTree lab mn bs) = do
is <- get
modify (ix 0 +~ 1)
bs' <- mapM (mbTree %%~ numMetaTree') bs
return $ MTree (is,lab) (mn & nodeMetaTree %~ (\nmt -> evalState (numMetaTree' nmt) (0:is))) bs'
return $ MTree (is, lab) (mn & nodeMetaTree %~ (\nmt -> evalState (numMetaTree' nmt) (0 : is))) bs'
showIntsString :: ([Int],String) -> String
showIntsString (is,s) = foldr1 (++) (intersperse ":" (map show $ reverse is)) ++ ':':s
showIntsString :: ([Int], String) -> String
showIntsString (is, s) = foldr1 (++) (intersperse ":" (map show $ reverse is)) ++ ':' : s
src/Dodge/Tree/Shift.hs
+107 -93
View File
@@ -1,150 +1,164 @@
{-# LANGUAGE StrictData #-}
{-# LANGUAGE TemplateHaskell #-}
{- | Given a tree of rooms, tries to shift them into place in such a way that their
links connect and that none of them clip.
Creates a list of rooms; after this step the structure is determined by the actual positions of rooms. -}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE StrictData #-}
module Dodge.Tree.Shift
( positionRoomsFromTree
, PosRooms (..)
) where
--import Dodge.LevelGen.Data
import Dodge.Data
Creates a list of rooms; after this step the structure is determined by the actual positions of rooms.
-}
module Dodge.Tree.Shift (
positionRoomsFromTree,
PosRooms (..),
) where
import Control.Lens
import Data.Bifunctor
import Data.List (delete)
import qualified Data.Sequence as Seq
import qualified Data.Set as S
import Dodge.Data.GenWorld
import Dodge.Room.Link
import TreeHelp
import Dodge.RoomLink
import Geometry.ConvexPoly
--import Geometry.Data
import LensHelp hiding (Empty, (<|), (|>))
import Padding
import LensHelp hiding (Empty, (<|) , (|>))
--import Control.Lens hiding (Empty, (<|) , (|>))
import TreeHelp
import qualified Data.Set as S
import qualified Data.Sequence as Seq
import Data.List (delete)
import Data.Bifunctor
import Control.Lens
type RoomInt = (Room,Int)
type RoomInt = (Room, Int)
data PosRooms = PosRooms
{ _prBounds :: [ConvexPoly]
, _prRooms :: [RoomInt]
, _prRooms :: [RoomInt]
}
makeLenses ''PosRooms
positionRoomsFromTree :: Tree RoomInt -> IO (Maybe PosRooms)
positionRoomsFromTree (Node (r,i) ts) = printColumnTitles
>> fmap (fmap (prRooms %~ map (first createUnusedLinkPos)))
(posRms (PosRooms (map pointsToPoly $ _rmBound r') []) (r',i) (zipCount ts) Empty)
positionRoomsFromTree (Node (r, i) ts) =
printColumnTitles
>> fmap
(fmap (prRooms %~ map (first createUnusedLinkPos)))
(posRms (PosRooms (map pointsToPoly $ _rmBound r') []) (r', i) (zipCount ts) Empty)
where
r' = r & rmMID ?~ 0
posRms :: PosRooms
-> RoomInt
-> [(Int,Tree RoomInt)] -- the list of children, with indices
-> Seq.Seq (Tree RoomInt)
-> IO (Maybe PosRooms)
posRms ::
PosRooms ->
RoomInt ->
[(Int, Tree RoomInt)] -> -- the list of children, with indices
Seq.Seq (Tree RoomInt) ->
IO (Maybe PosRooms)
posRms prs roomi [] st = case st of
Empty -> return $ Just $ prs & prRooms .:~ roomi
Empty -> return $ Just $ prs & prRooms .:~ roomi
Node nextroomi ts Seq.:<| tseq -> posRms (prs & prRooms .:~ roomi) nextroomi (zipCount ts) tseq
_ -> error "unexpected outcome in posRms"
posRms prs parenti@(parent,_) ( (numChild,t@(Node childi _) ):its) tseq = do
posRms prs parenti@(parent, _) ((numChild, t@(Node childi _)) : its) tseq = do
printInfoCheckNum parenti numChild childi
tryParentLinks outlinks
where
child = fst childi
outlinks = zipCount
. Prelude.filter (_rmConnectsTo child . _rlType)
$ _rmLinks parent
outlinks =
zipCount
. Prelude.filter (_rmConnectsTo child . _rlType)
$ _rmLinks parent
tryParentLinks [] = putStrLn "no viable link pairs, backtrack" >> return Nothing
tryParentLinks ((j,outlnk):ls) = tryChildLinks . zipCount . rmInLinks $ fst childi
tryParentLinks ((j, outlnk) : ls) = tryChildLinks . zipCount . rmInLinks $ fst childi
where
tryChildLinks [] = tryParentLinks ls
tryChildLinks ((numinlink,il):ils)
| clipping = tryChildLinks ils
tryChildLinks ((numinlink, il) : ils)
| clipping = tryChildLinks ils
| otherwise = do
putStrLn $ show j ++ "-" ++ show numinlink
mayrs <- posRms
(prs & prBounds .++~ newBounds)
(first updateparent parenti)
its
(tseq |> shiftedt)
mayrs <-
posRms
(prs & prBounds .++~ newBounds)
(first updateparent parenti)
its
(tseq |> shiftedt)
case mayrs of
Just rms -> return $ Just rms
Nothing -> printInfo parenti numChild childi
>> tryChildLinks ils
Nothing ->
printInfo parenti numChild childi
>> tryChildLinks ils
where
newBounds = map pointsToPoly . _rmBound . doRoomShift . fst $ rootLabel shiftedt
clipping = or (convexPolysOverlap <$> newBounds <*> _prBounds prs)
updateparent rm = _rmLinkEff rm il child numChild outlnk rm
& rmLinks %~ delete outlnk
& rmPos .:~ RoomPos
{ _rpPos = fst (lnkPosDir outlnk)
, _rpDir = snd (lnkPosDir outlnk)
, _rpType = S.empty
, _rpLinkStatus = UsedOutLink (_rlType outlnk) numChild (snd childi)
, _rpPlacementUse = 0
}
& rmChildren .:~ snd childi
updateparent rm =
_rmLinkEff rm il child numChild outlnk rm
& rmLinks %~ delete outlnk
& rmPos
.:~ RoomPos
{ _rpPos = fst (lnkPosDir outlnk)
, _rpDir = snd (lnkPosDir outlnk)
, _rpType = S.empty
, _rpLinkStatus = UsedOutLink (_rlType outlnk) numChild (snd childi)
, _rpPlacementUse = 0
}
& rmChildren .:~ snd childi
shiftedoutlink = shiftLinkBy (_rmShift parent) outlnk
updatechild rm = rm
& rmMParent ?~ snd parenti
& rmMID ?~ snd childi
& rmLinks %~ delete il
& rmPos .:~ RoomPos
{ _rpPos = fst (lnkPosDir il)
, _rpDir = snd (lnkPosDir il)
, _rpType = S.empty
, _rpLinkStatus = UsedInLink (_rlType il) (snd parenti)
, _rpPlacementUse = 0
}
shiftedt = over root
(first $ updatechild . shiftRoomShiftToLink (lnkPosDir shiftedoutlink) (lnkPosDir il))
t
updatechild rm =
rm
& rmMParent ?~ snd parenti
& rmMID ?~ snd childi
& rmLinks %~ delete il
& rmPos
.:~ RoomPos
{ _rpPos = fst (lnkPosDir il)
, _rpDir = snd (lnkPosDir il)
, _rpType = S.empty
, _rpLinkStatus = UsedInLink (_rlType il) (snd parenti)
, _rpPlacementUse = 0
}
shiftedt =
over
root
(first $ updatechild . shiftRoomShiftToLink (lnkPosDir shiftedoutlink) (lnkPosDir il))
t
createUnusedLinkPos :: Room -> Room
createUnusedLinkPos rm = rm & rmPos .++~ map f (_rmLinks rm)
where
f rl = RoomPos
{ _rpPos = _rlPos rl
, _rpDir = _rlDir rl
, _rpType = S.empty
, _rpLinkStatus = UnusedLink $ _rlType rl
, _rpPlacementUse = 0
}
f rl =
RoomPos
{ _rpPos = _rlPos rl
, _rpDir = _rlDir rl
, _rpType = S.empty
, _rpLinkStatus = UnusedLink $ _rlType rl
, _rpPlacementUse = 0
}
zipCount :: [a] -> [(Int,a)]
zipCount = Prelude.zip [0..]
zipCount :: [a] -> [(Int, a)]
zipCount = Prelude.zip [0 ..]
printColumns :: [Int] -> [String] -> IO ()
printColumns is ss = printPartialColumns is ss >> putStrLn ""
printPartialColumns :: [Int] -> [String] -> IO ()
printPartialColumns (i:is) (s:strs) = putStr (rightPad i ' ' s) >> printPartialColumns is strs
printPartialColumns (i : is) (s : strs) = putStr (rightPad i ' ' s) >> printPartialColumns is strs
printPartialColumns _ strs = putStr $ concat strs
theColumns :: [String] -> IO ()
theColumns = printColumns [20,5,20,20]
theColumns = printColumns [20, 5, 20, 20]
printColumnTitles :: IO ()
printColumnTitles = theColumns ["Parent","Cnum","Child","Link pair"]
printColumnTitles = theColumns ["Parent", "Cnum", "Child", "Link pair"]
printInfo :: (Show a) => RoomInt -> a -> RoomInt -> IO ()
printInfo (parentrm,parenti) childn (childrm,childi) = printPartialColumns
[20,5,20]
[_rmName parentrm ++ "-" ++ show parenti
,show childn ++ " "
,_rmName childrm ++ "-" ++ show childi
]
printInfo (parentrm, parenti) childn (childrm, childi) =
printPartialColumns
[20, 5, 20]
[ _rmName parentrm ++ "-" ++ show parenti
, show childn ++ " "
, _rmName childrm ++ "-" ++ show childi
]
printInfoCheckNum :: (Show a, Eq a, Num a) => RoomInt -> a -> RoomInt -> IO ()
printInfoCheckNum (parentrm,parenti) childn (childrm,childi) = printPartialColumns
[20,5,20]
[rname
,show childn
,_rmName childrm ++ "-" ++ show childi
]
printInfoCheckNum (parentrm, parenti) childn (childrm, childi) =
printPartialColumns
[20, 5, 20]
[ rname
, show childn
, _rmName childrm ++ "-" ++ show childi
]
where
rname = case childn of
0 -> _rmName parentrm ++ "-" ++ show parenti