-- | "Text.Regex.TDFA.TDFA" converts the QNFA from TNFA into the DFA.
-- A DFA state corresponds to a Set of QNFA states, repesented 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 Data.List(foldl')
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 (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 (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 (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 (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 (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((Transition -> Transition)
-> (Position, Transition) -> (Position, Transition)
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 (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((Transition -> Transition)
-> (Position, Transition) -> (Position, Transition)
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 :: DT
dt_a = DT -> DT -> DT
mergeDT DT
a DT
dt2, dt_b :: DT
dt_b = DT -> DT -> DT
mergeDT DT
b DT
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 (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
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 (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 (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 (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
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 Unexpeted 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 Unexpeted 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 (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 (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
showList :: [AlterOrbit] -> String -> String
$cshowList :: [AlterOrbit] -> String -> String
show :: AlterOrbit -> String
$cshow :: AlterOrbit -> String
showsPrec :: Position -> AlterOrbit -> String -> String
$cshowsPrec :: Position -> 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 (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 (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 :: Bool
newInOrbit = Bool
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
  (IntMap Action
a,IntMap AlterOrbit
c) <- StateT
  (IntMap Action, IntMap AlterOrbit)
  Identity
  (IntMap Action, IntMap AlterOrbit)
forall s (m :: * -> *). MonadState s m => m s
get
  let a' :: IntMap Action
a' = Position -> Action -> IntMap Action -> IntMap Action
forall a. Position -> a -> IntMap a -> IntMap a
IMap.insert Position
tag Action
todo IntMap Action
a
  IntMap Action
-> State (IntMap Action, IntMap AlterOrbit) ()
-> State (IntMap Action, IntMap AlterOrbit) ()
seq IntMap Action
a' (State (IntMap Action, IntMap AlterOrbit) ()
 -> State (IntMap Action, IntMap AlterOrbit) ())
-> State (IntMap Action, IntMap AlterOrbit) ()
-> State (IntMap Action, IntMap AlterOrbit) ()
forall a b. (a -> b) -> a -> b
$ (IntMap Action, IntMap AlterOrbit)
-> State (IntMap Action, IntMap AlterOrbit) ()
forall s (m :: * -> *). MonadState s m => s -> m ()
put (IntMap Action
a',IntMap AlterOrbit
c)

modifyOrbit :: (IntMap AlterOrbit -> IntMap AlterOrbit) -> CompileInstructions ()
modifyOrbit :: (IntMap AlterOrbit -> IntMap AlterOrbit)
-> State (IntMap Action, IntMap AlterOrbit) ()
modifyOrbit IntMap AlterOrbit -> IntMap AlterOrbit
f = do
  (IntMap Action
a,IntMap AlterOrbit
c) <- StateT
  (IntMap Action, IntMap AlterOrbit)
  Identity
  (IntMap Action, IntMap AlterOrbit)
forall s (m :: * -> *). MonadState s m => m s
get
  let c' :: IntMap AlterOrbit
c' = IntMap AlterOrbit -> IntMap AlterOrbit
f IntMap AlterOrbit
c
  IntMap AlterOrbit
-> State (IntMap Action, IntMap AlterOrbit) ()
-> State (IntMap Action, IntMap AlterOrbit) ()
seq IntMap AlterOrbit
c' (State (IntMap Action, IntMap AlterOrbit) ()
 -> State (IntMap Action, IntMap AlterOrbit) ())
-> State (IntMap Action, IntMap AlterOrbit) ()
-> State (IntMap Action, IntMap AlterOrbit) ()
forall a b. (a -> b) -> a -> b
$ (IntMap Action, IntMap AlterOrbit)
-> State (IntMap Action, IntMap AlterOrbit) ()
forall s (m :: * -> *). MonadState s m => s -> m ()
put (IntMap Action
a,IntMap AlterOrbit
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 (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 :: Bool
inOrbit = Bool
inOrbit'
                                                   , getOrbits :: Seq Position
getOrbits = Orbits -> Seq Position
getOrbits Orbits
old Seq Position -> Position -> Seq Position
forall a. Seq a -> a -> Seq a
|> Position
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 :: Bool
inOrbit=Bool
False}) OrbitLog
m)