{-# LANGUAGE MultiWayIf, TupleSections, ScopedTypeVariables #-}
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
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
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]