module NLP.GenI.GeniVal where
import Control.Arrow (first, (***))
import Control.Monad (liftM)
import Data.List
import Data.Maybe (fromMaybe, isJust)
import Data.Generics (Data)
import Data.Typeable (Typeable)
import qualified Data.Map as Map
import Test.HUnit
import Test.QuickCheck hiding (collect)
import Test.Framework
import Test.Framework.Providers.HUnit
import Test.Framework.Providers.QuickCheck
import Data.Generics.PlateDirect
import Control.Parallel.Strategies
import NLP.GenI.General (geniBug)
data GeniVal = GConst [String]
| GVar String
| GAnon
deriving (Eq,Ord, Data, Typeable)
instance Uniplate GeniVal where
uniplate x = (Zero, \Zero -> x)
instance Show GeniVal where
show (GConst x) = concat $ intersperse "|" x
show (GVar x) = '?':x
show GAnon = "?_"
isConst :: GeniVal -> Bool
isConst (GConst _) = True
isConst _ = False
isVar :: GeniVal -> Bool
isVar (GVar _) = True
isVar _ = False
isAnon :: GeniVal -> Bool
isAnon GAnon = True
isAnon _ = False
fromGConst :: GeniVal -> [String]
fromGConst (GConst x) = x
fromGConst x = error ("fromGConst on " ++ show x)
fromGVar :: GeniVal -> String
fromGVar (GVar x) = x
fromGVar x = error ("fromGVar on " ++ show x)
type Subst = Map.Map String GeniVal
unify :: Monad m => [GeniVal] -> [GeniVal] -> m ([GeniVal], Subst)
unify l1 l2 = repropagate `liftM` helper l1 l2
where
repropagate (xs, sub) = (replace sub xs, sub)
helper [] l2 = return (l2, Map.empty)
helper l1 [] = return (l1, Map.empty)
helper (h1:t1) (h2:t2) =
case unifyOne h1 h2 of
Failure -> fail $ "unification failure between " ++ show h1 ++ " and " ++ show h2
SuccessRep v g -> prepend `liftM` helper t1b t2b
where
s = (v,g)
t1b = replaceOne s t1
t2b = replaceOne s t2
prepend = (g:) *** prependToSubst s
SuccessSans g -> first (g:) `liftM` helper t1 t2
mergeSubst :: Subst -> Subst -> Subst
mergeSubst sm1 sm2 = Map.foldWithKey (curry prependToSubst) sm2 sm1
prependToSubst :: (String,GeniVal) -> Subst -> Subst
prependToSubst (v, gr@(GVar r)) sm =
case Map.lookup v sm of
Just v2 -> geniBug . unlines $
[ "prependToSubst: GenI just tried to prepend the substitution"
, " " ++ show (GVar v) ++ " -> " ++ show gr
, "to one where where "
, " " ++ show (GVar v) ++ " -> " ++ show v2
, "is slated to occur afterwards."
, ""
, "This could mean that either"
, " (a) the core unification algorithm is broken"
, " (b) we failed to propagate a value somewhere or"
, " (c) we are attempting unification without renaming."
]
Nothing -> Map.insert v gr2 sm
where gr2 = fromMaybe gr $ Map.lookup r sm
prependToSubst (v, gr) sm = Map.insert v gr sm
data UnificationResult = SuccessSans GeniVal
| SuccessRep String GeniVal
| Failure
unifyOne :: GeniVal -> GeniVal -> UnificationResult
unifyOne g GAnon = SuccessSans g
unifyOne GAnon g = SuccessSans g
unifyOne (GVar v) gc@(GConst _) = SuccessRep v gc
unifyOne gc@(GConst _) (GVar v) = SuccessRep v gc
unifyOne (GConst v1) (GConst v2) =
case v1 `intersect` v2 of
[] -> Failure
newV -> SuccessSans (GConst newV)
unifyOne x1@(GVar v1) (GVar v2) =
if v1 == v2
then SuccessSans x1
else SuccessRep v2 x1
replace :: DescendGeniVal a => Subst -> a -> a
replace m | Map.null m = id
replace m = descendGeniVal (replaceMapG m)
replaceOne :: DescendGeniVal a => (String, GeniVal) -> a -> a
replaceOne = descendGeniVal . replaceOneG
replaceList :: DescendGeniVal a => [(String,GeniVal)] -> a -> a
replaceList = replace . foldl' update Map.empty
where
update m (s1,s2) = Map.insert s1 s2 $ Map.map (replaceOne (s1,s2)) m
replaceMapG :: Subst -> GeniVal -> GeniVal
replaceMapG m v@(GVar v_) = Map.findWithDefault v v_ m
replaceMapG _ v = v
replaceOneG :: (String, GeniVal) -> GeniVal -> GeniVal
replaceOneG (s1, s2) (GVar v_) | v_ == s1 = s2
replaceOneG _ v = v
instance NFData GeniVal
where rnf (GConst x1) = rnf x1
rnf (GVar x1) = rnf x1
rnf (GAnon) = ()
class DescendGeniVal a where
descendGeniVal :: (GeniVal -> GeniVal) -> a -> a
instance DescendGeniVal GeniVal where
descendGeniVal f = f
instance (Functor f, DescendGeniVal a) => DescendGeniVal (f a) where
descendGeniVal = fmap . descendGeniVal
testSuite = testGroup "unification"
[ testProperty "self" prop_unify_sym
, testProperty "anonymous variables" prop_unify_anon
, testProperty "symmetry" prop_unify_sym
, testBackPropagation
]
prop_unify_self :: [GeniVal] -> Property
prop_unify_self x =
(all qc_not_empty_GConst) x ==>
case unify x x of
Nothing -> False
Just unf -> fst unf == x
prop_unify_anon :: [GeniVal] -> Bool
prop_unify_anon x =
case unify x y of
Nothing -> False
Just unf -> fst unf == x
where
y = replicate (length x) GAnon
prop_unify_sym :: [GeniVal] -> [GeniVal] -> Property
prop_unify_sym x y =
let u1 = (unify x y) :: Maybe ([GeniVal],Subst)
u2 = unify y x
notOverlap (GVar _, GVar _) = False
notOverlap _ = True
in (all qc_not_empty_GConst) x &&
(all qc_not_empty_GConst) y &&
all (notOverlap) (zip x y) ==> u1 == u2
testBackPropagation =
testGroup "back propagation"
[ testCase "unify left/right" $ assertEqual "" expected $ unify left right
, testCase "unify right/left" $ assertEqual "" expected $ unify right left
]
where
n = 3
cx = GConst ["X"]
leftStrs = map show [1..n]
left = map GVar leftStrs
right = drop 1 left ++ [cx]
expected = Just (expectedResult, expectedSubst)
expectedResult = replicate n cx
expectedSubst = Map.fromList $ zip leftStrs (repeat cx)
newtype GTestString = GTestString String
newtype GTestString2 = GTestString2 String
fromGTestString :: GTestString -> String
fromGTestString (GTestString s) = s
fromGTestString2 :: GTestString2 -> String
fromGTestString2 (GTestString2 s) = s
instance Arbitrary GTestString where
arbitrary =
oneof $ map (return . GTestString) $
[ "a", "apple" , "b", "banana", "c", "carrot", "d", "durian"
, "e", "eggplant", "f", "fennel" , "g", "grape" ]
coarbitrary = error "no implementation of coarbitrary for GTestString"
instance Arbitrary GTestString2 where
arbitrary =
oneof $ map (return . GTestString2) $
[ "X", "Y", "Z", "H", "I", "J", "P", "Q", "R", "S", "T", "U" ]
coarbitrary = error "no implementation of coarbitrary for GTestString2"
instance Arbitrary GeniVal where
arbitrary = oneof [ return $ GAnon,
fmap (GVar . fromGTestString2) arbitrary,
fmap (GConst . nub . sort . map fromGTestString) arbitrary ]
coarbitrary = error "no implementation of coarbitrary for GeniVal"
qc_not_empty_GConst :: GeniVal -> Bool
qc_not_empty_GConst (GConst []) = False
qc_not_empty_GConst _ = True