{- |
Module      :  ./OWL2/Taxonomy.hs
Description :  Taxonomy extraction for OWL
Copyright   :  (c) Dominik Luecke, Uni Bremen 2008
License     :  GPLv2 or higher, see LICENSE.txt

Maintainer  :  luecke@informatik.uni-bremen.de
Stability   :  provisional
Portability :  portabl

Taxonomy extraction for OWL
-}

module OWL2.Taxonomy ( onto2Tax ) where

import OWL2.Sign
import OWL2.ManchesterPrint
import OWL2.ProvePellet

import Common.AS_Annotation
import Common.Result
import Taxonomy.MMiSSOntology
import Common.Taxonomy
import Common.Utils

import OWL2.AS

import System.IO.Unsafe

import qualified Data.Foldable as Fold
import qualified Common.Lib.Rel as Rel
import qualified Data.Map as Map
import Data.List

import qualified Data.Set as Set
import qualified Control.Monad.Fail as Fail

-- | Derivation of an Taxonomy for OWL
onto2Tax :: TaxoGraphKind
         -> MMiSSOntology
         -> Sign -> [Named Axiom]
         -> Result MMiSSOntology
onto2Tax :: TaxoGraphKind
-> MMiSSOntology -> Sign -> [Named Axiom] -> Result MMiSSOntology
onto2Tax gk :: TaxoGraphKind
gk inOnto :: MMiSSOntology
inOnto sig :: Sign
sig sens :: [Named Axiom]
sens = case TaxoGraphKind
gk of
  KSubsort -> String -> Result MMiSSOntology
forall (m :: * -> *) a. MonadFail m => String -> m a
Fail.fail "Dear user, this logic is single sorted, sorry!"
  KConcept -> do
    String
cs <- IO (Result String) -> Result String
forall a. IO a -> a
unsafePerformIO (IO (Result String) -> Result String)
-> IO (Result String) -> Result String
forall a b. (a -> b) -> a -> b
$ Sign -> [Named Axiom] -> IO (Result String)
runClassifier Sign
sig [Named Axiom]
sens
    [Rel String]
tree <- String -> Result [Rel String]
relBuilder String
cs
    let subRel :: Rel String
subRel = Rel String -> Rel String
forall a. Ord a => Rel a -> Rel a
Rel.transReduce (Rel String -> Rel String) -> Rel String -> Rel String
forall a b. (a -> b) -> a -> b
$ (Rel String -> Rel String -> Rel String)
-> Rel String -> [Rel String] -> Rel String
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl Rel String -> Rel String -> Rel String
forall a. Ord a => Rel a -> Rel a -> Rel a
Rel.union Rel String
forall a. Rel a
Rel.empty [Rel String]
tree
        superRel :: Rel String
superRel = Rel String -> Rel String
forall a. Ord a => Rel a -> Rel a
Rel.irreflex (Rel String -> Rel String) -> Rel String -> Rel String
forall a b. (a -> b) -> a -> b
$ Rel String -> Rel String
forall a. Ord a => Rel a -> Rel a
Rel.transpose Rel String
subRel
        superMap :: Map String (Set String)
superMap = Rel String -> Map String (Set String)
forall a. Rel a -> Map a (Set a)
Rel.toMap Rel String
superRel
        classes :: [String]
classes = Set String -> [String]
forall a. Set a -> [a]
Set.toList (Set String -> [String]) -> Set String -> [String]
forall a b. (a -> b) -> a -> b
$ ((String, String) -> String) -> Set (String, String) -> Set String
forall b a. Ord b => (a -> b) -> Set a -> Set b
Set.map (String, String) -> String
forall a b. (a, b) -> a
fst (Set (String, String) -> Set String)
-> Set (String, String) -> Set String
forall a b. (a -> b) -> a -> b
$ Rel String -> Set (String, String)
forall a. Ord a => Rel a -> Set (a, a)
Rel.toSet Rel String
subRel
    MMiSSOntology
-> Map String (Set String) -> [String] -> Result MMiSSOntology
makeMiss MMiSSOntology
inOnto Map String (Set String)
superMap [String]
classes

dropClutter :: String -> String
dropClutter :: String -> String
dropClutter = String -> String -> String
tryToStripPrefix "unamed:"

-- | Generation of a MissOntology
makeMiss :: MMiSSOntology
         -> Map.Map String (Set.Set String)
         -> [String]
         -> Result MMiSSOntology
makeMiss :: MMiSSOntology
-> Map String (Set String) -> [String] -> Result MMiSSOntology
makeMiss o :: MMiSSOntology
o r :: Map String (Set String)
r =
  (MMiSSOntology -> String -> Result MMiSSOntology)
-> MMiSSOntology -> [String] -> Result MMiSSOntology
forall (t :: * -> *) (m :: * -> *) b a.
(Foldable t, Monad m) =>
(b -> a -> m b) -> b -> t a -> m b
Fold.foldlM (\ x :: MMiSSOntology
x y :: String
y -> WithError MMiSSOntology -> Result MMiSSOntology
forall (m :: * -> *) a. MonadFail m => WithError a -> m a
fromWithError (WithError MMiSSOntology -> Result MMiSSOntology)
-> WithError MMiSSOntology -> Result MMiSSOntology
forall a b. (a -> b) -> a -> b
$ MMiSSOntology
-> String
-> String
-> [String]
-> Maybe ClassType
-> WithError MMiSSOntology
insertClass MMiSSOntology
x (String -> String
dropClutter String
y) ""
                (case String -> Map String (Set String) -> Maybe (Set String)
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup String
y Map String (Set String)
r of
                   Nothing -> []
                   Just z :: Set String
z -> Set String -> [String]
forall a. Set a -> [a]
Set.toList (Set String -> [String]) -> Set String -> [String]
forall a b. (a -> b) -> a -> b
$ (String -> String) -> Set String -> Set String
forall b a. Ord b => (a -> b) -> Set a -> Set b
Set.map String -> String
dropClutter Set String
z
                ) Maybe ClassType
forall a. Maybe a
Nothing) MMiSSOntology
o

-- | Builder for all relations
relBuilder :: String
           -> Result [Rel.Rel String]
relBuilder :: String -> Result [Rel String]
relBuilder tr :: String
tr =
  let ln :: [String]
ln = (String -> Bool) -> [String] -> [String]
forall a. (a -> Bool) -> [a] -> [a]
filter (Bool -> Bool
not (Bool -> Bool) -> (String -> Bool) -> String -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null) ([String] -> [String]) -> [String] -> [String]
forall a b. (a -> b) -> a -> b
$ String -> [String]
lines String
tr in
  if (String -> Bool) -> [String] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (String -> String -> Bool
forall a. Eq a => [a] -> [a] -> Bool
isPrefixOf "ERROR: ") [String]
ln Bool -> Bool -> Bool
|| [String] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [String]
ln then
    String -> Result [Rel String]
forall (m :: * -> *) a. MonadFail m => String -> m a
Fail.fail "Classification via Pellet failed! Ontology might be inconsistent!"
    else [Rel String] -> Result [Rel String]
forall (m :: * -> *) a. Monad m => a -> m a
return ([Rel String] -> Result [Rel String])
-> [Rel String] -> Result [Rel String]
forall a b. (a -> b) -> a -> b
$ ([String] -> Rel String) -> [[String]] -> [Rel String]
forall a b. (a -> b) -> [a] -> [b]
map [String] -> Rel String
relBuild ([[String]] -> [Rel String]) -> [[String]] -> [Rel String]
forall a b. (a -> b) -> a -> b
$ [String] -> [[String]]
splitter ([String] -> [[String]]) -> [String] -> [[String]]
forall a b. (a -> b) -> a -> b
$ (String -> String) -> [String] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map String -> String
forall a. [a] -> [a]
tail [String]
ln

-- | splitter for output
splitter :: [String] -> [[String]]
splitter :: [String] -> [[String]]
splitter ls :: [String]
ls = case [String]
ls of
  [] -> []
  (h :: String
h : t :: [String]
t) -> let (l :: [String]
l, r :: [String]
r) = (String -> Bool) -> [String] -> ([String], [String])
forall a. (a -> Bool) -> [a] -> ([a], [a])
span (\ x :: String
x -> String -> Char
forall a. [a] -> a
head String
x Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== ' ') [String]
t in (String
h String -> [String] -> [String]
forall a. a -> [a] -> [a]
: [String]
l) [String] -> [[String]] -> [[String]]
forall a. a -> [a] -> [a]
: [String] -> [[String]]
splitter [String]
r

-- | builder for a single relation
relBuild :: [String]
         -> Rel.Rel String
relBuild :: [String] -> Rel String
relBuild s :: [String]
s = case [String]
s of
  [] -> Rel String
forall a. Rel a
Rel.empty
  (t :: String
t : ts :: [String]
ts) ->
    let nt :: [String]
nt = (String -> String) -> [String] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map (Int -> String -> String
forall a. Int -> [a] -> [a]
drop 3) [String]
ts
        children :: [[String]]
children = [String] -> [[String]]
splitter [String]
nt
        ch :: Rel String
ch = (Rel String -> Rel String -> Rel String)
-> Rel String -> [Rel String] -> Rel String
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl Rel String -> Rel String -> Rel String
forall a. Ord a => Rel a -> Rel a -> Rel a
Rel.union Rel String
forall a. Rel a
Rel.empty ([Rel String] -> Rel String) -> [Rel String] -> Rel String
forall a b. (a -> b) -> a -> b
$ ([String] -> Rel String) -> [[String]] -> [Rel String]
forall a b. (a -> b) -> [a] -> [b]
map [String] -> Rel String
relBuild [[String]]
children
        suc :: [String]
suc = ([String] -> String) -> [[String]] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map [String] -> String
forall a. [a] -> a
head [[String]]
children
    in String -> Rel String -> Rel String
forall a. Ord a => a -> Rel a -> Rel a
Rel.insertKey String
t (Rel String -> Rel String) -> Rel String -> Rel String
forall a b. (a -> b) -> a -> b
$ [(String, String)] -> Rel String
forall a. Ord a => [(a, a)] -> Rel a
Rel.fromList ([String] -> [String] -> [(String, String)]
forall a b. [a] -> [b] -> [(a, b)]
zip (String -> [String]
forall a. a -> [a]
repeat String
t) [String]
suc) Rel String -> Rel String -> Rel String
forall a. Ord a => Rel a -> Rel a -> Rel a
`Rel.union` Rel String
ch

-- | Invocation of Pellet
-- TODO: commented out in 1993
runClassifier :: Sign -> [Named Axiom] -> IO (Result String)
runClassifier :: Sign -> [Named Axiom] -> IO (Result String)
runClassifier sig :: Sign
sig sen :: [Named Axiom]
sen = do
  let th :: String
th = Doc -> String
forall a. Show a => a -> String
show (Doc -> String) -> Doc -> String
forall a b. (a -> b) -> a -> b
$ (Sign, [Named Axiom]) -> Doc
printOWLBasicTheory (Sign
sig, (Named Axiom -> Bool) -> [Named Axiom] -> [Named Axiom]
forall a. (a -> Bool) -> [a] -> [a]
filter Named Axiom -> Bool
forall s a. SenAttr s a -> Bool
isAxiom [Named Axiom]
sen)
      tLimit :: Int
tLimit = 800
  Maybe (Bool, String, String)
res <- String
-> String
-> String
-> Maybe String
-> Int
-> IO (Maybe (Bool, String, String))
runTimedPellet "classify" "PelletClassifier" String
th Maybe String
forall a. Maybe a
Nothing Int
tLimit
  Result String -> IO (Result String)
forall (m :: * -> *) a. Monad m => a -> m a
return (Result String -> IO (Result String))
-> Result String -> IO (Result String)
forall a b. (a -> b) -> a -> b
$ case Maybe (Bool, String, String)
res of
    Nothing -> String -> Result String
forall (m :: * -> *) a. MonadFail m => String -> m a
Fail.fail (String -> Result String) -> String -> Result String
forall a b. (a -> b) -> a -> b
$ "Timeout after " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show Int
tLimit String -> String -> String
forall a. [a] -> [a] -> [a]
++ " seconds!"
    Just (progTh :: Bool
progTh, out :: String
out, _) ->
      if Bool
progTh then String -> Result String
forall (m :: * -> *) a. Monad m => a -> m a
return String
out else String -> Result String
forall (m :: * -> *) a. MonadFail m => String -> m a
Fail.fail "Pellet not found"
-- runClassifier :: Sign -> [Named Axiom] -> IO (Result String)
-- runClassifier _ _ = return $ return []