Slightly broken placements
This commit is contained in:
+2
-1
@@ -34,7 +34,8 @@ initialAnoTree = padSucWithCorridors $ treeFromTrunk
|
||||
[[StartRoom]
|
||||
,[ChainAnos
|
||||
[[SetLabel 0 $ return $ roomRectAutoLinks 100 100
|
||||
& rmExtPmnt ?~ externalButton red (anyLnkInPS 5 & psLnkRoomEff .~ putWireStart 0)
|
||||
& rmExtPmnt ?~ externalButton red
|
||||
(anyLnkInPS 5 & psLnkRoomEff .~ (putWireStart 0 . extractRoomPos) )
|
||||
-- & rmStartWires .~ IM.fromList [(0,RoomWire 0 0)]
|
||||
& rmLinkEff .~ [putWireEndInvRmShift 0]
|
||||
]
|
||||
|
||||
+32
-24
@@ -14,8 +14,8 @@ import Dodge.LevelGen.Pathing
|
||||
import Dodge.LevelGen.TriggerDoor
|
||||
import Dodge.LevelGen.Data
|
||||
import Dodge.Default.Wall
|
||||
import Dodge.RandomHelp
|
||||
import Dodge.Placements.Spot
|
||||
--import Dodge.RandomHelp
|
||||
--import Dodge.Placements.Spot
|
||||
import Geometry
|
||||
import Geometry.Vector3D
|
||||
import Shape
|
||||
@@ -26,13 +26,14 @@ import System.Random
|
||||
import Control.Monad.State
|
||||
import Control.Lens
|
||||
import qualified Data.IntSet as IS
|
||||
import Data.Bifunctor
|
||||
|
||||
-- when placing a placement, we update the world and the room and assign an id
|
||||
-- to the placement
|
||||
placeSpot :: (World,Room) -> Placement -> ( (World,Room), [Placement] )
|
||||
placeSpot (w,rm) plmnt = case plmnt of
|
||||
Placement{_plSpot = PSRoomRand i} -> placeSpotRoomRand rm i plmnt w
|
||||
Placement{_plSpot = PSLnk{}} -> placeSpotUsingLink w rm plmnt
|
||||
Placement{_plSpot = PSLnk extract eff fallback} -> placeSpotUsingLink w rm plmnt extract eff fallback
|
||||
Placement{} ->
|
||||
let (i,w') = placeSpotID (shiftPSBy shift (_plSpot plmnt)) (_plType plmnt) w
|
||||
newplmnt = plmnt & plMID ?~ i
|
||||
@@ -48,37 +49,33 @@ placeSpot (w,rm) plmnt = case plmnt of
|
||||
where
|
||||
shift = _rmShift rm
|
||||
|
||||
invShiftPSBy :: (Point2,Float) -> PlacementSpot -> PlacementSpot
|
||||
invShiftPSBy (pos,rot) (PS p r) = PS (invShiftPointBy (pos,rot) p) (r - rot)
|
||||
invShiftPSBy _ ps = ps
|
||||
|
||||
|
||||
-- this should be tidied up
|
||||
placeSpotUsingLink :: World -> Room -> Placement -> ((World, Room), [Placement])
|
||||
placeSpotUsingLink w rm plmnt = case lnks of
|
||||
((lnki,lnk):_) -> placeSpot (w & randGen .~ g,uselnk lnki lnk) (updatePS (f lnk) plmnt)
|
||||
[] -> case fallback of
|
||||
placeSpotUsingLink :: World -> Room -> Placement
|
||||
-> (RoomPos -> Maybe PlacementSpot)
|
||||
-> (RoomPos -> Room -> Room)
|
||||
-> Maybe Placement
|
||||
-> ((World, Room), [Placement])
|
||||
placeSpotUsingLink w rm plmnt extract eff fallback = case searchedPoss (_rmPos rm) of
|
||||
Just (ps,pos,newrmpos) -> placeSpot (w, eff pos $ rm & rmPos .~ newrmpos) (plmnt & plSpot .~ ps)
|
||||
Nothing -> case fallback of
|
||||
Nothing -> ((w,rm),[plmnt])
|
||||
Just plmnt' -> placeSpot (w,rm) plmnt'
|
||||
where
|
||||
uselnk lnki lnk = _psLnkRoomEff rps (f' lnk rps) rm & rmLinks %~ deletei lnki
|
||||
rps = _plSpot plmnt
|
||||
fallback = _psLnkFallback rps
|
||||
test = _psLnkTest rps
|
||||
(lnks,g) = runState (shuffle $ filter (test . snd) $ zip [0..]
|
||||
$ map (invShiftLinkBy $ _rmShift rm) $ _rmLinks rm) $ _randGen w
|
||||
f' x (PSLnk t s _ _)
|
||||
| t x = s x
|
||||
f' _ _ = error "wrong type of link: something is wrong"
|
||||
f x (PSLnk t s _ _)
|
||||
| t x = uncurry PS $ s x
|
||||
f _ ps = ps
|
||||
invShiftLinkBy :: (Point2,Float) -> (Point2,Float) -> (Point2,Float)
|
||||
invShiftLinkBy (pos,rot) (p,r) = (invShiftPointBy (pos,rot) p, r - rot)
|
||||
searchedPoss [] = error "no correct pos type for lnk placement"
|
||||
searchedPoss (pos:poss) = case extract (invShiftPosBy (_rmShift rm) pos) of
|
||||
Nothing -> second (pos:) <$> searchedPoss poss
|
||||
Just ps -> Just ( ps,pos, poss)
|
||||
|
||||
placeSpotRoomRand :: Room -> Int -> Placement -> World -> ((World,Room),[Placement])
|
||||
placeSpotRoomRand rm i plmnt w =
|
||||
let (ps,g) = runState (_rmRandPSs rm !! i) $_randGen w
|
||||
in placeSpot (w & randGen .~ g,rm) (plmnt & plSpot .~ uncurry PS ps)
|
||||
|
||||
deletei :: Int -> [a] -> [a]
|
||||
deletei i xs = take i xs ++ drop (i+1) xs
|
||||
|
||||
shiftPlacement :: (Point2,Float) -> Placement -> Placement
|
||||
shiftPlacement shift plmnt = case plmnt of
|
||||
Placement {} -> plmnt & plSpot %~ shiftPSBy shift
|
||||
@@ -138,6 +135,17 @@ shiftPointBy (pos,rot) p = pos +.+ rotateV rot p
|
||||
invShiftPointBy :: (Point2,Float) -> Point2 -> Point2
|
||||
invShiftPointBy (p1,r) p2 = rotateV (-r) $ p2 -.- p1
|
||||
|
||||
invShiftPosBy :: (Point2,Float) -> RoomPos -> RoomPos
|
||||
invShiftPosBy s rp = case rp of
|
||||
OutLink i p a -> uncurry (OutLink i) $ invShiftLinkBy s (p,a)
|
||||
InLink p a -> uncurry (InLink) $ invShiftLinkBy s (p,a)
|
||||
UnusedLink p a -> uncurry (UnusedLink) $ invShiftLinkBy s (p,a)
|
||||
PosPl p a -> uncurry (PosPl) $ invShiftLinkBy s (p,a)
|
||||
LabPos i rp' -> LabPos i $ invShiftPosBy s rp'
|
||||
|
||||
invShiftLinkBy :: (Point2,Float) -> (Point2,Float) -> (Point2,Float)
|
||||
invShiftLinkBy (pos,rot) (p,r) = (invShiftPointBy (pos,rot) p, r - rot)
|
||||
|
||||
shiftPoint3By :: (Point2,Float) -> Point3 -> Point3
|
||||
shiftPoint3By (pos,rot) (V3 x y z) = addZ z $ pos +.+ rotateV rot (V2 x y)
|
||||
|
||||
|
||||
+87
-59
@@ -36,9 +36,8 @@ data PSType = PutCrit {_unPutCrit :: Creature}
|
||||
data PlacementSpot
|
||||
= PS { _psPos :: Point2 , _psRot :: Float }
|
||||
| PSLnk
|
||||
{ _psLnkTest :: (Point2,Float) -> Bool
|
||||
, _psLnkShift :: (Point2,Float) -> (Point2,Float)
|
||||
, _psLnkRoomEff :: (Point2,Float) -> Room -> Room
|
||||
{ _psLnkShift :: RoomPos -> Maybe PlacementSpot
|
||||
, _psLnkRoomEff :: RoomPos -> Room -> Room
|
||||
, _psLnkFallback :: Maybe Placement
|
||||
}
|
||||
| PSRoomRand { _psRoomRandPointNum :: Int }
|
||||
@@ -51,62 +50,6 @@ data Placement = Placement
|
||||
| PlacementUsingPos Point3 (Point3 -> Placement) -- allows a placement to use a shifted position
|
||||
| RandomPlacement {_unRandomPlacement :: State StdGen Placement}
|
||||
|
||||
anyLnkOutPS :: PlacementSpot
|
||||
anyLnkOutPS = PSLnk (const True) id (const id) Nothing
|
||||
|
||||
anyLnkInPS :: Float -- ^ amount to shift inward
|
||||
-> PlacementSpot
|
||||
anyLnkInPS x = PSLnk (const True) f (const id) Nothing
|
||||
where
|
||||
f (v,a) = (v -.- x *.* unitVectorAtAngle (a + 0.5 * pi), a+ pi)
|
||||
|
||||
spNoID :: PlacementSpot -> PSType -> Placement
|
||||
spNoID ps pst = Placement ps pst Nothing (const Nothing)
|
||||
|
||||
pContID :: PlacementSpot -> PSType -> (Int -> Maybe Placement) -> Placement
|
||||
pContID ps pt = Placement ps pt Nothing . intPlPlPl
|
||||
|
||||
plCont :: PlacementSpot -> PSType -> (Placement -> Maybe Placement) -> Placement
|
||||
plCont ps pt = Placement ps pt Nothing
|
||||
|
||||
sPS :: Point2 -> Float -> PSType -> Placement
|
||||
sPS p a pt = Placement (PS p a) pt Nothing (const Nothing)
|
||||
|
||||
jsps :: Point2 -> Float -> PSType -> Maybe Placement
|
||||
jsps p a pst = Just $ Placement (PS p a) pst Nothing $ const Nothing
|
||||
|
||||
jsps0 :: PSType -> Maybe Placement
|
||||
jsps0 pst = Just $ sPS (V2 0 0) 0 pst
|
||||
|
||||
sps0 :: PSType -> Placement
|
||||
sps0 = sPS (V2 0 0) 0
|
||||
|
||||
jspsJ :: Point2 -> Float -> PSType -> Placement -> Maybe Placement
|
||||
jspsJ p a pst plm = Just $ Placement (PS p a) pst Nothing $ \_ -> Just plm
|
||||
|
||||
jsps0J :: PSType -> Placement -> Maybe Placement
|
||||
jsps0J pst plm = Just $ Placement (PS (V2 0 0) 0) pst Nothing $ \_ -> Just plm
|
||||
|
||||
ps0 :: PSType -> (Int -> Maybe Placement) -> Placement
|
||||
ps0 pst = Placement (PS (V2 0 0) 0) pst Nothing . intPlPlPl
|
||||
|
||||
intPlPlPl :: (Int -> Maybe Placement) -> Placement -> Maybe Placement
|
||||
intPlPlPl f = f . fromJust . _plMID
|
||||
|
||||
jps0 :: PSType -> (Int -> Maybe Placement) -> Maybe Placement
|
||||
jps0 pst = Just . Placement (PS (V2 0 0) 0) pst Nothing . intPlPlPl
|
||||
|
||||
ps0j :: PSType -> Placement -> Placement
|
||||
ps0j pst plmnt = Placement (PS (V2 0 0) 0) pst Nothing (const $ Just plmnt)
|
||||
|
||||
addPlmnt :: Placement -> Placement -> Placement
|
||||
addPlmnt pl pl2 = case pl2 of
|
||||
(PlacementUsingPos p f) -> PlacementUsingPos p (fmap (addPlmnt pl) f)
|
||||
(RandomPlacement rp) -> RandomPlacement $ fmap (addPlmnt pl) rp
|
||||
(Placement ps pt mi f) -> Placement ps pt mi (fmap g f)
|
||||
where
|
||||
g Nothing = Just pl
|
||||
g (Just pl') = Just $ addPlmnt pl pl'
|
||||
|
||||
{-
|
||||
The '_rmPolys' list states which polygons should be cut out to form the indestructible walls of the room.
|
||||
@@ -147,7 +90,92 @@ data RoomPos
|
||||
| PosPl Point2 Float
|
||||
| LabPos Int RoomPos
|
||||
deriving (Eq,Ord,Show)
|
||||
|
||||
extractRoomPos :: RoomPos -> (Point2,Float)
|
||||
extractRoomPos rp = case rp of
|
||||
OutLink _ p a -> (p,a)
|
||||
InLink p a -> (p,a)
|
||||
UnusedLink p a -> (p,a)
|
||||
PosPl p a -> (p,a)
|
||||
LabPos _ rp' -> extractRoomPos rp'
|
||||
|
||||
makeLenses ''Room
|
||||
makeLenses ''PSType
|
||||
makeLenses ''PlacementSpot
|
||||
makeLenses ''Placement
|
||||
|
||||
-- TODO rename to any unused link facing out
|
||||
anyLnkOutPS :: PlacementSpot
|
||||
anyLnkOutPS = PSLnk f (const id) Nothing
|
||||
where
|
||||
f (UnusedLink p a) = Just $ PS p a
|
||||
f _ = Nothing
|
||||
|
||||
|
||||
anyLnkInPS :: Float -- ^ amount to shift inward
|
||||
-> PlacementSpot
|
||||
anyLnkInPS x = PSLnk f (const id) Nothing
|
||||
where
|
||||
f (UnusedLink v a) = Just $ PS (v -.- x *.* unitVectorAtAngle (a + 0.5 * pi)) (a+ pi)
|
||||
f _ = Nothing
|
||||
|
||||
spNoID :: PlacementSpot -> PSType -> Placement
|
||||
spNoID ps pst = Placement ps pst Nothing (const Nothing)
|
||||
|
||||
pContID :: PlacementSpot -> PSType -> (Int -> Maybe Placement) -> Placement
|
||||
pContID ps pt = Placement ps pt Nothing . intPlPlPl
|
||||
|
||||
plCont :: PlacementSpot -> PSType -> (Placement -> Maybe Placement) -> Placement
|
||||
plCont ps pt = Placement ps pt Nothing
|
||||
|
||||
sPS :: Point2 -> Float -> PSType -> Placement
|
||||
sPS p a pt = Placement (PS p a) pt Nothing (const Nothing)
|
||||
|
||||
jsps :: Point2 -> Float -> PSType -> Maybe Placement
|
||||
jsps p a pst = Just $ Placement (PS p a) pst Nothing $ const Nothing
|
||||
|
||||
jsps0 :: PSType -> Maybe Placement
|
||||
jsps0 pst = Just $ sPS (V2 0 0) 0 pst
|
||||
|
||||
sps0 :: PSType -> Placement
|
||||
sps0 = sPS (V2 0 0) 0
|
||||
|
||||
jspsJ :: Point2 -> Float -> PSType -> Placement -> Maybe Placement
|
||||
jspsJ p a pst plm = Just $ Placement (PS p a) pst Nothing $ \_ -> Just plm
|
||||
|
||||
jsps0J :: PSType -> Placement -> Maybe Placement
|
||||
jsps0J pst plm = Just $ Placement (PS (V2 0 0) 0) pst Nothing $ \_ -> Just plm
|
||||
|
||||
ps0 :: PSType -> (Int -> Maybe Placement) -> Placement
|
||||
ps0 pst = Placement (PS (V2 0 0) 0) pst Nothing . intPlPlPl
|
||||
|
||||
pt0 :: PSType -> (Placement -> Maybe Placement) -> Placement
|
||||
pt0 pst = Placement (PS (V2 0 0) 0) pst Nothing
|
||||
|
||||
contToIDCont :: (Int -> Maybe Placement) -> Placement -> Maybe Placement
|
||||
contToIDCont f plmnt = f $ fromJust (_plMID plmnt)
|
||||
|
||||
intPlPlPl :: (Int -> Maybe Placement) -> Placement -> Maybe Placement
|
||||
intPlPlPl f = f . fromJust . _plMID
|
||||
|
||||
jps0 :: PSType -> (Int -> Maybe Placement) -> Maybe Placement
|
||||
jps0 pst = Just . Placement (PS (V2 0 0) 0) pst Nothing . intPlPlPl
|
||||
|
||||
jps0PushPS :: PSType -> (Int -> Maybe Placement) -> Maybe Placement
|
||||
jps0PushPS pst f = Just . Placement (PS (V2 0 0) 0) pst Nothing
|
||||
$ \plmnt -> (f (fromJust $ _plMID plmnt) <&> plSpot .~ _plSpot plmnt)
|
||||
|
||||
ps0j :: PSType -> Placement -> Placement
|
||||
ps0j pst plmnt = Placement (PS (V2 0 0) 0) pst Nothing (const $ Just plmnt)
|
||||
|
||||
ps0jPushPS :: PSType -> Placement -> Placement
|
||||
ps0jPushPS pst plmnt = Placement (PS (V2 0 0) 0) pst Nothing (\p -> Just $ plmnt & plSpot .~ _plSpot p)
|
||||
|
||||
addPlmnt :: Placement -> Placement -> Placement
|
||||
addPlmnt pl pl2 = case pl2 of
|
||||
(PlacementUsingPos p f) -> PlacementUsingPos p (fmap (addPlmnt pl) f)
|
||||
(RandomPlacement rp) -> RandomPlacement $ fmap (addPlmnt pl) rp
|
||||
(Placement ps pt mi f) -> Placement ps pt mi (fmap g f)
|
||||
where
|
||||
g Nothing = Just pl
|
||||
g (Just pl') = Just $ addPlmnt pl pl'
|
||||
|
||||
@@ -10,18 +10,24 @@ import Dodge.LevelGen.Switch
|
||||
import Dodge.Placements.LightSource
|
||||
import Dodge.Placements.Spot
|
||||
|
||||
import Data.Maybe
|
||||
import Control.Lens
|
||||
|
||||
externalButton :: Color -> PlacementSpot -> Placement
|
||||
externalButton col ps = pContID ps (PutTrigger (const False))
|
||||
$ \trigid -> Just $ pContID ps (PutButton (makeSwitch col col (oneff trigid) (offeff trigid)))
|
||||
--externalButton col ps = pContID ps (PutTrigger (const False))
|
||||
-- $ \trigid -> Just $ pContID ps (PutButton (makeSwitch col col (oneff trigid) (offeff trigid)))
|
||||
-- (const Nothing)
|
||||
externalButton col ps = plCont ps (PutTrigger (const False))
|
||||
$ \tp -> Just $ pContID ps (PutButton (makeSwitch col col (oneff $ trigid tp) (offeff $ trigid tp)))
|
||||
(const Nothing)
|
||||
where
|
||||
trigid tp = fromJust $ _plMID tp
|
||||
oneff tid = triggers . ix tid .~ const True
|
||||
offeff tid = triggers . ix tid .~ const False
|
||||
|
||||
putLitButtonID :: Color -> Point2 -> Float -> (Int -> Maybe Placement) -> Placement
|
||||
putLitButtonID col p a subpl = mntLSOn aShape (Just col) ls p'' (addZ 40 p')
|
||||
$ contToIDCont
|
||||
$ \lsid -> jps0 (PutButton (makeButton col (changeLight lsid)) {_btPos = p, _btRot = a})
|
||||
subpl
|
||||
where
|
||||
@@ -30,12 +36,13 @@ putLitButtonID col p a subpl = mntLSOn aShape (Just col) ls p'' (addZ 40 p')
|
||||
changeLight lsid = lightSources . ix lsid . lsIntensity .~ V3 0 0.5 0
|
||||
ls = defaultLS { _lsRad = 75 , _lsIntensity = V3 0.5 0 0 }
|
||||
|
||||
putLitButtonID' :: Color -> ((Point2,Float) -> Bool) -> (Int -> Maybe Placement) -> Placement
|
||||
putLitButtonID' col f subpl
|
||||
= updatePSToLevel 3 (const thePS) $ mntLSOn aShape (Just col) ls 0 (V3 0 (-40) 40)
|
||||
$ \lsid -> jps0 (PutButton (makeButton col (changeLight lsid)) {_btPos = V2 0 (-1), _btRot = pi})
|
||||
subpl
|
||||
putLitButOnPos :: Color -> (RoomPos -> Maybe PlacementSpot) -> (Int -> Maybe Placement) -> Placement
|
||||
putLitButOnPos col f subpl
|
||||
= updatePSToLevel 1 (const thePS) $ mntLSOn aShape (Just col) ls 0 (V3 0 (-40) 40)
|
||||
$ \plmnt -> let lsid = fromJust $ _plMID plmnt
|
||||
in jps0 (PutButton (makeButton col (changeLight lsid)) {_btPos = V2 0 (-1), _btRot = pi})
|
||||
subpl <&> plSpot .~ _plSpot plmnt
|
||||
where
|
||||
changeLight lsid = lightSources . ix lsid . lsIntensity .~ V3 0 0.5 0
|
||||
ls = defaultLS { _lsRad = 75 , _lsIntensity = V3 0.5 0 0 }
|
||||
thePS = PSLnk f id (const id) Nothing
|
||||
thePS = PSLnk f (const id) Nothing
|
||||
|
||||
@@ -17,10 +17,10 @@ import Shape
|
||||
mntLSOn
|
||||
:: (Point2 -> Point3 -> Shape) -- ^ function describing the mount shape
|
||||
-> Maybe Color -- ^ describing a possible color override for the shape
|
||||
-> LightSource -> Point2 -> Point3 -> (Int -> Maybe Placement) -> Placement
|
||||
-> LightSource -> Point2 -> Point3 -> (Placement -> Maybe Placement) -> Placement
|
||||
mntLSOn shapeF mcol ls wallp lsp@(V3 lx ly _)
|
||||
= ps0j (PutForeground . setCol $ shapeF wallp lsp)
|
||||
. ps0 (PutLS $ ls {_lsPos = lsp'})
|
||||
= ps0jPushPS (PutForeground . setCol $ shapeF wallp lsp)
|
||||
. pt0 (PutLS $ ls {_lsPos = lsp'})
|
||||
where
|
||||
lsp' = lsp -.-.- V3 x y 1
|
||||
-- hack! perturb the light position
|
||||
@@ -79,8 +79,8 @@ vShape wallpos (V3 x y z) =
|
||||
mntLS :: (Point2 -> Point3 -> Shape) -> Point2 -> Point3 -> Placement
|
||||
mntLS shp wallp lampp = mntLSOn shp Nothing defaultLS wallp lampp (const Nothing)
|
||||
|
||||
mntLSCond :: (Point2 -> Point3 -> Shape) -> ((Point2,Float) -> Bool) -> Placement
|
||||
mntLSCond shp cond = updatePSToLevel 2 (const $ PSLnk cond id (const id) Nothing)
|
||||
mntLSCond :: (Point2 -> Point3 -> Shape) -> (RoomPos -> Maybe PlacementSpot) -> Placement
|
||||
mntLSCond shp shift = updatePSToLevel 2 (const $ PSLnk shift (const id) Nothing)
|
||||
$ mntLS shp 0 (V3 0 (-40) 90)
|
||||
-- note that this perhaps pushes the vshape light out too far
|
||||
|
||||
@@ -89,11 +89,16 @@ mntLight a b = RandomPlacement $ do
|
||||
shp <- takeOne [vShape,iShape,lShape,jShape,liShape]
|
||||
return $ mntLS shp a (addZ 90 b)
|
||||
|
||||
mntLightLnkCond :: ((Point2,Float) -> Bool) -> Placement
|
||||
mntLightLnkCond :: (RoomPos -> Maybe PlacementSpot) -> Placement
|
||||
mntLightLnkCond f = RandomPlacement $ do
|
||||
shp <- takeOne [vShape,iShape,lShape,jShape,liShape]
|
||||
return $ mntLSCond shp f
|
||||
|
||||
unusedLnkToPS :: RoomPos -> Maybe PlacementSpot
|
||||
unusedLnkToPS rp = case rp of
|
||||
UnusedLink p a -> Just $ PS p a
|
||||
_ -> Nothing
|
||||
|
||||
spanColLightI :: Point3 -> Float -> Point2 -> Point2 -> Placement
|
||||
spanColLightI col h a b = ps0j (PutLS $ colorLightAt col (V3 x y (h-5)) 0)
|
||||
$ sps0 $ PutForeground $ thinHighBar h a b
|
||||
|
||||
@@ -114,10 +114,10 @@ addButtonSlowDoor x h rm = do
|
||||
openDoorBound = rectNSEW (h + 5) (h - 5) (-x/2) (3*x/2)
|
||||
belowH y = (sndV2 . fst) y < h - 40
|
||||
aboveH y = (sndV2 . fst) y > h + 40
|
||||
butDoor _ _ = putLitButtonID' col butPosCond
|
||||
--butDoor bpos brot = putLitButtonID col bpos brot
|
||||
butDoor _ _ = putLitButOnPos col butPosCond
|
||||
$ \btid -> Just $ putDoubleDoor False col (cond' btid) (V2 0 h) (V2 x h) 2
|
||||
butPosCond (V2 _ y,_) = y < h
|
||||
butPosCond (UnusedLink (V2 x' y') a') | y' < 0.5 * h = Just $ PS (V2 x' y') a'
|
||||
butPosCond _ = Nothing
|
||||
--butPosCond _ = True -- y < h
|
||||
col = dim $ light red
|
||||
cond' btid w = w ^? buttons . ix btid . btState /= Just BtOff
|
||||
|
||||
@@ -71,7 +71,7 @@ roomRectAutoLinks x y = (roomRect x y ((ceiling x - 40) `div` 60) ((ceiling y -
|
||||
{_rmPmnts = plmnts}
|
||||
where
|
||||
plmnts =
|
||||
[mntLightLnkCond (const True)
|
||||
[mntLightLnkCond unusedLnkToPS
|
||||
-- ,sps0 $ PutForeground $ thinHighBarChain 50 $ rectNSWE y 0 0 x
|
||||
]
|
||||
{- Combines two rooms into one room.
|
||||
|
||||
+13
-10
@@ -104,10 +104,11 @@ glassSwitchBack = do
|
||||
hgt <- state $ randomR (400,600)
|
||||
wllen <- state $ randomR (60,wth/2-40)
|
||||
let hf = hgt/5
|
||||
con1 (V2 _ y,_) = y < 0.5*hgt
|
||||
con1 cond (UnusedLink (V2 x y) a) | cond y = Just $ PS (V2 x y) a
|
||||
con1 _ _ = Nothing
|
||||
plmnts =
|
||||
[ mntLightLnkCond con1
|
||||
, mntLightLnkCond (not . con1)
|
||||
[ mntLightLnkCond $ con1 (< 0.5 * hgt)
|
||||
, mntLightLnkCond $ con1 (> 0.5 * hgt)
|
||||
,windowLine (V2 (wth-60 ) hf ) (V2 wllen hf )
|
||||
,windowLine (V2 (wth-wllen) (2*hf)) (V2 60 (2*hf))
|
||||
,windowLine (V2 (wth-60 ) (3*hf)) (V2 wllen (3*hf))
|
||||
@@ -199,8 +200,8 @@ roomCenterPillar = changeLinkTo ((\p -> dist p (V2 120 0) < 10) . fst)
|
||||
, blockLine (V2 125 115) (V2 125 125)
|
||||
--, sPS (V2 40 120) 0 putLamp
|
||||
--, sPS (V2 200 120) 0 putLamp
|
||||
, mntLightLnkCond (const True)
|
||||
, mntLightLnkCond (const True)
|
||||
, mntLightLnkCond unusedLnkToPS
|
||||
, mntLightLnkCond unusedLnkToPS
|
||||
]
|
||||
|
||||
roomOctogon :: Room
|
||||
@@ -249,7 +250,7 @@ weaponEmptyRoom = do
|
||||
,sPS (V2 20 20) (pi/2) randC1
|
||||
,sPS (V2 (w-20) 20) (pi/2) randC1
|
||||
--,sPS (V2 (w/2) (h/2)) 0 putLamp
|
||||
,mntLightLnkCond (const True)
|
||||
,mntLightLnkCond unusedLnkToPS
|
||||
]
|
||||
(fmap connectRoom . randomiseOutLinks) =<<
|
||||
changeLinkTo ((\p -> dist p (V2 (w/2) 0) < 10) . fst) (set rmPmnts plmnts $ roomRect w h 2 2)
|
||||
@@ -441,10 +442,12 @@ pillarGrid = do
|
||||
y <- takeOne ys
|
||||
a <- state $ randomR (0,2*pi)
|
||||
return (V2 (x+gap) y,a)
|
||||
cornerRestrict (V2 x y,_)
|
||||
= (x > 40 && x < h - 40)
|
||||
|| (y > 40 && y < h - 40)
|
||||
let plmnts = replicate 8 (mntLightLnkCond cornerRestrict)
|
||||
-- the following was used to stop lights from being mounted in corners and
|
||||
-- potentially overlapping, might want to redo
|
||||
-- cornerRestrict (V2 x y,_)
|
||||
-- = (x > 40 && x < h - 40)
|
||||
-- || (y > 40 && y < h - 40)
|
||||
let plmnts = replicate 8 (mntLightLnkCond unusedLnkToPS)
|
||||
++
|
||||
concat [f x y | x<-xs,y<-ys]
|
||||
return $ roomRect w h (max i 2) (max i 2)
|
||||
|
||||
@@ -40,6 +40,6 @@ startRoom = do
|
||||
<$> randomiseOutLinks
|
||||
(shiftRoomBy (V2 (-20) (-20),0)
|
||||
$ roomRectAutoLinks w h & rmPmnts %~ (plmnts ++)
|
||||
& rmStartWires .~ IM.fromList [(0,RoomWire (V2 0 0) 0)]
|
||||
& rmEndWires .~ IM.fromList [(0,RoomWire (V2 (500) 500) 0)]
|
||||
& rmStartWires .~ IM.fromList [(0,RoomWire (V2 0 0) 0)]
|
||||
& rmEndWires .~ IM.fromList [(0,RoomWire (V2 500 500) 0)]
|
||||
)
|
||||
|
||||
Reference in New Issue
Block a user