parabox/app/Parser.hs

{-# Language ViewPatterns #-}
module Parser where

import Model
import Graphics.Vty.Attributes
import Data.Array (Array, listArray)
import Data.Map qualified as Map
import Data.Set qualified as Set

parse :: String -> World
parse str = either error id $
  case lines str of
    x:xs ->
      do h <- parseHeader x
         bs <- parseBlocks xs
         let m = Map.fromListWith (++) [(k,[v]) | (_,_,kvs) <- bs, (k,v) <- kvs]
         pure $ World
          (Map.fromList [
            (n, b { boxLocation = head (m Map.! n)})
            | (n,b,_) <- bs
          ])
          h
          (Set.fromList (Map.findWithDefault [] '-' m))
          (head (m Map.! '='))
    [] -> Left "empty input"

parseHeader :: String -> Either String Char
parseHeader (words -> ["player", [p]]) = Right p
parseHeader _ = Left "bad header"

parseBlocks :: [String] -> Either String [(Char, Box, [(Char, Location)])]
parseBlocks [] = Right []
parseBlocks (x:xs) =
  case words x of
    ["block", [name], color, boring] ->
      do color_ <- parseColor color
         let (xs1,xs2) = splitWalls xs
         let locs = findLocs name xs1
         let b = Box undefined (Original (walls xs1)) color_ (boring == "boring")
         bs <- parseBlocks xs2
         pure ((name, b, locs):bs)
    ["link", [name], [target], color] ->
      do color_ <- parseColor color
         bs <- parseBlocks xs
         pure ((name, Box undefined (Link target) color_ True, []):bs)
    ["infinity", [name], [target], color] ->
      do color_ <- parseColor color
         bs <- parseBlocks xs
         pure ((name, Box undefined (Infinity target) color_ True,[]):bs)
    ["epsilon", [name], [target], color] ->
      do color_ <- parseColor color
         let (xs1,xs2) = splitWalls xs
         let locs = findLocs name xs1
         let b = Box undefined (Epsilon target (walls xs1)) color_ False
         bs <- parseBlocks xs2
         pure ((name, b, locs):bs)
    _ -> Left "bad block"

splitWalls (x:xs) =
  case splitAt (length x - 1) xs of
    (a,b) -> (x:a, b)

parseColor :: String -> Either String Attr
parseColor "white" = Right (withForeColor defAttr white)
parseColor "cyan" = Right (withForeColor defAttr cyan)
parseColor "blue" = Right (withForeColor defAttr blue)
parseColor "red" = Right (withForeColor defAttr red)
parseColor "yellow" = Right (withForeColor defAttr yellow)
parseColor "magenta" = Right (withForeColor defAttr magenta)
parseColor "black" = Right (withForeColor defAttr black)
parseColor "green" = Right (withForeColor defAttr green)
parseColor x = Left ("bad color " ++ x)

walls :: [String] -> Array Coord Bool
walls rows = listArray ((ylo,xlo),(yhi,xhi)) (map ('▓'==) (concat rows))
  where
    width = length (head rows)
    height = length rows
    ylo = - ((height - 1) `div` 2)
    yhi = height `div` 2
    xlo = - ((width - 1) `div` 2)
    xhi = width `div` 2

mkRange :: Int -> (Int, Int)
mkRange n = (-(n-1)`div`2, n`div`2)

findLocs :: Char -> [[Char]] -> [(Char, Location)]
findLocs name xs =
  [ (c, Location name y x)
    | let (ylo, yhi) = mkRange (length xs)
    , (y, row) <- zip [ylo .. yhi] xs
    , let (xlo,xhi) = mkRange (length row)
    , (x, c  ) <- zip [xlo..xhi] row
  ]