[first matching implementation
martin.hofmann@uni-bamberg.de**20090506152619] hunk ./src/RuleDevelopment/Matching.hs 4
+import qualified Data.Map as M
+import Data.List
+import Data.Function (on)
+import Data.Maybe (catMaybes)
+import Control.Monad
+import Control.Monad.Trans
+
hunk ./src/RuleDevelopment/Matching.hs 12
+import Data.Rules 
+import Syntax
+import Language.Haskell.TH
+import Syntax.Unifier
hunk ./src/RuleDevelopment/Matching.hs 17
+import Data.CallDependencies
hunk ./src/RuleDevelopment/Matching.hs 20
-introduceMatchings _ rf = do 
-    covcruls <- breakupM $ rf
-    return []
+introduceMatchings cd cr = do
+    iod      <- getEvidence
+    liftM concat $ mapM (computeMatchings cr) (allowdCs iod)
+    
+    where
+    subcalls    = allowedMaxCall (name cr) cd
+    bckgcalls i =  map (flip (,) (Just GT)) (background i)
+    allowdCs i  =  M.toList $ foldl (flip $ uncurry M.insert) subcalls (bckgcalls i)
+
+computeMatchings :: CovrRule -> (Name, Maybe Ordering) -> IM [(CovrRules,[Call])]
+computeMatchings _ (_, Nothing) =  return [] -- no call allowed
+computeMatchings cr (n, Just o) = do
+     tgtrs <- breakupM $ cr
+     cllrs <- liftM (getAll n) getEvidence
+     cllios <- liftM oneFromEachCol $ makeIOMatrix tgtrs o cllrs
+     mapM (makeCall cr n) $ cllios
+
+-- TODO: should return a Maybe, because matching may fail intendedly, need to catch this here
+makeCall :: CovrRule -> Name -> [(Ordering, [Rule])] -> IM (CovrRules,[Call])
+makeCall cr tgtn ios = do
+    let subargsio = transpose $ map snd ios
+    subfns  <- mapM (addIO.rules) subargsio
+    let subftys = map (typeOf.rhs.head) subargsio
+    let subcalls = map (\(n,ty) -> mkCall n ty (lhs.crul $ cr)) (zip subfns subftys)
+    let cr' = modifycrul cr $ mkCallAt (Body Root) tgtn subcalls 
+    subinis <- mapM (\n -> liftM (fuse.(getAll n)) getEvidence) subfns
+    let tgtcall = ((name cr),tgtn, maximum (map fst ios))
+    let subcalls = map (\n -> (tgtn,n,EQ)) subfns
+    return (covrRules (cr':subinis),tgtcall:subcalls)
+     
+    
+{- | For n rules of the target function (t = [t1 .. tn]) and m rules of the function
+     to call (c =  [c1 .. cn]), the cross-product ( t * c) is generated as a 
+     list of collumns 
+     
+        [[t1c1  [t1c2  ... [t1cn
+         ,t2c1  ,t2c2  ... ,t2cn
+         ,...   ,...   ... ,...
+         ,tnc1] ,tnc2] ... ,tncn]]
+     
+     where each 'ticj' is a list of rules resulting from @abduceIO ti o cj@. 
+
+-}
+makeIOMatrix :: [CovrRule] -> Ordering -> [CovrRule] -> IM [[(Ordering, [Rule])]]
+makeIOMatrix tgtrs o cllrs = 
+    sequence [ liftM catMaybes $ sequence $ [abduceIO t o c | t <- tgtrs] | c <- cllrs ]
+
+oneFromEachCol []    = [[]]
+oneFromEachCol (x:xs)= [e:es | e <- x, es <- (oneFromEachCol xs)]
+   
+-- | @abduceIO tgt o cll@ abduces one IO pair for each argument of 'tgt' if 
+--   admissible. It is not admissible to call 'cll' from 'tgt' if the difference
+--   in size of the lhss of 'tgt' and 'cll' is greater than the max difference 
+--   'o'.       
+abduceIO :: CovrRule -> Ordering ->  CovrRule -> IM (Maybe (Ordering, [Rule]))
+abduceIO tgt o cll = do
+    let callrel = on compare (lhs.crul) tgt cll 
+    if o < callrel then return Nothing
+      else do s <- lift $ on matchesWithSubs (rhs.crul) tgt cll
+              let cllvars = (concatMap getVars (lhs.crul $ cll))
+              let unaffectedvars = cllvars \\ (map fst s)
+              let s' = s ++ [ v <~ (TWildE n t) | v@(TVarE n t) <- unaffectedvars]
+              -- replace all vars not in the substitution by wildcards 
+              let lhss' = lhs.crul $ cll
+              rhss' <- lift $ mapM (apply s') (lhs.crul $ tgt)  
+              -- new rhss are the substituted lhss of tgt
+              return.Just $ (callrel, map (rule lhss') rhss')