{-# OPTIONS_GHC -Wall #-} -- $Id: GuptaNishimura.hs 1260 2011-06-14 15:18:21Z bash $ module HarmTrace.Matching.GuptaNishimura where -------------------------------------------------------------------------------- -- Finding the Largest Common Embedable Subtrees (LCES) -- Based on: Gupta, A. and Nishimura, N. (1998) Finding largest subtrees and -- smallest supertrees, Algorithmica, 21(2), p. 183--210 -- author: Bas de Haas -------------------------------------------------------------------------------- import Data.Ord import Data.Maybe import Data.Array import Data.List import HarmTrace.Matching.Tree -------------------------------------------------------------------------------- -- Top Level LCES function -------------------------------------------------------------------------------- -- Top level function that returns the largest common embedable subtree -- of two trees getLCES :: (Eq t) => Tree t -> Tree t -> [Tree t] getLCES ta tb = matchToTree ta (map fst (reverse m)) where n = lces ta tb (m,_) = n!b (_,b) = bounds n -- calculates the largest labeled common embeddable subtree lces :: (Eq t) => Tree t -> Tree t -> Array (Int, Int) ([(Int,Int)], Int) lces ta tb = n where la = size ta-1 lb = size tb-1 a = listArray (0,la) (pot ta) b = listArray (0,lb) (pot tb) maxi :: Int -> [Int] -> ([(Int,Int)],Int) maxi _ [] = ([],0) maxi i cb = {-# SCC "maxi_lces" #-}n!(i,maximumBy (comparing (\j -> getWeight $ n!(i,j))) cb ) maxj :: [Int] -> Int -> ([(Int,Int)],Int) maxj [] _ = ([],0) maxj ca j = {-# SCC "maxi_lces" #-}n!( maximumBy (comparing (\i -> getWeight $ n!(i,j))) ca,j) recur i j = findBestMatch (getLabel (a!i) == getLabel (b!j))i j mc mi mj where mi = maxi i (getChildPns (b!j)) mj = maxj (getChildPns (a!i)) j mc = wbMatch (getChild (a!i)) (getChild $ b!j) n n = array ((0,0), (la, lb)) (((0,0), if getLabel (a!0)==getLabel (b!0) then ([(0,0)],1) else ([],0)) : [((0,j), recur 0 j) | j <- [1..lb]] ++ [((i,0), recur i 0) | i <- [1..la]] ++ [((i,j), recur i j) | i <- [1..la], j <- [1..lb]]) -- returns the best matching candidate, given the previous candidates, the -- bipartite matching. The function depends on wheter the currend nodes -- match and wether, in that case, on of the current nodes is not allready -- matched findBestMatch :: Bool -> Int -> Int -> ([(Int,Int)], Int) -> ([(Int,Int)], Int) -> ([(Int,Int)], Int) -> ([(Int,Int)], Int) findBestMatch match i j a b c | not match = first | otherwise = if isFree first i j then ((i,j):mf,wf+1) --add match else if wf /= ws then first else if isFree second i j then ((i,j):ms,ws+1) else if wf /= wt then first else if isFree second i j then ((i,j):mt,wt+1) else first where (first@(mf,wf) : second@(ms,ws) : (mt,wt) : []) = {- SCC sorting -} reverse $ sortBy (comparing getWeight) [a,b,c] -------------------------------------------------------------------------------- -- Weighted Plannar Matching of a Bipartite Graph -------------------------------------------------------------------------------- -- selects the most lower right cell in the wbMatch' matrix wbMatch :: (Eq t) => [Tree t] -> [Tree t] -> Array (Int, Int) ([(Int, Int)], Int) -> ([(Int, Int)], Int) wbMatch _ [] _ = ([],0) wbMatch [] _ _ = ([],0) wbMatch a b n = getDownRight $ wbMatch' a b n -- returns the actual planar weighted bipartite matchings. n should contain -- the weights of the edge between a[i] and b[j] wbMatch' :: (Eq t) => [Tree t] -> [Tree t] -> Array (Int, Int) ([(Int,Int)], Int) -> Array (Int, Int) ([(Int,Int)], Int) wbMatch' _ [] _ = {-# SCC "listArrayA" #-} listArray ((0,0),(0,0)) [] wbMatch' [] _ _ = {-# SCC "listArrayB" #-} listArray ((0,0),(0,0)) [] wbMatch' a b n = m where la = length a-1 lb = length b-1 -- returns a previously matched subtree subTree :: Int -> Int -> ([(Int,Int)], Int) subTree i j = n ! (fromJust . getPn $ a!!i, fromJust . getPn $ b!!j) -- this is the actual core recursive definintion of the algorithm match :: Int -> Int -> ([(Int,Int)], Int) match i j = maximumBy (comparing getWeight) [maxPrv, minPrv, diagM] where s@(_mat,w) = subTree i j hasMatch = w > 0 maxPrv = if not hasMatch then m!(i-1,j) else if isFree (m!(i-1,j)) i j then merge s (m!(i-1,j)) else m!(i-1,j) minPrv = if not hasMatch then m!(i,j-1) else if isFree (m!(i,j-1)) i j then merge s (m!(i,j-1)) else m!(i,j-1) diagM = merge s (m!(i-1,j-1)) m = array ((0,0),(la,lb)) (((0,0), subTree 0 0) : [((0,j), if getWeight (subTree 0 j) > getWeight (m!(0,j-1)) then subTree 0 j else m!(0,j-1)) | j <- [1..lb]] ++ [((i,0), if getWeight (subTree i 0) > getWeight (m!(i-1,0)) then subTree i 0 else m!(i-1,0)) | i <- [1..la]] ++ [((i,j), match i j) | i <- [1..la], j <- [1..lb]]) -------------------------------------------------------------------------------- -- Some LCES helper functions -------------------------------------------------------------------------------- getDownRight :: (Ix i) => Array i e -> e getDownRight n = n ! snd (bounds n) -- returns the weight of a match and is synonymous to snd getWeight :: (a, b) -> b getWeight (_,w) = w -- returns the list with matches and is synonymous to fst getMatch :: ([a], b) -> [a] getMatch (m,_) = m -- checks if the previously calculated optimal solution does not -- contain the indices i and j in a and b, resepectivly isFree :: ([(Int,Int)], Int) -> Int -> Int -> Bool isFree ([],_) _ _ = True isFree ((previ, prevj):_,_) i j = ( i > previ && j > prevj) -- mergest two lists with matches merge :: ([a], Int) -> ([a], Int) -> ([a], Int) merge (a, wa) (b, wb) = (a ++ b, wa + wb) -- adds a match to a list of matches -- addMatch :: (Int, Int) -> ([(Int, Int)], Int) -> ([(Int, Int)], Int) -- addMatch (i,j) (a, w)= ((i,j):a, w+1)