    -- | "Text.Regex.TDFA.TDFA" converts the QNFA from TNFA into the DFA.
    -- A DFA state corresponds to a Set of QNFA states, represented as list
    -- of Index which are used to lookup the DFA state in a lazy Trie
    -- which holds all possible subsets of QNFA states.
    module Text.Regex.TDFA.TDFA(patternToRegex,DFA(..),DT(..)
                                ,examineDFA,nfaToDFA,dfaMap) where

    --import Control.Arrow((***))
    import Data.Monoid as Mon(Monoid(..))
    import Control.Monad.State(State,MonadState(..),execState)
    import Data.Array.IArray(Array,(!),bounds,{-assocs-})
    import Data.IntMap(IntMap)
    import qualified Data.IntMap as IMap(empty,keys,delete,null,lookup,fromDistinctAscList
                                        ,member,unionWith,singleton,union
                                        ,toAscList,Key,elems,toList,insert
                                        ,insertWith,insertWithKey)
    import Data.IntMap.CharMap2(CharMap(..))
    import qualified Data.IntMap.CharMap2 as Map(empty)
    --import Data.IntSet(IntSet)
    import qualified Data.IntSet as ISet(empty,singleton,null)
    import qualified Data.List as List
    import qualified Data.Map (Map,empty,member,insert,elems)
    import Data.Sequence as S((|>),{-viewl,ViewL(..)-})

    import Text.Regex.TDFA.Common {- all -}
    import Text.Regex.TDFA.IntArrTrieSet(TrieSet)
    import qualified Text.Regex.TDFA.IntArrTrieSet as Trie(lookupAsc,fromSinglesMerge)
    import Text.Regex.TDFA.Pattern(Pattern)
    --import Text.Regex.TDFA.RunMutState(toInstructions)
    import Text.Regex.TDFA.TNFA(patternToNFA)
    --import Debug.Trace

    {- By Chris Kuklewicz, 2007. BSD License, see the LICENSE file. -}

    err :: String -> a
    err :: forall a. String -> a
    err String
    s = String -> String -> a
    forall a. String -> String -> a
    common_error String
    "Text.Regex.TDFA.TDFA"  String
    s

    dlose :: DFA
    dlose :: DFA
    dlose = DFA { d_id :: SetIndex
    d_id = SetIndex
    ISet.empty
                , d_dt :: DT
    d_dt = Simple' { dt_win :: IntMap Instructions
    dt_win = IntMap Instructions
    forall a. IntMap a
    IMap.empty
                                 , dt_trans :: CharMap Transition
    dt_trans = CharMap Transition
    forall a. CharMap a
    Map.empty
                                 , dt_other :: Transition
    dt_other = DFA -> DFA -> DTrans -> Transition
    Transition DFA
    dlose DFA
    dlose DTrans
    forall a. Monoid a => a
    mempty } }

    -- dumb smart constructor for tracing construction (I wanted to monitor laziness)
    {-# INLINE makeDFA #-}
    makeDFA :: SetIndex -> DT -> DFA
    makeDFA :: SetIndex -> DT -> DFA
    makeDFA SetIndex
    i DT
    dt = SetIndex -> DT -> DFA
    DFA SetIndex
    i DT
    dt

    -- Note that no CompOption or ExecOption parameter is needed.
    nfaToDFA :: ((Index,Array Index QNFA),Array Tag OP,Array GroupIndex [GroupInfo])
             -> CompOption -> ExecOption
             -> Regex
    nfaToDFA :: ((Position, Array Position QNFA), Array Position OP,
     Array Position [GroupInfo])
    -> CompOption -> ExecOption -> Regex
    nfaToDFA ((Position
    startIndex,Array Position QNFA
    aQNFA),Array Position OP
    aTagOp,Array Position [GroupInfo]
    aGroupInfo) CompOption
    co ExecOption
    eo = DFA
    -> Position
    -> (Position, Position)
    -> (Position, Position)
    -> TrieSet DFA
    -> Array Position OP
    -> Array Position [GroupInfo]
    -> Bool
    -> CompOption
    -> ExecOption
    -> Regex
    Regex DFA
    dfa Position
    startIndex (Position, Position)
    indexBounds (Position, Position)
    tagBounds TrieSet DFA
    trie Array Position OP
    aTagOp Array Position [GroupInfo]
    aGroupInfo Bool
    ifa CompOption
    co ExecOption
    eo where
      dfa :: DFA
    dfa = [Position] -> DFA
    indexesToDFA [Position
    startIndex]
      indexBounds :: (Position, Position)
    indexBounds = Array Position QNFA -> (Position, Position)
    forall i. Ix i => Array i QNFA -> (i, i)
    forall (a :: * -> * -> *) e i.
    (IArray a e, Ix i) =>
    a i e -> (i, i)
    bounds Array Position QNFA
    aQNFA
      tagBounds :: (Position, Position)
    tagBounds = Array Position OP -> (Position, Position)
    forall i. Ix i => Array i OP -> (i, i)
    forall (a :: * -> * -> *) e i.
    (IArray a e, Ix i) =>
    a i e -> (i, i)
    bounds Array Position OP
    aTagOp
      ifa :: Bool
    ifa = (Bool -> Bool
    not (CompOption -> Bool
    multiline CompOption
    co)) Bool -> Bool -> Bool
    && DFA -> Bool
    isDFAFrontAnchored DFA
    dfa

      indexesToDFA :: [Position] -> DFA
    indexesToDFA = {-# SCC "nfaToDFA.indexesToDFA" #-} TrieSet DFA -> [Position] -> DFA
    forall v. TrieSet v -> [Position] -> v
    Trie.lookupAsc TrieSet DFA
    trie  -- Lookup in cache

      trie :: TrieSet DFA
      trie :: TrieSet DFA
    trie = DFA
    -> (DFA -> DFA -> DFA)
    -> (Position, Position)
    -> (Position -> DFA)
    -> TrieSet DFA
    forall v.
    v
    -> (v -> v -> v)
    -> (Position, Position)
    -> (Position -> v)
    -> TrieSet v
    Trie.fromSinglesMerge DFA
    dlose DFA -> DFA -> DFA
    mergeDFA (Array Position QNFA -> (Position, Position)
    forall i. Ix i => Array i QNFA -> (i, i)
    forall (a :: * -> * -> *) e i.
    (IArray a e, Ix i) =>
    a i e -> (i, i)
    bounds Array Position QNFA
    aQNFA) Position -> DFA
    indexToDFA

      newTransition :: DTrans -> Transition
      newTransition :: DTrans -> Transition
    newTransition DTrans
    dtrans = Transition { trans_many :: DFA
    trans_many = [Position] -> DFA
    indexesToDFA (DTrans -> [Position]
    forall a. IntMap a -> [Position]
    IMap.keys DTrans
    dtransWithSpawn)
                                        , trans_single :: DFA
    trans_single = [Position] -> DFA
    indexesToDFA (DTrans -> [Position]
    forall a. IntMap a -> [Position]
    IMap.keys DTrans
    dtrans)
                                        , trans_how :: DTrans
    trans_how = DTrans
    dtransWithSpawn }
        where dtransWithSpawn :: DTrans
    dtransWithSpawn = DTrans -> DTrans
    addSpawn DTrans
    dtrans

      makeTransition :: DTrans -> Transition
      makeTransition :: DTrans -> Transition
    makeTransition DTrans
    dtrans | Bool
    hasSpawn  = Transition { trans_many :: DFA
    trans_many = [Position] -> DFA
    indexesToDFA (DTrans -> [Position]
    forall a. IntMap a -> [Position]
    IMap.keys DTrans
    dtrans)
                                                     , trans_single :: DFA
    trans_single = [Position] -> DFA
    indexesToDFA (DTrans -> [Position]
    forall a. IntMap a -> [Position]
    IMap.keys (Position -> DTrans -> DTrans
    forall a. Position -> IntMap a -> IntMap a
    IMap.delete Position
    startIndex DTrans
    dtrans))
                                                     , trans_how :: DTrans
    trans_how = DTrans
    dtrans }
                            | Bool
    otherwise = Transition { trans_many :: DFA
    trans_many = [Position] -> DFA
    indexesToDFA (DTrans -> [Position]
    forall a. IntMap a -> [Position]
    IMap.keys DTrans
    dtrans)
                                                     , trans_single :: DFA
    trans_single = [Position] -> DFA
    indexesToDFA (DTrans -> [Position]
    forall a. IntMap a -> [Position]
    IMap.keys DTrans
    dtrans)
                                                     , trans_how :: DTrans
    trans_how = DTrans
    dtrans }
        where hasSpawn :: Bool
    hasSpawn = Bool
    -> (IntMap (DoPa, Instructions) -> Bool)
    -> Maybe (IntMap (DoPa, Instructions))
    -> Bool
    forall b a. b -> (a -> b) -> Maybe a -> b
    maybe Bool
    False IntMap (DoPa, Instructions) -> Bool
    forall a. IntMap a -> Bool
    IMap.null (Position -> DTrans -> Maybe (IntMap (DoPa, Instructions))
    forall a. Position -> IntMap a -> Maybe a
    IMap.lookup Position
    startIndex DTrans
    dtrans)

      -- coming from (-1) means spawn a new starting item
      addSpawn :: DTrans -> DTrans
      addSpawn :: DTrans -> DTrans
    addSpawn DTrans
    dtrans | Position -> DTrans -> Bool
    forall a. Position -> IntMap a -> Bool
    IMap.member Position
    startIndex DTrans
    dtrans = DTrans
    dtrans
                      | Bool
    otherwise = Position -> IntMap (DoPa, Instructions) -> DTrans -> DTrans
    forall a. Position -> a -> IntMap a -> IntMap a
    IMap.insert Position
    startIndex IntMap (DoPa, Instructions)
    forall a. Monoid a => a
    mempty DTrans
    dtrans

      indexToDFA :: Index -> DFA  -- used to seed the Trie from the NFA
      indexToDFA :: Position -> DFA
    indexToDFA Position
    i = {-# SCC "nfaToDFA.indexToDFA" #-} SetIndex -> DT -> DFA
    makeDFA (Position -> SetIndex
    ISet.singleton Position
    source) (QT -> DT
    qtToDT QT
    qtIn)
        where
          (QNFA {q_id :: QNFA -> Position
    q_id = Position
    source,q_qt :: QNFA -> QT
    q_qt = QT
    qtIn}) = Array Position QNFA
    aQNFAArray Position QNFA -> Position -> QNFA
    forall (a :: * -> * -> *) e i.
    (IArray a e, Ix i) =>
    a i e -> i -> e
    !Position
    i
          qtToDT :: QT -> DT
          qtToDT :: QT -> DT
    qtToDT (Testing {qt_test :: QT -> WhichTest
    qt_test=WhichTest
    wt, qt_dopas :: QT -> EnumSet DoPa
    qt_dopas=EnumSet DoPa
    dopas, qt_a :: QT -> QT
    qt_a=QT
    a, qt_b :: QT -> QT
    qt_b=QT
    b}) =
              Testing' { dt_test :: WhichTest
    dt_test = WhichTest
    wt
                       , dt_dopas :: EnumSet DoPa
    dt_dopas = EnumSet DoPa
    dopas
                       , dt_a :: DT
    dt_a = QT -> DT
    qtToDT QT
    a
                       , dt_b :: DT
    dt_b = QT -> DT
    qtToDT QT
    b }
          qtToDT (Simple {qt_win :: QT -> WinTags
    qt_win=WinTags
    w, qt_trans :: QT -> CharMap QTrans
    qt_trans=CharMap QTrans
    t, qt_other :: QT -> QTrans
    qt_other=QTrans
    o}) =
            Simple' { dt_win :: IntMap Instructions
    dt_win = IntMap Instructions
    makeWinner
                    , dt_trans :: CharMap Transition
    dt_trans = (QTrans -> Transition) -> CharMap QTrans -> CharMap Transition
    forall a b. (a -> b) -> CharMap a -> CharMap b
    forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
    fmap QTrans -> Transition
    qtransToDFA CharMap QTrans
    t
    --                , dt_other = if IMap.null o then Just (newTransition $ IMap.singleton startIndex mempty) else Just (qtransToDFA o)}
                    , dt_other :: Transition
    dt_other = QTrans -> Transition
    qtransToDFA QTrans
    o}
            where
              makeWinner :: IntMap {- Index -} Instructions --  (RunState ())
              makeWinner :: IntMap Instructions
    makeWinner | WinTags -> Bool
    noWin WinTags
    w = IntMap Instructions
    forall a. IntMap a
    IMap.empty
                         | Bool
    otherwise = Position -> Instructions -> IntMap Instructions
    forall a. Position -> a -> IntMap a
    IMap.singleton Position
    source (WinTags -> Instructions
    cleanWin WinTags
    w)

              qtransToDFA :: QTrans -> Transition
              qtransToDFA :: QTrans -> Transition
    qtransToDFA QTrans
    qtrans = {-# SCC "nfaToDFA.indexToDFA.qtransToDFA" #-}
                                   DTrans -> Transition
    newTransition DTrans
    dtrans
                where
                  dtrans :: DTrans
                  dtrans :: DTrans
    dtrans =[(Position, IntMap (DoPa, Instructions))] -> DTrans
    forall a. [(Position, a)] -> IntMap a
    IMap.fromDistinctAscList ([(Position, IntMap (DoPa, Instructions))] -> DTrans)
    -> ([(Position, (DoPa, Instructions))]
        -> [(Position, IntMap (DoPa, Instructions))])
    -> [(Position, (DoPa, Instructions))]
    -> DTrans
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . ((DoPa, Instructions) -> IntMap (DoPa, Instructions))
    -> [(Position, (DoPa, Instructions))]
    -> [(Position, IntMap (DoPa, Instructions))]
    forall (f :: * -> *) t1 t2 t.
    Functor f =>
    (t1 -> t2) -> f (t, t1) -> f (t, t2)
    mapSnd (Position -> (DoPa, Instructions) -> IntMap (DoPa, Instructions)
    forall a. Position -> a -> IntMap a
    IMap.singleton Position
    source) ([(Position, (DoPa, Instructions))] -> DTrans)
    -> [(Position, (DoPa, Instructions))] -> DTrans
    forall a b. (a -> b) -> a -> b
    $ [(Position, (DoPa, Instructions))]
    best
                  best :: [(Index {- Destination -} ,(DoPa,Instructions))]
                  best :: [(Position, (DoPa, Instructions))]
    best = Array Position OP -> QTrans -> [(Position, (DoPa, Instructions))]
    pickQTrans Array Position OP
    aTagOp (QTrans -> [(Position, (DoPa, Instructions))])
    -> QTrans -> [(Position, (DoPa, Instructions))]
    forall a b. (a -> b) -> a -> b
    $ QTrans
    qtrans

      -- The DFA states are built up by merging the singleton ones converted from the NFA.
      -- Thus the "source" indices in the DTrans should not collide.
      mergeDFA :: DFA -> DFA -> DFA
      mergeDFA :: DFA -> DFA -> DFA
    mergeDFA DFA
    d1 DFA
    d2 = {-# SCC "nfaToDFA.mergeDFA" #-} SetIndex -> DT -> DFA
    makeDFA SetIndex
    i DT
    dt
        where
          i :: SetIndex
    i = DFA -> SetIndex
    d_id DFA
    d1 SetIndex -> SetIndex -> SetIndex
    forall a. Monoid a => a -> a -> a
    `mappend` DFA -> SetIndex
    d_id DFA
    d2
          dt :: DT
    dt = DFA -> DT
    d_dt DFA
    d1 DT -> DT -> DT
    `mergeDT` DFA -> DT
    d_dt DFA
    d2
          mergeDT,nestDT :: DT -> DT -> DT
          mergeDT :: DT -> DT -> DT
    mergeDT (Simple' IntMap Instructions
    w1 CharMap Transition
    t1 Transition
    o1) (Simple' IntMap Instructions
    w2 CharMap Transition
    t2 Transition
    o2) = IntMap Instructions -> CharMap Transition -> Transition -> DT
    Simple' IntMap Instructions
    w CharMap Transition
    t Transition
    o
            where
              w :: IntMap Instructions
    w = IntMap Instructions
    w1 IntMap Instructions -> IntMap Instructions -> IntMap Instructions
    forall a. Monoid a => a -> a -> a
    `mappend` IntMap Instructions
    w2
              t :: CharMap Transition
    t = CharMap Transition
    fuseDTrans -- t1 o1 t2 o2
              o :: Transition
    o = Transition -> Transition -> Transition
    mergeDTrans Transition
    o1 Transition
    o2
              -- This is very much like mergeQTrans
              mergeDTrans :: Transition -> Transition -> Transition
              mergeDTrans :: Transition -> Transition -> Transition
    mergeDTrans (Transition {trans_how :: Transition -> DTrans
    trans_how=DTrans
    dt1}) (Transition {trans_how :: Transition -> DTrans
    trans_how=DTrans
    dt2}) = DTrans -> Transition
    makeTransition DTrans
    dtrans
                where dtrans :: DTrans
    dtrans = (IntMap (DoPa, Instructions)
     -> IntMap (DoPa, Instructions) -> IntMap (DoPa, Instructions))
    -> DTrans -> DTrans -> DTrans
    forall a. (a -> a -> a) -> IntMap a -> IntMap a -> IntMap a
    IMap.unionWith IntMap (DoPa, Instructions)
    -> IntMap (DoPa, Instructions) -> IntMap (DoPa, Instructions)
    forall a. IntMap a -> IntMap a -> IntMap a
    IMap.union DTrans
    dt1 DTrans
    dt2
              -- This is very much like fuseQTrans
              fuseDTrans :: CharMap Transition
              fuseDTrans :: CharMap Transition
    fuseDTrans = IntMap Transition -> CharMap Transition
    forall a. IntMap a -> CharMap a
    CharMap ([(Position, Transition)] -> IntMap Transition
    forall a. [(Position, a)] -> IntMap a
    IMap.fromDistinctAscList ([(Position, Transition)]
    -> [(Position, Transition)] -> [(Position, Transition)]
    fuse [(Position, Transition)]
    l1 [(Position, Transition)]
    l2))
                where
                  l1 :: [(Position, Transition)]
    l1 = IntMap Transition -> [(Position, Transition)]
    forall a. IntMap a -> [(Position, a)]
    IMap.toAscList (CharMap Transition -> IntMap Transition
    forall a. CharMap a -> IntMap a
    unCharMap CharMap Transition
    t1)
                  l2 :: [(Position, Transition)]
    l2 = IntMap Transition -> [(Position, Transition)]
    forall a. IntMap a -> [(Position, a)]
    IMap.toAscList (CharMap Transition -> IntMap Transition
    forall a. CharMap a -> IntMap a
    unCharMap CharMap Transition
    t2)
                  fuse :: [(IMap.Key, Transition)]
                       -> [(IMap.Key, Transition)]
                       -> [(IMap.Key, Transition)]
                  fuse :: [(Position, Transition)]
    -> [(Position, Transition)] -> [(Position, Transition)]
    fuse [] [(Position, Transition)]
    y = ((Position, Transition) -> (Position, Transition))
    -> [(Position, Transition)] -> [(Position, Transition)]
    forall a b. (a -> b) -> [a] -> [b]
    forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
    fmap ((Transition -> Transition)
    -> (Position, Transition) -> (Position, Transition)
    forall a b. (a -> b) -> (Position, a) -> (Position, b)
    forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
    fmap (Transition -> Transition -> Transition
    mergeDTrans Transition
    o1)) [(Position, Transition)]
    y
                  fuse [(Position, Transition)]
    x [] = ((Position, Transition) -> (Position, Transition))
    -> [(Position, Transition)] -> [(Position, Transition)]
    forall a b. (a -> b) -> [a] -> [b]
    forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
    fmap ((Transition -> Transition)
    -> (Position, Transition) -> (Position, Transition)
    forall a b. (a -> b) -> (Position, a) -> (Position, b)
    forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
    fmap (Transition -> Transition -> Transition
    mergeDTrans Transition
    o2)) [(Position, Transition)]
    x
                  fuse x :: [(Position, Transition)]
    x@((Position
    xc,Transition
    xa):[(Position, Transition)]
    xs) y :: [(Position, Transition)]
    y@((Position
    yc,Transition
    ya):[(Position, Transition)]
    ys) =
                    case Position -> Position -> Ordering
    forall a. Ord a => a -> a -> Ordering
    compare Position
    xc Position
    yc of
                      Ordering
    LT -> (Position
    xc,Transition -> Transition -> Transition
    mergeDTrans Transition
    o2 Transition
    xa) (Position, Transition)
    -> [(Position, Transition)] -> [(Position, Transition)]
    forall a. a -> [a] -> [a]
    : [(Position, Transition)]
    -> [(Position, Transition)] -> [(Position, Transition)]
    fuse [(Position, Transition)]
    xs [(Position, Transition)]
    y
                      Ordering
    EQ -> (Position
    xc,Transition -> Transition -> Transition
    mergeDTrans Transition
    xa Transition
    ya) (Position, Transition)
    -> [(Position, Transition)] -> [(Position, Transition)]
    forall a. a -> [a] -> [a]
    : [(Position, Transition)]
    -> [(Position, Transition)] -> [(Position, Transition)]
    fuse [(Position, Transition)]
    xs [(Position, Transition)]
    ys
                      Ordering
    GT -> (Position
    yc,Transition -> Transition -> Transition
    mergeDTrans Transition
    o1 Transition
    ya) (Position, Transition)
    -> [(Position, Transition)] -> [(Position, Transition)]
    forall a. a -> [a] -> [a]
    : [(Position, Transition)]
    -> [(Position, Transition)] -> [(Position, Transition)]
    fuse [(Position, Transition)]
    x [(Position, Transition)]
    ys
          mergeDT dt1 :: DT
    dt1@(Testing' WhichTest
    wt1 EnumSet DoPa
    dopas1 DT
    a1 DT
    b1) dt2 :: DT
    dt2@(Testing' WhichTest
    wt2 EnumSet DoPa
    dopas2 DT
    a2 DT
    b2) =
            case WhichTest -> WhichTest -> Ordering
    forall a. Ord a => a -> a -> Ordering
    compare WhichTest
    wt1 WhichTest
    wt2 of
              Ordering
    LT -> DT -> DT -> DT
    nestDT DT
    dt1 DT
    dt2
              Ordering
    EQ -> Testing' { dt_test :: WhichTest
    dt_test = WhichTest
    wt1
                             , dt_dopas :: EnumSet DoPa
    dt_dopas = EnumSet DoPa
    dopas1 EnumSet DoPa -> EnumSet DoPa -> EnumSet DoPa
    forall a. Monoid a => a -> a -> a
    `mappend` EnumSet DoPa
    dopas2
                             , dt_a :: DT
    dt_a = DT -> DT -> DT
    mergeDT DT
    a1 DT
    a2
                             , dt_b :: DT
    dt_b = DT -> DT -> DT
    mergeDT DT
    b1 DT
    b2 }
              Ordering
    GT -> DT -> DT -> DT
    nestDT DT
    dt2 DT
    dt1
          mergeDT dt1 :: DT
    dt1@(Testing' {}) DT
    dt2 = DT -> DT -> DT
    nestDT DT
    dt1 DT
    dt2
          mergeDT DT
    dt1 dt2 :: DT
    dt2@(Testing' {}) = DT -> DT -> DT
    nestDT DT
    dt2 DT
    dt1
          nestDT :: DT -> DT -> DT
    nestDT dt1 :: DT
    dt1@(Testing' {dt_a :: DT -> DT
    dt_a=DT
    a,dt_b :: DT -> DT
    dt_b=DT
    b}) DT
    dt2 = DT
    dt1 { dt_a = mergeDT a dt2, dt_b = mergeDT b dt2 }
          nestDT DT
    _ DT
    _ = String -> DT
    forall a. String -> a
    err String
    "nestDT called on Simple -- cannot happen"

    patternToRegex :: (Pattern,(GroupIndex, DoPa)) -> CompOption -> ExecOption -> Regex
    patternToRegex :: (Pattern, (Position, DoPa)) -> CompOption -> ExecOption -> Regex
    patternToRegex (Pattern, (Position, DoPa))
    pattern CompOption
    compOpt ExecOption
    execOpt = ((Position, Array Position QNFA), Array Position OP,
     Array Position [GroupInfo])
    -> CompOption -> ExecOption -> Regex
    nfaToDFA (CompOption
    -> (Pattern, (Position, DoPa))
    -> ((Position, Array Position QNFA), Array Position OP,
        Array Position [GroupInfo])
    patternToNFA CompOption
    compOpt (Pattern, (Position, DoPa))
    pattern) CompOption
    compOpt ExecOption
    execOpt

    dfaMap :: DFA -> Data.Map.Map SetIndex DFA
    dfaMap :: DFA -> Map SetIndex DFA
    dfaMap = Map SetIndex DFA -> DFA -> Map SetIndex DFA
    seen (Map SetIndex DFA
    forall k a. Map k a
    Data.Map.empty) where
      seen :: Map SetIndex DFA -> DFA -> Map SetIndex DFA
    seen Map SetIndex DFA
    old d :: DFA
    d@(DFA {d_id :: DFA -> SetIndex
    d_id=SetIndex
    i,d_dt :: DFA -> DT
    d_dt=DT
    dt}) =
        if SetIndex
    i SetIndex -> Map SetIndex DFA -> Bool
    forall k a. Ord k => k -> Map k a -> Bool
    `Data.Map.member` Map SetIndex DFA
    old
          then Map SetIndex DFA
    old
          else let new :: Map SetIndex DFA
    new = SetIndex -> DFA -> Map SetIndex DFA -> Map SetIndex DFA
    forall k a. Ord k => k -> a -> Map k a -> Map k a
    Data.Map.insert SetIndex
    i DFA
    d Map SetIndex DFA
    old
               in (Map SetIndex DFA -> DFA -> Map SetIndex DFA)
    -> Map SetIndex DFA -> [DFA] -> Map SetIndex DFA
    forall b a. (b -> a -> b) -> b -> [a] -> b
    forall (t :: * -> *) b a.
    Foldable t =>
    (b -> a -> b) -> b -> t a -> b
    List.foldl' Map SetIndex DFA -> DFA -> Map SetIndex DFA
    seen Map SetIndex DFA
    new (DT -> [DFA]
    flattenDT DT
    dt)

    -- Get all trans_many states
    flattenDT :: DT -> [DFA]
    flattenDT :: DT -> [DFA]
    flattenDT (Simple' {dt_trans :: DT -> CharMap Transition
    dt_trans=(CharMap IntMap Transition
    mt),dt_other :: DT -> Transition
    dt_other=Transition
    o}) = (Transition -> [DFA]) -> [Transition] -> [DFA]
    forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
    concatMap (\Transition
    d -> [Transition -> DFA
    trans_many Transition
    d {-,trans_single d-}]) ([Transition] -> [DFA])
    -> (IntMap Transition -> [Transition])
    -> IntMap Transition
    -> [DFA]
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . (:) Transition
    o ([Transition] -> [Transition])
    -> (IntMap Transition -> [Transition])
    -> IntMap Transition
    -> [Transition]
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . IntMap Transition -> [Transition]
    forall a. IntMap a -> [a]
    IMap.elems (IntMap Transition -> [DFA]) -> IntMap Transition -> [DFA]
    forall a b. (a -> b) -> a -> b
    $ IntMap Transition
    mt
    flattenDT (Testing' {dt_a :: DT -> DT
    dt_a=DT
    a,dt_b :: DT -> DT
    dt_b=DT
    b}) = DT -> [DFA]
    flattenDT DT
    a [DFA] -> [DFA] -> [DFA]
    forall a. [a] -> [a] -> [a]
    ++ DT -> [DFA]
    flattenDT DT
    b

    examineDFA :: Regex -> String
    examineDFA :: Regex -> String
    examineDFA (Regex {regex_dfa :: Regex -> DFA
    regex_dfa=DFA
    dfa}) = [String] -> String
    unlines ([String] -> String) -> ([DFA] -> [String]) -> [DFA] -> String
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . (:) (String
    "Number of reachable DFA states: "String -> String -> String
    forall a. [a] -> [a] -> [a]
    ++Position -> String
    forall a. Show a => a -> String
    show ([DFA] -> Position
    forall a. [a] -> Position
    forall (t :: * -> *) a. Foldable t => t a -> Position
    length [DFA]
    dfas)) ([String] -> [String]) -> ([DFA] -> [String]) -> [DFA] -> [String]
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . (DFA -> String) -> [DFA] -> [String]
    forall a b. (a -> b) -> [a] -> [b]
    map DFA -> String
    forall a. Show a => a -> String
    show ([DFA] -> String) -> [DFA] -> String
    forall a b. (a -> b) -> a -> b
    $ [DFA]
    dfas
      where dfas :: [DFA]
    dfas = Map SetIndex DFA -> [DFA]
    forall k a. Map k a -> [a]
    Data.Map.elems (Map SetIndex DFA -> [DFA]) -> Map SetIndex DFA -> [DFA]
    forall a b. (a -> b) -> a -> b
    $ DFA -> Map SetIndex DFA
    dfaMap DFA
    dfa

    {-

    fillMap :: Tag -> IntMap (Position,Bool)
    fillMap tag = IMap.fromDistinctAscList [(t,(-1,True)) | t <- [0..tag] ]

    diffMap :: IntMap (Position,Bool) -> IntMap (Position,Bool) -> [(Index,(Position,Bool))]
    diffMap old new = IMap.toList (IMap.differenceWith (\a b -> if a==b then Nothing else Just b) old new)

    examineDFA :: (DFA,Index,Array Tag OP,Array GroupIndex [GroupInfo]) -> String
    examineDFA (dfa,_,aTags,_) = unlines $ map (examineDFA' (snd . bounds $ aTags)) (Map.elems $ dfaMap dfa)

    examineDFA' :: Tag -> DFA -> String
    examineDFA' maxTag = showDFA (fillMap maxTag)

    {-
    instance Show DFA where
      show (DFA {d_id=i,d_dt=dt}) = "DFA {d_id = "++show (ISet.toList i)
                                ++"\n    ,d_dt = "++ show dt
                                ++"\n}"
    -}
    -- instance Show DT where show = showDT

    showDFA :: IntMap (Position,Bool) -> DFA -> String
    showDFA m (DFA {d_id=i,d_dt=dt}) = "DFA {d_id = "++show (ISet.toList i)
                                   ++"\n    ,d_dt = "++ showDT m dt
                                   ++"\n}"
    -}

    -- pick QTrans can be told the unique source and knows all the
    -- destinations (hmm...along with qt_win)!  So if in ascending destination order the last source
    -- is free to mutatate the old state.  If the QTrans has only one
    -- entry then all we need to do is mutate that entry when making a
    -- transition.
    --
    pickQTrans :: Array Tag OP -> QTrans -> [({-Destination-}Index,(DoPa,Instructions))]
    pickQTrans :: Array Position OP -> QTrans -> [(Position, (DoPa, Instructions))]
    pickQTrans Array Position OP
    op QTrans
    tr = ([TagCommand] -> (DoPa, Instructions))
    -> [(Position, [TagCommand])] -> [(Position, (DoPa, Instructions))]
    forall (f :: * -> *) t1 t2 t.
    Functor f =>
    (t1 -> t2) -> f (t, t1) -> f (t, t2)
    mapSnd (Array Position OP -> [TagCommand] -> (DoPa, Instructions)
    bestTrans Array Position OP
    op) ([(Position, [TagCommand])] -> [(Position, (DoPa, Instructions))])
    -> (QTrans -> [(Position, [TagCommand])])
    -> QTrans
    -> [(Position, (DoPa, Instructions))]
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . QTrans -> [(Position, [TagCommand])]
    forall a. IntMap a -> [(Position, a)]
    IMap.toList (QTrans -> [(Position, (DoPa, Instructions))])
    -> QTrans -> [(Position, (DoPa, Instructions))]
    forall a b. (a -> b) -> a -> b
    $ QTrans
    tr

    cleanWin :: WinTags -> Instructions
    cleanWin :: WinTags -> Instructions
    cleanWin = WinTags -> Instructions
    toInstructions

    bestTrans :: Array Tag OP -> [TagCommand] -> (DoPa,Instructions)
    bestTrans :: Array Position OP -> [TagCommand] -> (DoPa, Instructions)
    bestTrans Array Position OP
    _ [] = String -> (DoPa, Instructions)
    forall a. String -> a
    err String
    "bestTrans : There were no transition choose from!"
    bestTrans Array Position OP
    aTagOP (TagCommand
    f:[TagCommand]
    fs) | [TagCommand] -> Bool
    forall a. [a] -> Bool
    forall (t :: * -> *) a. Foldable t => t a -> Bool
    null [TagCommand]
    fs = TagCommand -> (DoPa, Instructions)
    canonical TagCommand
    f
                            | Bool
    otherwise = (DoPa, Instructions)
    answer -- if null toDisplay then answer else trace toDisplay answer
     where
      answer :: (DoPa, Instructions)
    answer = ((DoPa, Instructions) -> TagCommand -> (DoPa, Instructions))
    -> (DoPa, Instructions) -> [TagCommand] -> (DoPa, Instructions)
    forall b a. (b -> a -> b) -> b -> [a] -> b
    forall (t :: * -> *) b a.
    Foldable t =>
    (b -> a -> b) -> b -> t a -> b
    List.foldl' (DoPa, Instructions) -> TagCommand -> (DoPa, Instructions)
    pick (TagCommand -> (DoPa, Instructions)
    canonical TagCommand
    f) [TagCommand]
    fs
      {- toDisplay | null fs = ""
                   | otherwise = unlines $ "bestTrans" : show (answer) : "from among" : concatMap (\x -> [show x, show (toInstructions (snd x))]) (f:fs) -}
      canonical :: TagCommand -> (DoPa,Instructions)
      canonical :: TagCommand -> (DoPa, Instructions)
    canonical (DoPa
    dopa,WinTags
    spec) = (DoPa
    dopa, WinTags -> Instructions
    toInstructions WinTags
    spec)
      pick :: (DoPa,Instructions) -> TagCommand -> (DoPa,Instructions)
      pick :: (DoPa, Instructions) -> TagCommand -> (DoPa, Instructions)
    pick win :: (DoPa, Instructions)
    win@(DoPa
    dopa1,Instructions
    winI) (DoPa
    dopa2,WinTags
    spec) =
        let nextI :: Instructions
    nextI = WinTags -> Instructions
    toInstructions WinTags
    spec
    --    in case compareWith choose winPos nextPos of -- XXX 2009: add in enterOrbit information
        in case (Maybe (Position, Action) -> Maybe (Position, Action) -> Ordering)
    -> [(Position, Action)] -> [(Position, Action)] -> Ordering
    forall x a b c.
    (Ord x, Monoid a) =>
    (Maybe (x, b) -> Maybe (x, c) -> a) -> [(x, b)] -> [(x, c)] -> a
    compareWith Maybe (Position, Action) -> Maybe (Position, Action) -> Ordering
    choose (Instructions -> [(Position, Action)]
    toListing Instructions
    winI) (Instructions -> [(Position, Action)]
    toListing Instructions
    nextI) of
             Ordering
    GT -> (DoPa, Instructions)
    win
             Ordering
    LT -> (DoPa
    dopa2,Instructions
    nextI)
             Ordering
    EQ -> if DoPa
    dopa1 DoPa -> DoPa -> Bool
    forall a. Ord a => a -> a -> Bool
    >= DoPa
    dopa2 then (DoPa, Instructions)
    win else (DoPa
    dopa2,Instructions
    nextI) -- no deep reason not to just pick win

      toListing :: Instructions -> [(Tag,Action)]
      toListing :: Instructions -> [(Position, Action)]
    toListing (Instructions {newPos :: Instructions -> [(Position, Action)]
    newPos = [(Position, Action)]
    nextPos}) = ((Position, Action) -> Bool)
    -> [(Position, Action)] -> [(Position, Action)]
    forall a. (a -> Bool) -> [a] -> [a]
    filter (Position, Action) -> Bool
    forall {a}. (a, Action) -> Bool
    notReset [(Position, Action)]
    nextPos
        where notReset :: (a, Action) -> Bool
    notReset (a
    _,SetVal (-1)) = Bool
    False
              notReset (a, Action)
    _ = Bool
    True
    {-
      toListing (Instructions {newPos = nextPos}) = mergeTagOrbit nextPos (filter snd nextFlags)

      mergeTagOrbit xx [] = xx
      mergeTagOrbit [] yy = yy
      mergeTagOrbit xx@(x:xs) yy@(y:ys) =
        case compare (fst x) (fst y) of
          GT -> y : mergeTagOrbit xx ys
          LT -> x : mergeTagOrbit xs yy
          EQ -> x : mergeTagOrbit xs ys -- keep tag setting over orbit setting.
    -}

      {-# INLINE choose #-}
      choose :: Maybe (Tag,Action) -> Maybe (Tag,Action) -> Ordering
      choose :: Maybe (Position, Action) -> Maybe (Position, Action) -> Ordering
    choose Maybe (Position, Action)
    Nothing Maybe (Position, Action)
    Nothing = Ordering
    EQ
      choose Maybe (Position, Action)
    Nothing Maybe (Position, Action)
    x = Ordering -> Ordering
    flipOrder (Maybe (Position, Action) -> Maybe (Position, Action) -> Ordering
    choose Maybe (Position, Action)
    x Maybe (Position, Action)
    forall a. Maybe a
    Nothing)
      choose (Just (Position
    tag,Action
    _post)) Maybe (Position, Action)
    Nothing =
        case Array Position OP
    aTagOPArray Position OP -> Position -> OP
    forall (a :: * -> * -> *) e i.
    (IArray a e, Ix i) =>
    a i e -> i -> e
    !Position
    tag of
          OP
    Maximize -> Ordering
    GT
          OP
    Minimize -> Ordering
    LT -- needed to choose best path inside nested * operators,
                        -- this needs a leading Minimize tag inside at least the parent * operator
          OP
    Ignore -> Ordering
    GT -- XXX this is a guess in analogy with Maximize for the end bit of a group
          OP
    Orbit -> Ordering
    LT -- trace ("choose LT! Just "++show tag++" < Nothing") LT -- 2009 XXX : comment out next line and use the Orbit instead
    --      Orbit -> err $ "bestTrans.choose : Very Unexpected Orbit in Just Nothing: "++show (tag,post,aTagOP,f:fs)
      choose (Just (Position
    tag,Action
    post1)) (Just (Position
    _,Action
    post2)) =
        case Array Position OP
    aTagOPArray Position OP -> Position -> OP
    forall (a :: * -> * -> *) e i.
    (IArray a e, Ix i) =>
    a i e -> i -> e
    !Position
    tag of
          OP
    Maximize -> Ordering
    order
          OP
    Minimize -> Ordering -> Ordering
    flipOrder Ordering
    order
          OP
    Ignore -> Ordering
    EQ
          OP
    Orbit -> Ordering
    EQ
    --      Orbit -> err $ "bestTrans.choose : Very Unexpected Orbit in Just Just: "++show (tag,(post1,post2),aTagOP,f:fs)
       where order :: Ordering
    order = case (Action
    post1,Action
    post2) of
                       (Action
    SetPre,Action
    SetPre) -> Ordering
    EQ
                       (Action
    SetPost,Action
    SetPost) -> Ordering
    EQ
                       (Action
    SetPre,Action
    SetPost) -> Ordering
    LT
                       (Action
    SetPost,Action
    SetPre) -> Ordering
    GT
                       (SetVal Position
    v1,SetVal Position
    v2) -> Position -> Position -> Ordering
    forall a. Ord a => a -> a -> Ordering
    compare Position
    v1 Position
    v2
                       (Action, Action)
    _ -> String -> Ordering
    forall a. String -> a
    err (String -> Ordering) -> String -> Ordering
    forall a b. (a -> b) -> a -> b
    $ String
    "bestTrans.compareWith.choose sees incomparable "String -> String -> String
    forall a. [a] -> [a] -> [a]
    ++(Position, Action, Action) -> String
    forall a. Show a => a -> String
    show (Position
    tag,Action
    post1,Action
    post2)

      {-# INLINE compareWith #-}
      compareWith :: (Ord x,Monoid a) => (Maybe (x,b) -> Maybe (x,c) -> a) -> [(x,b)] -> [(x,c)] -> a
      compareWith :: forall x a b c.
    (Ord x, Monoid a) =>
    (Maybe (x, b) -> Maybe (x, c) -> a) -> [(x, b)] -> [(x, c)] -> a
    compareWith Maybe (x, b) -> Maybe (x, c) -> a
    comp = [(x, b)] -> [(x, c)] -> a
    cw where
        cw :: [(x, b)] -> [(x, c)] -> a
    cw [] [] = Maybe (x, b) -> Maybe (x, c) -> a
    comp Maybe (x, b)
    forall a. Maybe a
    Nothing Maybe (x, c)
    forall a. Maybe a
    Nothing
        cw xx :: [(x, b)]
    xx@((x, b)
    x:[(x, b)]
    xs) yy :: [(x, c)]
    yy@((x, c)
    y:[(x, c)]
    ys) =
          case x -> x -> Ordering
    forall a. Ord a => a -> a -> Ordering
    compare ((x, b) -> x
    forall a b. (a, b) -> a
    fst (x, b)
    x) ((x, c) -> x
    forall a b. (a, b) -> a
    fst (x, c)
    y) of
            Ordering
    GT -> Maybe (x, b) -> Maybe (x, c) -> a
    comp Maybe (x, b)
    forall a. Maybe a
    Nothing  ((x, c) -> Maybe (x, c)
    forall a. a -> Maybe a
    Just (x, c)
    y) a -> a -> a
    forall a. Monoid a => a -> a -> a
    `mappend` [(x, b)] -> [(x, c)] -> a
    cw [(x, b)]
    xx [(x, c)]
    ys
            Ordering
    EQ -> Maybe (x, b) -> Maybe (x, c) -> a
    comp ((x, b) -> Maybe (x, b)
    forall a. a -> Maybe a
    Just (x, b)
    x) ((x, c) -> Maybe (x, c)
    forall a. a -> Maybe a
    Just (x, c)
    y) a -> a -> a
    forall a. Monoid a => a -> a -> a
    `mappend` [(x, b)] -> [(x, c)] -> a
    cw [(x, b)]
    xs [(x, c)]
    ys
            Ordering
    LT -> Maybe (x, b) -> Maybe (x, c) -> a
    comp ((x, b) -> Maybe (x, b)
    forall a. a -> Maybe a
    Just (x, b)
    x) Maybe (x, c)
    forall a. Maybe a
    Nothing  a -> a -> a
    forall a. Monoid a => a -> a -> a
    `mappend` [(x, b)] -> [(x, c)] -> a
    cw [(x, b)]
    xs [(x, c)]
    yy
        cw [(x, b)]
    xx [] = ((x, b) -> a -> a) -> a -> [(x, b)] -> a
    forall a b. (a -> b -> b) -> b -> [a] -> b
    forall (t :: * -> *) a b.
    Foldable t =>
    (a -> b -> b) -> b -> t a -> b
    foldr (\(x, b)
    x a
    rest -> Maybe (x, b) -> Maybe (x, c) -> a
    comp ((x, b) -> Maybe (x, b)
    forall a. a -> Maybe a
    Just (x, b)
    x) Maybe (x, c)
    forall a. Maybe a
    Nothing  a -> a -> a
    forall a. Monoid a => a -> a -> a
    `mappend` a
    rest) a
    forall a. Monoid a => a
    mempty [(x, b)]
    xx
        cw [] [(x, c)]
    yy = ((x, c) -> a -> a) -> a -> [(x, c)] -> a
    forall a b. (a -> b -> b) -> b -> [a] -> b
    forall (t :: * -> *) a b.
    Foldable t =>
    (a -> b -> b) -> b -> t a -> b
    foldr (\(x, c)
    y a
    rest -> Maybe (x, b) -> Maybe (x, c) -> a
    comp Maybe (x, b)
    forall a. Maybe a
    Nothing  ((x, c) -> Maybe (x, c)
    forall a. a -> Maybe a
    Just (x, c)
    y) a -> a -> a
    forall a. Monoid a => a -> a -> a
    `mappend` a
    rest) a
    forall a. Monoid a => a
    mempty [(x, c)]
    yy

    isDFAFrontAnchored :: DFA -> Bool
    isDFAFrontAnchored :: DFA -> Bool
    isDFAFrontAnchored = DT -> Bool
    isDTFrontAnchored (DT -> Bool) -> (DFA -> DT) -> DFA -> Bool
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . DFA -> DT
    d_dt
     where
      isDTFrontAnchored :: DT -> Bool
      isDTFrontAnchored :: DT -> Bool
    isDTFrontAnchored (Simple' {}) = Bool
    False
      isDTFrontAnchored (Testing' {dt_test :: DT -> WhichTest
    dt_test=WhichTest
    wt,dt_a :: DT -> DT
    dt_a=DT
    a,dt_b :: DT -> DT
    dt_b=DT
    b}) | WhichTest
    wt WhichTest -> WhichTest -> Bool
    forall a. Eq a => a -> a -> Bool
    == WhichTest
    Test_BOL = DT -> Bool
    isDTLosing DT
    b
                                                              | Bool
    otherwise = DT -> Bool
    isDTFrontAnchored DT
    a Bool -> Bool -> Bool
    && DT -> Bool
    isDTFrontAnchored DT
    b
       where
        -- can DT never win or accept a character (when following trans_single)?
        isDTLosing :: DT -> Bool
        isDTLosing :: DT -> Bool
    isDTLosing (Testing' {dt_a :: DT -> DT
    dt_a=DT
    a',dt_b :: DT -> DT
    dt_b=DT
    b'}) = DT -> Bool
    isDTLosing DT
    a' Bool -> Bool -> Bool
    && DT -> Bool
    isDTLosing DT
    b'
        isDTLosing (Simple' {dt_win :: DT -> IntMap Instructions
    dt_win=IntMap Instructions
    w}) | Bool -> Bool
    not (IntMap Instructions -> Bool
    forall a. IntMap a -> Bool
    IMap.null IntMap Instructions
    w) = Bool
    False -- can win with 0 characters
        isDTLosing (Simple' {dt_trans :: DT -> CharMap Transition
    dt_trans=CharMap IntMap Transition
    mt,dt_other :: DT -> Transition
    dt_other=Transition
    o}) =
          let ts :: [Transition]
    ts = Transition
    o Transition -> [Transition] -> [Transition]
    forall a. a -> [a] -> [a]
    : IntMap Transition -> [Transition]
    forall a. IntMap a -> [a]
    IMap.elems IntMap Transition
    mt
          in (Transition -> Bool) -> [Transition] -> Bool
    forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
    all Transition -> Bool
    transLoses [Transition]
    ts
         where
          transLoses :: Transition -> Bool
          transLoses :: Transition -> Bool
    transLoses (Transition {trans_single :: Transition -> DFA
    trans_single=DFA
    dfa,trans_how :: Transition -> DTrans
    trans_how=DTrans
    dtrans}) = DFA -> Bool
    isDTLose DFA
    dfa Bool -> Bool -> Bool
    || DTrans -> Bool
    onlySpawns DTrans
    dtrans
           where
            isDTLose :: DFA -> Bool
            isDTLose :: DFA -> Bool
    isDTLose DFA
    dfa' = SetIndex -> Bool
    ISet.null (DFA -> SetIndex
    d_id DFA
    dfa')
            onlySpawns :: DTrans -> Bool
            onlySpawns :: DTrans -> Bool
    onlySpawns DTrans
    t = case DTrans -> [IntMap (DoPa, Instructions)]
    forall a. IntMap a -> [a]
    IMap.elems DTrans
    t of
                             [IntMap (DoPa, Instructions)
    m] -> IntMap (DoPa, Instructions) -> Bool
    forall a. IntMap a -> Bool
    IMap.null IntMap (DoPa, Instructions)
    m
                             [IntMap (DoPa, Instructions)]
    _ -> Bool
    False

    {- toInstructions -}

    toInstructions :: TagList -> Instructions
    toInstructions :: WinTags -> Instructions
    toInstructions WinTags
    spec =
      let (IntMap Action
    p,IntMap AlterOrbit
    o) = State (IntMap Action, IntMap AlterOrbit) ()
    -> (IntMap Action, IntMap AlterOrbit)
    -> (IntMap Action, IntMap AlterOrbit)
    forall s a. State s a -> s -> s
    execState (WinTags -> State (IntMap Action, IntMap AlterOrbit) ()
    assemble WinTags
    spec) (IntMap Action
    forall a. Monoid a => a
    mempty,IntMap AlterOrbit
    forall a. Monoid a => a
    mempty)
      in Instructions { newPos :: [(Position, Action)]
    newPos = IntMap Action -> [(Position, Action)]
    forall a. IntMap a -> [(Position, a)]
    IMap.toList IntMap Action
    p
                      , newOrbits :: Maybe (Position -> OrbitTransformer)
    newOrbits = if IntMap AlterOrbit -> Bool
    forall a. IntMap a -> Bool
    IMap.null IntMap AlterOrbit
    o then Maybe (Position -> OrbitTransformer)
    forall a. Maybe a
    Nothing
                                      else (Position -> OrbitTransformer)
    -> Maybe (Position -> OrbitTransformer)
    forall a. a -> Maybe a
    Just ((Position -> OrbitTransformer)
     -> Maybe (Position -> OrbitTransformer))
    -> (Position -> OrbitTransformer)
    -> Maybe (Position -> OrbitTransformer)
    forall a b. (a -> b) -> a -> b
    $ [(Position, AlterOrbit)] -> Position -> OrbitTransformer
    alterOrbits (IntMap AlterOrbit -> [(Position, AlterOrbit)]
    forall a. IntMap a -> [(Position, a)]
    IMap.toList IntMap AlterOrbit
    o)
                      }

    type CompileInstructions a = State
      ( IntMap Action -- 2009: change to SetPre | SetPost enum
      , IntMap AlterOrbit
      ) a

    data AlterOrbit = AlterReset                        -- removing the Orbits record from the OrbitLog
                    | AlterLeave                        -- set inOrbit to False
                    | AlterModify { AlterOrbit -> Bool
    newInOrbit :: Bool   -- set inOrbit to the newInOrbit value
                                  , AlterOrbit -> Bool
    freshOrbit :: Bool}  -- freshOrbit of True means to set getOrbits to mempty
                      deriving (Position -> AlterOrbit -> String -> String
    [AlterOrbit] -> String -> String
    AlterOrbit -> String
    (Position -> AlterOrbit -> String -> String)
    -> (AlterOrbit -> String)
    -> ([AlterOrbit] -> String -> String)
    -> Show AlterOrbit
    forall a.
    (Position -> a -> String -> String)
    -> (a -> String) -> ([a] -> String -> String) -> Show a
    $cshowsPrec :: Position -> AlterOrbit -> String -> String
    showsPrec :: Position -> AlterOrbit -> String -> String
    $cshow :: AlterOrbit -> String
    show :: AlterOrbit -> String
    $cshowList :: [AlterOrbit] -> String -> String
    showList :: [AlterOrbit] -> String -> String
    Show)                   -- freshOrbit of False means try appending position or else Seq.empty

    assemble :: TagList -> CompileInstructions ()
    assemble :: WinTags -> State (IntMap Action, IntMap AlterOrbit) ()
    assemble = ((Position, TagUpdate)
     -> State (IntMap Action, IntMap AlterOrbit) ())
    -> WinTags -> State (IntMap Action, IntMap AlterOrbit) ()
    forall (t :: * -> *) (m :: * -> *) a b.
    (Foldable t, Monad m) =>
    (a -> m b) -> t a -> m ()
    mapM_ (Position, TagUpdate)
    -> State (IntMap Action, IntMap AlterOrbit) ()
    oneInstruction where
      oneInstruction :: (Position, TagUpdate)
    -> State (IntMap Action, IntMap AlterOrbit) ()
    oneInstruction (Position
    tag,TagUpdate
    command) =
        case TagUpdate
    command of
          PreUpdate TagTask
    TagTask -> Position -> State (IntMap Action, IntMap AlterOrbit) ()
    setPreTag Position
    tag
          PreUpdate TagTask
    ResetGroupStopTask -> Position -> State (IntMap Action, IntMap AlterOrbit) ()
    resetGroupTag Position
    tag
          PreUpdate TagTask
    SetGroupStopTask -> Position -> State (IntMap Action, IntMap AlterOrbit) ()
    setGroupTag Position
    tag
          PreUpdate TagTask
    ResetOrbitTask -> Position -> State (IntMap Action, IntMap AlterOrbit) ()
    resetOrbit Position
    tag
          PreUpdate TagTask
    EnterOrbitTask -> Position -> State (IntMap Action, IntMap AlterOrbit) ()
    enterOrbit Position
    tag
          PreUpdate TagTask
    LeaveOrbitTask -> Position -> State (IntMap Action, IntMap AlterOrbit) ()
    leaveOrbit Position
    tag
          PostUpdate TagTask
    TagTask -> Position -> State (IntMap Action, IntMap AlterOrbit) ()
    setPostTag Position
    tag
          PostUpdate TagTask
    ResetGroupStopTask -> Position -> State (IntMap Action, IntMap AlterOrbit) ()
    resetGroupTag Position
    tag
          PostUpdate TagTask
    SetGroupStopTask -> Position -> State (IntMap Action, IntMap AlterOrbit) ()
    setGroupTag Position
    tag
          TagUpdate
    _ -> String -> State (IntMap Action, IntMap AlterOrbit) ()
    forall a. String -> a
    err (String
    "assemble : Weird orbit command: "String -> String -> String
    forall a. [a] -> [a] -> [a]
    ++(Position, TagUpdate) -> String
    forall a. Show a => a -> String
    show (Position
    tag,TagUpdate
    command))

    setPreTag :: Tag -> CompileInstructions ()
    setPreTag :: Position -> State (IntMap Action, IntMap AlterOrbit) ()
    setPreTag = Action -> Position -> State (IntMap Action, IntMap AlterOrbit) ()
    modifyPos Action
    SetPre

    setPostTag :: Tag -> CompileInstructions ()
    setPostTag :: Position -> State (IntMap Action, IntMap AlterOrbit) ()
    setPostTag = Action -> Position -> State (IntMap Action, IntMap AlterOrbit) ()
    modifyPos Action
    SetPost

    resetGroupTag :: Tag -> CompileInstructions ()
    resetGroupTag :: Position -> State (IntMap Action, IntMap AlterOrbit) ()
    resetGroupTag = Action -> Position -> State (IntMap Action, IntMap AlterOrbit) ()
    modifyPos (Position -> Action
    SetVal (-Position
    1))

    setGroupTag :: Tag -> CompileInstructions ()
    setGroupTag :: Position -> State (IntMap Action, IntMap AlterOrbit) ()
    setGroupTag = Action -> Position -> State (IntMap Action, IntMap AlterOrbit) ()
    modifyPos (Position -> Action
    SetVal Position
    0)

    -- The following is ten times more complicated than it ought to be.  Sorry, I was too new, and now
    -- too busy to clean this up.

    resetOrbit :: Tag -> CompileInstructions ()
    resetOrbit :: Position -> State (IntMap Action, IntMap AlterOrbit) ()
    resetOrbit Position
    tag = Action -> Position -> State (IntMap Action, IntMap AlterOrbit) ()
    modifyPos (Position -> Action
    SetVal (-Position
    1)) Position
    tag State (IntMap Action, IntMap AlterOrbit) ()
    -> State (IntMap Action, IntMap AlterOrbit) ()
    -> State (IntMap Action, IntMap AlterOrbit) ()
    forall a b.
    StateT (IntMap Action, IntMap AlterOrbit) Identity a
    -> StateT (IntMap Action, IntMap AlterOrbit) Identity b
    -> StateT (IntMap Action, IntMap AlterOrbit) Identity b
    forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
    >> (IntMap AlterOrbit -> IntMap AlterOrbit)
    -> State (IntMap Action, IntMap AlterOrbit) ()
    modifyOrbit (Position -> AlterOrbit -> IntMap AlterOrbit -> IntMap AlterOrbit
    forall a. Position -> a -> IntMap a -> IntMap a
    IMap.insert Position
    tag AlterOrbit
    AlterReset)

    enterOrbit :: Tag -> CompileInstructions ()
    enterOrbit :: Position -> State (IntMap Action, IntMap AlterOrbit) ()
    enterOrbit Position
    tag = Action -> Position -> State (IntMap Action, IntMap AlterOrbit) ()
    modifyPos (Position -> Action
    SetVal Position
    0) Position
    tag State (IntMap Action, IntMap AlterOrbit) ()
    -> State (IntMap Action, IntMap AlterOrbit) ()
    -> State (IntMap Action, IntMap AlterOrbit) ()
    forall a b.
    StateT (IntMap Action, IntMap AlterOrbit) Identity a
    -> StateT (IntMap Action, IntMap AlterOrbit) Identity b
    -> StateT (IntMap Action, IntMap AlterOrbit) Identity b
    forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
    >> (IntMap AlterOrbit -> IntMap AlterOrbit)
    -> State (IntMap Action, IntMap AlterOrbit) ()
    modifyOrbit IntMap AlterOrbit -> IntMap AlterOrbit
    changeOrbit where
      changeOrbit :: IntMap AlterOrbit -> IntMap AlterOrbit
    changeOrbit = (AlterOrbit -> AlterOrbit -> AlterOrbit)
    -> Position -> AlterOrbit -> IntMap AlterOrbit -> IntMap AlterOrbit
    forall a. (a -> a -> a) -> Position -> a -> IntMap a -> IntMap a
    IMap.insertWith AlterOrbit -> AlterOrbit -> AlterOrbit
    forall {p}. p -> AlterOrbit -> AlterOrbit
    overwriteOrbit Position
    tag AlterOrbit
    appendNewOrbit

      appendNewOrbit :: AlterOrbit
    appendNewOrbit = AlterModify {newInOrbit :: Bool
    newInOrbit = Bool
    True, freshOrbit :: Bool
    freshOrbit = Bool
    False} -- try to append
      startNewOrbit :: AlterOrbit
    startNewOrbit  = AlterModify {newInOrbit :: Bool
    newInOrbit = Bool
    True, freshOrbit :: Bool
    freshOrbit = Bool
    True}  -- will start a new series

      overwriteOrbit :: p -> AlterOrbit -> AlterOrbit
    overwriteOrbit p
    _ AlterOrbit
    AlterReset = AlterOrbit
    startNewOrbit
      overwriteOrbit p
    _ AlterOrbit
    AlterLeave = AlterOrbit
    startNewOrbit
      overwriteOrbit p
    _ (AlterModify {newInOrbit :: AlterOrbit -> Bool
    newInOrbit = Bool
    False}) = AlterOrbit
    startNewOrbit
      overwriteOrbit p
    _ (AlterModify {newInOrbit :: AlterOrbit -> Bool
    newInOrbit = Bool
    True}) =
        String -> AlterOrbit
    forall a. String -> a
    err (String -> AlterOrbit) -> String -> AlterOrbit
    forall a b. (a -> b) -> a -> b
    $ String
    "enterOrbit: Cannot enterOrbit twice in a row: " String -> String -> String
    forall a. [a] -> [a] -> [a]
    ++ Position -> String
    forall a. Show a => a -> String
    show Position
    tag

    leaveOrbit :: Tag -> CompileInstructions ()
    leaveOrbit :: Position -> State (IntMap Action, IntMap AlterOrbit) ()
    leaveOrbit Position
    tag = (IntMap AlterOrbit -> IntMap AlterOrbit)
    -> State (IntMap Action, IntMap AlterOrbit) ()
    modifyOrbit IntMap AlterOrbit -> IntMap AlterOrbit
    escapeOrbit where
      escapeOrbit :: IntMap AlterOrbit -> IntMap AlterOrbit
    escapeOrbit = (AlterOrbit -> AlterOrbit -> AlterOrbit)
    -> Position -> AlterOrbit -> IntMap AlterOrbit -> IntMap AlterOrbit
    forall a. (a -> a -> a) -> Position -> a -> IntMap a -> IntMap a
    IMap.insertWith AlterOrbit -> AlterOrbit -> AlterOrbit
    forall {p}. p -> AlterOrbit -> AlterOrbit
    setInOrbitFalse Position
    tag AlterOrbit
    AlterLeave where
        setInOrbitFalse :: p -> AlterOrbit -> AlterOrbit
    setInOrbitFalse p
    _ x :: AlterOrbit
    x@(AlterModify {}) = AlterOrbit
    x {newInOrbit = False}
        setInOrbitFalse p
    _ AlterOrbit
    x = AlterOrbit
    x

    modifyPos :: Action -> Tag -> CompileInstructions ()
    modifyPos :: Action -> Position -> State (IntMap Action, IntMap AlterOrbit) ()
    modifyPos Action
    todo Position
    tag = do
      (a,c) <- StateT
      (IntMap Action, IntMap AlterOrbit)
      Identity
      (IntMap Action, IntMap AlterOrbit)
    forall s (m :: * -> *). MonadState s m => m s
    get
      let a' = Position -> Action -> IntMap Action -> IntMap Action
    forall a. Position -> a -> IntMap a -> IntMap a
    IMap.insert Position
    tag Action
    todo IntMap Action
    a
      seq a' $ put (a',c)

    modifyOrbit :: (IntMap AlterOrbit -> IntMap AlterOrbit) -> CompileInstructions ()
    modifyOrbit :: (IntMap AlterOrbit -> IntMap AlterOrbit)
    -> State (IntMap Action, IntMap AlterOrbit) ()
    modifyOrbit IntMap AlterOrbit -> IntMap AlterOrbit
    f = do
      (a,c) <- StateT
      (IntMap Action, IntMap AlterOrbit)
      Identity
      (IntMap Action, IntMap AlterOrbit)
    forall s (m :: * -> *). MonadState s m => m s
    get
      let c' = IntMap AlterOrbit -> IntMap AlterOrbit
    f IntMap AlterOrbit
    c
      seq c' $ put (a,c')

    ----

    alterOrbits :: [(Tag,AlterOrbit)] -> (Position -> OrbitTransformer)
    alterOrbits :: [(Position, AlterOrbit)] -> Position -> OrbitTransformer
    alterOrbits [(Position, AlterOrbit)]
    x = let items :: [Position -> OrbitTransformer]
    items = ((Position, AlterOrbit) -> Position -> OrbitTransformer)
    -> [(Position, AlterOrbit)] -> [Position -> OrbitTransformer]
    forall a b. (a -> b) -> [a] -> [b]
    map (Position, AlterOrbit) -> Position -> OrbitTransformer
    alterOrbit [(Position, AlterOrbit)]
    x
                    in (\ Position
    pos OrbitLog
    m -> (OrbitLog -> OrbitTransformer -> OrbitLog)
    -> OrbitLog -> [OrbitTransformer] -> OrbitLog
    forall b a. (b -> a -> b) -> b -> [a] -> b
    forall (t :: * -> *) b a.
    Foldable t =>
    (b -> a -> b) -> b -> t a -> b
    foldl ((OrbitTransformer -> OrbitTransformer)
    -> OrbitLog -> OrbitTransformer -> OrbitLog
    forall a b c. (a -> b -> c) -> b -> a -> c
    flip OrbitTransformer -> OrbitTransformer
    forall a b. (a -> b) -> a -> b
    ($)) OrbitLog
    m (((Position -> OrbitTransformer) -> OrbitTransformer)
    -> [Position -> OrbitTransformer] -> [OrbitTransformer]
    forall a b. (a -> b) -> [a] -> [b]
    map ((Position -> OrbitTransformer) -> Position -> OrbitTransformer
    forall a b. (a -> b) -> a -> b
    $ Position
    pos) [Position -> OrbitTransformer]
    items))

    alterOrbit :: (Tag,AlterOrbit) -> (Position -> OrbitTransformer)

    alterOrbit :: (Position, AlterOrbit) -> Position -> OrbitTransformer
    alterOrbit (Position
    tag,AlterModify {newInOrbit :: AlterOrbit -> Bool
    newInOrbit = Bool
    inOrbit',freshOrbit :: AlterOrbit -> Bool
    freshOrbit = Bool
    True}) =
      (\ Position
    pos OrbitLog
    m -> Position -> Orbits -> OrbitTransformer
    forall a. Position -> a -> IntMap a -> IntMap a
    IMap.insert Position
    tag (Orbits { inOrbit :: Bool
    inOrbit = Bool
    inOrbit'
                                         , basePos :: Position
    basePos = Position
    pos
                                         , ordinal :: Maybe Position
    ordinal = Maybe Position
    forall a. Maybe a
    Nothing
                                         , getOrbits :: Seq Position
    getOrbits = Seq Position
    forall a. Monoid a => a
    mempty}) OrbitLog
    m)

    alterOrbit (Position
    tag,AlterModify {newInOrbit :: AlterOrbit -> Bool
    newInOrbit = Bool
    inOrbit',freshOrbit :: AlterOrbit -> Bool
    freshOrbit = Bool
    False}) =
      (\ Position
    pos OrbitLog
    m -> (Position -> Orbits -> Orbits -> Orbits)
    -> Position -> Orbits -> OrbitTransformer
    forall a.
    (Position -> a -> a -> a) -> Position -> a -> IntMap a -> IntMap a
    IMap.insertWithKey (Position -> Position -> Orbits -> Orbits -> Orbits
    forall {p}. Position -> p -> Orbits -> Orbits -> Orbits
    updateOrbit Position
    pos) Position
    tag (Position -> Orbits
    newOrbit Position
    pos) OrbitLog
    m) where
      newOrbit :: Position -> Orbits
    newOrbit Position
    pos = Orbits { inOrbit :: Bool
    inOrbit = Bool
    inOrbit'
                            , basePos :: Position
    basePos = Position
    pos
                            , ordinal :: Maybe Position
    ordinal = Maybe Position
    forall a. Maybe a
    Nothing
                            , getOrbits :: Seq Position
    getOrbits = Seq Position
    forall a. Monoid a => a
    Mon.mempty}
      updateOrbit :: Position -> p -> Orbits -> Orbits -> Orbits
    updateOrbit Position
    pos p
    _tag Orbits
    new Orbits
    old | Orbits -> Bool
    inOrbit Orbits
    old = Orbits
    old { inOrbit = inOrbit'
                                                       , getOrbits = getOrbits old |> pos }
                                   | Bool
    otherwise = Orbits
    new

    alterOrbit (Position
    tag,AlterOrbit
    AlterReset) = (\ Position
    _ OrbitLog
    m -> Position -> OrbitTransformer
    forall a. Position -> IntMap a -> IntMap a
    IMap.delete Position
    tag OrbitLog
    m)

    alterOrbit (Position
    tag,AlterOrbit
    AlterLeave) = (\ Position
    _ OrbitLog
    m -> case Position -> OrbitLog -> Maybe Orbits
    forall a. Position -> IntMap a -> Maybe a
    IMap.lookup Position
    tag OrbitLog
    m of
                                             Maybe Orbits
    Nothing -> OrbitLog
    m
                                             Just Orbits
    x -> Position -> Orbits -> OrbitTransformer
    forall a. Position -> a -> IntMap a -> IntMap a
    IMap.insert Position
    tag (Orbits
    x {inOrbit=False}) OrbitLog
    m)