[Prematching for direct call detection added
martin.hofmann@uni-bamberg.de**20090610080107] hunk ./src/Data/IgorMonad.hs 92
+getPatComparison :: IM (LHS -> LHS -> Ordering)
+getPatComparison = do
+     howCompare <- recArgComp
+     case howCompare of 
+        Linear -> return $ compareSizeLinear
+        AWise  -> return $ compareSizePairwise
+                    
hunk ./src/RuleDevelopment/Matching.hs 7
-import Data.Maybe (catMaybes, isJust)
+import Data.Maybe (catMaybes, isJust, fromJust)
hunk ./src/RuleDevelopment/Matching.hs 23
-    iod      <- getEvidence
hunk ./src/RuleDevelopment/Matching.hs 36
+-- compute
hunk ./src/RuleDevelopment/Matching.hs 44
-     llogIN (text "Matching (target,caller)" <$> pretty (tgtrs,cllrs))
-     ios <-  makeIOMatrix tgtrs o cllrs  
-     llogIN (text "Matchings" <$> (pretty ios))
-     if any null ios then llogIN (text "Insufficient matching! At least one argument didn't match at all!") >> return []
-       else mapM (makeCall cr n) $ (oneFromEachCol ios)
+     dcp    <- constantCall cr (n,o)
+     if (not.null $ dcp) 
+        then do llogIN (text "Direct Calls possible!")
+                mapM (makeDirectCall cr n) dcp
+        else do llogIN (text "Need to try matchings (target,caller)" <$> pretty (tgtrs,cllrs))
+                ios <-  makeIOMatrix tgtrs o cllrs  
+                llogIN (text "Matchings" <$> (pretty ios))
+                if any null ios then llogIN (text "Insufficient matching! At least one argument didn't match at all!\n") >> return []
+                  else mapM (makeCall cr n) $ (oneFromEachCol ios)
+
+constantCall :: CovrRule -> (Name,Ordering) -> IM [(Ordering,LHS)]
+constantCall cr (n,maxcall) = do
+     
+     smllstio   <- liftM (minimumBy (compare `on` (size.lhs.crul))) $ breakupM  cr
+     -- get the smallest (by size on lhs) covered example
+     
+     comparator <- getPatComparison
+     let admissible   = (filter (\t ->  maxcall >= (on comparator (lhs.crul) t smllstio)))
+     tgtrs     <- liftM (admissible.(getAll n)) getEvidence
+     
+     tgtlhs   <- lift $ liftM catMaybes $ mapM (on normalize crul smllstio) $ tgtrs
+     -- the LHSs of admissible target rules, renamed w.r.t. the smallest IO
+     subs       <- lift $ (on matchesLhs crul smllstio cr) `catchError`
+                            \e -> return []
+     -- get the substitution with which the smallest IO matches the pattern of
+     -- its covering rule
+     
+     cllrs       <- breakupM $ cr
+     let possiblePats = map (buildPat subs) $ tgtlhs
+     testedPats <-  mapM (testPat cllrs (lhs.crul $ cr)) possiblePats
+     return $ map (\p -> (comparator (lhs.crul $ smllstio) p,p)) $ catMaybes testedPats
+     where
+     normalize cll tgt =
+     	(matchesRhs cll tgt >>=  flip applyL (lhs  tgt) >>= return.Just) `catchError`
+          \_ -> return Nothing
+        
+     buildPat subs =  map (buildPatArg subs)
+     buildPatArg subs tgtlhs = fromJust $ mplus 
+                         (liftM fst $ find ((tgtlhs==).snd) subs) 
+                         -- either the pattern is already in the substitution
+                         -- then take it
+                         (Just $ (root tgtlhs $ buildPat subs (subterms tgtlhs)))
+                         -- or (if not) we keep the top ctor symbol and apply 
+                         -- 'buildPat' recursively to the subterms
+     testPat cllrs lp rps = do
+        let rs = map (rule lp) rps -- 
+        isok <- liftM or $ mapM ((check rs).crul) cllrs  
+        if isok then return (Just rps) else return Nothing
+     check rs cr = do
+        let rside = mapM (matchEval.lhs $ cr) rs
+        rside' <- maybe (return Nothing) (evalIO n) rside
+        return $ maybe False ( == (rhs cr)) rside'
hunk ./src/RuleDevelopment/Matching.hs 107
+    llogIN (text "Call added:" <^> (text.show $ cr'))
hunk ./src/RuleDevelopment/Matching.hs 109
-     
+
+ 
+makeDirectCall :: CovrRule -> Name -> (Ordering,LHS) -> IM (CovrRules,[Call])
+makeDirectCall cr tgtn (o,pat) = do
+    let cr' = modifycrul cr $ mkCallAt (Body Root) tgtn pat
+    let tgtcall = ((name cr),tgtn, o)
+    llogIN (text "Call added:" <^> (text.show $ cr'))
+    return (covrRules [cr'],[tgtcall])   
hunk ./src/RuleDevelopment/Matching.hs 143
-    howCompare <- recArgComp
-    let callrel = case howCompare of 
-                    Linear -> on compareSizeLinear   (lhs.crul) tgt cll
-                    AWise  -> on compareSizePairwise (lhs.crul) tgt cll
+    callrel <- liftM (\f -> on f (lhs.crul) tgt cll) getPatComparison
hunk ./src/RuleDevelopment/Matching.hs 149
-      else do s <- lift $ (liftM Just $ on (matchesWithSubs) (rhs.crul) tgt cll) `catchError`
+      else do s <- lift $ (liftM Just $ on (matchesWithSubs) (rhs.crul) cll tgt) `catchError`