{-# LANGUAGE StandaloneDeriving #-}

module GLL.Types.BSR where

import qualified    Data.Map as M
import qualified    Data.IntMap as IM
import qualified    Data.IntSet as IS 

import GLL.Types.Grammar

-- make sure that tokens are equal independent of their character level value
type SlotL t    = (Slot t, Int)                   -- slot with left extent
type PrL t      = (Prod t, Int)                     -- Production rule with left extent
type NtL        = (Nt, Int)                     -- Nonterminal with left extent

-- | 
-- Stores packed nodes using nested "Data.IntMap"s, nesting is as follows:
--
-- * left extent
-- * right extent
-- * dot position (from left to right)
-- * mapping from productions to set of pivots
type BSRs t  =   IM.IntMap (IM.IntMap (IM.IntMap (M.Map (Prod t) IS.IntSet)))
type BSR t = (Slot t, Int, Int, Int)

emptyBSRs :: (Ord t) => BSRs t
emptyBSRs :: forall t. Ord t => BSRs t
emptyBSRs = forall a. IntMap a
IM.empty

pNodeLookup :: (Ord t) => BSRs t -> (Slot t, Int, Int) -> Maybe [Int]
pNodeLookup :: forall t. Ord t => BSRs t -> (Slot t, Int, Int) -> Maybe [Int]
pNodeLookup BSRs t
bsrs (Slot Nt
x [Symbol t]
alpha [Symbol t]
beta,Int
l,Int
r)= forall t.
Ord t =>
BSRs t -> ((Prod t, Int), Int, Int) -> Maybe [Int]
pNodeLookup' BSRs t
bsrs ((forall t. Nt -> Symbols t -> Prod t
Prod Nt
x ([Symbol t]
alphaforall a. [a] -> [a] -> [a]
++[Symbol t]
beta),forall (t :: * -> *) a. Foldable t => t a -> Int
length [Symbol t]
alpha),Int
l,Int
r)

pNodeLookup' :: (Ord t) => BSRs t -> ((Prod t, Int), Int, Int) -> Maybe [Int]
pNodeLookup' :: forall t.
Ord t =>
BSRs t -> ((Prod t, Int), Int, Int) -> Maybe [Int]
pNodeLookup' BSRs t
pMap ((Prod t
alt,Int
j),Int
l,Int
r) = forall b a. b -> (a -> b) -> Maybe a -> b
maybe forall a. Maybe a
Nothing IntMap (IntMap (Map (Prod t) IntSet)) -> Maybe [Int]
inner forall a b. (a -> b) -> a -> b
$ forall a. Int -> IntMap a -> Maybe a
IM.lookup Int
l BSRs t
pMap
    where   inner :: IntMap (IntMap (Map (Prod t) IntSet)) -> Maybe [Int]
inner   = forall b a. b -> (a -> b) -> Maybe a -> b
maybe forall a. Maybe a
Nothing IntMap (Map (Prod t) IntSet) -> Maybe [Int]
inner2 forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Int -> IntMap a -> Maybe a
IM.lookup Int
r
            inner2 :: IntMap (Map (Prod t) IntSet) -> Maybe [Int]
inner2  = forall b a. b -> (a -> b) -> Maybe a -> b
maybe forall a. Maybe a
Nothing Map (Prod t) IntSet -> Maybe [Int]
inner3 forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Int -> IntMap a -> Maybe a
IM.lookup Int
j
            inner3 :: Map (Prod t) IntSet -> Maybe [Int]
inner3  = forall b a. b -> (a -> b) -> Maybe a -> b
maybe forall a. Maybe a
Nothing (forall a. a -> Maybe a
Just forall b c a. (b -> c) -> (a -> b) -> a -> c
. IntSet -> [Int]
IS.toList) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup Prod t
alt

addBSR :: forall t. Ord t => BSR t -> BSRs t -> BSRs t
addBSR = forall t. Ord t => BSR t -> BSRs t -> BSRs t
pMapInsert
addBSR, pMapInsert :: (Ord t) => BSR t -> BSRs t -> BSRs t
pMapInsert :: forall t. Ord t => BSR t -> BSRs t -> BSRs t
pMapInsert f :: BSR t
f@((Slot Nt
x [Symbol t]
alpha [Symbol t]
beta), Int
l, Int
k, Int
r) BSRs t
pMap = 
 Prod t -> Int -> Int -> Int -> Int -> BSRs t
add (forall t. Nt -> Symbols t -> Prod t
Prod Nt
x ([Symbol t]
alphaforall a. [a] -> [a] -> [a]
++[Symbol t]
beta)) (forall (t :: * -> *) a. Foldable t => t a -> Int
length [Symbol t]
alpha) Int
l Int
r Int
k
 where add :: Prod t -> Int -> Int -> Int -> Int -> BSRs t
add Prod t
alt Int
j Int
l Int
r Int
k = forall a. (Maybe a -> Maybe a) -> Int -> IntMap a -> IntMap a
IM.alter Maybe (IntMap (IntMap (Map (Prod t) IntSet)))
-> Maybe (IntMap (IntMap (Map (Prod t) IntSet)))
addInnerL Int
l BSRs t
pMap
        where addInnerL :: Maybe (IntMap (IntMap (Map (Prod t) IntSet)))
-> Maybe (IntMap (IntMap (Map (Prod t) IntSet)))
addInnerL Maybe (IntMap (IntMap (Map (Prod t) IntSet)))
mm = case Maybe (IntMap (IntMap (Map (Prod t) IntSet)))
mm of 
                             Maybe (IntMap (IntMap (Map (Prod t) IntSet)))
Nothing -> forall a. a -> Maybe a
Just IntMap (IntMap (Map (Prod t) IntSet))
singleRJAK
                             Just IntMap (IntMap (Map (Prod t) IntSet))
m ->  forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ forall a. (Maybe a -> Maybe a) -> Int -> IntMap a -> IntMap a
IM.alter Maybe (IntMap (Map (Prod t) IntSet))
-> Maybe (IntMap (Map (Prod t) IntSet))
addInnerR Int
r IntMap (IntMap (Map (Prod t) IntSet))
m
              addInnerR :: Maybe (IntMap (Map (Prod t) IntSet))
-> Maybe (IntMap (Map (Prod t) IntSet))
addInnerR Maybe (IntMap (Map (Prod t) IntSet))
mm = case Maybe (IntMap (Map (Prod t) IntSet))
mm of
                             Maybe (IntMap (Map (Prod t) IntSet))
Nothing -> forall a. a -> Maybe a
Just IntMap (Map (Prod t) IntSet)
singleJAK
                             Just IntMap (Map (Prod t) IntSet)
m  -> forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ forall a. (Maybe a -> Maybe a) -> Int -> IntMap a -> IntMap a
IM.alter Maybe (Map (Prod t) IntSet) -> Maybe (Map (Prod t) IntSet)
addInnerJ Int
j IntMap (Map (Prod t) IntSet)
m
              addInnerJ :: Maybe (Map (Prod t) IntSet) -> Maybe (Map (Prod t) IntSet)
addInnerJ Maybe (Map (Prod t) IntSet)
mm = case Maybe (Map (Prod t) IntSet)
mm of
                             Maybe (Map (Prod t) IntSet)
Nothing -> forall a. a -> Maybe a
Just Map (Prod t) IntSet
singleAK
                             Just Map (Prod t) IntSet
m  -> forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ forall k a. Ord k => (a -> a -> a) -> k -> a -> Map k a -> Map k a
M.insertWith IntSet -> IntSet -> IntSet
IS.union Prod t
alt IntSet
singleK Map (Prod t) IntSet
m
              singleRJAK :: IntMap (IntMap (Map (Prod t) IntSet))
singleRJAK= forall a. [(Int, a)] -> IntMap a
IM.fromList [(Int
r, IntMap (Map (Prod t) IntSet)
singleJAK)]
              singleJAK :: IntMap (Map (Prod t) IntSet)
singleJAK = forall a. [(Int, a)] -> IntMap a
IM.fromList [(Int
j, Map (Prod t) IntSet
singleAK)]
              singleAK :: Map (Prod t) IntSet
singleAK  = forall k a. Ord k => [(k, a)] -> Map k a
M.fromList [(Prod t
alt, IntSet
singleK)]
              singleK :: IntSet
singleK   = Int -> IntSet
IS.singleton Int
k

showBSRs :: IntMap (IntMap (IntMap (Map a a))) -> String
showBSRs IntMap (IntMap (IntMap (Map a a)))
pMap = [String] -> String
unlines [ forall a. Show a => a -> String
show ((a
a,Int
j),Int
l,Int
r) forall a. [a] -> [a] -> [a]
++ String
" --> " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show a
kset
                        | (Int
l,IntMap (IntMap (Map a a))
r2j) <- forall a. IntMap a -> [(Int, a)]
IM.assocs IntMap (IntMap (IntMap (Map a a)))
pMap, (Int
r,IntMap (Map a a)
j2a) <- forall a. IntMap a -> [(Int, a)]
IM.assocs IntMap (IntMap (Map a a))
r2j
                        , (Int
j,Map a a
a2k) <- forall a. IntMap a -> [(Int, a)]
IM.assocs IntMap (Map a a)
j2a, (a
a,a
kset) <- forall k a. Map k a -> [(k, a)]
M.assocs Map a a
a2k ]