-- |This module provides functionality for converting the Turing machine 'Tms' to 'TMType.TM'.
module Tms2TuringMachine (tms2turingMachine, hash) where

import qualified Data.List.NonEmpty as NonEmpty
import Data.Char (ord)
import Data.List.NonEmpty (NonEmpty(..))
import Data.Bits (xor)
import Data.Maybe (fromMaybe)

import TuringMachine
import TmsType

tms2turingMachine :: Tms -> Either String TuringMachine
tms2turingMachine :: Tms -> Either String TuringMachine
tms2turingMachine
    ( Tms
        ( String
_,
          TmsState
startSt,
          [TmsState
acc],
          [TmsCommand]
commands,
          [alph :: String
alph@(Char
x : String
xs)]
          )
      ) = do
        [OneTapeTMCommand]
oneTapeCmds <- (TmsCommand -> Either String OneTapeTMCommand)
-> [TmsCommand] -> Either String [OneTapeTMCommand]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse TmsCommand -> Either String OneTapeTMCommand
toOneTapeCommand [TmsCommand]
commands -- [(TmsState, TmsSingleTapeCommand, TmsState)]
        let otherStates :: [TmsState]
otherStates = (TmsState -> Bool) -> [TmsState] -> [TmsState]
forall a. (a -> Bool) -> [a] -> [a]
filter (\TmsState
s -> TmsState
s TmsState -> TmsState -> Bool
forall a. Eq a => a -> a -> Bool
/= TmsState
startSt Bool -> Bool -> Bool
&& TmsState
s TmsState -> TmsState -> Bool
forall a. Eq a => a -> a -> Bool
/= TmsState
acc) ((OneTapeTMCommand -> [TmsState])
-> [OneTapeTMCommand] -> [TmsState]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (\(TmsState
s1, TmsSingleTapeCommand
_, TmsState
s2) -> [TmsState
s1, TmsState
s2]) [OneTapeTMCommand]
oneTapeCmds)
        let stateToInd :: Map TmsState Int
stateToInd = [(TmsState, Int)] -> Map TmsState Int
forall c v. UnsafeListable c v => [v] -> c
fromList ([(TmsState, Int)] -> Map TmsState Int)
-> [(TmsState, Int)] -> Map TmsState Int
forall a b. (a -> b) -> a -> b
$ [TmsState] -> [Int] -> [(TmsState, Int)]
forall a b. [a] -> [b] -> [(a, b)]
zip (TmsState
acc TmsState -> [TmsState] -> [TmsState]
forall a. a -> [a] -> [a]
: TmsState
startSt TmsState -> [TmsState] -> [TmsState]
forall a. a -> [a] -> [a]
: [TmsState]
otherStates) [Int
0 ..]
        let alphabet' :: Alphabet
alphabet' = [(ShowedSymbol, Symbol)] -> Alphabet
forall c v. UnsafeListable c v => [v] -> c
fromList ([(ShowedSymbol, Symbol)] -> Alphabet)
-> [(ShowedSymbol, Symbol)] -> Alphabet
forall a b. (a -> b) -> a -> b
$ [ShowedSymbol] -> [Symbol] -> [(ShowedSymbol, Symbol)]
forall a b. [a] -> [b] -> [(a, b)]
zip (ShowedSymbol
blank ShowedSymbol -> [ShowedSymbol] -> [ShowedSymbol]
forall a. a -> [a] -> [a]
: (Char -> ShowedSymbol) -> String -> [ShowedSymbol]
forall a b. (a -> b) -> [a] -> [b]
map (String -> ShowedSymbol
forall a. Read a => String -> a
read (String -> ShowedSymbol)
-> (Char -> String) -> Char -> ShowedSymbol
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Char -> String
forall (f :: * -> *) a. Applicative f => a -> f a
pure) String
alph) [Symbol
forall a. Bounded a => a
minBound..] :: Alphabet
        TuringMachine -> Either String TuringMachine
forall (m :: * -> *) a. Monad m => a -> m a
return (TuringMachine -> Either String TuringMachine)
-> TuringMachine -> Either String TuringMachine
forall a b. (a -> b) -> a -> b
$ Quadruples -> LabeledStates -> Alphabet -> TuringMachine
turingMachine ([Quadruple] -> Quadruples
forall c v. UnsafeListable c v => [v] -> c
fromList ([Quadruple] -> Quadruples) -> [Quadruple] -> Quadruples
forall a b. (a -> b) -> a -> b
$ ((Int, OneTapeTMCommand) -> [Quadruple])
-> [(Int, OneTapeTMCommand)] -> [Quadruple]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (NonEmpty Char
-> Map TmsState Int
-> Alphabet
-> (Int, OneTapeTMCommand)
-> [Quadruple]
tmsCmd2tmCmd (Char
x Char -> String -> NonEmpty Char
forall a. a -> [a] -> NonEmpty a
:| String
xs) Map TmsState Int
stateToInd Alphabet
alphabet') ([Int] -> [OneTapeTMCommand] -> [(Int, OneTapeTMCommand)]
forall a b. [a] -> [b] -> [(a, b)]
zip [Int
0, String -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
Prelude.length String
alph ..] [OneTapeTMCommand]
oneTapeCmds)) LabeledStates
forall c. Nullable c => c
emptyC Alphabet
alphabet'
    where
        toOneTapeCommand :: TmsCommand -> Either String OneTapeTMCommand
        toOneTapeCommand :: TmsCommand -> Either String OneTapeTMCommand
toOneTapeCommand (TmsCommand (TmsState
tmsStartSt, [TmsSingleTapeCommand
cmd], TmsState
fol)) = OneTapeTMCommand -> Either String OneTapeTMCommand
forall (m :: * -> *) a. Monad m => a -> m a
return (TmsState
tmsStartSt, TmsSingleTapeCommand
cmd, TmsState
fol)
        toOneTapeCommand TmsCommand
_                                     = String -> Either String OneTapeTMCommand
forall a b. a -> Either a b
Left String
"Multi tape command found."
tms2turingMachine Tms
_ = String -> Either String TuringMachine
forall a b. a -> Either a b
Left String
"Must have only one tape, one accept state and nonempty alphabet."

-- | Hash function used to proivde algorithm with extra unique names.
hash :: String -> Int
hash :: String -> Int
hash = (Int -> Char -> Int) -> Int -> String -> Int
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl (\Int
h Char
c -> Int
29 Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
h Int -> Int -> Int
forall a. Bits a => a -> a -> a
`xor` Char -> Int
ord Char
c) Int
0

type Transition = (Symbol, SymbolOrMove)

-- | Convert TmsSingleTapeCommand to [Quadriple]
tmsCmd2tmCmd :: NonEmpty.NonEmpty Char -> Map TmsState Int -> Alphabet -> (Int, OneTapeTMCommand) -> [TuringMachine.Quadruple]
tmsCmd2tmCmd :: NonEmpty Char
-> Map TmsState Int
-> Alphabet
-> (Int, OneTapeTMCommand)
-> [Quadruple]
tmsCmd2tmCmd NonEmpty Char
alph Map TmsState Int
stateToInd Alphabet
alphabet (Int
transStart, (TmsState
iniSt, TmsSingleTapeCommand (TmsTapeSquare
action, TmsTapeHeadMovement
move), TmsState
folSt)) = (NonEmpty Quadruple -> [Quadruple])
-> NonEmpty (NonEmpty Quadruple) -> [Quadruple]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap NonEmpty Quadruple -> [Quadruple]
forall a. NonEmpty a -> [a]
NonEmpty.toList (NonEmpty (NonEmpty Quadruple) -> [Quadruple])
-> NonEmpty (NonEmpty Quadruple) -> [Quadruple]
forall a b. (a -> b) -> a -> b
$ do
    NonEmpty Transition
oneSequence <- NonEmpty Char
-> (TmsTapeSquare, TmsTapeHeadMovement)
-> NonEmpty (NonEmpty Transition)
translate NonEmpty Char
alph (TmsTapeSquare
action, TmsTapeHeadMovement
move)
    case NonEmpty Transition
oneSequence of
        (Transition
step :| [])             -> NonEmpty Quadruple -> NonEmpty (NonEmpty Quadruple)
forall (m :: * -> *) a. Monad m => a -> m a
return (NonEmpty Quadruple -> NonEmpty (NonEmpty Quadruple))
-> (Quadruple -> NonEmpty Quadruple)
-> Quadruple
-> NonEmpty (NonEmpty Quadruple)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Quadruple -> NonEmpty Quadruple
forall (m :: * -> *) a. Monad m => a -> m a
return (Quadruple -> NonEmpty (NonEmpty Quadruple))
-> Quadruple -> NonEmpty (NonEmpty Quadruple)
forall a b. (a -> b) -> a -> b
$ Transition -> TmsState -> TmsState -> Quadruple
forall b a.
(b, a) -> TmsState -> TmsState -> ((State, b), (a, State))
makeQuad Transition
step TmsState
iniSt TmsState
folSt
        (Transition
step :| extras :: [Transition]
extras@(Transition
_ : [Transition]
_)) -> NonEmpty Quadruple -> NonEmpty (NonEmpty Quadruple)
forall (m :: * -> *) a. Monad m => a -> m a
return (NonEmpty Quadruple -> NonEmpty (NonEmpty Quadruple))
-> NonEmpty Quadruple -> NonEmpty (NonEmpty Quadruple)
forall a b. (a -> b) -> a -> b
$
            Transition -> TmsState -> State -> Quadruple
forall b a b. (b, a) -> TmsState -> b -> ((State, b), (a, b))
makeQuad' Transition
step TmsState
iniSt (Int -> TmsState -> State
addIndex Int
transStart TmsState
iniSt) Quadruple -> [Quadruple] -> NonEmpty Quadruple
forall a. a -> [a] -> NonEmpty a
:|
            (
                (TmsState -> (Int, Transition) -> Quadruple
makeTransition TmsState
iniSt ((Int, Transition) -> Quadruple)
-> [(Int, Transition)] -> [Quadruple]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Int] -> [Transition] -> [(Int, Transition)]
forall a b. [a] -> [b] -> [(a, b)]
zip [Int
transStart ..] ([Transition] -> [Transition]
forall a. [a] -> [a]
Prelude.init [Transition]
extras)) [Quadruple] -> [Quadruple] -> [Quadruple]
forall a. [a] -> [a] -> [a]
++
                [Transition -> State -> TmsState -> Quadruple
forall b a a. (b, a) -> a -> TmsState -> ((a, b), (a, State))
makeQuad'' ([Transition] -> Transition
forall a. [a] -> a
Prelude.last [Transition]
extras) (Int -> TmsState -> State
addIndex (Int
transStart Int -> Int -> Int
forall a. Num a => a -> a -> a
+ [Transition] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
Prelude.length [Transition]
extras Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1) TmsState
iniSt) TmsState
folSt]
            )
    where
        makeQuad :: (b, a) -> TmsState -> TmsState -> ((State, b), (a, State))
makeQuad (b
s, a
m) TmsState
startSt TmsState
fol   = ((TmsState -> State
tmsState2state TmsState
startSt, b
s), (a
m, TmsState -> State
tmsState2state TmsState
fol))
        makeQuad' :: (b, a) -> TmsState -> b -> ((State, b), (a, b))
makeQuad' (b
s, a
m) TmsState
startSt b
fol  = ((TmsState -> State
tmsState2state TmsState
startSt, b
s), (a
m, b
fol))
        makeQuad'' :: (b, a) -> a -> TmsState -> ((a, b), (a, State))
makeQuad'' (b
s, a
m) a
startSt TmsState
fol = ((a
startSt, b
s), (a
m, TmsState -> State
tmsState2state TmsState
fol))

        makeTransition :: TmsState -> (Int, Transition) -> TuringMachine.Quadruple
        makeTransition :: TmsState -> (Int, Transition) -> Quadruple
makeTransition TmsState
startSt (Int
ind, (Symbol
s, SymbolOrMove
sm)) = ((Int -> TmsState -> State
addIndex Int
ind TmsState
startSt, Symbol
s), (SymbolOrMove
sm, Int -> TmsState -> State
addIndex (Int -> Int
forall a. Enum a => a -> a
succ Int
ind) TmsState
startSt))

        addIndex :: Int -> TmsState -> State
        addIndex :: Int -> TmsState -> State
addIndex Int
x (TmsState String
name) = TmsState -> State
tmsState2state (TmsState -> State) -> TmsState -> State
forall a b. (a -> b) -> a -> b
$ String -> TmsState
TmsState (String
name String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"_" String -> String -> String
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show Int
x)

        tmsState2state :: TmsState -> State
        tmsState2state :: TmsState -> State
tmsState2state TmsState
st = Int -> State
state (Int -> State) -> Int -> State
forall a b. (a -> b) -> a -> b
$ TmsState -> Map TmsState Int -> Int
safeLookup TmsState
st Map TmsState Int
stateToInd

        safeLookup :: TmsState -> Map TmsState Int -> Int
        safeLookup :: TmsState -> Map TmsState Int -> Int
safeLookup key :: TmsState
key@(TmsState String
name) Map TmsState Int
m = Int -> Maybe Int -> Int
forall a. a -> Maybe a -> a
fromMaybe (String -> Int
hash String
name) (Map TmsState Int
m Map TmsState Int -> TmsState -> Maybe Int
forall c k v (m :: * -> *).
(Indexable c k v, MonadFail m) =>
c -> k -> m v
!? TmsState
key)

        -- | List of equivalent sequences of Transitions.
        translate :: NonEmpty Char -> (TmsTapeSquare, TmsTapeHeadMovement) -> NonEmpty (NonEmpty Transition)
        translate :: NonEmpty Char
-> (TmsTapeSquare, TmsTapeHeadMovement)
-> NonEmpty (NonEmpty Transition)
translate NonEmpty Char
_ (ChangeFromTo Char
f Char
t, TmsTapeHeadMovement
MoveLeft)  | Char
f Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
t    = NonEmpty Transition -> NonEmpty (NonEmpty Transition)
forall (m :: * -> *) a. Monad m => a -> m a
return (NonEmpty Transition -> NonEmpty (NonEmpty Transition))
-> NonEmpty Transition -> NonEmpty (NonEmpty Transition)
forall a b. (a -> b) -> a -> b
$ (Char -> Symbol
smb Char
f, Move -> SymbolOrMove
forall s. Move -> MoveOr s
M Move
toLeft)  Transition -> [Transition] -> NonEmpty Transition
forall a. a -> [a] -> NonEmpty a
:| []
                                                  | Bool
otherwise = NonEmpty Transition -> NonEmpty (NonEmpty Transition)
forall (m :: * -> *) a. Monad m => a -> m a
return (NonEmpty Transition -> NonEmpty (NonEmpty Transition))
-> NonEmpty Transition -> NonEmpty (NonEmpty Transition)
forall a b. (a -> b) -> a -> b
$ (Char -> Symbol
smb Char
f, Char -> SymbolOrMove
chg Char
t)     Transition -> [Transition] -> NonEmpty Transition
forall a. a -> [a] -> NonEmpty a
:| [(Char -> Symbol
smb Char
t, Move -> SymbolOrMove
forall s. Move -> MoveOr s
M Move
toLeft)]
        translate NonEmpty Char
_ (ChangeFromTo Char
f Char
t, TmsTapeHeadMovement
MoveRight) | Char
f Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
t    = NonEmpty Transition -> NonEmpty (NonEmpty Transition)
forall (m :: * -> *) a. Monad m => a -> m a
return (NonEmpty Transition -> NonEmpty (NonEmpty Transition))
-> NonEmpty Transition -> NonEmpty (NonEmpty Transition)
forall a b. (a -> b) -> a -> b
$ (Char -> Symbol
smb Char
f, Move -> SymbolOrMove
forall s. Move -> MoveOr s
M Move
toRight) Transition -> [Transition] -> NonEmpty Transition
forall a. a -> [a] -> NonEmpty a
:| []
                                                  | Bool
otherwise = NonEmpty Transition -> NonEmpty (NonEmpty Transition)
forall (m :: * -> *) a. Monad m => a -> m a
return (NonEmpty Transition -> NonEmpty (NonEmpty Transition))
-> NonEmpty Transition -> NonEmpty (NonEmpty Transition)
forall a b. (a -> b) -> a -> b
$ (Char -> Symbol
smb Char
f, Char -> SymbolOrMove
chg Char
t)     Transition -> [Transition] -> NonEmpty Transition
forall a. a -> [a] -> NonEmpty a
:| [(Char -> Symbol
smb Char
t, Move -> SymbolOrMove
forall s. Move -> MoveOr s
M Move
toRight)]
        translate NonEmpty Char
_ (ChangeFromTo Char
f Char
t, TmsTapeHeadMovement
Stay)                  = NonEmpty Transition -> NonEmpty (NonEmpty Transition)
forall (m :: * -> *) a. Monad m => a -> m a
return (NonEmpty Transition -> NonEmpty (NonEmpty Transition))
-> NonEmpty Transition -> NonEmpty (NonEmpty Transition)
forall a b. (a -> b) -> a -> b
$ (Char -> Symbol
smb Char
f, Char -> SymbolOrMove
chg Char
t)     Transition -> [Transition] -> NonEmpty Transition
forall a. a -> [a] -> NonEmpty a
:| []

        translate NonEmpty Char
abc (TmsTapeSquare
Leave, TmsTapeHeadMovement
Stay) = do
            Char
ch <- Char -> NonEmpty Char -> NonEmpty Char
forall a. a -> NonEmpty a -> NonEmpty a
NonEmpty.cons Char
'_' NonEmpty Char
abc
            NonEmpty Transition -> NonEmpty (NonEmpty Transition)
forall (m :: * -> *) a. Monad m => a -> m a
return (NonEmpty Transition -> NonEmpty (NonEmpty Transition))
-> NonEmpty Transition -> NonEmpty (NonEmpty Transition)
forall a b. (a -> b) -> a -> b
$ Transition -> NonEmpty Transition
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Char -> Symbol
smb Char
ch, Char -> SymbolOrMove
chg Char
ch)
        translate NonEmpty Char
abc (TmsTapeSquare
Leave, TmsTapeHeadMovement
MoveLeft) = do
            Char
ch <- Char -> NonEmpty Char -> NonEmpty Char
forall a. a -> NonEmpty a -> NonEmpty a
NonEmpty.cons Char
'_' NonEmpty Char
abc
            NonEmpty Transition -> NonEmpty (NonEmpty Transition)
forall (m :: * -> *) a. Monad m => a -> m a
return (NonEmpty Transition -> NonEmpty (NonEmpty Transition))
-> NonEmpty Transition -> NonEmpty (NonEmpty Transition)
forall a b. (a -> b) -> a -> b
$ Transition -> NonEmpty Transition
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Char -> Symbol
smb Char
ch, Move -> SymbolOrMove
forall s. Move -> MoveOr s
M Move
toLeft)
        translate NonEmpty Char
abc (TmsTapeSquare
Leave, TmsTapeHeadMovement
MoveRight) = do
            Char
ch <- Char -> NonEmpty Char -> NonEmpty Char
forall a. a -> NonEmpty a -> NonEmpty a
NonEmpty.cons Char
'_' NonEmpty Char
abc
            NonEmpty Transition -> NonEmpty (NonEmpty Transition)
forall (m :: * -> *) a. Monad m => a -> m a
return (NonEmpty Transition -> NonEmpty (NonEmpty Transition))
-> NonEmpty Transition -> NonEmpty (NonEmpty Transition)
forall a b. (a -> b) -> a -> b
$ Transition -> NonEmpty Transition
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Char -> Symbol
smb Char
ch, Move -> SymbolOrMove
forall s. Move -> MoveOr s
M Move
toRight)

        smb :: Char -> Symbol
        smb :: Char -> Symbol
smb Char
'_' = Symbol
blankSymbol
        smb Char
c   = Symbol -> Maybe Symbol -> Symbol
forall a. a -> Maybe a -> a
fromMaybe Symbol
blankSymbol (Maybe Symbol -> Symbol) -> Maybe Symbol -> Symbol
forall a b. (a -> b) -> a -> b
$ Alphabet
alphabet Alphabet -> ShowedSymbol -> Maybe Symbol
forall c k v (m :: * -> *).
(Indexable c k v, MonadFail m) =>
c -> k -> m v
!? String -> ShowedSymbol
forall a. Read a => String -> a
read [Char
c]

        chg :: Char -> SymbolOrMove
        chg :: Char -> SymbolOrMove
chg = Symbol -> SymbolOrMove
forall s. s -> MoveOr s
S (Symbol -> SymbolOrMove)
-> (Char -> Symbol) -> Char -> SymbolOrMove
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Char -> Symbol
smb