module GLL.Types.DataSets where

import GLL.Types.Grammar
import GLL.Types.BSR

import qualified Data.IntMap as IM
import qualified Data.Map as M
import qualified Data.Set as S
import Data.List (nub)

type Descr t    = (Slot t, Int, Int)
type Comm t     = (Nt, Int)
data Cont t c   = Cont (Slot t, Int) c
data State t c  = State { uset       :: USet t
                        , grel       :: GRel t c
                        , prel       :: PRel t
                        , bsrs       :: BSRs t
                        , successes  :: Int
                        }

instance (Ord t) => Ord (Cont t c) where
  (Cont c _) `compare` (Cont c' _) = c `compare` c'

instance (Eq t) => Eq (Cont t c) where
  (Cont c _) == (Cont c' _) = c == c'

emptyUSet       :: USet t
addDescr        :: (Ord t) => Descr t  -> USet t   -> USet t
hasDescr        :: (Ord t) => Descr t  -> USet t   -> Bool

emptyG         :: GRel t c
addCont         :: (Ord t) => Comm t -> (Slot t, Int, c) -> GRel t c -> GRel t c
conts           :: Comm t -> GRel t c -> [(Slot t, Int, c)]

emptyP         :: PRel t
addExtent       :: Comm t -> Int -> PRel t -> PRel t
extents         :: Comm t -> PRel t -> [Int]

emptyState :: (Ord t) => State t c
emptyState = State emptyUSet emptyG emptyP emptyBSRs 0

type RList t    =   [Descr t]
type USet t     =   IM.IntMap (IM.IntMap (S.Set (Slot t)))
type GRel t c   =   IM.IntMap (M.Map Nt (S.Set (Cont t c)))
type PRel t     =   IM.IntMap (M.Map Nt [Int])

descrs2list :: USet t -> [(Slot t, Int, Int)]
descrs2list uset =  [ (g,l,k)
                    | (l, k2m)  <- IM.assocs uset
                    , (k, g2m)  <- IM.assocs k2m
                    , g         <- S.toList g2m ]

printDescrs :: (Show t) => USet t -> IO ()
printDescrs = putStr . unlines . map show . descrs2list

emptyRList = []
popRList (x:xs)  = (x,xs) 
popRList _       = error "popRList"
unionRList       = flip (++)
singletonRList   = (:[])
fromListRList    :: Ord t => [Descr t]  -> USet t   -> RList t
fromListRList ds uset = foldr op emptyRList (nub ds)
  where op d rset   | hasDescr d uset   = rset
                    | otherwise         = unionRList (singletonRList d) rset


emptyUSet = IM.empty

addDescr alt@(slot,i,l) = IM.alter inner i 
  where inner mm = case mm of 
                      Nothing -> Just $ IM.singleton l single 
                      Just m  -> Just $ IM.insertWith (S.union) l single m
        single = S.singleton slot

hasDescr alt@(slot,i,l) = not . maybe True inner . IM.lookup i
  where inner m = maybe True (not . (slot `S.member`)) $ IM.lookup l m

emptyG = IM.empty
singleCG k v = addCont k v emptyG
addCont (n,i) (gs,l,c) = IM.alter inner i
 where inner mm = case mm of 
                    Nothing -> Just $ M.singleton n single 
                    Just m  -> Just $ M.insertWith S.union n single m
       single = S.singleton (Cont (gs,l) c)
conts (n,l) = maybe [] inner . IM.lookup l
         where inner m = maybe [] (map unCont . S.toList) $ M.lookup n m
               unCont (Cont (gs,l') cf) = (gs,l',cf)

emptyP = IM.empty
addExtent (gs,l) i = IM.alter inner l
 where inner mm = case mm of 
                    Nothing -> Just $ M.singleton gs [i]
                    Just m  -> Just $ M.insertWith (++) gs [i] m

extents (gs,l) = maybe [] inner . IM.lookup l 
         where inner = maybe [] id .  M.lookup gs