{-# LANGUAGE BangPatterns, MagicHash, UnboxedTuples #-} {-| Library for using the LCM algorithm in order to compute closed frequent pattern. Input must be a transaction database, either in text format (as a ByteString) or in @[[Item]]@ format, where @Item = Int@. Several bencharking functions allowing to tune parallel strategy used and depth cutoff are also provided. -} -- HLCM -- (c) Alexandre Termier, 2009-2010 -- Original LCM algorithm from Takaki Uno and Hiroki Arimura. -- Many performance improvements thanks to Simon Marlow and Satnam Singh. -- -- Module implementing the LCM algorithm. -- -- -- See the README file for installation, usage, and details. -- See the LICENSE file for licensing. module HLCM ( Frequency, Item , runLCMstring , runLCMmatrix , benchLCM_parBuffer , benchLCM_parMap ) where ----------------------------------------------------------------- -- Imports ----------------------------------------------------------------- import Data.List import Data.Array.Unboxed import Control.Monad.ST import Data.Array.ST import Control.Parallel import Control.Parallel.Strategies import Control.Exception( evaluate ) import Data.Array.Base import Control.Monad import GHC.Exts import GHC.ST import qualified Data.List as List import qualified Data.ByteString.Char8 as L ----------------------------------------------------------------- -- Type definitions ----------------------------------------------------------------- type Item = Int type Frequency = Int type Tid = Int type Weight = Int ----------------------------------------------------------------- -- LCM functions ----------------------------------------------------------------- {-| Get the data as a long bytestring, parses it and and executes LCM to discover closed frequent itemsets. -} runLCMstring :: L.ByteString -- ^ The transaction database as a big string. Transactions are separated by newlines, items are separated by spaces -> Frequency -- ^ Minimum frequency threshold for the frequent itemsets -> [[Item]] -- ^ Output: list of closed frequent itemsets runLCMstring stringMatrix freq = let -- Load the file and convert it in the transaction database format (lexicographic tree) (transactionsLT, maxItem, antiPerm) = loadTransactionsString stringMatrix freq -- Compute occurrences for 1-itemsets occs = occurrenceDeliverLT transactionsLT maxItem in reversePerm antiPerm $ concat (parBuffer 8 rdeepseq $ (map (\x -> lcmIter 1 transactionsLT [] x (-1) occs maxItem freq) [0..maxItem]) ) {-| Get the data as a matrix of Items, parses it and and executes LCM to discover closed frequent itemsets. -} runLCMmatrix :: [[Item]] -- ^ The transaction database as matrix of items (List of List) -> Frequency -- ^ Minimum frequency threshold for the frequent itemsets -> [[Item]] -- ^ Output: list of closed frequent itemsets runLCMmatrix transMatrix freq = let -- Convert the matrix in the transaction database format (lexicographic tree) (transactionsLT, maxItem, antiPerm) = loadTransactionsMatrix transMatrix freq -- Compute occurrences for 1-itemsets occs = occurrenceDeliverLT transactionsLT maxItem in reversePerm antiPerm $ concat (parBuffer 8 rdeepseq $ (map (\x -> lcmIter 1 transactionsLT [] x (-1) occs maxItem freq) [0..maxItem]) ) {-| Use for benchmarking, parallel strategy = parBuffer by Simon Marlow. This strategy does not have space leak. /Warning: outputs are unusable as is, because items are renamed internally, and in this function the reverse renaming is not performed. It is trivial to have it back by copying the code from runLCMstring./ -} benchLCM_parBuffer :: L.ByteString -- ^ The transaction database as a big string. Transactions are separated by newlines, items are separated by spaces -> Frequency -- ^ Minimum frequency threshold for the frequent itemsets -> Int -- ^ value for parBuffer -> Int -- ^ depth for cutting parallelism -> [[Item]] -- ^ Output: list of closed frequent itemsets benchLCM_parBuffer stringMatrix freq n d = let -- Load the file and convert it in the transaction database format (lexicographic tree) (transactionsLT, maxItem, antiPerm) = loadTransactionsString stringMatrix freq -- Compute occurrences for 1-itemsets occs = occurrenceDeliverLT transactionsLT maxItem in concat (parBuffer n rdeepseq $ (map (\x -> lcmIterParBuffer 1 transactionsLT [] x (-1) occs maxItem freq n d) [0..maxItem]) ) {-| Use for benchmarking, parallel strategy = parMap from Control.Parallel.Strategies. /Warning: outputs are unusable as is, because items are renamed internally, and in this function the reverse renaming is not performed. It is trivial to have it back by copying the code from runLCMstring./ -} benchLCM_parMap :: L.ByteString -- ^ The transaction database as a big string. Transactions are separated by newlines, items are separated by spaces -> Frequency -- ^ Minimum frequency threshold for the frequent itemsets -> Int -- ^ depth for cutting parallelism -> [[Item]] -- ^ Output: list of closed frequent itemsets benchLCM_parMap stringMatrix freq d = let -- Load the file and convert it in the transaction database format (lexicographic tree) (transactionsLT, maxItem, antiPerm) = loadTransactionsString stringMatrix freq -- Compute occurrences for 1-itemsets occs = occurrenceDeliverLT transactionsLT maxItem in concat ( ((parMap rdeepseq) (\x -> lcmIterParMap 1 transactionsLT [] x (-1) occs maxItem freq d) [0..maxItem])) {-| Takes a list of itemsets and a permutation of items, an apply this permutation to the itemsets. -} reversePerm :: UArray Item Item -- ^ A permutation of items -> [[Item]] -- ^ Input list of itemsets. An itemset is a list of items, starting with its frequency. -> [[Item]] -- ^ Permuted list of itemsets. Frequency at the head of the itemset is untouched. reversePerm _ [] = [] reversePerm antiPerm (t:ts) = ((head t):(sort $ map (\it -> unsafeAt antiPerm it) (tail t))):(reversePerm antiPerm ts) {-| Loads input datase as string into a database of transactions in lexicographic tree format. Also reorders/renames the item by their frequency. The permutation between old item values and new item values is also returned. -} loadTransactionsString :: L.ByteString -- ^ Data as a long bytestring -> Frequency -- ^ Minimum support threshold -> (LexicoTreeItem, Item, UArray Item Item) -- ^ Return value : (Database, maximum item value after reduction, permutation of items) loadTransactionsString s thres = case stringToTransDB (L.lines s) of Nothing -> (Nil, -1, array (1,0) []) Just intMatrix -> let itmFrq = histogram (0, maxItem) intMatrix maxItem = maximum (concat intMatrix) (perm, antiPerm) = permut itmFrq reorderedMat = reorderMat intMatrix perm itmFrq thres maxItem' = maximum (concat reorderedMat) lexicoTree = foldr (\t lt -> insertLT t (-1) 1 lt) Nil reorderedMat in (lexicoTree, maxItem', antiPerm) {-| Loads input datase as a matrix of Items into a database of transactions in lexicographic tree format. Also reorders/renames the item by their frequency. The permutation between old item values and new item values is also returned. -} loadTransactionsMatrix :: [[Item]] -- ^ Data as a matrix of Items -> Frequency -- ^ Minimum support threshold -> (LexicoTreeItem, Item, UArray Item Item) -- ^ Return value : (Database, maximum item value after reduction, permutation of items) loadTransactionsMatrix intMatrix thres = let itmFrq = histogram (0, maxItem) intMatrix maxItem = maximum (concat intMatrix) (perm, antiPerm) = permut itmFrq reorderedMat = reorderMat intMatrix perm itmFrq thres maxItem' = maximum (concat reorderedMat) lexicoTree = foldr (\t lt -> insertLT t (-1) 1 lt) Nil reorderedMat in (lexicoTree, maxItem', antiPerm) {-| Converts the contents of a data string to a transaction database and computes maxItem. -} stringToTransDB :: [L.ByteString] -- ^ List of transactions -> Maybe [[Item]] -- ^ Return value : transactions as lists of items, and maxItem stringToTransDB [] = return [] stringToTransDB (t:ts) = do ts' <- stringToTransDB ts return (convertOneTrans t:ts') {-| Converts one transaction from string format to item format [Item]. -} convertOneTrans :: L.ByteString -- ^ Transaction as extracted from file -> [Item] -- ^ Result : list of items convertOneTrans s = case L.readInt s of Nothing -> [] Just (itm, rest) -> if (not $ L.null rest) then itm:(convertOneTrans (L.tail rest)) else [itm] {-| For a transaction database of type [[Item]], compute the frequency of each item and return an array (item, frequency). -} histogram :: (Item,Item) -- ^ Bounds for resulting array, must be (0, maxItem) -> [[Item]] -- ^ Transaction database -> UArray Item Frequency -- ^ Result : Array associating each item with its frequency histogram bnds lst = accumArray (+) 0 bnds [(i, 1) | j <- lst, i <- {-nub-} j{-, inRange bnds i-}] {-| Sorts a list of (Item, frequency of this item) in decreasing ordrer of frequency. XXX PERF : seems unefficient. -} sortFrq :: [(Item,Frequency)] -- ^ Each item is associated with its frequency -> [(Item,Frequency)] -- ^ Same list as input, but sorted in decreasing frequency order sortFrq [] = [] sortFrq ((x,y):rest) = (sortFrq [(x',y') | (x',y') <- rest, y' >= y]) ++ [(x,y)] ++ (sortFrq [(x'',y'') | (x'',y'') <- rest, y'' < y]) -- XXX PERF: lots of copies here...maybe not a pb for small lists ? {-| From an array of (item, frequency of this item), computes an associative array X where X[i] is the ith most frequent item. XXX PERF : performance issue with conversions to and from list inside function. -} permut :: UArray Item Frequency -- ^ Array associating to each item its frequency -> (UArray Item Item, UArray Item Item) -- ^ Result : new array where items are ranked by frequency, and the reverse permut arr = let (lo,hi) = bounds arr lstVal = [(i,(arr!i)) | i <- [lo..hi]] lst2 = sortFrq lstVal -- in array (lo,hi) [(k, (fst (lst2 !! (k)))) | k <- [lo..hi]] in (array (lo,hi) [(k, (head $ findIndices ((==k).fst) lst2)) | k <- [lo..hi]], array (lo,hi) [(k, (fst (lst2 !! (k)))) | k <- [lo..hi]]) -- XXX PERF: must be bad : the array is converted to list (one copy), -- then this list is sorted (more copies of small lists), and at -- last a new array is created... -- Try to improve this with a mutable array and more "in place" spirit... {-| Rewrites an input transaction database by removing infrequent items and using reordered items (i.e. each item is replaced by its rank in decreasing frequency order). -} reorderMat :: [[Item]] -- ^ Original transaction database -> UArray Item Item -- ^ Array of items sorted by decreasing frequency order (item, rank) -> UArray Item Frequency -- ^ Array associating each item with its frequency (item, frequency) -> Frequency -- ^ Minimum frequency threshold -> [[Item]] -- ^ Result : rewritten transaction database reorderMat ts perm itmFrq thres = map (\t -> sort $ (map (\i -> (unsafeAt perm i)) -- permutates items (filter (\x -> (unsafeAt itmFrq x) >= thres) -- eliminate unfrequent items t))) ts {-| Compute for each item of the transaction database its frequency. -} occurrenceDeliverLT :: LexicoTreeItem -- ^ Transaction database (in lexicographic tree format) -> Item -- ^ Maximal item in transaction database -> UArray Item Frequency -- ^ Result : array associating each item to its frequency. occurrenceDeliverLT cdb maxItem = runST (do arr <- newArray_ (0,maxItem) -- Creates an empty array : each item starts with frequency 0 forM_ [0..maxItem] $ \i -> unsafeWrite arr i 0 -- workaround for http://hackage.haskell.org/trac/ghc/ticket/3586 -- Compute frequencies for each item by efficient tree traversal _ <- traverse cdb arr unsafeFreeze arr ) {-| Efficient traversal of the transaction database as a lexicographic tree. Items frequencies are updated on the fly. -} traverse :: LexicoTreeItem -- ^ Transaction database -> STUArray s Item Frequency -- ^ Array associating each item with its frequency. UPDATED by this function ! -> ST s () traverse tree arr = ST $ \s -> case traverse' tree arr s of (# s', _ #) -> (# s', () #) traverse' :: LexicoTreeItem -> STUArray s Item Frequency -> State# s -> (# State# s, Int# #) traverse' Nil !arr s = (# s, 0# #) traverse' (Node item child alt w@(I# w#)) !arr s0 = case traverse' child arr s0 of { (# s1, childw #) -> case traverse' alt arr s1 of { (# s2, altw #) -> case unsafeRead arr item of { ST f -> case f s2 of { (# s3, I# itemw #) -> case unsafeWrite arr item (I# itemw + I# childw + w) of { ST f -> case f s2 of { (# s4, _ #) -> (# s4, childw +# w# +# altw #) }}}}}} {-| For a transaction database, a closed frequent itemset, and a candidate item for extension of this closed frequent itemset, recursively computes all the successor closed frequent itemsets by PPC-extension. -} lcmIter :: Int -- ^ Current depth in the search tree (for parallel optimisation purposes) -> LexicoTreeItem -- ^ Transaction database. -> [Item] -- ^ Input closed frequent itemset. -> Item -- ^ Candidate to extend the closed frequent itemset above. -> Item -- ^ CoreI item relative to the closed frequent itemset -> UArray Item Frequency -- ^ Array associating each item with its frequency -> Item -- ^ Maximal item -> Frequency -- ^ Minimum suppport threshold -> [[Item]] -- ^ Result : list of closed frequent itemsets. Each result is a list of items, the head of the list being the frequency of the item. lcmIter prof cdb itemset candidate coreI occs maxItem thres = let -- Reduce database rdb = projectAndReduce cdb candidate occs -- Compute items occurrences in reduced database newOccs = occurrenceDeliverLT rdb maxItem -- Check which items actually appear in reduced database presentItems = filter (\i -> newOccs!i > 0) [0..maxItem] candidateFreq = occs!candidate -- Compute 100% frequent items, unfrequent items, and future candidates (closedFrqItems, candidates, unfrqItems) = computeCandidates thres candidateFreq presentItems newOccs -- Update items occurrences table by suppressing 100% frequent and unfrequent items newOccs' = suppressItems newOccs closedFrqItems unfrqItems -- Result closed frequent itemset = input closed frequent itemset + 100% frequent items closedItemset = sort (itemset ++ closedFrqItems) -- Only candidates with value lower than input candidate can be used for further extension on this branch smallCandidates = takeWhile ( 0) -- ... and if we have at least 1 possible extension then -- recursiverly extend the candidates if (prof < 3) -- create parallel sparks only for low search space depth then ((candidateFreq:closedItemset):(concat (parBuffer 2 rdeepseq $ (map (\x -> lcmIter (prof+1) rdb closedItemset x candidate newOccs' maxItem thres) smallCandidates)))) else ((candidateFreq:closedItemset):(concat (map (\x -> lcmIter (prof+1) rdb closedItemset x candidate newOccs' maxItem thres) smallCandidates))) else [candidateFreq:closedItemset] else [] else [] ------------------------------- BENCHMARKING ------------------------------ {-| -} lcmIterParBuffer :: Int -- ^ Current depth in the search tree (for parallel optimisation purposes) -> LexicoTreeItem -- ^ Transaction database. -> [Item] -- ^ Input closed frequent itemset. -> Item -- ^ Candidate to extend the closed frequent itemset above. -> Item -- ^ CoreI item relative to the closed frequent itemset -> UArray Item Frequency -- ^ Array associating each item with its frequency -> Item -- ^ Maximal item -> Frequency -- ^ Minimum suppport threshold -> Int -- ^ Value for parBuffer -> Int -- ^ Depth for cutting parallelism -> [[Item]] -- ^ Result : list of closed frequent itemsets. Each result is a list of items, the head of the list being the frequency of the item. lcmIterParBuffer prof cdb itemset candidate coreI occs maxItem thres n d = let -- Reduce database rdb = projectAndReduce cdb candidate occs -- Compute items occurrences in reduced database newOccs = occurrenceDeliverLT rdb maxItem -- Check which items actually appear in reduced database presentItems = filter (\i -> newOccs!i > 0) [0..maxItem] candidateFreq = occs!candidate -- Compute 100% frequent items, unfrequent items, and future candidates (closedFrqItems, candidates, unfrqItems) = computeCandidates thres candidateFreq presentItems newOccs -- Update items occurrences table by suppressing 100% frequent and unfrequent items newOccs' = suppressItems newOccs closedFrqItems unfrqItems -- Result closed frequent itemset = input closed frequent itemset + 100% frequent items closedItemset = sort (itemset ++ closedFrqItems) -- Only candidates with value lower than input candidate can be used for further extension on this branch smallCandidates = takeWhile ( 0) -- ... and if we have at least 1 possible extension then -- recursiverly extend the candidates if (prof < d) -- create parallel sparks only for low search space depth then ((candidateFreq:closedItemset):(concat (parBuffer n rdeepseq $ (map (\x -> lcmIterParBuffer (prof+1) rdb closedItemset x candidate newOccs' maxItem thres n d) smallCandidates)))) else ((candidateFreq:closedItemset):(concat (map (\x -> lcmIterParBuffer (prof+1) rdb closedItemset x candidate newOccs' maxItem thres n d) smallCandidates))) else [candidateFreq:closedItemset] else [] else [] --- {-| -} lcmIterParMap :: Int -- ^ Current depth in the search tree (for parallel optimisation purposes) -> LexicoTreeItem -- ^ Transaction database. -> [Item] -- ^ Input closed frequent itemset. -> Item -- ^ Candidate to extend the closed frequent itemset above. -> Item -- ^ CoreI item relative to the closed frequent itemset -> UArray Item Frequency -- ^ Array associating each item with its frequency -> Item -- ^ Maximal item -> Frequency -- ^ Minimum suppport threshold -> Int -- ^ Depth for cutting parallelism -> [[Item]] -- ^ Result : list of closed frequent itemsets. Each result is a list of items, the head of the list being the frequency of the item. lcmIterParMap prof cdb itemset candidate coreI occs maxItem thres d = let -- Reduce database rdb = projectAndReduce cdb candidate occs -- Compute items occurrences in reduced database newOccs = occurrenceDeliverLT rdb maxItem -- Check which items actually appear in reduced database presentItems = filter (\i -> newOccs!i > 0) [0..maxItem] candidateFreq = occs!candidate -- Compute 100% frequent items, unfrequent items, and future candidates (closedFrqItems, candidates, unfrqItems) = computeCandidates thres candidateFreq presentItems newOccs -- Update items occurrences table by suppressing 100% frequent and unfrequent items newOccs' = suppressItems newOccs closedFrqItems unfrqItems -- Result closed frequent itemset = input closed frequent itemset + 100% frequent items closedItemset = sort (itemset ++ closedFrqItems) -- Only candidates with value lower than input candidate can be used for further extension on this branch smallCandidates = takeWhile ( 0) -- ... and if we have at least 1 possible extension then -- recursiverly extend the candidates if (prof < d) -- create parallel sparks only for low search space depth then ((candidateFreq:closedItemset):(concat ((parMap rdeepseq) (\x -> lcmIterParMap (prof+1) rdb closedItemset x candidate newOccs' maxItem thres d) smallCandidates))) else ((candidateFreq:closedItemset):(concat (map (\x -> lcmIterParMap (prof+1) rdb closedItemset x candidate newOccs' maxItem thres d) smallCandidates))) else [candidateFreq:closedItemset] else [] else [] ------------------- END OF BENMARKING FUNCTIONS ------------------------------- {-| For a given itemset being extended by a given candidate, compute the closure of this itemset and compute the candidates for further extension. -} computeCandidates :: Frequency -- ^ Minimum support thresold -> Frequency -- ^ Frequency of item selected for extension (@candidate@) -> [Item] -- ^ List of items in the transaction database -> UArray Item Frequency -- ^ Array associating to each item its frequency -> ([Item], [Item], [Item]) -- ^ Result : (100% frequent items = closure, -- candidates for further extension, unfrequent items) computeCandidates thres candidateFreq presentItems occs = let (frequentItems, unfrqItems) = partition(\i -> occs!i >= thres) presentItems closedFrqItems = filter (\i -> occs!i == candidateFreq) frequentItems candidates = frequentItems \\ closedFrqItems in (closedFrqItems, candidates, unfrqItems) {-| Modifies an array associating items with their frequency, in order to give a frequency of 0 to a given list of items. NB : for performance reasons, this is REALLY a modification, made with unsafe operations. -} suppressItems :: UArray Item Frequency -- ^ Array associating an item with its frequency -> [Item] -- ^ List of 100% frequent items -> [Item] -- ^ List of unfrequent items -> UArray Item Frequency -- ^ Initial array, with frequencies of 100% frequent items -- and unfrequent items set to 0. suppressItems occs closedItems unfreqItems = runST $ do occsST <- unsafeThaw occs :: ST s (STUArray s Item Frequency) -- Can be used in multithread because no concurrent write sequence_ (map (\i -> writeArray occsST i 0) closedItems) sequence_ (map (\i -> writeArray occsST i 0) unfreqItems) newOccs <- unsafeFreeze occsST -- Can be used in multithread because no concurrent write return newOccs {-| Creates a new, reduced transaction database by eliminating all items greater than @candidate@ item, and all infrequent items. -} projectAndReduce :: LexicoTreeItem -- ^ Original transaction database -> Item -- ^ Candidate item, on which the projection is made -> UArray Item Frequency -- ^ Array associating each item with its frequency in -- original transaction database. -> LexicoTreeItem -- ^ Result : Reduced transaction database projectAndReduce Nil _ _ = Nil projectAndReduce (Node e suiv alt w) !candidate occs | e > candidate = Nil | e == candidate = let !(TreeWeight suiv' addWeight) = filterInfrequent suiv occs in (Node e suiv' Nil (w+addWeight)) | e < candidate = let !alt' = projectAndReduce alt candidate occs !suiv' = projectAndReduce suiv candidate occs in if (occs!e > 0) then if notNil suiv' && notNil alt' then (Node e suiv' alt' 0) else if notNil suiv' then (Node e suiv' Nil 0) else alt' else if notNil suiv' && notNil alt' then mergeAlts suiv' alt' else if notNil suiv' then suiv' else alt' {-| Suppress all infrequent items from a transaction database expressed as lexicographic tree, and returns a new lexicographic tree. -} filterInfrequent :: LexicoTreeItem -- ^ Original transaction database -> UArray Item Frequency -- ^ Array associating each item with its frequency in -- original transaction database. In this setting, -- an infrequent item as a frequency of 0 (because of preprocessing by -- 'suppressItems'). -> TreeWeight -- ^ Result : (transaction database without infrequent items, weight to report in parent nodes) filterInfrequent Nil _ = TreeWeight Nil 0 filterInfrequent (Node e suiv alt w) occs | occs!e > 0 = TreeWeight (Node e suiv' alt' (w+ws)) wa | notNil suiv' && notNil alt' = TreeWeight (mergeAlts suiv' alt') w' | notNil alt' = TreeWeight alt' w' | notNil suiv' = TreeWeight suiv' w' | otherwise = TreeWeight Nil w' where w' = w+ws+wa !(TreeWeight suiv' ws) = filterInfrequent suiv occs !(TreeWeight alt' wa) = filterInfrequent alt occs {-# INLINE notNil #-} notNil Nil = False notNil _ = True data TreeWeight = TreeWeight !LexicoTreeItem {-#UNPACK#-}!Weight ----------------------------------------------------------------- -- LEXICOGRAPHIC TREE MANIPULATION ----------------------------------------------------------------- {-| Type for a lexicographic tree, implementating a n-ary tree over a binary tree. -} data LexicoTreeItem = Nil -- ^ Void node | Node {-#UNPACK#-} !Item !LexicoTreeItem -- NB. experimental strictness annotation !LexicoTreeItem -- NB. experimental strictness annotation {-#UNPACK#-} !Int -- ^ A node : item, next node (next in transaction), alternative node (other branch), weight deriving (Eq, Show) {-| Returns the maximal item of a lexicographic tree -} treeMax :: LexicoTreeItem -> Item treeMax Nil = -1 treeMax (Node e Nil Nil _) = e treeMax (Node _ suiv Nil _) = treeMax suiv treeMax (Node _ Nil alt _) = treeMax alt treeMax (Node _ suiv alt _) = max (treeMax suiv) (treeMax alt) {-| Inserts a transaction in list format into the lexicographic tree. Automatically merges identical transactions. Performs suffix intersection. -} insertLT :: [Item] -- ^ Transaction to insert into lexicographic tree -> Item -- ^ "coreI" item, for suffix intersection. -> Int -- ^ Weight of the transaction to inserct -> LexicoTreeItem -- ^ Input lexicographic tree -> LexicoTreeItem -- ^ Result : a new lexicographic tree with the transaction inserted insertLT [] _ _ lt = lt insertLT lst _ w Nil = createPath lst w insertLT [x] i w (Node e suiv alt weight) | x < e = Node x Nil (Node e suiv alt weight) w | x == e = Node e suiv alt (weight + w) | x > e = Node e suiv (insertLT [x] i w alt) weight insertLT (x:xs) i w (Node e suiv alt weight) | x < e = Node x (createPath xs w) (Node e suiv alt weight) 0 | x == e = if (e /= i) then Node e (insertLT xs i w suiv) alt weight else suffixIntersectionLT xs w (Node e suiv alt weight) | x > e = Node e suiv (insertLT (x:xs) i w alt) weight {-| From a transaction and its weight, directly creates a path-shaped lexicographic tree. -} createPath :: [Item] -- ^ Transaction -> Int -- ^ Weight of the transaction -> LexicoTreeItem -- ^ Result : a path-shaped lexicographic tree encoding the transaction createPath [] _ = Nil createPath [x] w = Node x Nil Nil w createPath (x:xs) w = Node x (createPath xs w) Nil 0 {-| Perform the "suffix intersection" operation with the suffix of a transaction and the corresponding part of a lexicographic tree. For more details, see "prefixIntersection" in Takeaki Uno's papers about LCM. -} suffixIntersectionLT :: [Item] -- ^ Suffix of the transaction to insert. -> Int -- ^ Weight of the transaction to insert -> LexicoTreeItem -- ^ (Sub-)lexicographic tree where the transaction must be inserted. The @next@ part (see data type comments) -- should be a simple path, it will be the target of intersection with the suffix. -> LexicoTreeItem -- ^ Result : lexicographic tree where the suffix has been added, with correct intersections performed. suffixIntersectionLT _ w (Node e Nil alt weight) = Node e Nil alt (weight+w) suffixIntersectionLT lst w (Node e suiv alt weight) = let (newSuiv, addWeight) = suffInterSuiv lst w suiv in Node e newSuiv alt (weight+addWeight) {-| Intersects a list-shaped transaction and a path-shaped lexicographic tree. The result is a path shaped lexicographic tree with weights correctly updated. -} suffInterSuiv :: [Item] -- ^ Transaction as list -> Int -- ^ Weight of the above transaction -> LexicoTreeItem -- ^ Path-shaped lexicographic tree -> (LexicoTreeItem, Int) -- ^ Result : (path-shaped lexicographic tree representing the intersection -- of transaction and input path , 0 if intersection not [] / sum of weights else) suffInterSuiv lst w suiv = let (lstSuiv, weightSuiv) = getLstSuiv suiv inter = List.intersect lstSuiv lst in if (inter /= []) then (createPath inter (weightSuiv+w), 0) else (Nil, weightSuiv+w) {-| Collects all the nodes of lexicographic tree in a list of elements. -} getLstSuiv :: LexicoTreeItem -- ^ Path shaped lexicographic tree. -> ([Item], Int) -- ^ Result : (list of elements in the path, sum of weights of nodes in the path) getLstSuiv Nil = ([], 0) getLstSuiv (Node e suiv Nil weight) = let (lst, w) = getLstSuiv suiv in (e:lst, w + weight) {-| Merge two lexicographic trees. -} mergeAlts :: LexicoTreeItem -- ^ Tree 1 -> LexicoTreeItem -- ^ Tree 2 -> LexicoTreeItem -- ^ Return : Tree 1 merged with Tree 2 mergeAlts Nil lt = lt mergeAlts lt Nil = lt mergeAlts (Node e1 suiv1 alt1 w1) (Node e2 suiv2 alt2 w2) | e1 < e2 = (Node e1 suiv1 (mergeAlts alt1 (Node e2 suiv2 alt2 w2)) w1) | e1 > e2 = (Node e2 suiv2 (mergeAlts (Node e1 suiv1 alt1 w1) alt2) w2) | e1 == e2 = (Node e1 (mergeAlts suiv1 suiv2) (mergeAlts alt1 alt2) (w1+w2)) ------------------------------------------------------------------