Cleanup: broken pathfinding

src/Dodge/Placement/Instance.hs

@@ -0,0 +1,17 @@
+module Dodge.Placement.Instance
+    ( module Dodge.Placement.Instance.Door
+    , module Dodge.Placement.Instance.LightSource
+    , module Dodge.Placement.Instance.Wall
+    , module Dodge.Placement.Instance.Button
+    , module Dodge.Placement.Instance.Turret
+    , module Dodge.Placement.Instance.Sensor
+    , module Dodge.Placement.Instance.Creature
+    )
+    where
+import Dodge.Placement.Instance.Door
+import Dodge.Placement.Instance.LightSource
+import Dodge.Placement.Instance.Wall
+import Dodge.Placement.Instance.Button
+import Dodge.Placement.Instance.Turret
+import Dodge.Placement.Instance.Sensor
+import Dodge.Placement.Instance.Creature

src/Dodge/Placement/Instance/Button.hs

@@ -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

src/Dodge/Placement/Instance/Creature.hs

@@ -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

src/Dodge/Placement/Instance/Door.hs

@@ -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

src/Dodge/Placement/Instance/LightSource.hs

@@ -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)

src/Dodge/Placement/Instance/Sensor.hs

@@ -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

src/Dodge/Placement/Instance/Turret.hs

@@ -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

src/Dodge/Placement/Instance/Wall.hs

@@ -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)
+    ]

src/Dodge/Placement/PlaceSpot.hs

@@ -0,0 +1,199 @@
+{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE RankNTypes #-}
+-- | deals with placement of objects within the world
+-- after they have had their coordinates set by the layout
+module Dodge.Placement.PlaceSpot
+    ( shiftPlacement
+    , shiftPointBy
+    , invShiftPointBy
+    , placeSpot
+    ) where
+import Dodge.Data
+import Dodge.Path
+import Dodge.Placement.PlaceSpot.Block
+import Dodge.Placement.PlaceSpot.TriggerDoor
+import Dodge.LevelGen.Data
+import Dodge.Default.Wall
+import Dodge.ShiftPoint
+--import Dodge.RandomHelp
+--import Dodge.Placements.Spot
+import Geometry
+import Geometry.Vector3D
+import Shape
+import qualified IntMapHelp as IM
+import Color
+
+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 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
+        in maybe ((w',rm),[newplmnt]) (recrPlace newplmnt w') (_plIDCont plmnt newplmnt)
+      where
+        recrPlace newplmnt w' pl = let (wr,newplmnts) = placeSpot (w',rm) pl
+                        in (wr,newplmnt:newplmnts)
+            -- (placeSpot (w',rm)) (_plIDCont plmnt i)
+    PlacementUsingPos p subpl -> placeSpot (w,rm) (subpl (shiftPoint3By shift p))
+    RandomPlacement rplmnt -> placeSpot (w & randGen .~ g,rm) plmnt'
+      where
+        (plmnt', g) = runState rplmnt (_randGen w)
+  where
+    shift = _rmShift rm
+
+-- this should be tidied up
+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
+    searchedPoss [] = error "no correct pos type for lnk placement"
+    searchedPoss (pos:poss) = case extract 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)
+
+shiftPlacement :: (Point2,Float) -> Placement -> Placement
+shiftPlacement shift plmnt = case plmnt of
+    Placement {} -> plmnt & plSpot %~ shiftPSBy shift 
+        & plIDCont %~ fmap (fmap $ shiftPlacement shift)
+    PlacementUsingPos p f -> PlacementUsingPos (shiftPoint3By shift p)
+        (fmap (shiftPlacement shift) f)
+    RandomPlacement rpl -> RandomPlacement $ fmap (shiftPlacement shift) rpl
+
+shiftPSBy :: (Point2,Float) -> PlacementSpot -> PlacementSpot
+shiftPSBy (pos,rot) ps = ps
+    & psPos %~ shiftPointBy (pos,rot)
+    & psRot %~ (+ rot)
+
+-- the Int here allows for passing parameters down to other placements:
+-- button ids, etc
+placeSpotID :: PlacementSpot -> PSType -> World -> (Int, World)
+placeSpotID ps pt w = case pt of
+    PutTrigger cond -> placeNewInto triggers cond w
+    PutProp prop    -> plNewUpID props pjID (mvProp p rot prop) w
+    PutButton bt    -> plNewUpID buttons btID (mvButton p rot bt) w
+    PutFlIt itm     -> plNewUpID floorItems flItID (createFlIt p rot itm) w
+    PutCrit cr      -> plNewUpID creatures crID (mvCr p rot cr) w
+    PutMachine col wallpoly mc -> placeMachine col (map doShift wallpoly) mc p rot w
+    PutLS ls        -> plNewUpID lightSources lsID (mvLS p' rot ls) w
+    PutPressPlate pp -> plNewUpID pressPlates ppID (mvPP p rot pp) w
+    RandPS rgen -> evaluateRandPS rgen ps w
+    PutDoor col f pss -> placeDoor col f (map (bimap doShift doShift) pss) w
+    PutCoordinate coordp -> placeNewInto coordinates (doShift coordp) w
+    PutSlideDoor pathing col f a b spd -> placeSlideDoor pathing col f (doShift a) (doShift b) spd w
+    PutBlock (hp:hps) col ps' -> placeBlock (map doShift ps') hp col Opaque hps w
+    PutBlock{} -> error "messed up block placement somehow"
+    PutLineBlock wl wdth dpth a b -> placeLineBlock wl wdth dpth (doShift a) (doShift b) w
+    PutWall { _pwPoly = ps', _pwWall = wl } -> (0,placeWallPoly (map doShift ps') wl w)
+    PutForeground sh -> (0,w & foregroundShape %~ ((uncurryV translateSHf p . rotateSH rot) sh <>))
+    PutNothing -> (0,w)
+    PutID i -> (i, w)
+    PutWorldUpdate f -> (0,f ps w)
+  where 
+    p@(V2 px py) = _psPos ps
+    p' = V3 px py 0
+    rot = _psRot ps
+    doShift = shiftPointBy (p,rot)
+
+evaluateRandPS :: State StdGen PSType -> PlacementSpot -> World -> (Int,World)
+evaluateRandPS rgen ps w = placeSpotID ps evaluatedType (set randGen g w)
+  where 
+    (evaluatedType, g) = runState rgen (_randGen w)
+
+placeWallPoly :: [Point2] -> Wall -> World -> World
+placeWallPoly ps wl = rmCrossPaths . over walls (addWalls 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
+  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
+  where
+    wlid = IM.newKey wls
+
+-- | generalised way of putting a new item into a lensed intmap, returning the
+-- new index as well
+placeNewInto :: ALens' World (IM.IntMap a)
+    -> a
+    -> World
+    -> (Int,World)
+placeNewInto l x w = (i,w & l #%~ IM.insert i x)
+  where
+    i = IM.newKey $ w ^# l
+
+-- | place an new object into an intmap and update its id
+plNewUpID :: ALens' World (IM.IntMap a)
+    -> ALens' a Int
+    -> a
+    -> World
+    -> (Int,World)
+plNewUpID l li x w = (i,w & l #%~ IM.insert i (x & li #~ i))
+  where
+    i = IM.newKey $ w ^# l
+
+mvProp :: Point2 -> Float -> Prop -> Prop
+mvProp p a = (pjRot +~ a) . (pjPos %~ ( (p +.+) . rotateV a ))
+
+mvButton :: Point2 -> Float -> Button -> Button
+mvButton p a = (btRot +~ a) . (btPos %~ ( (p +.+) . rotateV a ))
+
+{- Creates a floor item at a given point.-}
+createFlIt :: Point2 -> Float -> Item -> FloorItem
+createFlIt p rot itm = FlIt { _flItPos = p , _flItRot = rot , _flItID = 0 , _flIt = itm }
+
+mvPP :: Point2 -> Float -> PressPlate -> PressPlate
+mvPP p rot pp = pp {_ppPos = p,_ppRot = rot}
+
+mvCr :: Point2 -> Float -> Creature -> Creature
+mvCr p rot cr = cr {_crPos = p,_crOldPos = p,_crDir = rot}
+
+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 = IS.fromList [wlid .. wlid + length wallpoly - 1]
+    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
+
+mvLS :: Point3 -> Float -> LightSource -> LightSource
+mvLS (V3 x y z) rot ls = ls {_lsPos = V3 x y z +.+.+ startPos,_lsDir = rot}
+  where
+    startPos = onXY (rotateV rot) $ _lsPos ls

src/Dodge/Placement/PlaceSpot/Block.hs

@@ -0,0 +1,108 @@
+{- | Creation, update and destruction of destructible walls.  -}
+module Dodge.Placement.PlaceSpot.Block 
+    ( placeBlock
+    , placeLineBlock
+    )
+    where
+import Dodge.Data
+import Dodge.Path
+import Dodge.Base
+import Dodge.Zone
+import Dodge.Default.Wall
+import Geometry
+import qualified IntMapHelp as IM
+import Color
+
+import Control.Lens
+import Data.List
+import qualified Data.IntSet as IS
+
+addBlock 
+    :: [Point2]     -- ^ Block polygon
+    -> Int          -- ^ First layer of health
+    -> Color 
+    -> Opacity         -- ^ Is the block see through?
+    -> [Int]        -- ^ Extra layers of health
+    -> World 
+    -> World
+addBlock (p:ps) hp col opacity hps w 
+    | hp <= 0 && null 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
+        & blocks %~ IM.insert blid (Block {_blID = blid,_blWallIDs = IS.fromList is, _blHPs = hp:hps, _blShadows=[]})
+  where 
+    blid = IM.newKey $ _blocks w
+    lns = zip (p:ps) (ps ++ [p])
+    i = IM.newKey $ _walls w
+    is = [i.. i + length lns-1]
+    panes = IM.fromList $ zipWith 
+        (\j (a,b) -> (,) j defaultWall 
+            { _wlLine = (a,b)
+            , _wlID = j
+            , _wlColor = col
+            , _wlOpacity = opacity
+            , _wlStructure = BlockPart blid
+            , _wlFireThrough = True
+            }
+        ) is lns
+    wallInZone wl 
+        | uncurry dist (_wlLine wl) <= 2*zoneSize 
+            = 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)
+        wlid  = _wlID wl
+        ips = map zoneOfPoint $ uncurry (divideLine (2*zoneSize)) (_wlLine wl)
+addBlock _ _ _ _ _ _ = error "Trying to add a block with incomplete polygon"
+        
+placeBlock :: [Point2] -> Int -> Color -> Opacity -> [Int] -> World -> (Int,World)
+placeBlock poly i c opac is w = (0, foldr (uncurry removePathsCrossing) wWithBlock pairs)
+  where 
+    pairs = loopPairs poly
+    wWithBlock = addBlock poly i c opac is w
+
+{- | Splits a line into many four cornered blocks. -}
+placeLineBlock 
+    :: Wall     -- ^ Base pane
+    -> Float    -- ^ Block width
+    -> Float    -- ^ Block depth
+    -> Point2   -- ^ Start point (symmetric)
+    -> Point2   -- ^ End point (symmetric)
+    -> World 
+    -> (Int, World)
+placeLineBlock basePane blockWidth depth a b w = (,) 0 
+    $ removePathsCrossing a b $ foldr insertWall (insertBlocks w) listWalls
+  where 
+    psOnLine = divideLineOddNumPoints blockWidth a b
+    halfBlockWidth = dist a b / fromIntegral (length psOnLine - 1)
+    blockCenPs = snd $ evenOddSplit psOnLine
+    numBlocks = length blockCenPs
+    is = [0.. numBlocks - 1]
+    cornerPoints = reverse $ rectWH halfBlockWidth depth -- goes clockwise around the block
+    cornersAt p = fmap ( (p +.+) . rotateV (argV (b -.- a)) ) cornerPoints
+    linesAt p = loopPairs $ cornersAt p
+    wlid = IM.newKey $ _walls w
+    blid = IM.newKey $ _blocks w
+    insertBlock i = over blocks $ IM.insert (i+blid) Block 
+        {_blID = i + blid, _blWallIDs = IS.fromList $ ksAtI i, _blHPs = [5,5], _blShadows = shadowsAt i}
+    insertBlocks = flip (foldr insertBlock) is
+    ksAtI i = map ( + (wlid + i*4) ) [0,1,2,3]
+    visibilityAt i 
+        | i == 0             = [False,True,True ,True]
+        | i == numBlocks - 1 = [True ,True,False,True]
+        | otherwise          = [False,True,False,True]
+    shadowsAt i
+        | i == 0             = ksAtI 1
+        | i == numBlocks - 1 = ksAtI $ numBlocks - 2
+        | otherwise          = ksAtI (i-1) ++ ksAtI (i+1)
+    makeWallAt p i = zipWith3 (makePane i) (visibilityAt i) (ksAtI i) (linesAt p)
+    makePane i visStatus k ps = basePane
+        {_wlID = k
+        ,_wlStructure = BlockPart $ i + blid
+        ,_wlLine = ps
+        ,_wlDraw = visStatus
+        }
+    listWalls = concat $ zipWith makeWallAt blockCenPs is
+    insertWall wl = over walls $ IM.insert (_wlID wl) wl

src/Dodge/Placement/PlaceSpot/TriggerDoor.hs

@@ -0,0 +1,137 @@
+--{-# LANGUAGE BangPatterns #-}
+module Dodge.Placement.PlaceSpot.TriggerDoor
+    ( placeDoor
+    , placeSlideDoor
+    ) where
+import Dodge.Data
+import Dodge.Default.Wall
+import Dodge.Wall.Move
+import Dodge.LevelGen.DoorPane
+import Picture
+import Geometry
+import qualified IntMapHelp as IM
+import Dodge.SoundLogic
+import Dodge.SoundLogic.LoadSound
+import Dodge.Data.SoundOrigin
+
+import Data.List
+import Control.Lens
+--import Data.Graph.Inductive hiding ((&))
+import qualified Data.IntSet as IS
+placeDoor 
+    :: Color 
+    -> (World -> Bool)      -- ^ Opening condition
+    -> [(Point2,Point2)]   -- ^ Door positions, closed to open.
+                    -- Bumped out up and down by 9, not widened
+    -> World 
+    -> (Int,World)
+placeDoor col cond pss w = (drid, addWalls w & doors %~ addDoor)
+  where
+    drid = IM.newKey $ _doors w
+    addDoor = IM.insert drid $ Door
+        { _drID = drid
+        , _drWallIDs = IS.fromList wlids
+        , _drStatus = DoorInt 0
+        , _drTrigger = cond
+        , _drMech   = doorMechanismStepwise nsteps drid wlids pss
+        }
+    nsteps = length pss - 1
+    wlids = take 4 [IM.newKey $ _walls w ..]
+    wlps' = uncurry (rectanglePairs 9) $ head pss
+    addWalls w' = foldl' addWall w' $ zip wlids wlps'
+    addWall w' (wlid, wlps) = w' & walls %~ IM.insert wlid defaultWall
+        { _wlLine = wlps
+        , _wlID = wlid
+        , _wlColor = col
+        , _wlSeen = False
+        , _wlOpacity = Opaque
+        , _wlPathable = False
+        }
+-- TODO use vector instead of list, perhaps also memoisation of rectanglePairs
+-- perhaps also remove use of DoorInt in favour of DoorOpen/DoorClosed
+doorMechanismStepwise :: Int -> Int -> [Int] -> [(Point2,Point2)] -> Door -> World -> World
+doorMechanismStepwise nsteps drid wlids pss dr w 
+    | toOpen = case _drStatus dr of
+        DoorInt x | x == nsteps -> w
+        DoorInt x      -> setWalls (x+1)
+        _ -> w
+    | otherwise = case _drStatus dr of
+        DoorInt 0 -> w
+        DoorInt x -> setWalls (x-1)
+        _ -> w
+  where
+    playSound = soundContinue (WallSound drid) (fst $ head pss) slideDoorS (Just 1)
+    toOpen = _drTrigger dr w
+    setWalls n = playSound (foldl' (&) w (zipWith moveWallID wlids newps))
+        & doors . ix drid . drStatus .~ DoorInt n
+      where
+        newps = uncurry (rectanglePairs 9) (pss !! n)
+-- it is not at all clear that the zoning selects the correct walls
+
+doorMechanism :: Int -> Float -> [(Int,(Point2,Point2),(Point2,Point2))] -> Door -> World -> World
+doorMechanism drid speed wlidOpCps dr w 
+    | toOpen     && dstatus /= DoorOpen   = moveUpdate $ foldl' doOpen  w wlidOpCps
+    | not toOpen && dstatus /= DoorClosed = moveUpdate $ foldl' doClose w wlidOpCps
+    | otherwise = w
+  where
+    moveUpdate = playSound . setStatus
+    playSound = soundContinue (WallSound drid) (fst cpos) slideDoorS (Just 1)
+    setStatus
+        | dist (fst wlpos) (fst opos) < 1 = doors . ix drid . drStatus .~ DoorOpen
+        | dist (fst wlpos) (fst cpos) < 1 = doors . ix drid . drStatus .~ DoorClosed
+        | otherwise                       = doors . ix drid . drStatus .~ DoorHalfway
+    (wlid',opos,cpos) = head wlidOpCps
+    wlpos   = _wlLine $ _walls w IM.! wlid'
+    toOpen  = _drTrigger dr w
+    dstatus = _drStatus dr
+    doOpen  w' (wlid,opp, _) = moveWallIDToward wlid speed opp w'
+    doClose w' (wlid,_ ,clp) = moveWallIDToward wlid speed clp w'
+
+-- TODO cut pathing if not pathable, reset when opened
+placeSlideDoor :: Bool -> Color -> (World -> Bool) -> Point2 -> Point2 -> Float -> World
+    -> (Int, World)
+placeSlideDoor isPathable col cond a b speed w = (drid, addWalls w & doors %~ addDoor)
+  where
+    drid = IM.newKey $ _doors w
+    addDoor = IM.insert drid $ Door
+        { _drID = drid
+        , _drWallIDs = IS.fromList wlids
+        , _drStatus = DoorClosed
+        , _drTrigger = cond
+        , _drMech   = doorMechanism drid speed (zip3 wlids shiftedPairs pairs)
+        }
+    addWalls w' = foldl' addWall w' $ zip wlids pairs
+    addWall w' (wlid, wlps) = w' & walls %~ IM.insert wlid defaultWall
+        { _wlLine = wlps
+        , _wlID = wlid
+        , _wlColor = col
+        , _wlSeen       = False
+        , _wlOpacity    = Opaque
+        , _wlPathable   = isPathable
+        }
+    pairs = rectanglePairs 9 a b
+    shiftedPairs = map (bimap shiftLeft shiftLeft) pairs
+    shiftLeft  = (+.+ (a -.- b))
+    wlids = take 4 [IM.newKey $ _walls w ..]
+-- old code that may help with pathing
+--import Dodge.LevelGen.Pathing
+--import Data.Graph.Inductive hiding ((&))
+--addButtonDoor :: Color -> Point2 -> Float -> Point2 -> Point2 -> Float -> World -> (Int, World)
+--addButtonDoor c btp btr a b speed w 
+--    = (,) 0
+--    . over buttons (IM.insert bid bt) 
+--    $ set pathPoints (foldr insertPoint IM.empty (labNodes newGraph))
+--    $ set pathGraph newGraph
+--    $ set pathGraphP newGraphPairs
+--    $ snd (placeSlideDoor False c cond a b speed w)
+--  where 
+--    bid = IM.newKey $ _buttons w
+--    cond w' = BtNoLabel == _btState (_buttons w' IM.! bid)
+--    bt = (makeButton c eff) {_btPos = btp, _btRot = btr, _btID = bid}
+--    (newGraphPairs,removedPairs) = partition (isNothing . uncurry (intersectSegSeg a b)) 
+--                                             $ _pathGraphP w
+--    newGraph = pairsToGraph dist newGraphPairs
+--    insertPoint  pp@(_,V2 x y) = insertInZoneWith (floorHun x) (floorHun y) (++) [pp]
+--    eff w' = over pathGraphP (removedPairs ++) 
+--             . over pathGraph (flip run_ $ insMapEdgesM $ map f removedPairs) $ w'
+--    f (x,y) = (x,y,dist x y)