Add objects based on walls, called machines
This commit is contained in:
+12
-11
@@ -83,20 +83,23 @@ collideDirectionIndirect d p1 p2 wls
|
||||
= fromMaybe d
|
||||
$
|
||||
( L.fold
|
||||
. L.prefilter (not . _wlIsSeeThrough)
|
||||
. L.prefilter wlIsOpaque
|
||||
. L.premapMaybe (fmap (dist p1) . uncurry (intersectSegSeg p1 p3) . _wlLine)
|
||||
) L.minimum
|
||||
wls
|
||||
where
|
||||
p3 = p1 +.+ d *.* safeNormalizeV (p2 -.- p1)
|
||||
|
||||
wlIsOpaque :: Wall -> Bool
|
||||
wlIsOpaque wl = _wlOpacity wl == Opaque
|
||||
|
||||
collidePointUpToIndirect
|
||||
:: Point2 -- ^start point
|
||||
-> Point2 -- ^end point
|
||||
-> IM.IntMap Wall
|
||||
-> Point2
|
||||
{-# INLINE collidePointUpToIndirect #-}
|
||||
collidePointUpToIndirect p1 p2 = foldr f p2 . IM.filter (not . _wlIsSeeThrough)
|
||||
collidePointUpToIndirect p1 p2 = foldr f p2 . IM.filter wlIsOpaque
|
||||
where
|
||||
f wl x = fromMaybe x . uncurry (intersectSegSeg p1 x) $ _wlLine wl
|
||||
|
||||
@@ -107,7 +110,7 @@ collidePointUpToIndirectMinDist
|
||||
-> IM.IntMap Wall
|
||||
-> Point2
|
||||
{-# INLINE collidePointUpToIndirectMinDist #-}
|
||||
collidePointUpToIndirectMinDist p1 p2 md = ssfold prop f p2 . IM.filter (not . _wlIsSeeThrough)
|
||||
collidePointUpToIndirectMinDist p1 p2 md = ssfold prop f p2 . IM.filter wlIsOpaque
|
||||
where
|
||||
f x wl = fromMaybe x . uncurry (intersectSegSeg p1 x) $ _wlLine wl
|
||||
prop p3 = dist p1 p3 < md
|
||||
@@ -121,7 +124,7 @@ ssfold p f a0 xs = foldr (\x g a -> if p a then a else g (f a x)) id xs a0
|
||||
|
||||
collidePointIndirect :: Point2 -> Point2 -> IM.IntMap Wall -> Maybe Point2
|
||||
{-# INLINE collidePointIndirect #-}
|
||||
collidePointIndirect p1 p2 = test . foldr f p2 . IM.filter (not . _wlIsSeeThrough)
|
||||
collidePointIndirect p1 p2 = test . foldr f p2 . IM.filter wlIsOpaque
|
||||
where
|
||||
f wl p = fromMaybe p $ uncurry (intersectSegSeg p1 p) $ _wlLine wl
|
||||
test p | p == p2 = Nothing
|
||||
@@ -131,7 +134,7 @@ collidePointIndirect' :: Point2 -> Point2 -> IM.IntMap Wall -> Maybe Point2
|
||||
{-# INLINE collidePointIndirect' #-}
|
||||
collidePointIndirect' p1 p2
|
||||
= L.fold
|
||||
. L.prefilter (not . _wlIsSeeThrough)
|
||||
. L.prefilter wlIsOpaque
|
||||
. L.premapMaybe (uncurry (intersectSegSeg p1 p2) . _wlLine)
|
||||
$ L.minimumOn (dist p1)
|
||||
|
||||
@@ -141,17 +144,15 @@ collidePointFire :: Point2 -> Point2 -> IM.IntMap Wall -> Maybe Point2
|
||||
collidePointFire p1 p2 ws
|
||||
= safeMinimumOn (dist p1)
|
||||
. IM.mapMaybe ( uncurry (intersectSegSeg p1 p2) . _wlLine )
|
||||
$ IM.filter (\wl -> not (_wlIsSeeThrough wl && isJust (wl ^? wlBlockID))) ws
|
||||
$ IM.filter (\wl -> not (_wlFireThrough wl) || wlIsOpaque wl) ws
|
||||
{- | Checks to see whether someone can fire bullets effectively between two points.
|
||||
- Not sure if this needs vision as well, need to make this uniform. -}
|
||||
collidePointFireVision :: Point2 -> Point2 -> IM.IntMap Wall -> Bool
|
||||
collidePointFireVision p1 p2 ws
|
||||
= any ( isJust . uncurry (intersectSegSeg p1 p2) . _wlLine)
|
||||
$ IM.filter notBlockWindow ws
|
||||
$ IM.filter theTest ws
|
||||
where
|
||||
notBlockWindow wl = case wl ^? wlBlockID of
|
||||
Just _ -> not $ _wlIsSeeThrough wl
|
||||
Nothing -> True
|
||||
theTest wl = not (_wlFireThrough wl) || wlIsOpaque wl
|
||||
|
||||
-- the reason for using the dashed version is the hope that this will short
|
||||
-- circuit
|
||||
@@ -180,7 +181,7 @@ pathToPointFireable :: Int -> Point2 -> World -> Bool
|
||||
pathToPointFireable i p w
|
||||
= not
|
||||
. pointHitsWalls (_crPos $ _creatures w IM.! i) p
|
||||
$ IM.filter (isNothing . (^? wlBlockID) ) $ wallsAlongLine p1 p w
|
||||
$ IM.filter (not . _wlFireThrough ) $ wallsAlongLine p1 p w
|
||||
where
|
||||
p1 = _crPos (_creatures w IM.! i)
|
||||
|
||||
|
||||
+33
-9
@@ -57,6 +57,7 @@ data World = World
|
||||
, _particles :: ![Particle]
|
||||
, _walls :: !(IM.IntMap Wall)
|
||||
, _doors :: IM.IntMap Door
|
||||
, _machines :: IM.IntMap Machine
|
||||
, _blocks :: IM.IntMap Block
|
||||
, _wallsZone :: Zone (IM.IntMap Wall)
|
||||
, _floorItems :: IM.IntMap FloorItem
|
||||
@@ -549,6 +550,16 @@ data Block = Block
|
||||
, _blHPs :: [Int]
|
||||
, _blShadows :: [Int]
|
||||
}
|
||||
data Machine = Machine
|
||||
{ _mcID :: Int
|
||||
, _mcWallIDs :: [Int]
|
||||
, _mcUpdate :: Machine -> World -> World
|
||||
, _mcDraw :: Machine -> SPic
|
||||
, _mcPos :: Point2
|
||||
, _mcDir :: Float
|
||||
, _mcHP :: Int
|
||||
, _mcSensor :: Int
|
||||
}
|
||||
data Door = Door
|
||||
{ _drID :: Int
|
||||
, _drWallIDs :: [Int]
|
||||
@@ -559,16 +570,27 @@ data Door = Door
|
||||
data DoorStatus = DoorOpen | DoorClosed | DoorHalfway | DoorInt Int
|
||||
deriving (Eq, Ord, Show)
|
||||
data Wall = Wall
|
||||
{ _wlLine :: (Point2,Point2)
|
||||
, _wlID :: Int
|
||||
, _wlColor :: Color
|
||||
, _wlSeen :: Bool
|
||||
, _wlIsSeeThrough :: Bool
|
||||
, _wlPathable :: Bool
|
||||
, _wlDraw :: Bool
|
||||
, _wlRotateTo :: Bool
|
||||
, _wlBlockID :: Maybe' Int
|
||||
{ _wlLine :: (Point2,Point2)
|
||||
, _wlID :: Int
|
||||
, _wlColor :: Color
|
||||
, _wlSeen :: Bool
|
||||
, _wlOpacity :: Opacity
|
||||
, _wlPathable :: Bool
|
||||
, _wlFireThrough :: Bool
|
||||
, _wlDraw :: Bool
|
||||
, _wlRotateTo :: Bool
|
||||
, _wlStructure :: WallStructure
|
||||
}
|
||||
data Opacity
|
||||
= SeeThrough
|
||||
| SeeAbove
|
||||
| Opaque
|
||||
deriving (Eq,Ord,Show)
|
||||
data WallStructure
|
||||
= StandaloneWall
|
||||
| DoorPart { _wlStDoor :: Int }
|
||||
| MachinePart { _wlStMachine :: Int }
|
||||
| BlockPart { _wlStBlock :: Int }
|
||||
-- | Strict maybe
|
||||
data Maybe' a = Just' a | Nothing'
|
||||
|
||||
@@ -749,6 +771,7 @@ makeLenses ''PjParam
|
||||
makeLenses ''Prop
|
||||
makeLenses ''Particle
|
||||
makeLenses ''Wall
|
||||
makeLenses ''WallStructure
|
||||
makeLenses ''PressPlate
|
||||
makeLenses ''Button
|
||||
makeLenses ''ActionPlan
|
||||
@@ -759,5 +782,6 @@ makeLenses ''CrMvType
|
||||
makeLenses ''Intention
|
||||
makeLenses ''Door
|
||||
makeLenses ''Block
|
||||
makeLenses ''Machine
|
||||
makeLenses ''Zone
|
||||
makeLenses ''ItemDimension
|
||||
|
||||
@@ -14,6 +14,7 @@ import Control.Lens
|
||||
data DamageType
|
||||
= Piercing {_dmAmount :: Int , _dmFrom :: Point2 , _dmAt :: Point2 , _dmTo :: Point2 }
|
||||
| Blunt {_dmAmount :: Int , _dmFrom :: Point2 , _dmAt :: Point2 , _dmTo :: Point2 }
|
||||
| Cutting {_dmAmount :: Int , _dmFrom :: Point2 , _dmAt :: Point2 , _dmTo :: Point2 }
|
||||
| SparkDam {_dmAmount :: Int , _dmFrom :: Point2 , _dmAt :: Point2 , _dmTo :: Point2 }
|
||||
| Flaming {_dmAmount :: Int , _dmFrom :: Point2 , _dmAt :: Point2 , _dmTo :: Point2 }
|
||||
| Lasering {_dmAmount :: Int , _dmFrom :: Point2 , _dmAt :: Point2 , _dmTo :: Point2 }
|
||||
|
||||
@@ -43,7 +43,7 @@ lineOnScreenCone w p1 p2 = pointInPolygon p1 sp
|
||||
|
||||
drawWallFace :: World -> Wall -> Picture
|
||||
drawWallFace w wall
|
||||
| isRHS sightFrom x y || _wlIsSeeThrough wall = blank
|
||||
| isRHS sightFrom x y || _wlOpacity wall /= Opaque = blank
|
||||
| otherwise = setDepth (-1) . color (withAlpha 0 black) . polygon $ points
|
||||
where
|
||||
(x,y) = _wlLine wall
|
||||
@@ -56,13 +56,13 @@ extendConeToScreenEdge w c (x,y) = orderPolygon $ wallScreenIntersect ++ [x,y] +
|
||||
borderPs = mapMaybe (intersectLinefromScreen w c) [x,y]
|
||||
cornerPs = filter (pointIsInCone c (x,y)) $ screenPolygon w
|
||||
wallScreenIntersect = mapMaybe (uncurry $ intersectSegSeg y ((2*.*y) -.- x))
|
||||
. makeLoopPairs $ screenPolygon w
|
||||
. loopPairs $ screenPolygon w
|
||||
|
||||
-- the following assumes that the point a is inside the screen
|
||||
-- it still works otherwise, but it might intersect two points:
|
||||
-- it is not obvious which will be returned
|
||||
intersectLinefromScreen :: World -> Point2 -> Point2 -> Maybe Point2
|
||||
intersectLinefromScreen w a b = listToMaybe
|
||||
. mapMaybe (\(x,y) -> intersectSegLineFrom' x y b (b +.+ b -.- a))
|
||||
. makeLoopPairs
|
||||
. mapMaybe (\(x,y) -> intersectSegLineFrom x y b (b +.+ b -.- a))
|
||||
. loopPairs
|
||||
$ screenPolygon w
|
||||
|
||||
@@ -62,6 +62,7 @@ defaultCreature = Creature
|
||||
, _crGroup = LoneWolf
|
||||
, _crMvType = defaultAimMvType
|
||||
}
|
||||
|
||||
defaultCreatureMemory :: MemoryState
|
||||
defaultCreatureMemory = MemoryState
|
||||
{ _soundsToInvestigate = []
|
||||
@@ -208,6 +209,18 @@ defaultIt = Consumable
|
||||
, _itHammer = HammerUp
|
||||
, _itAimStance = LeaveHolstered
|
||||
}
|
||||
defaultMachine :: Machine
|
||||
defaultMachine = Machine
|
||||
{ _mcID = 0
|
||||
, _mcWallIDs = []
|
||||
, _mcUpdate = const id
|
||||
, _mcDraw = const mempty
|
||||
, _mcPos = V2 0 0
|
||||
, _mcDir = 0
|
||||
, _mcHP = 100
|
||||
, _mcSensor = 0
|
||||
}
|
||||
|
||||
defaultDrawButton :: Color -> Button -> SPic
|
||||
defaultDrawButton col bt =
|
||||
( translateSHz 15 . colorSH col $ upperPrismPoly 5 buttonGeometry
|
||||
|
||||
@@ -10,19 +10,23 @@ defaultWall = Wall
|
||||
, _wlID = 0
|
||||
, _wlColor = greyN 0.6
|
||||
, _wlSeen = False
|
||||
, _wlIsSeeThrough = False
|
||||
, _wlPathable = False
|
||||
, _wlOpacity = Opaque
|
||||
, _wlPathable = False
|
||||
, _wlFireThrough = False
|
||||
, _wlDraw = True
|
||||
, _wlRotateTo = True
|
||||
, _wlBlockID = Nothing'
|
||||
, _wlStructure = StandaloneWall
|
||||
}
|
||||
{- Indestructible see-through wall. -}
|
||||
defaultCrystalWall :: Wall
|
||||
defaultCrystalWall = defaultWall
|
||||
{ _wlLine = (V2 0 0,V2 50 0)
|
||||
, _wlID = 0
|
||||
, _wlColor = withAlpha 0.5 aquamarine
|
||||
, _wlSeen = False
|
||||
, _wlIsSeeThrough = True
|
||||
, _wlPathable = False
|
||||
{ _wlColor = withAlpha 0.5 aquamarine
|
||||
, _wlOpacity = SeeThrough
|
||||
}
|
||||
defaultMachineWall :: Wall
|
||||
defaultMachineWall = defaultWall
|
||||
{ _wlOpacity = SeeAbove
|
||||
, _wlDraw = False
|
||||
, _wlRotateTo = False
|
||||
, _wlStructure = MachinePart 0
|
||||
}
|
||||
|
||||
@@ -36,6 +36,7 @@ defaultWorld = World
|
||||
, _particles = []
|
||||
, _walls = IM.empty
|
||||
, _blocks = IM.empty
|
||||
, _machines = IM.empty
|
||||
, _doors = IM.empty
|
||||
, _wallsZone = Zone IM.empty
|
||||
, _floorItems = IM.empty
|
||||
|
||||
@@ -189,7 +189,7 @@ moveLaser phaseV pos dir w pt
|
||||
f :: [Wall] -> Point2 -> Point2 -> (Maybe (Point2,Either Creature Wall),[Point2])
|
||||
f seenWs x y = case find (h' seenWs) $ thingsHitExceptCrLongLine Nothing x y w of
|
||||
Just (p,Right wl)
|
||||
| _wlIsSeeThrough wl -> f' p $ f (wl:seenWs) p (h x y wl p)
|
||||
| _wlOpacity wl == SeeThrough -> f' p $ f (wl:seenWs) p (h x y wl p)
|
||||
| otherwise -> (Just (p,Right wl), [p])
|
||||
Just (p,obj) -> (Just (p,obj), [p])
|
||||
Nothing -> (Nothing, [y])
|
||||
|
||||
@@ -267,7 +267,7 @@ miniGun = defaultAutoGun
|
||||
, _itAimingRange = 1
|
||||
, _itEquipPict = pictureWeaponAim miniGunPictItem
|
||||
, _wpAmmo = basicBullet
|
||||
}
|
||||
} & itDimension . muzzleLength .~ 15
|
||||
where
|
||||
recoilAmount = 5
|
||||
[vm1,vm2,vm3,vm4] =
|
||||
|
||||
+37
-18
@@ -16,10 +16,12 @@ import Dodge.LevelGen.AutoDoor
|
||||
import Dodge.LevelGen.TriggerDoor
|
||||
import Dodge.LevelGen.Switch
|
||||
import Dodge.LevelGen.Data
|
||||
import Dodge.Default.Wall
|
||||
import Geometry
|
||||
import Geometry.Vector3D
|
||||
import Shape
|
||||
import qualified IntMapHelp as IM
|
||||
import Color
|
||||
|
||||
import Control.Monad.State
|
||||
import Control.Lens
|
||||
@@ -46,30 +48,30 @@ placeSpotID ps w = case _psType ps of
|
||||
PutButton bt -> placeBt bt p rot w
|
||||
PutFlIt itm -> placeFlIt itm p rot w
|
||||
PutCrit cr -> placeCr cr p rot w
|
||||
PutMachine col wallpoly mc -> placeMachine col (map doShift wallpoly) mc p rot w
|
||||
PutLS ls -> placeLS ls p' rot w
|
||||
PutPressPlate pp -> placePressPlate pp p rot w
|
||||
RandPS rgen -> placeSpotID (set psType evaluatedType ps) (set randGen g w)
|
||||
where
|
||||
(evaluatedType, g) = runState rgen (_randGen w)
|
||||
PutDoor col f pss -> putDoor col f (map (mapBoth $ shiftPointBy (p,rot)) pss) w
|
||||
PutDoor col f pss -> putDoor col f (map (mapBoth doShift) pss) w
|
||||
where
|
||||
mapBoth fn (x,y) = (fn x, fn y)
|
||||
PutSingleDoor col f a b speed
|
||||
-> putSingleDoor False col f (shiftPointBy (p,rot) a) (shiftPointBy (p,rot) b) speed w
|
||||
-> putSingleDoor False col f (doShift a) (doShift b) speed w
|
||||
PutDoubleDoor col f a b speed
|
||||
-> (,) 0 $ insertDoubleDoor False col f (shiftPointBy (p,rot) a) (shiftPointBy (p,rot) b) speed w
|
||||
PutAutoDoor a b -> (,) 0 $ addAutoDoor (shiftPointBy (p,rot) a) (shiftPointBy (p,rot) b) w
|
||||
PutBlock (hp:hps) col ps' -> putBlock (map (shiftPointBy (p,rot)) ps') hp col False hps w
|
||||
-> (,) 0 $ insertDoubleDoor False col f (doShift a) (doShift b) speed w
|
||||
PutAutoDoor a b -> (,) 0 $ addAutoDoor (doShift a) (doShift b) w
|
||||
PutBlock (hp:hps) col ps' -> placeBlock (map doShift ps') hp col Opaque hps w
|
||||
PutBlock{} -> error "messed up block placement somehow"
|
||||
PutBtDoor c bp f a b speed
|
||||
-> addButtonDoor c (shiftPointBy (p,rot) bp) (f + rot)
|
||||
(shiftPointBy (p,rot) a) (shiftPointBy (p,rot) b) speed w
|
||||
PutBtDoor c bp f a b speed -> addButtonDoor c (doShift bp) (f + rot)
|
||||
(doShift a) (doShift b) speed w
|
||||
PutLineBlock wl width depth a b
|
||||
-> putLineBlock wl width depth (shiftPointBy (p,rot) a) (shiftPointBy (p,rot) b) w
|
||||
PutWall { _pwPoly = ps', _pwWall = wl } -> (0,rmCrossPaths $ over walls (addWalls (q:qs) wl) w)
|
||||
-> putLineBlock wl width depth (doShift a) (doShift b) w
|
||||
PutWall { _pwPoly = ps', _pwWall = wl } -> (0,rmCrossPaths $ over walls (addWalls qs wl) w)
|
||||
where
|
||||
(q:qs) = map (shiftPointBy (p,rot)) ps'
|
||||
rmCrossPaths w' = foldr (uncurry removePathsCrossing) w' $ zip (q:qs) (qs++[q])
|
||||
qs = map doShift ps'
|
||||
rmCrossPaths w' = foldr (uncurry removePathsCrossing) w' $ loopPairs qs
|
||||
PutForeground sh -> (0,w & foregroundShape %~ ((uncurryV translateSHf p . rotateSH rot) sh <>))
|
||||
PutNothing -> (0,w)
|
||||
PutID i -> (i, w)
|
||||
@@ -78,6 +80,7 @@ placeSpotID ps w = case _psType ps of
|
||||
p@(V2 px py) = _psPos ps
|
||||
p' = V3 px py 0
|
||||
rot = _psRot ps
|
||||
doShift = shiftPointBy (p,rot)
|
||||
|
||||
-- TODO: remove this typeclass
|
||||
class Shiftable a where
|
||||
@@ -179,13 +182,29 @@ placeUpdateCr scr p rot w = (w & creatures %~ IM.insert cid cr, PutCrit cr)
|
||||
cr = scr {_crPos = p,_crOldPos = p,_crDir = rot,_crID = cid}
|
||||
|
||||
placeCr :: Creature -> Point2 -> Float -> World -> (Int,World)
|
||||
placeCr crF p rot w = (i, over creatures addCr w)
|
||||
placeCr crF p rot w = (cid, over creatures addCr w)
|
||||
where
|
||||
i = IM.newKey $ _creatures w
|
||||
addCr crs = IM.insert
|
||||
(IM.newKey crs)
|
||||
(crF {_crPos = p,_crOldPos = p,_crDir = rot,_crID = IM.newKey crs})
|
||||
crs
|
||||
cid = IM.newKey $ _creatures w
|
||||
addCr crs = IM.insert cid (crF {_crPos = p,_crOldPos = p,_crDir = rot,_crID = cid}) crs
|
||||
|
||||
placeMachine :: Color -> [Point2] -> Machine -> Point2 -> Float -> World -> (Int,World)
|
||||
placeMachine color wallpoly mc p rot w = (mcid
|
||||
, w & machines %~ addMc
|
||||
& walls %~ placeMachineWalls color wallpoly mcid wlid
|
||||
)
|
||||
where
|
||||
mcid = IM.newKey $ _machines w
|
||||
wlid = IM.newKey $ _walls w
|
||||
wlids = [wlid .. wlid + length wallpoly]
|
||||
addMc mcs = IM.insert mcid (mc {_mcPos = p,_mcDir = rot,_mcID = mcid, _mcWallIDs = wlids}) mcs
|
||||
-- TODO correctly remove/shift pathfinding lines (removePathsCrossing)
|
||||
placeMachineWalls :: Color -> [Point2] -> Int -> Int -> IM.IntMap Wall -> IM.IntMap Wall
|
||||
placeMachineWalls col poly mcid wlid = flip (foldr f) $ zip [wlid..] $ loopPairs poly
|
||||
where
|
||||
f (wid,l) = IM.insert wid baseWall{_wlID = wid, _wlLine = l}
|
||||
baseWall = defaultMachineWall
|
||||
& wlColor .~ col
|
||||
& wlStructure . wlStMachine .~ mcid
|
||||
|
||||
placeLS :: LightSource -> Point3 -> Float -> World -> (Int,World)
|
||||
placeLS ls (V3 x y z) rot w = (i, over lightSources addLS w)
|
||||
|
||||
+13
-13
@@ -1,6 +1,6 @@
|
||||
{- | Creation, update and destruction of destructible walls. -}
|
||||
module Dodge.LevelGen.Block
|
||||
( putBlock
|
||||
( placeBlock
|
||||
, putLineBlock
|
||||
)
|
||||
where
|
||||
@@ -20,13 +20,13 @@ addBlock
|
||||
:: [Point2] -- ^ Block polygon
|
||||
-> Int -- ^ First layer of health
|
||||
-> Color
|
||||
-> Bool -- ^ Is the block see through?
|
||||
-> Opacity -- ^ Is the block see through?
|
||||
-> [Int] -- ^ Extra layers of health
|
||||
-> World
|
||||
-> World
|
||||
addBlock (p:ps) hp col isSeeThrough hps w
|
||||
addBlock (p:ps) hp col opacity hps w
|
||||
| hp <= 0 && null hps = w
|
||||
| hp <= 0 = addBlock (p:ps) (head hps + hp) col isSeeThrough (tail hps) w
|
||||
| hp <= 0 = addBlock (p:ps) (head hps + hp) col opacity (tail hps) w
|
||||
| otherwise = w
|
||||
& wallsZone . znObjects %~ flip (IM.foldl' $ flip wallInZone) panes
|
||||
& walls %~ IM.union panes
|
||||
@@ -41,8 +41,9 @@ addBlock (p:ps) hp col isSeeThrough hps w
|
||||
{ _wlLine = (a,b)
|
||||
, _wlID = j
|
||||
, _wlColor = col
|
||||
, _wlIsSeeThrough = isSeeThrough
|
||||
, _wlBlockID = Just' blid
|
||||
, _wlOpacity = opacity
|
||||
, _wlStructure = BlockPart blid
|
||||
, _wlFireThrough = True
|
||||
}
|
||||
) is lns
|
||||
wallInZone wl
|
||||
@@ -55,12 +56,11 @@ addBlock (p:ps) hp col isSeeThrough hps w
|
||||
ips = map zoneOfPoint $ uncurry (divideLine (2*zoneSize)) (_wlLine wl)
|
||||
addBlock _ _ _ _ _ _ = error "Trying to add a block with incomplete polygon"
|
||||
|
||||
putBlock :: [Point2] -> Int -> Color -> Bool -> [Int] -> World -> (Int,World)
|
||||
putBlock (p:ps) i c b is w = (0, foldr (uncurry removePathsCrossing) wWithBlock pairs)
|
||||
placeBlock :: [Point2] -> Int -> Color -> Opacity -> [Int] -> World -> (Int,World)
|
||||
placeBlock poly i c opac is w = (0, foldr (uncurry removePathsCrossing) wWithBlock pairs)
|
||||
where
|
||||
pairs = zip (p:ps) (ps ++ [p])
|
||||
wWithBlock = addBlock (p:ps) i c b is w
|
||||
putBlock _ _ _ _ _ _ = error "Trying to put a block with incomplete polygon"
|
||||
pairs = loopPairs poly
|
||||
wWithBlock = addBlock poly i c opac is w
|
||||
|
||||
{- | Splits a line into many four cornered blocks. -}
|
||||
putLineBlock
|
||||
@@ -83,7 +83,7 @@ putLineBlock basePane blockWidth depth a b w = (,) 0
|
||||
is = [0.. numBlocks - 1]
|
||||
cornerPoints = reverse $ rectWH halfBlockWidth depth -- goes clockwise around the block
|
||||
cornersAt p = fmap ( (p +.+) . rotateV rot) cornerPoints
|
||||
linesAt p = makeLoopPairs $ cornersAt p
|
||||
linesAt p = loopPairs $ cornersAt p
|
||||
k = IM.newKey $ _walls w
|
||||
blid = IM.newKey $ _blocks w
|
||||
insertBlock i = over blocks $ IM.insert (i+blid) Block
|
||||
@@ -101,7 +101,7 @@ putLineBlock basePane blockWidth depth a b w = (,) 0
|
||||
makeWallAt p i = zipWith3 (makePane i) (visibilityAt i) (ksAtI i) (linesAt p)
|
||||
makePane i visStatus k' ps = basePane
|
||||
{_wlID = k'
|
||||
,_wlBlockID = Just' $ i + blid
|
||||
,_wlStructure = BlockPart $ i + blid
|
||||
,_wlLine = ps
|
||||
,_wlDraw = visStatus
|
||||
}
|
||||
|
||||
@@ -11,6 +11,7 @@ import Control.Lens
|
||||
import Control.Monad.State
|
||||
import System.Random
|
||||
data PSType = PutCrit {_unPutCrit :: Creature}
|
||||
| PutMachine Color [Point2] Machine
|
||||
| PutLS LightSource
|
||||
| PutButton Button
|
||||
| PutProp Prop
|
||||
|
||||
@@ -72,7 +72,7 @@ putDoor col cond pss w = (drid, addWalls w & doors %~ addDoor)
|
||||
, _wlID = wlid
|
||||
, _wlColor = col
|
||||
, _wlSeen = False
|
||||
, _wlIsSeeThrough = False
|
||||
, _wlOpacity = Opaque
|
||||
, _wlPathable = False
|
||||
}
|
||||
-- TODO use vector instead of list, perhaps also memoisation of rectanglePairs
|
||||
@@ -146,9 +146,9 @@ putSingleDoor isPathable col cond a b speed w = (drid, addWalls w
|
||||
{ _wlLine = wlps
|
||||
, _wlID = wlid
|
||||
, _wlColor = col
|
||||
, _wlSeen = False
|
||||
, _wlIsSeeThrough = False
|
||||
, _wlPathable = isPathable
|
||||
, _wlSeen = False
|
||||
, _wlOpacity = Opaque
|
||||
, _wlPathable = isPathable
|
||||
}
|
||||
pairs = rectanglePairs 9 a b
|
||||
shiftedPairs = map (bimap shiftLeft shiftLeft) pairs
|
||||
|
||||
@@ -0,0 +1,21 @@
|
||||
module Dodge.Machine.Sensor
|
||||
( lightSensor
|
||||
) where
|
||||
import Color
|
||||
import Dodge.Data
|
||||
import Dodge.LevelGen.Data
|
||||
import Dodge.Default
|
||||
import Geometry
|
||||
import ShapePicture
|
||||
import Shape
|
||||
|
||||
lightSensor :: PSType
|
||||
lightSensor = PutMachine blue (reverse $ square wdth) defaultMachine
|
||||
{ _mcDraw = const lightSensorSPic }
|
||||
|
||||
lightSensorSPic :: SPic
|
||||
lightSensorSPic = ( colorSH blue $ upperPrismPoly 25 (square wdth)
|
||||
, mempty )
|
||||
|
||||
wdth :: Float
|
||||
wdth = 5
|
||||
@@ -138,9 +138,8 @@ lineOnScreen w p1 p2 = pointInPolygon p1 sp
|
||||
sp = screenPolygon w
|
||||
sps = zip sp (tail sp ++ [head sp])
|
||||
|
||||
|
||||
drawWallFloor :: Wall -> Picture
|
||||
drawWallFloor wl = if _wlIsSeeThrough wl
|
||||
drawWallFloor wl = if _wlOpacity wl == SeeThrough
|
||||
then setDepth 0.9 . color c $ polygon [x,x +.+ n2,y+.+n2, y]
|
||||
else blank
|
||||
where
|
||||
@@ -159,7 +158,8 @@ wallsAndWindows w
|
||||
= (map f wls, map f wins)
|
||||
where
|
||||
f wl = (_wlLine wl, _wlColor wl)
|
||||
(wins,wls) = partition _wlIsSeeThrough . IM.elems . IM.filter _wlDraw $ wallsDoubleScreen w
|
||||
(wins,wls) = partition theTest . IM.elems . IM.filter _wlDraw $ wallsDoubleScreen w
|
||||
theTest wl = _wlOpacity wl /= Opaque
|
||||
|
||||
lightsForGloom :: World -> [(Point3,Float,Point3)]
|
||||
lightsForGloom w = mapMaybe getLS (IM.elems $ _lightSources w) ++ mapMaybe getTLS (_tempLightSources w)
|
||||
|
||||
@@ -17,11 +17,15 @@ worldShape w = _foregroundShape w
|
||||
<> foldMap (_spShape . floorItemSPic) (IM.filter (pointIsClose . _flItPos) $ _floorItems w)
|
||||
<> foldMap (_spShape . dbArg _prDraw) (IM.filter (pointIsClose . _pjPos) $ _props w)
|
||||
<> foldMap btShape (IM.filter (pointIsClose . _btPos) $ _buttons w)
|
||||
<> foldMap mcShape (IM.filter (pointIsClose . _mcPos) $ _machines w)
|
||||
where
|
||||
pointIsClose p = dist camCen p < winSize
|
||||
winSize = 30 + max (getWindowX w) (getWindowY w)
|
||||
camCen = _cameraCenter w
|
||||
|
||||
mcShape :: Machine -> Shape
|
||||
mcShape mc = uncurryV translateSHf (_mcPos mc) $ rotateSH (_mcDir mc) $ _spShape $ _mcDraw mc mc
|
||||
|
||||
btShape :: Button -> Shape
|
||||
btShape bt = uncurryV translateSHf (_btPos bt) $ rotateSH (_btRot bt) (_spShape $ _btPict bt bt)
|
||||
|
||||
|
||||
@@ -96,8 +96,9 @@ baseBlockPane = defaultWall
|
||||
, _wlID = 0
|
||||
, _wlColor = greyN 0.5
|
||||
, _wlSeen = False
|
||||
, _wlIsSeeThrough = False
|
||||
, _wlOpacity = Opaque
|
||||
, _wlDraw = True
|
||||
, _wlFireThrough = True
|
||||
}
|
||||
baseWindowPane :: Wall
|
||||
baseWindowPane = defaultWall
|
||||
@@ -105,8 +106,9 @@ baseWindowPane = defaultWall
|
||||
, _wlID = 0
|
||||
, _wlColor = withAlpha 0.2 cyan
|
||||
, _wlSeen = False
|
||||
, _wlIsSeeThrough = True
|
||||
, _wlOpacity = SeeThrough
|
||||
, _wlDraw = True
|
||||
, _wlFireThrough = True
|
||||
}
|
||||
{- Replaces instances of a given 'PutID' with 'PSType's drawn from a list. -}
|
||||
replacePutID
|
||||
|
||||
@@ -9,6 +9,7 @@ import Dodge.Room.Furniture
|
||||
import Dodge.Layout.Tree.Polymorphic
|
||||
import Dodge.LevelGen.Data
|
||||
import Dodge.LightSources.Fitting
|
||||
import Dodge.Machine.Sensor
|
||||
import Geometry.Data
|
||||
import Color
|
||||
import Shape
|
||||
@@ -36,6 +37,7 @@ startRoom = do
|
||||
, tankSquareEmboss4 (dim orange) 50 (h-60)
|
||||
, tankSquare (dim orange) 50 50
|
||||
, tankSquare (dim orange) 50 120
|
||||
, sPS (V2 (0.8*w) (0.25*h)) 0 lightSensor
|
||||
, sps0 $ PutForeground $ colorSH orange $ pipePP 2 (V3 50 50 25) (V3 50 120 25)
|
||||
]
|
||||
)
|
||||
|
||||
+4
-3
@@ -90,8 +90,8 @@ splinterBlock bl w = foldr unshadowBlock w (_blShadows bl) -- foldr shiftTowardC
|
||||
ps = map (fst . _wlLine) wls
|
||||
cen = centroid ps
|
||||
theSoundEffect
|
||||
| _wlIsSeeThrough (head wls) = mkSoundSplinterGlass
|
||||
| otherwise = mkSoundSplinterBlock
|
||||
| _wlOpacity (head wls) == SeeThrough = mkSoundSplinterGlass
|
||||
| otherwise = mkSoundSplinterBlock
|
||||
|
||||
unshadowBlock :: Int -> World -> World
|
||||
unshadowBlock wlid w = case w ^? walls . ix wlid of
|
||||
@@ -298,7 +298,7 @@ rotateToOverlappingWall w = case theWall of
|
||||
{- Finds the visible walls from a point to another point. -}
|
||||
visibleWalls :: Point2 -> Point2 -> IM.IntMap Wall -> [Wall]
|
||||
visibleWalls p1 p2 ws
|
||||
= takeUntil _wlIsSeeThrough
|
||||
= takeUntil theTest
|
||||
. map snd
|
||||
. sortOn (dist p1 . fromJust . fst)
|
||||
. filter (isJust . fst)
|
||||
@@ -306,3 +306,4 @@ visibleWalls p1 p2 ws
|
||||
$ IM.elems ws
|
||||
where
|
||||
f wl = (uncurry intersectSegSeg (_wlLine wl) p1 p2, wl)
|
||||
theTest wl = _wlOpacity wl /= Opaque
|
||||
|
||||
@@ -6,9 +6,9 @@ import Dodge.Data
|
||||
import Control.Lens
|
||||
|
||||
damageBlocksBy :: Int -> Wall -> World -> World
|
||||
damageBlocksBy x wl = case _wlBlockID wl of
|
||||
Just' blid -> blocks . ix blid . blHPs %~ reduceHeadBy x
|
||||
Nothing' -> id
|
||||
damageBlocksBy x wl = case wl ^? wlStructure . wlStBlock of
|
||||
Just blid -> blocks . ix blid . blHPs %~ reduceHeadBy x
|
||||
Nothing -> id
|
||||
where
|
||||
reduceHeadBy y (z:zs) = z - y : zs
|
||||
reduceHeadBy _ [] = []
|
||||
|
||||
@@ -10,7 +10,6 @@ import Dodge.Creature.State.Data
|
||||
import Geometry
|
||||
|
||||
import Data.Bifunctor
|
||||
import Data.Maybe
|
||||
import Control.Lens
|
||||
|
||||
type HitCreatureEffect = Particle -> Point2 -> Creature -> World -> World
|
||||
@@ -67,7 +66,7 @@ penWalls
|
||||
penWalls crEff wlEff pt hitThings w = case hitThings of
|
||||
[] -> ( w, mvPt pt)
|
||||
((p,Left cr):_) -> (crEff pt p cr w, destroyAt p pt)
|
||||
((p,Right wl):hs) | isJust (wl ^? wlBlockID)
|
||||
((p,Right wl):hs) | _wlFireThrough wl
|
||||
-> first (wlEff pt p wl) $ penWalls crEff wlEff pt hs w
|
||||
((p,Right wl):_) -> (wlEff pt p wl w, destroyAt p pt)
|
||||
|
||||
|
||||
+4
-4
@@ -449,10 +449,10 @@ arcStepwisePositive ssize a cen v = (cen +.+) . (`rotateV` v) <$> rots
|
||||
|
||||
-- | Given a list of points, returns pairs of points linking the points into a
|
||||
-- loop.
|
||||
makeLoopPairs :: [Point2] -> [(Point2,Point2)]
|
||||
makeLoopPairs [] = error "tried to make loop with empty list of points"
|
||||
makeLoopPairs [_] = error "tried to make loop with singleton list of points"
|
||||
makeLoopPairs (x:xs) = zip (x:xs) (xs ++ [x])
|
||||
loopPairs :: [Point2] -> [(Point2,Point2)]
|
||||
loopPairs [] = error "tried to make loop with empty list of points"
|
||||
loopPairs [_] = error "tried to make loop with singleton list of points"
|
||||
loopPairs (x:xs) = zip (x:xs) (xs ++ [x])
|
||||
-- | Test whether a point is in a cone.
|
||||
-- Note the pair is ordered.
|
||||
-- Doesn't work for obtuse angles.
|
||||
|
||||
@@ -34,9 +34,9 @@ intersectSegSeg (V2 x1 y1) (V2 x2 y2) (V2 x3 y3) (V2 x4 y4)
|
||||
u' = (y1-y2)*(x1-x3) - (x1-x2)*(y1-y3)
|
||||
-- | Intended to intersect a segment with a half-line-segment, ie a segment
|
||||
-- extending infinitely in one direction.
|
||||
intersectSegLineFrom' :: Point2 -> Point2 -> Point2 -> Point2 -> Maybe Point2
|
||||
{-# INLINE intersectSegLineFrom' #-}
|
||||
intersectSegLineFrom' (V2 x1 y1) (V2 x2 y2) (V2 x3 y3) (V2 x4 y4)
|
||||
intersectSegLineFrom :: Point2 -> Point2 -> Point2 -> Point2 -> Maybe Point2
|
||||
{-# INLINE intersectSegLineFrom #-}
|
||||
intersectSegLineFrom (V2 x1 y1) (V2 x2 y2) (V2 x3 y3) (V2 x4 y4)
|
||||
| den == 0 = Nothing
|
||||
| den > 0 && ( t' < 0 || u' < 0 || t' > den )
|
||||
= Nothing
|
||||
|
||||
Reference in New Issue
Block a user