-- |This module provides functionality for converting the Turing machine 'TMType.TM' to 'Tms'.
module TM2Tms (tm2tms) where

import Data.List (transpose, intercalate)
import Data.Set (toList)
import Data.Map (fromList, lookup, Map)
import Data.List.NonEmpty (reverse, NonEmpty(..), length)
import Data.Maybe (fromMaybe)

import TMType
import TmsType

tm2tms :: TM -> Either String Tms
tm2tms :: TM -> Either String Tms
tm2tms
    (TM
        (InputAlphabet
_, -- Input Alphabet
        [TapeAlphabet]
tapeAlphabets,
        MultiTapeStates
_, -- Tape States
        Commands Set [TapeCommand]
commands,
        StartStates [State]
startStates,
        AccessStates [State]
accessStates)
    ) = do
        [[TmsCommand]]
tmsCmdsBlocks <- ([TapeCommand] -> Either String [TmsCommand])
-> [[TapeCommand]] -> Either String [[TmsCommand]]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse [TapeCommand] -> Either String [TmsCommand]
cmd2tmsTapeCmds (Set [TapeCommand] -> [[TapeCommand]]
forall a. Set a -> [a]
toList Set [TapeCommand]
commands)
        let tmsCmds :: [TmsCommand]
tmsCmds = [[TmsCommand]] -> [TmsCommand]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [[TmsCommand]]
tmsCmdsBlocks
        [String]
tmsAlph <- (TapeAlphabet -> Either String String)
-> [TapeAlphabet] -> Either String [String]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse TapeAlphabet -> Either String String
alph2tmsAlph [TapeAlphabet]
tapeAlphabets
        Tms -> Either String Tms
forall (m :: * -> *) a. Monad m => a -> m a
return (Tms -> Either String Tms) -> Tms -> Either String Tms
forall a b. (a -> b) -> a -> b
$ (String, TmsState, [TmsState], [TmsCommand], [String]) -> Tms
Tms (
            String
"TMType_TM",
            [String] -> TmsState
mergeMultipleNames ([String] -> TmsState) -> [String] -> TmsState
forall a b. (a -> b) -> a -> b
$ (\(State String
s) -> String
s) (State -> String) -> [State] -> [String]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [State]
startStates,
            TmsState -> [TmsState]
forall (f :: * -> *) a. Applicative f => a -> f a
pure (TmsState -> [TmsState]) -> TmsState -> [TmsState]
forall a b. (a -> b) -> a -> b
$ [String] -> TmsState
mergeMultipleNames ([String] -> TmsState) -> [String] -> TmsState
forall a b. (a -> b) -> a -> b
$ (\(State String
s) -> String
s) (State -> String) -> [State] -> [String]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [State]
accessStates,
            [TmsCommand]
tmsCmds,
            [String]
tmsAlph)
    where
        alph2tmsAlph :: TapeAlphabet -> Either String String
        alph2tmsAlph :: TapeAlphabet -> Either String String
alph2tmsAlph (TapeAlphabet Set Square
squares) = (Square -> Either String Char) -> [Square] -> Either String String
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse Square -> Either String Char
toValue (Set Square -> [Square]
forall a. Set a -> [a]
toList Set Square
squares)

tmState2tmsState :: State -> TmsState
tmState2tmsState :: State -> TmsState
tmState2tmsState (State String
s) = String -> TmsState
TmsState String
s

-- Section of helper functions.

-- |Make transitional state.
-- Being used in 'cmd2tmsTapeCmd' if more than one command is created.
makeTransSt :: State -> State -> State
makeTransSt :: State -> State -> State
makeTransSt (State String
from) (State String
to) = String -> State
State (String -> State) -> String -> State
forall a b. (a -> b) -> a -> b
$ String
"FROM_" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
from String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"_TO_" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
to

-- |Convert 'TapeCommand' to non empty list of 'TmsSingleTapeCommand'.
cmd2tmsTapeCmd :: TapeCommand -> Either String (NonEmpty OneTapeTMCommand)

-- Command translation cases.

-- 'TM' : Do not change anything.
-- 'Tms': Do not change anything.
cmd2tmsTapeCmd :: TapeCommand -> Either String (NonEmpty OneTapeTMCommand)
cmd2tmsTapeCmd (
    SingleTapeCommand (
        (Square
ES, State
iniSt, Square
RBS),
        (Square
ES, State
folSt, Square
RBS))
    ) = NonEmpty OneTapeTMCommand
-> Either String (NonEmpty OneTapeTMCommand)
forall (m :: * -> *) a. Monad m => a -> m a
return (NonEmpty OneTapeTMCommand
 -> Either String (NonEmpty OneTapeTMCommand))
-> NonEmpty OneTapeTMCommand
-> Either String (NonEmpty OneTapeTMCommand)
forall a b. (a -> b) -> a -> b
$
    (State -> TmsState
tmState2tmsState State
iniSt, (TmsTapeSquare, TmsTapeHeadMovement) -> TmsSingleTapeCommand
TmsSingleTapeCommand (TmsTapeSquare
Leave, TmsTapeHeadMovement
Stay), State -> TmsState
tmState2tmsState State
folSt) OneTapeTMCommand -> [OneTapeTMCommand] -> NonEmpty OneTapeTMCommand
forall a. a -> [a] -> NonEmpty a
:|
    []

-- 'TM' : Insert value to the left from head.
-- 'Tms': Move head to left and put the value there.
cmd2tmsTapeCmd (
    SingleTapeCommand (
        (Square
ES,                 State
iniSt, Square
RBS),
        (Value String
name Int
nquts, State
folSt, Square
RBS)
    )) = do
    Char
ch <- String -> Int -> Either String Char
quotName2Char String
name Int
nquts
    let transit :: TmsState
transit = State -> TmsState
tmState2tmsState (State -> TmsState) -> State -> TmsState
forall a b. (a -> b) -> a -> b
$ State -> State -> State
makeTransSt State
iniSt State
folSt
    NonEmpty OneTapeTMCommand
-> Either String (NonEmpty OneTapeTMCommand)
forall (m :: * -> *) a. Monad m => a -> m a
return (NonEmpty OneTapeTMCommand
 -> Either String (NonEmpty OneTapeTMCommand))
-> NonEmpty OneTapeTMCommand
-> Either String (NonEmpty OneTapeTMCommand)
forall a b. (a -> b) -> a -> b
$
        (State -> TmsState
tmState2tmsState State
iniSt, (TmsTapeSquare, TmsTapeHeadMovement) -> TmsSingleTapeCommand
TmsSingleTapeCommand (TmsTapeSquare
Leave,                   TmsTapeHeadMovement
MoveLeft), TmsState
transit) OneTapeTMCommand -> [OneTapeTMCommand] -> NonEmpty OneTapeTMCommand
forall a. a -> [a] -> NonEmpty a
:|
        [(TmsState
transit,               (TmsTapeSquare, TmsTapeHeadMovement) -> TmsSingleTapeCommand
TmsSingleTapeCommand (Char -> Char -> TmsTapeSquare
ChangeFromTo Char
'_' Char
ch,   TmsTapeHeadMovement
Stay),     State -> TmsState
tmState2tmsState State
folSt)]

-- 'TM' : Erase symbol to the left from the head.
-- 'Tms': Erase (put empty symbol) value in head position and move head to right.
cmd2tmsTapeCmd (
    SingleTapeCommand (
        (Value String
name Int
nquts, State
iniSt, Square
RBS),
        (Square
ES,                 State
folSt, Square
RBS)
    )) = do
    Char
ch <- String -> Int -> Either String Char
quotName2Char String
name Int
nquts
    NonEmpty OneTapeTMCommand
-> Either String (NonEmpty OneTapeTMCommand)
forall (m :: * -> *) a. Monad m => a -> m a
return (NonEmpty OneTapeTMCommand
 -> Either String (NonEmpty OneTapeTMCommand))
-> NonEmpty OneTapeTMCommand
-> Either String (NonEmpty OneTapeTMCommand)
forall a b. (a -> b) -> a -> b
$
        (State -> TmsState
tmState2tmsState State
iniSt, (TmsTapeSquare, TmsTapeHeadMovement) -> TmsSingleTapeCommand
TmsSingleTapeCommand (Char -> Char -> TmsTapeSquare
ChangeFromTo Char
ch Char
'_', TmsTapeHeadMovement
MoveRight), State -> TmsState
tmState2tmsState State
folSt) OneTapeTMCommand -> [OneTapeTMCommand] -> NonEmpty OneTapeTMCommand
forall a. a -> [a] -> NonEmpty a
:|
        []

-- 'TM' : Replace value to left from the head.
-- 'Tms': Change value in head position.
cmd2tmsTapeCmd (
    SingleTapeCommand (
        (Value String
iniName Int
iniNquts, State
iniSt, Square
RBS),
        (Value String
folName Int
folNquts, State
folSt, Square
RBS)
    )) = do
    Char
iniCh <- String -> Int -> Either String Char
quotName2Char String
iniName Int
iniNquts
    Char
folCh <- String -> Int -> Either String Char
quotName2Char String
folName Int
folNquts
    NonEmpty OneTapeTMCommand
-> Either String (NonEmpty OneTapeTMCommand)
forall (m :: * -> *) a. Monad m => a -> m a
return (NonEmpty OneTapeTMCommand
 -> Either String (NonEmpty OneTapeTMCommand))
-> NonEmpty OneTapeTMCommand
-> Either String (NonEmpty OneTapeTMCommand)
forall a b. (a -> b) -> a -> b
$
        (State -> TmsState
tmState2tmsState State
iniSt, (TmsTapeSquare, TmsTapeHeadMovement) -> TmsSingleTapeCommand
TmsSingleTapeCommand (Char -> Char -> TmsTapeSquare
ChangeFromTo Char
iniCh Char
folCh, TmsTapeHeadMovement
Stay), State -> TmsState
tmState2tmsState State
folSt) OneTapeTMCommand -> [OneTapeTMCommand] -> NonEmpty OneTapeTMCommand
forall a. a -> [a] -> NonEmpty a
:|
        []

-- 'TM' : Check if tape is empty.
-- 'Tms': Check if tape is empty.
cmd2tmsTapeCmd (
    SingleTapeCommand (
        (Square
LBS, State
iniSt, Square
RBS),
        (Square
LBS, State
folSt, Square
RBS)
    )) = NonEmpty OneTapeTMCommand
-> Either String (NonEmpty OneTapeTMCommand)
forall (m :: * -> *) a. Monad m => a -> m a
return (NonEmpty OneTapeTMCommand
 -> Either String (NonEmpty OneTapeTMCommand))
-> NonEmpty OneTapeTMCommand
-> Either String (NonEmpty OneTapeTMCommand)
forall a b. (a -> b) -> a -> b
$
        (State -> TmsState
tmState2tmsState State
iniSt, (TmsTapeSquare, TmsTapeHeadMovement) -> TmsSingleTapeCommand
TmsSingleTapeCommand (Char -> Char -> TmsTapeSquare
ChangeFromTo Char
'_' Char
'_', TmsTapeHeadMovement
Stay), State -> TmsState
tmState2tmsState State
folSt) OneTapeTMCommand -> [OneTapeTMCommand] -> NonEmpty OneTapeTMCommand
forall a. a -> [a] -> NonEmpty a
:|
        []

-- Command can not be translated to Tms format.
cmd2tmsTapeCmd TapeCommand
cmd = String -> Either String (NonEmpty OneTapeTMCommand)
forall a b. a -> Either a b
Left (String -> Either String (NonEmpty OneTapeTMCommand))
-> String -> Either String (NonEmpty OneTapeTMCommand)
forall a b. (a -> b) -> a -> b
$ String
"Command '" String -> String -> String
forall a. [a] -> [a] -> [a]
++ TapeCommand -> String
forall a. Show a => a -> String
show TapeCommand
cmd String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"' can not be converted to '[TmsSingleTapeCommand]'"

cmd2tmsTapeCmds :: [TapeCommand] -> Either String [TmsCommand]
cmd2tmsTapeCmds :: [TapeCommand] -> Either String [TmsCommand]
cmd2tmsTapeCmds [TapeCommand]
tapeCmds = do
    [NonEmpty OneTapeTMCommand]
tapeCmdSeqs <- (TapeCommand -> Either String (NonEmpty OneTapeTMCommand))
-> [TapeCommand] -> Either String [NonEmpty OneTapeTMCommand]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse TapeCommand -> Either String (NonEmpty OneTapeTMCommand)
cmd2tmsTapeCmd [TapeCommand]
tapeCmds
    let tapeCmdSeqsRev :: [NonEmpty OneTapeTMCommand]
tapeCmdSeqsRev = (NonEmpty OneTapeTMCommand -> NonEmpty OneTapeTMCommand)
-> [NonEmpty OneTapeTMCommand] -> [NonEmpty OneTapeTMCommand]
forall a b. (a -> b) -> [a] -> [b]
Prelude.map NonEmpty OneTapeTMCommand -> NonEmpty OneTapeTMCommand
forall a. NonEmpty a -> NonEmpty a
Data.List.NonEmpty.reverse [NonEmpty OneTapeTMCommand]
tapeCmdSeqs
    let mxLen :: Int
mxLen = (Int -> NonEmpty OneTapeTMCommand -> Int)
-> Int -> [NonEmpty OneTapeTMCommand] -> Int
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl (\Int
mx NonEmpty OneTapeTMCommand
sq -> Int -> Int -> Int
forall a. Ord a => a -> a -> a
max Int
mx (NonEmpty OneTapeTMCommand -> Int
forall a. NonEmpty a -> Int
Data.List.NonEmpty.length NonEmpty OneTapeTMCommand
sq)) Int
0 [NonEmpty OneTapeTMCommand]
tapeCmdSeqs
    let sameLenCmds :: [[OneTapeTMCommand]]
sameLenCmds = (NonEmpty OneTapeTMCommand -> [OneTapeTMCommand])
-> [NonEmpty OneTapeTMCommand] -> [[OneTapeTMCommand]]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Int -> NonEmpty OneTapeTMCommand -> [OneTapeTMCommand]
fillSeqWithIdCmds Int
mxLen) [NonEmpty OneTapeTMCommand]
tapeCmdSeqsRev
    let sameLenCmdsRev :: [[OneTapeTMCommand]]
sameLenCmdsRev = [[OneTapeTMCommand]] -> [[OneTapeTMCommand]]
forall a. [[a]] -> [[a]]
transpose ([[OneTapeTMCommand]] -> [[OneTapeTMCommand]])
-> [[OneTapeTMCommand]] -> [[OneTapeTMCommand]]
forall a b. (a -> b) -> a -> b
$ ([OneTapeTMCommand] -> [OneTapeTMCommand])
-> [[OneTapeTMCommand]] -> [[OneTapeTMCommand]]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap [OneTapeTMCommand] -> [OneTapeTMCommand]
forall a. [a] -> [a]
Prelude.reverse [[OneTapeTMCommand]]
sameLenCmds
    [TmsCommand] -> Either String [TmsCommand]
forall (m :: * -> *) a. Monad m => a -> m a
return ([TmsCommand] -> Either String [TmsCommand])
-> [TmsCommand] -> Either String [TmsCommand]
forall a b. (a -> b) -> a -> b
$ (\[OneTapeTMCommand]
cmds -> (TmsState, [TmsSingleTapeCommand], TmsState) -> TmsCommand
TmsCommand ([OneTapeTMCommand] -> TmsState
forall b c. [(TmsState, b, c)] -> TmsState
startState [OneTapeTMCommand]
cmds, [OneTapeTMCommand] -> [TmsSingleTapeCommand]
forall a b c. [(a, b, c)] -> [b]
commands [OneTapeTMCommand]
cmds, [OneTapeTMCommand] -> TmsState
forall a b. [(a, b, TmsState)] -> TmsState
finalState [OneTapeTMCommand]
cmds)) ([OneTapeTMCommand] -> TmsCommand)
-> [[OneTapeTMCommand]] -> [TmsCommand]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [[OneTapeTMCommand]]
sameLenCmdsRev
    where
        fillSeqWithIdCmds :: Int -> NonEmpty OneTapeTMCommand -> [OneTapeTMCommand]
        fillSeqWithIdCmds :: Int -> NonEmpty OneTapeTMCommand -> [OneTapeTMCommand]
fillSeqWithIdCmds Int
len (OneTapeTMCommand
x :| [OneTapeTMCommand]
xs) = Int -> OneTapeTMCommand -> [OneTapeTMCommand]
forall a. Int -> a -> [a]
replicate (Int
len Int -> Int -> Int
forall a. Num a => a -> a -> a
- [OneTapeTMCommand] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
Prelude.length [OneTapeTMCommand]
xs Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1) (OneTapeTMCommand -> OneTapeTMCommand
makeIdTapeCommand OneTapeTMCommand
x) [OneTapeTMCommand] -> [OneTapeTMCommand] -> [OneTapeTMCommand]
forall a. [a] -> [a] -> [a]
++ OneTapeTMCommand -> [OneTapeTMCommand]
forall (f :: * -> *) a. Applicative f => a -> f a
pure OneTapeTMCommand
x [OneTapeTMCommand] -> [OneTapeTMCommand] -> [OneTapeTMCommand]
forall a. [a] -> [a] -> [a]
++ [OneTapeTMCommand]
xs
        makeIdTapeCommand :: OneTapeTMCommand -> OneTapeTMCommand
        makeIdTapeCommand :: OneTapeTMCommand -> OneTapeTMCommand
makeIdTapeCommand (TmsState
_, TmsSingleTapeCommand
_, TmsState
st) = (TmsState
st, (TmsTapeSquare, TmsTapeHeadMovement) -> TmsSingleTapeCommand
TmsSingleTapeCommand (TmsTapeSquare
Leave, TmsTapeHeadMovement
Stay), TmsState
st)
        startState :: [(TmsState, b, c)] -> TmsState
startState = [String] -> TmsState
mergeMultipleNames ([String] -> TmsState)
-> ([(TmsState, b, c)] -> [String])
-> [(TmsState, b, c)]
-> TmsState
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((TmsState, b, c) -> String) -> [(TmsState, b, c)] -> [String]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (\(TmsState String
s, b
_, c
_) -> String
s)
        finalState :: [(a, b, TmsState)] -> TmsState
finalState = [String] -> TmsState
mergeMultipleNames ([String] -> TmsState)
-> ([(a, b, TmsState)] -> [String])
-> [(a, b, TmsState)]
-> TmsState
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((a, b, TmsState) -> String) -> [(a, b, TmsState)] -> [String]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (\(a
_, b
_, TmsState String
f) -> String
f)
        commands :: [(a, b, c)] -> [b]
commands = ((a, b, c) -> b) -> [(a, b, c)] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (((a, b, c) -> b) -> [(a, b, c)] -> [b])
-> ((a, b, c) -> b) -> [(a, b, c)] -> [b]
forall a b. (a -> b) -> a -> b
$ \(a
_, b
x, c
_) -> b
x

-- |Convert 'Square' to 'Char'.
toValue :: Square -> Either String Char
toValue :: Square -> Either String Char
toValue (Value String
name Int
n) =
    String -> Int -> Either String Char
quotName2Char String
name Int
n
toValue Square
_              = String -> Either String Char
forall a b. a -> Either a b
Left String
"Square is expected to be 'Value' to convert to 'Char'"

-- |Convert 'String' with 'Int' quotes to 'Char'.
-- Character length is exactly 1, so longer strings can not be supported, so as many quotes.
quotName2Char :: String -> Int -> Either String Char
quotName2Char :: String -> Int -> Either String Char
quotName2Char (Char
c : String
"") Int
0 = Char -> Either String Char
forall (m :: * -> *) a. Monad m => a -> m a
return Char
c
quotName2Char (Char
c : String
"") Int
1 = Char -> Either String Char
forall (m :: * -> *) a. Monad m => a -> m a
return (Char -> Either String Char) -> Char -> Either String Char
forall a b. (a -> b) -> a -> b
$ Char -> Char
toQuot Char
c
quotName2Char String
name Int
nQuot = String -> Either String Char
forall a b. a -> Either a b
Left (String -> Either String Char) -> String -> Either String Char
forall a b. (a -> b) -> a -> b
$ String
"Can not convert string '" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
name String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"' with " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show Int
nQuot String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" quotes into 'Char'."

-- |Quoted (or just fancy) version of characters.
quoted :: Data.Map.Map Char Char
quoted :: Map Char Char
quoted = [(Char, Char)] -> Map Char Char
forall k a. Ord k => [(k, a)] -> Map k a
Data.Map.fromList [(Char
'a', Char
'à'), (Char
'b', Char
'ƀ'), (Char
'c', Char
'ć'), (Char
'd', Char
'ď'), (Char
'e', Char
'ė'), (Char
'f', Char
'ƒ'), (Char
'g', Char
'ĝ'), (Char
'h', Char
'ĥ'), (Char
'i', Char
'ĩ'), (Char
'j', Char
'ĵ'), (Char
'k', Char
'ķ'), (Char
'l', Char
'ĺ'), (Char
'm', Char
'ɱ'), (Char
'n', Char
'ń'), (Char
'o', Char
'ō'), (Char
'p', Char
'ƥ'), (Char
'q', Char
'ɋ'), (Char
'r', Char
'ŕ'), (Char
's', Char
'ś'), (Char
't', Char
'ť'), (Char
'u', Char
'ū'), (Char
'v', Char
'ʌ'), (Char
'w', Char
'ŵ'), (Char
'x', Char
'×'), (Char
'y', Char
'ŷ'), (Char
'z', Char
'ź'), (Char
'A', Char
'Ã'), (Char
'B', Char
'Ɓ'), (Char
'C', Char
'Ć'), (Char
'D', Char
'Đ'), (Char
'E', Char
'Ė'), (Char
'F', Char
'Ƒ'), (Char
'G', Char
'Ĝ'), (Char
'H', Char
'Ĥ'), (Char
'I', Char
'Ĩ'), (Char
'J', Char
'Ĵ'), (Char
'K', Char
'Ķ'), (Char
'L', Char
'Ĺ'), (Char
'M', Char
'Ɯ'), (Char
'N', Char
'Ń'), (Char
'O', Char
'Ō'), (Char
'P', Char
'Ƥ'), (Char
'Q', Char
'Ɋ'), (Char
'R', Char
'Ŕ'), (Char
'S', Char
'Ś'), (Char
'T', Char
'Ť'), (Char
'U', Char
'Ū'), (Char
'V', Char
'Ʌ'), (Char
'W', Char
'Ŵ'), (Char
'X', Char
'χ'), (Char
'Y', Char
'Ŷ'), (Char
'Z', Char
'Ź')]

toQuot :: Char -> Char
toQuot :: Char -> Char
toQuot Char
c = Char -> Maybe Char -> Char
forall a. a -> Maybe a -> a
fromMaybe (String -> Char
forall a. HasCallStack => String -> a
error (String -> Char) -> String -> Char
forall a b. (a -> b) -> a -> b
$ String
"Can not find character with quote for '" String -> String -> String
forall a. [a] -> [a] -> [a]
++ Char -> String
forall (f :: * -> *) a. Applicative f => a -> f a
pure Char
c String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"'") (Char -> Map Char Char -> Maybe Char
forall k a. Ord k => k -> Map k a -> Maybe a
Data.Map.lookup Char
c Map Char Char
quoted)

-- |Concat and filter list of states.
mergeMultipleNames :: [String] -> TmsState
mergeMultipleNames :: [String] -> TmsState
mergeMultipleNames = String -> TmsState
TmsState (String -> TmsState)
-> ([String] -> String) -> [String] -> TmsState
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (String
"Q__" String -> String -> String
forall a. [a] -> [a] -> [a]
++ ) (String -> String) -> ([String] -> String) -> [String] -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> [String] -> String
forall a. [a] -> [[a]] -> [a]
intercalate String
"__" ([String] -> String)
-> ([String] -> [String]) -> [String] -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (String -> String) -> [String] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map String -> String
filterStateName ([String] -> [String])
-> ([String] -> [String]) -> [String] -> [String]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [String] -> [String]
enum
    where
        enum :: [String] -> [String]
enum [String]
ss = ((Integer, String) -> String) -> [(Integer, String)] -> [String]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (\(Integer
num, String
s) -> Integer -> String
forall a. Show a => a -> String
show Integer
num String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"__" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
s) ([Integer] -> [String] -> [(Integer, String)]
forall a b. [a] -> [b] -> [(a, b)]
zip [Integer
0 ..] [String]
ss)