Refactor, try to limit dependencies
This commit is contained in:
+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)
|
||||
|
||||
Reference in New Issue
Block a user