Cleanup: broken pathfinding
This commit is contained in:
@@ -0,0 +1,68 @@
|
||||
module Dodge.Placement.Instance.Button where
|
||||
import Dodge.Data
|
||||
import Color
|
||||
import Geometry
|
||||
import Geometry.Vector3D
|
||||
import Dodge.LevelGen.Data
|
||||
import Dodge.Default
|
||||
import Dodge.LevelGen.Switch
|
||||
import Dodge.Placement.Instance.LightSource
|
||||
import Dodge.PlacementSpot
|
||||
import ShapePicture
|
||||
|
||||
import Data.Maybe
|
||||
import Control.Lens
|
||||
|
||||
triggerSwitchSPic :: (Button -> SPic) -> PlacementSpot -> Placement
|
||||
triggerSwitchSPic sdraw ps = plCont ps (PutTrigger (const False))
|
||||
$ \tp -> Just $ pContID ps (PutButton (makeSwitchSPic sdraw (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
|
||||
|
||||
triggerSwitchSPicLight :: (Button -> SPic) -> PlacementSpot -> Placement
|
||||
triggerSwitchSPicLight sdraw ps = plCont ps (PutTrigger (const False))
|
||||
$ \tp -> Just $ pContID fstLnkOut (PutLS thels)
|
||||
$ \lsid -> Just
|
||||
$ pContID ps (PutButton (makeSwitchSPic sdraw (oneff lsid $ trigid tp) (offeff lsid $ trigid tp)))
|
||||
(const Nothing)
|
||||
where
|
||||
thels = defaultLS {_lsIntensity = V3 0.5 0 0, _lsPos = V3 0 0 78, _lsRad = 75}
|
||||
trigid tp = fromJust $ _plMID tp
|
||||
eff lsid tid b c = (triggers . ix tid .~ const b)
|
||||
. (lightSources . ix lsid . lsIntensity .~ c)
|
||||
oneff lsid tid = eff lsid tid True (V3 0 0.5 0)
|
||||
offeff lsid tid = eff lsid tid False (V3 0.5 0 0)
|
||||
|
||||
triggerSwitch :: Color -> PlacementSpot -> Placement
|
||||
triggerSwitch 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
|
||||
p' = p -.- 30 *.* vNormal (unitVectorAtAngle a)
|
||||
p'' = p +.+ 10 *.* vNormal (unitVectorAtAngle a)
|
||||
changeLight lsid = lightSources . ix lsid . lsIntensity .~ V3 0 0.5 0
|
||||
ls = defaultLS { _lsRad = 75 , _lsIntensity = V3 0.5 0 0 }
|
||||
|
||||
putLitButOnPos :: Color -> (RoomPos -> Maybe PlacementSpot) -> (Int -> Maybe Placement) -> Placement
|
||||
putLitButOnPos col f subpl
|
||||
= plSpot .~ 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 (const id) Nothing
|
||||
@@ -0,0 +1,8 @@
|
||||
module Dodge.Placement.Instance.Creature where
|
||||
import Dodge.LevelGen.Data
|
||||
import Dodge.RandomHelp
|
||||
import Dodge.Creature.ArmourChase
|
||||
import Dodge.Creature.ChaseCrit
|
||||
|
||||
randC1 :: PSType
|
||||
randC1 = RandPS $ takeOne $ map PutCrit $ armourChaseCrit : replicate 50 chaseCrit
|
||||
@@ -0,0 +1,40 @@
|
||||
module Dodge.Placement.Instance.Door where
|
||||
import Dodge.Data
|
||||
import Dodge.Base
|
||||
import Color
|
||||
import Geometry
|
||||
import Geometry.Vector3D
|
||||
import Dodge.LevelGen.Data
|
||||
import Dodge.Creature.Property
|
||||
import Dodge.LevelGen.Switch
|
||||
|
||||
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 a b speed Nothing
|
||||
|
||||
putDoubleDoorThen :: Bool -> Color -> (World -> Bool)
|
||||
-> Point2 -> Point2 -> Float -> Maybe Placement -> Placement
|
||||
putDoubleDoorThen pathing col cond a b speed mayp = ps0j (PutSlideDoor pathing col cond a half speed)
|
||||
$ Placement (PS (V2 0 0) 0) ( PutSlideDoor pathing col cond b half speed) Nothing $ const mayp
|
||||
where
|
||||
half = 0.5 *.* (a +.+ b)
|
||||
|
||||
|
||||
|
||||
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
|
||||
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)))
|
||||
. IM.filter isAnimate . _creatures
|
||||
|
||||
switchDoor :: Point2 -> Float -> Point2 -> Point2 -> Color -> Placement
|
||||
switchDoor btpos btrot dra drb col = pContID (PS btpos btrot) (PutButton $ makeSwitch col red id id)
|
||||
$ \btid -> jsps0J (PutSlideDoor False col (cond btid) dra drc 2)
|
||||
$ sps0 (PutSlideDoor False col (cond btid) drb drc 2)
|
||||
where
|
||||
drc = 0.5 *.* (dra +.+ drb)
|
||||
cond btid w' = _btState (_buttons w' IM.! btid) == BtOn
|
||||
@@ -0,0 +1,120 @@
|
||||
module Dodge.Placement.Instance.LightSource where
|
||||
import Dodge.Data
|
||||
import Dodge.LightSources.Lamp
|
||||
import Dodge.LevelGen.Data
|
||||
import Dodge.Room.Foreground
|
||||
import Geometry
|
||||
import Geometry.Vector3D
|
||||
import Dodge.Creature.Inanimate
|
||||
import Shape.Data
|
||||
import Dodge.Default
|
||||
import Dodge.RandomHelp
|
||||
import Color
|
||||
import Shape
|
||||
|
||||
import Control.Lens
|
||||
|
||||
-- | mount a light source on a shape
|
||||
mntLSOn
|
||||
:: (Point2 -> Point3 -> Shape) -- ^ function describing the mount shape
|
||||
-> Maybe Color -- ^ describing a possible color override for the shape
|
||||
-> LightSource -> Point2 -> Point3 -> (Placement -> Maybe Placement) -> Placement
|
||||
mntLSOn shapeF mcol ls wallp lsp@(V3 lx ly _)
|
||||
= ps0jPushPS (PutForeground . setCol $ shapeF wallp lsp)
|
||||
. pt0 (PutLS $ ls {_lsPos = lsp'})
|
||||
where
|
||||
lsp' = lsp -.-.- V3 x y 1
|
||||
-- hack! perturb the light position
|
||||
V2 x y = rotateV 1 . (0.1 *.*) . normalizeV $ wallp -.- V2 lx ly
|
||||
setCol = maybe id colorSH mcol
|
||||
|
||||
|
||||
iShape :: Point2 -> Point3 -> Shape
|
||||
iShape wp (V3 x y z) = thinHighBar z wp (V2 x y)
|
||||
|
||||
lShape :: Point2 -> Point3 -> Shape
|
||||
lShape wp (V3 x y z) = thinHighBar z wallposUp turnpos
|
||||
<> thinHighBar z turnpos (V2 x y)
|
||||
where
|
||||
n = vNormal (wp -.- V2 x y)
|
||||
wallposUp = wp +.+ n
|
||||
turnpos = V2 x y +.+ n
|
||||
|
||||
jShape :: Point2 -> Point3 -> Shape
|
||||
jShape wallpos (V3 x y z) = thinHighBar z wallposUp turn1
|
||||
<> thinHighBar z turn1 turn2
|
||||
<> thinHighBar z turn2 endpos
|
||||
where
|
||||
n = vNormal (wallpos -.- V2 x y)
|
||||
wallposUp = wallpos +.+ n
|
||||
turnpos = V2 x y +.+ n
|
||||
endpos = V2 x y
|
||||
turn1 = 0.5 *.* (wallposUp +.+ turnpos)
|
||||
turn2 = 0.5 *.* (turnpos +.+ endpos)
|
||||
|
||||
liShape :: Point2 -> Point3 -> Shape
|
||||
liShape wallpos (V3 x y z) =
|
||||
thinHighBar z wallposUp turnpos
|
||||
<> thinHighBar z turnpos (V2 x y)
|
||||
where
|
||||
n = vNormal (V2 x y -.- wallpos)
|
||||
wallposUp = wallpos +.+ n
|
||||
turnpos = V2 x y +.+ n
|
||||
|
||||
aShape :: Point2 -> Point3 -> Shape
|
||||
aShape wallpos (V3 x y z) =
|
||||
girder (z+2) 20 10 pout wallpos
|
||||
where
|
||||
pout = V2 x y -.- 2 *.* safeNormalizeV (V2 x y -.- wallpos)
|
||||
|
||||
vShape :: Point2 -> Point3 -> Shape
|
||||
vShape wallpos (V3 x y z) =
|
||||
thinHighBar z wallposUp lxy
|
||||
<> thinHighBar z wallposDown lxy
|
||||
where
|
||||
lxy = V2 x y
|
||||
n = vNormal (wallpos -.- lxy)
|
||||
wallposUp = wallpos +.+ n
|
||||
wallposDown = wallpos -.- n
|
||||
|
||||
mntLS :: (Point2 -> Point3 -> Shape) -> Point2 -> Point3 -> Placement
|
||||
mntLS shp wallp lampp = mntLSOn shp Nothing defaultLS wallp lampp (const Nothing)
|
||||
|
||||
mntLSCond :: (Point2 -> Point3 -> Shape) -> (RoomPos -> Maybe PlacementSpot) -> Placement
|
||||
mntLSCond shp shift = -- updatePSToLevel 1 (const $ PSLnk shift (const id) Nothing) $
|
||||
mntLS shp 0 (V3 0 (-40) 90)
|
||||
& plSpot .~ PSLnk shift (const id) Nothing
|
||||
-- note that this perhaps pushes the vshape light out too far
|
||||
|
||||
mntLight :: Point2 -> Point2 -> Placement
|
||||
mntLight a b = RandomPlacement $ do
|
||||
shp <- takeOne [vShape,iShape,lShape,jShape,liShape]
|
||||
return $ mntLS shp a (addZ 90 b)
|
||||
|
||||
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
|
||||
where
|
||||
V2 x y = 0.5 *.* (a +.+ b)
|
||||
|
||||
spanLightI :: Point2 -> Point2 -> Placement
|
||||
spanLightI = spanColLightI 0.75 50
|
||||
|
||||
extendAway :: Point2 -> Point2 -> Point2
|
||||
extendAway p x = p +.+ safeNormalizeV (p -.- x)
|
||||
|
||||
putColorLamp :: Point3 -> PSType
|
||||
putColorLamp col = PutCrit (colorLamp col 90)
|
||||
|
||||
putLamp :: PSType
|
||||
putLamp = PutCrit (lamp 90)
|
||||
@@ -0,0 +1,54 @@
|
||||
module Dodge.Placement.Instance.Sensor
|
||||
( lightSensor
|
||||
) where
|
||||
import Color
|
||||
import Dodge.Data
|
||||
import Dodge.LevelGen.Data
|
||||
import Dodge.Default
|
||||
import Geometry
|
||||
import ShapePicture
|
||||
import Shape
|
||||
|
||||
import Control.Lens
|
||||
import Data.Either
|
||||
|
||||
damageSensor
|
||||
:: (DamageType -> Either Int Int) -- Left gets sensed, Right does damage
|
||||
-> Point2 -> Float -> Placement
|
||||
damageSensor damF p r = pContID (PS p r) ( PutLS theLS)
|
||||
$ \lsid -> jsps p r $ PutMachine yellow (reverse $ square wdth) defaultMachine
|
||||
{ _mcDraw = sensorSPic
|
||||
, _mcUpdate = sensorUpdate damF
|
||||
, _mcLSs = [lsid]
|
||||
}
|
||||
where
|
||||
theLS = defaultLS { _lsPos = V3 0 0 30 , _lsIntensity = 0.1 }
|
||||
|
||||
lightSensor :: Point2 -> Float -> Placement
|
||||
lightSensor = damageSensor senseLasering
|
||||
|
||||
senseLasering :: DamageType -> Either Int Int
|
||||
senseLasering Lasering {_dmAmount = x} = Left x
|
||||
senseLasering _ = Right 0
|
||||
|
||||
sensorUpdate :: (DamageType -> Either Int Int) -> Machine -> World -> World
|
||||
sensorUpdate damF mc w = w & machines . ix mcid %~ upmc
|
||||
& lightSources . ix lsid %~ upls
|
||||
where
|
||||
upmc = ( mcSensor %~ \x' -> min 750 (max 0 (x' - 5 + newSense)) )
|
||||
. ( mcHP -~ sum dam )
|
||||
. (mcDamage .~ [])
|
||||
x = _mcSensor mc
|
||||
mcid = _mcID mc
|
||||
lsid = head (_mcLSs mc)
|
||||
(senseData,dam) = partitionEithers $ map damF $ _mcDamage mc
|
||||
newSense = sum senseData
|
||||
ni = fromIntegral x / 500
|
||||
upls = lsIntensity .~ V3 ni ni ni
|
||||
|
||||
sensorSPic :: Machine -> SPic
|
||||
sensorSPic _ = ( colorSH yellow $ upperPrismPoly 25 (square wdth)
|
||||
, mempty )
|
||||
|
||||
wdth :: Float
|
||||
wdth = 10
|
||||
@@ -0,0 +1,91 @@
|
||||
module Dodge.Placement.Instance.Turret where
|
||||
import Color
|
||||
import Dodge.Data
|
||||
import Dodge.LevelGen.Data
|
||||
import Dodge.Default
|
||||
import Dodge.Wall.Delete
|
||||
import Dodge.WorldEvent.Explosion
|
||||
import Dodge.Item.Weapon.BatteryGuns
|
||||
import Dodge.SoundLogic.LoadSound
|
||||
import Dodge.SoundLogic
|
||||
import Dodge.Data.SoundOrigin
|
||||
import Geometry
|
||||
import ShapePicture
|
||||
import Shape
|
||||
import Dodge.Base
|
||||
import Dodge.Base.Collide
|
||||
|
||||
import Data.List
|
||||
import Control.Lens
|
||||
import qualified Data.IntMap.Strict as IM
|
||||
|
||||
putLasTurret :: Placement
|
||||
putLasTurret = sps0 $ PutMachine blue (reverse $ square wdth) defaultMachine
|
||||
{ _mcDraw = drawTurret
|
||||
, _mcUpdate = updateTurret
|
||||
, _mcType = lasTurret
|
||||
, _mcHP = 50000
|
||||
}
|
||||
lasTurret :: MachineType
|
||||
lasTurret = Turret
|
||||
{ _tuWeapon = lasGun
|
||||
, _tuTurnSpeed = 0.1
|
||||
, _tuFireTime = 0
|
||||
}
|
||||
|
||||
updateTurret :: Machine -> World -> World
|
||||
updateTurret mc w
|
||||
| _mcHP mc < 1 = w & machines %~ IM.delete mcid
|
||||
& deleteWallIDs (_mcWallIDs mc)
|
||||
& makeExplosionAt mcpos
|
||||
| otherwise = w & doDamage & maybeFire & elecDamBranch
|
||||
where
|
||||
doDamage = machines . ix mcid %~
|
||||
( (mcDamage .~ [Electrical (min 2500 $ max 0 (elecDam - 10)) 0 0 0])
|
||||
. (mcHP -~ dam)
|
||||
)
|
||||
elecDamBranch
|
||||
| elecDam < 10 = updateFiringStatus . doTurn
|
||||
| otherwise = id
|
||||
maybeFire
|
||||
| _tuFireTime (_mcType mc) > 0
|
||||
= ( particles %~ (makeLaserAt 5 (mcpos + 15 *.* unitVectorAtAngle mcdir) mcdir :) )
|
||||
. soundContinue (MachineSound mcid) mcpos tone440sawtoothS (Just 1)
|
||||
| otherwise = id
|
||||
mcid = _mcID mc
|
||||
ypos = _crPos $ you w
|
||||
mcpos = _mcPos mc
|
||||
mcdir = _mcDir mc
|
||||
seesYou = hasLOSIndirect mcpos ypos w
|
||||
(elecDams, dams) = partition isElectrical $ _mcDamage mc
|
||||
dam = sum $ map _dmAmount dams
|
||||
elecDam = sum $ map _dmAmount elecDams
|
||||
doTurn
|
||||
| seesYou = machines . ix mcid . mcDir %~ turnTo 0.005 mcpos ypos
|
||||
| otherwise = id
|
||||
closeFireAngle = seesYou && angleVV (ypos -.- mcpos) (unitVectorAtAngle mcdir) < 1
|
||||
updateFiringStatus
|
||||
| closeFireAngle = machines . ix mcid . mcType . tuFireTime .~ 20
|
||||
| otherwise = machines . ix mcid . mcType . tuFireTime %~ (max 0 . subtract 1)
|
||||
|
||||
turnTo :: Float -> Point2 -> Point2 -> Float -> Float
|
||||
turnTo turnSpeed sp tp a
|
||||
| vToTarg == V2 0 0 = a
|
||||
| angleVV vToTarg vdir <= turnSpeed
|
||||
= argV vToTarg
|
||||
| isLHS (sp +.+ vdir) sp tp = a - turnSpeed
|
||||
| otherwise = a + turnSpeed
|
||||
where
|
||||
vdir = unitVectorAtAngle a
|
||||
vToTarg = tp -.- sp
|
||||
|
||||
drawTurret :: Machine -> SPic
|
||||
drawTurret mc = (rotateSH (-_mcDir mc) . colorSH blue $ upperPrismPoly 20 (square wdth)
|
||||
, mempty -- setLayer 5 $ scale 0.5 0.5 $ text $ show $ _mcDir mc )
|
||||
)
|
||||
<> translateSPz 20 (_itFloorPict it it)
|
||||
where
|
||||
it = _tuWeapon $ _mcType mc
|
||||
|
||||
wdth :: Float
|
||||
wdth = 10
|
||||
@@ -0,0 +1,131 @@
|
||||
module Dodge.Placement.Instance.Wall
|
||||
where
|
||||
import Dodge.Data
|
||||
import Color
|
||||
import Geometry
|
||||
import Dodge.LevelGen.Data
|
||||
import Dodge.Default.Wall
|
||||
|
||||
import Data.List
|
||||
import Control.Lens
|
||||
singleBlock :: Point2 -> [Placement]
|
||||
singleBlock a =
|
||||
[sPS a 0
|
||||
$ PutBlock [5,20,20] (greyN 0.5)
|
||||
$ reverse
|
||||
$ rectNSWE 10 (-10) (-10) 10
|
||||
]
|
||||
{-
|
||||
Places a line of blocks between two points.
|
||||
Width 9, also extends out from each point by 9.
|
||||
-}
|
||||
blockLine :: Point2 -> Point2 -> Placement
|
||||
blockLine a b = sps0 $ PutLineBlock baseBlockPane 9 9 a b
|
||||
|
||||
{-
|
||||
Places an breakable window between two points.
|
||||
Width 8, also extends out from each point by 8.
|
||||
-}
|
||||
windowLine :: Point2 -> Point2 -> Placement
|
||||
windowLine a b = sps0 $ PutLineBlock baseWindowPane 8 8 a b
|
||||
{-
|
||||
Places an unbreakable window between two points.
|
||||
Width 7, also extends out from each point by 7.
|
||||
-}
|
||||
crystalLine :: Point2 -> Point2 -> Placement
|
||||
crystalLine a b = sps0 $ PutWall ps defaultCrystalWall
|
||||
where
|
||||
ps =
|
||||
[ a +.+ left +.+ up
|
||||
, (a +.+ left) -.- up
|
||||
, (b -.- left) -.- up
|
||||
, (b -.- left) +.+ up
|
||||
]
|
||||
left = 7 *.* normalizeV (a-.-b)
|
||||
up = vNormal left
|
||||
{- Places an unbreakable wall between two points.
|
||||
Depth 15, does not extend wider than points.
|
||||
-}
|
||||
wallLine :: Point2 -> Point2 -> Placement
|
||||
wallLine a b = sps0 $ PutWall ps defaultWall
|
||||
where
|
||||
ps = [ a +.+ up
|
||||
, a -.- up
|
||||
, b -.- up
|
||||
, b +.+ up
|
||||
]
|
||||
left = 15 *.* normalizeV (a-.-b)
|
||||
up = vNormal left
|
||||
|
||||
windowLineType :: Point2 -> Point2 -> PSType
|
||||
windowLineType = PutLineBlock baseWindowPane 8 8
|
||||
|
||||
baseBlockPane :: Wall
|
||||
baseBlockPane = defaultWall
|
||||
{ _wlLine = (V2 0 0,V2 50 0)
|
||||
, _wlID = 0
|
||||
, _wlColor = greyN 0.5
|
||||
, _wlSeen = False
|
||||
, _wlOpacity = Opaque
|
||||
, _wlDraw = True
|
||||
, _wlFireThrough = True
|
||||
}
|
||||
baseWindowPane :: Wall
|
||||
baseWindowPane = defaultWall
|
||||
{ _wlLine = (V2 0 0,V2 50 0)
|
||||
, _wlID = 0
|
||||
, _wlColor = withAlpha 0.2 cyan
|
||||
, _wlSeen = False
|
||||
, _wlOpacity = SeeThrough
|
||||
, _wlDraw = True
|
||||
, _wlFireThrough = True
|
||||
}
|
||||
-- TODO find home for this
|
||||
{- Replaces instances of a given 'PutID' with 'PSType's drawn from a list. -}
|
||||
replacePutID
|
||||
:: Int -- ^ The id of 'PutID' to be replaced
|
||||
-> [PSType] -- ^ List of replacements
|
||||
-> Room
|
||||
-> Room
|
||||
replacePutID i psts r =
|
||||
r & rmPmnts %~ flip (subZipWith (isPutID i) (\ps pt -> ps & plType .~ pt)) psts
|
||||
{- Partition a list by a predicate, apply a zip to those elements
|
||||
that satisfy the predicate, concatenate
|
||||
the new zipped list and the other (unchanged) half. -}
|
||||
subZipWith
|
||||
:: (a -> Bool) -- ^ Filter: elements to apply zip to
|
||||
-> (a -> b -> a) -- ^ Combining function
|
||||
-> [a] -- ^ List to be partitioned
|
||||
-> [b] -- ^ Modifying list
|
||||
-> [a]
|
||||
subZipWith f g xs ys =
|
||||
let (zs,ws) = partition f xs
|
||||
in zipWith g zs ys ++ ws
|
||||
|
||||
isPutID :: Int -> Placement -> Bool
|
||||
isPutID i ps = Just i == ps ^? plType . putID
|
||||
|
||||
putBlockRect :: Float -> Float -> Float -> Float -> [Placement]
|
||||
putBlockRect a x b y =
|
||||
[ blockLine (V2 a b) (V2 a y)
|
||||
, blockLine (V2 a y) (V2 x y)
|
||||
, blockLine (V2 x y) (V2 x b)
|
||||
, blockLine (V2 x b) (V2 a b)
|
||||
]
|
||||
putBlockV :: Float -> Float -> Float -> Float -> [Placement]
|
||||
putBlockV a x b y =
|
||||
[ blockLine (V2 a b) (V2 a y)
|
||||
, blockLine (V2 x b) (V2 a b)
|
||||
]
|
||||
putBlockC :: Float -> Float -> Float -> Float -> [Placement]
|
||||
putBlockC a x b y =
|
||||
[ blockLine (V2 a b) (V2 a y)
|
||||
, blockLine (V2 x b) (V2 a b)
|
||||
, blockLine (V2 a y) (V2 x y)
|
||||
]
|
||||
putBlockN :: Float -> Float -> Float -> Float -> [Placement]
|
||||
putBlockN a x b y =
|
||||
[ blockLine (V2 a b) (V2 a y)
|
||||
, blockLine (V2 x b) (V2 a b)
|
||||
, blockLine (V2 x y) (V2 x b)
|
||||
]
|
||||
Reference in New Issue
Block a user