module NLP.WordNet
(
module NLP.WordNet.Types,
runWordNet,
runWordNetQuiet,
runWordNetWithOptions,
initializeWordNet,
initializeWordNetWithOptions,
closeWordNet,
runs,
getOverview,
searchByOverview,
search,
lookupKey,
relatedBy,
closure,
closureOn,
meet,
meetPaths,
meetSearchPaths,
Bag(..),
emptyQueue,
emptyStack,
)
where
import Prelude hiding (catch)
import Data.Array
import GHC.Arr (unsafeIndex)
import GHC.Handle
import Data.Tree
import Data.IORef
import Data.Dynamic
import qualified Data.Set as Set
import Numeric (readHex, readDec)
import System.IO.Unsafe
import NLP.WordNet.Common
import NLP.WordNet.Consts
import NLP.WordNet.Util
import NLP.WordNet.Types
import qualified NLP.WordNet.PrimTypes as T
import qualified NLP.WordNet.Prims as P
runWordNet :: WN a -> IO a
runWordNet = runWordNetWithOptions Nothing Nothing
runWordNetQuiet :: WN a -> IO a
runWordNetQuiet = runWordNetWithOptions Nothing (Just (\_ _ -> return ()))
runWordNetWithOptions ::
Maybe FilePath ->
Maybe (String -> Exception -> IO ()) ->
WN a ->
IO a
runWordNetWithOptions dd warn wn = do
wne <- P.initializeWordNetWithOptions dd warn
let a = let ?wne = wne in wn
return a
initializeWordNet :: IO WordNetEnv
initializeWordNet = P.initializeWordNet
initializeWordNetWithOptions :: Maybe FilePath -> Maybe (String -> Exception -> IO ()) -> IO WordNetEnv
initializeWordNetWithOptions = P.initializeWordNetWithOptions
closeWordNet :: WordNetEnv -> IO ()
closeWordNet = P.closeWordNet
runs :: WordNetEnv -> WN a -> a
runs wne x = let ?wne = wne in x
getOverview :: WN (Word -> Overview)
getOverview word = unsafePerformIO $ do
idxN <- unsafeInterleaveIO $ getOverview' Noun
idxV <- unsafeInterleaveIO $ getOverview' Verb
idxA <- unsafeInterleaveIO $ getOverview' Adj
idxR <- unsafeInterleaveIO $ getOverview' Adv
return (T.Overview idxN idxV idxA idxR)
where
getOverview' pos = do
strM <- P.getIndexString ?wne word pos
case strM of
Nothing -> return Nothing
Just s -> unsafeInterleaveIO $ P.indexLookup ?wne word pos
searchByOverview :: WN (Overview -> POS -> SenseType -> [SearchResult])
searchByOverview overview pos sense = unsafePerformIO $
case (case pos of { Noun -> T.nounIndex ; Verb -> T.verbIndex ; Adj -> T.adjIndex ; Adv -> T.advIndex })
overview of
Nothing -> return []
Just idx -> do
let numSenses = T.indexSenseCount idx
skL <- mapMaybe id `liftM`
unsafeInterleaveIO (
mapM (\sense -> do
skey <- P.indexToSenseKey ?wne idx sense
return (liftM ((,) sense) skey)
) (sensesOf numSenses sense)
)
r <- unsafeInterleaveIO $ mapM (\ (snum, skey) ->
unsafeInterleaveIO (P.getSynsetForSense ?wne skey) >>= \v ->
case v of
Nothing -> return Nothing
Just ss -> return $ Just (T.SearchResult
(Just skey)
(Just overview)
(Just idx)
(Just (SenseNumber snum))
ss)
) skL
return (mapMaybe id r)
search :: WN (Word -> POS -> SenseType -> [SearchResult])
search word pos sense = searchByOverview (getOverview word) pos sense
lookupKey :: WN (Key -> SearchResult)
lookupKey (T.Key (o,p)) = unsafePerformIO $ do
ss <- unsafeInterleaveIO $ P.readSynset ?wne p o ""
return $ T.SearchResult Nothing Nothing Nothing Nothing ss
relatedBy :: WN (Form -> SearchResult -> [SearchResult])
relatedBy form sr = map lookupKey $ srFormKeys sr form
closure :: (a -> [a]) -> a -> Tree a
closure f x = Node x (map (closure f) $ f x)
closureOn :: WN (Form -> SearchResult -> Tree SearchResult)
closureOn form = closure (relatedBy form)
class Bag b a where
emptyBag :: b a
addToBag :: b a -> a -> b a
addListToBag :: b a -> [a] -> b a
isEmptyBag :: b a -> Bool
splitBag :: b a -> (a, b a)
addListToBag = foldr (flip addToBag)
instance Bag [] a where
emptyBag = []
addToBag = flip (:)
isEmptyBag = null
splitBag (x:xs) = (x, xs)
newtype Queue a = Queue [a] deriving (Show)
instance Bag Queue a where
emptyBag = Queue []
addToBag (Queue l) a = Queue (l++[a])
isEmptyBag (Queue l) = null l
splitBag (Queue (x:xs)) = (x, Queue xs)
addListToBag (Queue l) l' = Queue (l ++ l')
emptyStack :: [a]
emptyStack = []
emptyQueue :: Queue a
emptyQueue = Queue []
meet :: Bag b (Tree SearchResult) => WN (b (Tree SearchResult) -> SearchResult -> SearchResult -> Maybe SearchResult)
meet emptyBg sr1 sr2 = srch Set.empty Set.empty (addToBag emptyBg t1) (addToBag emptyBg t2)
where
t1 = closureOn Hypernym sr1
t2 = closureOn Hypernym sr2
srch v1 v2 bag1 bag2
| isEmptyBag bag1 && isEmptyBag bag2 = Nothing
| isEmptyBag bag1 = srch v2 v1 bag2 bag1
| otherwise =
let (Node sr chl, bag1') = splitBag bag1
in if v2 `containsResult` sr
then Just sr
else srch v2 (addResult v1 sr) bag2 (addListToBag bag1' chl)
containsResult v sr = srWords sr AllSenses `Set.member` v
addResult v sr = Set.insert (srWords sr AllSenses) v
meetPaths :: Bag b (Tree SearchResult) =>
WN (
b (Tree SearchResult) ->
SearchResult ->
SearchResult ->
Maybe ([SearchResult], SearchResult, [SearchResult]))
meetPaths emptyBg sr1 sr2 = meetSearchPaths emptyBg t1 t2
where
t1 = closureOn Hypernym sr1
t2 = closureOn Hypernym sr2
meetSearchPaths emptyBg t1 t2 =
let srch b v1 v2 bag1 bag2
| isEmptyBag bag1 && isEmptyBag bag2 = Nothing
| isEmptyBag bag1 = srch (not b) v2 v1 bag2 bag1
| otherwise =
let (Node sr chl, bag1') = splitBag bag1
sl = srWords sr AllSenses
in if v2 `containsResult` sl
then Just $ if b
then (reverse v1, sr, drop 1 $ dropWhile ((/=sl) . flip srWords AllSenses) v2)
else (reverse $ drop 1 $ dropWhile ((/=sl) . flip srWords AllSenses) v2, sr, v1)
else srch (not b)
v2 (addResult v1 sr)
bag2 (addListToBag bag1' chl)
in srch True [] [] (addToBag emptyBg t1) (addToBag emptyBg t2)
where
containsResult v sl = sl `elem` map (flip srWords AllSenses) v
addResult v sr = sr:v
personTree = runWordNetQuiet (closureOn Hypernym (head $ search "person" Noun AllSenses))
organizationTree = runWordNetQuiet (closureOn Hypernym (head $ search "organization" Noun AllSenses))