Refactor, try to limit dependencies
This commit is contained in:
@@ -1,71 +1,45 @@
|
||||
module Dodge.Placement.Instance.Analyser
|
||||
( analyser
|
||||
) where
|
||||
--import Dodge.LevelGen.Data
|
||||
--import Dodge.PlacementSpot
|
||||
import Dodge.Data
|
||||
--import Dodge.Base.You
|
||||
import Dodge.Default
|
||||
import Dodge.Terminal
|
||||
--import Dodge.Tree
|
||||
--import Dodge.RoomLink
|
||||
--import Dodge.Room.Door
|
||||
--import Dodge.Room.Corridor
|
||||
--import Dodge.Room.Link
|
||||
--import Dodge.Room.Ngon
|
||||
--import Dodge.Room.Procedural
|
||||
--import Dodge.Room.Foreground
|
||||
--import Dodge.Room.RoadBlock
|
||||
import Dodge.Placement.Instance
|
||||
--import Dodge.Placement.Shift
|
||||
--import Dodge.SoundLogic
|
||||
--import Dodge.Default.Room
|
||||
--import Dodge.Item.Weapon.BulletGuns
|
||||
--import Dodge.Item.Weapon.Utility
|
||||
--import Dodge.LevelGen.Data
|
||||
--import Geometry.Data
|
||||
--import Geometry
|
||||
--import Padding
|
||||
module Dodge.Placement.Instance.Analyser (
|
||||
analyser,
|
||||
) where
|
||||
|
||||
import Color
|
||||
--import Shape
|
||||
--import ShapePicture
|
||||
import Dodge.Data.GenWorld
|
||||
import Dodge.Default
|
||||
import Dodge.Placement.Instance
|
||||
import Dodge.Terminal
|
||||
import LensHelp
|
||||
--import Dodge.RandomHelp
|
||||
|
||||
--import qualified Data.Set as S
|
||||
--import Data.Maybe
|
||||
--import Data.Tree
|
||||
--import Control.Monad.State
|
||||
--import System.Random
|
||||
|
||||
analyser
|
||||
:: ProximityRequirement
|
||||
-> PlacementSpot
|
||||
-> PlacementSpot
|
||||
-> Placement
|
||||
analyser ::
|
||||
ProximityRequirement ->
|
||||
PlacementSpot ->
|
||||
PlacementSpot ->
|
||||
Placement
|
||||
analyser proxreq pslight psmc = extTrigLitPos pslight $ \tp ->
|
||||
Just $ plSpot .~ psmc $ putTerminal
|
||||
(themachine & mcMounts . at ObTrigger .~ _plMID tp)
|
||||
tparams -- (linksensortotrigger tp)
|
||||
Just $
|
||||
plSpot .~ psmc $
|
||||
putTerminal
|
||||
(themachine & mcMounts . at ObTrigger .~ _plMID tp)
|
||||
tparams -- (linksensortotrigger tp)
|
||||
where
|
||||
tparams = basicTerminal & tmScrollCommands .:~ sensorCommand
|
||||
-- linksensortotrigger tp _ mc
|
||||
-- = triggers . ix (fromJust $ _plMID tp) .~ const (_sensToggle $ _mcSensor mc)
|
||||
themachine = defaultMachine & mcColor .~ aquamarine
|
||||
-- & mcUpdate .~ mcProximitySensorUpdate
|
||||
& mcDraw .~ MachineDrawTerminal
|
||||
& mcHP .~ 100
|
||||
& mcSensor .~ defaultProximitySensor {_proxRequirement = proxreq}
|
||||
-- linksensortotrigger tp _ mc
|
||||
-- = triggers . ix (fromJust $ _plMID tp) .~ const (_sensToggle $ _mcSensor mc)
|
||||
themachine =
|
||||
defaultMachine & mcColor .~ aquamarine
|
||||
-- & mcUpdate .~ mcProximitySensorUpdate
|
||||
& mcDraw .~ MachineDrawTerminal
|
||||
& mcHP .~ 100
|
||||
& mcSensor .~ defaultProximitySensor{_proxRequirement = proxreq}
|
||||
|
||||
--this can probably be deleted
|
||||
--mcProximitySensorUpdate :: Machine -> World -> World
|
||||
--mcProximitySensorUpdate mc w = case
|
||||
--mcProximitySensorUpdate mc w = case
|
||||
-- (_proxStatus sens
|
||||
-- , _sensToggle sens
|
||||
-- , mcProxTest mc w
|
||||
-- , mcProxTest mc w
|
||||
-- , dist (_crPos ycr) (_mcPos mc) < _proxDist sens) of
|
||||
-- (_,True,_,_) -> w
|
||||
-- (_,False,True,True) -> w
|
||||
-- (_,False,True,True) -> w
|
||||
-- & machines . ix (_mcID mc) . mcSensor . sensToggle .~ True
|
||||
-- & playsound dedaS
|
||||
-- & machines . ix (_mcID mc) . mcSensor . proxStatus .~ IsClose
|
||||
|
||||
@@ -1,26 +1,28 @@
|
||||
module Dodge.Placement.Instance.Block where
|
||||
import Dodge.Data
|
||||
import Geometry
|
||||
import Color
|
||||
import LensHelp
|
||||
import Dodge.Default.Wall
|
||||
import Dodge.Default.Block
|
||||
|
||||
--decoratedBlock :: (Block -> Shape) -> Material -> Color -> Float -> [Point2] -> PSType
|
||||
import Color
|
||||
import Dodge.Data.GenWorld
|
||||
import Dodge.Default.Block
|
||||
import Dodge.Default.Wall
|
||||
import Geometry
|
||||
import LensHelp
|
||||
|
||||
decoratedBlock :: BlSh -> Material -> Color -> Float -> [Point2] -> PSType
|
||||
decoratedBlock decf mat col h ps = PutBlock bl wl $ reverse ps
|
||||
where
|
||||
bl = defaultBlock
|
||||
& blDraw .~ BlockDraws [BlockDrawColHeightPoss col h (reverse ps),BlockDrawBlSh decf]
|
||||
bl =
|
||||
defaultBlock
|
||||
& blDraw .~ BlockDraws [BlockDrawColHeightPoss col h (reverse ps), BlockDrawBlSh decf]
|
||||
--(\bl' -> noPic (colorSH col (upperPrismPoly h $ reverse ps) <> decf bl'))
|
||||
& blHeight .~ h
|
||||
& blMaterial .~ mat
|
||||
wl = defaultWall
|
||||
& wlColor .~ col
|
||||
& wlRotateTo .~ False
|
||||
& wlOpacity .~ SeeAbove
|
||||
& wlMaterial .~ mat
|
||||
& wlHeight .~ h
|
||||
& blHeight .~ h
|
||||
& blMaterial .~ mat
|
||||
wl =
|
||||
defaultWall
|
||||
& wlColor .~ col
|
||||
& wlRotateTo .~ False
|
||||
& wlOpacity .~ SeeAbove
|
||||
& wlMaterial .~ mat
|
||||
& wlHeight .~ h
|
||||
|
||||
lowBlock :: Material -> Color -> Float -> [Point2] -> PSType
|
||||
lowBlock = decoratedBlock BlShMempty
|
||||
|
||||
@@ -1,85 +1,129 @@
|
||||
module Dodge.Placement.Instance.Button where
|
||||
import Dodge.Data
|
||||
import Dodge.LightSource
|
||||
|
||||
import Color
|
||||
import Geometry
|
||||
import Control.Lens
|
||||
import Data.Maybe
|
||||
import Dodge.Data.GenWorld
|
||||
import Dodge.LevelGen.Data
|
||||
import Dodge.LevelGen.Switch
|
||||
import Dodge.LightSource
|
||||
import Dodge.Placement.Instance.LightSource
|
||||
import Dodge.PlacementSpot
|
||||
|
||||
import Data.Maybe
|
||||
import Control.Lens
|
||||
import Geometry
|
||||
|
||||
triggerSwitchSPic :: ButtonDraw -> PlacementSpot -> Placement
|
||||
triggerSwitchSPic sdraw ps = psPtCont ps (PutTrigger False)
|
||||
$ \tp -> Just $ pContID ps (PutButton (makeSwitchSPic sdraw (SetTrigger True $ trigid tp)
|
||||
(SetTrigger False $ trigid tp)))
|
||||
(const Nothing)
|
||||
triggerSwitchSPic sdraw ps = psPtCont ps (PutTrigger False) $
|
||||
\tp ->
|
||||
Just $
|
||||
pContID
|
||||
ps
|
||||
( PutButton
|
||||
( makeSwitchSPic
|
||||
sdraw
|
||||
(SetTrigger True $ trigid tp)
|
||||
(SetTrigger False $ trigid tp)
|
||||
)
|
||||
)
|
||||
(const Nothing)
|
||||
where
|
||||
trigid tp = fromJust $ _plMID tp
|
||||
|
||||
triggerSwitchSPicLight :: ButtonDraw -> PlacementSpot -> Placement
|
||||
triggerSwitchSPicLight sdraw ps = psPtCont ps (PutTrigger False)
|
||||
$ \tp -> Just $ pContID atFstLnkOut (PutLS thels)
|
||||
$ \lsid -> Just
|
||||
$ pContID ps (PutButton (makeSwitchSPic sdraw (oneff lsid $ trigid tp) (offeff lsid $ trigid tp)))
|
||||
(const Nothing)
|
||||
triggerSwitchSPicLight sdraw ps = psPtCont ps (PutTrigger False) $
|
||||
\tp -> Just $
|
||||
pContID atFstLnkOut (PutLS thels) $
|
||||
\lsid ->
|
||||
Just $
|
||||
pContID
|
||||
ps
|
||||
(PutButton (makeSwitchSPic sdraw (oneff lsid $ trigid tp) (offeff lsid $ trigid tp)))
|
||||
(const Nothing)
|
||||
where
|
||||
thels = lsColPosRad (V3 0.5 0 0) (V3 0 0 78) 75
|
||||
trigid tp = fromJust $ _plMID tp
|
||||
oneff lsid tid = WorldEffects [SetLSCol (V3 0 0.5 0) lsid, SetTrigger True tid]
|
||||
oneff lsid tid = WorldEffects [SetLSCol (V3 0 0.5 0) lsid, SetTrigger True tid]
|
||||
offeff lsid tid = WorldEffects [SetLSCol (V3 0.5 0 0) lsid, SetTrigger False tid]
|
||||
|
||||
triggerSwitch :: Color -> PlacementSpot -> Placement
|
||||
triggerSwitch col ps = psPtCont ps (PutTrigger False)
|
||||
$ \tp -> Just $ pContID ps (PutButton (makeSwitch col col (SetTrigger True $ trigid tp)
|
||||
(SetTrigger False $ trigid tp)))
|
||||
(const Nothing)
|
||||
triggerSwitch col ps = psPtCont ps (PutTrigger False) $
|
||||
\tp ->
|
||||
Just $
|
||||
pContID
|
||||
ps
|
||||
( PutButton
|
||||
( makeSwitch
|
||||
col
|
||||
col
|
||||
(SetTrigger True $ trigid tp)
|
||||
(SetTrigger False $ trigid tp)
|
||||
)
|
||||
)
|
||||
(const Nothing)
|
||||
where
|
||||
trigid tp = fromJust $ _plMID tp
|
||||
|
||||
putLitButOnPos :: Color
|
||||
-> PlacementSpot
|
||||
-> (Placement -> Maybe Placement) -> Placement
|
||||
putLitButOnPos col theps subpl
|
||||
= plSpot .~ theps $ mntLSOn aShape (Just col) ls 0 (V3 0 (-40) 40)
|
||||
$ \plmnt -> jps0' (PutButton (makeButton col (changeLight . fromJust $ _plMID plmnt)) {_btPos = V2 0 (-1), _btRot = pi})
|
||||
subpl <&> plSpot .~ _plSpot plmnt
|
||||
putLitButOnPos ::
|
||||
Color ->
|
||||
PlacementSpot ->
|
||||
(Placement -> Maybe Placement) ->
|
||||
Placement
|
||||
putLitButOnPos col theps subpl =
|
||||
plSpot .~ theps $
|
||||
mntLSOn aShape (Just col) ls 0 (V3 0 (-40) 40) $
|
||||
\plmnt ->
|
||||
jps0'
|
||||
(PutButton (makeButton col (changeLight . fromJust $ _plMID plmnt)){_btPos = V2 0 (-1), _btRot = pi})
|
||||
subpl
|
||||
<&> plSpot
|
||||
.~ _plSpot plmnt
|
||||
where
|
||||
changeLight lsid = SetLSCol (V3 0 0.5 0) lsid
|
||||
ls = lsRadCol 75 (V3 0.5 0 0)
|
||||
|
||||
-- creates a lit external trigger, passes the trigger placement forward
|
||||
extTrigLitPos :: PlacementSpot -> (Placement -> Maybe Placement) -> Placement
|
||||
extTrigLitPos ps f = psPtCont ps (PutTrigger False)
|
||||
$ \tp -> Just $ pContID (ps' tp) (PutLS thels)
|
||||
$ \lsid -> Just $ pContID (ps' tp) (PutMod $ themod lsid tp)
|
||||
$ const (f tp)
|
||||
extTrigLitPos ps f = psPtCont ps (PutTrigger False) $
|
||||
\tp -> Just $
|
||||
pContID (ps' tp) (PutLS thels) $
|
||||
\lsid ->
|
||||
Just $
|
||||
pContID (ps' tp) (PutMod $ themod lsid tp) $
|
||||
const (f tp)
|
||||
where
|
||||
ps' tp = _plSpot tp
|
||||
themod lsid tp = ModIDID
|
||||
{_mdID = 0
|
||||
,_mdExternalID1 = lsid
|
||||
,_mdExternalID2 = fromJust $ _plMID tp
|
||||
,_mdUpdate = MdTrigIf (MdSetLSCol (V3 0 0.5 0)) (MdSetLSCol (V3 0.5 0 0))
|
||||
}
|
||||
themod lsid tp =
|
||||
ModIDID
|
||||
{ _mdID = 0
|
||||
, _mdExternalID1 = lsid
|
||||
, _mdExternalID2 = fromJust $ _plMID tp
|
||||
, _mdUpdate = MdTrigIf (MdSetLSCol (V3 0 0.5 0)) (MdSetLSCol (V3 0.5 0 0))
|
||||
}
|
||||
thels = lsColPosRad (V3 0.5 0 0) (V3 0 0 78) 75
|
||||
|
||||
putLitButOnPosExtTrig :: Color -> PlacementSpot -> Placement
|
||||
putLitButOnPosExtTrig col thePS = putLitButOnPosExtTrig' col thePS (const . const . const Nothing)
|
||||
|
||||
putLitButOnPosExtTrig' :: Color
|
||||
-> PlacementSpot
|
||||
-> (Placement -> Placement -> Placement -> Maybe Placement)
|
||||
-> Placement
|
||||
putLitButOnPosExtTrig' col thePS cnt
|
||||
= psPtCont thePS (PutTrigger False)
|
||||
$ \tp -> Just $ plSpot .~ _plSpot tp $ mntLSOn aShape (Just col) ls 0 (V3 0 (-40) 40)
|
||||
$ \plmnt -> jps0' (PutButton
|
||||
(makeButton col (WorldEffects [changeLight (fromJust $ _plMID plmnt), oneff (trigid tp)]))
|
||||
{_btPos = V2 0 (-1), _btRot = pi})
|
||||
(cnt tp plmnt) <&> plSpot .~ _plSpot plmnt
|
||||
putLitButOnPosExtTrig' ::
|
||||
Color ->
|
||||
PlacementSpot ->
|
||||
(Placement -> Placement -> Placement -> Maybe Placement) ->
|
||||
Placement
|
||||
putLitButOnPosExtTrig' col thePS cnt =
|
||||
psPtCont thePS (PutTrigger False) $
|
||||
\tp -> Just $
|
||||
plSpot .~ _plSpot tp $
|
||||
mntLSOn aShape (Just col) ls 0 (V3 0 (-40) 40) $
|
||||
\plmnt ->
|
||||
jps0'
|
||||
( PutButton
|
||||
(makeButton col (WorldEffects [changeLight (fromJust $ _plMID plmnt), oneff (trigid tp)]))
|
||||
{ _btPos = V2 0 (-1)
|
||||
, _btRot = pi
|
||||
}
|
||||
)
|
||||
(cnt tp plmnt)
|
||||
<&> plSpot
|
||||
.~ _plSpot plmnt
|
||||
where
|
||||
trigid tp = fromJust $ _plMID tp
|
||||
oneff tid = SetTrigger True tid
|
||||
|
||||
@@ -1,9 +1,9 @@
|
||||
module Dodge.Placement.Instance.Creature where
|
||||
--import Dodge.LevelGen.Data
|
||||
import Dodge.Data
|
||||
import RandomHelp
|
||||
|
||||
import Dodge.Creature.ArmourChase
|
||||
import Dodge.Creature.ChaseCrit
|
||||
import Dodge.Data.GenWorld
|
||||
import RandomHelp
|
||||
|
||||
randC1 :: PSType
|
||||
randC1 = RandPS $ takeOne $ map PutCrit $ armourChaseCrit : replicate 50 chaseCrit
|
||||
|
||||
@@ -1,76 +1,112 @@
|
||||
module Dodge.Placement.Instance.Door
|
||||
( putDoubleDoor
|
||||
, putAutoDoor
|
||||
, putDoubleDoorThen
|
||||
, switchDoor -- not used 9/3/22
|
||||
) where
|
||||
import Dodge.Data
|
||||
import Dodge.Default.Door
|
||||
module Dodge.Placement.Instance.Door (
|
||||
putDoubleDoor,
|
||||
putAutoDoor,
|
||||
putDoubleDoorThen,
|
||||
switchDoor, -- not used 9/3/22
|
||||
) where
|
||||
|
||||
import Color
|
||||
import Geometry
|
||||
import Control.Lens
|
||||
import Dodge.Data.CreatureEffect
|
||||
import Dodge.Data.GenWorld
|
||||
import Dodge.Default.Door
|
||||
import Dodge.LevelGen.Data
|
||||
import Dodge.LevelGen.Switch
|
||||
|
||||
import Control.Lens
|
||||
import Geometry
|
||||
|
||||
putDoubleDoor :: EdgeObstacle -> Wall -> WdBl -> Point2 -> Point2 -> Float -> Placement
|
||||
putDoubleDoor eo wl cond a b speed
|
||||
= putDoubleDoorThen eo wl cond 1 a b speed (const $ const Nothing)
|
||||
putDoubleDoor eo wl cond a b speed =
|
||||
putDoubleDoorThen eo wl cond 1 a b speed (const $ const Nothing)
|
||||
|
||||
putDoubleDoorThen ::EdgeObstacle -> Wall -> WdBl
|
||||
-> Float -> Point2 -> Point2 -> Float
|
||||
-> (Placement -> Placement -> Maybe Placement)
|
||||
-> Placement
|
||||
putDoubleDoorThen eo wl cond soff a b speed cont
|
||||
= doorBetween eo wl cond soff a half speed
|
||||
$ \pl1 -> Just $ doorBetween eo wl cond soff b half speed
|
||||
$ \pl2 -> cont pl1 pl2
|
||||
putDoubleDoorThen ::
|
||||
EdgeObstacle ->
|
||||
Wall ->
|
||||
WdBl ->
|
||||
Float ->
|
||||
Point2 ->
|
||||
Point2 ->
|
||||
Float ->
|
||||
(Placement -> Placement -> Maybe Placement) ->
|
||||
Placement
|
||||
putDoubleDoorThen eo wl cond soff a b speed cont =
|
||||
doorBetween eo wl cond soff a half speed $
|
||||
\pl1 -> Just $
|
||||
doorBetween eo wl cond soff b half speed $
|
||||
\pl2 -> cont pl1 pl2
|
||||
where
|
||||
half = 0.5 *.* (a +.+ b)
|
||||
|
||||
doorBetween :: EdgeObstacle -> Wall -> WdBl -> Float -> Point2 -> Point2 -> Float ->
|
||||
(Placement -> Maybe Placement) -> Placement
|
||||
doorBetween ::
|
||||
EdgeObstacle ->
|
||||
Wall ->
|
||||
WdBl ->
|
||||
Float ->
|
||||
Point2 ->
|
||||
Point2 ->
|
||||
Float ->
|
||||
(Placement -> Maybe Placement) ->
|
||||
Placement
|
||||
doorBetween eo wl cond soff pa pb speed g = case divideLine 40 pa pb of
|
||||
[x,y] -> ptCont (PutSlideDr adoor wl eo soff x y) g
|
||||
(x:y:zs) -> divideDoorPane Nothing wl cond (soff - dist y pb) speed (zip (x:y:zs) (y:zs)) g
|
||||
[x, y] -> ptCont (PutSlideDr adoor wl eo 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
|
||||
adoor =
|
||||
defaultDoor
|
||||
& drTrigger .~ cond
|
||||
& drSpeed .~ speed
|
||||
|
||||
divideDoorPane :: Maybe Int -> Wall -> WdBl -> Float -> Float
|
||||
-> [(Point2,Point2)] -> (Placement -> Maybe Placement) -> Placement
|
||||
divideDoorPane ::
|
||||
Maybe Int ->
|
||||
Wall ->
|
||||
WdBl ->
|
||||
Float ->
|
||||
Float ->
|
||||
[(Point2, Point2)] ->
|
||||
(Placement -> Maybe Placement) ->
|
||||
Placement
|
||||
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) wl 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 thedoor wl DoorObstacle soff x y
|
||||
thedoor = defaultDoor & drSpeed .~ speed & drTrigger .~ cond
|
||||
& drPushedBy .~ maybe PushesItself PushedBy mid
|
||||
adoor (x, y) = PutSlideDr thedoor wl DoorObstacle 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 AutoDoorObstacle defaultAutoWall
|
||||
(cond az bz) a b 3
|
||||
putAutoDoor a b = PlacementUsingPos (addZ 0 a) $
|
||||
\az -> PlacementUsingPos (addZ 0 b) $
|
||||
\bz ->
|
||||
putDoubleDoor
|
||||
AutoDoorObstacle
|
||||
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 = WdBlCrFilterNearPoint 40 (0.5 *.* (stripZ az +.+ stripZ bz)) CrIsAnimate
|
||||
-- any (crNearPoint 40 (0.5 *.* (stripZ az +.+ stripZ bz)))
|
||||
-- . IM.filter isAnimate . _creatures
|
||||
|
||||
-- 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)
|
||||
switchDoor btpos btrot dra drb col = pContID
|
||||
(PS btpos btrot)
|
||||
(PutButton $ makeSwitch col red NoWorldEffect NoWorldEffect)
|
||||
$ \btid -> jsps0J (doorbetween btid dra drc)
|
||||
$ sps0 (doorbetween btid drb drc)
|
||||
$ \btid ->
|
||||
jsps0J (doorbetween btid dra drc) $
|
||||
sps0 (doorbetween btid drb drc)
|
||||
where
|
||||
doorbetween btid a b = PutSlideDr thedoor (switchWallCol col) DoorObstacle 1 a b
|
||||
where
|
||||
thedoor = defaultDoor
|
||||
& drTrigger .~ WdBlBtOn btid
|
||||
& drSpeed .~ 2
|
||||
thedoor =
|
||||
defaultDoor
|
||||
& drTrigger .~ WdBlBtOn btid
|
||||
& drSpeed .~ 2
|
||||
drc = 0.5 *.* (dra +.+ drb)
|
||||
--cond btid w' = _btState (_buttons w' IM.! btid) == BtOn
|
||||
|
||||
--cond btid w' = _btState (_buttons w' IM.! btid) == BtOn
|
||||
|
||||
@@ -1,58 +1,70 @@
|
||||
module Dodge.Placement.Instance.LightSource where
|
||||
import Dodge.Data
|
||||
import Dodge.LightSource
|
||||
|
||||
import Color
|
||||
import Control.Lens
|
||||
import Data.Maybe
|
||||
import Dodge.Creature.Inanimate
|
||||
import Dodge.Data.GenWorld
|
||||
import Dodge.Default
|
||||
import Dodge.LevelGen.Data
|
||||
import Dodge.LightSource
|
||||
import Dodge.Room.Foreground
|
||||
import Geometry
|
||||
--import Geometry.Vector3D
|
||||
import Dodge.Creature.Inanimate
|
||||
import Shape.Data
|
||||
import Dodge.Default
|
||||
import RandomHelp
|
||||
import Color
|
||||
import Shape
|
||||
import ShapePicture
|
||||
|
||||
import Control.Lens
|
||||
import Data.Maybe
|
||||
propLSThen ::
|
||||
PropUpdate ->
|
||||
PrWdLsLs -> --(Prop -> World -> LightSource -> LightSource)
|
||||
LightSource ->
|
||||
Prop ->
|
||||
-- | continuation, access to ls and prop placements
|
||||
(Placement -> Placement -> Maybe Placement) ->
|
||||
Placement
|
||||
propLSThen propf lsf ls prop cont = pt0 (PutLS ls) $
|
||||
\lspl ->
|
||||
Just $
|
||||
pt0 (PutProp $ prop & prUpdate .~ PropUpdates [propf, PropUpdateLS (fromJust $ _plMID lspl) lsf]) $
|
||||
cont lspl
|
||||
|
||||
propLSThen :: PropUpdate
|
||||
-> PrWdLsLs --(Prop -> World -> LightSource -> LightSource)
|
||||
-> LightSource
|
||||
-> Prop
|
||||
-> (Placement -> Placement -> Maybe Placement) -- ^ continuation, access to ls and prop placements
|
||||
-> Placement
|
||||
propLSThen propf lsf ls prop cont = pt0 (PutLS ls)
|
||||
$ \lspl -> Just $ pt0 (PutProp $ prop & prUpdate .~ PropUpdates [propf,PropUpdateLS (fromJust $ _plMID lspl) lsf])
|
||||
$ cont lspl
|
||||
moveLSThen ::
|
||||
WdP2f -> --(World -> (Point2,Float))
|
||||
|
||||
moveLSThen :: WdP2f --(World -> (Point2,Float))
|
||||
-> Point3 -- ^ light source offset
|
||||
-> Shape
|
||||
-> (Placement -> Placement -> Maybe Placement)
|
||||
-> Placement
|
||||
-- | light source offset
|
||||
Point3 ->
|
||||
Shape ->
|
||||
(Placement -> Placement -> Maybe Placement) ->
|
||||
Placement
|
||||
moveLSThen posf off sh = propLSThen (PropUpdatePosition posf) (PrWdLsSetPosition posf off) thels theprop
|
||||
where
|
||||
--lsupdate _ w = lsParam . lsPos .~ addZ 0 (fst (posf w)) +.+.+ rotate3z (snd (posf w)) off
|
||||
thels = defaultLS
|
||||
theprop = ShapeProp
|
||||
{ _prPos = 0
|
||||
, _prID = 0
|
||||
, _prRot = 0
|
||||
, _prUpdate = PropUpdateId
|
||||
--, _prDraw = PropDrawSPic $ noPic $ uncurryV translateSHf (_prPos pr) $ rotateSH (_pjRot pr) sh
|
||||
, _prDraw = PropDrawFlatTranslate $ PropDrawSPic $ noPic sh
|
||||
, _prToggle = True
|
||||
}
|
||||
|
||||
theprop =
|
||||
ShapeProp
|
||||
{ _prPos = 0
|
||||
, _prID = 0
|
||||
, _prRot = 0
|
||||
, _prUpdate = PropUpdateId
|
||||
, --, _prDraw = PropDrawSPic $ noPic $ uncurryV translateSHf (_prPos pr) $ rotateSH (_pjRot pr) sh
|
||||
_prDraw = PropDrawFlatTranslate $ PropDrawSPic $ noPic sh
|
||||
, _prToggle = True
|
||||
}
|
||||
|
||||
-- | 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 (putShape . setCol $ shapeF wallp lsp)
|
||||
. pt0 (PutLS $ ls & lsParam . lsPos .~ lsp')
|
||||
mntLSOn ::
|
||||
-- | function describing the mount shape
|
||||
(Point2 -> Point3 -> Shape) ->
|
||||
-- | describing a possible color override for the shape
|
||||
Maybe Color ->
|
||||
LightSource ->
|
||||
Point2 ->
|
||||
Point3 ->
|
||||
(Placement -> Maybe Placement) ->
|
||||
Placement
|
||||
mntLSOn shapeF mcol ls wallp lsp@(V3 lx ly _) =
|
||||
ps0jPushPS (putShape . setCol $ shapeF wallp lsp)
|
||||
. pt0 (PutLS $ ls & lsParam . lsPos .~ lsp')
|
||||
where
|
||||
lsp' = lsp -.-.- V3 x y 1
|
||||
-- hack! perturb the light position
|
||||
@@ -63,17 +75,19 @@ 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)
|
||||
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
|
||||
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
|
||||
@@ -84,8 +98,8 @@ jShape wallpos (V3 x y z) = thinHighBar z wallposUp turn1
|
||||
|
||||
liShape :: Point2 -> Point3 -> Shape
|
||||
liShape wallpos (V3 x y z) =
|
||||
thinHighBar z wallposUp turnpos
|
||||
<> thinHighBar z turnpos (V2 x y)
|
||||
thinHighBar z wallposUp turnpos
|
||||
<> thinHighBar z turnpos (V2 x y)
|
||||
where
|
||||
n = vNormal (V2 x y -.- wallpos)
|
||||
wallposUp = wallpos +.+ n
|
||||
@@ -93,14 +107,14 @@ liShape wallpos (V3 x y z) =
|
||||
|
||||
aShape :: Point2 -> Point3 -> Shape
|
||||
aShape wallpos (V3 x y z) =
|
||||
girder (z+2) 20 10 pout wallpos
|
||||
girder (z + 2) 20 10 pout wallpos
|
||||
where
|
||||
pout = V2 x y -.- 2 *.* squashNormalizeV (V2 x y -.- wallpos)
|
||||
|
||||
vShape :: Point2 -> Point3 -> Shape
|
||||
vShape wallpos (V3 x y z) =
|
||||
thinHighBar z wallposUp lxy
|
||||
<> thinHighBar z wallposDown lxy
|
||||
<> thinHighBar z wallposDown lxy
|
||||
where
|
||||
lxy = V2 x y
|
||||
n = vNormal (wallpos -.- lxy)
|
||||
@@ -114,52 +128,65 @@ mntLSCol :: (Point2 -> Point3 -> Shape) -> Color -> Point2 -> Point3 -> Placemen
|
||||
mntLSCol shp col wallp lampp = mntLSOn shp (Just col) defaultLS wallp lampp (const Nothing)
|
||||
|
||||
mntLSLampCol :: (Point2 -> Point3 -> Shape) -> Color -> Point2 -> Point3 -> Placement
|
||||
mntLSLampCol shp (V4 x y z _) wallp lampp = mntLSOn shp Nothing (defaultLS & lsParam . lsCol .~ col)
|
||||
wallp lampp (const Nothing)
|
||||
mntLSLampCol shp (V4 x y z _) wallp lampp =
|
||||
mntLSOn
|
||||
shp
|
||||
Nothing
|
||||
(defaultLS & lsParam . lsCol .~ col)
|
||||
wallp
|
||||
lampp
|
||||
(const Nothing)
|
||||
where
|
||||
col = V3 x y z
|
||||
|
||||
mntLSCond :: (Point2 -> Point3 -> Shape)
|
||||
-- -> (RoomPos -> Room -> Maybe (PlacementSpot,RoomPos))
|
||||
-> PlacementSpot
|
||||
-> Placement
|
||||
mntLSCond shp ps = -- updatePSToLevel 1 (const $ PSLnk shift (const id) Nothing) $
|
||||
mntLSCond ::
|
||||
(Point2 -> Point3 -> Shape) ->
|
||||
-- -> (RoomPos -> Room -> Maybe (PlacementSpot,RoomPos))
|
||||
PlacementSpot ->
|
||||
Placement
|
||||
mntLSCond shp ps =
|
||||
-- updatePSToLevel 1 (const $ PSLnk shift (const id) Nothing) $
|
||||
mntLS shp 0 (V3 0 (-20) 95)
|
||||
& plSpot .~ ps
|
||||
-- note that this perhaps pushes the vshape light out too far
|
||||
& plSpot .~ ps
|
||||
|
||||
-- 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]
|
||||
shp <- takeOne [vShape, iShape, lShape, jShape, liShape]
|
||||
return $ mntLS shp a (addZ 90 b)
|
||||
|
||||
mntLightLnkCond :: PlacementSpot -> Placement
|
||||
mntLightLnkCond ps = RandomPlacement $ do
|
||||
shp <- takeOne [vShape,lShape,jShape,liShape]
|
||||
shp <- takeOne [vShape, lShape, jShape, liShape]
|
||||
return $ mntLSCond (fmap (fmap $ colorSH black) shp) ps
|
||||
|
||||
spanLSLightI :: LightSource -> Float -> Point2 -> Point2 -> Placement
|
||||
spanLSLightI ls h a b = ps0j (PutLS $ ls & lsParam . lsPos .~ V3 x y h)
|
||||
$ sps0 $ putShape $ thinHighBar h a b
|
||||
spanLSLightI ls h a b =
|
||||
ps0j (PutLS $ ls & lsParam . lsPos .~ V3 x y h) $
|
||||
sps0 $ putShape $ thinHighBar h a b
|
||||
where
|
||||
V2 x y = 0.5 *.* (a +.+ b)
|
||||
|
||||
spanLS :: LightSource -> Point2 -> Point2 -> Placement
|
||||
spanLS ls a b = Placement 10 (PS (V2 x y) 0) (PutLS ls) Nothing
|
||||
$ const $ const $ Just $ sps0 $ putShape $ thinHighBar h a b
|
||||
spanLS ls a b =
|
||||
Placement 10 (PS (V2 x y) 0) (PutLS ls) Nothing $
|
||||
const $ const $ Just $ sps0 $ putShape $ thinHighBar h a b
|
||||
where
|
||||
V3 _ _ h = _lsPos (_lsParam ls) + 5
|
||||
V2 x y = 0.5 *.* (a +.+ b)
|
||||
|
||||
spanColLightI :: Point3 -> Float -> Point2 -> Point2 -> Placement
|
||||
spanColLightI col h a b = ps0j (PutLS $ lsColPos col (V3 x y (h-5)))
|
||||
$ sps0 $ putShape $ thinHighBar h a b
|
||||
spanColLightI col h a b =
|
||||
ps0j (PutLS $ lsColPos col (V3 x y (h -5))) $
|
||||
sps0 $ putShape $ thinHighBar h a b
|
||||
where
|
||||
V2 x y = 0.5 *.* (a +.+ b)
|
||||
|
||||
spanColLightBlackI :: Point3 -> Float -> Point2 -> Point2 -> Placement
|
||||
spanColLightBlackI col h a b = ps0j (PutLS $ lsColPos col (V3 x y (h-5)))
|
||||
$ sps0 $ putShape $ colorSH black $ thinHighBar h a b
|
||||
spanColLightBlackI col h a b =
|
||||
ps0j (PutLS $ lsColPos col (V3 x y (h -5))) $
|
||||
sps0 $ putShape $ colorSH black $ thinHighBar h a b
|
||||
where
|
||||
V2 x y = 0.5 *.* (a +.+ b)
|
||||
|
||||
|
||||
@@ -1,35 +1,43 @@
|
||||
module Dodge.Placement.Instance.LightSource.Cover where
|
||||
import Dodge.Data
|
||||
import Geometry.Data
|
||||
|
||||
import Dodge.Data.Prop
|
||||
import Dodge.Data.WorldEffect
|
||||
import Dodge.Default.Prop
|
||||
import Geometry.Data
|
||||
|
||||
lampCover :: Float -> Prop
|
||||
lampCover h = ShapeProp
|
||||
{ _prPos = V2 0 0
|
||||
, _prID = 0
|
||||
, _prRot = 0
|
||||
, _prUpdate = PropRotate 0.15
|
||||
, _prDraw = PropLampCover h
|
||||
, _prToggle = True
|
||||
}
|
||||
lampCover h =
|
||||
ShapeProp
|
||||
{ _prPos = V2 0 0
|
||||
, _prID = 0
|
||||
, _prRot = 0
|
||||
, _prUpdate = PropRotate 0.15
|
||||
, _prDraw = PropLampCover h
|
||||
, _prToggle = True
|
||||
}
|
||||
|
||||
lampCoverWhen :: WdBl -> Point2 -> Float -> Prop
|
||||
lampCoverWhen cond pos h = defaultProp
|
||||
{ _prPos = pos
|
||||
, _prUpdate = PropSetToggleAnd cond (PropRotate 0.15)
|
||||
, _prDraw = PropLampCover h
|
||||
, _prToggle = True
|
||||
}
|
||||
lampCoverWhen cond pos h =
|
||||
defaultProp
|
||||
{ _prPos = pos
|
||||
, _prUpdate = PropSetToggleAnd cond (PropRotate 0.15)
|
||||
, _prDraw = PropLampCover h
|
||||
, _prToggle = True
|
||||
}
|
||||
|
||||
doubleLampCover :: Float -> Prop
|
||||
doubleLampCover h = defaultProp
|
||||
{ _prPos = V2 0 0
|
||||
, _prUpdate = PropRotate 0.15
|
||||
, _prDraw = PropDoubleLampCover h
|
||||
}
|
||||
doubleLampCover h =
|
||||
defaultProp
|
||||
{ _prPos = V2 0 0
|
||||
, _prUpdate = PropRotate 0.15
|
||||
, _prDraw = PropDoubleLampCover h
|
||||
}
|
||||
|
||||
-- on the current (27/9/21) version of shadow stencilling, this glitches
|
||||
-- slightly when the shadow rotates towards the screen
|
||||
verticalLampCover :: Float -> Prop
|
||||
verticalLampCover h = defaultProp
|
||||
{ _prUpdate = PropRotate 0.15
|
||||
, _prDraw = PropVerticalLampCover h
|
||||
}
|
||||
verticalLampCover h =
|
||||
defaultProp
|
||||
{ _prUpdate = PropRotate 0.15
|
||||
, _prDraw = PropVerticalLampCover h
|
||||
}
|
||||
|
||||
@@ -1,32 +1,39 @@
|
||||
module Dodge.Placement.Instance.LightSource.Flicker where
|
||||
import Dodge.LevelGen.Data
|
||||
import Dodge.Data
|
||||
import Data.Maybe
|
||||
|
||||
import Control.Lens
|
||||
import Data.Maybe
|
||||
import Dodge.Data.GenWorld
|
||||
import Dodge.LevelGen.Data
|
||||
import System.Random
|
||||
|
||||
-- Supposes the orginal placement is a light source, adds a flicker
|
||||
flickerMod :: Placement -> Maybe Placement
|
||||
flickerMod pl = Just $ sps0 $ PutMod $ ModIDTimerPoint3Bool
|
||||
{ _mdID = 0
|
||||
, _mdExternalID = fromJust $ _plMID pl
|
||||
, _mdUpdate = MdFlickerUpdate
|
||||
, _mdTimer = 10
|
||||
, _mdPoint3 = 0.8
|
||||
, _mdBool = True
|
||||
}
|
||||
flickerMod pl =
|
||||
Just $
|
||||
sps0 $
|
||||
PutMod $
|
||||
ModIDTimerPoint3Bool
|
||||
{ _mdID = 0
|
||||
, _mdExternalID = fromJust $ _plMID pl
|
||||
, _mdUpdate = MdFlickerUpdate
|
||||
, _mdTimer = 10
|
||||
, _mdPoint3 = 0.8
|
||||
, _mdBool = True
|
||||
}
|
||||
|
||||
flickerUpdate :: Modification -> World -> World
|
||||
flickerUpdate md w
|
||||
flickerUpdate md w
|
||||
| _mdTimer md > 0 = w & cWorld . modifications . ix mdid . mdTimer -~ 1
|
||||
| otherwise = w & cWorld . lightSources . ix lsid . lsParam . lsCol .~ mdcol
|
||||
& cWorld . modifications . ix mdid
|
||||
%~ ( (mdTimer .~ newtime) . (mdPoint3 .~ lscol) . (mdBool %~ not) )
|
||||
| otherwise =
|
||||
w & cWorld . lightSources . ix lsid . lsParam . lsCol .~ mdcol
|
||||
& cWorld . modifications . ix mdid
|
||||
%~ ((mdTimer .~ newtime) . (mdPoint3 .~ lscol) . (mdBool %~ not))
|
||||
where
|
||||
mdcol = _mdPoint3 md
|
||||
lscol = w ^?! cWorld . lightSources . ix lsid . lsParam . lsCol -- _lsCol $ _lsParam $ _lightSources w IM.! lsid
|
||||
lsid = _mdExternalID md
|
||||
mdid = _mdID md
|
||||
timerange
|
||||
| _mdBool md = (2,10)
|
||||
| otherwise = (2,30)
|
||||
(newtime,_) = randomR timerange $ _randGen w
|
||||
timerange
|
||||
| _mdBool md = (2, 10)
|
||||
| otherwise = (2, 30)
|
||||
(newtime, _) = randomR timerange $ _randGen w
|
||||
|
||||
@@ -1,48 +1,55 @@
|
||||
module Dodge.Placement.Instance.Sensor
|
||||
( lightSensor
|
||||
, damageSensor
|
||||
, sensorSPic -- this should be moved
|
||||
) where
|
||||
module Dodge.Placement.Instance.Sensor (
|
||||
lightSensor,
|
||||
damageSensor,
|
||||
sensorSPic, -- this should be moved
|
||||
) where
|
||||
|
||||
import Color
|
||||
import Dodge.LightSource
|
||||
import Dodge.Data
|
||||
import Dodge.LevelGen.Data
|
||||
import Control.Lens
|
||||
import qualified Data.Map.Strict as M
|
||||
import Dodge.Data.GenWorld
|
||||
import Dodge.Default
|
||||
import Dodge.LevelGen.Data
|
||||
import Dodge.LightSource
|
||||
import Dodge.Placement.TopDecoration
|
||||
import Geometry
|
||||
import ShapePicture
|
||||
import Shape
|
||||
import ShapePicture
|
||||
|
||||
import qualified Data.Map.Strict as M
|
||||
import Control.Lens
|
||||
damageSensor ::
|
||||
DamageType ->
|
||||
Float ->
|
||||
Maybe Int ->
|
||||
PlacementSpot ->
|
||||
Placement
|
||||
damageSensor dt wdth mtrid ps = pContID ps (PutLS $ lsPosCol (V3 0 0 30) 0.1) $
|
||||
\lsid -> Just $
|
||||
spNoID ps $
|
||||
PutUsingGenParams $
|
||||
\gw ->
|
||||
(,) gw $
|
||||
PutMachine
|
||||
(reverse $ square wdth)
|
||||
( defaultMachine
|
||||
& mcColor .~ yellow
|
||||
& mcMounts . at ObTrigger .~ mtrid
|
||||
& mcMounts . at ObLightSource ?~ lsid
|
||||
& mcDraw .~ MachineDrawDamageSensor wdth (_sensorCoding (_genParams (_cWorld gw)) M.! dt)
|
||||
& mcSensor .~ DamageSensor False 0 dt
|
||||
)
|
||||
defaultSensorWall
|
||||
|
||||
damageSensor
|
||||
:: DamageType
|
||||
-> Float
|
||||
-> Maybe Int
|
||||
-> PlacementSpot
|
||||
-> Placement
|
||||
damageSensor dt wdth mtrid ps = pContID ps (PutLS $ lsPosCol (V3 0 0 30) 0.1)
|
||||
$ \lsid -> Just $ spNoID ps $ PutUsingGenParams
|
||||
$ \gw -> (,) gw $ PutMachine (reverse $ square wdth)
|
||||
(defaultMachine
|
||||
& mcColor .~ yellow
|
||||
& mcMounts . at ObTrigger .~ mtrid
|
||||
& mcMounts . at ObLightSource ?~ lsid
|
||||
& mcDraw .~ MachineDrawDamageSensor wdth (_sensorCoding (_genParams (_cWorld gw)) M.! dt)
|
||||
& mcSensor .~ DamageSensor False 0 dt
|
||||
)
|
||||
defaultSensorWall
|
||||
|
||||
lightSensor :: Float
|
||||
-> Maybe Int
|
||||
-> PlacementSpot
|
||||
-> Placement
|
||||
lightSensor ::
|
||||
Float ->
|
||||
Maybe Int ->
|
||||
PlacementSpot ->
|
||||
Placement
|
||||
lightSensor = damageSensor LASERING
|
||||
|
||||
sensorSPic :: Float -> (PaletteColor,DecorationShape) -> Machine -> SPic
|
||||
sensorSPic wdth (pc,ds) mc = noPic
|
||||
$ colorSH (_mcColor mc) (upperPrismPoly 25 (square wdth))
|
||||
<> decorationToShape ds wdth wdth 25 col col
|
||||
sensorSPic :: Float -> (PaletteColor, DecorationShape) -> Machine -> SPic
|
||||
sensorSPic wdth (pc, ds) mc =
|
||||
noPic $
|
||||
colorSH (_mcColor mc) (upperPrismPoly 25 (square wdth))
|
||||
<> decorationToShape ds wdth wdth 25 col col
|
||||
where
|
||||
col = paletteToColor pc
|
||||
|
||||
@@ -1,47 +1,52 @@
|
||||
module Dodge.Placement.Instance.Tank
|
||||
( tankSquareDec
|
||||
, roundTank
|
||||
, roundTankCross
|
||||
) where
|
||||
import Dodge.Data
|
||||
module Dodge.Placement.Instance.Tank (
|
||||
tankSquareDec,
|
||||
roundTank,
|
||||
roundTankCross,
|
||||
) where
|
||||
|
||||
import Color
|
||||
import Dodge.Data.GenWorld
|
||||
import Dodge.LevelGen.Data
|
||||
import Dodge.Room.Foreground
|
||||
import Dodge.Placement.Instance.Block
|
||||
import Dodge.Room.Foreground
|
||||
import Geometry
|
||||
import Shape
|
||||
import Color
|
||||
--import LensHelp
|
||||
--import Quaternion
|
||||
|
||||
tankSquareDec :: (Float -> Float -> Float -> Color -> Color -> Shape)
|
||||
-> Color -> Color -> Placement
|
||||
tankSquareDec ::
|
||||
(Float -> Float -> Float -> Color -> Color -> Shape) ->
|
||||
Color ->
|
||||
Color ->
|
||||
Placement
|
||||
tankSquareDec dec = tankShape (square 20) (dec 20 20 31)
|
||||
|
||||
tankShape :: [Point2] -> (Color -> Color -> Shape) -> Color -> Color -> Placement
|
||||
tankShape baseshape facade col col' = sps0 $ decoratedBlock (BlShConst $ facade col col') Metal col 31 baseshape
|
||||
|
||||
-- = sps0 $ PutBlock bl wl $ reverse baseshape
|
||||
-- where
|
||||
-- bl = defaultBlock
|
||||
-- & blDraw .~ const (noPic $ colorSH col (upperPrismPoly 31 $ reverse baseshape) <> facade col col')
|
||||
-- & blDeath .~ const id
|
||||
-- wl = defaultWall
|
||||
-- & wlColor .~ col
|
||||
-- & wlRotateTo .~ False
|
||||
-- wl = defaultWall
|
||||
-- & wlColor .~ col
|
||||
-- & wlRotateTo .~ False
|
||||
-- & wlOpacity .~ SeeAbove
|
||||
-- & wlMaterial .~ Metal
|
||||
|
||||
-- = ps0jPushPS
|
||||
-- (PutShape $ colorSH col (upperPrismPoly 31 baseshape) <> facade col col')
|
||||
-- $ sps0 $ PutWall baseshape defaultWall
|
||||
-- $ sps0 $ PutWall baseshape defaultWall
|
||||
-- {_wlUnshadowed = False, _wlColor = col, _wlRotateTo = False, _wlOpacity = SeeAbove}
|
||||
|
||||
roundTank :: Color -> Color -> Placement
|
||||
roundTank = tankShape (polyCirc 4 20)
|
||||
$ \_ c' -> colorSH c' $ foldMap toprail (take 8 [0,pi/4..])
|
||||
roundTank = tankShape (polyCirc 4 20) $
|
||||
\_ c' -> colorSH c' $ foldMap toprail (take 8 [0, pi / 4 ..])
|
||||
where
|
||||
toprail a = rotateSH a $ thinHighBar 31 (V2 0 20) (rotateV (pi/4) $ V2 0 20)
|
||||
toprail a = rotateSH a $ thinHighBar 31 (V2 0 20) (rotateV (pi / 4) $ V2 0 20)
|
||||
|
||||
roundTankCross :: Color -> Color -> Placement
|
||||
roundTankCross = tankShape (polyCirc 4 20)
|
||||
$ \_ c -> colorSH c $ thinHighBar 31 (V2 20 0) (V2 (-20) 0)
|
||||
<> thinHighBar 31 (V2 0 20) (V2 0 (-20))
|
||||
roundTankCross = tankShape (polyCirc 4 20) $
|
||||
\_ c ->
|
||||
colorSH c $
|
||||
thinHighBar 31 (V2 20 0) (V2 (-20) 0)
|
||||
<> thinHighBar 31 (V2 0 20) (V2 0 (-20))
|
||||
|
||||
@@ -1,62 +1,67 @@
|
||||
--{-# LANGUAGE TupleSections #-}
|
||||
module Dodge.Placement.Instance.Terminal
|
||||
( putMessageTerminal
|
||||
, putTerminal
|
||||
-- , simpleTermMessage
|
||||
, terminalColor
|
||||
-- , accessTerminal
|
||||
) where
|
||||
import Dodge.Data
|
||||
import Dodge.LevelGen.Data
|
||||
import Dodge.Default
|
||||
import Dodge.SoundLogic
|
||||
module Dodge.Placement.Instance.Terminal (
|
||||
putMessageTerminal,
|
||||
putTerminal,
|
||||
terminalColor,
|
||||
) where
|
||||
|
||||
import Color
|
||||
import Data.Maybe
|
||||
import Dodge.Data.GenWorld
|
||||
import Dodge.Default
|
||||
import Dodge.LevelGen.Data
|
||||
import Dodge.SoundLogic
|
||||
import Geometry
|
||||
import LensHelp
|
||||
|
||||
import Data.Maybe
|
||||
|
||||
putTerminal :: Machine -> Terminal -> Placement
|
||||
putTerminal mc tm
|
||||
= ps0PushPS (PutTerminal tm)
|
||||
$ \tmpl -> Just $ ps0PushPS (PutButton termButton)
|
||||
$ \btpl -> Just $ pt0
|
||||
(PutMachine (reverse $ square 10)
|
||||
(mc & mcMounts . at ObButton ?~ fromJust (_plMID btpl)
|
||||
& mcCloseSound ?~ fridgeHumS)
|
||||
defaultSensorWall
|
||||
)
|
||||
$ \mcpl -> Just $ sps0 $ PutWorldUpdate $ const (setids tmpl btpl mcpl)
|
||||
putTerminal mc tm =
|
||||
ps0PushPS (PutTerminal tm) $
|
||||
\tmpl -> Just $
|
||||
ps0PushPS (PutButton termButton) $
|
||||
\btpl -> Just $
|
||||
pt0
|
||||
( PutMachine
|
||||
(reverse $ square 10)
|
||||
( mc & mcMounts . at ObButton ?~ fromJust (_plMID btpl)
|
||||
& mcCloseSound ?~ fridgeHumS
|
||||
)
|
||||
defaultSensorWall
|
||||
)
|
||||
$ \mcpl -> Just $ sps0 $ PutWorldUpdate $ const (setids tmpl btpl mcpl)
|
||||
where
|
||||
setids tmpl btpl mcpl w = w
|
||||
& cWorld . terminals . ix tmid . tmButtonID .~ btid
|
||||
& cWorld . terminals . ix tmid . tmMachineID .~ mcid
|
||||
& cWorld . machines . ix mcid . mcMounts . at ObTerminal ?~ tmid
|
||||
& cWorld . buttons . ix btid . btTermMID ?~ tmid
|
||||
setids tmpl btpl mcpl w =
|
||||
w
|
||||
& cWorld . terminals . ix tmid . tmButtonID .~ btid
|
||||
& cWorld . terminals . ix tmid . tmMachineID .~ mcid
|
||||
& cWorld . machines . ix mcid . mcMounts . at ObTerminal ?~ tmid
|
||||
& cWorld . buttons . ix btid . btTermMID ?~ tmid
|
||||
where
|
||||
tmid = fromJust (_plMID tmpl)
|
||||
btid = fromJust (_plMID btpl)
|
||||
mcid = fromJust (_plMID mcpl)
|
||||
|
||||
putMessageTerminal :: Color -> Terminal -> Placement
|
||||
putMessageTerminal col = putTerminal $ defaultMachine
|
||||
& mcColor .~ col
|
||||
& mcDraw .~ MachineDrawTerminal --terminalSPic
|
||||
& mcHP .~ 100
|
||||
putMessageTerminal col =
|
||||
putTerminal $
|
||||
defaultMachine
|
||||
& mcColor .~ col
|
||||
& mcDraw .~ MachineDrawTerminal --terminalSPic
|
||||
& mcHP .~ 100
|
||||
|
||||
termButton :: Button
|
||||
termButton = Button
|
||||
{ _btPict = DrawNoButton
|
||||
, _btPos = 0
|
||||
, _btRot = 0
|
||||
, _btEvent = ButtonAccessTerminal
|
||||
, _btID = 0
|
||||
, _btText = "TERMINAL"
|
||||
, _btState = BtOff
|
||||
, _btTermMID = Nothing
|
||||
, _btName = ""
|
||||
, _btColor = dark magenta
|
||||
}
|
||||
termButton =
|
||||
Button
|
||||
{ _btPict = DrawNoButton
|
||||
, _btPos = 0
|
||||
, _btRot = 0
|
||||
, _btEvent = ButtonAccessTerminal
|
||||
, _btID = 0
|
||||
, _btText = "TERMINAL"
|
||||
, _btState = BtOff
|
||||
, _btTermMID = Nothing
|
||||
, _btName = ""
|
||||
, _btColor = dark magenta
|
||||
}
|
||||
|
||||
terminalColor :: Color
|
||||
terminalColor = dark magenta
|
||||
|
||||
@@ -1,87 +1,99 @@
|
||||
module Dodge.Placement.Instance.Turret where
|
||||
import Color
|
||||
import Dodge.Data
|
||||
import Dodge.LevelGen.Data
|
||||
import Dodge.Default
|
||||
import Dodge.Movement.Turn
|
||||
import Dodge.FloorItem
|
||||
import Dodge.Wall.Delete
|
||||
import Dodge.WorldEvent.Explosion
|
||||
import Dodge.Item.Weapon.BatteryGuns
|
||||
import Geometry
|
||||
import ShapePicture
|
||||
import Shape
|
||||
import Dodge.Base
|
||||
import LensHelp
|
||||
import qualified IntMapHelp as IM
|
||||
|
||||
import Dodge.Item.Held.BatteryGuns
|
||||
import Color
|
||||
import Data.List
|
||||
import Data.Maybe
|
||||
import Dodge.Base
|
||||
import Dodge.Data.GenWorld
|
||||
import Dodge.Default
|
||||
import Dodge.FloorItem
|
||||
import Dodge.LevelGen.Data
|
||||
import Dodge.Movement.Turn
|
||||
import Dodge.Wall.Delete
|
||||
import Dodge.WorldEvent.Explosion
|
||||
import Geometry
|
||||
import qualified IntMapHelp as IM
|
||||
import LensHelp
|
||||
import Shape
|
||||
import ShapePicture
|
||||
|
||||
putLasTurret :: Float -> Placement
|
||||
putLasTurret rotSpeed = sps0 $ PutMachine (reverse $ square wdth)
|
||||
(defaultMachine
|
||||
& mcColor .~ blue
|
||||
& mcDraw .~ MachineDrawTurret
|
||||
& mcType .~ (lasTurret & tuTurnSpeed .~ rotSpeed)
|
||||
& mcHP .~ 50000
|
||||
)
|
||||
defaultMachineWall
|
||||
putLasTurret rotSpeed =
|
||||
sps0 $
|
||||
PutMachine
|
||||
(reverse $ square wdth)
|
||||
( defaultMachine
|
||||
& mcColor .~ blue
|
||||
& mcDraw .~ MachineDrawTurret
|
||||
& mcType .~ (lasTurret & tuTurnSpeed .~ rotSpeed)
|
||||
& mcHP .~ 50000
|
||||
)
|
||||
defaultMachineWall
|
||||
|
||||
lasTurret :: MachineType
|
||||
lasTurret = Turret
|
||||
{ _tuWeapon = lasGun
|
||||
-- { _tuWeapon = autoRifle
|
||||
, _tuTurnSpeed = 0.1
|
||||
, _tuFireTime = 0
|
||||
, _tuMCrID = Nothing
|
||||
}
|
||||
lasTurret =
|
||||
Turret
|
||||
{ _tuWeapon = lasGun
|
||||
, -- { _tuWeapon = autoRifle
|
||||
_tuTurnSpeed = 0.1
|
||||
, _tuFireTime = 0
|
||||
, _tuMCrID = Nothing
|
||||
}
|
||||
|
||||
-- this needs a major cleanup
|
||||
updateTurret :: Float -> Machine -> World -> World
|
||||
updateTurret rotSpeed mc w
|
||||
| _mcHP mc < 1 = w & cWorld . machines %~ IM.delete mcid
|
||||
& deleteWallIDs (_mcWallIDs mc)
|
||||
& makeExplosionAt mcpos
|
||||
& copyItemToFloor mcpos lasGun
|
||||
& deleteHomonculus
|
||||
| otherwise = w
|
||||
& initHomonculus
|
||||
& dodamage
|
||||
& maybeFire
|
||||
& elecDamBranch
|
||||
updateTurret rotSpeed mc w
|
||||
| _mcHP mc < 1 =
|
||||
w & cWorld . machines %~ IM.delete mcid
|
||||
& deleteWallIDs (_mcWallIDs mc)
|
||||
& makeExplosionAt mcpos
|
||||
& copyItemToFloor mcpos lasGun
|
||||
& deleteHomonculus
|
||||
| otherwise =
|
||||
w
|
||||
& initHomonculus
|
||||
& dodamage
|
||||
& maybeFire
|
||||
& elecDamBranch
|
||||
where
|
||||
deleteHomonculus = case _tuMCrID (_mcType mc) of
|
||||
Nothing -> id
|
||||
Just cid -> cWorld . creatures . at cid .~ Nothing
|
||||
initHomonculus w' = case w' ^? cWorld . machines . ix mcid . mcType . tuMCrID . _Just of
|
||||
Nothing -> w' & cWorld . machines . ix mcid . mcType . tuMCrID ?~ cid
|
||||
& cWorld . creatures . at cid ?~ thecreature
|
||||
Nothing ->
|
||||
w' & cWorld . machines . ix mcid . mcType . tuMCrID ?~ cid
|
||||
& cWorld . creatures . at cid ?~ thecreature
|
||||
where
|
||||
cid = IM.newKey (_creatures (_cWorld w'))
|
||||
thecreature = defaultCreature
|
||||
& crID .~ cid
|
||||
& crInv . at 0 ?~ (_tuWeapon (_mcType mc) & itUse . useAim . aimHandlePos -~ 10
|
||||
& itUse . heldConsumption . laLoaded .~ 1
|
||||
)
|
||||
& crPos .~ mcpos
|
||||
& crOldPos .~ mcpos
|
||||
& crRad .~ 1
|
||||
& crDir .~ mcdir
|
||||
& crStance . posture .~ Aiming
|
||||
& crMaterial .~ Crystal
|
||||
Just cid -> w'
|
||||
& cWorld . creatures . ix cid . crPos .~ mcpos
|
||||
& cWorld . creatures . ix cid . crDir .~ mcdir
|
||||
dodamage = cWorld . machines . ix mcid %~
|
||||
( (mcDamage .~ [Damage ELECTRICAL (min 2500 $ max 0 (elecDam - 10)) 0 0 0 NoDamageEffect])
|
||||
. (mcHP -~ dam)
|
||||
)
|
||||
thecreature =
|
||||
defaultCreature
|
||||
& crID .~ cid
|
||||
& crInv . at 0
|
||||
?~ ( _tuWeapon (_mcType mc) & itUse . heldAim . aimHandlePos -~ 10
|
||||
& itUse . heldConsumption . laLoaded .~ 1
|
||||
)
|
||||
& crPos .~ mcpos
|
||||
& crOldPos .~ mcpos
|
||||
& crRad .~ 1
|
||||
& crDir .~ mcdir
|
||||
& crStance . posture .~ Aiming
|
||||
& crMaterial .~ Crystal
|
||||
Just cid ->
|
||||
w'
|
||||
& cWorld . creatures . ix cid . crPos .~ mcpos
|
||||
& cWorld . creatures . ix cid . crDir .~ mcdir
|
||||
dodamage =
|
||||
cWorld . machines . ix mcid
|
||||
%~ ( (mcDamage .~ [Damage ELECTRICAL (min 2500 $ max 0 (elecDam - 10)) 0 0 0 NoDamageEffect])
|
||||
. (mcHP -~ dam)
|
||||
)
|
||||
elecDamBranch
|
||||
| elecDam < 10 = updateFiringStatus . doTurn
|
||||
| otherwise = id
|
||||
maybeFire
|
||||
| _tuFireTime (_mcType mc) > 0
|
||||
= fromMaybe id $ do
|
||||
| _tuFireTime (_mcType mc) > 0 =
|
||||
fromMaybe id $ do
|
||||
cid <- _tuMCrID (_mcType mc)
|
||||
return $ cWorld . creatures . ix cid . crActionPlan . apImpulse .~ [UseItem]
|
||||
| otherwise = id
|
||||
@@ -93,19 +105,20 @@ updateTurret rotSpeed mc w
|
||||
(elecDams, dams) = partition isElectrical $ _mcDamage mc
|
||||
dam = sum $ map _dmAmount dams
|
||||
elecDam = sum $ map _dmAmount elecDams
|
||||
doTurn
|
||||
doTurn
|
||||
| seesYou = cWorld . machines . ix mcid . mcDir %~ turnTo rotSpeed mcpos ypos
|
||||
| otherwise = id
|
||||
closeFireAngle = seesYou -- && angleVV (ypos -.- mcpos) (unitVectorAtAngle mcdir) < 1
|
||||
updateFiringStatus
|
||||
updateFiringStatus
|
||||
| closeFireAngle = cWorld . machines . ix mcid . mcType . tuFireTime .~ 20
|
||||
| otherwise = cWorld . machines . ix mcid . mcType . tuFireTime %~ (max 0 . subtract 1)
|
||||
|
||||
| otherwise = cWorld . machines . ix mcid . mcType . tuFireTime %~ (max 0 . subtract 1)
|
||||
|
||||
drawTurret :: Machine -> SPic
|
||||
drawTurret mc = (rotateSH (-_mcDir mc) . colorSH (_mcColor mc) $ upperPrismPoly 20 (square wdth)
|
||||
drawTurret mc =
|
||||
( rotateSH (- _mcDir mc) . colorSH (_mcColor mc) $ upperPrismPoly 20 (square wdth)
|
||||
, mempty -- setLayer 5 $ scale 0.5 0.5 $ text $ show $ _mcDir mc )
|
||||
)
|
||||
|
||||
-- <> translateSPz 20 (itSPic it)
|
||||
-- where
|
||||
-- it = _tuWeapon $ _mcType mc
|
||||
|
||||
@@ -1,38 +1,40 @@
|
||||
module Dodge.Placement.Instance.Wall
|
||||
where
|
||||
import Dodge.Data
|
||||
import Dodge.Placement.Instance.Block
|
||||
import Dodge.Default.Block
|
||||
--import Dodge.Block.Debris
|
||||
import Dodge.LevelGen.Data
|
||||
import Dodge.Default.Wall
|
||||
import Geometry
|
||||
import Color
|
||||
module Dodge.Placement.Instance.Wall where
|
||||
|
||||
import Data.List
|
||||
import Color
|
||||
import Control.Lens
|
||||
import Data.List
|
||||
import Dodge.Data.GenWorld
|
||||
import Dodge.Default.Block
|
||||
import Dodge.Default.Wall
|
||||
import Dodge.LevelGen.Data
|
||||
import Dodge.Placement.Instance.Block
|
||||
import Geometry
|
||||
|
||||
heightWallPS :: PlacementSpot -> Float -> [Point2] -> Placement
|
||||
heightWallPS spot h ps = spNoID spot $ lowBlock Stone (_wlColor defaultWall) h ps
|
||||
|
||||
invisibleWall :: [Point2] -> Placement
|
||||
invisibleWall ps = sps0 $ PutWall ps $ defaultWall
|
||||
{ _wlOpacity = SeeAbove
|
||||
, _wlUnshadowed = False
|
||||
, _wlHeight = 0
|
||||
, _wlTouchThrough = True
|
||||
}
|
||||
invisibleWall ps =
|
||||
sps0 $
|
||||
PutWall ps $
|
||||
defaultWall
|
||||
{ _wlOpacity = SeeAbove
|
||||
, _wlUnshadowed = False
|
||||
, _wlHeight = 0
|
||||
, _wlTouchThrough = True
|
||||
}
|
||||
|
||||
midWall :: [Point2] -> Placement
|
||||
midWall = heightWallPS (PS 0 0) 50
|
||||
|
||||
singleBlock :: Point2 -> [Placement]
|
||||
singleBlock a =
|
||||
[sPS a 0
|
||||
$ PutBlock defaultBlock baseBlockPane
|
||||
$ reverse
|
||||
$ square 10
|
||||
singleBlock a =
|
||||
[ sPS a 0 $
|
||||
PutBlock defaultBlock baseBlockPane $
|
||||
reverse $
|
||||
square 10
|
||||
]
|
||||
|
||||
{-
|
||||
Places a line of blocks between two points.
|
||||
-}
|
||||
@@ -45,15 +47,17 @@ Width 8, also extends out from each point by 8.
|
||||
-}
|
||||
windowLine :: Point2 -> Point2 -> Placement
|
||||
windowLine a b = sps0 $ PutLineBlock defaultWindow 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 $ PutLineBlock defaultCrystalWall 7 a b
|
||||
|
||||
--crystalLine a b = sps0 $ PutWall ps defaultCrystalWall
|
||||
-- where
|
||||
-- ps =
|
||||
-- ps =
|
||||
-- [ a +.+ left +.+ up
|
||||
-- , (a +.+ left) -.- up
|
||||
-- , (b -.- left) -.- up
|
||||
@@ -67,63 +71,74 @@ 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
|
||||
ps =
|
||||
[ a +.+ up
|
||||
, a -.- up
|
||||
, b -.- up
|
||||
, b +.+ up
|
||||
]
|
||||
left = 15 *.* normalizeV (a-.-b)
|
||||
up = vNormal left
|
||||
left = 15 *.* normalizeV (a -.- b)
|
||||
up = vNormal left
|
||||
|
||||
windowLineType :: Point2 -> Point2 -> PSType
|
||||
windowLineType = PutLineBlock defaultWindow 8
|
||||
|
||||
baseBlockPane :: Wall
|
||||
baseBlockPane = defaultWall
|
||||
{ _wlLine = (V2 0 0,V2 50 0)
|
||||
, _wlID = 0
|
||||
, _wlColor = greyN 0.5
|
||||
, _wlSeen = False
|
||||
, _wlOpacity = Opaque
|
||||
, _wlUnshadowed = True
|
||||
, _wlFireThrough = True
|
||||
, _wlPenetrable = True
|
||||
}
|
||||
baseBlockPane =
|
||||
defaultWall
|
||||
{ _wlLine = (V2 0 0, V2 50 0)
|
||||
, _wlID = 0
|
||||
, _wlColor = greyN 0.5
|
||||
, _wlSeen = False
|
||||
, _wlOpacity = Opaque
|
||||
, _wlUnshadowed = True
|
||||
, _wlFireThrough = True
|
||||
, _wlPenetrable = 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 ::
|
||||
-- | The id of 'PutID' to be replaced
|
||||
Int ->
|
||||
-- | List of replacements
|
||||
[PSType] ->
|
||||
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
|
||||
|
||||
{- 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 ::
|
||||
-- | Filter: elements to apply zip to
|
||||
(a -> Bool) ->
|
||||
-- | Combining function
|
||||
(a -> b -> a) ->
|
||||
-- | List to be partitioned
|
||||
[a] ->
|
||||
-- | Modifying list
|
||||
[b] ->
|
||||
[a]
|
||||
subZipWith f g xs ys =
|
||||
let (zs,ws) = partition f xs
|
||||
in zipWith g zs ys ++ ws
|
||||
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 -> Placement
|
||||
putBlockRect' w h = ps0jPushPS (aline tl tr)
|
||||
$ ps0jPushPS (aline tr br)
|
||||
$ ps0jPushPS (aline br bl)
|
||||
$ sps0 (aline bl tl)
|
||||
putBlockRect' w h =
|
||||
ps0jPushPS (aline tl tr) $
|
||||
ps0jPushPS (aline tr br) $
|
||||
ps0jPushPS (aline br bl) $
|
||||
sps0 (aline bl tl)
|
||||
where
|
||||
tl = V2 (-w) h
|
||||
tl = V2 (- w) h
|
||||
tr = V2 w h
|
||||
br = V2 w (-h)
|
||||
bl = V2 (-w) (-h)
|
||||
br = V2 w (- h)
|
||||
bl = V2 (- w) (- h)
|
||||
aline = PutLineBlock baseBlockPane 9
|
||||
|
||||
putBlockRect :: Float -> Float -> Float -> Float -> [Placement]
|
||||
@@ -133,19 +148,22 @@ putBlockRect a x b 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 =
|
||||
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 =
|
||||
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 =
|
||||
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)
|
||||
|
||||
+124
-108
@@ -1,39 +1,37 @@
|
||||
{-# 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
|
||||
( placeSpot
|
||||
) where
|
||||
import Dodge.Placement.Shift
|
||||
import Dodge.Data
|
||||
--import Dodge.Path
|
||||
{- | deals with placement of objects within the world
|
||||
after they have had their coordinates set by the layout
|
||||
-}
|
||||
module Dodge.Placement.PlaceSpot (
|
||||
placeSpot,
|
||||
) where
|
||||
|
||||
import Color
|
||||
import Control.Lens
|
||||
import Control.Monad.State
|
||||
import Data.Bifunctor
|
||||
import Data.Foldable
|
||||
import qualified Data.IntSet as IS
|
||||
import Data.Maybe
|
||||
import Dodge.Base.NewID
|
||||
import Dodge.Data.GenWorld
|
||||
import Dodge.Path
|
||||
import Dodge.Placement.PlaceSpot.Block
|
||||
import Dodge.Placement.PlaceSpot.TriggerDoor
|
||||
import Dodge.Path
|
||||
import Dodge.Placement.Shift
|
||||
import Dodge.ShiftPoint
|
||||
import Dodge.Base.NewID
|
||||
import Geometry
|
||||
import qualified IntMapHelp as IM
|
||||
import Color
|
||||
import Picture
|
||||
|
||||
import Data.Foldable
|
||||
import Data.Maybe
|
||||
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 :: (GenWorld,Room) -> Placement -> ( (GenWorld,Room), [Placement] )
|
||||
placeSpot (w,rm) plmnt = case plmnt of
|
||||
placeSpot :: (GenWorld, Room) -> Placement -> ((GenWorld, Room), [Placement])
|
||||
placeSpot (w, rm) plmnt = case plmnt of
|
||||
Placement{_plSpot = PSRoomRand i f} -> placeSpotRoomRand rm i f plmnt w
|
||||
Placement{_plSpot = PSPos extract eff fallback} -> placeSpotUsingLink w rm plmnt extract eff fallback
|
||||
Placement{} -> placePlainPSSpot w rm plmnt shift
|
||||
PlacementUsingPos p subpl -> placeSpot (w,rm) (subpl (shiftPoint3By shift p))
|
||||
PlacementUsingPos p subpl -> placeSpot (w, rm) (subpl (shiftPoint3By shift p))
|
||||
RandomPlacement rplmnt -> placeRandomPlacement rplmnt w rm
|
||||
PickOnePlacement i pl -> ((placePickOne i pl rm w, rm), [])
|
||||
where
|
||||
@@ -42,162 +40,180 @@ placeSpot (w,rm) plmnt = case plmnt of
|
||||
placePickOne :: Int -> Placement -> Room -> GenWorld -> GenWorld
|
||||
placePickOne i pl rm w = w & genPlacements %~ IM.insertWith (++) i [(pl, fromJust (_rmMID rm))]
|
||||
|
||||
placeRandomPlacement :: State StdGen Placement -> GenWorld -> Room -> ((GenWorld,Room),[Placement])
|
||||
placeRandomPlacement rplmnt w rm = placeSpot (w & gwWorld . randGen .~ g,rm) plmnt'
|
||||
placeRandomPlacement :: State StdGen Placement -> GenWorld -> Room -> ((GenWorld, Room), [Placement])
|
||||
placeRandomPlacement rplmnt w rm = placeSpot (w & gwWorld . randGen .~ g, rm) plmnt'
|
||||
where
|
||||
(plmnt', g) = runState rplmnt (_randGen (_gwWorld w))
|
||||
|
||||
placePlainPSSpot :: GenWorld -> Room -> Placement -> DPoint2 -> ((GenWorld,Room),[Placement])
|
||||
placePlainPSSpot w rm plmnt shift =
|
||||
let (i,w') = placeSpotID (shiftPSBy shift (_plSpot plmnt)) (_plType plmnt) w
|
||||
placePlainPSSpot :: GenWorld -> Room -> Placement -> DPoint2 -> ((GenWorld, Room), [Placement])
|
||||
placePlainPSSpot w rm plmnt shift =
|
||||
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 (_gwWorld w') newplmnt)
|
||||
in maybe ((w', rm), [newplmnt]) (recrPlace newplmnt w') (_plIDCont plmnt (_gwWorld w') newplmnt)
|
||||
where
|
||||
recrPlace newplmnt w' pl = let (wr,newplmnts) = placeSpot (w',rm) pl
|
||||
in (wr,newplmnt:newplmnts)
|
||||
recrPlace newplmnt w' pl =
|
||||
let (wr, newplmnts) = placeSpot (w', rm) pl
|
||||
in (wr, newplmnt : newplmnts)
|
||||
|
||||
-- this should be tidied up
|
||||
placeSpotUsingLink :: GenWorld
|
||||
-> Room
|
||||
-> Placement
|
||||
-> (RoomPos -> Room -> Maybe (PlacementSpot,RoomPos))
|
||||
-> (RoomPos -> Room -> Room)
|
||||
-> Maybe Placement
|
||||
-> ((GenWorld, Room), [Placement])
|
||||
placeSpotUsingLink ::
|
||||
GenWorld ->
|
||||
Room ->
|
||||
Placement ->
|
||||
(RoomPos -> Room -> Maybe (PlacementSpot, RoomPos)) ->
|
||||
(RoomPos -> Room -> Room) ->
|
||||
Maybe Placement ->
|
||||
((GenWorld, Room), [Placement])
|
||||
placeSpotUsingLink w rm plmnt extract eff fallback = case searchedPoss (_rmPos rm) of
|
||||
Just (ps,rmposs) -> placeSpot (w, eff (head rmposs) $ rm & rmPos .~ rmposs) (plmnt & plSpot .~ ps)
|
||||
Just (ps, rmposs) -> placeSpot (w, eff (head rmposs) $ rm & rmPos .~ rmposs) (plmnt & plSpot .~ ps)
|
||||
Nothing -> case fallback of
|
||||
Nothing -> ((w,rm),[plmnt])
|
||||
Just plmnt' -> placeSpot (w,rm) plmnt'
|
||||
Nothing -> ((w, rm), [plmnt])
|
||||
Just plmnt' -> placeSpot (w, rm) plmnt'
|
||||
where
|
||||
searchedPoss [] = Nothing
|
||||
searchedPoss (pos:poss) = case extract pos rm of
|
||||
Nothing -> second (pos:) <$> searchedPoss poss
|
||||
Just (ps,rmpos) -> Just ( ps,rmpos:poss)
|
||||
searchedPoss (pos : poss) = case extract pos rm of
|
||||
Nothing -> second (pos :) <$> searchedPoss poss
|
||||
Just (ps, rmpos) -> Just (ps, rmpos : poss)
|
||||
|
||||
placeSpotRoomRand :: Room -> Int -> (DPoint2 -> PlacementSpot)
|
||||
-> Placement -> GenWorld -> ((GenWorld,Room),[Placement])
|
||||
placeSpotRoomRand ::
|
||||
Room ->
|
||||
Int ->
|
||||
(DPoint2 -> PlacementSpot) ->
|
||||
Placement ->
|
||||
GenWorld ->
|
||||
((GenWorld, Room), [Placement])
|
||||
placeSpotRoomRand rm i f plmnt w =
|
||||
let (ps,g) = runState (_rmRandPSs rm !! i) $_randGen (_gwWorld w)
|
||||
in placeSpot (w & gwWorld . randGen .~ g,rm) (plmnt & plSpot .~ f ps)
|
||||
let (ps, g) = runState (_rmRandPSs rm !! i) $_randGen (_gwWorld w)
|
||||
in placeSpot (w & gwWorld . randGen .~ g, rm) (plmnt & plSpot .~ f ps)
|
||||
|
||||
placeSpotID :: PlacementSpot -> PSType -> GenWorld -> (Int, GenWorld)
|
||||
placeSpotID ps pt gw = let (i,w) = placeSpotID' ps pt (_gwWorld gw)
|
||||
in (i,gw & gwWorld .~ w)
|
||||
placeSpotID ps pt gw =
|
||||
let (i, w) = placeSpotID' ps pt (_gwWorld gw)
|
||||
in (i, gw & gwWorld .~ w)
|
||||
|
||||
-- the Int here is some id that is assigned when the placement is placed
|
||||
placeSpotID' :: PlacementSpot -> PSType -> World -> (Int, World)
|
||||
placeSpotID' ps pt w = case pt of
|
||||
PutTrigger cnd -> plNewID (cWorld . triggers) cnd w
|
||||
PutMod mdi -> plNewUpID (cWorld . modifications) mdID mdi w
|
||||
PutProp prp -> plNewUpID (cWorld . props) prID (mvProp p rot prp) w
|
||||
PutButton bt -> plNewUpID (cWorld . buttons) btID (mvButton p rot bt) w
|
||||
PutTerminal tm -> plNewUpID (cWorld . terminals) tmID tm w
|
||||
PutFlIt itm -> plNewUpID (cWorld . floorItems) flItID (createFlIt p rot itm) w
|
||||
PutCrit cr -> plNewUpID (cWorld . creatures) crID (mvCr p rot cr) w
|
||||
PutForeground fs -> plNewUpID (cWorld . foregroundShapes) fsID (mvFS p rot fs) w
|
||||
PutDecoration pic -> plNewID (cWorld . decorations) (shiftDec p rot pic) w
|
||||
PutMachine pps mc wl -> plMachine (map doShift pps) mc wl p rot w
|
||||
PutLS ls -> plNewUpID (cWorld . lightSources) lsID (mvLS p' rot ls) w
|
||||
PutPPlate pp -> plNewUpID (cWorld . pressPlates) ppID (mvPP p rot pp) w
|
||||
RandPS rgn -> evaluateRandPS rgn ps w
|
||||
PutDoor col eo f pss -> plDoor col eo f (map (bimap doShift doShift) pss) w
|
||||
PutCoord cp -> plNewID (cWorld . coordinates) (doShift cp) w
|
||||
PutSlideDr wl dr eo off a b
|
||||
-> plSlideDoor wl dr eo off (doShift a) (doShift b) w
|
||||
PutBlock bl wl ps' -> plBlock (map doShift ps') (bl & blPos %~ doShift & blDir .~ rot)
|
||||
wl w
|
||||
PutLineBlock wl wdth a b -> plLineBlock wl wdth (doShift a) (doShift b) w
|
||||
PutWall qs wl -> (0,placeWallPoly (map doShift qs) wl w)
|
||||
PutNothing -> (0,w)
|
||||
PutID i -> (i, w)
|
||||
PutWorldUpdate f -> (0, w & f ps)
|
||||
PutUsingGenParams f -> let (w',pt') = f w
|
||||
in placeSpotID' ps pt' w'
|
||||
where
|
||||
PutTrigger cnd -> plNewID (cWorld . triggers) cnd w
|
||||
PutMod mdi -> plNewUpID (cWorld . modifications) mdID mdi w
|
||||
PutProp prp -> plNewUpID (cWorld . props) prID (mvProp p rot prp) w
|
||||
PutButton bt -> plNewUpID (cWorld . buttons) btID (mvButton p rot bt) w
|
||||
PutTerminal tm -> plNewUpID (cWorld . terminals) tmID tm w
|
||||
PutFlIt itm -> plNewUpID (cWorld . floorItems) flItID (createFlIt p rot itm) w
|
||||
PutCrit cr -> plNewUpID (cWorld . creatures) crID (mvCr p rot cr) w
|
||||
PutForeground fs -> plNewUpID (cWorld . foregroundShapes) fsID (mvFS p rot fs) w
|
||||
PutDecoration pic -> plNewID (cWorld . decorations) (shiftDec p rot pic) w
|
||||
PutMachine pps mc wl -> plMachine (map doShift pps) mc wl p rot w
|
||||
PutLS ls -> plNewUpID (cWorld . lightSources) lsID (mvLS p' rot ls) w
|
||||
PutPPlate pp -> plNewUpID (cWorld . pressPlates) ppID (mvPP p rot pp) w
|
||||
RandPS rgn -> evaluateRandPS rgn ps w
|
||||
PutDoor col eo f pss -> plDoor col eo f (map (bimap doShift doShift) pss) w
|
||||
PutCoord cp -> plNewID (cWorld . coordinates) (doShift cp) w
|
||||
PutSlideDr wl dr eo off a b ->
|
||||
plSlideDoor wl dr eo off (doShift a) (doShift b) w
|
||||
PutBlock bl wl ps' ->
|
||||
plBlock
|
||||
(map doShift ps')
|
||||
(bl & blPos %~ doShift & blDir .~ rot)
|
||||
wl
|
||||
w
|
||||
PutLineBlock wl wdth a b -> plLineBlock wl wdth (doShift a) (doShift b) w
|
||||
PutWall qs wl -> (0, placeWallPoly (map doShift qs) wl w)
|
||||
PutNothing -> (0, w)
|
||||
PutID i -> (i, w)
|
||||
PutWorldUpdate f -> (0, w & f ps)
|
||||
PutUsingGenParams f ->
|
||||
let (w', pt') = f w
|
||||
in placeSpotID' ps pt' w'
|
||||
where
|
||||
p@(V2 px py) = _psPos ps
|
||||
p' = V3 px py 0
|
||||
rot = _psRot ps
|
||||
doShift = shiftPointBy (p,rot)
|
||||
doShift = shiftPointBy (p, rot)
|
||||
|
||||
shiftDec :: Point2 -> Float -> Picture -> Picture
|
||||
shiftDec p r pic = uncurryV translate p $ rotate r pic
|
||||
|
||||
evaluateRandPS :: State StdGen PSType -> PlacementSpot -> World -> (Int,World)
|
||||
evaluateRandPS :: State StdGen PSType -> PlacementSpot -> World -> (Int, World)
|
||||
evaluateRandPS rgen ps w = placeSpotID' ps evaluatedType (set randGen g w)
|
||||
where
|
||||
where
|
||||
(evaluatedType, g) = runState rgen (_randGen w)
|
||||
|
||||
--placeWallPoly :: [Point2] -> Wall -> World -> World
|
||||
--placeWallPoly ps wl = -- rmCrossPaths .
|
||||
--placeWallPoly ps wl = -- rmCrossPaths .
|
||||
-- over walls (placeWalls ps wl)
|
||||
---- where
|
||||
---- rmCrossPaths w = foldr (uncurry obstructPathsCrossing) w $ loopPairs ps
|
||||
|
||||
--placeWalls :: [Point2] -> Wall -> IM.IntMap Wall -> IM.IntMap Wall
|
||||
--placeWalls qs wl wls = foldl' (addPane wl) wls pairs
|
||||
-- where
|
||||
-- where
|
||||
-- (p:ps) = orderPolygon qs
|
||||
-- pairs = zip (ps ++ [p]) (p:ps)
|
||||
|
||||
placeWallPoly :: [Point2] -> Wall -> World -> World
|
||||
placeWallPoly qs wl w = foldl' (addPane wl) w pairs
|
||||
where
|
||||
(p:ps) = orderPolygon qs
|
||||
pairs = zip (ps ++ [p]) (p:ps)
|
||||
where
|
||||
(p : ps) = orderPolygon qs
|
||||
pairs = zip (ps ++ [p]) (p : ps)
|
||||
|
||||
addPane :: Wall -> World -> (Point2,Point2) -> World
|
||||
addPane :: Wall -> World -> (Point2, Point2) -> World
|
||||
--addPane wl w l = w & walls %~ IM.insert wlid (wl { _wlLine = l, _wlID = wlid })
|
||||
addPane wl w l = w & plNew (cWorld . walls) wlID (wl & wlLine .~ l)
|
||||
& fst . uncurry (obstructPathsCrossing WallObstacle) l
|
||||
addPane wl w l =
|
||||
w & plNew (cWorld . walls) wlID (wl & wlLine .~ l)
|
||||
& fst . uncurry (obstructPathsCrossing WallObstacle) l
|
||||
|
||||
-- where
|
||||
-- wlid = IM.newKey (_walls w)
|
||||
|
||||
mvProp :: Point2 -> Float -> Prop -> Prop
|
||||
mvProp p a = (prRot +~ a) . (prPos %~ ( (p +.+) . rotateV a ))
|
||||
mvProp p a = (prRot +~ a) . (prPos %~ ((p +.+) . rotateV a))
|
||||
|
||||
mvButton :: Point2 -> Float -> Button -> Button
|
||||
mvButton p a = (btRot +~ a) . (btPos %~ ( (p +.+) . rotateV a ))
|
||||
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 }
|
||||
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}
|
||||
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}
|
||||
mvCr p rot cr = cr{_crPos = p, _crOldPos = p, _crDir = rot}
|
||||
|
||||
mvFS :: Point2 -> Float -> ForegroundShape -> ForegroundShape
|
||||
mvFS p a = (fsDir +~ a) . (fsPos %~ ( (p +.+) . rotateV a ))
|
||||
mvFS p a = (fsDir +~ a) . (fsPos %~ ((p +.+) . rotateV a))
|
||||
|
||||
plMachine :: [Point2] -> Machine -> Wall -> Point2 -> Float -> World -> (Int,World)
|
||||
plMachine wallpoly mc wl p rot gw = (mcid
|
||||
, gw & cWorld . machines %~ addMc
|
||||
& cWorld . walls %~ placeMachineWalls wl col wallpoly mcid wlid
|
||||
plMachine :: [Point2] -> Machine -> Wall -> Point2 -> Float -> World -> (Int, World)
|
||||
plMachine wallpoly mc wl p rot gw =
|
||||
( mcid
|
||||
, gw & cWorld . machines %~ addMc
|
||||
& cWorld . walls %~ placeMachineWalls wl col wallpoly mcid wlid
|
||||
)
|
||||
where
|
||||
where
|
||||
col = _mcColor mc
|
||||
w' = gw
|
||||
mcid = IM.newKey $ _machines (_cWorld w')
|
||||
wlid = IM.newKey $ _walls (_cWorld w')
|
||||
wlids = IS.fromList [wlid .. wlid + length wallpoly - 1]
|
||||
--addMc = IM.insert mcid (mc {_mcPos = centroid wallpoly,_mcDir = rot,_mcID = mcid, _mcWallIDs = wlids})
|
||||
addMc = IM.insert mcid (mc {_mcPos = p,_mcDir = rot,_mcID = mcid, _mcWallIDs = wlids})
|
||||
addMc = IM.insert mcid (mc{_mcPos = p, _mcDir = rot, _mcID = mcid, _mcWallIDs = wlids})
|
||||
|
||||
-- TODO correctly remove/shift pathfinding lines (removePathsCrossing)
|
||||
placeMachineWalls :: Wall -> Color -> [Point2] -> Int -> Int -> IM.IntMap Wall -> IM.IntMap Wall
|
||||
placeMachineWalls wl col poly mcid wlid = flip (foldr f) $ zip [wlid..] $ loopPairs poly
|
||||
placeMachineWalls wl col poly mcid wlid = flip (foldr f) $ zip [wlid ..] $ loopPairs poly
|
||||
where
|
||||
f (wid,l) = IM.insert wid baseWall{_wlID = wid, _wlLine = l}
|
||||
baseWall = wl
|
||||
& wlColor .~ col
|
||||
& wlStructure . wsMachine .~ mcid
|
||||
& wlTouchThrough .~ True
|
||||
f (wid, l) = IM.insert wid baseWall{_wlID = wid, _wlLine = l}
|
||||
baseWall =
|
||||
wl
|
||||
& wlColor .~ col
|
||||
& wlStructure . wsMachine .~ mcid
|
||||
& wlTouchThrough .~ True
|
||||
|
||||
mvLS :: Point3 -> Float -> LightSource -> LightSource
|
||||
mvLS (V3 x y z) rot ls = ls & lsParam . lsPos .~ V3 x y z +.+.+ startPos
|
||||
& lsDir .~ rot
|
||||
mvLS (V3 x y z) rot ls =
|
||||
ls & lsParam . lsPos .~ V3 x y z +.+.+ startPos
|
||||
& lsDir .~ rot
|
||||
where
|
||||
startPos = onXY (rotateV rot) $ _lsPos (_lsParam ls)
|
||||
|
||||
@@ -1,105 +1,123 @@
|
||||
{- | Creation, update and destruction of destructible walls. -}
|
||||
module Dodge.Placement.PlaceSpot.Block
|
||||
( plBlock
|
||||
, plLineBlock
|
||||
)
|
||||
where
|
||||
import Dodge.Data
|
||||
import Dodge.Path
|
||||
-- | Creation, update and destruction of destructible walls.
|
||||
module Dodge.Placement.PlaceSpot.Block (
|
||||
plBlock,
|
||||
plLineBlock,
|
||||
) where
|
||||
|
||||
import Control.Lens
|
||||
import qualified Data.IntSet as IS
|
||||
import Data.List
|
||||
import Dodge.Base
|
||||
--import Dodge.Zone
|
||||
import Dodge.Data.World
|
||||
import Dodge.Path
|
||||
import Geometry
|
||||
import qualified IntMapHelp as IM
|
||||
|
||||
import Control.Lens
|
||||
import Data.List
|
||||
import qualified Data.IntSet as IS
|
||||
|
||||
plBlock
|
||||
:: [Point2] -- ^ Block polygon
|
||||
-> Block
|
||||
-> Wall -- ^ Base Pane
|
||||
-> World
|
||||
-> (Int,World)
|
||||
plBlock ::
|
||||
-- | Block polygon
|
||||
[Point2] ->
|
||||
Block ->
|
||||
-- | Base Pane
|
||||
Wall ->
|
||||
World ->
|
||||
(Int, World)
|
||||
plBlock [] _ _ _ = error "Trying to add a block with incomplete polygon"
|
||||
plBlock (p:ps) bl wl w = (,) blid $ w
|
||||
& cWorld . blocks . at blid ?~ bl
|
||||
{ _blID = blid
|
||||
, _blWallIDs = IS.fromList is
|
||||
, _blShadows = []
|
||||
, _blFootprint = p:ps
|
||||
}
|
||||
& insertWalls blid wls
|
||||
where
|
||||
plBlock (p : ps) bl wl w =
|
||||
(,) blid $
|
||||
w
|
||||
& cWorld . blocks . at blid
|
||||
?~ bl
|
||||
{ _blID = blid
|
||||
, _blWallIDs = IS.fromList is
|
||||
, _blShadows = []
|
||||
, _blFootprint = p : ps
|
||||
}
|
||||
& insertWalls blid wls
|
||||
where
|
||||
blid = IM.newKey $ _blocks (_cWorld w)
|
||||
lns = zip (p:ps) (ps ++ [p])
|
||||
lns = zip (p : ps) (ps ++ [p])
|
||||
i = IM.newKey $ _walls (_cWorld w)
|
||||
is = [i.. i + length lns-1]
|
||||
wls = zipWith
|
||||
(\j ln -> wl & wlLine .~ ln & wlID .~ j & wlStructure .~ BlockPart blid)
|
||||
is
|
||||
lns
|
||||
|
||||
{- | Splits a line into many four cornered blocks. -}
|
||||
plLineBlock
|
||||
:: Wall -- ^ Base pane
|
||||
-> Float
|
||||
-> Point2 -- ^ Start point (symmetric)
|
||||
-> Point2 -- ^ End point (symmetric)
|
||||
-> World
|
||||
-> (Int, World)
|
||||
plLineBlock basePane blwidth a b gw = ( 0
|
||||
-- , foldr insertWall (insertBlocks gw) listWalls
|
||||
, insertBlocks gw
|
||||
is = [i .. i + length lns -1]
|
||||
wls =
|
||||
zipWith
|
||||
(\j ln -> wl & wlLine .~ ln & wlID .~ j & wlStructure .~ BlockPart blid)
|
||||
is
|
||||
lns
|
||||
|
||||
-- | Splits a line into many four cornered blocks.
|
||||
plLineBlock ::
|
||||
-- | Base pane
|
||||
Wall ->
|
||||
Float ->
|
||||
-- | Start point (symmetric)
|
||||
Point2 ->
|
||||
-- | End point (symmetric)
|
||||
Point2 ->
|
||||
World ->
|
||||
(Int, World)
|
||||
plLineBlock basePane blwidth a b gw =
|
||||
( 0
|
||||
, -- , foldr insertWall (insertBlocks gw) listWalls
|
||||
insertBlocks gw
|
||||
)
|
||||
where
|
||||
where
|
||||
depth = blwidth
|
||||
psOnLine = divideLineOddNumPoints blwidth a b
|
||||
halfBlockWidth = dist a b / fromIntegral (length psOnLine - 1)
|
||||
blockCenPs = snd $ evenOddSplit psOnLine
|
||||
numBlocks = length blockCenPs
|
||||
is = [0.. numBlocks - 1]
|
||||
is = [0 .. numBlocks - 1]
|
||||
cornerPoints = reverse $ rectWH halfBlockWidth depth -- goes clockwise around the block
|
||||
cornersAt p = fmap ( (p +.+) . rotateV (argV (b -.- a)) ) cornerPoints
|
||||
cornersAt p = fmap ((p +.+) . rotateV (argV (b -.- a))) cornerPoints
|
||||
linesAt p = loopPairs $ cornersAt p
|
||||
wlid = IM.newKey $ _walls (_cWorld gw)
|
||||
blid = IM.newKey $ _blocks (_cWorld gw)
|
||||
insertBlock (i,p) =
|
||||
insertBlock (i, p) =
|
||||
insertWalls (i + blid) (makeWallAt p i)
|
||||
. over (cWorld . blocks) (IM.insert (i+blid) Block
|
||||
{ _blID = i + blid, _blWallIDs = IS.fromList $ ksAtI i
|
||||
, _blHP = 1000, _blShadows = shadowsAt i
|
||||
, _blDir = 0 -- THIS IS NOT SENSIBLE. TODO rethink block positioning
|
||||
, _blFootprint = cornersAt p -- TODO check winding (clockwise, anticlockwise)
|
||||
, _blObstructs = []
|
||||
, _blMaterial = _wlMaterial basePane
|
||||
, _blHeight = 100
|
||||
, _blPos = p, _blDraw = BlockDrawMempty }
|
||||
)
|
||||
. over
|
||||
(cWorld . blocks)
|
||||
( IM.insert
|
||||
(i + blid)
|
||||
Block
|
||||
{ _blID = i + blid
|
||||
, _blWallIDs = IS.fromList $ ksAtI i
|
||||
, _blHP = 1000
|
||||
, _blShadows = shadowsAt i
|
||||
, _blDir = 0 -- THIS IS NOT SENSIBLE. TODO rethink block positioning
|
||||
, _blFootprint = cornersAt p -- TODO check winding (clockwise, anticlockwise)
|
||||
, _blObstructs = []
|
||||
, _blMaterial = _wlMaterial basePane
|
||||
, _blHeight = 100
|
||||
, _blPos = p
|
||||
, _blDraw = BlockDrawMempty
|
||||
}
|
||||
)
|
||||
insertBlocks = flip (foldr insertBlock) $ zip is blockCenPs
|
||||
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]
|
||||
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 == 0 = ksAtI 1
|
||||
| i == numBlocks - 1 = ksAtI $ numBlocks - 2
|
||||
| otherwise = ksAtI (i-1) ++ ksAtI (i+1)
|
||||
| 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
|
||||
,_wlUnshadowed = visStatus
|
||||
}
|
||||
makePane i visStatus k ps =
|
||||
basePane
|
||||
{ _wlID = k
|
||||
, _wlStructure = BlockPart $ i + blid
|
||||
, _wlLine = ps
|
||||
, _wlUnshadowed = visStatus
|
||||
}
|
||||
|
||||
-- | Must be done after inserting the block
|
||||
insertWalls :: Int -> [Wall] -> World -> World
|
||||
insertWalls blid wls w = w' & cWorld . blocks . ix blid . blObstructs .~ concat paths
|
||||
where
|
||||
(w',paths) = mapAccumR (flip insertWall) w wls
|
||||
(w', paths) = mapAccumR (flip insertWall) w wls
|
||||
|
||||
insertWall :: Wall -> World -> (World,[(Int,Int,PathEdge)])
|
||||
insertWall wl = uncurry (obstructPathsCrossing BlockObstacle) (_wlLine wl)
|
||||
. (cWorld . walls . at (_wlID wl) ?~ wl)
|
||||
insertWall :: Wall -> World -> (World, [(Int, Int, PathEdge)])
|
||||
insertWall wl =
|
||||
uncurry (obstructPathsCrossing BlockObstacle) (_wlLine wl)
|
||||
. (cWorld . walls . at (_wlID wl) ?~ wl)
|
||||
|
||||
@@ -4,15 +4,12 @@ module Dodge.Placement.PlaceSpot.Block
|
||||
, plLineBlock
|
||||
)
|
||||
where
|
||||
import Dodge.Data
|
||||
import Dodge.Data.World
|
||||
import Dodge.Path
|
||||
import Dodge.Block.Debris
|
||||
--import Dodge.LevelGen.LevelStructure
|
||||
import Dodge.Base
|
||||
--import Dodge.Zone
|
||||
import Geometry
|
||||
import qualified IntMapHelp as IM
|
||||
|
||||
import Control.Lens
|
||||
import qualified Data.IntSet as IS
|
||||
|
||||
|
||||
@@ -1,118 +1,128 @@
|
||||
--{-# LANGUAGE BangPatterns #-}
|
||||
module Dodge.Placement.PlaceSpot.TriggerDoor
|
||||
( plDoor
|
||||
, plSlideDoor
|
||||
, maybeClearDoorPaths
|
||||
) where
|
||||
import Dodge.Zoning.Wall
|
||||
import Dodge.Data
|
||||
module Dodge.Placement.PlaceSpot.TriggerDoor (
|
||||
plDoor,
|
||||
plSlideDoor,
|
||||
maybeClearDoorPaths,
|
||||
) where
|
||||
|
||||
import qualified Data.Graph.Inductive as FGL
|
||||
import qualified Data.IntSet as IS
|
||||
import Data.List
|
||||
import Dodge.Base
|
||||
import Dodge.Path
|
||||
import Dodge.Data.World
|
||||
import Dodge.Default.Door
|
||||
import Dodge.LevelGen.DoorPane
|
||||
import Picture
|
||||
import Dodge.Path
|
||||
import Dodge.Zoning.Wall
|
||||
import Geometry
|
||||
import qualified IntMapHelp as IM
|
||||
import LensHelp
|
||||
--import Dodge.LevelGen.LevelStructure
|
||||
import Picture
|
||||
|
||||
--import Data.Maybe
|
||||
import Data.List
|
||||
import qualified Data.IntSet as IS
|
||||
import qualified Data.Graph.Inductive as FGL
|
||||
plDoor :: Color
|
||||
-> EdgeObstacle
|
||||
-> WdBl -- ^ Opening condition
|
||||
-> [(Point2,Point2)] -- ^ Door positions, closed to open.
|
||||
-- Bumped out up and down by 9, not widened
|
||||
-> World
|
||||
-> (Int,World)
|
||||
plDoor ::
|
||||
Color ->
|
||||
EdgeObstacle ->
|
||||
-- | Opening condition
|
||||
WdBl ->
|
||||
-- | Door positions, closed to open.
|
||||
-- Bumped out up and down by 9, not widened
|
||||
[(Point2, Point2)] ->
|
||||
World ->
|
||||
(Int, World)
|
||||
plDoor col eo cond pss gw = (drid, addWalls $ gw & cWorld . doors %~ addDoor) -- carefull with the ordering of addWalls
|
||||
where
|
||||
drid = IM.newKey $ _doors (_cWorld gw)
|
||||
addDoor = IM.insert drid $ defaultDoor
|
||||
{ _drID = drid
|
||||
, _drWallIDs = IS.fromList wlids
|
||||
, _drStatus = DoorInt 0
|
||||
, _drTrigger = cond
|
||||
, _drMech = DrWdMechanismStepwise nsteps wlids pss
|
||||
, _drPos = head pss
|
||||
, _drOpenPos = head pss
|
||||
, _drClosePos = last pss
|
||||
, _drObstacleType = eo
|
||||
}
|
||||
addDoor =
|
||||
IM.insert drid $
|
||||
defaultDoor
|
||||
{ _drID = drid
|
||||
, _drWallIDs = IS.fromList wlids
|
||||
, _drStatus = DoorInt 0
|
||||
, _drTrigger = cond
|
||||
, _drMech = DrWdMechanismStepwise nsteps wlids pss
|
||||
, _drPos = head pss
|
||||
, _drOpenPos = head pss
|
||||
, _drClosePos = last pss
|
||||
, _drObstacleType = eo
|
||||
}
|
||||
nsteps = length pss - 1
|
||||
wlids = take 4 [IM.newKey $ _walls (_cWorld gw) ..]
|
||||
wlps' = uncurry (rectanglePairs 9) $ head pss
|
||||
addWalls w' = foldl' (addDoorWall eo drid $ switchWallCol col) w' $ zip wlids wlps'
|
||||
|
||||
addDoorWall :: EdgeObstacle -> Int -> Wall -> World -> (Int,(Point2,Point2)) -> World
|
||||
addDoorWall eo drid wl w (wlid,wlps) = w'
|
||||
& cWorld . walls %~ IM.insert wlid wl
|
||||
{ _wlLine = wlps
|
||||
, _wlID = wlid
|
||||
, _wlStructure = DoorPart drid
|
||||
}
|
||||
& cWorld . doors . ix drid . drObstructs .++~ es
|
||||
addDoorWall :: EdgeObstacle -> Int -> Wall -> World -> (Int, (Point2, Point2)) -> World
|
||||
addDoorWall eo drid wl w (wlid, wlps) =
|
||||
w'
|
||||
& cWorld . walls
|
||||
%~ IM.insert
|
||||
wlid
|
||||
wl
|
||||
{ _wlLine = wlps
|
||||
, _wlID = wlid
|
||||
, _wlStructure = DoorPart drid
|
||||
}
|
||||
& cWorld . doors . ix drid . drObstructs .++~ es
|
||||
where
|
||||
(w',es) = uncurry (obstructPathsCrossing eo) wlps w
|
||||
(w', es) = uncurry (obstructPathsCrossing eo) wlps w
|
||||
|
||||
maybeClearDoorPaths :: EdgeObstacle -> [(Int,Int,PathEdge)] -> World -> World
|
||||
maybeClearDoorPaths :: EdgeObstacle -> [(Int, Int, PathEdge)] -> World -> World
|
||||
maybeClearDoorPaths eo es w = foldl' (maybeClearDoorPath eo) w es
|
||||
|
||||
maybeClearDoorPath :: EdgeObstacle -> World -> (Int,Int,PathEdge) -> World
|
||||
maybeClearDoorPath eo w (x,y,pe)
|
||||
| not . null $ overlapSegWalls (_peStart pe) (_peEnd pe) $ wlsNearSeg (_peStart pe) (_peEnd pe) w
|
||||
= w & cWorld . pathGraph %~ FGL.insEdge (x,y,pe & peObstacles . at eo ?~ ()) . FGL.delEdge (x,y)
|
||||
| otherwise
|
||||
= w & cWorld . pathGraph %~ FGL.insEdge (x,y,pe & peObstacles . at eo .~ Nothing) . FGL.delEdge (x,y)
|
||||
maybeClearDoorPath :: EdgeObstacle -> World -> (Int, Int, PathEdge) -> World
|
||||
maybeClearDoorPath eo w (x, y, pe)
|
||||
| not . null $ overlapSegWalls (_peStart pe) (_peEnd pe) $ wlsNearSeg (_peStart pe) (_peEnd pe) w =
|
||||
w & cWorld . pathGraph %~ FGL.insEdge (x, y, pe & peObstacles . at eo ?~ ()) . FGL.delEdge (x, y)
|
||||
| otherwise =
|
||||
w & cWorld . pathGraph %~ FGL.insEdge (x, y, pe & peObstacles . at eo .~ Nothing) . FGL.delEdge (x, y)
|
||||
|
||||
plSlideDoor
|
||||
:: Door
|
||||
-> Wall
|
||||
-> EdgeObstacle
|
||||
-> Float
|
||||
-> Point2
|
||||
-> Point2
|
||||
-> World
|
||||
-> (Int, World)
|
||||
plSlideDoor dr wl eo shiftOffset a b gw
|
||||
= (drid, addDoorWalls $ gw & cWorld . doors %~ addDoor)
|
||||
plSlideDoor ::
|
||||
Door ->
|
||||
Wall ->
|
||||
EdgeObstacle ->
|
||||
Float ->
|
||||
Point2 ->
|
||||
Point2 ->
|
||||
World ->
|
||||
(Int, World)
|
||||
plSlideDoor dr wl eo shiftOffset a b gw =
|
||||
(drid, addDoorWalls $ gw & cWorld . doors %~ addDoor)
|
||||
where
|
||||
drid = IM.newKey $ _doors (_cWorld gw)
|
||||
addDoor = IM.insert drid $ dr
|
||||
{ _drID = drid
|
||||
, _drWallIDs = IS.fromList wlids
|
||||
, _drStatus = DoorClosed
|
||||
, _drMech = DoorMechanism
|
||||
, _drPos = (a,b)
|
||||
, _drOpenPos = (shiftLeft a,shiftLeft b)
|
||||
, _drClosePos = (a,b)
|
||||
, _drObstacleType = eo
|
||||
}
|
||||
addDoor =
|
||||
IM.insert drid $
|
||||
dr
|
||||
{ _drID = drid
|
||||
, _drWallIDs = IS.fromList wlids
|
||||
, _drStatus = DoorClosed
|
||||
, _drMech = DoorMechanism
|
||||
, _drPos = (a, b)
|
||||
, _drOpenPos = (shiftLeft a, shiftLeft b)
|
||||
, _drClosePos = (a, b)
|
||||
, _drObstacleType = eo
|
||||
}
|
||||
addDoorWalls w' = foldl' (addDoorWall eo drid wl) w' $ zip wlids pairs
|
||||
pairs = rectanglePairs 9 a b
|
||||
shiftLeft = (+.+ (a -.- b +.+ shiftOffset *.* normalizeV (b -.- a)))
|
||||
shiftLeft = (+.+ (a -.- b +.+ shiftOffset *.* normalizeV (b -.- a)))
|
||||
wlids = take 4 [IM.newKey $ _walls (_cWorld gw) ..]
|
||||
|
||||
-- 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
|
||||
--addButtonDoor c btp btr a b speed w
|
||||
-- = (,) 0
|
||||
-- . over buttons (IM.insert bid bt)
|
||||
-- . 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
|
||||
-- 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))
|
||||
-- (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 ++)
|
||||
-- eff w' = over pathGraphP (removedPairs ++)
|
||||
-- . over pathGraph (flip run_ $ insMapEdgesM $ map f removedPairs) $ w'
|
||||
-- f (x,y) = (x,y,dist x y)
|
||||
|
||||
@@ -1,13 +1,15 @@
|
||||
module Dodge.Placement.Random where
|
||||
import Dodge.Data
|
||||
|
||||
import Dodge.Data.Item
|
||||
import Dodge.Item
|
||||
import RandomHelp
|
||||
|
||||
{- Probabilites of the type of the first floor weapon. -}
|
||||
randFirstWeapon :: State StdGen Item
|
||||
randFirstWeapon = takeOne $
|
||||
replicate 10 pistol
|
||||
++ replicate 5 (bangStick 4)
|
||||
++ replicate 5 (volleyGun 3)
|
||||
++ replicate 5 bangCone
|
||||
++ [lasGun]
|
||||
randFirstWeapon =
|
||||
takeOne $
|
||||
replicate 10 pistol
|
||||
++ replicate 5 (bangStick 4)
|
||||
++ replicate 5 (volleyGun 3)
|
||||
++ replicate 5 bangCone
|
||||
++ [lasGun]
|
||||
|
||||
@@ -1,27 +1,33 @@
|
||||
module Dodge.Placement.Shift
|
||||
( shiftPlacement
|
||||
, shiftPSBy
|
||||
, shiftRelativeToPS
|
||||
) where
|
||||
--import Dodge.LevelGen.Data
|
||||
import Dodge.Data
|
||||
module Dodge.Placement.Shift (
|
||||
shiftPlacement,
|
||||
shiftPSBy,
|
||||
shiftRelativeToPS,
|
||||
) where
|
||||
|
||||
import Dodge.Data.GenWorld
|
||||
import Dodge.ShiftPoint
|
||||
import Geometry
|
||||
import LensHelp
|
||||
|
||||
import Geometry
|
||||
shiftPSBy :: (Point2,Float) -> PlacementSpot -> PlacementSpot
|
||||
shiftPSBy (pos,rot) ps = ps
|
||||
& psPos %~ shiftPointBy (pos,rot)
|
||||
& psRot +~ rot
|
||||
shiftPSBy :: (Point2, Float) -> PlacementSpot -> PlacementSpot
|
||||
shiftPSBy (pos, rot) ps =
|
||||
ps
|
||||
& psPos %~ shiftPointBy (pos, rot)
|
||||
& psRot +~ rot
|
||||
|
||||
shiftRelativeToPS :: Point2 -> PlacementSpot -> PlacementSpot
|
||||
shiftRelativeToPS p ps = ps & psPos .+.+~ rotateV (_psRot ps) p
|
||||
shiftPlacement :: (Point2,Float) -> Placement -> Placement
|
||||
|
||||
shiftPlacement :: (Point2, Float) -> Placement -> Placement
|
||||
shiftPlacement shift plmnt = case plmnt of
|
||||
-- slightly messy NoShiftCont, necessary to stop interference with ps0jPushPS
|
||||
Placement {_plSpot = PSNoShiftCont {}} -> plmnt & plSpot %~ shiftPSBy shift
|
||||
Placement {} -> plmnt & plSpot %~ shiftPSBy shift
|
||||
& plIDCont %~ fmap (fmap (fmap $ shiftPlacement shift))
|
||||
PlacementUsingPos p f -> PlacementUsingPos (shiftPoint3By shift p)
|
||||
(fmap (shiftPlacement shift) f)
|
||||
-- slightly messy NoShiftCont, necessary to stop interference with ps0jPushPS
|
||||
Placement{_plSpot = PSNoShiftCont{}} -> plmnt & plSpot %~ shiftPSBy shift
|
||||
Placement{} ->
|
||||
plmnt & plSpot %~ shiftPSBy shift
|
||||
& plIDCont %~ fmap (fmap (fmap $ shiftPlacement shift))
|
||||
PlacementUsingPos p f ->
|
||||
PlacementUsingPos
|
||||
(shiftPoint3By shift p)
|
||||
(fmap (shiftPlacement shift) f)
|
||||
RandomPlacement rpl -> RandomPlacement $ fmap (shiftPlacement shift) rpl
|
||||
PickOnePlacement i pl -> PickOnePlacement i (shiftPlacement shift pl)
|
||||
|
||||
@@ -1,62 +1,73 @@
|
||||
module Dodge.Placement.TopDecoration where
|
||||
import Dodge.Data
|
||||
import Dodge.Room.Foreground
|
||||
--import Dodge.LevelGen.Data
|
||||
import Shape
|
||||
import Geometry
|
||||
|
||||
import Color
|
||||
import Dodge.Data.GenParams
|
||||
import Dodge.Room.Foreground
|
||||
import Geometry
|
||||
import Shape
|
||||
|
||||
decorationToShape :: DecorationShape -> Float -> Float -> Float -> Color -> Color -> Shape
|
||||
decorationToShape dec = case dec of
|
||||
PLUS -> plusDecoration
|
||||
SQUARE -> squareDecoration
|
||||
CIRCLE -> circleDecoration
|
||||
THREELINES -> threeLineDecoration
|
||||
PLUS -> plusDecoration
|
||||
SQUARE -> squareDecoration
|
||||
CIRCLE -> circleDecoration
|
||||
THREELINES -> threeLineDecoration
|
||||
|
||||
midBarDecoration :: Float -> Float -> Float -> Color -> Color -> Shape
|
||||
midBarDecoration w h z _ c = embossingR
|
||||
<> rotateSH pi embossingR
|
||||
<> colorSH c (thinHighBar (z + 7) (V2 (-0.3*w) 0) (V2 (0.3*w) 0))
|
||||
midBarDecoration w h z _ c =
|
||||
embossingR
|
||||
<> rotateSH pi embossingR
|
||||
<> colorSH c (thinHighBar (z + 7) (V2 (-0.3 * w) 0) (V2 (0.3 * w) 0))
|
||||
where
|
||||
w' = 0.3 * w
|
||||
embossingR = colorSH c $ prismPoly
|
||||
[V3 w h z,V3 w (0.3*h) 41,V3 w (-0.3*h) 41,V3 w (-h) z]
|
||||
[V3 w' h z,V3 w' (0.3*h) 41,V3 w' (-0.3*h) 41,V3 w' (-h) z]
|
||||
embossingR =
|
||||
colorSH c $
|
||||
prismPoly
|
||||
[V3 w h z, V3 w (0.3 * h) 41, V3 w (-0.3 * h) 41, V3 w (- h) z]
|
||||
[V3 w' h z, V3 w' (0.3 * h) 41, V3 w' (-0.3 * h) 41, V3 w' (- h) z]
|
||||
|
||||
fourEmbossDecoration :: Float -> Float -> Float -> Color -> Color -> Shape
|
||||
fourEmbossDecoration w h z _ c = colorSH c $ foldMap f [(w,h),(-w,h),(w,-h),(-w,-h)]
|
||||
fourEmbossDecoration w h z _ c = colorSH c $ foldMap f [(w, h), (- w, h), (w, - h), (- w, - h)]
|
||||
where
|
||||
f (a,b) = translateSH (V3 (a/2) (b/2) z) embossing
|
||||
embossing = upperPrismPolyHalf 10 $ reverse $ rectNSWE (h/2) (-h/2) (-w/2) (w/2)
|
||||
f (a, b) = translateSH (V3 (a / 2) (b / 2) z) embossing
|
||||
embossing = upperPrismPolyHalf 10 $ reverse $ rectNSWE (h / 2) (- h / 2) (- w / 2) (w / 2)
|
||||
|
||||
plusDecoration :: Float -> Float -> Float -> Color -> Color -> Shape
|
||||
plusDecoration w h z _ c = colorSH c $ thinHighBar z (V2 w 0) (V2 (-w) 0)
|
||||
<> thinHighBar z (V2 0 h) (V2 0 (-h))
|
||||
plusDecoration w h z _ c =
|
||||
colorSH c $
|
||||
thinHighBar z (V2 w 0) (V2 (- w) 0)
|
||||
<> thinHighBar z (V2 0 h) (V2 0 (- h))
|
||||
|
||||
squareDecoration :: Float -> Float -> Float -> Color -> Color -> Shape
|
||||
squareDecoration w h z _ col = colorSH col $ foldMap f
|
||||
[(w',-w',h',h')
|
||||
,(w',-w',-h',-h')
|
||||
,(w',w',h',-h')
|
||||
,(-w',-w',h',-h')
|
||||
]
|
||||
squareDecoration w h z _ col =
|
||||
colorSH col $
|
||||
foldMap
|
||||
f
|
||||
[ (w', - w', h', h')
|
||||
, (w', - w', - h', - h')
|
||||
, (w', w', h', - h')
|
||||
, (- w', - w', h', - h')
|
||||
]
|
||||
where
|
||||
w' = w - 1.5
|
||||
h' = h - 1.5
|
||||
f (a,c,b,d) = thinHighBar z (V2 a b) (V2 c d)
|
||||
f (a, c, b, d) = thinHighBar z (V2 a b) (V2 c d)
|
||||
|
||||
circleDecoration :: Float -> Float -> Float -> Color -> Color -> Shape
|
||||
circleDecoration w _ z _ c = colorSH c $ foldMap toprail (take 8 [0,pi/4..])
|
||||
circleDecoration w _ z _ c = colorSH c $ foldMap toprail (take 8 [0, pi / 4 ..])
|
||||
where
|
||||
toprail a = rotateSH a $ thinHighBar z (V2 0 w) (rotateV (pi/4) $ V2 0 w)
|
||||
toprail a = rotateSH a $ thinHighBar z (V2 0 w) (rotateV (pi / 4) $ V2 0 w)
|
||||
|
||||
threeLineDecoration :: Float -> Float -> Float -> Color -> Color -> Shape
|
||||
threeLineDecoration w h z _ col = colorSH col $ foldMap f
|
||||
[(w',-w',h',h')
|
||||
,(w',-w',0,0)
|
||||
,(w',-w',-h',-h')
|
||||
]
|
||||
threeLineDecoration w h z _ col =
|
||||
colorSH col $
|
||||
foldMap
|
||||
f
|
||||
[ (w', - w', h', h')
|
||||
, (w', - w', 0, 0)
|
||||
, (w', - w', - h', - h')
|
||||
]
|
||||
where
|
||||
w' = w - 1.5
|
||||
h' = h - 1.5
|
||||
f (a,c,b,d) = thinHighBar z (V2 a b) (V2 c d)
|
||||
f (a, c, b, d) = thinHighBar z (V2 a b) (V2 c d)
|
||||
|
||||
Reference in New Issue
Block a user