content: {- |
  Module      :  ./CASL/CompositionTable/ModelTable.hs
  Description :  intermediate calculus table
  Copyright   :  (c) Uni Bremen 2005
  License     :  GPLv2 or higher, see LICENSE.txt
  
  Maintainer  :  Christian.Maeder@dfki.de
  Stability   :  provisional
  Portability :  portable
  
  -}
  
  module CASL.CompositionTable.ModelTable where
  
  import CASL.CompositionTable.CompositionTable
  import Common.Utils
  
  import qualified Data.IntSet as IntSet
  import qualified Data.IntMap as IntMap
  import qualified Data.Map as Map
  import Data.List
  
  data Table2 = Table2 String Int (IntMap.IntMap Baserel) BSet CmpTbl ConTables
  
  type BSet = IntSet.IntSet
  
  type CmpTbl = IntMap.IntMap (IntMap.IntMap IntSet.IntSet)
  
  type ConTable = IntMap.IntMap IntSet.IntSet
  
  type ConTables = (ConTable, ConTable, ConTable, ConTable)
  
  lkup :: (Show a, Ord a) => a -> Map.Map a Int -> Int
  lkup i = Map.findWithDefault
    (error $ "CASL.CompositionTable.ModelTable.lkup" ++ show i) i
  
  toTable2 :: Table -> Table2
  toTable2 (Table (Table_Attrs name id_ baserels)
    (Compositiontable comptbl) convtbl _ _) =
    let ns = number baserels
        m = Map.fromList ns
    in Table2 name (lkup id_ m)
      (IntMap.fromList $ map (\ (a, b) -> (b, a)) ns)
      (IntSet.fromAscList [1 .. Map.size m])
      (toCmpTbl m comptbl)
      $ toConTables m convtbl
  
  toCmpTbl :: Map.Map Baserel Int -> [Cmptabentry] -> CmpTbl
  toCmpTbl m =
    foldl' (\ t (Cmptabentry (Cmptabentry_Attrs rel1 rel2) bs)
                -> IntMap.insertWith IntMap.union (lkup rel1 m)
                   (IntMap.insertWith IntSet.union (lkup rel2 m)
                   (IntSet.fromList $ map (`lkup` m) bs) IntMap.empty) t)
    IntMap.empty
  
  toConTab :: Map.Map Baserel Int -> (a -> Baserel) -> (a -> [Baserel]) -> [a]
    -> ConTable
  toConTab m s1 s2 = foldl' (\ t a ->
      IntMap.insertWith IntSet.union (lkup (s1 a) m)
             (IntSet.fromList $ map (`lkup` m) $ s2 a) t) IntMap.empty
  
  toConTab2 :: Map.Map Baserel Int -> [Contabentry_Ternary] -> ConTable
  toConTab2 m =
    toConTab m contabentry_TernaryArgBaseRel contabentry_TernaryConverseBaseRels
  
  toConTables :: Map.Map Baserel Int -> Conversetable -> ConTables
  toConTables m c = case c of
    Conversetable l ->
      (toConTab m contabentryArgBaseRel contabentryConverseBaseRel l
      , IntMap.empty, IntMap.empty, IntMap.empty)
    Conversetable_Ternary l1 l2 l3 ->
      (IntMap.empty, toConTab2 m l1, toConTab2 m l2, toConTab2 m l3)
  