-- |This module represents functionality for converting the 'TMTypes.TuringMachine' to 'TmsType.Tms'.
module TuringMachine2Tms (turingMachine2tms, turingMachineSt2tmsSt) where

import Data.Functor ((<&>))
import Data.Maybe (fromMaybe)
import Data.List (sort)

import TmsType
import TuringMachine

turingMachine2tms :: TuringMachine -> Tms
turingMachine2tms :: TuringMachine -> Tms
turingMachine2tms TuringMachine
tm =
    (String, TmsState, [TmsState], [TmsCommand], [String]) -> Tms
Tms (
            String
"TMTypes_TuringMachine",
            State -> TmsState
turingMachineSt2tmsSt State
startState,
            [State -> TmsState
turingMachineSt2tmsSt State
finalState],
            [TmsCommand] -> [TmsCommand]
forall a. Ord a => [a] -> [a]
sort ([TmsCommand] -> [TmsCommand]) -> [TmsCommand] -> [TmsCommand]
forall a b. (a -> b) -> a -> b
$ Quadruples -> [Quadruple]
forall c v. Listable c v => c -> [v]
toList (TuringMachine
tmTuringMachine
-> Getting Quadruples TuringMachine Quadruples -> Quadruples
forall s a. s -> Getting a s a -> a
^.Getting Quadruples TuringMachine Quadruples
Lens' TuringMachine Quadruples
quadruples) [Quadruple]
-> (Quadruple -> OneTapeTMCommand) -> [OneTapeTMCommand]
forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> Alphabet -> Quadruple -> OneTapeTMCommand
turingMCmd2tms (TuringMachine
tmTuringMachine
-> Getting Alphabet TuringMachine Alphabet -> Alphabet
forall s a. s -> Getting a s a -> a
^.Getting Alphabet TuringMachine Alphabet
Lens' TuringMachine Alphabet
alphabet) [OneTapeTMCommand]
-> (OneTapeTMCommand -> TmsCommand) -> [TmsCommand]
forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> OneTapeTMCommand -> TmsCommand
toTmsCommand,
            [String -> Char
forall a. [a] -> a
head (String -> Char)
-> (ShowedSymbol -> String) -> ShowedSymbol -> Char
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ShowedSymbol -> String
forall a. Show a => a -> String
show (ShowedSymbol -> Char) -> [ShowedSymbol] -> String
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (ShowedSymbol
blank ShowedSymbol -> [ShowedSymbol] -> [ShowedSymbol]
forall c v. Deletable c v => v -> c -> c
\> (Alphabet -> [ShowedSymbol]
forall c v. Valuable c v => c -> [v]
values (TuringMachine
tmTuringMachine
-> Getting Alphabet TuringMachine Alphabet -> Alphabet
forall s a. s -> Getting a s a -> a
^.Getting Alphabet TuringMachine Alphabet
Lens' TuringMachine Alphabet
alphabet) :: ShowedSymbols))]
        )

-- Section of helper functions.

turingMachineSt2tmsSt :: State -> TmsState
turingMachineSt2tmsSt :: State -> TmsState
turingMachineSt2tmsSt State
q = String -> TmsState
TmsState (String -> TmsState) -> String -> TmsState
forall a b. (a -> b) -> a -> b
$ String
"Q_" String -> String -> String
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show (State -> Int
numState State
q)

turingMCmd2tms :: Alphabet -> TuringMachine.Quadruple -> OneTapeTMCommand
turingMCmd2tms :: Alphabet -> Quadruple -> OneTapeTMCommand
turingMCmd2tms Alphabet
alph ((State
iniSt, Symbol
from), (SymbolOrMove
act, State
folSt)) = (
        State -> TmsState
turingMachineSt2tmsSt State
iniSt,
        (TmsTapeSquare, TmsTapeHeadMovement) -> TmsSingleTapeCommand
TmsSingleTapeCommand (TmsTapeSquare
action, TmsTapeHeadMovement
move),
        State -> TmsState
turingMachineSt2tmsSt State
folSt)
    where
        (TmsTapeHeadMovement
move, TmsTapeSquare
action) = case SymbolOrMove
act of
            S Symbol
to -> (TmsTapeHeadMovement
Stay,      Char -> Char -> TmsTapeSquare
ChangeFromTo (Symbol -> Char
symb2char Symbol
from) (Symbol -> Char
symb2char Symbol
to))
            M Move
m | Move
m Move -> Move -> Bool
forall a. Eq a => a -> a -> Bool
== Move
toLeft -> (TmsTapeHeadMovement
MoveLeft,  Char -> Char -> TmsTapeSquare
ChangeFromTo (Symbol -> Char
symb2char Symbol
from) (Symbol -> Char
symb2char Symbol
from))
                | Bool
otherwise   -> (TmsTapeHeadMovement
MoveRight, Char -> Char -> TmsTapeSquare
ChangeFromTo (Symbol -> Char
symb2char Symbol
from) (Symbol -> Char
symb2char Symbol
from))
        symb2char :: Symbol -> Char
        symb2char :: Symbol -> Char
symb2char Symbol
s = Char -> Maybe Char -> Char
forall a. a -> Maybe a -> a
fromMaybe Char
'?' (Maybe Char -> Char) -> Maybe Char -> Char
forall a b. (a -> b) -> a -> b
$ do
            ShowedSymbol
s' <- Alphabet
alph Alphabet -> Symbol -> Maybe ShowedSymbol
forall c k v (m :: * -> *).
(Indexable c k v, MonadFail m) =>
c -> k -> m v
!? Symbol
s
            Char -> Maybe Char
forall (m :: * -> *) a. Monad m => a -> m a
return (Char -> Maybe Char) -> Char -> Maybe Char
forall a b. (a -> b) -> a -> b
$
                if ShowedSymbol
s' ShowedSymbol -> ShowedSymbol -> Bool
forall a. Eq a => a -> a -> Bool
== ShowedSymbol
blank
                then Char
'_'
                else String -> Char
forall a. [a] -> a
head (String -> Char) -> String -> Char
forall a b. (a -> b) -> a -> b
$ ShowedSymbol -> String
forall a. Show a => a -> String
show ShowedSymbol
s'