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