Sokoban text clone

Question

I rewrote this simple, list-based Sokoban implementation a few times, trying to make it better. Right now, I'm stuck without ideas, but I still feel there is room for improvement, specially in runLoop and data types.

Is there anything, such as monad transformers, FRP, lenses, or anything else that I should study to be able to improve it?

module Main where

import Control.Monad.Loops
import Data.Char
import Data.List
import Data.Maybe
import Linear.V2
import System.IO

type Tile = Char
type Level = [[Tile]]
type Position  = V2 Int
type Direction = V2 Int

up    = V2   0 (-1)
down  = V2   0   1
left  = V2 (-1)  0
right = V2   1   0

sampleLevel =   "############  \n\
                \#..  #     ###\n\
                \#..  # $  $  #\n\
                \#..  #$####  #\n\
                \#..    @ ##  #\n\
                \#..  # #  $ ##\n\
                \###### ##$ $ #\n\
                \  # $  $ $ $ #\n\
                \  #    #     #\n\
                \  ############\n"

main = do
    initialize
    runLoop $ readLevel sampleLevel
    return ()

initialize :: IO ()
initialize = do
    hSetEcho stdin False
    hSetBuffering stdin NoBuffering 

readLevel :: String -> Level
readLevel = lines

showLevel :: Level -> IO ()
showLevel = putStrLn . unlines

runLoop :: Level -> IO Level
runLoop level = do
    showLevel level
    if isFinished level then do
        putStrLn "Congratulations!"
        return level
    else do
        command <- iterateUntil (`elem` "WASDX") $ toUpper <$> getChar
        case command of
            'W' -> runLoop $ tryMove level $ up
            'A' -> runLoop $ tryMove level $ left
            'S' -> runLoop $ tryMove level $ down
            'D' -> runLoop $ tryMove level $ right
            'X' -> return level

isFinished :: Level -> Bool
isFinished = isNothing . findIndex (`elem` ".+") . concat

tryMove :: Level -> Direction -> Level
tryMove level direction = foldl setTile level $ zip positions updatedTiles
    where
        updatedTiles = case getTile level <$> positions of
            ['@',' ', _ ] -> " @"
            ['@','.', _ ] -> " +"
            ['+',' ', _ ] -> ".@"
            ['+','.', _ ] -> ".+"
            ['@','$',' '] -> " @$"
            ['@','$','.'] -> " @*"
            ['@','*',' '] -> " +$"
            ['@','*','.'] -> " +*"
            ['+','$',' '] -> ".@$"
            ['+','$','.'] -> ".@*"
            ['+','*',' '] -> ".+$"
            ['+','*','.'] -> ".+*"
            otherwise     -> "" 
        positions = [pusherPosition level + direction * pure x | x <-[0..2]]

pusherPosition :: Level -> Position
pusherPosition xss = head [ V2 x y
                          | (y, line) <- zip [0..] xss
                          , (x, tile) <- zip [0..] line
                          , tile `elem` "@+" ] 

getTile :: Level -> Position -> Tile
getTile xss (V2 x y) = xss !! y !! x

setTile :: Level -> (Position,Tile) -> Level
setTile xss (V2 x y, tile) = adjust (update tile x) y xss 

adjust :: (a -> a) -> Int -> [a] -> [a]
adjust f index xs = take index xs ++ f (xs !! index) : drop (index + 1) xs

update :: a -> Int -> [a] -> [a]
update value index xs = adjust (const value) index xs

Answer 1

Lens: ix y . ix x can replace your last four definitions.

Why does runLoop return IO Level as opposed to IO () when you never use the Level?

I would inline readLevel, or do you plan to make it more complicated in later versions?

I would change tryMove's type signature into Direction -> Level -> Level.