{-# LANGUAGE TupleSections #-}
{-# OPTIONS_GHC -Wno-incomplete-patterns #-}

module CFG2TM where

import GrammarType
import TMType
import qualified Data.Set as Set
import Helpers
import Data.List (elemIndices, groupBy, sortBy, sort, group)

-- define a start states
sSFT :: State
sSFT :: State
sSFT = String -> State
State String
"q_{0}^{1}"
sSST :: State
sSST :: State
sSST = String -> State
State String
"q_{0}^{2}"
-- define a final states
fSFT :: State
fSFT :: State
fSFT = String -> State
State String
"q_{1}^{1}"
fSST :: State
fSST :: State
fSST = String -> State
State String
"q_{2}^{2}"
iSST :: State
iSST :: State
iSST = String -> State
State String
"q_{1}^{2}"

first :: [Relation] -> Symbol -> [String]
first :: [Relation] -> Symbol -> [String]
first [Relation]
_ (T (Terminal String
t)) = [String
t]
first [Relation]
rels Symbol
Eps = (Relation -> [String]) -> [Relation] -> [String]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (\(Relation (Nonterminal
n, [Symbol]
_)) -> [Relation] -> Symbol -> [String]
follow [Relation]
rels (Nonterminal -> Symbol
N Nonterminal
n)) ([Relation] -> [String])
-> ([Relation] -> [Relation]) -> [Relation] -> [String]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Relation -> Bool) -> [Relation] -> [Relation]
forall a. (a -> Bool) -> [a] -> [a]
filter (\(Relation (Nonterminal
_, Symbol
e : [Symbol]
_)) -> Symbol
e Symbol -> Symbol -> Bool
forall a. Eq a => a -> a -> Bool
== Symbol
Eps) ([Relation] -> [String]) -> [Relation] -> [String]
forall a b. (a -> b) -> a -> b
$ [Relation]
rels
first [Relation]
rels s :: Symbol
s@(N Nonterminal
n) = (Relation -> [String]) -> [Relation] -> [String]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (\(Relation (Nonterminal
_, Symbol
h : [Symbol]
_)) -> [Relation] -> Symbol -> [String]
first [Relation]
rels Symbol
h) ([Relation] -> [String])
-> ([Relation] -> [Relation]) -> [Relation] -> [String]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Relation -> Bool) -> [Relation] -> [Relation]
forall a. (a -> Bool) -> [a] -> [a]
filter (\(Relation (Nonterminal
x, Symbol
h : [Symbol]
_)) -> Nonterminal
x Nonterminal -> Nonterminal -> Bool
forall a. Eq a => a -> a -> Bool
== Nonterminal
n Bool -> Bool -> Bool
&& Symbol
h Symbol -> Symbol -> Bool
forall a. Eq a => a -> a -> Bool
/= Symbol
s) ([Relation] -> [String]) -> [Relation] -> [String]
forall a b. (a -> b) -> a -> b
$ [Relation]
rels

follow :: [Relation] -> Symbol -> [String]
follow :: [Relation] -> Symbol -> [String]
follow [Relation]
rels Symbol
n = (Symbol -> [String]) -> [Symbol] -> [String]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap ([Relation] -> Symbol -> [String]
first [Relation]
rels)
                    ([Symbol] -> [String])
-> ([Relation] -> [Symbol]) -> [Relation] -> [String]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Relation -> [Symbol]) -> [Relation] -> [Symbol]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (\(Relation (Nonterminal
_, [Symbol]
symb)) -> (Int -> Symbol) -> [Int] -> [Symbol]
forall a b. (a -> b) -> [a] -> [b]
map ([Symbol]
symb [Symbol] -> Int -> Symbol
forall a. [a] -> Int -> a
!!) ([Int] -> [Symbol]) -> ([Int] -> [Int]) -> [Int] -> [Symbol]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Int -> Bool) -> [Int] -> [Int]
forall a. (a -> Bool) -> [a] -> [a]
filter (Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< [Symbol] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Symbol]
symb) ([Int] -> [Int]) -> ([Int] -> [Int]) -> [Int] -> [Int]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Int -> Int) -> [Int] -> [Int]
forall a b. (a -> b) -> [a] -> [b]
map (Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1) ([Int] -> [Symbol]) -> [Int] -> [Symbol]
forall a b. (a -> b) -> a -> b
$ Symbol -> [Symbol] -> [Int]
forall a. Eq a => a -> [a] -> [Int]
elemIndices Symbol
n [Symbol]
symb)
                    ([Relation] -> [Symbol])
-> ([Relation] -> [Relation]) -> [Relation] -> [Symbol]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Relation -> Bool) -> [Relation] -> [Relation]
forall a. (a -> Bool) -> [a] -> [a]
filter (\(Relation (Nonterminal
_, [Symbol]
symb)) -> Symbol
n Symbol -> [Symbol] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [Symbol]
symb) ([Relation] -> [String]) -> [Relation] -> [String]
forall a b. (a -> b) -> a -> b
$ [Relation]
rels

first2 :: [Symbol] -> [Relation] -> [String] -> [String]
first2 :: [Symbol] -> [Relation] -> [String] -> [String]
first2 [Symbol]
symb [Relation]
rels [String]
acc =
    case [Symbol]
symb of
        Symbol
Eps : [Symbol]
t -> [Symbol] -> [Relation] -> [String] -> [String]
first2 [Symbol]
t [Relation]
rels [String]
acc
        N Nonterminal
n : [Symbol]
t -> (Relation -> [String]) -> [Relation] -> [String]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (\(Relation (Nonterminal
_, [Symbol]
s)) -> [Symbol] -> [Relation] -> [String] -> [String]
first2 ([Symbol]
s [Symbol] -> [Symbol] -> [Symbol]
forall a. [a] -> [a] -> [a]
++ [Symbol]
t) [Relation]
rels [String]
acc) ([Relation] -> [String])
-> ([Relation] -> [Relation]) -> [Relation] -> [String]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Relation -> Bool) -> [Relation] -> [Relation]
forall a. (a -> Bool) -> [a] -> [a]
filter (\(Relation (Nonterminal
x, [Symbol]
_)) -> Nonterminal
x Nonterminal -> Nonterminal -> Bool
forall a. Eq a => a -> a -> Bool
== Nonterminal
n) ([Relation] -> [String]) -> [Relation] -> [String]
forall a b. (a -> b) -> a -> b
$ [Relation]
rels
        T (Terminal String
term) : [Symbol]
t | [String] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [String]
acc Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
1 -> [String
term]
                                | Bool
otherwise -> [Symbol] -> [Relation] -> [String] -> [String]
first2 [Symbol]
t [Relation]
rels (String
term String -> [String] -> [String]
forall a. a -> [a] -> [a]
: [String]
acc)
        [] -> []

genRelationCommand :: (Relation, State) -> [State] -> [Relation] -> ([State], [[TapeCommand]])
genRelationCommand :: (Relation, State)
-> [State] -> [Relation] -> ([State], [[TapeCommand]])
genRelationCommand (Relation (ns :: Nonterminal
ns@(Nonterminal String
start), [Symbol
Eps]), State
st) [State]
states [Relation]
rels =
    ([State]
states,
        [[((Square, State, Square), (Square, State, Square)) -> TapeCommand
SingleTapeCommand ((Square
LBS, State
sSFT, Square
RBS), (Square
LBS, State
sSFT, Square
RBS)),
        ((Square, State, Square), (Square, State, Square)) -> TapeCommand
SingleTapeCommand ((String -> Square
defValue String
start, State
iSST, Square
RBS), (Square
ES, State
iSST, Square
RBS))],
        [((Square, State, Square), (Square, State, Square)) -> TapeCommand
SingleTapeCommand ((Square
LBS, State
sSFT, Square
RBS), (Square
LBS, State
sSFT, Square
RBS)),
        ((Square, State, Square), (Square, State, Square)) -> TapeCommand
SingleTapeCommand ((Square
ES, State
sSST, Square
RBS), (String -> Square
defValue String
start, State
iSST, Square
RBS))]] [[TapeCommand]] -> [[TapeCommand]] -> [[TapeCommand]]
forall a. [a] -> [a] -> [a]
++ [[TapeCommand]]
followcmds)
            where
            followcmds :: [[TapeCommand]]
followcmds = (String -> [TapeCommand]) -> [String] -> [[TapeCommand]]
forall a b. (a -> b) -> [a] -> [b]
map (\String
fns -> [((Square, State, Square), (Square, State, Square)) -> TapeCommand
SingleTapeCommand ((String -> Square
defValue String
fns, State
st, Square
RBS), (String -> Square
defValue String
fns, State
st, Square
RBS)),
                                            ((Square, State, Square), (Square, State, Square)) -> TapeCommand
SingleTapeCommand ((String -> Square
defValue String
start, State
iSST, Square
RBS), (Square
ES, State
iSST, Square
RBS))]) ([String] -> [[TapeCommand]]) -> [String] -> [[TapeCommand]]
forall a b. (a -> b) -> a -> b
$ [Relation] -> Symbol -> [String]
follow [Relation]
rels (Symbol -> [String]) -> Symbol -> [String]
forall a b. (a -> b) -> a -> b
$ Nonterminal -> Symbol
N Nonterminal
ns
genRelationCommand (Relation (Nonterminal String
nonterminalSymbol, [Symbol
symbol]), State
st) [State]
states [Relation]
rels =
    ([State]
states,
        [[((Square, State, Square), (Square, State, Square)) -> TapeCommand
SingleTapeCommand ((String -> Square
defValue String
fnt, State
st, Square
RBS), (String -> Square
defValue String
fnt, State
st, Square
RBS)),
        ((Square, State, Square), (Square, State, Square)) -> TapeCommand
SingleTapeCommand ((String -> Square
defValue String
nonterminalSymbol, State
iSST, Square
RBS), (Symbol -> Square
disjoinIfTerminal Symbol
symbol, State
iSST, Square
RBS))]])
            where
            [String
fnt] = [Relation] -> Symbol -> [String]
first [Relation]
rels Symbol
symbol
genRelationCommand (Relation (Nonterminal
_, []), State
_) [State]
_ [Relation]
_ = String -> ([State], [[TapeCommand]])
forall a. HasCallStack => String -> a
error String
"Relation production is empty"
genRelationCommand (Relation (Nonterminal String
nonterminalSymbol, [Symbol]
symbols), State
st) [State]
states [Relation]
rels = ([State]
newStates, [TapeCommand]
lcmd [TapeCommand] -> [[TapeCommand]] -> [[TapeCommand]]
forall a. a -> [a] -> [a]
: [[TapeCommand]]
commands)
    where
        reversedSymbols :: [Symbol]
reversedSymbols = [Symbol] -> [Symbol]
forall a. [a] -> [a]
reverse [Symbol]
symbols
        foldFunc :: ([State], [[TapeCommand]]) -> Symbol -> ([State], [[TapeCommand]])
foldFunc ([State], [[TapeCommand]])
acc Symbol
x = (State
nextState State -> [State] -> [State]
forall a. a -> [a] -> [a]
: [State]
prevStates, [TapeCommand]
cmd [TapeCommand] -> [[TapeCommand]] -> [[TapeCommand]]
forall a. a -> [a] -> [a]
: [[TapeCommand]]
prevCmds)
            where
                (prevStates :: [State]
prevStates@(State
prevState : [State]
_), [[TapeCommand]]
prevCmds) = ([State], [[TapeCommand]])
acc
                nextState :: State
nextState = [State] -> State
genNextStateList [State]
prevStates
                cmd :: [TapeCommand]
cmd = [ ((Square, State, Square), (Square, State, Square)) -> TapeCommand
SingleTapeCommand ((Square
ES, State
st, Square
RBS),(Square
ES, State
st, Square
RBS)),
                        ((Square, State, Square), (Square, State, Square)) -> TapeCommand
SingleTapeCommand ((Square
ES, State
prevState, Square
RBS), (Symbol -> Square
disjoinIfTerminal Symbol
x, State
nextState, Square
RBS))]
        Symbol
hsymbol : [Symbol]
tsymbols = [Symbol]
reversedSymbols
        startState :: State
startState = [State] -> State
genNextStateList [State]
states
        fnts :: [String]
fnts = [Relation] -> Symbol -> [String]
first [Relation]
rels (Symbol -> [String]) -> Symbol -> [String]
forall a b. (a -> b) -> a -> b
$ [Symbol] -> Symbol
forall a. [a] -> a
head [Symbol]
symbols
        makefcmd :: String -> [TapeCommand]
makefcmd String
fnt = [((Square, State, Square), (Square, State, Square)) -> TapeCommand
SingleTapeCommand ((String -> Square
defValue String
fnt, State
st, Square
RBS), (String -> Square
defValue String
fnt, State
st, Square
RBS)),
                        ((Square, State, Square), (Square, State, Square)) -> TapeCommand
SingleTapeCommand ((String -> Square
defValue String
nonterminalSymbol, State
iSST, Square
RBS), (Symbol -> Square
disjoinIfTerminal Symbol
hsymbol, State
startState, Square
RBS))]
        fcmds :: [[TapeCommand]]
fcmds = (String -> [TapeCommand]) -> [String] -> [[TapeCommand]]
forall a b. (a -> b) -> [a] -> [b]
map String -> [TapeCommand]
makefcmd [String]
fnts
        ([State]
newStates, [[TapeCommand]]
commands) = (([State], [[TapeCommand]])
 -> Symbol -> ([State], [[TapeCommand]]))
-> ([State], [[TapeCommand]])
-> [Symbol]
-> ([State], [[TapeCommand]])
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl ([State], [[TapeCommand]]) -> Symbol -> ([State], [[TapeCommand]])
foldFunc (State
startState State -> [State] -> [State]
forall a. a -> [a] -> [a]
: [State]
states, [[TapeCommand]]
fcmds) [Symbol]
tsymbols
        lcmd :: [TapeCommand]
lcmd = [((Square, State, Square), (Square, State, Square)) -> TapeCommand
SingleTapeCommand ((Square
ES, State
st, Square
RBS), (Square
ES, State
sSFT, Square
RBS)),
                ((Square, State, Square), (Square, State, Square)) -> TapeCommand
SingleTapeCommand ((Square
ES, [State] -> State
forall a. [a] -> a
head [State]
newStates, Square
RBS), (Square
ES, State
iSST, Square
RBS))]




genEraseCommand :: Terminal -> [TapeCommand]
genEraseCommand :: Terminal -> [TapeCommand]
genEraseCommand (Terminal String
terminal) =  [((Square, State, Square), (Square, State, Square)) -> TapeCommand
SingleTapeCommand ((Square
x, State
sSFT, Square
RBS), (Square
ES, State
sSFT, Square
RBS)),
                                        ((Square, State, Square), (Square, State, Square)) -> TapeCommand
SingleTapeCommand ((Square -> Square
getDisjoinSquare Square
x, State
iSST, Square
RBS), (Square
ES, State
iSST, Square
RBS))]
                where
                    x :: Square
x = String -> Square
defValue String
terminal

genPreviewCommand :: [Relation] -> [State] -> ([State], [[TapeCommand]], [(Relation, State)])
genPreviewCommand :: [Relation]
-> [State] -> ([State], [[TapeCommand]], [(Relation, State)])
genPreviewCommand [Relation]
rels [State]
states = if ([Relation] -> Bool) -> [[Relation]] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all [Relation] -> Bool
checkDeterm [[Relation]]
groups then (([State], [[TapeCommand]], [(Relation, State)])
 -> [Relation] -> ([State], [[TapeCommand]], [(Relation, State)]))
-> ([State], [[TapeCommand]], [(Relation, State)])
-> [[Relation]]
-> ([State], [[TapeCommand]], [(Relation, State)])
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl ([State], [[TapeCommand]], [(Relation, State)])
-> [Relation] -> ([State], [[TapeCommand]], [(Relation, State)])
func ([State]
states, [], []) [[Relation]]
groups else ([State]
states, [], (Relation -> (Relation, State))
-> [Relation] -> [(Relation, State)]
forall a b. (a -> b) -> [a] -> [b]
map (, State
sSFT) [Relation]
rels)
    where
        groups :: [[Relation]]
groups = (Relation -> Relation -> Bool) -> [Relation] -> [[Relation]]
forall a. (a -> a -> Bool) -> [a] -> [[a]]
groupBy (\(Relation (Nonterminal
n1, Symbol
h1 : [Symbol]
_)) (Relation (Nonterminal
n2, Symbol
h2 : [Symbol]
_)) -> Nonterminal
n1 Nonterminal -> Nonterminal -> Bool
forall a. Eq a => a -> a -> Bool
== Nonterminal
n2 Bool -> Bool -> Bool
&& [Relation] -> Symbol -> [String]
first [Relation]
rels Symbol
h1 [String] -> [String] -> Bool
forall a. Eq a => a -> a -> Bool
== [Relation] -> Symbol -> [String]
first [Relation]
rels Symbol
h2) ([Relation] -> [[Relation]])
-> ([Relation] -> [Relation]) -> [Relation] -> [[Relation]]
forall b c a. (b -> c) -> (a -> b) -> a -> c
.
                    (Relation -> Relation -> Ordering) -> [Relation] -> [Relation]
forall a. (a -> a -> Ordering) -> [a] -> [a]
sortBy (\(Relation (Nonterminal
n1, Symbol
h1 : [Symbol]
_)) (Relation (Nonterminal
n2, Symbol
h2 : [Symbol]
_)) -> (Nonterminal, [String]) -> (Nonterminal, [String]) -> Ordering
forall a. Ord a => a -> a -> Ordering
compare (Nonterminal
n1, [Relation] -> Symbol -> [String]
first [Relation]
rels Symbol
h1) (Nonterminal
n2, [Relation] -> Symbol -> [String]
first [Relation]
rels Symbol
h2) ) ([Relation] -> [[Relation]]) -> [Relation] -> [[Relation]]
forall a b. (a -> b) -> a -> b
$ [Relation]
rels
        getFirst2 :: Relation -> [String]
getFirst2 (Relation (Nonterminal
_, [Symbol]
symb)) = [Symbol] -> [Relation] -> [String] -> [String]
first2 [Symbol]
symb [Relation]
rels []
        getFirst :: Relation -> [String]
getFirst (Relation (Nonterminal
_, Symbol
h : [Symbol]
_)) = [Relation] -> Symbol -> [String]
first [Relation]
rels Symbol
h
        getFirst (Relation (Nonterminal
_, [])) = String -> [String]
forall a. HasCallStack => String -> a
error String
"Empty symb"
        getNonterm :: Relation -> String
getNonterm (Relation (Nonterminal String
n, [Symbol]
_)) = String
n
        isOne :: Relation -> Bool
isOne = Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
(==) Int
1 (Int -> Bool) -> (Relation -> Int) -> Relation -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [[String]] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length ([[String]] -> Int) -> (Relation -> [[String]]) -> Relation -> Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [String] -> [[String]]
forall a. Eq a => [a] -> [[a]]
group ([String] -> [[String]])
-> (Relation -> [String]) -> Relation -> [[String]]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [String] -> [String]
forall a. Ord a => [a] -> [a]
sort ([String] -> [String])
-> (Relation -> [String]) -> Relation -> [String]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Relation -> [String]
getFirst2
        isAllDiff :: t Relation -> Bool
isAllDiff t Relation
gr = Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
(==) (t Relation -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length t Relation
gr) (Int -> Bool) -> (t Relation -> Int) -> t Relation -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [[String]] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length ([[String]] -> Int)
-> (t Relation -> [[String]]) -> t Relation -> Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [String] -> [[String]]
forall a. Eq a => [a] -> [[a]]
group ([String] -> [[String]])
-> (t Relation -> [String]) -> t Relation -> [[String]]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [String] -> [String]
forall a. Ord a => [a] -> [a]
sort ([String] -> [String])
-> (t Relation -> [String]) -> t Relation -> [String]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Relation -> [String]) -> t Relation -> [String]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap Relation -> [String]
getFirst2 (t Relation -> Bool) -> t Relation -> Bool
forall a b. (a -> b) -> a -> b
$ t Relation
gr
        checkDeterm :: [Relation] -> Bool
checkDeterm [Relation
_] = Bool
True
        checkDeterm [Relation]
gr = (Relation -> Bool) -> [Relation] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all Relation -> Bool
isOne [Relation]
gr Bool -> Bool -> Bool
&& [Relation] -> Bool
forall (t :: * -> *). Foldable t => t Relation -> Bool
isAllDiff [Relation]
gr
        func :: ([State], [[TapeCommand]], [(Relation, State)])
-> [Relation] -> ([State], [[TapeCommand]], [(Relation, State)])
func ([State]
sts, [[TapeCommand]]
commands, [(Relation, State)]
relState) [Relation
h] = ([State]
sts, [[TapeCommand]]
commands, (Relation
h, State
sSFT) (Relation, State) -> [(Relation, State)] -> [(Relation, State)]
forall a. a -> [a] -> [a]
: [(Relation, State)]
relState)
        func ([State]
sts, [[TapeCommand]]
commands, [(Relation, State)]
relState) [Relation]
gr = ([State]
newStates, [[TapeCommand]]
newcmds, [(Relation, State)]
rs)
            where
                fL :: Square
fL = String -> Square
defValue (String -> Square) -> String -> Square
forall a b. (a -> b) -> a -> b
$ [String] -> String
forall a. [a] -> a
head ([String] -> String) -> [String] -> String
forall a b. (a -> b) -> a -> b
$ Relation -> [String]
getFirst (Relation -> [String]) -> Relation -> [String]
forall a b. (a -> b) -> a -> b
$ [Relation] -> Relation
forall a. [a] -> a
head [Relation]
gr
                nterm :: Square
nterm = String -> Square
defValue (String -> Square) -> String -> Square
forall a b. (a -> b) -> a -> b
$ Relation -> String
getNonterm (Relation -> String) -> Relation -> String
forall a b. (a -> b) -> a -> b
$ [Relation] -> Relation
forall a. [a] -> a
head [Relation]
gr
                startState :: State
startState = [State] -> State
genNextStateList [State]
states
                gencmds :: ([State], [[TapeCommand]], [(Relation, State)])
-> Relation -> ([State], [[TapeCommand]], [(Relation, State)])
gencmds ([State]
newstates, [[TapeCommand]]
cmds, [(Relation, State)]
rules) Relation
r = (State
endState State -> [State] -> [State]
forall a. a -> [a] -> [a]
: State
findState State -> [State] -> [State]
forall a. a -> [a] -> [a]
: [State]
newstates, [[TapeCommand]]
newCmds [[TapeCommand]] -> [[TapeCommand]] -> [[TapeCommand]]
forall a. [a] -> [a] -> [a]
++ [[TapeCommand]]
cmds, (Relation
r, State
endState) (Relation, State) -> [(Relation, State)] -> [(Relation, State)]
forall a. a -> [a] -> [a]
: [(Relation, State)]
rules)
                            where
                                f2 :: Square
f2 = String -> Square
defValue (String -> Square) -> String -> Square
forall a b. (a -> b) -> a -> b
$ [String] -> String
forall a. [a] -> a
head ([String] -> String) -> [String] -> String
forall a b. (a -> b) -> a -> b
$ Relation -> [String]
getFirst2 Relation
r
                                findState :: State
findState = [State] -> State
genNextStateList [State]
newstates
                                endState :: State
endState = [State] -> State
genNextStateList (State
findState State -> [State] -> [State]
forall a. a -> [a] -> [a]
: [State]
newstates)
                                newCmds :: [[TapeCommand]]
newCmds = [ [((Square, State, Square), (Square, State, Square)) -> TapeCommand
SingleTapeCommand ((Square
f2, State
startState, Square
fL), (Square
f2, State
findState, Square
fL)),
                                            ((Square, State, Square), (Square, State, Square)) -> TapeCommand
SingleTapeCommand ((Square
nterm, State
iSST, Square
RBS), (Square
nterm, State
iSST, Square
RBS))],
                                            [((Square, State, Square), (Square, State, Square)) -> TapeCommand
SingleTapeCommand ((Square
ES, State
findState, Square
fL), (Square
fL, State
findState, Square
ES)),
                                            ((Square, State, Square), (Square, State, Square)) -> TapeCommand
SingleTapeCommand ((Square
nterm, State
iSST, Square
RBS), (Square
nterm, State
iSST, Square
RBS))],
                                            [((Square, State, Square), (Square, State, Square)) -> TapeCommand
SingleTapeCommand ((Square
fL, State
findState, Square
RBS), (Square
fL, State
endState, Square
RBS)),
                                            ((Square, State, Square), (Square, State, Square)) -> TapeCommand
SingleTapeCommand ((Square
nterm, State
iSST, Square
RBS), (Square
nterm, State
iSST, Square
RBS))]]
                startCmd :: [TapeCommand]
startCmd = [((Square, State, Square), (Square, State, Square)) -> TapeCommand
SingleTapeCommand ((Square
fL, State
sSFT, Square
ES), (Square
ES, State
startState, Square
fL)),
                            ((Square, State, Square), (Square, State, Square)) -> TapeCommand
SingleTapeCommand ((Square
nterm, State
iSST, Square
RBS), (Square
nterm, State
iSST, Square
RBS))]
                ([State]
newStates, [[TapeCommand]]
newcmds, [(Relation, State)]
rs) = (([State], [[TapeCommand]], [(Relation, State)])
 -> Relation -> ([State], [[TapeCommand]], [(Relation, State)]))
-> ([State], [[TapeCommand]], [(Relation, State)])
-> [Relation]
-> ([State], [[TapeCommand]], [(Relation, State)])
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl ([State], [[TapeCommand]], [(Relation, State)])
-> Relation -> ([State], [[TapeCommand]], [(Relation, State)])
gencmds (State
startState State -> [State] -> [State]
forall a. a -> [a] -> [a]
: [State]
sts, [TapeCommand]
startCmd [TapeCommand] -> [[TapeCommand]] -> [[TapeCommand]]
forall a. a -> [a] -> [a]
: [[TapeCommand]]
commands, [(Relation, State)]
relState) [Relation]
gr


cfg2tm :: Grammar -> TM
cfg2tm :: Grammar -> TM
cfg2tm
    (Grammar
        (Set Nonterminal
setOfNonterminals,
        Set Terminal
setOfTerminals,
        Set Relation
setOfRelations,
        Nonterminal String
startSymbol)) = do
    let terminalsList :: [Terminal]
terminalsList = Set Terminal -> [Terminal]
forall a. Set a -> [a]
Set.toList Set Terminal
setOfTerminals
    let nonterminalSquares :: [Square]
nonterminalSquares = [String] -> [Square]
mapValue ([String] -> [Square]) -> [String] -> [Square]
forall a b. (a -> b) -> a -> b
$ (Nonterminal -> String) -> [Nonterminal] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map (\(Nonterminal String
x) -> String
x) ([Nonterminal] -> [String]) -> [Nonterminal] -> [String]
forall a b. (a -> b) -> a -> b
$ Set Nonterminal -> [Nonterminal]
forall a. Set a -> [a]
Set.elems Set Nonterminal
setOfNonterminals
    let terminalSquares :: [Square]
terminalSquares = [String] -> [Square]
mapValue ([String] -> [Square]) -> [String] -> [Square]
forall a b. (a -> b) -> a -> b
$ (Terminal -> String) -> [Terminal] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map (\(Terminal String
x) -> String
x) [Terminal]
terminalsList
    let setOfSecondTapeAlphabet :: Set Square
setOfSecondTapeAlphabet = [Square] -> Set Square
forall a. Ord a => [a] -> Set a
Set.fromList ([Square] -> Set Square) -> [Square] -> Set Square
forall a b. (a -> b) -> a -> b
$ [Square] -> [Square] -> [Square]
forall a. [a] -> [a] -> [a]
(++) [Square]
nonterminalSquares ([Square] -> [Square]) -> [Square] -> [Square]
forall a b. (a -> b) -> a -> b
$ (Square -> Square) -> [Square] -> [Square]
forall a b. (a -> b) -> [a] -> [b]
map Square -> Square
getDisjoinSquare [Square]
terminalSquares
    let setOfTerminalSquares :: Set Square
setOfTerminalSquares = [Square] -> Set Square
forall a. Ord a => [a] -> Set a
Set.fromList [Square]
terminalSquares
    let tmInputAlphabet :: InputAlphabet
tmInputAlphabet = Set Square -> InputAlphabet
InputAlphabet Set Square
setOfTerminalSquares
    let tmTapeAlphabets :: [TapeAlphabet]
tmTapeAlphabets =
            [
                Set Square -> TapeAlphabet
TapeAlphabet Set Square
setOfTerminalSquares,
                Set Square -> TapeAlphabet
TapeAlphabet Set Square
setOfSecondTapeAlphabet
            ]
    let startStates :: StartStates
startStates = [State] -> StartStates
StartStates [State
sSFT, State
sSST]
    let accessStates :: AccessStates
accessStates = [State] -> AccessStates
AccessStates [State
fSFT, State
fSST]
    -- define first transition
    let firstCommand :: [TapeCommand]
firstCommand = [((Square, State, Square), (Square, State, Square)) -> TapeCommand
SingleTapeCommand ((Square
ES, State
sSFT, Square
RBS), (Square
ES, State
sSFT, Square
RBS)),
                        ((Square, State, Square), (Square, State, Square)) -> TapeCommand
SingleTapeCommand ((Square
ES, State
sSST, Square
RBS), (String -> Square
defValue String
startSymbol, State
iSST, Square
RBS))]
    -- convert relations
    let rels :: [Relation]
rels = Set Relation -> [Relation]
forall a. Set a -> [a]
Set.elems Set Relation
setOfRelations
    let ([State]
firstStatesAfterPreview, [[TapeCommand]]
previewCmds, [(Relation, State)]
relStates) = [Relation]
-> [State] -> ([State], [[TapeCommand]], [(Relation, State)])
genPreviewCommand [Relation]
rels [State
sSFT, State
fSFT]
    let proxyGenRelation :: ([State], [[TapeCommand]])
-> (Relation, State) -> ([State], [[TapeCommand]])
proxyGenRelation ([State]
states, [[TapeCommand]]
acccmds) (Relation, State)
x = ([State]
newStates, [[TapeCommand]]
cmds [[TapeCommand]] -> [[TapeCommand]] -> [[TapeCommand]]
forall a. [a] -> [a] -> [a]
++ [[TapeCommand]]
acccmds)
            where
                ([State]
newStates, [[TapeCommand]]
cmds) = (Relation, State)
-> [State] -> [Relation] -> ([State], [[TapeCommand]])
genRelationCommand (Relation, State)
x [State]
states [Relation]
rels
    let ([State]
listOfStates, [[TapeCommand]]
mappedRelations) = (([State], [[TapeCommand]])
 -> (Relation, State) -> ([State], [[TapeCommand]]))
-> ([State], [[TapeCommand]])
-> [(Relation, State)]
-> ([State], [[TapeCommand]])
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl ([State], [[TapeCommand]])
-> (Relation, State) -> ([State], [[TapeCommand]])
proxyGenRelation ([State
fSST, State
sSST, State
iSST], []) [(Relation, State)]
relStates
    -- map terminals to transitions
    let mappedTerminals :: [[TapeCommand]]
mappedTerminals = (Terminal -> [TapeCommand]) -> [Terminal] -> [[TapeCommand]]
forall a b. (a -> b) -> [a] -> [b]
map Terminal -> [TapeCommand]
genEraseCommand [Terminal]
terminalsList
    let acceptCommand :: [TapeCommand]
acceptCommand = [((Square, State, Square), (Square, State, Square)) -> TapeCommand
SingleTapeCommand ((Square
LBS, State
sSFT, Square
RBS), (Square
LBS, State
fSFT, Square
RBS)),
                        ((Square, State, Square), (Square, State, Square)) -> TapeCommand
SingleTapeCommand ((Square
LBS, State
iSST, Square
RBS), (Square
LBS, State
fSST, Square
RBS))]
    let transitions :: Set [TapeCommand]
transitions = [[TapeCommand]] -> Set [TapeCommand]
forall a. Ord a => [a] -> Set a
Set.fromList ([[TapeCommand]
acceptCommand, [TapeCommand]
firstCommand] [[TapeCommand]] -> [[TapeCommand]] -> [[TapeCommand]]
forall a. [a] -> [a] -> [a]
++ [[TapeCommand]]
mappedTerminals [[TapeCommand]] -> [[TapeCommand]] -> [[TapeCommand]]
forall a. [a] -> [a] -> [a]
++ [[TapeCommand]]
mappedRelations [[TapeCommand]] -> [[TapeCommand]] -> [[TapeCommand]]
forall a. [a] -> [a] -> [a]
++ [[TapeCommand]]
previewCmds)
    let multiTapeStates :: MultiTapeStates
multiTapeStates = [Set State] -> MultiTapeStates
MultiTapeStates [
            [State] -> Set State
forall a. Ord a => [a] -> Set a
Set.fromList [State]
firstStatesAfterPreview,
            [State] -> Set State
forall a. Ord a => [a] -> Set a
Set.fromList [State]
listOfStates
            ]
    (InputAlphabet, [TapeAlphabet], MultiTapeStates, Commands,
 StartStates, AccessStates)
-> TM
TM (InputAlphabet
tmInputAlphabet, [TapeAlphabet]
tmTapeAlphabets, MultiTapeStates
multiTapeStates, Set [TapeCommand] -> Commands
Commands Set [TapeCommand]
transitions, StartStates
startStates, AccessStates
accessStates)