{-# LANGUAGE RankNTypes, FlexibleContexts #-}

module TuringMachine.Quadruple (
    QuadrupleFromPart,
    QuadrupleToPart,
    TuringMachine.Quadruple.Quadruple,
    Quadruples,
    StrQuadruple,
    StrPair,
    toStrQ,
    Predicate,
    (&.),
    (|.),
    fromState,
    toState,
    fromSymbol,
    toSymbol,
    withMove,
    withoutMove,
    takeOnly,
    takeFromPart,
    takeToPart,
    withoutLoops,
    copy,
    module TuringMachine.State,
    module TuringMachine.SymbolOrMove,
  ) where

import TuringMachine.State
import TuringMachine.SymbolOrMove

import Containers
import Lens

infixr 3 &.
infixr 2 |.

type QuadrupleFromPart = (State, Symbol)

type QuadrupleToPart = (SymbolOrMove, State)

type Quadruple = (QuadrupleFromPart, QuadrupleToPart)

type Quadruples = Map QuadrupleFromPart QuadrupleToPart

type StrQuadruple = Containers.Quadruple String

type StrPair = Pair String

toStrQ :: TuringMachine.Quadruple.Quadruple -> StrQuadruple
toStrQ :: Quadruple -> StrQuadruple
toStrQ ((State
q1, Symbol
s), (SymbolOrMove
ms, State
q2)) =
    (String, String, String, String) -> StrQuadruple
forall a. (a, a, a, a) -> Quadruple a
Quadruple (
        Int -> String
forall a. Show a => a -> String
show (Int -> String) -> Int -> String
forall a b. (a -> b) -> a -> b
$ State -> Int
numState State
q1,
        Int -> String
forall a. Show a => a -> String
show (Int -> String) -> Int -> String
forall a b. (a -> b) -> a -> b
$ Symbol -> Int
numSymbol Symbol
s,
        SymbolOrMove -> String
showSymbolOrMove SymbolOrMove
ms,
        Int -> String
forall a. Show a => a -> String
show (Int -> String) -> Int -> String
forall a b. (a -> b) -> a -> b
$ State -> Int
numState State
q2
      )
  where
    showSymbolOrMove :: SymbolOrMove -> String
showSymbolOrMove (M Move
m') = Move -> String
forall a. Show a => a -> String
show Move
m'
    showSymbolOrMove (S Symbol
s') = Int -> String
forall a. Show a => a -> String
show (Int -> String) -> Int -> String
forall a b. (a -> b) -> a -> b
$ Symbol -> Int
numSymbol Symbol
s'

type Predicate a = a -> Bool

type StrQuadruplePredicate = Predicate StrQuadruple

(&.) :: Predicate a -> Predicate a -> Predicate a
Predicate a
p1 &. :: Predicate a -> Predicate a -> Predicate a
&. Predicate a
p2 = \a
a -> Predicate a
p1 a
a Bool -> Bool -> Bool
&& Predicate a
p2 a
a

(|.) :: Predicate a -> Predicate a -> Predicate a
Predicate a
p1 |. :: Predicate a -> Predicate a -> Predicate a
|. Predicate a
p2 = \a
a -> Predicate a
p1 a
a Bool -> Bool -> Bool
|| Predicate a
p2 a
a

fromState :: State -> StrQuadruplePredicate
fromState :: State -> StrQuadruplePredicate
fromState State
s (Quadruple (String
s', String
_, String
_, String
_)) = Int -> String
forall a. Show a => a -> String
show (State -> Int
numState State
s) String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== String
s'

toState :: State -> StrQuadruplePredicate
toState :: State -> StrQuadruplePredicate
toState State
s (Quadruple (String
_, String
_, String
_, String
s')) = Int -> String
forall a. Show a => a -> String
show (State -> Int
numState State
s) String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== String
s'

fromSymbol :: Symbol -> StrQuadruplePredicate
fromSymbol :: Symbol -> StrQuadruplePredicate
fromSymbol Symbol
s (Quadruple (String
_, String
s', String
_, String
_)) = Int -> String
forall a. Show a => a -> String
show (Symbol -> Int
numSymbol Symbol
s) String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== String
s'

toSymbol :: Symbol -> StrQuadruplePredicate
toSymbol :: Symbol -> StrQuadruplePredicate
toSymbol Symbol
s (Quadruple (String
_, String
_, String
s', String
_)) = Int -> String
forall a. Show a => a -> String
show (Symbol -> Int
numSymbol Symbol
s) String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== String
s'

withMove :: Move -> StrQuadruplePredicate
withMove :: Move -> StrQuadruplePredicate
withMove Move
m (Quadruple (String
_, String
_, String
m', String
_)) = Move -> String
forall a. Show a => a -> String
show Move
m String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== String
m'

withoutMove :: StrQuadruplePredicate
withoutMove :: StrQuadruplePredicate
withoutMove (Quadruple (String
_, String
_, String
m', String
_)) = String
m' String -> [String] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`notElem` (Move -> String) -> [Move] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map Move -> String
forall a. Show a => a -> String
show [Move
toLeft,Move
toRight]

takeOnly :: Predicate a -> Getter (Set a) (Set a)
takeOnly :: Predicate a -> Getter (Set a) (Set a)
takeOnly Predicate a
p = (Set a -> Set a) -> Optic' (->) f (Set a) (Set a)
forall (p :: * -> * -> *) (f :: * -> *) s a.
(Profunctor p, Contravariant f) =>
(s -> a) -> Optic' p f s a
to ((Set a -> Set a) -> Optic' (->) f (Set a) (Set a))
-> (Set a -> Set a) -> Optic' (->) f (Set a) (Set a)
forall a b. (a -> b) -> a -> b
$ (Predicate a
p Predicate a -> Set a -> Set a
forall c v. Filterable c v => (v -> Bool) -> c -> c
<?>)

takeFromPart :: Getter (Set StrQuadruple) (Set StrPair)
takeFromPart :: (Set StrPair -> f (Set StrPair))
-> Set StrQuadruple -> f (Set StrQuadruple)
takeFromPart = (Set StrQuadruple -> Set StrPair)
-> (Set StrPair -> f (Set StrPair))
-> Set StrQuadruple
-> f (Set StrQuadruple)
forall (p :: * -> * -> *) (f :: * -> *) s a.
(Profunctor p, Contravariant f) =>
(s -> a) -> Optic' p f s a
to ((Set StrQuadruple -> Set StrPair)
 -> (Set StrPair -> f (Set StrPair))
 -> Set StrQuadruple
 -> f (Set StrQuadruple))
-> (Set StrQuadruple -> Set StrPair)
-> (Set StrPair -> f (Set StrPair))
-> Set StrQuadruple
-> f (Set StrQuadruple)
forall a b. (a -> b) -> a -> b
$ (StrQuadruple -> StrPair) -> Set StrQuadruple -> Set StrPair
forall c1 c2 v1 v2. Gunctor c1 c2 v1 v2 => (v1 -> v2) -> c1 -> c2
gmap ((StrQuadruple -> StrPair) -> Set StrQuadruple -> Set StrPair)
-> (StrQuadruple -> StrPair) -> Set StrQuadruple -> Set StrPair
forall a b. (a -> b) -> a -> b
$ \(Containers.Quadruple (String
qf, String
s, String
_, String
_)) -> (String, String) -> StrPair
forall a. (a, a) -> Pair a
Pair (String
qf,String
s)

takeToPart :: Getter (Set StrQuadruple) (Set StrPair)
takeToPart :: (Set StrPair -> f (Set StrPair))
-> Set StrQuadruple -> f (Set StrQuadruple)
takeToPart = (Set StrQuadruple -> Set StrPair)
-> (Set StrPair -> f (Set StrPair))
-> Set StrQuadruple
-> f (Set StrQuadruple)
forall (p :: * -> * -> *) (f :: * -> *) s a.
(Profunctor p, Contravariant f) =>
(s -> a) -> Optic' p f s a
to ((Set StrQuadruple -> Set StrPair)
 -> (Set StrPair -> f (Set StrPair))
 -> Set StrQuadruple
 -> f (Set StrQuadruple))
-> (Set StrQuadruple -> Set StrPair)
-> (Set StrPair -> f (Set StrPair))
-> Set StrQuadruple
-> f (Set StrQuadruple)
forall a b. (a -> b) -> a -> b
$ (StrQuadruple -> StrPair) -> Set StrQuadruple -> Set StrPair
forall c1 c2 v1 v2. Gunctor c1 c2 v1 v2 => (v1 -> v2) -> c1 -> c2
gmap ((StrQuadruple -> StrPair) -> Set StrQuadruple -> Set StrPair)
-> (StrQuadruple -> StrPair) -> Set StrQuadruple -> Set StrPair
forall a b. (a -> b) -> a -> b
$ \(Containers.Quadruple (String
_, String
_, String
sm, String
qt)) -> (String, String) -> StrPair
forall a. (a, a) -> Pair a
Pair (String
sm,String
qt)

withoutLoops :: Getter (Set StrQuadruple) (Set StrQuadruple)
withoutLoops :: (Set StrQuadruple -> f (Set StrQuadruple))
-> Set StrQuadruple -> f (Set StrQuadruple)
withoutLoops = (Set StrQuadruple -> Set StrQuadruple)
-> (Set StrQuadruple -> f (Set StrQuadruple))
-> Set StrQuadruple
-> f (Set StrQuadruple)
forall (p :: * -> * -> *) (f :: * -> *) s a.
(Profunctor p, Contravariant f) =>
(s -> a) -> Optic' p f s a
to ((Set StrQuadruple -> Set StrQuadruple)
 -> (Set StrQuadruple -> f (Set StrQuadruple))
 -> Set StrQuadruple
 -> f (Set StrQuadruple))
-> (Set StrQuadruple -> Set StrQuadruple)
-> (Set StrQuadruple -> f (Set StrQuadruple))
-> Set StrQuadruple
-> f (Set StrQuadruple)
forall a b. (a -> b) -> a -> b
$ StrQuadruplePredicate -> Set StrQuadruple -> Set StrQuadruple
forall c v. Filterable c v => (v -> Bool) -> c -> c
filterC StrQuadruplePredicate
isn'tLoop where
    isn'tLoop :: Predicate StrQuadruple
    isn'tLoop :: StrQuadruplePredicate
isn'tLoop (Containers.Quadruple (String
qf, String
s, String
sm, String
qt)) = String
qf String -> String -> Bool
forall a. Eq a => a -> a -> Bool
/= String
qt Bool -> Bool -> Bool
|| String
s String -> String -> Bool
forall a. Eq a => a -> a -> Bool
/= String
sm

copy ::
    (Listable c String, Indexable c Index String) =>
    Int -> Getter (Set c) (Set [String])
copy :: Int -> Getter (Set c) (Set [String])
copy Int
i = (Set c -> Set [String]) -> Optic' (->) f (Set c) (Set [String])
forall (p :: * -> * -> *) (f :: * -> *) s a.
(Profunctor p, Contravariant f) =>
(s -> a) -> Optic' p f s a
to ((Set c -> Set [String]) -> Optic' (->) f (Set c) (Set [String]))
-> (Set c -> Set [String]) -> Optic' (->) f (Set c) (Set [String])
forall a b. (a -> b) -> a -> b
$ (c -> [String]) -> Set c -> Set [String]
forall c1 c2 v1 v2. Gunctor c1 c2 v1 v2 => (v1 -> v2) -> c1 -> c2
gmap ((c -> [String]) -> Set c -> Set [String])
-> (c -> [String]) -> Set c -> Set [String]
forall a b. (a -> b) -> a -> b
$ \c
c ->
    let a :: [String]
a = c
c c -> Index -> [String]
forall c k v (m :: * -> *).
(Indexable c k v, MonadFail m) =>
c -> k -> m v
!? Int -> Index
index Int
i
        ([String]
l1, [String]
l2) = Int -> [String] -> ([String], [String])
forall a. Int -> [a] -> ([a], [a])
splitAt Int
i ([String] -> ([String], [String]))
-> [String] -> ([String], [String])
forall a b. (a -> b) -> a -> b
$ c -> [String]
forall c v. Listable c v => c -> [v]
toList c
c
    in  [String]
l1 [String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++ [String]
a [String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++ [String]
l2