SetFastLattice.hs

{-
     FCA - A generator of a Formal Concept Analysis Lattice
     Copyright (C) 2014  Raymond Racine

     This program is free software: you can redistribute it and/or modify
     it under the terms of the GNU Affero General Public License as
     published by the Free Software Foundation, either version 3 of the
     License, or (at your option) any later version.

     This program is distributed in the hope that it will be useful,
     but WITHOUT ANY WARRANTY; without even the implied warranty of
     MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
     GNU Affero General Public License for more details.

     You should have received a copy of the GNU Affero General Public License
     along with this program.  If not, see <http://www.gnu.org/licenses/>.
-}

{-# LANGUAGE FlexibleContexts     #-}
{-# LANGUAGE FlexibleInstances    #-}
{-# LANGUAGE ImpredicativeTypes   #-}
{-# LANGUAGE Rank2Types           #-}
{-# LANGUAGE TypeSynonymInstances #-}

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

-- FIXME RPR - Deal with G o's without an I o a entry.
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

-- Equiv. to M a -> IdxMG a o -> G o as types are equiv.
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' -- nub $ (Concept g' m') : ns'
         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