diff --git a/src/Dodge/Data.hs b/src/Dodge/Data.hs index e89a490d6..46ba3b1c5 100644 --- a/src/Dodge/Data.hs +++ b/src/Dodge/Data.hs @@ -1412,8 +1412,8 @@ data PSType = PutCrit {_unPutCrit :: Creature} | PutLineBlock {_putWall :: Wall , _putWidth :: Float , _putStartPoint :: Point2, _putEndPoint :: Point2} | PutWall { _pwPoly :: [Point2] , _pwWall :: Wall } - | PutSlideDr Door Wall Float Point2 Point2 - | PutDoor Color (World -> Bool) [(Point2,Point2)] + | PutSlideDr Door Wall EdgeObstacle Float Point2 Point2 + | PutDoor Color EdgeObstacle (World -> Bool) [(Point2,Point2)] | RandPS (State StdGen PSType) | PutForeground ForegroundShape | PutWorldUpdate (PlacementSpot -> World -> World) diff --git a/src/Dodge/Placement/Instance/Door.hs b/src/Dodge/Placement/Instance/Door.hs index 904307474..63804492b 100644 --- a/src/Dodge/Placement/Instance/Door.hs +++ b/src/Dodge/Placement/Instance/Door.hs @@ -33,7 +33,7 @@ putDoubleDoorThen wl cond soff a b speed cont doorBetween :: Wall -> (World -> Bool) -> Float -> Point2 -> Point2 -> Float -> (Placement -> Maybe Placement) -> Placement doorBetween wl cond soff pa pb speed g = case divideLine 40 pa pb of - [x,y] -> ptCont (PutSlideDr adoor wl soff x y) g + [x,y] -> ptCont (PutSlideDr adoor wl DoorObstacle soff x y) g (x:y:zs) -> divideDoorPane Nothing wl cond (soff - dist y pb) speed (zip (x:y:zs) (y:zs)) g _ -> undefined where @@ -48,7 +48,7 @@ divideDoorPane mid wl cond soff speed ppairs g = case ppairs of (p:ps) -> ptCont (adoor p) $ \pl -> Just $ divideDoorPane (_plMID pl) wl cond soff speed ps g _ -> undefined where - adoor (x,y) = PutSlideDr thedoor wl soff x y + adoor (x,y) = PutSlideDr thedoor wl DoorObstacle soff x y thedoor = defaultDoor & drSpeed .~ speed & drTrigger .~ cond & drPushedBy .~ maybe PushesItself PushedBy mid @@ -67,7 +67,7 @@ switchDoor btpos btrot dra drb col = pContID (PS btpos btrot) (PutButton $ makeS $ \btid -> jsps0J (doorbetween btid dra drc) $ sps0 (doorbetween btid drb drc) where - doorbetween btid a b = PutSlideDr thedoor (switchWallCol col) 1 a b + doorbetween btid a b = PutSlideDr thedoor (switchWallCol col) DoorObstacle 1 a b where thedoor = defaultDoor & drTrigger .~ cond btid diff --git a/src/Dodge/Placement/PlaceSpot.hs b/src/Dodge/Placement/PlaceSpot.hs index 9f5ac8869..ea4f6fa40 100644 --- a/src/Dodge/Placement/PlaceSpot.hs +++ b/src/Dodge/Placement/PlaceSpot.hs @@ -95,10 +95,10 @@ placeSpotID ps pt w = case pt of PutLS ls -> plNewUpID lightSources lsID (mvLS p' rot ls) w PutPPlate pp -> plNewUpID pressPlates ppID (mvPP p rot pp) w RandPS rgn -> evaluateRandPS rgn ps w - PutDoor col f pss -> plDoor col f (map (bimap doShift doShift) pss) w + PutDoor col eo f pss -> plDoor col eo f (map (bimap doShift doShift) pss) w PutCoord cp -> plNewID coordinates (doShift cp) w - PutSlideDr wl dr off a b - -> plSlideDoor wl dr off (doShift a) (doShift b) w + PutSlideDr wl dr eo off a b + -> plSlideDoor wl dr eo off (doShift a) (doShift b) w PutBlock bl wl ps' -> plBlock (map doShift ps') (bl & blPos %~ doShift & blDir .~ rot) wl w PutLineBlock wl wdth a b -> plLineBlock wl wdth (doShift a) (doShift b) w diff --git a/src/Dodge/Placement/PlaceSpot/TriggerDoor.hs b/src/Dodge/Placement/PlaceSpot/TriggerDoor.hs index 7fedbc39a..de8bc02f1 100644 --- a/src/Dodge/Placement/PlaceSpot/TriggerDoor.hs +++ b/src/Dodge/Placement/PlaceSpot/TriggerDoor.hs @@ -23,12 +23,13 @@ import qualified Data.IntSet as IS import qualified Data.Graph.Inductive as FGL import qualified Streaming.Prelude as S plDoor :: Color + -> EdgeObstacle -> (World -> Bool) -- ^ Opening condition -> [(Point2,Point2)] -- ^ Door positions, closed to open. -- Bumped out up and down by 9, not widened -> World -> (Int,World) -plDoor col cond pss gw = (drid, addWalls $ gw & doors %~ addDoor) -- carefull with the ordering of addWalls +plDoor col eo cond pss gw = (drid, addWalls $ gw & doors %~ addDoor) -- carefull with the ordering of addWalls where drid = IM.newKey $ _doors gw addDoor = IM.insert drid $ defaultDoor @@ -40,14 +41,15 @@ plDoor col cond pss gw = (drid, addWalls $ gw & doors %~ addDoor) -- carefull wi , _drPos = head pss , _drOpenPos = head pss , _drClosePos = last pss + , _drObstacleType = eo } nsteps = length pss - 1 wlids = take 4 [IM.newKey $ _walls gw ..] wlps' = uncurry (rectanglePairs 9) $ head pss - addWalls w' = foldl' (addDoorWall drid $ switchWallCol col) w' $ zip wlids wlps' + addWalls w' = foldl' (addDoorWall eo drid $ switchWallCol col) w' $ zip wlids wlps' -addDoorWall :: Int -> Wall -> World -> (Int,(Point2,Point2)) -> World -addDoorWall drid wl w (wlid,wlps) = w' +addDoorWall :: EdgeObstacle -> Int -> Wall -> World -> (Int,(Point2,Point2)) -> World +addDoorWall eo drid wl w (wlid,wlps) = w' & walls %~ IM.insert wlid wl { _wlLine = wlps , _wlID = wlid @@ -55,7 +57,7 @@ addDoorWall drid wl w (wlid,wlps) = w' } & doors . ix drid . drObstructs .++~ es where - (w',es) = uncurry (obstructPathsCrossing DoorObstacle) wlps w + (w',es) = uncurry (obstructPathsCrossing eo) wlps w -- TODO use vector instead of list, perhaps also memoisation of rectanglePairs -- TODO update _drPos -- perhaps also remove use of DoorInt in favour of DoorOpen/DoorClosed @@ -121,12 +123,13 @@ maybeClearDoorPath eo w (x,y,pe) plSlideDoor :: Door -> Wall + -> EdgeObstacle -> Float -> Point2 -> Point2 -> World -> (Int, World) -plSlideDoor dr wl shiftOffset a b gw +plSlideDoor dr wl eo shiftOffset a b gw = (drid, addDoorWalls $ gw & doors %~ addDoor) where drid = IM.newKey $ _doors gw @@ -138,9 +141,9 @@ plSlideDoor dr wl shiftOffset a b gw , _drPos = (a,b) , _drOpenPos = (shiftLeft a,shiftLeft b) , _drClosePos = (a,b) - , _drObstacleType = DoorObstacle + , _drObstacleType = eo } - addDoorWalls w' = foldl' (addDoorWall drid wl) w' $ zip wlids pairs + addDoorWalls w' = foldl' (addDoorWall eo drid wl) w' $ zip wlids pairs pairs = rectanglePairs 9 a b shiftLeft = (+.+ (a -.- b +.+ shiftOffset *.* normalizeV (b -.- a))) wlids = take 4 [IM.newKey $ _walls gw ..] diff --git a/src/Dodge/Render/ShapePicture.hs b/src/Dodge/Render/ShapePicture.hs index e61875fa2..a24807fe8 100644 --- a/src/Dodge/Render/ShapePicture.hs +++ b/src/Dodge/Render/ShapePicture.hs @@ -160,17 +160,18 @@ drawInspectWall w wl = setLayer DebugLayer $ drawDoorPaths :: World -> Int -> Picture drawDoorPaths w drid = fromMaybe mempty $ do paths <- w ^? doors . ix drid . drObstructs --- path <- listToMaybe paths --- undefined return $ foldMap (drawPathEdge . (^. _3)) paths --- return $ (drawPathEdge . (^. _3)) path drawPathEdge :: PathEdge -> Picture -drawPathEdge pe = setLayer DebugLayer $ color col $ arrow (_peStart pe) (_peEnd pe) - where - col = case _peObstacles pe of - pos | WallObstacle `Set.member` pos -> blue - | True -> red +drawPathEdge pe = setLayer DebugLayer + $ multiArrow (_peStart pe) (_peEnd pe) green (Set.map obstacleColor (_peObstacles pe)) + +obstacleColor :: EdgeObstacle -> Color +obstacleColor eo = case eo of + WallObstacle -> cyan + DoorObstacle -> red + AutoDoorObstacle -> yellow + BlockObstacle -> blue drawWorldSelect :: World -> Picture drawWorldSelect w = setLayer DebugLayer @@ -293,15 +294,8 @@ drawWlIDs cfig w = setLayer FixedCoordLayer $ foldMap f (_walls w) edgeToPic :: [Point2] -> PathEdge -> Picture edgeToPic poly pe | not (pointInPolygon sp poly) && not (pointInPolygon ep poly) = mempty - | null $ _peObstacles pe - = anarrow green - | hasobstacle BlockObstacle - = anarrow red - | hasobstacle AutoDoorObstacle = anarrow yellow - | otherwise = anarrow cyan + | otherwise = drawPathEdge pe where - hasobstacle = (`Set.member` _peObstacles pe) - anarrow col = color col $ arrow sp ep sp = _peStart pe ep = _peEnd pe diff --git a/src/Dodge/Room/Airlock.hs b/src/Dodge/Room/Airlock.hs index 443236d60..8f46e5a8f 100644 --- a/src/Dodge/Room/Airlock.hs +++ b/src/Dodge/Room/Airlock.hs @@ -44,6 +44,14 @@ airlock0 = defaultRoom cond' btid w' = _btState (_buttons w' IM.! btid) == BtOn col = dim $ dim $ bright red +airlockDoor :: Color -> (World -> Bool) -> [(Point2,Point2)] -> PSType +airlockDoor col = PutDoor col DoorObstacle + +airlockDoubleDoor :: Point2 -> Point2 -> Color -> (World -> Bool) -> [(Point2,Point2)] + -> [(Point2,Point2)] -> Maybe Placement +airlockDoubleDoor p1 p2 col cond outDoorps inDoorps = jspsJ p1 0 (airlockDoor col cond outDoorps) + $ sPS p2 0 (airlockDoor col cond inDoorps) + airlockSimple :: Room airlockSimple = defaultRoom { _rmPolys = @@ -52,8 +60,9 @@ airlockSimple = defaultRoom , _rmPath = foldMap (doublePairSet . (V2 90 30,) . fst) lnks , _rmPmnts = [pContID (PS (V2 90 115) pi) (PutButton $ makeSwitch col red id id) - $ \btid -> jspsJ (V2 0 0) 0 (PutDoor col (cond btid) outDoorps) - $ sPS (V2 180 0) 0 (PutDoor col (cond btid) inDoorps) + $ \btid -> airlockDoubleDoor 0 (V2 180 0) col (cond btid) outDoorps inDoorps +-- jspsJ (V2 0 0) 0 (airlockDoor col (cond btid) outDoorps) +-- $ sPS (V2 180 0) 0 (airlockDoor col (cond btid) inDoorps) ] , _rmBound = [ rectNSWE 120 0 0 180 ] @@ -78,8 +87,9 @@ airlockZ = defaultRoom -- ] , _rmPmnts = [pContID (PS (V2 90 115) pi) (PutButton $ makeSwitch col red id id) - $ \btid -> jspsJ (V2 0 60) 0 (PutDoor col (cond btid) outDoorps) - $ sPS (V2 180 60) 0 (PutDoor col (cond btid) inDoorps) + $ \btid -> airlockDoubleDoor (V2 0 60) (V2 180 60) col (cond btid) outDoorps inDoorps +-- jspsJ (V2 0 60) 0 (airlockDoor col (cond btid) outDoorps) +-- $ sPS (V2 180 60) 0 (airlockDoor col (cond btid) inDoorps) , sps0 $ PutWall (reverse $ rectNSWE 70 50 60 120) defaultWall , lighting ] @@ -112,7 +122,7 @@ airlock90 = defaultRoom , _rmPath = doublePairSet (V2 0 40,V2 40 0) , _rmPmnts = [ pContID (PS (V2 120 120) (3 * pi/4)) (PutButton $ makeSwitch col red id id) - $ \btid -> jsps (V2 5 5) 0 $ PutDoor col (cond btid) pss + $ \btid -> jsps (V2 5 5) 0 $ airlockDoor col (cond btid) pss , mntLS vShape (V2 35 35) (V3 70 70 50) ] , _rmBound = @@ -137,7 +147,7 @@ airlockCrystal = defaultRoom , _rmPath = mempty , _rmPmnts = [pContID (PS (V2 145 70) (pi/2)) ( PutButton $ makeSwitch col red id id) - $ \btid -> jsps0 $ PutDoor col (cond btid) pss + $ \btid -> jsps0 $ airlockDoor col (cond btid) pss , crystalLine (V2 0 70) (V2 40 70) , mntLS vShape (V2 150 70) (V3 110 70 70) ] diff --git a/src/Dodge/Room/LongDoor.hs b/src/Dodge/Room/LongDoor.hs index 51cb18ee5..7f95f2335 100644 --- a/src/Dodge/Room/LongDoor.hs +++ b/src/Dodge/Room/LongDoor.hs @@ -46,8 +46,8 @@ twinSlowDoorRoom w h x = defaultRoom , _rmPath = mempty , _rmPmnts = [ pContID (PS (V2 0 (h-5)) pi) ( PutButton $ makeButton col id) - $ \btid -> jsps0J (PutSlideDr (thedoor btid) thewall 1 (V2 x 1) (V2 x h)) - $ ps0 (PutSlideDr (thedoor btid) thewall 1 (V2 (-x) 1) (V2 (-x) h)) + $ \btid -> jsps0J (PutSlideDr (thedoor btid) thewall DoorObstacle 1 (V2 x 1) (V2 x h)) + $ ps0 (PutSlideDr (thedoor btid) thewall DoorObstacle 1 (V2 (-x) 1) (V2 (-x) h)) $ \did -> jps0' (PutLS (lsColPos (V3 0.75 0 0) (V3 0 (h-1) lampHeight))) $ \lspl -> jsps0 $ PutProp $ addColorChange (fromJust $ _plMID lspl) did $ lampCoverWhen (drmoving did) (V2 0 (h-1)) lampHeight ] diff --git a/src/Dodge/Room/Procedural.hs b/src/Dodge/Room/Procedural.hs index 3a9e67372..e5998f5c6 100644 --- a/src/Dodge/Room/Procedural.hs +++ b/src/Dodge/Room/Procedural.hs @@ -267,8 +267,8 @@ centerVaultRoom w h d = return $ defaultRoom col = dim $ dim $ bright red theDoor = [ pContID (PS (V2 35 (d+4)) 0) (PutButton $ makeSwitch col red id id) - $ \btid -> jspsJ (V2 0 (d-10)) 0 (PutSlideDr (thedoor btid) thewall 1 (V2 (-21) 0) (V2 0 0)) - $ sPS (V2 0 (d-10)) 0 (PutSlideDr (thedoor btid) thewall 1 (V2 21 0) (V2 0 0)) + $ \btid -> jspsJ (V2 0 (d-10)) 0 (PutSlideDr (thedoor btid) thewall DoorObstacle 1 (V2 (-21) 0) (V2 0 0)) + $ sPS (V2 0 (d-10)) 0 (PutSlideDr (thedoor btid) thewall DoorObstacle 1 (V2 21 0) (V2 0 0)) ] thewall = switchWallCol col thedoor btid = defaultDoor diff --git a/src/Picture/Composite.hs b/src/Picture/Composite.hs index b007742fb..048c78f03 100644 --- a/src/Picture/Composite.hs +++ b/src/Picture/Composite.hs @@ -2,11 +2,20 @@ module Picture.Composite where import Picture.Data import Picture.Base import Geometry ---import Color + +import Data.Foldable arrowPath :: [Point2] -> Picture arrowPath xs = mconcat $ zipWith arrow xs $ tail xs +multiArrow :: Foldable t => Point2 -> Point2 -> Color -> t Color -> Picture +multiArrow sp ep col' cols + | null cols = color col' (arrow sp ep) + | otherwise = foldl' f mempty cols + where + f pic col = uncurryV translate offset pic <> color col (arrow sp ep) + offset = normalizeV (vNormal (ep -.- sp)) + arrow :: Point2 -> Point2 -> Picture arrow a b = line [a,b] <> line [b +.+ n -.- v,b]