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)