{-# LANGUAGE MultiWayIf, TupleSections, ScopedTypeVariables #-}

-- |Module `TuringMachine.Constructors` include a lot of constructors of Turing
-- machine.
module TuringMachine.Constructors (
    makeStandartTM,
    crash,
    check,
    die,
    move,
    moveInf,
    rewrite,
    rewriteAndMove,
    (+^>),
    (>+^),
    (-^),
    (++>),
    (||>),
    (@@>),
    loop,
    forSs,
    module TuringMachine,
  ) where

import TuringMachine

import Containers.Map (intersectionWith)
import Containers.PrismMap (toMap)

import Control.Monad (forM_, (>=>))
import Data.Maybe (mapMaybe)
import qualified Control.Monad.State as ST

infixl 8 +^>, >+^
infix  7 @@>
infixl 6 ++>
infixl 5 ||>

type LocalState = ST.State (TuringMachine, TuringMachine)

type LocalQuadruple = (State, ShowedSymbol, ShowedSymbolOrMove, State)

makeStandartTM :: [LocalQuadruple] -> TuringMachine
makeStandartTM :: [LocalQuadruple] -> TuringMachine
makeStandartTM [LocalQuadruple]
lqs =
    let cs :: Set ShowedSymbol
cs = [ShowedSymbol] -> Set ShowedSymbol
forall c v. UnsafeListable c v => [v] -> c
fromList ((LocalQuadruple -> [ShowedSymbol])
-> [LocalQuadruple] -> [ShowedSymbol]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap LocalQuadruple -> [ShowedSymbol]
getSs [LocalQuadruple]
lqs) Set ShowedSymbol -> ShowedSymbol -> Set ShowedSymbol
forall c v. Deletable c v => c -> v -> c
<\ ShowedSymbol
blank :: Set ShowedSymbol
        ls :: PrismMap String State
ls = [(String, State)] -> PrismMap String State
forall c v. UnsafeListable c v => [v] -> c
fromList [] :: PrismMap String State
        a :: Alphabet
a  = [(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]
: Set ShowedSymbol -> [ShowedSymbol]
forall c v. Listable c v => c -> [v]
toList Set ShowedSymbol
cs) [Symbol
forall a. Bounded a => a
minBound..]
    in  Quadruples -> PrismMap String State -> 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
$ (LocalQuadruple -> Maybe Quadruple)
-> [LocalQuadruple] -> [Quadruple]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe (Alphabet -> LocalQuadruple -> Maybe Quadruple
toQ Alphabet
a) [LocalQuadruple]
lqs) PrismMap String State
ls Alphabet
a
      where
        getSs :: LocalQuadruple -> [ShowedSymbol]
        getSs :: LocalQuadruple -> [ShowedSymbol]
getSs (State
_, ShowedSymbol
s, M Move
_, State
_) = [ShowedSymbol
s]
        getSs (State
_, ShowedSymbol
s, S ShowedSymbol
s', State
_) = [ShowedSymbol
s, ShowedSymbol
s']
        toQ :: Alphabet -> LocalQuadruple -> Maybe TuringMachine.Quadruple
        toQ :: Alphabet -> LocalQuadruple -> Maybe Quadruple
toQ Alphabet
a (State
q1, ShowedSymbol
s, M Move
m, State
q2) = do
            Symbol
s_ <- Alphabet
a Alphabet -> ShowedSymbol -> Maybe Symbol
forall c k v (m :: * -> *).
(Indexable c k v, MonadFail m) =>
c -> k -> m v
!? ShowedSymbol
s
            Quadruple -> Maybe Quadruple
forall (m :: * -> *) a. Monad m => a -> m a
return ((State
q1, Symbol
s_), (Move -> MoveOr Symbol
forall s. Move -> MoveOr s
M Move
m, State
q2))
        toQ Alphabet
a (State
q1, ShowedSymbol
s, S ShowedSymbol
s', State
q2) = do
            Symbol
s_  <- Alphabet
a Alphabet -> ShowedSymbol -> Maybe Symbol
forall c k v (m :: * -> *).
(Indexable c k v, MonadFail m) =>
c -> k -> m v
!? ShowedSymbol
s
            Symbol
s'_ <- Alphabet
a Alphabet -> ShowedSymbol -> Maybe Symbol
forall c k v (m :: * -> *).
(Indexable c k v, MonadFail m) =>
c -> k -> m v
!? ShowedSymbol
s'
            Quadruple -> Maybe Quadruple
forall (m :: * -> *) a. Monad m => a -> m a
return ((State
q1, Symbol
s_), (Symbol -> MoveOr Symbol
forall s. s -> MoveOr s
S Symbol
s'_, State
q2))

forSs ::
    ShowedSymbolClass s =>
    (ShowedSymbol -> TuringMachine) ->
    [s] ->
    TuringMachine
forSs :: (ShowedSymbol -> TuringMachine) -> [s] -> TuringMachine
forSs ShowedSymbol -> TuringMachine
sstm = (TuringMachine -> TuringMachine -> TuringMachine)
-> TuringMachine -> [TuringMachine] -> TuringMachine
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr TuringMachine -> TuringMachine -> TuringMachine
(||>) TuringMachine
crash ([TuringMachine] -> TuringMachine)
-> ([s] -> [TuringMachine]) -> [s] -> TuringMachine
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (ShowedSymbol -> TuringMachine)
-> [ShowedSymbol] -> [TuringMachine]
forall a b. (a -> b) -> [a] -> [b]
map ShowedSymbol -> TuringMachine
sstm ([ShowedSymbol] -> [TuringMachine])
-> ([s] -> [ShowedSymbol]) -> [s] -> [TuringMachine]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [s] -> [ShowedSymbol]
forall s. ShowedSymbolClass s => [s] -> [ShowedSymbol]
showedSymbols

crash :: TuringMachine
crash :: TuringMachine
crash = [LocalQuadruple] -> TuringMachine
makeStandartTM []

check :: ShowedSymbolClass s => [s] -> TuringMachine
check :: [s] -> TuringMachine
check = (ShowedSymbol -> TuringMachine) -> [s] -> TuringMachine
forall s.
ShowedSymbolClass s =>
(ShowedSymbol -> TuringMachine) -> [s] -> TuringMachine
forSs ((ShowedSymbol -> TuringMachine) -> [s] -> TuringMachine)
-> (ShowedSymbol -> TuringMachine) -> [s] -> TuringMachine
forall a b. (a -> b) -> a -> b
$ \ShowedSymbol
s -> [LocalQuadruple] -> TuringMachine
makeStandartTM [(State
startState, ShowedSymbol
s, ShowedSymbol -> MoveOr ShowedSymbol
forall s. s -> MoveOr s
S ShowedSymbol
s, State
finalState)]

die :: ShowedSymbolClass s => [s] -> TuringMachine
die :: [s] -> TuringMachine
die = (ShowedSymbol -> TuringMachine) -> [s] -> TuringMachine
forall s.
ShowedSymbolClass s =>
(ShowedSymbol -> TuringMachine) -> [s] -> TuringMachine
forSs ((ShowedSymbol -> TuringMachine) -> [s] -> TuringMachine)
-> (ShowedSymbol -> TuringMachine) -> [s] -> TuringMachine
forall a b. (a -> b) -> a -> b
$ \ShowedSymbol
s -> [LocalQuadruple] -> TuringMachine
makeStandartTM [(State
startState, ShowedSymbol
s, ShowedSymbol -> MoveOr ShowedSymbol
forall s. s -> MoveOr s
S ShowedSymbol
s, State
startState)]

move :: ShowedSymbolClass s => Move -> [s] -> TuringMachine
move :: Move -> [s] -> TuringMachine
move Move
m = (ShowedSymbol -> TuringMachine) -> [s] -> TuringMachine
forall s.
ShowedSymbolClass s =>
(ShowedSymbol -> TuringMachine) -> [s] -> TuringMachine
forSs ((ShowedSymbol -> TuringMachine) -> [s] -> TuringMachine)
-> (ShowedSymbol -> TuringMachine) -> [s] -> TuringMachine
forall a b. (a -> b) -> a -> b
$ \ShowedSymbol
s -> [LocalQuadruple] -> TuringMachine
makeStandartTM [(State
startState, ShowedSymbol
s, Move -> MoveOr ShowedSymbol
forall s. Move -> MoveOr s
M Move
m, State
finalState)]

moveInf :: ShowedSymbolClass s => Move -> [s] -> TuringMachine
moveInf :: Move -> [s] -> TuringMachine
moveInf Move
m = (ShowedSymbol -> TuringMachine) -> [s] -> TuringMachine
forall s.
ShowedSymbolClass s =>
(ShowedSymbol -> TuringMachine) -> [s] -> TuringMachine
forSs ((ShowedSymbol -> TuringMachine) -> [s] -> TuringMachine)
-> (ShowedSymbol -> TuringMachine) -> [s] -> TuringMachine
forall a b. (a -> b) -> a -> b
$ \ShowedSymbol
s -> [LocalQuadruple] -> TuringMachine
makeStandartTM [(State
startState, ShowedSymbol
s, Move -> MoveOr ShowedSymbol
forall s. Move -> MoveOr s
M Move
m, State
startState)]

rewrite :: ShowedSymbolClass s => [s] -> ShowedSymbol -> TuringMachine
rewrite :: [s] -> ShowedSymbol -> TuringMachine
rewrite [s]
ss ShowedSymbol
s' =
    (ShowedSymbol -> TuringMachine) -> [s] -> TuringMachine
forall s.
ShowedSymbolClass s =>
(ShowedSymbol -> TuringMachine) -> [s] -> TuringMachine
forSs (\ShowedSymbol
s -> [LocalQuadruple] -> TuringMachine
makeStandartTM [(State
startState, ShowedSymbol
s, ShowedSymbol -> MoveOr ShowedSymbol
forall s. s -> MoveOr s
S ShowedSymbol
s', State
finalState)]) [s]
ss

(+^>) :: String -> TuringMachine -> TuringMachine
String
lbl +^> :: String -> TuringMachine -> TuringMachine
+^> TuringMachine
tm = TuringMachine
tm TuringMachine -> (TuringMachine -> TuringMachine) -> TuringMachine
forall a b. a -> (a -> b) -> b
& (PrismMap String State -> Identity (PrismMap String State))
-> TuringMachine -> Identity TuringMachine
Lens' TuringMachine (PrismMap String State)
labeledStates ((PrismMap String State -> Identity (PrismMap String State))
 -> TuringMachine -> Identity TuringMachine)
-> (String, State) -> TuringMachine -> TuringMachine
forall c v s t. Insertable c v => ASetter s t c c -> v -> s -> t
<+~ (String
lbl, State
startState)

(>+^) :: TuringMachine -> String -> TuringMachine
TuringMachine
tm >+^ :: TuringMachine -> String -> TuringMachine
>+^ String
lbl = TuringMachine
tm TuringMachine -> (TuringMachine -> TuringMachine) -> TuringMachine
forall a b. a -> (a -> b) -> b
& (PrismMap String State -> Identity (PrismMap String State))
-> TuringMachine -> Identity TuringMachine
Lens' TuringMachine (PrismMap String State)
labeledStates ((PrismMap String State -> Identity (PrismMap String State))
 -> TuringMachine -> Identity TuringMachine)
-> (String, State) -> TuringMachine -> TuringMachine
forall c v s t. Insertable c v => ASetter s t c c -> v -> s -> t
<+~ (String
lbl, State
finalState)

(-^) :: TuringMachine -> String -> TuringMachine
TuringMachine
tm -^ :: TuringMachine -> String -> TuringMachine
-^ String
lbl = TuringMachine
tm TuringMachine -> (TuringMachine -> TuringMachine) -> TuringMachine
forall a b. a -> (a -> b) -> b
& (PrismMap String State -> Identity (PrismMap String State))
-> TuringMachine -> Identity TuringMachine
Lens' TuringMachine (PrismMap String State)
labeledStates ((PrismMap String State -> Identity (PrismMap String State))
 -> TuringMachine -> Identity TuringMachine)
-> (PrismMap String State -> PrismMap String State)
-> TuringMachine
-> TuringMachine
forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
%~ (PrismMap String State -> String -> PrismMap String State
forall c v. Deletable c v => c -> v -> c
<\ String
lbl)

makeTMop ::
    LocalState () ->
    TuringMachine ->
    TuringMachine ->
    TuringMachine
makeTMop :: LocalState () -> TuringMachine -> TuringMachine -> TuringMachine
makeTMop LocalState ()
mainAction = ((TuringMachine, TuringMachine) -> TuringMachine)
-> TuringMachine -> TuringMachine -> TuringMachine
forall a b c. ((a, b) -> c) -> a -> b -> c
curry (((TuringMachine, TuringMachine) -> TuringMachine)
 -> TuringMachine -> TuringMachine -> TuringMachine)
-> ((TuringMachine, TuringMachine) -> TuringMachine)
-> TuringMachine
-> TuringMachine
-> TuringMachine
forall a b. (a -> b) -> a -> b
$ State (TuringMachine, TuringMachine) TuringMachine
-> (TuringMachine, TuringMachine) -> TuringMachine
forall s a. State s a -> s -> a
ST.evalState (State (TuringMachine, TuringMachine) TuringMachine
 -> (TuringMachine, TuringMachine) -> TuringMachine)
-> State (TuringMachine, TuringMachine) TuringMachine
-> (TuringMachine, TuringMachine)
-> TuringMachine
forall a b. (a -> b) -> a -> b
$ do
    LocalState ()
mainAction
    PrismMap String State
newLS <- StateT
  (TuringMachine, TuringMachine) Identity (PrismMap String State)
updateLabeledStates
    Alphabet
newA  <- StateT (TuringMachine, TuringMachine) Identity Alphabet
updateAlphabet
    PrismMap String State
-> Alphabet -> State (TuringMachine, TuringMachine) TuringMachine
unionTMs PrismMap String State
newLS Alphabet
newA
      where
        updateLabeledStates :: StateT
  (TuringMachine, TuringMachine) Identity (PrismMap String State)
updateLabeledStates = do
            (PrismMap String State
ls1, PrismMap String State
ls2) <- ((TuringMachine, TuringMachine)
 -> (PrismMap String State, PrismMap String State))
-> StateT
     (TuringMachine, TuringMachine)
     Identity
     (PrismMap String State, PrismMap String State)
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
ST.gets (((TuringMachine, TuringMachine)
  -> (PrismMap String State, PrismMap String State))
 -> StateT
      (TuringMachine, TuringMachine)
      Identity
      (PrismMap String State, PrismMap String State))
-> ((TuringMachine, TuringMachine)
    -> (PrismMap String State, PrismMap String State))
-> StateT
     (TuringMachine, TuringMachine)
     Identity
     (PrismMap String State, PrismMap String State)
forall a b. (a -> b) -> a -> b
$ (TuringMachine -> Identity (PrismMap String State))
-> (TuringMachine, TuringMachine)
-> Identity (PrismMap String State, PrismMap String State)
forall (r :: * -> * -> *) a b.
Bitraversable r =>
Traversal (r a a) (r b b) a b
both ((TuringMachine -> Identity (PrismMap String State))
 -> (TuringMachine, TuringMachine)
 -> Identity (PrismMap String State, PrismMap String State))
-> (TuringMachine -> PrismMap String State)
-> (TuringMachine, TuringMachine)
-> (PrismMap String State, PrismMap String State)
forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
%~ Getting
  (PrismMap String State) TuringMachine (PrismMap String State)
-> TuringMachine -> PrismMap String State
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Getting
  (PrismMap String State) TuringMachine (PrismMap String State)
Lens' TuringMachine (PrismMap String State)
labeledStates
            let sharedLabels :: [(String, (State, State))]
sharedLabels = Map String (State, State) -> [(String, (State, State))]
forall c v. Listable c v => c -> [v]
toList (Map String (State, State) -> [(String, (State, State))])
-> Map String (State, State) -> [(String, (State, State))]
forall a b. (a -> b) -> a -> b
$
                    (State -> State -> (State, State))
-> Map String State
-> Map String State
-> Map String (State, State)
forall k a b c.
Ord k =>
(a -> b -> c) -> Map k a -> Map k b -> Map k c
intersectionWith (,) (PrismMap String State -> Map String State
forall k a. PrismMap k a -> Map k a
toMap PrismMap String State
ls1) (PrismMap String State -> Map String State
forall k a. PrismMap k a -> Map k a
toMap PrismMap String State
ls2)
            [(String, (State, State))]
-> ((String, (State, State)) -> LocalState ()) -> LocalState ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [(String, (State, State))]
sharedLabels (((String, (State, State)) -> LocalState ()) -> LocalState ())
-> ((String, (State, State)) -> LocalState ()) -> LocalState ()
forall a b. (a -> b) -> a -> b
$ \(String
_, (State
s1, State
s2)) ->
                (TuringMachine -> Identity TuringMachine)
-> (TuringMachine, TuringMachine)
-> Identity (TuringMachine, TuringMachine)
forall s t a b. Field2 s t a b => Lens s t a b
_2((TuringMachine -> Identity TuringMachine)
 -> (TuringMachine, TuringMachine)
 -> Identity (TuringMachine, TuringMachine))
-> ((State -> Identity (Maybe State))
    -> TuringMachine -> Identity TuringMachine)
-> (State -> Identity (Maybe State))
-> (TuringMachine, TuringMachine)
-> Identity (TuringMachine, TuringMachine)
forall b c a. (b -> c) -> (a -> b) -> a -> c
.(State -> Identity (Maybe State))
-> TuringMachine -> Identity TuringMachine
TMSetter State (Maybe State)
states ((State -> Identity (Maybe State))
 -> (TuringMachine, TuringMachine)
 -> Identity (TuringMachine, TuringMachine))
-> (State -> Maybe State) -> LocalState ()
forall s (m :: * -> *) a b.
MonadState s m =>
ASetter s s a b -> (a -> b) -> m ()
%= \State
s -> State -> Maybe State
forall a. a -> Maybe a
Just (State -> Maybe State) -> State -> Maybe State
forall a b. (a -> b) -> a -> b
$
                    if State
s State -> State -> Bool
forall a. Eq a => a -> a -> Bool
== State
s2
                    then State
s1
                    else State
s
            let ls1' :: [(String, State)]
ls1' = PrismMap String State -> [(String, State)]
forall c v. Listable c v => c -> [v]
toList PrismMap String State
ls1
                ls2' :: [(String, State)]
ls2' = 
                    (State -> Maybe (String, State)) -> [State] -> [(String, State)]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe
                        (\State
lbl -> (,State
lbl) (String -> (String, State))
-> Maybe String -> Maybe (String, State)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (PrismMap String State
ls2 PrismMap String State -> State -> Maybe String
forall c k v (m :: * -> *).
(Indexable c k v, MonadFail m) =>
c -> k -> m v
!? State
lbl))
                        (Set State -> [State]
forall c v. Listable c v => c -> [v]
toList (Set State -> [State]) -> Set State -> [State]
forall a b. (a -> b) -> a -> b
$ PrismMap String State -> Set State
forall c v. (Valuable c v, Ord v) => c -> Set v
valuesSet PrismMap String State
ls2 Set State -> Set State -> Set State
forall c. Operable c => c -> c -> c
\\ PrismMap String State -> Set State
forall c v. (Valuable c v, Ord v) => c -> Set v
valuesSet PrismMap String State
ls1)
            PrismMap String State
-> StateT
     (TuringMachine, TuringMachine) Identity (PrismMap String State)
forall (m :: * -> *) a. Monad m => a -> m a
return (PrismMap String State
 -> StateT
      (TuringMachine, TuringMachine) Identity (PrismMap String State))
-> PrismMap String State
-> StateT
     (TuringMachine, TuringMachine) Identity (PrismMap String State)
forall a b. (a -> b) -> a -> b
$ [(String, State)] -> PrismMap String State
forall c v. UnsafeListable c v => [v] -> c
fromList ([(String, State)] -> PrismMap String State)
-> [(String, State)] -> PrismMap String State
forall a b. (a -> b) -> a -> b
$ [(String, State)]
ls1' [(String, State)] -> [(String, State)] -> [(String, State)]
forall a. [a] -> [a] -> [a]
++ [(String, State)]
ls2'
        updateAlphabet :: StateT (TuringMachine, TuringMachine) Identity Alphabet
updateAlphabet = do
            (Alphabet
a1, Alphabet
a2) <- ((TuringMachine, TuringMachine) -> (Alphabet, Alphabet))
-> StateT
     (TuringMachine, TuringMachine) Identity (Alphabet, Alphabet)
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
ST.gets (((TuringMachine, TuringMachine) -> (Alphabet, Alphabet))
 -> StateT
      (TuringMachine, TuringMachine) Identity (Alphabet, Alphabet))
-> ((TuringMachine, TuringMachine) -> (Alphabet, Alphabet))
-> StateT
     (TuringMachine, TuringMachine) Identity (Alphabet, Alphabet)
forall a b. (a -> b) -> a -> b
$ (TuringMachine -> Identity Alphabet)
-> (TuringMachine, TuringMachine) -> Identity (Alphabet, Alphabet)
forall (r :: * -> * -> *) a b.
Bitraversable r =>
Traversal (r a a) (r b b) a b
both ((TuringMachine -> Identity Alphabet)
 -> (TuringMachine, TuringMachine) -> Identity (Alphabet, Alphabet))
-> (TuringMachine -> Alphabet)
-> (TuringMachine, TuringMachine)
-> (Alphabet, Alphabet)
forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
%~ Getting Alphabet TuringMachine Alphabet
-> TuringMachine -> Alphabet
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Getting Alphabet TuringMachine Alphabet
Lens' TuringMachine Alphabet
alphabet
            let [ShowedSymbol]
allChars :: [ShowedSymbol] = Set ShowedSymbol -> [ShowedSymbol]
forall c v. Listable c v => c -> [v]
toList (Set ShowedSymbol -> [ShowedSymbol])
-> Set ShowedSymbol -> [ShowedSymbol]
forall a b. (a -> b) -> a -> b
$ Alphabet -> Set ShowedSymbol
forall c v. (Valuable c v, Ord v) => c -> Set v
valuesSet Alphabet
a1 Set ShowedSymbol -> Set ShowedSymbol -> Set ShowedSymbol
forall c. Operable c => c -> c -> c
\/ Alphabet -> Set ShowedSymbol
forall c v. (Valuable c v, Ord v) => c -> Set v
valuesSet Alphabet
a2
                newA :: Alphabet
newA = [(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]
allChars [Symbol
forall a. Bounded a => a
minBound..]
            [((TuringMachine -> Identity TuringMachine)
  -> (TuringMachine, TuringMachine)
  -> Identity (TuringMachine, TuringMachine),
  Alphabet)]
-> (((TuringMachine -> Identity TuringMachine)
     -> (TuringMachine, TuringMachine)
     -> Identity (TuringMachine, TuringMachine),
     Alphabet)
    -> LocalState ())
-> LocalState ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [((TuringMachine -> Identity TuringMachine)
-> (TuringMachine, TuringMachine)
-> Identity (TuringMachine, TuringMachine)
forall s t a b. Field1 s t a b => Lens s t a b
_1, Alphabet
a1), ((TuringMachine -> Identity TuringMachine)
-> (TuringMachine, TuringMachine)
-> Identity (TuringMachine, TuringMachine)
forall s t a b. Field2 s t a b => Lens s t a b
_2, Alphabet
a2)] ((((TuringMachine -> Identity TuringMachine)
   -> (TuringMachine, TuringMachine)
   -> Identity (TuringMachine, TuringMachine),
   Alphabet)
  -> LocalState ())
 -> LocalState ())
-> (((TuringMachine -> Identity TuringMachine)
     -> (TuringMachine, TuringMachine)
     -> Identity (TuringMachine, TuringMachine),
     Alphabet)
    -> LocalState ())
-> LocalState ()
forall a b. (a -> b) -> a -> b
$ \((TuringMachine -> Identity TuringMachine)
-> (TuringMachine, TuringMachine)
-> Identity (TuringMachine, TuringMachine)
tm, Alphabet
a) ->
                (TuringMachine -> Identity TuringMachine)
-> (TuringMachine, TuringMachine)
-> Identity (TuringMachine, TuringMachine)
tm((TuringMachine -> Identity TuringMachine)
 -> (TuringMachine, TuringMachine)
 -> Identity (TuringMachine, TuringMachine))
-> ((Symbol -> Identity (Maybe Symbol))
    -> TuringMachine -> Identity TuringMachine)
-> (Symbol -> Identity (Maybe Symbol))
-> (TuringMachine, TuringMachine)
-> Identity (TuringMachine, TuringMachine)
forall b c a. (b -> c) -> (a -> b) -> a -> c
.(Symbol -> Identity (Maybe Symbol))
-> TuringMachine -> Identity TuringMachine
TMSetter Symbol (Maybe Symbol)
symbols ((Symbol -> Identity (Maybe Symbol))
 -> (TuringMachine, TuringMachine)
 -> Identity (TuringMachine, TuringMachine))
-> (Symbol -> Maybe Symbol) -> LocalState ()
forall s (m :: * -> *) a b.
MonadState s m =>
ASetter s s a b -> (a -> b) -> m ()
%= ((Alphabet
a Alphabet -> Symbol -> Maybe ShowedSymbol
forall c k v (m :: * -> *).
(Indexable c k v, MonadFail m) =>
c -> k -> m v
!?) (Symbol -> Maybe ShowedSymbol)
-> (ShowedSymbol -> Maybe Symbol) -> Symbol -> Maybe Symbol
forall (m :: * -> *) a b c.
Monad m =>
(a -> m b) -> (b -> m c) -> a -> m c
>=> (Alphabet
newA Alphabet -> ShowedSymbol -> Maybe Symbol
forall c k v (m :: * -> *).
(Indexable c k v, MonadFail m) =>
c -> k -> m v
!?))
            Alphabet -> StateT (TuringMachine, TuringMachine) Identity Alphabet
forall (m :: * -> *) a. Monad m => a -> m a
return Alphabet
newA
        --here you must use either FlexibleContexts extension or type definition
        unionTMs :: LabeledStates -> Alphabet -> LocalState TuringMachine
        unionTMs :: PrismMap String State
-> Alphabet -> State (TuringMachine, TuringMachine) TuringMachine
unionTMs PrismMap String State
newLS Alphabet
newA = do
            (Quadruples
qs1, Quadruples
qs2) <- ((TuringMachine, TuringMachine) -> (Quadruples, Quadruples))
-> StateT
     (TuringMachine, TuringMachine) Identity (Quadruples, Quadruples)
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
ST.gets (((TuringMachine, TuringMachine) -> (Quadruples, Quadruples))
 -> StateT
      (TuringMachine, TuringMachine) Identity (Quadruples, Quadruples))
-> ((TuringMachine, TuringMachine) -> (Quadruples, Quadruples))
-> StateT
     (TuringMachine, TuringMachine) Identity (Quadruples, Quadruples)
forall a b. (a -> b) -> a -> b
$ (TuringMachine -> Identity Quadruples)
-> (TuringMachine, TuringMachine)
-> Identity (Quadruples, Quadruples)
forall (r :: * -> * -> *) a b.
Bitraversable r =>
Traversal (r a a) (r b b) a b
both ((TuringMachine -> Identity Quadruples)
 -> (TuringMachine, TuringMachine)
 -> Identity (Quadruples, Quadruples))
-> (TuringMachine -> Quadruples)
-> (TuringMachine, TuringMachine)
-> (Quadruples, Quadruples)
forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
%~ Getting Quadruples TuringMachine Quadruples
-> TuringMachine -> Quadruples
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Getting Quadruples TuringMachine Quadruples
Lens' TuringMachine Quadruples
quadruples
            let newQs :: Quadruples
newQs = Quadruples
qs1 Quadruples -> Quadruples -> Quadruples
forall c. Operable c => c -> c -> c
\/ Quadruples
qs2
            TuringMachine -> State (TuringMachine, TuringMachine) TuringMachine
forall (m :: * -> *) a. Monad m => a -> m a
return (TuringMachine
 -> State (TuringMachine, TuringMachine) TuringMachine)
-> TuringMachine
-> State (TuringMachine, TuringMachine) TuringMachine
forall a b. (a -> b) -> a -> b
$ Quadruples -> PrismMap String State -> Alphabet -> TuringMachine
turingMachine Quadruples
newQs PrismMap String State
newLS Alphabet
newA

(++>) :: TuringMachine -> TuringMachine -> TuringMachine
++> :: TuringMachine -> TuringMachine -> TuringMachine
(++>) = LocalState () -> TuringMachine -> TuringMachine -> TuringMachine
makeTMop (LocalState () -> TuringMachine -> TuringMachine -> TuringMachine)
-> LocalState () -> TuringMachine -> TuringMachine -> TuringMachine
forall a b. (a -> b) -> a -> b
$ do
    State
newStartState2 <- LensLike' (Const State) (TuringMachine, TuringMachine) Int
-> (Int -> State)
-> StateT (TuringMachine, TuringMachine) Identity State
forall s (m :: * -> *) r a.
MonadState s m =>
LensLike' (Const r) s a -> (a -> r) -> m r
uses ((TuringMachine -> Const State TuringMachine)
-> (TuringMachine, TuringMachine)
-> Const State (TuringMachine, TuringMachine)
forall s t a b. Field1 s t a b => Lens s t a b
_1((TuringMachine -> Const State TuringMachine)
 -> (TuringMachine, TuringMachine)
 -> Const State (TuringMachine, TuringMachine))
-> ((Int -> Const State Int)
    -> TuringMachine -> Const State TuringMachine)
-> LensLike' (Const State) (TuringMachine, TuringMachine) Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
.(Int -> Const State Int)
-> TuringMachine -> Const State TuringMachine
TMGetter Int
maxNumState) (Int -> State
state (Int -> State) -> (Int -> Int) -> Int -> State
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Int -> Int -> Int
forall a. Num a => a -> a -> a
+Int
1))
    (TuringMachine -> Identity TuringMachine)
-> (TuringMachine, TuringMachine)
-> Identity (TuringMachine, TuringMachine)
forall s t a b. Field1 s t a b => Lens s t a b
_1((TuringMachine -> Identity TuringMachine)
 -> (TuringMachine, TuringMachine)
 -> Identity (TuringMachine, TuringMachine))
-> ((State -> Identity (Maybe State))
    -> TuringMachine -> Identity TuringMachine)
-> (State -> Identity (Maybe State))
-> (TuringMachine, TuringMachine)
-> Identity (TuringMachine, TuringMachine)
forall b c a. (b -> c) -> (a -> b) -> a -> c
.(State -> Identity (Maybe State))
-> TuringMachine -> Identity TuringMachine
TMSetter State (Maybe State)
states ((State -> Identity (Maybe State))
 -> (TuringMachine, TuringMachine)
 -> Identity (TuringMachine, TuringMachine))
-> (State -> Maybe State) -> LocalState ()
forall s (m :: * -> *) a b.
MonadState s m =>
ASetter s s a b -> (a -> b) -> m ()
%= \State
s -> State -> Maybe State
forall a. a -> Maybe a
Just (State -> Maybe State) -> State -> Maybe State
forall a b. (a -> b) -> a -> b
$
        if State
s State -> State -> Bool
forall a. Eq a => a -> a -> Bool
== State
finalState
        then State
newStartState2
        else State
s
    (TuringMachine -> Identity TuringMachine)
-> (TuringMachine, TuringMachine)
-> Identity (TuringMachine, TuringMachine)
forall s t a b. Field2 s t a b => Lens s t a b
_2((TuringMachine -> Identity TuringMachine)
 -> (TuringMachine, TuringMachine)
 -> Identity (TuringMachine, TuringMachine))
-> ((State -> Identity (Maybe State))
    -> TuringMachine -> Identity TuringMachine)
-> (State -> Identity (Maybe State))
-> (TuringMachine, TuringMachine)
-> Identity (TuringMachine, TuringMachine)
forall b c a. (b -> c) -> (a -> b) -> a -> c
.(State -> Identity (Maybe State))
-> TuringMachine -> Identity TuringMachine
TMSetter State (Maybe State)
states ((State -> Identity (Maybe State))
 -> (TuringMachine, TuringMachine)
 -> Identity (TuringMachine, TuringMachine))
-> (State -> Maybe State) -> LocalState ()
forall s (m :: * -> *) a b.
MonadState s m =>
ASetter s s a b -> (a -> b) -> m ()
%= \State
s -> State -> Maybe State
forall a. a -> Maybe a
Just (State -> Maybe State) -> State -> Maybe State
forall a b. (a -> b) -> a -> b
$
        if State
s State -> State -> Bool
forall a. Eq a => a -> a -> Bool
== State
finalState
        then State
finalState
        else State
s State -> State -> State
forall a. Num a => a -> a -> a
+ State
newStartState2 State -> State -> State
forall a. Num a => a -> a -> a
- State
startState

(||>) :: TuringMachine -> TuringMachine -> TuringMachine
||> :: TuringMachine -> TuringMachine -> TuringMachine
(||>) = LocalState () -> TuringMachine -> TuringMachine -> TuringMachine
makeTMop (LocalState () -> TuringMachine -> TuringMachine -> TuringMachine)
-> LocalState () -> TuringMachine -> TuringMachine -> TuringMachine
forall a b. (a -> b) -> a -> b
$ do
    State
maxState1 <- LensLike' (Const State) (TuringMachine, TuringMachine) Int
-> (Int -> State)
-> StateT (TuringMachine, TuringMachine) Identity State
forall s (m :: * -> *) r a.
MonadState s m =>
LensLike' (Const r) s a -> (a -> r) -> m r
uses ((TuringMachine -> Const State TuringMachine)
-> (TuringMachine, TuringMachine)
-> Const State (TuringMachine, TuringMachine)
forall s t a b. Field1 s t a b => Lens s t a b
_1((TuringMachine -> Const State TuringMachine)
 -> (TuringMachine, TuringMachine)
 -> Const State (TuringMachine, TuringMachine))
-> ((Int -> Const State Int)
    -> TuringMachine -> Const State TuringMachine)
-> LensLike' (Const State) (TuringMachine, TuringMachine) Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
.(Int -> Const State Int)
-> TuringMachine -> Const State TuringMachine
TMGetter Int
maxNumState) Int -> State
state
    (TuringMachine -> Identity TuringMachine)
-> (TuringMachine, TuringMachine)
-> Identity (TuringMachine, TuringMachine)
forall s t a b. Field2 s t a b => Lens s t a b
_2((TuringMachine -> Identity TuringMachine)
 -> (TuringMachine, TuringMachine)
 -> Identity (TuringMachine, TuringMachine))
-> ((State -> Identity (Maybe State))
    -> TuringMachine -> Identity TuringMachine)
-> (State -> Identity (Maybe State))
-> (TuringMachine, TuringMachine)
-> Identity (TuringMachine, TuringMachine)
forall b c a. (b -> c) -> (a -> b) -> a -> c
.(State -> Identity (Maybe State))
-> TuringMachine -> Identity TuringMachine
TMSetter State (Maybe State)
states ((State -> Identity (Maybe State))
 -> (TuringMachine, TuringMachine)
 -> Identity (TuringMachine, TuringMachine))
-> (State -> Maybe State) -> LocalState ()
forall s (m :: * -> *) a b.
MonadState s m =>
ASetter s s a b -> (a -> b) -> m ()
%= \State
s -> State -> Maybe State
forall a. a -> Maybe a
Just (State -> Maybe State) -> State -> Maybe State
forall a b. (a -> b) -> a -> b
$
        if  | State
s State -> State -> Bool
forall a. Eq a => a -> a -> Bool
== State
startState -> State
startState
            | State
s State -> State -> Bool
forall a. Eq a => a -> a -> Bool
== State
finalState -> State
finalState
            | Bool
otherwise -> State
s State -> State -> State
forall a. Num a => a -> a -> a
- State
startState State -> State -> State
forall a. Num a => a -> a -> a
+ State
maxState1

(@@>) :: TuringMachine -> TuringMachine -> TuringMachine
@@> :: TuringMachine -> TuringMachine -> TuringMachine
(@@>) = LocalState () -> TuringMachine -> TuringMachine -> TuringMachine
makeTMop (LocalState () -> TuringMachine -> TuringMachine -> TuringMachine)
-> LocalState () -> TuringMachine -> TuringMachine -> TuringMachine
forall a b. (a -> b) -> a -> b
$ do
    State
maxState1 <- LensLike' (Const State) (TuringMachine, TuringMachine) Int
-> (Int -> State)
-> StateT (TuringMachine, TuringMachine) Identity State
forall s (m :: * -> *) r a.
MonadState s m =>
LensLike' (Const r) s a -> (a -> r) -> m r
uses ((TuringMachine -> Const State TuringMachine)
-> (TuringMachine, TuringMachine)
-> Const State (TuringMachine, TuringMachine)
forall s t a b. Field1 s t a b => Lens s t a b
_1((TuringMachine -> Const State TuringMachine)
 -> (TuringMachine, TuringMachine)
 -> Const State (TuringMachine, TuringMachine))
-> ((Int -> Const State Int)
    -> TuringMachine -> Const State TuringMachine)
-> LensLike' (Const State) (TuringMachine, TuringMachine) Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
.(Int -> Const State Int)
-> TuringMachine -> Const State TuringMachine
TMGetter Int
maxNumState) Int -> State
state
    (TuringMachine -> Identity TuringMachine)
-> (TuringMachine, TuringMachine)
-> Identity (TuringMachine, TuringMachine)
forall s t a b. Field2 s t a b => Lens s t a b
_2((TuringMachine -> Identity TuringMachine)
 -> (TuringMachine, TuringMachine)
 -> Identity (TuringMachine, TuringMachine))
-> ((State -> Identity (Maybe State))
    -> TuringMachine -> Identity TuringMachine)
-> (State -> Identity (Maybe State))
-> (TuringMachine, TuringMachine)
-> Identity (TuringMachine, TuringMachine)
forall b c a. (b -> c) -> (a -> b) -> a -> c
.(State -> Identity (Maybe State))
-> TuringMachine -> Identity TuringMachine
TMSetter State (Maybe State)
states ((State -> Identity (Maybe State))
 -> (TuringMachine, TuringMachine)
 -> Identity (TuringMachine, TuringMachine))
-> (State -> Maybe State) -> LocalState ()
forall s (m :: * -> *) a b.
MonadState s m =>
ASetter s s a b -> (a -> b) -> m ()
%= \State
s -> State -> Maybe State
forall a. a -> Maybe a
Just (State -> Maybe State) -> State -> Maybe State
forall a b. (a -> b) -> a -> b
$
        if  | State
s State -> State -> Bool
forall a. Eq a => a -> a -> Bool
== State
startState -> State
finalState
            | State
s State -> State -> Bool
forall a. Eq a => a -> a -> Bool
== State
finalState -> State
startState
            | Bool
otherwise -> State
s State -> State -> State
forall a. Num a => a -> a -> a
- State
startState State -> State -> State
forall a. Num a => a -> a -> a
+ State
maxState1

loop :: TuringMachine -> TuringMachine
loop :: TuringMachine -> TuringMachine
loop =
    (State -> Identity (Maybe State))
-> TuringMachine -> Identity TuringMachine
TMSetter State (Maybe State)
states ((State -> Identity (Maybe State))
 -> TuringMachine -> Identity TuringMachine)
-> (State -> Maybe State) -> TuringMachine -> TuringMachine
forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
%~ \State
s -> State -> Maybe State
forall a. a -> Maybe a
Just (State -> Maybe State) -> State -> Maybe State
forall a b. (a -> b) -> a -> b
$
        if State
s State -> State -> Bool
forall a. Eq a => a -> a -> Bool
== State
finalState
        then State
startState
        else State
s

rewriteAndMove :: ShowedSymbolClass s => [s] -> ShowedSymbol -> Move -> TuringMachine
rewriteAndMove :: [s] -> ShowedSymbol -> Move -> TuringMachine
rewriteAndMove [s]
ss ShowedSymbol
s Move
m = [s] -> ShowedSymbol -> TuringMachine
forall s.
ShowedSymbolClass s =>
[s] -> ShowedSymbol -> TuringMachine
rewrite [s]
ss ShowedSymbol
s TuringMachine -> TuringMachine -> TuringMachine
++> Move -> [ShowedSymbol] -> TuringMachine
forall s. ShowedSymbolClass s => Move -> [s] -> TuringMachine
move Move
m [ShowedSymbol
s]