{-# LANGUAGE BlockArguments, LambdaCase, OverloadedStrings, FlexibleContexts #-}
module Text.RLE (Rule, parse, make, printAll) where
import qualified Data.Char as Char
import qualified Data.String as String
import qualified Control.Applicative as Ap
import Data.Functor.Identity (Identity)
import Data.String (IsString)
import Text.Parsec
( Parsec, Stream, runParser
, (<|>), try, many, many1, manyTill, satisfy
, anyChar, digit, string, spaces
)
import qualified Data.Text.IO as IO
import qualified Data.CA.Pattern as Pat
import Data.CA.Pattern (Pattern)
type Rule = String
data RunType = Dead | Alive | Newline
deriving (RunType -> RunType -> Bool
(RunType -> RunType -> Bool)
-> (RunType -> RunType -> Bool) -> Eq RunType
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: RunType -> RunType -> Bool
$c/= :: RunType -> RunType -> Bool
== :: RunType -> RunType -> Bool
$c== :: RunType -> RunType -> Bool
Eq)
type Run = (Int, RunType)
data = Int Int (Maybe Rule)
type RLEData = (Header, [Run])
type Parser s = Parsec s ()
natural :: (Stream s Identity Char) => Parser s Int
natural :: Parser s Int
natural = do
[Char]
num <- ParsecT s () Identity Char -> ParsecT s () Identity [Char]
forall s (m :: * -> *) t u a.
Stream s m t =>
ParsecT s u m a -> ParsecT s u m [a]
many1 ParsecT s () Identity Char
forall s (m :: * -> *) u. Stream s m Char => ParsecT s u m Char
digit
ParsecT s () Identity ()
forall s (m :: * -> *) u. Stream s m Char => ParsecT s u m ()
spaces
Int -> Parser s Int
forall (m :: * -> *) a. Monad m => a -> m a
return ([Char] -> Int
forall a. Read a => [Char] -> a
read [Char]
num)
symbol :: (Stream s Identity Char) => String -> Parser s ()
symbol :: [Char] -> Parser s ()
symbol [Char]
sym = [Char] -> ParsecT s () Identity [Char]
forall s (m :: * -> *) u.
Stream s m Char =>
[Char] -> ParsecT s u m [Char]
string [Char]
sym ParsecT s () Identity [Char] -> Parser s () -> Parser s ()
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Parser s ()
forall s (m :: * -> *) u. Stream s m Char => ParsecT s u m ()
spaces
parseWidth :: (Stream s Identity Char) => Parser s Int
parseWidth :: Parser s Int
parseWidth = [Char] -> Parser s ()
forall s. Stream s Identity Char => [Char] -> Parser s ()
symbol [Char]
"x" Parser s () -> Parser s () -> Parser s ()
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> [Char] -> Parser s ()
forall s. Stream s Identity Char => [Char] -> Parser s ()
symbol [Char]
"=" Parser s () -> Parser s Int -> Parser s Int
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Parser s Int
forall s. Stream s Identity Char => Parser s Int
natural
parseHeight :: (Stream s Identity Char) => Parser s Int
parseHeight :: Parser s Int
parseHeight = [Char] -> Parser s ()
forall s. Stream s Identity Char => [Char] -> Parser s ()
symbol [Char]
"," Parser s () -> Parser s () -> Parser s ()
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> [Char] -> Parser s ()
forall s. Stream s Identity Char => [Char] -> Parser s ()
symbol [Char]
"y" Parser s () -> Parser s () -> Parser s ()
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> [Char] -> Parser s ()
forall s. Stream s Identity Char => [Char] -> Parser s ()
symbol [Char]
"=" Parser s () -> Parser s Int -> Parser s Int
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Parser s Int
forall s. Stream s Identity Char => Parser s Int
natural
parseRule :: (Stream s Identity Char) => Parser s Rule
parseRule :: Parser s [Char]
parseRule = do
[Char] -> Parser s ()
forall s. Stream s Identity Char => [Char] -> Parser s ()
symbol [Char]
"," Parser s () -> Parser s () -> Parser s ()
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> [Char] -> Parser s ()
forall s. Stream s Identity Char => [Char] -> Parser s ()
symbol [Char]
"rule" Parser s () -> Parser s () -> Parser s ()
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> [Char] -> Parser s ()
forall s. Stream s Identity Char => [Char] -> Parser s ()
symbol [Char]
"="
[Char]
rule <- ParsecT s () Identity Char -> Parser s [Char]
forall s (m :: * -> *) t u a.
Stream s m t =>
ParsecT s u m a -> ParsecT s u m [a]
many1 ((Char -> Bool) -> ParsecT s () Identity Char
forall s (m :: * -> *) u.
Stream s m Char =>
(Char -> Bool) -> ParsecT s u m Char
satisfy (Bool -> Bool
not (Bool -> Bool) -> (Char -> Bool) -> Char -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Char -> Bool
Char.isSpace))
Parser s ()
forall s (m :: * -> *) u. Stream s m Char => ParsecT s u m ()
spaces
[Char] -> Parser s [Char]
forall (m :: * -> *) a. Monad m => a -> m a
return [Char]
rule
parseHeader :: (Stream s Identity Char) => Parser s Header
= (Int -> Int -> Maybe [Char] -> Header)
-> ParsecT s () Identity Int
-> ParsecT s () Identity Int
-> ParsecT s () Identity (Maybe [Char])
-> Parser s Header
forall (f :: * -> *) a b c d.
Applicative f =>
(a -> b -> c -> d) -> f a -> f b -> f c -> f d
Ap.liftA3 Int -> Int -> Maybe [Char] -> Header
Header ParsecT s () Identity Int
forall s. Stream s Identity Char => Parser s Int
parseWidth ParsecT s () Identity Int
forall s. Stream s Identity Char => Parser s Int
parseHeight ParsecT s () Identity (Maybe [Char])
maybeRule
where maybeRule :: ParsecT s () Identity (Maybe [Char])
maybeRule = ([Char] -> Maybe [Char])
-> ParsecT s () Identity [Char]
-> ParsecT s () Identity (Maybe [Char])
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap [Char] -> Maybe [Char]
forall a. a -> Maybe a
Just ParsecT s () Identity [Char]
forall s. Stream s Identity Char => Parser s [Char]
parseRule ParsecT s () Identity (Maybe [Char])
-> ParsecT s () Identity (Maybe [Char])
-> ParsecT s () Identity (Maybe [Char])
forall s u (m :: * -> *) a.
ParsecT s u m a -> ParsecT s u m a -> ParsecT s u m a
<|> Maybe [Char] -> ParsecT s () Identity (Maybe [Char])
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe [Char]
forall a. Maybe a
Nothing
parseRunType :: (Stream s Identity Char) => Parser s RunType
parseRunType :: Parser s RunType
parseRunType = ([Char] -> Parser s ()
forall s. Stream s Identity Char => [Char] -> Parser s ()
symbol [Char]
"b" Parser s () -> Parser s RunType -> Parser s RunType
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> RunType -> Parser s RunType
forall (m :: * -> *) a. Monad m => a -> m a
return RunType
Dead)
Parser s RunType -> Parser s RunType -> Parser s RunType
forall s u (m :: * -> *) a.
ParsecT s u m a -> ParsecT s u m a -> ParsecT s u m a
<|> ([Char] -> Parser s ()
forall s. Stream s Identity Char => [Char] -> Parser s ()
symbol [Char]
"o" Parser s () -> Parser s RunType -> Parser s RunType
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> RunType -> Parser s RunType
forall (m :: * -> *) a. Monad m => a -> m a
return RunType
Alive)
Parser s RunType -> Parser s RunType -> Parser s RunType
forall s u (m :: * -> *) a.
ParsecT s u m a -> ParsecT s u m a -> ParsecT s u m a
<|> ([Char] -> Parser s ()
forall s. Stream s Identity Char => [Char] -> Parser s ()
symbol [Char]
"$" Parser s () -> Parser s RunType -> Parser s RunType
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> RunType -> Parser s RunType
forall (m :: * -> *) a. Monad m => a -> m a
return RunType
Newline)
parseRun :: (Stream s Identity Char) => Parser s Run
parseRun :: Parser s Run
parseRun = (Int -> RunType -> Run)
-> ParsecT s () Identity Int
-> ParsecT s () Identity RunType
-> Parser s Run
forall (f :: * -> *) a b c.
Applicative f =>
(a -> b -> c) -> f a -> f b -> f c
Ap.liftA2 (,) (ParsecT s () Identity Int
forall s. Stream s Identity Char => Parser s Int
natural ParsecT s () Identity Int
-> ParsecT s () Identity Int -> ParsecT s () Identity Int
forall s u (m :: * -> *) a.
ParsecT s u m a -> ParsecT s u m a -> ParsecT s u m a
<|> Int -> ParsecT s () Identity Int
forall (m :: * -> *) a. Monad m => a -> m a
return Int
1) ParsecT s () Identity RunType
forall s. Stream s Identity Char => Parser s RunType
parseRunType
parseData :: (Stream s Identity Char) => Parser s RLEData
parseData :: Parser s RLEData
parseData = do
RLEData
rle <- (Header -> [Run] -> RLEData)
-> ParsecT s () Identity Header
-> ParsecT s () Identity [Run]
-> Parser s RLEData
forall (f :: * -> *) a b c.
Applicative f =>
(a -> b -> c) -> f a -> f b -> f c
Ap.liftA2 (,) ParsecT s () Identity Header
forall s. Stream s Identity Char => Parser s Header
parseHeader (ParsecT s () Identity Run -> ParsecT s () Identity [Run]
forall s (m :: * -> *) t u a.
Stream s m t =>
ParsecT s u m a -> ParsecT s u m [a]
many1 ParsecT s () Identity Run
forall s. Stream s Identity Char => Parser s Run
parseRun)
[Char] -> Parser s ()
forall s. Stream s Identity Char => [Char] -> Parser s ()
symbol [Char]
"!"
RLEData -> Parser s RLEData
forall (m :: * -> *) a. Monad m => a -> m a
return RLEData
rle
parseComment :: (Stream s Identity Char) => Parser s ()
= [Char] -> Parser s ()
forall s. Stream s Identity Char => [Char] -> Parser s ()
symbol [Char]
"#" Parser s ()
-> ParsecT s () Identity [Char] -> ParsecT s () Identity [Char]
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> ParsecT s () Identity Char
-> Parser s () -> ParsecT s () Identity [Char]
forall s (m :: * -> *) t u a end.
Stream s m t =>
ParsecT s u m a -> ParsecT s u m end -> ParsecT s u m [a]
manyTill ParsecT s () Identity Char
forall s (m :: * -> *) u. Stream s m Char => ParsecT s u m Char
anyChar Parser s ()
newline ParsecT s () Identity [Char] -> Parser s () -> Parser s ()
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> () -> Parser s ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
where newline :: Parser s ()
newline = Parser s () -> Parser s ()
forall s u (m :: * -> *) a. ParsecT s u m a -> ParsecT s u m a
try ([Char] -> Parser s ()
forall s. Stream s Identity Char => [Char] -> Parser s ()
symbol [Char]
"\n")
parseRLE :: (Stream s Identity Char) => Parser s RLEData
parseRLE :: Parser s RLEData
parseRLE = ParsecT s () Identity ()
forall s (m :: * -> *) u. Stream s m Char => ParsecT s u m ()
spaces ParsecT s () Identity ()
-> ParsecT s () Identity [()] -> ParsecT s () Identity [()]
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> ParsecT s () Identity () -> ParsecT s () Identity [()]
forall s u (m :: * -> *) a. ParsecT s u m a -> ParsecT s u m [a]
many ParsecT s () Identity ()
forall s. Stream s Identity Char => Parser s ()
parseComment ParsecT s () Identity [()] -> Parser s RLEData -> Parser s RLEData
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Parser s RLEData
forall s. Stream s Identity Char => Parser s RLEData
parseData
updateRows :: [Run] -> [[Pat.Cell]] -> [[Pat.Cell]]
updateRows :: [Run] -> [[Cell]] -> [[Cell]]
updateRows = (([Run], [[Cell]]) -> [[Cell]]) -> [Run] -> [[Cell]] -> [[Cell]]
forall a b c. ((a, b) -> c) -> a -> b -> c
curry \case
([], [[Cell]]
rows) -> [[Cell]]
rows
((Int
0, RunType
_) : [Run]
runs, [[Cell]]
rows) -> [Run] -> [[Cell]] -> [[Cell]]
updateRows [Run]
runs [[Cell]]
rows
((Int
n, RunType
rt) : [Run]
runs, [[Cell]]
rows) -> let
add :: a -> [[a]] -> [[a]]
add a
cell = \case
[] -> [[a
cell]]
([a]
row : [[a]]
rest) -> (a
cell a -> [a] -> [a]
forall a. a -> [a] -> [a]
: [a]
row) [a] -> [[a]] -> [[a]]
forall a. a -> [a] -> [a]
: [[a]]
rest
runs' :: [Run]
runs' = (Int
n Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1, RunType
rt) Run -> [Run] -> [Run]
forall a. a -> [a] -> [a]
: [Run]
runs
rows' :: [[Cell]]
rows' = case RunType
rt of
RunType
Dead -> Cell -> [[Cell]] -> [[Cell]]
forall a. a -> [[a]] -> [[a]]
add Cell
Pat.Dead [[Cell]]
rows
RunType
Alive -> Cell -> [[Cell]] -> [[Cell]]
forall a. a -> [[a]] -> [[a]]
add Cell
Pat.Alive [[Cell]]
rows
RunType
Newline -> [] [Cell] -> [[Cell]] -> [[Cell]]
forall a. a -> [a] -> [a]
: [[Cell]]
rows
in [Run] -> [[Cell]] -> [[Cell]]
updateRows [Run]
runs' [[Cell]]
rows'
toPattern :: RLEData -> (Maybe Rule, Pattern)
toPattern :: RLEData -> (Maybe [Char], Pattern)
toPattern (Header Int
h Int
w Maybe [Char]
rule, [Run]
runs) = let
rows :: [[Cell]]
rows = [Run] -> [[Cell]] -> [[Cell]]
updateRows ([Run] -> [Run]
forall a. [a] -> [a]
reverse [Run]
runs) []
pat :: Pattern
pat = Int -> Int -> Pattern -> Pattern
Pat.setDimensions Int
h Int
w ([[Cell]] -> Pattern
Pat.fromList [[Cell]]
rows)
in (Maybe [Char]
rule, Pattern
pat)
parse :: (Stream s Identity Char) => s -> Maybe (Maybe Rule, Pattern)
parse :: s -> Maybe (Maybe [Char], Pattern)
parse s
str =
case Parsec s () RLEData
-> () -> [Char] -> s -> Either ParseError RLEData
forall s t u a.
Stream s Identity t =>
Parsec s u a -> u -> [Char] -> s -> Either ParseError a
runParser Parsec s () RLEData
forall s. Stream s Identity Char => Parser s RLEData
parseRLE () [Char]
"" s
str of
Left ParseError
_ -> Maybe (Maybe [Char], Pattern)
forall a. Maybe a
Nothing
Right RLEData
rle -> (Maybe [Char], Pattern) -> Maybe (Maybe [Char], Pattern)
forall a. a -> Maybe a
Just (RLEData -> (Maybe [Char], Pattern)
toPattern RLEData
rle)
updateRuns :: [[Pat.Cell]] -> [Run] -> [Run]
updateRuns :: [[Cell]] -> [Run] -> [Run]
updateRuns = let
add :: b -> [(a, b)] -> [(a, b)]
add b
rt = \case
(a
n, b
rt') : [(a, b)]
runs | b
rt b -> b -> Bool
forall a. Eq a => a -> a -> Bool
== b
rt' -> (a
n a -> a -> a
forall a. Num a => a -> a -> a
+ a
1, b
rt) (a, b) -> [(a, b)] -> [(a, b)]
forall a. a -> [a] -> [a]
: [(a, b)]
runs
[(a, b)]
runs -> (a
1, b
rt) (a, b) -> [(a, b)] -> [(a, b)]
forall a. a -> [a] -> [a]
: [(a, b)]
runs
in (([[Cell]], [Run]) -> [Run]) -> [[Cell]] -> [Run] -> [Run]
forall a b c. ((a, b) -> c) -> a -> b -> c
curry \case
([], [Run]
runs) -> [Run] -> [Run]
forall a. [a] -> [a]
reverse [Run]
runs
([] : [[Cell]]
rows, [Run]
runs) -> [[Cell]] -> [Run] -> [Run]
updateRuns [[Cell]]
rows (RunType -> [Run] -> [Run]
forall b a. (Eq b, Num a) => b -> [(a, b)] -> [(a, b)]
add RunType
Newline [Run]
runs)
((Cell
Pat.Dead : [Cell]
row) : [[Cell]]
rows, [Run]
runs) -> [[Cell]] -> [Run] -> [Run]
updateRuns ([Cell]
row [Cell] -> [[Cell]] -> [[Cell]]
forall a. a -> [a] -> [a]
: [[Cell]]
rows) (RunType -> [Run] -> [Run]
forall b a. (Eq b, Num a) => b -> [(a, b)] -> [(a, b)]
add RunType
Dead [Run]
runs)
((Cell
Pat.Alive : [Cell]
row) : [[Cell]]
rows, [Run]
runs) -> [[Cell]] -> [Run] -> [Run]
updateRuns ([Cell]
row [Cell] -> [[Cell]] -> [[Cell]]
forall a. a -> [a] -> [a]
: [[Cell]]
rows) (RunType -> [Run] -> [Run]
forall b a. (Eq b, Num a) => b -> [(a, b)] -> [(a, b)]
add RunType
Alive [Run]
runs)
fromShow :: (Show a, IsString s) => a -> s
fromShow :: a -> s
fromShow = [Char] -> s
forall a. IsString a => [Char] -> a
String.fromString ([Char] -> s) -> (a -> [Char]) -> a -> s
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> [Char]
forall a. Show a => a -> [Char]
show
showRunType :: (IsString s) => RunType -> s
showRunType :: RunType -> s
showRunType = \case
RunType
Dead -> s
"b"
RunType
Alive -> s
"o"
RunType
Newline -> s
"$"
showRun :: (Semigroup s, IsString s) => Run -> s
showRun :: Run -> s
showRun = \case
(Int
1, RunType
rt) -> RunType -> s
forall s. IsString s => RunType -> s
showRunType RunType
rt
(Int
n, RunType
rt) -> Int -> s
forall a s. (Show a, IsString s) => a -> s
fromShow Int
n s -> s -> s
forall a. Semigroup a => a -> a -> a
<> RunType -> s
forall s. IsString s => RunType -> s
showRunType RunType
rt
showRuns :: (Semigroup s, IsString s) => Int -> [Run] -> s
showRuns :: Int -> [Run] -> s
showRuns = ((Int, [Run]) -> s) -> Int -> [Run] -> s
forall a b c. ((a, b) -> c) -> a -> b -> c
curry \case
(Int
_, []) -> s
""
(Int
0, [Run]
runs) -> s
"\n" s -> s -> s
forall a. Semigroup a => a -> a -> a
<> Int -> [Run] -> s
forall s. (Semigroup s, IsString s) => Int -> [Run] -> s
showRuns Int
30 [Run]
runs
(Int
n, Run
run : [Run]
runs) -> Run -> s
forall s. (Semigroup s, IsString s) => Run -> s
showRun Run
run s -> s -> s
forall a. Semigroup a => a -> a -> a
<> Int -> [Run] -> s
forall s. (Semigroup s, IsString s) => Int -> [Run] -> s
showRuns (Int
n Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1) [Run]
runs
make :: (Semigroup s, IsString s) => Maybe Rule -> Pattern -> s
make :: Maybe [Char] -> Pattern -> s
make Maybe [Char]
rule Pattern
pat = let
x :: s
x = s
"x = " s -> s -> s
forall a. Semigroup a => a -> a -> a
<> Int -> s
forall a s. (Show a, IsString s) => a -> s
fromShow (Pattern -> Int
Pat.width Pattern
pat)
y :: s
y = s
", y = " s -> s -> s
forall a. Semigroup a => a -> a -> a
<> Int -> s
forall a s. (Show a, IsString s) => a -> s
fromShow (Pattern -> Int
Pat.height Pattern
pat)
r :: s
r = case Maybe [Char]
rule of
Maybe [Char]
Nothing -> s
""
Just [Char]
str -> s
", rule = " s -> s -> s
forall a. Semigroup a => a -> a -> a
<> [Char] -> s
forall a. IsString a => [Char] -> a
String.fromString [Char]
str
runs :: [Run]
runs = [[Cell]] -> [Run] -> [Run]
updateRuns (Pattern -> [[Cell]]
Pat.toList Pattern
pat) []
in s
x s -> s -> s
forall a. Semigroup a => a -> a -> a
<> s
y s -> s -> s
forall a. Semigroup a => a -> a -> a
<> s
r s -> s -> s
forall a. Semigroup a => a -> a -> a
<> s
"\n" s -> s -> s
forall a. Semigroup a => a -> a -> a
<> Int -> [Run] -> s
forall s. (Semigroup s, IsString s) => Int -> [Run] -> s
showRuns Int
30 [Run]
runs s -> s -> s
forall a. Semigroup a => a -> a -> a
<> s
"!\n"
printAll :: Maybe Rule -> [Pattern] -> IO ()
printAll :: Maybe [Char] -> [Pattern] -> IO ()
printAll Maybe [Char]
rule = (Pattern -> IO ()) -> [Pattern] -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (Text -> IO ()
IO.putStrLn (Text -> IO ()) -> (Pattern -> Text) -> Pattern -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Maybe [Char] -> Pattern -> Text
forall s. (Semigroup s, IsString s) => Maybe [Char] -> Pattern -> s
make Maybe [Char]
rule)