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) = splitAt 9 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) = splitAt 9 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"

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 ((-4,-4),(4,4)) (map ('▓'==) (concat rows))

findLocs :: Char -> [[Char]] -> [(Char, Location)]
findLocs name xs =
  [ (c, Location name y x)
    | (y, row) <- zip [-4..] xs
    , (x, c  ) <- zip [-4..] row
  ]