Haskell Quiz/Sokoban/Solution Anton

-- Rubyquiz Nr. 5 - Sokoban - Haskell solution
-- Copyright (C) 2011 Anton Pirogov
module Main where
 
import System (getArgs)
import System.IO
import System.IO.Unsafe (unsafePerformIO)
import Data.Char (chr)
import Data.Function (on)
import Data.List (groupBy, findIndex)
import Data.Maybe (fromJust, isJust, isNothing)
 
main = do
  args <- getArgs
  let startlevel = if not $ null args then (-1)+read (args !! 0) else 0
  hSetBuffering stdin NoBuffering
  hSetBuffering stdout NoBuffering
  playFrame [] startlevel (0,0) 0
 
playFrame l n p m = do
  -- check whether a new level is started (moves = 0) and init if neccessary
  let lvl = if m == 0 then levels !! n else l
  let pos@(x,y) = if m == 0 then findPlayer lvl else p
  if m == 0 then clearScr else return ()
 
  outputFrame lvl n pos m
 
  c <- getChar
  case () of _
               | c=='q' -> do clearScr; cursorTo (0,0); return ()  -- quit game
               | c=='r' -> playFrame lvl n pos 0
               | c=='n' -> if n<maxlevel then playFrame lvl (n+1) pos 0 else playFrame lvl n pos m
               | c=='p' -> if n>0 then playFrame lvl (n-1) pos 0 else playFrame lvl n pos m
               | any (==c) "wasd" -> let nlvl = tryMove lvl pos $ getDirection c in
                                     if lvl == nlvl then playFrame lvl n pos m
                                     else playFrame nlvl n (findPlayer nlvl) (m+1)
               | otherwise -> playFrame lvl n pos m
 
tryMove lvl (x,y) (dx,dy) =
  if a==' ' then apply '@' b else
  if a=='.' then apply '+' b else
  if a=='o' && b==' ' then apply '@' 'o' else
  if a=='o' && b=='.' then apply '@' '*' else
  if a=='*' && b=='.' then apply '+' '*' else
  if a=='*' && b==' ' then apply '+' 'o' else
  lvl
  where apply n m = setPos (x,y) (if p=='@' then ' ' else '.') $ setPos (x+dx,y+dy) n $ setPos (x+2*dx,y+2*dy) m lvl
        p = getPos lvl (x,y)
        a = getPos lvl (x+dx,y+dy)
        b = getPos lvl (x+2*dx,y+2*dy)
 
getDirection c = case c of
  'w' -> (0,-1)
  'a' -> (-1,0)
  's' -> (0,1)
  'd' -> (1,0)
 
-- Not portable, relying on ANSI escape sequences
clearScr = putStr (chr 27:"[2J")
cursorTo (x,y) = putStr (chr 27:"["++show (y+1)++";"++show (x+1)++"H")
----
 
levels = unsafePerformIO $ do fmap split $ readFile "sokoban_levels.txt"
  where split = filter (/=[""]) . groupBy ((==) `on` (=="")) . lines
 
maxlevel = (length levels) - 1
 
setPos (v,w) n lvl = a ++ (x++n:z):c
  where (a,b:c) = splitAt w lvl
        (x,y:z) = splitAt v b
 
getPos lvl (x,y) = lvl !! y !! x
 
findPlayer lvl = foldl findpos (-1,0) lvl
  where findpos (x,y) l = let r = findIndex (\a -> a=='@' || a=='+') l in
                            if isNothing r then
                              if x == -1 then (-1,y+1) else (x,y)
                            else (fromJust r,y)
 
checkSolved lvl = foldl (\a b -> if isJust $ findIndex (=='.') b then False else a) True lvl
 
outputFrame level nr pos moves = do
  cursorTo (0,0)
  putStr $ unlines level
  putStrLn $ "\nSokoban Level Nr.:\t"++show (nr+1)
  putStrLn $ "Number of moves:\t"++show moves
  putStrLn "Help: W,A,S,D -> Movement, R -> restart level, Q -> Quit game"
  putStrLn "N -> next level, P -> previous level\n"
  let solved = checkSolved level
  if solved then if nr<maxlevel
                 then putStrLn "Level solved! Press N for next level!"
                 else putStrLn "YOU ARE THE ULTIMATE SOKOBAN MASTER! CONGRATULATIONS!"
  else return ()
  cursorTo pos