module NLP.Partage.Auto.Set
(
fromGram
) where
import Control.Applicative ((<$>))
import Control.Monad (forM)
import qualified Control.Monad.State.Strict as E
import Data.List (foldl')
import Data.Maybe (maybeToList)
import qualified Data.Set as S
import qualified Data.Map.Strict as M
import Data.DAWG.Ord (ID)
import NLP.Partage.FactGram
( FactGram, Lab(..), Rule(..) )
import qualified NLP.Partage.Auto as A
shell :: (Ord a) => AutoSet a -> A.Auto a
shell AutoSet{..} = A.Auto
{ roots = S.fromList
. map unExID
. S.toList $ rootSet
, follow = \e x -> do
(autoID, i) <- M.lookup (ExID e) fromExID
auto <- M.lookup autoID autoMap
j <- A.follow auto i x
unExID <$> M.lookup (autoID, j) toExID
, edges = \e -> do
let mtl = maybeToList
(autoID, i) <- mtl $ M.lookup (ExID e) fromExID
auto <- mtl $ M.lookup autoID autoMap
(x, j) <- A.edges auto i
e' <- mtl $ M.lookup (autoID, j) toExID
return (x, unExID e')
}
fromGram
:: (Ord n, Ord t)
=> (FactGram n t -> A.GramAuto n t)
-> FactGram n t
-> A.GramAuto n t
fromGram mkOne = shell . buildAutoSet mkOne
newtype ExID = ExID { unExID :: ID }
deriving (Show, Eq, Ord)
newtype AutoID = AutoID { _unAutoID :: ID }
deriving (Show, Eq, Ord)
data AutoSet a = AutoSet
{ autoMap :: M.Map AutoID (A.Auto a)
, rootSet :: S.Set ExID
, fromExID :: M.Map ExID (AutoID, ID)
, toExID :: M.Map (AutoID, ID) ExID
}
emptyAS :: AutoSet a
emptyAS = AutoSet M.empty S.empty M.empty M.empty
unionAS :: AutoSet a -> AutoSet a -> AutoSet a
unionAS p q = AutoSet
{ autoMap = M.union (autoMap p) (autoMap q)
, rootSet = S.union (rootSet p) (rootSet q)
, fromExID = M.union (fromExID p) (fromExID q)
, toExID = M.union (toExID p) (toExID q) }
unionsAS :: [AutoSet a] -> AutoSet a
unionsAS = foldl' unionAS emptyAS
buildAutoSet
:: (Ord n, Ord t)
=> (FactGram n t -> A.GramAuto n t)
-> FactGram n t
-> AutoSet (A.Edge (Lab n t))
buildAutoSet mkOne gram = runM $
unionsAS <$> sequence
[ mkAutoSet
(AutoID autoID)
(mkOne ruleSet)
| (autoID, ruleSet)
<- zip [0..] (M.elems gramByHead) ]
where
gramByHead = M.fromListWith S.union
[ (headR r, S.singleton r)
| r <- S.toList gram ]
mkAutoSet autoID auto = do
rootMap <- mkNodeMap (A.roots auto)
descMap <- mkNodeMap (A.allIDs auto S.\\ A.roots auto)
let nodeMap = rootMap `M.union` descMap
return AutoSet
{ autoMap = M.singleton autoID auto
, rootSet = M.keysSet rootMap
, fromExID = nodeMap
, toExID = rev1to1 nodeMap }
where
mkNodeMap inNodeSet = fmap M.fromList $
forM (S.toList inNodeSet) $ \i -> do
e <- newExID
return (e, (autoID, i))
runM = flip E.evalState (0 :: Int)
newExID = E.state $ \k -> (ExID k, k + 1)
rev1to1 = M.fromList . map swap . M.toList
swap (x, y) = (y, x)