Various improvements, metal debris
This commit is contained in:
@@ -6,7 +6,6 @@ module Dodge.Placement.Instance.Door
|
||||
) where
|
||||
import Dodge.Data
|
||||
import Dodge.Default.Door
|
||||
--import Dodge.Base
|
||||
import Color
|
||||
import Geometry
|
||||
import Dodge.LevelGen.Data
|
||||
@@ -16,47 +15,48 @@ import Dodge.LevelGen.Switch
|
||||
import Control.Lens
|
||||
import qualified Data.IntMap.Strict as IM
|
||||
|
||||
putDoubleDoor :: Bool -> Color -> (World -> Bool) -> Point2 -> Point2 -> Float -> Placement
|
||||
putDoubleDoor pathing col cond a b speed
|
||||
= putDoubleDoorThen pathing col cond 1 a b speed (const $ const Nothing)
|
||||
putDoubleDoor :: Wall -> (World -> Bool) -> Point2 -> Point2 -> Float -> Placement
|
||||
putDoubleDoor wl cond a b speed
|
||||
= putDoubleDoorThen wl cond 1 a b speed (const $ const Nothing)
|
||||
|
||||
putDoubleDoorThen :: Bool -> Color -> (World -> Bool)
|
||||
putDoubleDoorThen :: Wall -> (World -> Bool)
|
||||
-> Float -> Point2 -> Point2 -> Float
|
||||
-> (Placement -> Placement -> Maybe Placement)
|
||||
-> Placement
|
||||
putDoubleDoorThen pathing col cond soff a b speed cont
|
||||
= doorBetween pathing col cond soff a half speed
|
||||
$ \pl1 -> Just $ doorBetween pathing col cond soff b half speed
|
||||
putDoubleDoorThen wl cond soff a b speed cont
|
||||
= doorBetween wl cond soff a half speed
|
||||
$ \pl1 -> Just $ doorBetween wl cond soff b half speed
|
||||
$ \pl2 -> cont pl1 pl2
|
||||
where
|
||||
half = 0.5 *.* (a +.+ b)
|
||||
|
||||
doorBetween :: Bool -> Color -> (World -> Bool) -> Float -> Point2 -> Point2 -> Float ->
|
||||
doorBetween :: Wall -> (World -> Bool) -> Float -> Point2 -> Point2 -> Float ->
|
||||
(Placement -> Maybe Placement) -> Placement
|
||||
doorBetween pathing col cond soff pa pb speed g = case divideLine 40 pa pb of
|
||||
[x,y] -> ptCont (PutSlideDr pathing col adoor soff x y) g
|
||||
(x:y:zs) -> divideDoorPane Nothing pathing col cond (soff - dist y pb) speed (zip (x:y:zs) (y:zs)) g
|
||||
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:zs) -> divideDoorPane Nothing wl cond (soff - dist y pb) speed (zip (x:y:zs) (y:zs)) g
|
||||
_ -> undefined
|
||||
where
|
||||
adoor = defaultDoor
|
||||
& drTrigger .~ cond
|
||||
& drSpeed .~ speed
|
||||
|
||||
divideDoorPane :: Maybe Int -> Bool -> Color -> (World -> Bool) -> Float -> Float
|
||||
divideDoorPane :: Maybe Int -> Wall -> (World -> Bool) -> Float -> Float
|
||||
-> [(Point2,Point2)] -> (Placement -> Maybe Placement) -> Placement
|
||||
divideDoorPane mid pathing col cond soff speed ppairs g = case ppairs of
|
||||
divideDoorPane mid wl cond soff speed ppairs g = case ppairs of
|
||||
[p] -> ptCont (adoor p) g
|
||||
(p:ps) -> ptCont (adoor p) $ \pl -> Just $ divideDoorPane (_plMID pl) pathing col cond soff speed ps g
|
||||
(p:ps) -> ptCont (adoor p) $ \pl -> Just $ divideDoorPane (_plMID pl) wl cond soff speed ps g
|
||||
_ -> undefined
|
||||
where
|
||||
adoor (x,y) = PutSlideDr pathing col thedoor soff x y
|
||||
adoor (x,y) = PutSlideDr thedoor wl soff x y
|
||||
thedoor = defaultDoor & drSpeed .~ speed & drTrigger .~ cond
|
||||
& drPushedBy .~ maybe PushesItself PushedBy mid
|
||||
|
||||
putAutoDoor :: Point2 -> Point2 -> Placement
|
||||
putAutoDoor a b = PlacementUsingPos (addZ 0 a)
|
||||
$ \az -> PlacementUsingPos (addZ 0 b)
|
||||
$ \bz -> putDoubleDoor True (dim yellow) (cond az bz) a b 3
|
||||
$ \bz -> putDoubleDoor defaultAutoWall
|
||||
(cond az bz) a b 3
|
||||
where
|
||||
--cond az bz = any (crNearSeg 40 (stripZ az) (stripZ bz)) . IM.filter isAnimate . _creatures
|
||||
cond az bz = any (crNearPoint 40 (0.5 *.* (stripZ az +.+ stripZ bz)))
|
||||
@@ -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 False col thedoor 1 a b
|
||||
doorbetween btid a b = PutSlideDr thedoor (switchWallCol col) 1 a b
|
||||
where
|
||||
thedoor = defaultDoor
|
||||
& drTrigger .~ cond btid
|
||||
|
||||
@@ -23,6 +23,7 @@ import Shape
|
||||
import qualified IntMapHelp as IM
|
||||
import Color
|
||||
|
||||
import Data.Foldable
|
||||
import Data.Maybe
|
||||
import System.Random
|
||||
import Control.Monad.State
|
||||
@@ -101,8 +102,8 @@ placeSpotID ps pt w = case pt of
|
||||
RandPS rgn -> evaluateRandPS rgn ps w
|
||||
PutDoor col f pss -> plDoor col f (map (bimap doShift doShift) pss) w
|
||||
PutCoord cp -> plNewID coordinates (doShift cp) w
|
||||
PutSlideDr pth col dr off a b
|
||||
-> plSlideDoor pth col dr off (doShift a) (doShift b) w
|
||||
PutSlideDr wl dr off a b
|
||||
-> plSlideDoor wl dr off (doShift a) (doShift b) w
|
||||
PutBlock bl wl ps' -> placeBlock (map doShift ps') (bl & blPos %~ doShift & blDir .~ rot)
|
||||
wl w
|
||||
PutLineBlock wl wdth dpth a b -> placeLineBlock wl wdth dpth (doShift a) (doShift b) w
|
||||
@@ -129,18 +130,18 @@ evaluateRandPS rgen ps w = placeSpotID ps evaluatedType (set randGen g w)
|
||||
(evaluatedType, g) = runState rgen (_randGen w)
|
||||
|
||||
placeWallPoly :: [Point2] -> Wall -> World -> World
|
||||
placeWallPoly ps wl = rmCrossPaths . over walls (addWalls ps wl)
|
||||
placeWallPoly ps wl = rmCrossPaths . over walls (placeWalls ps wl)
|
||||
where
|
||||
rmCrossPaths w = foldr (uncurry removePathsCrossing) w $ loopPairs ps
|
||||
|
||||
addWalls :: [Point2] -> Wall -> IM.IntMap Wall -> IM.IntMap Wall
|
||||
addWalls qs wl wls = foldr (addPane wl) wls pairs
|
||||
placeWalls :: [Point2] -> Wall -> IM.IntMap Wall -> IM.IntMap Wall
|
||||
placeWalls qs wl wls = foldl' (addPane wl) wls pairs
|
||||
where
|
||||
(p:ps) = orderPolygon qs
|
||||
pairs = zip (ps ++ [p]) (p:ps)
|
||||
|
||||
addPane :: Wall -> (Point2,Point2) -> IM.IntMap Wall -> IM.IntMap Wall
|
||||
addPane wl l wls = IM.insert wlid (wl { _wlLine = l, _wlID = wlid }) wls
|
||||
addPane :: Wall -> IM.IntMap Wall -> (Point2,Point2) -> IM.IntMap Wall
|
||||
addPane wl wls l = IM.insert wlid (wl { _wlLine = l, _wlID = wlid }) wls
|
||||
where
|
||||
wlid = IM.newKey wls
|
||||
|
||||
|
||||
@@ -47,7 +47,7 @@ addBlock (p:ps) wl bl w = w
|
||||
= insertIMInZone x y wlid wl'
|
||||
| otherwise = flip (foldl' $ flip (\(a,b) -> insertIMInZone a b wlid wl')) ips
|
||||
where
|
||||
(x,y) = zoneOfPoint $ uncurry pHalf (_wlLine wl)
|
||||
(x,y) = zoneOfPoint $ uncurry midPoint (_wlLine wl)
|
||||
wlid = _wlID wl
|
||||
ips = map zoneOfPoint $ uncurry (divideLine (2*zoneSize)) (_wlLine wl)
|
||||
addBlock _ _ _ _ = error "Trying to add a block with incomplete polygon"
|
||||
|
||||
@@ -5,7 +5,6 @@ module Dodge.Placement.PlaceSpot.TriggerDoor
|
||||
) where
|
||||
import Dodge.Data
|
||||
import Dodge.Base
|
||||
import Dodge.Default.Wall
|
||||
import Dodge.Default.Door
|
||||
import Dodge.Wall.Move
|
||||
import Dodge.LevelGen.DoorPane
|
||||
@@ -42,14 +41,12 @@ plDoor col cond pss gw = (drid, addWalls gw & doors %~ addDoor)
|
||||
nsteps = length pss - 1
|
||||
wlids = take 4 [IM.newKey $ _walls gw ..]
|
||||
wlps' = uncurry (rectanglePairs 9) $ head pss
|
||||
addWalls w' = foldl' (addDoorWall drid col False) w' $ zip wlids wlps'
|
||||
addWalls w' = foldl' (addDoorWall drid $ switchWallCol col) w' $ zip wlids wlps'
|
||||
|
||||
addDoorWall :: Int -> Color -> Bool -> World -> (Int,(Point2,Point2)) -> World
|
||||
addDoorWall drid col pathableStatus w (wlid,wlps) = w & walls %~ IM.insert wlid defaultWall
|
||||
addDoorWall :: Int -> Wall -> World -> (Int,(Point2,Point2)) -> World
|
||||
addDoorWall drid wl w (wlid,wlps) = w & walls %~ IM.insert wlid wl
|
||||
{ _wlLine = wlps
|
||||
, _wlID = wlid
|
||||
, _wlColor = col
|
||||
, _wlPathable = pathableStatus
|
||||
, _wlStructure = DoorPart drid
|
||||
}
|
||||
-- TODO use vector instead of list, perhaps also memoisation of rectanglePairs
|
||||
@@ -80,7 +77,7 @@ doorMechanismStepwise nsteps drid wlids pss dr w
|
||||
doorMechanism :: Door -> World -> World
|
||||
doorMechanism dr w = case mvDir of
|
||||
Just d -> w
|
||||
& flip (IS.foldr (`translateWallID` d)) (_drWallIDs dr)
|
||||
& flip (IS.foldl' (flip (`translateWallID` d))) (_drWallIDs dr)
|
||||
& moveUpdate
|
||||
& doors . ix drid . drPos . each %~ (+.+ d)
|
||||
Nothing -> w
|
||||
@@ -105,15 +102,14 @@ doorMechanism dr w = case mvDir of
|
||||
|
||||
-- TODO cut pathing if not pathable, reset when opened
|
||||
plSlideDoor
|
||||
:: Bool
|
||||
-> Color
|
||||
-> Door
|
||||
:: Door
|
||||
-> Wall
|
||||
-> Float
|
||||
-> Point2
|
||||
-> Point2
|
||||
-> World
|
||||
-> (Int, World)
|
||||
plSlideDoor isPathable col dr shiftOffset a b gw
|
||||
plSlideDoor dr wl shiftOffset a b gw
|
||||
= (drid, addDoorWalls gw & doors %~ addDoor)
|
||||
where
|
||||
drid = IM.newKey $ _doors gw
|
||||
@@ -126,7 +122,7 @@ plSlideDoor isPathable col dr shiftOffset a b gw
|
||||
, _drOpenPos = (shiftLeft a,shiftLeft b)
|
||||
, _drClosePos = (a,b)
|
||||
}
|
||||
addDoorWalls w' = foldl' (addDoorWall drid col isPathable) w' $ zip wlids pairs
|
||||
addDoorWalls w' = foldl' (addDoorWall 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 ..]
|
||||
|
||||
Reference in New Issue
Block a user