module TM2SymTM where

import TMType
import Data.Set (Set)
import qualified Data.Set as Set
import Helpers
import Text.Regex.TDFA
import Data.List (partition)

firstPhase :: [State] -> [TapeCommand] -> [[TapeCommand]] -> [State] -> [Set State] -> [State] -> [[TapeCommand]]
firstPhase :: [State]
-> [TapeCommand]
-> [[TapeCommand]]
-> [State]
-> [Set State]
-> [State]
-> [[TapeCommand]]
firstPhase [State]
kplus1tapeStates [TapeCommand]
acceptCommand [[TapeCommand]]
otherCommands [State]
startStates [Set State]
multiTapeStates [State]
startFirstPhaseStates = do
    let [State
startKPlusOneTapeState, State
kplus1tapeState, State
finalKPlusOneTapeState] = [State]
kplus1tapeStates

    let generateFirstPhaseCommand :: [TapeCommand] -> [State] -> [TapeCommand] -> [TapeCommand]
generateFirstPhaseCommand [TapeCommand]
command [State]
states [TapeCommand]
acc =
            case [State]
states of
                [] ->
                    [TapeCommand] -> [TapeCommand]
forall a. [a] -> [a]
reverse ([TapeCommand] -> [TapeCommand]) -> [TapeCommand] -> [TapeCommand]
forall a b. (a -> b) -> a -> b
$ ((Square, State, Square), (Square, State, Square)) -> TapeCommand
SingleTapeCommand ((Square
ES, State
kplus1tapeState, Square
RBS), ([TapeCommand] -> Square
BCommand [TapeCommand]
command, State
kplus1tapeState, Square
RBS)) TapeCommand -> [TapeCommand] -> [TapeCommand]
forall a. a -> [a] -> [a]
: [TapeCommand]
acc
                State
s : [State]
ss  | [TapeCommand] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [TapeCommand]
acc -> Square -> [TapeCommand]
gfpc Square
ES
                        | Bool
otherwise -> Square -> [TapeCommand]
gfpc Square
LBS
                    where
                        gfpc :: Square -> [TapeCommand]
gfpc Square
r = [TapeCommand] -> [State] -> [TapeCommand] -> [TapeCommand]
generateFirstPhaseCommand [TapeCommand]
command [State]
ss ([TapeCommand] -> [TapeCommand]) -> [TapeCommand] -> [TapeCommand]
forall a b. (a -> b) -> a -> b
$ ((Square, State, Square), (Square, State, Square)) -> TapeCommand
SingleTapeCommand ((Square
r, State
s, Square
RBS), (Square
r, State
s, Square
RBS)) TapeCommand -> [TapeCommand] -> [TapeCommand]
forall a. a -> [a] -> [a]
: [TapeCommand]
acc

    let firstPhaseFinalCommand :: [a] -> [State] -> [State] -> [TapeCommand] -> [TapeCommand]
firstPhaseFinalCommand [a]
tapeStates [State]
states [State]
sStates [TapeCommand]
acc =
            case ([a]
tapeStates, [State]
states, [State]
sStates) of
                ([], [], []) ->
                    [TapeCommand] -> [TapeCommand]
forall a. [a] -> [a]
reverse ([TapeCommand] -> [TapeCommand]) -> [TapeCommand] -> [TapeCommand]
forall a b. (a -> b) -> a -> b
$ ((Square, State, Square), (Square, State, Square)) -> TapeCommand
SingleTapeCommand ((Square
ES, State
kplus1tapeState, Square
RBS), (Square
ES, State
finalKPlusOneTapeState, Square
RBS)) TapeCommand -> [TapeCommand] -> [TapeCommand]
forall a. a -> [a] -> [a]
: [TapeCommand]
acc
                (a
_ : [a]
tt, State
s1 : [State]
ss1, State
s2 : [State]
ss2)    | [TapeCommand] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [TapeCommand]
acc -> Square -> [TapeCommand]
fpfc Square
ES
                                                | Bool
otherwise -> Square -> [TapeCommand]
fpfc Square
LBS
                    where
                        fpfc :: Square -> [TapeCommand]
fpfc Square
r = [a] -> [State] -> [State] -> [TapeCommand] -> [TapeCommand]
firstPhaseFinalCommand [a]
tt [State]
ss1 [State]
ss2 ([TapeCommand] -> [TapeCommand]) -> [TapeCommand] -> [TapeCommand]
forall a b. (a -> b) -> a -> b
$ ((Square, State, Square), (Square, State, Square)) -> TapeCommand
SingleTapeCommand ((Square
r, State
s1, Square
RBS), (Square
r, State
s2, Square
RBS)) TapeCommand -> [TapeCommand] -> [TapeCommand]
forall a. a -> [a] -> [a]
: [TapeCommand]
acc
                ([a], [State], [State])
_ -> [Char] -> [TapeCommand]
forall a. HasCallStack => [Char] -> a
error [Char]
"States don't match"

    let firstPhaseStartCommand :: [State] -> [TapeCommand] -> [TapeCommand]
firstPhaseStartCommand [State]
states [TapeCommand]
acc =
            case [State]
states of
                [] ->
                    [TapeCommand] -> [TapeCommand]
forall a. [a] -> [a]
reverse ([TapeCommand] -> [TapeCommand]) -> [TapeCommand] -> [TapeCommand]
forall a b. (a -> b) -> a -> b
$ ((Square, State, Square), (Square, State, Square)) -> TapeCommand
SingleTapeCommand ((Square
ES, State
startKPlusOneTapeState, Square
RBS), ([TapeCommand] -> Square
BCommand [TapeCommand]
acceptCommand, State
kplus1tapeState, Square
RBS)) TapeCommand -> [TapeCommand] -> [TapeCommand]
forall a. a -> [a] -> [a]
: [TapeCommand]
acc
                State
s : [State]
ss  | [TapeCommand] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [TapeCommand]
acc -> Square -> [TapeCommand]
fpsc Square
ES
                        | Bool
otherwise -> Square -> [TapeCommand]
fpsc Square
LBS
                    where
                        fpsc :: Square -> [TapeCommand]
fpsc Square
r = [State] -> [TapeCommand] -> [TapeCommand]
firstPhaseStartCommand [State]
ss ([TapeCommand] -> [TapeCommand]) -> [TapeCommand] -> [TapeCommand]
forall a b. (a -> b) -> a -> b
$ ((Square, State, Square), (Square, State, Square)) -> TapeCommand
SingleTapeCommand ((Square
r, State
s, Square
RBS), (Square
r, State
s, Square
RBS)) TapeCommand -> [TapeCommand] -> [TapeCommand]
forall a. a -> [a] -> [a]
: [TapeCommand]
acc

    let firstPhaseInternal :: [[TapeCommand]] -> [[TapeCommand]] -> [[TapeCommand]]
firstPhaseInternal [[TapeCommand]]
commands [[TapeCommand]]
acc =
            case [[TapeCommand]]
commands of
                [] -> [[TapeCommand]]
acc
                [TapeCommand]
h : [[TapeCommand]]
t -> [[TapeCommand]] -> [[TapeCommand]] -> [[TapeCommand]]
firstPhaseInternal [[TapeCommand]]
t ([[TapeCommand]] -> [[TapeCommand]])
-> [[TapeCommand]] -> [[TapeCommand]]
forall a b. (a -> b) -> a -> b
$ [TapeCommand] -> [State] -> [TapeCommand] -> [TapeCommand]
generateFirstPhaseCommand [TapeCommand]
h [State]
startFirstPhaseStates [] [TapeCommand] -> [[TapeCommand]] -> [[TapeCommand]]
forall a. a -> [a] -> [a]
: [[TapeCommand]]
acc

    [State] -> [TapeCommand] -> [TapeCommand]
firstPhaseStartCommand [State]
startFirstPhaseStates [] [TapeCommand] -> [[TapeCommand]] -> [[TapeCommand]]
forall a. a -> [a] -> [a]
: [Set State] -> [State] -> [State] -> [TapeCommand] -> [TapeCommand]
forall a.
[a] -> [State] -> [State] -> [TapeCommand] -> [TapeCommand]
firstPhaseFinalCommand [Set State]
multiTapeStates [State]
startFirstPhaseStates [State]
startStates [] [TapeCommand] -> [[TapeCommand]] -> [[TapeCommand]]
forall a. a -> [a] -> [a]
: [[TapeCommand]] -> [[TapeCommand]] -> [[TapeCommand]]
firstPhaseInternal [[TapeCommand]]
otherCommands []

generateEmptyStayCommands :: [State]
                                   -> [TapeCommand] -> [TapeCommand]
generateEmptyStayCommands :: [State] -> [TapeCommand] -> [TapeCommand]
generateEmptyStayCommands [State]
states [TapeCommand]
acc =
    case [State]
states of
        [] -> [TapeCommand] -> [TapeCommand]
forall a. [a] -> [a]
reverse [TapeCommand]
acc
        State
h : [State]
t -> [State] -> [TapeCommand] -> [TapeCommand]
generateEmptyStayCommands [State]
t ([TapeCommand] -> [TapeCommand]) -> [TapeCommand] -> [TapeCommand]
forall a b. (a -> b) -> a -> b
$ ((Square, State, Square), (Square, State, Square)) -> TapeCommand
SingleTapeCommand ((Square
LBS, State
h, Square
RBS), (Square
LBS, State
h, Square
RBS)) TapeCommand -> [TapeCommand] -> [TapeCommand]
forall a. a -> [a] -> [a]
: [TapeCommand]
acc

secondPhase :: State -> [[TapeCommand]] -> [State] -> [[TapeCommand]]
secondPhase :: State -> [[TapeCommand]] -> [State] -> [[TapeCommand]]
secondPhase State
finalKPlusOneTapeState [[TapeCommand]]
allcommands [State]
accessStates = do
    let addKPlusOneTapeCommands :: [[TapeCommand]] -> [[TapeCommand]] -> [[TapeCommand]]
addKPlusOneTapeCommands [[TapeCommand]]
cmd [[TapeCommand]]
acc =
            case [[TapeCommand]]
cmd of
                [TapeCommand]
h : [[TapeCommand]]
t ->
                    [[TapeCommand]] -> [[TapeCommand]] -> [[TapeCommand]]
addKPlusOneTapeCommands [[TapeCommand]]
t ([[TapeCommand]] -> [[TapeCommand]])
-> [[TapeCommand]] -> [[TapeCommand]]
forall a b. (a -> b) -> a -> b
$ ([TapeCommand]
h [TapeCommand] -> [TapeCommand] -> [TapeCommand]
forall a. [a] -> [a] -> [a]
++ [((Square, State, Square), (Square, State, Square)) -> TapeCommand
SingleTapeCommand (([TapeCommand] -> Square
BCommand [TapeCommand]
h, State
finalKPlusOneTapeState, Square
ES), (Square
ES, State
finalKPlusOneTapeState, [TapeCommand] -> Square
BCommand [TapeCommand]
h))]) [TapeCommand] -> [[TapeCommand]] -> [[TapeCommand]]
forall a. a -> [a] -> [a]
: [[TapeCommand]]
acc
                [] -> [[TapeCommand]]
acc

    let returnToRightEndmarkerCommands :: [[TapeCommand]] -> [[TapeCommand]] -> [[TapeCommand]]
returnToRightEndmarkerCommands [[TapeCommand]]
commands [[TapeCommand]]
acc =
            case [[TapeCommand]]
commands of
                [TapeCommand]
h : [[TapeCommand]]
t -> [[TapeCommand]] -> [[TapeCommand]] -> [[TapeCommand]]
returnToRightEndmarkerCommands [[TapeCommand]]
t ([[TapeCommand]] -> [[TapeCommand]])
-> [[TapeCommand]] -> [[TapeCommand]]
forall a b. (a -> b) -> a -> b
$
                                ([State] -> [TapeCommand] -> [TapeCommand]
generateEmptyStayCommands [State]
accessStates [] [TapeCommand] -> [TapeCommand] -> [TapeCommand]
forall a. [a] -> [a] -> [a]
++
                                [((Square, State, Square), (Square, State, Square)) -> TapeCommand
SingleTapeCommand ((Square
ES, State
finalKPlusOneTapeState, [TapeCommand] -> Square
BCommand [TapeCommand]
h), ([TapeCommand] -> Square
BCommand [TapeCommand]
h, State
finalKPlusOneTapeState, Square
ES))]
                                ) [TapeCommand] -> [[TapeCommand]] -> [[TapeCommand]]
forall a. a -> [a] -> [a]
: [[TapeCommand]]
acc
                [] -> [[TapeCommand]]
acc

    [[TapeCommand]] -> [[TapeCommand]] -> [[TapeCommand]]
addKPlusOneTapeCommands [[TapeCommand]]
allcommands [] [[TapeCommand]] -> [[TapeCommand]] -> [[TapeCommand]]
forall a. [a] -> [a] -> [a]
++ [[TapeCommand]] -> [[TapeCommand]] -> [[TapeCommand]]
returnToRightEndmarkerCommands [[TapeCommand]]
allcommands []

thirdPhase :: State -> [[TapeCommand]] -> [State] -> [[TapeCommand]]
thirdPhase :: State -> [[TapeCommand]] -> [State] -> [[TapeCommand]]
thirdPhase State
finalKPlusOneTapeState [[TapeCommand]]
allcommands [State]
accessStates = do
    let thirdPhaseInternal :: [[TapeCommand]] -> [[TapeCommand]] -> [[TapeCommand]]
thirdPhaseInternal [[TapeCommand]]
commands [[TapeCommand]]
acc =
            case [[TapeCommand]]
commands of
                [TapeCommand]
h : [[TapeCommand]]
t -> [[TapeCommand]] -> [[TapeCommand]] -> [[TapeCommand]]
thirdPhaseInternal [[TapeCommand]]
t ([[TapeCommand]] -> [[TapeCommand]])
-> [[TapeCommand]] -> [[TapeCommand]]
forall a b. (a -> b) -> a -> b
$ ([State] -> [TapeCommand] -> [TapeCommand]
generateEmptyStayCommands [State]
accessStates [] [TapeCommand] -> [TapeCommand] -> [TapeCommand]
forall a. [a] -> [a] -> [a]
++
                                                [((Square, State, Square), (Square, State, Square)) -> TapeCommand
SingleTapeCommand (([TapeCommand] -> Square
BCommand [TapeCommand]
h, State
finalKPlusOneTapeState,  Square
RBS), (Square
ES, State
finalKPlusOneTapeState, Square
RBS))]
                                                ) [TapeCommand] -> [[TapeCommand]] -> [[TapeCommand]]
forall a. a -> [a] -> [a]
: [[TapeCommand]]
acc
                [] -> [[TapeCommand]]
acc
    [[TapeCommand]] -> [[TapeCommand]] -> [[TapeCommand]]
thirdPhaseInternal [[TapeCommand]]
allcommands []

symCommands :: [[TapeCommand]] -> [[TapeCommand]]
symCommands :: [[TapeCommand]] -> [[TapeCommand]]
symCommands [[TapeCommand]]
allcommands = do
    let reverseCommands :: [TapeCommand] -> [TapeCommand] -> [TapeCommand]
reverseCommands [TapeCommand]
commands [TapeCommand]
acc =
            case [TapeCommand]
commands of
                SingleTapeCommand ((Square
a, State
s, Square
b), (Square
a1, State
s1, Square
b1)) : [TapeCommand]
t -> [TapeCommand] -> [TapeCommand] -> [TapeCommand]
reverseCommands [TapeCommand]
t (((Square, State, Square), (Square, State, Square)) -> TapeCommand
SingleTapeCommand ((Square
a1, State
s1, Square
b1), (Square
a, State
s, Square
b)) TapeCommand -> [TapeCommand] -> [TapeCommand]
forall a. a -> [a] -> [a]
: [TapeCommand]
acc)
                [] -> [TapeCommand] -> [TapeCommand]
forall a. [a] -> [a]
reverse [TapeCommand]
acc
                [TapeCommand]
_ -> [Char] -> [TapeCommand]
forall a. HasCallStack => [Char] -> a
error [Char]
"Must be SingleTapeCommand"

    let reverseAllCommands :: [[TapeCommand]] -> [[TapeCommand]] -> [[TapeCommand]]
reverseAllCommands [[TapeCommand]]
commands [[TapeCommand]]
acc =
            case [[TapeCommand]]
commands of
                [TapeCommand]
h : [[TapeCommand]]
t -> [[TapeCommand]] -> [[TapeCommand]] -> [[TapeCommand]]
reverseAllCommands [[TapeCommand]]
t ([TapeCommand] -> [TapeCommand] -> [TapeCommand]
reverseCommands [TapeCommand]
h [] [TapeCommand] -> [[TapeCommand]] -> [[TapeCommand]]
forall a. a -> [a] -> [a]
: [[TapeCommand]]
acc)
                [] -> [[TapeCommand]]
acc
    [[TapeCommand]] -> [[TapeCommand]] -> [[TapeCommand]]
reverseAllCommands [[TapeCommand]]
allcommands [[TapeCommand]]
allcommands

threePhaseProcessing :: TM -> TM
threePhaseProcessing :: TM -> TM
threePhaseProcessing
    (TM
        (InputAlphabet
inputAlphabet,
        [TapeAlphabet]
tapeAlphabets,
        MultiTapeStates [Set State]
multiTapeStates,
        Commands Set [TapeCommand]
commands,
        StartStates [State]
startStates,
        AccessStates [State]
accessStates)
    ) = do
        let kPlus1 :: Int
kPlus1 = Int -> Int -> Int
forall a. Num a => a -> a -> a
(+) Int
1 (Int -> Int) -> Int -> Int
forall a b. (a -> b) -> a -> b
$ [Set State] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Set State]
multiTapeStates
        let startKPlusOneTapeState :: State
startKPlusOneTapeState = [Char] -> State
State ([Char] -> State) -> [Char] -> State
forall a b. (a -> b) -> a -> b
$ [Char]
"q_0^" [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Int -> [Char]
forall a. Show a => a -> [Char]
show Int
kPlus1
        let kplus1tapeState :: State
kplus1tapeState = [Char] -> State
State ([Char] -> State) -> [Char] -> State
forall a b. (a -> b) -> a -> b
$ [Char]
"q_1^" [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Int -> [Char]
forall a. Show a => a -> [Char]
show Int
kPlus1
        let finalKPlusOneTapeState :: State
finalKPlusOneTapeState = [Char] -> State
State ([Char] -> State) -> [Char] -> State
forall a b. (a -> b) -> a -> b
$ [Char]
"q_2^" [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Int -> [Char]
forall a. Show a => a -> [Char]
show Int
kPlus1
        let acceptKPlusOneTapeState :: State
acceptKPlusOneTapeState = [Char] -> State
State ([Char] -> State) -> [Char] -> State
forall a b. (a -> b) -> a -> b
$ [Char]
"q_3^" [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Int -> [Char]
forall a. Show a => a -> [Char]
show Int
kPlus1
        let commandsList :: [[TapeCommand]]
commandsList = Set [TapeCommand] -> [[TapeCommand]]
forall a. Set a -> [a]
Set.toList Set [TapeCommand]
commands
        let ([[TapeCommand]
acceptCommand], [[TapeCommand]]
otherCommands) = if [[TapeCommand]] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [[TapeCommand]]
cmds1 then [Char] -> ([[TapeCommand]], [[TapeCommand]])
forall a. HasCallStack => [Char] -> a
error [Char]
"No accept command" else ([[TapeCommand]]
cmds1, [[TapeCommand]]
cmds2)
                where
                    isAcceptCommand :: [TapeCommand] -> Bool
isAcceptCommand [TapeCommand]
command = ((TapeCommand, State) -> Bool) -> [(TapeCommand, State)] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all (\(SingleTapeCommand ((Square, State, Square)
_, (Square
_, State
sh, Square
_)), State
ah) -> State
sh State -> State -> Bool
forall a. Eq a => a -> a -> Bool
== State
ah) ([(TapeCommand, State)] -> Bool) -> [(TapeCommand, State)] -> Bool
forall a b. (a -> b) -> a -> b
$ [TapeCommand] -> [State] -> [(TapeCommand, State)]
forall a b. [a] -> [b] -> [(a, b)]
zip [TapeCommand]
command [State]
accessStates
                    ([[TapeCommand]]
cmds1, [[TapeCommand]]
cmds2) = ([TapeCommand] -> Bool)
-> [[TapeCommand]] -> ([[TapeCommand]], [[TapeCommand]])
forall a. (a -> Bool) -> [a] -> ([a], [a])
partition [TapeCommand] -> Bool
isAcceptCommand [[TapeCommand]]
commandsList
        let startFirstPhaseStates :: [State]
startFirstPhaseStates = (Set State -> State) -> [Set State] -> [State]
forall a b. (a -> b) -> [a] -> [b]
map Set State -> State
genNextState [Set State]
multiTapeStates
        let commandsFirstPhase :: [[TapeCommand]]
commandsFirstPhase = [State]
-> [TapeCommand]
-> [[TapeCommand]]
-> [State]
-> [Set State]
-> [State]
-> [[TapeCommand]]
firstPhase [State
startKPlusOneTapeState, State
kplus1tapeState, State
finalKPlusOneTapeState] [TapeCommand]
acceptCommand [[TapeCommand]]
otherCommands [State]
startStates [Set State]
multiTapeStates [State]
startFirstPhaseStates
        let commandsSecondPhase :: [[TapeCommand]]
commandsSecondPhase = State -> [[TapeCommand]] -> [State] -> [[TapeCommand]]
secondPhase State
finalKPlusOneTapeState [[TapeCommand]]
commandsList [State]
accessStates
        let commandsThirdPhase :: [[TapeCommand]]
commandsThirdPhase = State -> [[TapeCommand]] -> [State] -> [[TapeCommand]]
thirdPhase State
finalKPlusOneTapeState [[TapeCommand]]
commandsList [State]
accessStates

        let tmAcceptCommand :: [TapeCommand]
tmAcceptCommand =
                (State -> TapeCommand) -> [State] -> [TapeCommand]
forall a b. (a -> b) -> [a] -> [b]
map (\State
st -> ((Square, State, Square), (Square, State, Square)) -> TapeCommand
SingleTapeCommand ((Square
LBS, State
st, Square
RBS), (Square
LBS, State
st, Square
RBS))) [State]
accessStates [TapeCommand] -> [TapeCommand] -> [TapeCommand]
forall a. [a] -> [a] -> [a]
++
                [((Square, State, Square), (Square, State, Square)) -> TapeCommand
SingleTapeCommand ((Square
LBS, State
finalKPlusOneTapeState, Square
RBS), (Square
LBS, State
acceptKPlusOneTapeState, Square
RBS))]

        let newTMCommands :: Commands
newTMCommands = Set [TapeCommand] -> Commands
Commands (Set [TapeCommand] -> Commands) -> Set [TapeCommand] -> Commands
forall a b. (a -> b) -> a -> b
$ [[TapeCommand]] -> Set [TapeCommand]
forall a. Ord a => [a] -> Set a
Set.fromList ([[TapeCommand]] -> Set [TapeCommand])
-> [[TapeCommand]] -> Set [TapeCommand]
forall a b. (a -> b) -> a -> b
$ [[TapeCommand]]
commandsFirstPhase [[TapeCommand]] -> [[TapeCommand]] -> [[TapeCommand]]
forall a. [a] -> [a] -> [a]
++ [[TapeCommand]]
commandsSecondPhase [[TapeCommand]] -> [[TapeCommand]] -> [[TapeCommand]]
forall a. [a] -> [a] -> [a]
++ [[TapeCommand]]
commandsThirdPhase [[TapeCommand]] -> [[TapeCommand]] -> [[TapeCommand]]
forall a. [a] -> [a] -> [a]
++ [[TapeCommand]
tmAcceptCommand]

        let newTMTapeAlphabets :: [TapeAlphabet]
newTMTapeAlphabets = [TapeAlphabet]
tapeAlphabets [TapeAlphabet] -> [TapeAlphabet] -> [TapeAlphabet]
forall a. [a] -> [a] -> [a]
++ [Set Square -> TapeAlphabet
TapeAlphabet (Set Square -> TapeAlphabet) -> Set Square -> TapeAlphabet
forall a b. (a -> b) -> a -> b
$ ([TapeCommand] -> Square) -> Set [TapeCommand] -> Set Square
forall b a. Ord b => (a -> b) -> Set a -> Set b
Set.map [TapeCommand] -> Square
BCommand Set [TapeCommand]
commands]

        let newTMStartStates :: StartStates
newTMStartStates = [State] -> StartStates
StartStates ([State]
startFirstPhaseStates [State] -> [State] -> [State]
forall a. [a] -> [a] -> [a]
++ [State
startKPlusOneTapeState])

        let newTMMultiTapeStates :: MultiTapeStates
newTMMultiTapeStates = [Set State] -> MultiTapeStates
MultiTapeStates (
                (State -> Set State -> Set State)
-> [State] -> [Set State] -> [Set State]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith State -> Set State -> Set State
forall a. Ord a => a -> Set a -> Set a
Set.insert [State]
startFirstPhaseStates [Set State]
multiTapeStates
                [Set State] -> [Set State] -> [Set State]
forall a. [a] -> [a] -> [a]
++ [[State] -> Set State
forall a. Ord a => [a] -> Set a
Set.fromList [State
startKPlusOneTapeState, State
kplus1tapeState, State
finalKPlusOneTapeState, State
acceptKPlusOneTapeState]]
                )

        let newTMAccessStates :: AccessStates
newTMAccessStates = [State] -> AccessStates
AccessStates ([State]
accessStates [State] -> [State] -> [State]
forall a. [a] -> [a] -> [a]
++ [State
acceptKPlusOneTapeState])

        (InputAlphabet, [TapeAlphabet], MultiTapeStates, Commands,
 StartStates, AccessStates)
-> TM
TM (InputAlphabet
inputAlphabet, [TapeAlphabet]
newTMTapeAlphabets, MultiTapeStates
newTMMultiTapeStates, Commands
newTMCommands, StartStates
newTMStartStates, AccessStates
newTMAccessStates)

doubleCommands :: [State] -> [State] -> [TapeAlphabet] -> [Set State] -> [[TapeCommand]] -> ([State], [State], [TapeAlphabet], [Set State], [[TapeCommand]])
doubleCommands :: [State]
-> [State]
-> [TapeAlphabet]
-> [Set State]
-> [[TapeCommand]]
-> ([State], [State], [TapeAlphabet], [Set State], [[TapeCommand]])
doubleCommands [State]
startStates [State]
accessStates [TapeAlphabet]
tapeAlphabets [Set State]
multiTapeStates [[TapeCommand]]
allcommands = do

    let doubleCommandsStateDisjoinFunction :: State -> State
doubleCommandsStateDisjoinFunction State
st = [Char] -> State
State ([Char] -> State) -> [Char] -> State
forall a b. (a -> b) -> a -> b
$ [Char]
"q_{" [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
stateNumber [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
"}^{" [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Float -> [Char]
forall a. Show a => a -> [Char]
show Float
tapeNumber [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
"}"
            where
                getNumber :: State -> [Char]
getNumber (State [Char]
s) = [Char]
n
                        where ([Char]
_, [Char]
_, [Char]
_, [[Char]
n]) = [Char]
s [Char] -> [Char] -> ([Char], [Char], [Char], [[Char]])
forall source source1 target.
(RegexMaker Regex CompOption ExecOption source,
 RegexContext Regex source1 target) =>
source1 -> source -> target
=~ [Char]
"q_{?([0-9]+)}?\\^{?[0-9]+}?" :: (String, String, String, [String])
                stateNumber :: [Char]
stateNumber = State -> [Char]
getNumber State
st
                getTapeNumber :: State -> Float
getTapeNumber (State [Char]
s) = [Char] -> Float
forall a. Read a => [Char] -> a
read [Char]
n :: Float
                        where ([Char]
_, [Char]
_, [Char]
_, [[Char]
n]) = [Char]
s [Char] -> [Char] -> ([Char], [Char], [Char], [[Char]])
forall source source1 target.
(RegexMaker Regex CompOption ExecOption source,
 RegexContext Regex source1 target) =>
source1 -> source -> target
=~ [Char]
"q_{?[0-9]+}?\\^{?([0-9]+)}?" :: (String, String, String, [String])
                tapeNumber :: Float
tapeNumber = Float -> Float -> Float
forall a. Num a => a -> a -> a
(+) Float
0.5 (Float -> Float) -> Float -> Float
forall a b. (a -> b) -> a -> b
$ State -> Float
getTapeNumber State
st

    let divideCommands :: [TapeCommand] -> [TapeCommand] -> [TapeCommand]
divideCommands [TapeCommand]
commands [TapeCommand]
acc =
            case [TapeCommand]
commands of
                SingleTapeCommand ((Square
a, State
s, Square
b), (Square
a1, State
s1, Square
b1)) : [TapeCommand]
t
                        | Square
b Square -> Square -> Bool
forall a. Eq a => a -> a -> Bool
== Square
RBS -> [TapeCommand] -> [TapeCommand] -> [TapeCommand]
divideCommands [TapeCommand]
t ([TapeCommand]
acc [TapeCommand] -> [TapeCommand] -> [TapeCommand]
forall a. [a] -> [a] -> [a]
++ [
                            ((Square, State, Square), (Square, State, Square)) -> TapeCommand
SingleTapeCommand ((Square
a, State
s, Square
RBS), (Square
a1, State
s1, Square
RBS)),
                            ((Square, State, Square), (Square, State, Square)) -> TapeCommand
SingleTapeCommand ((Square
LBS, State -> State
doubleCommandsStateDisjoinFunction State
s, Square
RBS), (Square
LBS, State -> State
doubleCommandsStateDisjoinFunction State
s1, Square
RBS))
                                                                                ])
                        | Bool
otherwise -> [TapeCommand] -> [TapeCommand] -> [TapeCommand]
divideCommands [TapeCommand]
t ([TapeCommand]
acc [TapeCommand] -> [TapeCommand] -> [TapeCommand]
forall a. [a] -> [a] -> [a]
++ [
                            ((Square, State, Square), (Square, State, Square)) -> TapeCommand
SingleTapeCommand ((Square
a, State
s, Square
RBS), (Square
a1, State
s1, Square
RBS)),
                            ((Square, State, Square), (Square, State, Square)) -> TapeCommand
SingleTapeCommand ((Square -> Square
getDisjoinSquare2 Square
b, State -> State
doubleCommandsStateDisjoinFunction State
s, Square
RBS), (Square -> Square
getDisjoinSquare2 Square
b1, State -> State
doubleCommandsStateDisjoinFunction State
s1, Square
RBS))
                                                                 ])
                [] -> [TapeCommand]
acc
                [TapeCommand]
_ -> [Char] -> [TapeCommand]
forall a. HasCallStack => [Char] -> a
error [Char]
"Must be SingleTapeCommand"

    let doubleCommandsInternal :: [[TapeCommand]] -> [[TapeCommand]] -> [[TapeCommand]]
doubleCommandsInternal [[TapeCommand]]
commands [[TapeCommand]]
acc =
            case [[TapeCommand]]
commands of
                [TapeCommand]
h : [[TapeCommand]]
t -> [[TapeCommand]] -> [[TapeCommand]] -> [[TapeCommand]]
doubleCommandsInternal [[TapeCommand]]
t ([TapeCommand] -> [TapeCommand] -> [TapeCommand]
divideCommands [TapeCommand]
h [] [TapeCommand] -> [[TapeCommand]] -> [[TapeCommand]]
forall a. a -> [a] -> [a]
: [[TapeCommand]]
acc)
                [] -> [[TapeCommand]]
acc

    let doubleMultitapeStates :: Set State -> [Set State]
doubleMultitapeStates Set State
states = [Set State
states, (State -> State) -> Set State -> Set State
forall b a. Ord b => (a -> b) -> Set a -> Set b
Set.map State -> State
doubleCommandsStateDisjoinFunction Set State
states]
    let doubleStates :: State -> [State]
doubleStates State
st = [State
st, State -> State
doubleCommandsStateDisjoinFunction State
st]
    let doubleTapeAlphabets :: TapeAlphabet -> [TapeAlphabet]
doubleTapeAlphabets TapeAlphabet
tapeAlphabet = [TapeAlphabet
tapeAlphabet, Set Square -> TapeAlphabet
TapeAlphabet (Set Square -> TapeAlphabet) -> Set Square -> TapeAlphabet
forall a b. (a -> b) -> a -> b
$ (Square -> Square) -> Set Square -> Set Square
forall b a. Ord b => (a -> b) -> Set a -> Set b
Set.map Square -> Square
getDisjoinSquare2 Set Square
a]
                where (TapeAlphabet Set Square
a) = TapeAlphabet
tapeAlphabet

    ((State -> [State]) -> [State] -> [State]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap State -> [State]
doubleStates [State]
startStates,
        (State -> [State]) -> [State] -> [State]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap State -> [State]
doubleStates [State]
accessStates,
        (TapeAlphabet -> [TapeAlphabet])
-> [TapeAlphabet] -> [TapeAlphabet]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap TapeAlphabet -> [TapeAlphabet]
doubleTapeAlphabets [TapeAlphabet]
tapeAlphabets,
        (Set State -> [Set State]) -> [Set State] -> [Set State]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap Set State -> [Set State]
doubleMultitapeStates [Set State]
multiTapeStates,
        [[TapeCommand]] -> [[TapeCommand]] -> [[TapeCommand]]
doubleCommandsInternal [[TapeCommand]]
allcommands [])

one2KCmds :: ([Set State], [[TapeCommand]]) -> ([Set State], [[TapeCommand]])
one2KCmds :: ([Set State], [[TapeCommand]]) -> ([Set State], [[TapeCommand]])
one2KCmds ([Set State]
multiTapeStates, [[TapeCommand]]
allcommands) = do
    let getStartAndFinalStatesOfCommand :: [TapeCommand] -> ([State], [State]) -> ([State], [State])
getStartAndFinalStatesOfCommand [TapeCommand]
command ([State]
starts, [State]
finals) =
            case [TapeCommand]
command of
                SingleTapeCommand ((Square
_, State
s1, Square
_), (Square
_, State
s2, Square
_)) : [TapeCommand]
t -> [TapeCommand] -> ([State], [State]) -> ([State], [State])
getStartAndFinalStatesOfCommand [TapeCommand]
t (State
s1 State -> [State] -> [State]
forall a. a -> [a] -> [a]
: [State]
starts, State
s2 State -> [State] -> [State]
forall a. a -> [a] -> [a]
: [State]
finals)
                [] -> ([State] -> [State]
forall a. [a] -> [a]
reverse [State]
starts, [State] -> [State]
forall a. [a] -> [a]
reverse [State]
finals)
                [TapeCommand]
_ -> [Char] -> ([State], [State])
forall a. HasCallStack => [Char] -> a
error [Char]
"Must be SingleTapeCommand"
    let oneActionCommand :: [Set State]
-> ([State], [State])
-> [TapeCommand]
-> a
-> a
-> ([Set State], [State], [TapeCommand])
-> ([Set State], [State], [TapeCommand])
oneActionCommand [Set State]
states ([State]
starts, [State]
finals) [TapeCommand]
command a
n a
i ([Set State]
newTapeStates, [State]
newStarts, [TapeCommand]
acc) =
            case ([Set State]
states, [TapeCommand]
command, [State]
starts, [State]
finals) of
                ([], [], [], []) -> ([Set State] -> [Set State]
forall a. [a] -> [a]
reverse [Set State]
newTapeStates, [State] -> [State]
forall a. [a] -> [a]
reverse [State]
newStarts, [TapeCommand] -> [TapeCommand]
forall a. [a] -> [a]
reverse [TapeCommand]
acc)
                (Set State
tape : [Set State]
tt, SingleTapeCommand ((Square
l1, State
_, Square
r1), (Square
l2, State
_, Square
r2)) : [TapeCommand]
t, State
start : [State]
st, State
final : [State]
ft)
                        | a
n a -> a -> Bool
forall a. Eq a => a -> a -> Bool
== a
i Bool -> Bool -> Bool
|| Square
l1 Square -> Square -> Bool
forall a. Eq a => a -> a -> Bool
== Square
ES Bool -> Bool -> Bool
&& Square
l2 Square -> Square -> Bool
forall a. Eq a => a -> a -> Bool
== Square
ES ->
                            [Set State]
-> ([State], [State])
-> [TapeCommand]
-> a
-> a
-> ([Set State], [State], [TapeCommand])
-> ([Set State], [State], [TapeCommand])
oneActionCommand [Set State]
tt ([State]
st, [State]
ft) [TapeCommand]
t a
n (a
i a -> a -> a
forall a. Num a => a -> a -> a
+ a
1) (Set State
tape Set State -> [Set State] -> [Set State]
forall a. a -> [a] -> [a]
: [Set State]
newTapeStates, State
final State -> [State] -> [State]
forall a. a -> [a] -> [a]
: [State]
newStarts, ((Square, State, Square), (Square, State, Square)) -> TapeCommand
SingleTapeCommand ((Square
l1, State
start, Square
r1), (Square
l2, State
final, Square
r2)) TapeCommand -> [TapeCommand] -> [TapeCommand]
forall a. a -> [a] -> [a]
: [TapeCommand]
acc)
                        | a
i a -> a -> Bool
forall a. Ord a => a -> a -> Bool
< a
n Bool -> Bool -> Bool
&& State
start State -> State -> Bool
forall a. Eq a => a -> a -> Bool
== State
final ->
                            [Set State]
-> ([State], [State])
-> [TapeCommand]
-> a
-> a
-> ([Set State], [State], [TapeCommand])
-> ([Set State], [State], [TapeCommand])
oneActionCommand [Set State]
tt ([State]
st, [State]
ft) [TapeCommand]
t a
n (a
i a -> a -> a
forall a. Num a => a -> a -> a
+ a
1) (Set State
tape Set State -> [Set State] -> [Set State]
forall a. a -> [a] -> [a]
: [Set State]
newTapeStates, State
final State -> [State] -> [State]
forall a. a -> [a] -> [a]
: [State]
newStarts, ((Square, State, Square), (Square, State, Square)) -> TapeCommand
SingleTapeCommand ((Square
ES, State
start, Square
r1), (Square
ES, State
final, Square
r2)) TapeCommand -> [TapeCommand] -> [TapeCommand]
forall a. a -> [a] -> [a]
: [TapeCommand]
acc)
                        | Bool
otherwise ->
                            [Set State]
-> ([State], [State])
-> [TapeCommand]
-> a
-> a
-> ([Set State], [State], [TapeCommand])
-> ([Set State], [State], [TapeCommand])
oneActionCommand [Set State]
tt ([State]
st, [State]
ft) [TapeCommand]
t a
n (a
i a -> a -> a
forall a. Num a => a -> a -> a
+ a
1) (State -> Set State -> Set State
forall a. Ord a => a -> Set a -> Set a
Set.insert State
intermediateState Set State
tape Set State -> [Set State] -> [Set State]
forall a. a -> [a] -> [a]
: [Set State]
newTapeStates, State
intermediateState State -> [State] -> [State]
forall a. a -> [a] -> [a]
: [State]
newStarts, ((Square, State, Square), (Square, State, Square)) -> TapeCommand
SingleTapeCommand ((Square
ES, State
start, Square
r1), (Square
ES, State
intermediateState, Square
r2)) TapeCommand -> [TapeCommand] -> [TapeCommand]
forall a. a -> [a] -> [a]
: [TapeCommand]
acc)
                                where intermediateState :: State
intermediateState = Set State -> State
genNextState Set State
tape
                ([Set State], [TapeCommand], [State], [State])
_ -> [Char] -> ([Set State], [State], [TapeCommand])
forall a. HasCallStack => [Char] -> a
error ([Char] -> ([Set State], [State], [TapeCommand]))
-> [Char] -> ([Set State], [State], [TapeCommand])
forall a b. (a -> b) -> a -> b
$ [Char]
"Non-exhaustive patterns in case " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ ([Set State], [State], [TapeCommand]) -> [Char]
forall a. Show a => a -> [Char]
show ([Set State] -> [Set State]
forall a. [a] -> [a]
reverse [Set State]
newTapeStates, [State] -> [State]
forall a. [a] -> [a]
reverse [State]
newStarts, [TapeCommand] -> [TapeCommand]
forall a. [a] -> [a]
reverse [TapeCommand]
acc)

    let one2KCmd :: [Set State]
-> ([State], [State])
-> a
-> [TapeCommand]
-> [TapeCommand]
-> [[TapeCommand]]
-> ([Set State], [[TapeCommand]])
one2KCmd [Set State]
states ([State]
starts, [State]
finals) a
i [TapeCommand]
command [TapeCommand]
immutCommand [[TapeCommand]]
acc =
            case [TapeCommand]
command of
                SingleTapeCommand ((Square
l1, State
_, Square
_), (Square
l2, State
_, Square
_)) : [TapeCommand]
t  | Square
l1 Square -> Square -> Bool
forall a. Eq a => a -> a -> Bool
== Square
ES Bool -> Bool -> Bool
&& Square
l2 Square -> Square -> Bool
forall a. Eq a => a -> a -> Bool
== Square
ES ->
                                                                            [Set State]
-> ([State], [State])
-> a
-> [TapeCommand]
-> [TapeCommand]
-> [[TapeCommand]]
-> ([Set State], [[TapeCommand]])
one2KCmd [Set State]
states ([State]
starts, [State]
finals) (a
i a -> a -> a
forall a. Num a => a -> a -> a
+ a
1) [TapeCommand]
t [TapeCommand]
immutCommand [[TapeCommand]]
acc
                                                                    | Bool
otherwise ->
                                                                            [Set State]
-> ([State], [State])
-> a
-> [TapeCommand]
-> [TapeCommand]
-> [[TapeCommand]]
-> ([Set State], [[TapeCommand]])
one2KCmd [Set State]
newTapeStates ([State]
newStarts, [State]
finals) (a
i a -> a -> a
forall a. Num a => a -> a -> a
+ a
1) [TapeCommand]
t [TapeCommand]
immutCommand ([[TapeCommand]] -> ([Set State], [[TapeCommand]]))
-> [[TapeCommand]] -> ([Set State], [[TapeCommand]])
forall a b. (a -> b) -> a -> b
$ [TapeCommand]
newCommand [TapeCommand] -> [[TapeCommand]] -> [[TapeCommand]]
forall a. a -> [a] -> [a]
: [[TapeCommand]]
acc
                                                                                where ([Set State]
newTapeStates, [State]
newStarts, [TapeCommand]
newCommand) = [Set State]
-> ([State], [State])
-> [TapeCommand]
-> a
-> a
-> ([Set State], [State], [TapeCommand])
-> ([Set State], [State], [TapeCommand])
forall a.
(Num a, Ord a) =>
[Set State]
-> ([State], [State])
-> [TapeCommand]
-> a
-> a
-> ([Set State], [State], [TapeCommand])
-> ([Set State], [State], [TapeCommand])
oneActionCommand [Set State]
states ([State]
starts, [State]
finals) [TapeCommand]
immutCommand a
i a
0 ([], [], [])
                [] -> ([Set State]
states, [[TapeCommand]]
acc)
                [TapeCommand]
_ -> [Char] -> ([Set State], [[TapeCommand]])
forall a. HasCallStack => [Char] -> a
error [Char]
"Must be SingleTapeCommand"
    let one2KCmdsInternal :: [Set State]
-> [[TapeCommand]]
-> [[TapeCommand]]
-> ([Set State], [[TapeCommand]])
one2KCmdsInternal [Set State]
states [[TapeCommand]]
commands [[TapeCommand]]
acc =
            case [[TapeCommand]]
commands of
                [TapeCommand]
h : [[TapeCommand]]
t -> [Set State]
-> [[TapeCommand]]
-> [[TapeCommand]]
-> ([Set State], [[TapeCommand]])
one2KCmdsInternal [Set State]
newTapeStates [[TapeCommand]]
t ([[TapeCommand]] -> ([Set State], [[TapeCommand]]))
-> [[TapeCommand]] -> ([Set State], [[TapeCommand]])
forall a b. (a -> b) -> a -> b
$ [[TapeCommand]]
newCommands [[TapeCommand]] -> [[TapeCommand]] -> [[TapeCommand]]
forall a. [a] -> [a] -> [a]
++ [[TapeCommand]]
acc
                    where   ([State]
starts, [State]
finals) = [TapeCommand] -> ([State], [State]) -> ([State], [State])
getStartAndFinalStatesOfCommand [TapeCommand]
h ([], [])
                            ([Set State]
newTapeStates, [[TapeCommand]]
newCommands) = [Set State]
-> ([State], [State])
-> Integer
-> [TapeCommand]
-> [TapeCommand]
-> [[TapeCommand]]
-> ([Set State], [[TapeCommand]])
forall a.
(Num a, Ord a) =>
[Set State]
-> ([State], [State])
-> a
-> [TapeCommand]
-> [TapeCommand]
-> [[TapeCommand]]
-> ([Set State], [[TapeCommand]])
one2KCmd [Set State]
states ([State]
starts, [State]
finals) Integer
0 [TapeCommand]
h [TapeCommand]
h []
                [] -> ([Set State]
states, [[TapeCommand]]
acc)


    [Set State]
-> [[TapeCommand]]
-> [[TapeCommand]]
-> ([Set State], [[TapeCommand]])
one2KCmdsInternal [Set State]
multiTapeStates [[TapeCommand]]
allcommands []

cmd2SIDCmd :: ([Set State], [[TapeCommand]]) -> ([Set State], [[TapeCommand]])
cmd2SIDCmd :: ([Set State], [[TapeCommand]]) -> ([Set State], [[TapeCommand]])
cmd2SIDCmd ([Set State]
tSts, [[TapeCommand]]
allcommands) = do
    let transformCommand :: [Set State] -> [TapeCommand] -> ([Set State], [[TapeCommand]])
transformCommand [Set State]
states [TapeCommand]
command = ([Set State]
newTapeStates, [[TapeCommand]
c1, [TapeCommand]
c2])
            where
                func :: TapeCommand -> Set State -> (TapeCommand, TapeCommand, Set State)
func (SingleTapeCommand ((Square
l1, State
s1, Square
r1), (Square
l2, State
s2, Square
r2))) Set State
tape = (((Square, State, Square), (Square, State, Square)) -> TapeCommand
SingleTapeCommand ((Square
l1, State
s1, Square
r1), (Square
ES, State
intermediateState, Square
r1)), ((Square, State, Square), (Square, State, Square)) -> TapeCommand
SingleTapeCommand ((Square
ES, State
intermediateState, Square
r1), (Square
l2, State
s2, Square
r2)), State -> Set State -> Set State
forall a. Ord a => a -> Set a -> Set a
Set.insert State
intermediateState Set State
tape)
                    where
                        intermediateState :: State
intermediateState = Set State -> State
genNextState Set State
tape
                func TapeCommand
_ Set State
_ = [Char] -> (TapeCommand, TapeCommand, Set State)
forall a. HasCallStack => [Char] -> a
error [Char]
"Must be SingleTapeCommand"
                ([TapeCommand]
c1, [TapeCommand]
c2, [Set State]
newTapeStates) = [(TapeCommand, TapeCommand, Set State)]
-> ([TapeCommand], [TapeCommand], [Set State])
forall a b c. [(a, b, c)] -> ([a], [b], [c])
unzip3 ([(TapeCommand, TapeCommand, Set State)]
 -> ([TapeCommand], [TapeCommand], [Set State]))
-> [(TapeCommand, TapeCommand, Set State)]
-> ([TapeCommand], [TapeCommand], [Set State])
forall a b. (a -> b) -> a -> b
$ (TapeCommand -> Set State -> (TapeCommand, TapeCommand, Set State))
-> [TapeCommand]
-> [Set State]
-> [(TapeCommand, TapeCommand, Set State)]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith TapeCommand -> Set State -> (TapeCommand, TapeCommand, Set State)
func [TapeCommand]
command [Set State]
states

    let checkLeftBounding :: t TapeCommand -> Bool
checkLeftBounding t TapeCommand
command = (TapeCommand -> Bool) -> t TapeCommand -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all (\(SingleTapeCommand ((Square
l1, State
_, Square
_), (Square
l2, State
_, Square
_))) -> Square
l1 Square -> Square -> Bool
forall a. Eq a => a -> a -> Bool
== Square
LBS Bool -> Bool -> Bool
|| Square
l1 Square -> Square -> Bool
forall a. Eq a => a -> a -> Bool
== Square
ES Bool -> Bool -> Bool
|| Square
l2 Square -> Square -> Bool
forall a. Eq a => a -> a -> Bool
== Square
ES) t TapeCommand
command

    let cmd2SIDCmdInternal :: [Set State]
-> [[TapeCommand]]
-> [[TapeCommand]]
-> ([Set State], [[TapeCommand]])
cmd2SIDCmdInternal [Set State]
states [[TapeCommand]]
commands [[TapeCommand]]
acc =
            case [[TapeCommand]]
commands of
                [TapeCommand]
h : [[TapeCommand]]
t   | [TapeCommand] -> Bool
forall (t :: * -> *). Foldable t => t TapeCommand -> Bool
checkLeftBounding [TapeCommand]
h -> [Set State]
-> [[TapeCommand]]
-> [[TapeCommand]]
-> ([Set State], [[TapeCommand]])
cmd2SIDCmdInternal [Set State]
states [[TapeCommand]]
t ([[TapeCommand]] -> ([Set State], [[TapeCommand]]))
-> [[TapeCommand]] -> ([Set State], [[TapeCommand]])
forall a b. (a -> b) -> a -> b
$ [TapeCommand]
h [TapeCommand] -> [[TapeCommand]] -> [[TapeCommand]]
forall a. a -> [a] -> [a]
: [[TapeCommand]]
acc
                        | Bool
otherwise -> [Set State]
-> [[TapeCommand]]
-> [[TapeCommand]]
-> ([Set State], [[TapeCommand]])
cmd2SIDCmdInternal [Set State]
newTapeStates [[TapeCommand]]
t ([[TapeCommand]] -> ([Set State], [[TapeCommand]]))
-> [[TapeCommand]] -> ([Set State], [[TapeCommand]])
forall a b. (a -> b) -> a -> b
$ [[TapeCommand]]
newCommands [[TapeCommand]] -> [[TapeCommand]] -> [[TapeCommand]]
forall a. [a] -> [a] -> [a]
++ [[TapeCommand]]
acc
                            where   ([Set State]
newTapeStates, [[TapeCommand]]
newCommands) = [Set State] -> [TapeCommand] -> ([Set State], [[TapeCommand]])
transformCommand [Set State]
states [TapeCommand]
h
                [] -> ([Set State]
states, [[TapeCommand]]
acc)

    [Set State]
-> [[TapeCommand]]
-> [[TapeCommand]]
-> ([Set State], [[TapeCommand]])
cmd2SIDCmdInternal [Set State]
tSts [[TapeCommand]]
allcommands []

symTM :: TM -> TM
symTM :: TM -> TM
symTM TM
tm = do
    let (TM (InputAlphabet
inputAlphabet,
            [TapeAlphabet]
tapeAlphabets,
            MultiTapeStates [Set State]
multiTapeStates,
            Commands Set [TapeCommand]
commandsSet,
            StartStates [State]
startStates,
            AccessStates [State]
accessStates)
            ) = TM -> TM
threePhaseProcessing TM
tm

    let commands :: [[TapeCommand]]
commands = Set [TapeCommand] -> [[TapeCommand]]
forall a. Set a -> [a]
Set.toList Set [TapeCommand]
commandsSet
    let ([State]
newStartStates, [State]
newAccessStates, [TapeAlphabet]
newTapeAlphabets, [Set State]
doubledTapeStates, [[TapeCommand]]
doubledCommands) = [State]
-> [State]
-> [TapeAlphabet]
-> [Set State]
-> [[TapeCommand]]
-> ([State], [State], [TapeAlphabet], [Set State], [[TapeCommand]])
doubleCommands [State]
startStates [State]
accessStates [TapeAlphabet]
tapeAlphabets [Set State]
multiTapeStates [[TapeCommand]]
commands
    let ([Set State]
newTapeStates, [[TapeCommand]]
newTMCommands) =    ([Set State], [[TapeCommand]]) -> ([Set State], [[TapeCommand]])
cmd2SIDCmd (([Set State], [[TapeCommand]]) -> ([Set State], [[TapeCommand]]))
-> ([Set State], [[TapeCommand]]) -> ([Set State], [[TapeCommand]])
forall a b. (a -> b) -> a -> b
$
                                            ([Set State], [[TapeCommand]]) -> ([Set State], [[TapeCommand]])
one2KCmds ([Set State]
doubledTapeStates, [[TapeCommand]]
doubledCommands)
    (InputAlphabet, [TapeAlphabet], MultiTapeStates, Commands,
 StartStates, AccessStates)
-> TM
TM (InputAlphabet
inputAlphabet,
        [TapeAlphabet]
newTapeAlphabets,
        [Set State] -> MultiTapeStates
MultiTapeStates [Set State]
newTapeStates,
        Set [TapeCommand] -> Commands
Commands ([[TapeCommand]] -> Set [TapeCommand]
forall a. Ord a => [a] -> Set a
Set.fromList ([[TapeCommand]] -> Set [TapeCommand])
-> [[TapeCommand]] -> Set [TapeCommand]
forall a b. (a -> b) -> a -> b
$ [[TapeCommand]] -> [[TapeCommand]]
symCommands [[TapeCommand]]
newTMCommands),
        [State] -> StartStates
StartStates [State]
newStartStates,
        [State] -> AccessStates
AccessStates [State]
newAccessStates)

symDetTM :: TM -> TM
symDetTM :: TM -> TM
symDetTM (TM (InputAlphabet
inputAlphabet,
            [TapeAlphabet]
tapeAlphabets,
            MultiTapeStates [Set State]
multiTapeStates,
            Commands Set [TapeCommand]
commandsSet,
            StartStates [State]
startStates,
            AccessStates [State]
accessStates)
            ) = do

    let commands :: [[TapeCommand]]
commands = Set [TapeCommand] -> [[TapeCommand]]
forall a. Set a -> [a]
Set.toList Set [TapeCommand]
commandsSet
    let ([State]
newStartStates, [State]
newAccessStates, [TapeAlphabet]
newTapeAlphabets, [Set State]
doubledTapeStates, [[TapeCommand]]
doubledCommands) = [State]
-> [State]
-> [TapeAlphabet]
-> [Set State]
-> [[TapeCommand]]
-> ([State], [State], [TapeAlphabet], [Set State], [[TapeCommand]])
doubleCommands [State]
startStates [State]
accessStates [TapeAlphabet]
tapeAlphabets [Set State]
multiTapeStates [[TapeCommand]]
commands
    let ([Set State]
newTapeStates, [[TapeCommand]]
newTMCommands) =    ([Set State], [[TapeCommand]]) -> ([Set State], [[TapeCommand]])
cmd2SIDCmd (([Set State], [[TapeCommand]]) -> ([Set State], [[TapeCommand]]))
-> ([Set State], [[TapeCommand]]) -> ([Set State], [[TapeCommand]])
forall a b. (a -> b) -> a -> b
$
                                            ([Set State], [[TapeCommand]]) -> ([Set State], [[TapeCommand]])
one2KCmds ([Set State]
doubledTapeStates, [[TapeCommand]]
doubledCommands)
    (InputAlphabet, [TapeAlphabet], MultiTapeStates, Commands,
 StartStates, AccessStates)
-> TM
TM (InputAlphabet
inputAlphabet,
        [TapeAlphabet]
newTapeAlphabets,
        [Set State] -> MultiTapeStates
MultiTapeStates [Set State]
newTapeStates,
        Set [TapeCommand] -> Commands
Commands ([[TapeCommand]] -> Set [TapeCommand]
forall a. Ord a => [a] -> Set a
Set.fromList ([[TapeCommand]] -> Set [TapeCommand])
-> [[TapeCommand]] -> Set [TapeCommand]
forall a b. (a -> b) -> a -> b
$ [[TapeCommand]] -> [[TapeCommand]]
symCommands [[TapeCommand]]
newTMCommands),
        [State] -> StartStates
StartStates [State]
newStartStates,
        [State] -> AccessStates
AccessStates [State]
newAccessStates)