{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE FlexibleInstances #-}
module Dodge.LevelGen 
    ( module Dodge.LevelGen
    , cutWalls
    , createInnerWalls
    , checkWalls
    , nubWalls
    , pairsToGraph
    , makeButton
    , makeSwitch
    )
    where

import Dodge.Data
import Dodge.Base

import Dodge.LevelGen.Block
import Dodge.LevelGen.Pathing
import Dodge.LevelGen.StaticWalls
import Dodge.LevelGen.AutoDoor
import Dodge.LevelGen.TriggerDoor
import Dodge.LevelGen.Switch

import Geometry
import Picture

import System.Random

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

-- deals with placement of objects within the world

placeSpots :: [PlacementSpot] -> World -> World
placeSpots pss w = foldr placeSpot w basicPlacements
    where (collectivePlacements,basicPlacements) = partition typeIsCollective pss
          typeIsCollective (ps@PS {}) = case _psType ps of CollectivePS {} -> True
                                                           _               -> False
          typeIsCollective _ = False
          
          groupedPlacements = groupBy ((==) `on` _collectiveID . _psType) 
                                $ sortBy (compare `on` _collectiveID . _psType) collectivePlacements

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 fi} 
        -> placeFlIt fi 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 = PutTriggerDoor col f a b} 
        -> addTriggerDoor 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 = PutBlockWall (hp:hps) col ps} 
        -> putBlockWallPart (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 = PutWindowBlock a b}
        -> putWindowBlock (shiftPointBy (p,rot) a) (shiftPointBy (p,rot) b) w

    PS {_psPos = p, _psRot = rot, _psType = PutWindow { _pwPoly = ps, _pwColor = c }}
        -> rmCrossPaths $ over walls (addWindow (q:qs) c) w
--                where (q:qs) = translateS p $ rotateS rot ps
                where (q:qs) = map (shiftPointBy (p,rot)) ps
                      rmCrossPaths w = foldr (uncurry removePathsCrossing) w $ zip (q:qs) (qs++[q])

    _   -> w

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 RoomLink where
    translateS q (RL p r) = RL (p +.+ q) r
    rotateS    s (RL p r) = RL (rotateV s p) (r+s)

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

putWindowBlock :: Point2 -> Point2 -> World -> World
putWindowBlock a b w = removePathsCrossing a b $ foldr makeBlockAt w $ zip ps ns
    where d = dist a b
          rot = argV (b -.- a)
          numPoints' = floor (d / 20)
          numPoints = numPoints'*2
          ns = take (numPoints+1) [0..]
          ps = map (\i -> a +.+ i/ (fromIntegral numPoints) *.* (b -.- a)) 
                   $ map fromIntegral ns
          k = newKey $ _walls w
          ksAtN i = [k+i*4,k+i*4 + 1 ,k+i*4 +2, k+i*4+3]
          bSide = d / (fromIntegral numPoints)
          ds = [(-bSide,-10),(-bSide,10),(bSide,10),(bSide,-10)]
          polyAtP p = map ((+.+) p . rotateV rot) ds
          hp = 1
          degradeHP = [5,5]
          winCol = withAlpha 0.5 cyan
          makeBlockAt :: (Point2,Int) -> World -> World
          makeBlockAt (p,i) w = 
            let (k0:k1:k2:k3:_) = ksAtN i
                (bl:tl:tr:br:_) = polyAtP p
                shadows | i == 0 = ksAtN 1
                        | i == numPoints - 1 = ksAtN $ numPoints - 2
                        | otherwise = ksAtN (i-1) ++ ksAtN (i+1)
                seen | even i    = True
                     | otherwise = False
                isLeftmost | i == 0 = True
                           | otherwise = False
                isRightmost | i == numPoints = True
                            | otherwise = False
                l = baseBlock 
                        { _wlLine = [bl,tl]
                        , _wlID = k0
                        , _blVisible = isLeftmost
                        }
                t = baseBlock 
                        { _wlLine = [tl,tr]
                        , _wlID = k1
                        , _blVisible = seen
                        }
                r = baseBlock 
                        { _wlLine = [tr,br]
                        , _wlID = k2
                        , _blVisible = isRightmost
                        }
                b = baseBlock 
                        { _wlLine = [br,bl]
                        , _wlID = k3
                        , _blVisible = seen
                        }
                baseBlock = Block
                        { _wlLine = []
                        , _wlID = 0
                        , _wlColor = winCol
                        , _wlDraw = Nothing
                        , _wlSeen = False
                        , _blIDs = ksAtN i
                        , _blHP = hp
                        , _wlIsSeeThrough = True
                        , _blVisible = seen
                        , _blShadows = shadows
                        , _blDegrades = degradeHP
                        , _wlCastShadow = False
                        }
                f = IM.insert k0 l . IM.insert k1 t . IM.insert k2 r . IM.insert k3 b
            in  over walls f w

shiftPointBy (pos,rot) p = pos +.+ rotateV rot p

addWindow :: [Point2] -> Color -> IM.IntMap Wall -> IM.IntMap Wall
addWindow qs c wls = foldr (addPane c) wls pairs
    where (p:ps) = orderPolygon qs
          pairs = zip (ps ++ [p]) (p:ps)
addPane :: Color -> (Point2,Point2) -> IM.IntMap Wall -> IM.IntMap Wall
addPane c (p0,p1) wls = IM.insert (newKey wls) (Wall { _wlLine = [p0,p1]
                                                     , _wlID = newKey wls
                                                     , _wlColor = c
                                                     , _wlDraw = Nothing
                                                     , _wlSeen = False 
                                                     , _wlIsSeeThrough = True
                                                     }
                                               ) 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
placeFlIt fi p rot w = over floorItems addFI w
    where addFI fis = IM.insert (newKey fis) (fi {_flItPos = p, _flItRot = rot, _flItID = newKey fis}) 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 -> Drawing -> 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