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
    ) 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)) w
    in  maybe w' (curry (placeSpot w') shift) (_idPlacement plmnt i)
placeSpot w (shift, PlacementPos p subpl) = placeSpot w (shift, subpl (shiftPoint3By shift p))

shiftPlacement :: (Point2,Float) -> Placement -> Placement
shiftPlacement shift (Placement ps f) = Placement (shiftPSBy shift ps)
     (fmap (fmap $ shiftPlacement shift) f)
shiftPlacement shift (PlacementPos p f) = PlacementPos (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 -> World -> (Int, World)
placeSpotID ps w = case _psType ps 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 (set psType evaluatedType ps) (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,rmCrossPaths $ over walls (addWalls qs wl) w)
      where 
        qs = map doShift ps'
        rmCrossPaths w' = foldr (uncurry removePathsCrossing) w' $ loopPairs qs
    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)

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

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)
    --addBT bts = IM.insert (IM.newKey bts) (bt {_btPos = p, _btRot = rot, _btID = IM.newKey bts}) bts
{- 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})