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

Cleanup

Browse Source
This commit is contained in:
justin
2021-11-23 22:33:23 +00:00
parent ddd120dee1
commit 5f6d81bd05
10 changed files with 65 additions and 53 deletions
Download Patch File Download Diff File Expand all files Collapse all files
src/Dodge/Debug/LinkDecoration.hs
+1 -1
View File
@@ -23,7 +23,7 @@ addRoomLinkDecorations rms w = w & decorations %~
IM.insertWithNewKeys (map roomLinkDecorations rms)
roomLinkDecorations :: Room -> Picture
roomLinkDecorations rm = pictures . map linkDecoration $ map lnkPosDir $ _rmLinks rm
roomLinkDecorations rm = pictures . map (linkDecoration . lnkPosDir) $ _rmLinks rm
linkDecoration :: (Point2,Float) -> Picture
linkDecoration (p,a) = setLayer 1 . onLayer DebugLayer . color red $ line [p, p +.+ 20 *.* unitVectorAtAngle (a - pi/2)]
src/Dodge/Layout.hs
+2 -2
View File
@@ -168,10 +168,10 @@ gameRoomFromRoom rm = GameRoom
[p +.+ 10 *.* unitVectorAtAngle a
,p -.- 10 *.* unitVectorAtAngle a
]
unpos (UsedOutLink _ p a) = doubleShift p a
unpos (UsedOutLink _ _ p a) = doubleShift p a
unpos (UsedInLink _ p a) = doubleShift p a
unpos _ = []
undir (UsedOutLink _ _ a) = Just $ 0.5*pi + a + snd (_rmShift rm)
undir (UsedOutLink _ _ _ a) = Just $ 0.5*pi + a + snd (_rmShift rm)
undir (UsedInLink _ _ a) = Just $ 0.5*pi + a + snd (_rmShift rm)
undir _ = Nothing
closePoints x y = roundPoint2 x == roundPoint2 y
src/Dodge/LevelGen/Data.hs
+20 -6
View File
@@ -91,18 +91,31 @@ data RoomLink = RoomLink
data RoomLinkType
= OutLink
| InLink
| AnyLink
| LabLink Int
deriving (Eq,Ord)
data RoomWire
= --RoomWire Point2 Float
WallWire Point2 Float Float
data RoomPos
= UsedOutLink Int Point2 Float
| UsedInLink Int Point2 Float
| UnusedLink Point2 Float
| PosPl Point2 Float
| LabPos Int RoomPos
= UsedOutLink
{_rpChildNum :: Int
,_rpOutRoomID :: Int
,_rpPos :: Point2
,_rpDir :: Float
}
| UsedInLink
{_rpInRoomID :: Int
,_rpPos :: Point2
,_rpDir ::Float
}
| UnusedLink
{_rpPos :: Point2
,_rpDir ::Float
}
| PosPl
{_rpPos :: Point2
,_rpDir ::Float
}
deriving (Eq,Ord,Show)
makeLenses ''Room
@@ -110,6 +123,7 @@ makeLenses ''PSType
makeLenses ''PlacementSpot
makeLenses ''Placement
makeLenses ''RoomLink
makeLenses ''RoomPos
spNoID :: PlacementSpot -> PSType -> Placement
spNoID ps pst = Placement ps pst Nothing (const Nothing)
src/Dodge/PlacementSpot.hs
+3 -3
View File
@@ -15,13 +15,13 @@ anyLnkOutPS = PSPos f (const id) Nothing
atFstLnkOut :: PlacementSpot
atFstLnkOut = PSPos f (const id) Nothing
where
f (UsedOutLink 0 p a) = Just (PS p a, UsedOutLink 0 p a)
f (UsedOutLink 0 i p a) = Just (PS p a, UsedOutLink 0 i p a)
f _ = Nothing
atNthLnkOutShiftBy :: Int -> ((Point2,Float) -> (Point2,Float)) -> PlacementSpot
atNthLnkOutShiftBy n theshift = PSPos f (const id) Nothing
where
f (UsedOutLink i p a) | n == i = Just (PS p' a', UsedOutLink n p a)
f (UsedOutLink i rmid p a) | n == i = Just (PS p' a', UsedOutLink n rmid p a)
where
(p',a') = theshift (p,a)
f _ = Nothing
@@ -40,7 +40,7 @@ atNthLnkOutShiftInward n x = atNthLnkOutShiftBy n f
overFstLnkOut :: PlacementSpot
overFstLnkOut = PSPos f (const id) Nothing
where
f (UsedOutLink 0 p a) = Just (PS p a, PosPl p a)
f (UsedOutLink 0 _ p a) = Just (PS p a, PosPl p a)
f _ = Nothing
anyLnkInPS :: Float -- ^ amount to shift inward
src/Dodge/Room/Boss.hs
+2 -2
View File
@@ -30,7 +30,7 @@ roomGlassOctogon x = createPathGrid $ defaultRoom
[rectNSWE x (-x) (-x) x
,rectNSWE 0 (-(x + 40)) (-20) 20
]
, _rmLinks = (map (uncurry outLink) $ init lnks) ++ [uncurry inLink $ last lnks]
, _rmLinks = map (uncurry outLink) (init lnks) ++ [uncurry inLink $ last lnks]
, _rmPath = linksAndPath lnks
[ ( V2 0 x , V2 0 (-(x+40)))
, ( V2 0 (-(x+40)), V2 0 x)
@@ -94,7 +94,7 @@ roomCross x y = defaultRoom
,(V2 (-x) (20-y),pi/2)
,(V2 (20-y) (-x),pi)
] ++
[uncurry inLink $ (V2 (y-20) (-x),pi)
[uncurry inLink (V2 (y-20) (-x),pi)
]
, _rmPath = []
, _rmPmnts =
src/Dodge/Room/Corridor.hs
+20 -19
View File
@@ -1,3 +1,4 @@
{-# LANGUAGE TupleSections #-}
module Dodge.Room.Corridor
where
import Dodge.LevelGen.Data
@@ -19,7 +20,7 @@ corridor = defaultRoom
{ _rmPolys = [poly]
, _rmLinks = lnks'
, _rmPath = concatMap (doublePair . (,) (V2 20 60) . fst) lnks
, _rmPmnts = [ spanLightI (V2 0 40) (V2 40 40) ]
, _rmPmnts = [ spanLightI (V2 0 40) (V2 40 40) ]
, _rmBound = [ rectNSWE 50 30 0 40 ]
, _rmFloor = [makeTileFromPoly poly 2]
, _rmRandPSs = [psRandRanges (10,30) (30,60) (0,2*pi)]
@@ -28,16 +29,16 @@ corridor = defaultRoom
where
poly = rectNSWE 80 0 0 40
lnks' =
[uncurry outLink ((V2 20 70) ,0)
,uncurry outLink ((V2 20 70), pi/6)
,uncurry outLink ((V2 20 70), negate $ pi/6)
,uncurry inLink ((V2 20 10) ,pi)
[uncurry outLink (V2 20 70 , 0)
,uncurry outLink (V2 20 70 , pi/6)
,uncurry outLink (V2 20 70 , negate $ pi/6)
,uncurry inLink (V2 20 10 , pi)
]
lnks =
[ ((V2 20 70) ,0::Float)
, ((V2 20 70), pi/6)
, ((V2 20 70), negate $ pi/6)
,((V2 20 10) ,pi)
[ (V2 20 70, 0::Float)
, (V2 20 70, pi/6)
, (V2 20 70, negate $ pi/6)
, (V2 20 10, pi)
]
keyholeCorridor :: Room
keyholeCorridor = corridor
@@ -90,14 +91,14 @@ tEast = defaultRoom
}
where
lnks =
[(V2 ( 30) (60),(-pi/2)::Float)
,(V2 (-30) (60),pi/2)
,((V2 0 10),pi)
[(V2 30 60, (-pi/2)::Float)
,(V2 (-30) 60, pi/2 )
,(V2 0 10, pi )
]
lnks' =
[uncurry outLink(V2 ( 30) (60),-pi/2)
,uncurry outLink(V2 (-30) (60),pi/2)
,uncurry inLink((V2 0 10),pi)
[uncurry outLink (V2 30 60,-pi/2)
,uncurry outLink (V2 (-30) 60,pi/2)
,uncurry inLink (V2 0 10,pi)
]
tWest :: Room
tWest = defaultRoom
@@ -105,13 +106,13 @@ tWest = defaultRoom
,rectNSWE 80 40 (-40) 40
]
, _rmLinks = lnks
, _rmPath = concatMap (doublePair . (,) (V2 0 60) . fst) $ map lnkPosDir lnks
, _rmPath = concatMap (doublePair . (V2 0 60 ,) . _rlPos) lnks
, _rmPmnts = []
, _rmBound = [ rectNSWE 70 10 0 40 ]
}
where
lnks =
[outLink (V2 (-30) (60)) (pi/2)
,outLink (V2 ( 30) (60)) (-pi/2)
,inLink (V2 (0) (10)) pi
[outLink (V2 (-30) 60) ( pi/2)
,outLink (V2 30 60) (-pi/2)
,inLink (V2 0 10) pi
]
src/Dodge/Room/Link.hs
+3 -3
View File
@@ -6,7 +6,7 @@ the outgoing links. -}
module Dodge.Room.Link
( --shiftRoomToLink
--, shiftRoomShiftToLink
shiftRoomShiftToLink'
shiftRoomShiftToLink
, shiftRoomBy
, shiftLinkBy
, doRoomShift
@@ -129,8 +129,8 @@ shiftRoomBy shift r = r
-- where
-- (p,a) = head $ _rmInLinks r
shiftRoomShiftToLink' :: (Point2,Float) -> (Point2,Float) -> Room -> Room
shiftRoomShiftToLink' l inlink r
shiftRoomShiftToLink :: (Point2,Float) -> (Point2,Float) -> Room -> Room
shiftRoomShiftToLink l inlink r
= shiftRoomShiftBy l
. shiftRoomShiftBy (V2 0 0 , pi-a)
$ shiftRoomShiftBy (V2 0 0 -.- p , 0)
src/Dodge/Room/RoadBlock.hs
+5 -3
View File
@@ -32,7 +32,9 @@ litCorridor90 = do
poly2 = rectNSWE (h-60) (h-100) (-60) 5
pure $ defaultRoom
{ _rmPolys = [poly,poly2]
, _rmLinks = [uncurry outLink (V2 40 (h - 80), -pi/2)] ++ [uncurry inLink (V2 20 0 , pi ) ]
, _rmLinks =
[ outLink (V2 40 (h - 80)) (-pi/2)
, inLink (V2 20 0 ) pi ]
, _rmPath = concatMap doublePair
[( V2 20 0 , V2 20 (h-40) )
,( V2 0 (h-40) , V2 20 (h-40) )
@@ -94,8 +96,8 @@ lasTunnel :: Room
lasTunnel = defaultRoom
{ _rmPolys = polys
, _rmBound = polys
, _rmLinks = [uncurry outLink(V2 20 190,1.5* pi)] ++ [uncurry inLink(V2 0 20,0.5* pi)]
, _rmPmnts = [putLasTurret 0.005 & plSpot .~ PS (V2 10 240) (1.5*pi)
, _rmLinks = [outLink (V2 20 190) (1.5* pi), inLink (V2 0 20) (0.5* pi)]
, _rmPmnts = [putLasTurret 0.005 & plSpot .~ PS (V2 10 240) (1.5*pi)
, midWall (rectNSEW 65 40 0 25)
, mntLS vShape (V2 50 10) (V3 40 20 50)
]
src/Dodge/RoomPos.hs
+1 -6
View File
@@ -3,9 +3,4 @@ import Dodge.LevelGen.Data
import Geometry
extractRoomPos :: RoomPos -> (Point2,Float)
extractRoomPos rp = case rp of
UsedOutLink _ p a -> (p,a)
UsedInLink _ p a -> (p,a)
UnusedLink p a -> (p,a)
PosPl p a -> (p,a)
LabPos _ rp' -> extractRoomPos rp'
extractRoomPos rp = (_rpPos rp,_rpDir rp)
src/Dodge/Tree/Shift.hs
+8 -8
View File
@@ -41,26 +41,26 @@ posRms bounds parenti@(parent,_) ( (numChild,t@(Node childi _) ):its) tseq = do
where
tryChildLinks [] = tryParentLinks ls
tryChildLinks ((numinlink,il):ils)
| clipping = tryChildLinks ils
| clipping = tryChildLinks ils
| otherwise = do
putStrLn $ show j ++ "-"++show numinlink
mayrs <- posRms (convexBounds ++ bounds)
mayrs <- posRms (newBounds ++ bounds)
(first updateparent parenti) its (tseq |> shiftedt)
case mayrs of
Just rms -> return $ Just rms
Nothing -> printInfo parenti numChild childi
>> tryChildLinks ils
where
convexBounds = map pointsToPoly $ _rmBound r'
clipping = or (convexPolysOverlap <$> convexBounds <*> bounds)
newBounds = map pointsToPoly $ _rmBound r'
clipping = or (convexPolysOverlap <$> newBounds <*> bounds)
updateparent rm = doLnkEff (lnkPosDir outlnk) $ rm
& rmLinks %~ delete outlnk & rmPos %~ (uncurry (UsedOutLink numChild) (lnkPosDir outlnk) :)
l' = shiftLinkBy (_rmShift parent) outlnk
& rmLinks %~ delete outlnk & rmPos %~ (uncurry (UsedOutLink numChild (snd childi)) (lnkPosDir outlnk) :)
shiftedoutlink = shiftLinkBy (_rmShift parent) outlnk
r' = doRoomShift . fst $ rootLabel shiftedt
updatechild rm = rm & rmLinks %~ delete il
& rmPos %~ ( (uncurry (UsedInLink 0) (lnkPosDir il):)
. (map (uncurry UnusedLink . lnkPosDir) (delete il (_rmLinks rm)) ++) )
shiftedt = applyToRoot (first $ updatechild . shiftRoomShiftToLink' (lnkPosDir l') (lnkPosDir il)) t
shiftedt = applyToRoot (first $ updatechild . shiftRoomShiftToLink (lnkPosDir shiftedoutlink) (lnkPosDir il)) t
zipCount :: [a] -> [(Int,a)]
zipCount = Prelude.zip [0..]
@@ -85,7 +85,7 @@ printInfo (parentrm,parenti) childn (childrm,childi) = do
printInfoCheckNum :: RoomInt -> Int -> RoomInt -> IO ()
printInfoCheckNum p 0 c = printInfo p 0 c
printInfoCheckNum _ childn (childrm,childi) = do
putStr $ rpns 20 ("")
putStr $ rpns 20 ""
++ rpns 5 (show childn ++ " ")
++ rpns 20 (_rmName childrm ++ "-" ++ show childi )
where