module SMInterpreter where
    import SMType
    import Data.Maybe
    import TM2SM
    import Prelude hiding (Word)
    import Data.List (isInfixOf, elemIndex, find)
    import Data.Map (Map)
    import qualified Data.Map as Map
    import Data.Graph.Inductive.Graph (mkGraph)
    import Data.Graph.Inductive.PatriciaTree (Gr)
    import Data.Tuple (swap)

    checkRule :: Word -> SRule -> Bool
    checkRule :: Word -> SRule -> Bool
checkRule (Word [Smb]
word) (SRule [(Word, Word)]
rule) = do
        let check :: (Word, b) -> Bool
check (Word [Smb]
l, b
_) = [Smb]
l [Smb] -> [Smb] -> Bool
forall a. Eq a => [a] -> [a] -> Bool
`isInfixOf` [Smb]
word
        ((Word, Word) -> Bool) -> [(Word, Word)] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all (Word, Word) -> Bool
forall b. (Word, b) -> Bool
check [(Word, Word)]
rule

    getApplicableRules :: [SRule] -> [Word] -> [[SRule]]
    getApplicableRules :: [SRule] -> [Word] -> [[SRule]]
getApplicableRules [SRule]
rules = (Word -> [SRule]) -> [Word] -> [[SRule]]
forall a b. (a -> b) -> [a] -> [b]
map (\Word
w -> (SRule -> Bool) -> [SRule] -> [SRule]
forall a. (a -> Bool) -> [a] -> [a]
filter (Word -> SRule -> Bool
checkRule Word
w) [SRule]
rules)

    reduceY :: [Smb] -> [Smb]
    reduceY :: [Smb] -> [Smb]
reduceY [Smb]
word =
        let reduceInternal :: [Smb] -> [Smb] -> [Smb]
reduceInternal [Smb]
smbs [Smb]
acc =
                case [Smb]
smbs of
                    [] -> [Smb] -> [Smb]
forall a. [a] -> [a]
reverse [Smb]
acc
                    smbh1 :: Smb
smbh1@(SmbY Y
h1) : smbh2 :: Smb
smbh2@(SmbY' Y
h2) : [Smb]
t  | Y
h1 Y -> Y -> Bool
forall a. Eq a => a -> a -> Bool
== Y
h2 -> [Smb] -> [Smb] -> [Smb]
reduceInternal [Smb]
t [Smb]
acc
                                                            | Bool
otherwise -> [Smb] -> [Smb] -> [Smb]
reduceInternal (Smb
smbh2 Smb -> [Smb] -> [Smb]
forall a. a -> [a] -> [a]
: [Smb]
t) (Smb
smbh1 Smb -> [Smb] -> [Smb]
forall a. a -> [a] -> [a]
: [Smb]
acc)
                    smbh1 :: Smb
smbh1@(SmbY' Y
h1) : smbh2 :: Smb
smbh2@(SmbY Y
h2) : [Smb]
t  | Y
h1 Y -> Y -> Bool
forall a. Eq a => a -> a -> Bool
== Y
h2 -> [Smb] -> [Smb] -> [Smb]
reduceInternal [Smb]
t [Smb]
acc
                                                            | Bool
otherwise -> [Smb] -> [Smb] -> [Smb]
reduceInternal (Smb
smbh2 Smb -> [Smb] -> [Smb]
forall a. a -> [a] -> [a]
: [Smb]
t) (Smb
smbh1 Smb -> [Smb] -> [Smb]
forall a. a -> [a] -> [a]
: [Smb]
acc)
                    Smb
h : [Smb]
t ->  [Smb] -> [Smb] -> [Smb]
reduceInternal [Smb]
t (Smb
h Smb -> [Smb] -> [Smb]
forall a. a -> [a] -> [a]
: [Smb]
acc)
        in
            [Smb] -> [Smb] -> [Smb]
reduceInternal [Smb]
word []

    replaceSublist :: [Smb] -> (Word, Word) -> [Smb]
    replaceSublist :: [Smb] -> (Word, Word) -> [Smb]
replaceSublist [Smb]
smbs (Word [Smb]
rulel, Word [Smb]
ruler) = [Smb]
l [Smb] -> [Smb] -> [Smb]
forall a. [a] -> [a] -> [a]
++ [Smb]
ruler [Smb] -> [Smb] -> [Smb]
forall a. [a] -> [a] -> [a]
++ [Smb]
r
        where
            replaceSublistInternal :: [a] -> [a] -> [a] -> ([a], [a])
replaceSublistInternal [a]
s [a]
rl [a]
acc =
                case ([a]
s, [a]
rl) of
                    (a
hs : [a]
ts, a
hrl : [a]
trl)    | a
hs a -> a -> Bool
forall a. Eq a => a -> a -> Bool
/= a
hrl -> [a] -> [a] -> [a] -> ([a], [a])
replaceSublistInternal [a]
ts [a]
rl ([a] -> ([a], [a])) -> [a] -> ([a], [a])
forall a b. (a -> b) -> a -> b
$ a
hs a -> [a] -> [a]
forall a. a -> [a] -> [a]
: [a]
acc
                                            | Bool
otherwise -> [a] -> [a] -> [a] -> ([a], [a])
replaceSublistInternal [a]
ts [a]
trl [a]
acc
                    ([a]
_, []) -> ([a] -> [a]
forall a. [a] -> [a]
reverse [a]
acc, [a]
s)
                    ([], a
_ : [a]
_) -> [Char] -> ([a], [a])
forall a. HasCallStack => [Char] -> a
error [Char]
"Substitute length more than substituteble"
            ([Smb]
l, [Smb]
r) = [Smb] -> [Smb] -> [Smb] -> ([Smb], [Smb])
forall a. Eq a => [a] -> [a] -> [a] -> ([a], [a])
replaceSublistInternal [Smb]
smbs [Smb]
rulel []

    applyRule :: Word -> SRule -> Word
    applyRule :: Word -> SRule -> Word
applyRule (Word [Smb]
smbs) (SRule [(Word, Word)]
rule) =
        [Smb] -> Word
Word ([Smb] -> Word) -> [Smb] -> Word
forall a b. (a -> b) -> a -> b
$ [Smb] -> [Smb]
reduceY ([Smb] -> [Smb]) -> [Smb] -> [Smb]
forall a b. (a -> b) -> a -> b
$ ([Smb] -> (Word, Word) -> [Smb])
-> [Smb] -> [(Word, Word)] -> [Smb]
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl [Smb] -> (Word, Word) -> [Smb]
replaceSublist [Smb]
smbs [(Word, Word)]
rule

    applyRules :: [Word] -> [SRule] -> Map Word Int -> [[Word]] -> ([[Word]], Map Word Int)
    applyRules :: [Word]
-> [SRule] -> Map Word Int -> [[Word]] -> ([[Word]], Map Word Int)
applyRules [Word]
wrds [SRule]
rules Map Word Int
m [[Word]]
acc =
        case [SRule]
rules of
            [] -> ([[Word]]
acc, Map Word Int
m)
            SRule
h : [SRule]
t   | Word -> Map Word Int -> Bool
forall k a. Ord k => k -> Map k a -> Bool
Map.member Word
new_word Map Word Int
m -> [Word]
-> [SRule] -> Map Word Int -> [[Word]] -> ([[Word]], Map Word Int)
applyRules [Word]
wrds [SRule]
t Map Word Int
new_m [[Word]]
acc
                    | Bool
otherwise             -> [Word]
-> [SRule] -> Map Word Int -> [[Word]] -> ([[Word]], Map Word Int)
applyRules [Word]
wrds [SRule]
t Map Word Int
new_m ([[Word]] -> ([[Word]], Map Word Int))
-> [[Word]] -> ([[Word]], Map Word Int)
forall a b. (a -> b) -> a -> b
$ ([Word]
wrds [Word] -> [Word] -> [Word]
forall a. [a] -> [a] -> [a]
++ [Word
new_word]) [Word] -> [[Word]] -> [[Word]]
forall a. a -> [a] -> [a]
: [[Word]]
acc
                                                where
                                                    new_word :: Word
new_word = Word -> SRule -> Word
applyRule ([Word] -> Word
forall a. [a] -> a
last [Word]
wrds) SRule
h
                                                    new_m :: Map Word Int
new_m = (Int -> Int -> Int) -> Word -> Int -> Map Word Int -> Map Word Int
forall k a. Ord k => (a -> a -> a) -> k -> a -> Map k a -> Map k a
Map.insertWith Int -> Int -> Int
forall a. Num a => a -> a -> a
(+) Word
new_word Int
1 Map Word Int
m

    applyRuless :: [[Word]] -> [[SRule]] -> Map Word Int -> [[Word]] -> ([[Word]], Map Word Int)
    applyRuless :: [[Word]]
-> [[SRule]]
-> Map Word Int
-> [[Word]]
-> ([[Word]], Map Word Int)
applyRuless [[Word]]
wordss [[SRule]]
ruless Map Word Int
m [[Word]]
acc =
        case ([[Word]]
wordss, [[SRule]]
ruless) of
            ([], []) -> ([[Word]]
acc, Map Word Int
m)
            ([Word]
wrds : [[Word]]
t1, [SRule]
rules : [[SRule]]
t2) -> [[Word]]
-> [[SRule]]
-> Map Word Int
-> [[Word]]
-> ([[Word]], Map Word Int)
applyRuless [[Word]]
t1 [[SRule]]
t2 Map Word Int
new_m ([[Word]] -> ([[Word]], Map Word Int))
-> [[Word]] -> ([[Word]], Map Word Int)
forall a b. (a -> b) -> a -> b
$ [[Word]]
acc_apply [[Word]] -> [[Word]] -> [[Word]]
forall a. [a] -> [a] -> [a]
++ [[Word]]
acc
                                        where
                                            ([[Word]]
acc_apply, Map Word Int
new_m) = [Word]
-> [SRule] -> Map Word Int -> [[Word]] -> ([[Word]], Map Word Int)
applyRules [Word]
wrds [SRule]
rules Map Word Int
m []
            ([[Word]], [[SRule]])
_ -> [Char] -> ([[Word]], Map Word Int)
forall a. HasCallStack => [Char] -> a
error [Char]
"Commandss and configss don't match"

    getFront :: [[Word]] -> [Word]
    getFront :: [[Word]] -> [Word]
getFront = ([Word] -> Word) -> [[Word]] -> [Word]
forall a b. (a -> b) -> [a] -> [b]
map [Word] -> Word
forall a. [a] -> a
last

    startInterpreting :: Word -> [[Word]] -> [SRule] -> Map Word Int -> ([Word], Map Word Int)
    startInterpreting :: Word
-> [[Word]] -> [SRule] -> Map Word Int -> ([Word], Map Word Int)
startInterpreting Word
accessWord [[Word]]
wordss [SRule]
rules Map Word Int
m =
        case ([Word] -> Bool) -> [[Word]] -> Maybe [Word]
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Maybe a
find (\[Word]
w -> [Word] -> Word
forall a. [a] -> a
last [Word]
w Word -> Word -> Bool
forall a. Eq a => a -> a -> Bool
== Word
accessWord) [[Word]]
wordss of
            Just [Word]
path -> ([Word]
path, Map Word Int
m)
            Maybe [Word]
Nothing | [[SRule]]
ruless [[SRule]] -> [[SRule]] -> Bool
forall a. Eq a => a -> a -> Bool
== [[]]    -> [Char] -> ([Word], Map Word Int)
forall a. HasCallStack => [Char] -> a
error [Char]
"No rule is applicable"
                    | Bool
otherwise         -> Word
-> [[Word]] -> [SRule] -> Map Word Int -> ([Word], Map Word Int)
startInterpreting Word
accessWord [[Word]]
acc_apply [SRule]
rules Map Word Int
new_m
        where
            ruless :: [[SRule]]
ruless = [SRule] -> [Word] -> [[SRule]]
getApplicableRules [SRule]
rules ([[Word]] -> [Word]
getFront [[Word]]
wordss)
            ([[Word]]
acc_apply, Map Word Int
new_m) = [[Word]]
-> [[SRule]]
-> Map Word Int
-> [[Word]]
-> ([[Word]], Map Word Int)
applyRuless [[Word]]
wordss [[SRule]]
ruless Map Word Int
m []

    interpretSM :: Word -> SM -> Word -> [Word]
    interpretSM :: Word -> SM -> Word -> [Word]
interpretSM Word
startWord SM
sm Word
accessWord = do
            let m :: Map Word Int
m = [(Word, Int)] -> Map Word Int
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList [(Word
startWord, Int
1)]
            let symmSmRules :: [SRule]
symmSmRules = [SRule] -> [SRule] -> [SRule]
forall a. [a] -> [a] -> [a]
(++) (SM -> [SRule]
srs SM
sm) ([SRule] -> [SRule]) -> [SRule] -> [SRule]
forall a b. (a -> b) -> a -> b
$ (SRule -> SRule) -> [SRule] -> [SRule]
forall a b. (a -> b) -> [a] -> [b]
map SRule -> SRule
symSM (SM -> [SRule]
srs SM
sm)
            let ([Word]
path, Map Word Int
_) = Word
-> [[Word]] -> [SRule] -> Map Word Int -> ([Word], Map Word Int)
startInterpreting Word
accessWord [[Word
startWord]] [SRule]
symmSmRules Map Word Int
m
            [Word]
path

    getRestrictedGraph :: Word -> SM -> Int -> (Gr Word Int, Map Word Int)
    getRestrictedGraph :: Word -> SM -> Int -> (Gr Word Int, Map Word Int)
getRestrictedGraph Word
startWord SM
sm Int
height = do
            let m :: Map Word Int
m = [(Word, Int)] -> Map Word Int
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList [(Word
startWord, Int
1)]
            let symmSmRules :: [SRule]
symmSmRules = SM -> [SRule]
srs SM
sm [SRule] -> [SRule] -> [SRule]
forall a. [a] -> [a] -> [a]
++ (SRule -> SRule) -> [SRule] -> [SRule]
forall a b. (a -> b) -> [a] -> [b]
map SRule -> SRule
symSM (SM -> [SRule]
srs SM
sm)
            let getRuleNumber :: SRule -> Int
getRuleNumber SRule
rule =
                    case SRule -> [SRule] -> Maybe Int
forall a. Eq a => a -> [a] -> Maybe Int
elemIndex SRule
rule ([SRule] -> Maybe Int) -> [SRule] -> Maybe Int
forall a b. (a -> b) -> a -> b
$ [SRule] -> [SRule]
forall a. [a] -> [a]
reverse [SRule]
symmSmRules of
                        Maybe Int
Nothing -> [Char] -> Int
forall a. HasCallStack => [Char] -> a
error [Char]
"Can't found the rule in set"
                        Just Int
i  -> (Int
i Int -> Int -> Int
forall a. Integral a => a -> a -> a
`mod` Int
l) Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1
                    where
                        l :: Int
l = [SRule] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length ([SRule] -> Int) -> [SRule] -> Int
forall a b. (a -> b) -> a -> b
$ SM -> [SRule]
srs SM
sm
            let applyRs :: Word
-> [SRule]
-> Map Word a
-> [Word]
-> [(Word, Int, Word)]
-> ([(Word, Int, Word)], Map Word a, [Word])
applyRs Word
old_word [SRule]
rules Map Word a
nm [Word]
front_acc [(Word, Int, Word)]
acc =
                    case [SRule]
rules of
                        [] -> ([(Word, Int, Word)]
acc, Map Word a
nm, [Word]
front_acc)
                        SRule
h : [SRule]
t   | Word -> Map Word a -> Bool
forall k a. Ord k => k -> Map k a -> Bool
Map.member Word
new_word Map Word a
nm -> Word
-> [SRule]
-> Map Word a
-> [Word]
-> [(Word, Int, Word)]
-> ([(Word, Int, Word)], Map Word a, [Word])
applyRs Word
old_word [SRule]
t Map Word a
new_m [Word]
front_acc [(Word, Int, Word)]
acc
                                | Bool
otherwise             -> Word
-> [SRule]
-> Map Word a
-> [Word]
-> [(Word, Int, Word)]
-> ([(Word, Int, Word)], Map Word a, [Word])
applyRs Word
old_word [SRule]
t Map Word a
new_m [Word]
new_front_acc ([(Word, Int, Word)] -> ([(Word, Int, Word)], Map Word a, [Word]))
-> [(Word, Int, Word)] -> ([(Word, Int, Word)], Map Word a, [Word])
forall a b. (a -> b) -> a -> b
$ (Word
old_word, SRule -> Int
getRuleNumber SRule
h, Word
new_word) (Word, Int, Word) -> [(Word, Int, Word)] -> [(Word, Int, Word)]
forall a. a -> [a] -> [a]
: [(Word, Int, Word)]
acc
                                                            where
                                                                new_word :: Word
new_word = Word -> SRule -> Word
applyRule Word
old_word SRule
h
                                                                new_m :: Map Word a
new_m = (a -> a -> a) -> Word -> a -> Map Word a -> Map Word a
forall k a. Ord k => (a -> a -> a) -> k -> a -> Map k a -> Map k a
Map.insertWith a -> a -> a
forall a. Num a => a -> a -> a
(+) Word
new_word a
1 Map Word a
nm
                                                                new_front_acc :: [Word]
new_front_acc = Word
new_word Word -> [Word] -> [Word]
forall a. a -> [a] -> [a]
: [Word]
front_acc

            let applyRss :: [Word]
-> [[SRule]]
-> Map Word a
-> [Word]
-> [(Word, Int, Word)]
-> ([(Word, Int, Word)], Map Word a, [Word])
applyRss [Word]
wrds [[SRule]]
ruless Map Word a
nm [Word]
front_acc [(Word, Int, Word)]
acc =
                    case ([Word]
wrds, [[SRule]]
ruless) of
                        ([], []) -> ([(Word, Int, Word)]
acc, Map Word a
nm, [Word]
front_acc)
                        (Word
word : [Word]
t1, [SRule]
rules : [[SRule]]
t2) -> [Word]
-> [[SRule]]
-> Map Word a
-> [Word]
-> [(Word, Int, Word)]
-> ([(Word, Int, Word)], Map Word a, [Word])
applyRss [Word]
t1 [[SRule]]
t2 Map Word a
new_m [Word]
new_front_acc [(Word, Int, Word)]
acc_apply
                                                    where
                                                        ([(Word, Int, Word)]
acc_apply, Map Word a
new_m, [Word]
new_front_acc) = Word
-> [SRule]
-> Map Word a
-> [Word]
-> [(Word, Int, Word)]
-> ([(Word, Int, Word)], Map Word a, [Word])
forall a.
Num a =>
Word
-> [SRule]
-> Map Word a
-> [Word]
-> [(Word, Int, Word)]
-> ([(Word, Int, Word)], Map Word a, [Word])
applyRs Word
word [SRule]
rules Map Word a
nm [Word]
front_acc [(Word, Int, Word)]
acc
                        ([Word], [[SRule]])
_ -> [Char] -> ([(Word, Int, Word)], Map Word a, [Word])
forall a. HasCallStack => [Char] -> a
error [Char]
"Commandss and configss don't match"
            let interpret :: [Word]
-> Map Word a
-> Int
-> [(Word, Int, Word)]
-> ([(Word, Int, Word)], Map Word a)
interpret [Word]
wrds Map Word a
nm Int
i [(Word, Int, Word)]
acc = if Int
height Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
i then [Word]
-> Map Word a
-> Int
-> [(Word, Int, Word)]
-> ([(Word, Int, Word)], Map Word a)
interpret [Word]
new_front Map Word a
new_m (Int
i Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1) [(Word, Int, Word)]
acc_apply else ([(Word, Int, Word)]
acc, Map Word a
nm)
                    where
                        ([(Word, Int, Word)]
acc_apply, Map Word a
new_m, [Word]
new_front) = [Word]
-> [[SRule]]
-> Map Word a
-> [Word]
-> [(Word, Int, Word)]
-> ([(Word, Int, Word)], Map Word a, [Word])
forall a.
Num a =>
[Word]
-> [[SRule]]
-> Map Word a
-> [Word]
-> [(Word, Int, Word)]
-> ([(Word, Int, Word)], Map Word a, [Word])
applyRss [Word]
wrds ([SRule] -> [Word] -> [[SRule]]
getApplicableRules [SRule]
symmSmRules [Word]
wrds) Map Word a
nm [] [(Word, Int, Word)]
acc

            let ([(Word, Int, Word)]
acc, Map Word Int
nm) = [Word]
-> Map Word Int
-> Int
-> [(Word, Int, Word)]
-> ([(Word, Int, Word)], Map Word Int)
forall a.
Num a =>
[Word]
-> Map Word a
-> Int
-> [(Word, Int, Word)]
-> ([(Word, Int, Word)], Map Word a)
interpret [Word
startWord] Map Word Int
m Int
0 []
            let m_nodes :: Map Word Int
m_nodes = (Int, Map Word Int) -> Map Word Int
forall a b. (a, b) -> b
snd ((Int, Map Word Int) -> Map Word Int)
-> (Int, Map Word Int) -> Map Word Int
forall a b. (a -> b) -> a -> b
$ (Int -> Int -> (Int, Int))
-> Int -> Map Word Int -> (Int, Map Word Int)
forall a b c k. (a -> b -> (a, c)) -> a -> Map k b -> (a, Map k c)
Map.mapAccum (\Int
a Int
_ -> (Int
a Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1, Int
a)) Int
1 Map Word Int
nm
            let get_node :: Word -> Int
get_node Word
w = Maybe Int -> Int
forall a. HasCallStack => Maybe a -> a
fromJust (Maybe Int -> Int) -> Maybe Int -> Int
forall a b. (a -> b) -> a -> b
$ Word -> Map Word Int -> Maybe Int
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup Word
w Map Word Int
m_nodes
            let g :: Gr Word Int
g = [LNode Word] -> [LEdge Int] -> Gr Word Int
forall (gr :: * -> * -> *) a b.
Graph gr =>
[LNode a] -> [LEdge b] -> gr a b
mkGraph (((Word, Int) -> LNode Word) -> [(Word, Int)] -> [LNode Word]
forall a b. (a -> b) -> [a] -> [b]
map (Word, Int) -> LNode Word
forall a b. (a, b) -> (b, a)
swap ([(Word, Int)] -> [LNode Word]) -> [(Word, Int)] -> [LNode Word]
forall a b. (a -> b) -> a -> b
$ Map Word Int -> [(Word, Int)]
forall k a. Map k a -> [(k, a)]
Map.toList Map Word Int
m_nodes)
                                (((Word, Int, Word) -> LEdge Int)
-> [(Word, Int, Word)] -> [LEdge Int]
forall a b. (a -> b) -> [a] -> [b]
map (\(Word
from_part, Int
rule_i, Word
to_part) -> (Word -> Int
get_node Word
from_part, Word -> Int
get_node Word
to_part, Int
rule_i)) [(Word, Int, Word)]
acc)
            (Gr Word Int
g, Map Word Int
nm)