loop/src/Dodge/LevelGen.hs

{-# LANGUAGE BangPatterns #-}
{-# 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.Base
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 Picture

import System.Random
import Control.Monad.State
import Control.Applicative
import Control.Lens
import Data.List
import Data.Function
import Data.Maybe
import qualified Data.IntMap.Strict as IM
import qualified Data.Set as S
import qualified Data.Map as M


placeSpots :: [PlacementSpot] -> World -> World
placeSpots pss w = foldr placeSpot w pss

placeSpot :: PlacementSpot -> World -> World
placeSpot ps w = case ps of
    PS {_psPos = p, _psRot = rot, _psType = PutButton bt} 
        -> placeBt bt p rot w
    PS {_psPos = p, _psRot = rot, _psType = PutFlIt itm} 
        -> placeFlIt itm p rot w
    PS {_psPos = p, _psRot = rot, _psType = PutCrit cr} 
        -> placeCr cr p rot w
    PS {_psPos = p, _psRot = rot, _psType = PutLS ls dec} 
        -> placeLS ls dec p rot w
    PS {_psPos = p, _psRot = rot, _psType = PutPressPlate pp} 
        -> placePressPlate pp p rot w
    PS {_psType = RandPS rgen} 
        -> placeSpot (set psType evaluatedType ps) (set randGen g w)
      where 
            (evaluatedType, g) = runState rgen (_randGen w)

    PS {_psPos = p, _psRot = rot, _psType = PutDoor col f pss} 
        -> putDoor col f (map (mapBoth $ shiftPointBy (p,rot)) pss) w
      where 
        mapBoth fn (x,y) = (fn x, fn y) 

    PS {_psPos = p, _psRot = rot, _psType = PutDoubleDoor col f a b} 
        -> putDoubleDoor col f (shiftPointBy (p,rot) a) (shiftPointBy (p,rot) b) w

    PS {_psPos = p, _psRot = rot, _psType = PutAutoDoor a b} 
        -> addAutoDoor (shiftPointBy (p,rot) a) (shiftPointBy (p,rot) b) w

    PS {_psPos = p, _psRot = rot, _psType = PutBlock (hp:hps) col ps} 
        -> putBlock (map (shiftPointBy (p,rot)) ps) hp col False hps w

    PS {_psPos = p, _psRot = rot, _psType = PutBtDoor c bp f a b} 
        -> addButtonDoor c (shiftPointBy (p,rot) bp) (f + rot) 
                            (shiftPointBy (p,rot) a) (shiftPointBy (p,rot) b) w
    PS {_psPos = p, _psRot = rot, _psType = PutSwitchDoor c bp f a b} 
        -> addSwitchDoor c (shiftPointBy (p,rot) bp) (f + rot) 
                            (shiftPointBy (p,rot) a) (shiftPointBy (p,rot) b) w

    PS {_psPos = p, _psRot = rot, _psType = PutLineBlock wl width depth a b}
        -> putLineBlock wl width depth (shiftPointBy (p,rot) a) (shiftPointBy (p,rot) b) w

    PS {_psPos = p, _psRot = rot, _psType = 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])

    _   -> w

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


placeBt bt p rot w = over buttons addBT w
  where 
    addBT bts = IM.insert (newKey bts) (bt {_btPos = p, _btRot = rot, _btID = 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 (newKey fis) 
        (FlIt
            { _flItPos = p
            , _flItRot = rot
            , _flItID = newKey fis
            , _flIt = itm
            }
        ) fis

placePressPlate pp p rot w = over pressPlates addPP w
    where addPP pps = IM.insert (newKey pps) (pp {_ppPos = p,_ppRot = rot}) pps

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

placeLS :: LightSource -> Picture -> Point2 -> Float -> World -> World
placeLS ls dec p rot w = over lightSources addLS 
                            $ over decorations addDec w
    where addLS lss = IM.insert (newKey lss) 
                                (ls {_lsPos = p,_lsDir = rot,_lsID = newKey lss}) 
                                lss
          addDec decs = IM.insert (newKey decs) 
                                  (uncurry translate p $ rotate (0 - rot) dec)
                                  decs