A Haskell BSQ solver, because why not, right?

BSQ.hs

{-# LANGUAGE NamedFieldPuns #-}
module Main where

import qualified Data.Array as A
import Text.Read
import Safe
import Data.Maybe
import Control.Monad
import System.Environment

type InputStream = A.Array Int Char

data Best = Best { pos :: (Int, Int)
                 , size :: Int }
                 deriving Show

chooseBest :: Best -> Best -> Best
chooseBest a@(Best _ sa) b@(Best _ sb) | sa < sb = b
                                       | otherwise = a

data Descriptor = Descriptor 
    { square   :: Char
    , obstacle :: Char 
    , empty    :: Char
    , lineC    :: Int }
    deriving (Show, Eq)

data BSQ = BSQ 
    { descriptor :: Descriptor
    , chars      :: String }
    deriving (Show, Eq)

checkDescriptor :: Descriptor -> Bool
checkDescriptor Descriptor{obstacle, square, empty, lineC} =
       obstacle /= square 
    && empty /= square
    
parseDescriptor :: String -> Maybe Descriptor
parseDescriptor s = do
    descriptor <- Descriptor <$> sq <*> obs <*> emp <*> size
    if checkDescriptor descriptor 
    then pure descriptor 
    else Nothing

    where sq   = lastMay s
          obs  = initMay s >>= lastMay
          emp  = initMay s >>= initMay >>= lastMay
          size = initMay s >>= initMay >>= initMay >>= readMaybe  


without :: Eq a => [a] -> a -> [a]
without (x:xs) t | x == t = without xs t
                 | otherwise = x : without xs t
without [] t = []

checkField :: String -> Descriptor -> Bool
checkField s Descriptor{obstacle, square, empty, lineC} =
        all (uncurry (==)) (zip (map length ls) (map length nex))
        && null (s `without` obstacle
                   `without` square
                   `without` empty
                   `without` '\n')
        && lineC == length (lines s)
    where ls = lines s
          nex = tail ls

readBSQ :: String -> Maybe BSQ
readBSQ s = do
    desc <- parseDescriptor descriptor
    buf <- rest
    if checkField buf desc
    then pure $ BSQ desc buf
    else Nothing 
    where descriptor = takeWhile (/='\n') s 
          rest = tailMay $ dropWhile (/='\n') s

type Field = A.Array (Int, Int) Int

mkField :: (Int, Int) -> Field
mkField (w, h) = A.array 
    ((0, 0), (w, h)) 
    [ ((x, y), 0) | x <- [0..w], y <- [0..h] ]

populateField :: Field -> (Int, Int) -> Bool -> Field
populateField field (x, y) isObstacle 
    | isObstacle = field A.// [ ((x, y), 0) ]
    | otherwise = field A.// [ ((x, y), min + 1) ]

    where min = minimum [ field A.! (x - 1, y - 1)
                        , field A.! (x    , y - 1)
                        , field A.! (x - 1, y    )
                        ]

getWidth :: BSQ -> Int
getWidth BSQ{chars} = length . head . lines $ chars

startBest :: Best
startBest = Best (0, 0) 0

type FieldFinder = (Field, Best)

findBest bsq@BSQ{descriptor=Descriptor{lineC, obstacle}, chars} =
    foldl (\(f, best) ((x, y), v) -> 
        let newField = populateField f (x, y) (obstacle == v)
            nbest = chooseBest best (Best (x, y) (newField A.! (x, y)))
            in (newField, nbest)) ff charfield
    where stfield = mkField (getWidth bsq, lineC)
          ff = (stfield, startBest)
          charfield = [ ((x, y), v) | (y, ls) <- zip [1..] (lines chars) , (x, v) <- zip [1..] ls]

showField :: A.Array (Int, Int) Int -> (Int, Int) -> IO ()
showField arr (w, h) =
    forM_ [1..h] $ \y -> do
        forM_ [1..w] $ \x ->
            putStr . show $ (arr A.! (x, y))
        putChar '\n'

isInBest :: (Int, Int) -> Best -> Bool
isInBest (x, y) (Best (x_, y_) size) =
       x <= x_ && x >= x_ - size
    && y <= y_ && y >= y_ - size

showSolvedBSQ :: BSQ -> Field -> Best -> IO ()
showSolvedBSQ bsq field best =
    forM_ [1..height] $ \y -> do
        forM_ [1..width] $ \x ->
            case field A.! (x, y) of
                0 -> putChar obstacle
                _ | isInBest (x, y) best -> putChar square 
                _ -> putChar empty

        putChar '\n' 
    where BSQ{descriptor=Descriptor{lineC = height, obstacle, square, empty}} = bsq
          width = getWidth bsq


main :: IO ()
main = do
    args <- getArgs
    forM_ args $ \arg -> do
        stuff <- readFile arg
        case readBSQ stuff of
            Just bsq -> do
                let BSQ{descriptor=Descriptor{lineC}} = bsq
                let (field, best) = findBest bsq
                showSolvedBSQ bsq field best
            _ ->
                putStrLn "map error"