Commit before attempting to remove Annotation datatype
This commit is contained in:
@@ -58,21 +58,29 @@ tutAnoTree =
|
||||
---- , AnTree $ weaponTut
|
||||
]
|
||||
|
||||
setRoomInt :: Room -> State LayoutVars (Int,Room)
|
||||
setRoomInt x = do
|
||||
i <- nextLayoutInt
|
||||
return (i,x & rmPmnts .:~ sps0 (PutWorldUpdate (f i)))
|
||||
where
|
||||
f i rm _ = genInts . at i ?~ (rm ^?! rmMID . _Just)
|
||||
|
||||
tutDrop :: State LayoutVars (MetaTree Room String)
|
||||
tutDrop = do
|
||||
x <- shuffleLinks =<< roomNgon 6 100
|
||||
i <- nextLayoutInt
|
||||
let y = decontamRoom i
|
||||
--let y = decontamRoom i
|
||||
(j,y) <- setRoomInt (decontamRoom i)
|
||||
rm <- roomRectAutoLinks 40 100
|
||||
return $
|
||||
tToBTree "TutDrop" $
|
||||
treePost
|
||||
[x & rmPmnts .:~ t, y, cleatOnward rm]
|
||||
[x & rmInPmnt .:~ t j, y, cleatOnward rm]
|
||||
where
|
||||
t =
|
||||
putMessageTerminal
|
||||
t j = \ gw -> let x = gw ^? genInts . ix j
|
||||
in putMessageTerminal
|
||||
terminalColor
|
||||
(defaultTerminal & tmBootLines .~ ss <> tlSetStatus (TerminalPressTo "QUIT") <> tlDoEffect TmWdWdPowerDownTerminal)
|
||||
(defaultTerminal & tmBootLines .~ ss <> tlSetStatus (TerminalPressTo $ show x <>"QUIT") <> tlDoEffect TmWdWdPowerDownTerminal)
|
||||
& plSpot .~ rprBoolShift isUnusedLnk
|
||||
(\(p, a) -> (p + 10 *.* unitVectorAtAngle (a - pi/2), a))
|
||||
ss =
|
||||
|
||||
@@ -36,7 +36,8 @@ overwriteLabel i t ts =
|
||||
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 upf t = safeUpdateSingleNode (isJust . upf . snd) ((root . _2 %~ g)
|
||||
. (root . _1 .:~ t))
|
||||
where
|
||||
g x = fromMaybe x (upf x)
|
||||
|
||||
@@ -78,7 +79,7 @@ composeNode (NodeTree t) = t
|
||||
composeNode (NodeMTree mt) = composeTree mt
|
||||
|
||||
attachList' :: Tree a -> [MetaBranch a b] -> Tree a
|
||||
attachList' t xs = shiftChildren $ foldr attachBranch (fmap ([],) t) xs
|
||||
attachList' t = shiftChildren . foldr attachBranch (fmap ([],) t)
|
||||
|
||||
attachBranch :: MetaBranch a b -> Tree ([Tree a], a) -> Tree ([Tree a], a)
|
||||
attachBranch mb =
|
||||
|
||||
Reference in New Issue
Block a user