Automata.hs

{-# LANGUAGE ScopedTypeVariables, MonadComprehensions #-}
{-|
  Module      : Text.ANTLR.Automata
  Description : Automatons and algorithms as used during tokenization
  Copyright   : (c) Karl Cronburg, 2018
  License     : BSD3
  Maintainer  : karl@cs.tufts.edu
  Stability   : experimental
  Portability : POSIX

-}
module Text.ANTLR.Lex.Automata where
import Text.ANTLR.Set (Set(..), member, toList, union, notMember, Hashable(..), fromList)
import qualified Text.ANTLR.Set as Set

-- | An automaton with edges @e@, symbols @s@, and state indices @i@
data Automata e s i = Automata
  { _S :: Set i                  -- ^ Finite set of states.
  , _Σ :: Set s                  -- ^ Input (edge) alphabet
  , _Δ :: Set (Transition e i)   -- ^ Transition function
  , s0 :: i                      -- ^ Start state
  , _F :: Set i                  -- ^ Accepting states
  } deriving (Eq)

instance (Eq e, Eq s, Eq i, Hashable e, Hashable s, Hashable i, Show e, Show s, Show i) => Show (Automata e s i) where
  show (Automata s sigma delta s0 f) =
    show s
    ++ "\n  Σ:  " ++ show sigma
    ++ "\n  Δ:  " ++ show delta
    ++ "\n  s0: " ++ show s0
    ++ "\n  F:  " ++ show f
    ++ "\n"

-- | Edge label of an automaton, on which we traverse if we match
--   on one of the tokens @t@ in the set. The boolean is for negation
--   of the set.
type AutomataEdge t = (Bool, Set t)

-- | A triplet with an edge alphabet of @e@ and node states of @i@.
type Transition e i = (i, AutomataEdge e, i)

-- | The from-node component of a 'Transition'
tFrom :: Transition e i -> i
tFrom (a,b,c) = a

-- | The to-node component of a 'Transition'
tTo   :: Transition e i -> i
tTo (a,b,c) = c

-- | The set of edge characters in @e@ of a 'Transition'
tEdge :: Transition e i -> Set e
tEdge (a,(comp, b),c) = b

-- | Determine the edge-label alphabet of a set of transitions.
transitionAlphabet __Δ =
  [ e
  | (_, (c, es), _) <- toList __Δ
  , e               <- es
  ]

-- | Compress a set of transitions such that every pair of (start,end) states
--   appears at most once in the set.
compress ::
  (Eq i, Eq e, Hashable i, Hashable e)
  => Set (Transition e i) -> Set (Transition e i)
compress __Δ = fromList
  [ ( a, (c, fromList [ e
             | (a', (c', es'), b') <- toList __Δ
             , a' == a && b' == b && c' == c
             , e <- toList es'
             ])
    , b)
  | (a, (c, es), b) <- toList __Δ
  ]

-- | XOR helper function over booleans.
xor a b = (not a && b) || (not b && a)

-- | Is the given transition triplet (with a single @e@ character as the edge
--   edge label) in some set of transitions? Note that we need to handle complement
--   sets here, in case the given @e@ is in the complement of one of the
--   transitions in the set.
transitionMember ::
  (Eq i, Hashable e, Eq e)
  => (i, e, i) -> Set (Transition e i) -> Bool
transitionMember (a, e, b) _Δ =
  or
      [ xor complement (e `member` es)
      | (a', (complement, es), b') <- toList _Δ
      , a' == a
      , b' == b
      ]

-- | Is the given character @s@ accepted by the given edge label?
edgeMember s (complement, es) = xor complement (s `member` es)

-- | An automaton must either 'Accept' or 'Reject'.
data Result = Accept | Reject

-- | Is the start state valid?
validStartState nfa = s0 nfa `member` _S nfa

-- | Are all of the ending states valid?
validFinalStates nfa = and [s `member` _S nfa | s <- toList $ _F nfa]

-- | Can all of the nodes as defined by the set of transitions be found
--   in the set of allowable states '_S'?
validTransitions ::
  forall e s i. (Hashable e, Hashable i, Eq e, Eq i)
  => Automata e s i -> Bool
validTransitions nfa = let
    vT :: [Transition e i] -> Bool
    vT [] = True
    vT ((s1, es, s2):rest) =
         s1 `member` _S nfa
      && s2 `member` _S nfa
      && vT rest
  in vT $ (toList . _Δ) nfa

-- | An automaton configuration is the set of state (indices) your
--   can currently be in.
type Config i = Set i

-- | Generic closure function so that *someone* never asks "what's a closure?" ever
--   again. For an epsilon-closure the given @fncn@ needs to return 'True' when
--   given an @e@ that is an epsilon, and 'False' in all other cases.
closureWith
  :: forall e s i. (Hashable e, Hashable i, Eq e, Eq i)
  => (e -> Bool) -> Automata e s i -> Config i -> Config i
closureWith fncn Automata{_S = _S, _Δ = _Δ'} states = let

    -- Check which edges are "epsilons" (or something else).
    _Δ = Set.map (\(a,(comp, b),c) -> (a, (comp, Set.map fncn b), c)) _Δ'

    cl :: Config i -> Config i -> Config i
    cl busy ss
      | Set.null ss = Set.empty
      | otherwise = let
          ret = fromList
                [ s'  | s  <- toList ss
                      , s' <- toList _S
                      , s' `notMember` busy
                      , (s, True, s') `transitionMember` _Δ ]
        in ret `union` cl (ret `union` busy) ret
  in states `union` cl Set.empty states
  --in Set.foldr (\a b -> union (cl a) b) Set.empty states

-- | Consume the @e@ character given, based on the fact that we are currently
--   in some 'Config i' of states, resulting in a new config consisting of the
--   states that we can get to by doing so.
move
  :: forall e s i. (Hashable e, Hashable i, Eq i, Eq e)
  => Automata e s i -> Config i -> e -> Config i
move Automata{_S = _S, _Δ = _Δ} _T a = fromList
  [ s'  | s  <- toList _T
        , s' <- toList _S
        , (s, a, s') `transitionMember` _Δ ]

-- | Whether or not (a, (True, _), b) is a transition in our set of transitions.
complementMember
  :: (Hashable i, Eq i, Hashable e, Eq e)
  => (i, i) -> Set (Transition e i) -> Bool
complementMember (a, b) =
  not . null . Set.filter (\(a', (c, _), b') -> a' == a && b' == b && c)

-- | Set of states you can move to if you see a character not in the alphabet.
moveComplement
  :: forall e s i. (Hashable e, Hashable i, Eq i, Eq e)
  => Automata e s i -> Config i -> Config i
moveComplement Automata{_S = _S, _Δ = _Δ} _T = fromList
  [ s'  | s  <- toList _T
        , s' <- toList _S
        , (s, s') `complementMember` _Δ ]