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 
    ( module Dodge.LevelGen
    , cutWalls
    , pairsToGraph
    , makeButton
    , makeSwitch
    ) where
import Dodge.Data
--import Dodge.Room.Data
import Dodge.LevelGen.Block
import Dodge.LevelGen.LineBlock
import Dodge.LevelGen.Pathing
import Dodge.LevelGen.StaticWalls
import Dodge.LevelGen.AutoDoor
import Dodge.LevelGen.TriggerDoor
import Dodge.LevelGen.Switch
import Dodge.LevelGen.Data
import Geometry
import Geometry.Vector3D
import Shape
--import Geometry.Data
import Picture
import qualified IntMapHelp as IM

--import System.Random
import Control.Monad.State
--import Control.Applicative
import Control.Lens
import Data.List.Extra
--import Data.Function
--import Data.Maybe
--import qualified Data.Set as S
--import qualified Data.Map as M

placeSpots :: [Placement] -> World -> World
placeSpots pss w = foldr (placeSpot . _placementSpot) w simplePlacements
  where
    (simplePlacements, idPlacements ) = partition isSimple pss
    isSimple SimplePlacement{} = True
    isSimple _ = False

placeSpot :: PlacementSpot -> World -> World
placeSpot 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
    PutLS ls dec -> placeLS ls dec p' rot w
    PutPressPlate pp -> placePressPlate pp p rot w
    RandPS rgen -> placeSpot (set psType evaluatedType ps) (set randGen g w)
      where 
        (evaluatedType, g) = runState rgen (_randGen w)
    PutDoor col f pss -> putDoor col f (map (mapBoth $ shiftPointBy (p,rot)) pss) w
      where 
        mapBoth fn (x,y) = (fn x, fn y) 
    PutDoubleDoor col f a b speed 
        -> putDoubleDoor False col f (shiftPointBy (p,rot) a) (shiftPointBy (p,rot) b) speed w
    PutSingleDoor col f a b speed 
        -> putSingleDoor False col f (shiftPointBy (p,rot) a) (shiftPointBy (p,rot) b) speed w
    PutAutoDoor a b -> addAutoDoor (shiftPointBy (p,rot) a) (shiftPointBy (p,rot) b) w
    PutBlock (hp:hps) col ps' -> putBlock (map (shiftPointBy (p,rot)) ps') hp col False hps w
    PutBlock{} -> error "messed up block placement somehow"
    PutBtDoor c bp f a b speed 
        -> addButtonDoor c (shiftPointBy (p,rot) bp) (f + rot) 
                            (shiftPointBy (p,rot) a) (shiftPointBy (p,rot) b) speed w
    PutLineBlock wl width depth a b
        -> putLineBlock wl width depth (shiftPointBy (p,rot) a) (shiftPointBy (p,rot) b) w
    PutWall { _pwPoly = ps', _pwWall = wl } -> rmCrossPaths $ over walls (addWalls (q:qs) wl) w
      where 
        (q:qs) = map (shiftPointBy (p,rot)) ps'
        rmCrossPaths w' = foldr (uncurry removePathsCrossing) w' $ zip (q:qs) (qs++[q])
    PutForeground sh -> w & foregroundShape %~ ((uncurryV translateSHf p . rotateSH rot) sh <>)
    PutNothing -> w
    PutID _ -> w
    --_   -> w
  where 
    p@(V2 px py) = _psPos ps
    p' = V3 px py 0
    rot = _psRot ps

-- TODO: remove this typeclass
class Shiftable a where
    translateS :: Point2 -> a -> a
    rotateS    :: Float -> a -> a

instance {-# OVERLAPPING #-} Shiftable Point2 where
    translateS = (+.+)
    rotateS    = rotateV

instance (Shiftable a,Shiftable b) => Shiftable (a, b) where
    translateS p (x,y) = (translateS p x,translateS p y)
    rotateS    r (x,y) = (   rotateS r x,   rotateS r y)

instance (Shiftable a) => Shiftable [a] where
    translateS p x = map (translateS p) x
    rotateS    r x = map (rotateS r)    x

instance Shiftable PlacementSpot where
    translateS p' (PS p r x) = PS (p +.+ p') r x
    rotateS    r' (PS p r x) = PS (rotateV r' p) (r + r') x

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

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 (p0,p1) wls = IM.insert (IM.newKey wls) (wl
    { _wlLine = (p0,p1)
    , _wlID = IM.newKey wls
    })
    wls

-- TODO make rotation of props sensible
placeProp 
    :: Prop
    -> Point2
    -> Float -- ^ Rotation
    -> World
    -> World
placeProp pr p a = over props addProp
  where 
    addProp prs = IM.insert (IM.newKey prs) (over pjRot (+a) pr {_pjPos = p, _pjID = IM.newKey prs}) prs

placePropID 
    :: Prop
    -> Point2
    -> Float -- ^ Rotation
    -> World
    -> (World,Int)
placePropID pr p a w = (w & props %~ addProp , k)
  where 
    k = IM.newKey (_props w)
    addProp prs = IM.insert (IM.newKey prs) (over pjRot (+a) pr {_pjPos = p, _pjID = IM.newKey prs}) prs

placeBt 
    :: Button
    -> Point2
    -> Float -- ^ Rotation
    -> World
    -> World
placeBt bt p rot = over buttons addBT
  where 
    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
    -> World
placeFlIt itm p rot = floorItems %~ 
    \ fis -> IM.insert (IM.newKey fis) 
        (FlIt
            { _flItPos = p
            , _flItRot = rot
            , _flItID = IM.newKey fis
            , _flIt = itm
            }
        ) fis

placePressPlate
    :: PressPlate
    -> Point2
    -> Float -- ^ Rotation
    -> World
    -> World
placePressPlate pp p rot = over pressPlates addPP
  where 
    addPP pps = IM.insert (IM.newKey pps) (pp {_ppPos = p,_ppRot = rot}) pps

placeUpdateCr :: Creature -> Point2 -> Float -> World -> (World, PSType)
placeUpdateCr scr p rot w = (w & creatures %~ IM.insert cid cr, PutCrit cr)
  where 
    cid = IM.newKey (_creatures w)
    cr = scr {_crPos = p,_crOldPos = p,_crDir = rot,_crID = cid} 

placeCr :: Creature -> Point2 -> Float -> World -> World
placeCr crF p rot = over creatures addCr
  where 
    addCr crs = IM.insert 
        (IM.newKey crs) 
        (crF {_crPos = p,_crOldPos = p,_crDir = rot,_crID = IM.newKey crs}) 
        crs

placeLS :: LightSource -> Picture -> Point3 -> Float -> World -> World
placeLS ls dec (V3 x y z) rot w = over lightSources addLS $ over decorations addDec w
  where 
    startPos = _lsPos ls
    addLS lss = IM.insert 
        (IM.newKey lss) 
        (ls {_lsPos = V3 x y z +.+.+ startPos,_lsDir = rot,_lsID = IM.newKey lss}) 
        lss
    addDec decs = IM.insert 
        (IM.newKey decs) 
        (translate x y $ rotate (negate rot) dec)
        decs