module Data.Fca.SetFastLattice (
generateLattice
) where
import Data.Fca.CElem (CElem)
import Data.Fca.Cid (Cid (..), cid)
import Data.Fca.Concept (Concept (..))
import Data.Fca.Ident (Identable (..))
import Data.Fca.Lattice (Lattice, Neighborhood (..),
appendNeighbors, emptyLattice)
import Data.Fca.SimpleTypes (Context (..), G, I, IdxGM, IdxMG, M, Obj)
import qualified Data.HashMap.Strict as Map
import qualified Data.HashSet as Set
import Data.List (foldl', nub, sort)
import Data.Maybe (fromJust)
import Prelude hiding (min)
emptyConcept :: Concept o a
emptyConcept = Concept emptyG emptyM
emptyG :: G o
emptyG = Set.empty
emptyM :: M a
emptyM = Set.empty
idxG :: (CElem o, CElem a) => G o -> I o a -> IdxGM o a
idxG gs oia = foldl' extend Map.empty oia
where
extend oas (o,a) =
case Map.lookup o oas of
Nothing -> Map.insert o (Set.singleton a) oas
Just as -> Map.insert o (Set.insert a as) oas
idxM :: (CElem o, CElem a) => M a -> I o a -> IdxMG a o
idxM as oia = foldl' extend Map.empty oia
where
extend aos (o,a) =
case Map.lookup a aos of
Nothing -> Map.insert a (Set.singleton o) aos
Just os -> Map.insert a (Set.insert o os) aos
prime :: (CElem o, CElem a) => G o -> IdxGM o a -> M a
prime os igm =
case Set.foldr interM Nothing os of
Nothing -> emptyM
Just rs' -> rs'
where
interM o ms =
let oms = fromJust (Map.lookup o igm)
in case ms of
Nothing -> Just oms
Just ms' -> Just $ Set.intersection oms ms'
neighbors :: (CElem o, CElem a) =>
IdxGM o a -> IdxMG a o -> G o -> G o -> [Concept o a] -> [Obj o] -> [Concept o a]
neighbors _ _ _ _ ns [] = ns
neighbors gos aos igs min ns ggs =
neighbors' min ns ggs
where
neighbors' _ ns' [] = ns'
neighbors' min' ns' (gg':ggs') =
if Set.null atMin
then neighbors' min' (Concept g' m' : ns') ggs'
else neighbors' (Set.delete gg' min') ns' ggs'
where
igs' = Set.insert gg' igs
m' = prime igs' gos
g' = prime m' aos
atMin = Set.intersection min' (g' `Set.difference` igs')
lattice :: (Identable (Concept o a), CElem o, CElem a) =>
IdxGM o a -> IdxMG a o -> G o -> (Lattice, [(Cid, Concept o a)])
lattice gos aos gs =
loopLattice [emptyConcept] (emptyLattice, [])
where
loopLattice [] rs = rs
loopLattice (c:cs) (l, lcs) = loopLattice (lectic (cs ++ upperNs)) (l', lcs')
where
lectic = sort . nub
currG = cG c
remainingG = gs `Set.difference` currG
upperNs = neighbors gos aos currG remainingG [] (Set.toList remainingG)
cidC = cid c
lcs' = (cidC, c) : lcs
l' = let cidNs = map cid upperNs
l'' = appendNeighbors l cidC (Neighborhood cidNs [])
cN = Neighborhood [] [cidC]
in foldl' (\aL aCid -> appendNeighbors aL aCid cN) l'' cidNs
generateLattice :: (Identable (Concept o a), CElem o, CElem a) =>
Context o a -> (Lattice, [(Cid, Concept o a)])
generateLattice (Context g m i) =
lattice ig im g
where
ig = idxG g i
im = idxM m i