module Map where

import Rules

import Data.Array.IO
import Control.Monad.State

import Data.Array.IO
import System.IO

import Debug.Trace

mkWorld :: Int -> Int -> [[Tile]] -> IO (IOArray (Int, Int) Tile)
mkWorld width height ts 
     = do arr <- newArray ((0,0), (width-1, height-1)) Empty
          setArr arr 0 (reverse ts)
          return arr
    where setArr arr h (l : ls) = do setLine arr h 0 l
                                     setArr arr  (h+1) ls
          setArr arr h [] = return ()
          setLine arr h c (x : xs) = do writeArray arr (h,c) x
                                        setLine arr h (c + 1) xs
          setLine arr h c [] = return ()


parseMeta s l 
   = case words l of
        ["Growth", r] -> s { growthrate = read r }
        ["Razors", r] -> s { razors = read r }
        ["Water", r] ->  s { waterlevel = read r }
        ["Waterproof", r] ->  s { waterproofing = read r }
        ["Flooding", r] -> s { floodstep = read r, floodrate = read r }
        ["Trampoline", [x], "targets", [y]] 
                      -> s { trampPath = updateMap y x (trampPath s) }
        _ -> s

updateMap x y [] = []
updateMap x y ((k, v) : xs) | x == k = (x, v) : (y, v) : updateMap x y xs
                            | otherwise = (k, v) : updateMap x y xs

loadMap :: a -> FilePath -> Bool -> IO (GameState a)
loadMap extra f tr 
          = do fdata <- readFile f
               let (tiles, metadata) = span (not.null) $ lines fdata
               let (w, h) = (maximum (map length tiles), length tiles)
               world <- newArray ((0,0), (w-1, h-1)) Empty
               oldworld <- newArray ((0,0), (w-1, h-1)) Empty
               let initSt = GS extra 
                            (0,0) (0, 0) 0 0 0 0 0 0 growth [] [] False False False False 
                            tr world 0 0 0 0 10 oldworld 0 2
               let mSt = foldl parseMeta initSt metadata
               mSt' <- execStateT (buildWorld w h tiles) mSt
               -- HACK! Do it again to update trampoline metadata
               return $ foldl parseMeta mSt' metadata

buildWorld :: Int -> Int -> [[Char]] -> StateT (GameState a) IO ()
buildWorld w h ts = setArr 0 (reverse (take h ts))
    where setArr h (l : ls) = do setLine h 0 (take w l)
                                 setArr (h + 1) ls
          setArr h [] = return ()
          setLine h c (x : xs) = do st <- get
                                    st' <- lift $ setAt st h c x
                                    put st'
                                    setLine h (c + 1) xs
          setLine h c [] = return ()

          setAt st h c '#' = do writeArray (world st) (c,h) Wall
                                return st
          setAt st h c 'R' = do writeArray (world st) (c,h) Player
                                return (st { playerpos = (c,h) })
          setAt st h c 'L' = do writeArray (world st) (c,h) Exit
                                return (st { exitpos = (c,h) })
          setAt st h c '.' = do writeArray (world st) (c,h) Dirt
                                return st
          setAt st h c '%' = do writeArray (world st) (c,h) (Bug UP RIGHT)
                                return st
          setAt st h c '*' = do writeArray (world st) (c,h) Rock
                                return st
          setAt st h c '@' = do writeArray (world st) (c,h) LamRock
                                return (st { lambdas = 1 + lambdas st,
                                             totalLams = 1 + totalLams st })
          setAt st h c '!' = do writeArray (world st) (c,h) Razor
                                return st
          setAt st h c 'W' = do writeArray (world st) (c,h) (Beard (growthrate st - 1))
                                return st
          setAt st h c '\\' = do writeArray (world st) (c,h) Lambda
                                 return (st { lambdas = 1 + lambdas st,
                                              totalLams = 1 + totalLams st })
          setAt st h c t 
              | t `elem` ['A'..'I']
                = do writeArray (world st) (c,h) (Trampoline t)
                     return $ st { trampLocs = (t, (c, h)) : trampLocs st }
              | t `elem` ['1'..'9']
                = do writeArray (world st) (c,h) Target
                     return $ st { trampPath = (t, (c, h)) : trampPath st }
          setAt st h c _ = do writeArray (world st) (c,h) Empty
                              return st

testWorld = let top = take 32 (repeat Wall)
                side = Wall : take 30 (repeat Empty) ++ Wall : [] in
             mkWorld 32 32 $ top : take 30 (repeat side) ++ top : []

stepWorld t s | mkTrace s
              = if (xmove s /= 0 || ymove s /= 0 || shave s || pause s)
                    then 
                      do printTrace s
                         hFlush stdout
                         s <- movePlayer s
                         s <- moveBugs s
                         s <- applyRules s
                         return $ s { timeSinceUpdate = 0, 
                                      xmove = 0, ymove = 0,
                                      shave = False, pause = False }
                    else return s
stepWorld t s = let time = t + timeSinceUpdate s in
                    if time > 0.1 && not (dead s) then
                      do s <- movePlayer s
                         s <- moveBugs s
                         s <- applyRules s
                         return $ s { timeSinceUpdate = 0}
                      else return $ s { timeSinceUpdate = time }               

stepSimulate v t (s_in, ('A':cs)) = stepSimulate v t (s_in, []) -- abort
stepSimulate v t (s_in, (c : cs))
  | not (dead s_in)
    = do let s = mkMove s_in c 
         s <- movePlayer s
         s <- moveBugs s
         s <- applyRules s
         return (s, cs)
stepSimulate v t (s, []) 
  | not (dead s)
    = do s <- moveBugs s
         s <- applyRules s
         return (s, [])
stepSimulate v t s = return s

validate s_in ('A' : cs) = validate s_in [] -- abort
validate s_in (c : cs)
  | not (dead s_in) && c `elem` "UDLRWS"
    = do let s = mkMove s_in c
         s <- movePlayer s
         s <- moveBugs s
         s <- applyRules s
         validate s cs
  | otherwise = validate s_in cs
validate s _ 
    = do return s

mkMove :: GameState a -> Char -> GameState a
mkMove s 'U' = s { ymove = 1, xmove = 0, shave = False }
mkMove s 'D' = s { ymove = -1, xmove = 0, shave = False }
mkMove s 'L' = s { ymove = 0, xmove = -1, shave = False }
mkMove s 'R' = s { ymove = 0, xmove = 1, shave = False }
mkMove s 'W' = s { ymove = 0, xmove = 0, shave = False }
mkMove s 'S' = s { ymove = 0, xmove = 0, shave = True }
mkMove s _ = s

printTrace :: GameState a -> IO ()
printTrace s 
    | xmove s == 1 = putStr "R"
    | xmove s == -1 = putStr "L"
    | ymove s == 1 = putStr "U"
    | ymove s == -1 = putStr "D"
    | shave s = putStr "S"
    | pause s = putStr "W"
printTrace _ = return ()