loop/src/Dodge/LevelGen.hs

{-# LANGUAGE FlexibleInstances #-}
-- | deals with placement of objects within the world
-- after they have had their coordinates set by the layout
module Dodge.LevelGen 
    ( shiftPlacement
    , shiftPointBy
    , placeSpot
    , invShiftPointBy
    ) where
import Dodge.Data
import Dodge.LevelGen.Block
import Dodge.LevelGen.Pathing
import Dodge.LevelGen.TriggerDoor
import Dodge.LevelGen.Data
import Dodge.Default.Wall
import Geometry
import Geometry.Vector3D
import Shape
import qualified IntMapHelp as IM
import Color

import Control.Monad.State
import Control.Lens
import qualified Data.IntSet as IS

placeSpot :: World -> ((Point2,Float) , Placement) -> World
placeSpot w (shift, plmnt@Placement{}) =
    let (i,w') =  placeSpotID (shiftPSBy shift (_placementSpot plmnt)) (_psType plmnt) w
    in  maybe w' (curry (placeSpot w') shift) (_idPlacement plmnt i)
placeSpot w (shift, PlacementUsingPos p subpl) = placeSpot w (shift, subpl (shiftPoint3By shift p))

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)

shiftPSBy :: (Point2,Float) -> PlacementSpot -> PlacementSpot
shiftPSBy (pos,rot) ps = ps
    & psPos %~ shiftPointBy (pos,rot)
    & psRot %~ (+ rot)

-- the Int here allows for passing parameters down to other placements:
-- button ids, etc
placeSpotID :: PlacementSpot -> PSType -> World -> (Int, World)
placeSpotID ps pt w = case pt of
    PutProp prop -> placeProp prop p rot w
    PutButton bt -> placeBt bt p rot w
    PutFlIt itm -> placeFlIt itm p rot w
    PutCrit cr -> placeCr cr p rot 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)
    PutDoor col f pss -> placeDoor col f (map (bimap doShift doShift) pss) w
    PutCoordinate coordp -> placeCoordinate (doShift coordp) w
    PutSlideDoor pathing col f a b spd -> placeSlideDoor pathing col f (doShift a) (doShift b) spd w
    PutBlock (hp:hps) col ps' -> placeBlock (map doShift ps') hp col Opaque hps w
    PutBlock{} -> error "messed up block placement somehow"
    PutLineBlock wl wdth dpth a b -> placeLineBlock wl wdth dpth (doShift a) (doShift b) w
    PutWall { _pwPoly = ps', _pwWall = wl } -> (0,placeWallPoly (map doShift ps') wl w)
    PutForeground sh -> (0,w & foregroundShape %~ ((uncurryV translateSHf p . rotateSH rot) sh <>))
    PutNothing -> (0,w)
    PutID i -> (i, w)
  where 
    p@(V2 px py) = _psPos ps
    p' = V3 px py 0
    rot = _psRot ps
    doShift = shiftPointBy (p,rot)

placeWallPoly :: [Point2] -> Wall -> World -> World
placeWallPoly ps wl = rmCrossPaths . over walls (addWalls ps wl)
  where
    rmCrossPaths w = foldr (uncurry removePathsCrossing) w $ loopPairs ps

shiftPointBy :: (Point2,Float) -> Point2 -> Point2
shiftPointBy (pos,rot) p = pos +.+ rotateV rot p

invShiftPointBy :: (Point2,Float) -> Point2 -> Point2
invShiftPointBy (p1,r) p2 = rotateV (-r) $ p2 -.- p1

shiftPoint3By :: (Point2,Float) -> Point3 -> Point3
shiftPoint3By (pos,rot) (V3 x y z) = addZ z $ pos +.+ rotateV rot (V2 x y)

addWalls :: [Point2] -> Wall -> IM.IntMap Wall -> IM.IntMap Wall
addWalls qs wl wls = foldr (addPane wl) wls pairs
  where 
    (p:ps) = orderPolygon qs
    pairs = zip (ps ++ [p]) (p:ps)

addPane :: Wall -> (Point2,Point2) -> IM.IntMap Wall -> IM.IntMap Wall
addPane wl l wls = IM.insert wlid (wl { _wlLine = l, _wlID = wlid }) wls
  where
    wlid = IM.newKey wls

placeCoordinate :: Point2 -> World -> (Int,World)
placeCoordinate p w = (i, w & coordinates %~ IM.insert i p)
  where
    i = IM.newKey $ _coordinates w

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)

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 xs = IM.insert i (f bt) xs
    f = (btRot +~ a) . (btPos %~ ( (p +.+) . rotateV a )) . (btID .~ i)
{- 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 %~ \ fis -> IM.insert i 
    ( FlIt { _flItPos = p , _flItRot = rot , _flItID = i , _flIt = itm }
    ) fis
    )
  where
    i = IM.newKey $ _floorItems w

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

placeMachine :: Color -> [Point2] -> Machine -> Point2 -> Float -> World -> (Int,World)
placeMachine color wallpoly mc p rot w = (mcid
    , w & machines  %~ addMc
        & walls     %~ placeMachineWalls color wallpoly mcid wlid
    )
  where 
    mcid = IM.newKey $ _machines w
    wlid = IM.newKey $ _walls w
    wlids = IS.fromList [wlid .. wlid + length wallpoly - 1]
    addMc mcs = IM.insert mcid (mc {_mcPos = p,_mcDir = rot,_mcID = mcid, _mcWallIDs = wlids}) mcs
-- TODO correctly remove/shift pathfinding lines (removePathsCrossing)
placeMachineWalls :: Color -> [Point2] -> Int -> Int -> IM.IntMap Wall -> IM.IntMap Wall
placeMachineWalls col poly mcid wlid = flip (foldr f) $ zip [wlid..] $ loopPairs poly
  where
    f (wid,l) = IM.insert wid baseWall{_wlID = wid, _wlLine = l}
    baseWall = defaultMachineWall 
        & wlColor .~ col
        & wlStructure . wlStMachine .~ mcid

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
    startPos = onXY (rotateV rot) $ _lsPos ls
    addLS = IM.insert i (ls {_lsPos = V3 x y z +.+.+ startPos,_lsDir = rot,_lsID = i})