{-# LANGUAGE TemplateHaskell #-}

-- |Module `TuringMachine.Interpreter` include functions for interpreting of
--  Turing machine.
module TuringMachine.Interpreter (
    WorkingState,
    currentState,
    tape,
    step,
    initWS,
    run,
    smartRun,
    superSmartRun,
    module TuringMachine.Interpreter.Tape,
    module TuringMachine,
  ) where

import TuringMachine.Interpreter.Tape
import TuringMachine

data WorkingState = WS
  { WorkingState -> State
_currentState  :: State
  , WorkingState -> Tape
_tape          :: Tape
  } deriving (WorkingState -> WorkingState -> Bool
(WorkingState -> WorkingState -> Bool)
-> (WorkingState -> WorkingState -> Bool) -> Eq WorkingState
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: WorkingState -> WorkingState -> Bool
$c/= :: WorkingState -> WorkingState -> Bool
== :: WorkingState -> WorkingState -> Bool
$c== :: WorkingState -> WorkingState -> Bool
Eq)

instance Show WorkingState where
    show :: WorkingState -> String
show (WS State
q Tape
t) = Tape -> String
forall a. Show a => a -> String
show Tape
t String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
"   (" String -> ShowS
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show (State -> Int
numState State
q) String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
")"

makeLenses ''WorkingState

step ::
    MonadFail m =>
    TuringMachine ->
    WorkingState ->
    m (TuringMachine.Quadruple, WorkingState)
step :: TuringMachine -> WorkingState -> m (Quadruple, WorkingState)
step TuringMachine
tm (WS State
q Tape
t) = do
    Symbol
s <- TuringMachine
tmTuringMachine
-> Getting (m Symbol) TuringMachine (m Symbol) -> m Symbol
forall s a. s -> Getting a s a -> a
^.(Alphabet -> Const (m Symbol) Alphabet)
-> TuringMachine -> Const (m Symbol) TuringMachine
Lens' TuringMachine Alphabet
alphabet((Alphabet -> Const (m Symbol) Alphabet)
 -> TuringMachine -> Const (m Symbol) TuringMachine)
-> TapeSymbol -> Getting (m Symbol) TuringMachine (m Symbol)
forall c k v (m :: * -> *) x y.
(Indexable c k v, MonadFail m) =>
Getting x y c -> k -> Getting x y (m v)
.@(Tape
tTape -> Getting TapeSymbol Tape TapeSymbol -> TapeSymbol
forall s a. s -> Getting a s a -> a
^.Getting TapeSymbol Tape TapeSymbol
Lens' Tape TapeSymbol
top)
    (MoveOr Symbol
sm, State
q') <- TuringMachine
tmTuringMachine
-> Getting
     (m (MoveOr Symbol, State)) TuringMachine (m (MoveOr Symbol, State))
-> m (MoveOr Symbol, State)
forall s a. s -> Getting a s a -> a
^.(Quadruples -> Const (m (MoveOr Symbol, State)) Quadruples)
-> TuringMachine -> Const (m (MoveOr Symbol, State)) TuringMachine
Lens' TuringMachine Quadruples
quadruples((Quadruples -> Const (m (MoveOr Symbol, State)) Quadruples)
 -> TuringMachine -> Const (m (MoveOr Symbol, State)) TuringMachine)
-> (State, Symbol)
-> Getting
     (m (MoveOr Symbol, State)) TuringMachine (m (MoveOr Symbol, State))
forall c k v (m :: * -> *) x y.
(Indexable c k v, MonadFail m) =>
Getting x y c -> k -> Getting x y (m v)
.@(State
q, Symbol
s)
    Tape
t' <- case MoveOr Symbol
sm of
            S Symbol
s' -> do
                TapeSymbol
c <- TuringMachine
tmTuringMachine
-> Getting (m TapeSymbol) TuringMachine (m TapeSymbol)
-> m TapeSymbol
forall s a. s -> Getting a s a -> a
^.(Alphabet -> Const (m TapeSymbol) Alphabet)
-> TuringMachine -> Const (m TapeSymbol) TuringMachine
Lens' TuringMachine Alphabet
alphabet((Alphabet -> Const (m TapeSymbol) Alphabet)
 -> TuringMachine -> Const (m TapeSymbol) TuringMachine)
-> Symbol -> Getting (m TapeSymbol) TuringMachine (m TapeSymbol)
forall c k v (m :: * -> *) x y.
(Indexable c k v, MonadFail m) =>
Getting x y c -> k -> Getting x y (m v)
.@Symbol
s'
                Tape -> m Tape
forall (m :: * -> *) a. Monad m => a -> m a
return (Tape
t Tape -> (Tape -> Tape) -> Tape
forall a b. a -> (a -> b) -> b
& (TapeSymbol -> Identity TapeSymbol) -> Tape -> Identity Tape
Lens' Tape TapeSymbol
top ((TapeSymbol -> Identity TapeSymbol) -> Tape -> Identity Tape)
-> TapeSymbol -> Tape -> Tape
forall s t a b. ASetter s t a b -> b -> s -> t
.~ TapeSymbol
c)
            M Move
m ->
                Tape -> m Tape
forall (m :: * -> *) a. Monad m => a -> m a
return (Tape
tTape -> Getting Tape Tape Tape -> Tape
forall s a. s -> Getting a s a -> a
^.Move -> Getter Tape Tape
move(Move
m))
    (Quadruple, WorkingState) -> m (Quadruple, WorkingState)
forall (m :: * -> *) a. Monad m => a -> m a
return (((State
q, Symbol
s), (MoveOr Symbol
sm, State
q')), State -> Tape -> WorkingState
WS State
q' Tape
t')

initWS :: String -> Int -> WorkingState
initWS :: String -> Int -> WorkingState
initWS String
s Int
i = State -> Tape -> WorkingState
WS State
startState (String -> Int -> Tape
fromString String
s Int
i)

run :: TuringMachine -> WorkingState -> [WorkingState]
run :: TuringMachine -> WorkingState -> [WorkingState]
run TuringMachine
tm WorkingState
ws =
    case TuringMachine -> WorkingState -> Maybe (Quadruple, WorkingState)
forall (m :: * -> *).
MonadFail m =>
TuringMachine -> WorkingState -> m (Quadruple, WorkingState)
step TuringMachine
tm WorkingState
ws of
        Maybe (Quadruple, WorkingState)
Nothing -> [WorkingState
ws]
        Just (Quadruple
_, WorkingState
ws') -> WorkingState
ws WorkingState -> [WorkingState] -> [WorkingState]
forall a. a -> [a] -> [a]
: TuringMachine -> WorkingState -> [WorkingState]
run TuringMachine
tm WorkingState
ws'

smartRun :: TuringMachine -> WorkingState -> [WorkingState]
smartRun :: TuringMachine -> WorkingState -> [WorkingState]
smartRun TuringMachine
tm WorkingState
ws =
    case TuringMachine -> WorkingState -> Maybe (Quadruple, WorkingState)
forall (m :: * -> *).
MonadFail m =>
TuringMachine -> WorkingState -> m (Quadruple, WorkingState)
step TuringMachine
tm WorkingState
ws of
        Maybe (Quadruple, WorkingState)
Nothing -> [WorkingState
ws]
        Just (((State
qf, Symbol
s), (MoveOr Symbol
sm, State
qt)), WorkingState
ws') ->
            if State
qf State -> State -> Bool
forall a. Eq a => a -> a -> Bool
== State
qt Bool -> Bool -> Bool
&& Symbol -> MoveOr Symbol
forall s. s -> MoveOr s
S Symbol
s MoveOr Symbol -> MoveOr Symbol -> Bool
forall a. Eq a => a -> a -> Bool
== MoveOr Symbol
sm
            then [WorkingState
ws, WorkingState
ws']
            else WorkingState
ws WorkingState -> [WorkingState] -> [WorkingState]
forall a. a -> [a] -> [a]
: TuringMachine -> WorkingState -> [WorkingState]
smartRun TuringMachine
tm WorkingState
ws'

superSmartRun ::
    MonadFail m =>
    TuringMachine ->
    WorkingState ->
    m [WorkingState]
superSmartRun :: TuringMachine -> WorkingState -> m [WorkingState]
superSmartRun TuringMachine
tm WorkingState
ws =
    case TuringMachine -> WorkingState -> Maybe (Quadruple, WorkingState)
forall (m :: * -> *).
MonadFail m =>
TuringMachine -> WorkingState -> m (Quadruple, WorkingState)
step TuringMachine
tm WorkingState
ws of
        Maybe (Quadruple, WorkingState)
Nothing ->
            if WorkingState
wsWorkingState -> Getting State WorkingState State -> State
forall s a. s -> Getting a s a -> a
^.Getting State WorkingState State
Lens' WorkingState State
currentState State -> State -> Bool
forall a. Eq a => a -> a -> Bool
== State
finalState
            then [WorkingState] -> m [WorkingState]
forall (m :: * -> *) a. Monad m => a -> m a
return [WorkingState
ws]
            else String -> m [WorkingState]
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"Can't find step from non-final state"
        Just (((State
qf, Symbol
s), (MoveOr Symbol
sm, State
qt)), WorkingState
ws') ->
            if State
qf State -> State -> Bool
forall a. Eq a => a -> a -> Bool
== State
qt Bool -> Bool -> Bool
&& Symbol -> MoveOr Symbol
forall s. s -> MoveOr s
S Symbol
s MoveOr Symbol -> MoveOr Symbol -> Bool
forall a. Eq a => a -> a -> Bool
== MoveOr Symbol
sm
            then [WorkingState] -> m [WorkingState]
forall (m :: * -> *) a. Monad m => a -> m a
return [WorkingState
ws, WorkingState
ws']
            else do
                [WorkingState]
wss <- TuringMachine -> WorkingState -> m [WorkingState]
forall (m :: * -> *).
MonadFail m =>
TuringMachine -> WorkingState -> m [WorkingState]
superSmartRun TuringMachine
tm WorkingState
ws'
                [WorkingState] -> m [WorkingState]
forall (m :: * -> *) a. Monad m => a -> m a
return (WorkingState
ws WorkingState -> [WorkingState] -> [WorkingState]
forall a. a -> [a] -> [a]
: [WorkingState]
wss)