import System.Environment (getArgs)
import Data.Maybe (fromJust)
import Debug.Trace (trace)
import Data.List (isPrefixOf)

main :: IO ()
main = do (boardFile:steps) <- getArgs
          boardString       <- readFile boardFile
          if null steps
            then putStrLn "Spelletjes spelen en zo"
          else
            putStr . unlines . map printBoard $ scanl (flip walk) (stringToBoard boardString) (map parseDir steps)
              where stringToBoard bs = parseBoard (splitLines bs) (Board [] [] (Player (0, 0) (0, 0) up ) Playing) 0

splitLines :: String -> [String]
splitLines str = foldr f [[]] str
  where f c l@(x:xs)
          | c == '\n'      = []    : l
          | otherwise      = (c:x) : xs

-- define necessary types/datatypes

data Board = Board [Surface] [Sausage] Player Status

data Surface =  Surface { surfaceType :: SurfaceType
                        , surfacePos  :: Coordinate }

data SurfaceType = Grass | Water | Grill

data Sausage = Sausage { fstHalf  :: SausageHalf
                       , sndHalf  :: SausageHalf
                       , orient   :: Orientation }

data SausageHalf  = SausageHalf { topState    :: SausageState
                                , bottomState :: SausageState
                                , sausagePos  :: Coordinate }

sausageUpper :: Char
sausageUpper = '\8745'

sausageLower :: Char
sausageLower = '\8746'

sausageLeft :: Char
sausageLeft = '\8834'

sausageRight :: Char
sausageRight = '\8835'

data Orientation = Vertical | Horizontal deriving (Eq)

data SausageState = Raw | Cooked | Burned

data Player = Player { bodyPos   :: Coordinate
                     , forkPos   :: Coordinate
                     , direction :: Direction }

data Status = Won | Lost | Playing

type Coordinate = (Int, Int)

type Direction = (Int, Int)

up :: Direction
up    =  (-1, 0)

down :: Direction
down  =  (1, 0)

left :: Direction
left  =  (0, -1)

right :: Direction
right =  (0, 1)

moveCoord :: Coordinate -> Direction -> Coordinate
moveCoord (row, col) (dy, dx) = (row + dy, col + dx)

-- parsing and printing

parseDir :: String -> Direction
parseDir dir
  | dir == "N" = up
  | dir == "W" = left
  | dir == "S" = down
  | dir == "E" = right


parseBoard :: [String] -> Board -> Int -> Board
parseBoard [] board _                  = board
parseBoard (line:rest) board rowNumber = parseBoard rest board' (rowNumber+1)
  where board' = parseBoardLine line board rowNumber 0


parseBoardLine :: String -> Board -> Int -> Int -> Board
parseBoardLine "" board _ _ = board
parseBoardLine (s:m:rest) board row col = parseBoardLine rest board' row (col+1)
  where board'  = parseBoardCell (s, m) row col board


parseBoardCell :: (Char, Char) -> Int -> Int -> Board -> Board
parseBoardCell (s, m) row col (Board surfaces sausages player st)
  | m `elem` [sausageUpper,sausageLeft] = Board surfaces' (sausage : sausages) player st
  | m `elem` ['N', 'E', 'S', 'W']       = Board surfaces' sausages player' st
  | otherwise                           = Board surfaces' sausages player st
  where surface
          | s == '~'  = Surface Water (row, col)
          | s == '+'  = Surface Grass (row, col)
          | s == '#'  = Surface Grill (row, col)
        surfaces' = (surface : surfaces)
        sausage = Sausage firstHalf secondHalf orientation
          where (dY, dX, orientation)
                  | m == sausageUpper = (1, 0, Vertical)
                  | m == sausageLeft  = (0, 1, Horizontal)
                firstHalf   = SausageHalf Raw Raw (row, col)
                secondHalf  = SausageHalf Raw Raw (row + dY, col + dX)
        player' = Player body fork (dY, dX)
          where (dY, dX)   = parseDir [m]
                body    = (row, col)
                fork    = (row + dY, col + dX)


printBoard :: Board -> String
printBoard (Board _ _ _ Won)            = "Opgelost!\n"
printBoard board@(Board surfaces _ _ _) = helper (reverse surfaces) board ""
  where
    helper :: [Surface] -> Board -> String -> String
    helper [] _ str                   = str
    helper [surf] board str           = helper [] board (str ++ (surface surf) ++ (movable $ surfacePos surf)) ++ "\n"
    helper (surf:next:rest) board str = helper (next:rest) board (str ++ (surface surf) ++ (movable $ surfacePos surf) ++ newLine)
      where newLine
              | ((fst $ surfacePos surf) + 1) == (fst $ surfacePos next) = "\n"
              | otherwise                                                = ""
    movable pos
      | sausageSymbol board pos   /= Nothing = fromJust $ sausageSymbol board pos
      | playerSymbol board pos    /= Nothing = fromJust $ playerSymbol board pos
      | hasFork board pos                    = "x"
      | otherwise                            = " "
    surface (Surface Grass _) = "+"
    surface (Surface Water _) = "~"
    surface (Surface Grill _) = "#"



sausageSymbol :: Board -> Coordinate -> Maybe String
sausageSymbol (Board _ sausages _ _) pos = findSausage sausages
  where findSausage []     = Nothing
        findSausage ((Sausage fstHalf sndHalf ori):xs)
          | sausagePos fstHalf == pos = Just $ fstHalfSymbol fstHalf
          | sausagePos sndHalf == pos = Just $ sndHalfSymbol sndHalf
          | otherwise                 = findSausage xs
          where fstHalfSymbol (SausageHalf Raw _ _)
                  | ori == Vertical = "∩"
                  | otherwise       = "⊂"
                fstHalfSymbol (SausageHalf Cooked _ _)
                  | ori == Vertical = "∧"
                  | otherwise       = "<"
                fstHalfSymbol (SausageHalf Burned _ _)
                  | ori == Vertical = "⊓"
                  | otherwise       = "⊏"
                sndHalfSymbol (SausageHalf Raw _ _)
                  | ori == Vertical = "∪"
                  | otherwise       = "⊃"
                sndHalfSymbol (SausageHalf Cooked _ _)
                  | ori == Vertical = "∨"
                  | otherwise       = ">"
                sndHalfSymbol (SausageHalf Burned _ _)
                  | ori == Vertical = "⊔"
                  | otherwise       = "⊐"


playerSymbol :: Board -> Coordinate -> Maybe String
playerSymbol (Board _ _ player _) pos
  | bodyPos player == pos = Just $ (dirSymbol (direction player))
  | otherwise             = Nothing
      where dirSymbol dir
              | dir == up    = "N"
              | dir == down  = "S"
              | dir == left  = "W"
              | dir == right = "E"


hasFork :: Board -> Coordinate -> Bool
hasFork (Board _ _ player _) pos = (forkPos player) == pos

-- moving player

walk :: Direction -> Board -> Board
walk dir board
  | isRotation dir board = checkIfWon . modifySausages . (rotatePlayer dir) $ board
  | canMove    dir board = checkIfWon . modifySausages . (movePlayer dir) $ board
  | otherwise            = board
  where isRotation mdir (Board _ _ (Player _ _ pdir) _)
          =   (mdir `elem` [left, right] && pdir `elem` [up, down])
           || (mdir `elem` [up, down]    && pdir `elem` [left, right])


canMove :: Direction -> Board -> Bool
canMove dir (Board surfaces _ player _) = walkable neighborSurface
  where pdir = direction player
        bpos = bodyPos player
        hasPos (Surface _ spos) = spos == moveCoord bpos dir
        neighborSurface =  head $ filter hasPos surfaces
        walkable (Surface Grass _) = True
        walkable _                 = False


rotatePlayer :: Direction -> Board -> Board
rotatePlayer dir (Board surf saus player st) = Board surf saus' player' st
  where body    = bodyPos player
        fork    = forkPos player
        fork'   = moveCoord body dir
        player' = Player body fork' dir
        -- when rotating, the player can potentially
        -- move a sausage at two positions, we'll call those positions
        -- pos1 and pos2
        pos1  = moveCoord fork dir
        pos2  = fork'
        (dy, dx) = direction player
        oppositeDir = (dy * (-1), dx * (-1))
        saus' = (moveSausage pos2 oppositeDir) . (moveSausage pos1 dir) $ saus

movePlayer :: Direction -> Board -> Board
movePlayer dir (Board surf saus (Player b f pdir) st)
  = Board surf saus' (Player (moveCoord b dir) (moveCoord f dir) pdir) st
  where b'    = moveCoord b dir
        f'    = moveCoord f dir
        reverseMovement = dir /= pdir
        saus'
        -- if the player is walking backwards, then sausages behind him should be moved
          | reverseMovement = moveSausage b' dir saus
          | otherwise       = moveSausage f' dir saus

moveSausage :: Coordinate -> Direction -> [Sausage] -> [Sausage]
moveSausage pos dir sausages
  | null $ filter (hasPos pos)  sausages = sausages
  -- if there are no sausages at this position, do nothing
  | null $ filter (hasPos pos') sausages = map (moveAtPos pos) sausages
  -- if there are no sausages next to the sausages at this position, only move this sauges
  | otherwise                            = map (moveAtPos pos) (moveSausage pos' dir sausages)
  -- otherwise, move the sausages next to this sausage before moving this saugage
  where
    pos' = moveCoord pos dir
    hasPos p (Sausage fh sh _) = (sausagePos fh) == p || (sausagePos sh) == p
    moveAtPos p s@(Sausage _ _ ori)
      | not (hasPos p s)   = s
      | fromSide           = rolled s
      | otherwise          = shoved s
      where
        ori = orient s
        fromSide =   (ori == Vertical && dir `elem` [left, right])
                  || (ori == Horizontal && dir `elem` [up, down])
    rolledHalf (SausageHalf t b c) = SausageHalf b t (moveCoord c dir)
    -- rolledHalf returns a sausage half where the top and bottom are switched
    rolled (Sausage fh sh ori) = Sausage (rolledHalf fh) (rolledHalf sh) ori
    shovedHalf (SausageHalf t b c) = SausageHalf t b (moveCoord c dir)
    shoved (Sausage fh sh ori) = Sausage (shovedHalf fh) (shovedHalf sh) ori

modifySausages :: Board -> Board
-- checks if any sausages are on a grill or in the water and
-- modifies them accordingly
modifySausages (Board surfaces sausages pl st) = Board surfaces sausages' pl st'
  where nextState Raw    = Cooked
        nextState Cooked = Burned
        nextState Burned = Burned
        surfAtPos pos = filter (\(Surface _ p) -> p == pos) surfaces
        hasGrill (Surface Grill _) = True
        hasGrill _                 = False
        grillHalf s@(SausageHalf t b pos)
          -- if there are no grills at the half's position, don't grill it
          -- otherwise grill it
          | null $ filter hasGrill (surfAtPos pos)  = s
          | otherwise                               = SausageHalf t (nextState b) pos
        grill (Sausage fh sh ori) = Sausage (grillHalf fh) (grillHalf sh) ori
        hasWater (Surface Water _) = True
        hasWater _                 = False
        halfUnsunken (SausageHalf _ _ pos) = (null $ filter hasWater (surfAtPos pos)) && (not $ null (surfAtPos pos))
        ssgUnsunken  (Sausage fh sh _) = halfUnsunken fh || halfUnsunken sh
        unsunken = filter ssgUnsunken sausages

        st'
        -- if a sausage has sunk, the game is lost
          | (length unsunken) == (length sausages) = st
          | otherwise                              = Lost

        sausages' = map grill unsunken


checkIfWon :: Board -> Board
checkIfWon b@(Board _ _ _ Lost) = b
checkIfWon (Board surfaces sausages _ _) =