Move towards more usable placements
This commit is contained in:
+61
-98
@@ -23,37 +23,15 @@ 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
|
||||
|
||||
placeSpotRoomRand :: Room -> Int -> Placement -> World -> (World,Room)
|
||||
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)
|
||||
|
||||
placeSpot :: (World,Room) -> Placement -> (World,Room)
|
||||
placeSpot (w,rm) plmnt = case plmnt of
|
||||
Placement{_plSpot = PSRoomRand i} -> 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)
|
||||
Placement{_plSpot = PSLnk{}} -> case lnks of
|
||||
((lnki,lnk):_) -> placeSpot (w & randGen .~ g,uselnk lnki) (updatePS (f lnk) plmnt)
|
||||
[] -> case fallback of
|
||||
Nothing -> (w,rm)
|
||||
Just plmnt' -> placeSpot (w,rm) plmnt'
|
||||
where
|
||||
uselnk lnki = rm & rmLinks %~ deletei lnki
|
||||
rps = _plSpot plmnt
|
||||
fallback = _psFallback rps
|
||||
test = _psLinkTest rps
|
||||
(lnks,g) = runState (shuffle $ filter (test . snd) $ zip [0..]
|
||||
$ map (invShiftLinkBy $ _rmShift rm) $ _rmLinks rm) $ _randGen w
|
||||
f x (PSLnk t s _)
|
||||
| t x = uncurry PS $ s x
|
||||
f _ ps = ps
|
||||
invShiftLinkBy :: (Point2,Float) -> (Point2,Float) -> (Point2,Float)
|
||||
invShiftLinkBy (pos,rot) (p,r) = (invShiftPointBy (pos,rot) p, r - rot)
|
||||
Placement{_plSpot = PSLnk{}} -> placeSpotUsingLink w rm plmnt
|
||||
Placement{} ->
|
||||
let (i,w') = placeSpotID (shiftPSBy shift (_plSpot plmnt)) (_plType plmnt) w
|
||||
in maybe (w',rm) (placeSpot (w',rm)) (_plIDCont plmnt i)
|
||||
@@ -64,15 +42,40 @@ placeSpot (w,rm) plmnt = case plmnt of
|
||||
where
|
||||
shift = _rmShift rm
|
||||
|
||||
placeSpotUsingLink :: World -> Room -> Placement -> (World, Room)
|
||||
placeSpotUsingLink w rm plmnt = case lnks of
|
||||
((lnki,lnk):_) -> placeSpot (w & randGen .~ g,uselnk lnki) (updatePS (f lnk) plmnt)
|
||||
[] -> case fallback of
|
||||
Nothing -> (w,rm)
|
||||
Just plmnt' -> placeSpot (w,rm) plmnt'
|
||||
where
|
||||
uselnk lnki = rm & rmLinks %~ deletei lnki
|
||||
rps = _plSpot plmnt
|
||||
fallback = _psFallback rps
|
||||
test = _psLinkTest rps
|
||||
(lnks,g) = runState (shuffle $ filter (test . snd) $ zip [0..]
|
||||
$ map (invShiftLinkBy $ _rmShift rm) $ _rmLinks rm) $ _randGen w
|
||||
f x (PSLnk t s _)
|
||||
| t x = uncurry PS $ s x
|
||||
f _ ps = ps
|
||||
invShiftLinkBy :: (Point2,Float) -> (Point2,Float) -> (Point2,Float)
|
||||
invShiftLinkBy (pos,rot) (p,r) = (invShiftPointBy (pos,rot) p, r - rot)
|
||||
|
||||
placeSpotRoomRand :: Room -> Int -> Placement -> World -> (World,Room)
|
||||
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)
|
||||
|
||||
deletei :: Int -> [a] -> [a]
|
||||
deletei i xs = take i xs ++ drop (i+1) xs
|
||||
|
||||
shiftPlacement :: (Point2,Float) -> Placement -> Placement
|
||||
shiftPlacement shift (Placement ps pt f) = Placement (shiftPSBy shift ps) pt
|
||||
(fmap (fmap $ shiftPlacement shift) f)
|
||||
shiftPlacement shift (PlacementUsingPos p f) = PlacementUsingPos (shiftPoint3By shift p)
|
||||
(fmap (shiftPlacement shift) f)
|
||||
shiftPlacement shift (RandomPlacement rpl) = RandomPlacement $ fmap (shiftPlacement shift) rpl
|
||||
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
|
||||
@@ -84,17 +87,14 @@ shiftPSBy (pos,rot) ps = ps
|
||||
placeSpotID :: PlacementSpot -> PSType -> World -> (Int, World)
|
||||
placeSpotID ps pt w = case pt of
|
||||
PutTrigger cond -> placeNewInto triggers cond w
|
||||
PutProp prop -> placeProp prop p rot w
|
||||
--PutButton bt -> placeBt bt p rot w
|
||||
PutButton bt -> placeNewUpdateID buttons btID (mvButton bt p rot) w
|
||||
PutFlIt itm -> placeFlIt itm p rot w
|
||||
PutCrit cr -> placeCr cr p rot 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 -> placeLS ls p' rot w
|
||||
PutPressPlate pp -> placePressPlate pp p rot w
|
||||
RandPS rgen -> placeSpotID ps evaluatedType (set randGen g w)
|
||||
where
|
||||
(evaluatedType, g) = runState rgen (_randGen 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
|
||||
@@ -112,6 +112,11 @@ placeSpotID ps pt w = case pt of
|
||||
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
|
||||
@@ -148,71 +153,30 @@ placeNewInto l x w = (i,w & l #%~ IM.insert i x)
|
||||
i = IM.newKey $ w ^# l
|
||||
|
||||
-- | place an new object into an intmap and update its id
|
||||
placeNewUpdateID :: ALens' World (IM.IntMap a)
|
||||
plNewUpID :: ALens' World (IM.IntMap a)
|
||||
-> ALens' a Int
|
||||
-> a
|
||||
-> World
|
||||
-> (Int,World)
|
||||
placeNewUpdateID l li x w = (i,w & l #%~ IM.insert i (x & li #~ i))
|
||||
plNewUpID l li x w = (i,w & l #%~ IM.insert i (x & li #~ i))
|
||||
where
|
||||
i = IM.newKey $ w ^# l
|
||||
|
||||
placeProp
|
||||
:: Prop
|
||||
-> Point2
|
||||
-> Float -- ^ Rotation
|
||||
-> World
|
||||
-> (Int, World)
|
||||
placeProp pr p a w = (i, w & props %~ addProp)
|
||||
where
|
||||
i = IM.newKey $ _props w
|
||||
addProp prs = IM.insert i (f pr) prs
|
||||
f = (pjRot +~ a) . (pjPos %~ ( (p +.+) . rotateV a )) . (pjID .~ i)
|
||||
mvProp :: Point2 -> Float -> Prop -> Prop
|
||||
mvProp p a = (pjRot +~ a) . (pjPos %~ ( (p +.+) . rotateV a ))
|
||||
|
||||
placeBt
|
||||
:: Button
|
||||
-> Point2
|
||||
-> Float -- ^ Rotation
|
||||
-> World
|
||||
-> (Int, World)
|
||||
placeBt bt p a w = (i , over buttons addBT w)
|
||||
where
|
||||
i = IM.newKey $ _buttons w
|
||||
addBT = IM.insert i (f bt)
|
||||
f = (btRot +~ a) . (btPos %~ ( (p +.+) . rotateV a )) . (btID .~ i)
|
||||
mvButton :: Point2 -> Float -> Button -> Button
|
||||
mvButton p a = (btRot +~ a) . (btPos %~ ( (p +.+) . rotateV a ))
|
||||
|
||||
mvButton bt p a = bt & 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 }
|
||||
|
||||
{- Creates a floor item at a given point.
|
||||
Assigns an id correctly. -}
|
||||
placeFlIt
|
||||
:: Item
|
||||
-> Point2 -- ^ Position
|
||||
-> Float -- ^ Rotation
|
||||
-> World
|
||||
-> (Int, World)
|
||||
placeFlIt itm p rot w = (i
|
||||
, w & floorItems %~ IM.insert i FlIt { _flItPos = p , _flItRot = rot , _flItID = i , _flIt = itm }
|
||||
)
|
||||
where
|
||||
i = IM.newKey $ _floorItems w
|
||||
mvPP :: Point2 -> Float -> PressPlate -> PressPlate
|
||||
mvPP p rot pp = pp {_ppPos = p,_ppRot = rot}
|
||||
|
||||
placePressPlate
|
||||
:: PressPlate
|
||||
-> Point2
|
||||
-> Float -- ^ Rotation
|
||||
-> World
|
||||
-> (Int, World)
|
||||
placePressPlate pp p rot w = (i , over pressPlates addPP w)
|
||||
where
|
||||
i = IM.newKey $ _pressPlates w
|
||||
addPP pps = IM.insert (IM.newKey pps) (pp {_ppPos = p,_ppRot = rot}) pps
|
||||
|
||||
placeCr :: Creature -> Point2 -> Float -> World -> (Int,World)
|
||||
placeCr crF p rot w = (cid, over creatures addCr w)
|
||||
where
|
||||
cid = IM.newKey $ _creatures w
|
||||
addCr crs = IM.insert cid (crF {_crPos = p,_crOldPos = p,_crDir = rot,_crID = cid}) crs
|
||||
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
|
||||
@@ -224,6 +188,7 @@ placeMachine color wallpoly mc p rot w = (mcid
|
||||
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
|
||||
@@ -233,9 +198,7 @@ placeMachineWalls col poly mcid wlid = flip (foldr f) $ zip [wlid..] $ loopPairs
|
||||
& wlColor .~ col
|
||||
& wlStructure . wlStMachine .~ mcid
|
||||
|
||||
placeLS :: LightSource -> Point3 -> Float -> World -> (Int,World)
|
||||
placeLS ls (V3 x y z) rot w = (i, over lightSources addLS w)
|
||||
where
|
||||
i = IM.newKey $ _lightSources w
|
||||
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
|
||||
addLS = IM.insert i (ls {_lsPos = V3 x y z +.+.+ startPos,_lsDir = rot,_lsID = i})
|
||||
|
||||
Reference in New Issue
Block a user