{- |
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)
