{-# LANGUAGE CPP #-}

#if __GLASGOW_HASKELL__ >= 902
{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-}
#endif

-- | This is the code for the main engine.  This captures the posix subexpressions. This 'execMatch'
-- also dispatches to "Engine_NC", "Engine_FA", and "Engine_FC_NA"
--
-- It is polymorphic over the internal Uncons type class, and specialized to produce the needed
-- variants.
module Text.Regex.TDFA.NewDFA.Engine(execMatch) where

import Control.Monad(when,forM,forM_,liftM2,foldM,join,filterM)
import Data.Array.Base(unsafeRead,unsafeWrite,STUArray(..))
-- #ifdef __GLASGOW_HASKELL__
import GHC.Arr(STArray(..))
import GHC.ST(ST(..))
import GHC.Exts(MutableByteArray#,RealWorld,Int#,sizeofMutableByteArray#,unsafeCoerce#)
{-
-- #else
import Control.Monad.ST(ST)
import Data.Array.ST(STArray)
-- #endif
-}
import Prelude hiding ((!!))

import Data.Array.MArray(MArray(..))
import Data.Array.Unsafe(unsafeFreeze)
import Data.Array.IArray(Array,bounds,assocs,Ix(rangeSize,range))
import qualified Data.IntMap.CharMap2 as CMap(findWithDefault)
import Data.IntMap(IntMap)
import qualified Data.IntMap as IMap(null,toList,lookup,insert)
import Data.Maybe(catMaybes)
import Data.Monoid as Mon(Monoid(..))
import qualified Data.IntSet as ISet(toAscList)
import Data.Array.IArray((!))
import Data.List(partition,sort,foldl',sortBy,groupBy)
import Data.STRef(STRef,newSTRef,readSTRef,writeSTRef)
import qualified Control.Monad.ST.Lazy as L(ST,runST,strictToLazyST)
import qualified Control.Monad.ST.Strict as S(ST)
import Data.Sequence(Seq,ViewL(..),viewl)
import qualified Data.Sequence as Seq(null)
import qualified Data.ByteString.Char8 as SBS(ByteString)
import qualified Data.ByteString.Lazy.Char8 as LBS(ByteString)

import Text.Regex.Base(MatchArray,MatchOffset,MatchLength)
import qualified Text.Regex.TDFA.IntArrTrieSet as Trie(lookupAsc)
import Text.Regex.TDFA.Common hiding (indent)
import Text.Regex.TDFA.NewDFA.Uncons(Uncons(uncons))
import Text.Regex.TDFA.NewDFA.MakeTest(test_singleline,test_multiline)
import qualified Text.Regex.TDFA.NewDFA.Engine_FA as FA(execMatch)
import qualified Text.Regex.TDFA.NewDFA.Engine_NC as NC(execMatch)
import qualified Text.Regex.TDFA.NewDFA.Engine_NC_FA as NC_FA(execMatch)

--import Debug.Trace

-- trace :: String -> a -> a
-- trace _ a = a
{-
see :: (Show x, Monad m) => String ->  x -> m a -> m a
see _ _ m = m
--see msg s m = trace ("\nsee: "++msg++" : "++show s) m

sees :: (Monad m) => String ->  String -> m a -> m a
sees _ _ m = m
--sees msg s m = trace ("\nsee: "++msg++" :\n"++s) m
-}
err :: String -> a
err :: forall a. [Char] -> a
err [Char]
s = [Char] -> [Char] -> a
forall a. [Char] -> [Char] -> a
common_error [Char]
"Text.Regex.TDFA.NewDFA.Engine"  [Char]
s

{-# INLINE (!!) #-}
(!!) :: (MArray a e (S.ST s),Ix i) => a i e -> Int -> S.ST s e
!! :: forall (a :: * -> * -> *) e s i.
(MArray a e (ST s), Ix i) =>
a i e -> Position -> ST s e
(!!) = a i e -> Position -> ST s e
forall (a :: * -> * -> *) e (m :: * -> *) i.
(MArray a e m, Ix i) =>
a i e -> Position -> m e
unsafeRead
{-# INLINE set #-}
set :: (MArray a e (S.ST s),Ix i) => a i e -> Int -> e -> S.ST s ()
set :: forall (a :: * -> * -> *) e s i.
(MArray a e (ST s), Ix i) =>
a i e -> Position -> e -> ST s ()
set = a i e -> Position -> e -> ST s ()
forall (a :: * -> * -> *) e (m :: * -> *) i.
(MArray a e m, Ix i) =>
a i e -> Position -> e -> m ()
unsafeWrite

{-# SPECIALIZE execMatch :: Regex -> Position -> Char -> ([] Char) -> [MatchArray] #-}
{-# SPECIALIZE execMatch :: Regex -> Position -> Char -> (Seq Char) -> [MatchArray] #-}
{-# SPECIALIZE execMatch :: Regex -> Position -> Char -> SBS.ByteString -> [MatchArray] #-}
{-# SPECIALIZE execMatch :: Regex -> Position -> Char -> LBS.ByteString -> [MatchArray] #-}
execMatch :: Uncons text => Regex -> Position -> Char -> text -> [MatchArray]
execMatch :: forall text.
Uncons text =>
Regex -> Position -> Char -> text -> [MatchArray]
execMatch r :: Regex
r@(Regex { regex_dfa :: Regex -> DFA
regex_dfa = DFA {d_id :: DFA -> SetIndex
d_id=SetIndex
didIn,d_dt :: DFA -> DT
d_dt=DT
dtIn}
                   , regex_init :: Regex -> Position
regex_init = Position
startState
                   , regex_b_index :: Regex -> (Position, Position)
regex_b_index = (Position, Position)
b_index
                   , regex_b_tags :: Regex -> (Position, Position)
regex_b_tags = (Position, Position)
b_tags_all
                   , regex_trie :: Regex -> TrieSet DFA
regex_trie = TrieSet DFA
trie
                   , regex_tags :: Regex -> Array Position OP
regex_tags = Array Position OP
aTags
                   , regex_groups :: Regex -> Array Position [GroupInfo]
regex_groups = Array Position [GroupInfo]
aGroups
                   , regex_isFrontAnchored :: Regex -> Bool
regex_isFrontAnchored = Bool
frontAnchored
                   , regex_compOptions :: Regex -> CompOption
regex_compOptions = CompOption { multiline :: CompOption -> Bool
multiline = Bool
newline }
                   , regex_execOptions :: Regex -> ExecOption
regex_execOptions = ExecOption { captureGroups :: ExecOption -> Bool
captureGroups = Bool
capture }})
          Position
offsetIn Char
prevIn text
inputIn = case (Bool
subCapture,Bool
frontAnchored) of
                                      (Bool
True  ,Bool
False) -> (forall s. ST s [MatchArray]) -> [MatchArray]
forall a. (forall s. ST s a) -> a
L.runST forall s. ST s [MatchArray]
runCaptureGroup
                                      (Bool
True  ,Bool
True)  -> Regex -> Position -> Char -> text -> [MatchArray]
forall text.
Uncons text =>
Regex -> Position -> Char -> text -> [MatchArray]
FA.execMatch Regex
r Position
offsetIn Char
prevIn text
inputIn
                                      (Bool
False ,Bool
False) -> Regex -> Position -> Char -> text -> [MatchArray]
forall text.
Uncons text =>
Regex -> Position -> Char -> text -> [MatchArray]
NC.execMatch Regex
r Position
offsetIn Char
prevIn text
inputIn
                                      (Bool
False ,Bool
True)  -> Regex -> Position -> Char -> text -> [MatchArray]
forall text.
Uncons text =>
Regex -> Position -> Char -> text -> [MatchArray]
NC_FA.execMatch Regex
r Position
offsetIn Char
prevIn text
inputIn
 where
  subCapture :: Bool
  subCapture :: Bool
subCapture = Bool
capture Bool -> Bool -> Bool
&& (Position
1Position -> Position -> Bool
forall a. Ord a => a -> a -> Bool
<=(Position, Position) -> Position
forall a. Ix a => (a, a) -> Position
rangeSize (Array Position [GroupInfo] -> (Position, Position)
forall (a :: * -> * -> *) e i.
(IArray a e, Ix i) =>
a i e -> (i, i)
bounds Array Position [GroupInfo]
aGroups))

  b_tags :: (Tag,Tag)
  !b_tags :: (Position, Position)
b_tags = (Position, Position)
b_tags_all

  orbitTags :: [Tag]
  !orbitTags :: [Position]
orbitTags = ((Position, OP) -> Position) -> [(Position, OP)] -> [Position]
forall a b. (a -> b) -> [a] -> [b]
map (Position, OP) -> Position
forall a b. (a, b) -> a
fst ([(Position, OP)] -> [Position])
-> (Array Position OP -> [(Position, OP)])
-> Array Position OP
-> [Position]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((Position, OP) -> Bool) -> [(Position, OP)] -> [(Position, OP)]
forall a. (a -> Bool) -> [a] -> [a]
filter ((OP
OrbitOP -> OP -> Bool
forall a. Eq a => a -> a -> Bool
==)(OP -> Bool) -> ((Position, OP) -> OP) -> (Position, OP) -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
.(Position, OP) -> OP
forall a b. (a, b) -> b
snd) ([(Position, OP)] -> [(Position, OP)])
-> (Array Position OP -> [(Position, OP)])
-> Array Position OP
-> [(Position, OP)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Array Position OP -> [(Position, OP)]
forall (a :: * -> * -> *) e i.
(IArray a e, Ix i) =>
a i e -> [(i, e)]
assocs (Array Position OP -> [Position])
-> Array Position OP -> [Position]
forall a b. (a -> b) -> a -> b
$ Array Position OP
aTags

  !test :: WhichTest -> Position -> Char -> text -> Bool
test = Bool -> WhichTest -> Position -> Char -> text -> Bool
forall text.
Uncons text =>
Bool -> WhichTest -> Position -> Char -> text -> Bool
mkTest Bool
newline

  comp :: C s
  comp :: forall s. C s
comp = {-# SCC "matchHere.comp" #-} Array Position OP -> C s
forall s. Array Position OP -> C s
ditzyComp'3 Array Position OP
aTags

  runCaptureGroup :: L.ST s [MatchArray]
  runCaptureGroup :: forall s. ST s [MatchArray]
runCaptureGroup = {-# SCC "runCaptureGroup" #-} do
    ST s [MatchArray]
obtainNext <- ST s (ST s [MatchArray]) -> ST s (ST s [MatchArray])
forall s a. ST s a -> ST s a
L.strictToLazyST ST s (ST s [MatchArray])
forall s. ST s (ST s [MatchArray])
constructNewEngine
    let loop :: ST s [MatchArray]
loop = do [MatchArray]
vals <- ST s [MatchArray] -> ST s [MatchArray]
forall s a. ST s a -> ST s a
L.strictToLazyST ST s [MatchArray]
obtainNext
                  if [MatchArray] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [MatchArray]
vals -- force vals before defining valsRest
                    then [MatchArray] -> ST s [MatchArray]
forall (m :: * -> *) a. Monad m => a -> m a
return [] -- end of capturing
                    else do [MatchArray]
valsRest <- ST s [MatchArray]
loop
                            [MatchArray] -> ST s [MatchArray]
forall (m :: * -> *) a. Monad m => a -> m a
return ([MatchArray]
vals [MatchArray] -> [MatchArray] -> [MatchArray]
forall a. [a] -> [a] -> [a]
++ [MatchArray]
valsRest)
    ST s [MatchArray]
loop

  constructNewEngine :: S.ST s (S.ST s [MatchArray])
  constructNewEngine :: forall s. ST s (ST s [MatchArray])
constructNewEngine =  {-# SCC "constructNewEngine" #-} do
    STRef s (ST s [MatchArray])
storeNext <- ST s [MatchArray] -> ST s (STRef s (ST s [MatchArray]))
forall a s. a -> ST s (STRef s a)
newSTRef ST s [MatchArray]
forall a. HasCallStack => a
undefined
    STRef s (ST s [MatchArray]) -> ST s [MatchArray] -> ST s ()
forall s a. STRef s a -> a -> ST s ()
writeSTRef STRef s (ST s [MatchArray])
storeNext (STRef s (ST s [MatchArray]) -> ST s [MatchArray]
forall s. STRef s (ST s [MatchArray]) -> ST s [MatchArray]
goNext STRef s (ST s [MatchArray])
storeNext)
    let obtainNext :: ST s [MatchArray]
obtainNext = ST s (ST s [MatchArray]) -> ST s [MatchArray]
forall (m :: * -> *) a. Monad m => m (m a) -> m a
join (STRef s (ST s [MatchArray]) -> ST s (ST s [MatchArray])
forall s a. STRef s a -> ST s a
readSTRef STRef s (ST s [MatchArray])
storeNext)
    ST s [MatchArray] -> ST s (ST s [MatchArray])
forall (m :: * -> *) a. Monad m => a -> m a
return ST s [MatchArray]
obtainNext

  goNext :: STRef s (ST s [MatchArray]) -> ST s [MatchArray]
  goNext :: forall s. STRef s (ST s [MatchArray]) -> ST s [MatchArray]
goNext STRef s (ST s [MatchArray])
storeNext = {-# SCC "goNext" #-} do
    (SScratch MScratch s
s1In MScratch s
s2In (MQ s
winQ,BlankScratch s
blank,STArray
  s
  Position
  ((Position, Instructions), STUArray s Position Position, OrbitLog)
which)) <- (Position, Position) -> (Position, Position) -> ST s (SScratch s)
forall s.
(Position, Position) -> (Position, Position) -> ST s (SScratch s)
newScratch (Position, Position)
b_index (Position, Position)
b_tags
    Position
_ <- (Position, Position)
-> BlankScratch s
-> Position
-> MScratch s
-> Position
-> ST s Position
forall s.
(Position, Position)
-> BlankScratch s
-> Position
-> MScratch s
-> Position
-> ST s Position
spawnStart (Position, Position)
b_tags BlankScratch s
blank Position
startState MScratch s
s1In Position
offsetIn
    STRef s Bool
eliminatedStateFlag <- Bool -> ST s (STRef s Bool)
forall a s. a -> ST s (STRef s a)
newSTRef Bool
False
    STRef s Bool
eliminatedRespawnFlag <- Bool -> ST s (STRef s Bool)
forall a s. a -> ST s (STRef s a)
newSTRef Bool
False
    let next :: MScratch s
-> MScratch s
-> SetIndex
-> DT
-> Position
-> Char
-> text
-> ST s [MatchArray]
next MScratch s
s1 MScratch s
s2 SetIndex
did DT
dt Position
offset Char
prev text
input = {-# SCC "goNext.next" #-}
          case DT
dt of
            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} ->
              if WhichTest -> Position -> Char -> text -> Bool
test WhichTest
wt Position
offset Char
prev text
input
                then MScratch s
-> MScratch s
-> SetIndex
-> DT
-> Position
-> Char
-> text
-> ST s [MatchArray]
next MScratch s
s1 MScratch s
s2 SetIndex
did DT
a Position
offset Char
prev text
input
                else MScratch s
-> MScratch s
-> SetIndex
-> DT
-> Position
-> Char
-> text
-> ST s [MatchArray]
next MScratch s
s1 MScratch s
s2 SetIndex
did DT
b Position
offset Char
prev text
input
            Simple' {dt_win :: DT -> IntMap Instructions
dt_win=IntMap Instructions
w,dt_trans :: DT -> CharMap Transition
dt_trans=CharMap Transition
t, dt_other :: DT -> Transition
dt_other=Transition
o}
              | IntMap Instructions -> Bool
forall a. IntMap a -> Bool
IMap.null IntMap Instructions
w ->
                  case text -> Maybe (Char, text)
forall a. Uncons a => a -> Maybe (Char, a)
uncons text
input of
                    Maybe (Char, text)
Nothing -> ST s [MatchArray]
finalizeWinners
                    Just (Char
c,text
input') ->
                      case Transition -> Char -> CharMap Transition -> Transition
forall a. a -> Char -> CharMap a -> a
CMap.findWithDefault Transition
o Char
c CharMap Transition
t of
                        Transition {trans_many :: Transition -> DFA
trans_many=DFA {d_id :: DFA -> SetIndex
d_id=SetIndex
did',d_dt :: DFA -> DT
d_dt=DT
dt'},trans_how :: Transition -> DTrans
trans_how=DTrans
dtrans} ->
                          MScratch s
-> MScratch s
-> SetIndex
-> SetIndex
-> DT
-> DTrans
-> Position
-> Char
-> text
-> ST s [MatchArray]
findTrans MScratch s
s1 MScratch s
s2 SetIndex
did SetIndex
did' DT
dt' DTrans
dtrans Position
offset Char
c text
input'
              | Bool
otherwise -> do
                  (SetIndex
did',DT
dt') <- MScratch s
-> SetIndex
-> DT
-> IntMap Instructions
-> Position
-> ST s (SetIndex, DT)
processWinner MScratch s
s1 SetIndex
did DT
dt IntMap Instructions
w Position
offset
                  MScratch s
-> MScratch s
-> SetIndex
-> DT
-> Position
-> Char
-> text
-> ST s [MatchArray]
next' MScratch s
s1 MScratch s
s2 SetIndex
did' DT
dt' Position
offset Char
prev text
input

        next' :: MScratch s
-> MScratch s
-> SetIndex
-> DT
-> Position
-> Char
-> text
-> ST s [MatchArray]
next' MScratch s
s1 MScratch s
s2 SetIndex
did DT
dt Position
offset Char
prev text
input = {-# SCC "goNext.next'" #-}
          case DT
dt of
            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} ->
              if WhichTest -> Position -> Char -> text -> Bool
test WhichTest
wt Position
offset Char
prev text
input
                then MScratch s
-> MScratch s
-> SetIndex
-> DT
-> Position
-> Char
-> text
-> ST s [MatchArray]
next' MScratch s
s1 MScratch s
s2 SetIndex
did DT
a Position
offset Char
prev text
input
                else MScratch s
-> MScratch s
-> SetIndex
-> DT
-> Position
-> Char
-> text
-> ST s [MatchArray]
next' MScratch s
s1 MScratch s
s2 SetIndex
did DT
b Position
offset Char
prev text
input
            Simple' {dt_trans :: DT -> CharMap Transition
dt_trans=CharMap Transition
t, dt_other :: DT -> Transition
dt_other=Transition
o} ->
              case text -> Maybe (Char, text)
forall a. Uncons a => a -> Maybe (Char, a)
uncons text
input of
                Maybe (Char, text)
Nothing -> ST s [MatchArray]
finalizeWinners
                Just (Char
c,text
input') ->
                  case Transition -> Char -> CharMap Transition -> Transition
forall a. a -> Char -> CharMap a -> a
CMap.findWithDefault Transition
o Char
c CharMap Transition
t of
                    Transition {trans_many :: Transition -> DFA
trans_many=DFA {d_id :: DFA -> SetIndex
d_id=SetIndex
did',d_dt :: DFA -> DT
d_dt=DT
dt'},trans_how :: Transition -> DTrans
trans_how=DTrans
dtrans} ->
                      MScratch s
-> MScratch s
-> SetIndex
-> SetIndex
-> DT
-> DTrans
-> Position
-> Char
-> text
-> ST s [MatchArray]
findTrans MScratch s
s1 MScratch s
s2 SetIndex
did SetIndex
did' DT
dt' DTrans
dtrans Position
offset Char
c text
input'

-- compressOrbits gets all the current Tag-0 start information from
-- the NFA states; then it loops through all the Orbit tags with
-- compressOrbit.
--
-- compressOrbit on such a Tag loops through all the NFS states'
-- m_orbit record, discarding ones that are Nothing and discarding
-- ones that are too new to care about (after the cutoff value).
--
-- compressOrbit then groups the Orbits records by the Tag-0 start
-- position and the basePos position.  Entries in different groups
-- will never be comparable in the future so they can be processed
-- separately.  Groups could probably be even more finely
-- distinguished, as a futher optimization, but the justification will
-- be tricky.
--
-- Current Tag-0 values are at most offset and all newly spawned
-- groups will have Tag-0 of at least (succ offset) so the current
-- groups are closed to those spawned in the future.  The basePos may
-- be as large as offset and may be overwritten later with values of
-- offset or larger (and this will also involve deleting the Orbits
-- record).  Thus there could be a future collision between a current
-- group with basePos==offset and an updated record that acquires
-- basePos==offset.  By excluding groups with basePos before the
-- current offset the collision between existing and future records
-- is avoided.
--
-- An entry in a group can only collide with that group's
-- descendents. compressOrbit sends each group to the compressGroup
-- command.
--
-- compressGroup on a single record checks whether it's Seq can be
-- cleared and if so it will clear it (and set ordinal to Nothing but
-- this this not particularly important).
--
-- compressGroup on many records sorts and groups the members and zips
-- the groups with their new ordinal value.  The comparision is based
-- on the old ordinal value, then the inOrbit value, and then the (Seq
-- Position) data.
--
-- The old ordinals of the group will all be Nothing or all be Just,
-- but this condition is neither checked nor violations detected.
-- This comparision is justified because once records get different
-- ordinals assigned they will never change places.
--
-- The inOrbit Bool is only different if one of them has set the stop
-- position to at most (succ offset).  They will obly be compared if
-- the other one leaves, an its stop position will be at least offset.
-- The previous sentence is justified by inspectin of the "assemble"
-- function in the TDFA module: there is no (PostUpdate
-- LeaveOrbitTask) so the largest possible value for the stop Tag is
-- (pred offset). Thus the record with inOrbit==False would beat (be
-- GT than) the record with inOrbit==True.
--
-- The Seq comparison is safe because the largest existing Position
-- value is (pred offset) and the smallest future Position value is
-- offset.  The previous sentence is justified by inspectin of the
-- "assemble" function in the TDFA module: there is no (PostUpdate
-- EnterOrbitTags) so the largest possible value in the Seq is (pred
-- offset).
--
-- The updated Orbits get the new ordinal value and an empty (Seq
-- Position).

        compressOrbits :: MScratch s -> SetIndex -> Position -> ST s ()
compressOrbits MScratch s
s1 SetIndex
did Position
offset = do
          let getStart :: Position -> ST s (Position, Position)
getStart Position
state = do Position
start <- ST s Position
-> (STUArray s Position Position -> ST s Position)
-> Maybe (STUArray s Position Position)
-> ST s Position
forall b a. b -> (a -> b) -> Maybe a -> b
maybe ([Char] -> ST s Position
forall a. [Char] -> a
err [Char]
"compressOrbit,1") (STUArray s Position Position -> Position -> ST s Position
forall (a :: * -> * -> *) e s i.
(MArray a e (ST s), Ix i) =>
a i e -> Position -> ST s e
!! Position
0) (Maybe (STUArray s Position Position) -> ST s Position)
-> ST s (Maybe (STUArray s Position Position)) -> ST s Position
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< MScratch s
-> STArray s Position (Maybe (STUArray s Position Position))
forall s.
MScratch s
-> STArray s Position (Maybe (STUArray s Position Position))
m_pos MScratch s
s1 STArray s Position (Maybe (STUArray s Position Position))
-> Position -> ST s (Maybe (STUArray s Position Position))
forall (a :: * -> * -> *) e s i.
(MArray a e (ST s), Ix i) =>
a i e -> Position -> ST s e
!! Position
state
                                  (Position, Position) -> ST s (Position, Position)
forall (m :: * -> *) a. Monad m => a -> m a
return (Position
state,Position
start)
              cutoff :: Position
cutoff = Position
offset Position -> Position -> Position
forall a. Num a => a -> a -> a
- Position
50 -- Require: cutoff <= offset, MAGIC TUNABLE CONSTANT 50
          [(Position, Position)]
ss <- (Position -> ST s (Position, Position))
-> [Position] -> ST s [(Position, Position)]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM Position -> ST s (Position, Position)
forall {s}.
(MArray (STUArray s) Position (ST s),
 MArray
   (STArray s) (Maybe (STUArray s Position Position)) (ST s)) =>
Position -> ST s (Position, Position)
getStart (SetIndex -> [Position]
ISet.toAscList SetIndex
did)
          let compressOrbit :: Position -> ST s ()
compressOrbit Position
tag = do
                [Maybe ((Position, Position), Orbits)]
mos <- [(Position, Position)]
-> ((Position, Position)
    -> ST s (Maybe ((Position, Position), Orbits)))
-> ST s [Maybe ((Position, Position), Orbits)]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM [(Position, Position)]
ss ( \ p :: (Position, Position)
p@(Position
state,Position
_start) -> do
                                  Maybe Orbits
mo <- (OrbitLog -> Maybe Orbits) -> ST s OrbitLog -> ST s (Maybe Orbits)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Position -> OrbitLog -> Maybe Orbits
forall a. Position -> IntMap a -> Maybe a
IMap.lookup Position
tag) (MScratch s -> STArray s Position OrbitLog
forall s. MScratch s -> STArray s Position OrbitLog
m_orbit MScratch s
s1 STArray s Position OrbitLog -> Position -> ST s OrbitLog
forall (a :: * -> * -> *) e s i.
(MArray a e (ST s), Ix i) =>
a i e -> Position -> ST s e
!! Position
state)
                                  case Maybe Orbits
mo of
                                    Just Orbits
orbits | Orbits -> Position
basePos Orbits
orbits Position -> Position -> Bool
forall a. Ord a => a -> a -> Bool
< Position
cutoff -> Maybe ((Position, Position), Orbits)
-> ST s (Maybe ((Position, Position), Orbits))
forall (m :: * -> *) a. Monad m => a -> m a
return (((Position, Position), Orbits)
-> Maybe ((Position, Position), Orbits)
forall a. a -> Maybe a
Just ((Position, Position)
p,Orbits
orbits))
                                                | Bool
otherwise -> Maybe ((Position, Position), Orbits)
-> ST s (Maybe ((Position, Position), Orbits))
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe ((Position, Position), Orbits)
forall a. Maybe a
Nothing
                                    Maybe Orbits
_ -> Maybe ((Position, Position), Orbits)
-> ST s (Maybe ((Position, Position), Orbits))
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe ((Position, Position), Orbits)
forall a. Maybe a
Nothing )
                let compressGroup :: [((Position, b), Orbits)] -> ST s ()
compressGroup [((Position
state,b
_),Orbits
orbit)] | Seq Position -> Bool
forall a. Seq a -> Bool
Seq.null (Orbits -> Seq Position
getOrbits Orbits
orbit) = () -> ST s ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
                                                      | Bool
otherwise =
                      STArray s Position OrbitLog -> Position -> OrbitLog -> ST s ()
forall (a :: * -> * -> *) e s i.
(MArray a e (ST s), Ix i) =>
a i e -> Position -> e -> ST s ()
set (MScratch s -> STArray s Position OrbitLog
forall s. MScratch s -> STArray s Position OrbitLog
m_orbit MScratch s
s1) Position
state
                      (OrbitLog -> ST s ())
-> (OrbitLog -> OrbitLog) -> OrbitLog -> ST s ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Position -> Orbits -> OrbitLog -> OrbitLog
forall a. Position -> a -> IntMap a -> IntMap a
IMap.insert Position
tag (Orbits -> OrbitLog -> OrbitLog) -> Orbits -> OrbitLog -> OrbitLog
forall a b. (a -> b) -> a -> b
$! (Orbits
orbit { ordinal :: Maybe Position
ordinal = Maybe Position
forall a. Maybe a
Nothing, getOrbits :: Seq Position
getOrbits = Seq Position
forall a. Monoid a => a
mempty}))
                      (OrbitLog -> ST s ()) -> ST s OrbitLog -> ST s ()
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< MScratch s -> STArray s Position OrbitLog
forall s. MScratch s -> STArray s Position OrbitLog
m_orbit MScratch s
s1 STArray s Position OrbitLog -> Position -> ST s OrbitLog
forall (a :: * -> * -> *) e s i.
(MArray a e (ST s), Ix i) =>
a i e -> Position -> ST s e
!! Position
state

                    compressGroup [((Position, b), Orbits)]
gs = do
                      let sortPos :: (a, Orbits) -> (a, Orbits) -> Ordering
sortPos (a
_,Orbits
b1) (a
_,Orbits
b2) = Maybe Position -> Maybe Position -> Ordering
forall a. Ord a => a -> a -> Ordering
compare (Orbits -> Maybe Position
ordinal Orbits
b1) (Orbits -> Maybe Position
ordinal Orbits
b2) Ordering -> Ordering -> Ordering
forall a. Monoid a => a -> a -> a
`mappend`
                                                  Bool -> Bool -> Ordering
forall a. Ord a => a -> a -> Ordering
compare (Orbits -> Bool
inOrbit Orbits
b2) (Orbits -> Bool
inOrbit Orbits
b1) Ordering -> Ordering -> Ordering
forall a. Monoid a => a -> a -> a
`mappend`
                                                  ViewL Position -> ViewL Position -> Ordering
comparePos (Seq Position -> ViewL Position
forall a. Seq a -> ViewL a
viewl (Orbits -> Seq Position
getOrbits Orbits
b1)) (Seq Position -> ViewL Position
forall a. Seq a -> ViewL a
viewl (Orbits -> Seq Position
getOrbits Orbits
b2))
                          groupPos :: (a, Orbits) -> (a, Orbits) -> Bool
groupPos (a
_,Orbits
b1) (a
_,Orbits
b2) = Orbits -> Maybe Position
ordinal Orbits
b1 Maybe Position -> Maybe Position -> Bool
forall a. Eq a => a -> a -> Bool
== Orbits -> Maybe Position
ordinal Orbits
b2 Bool -> Bool -> Bool
&& Orbits -> Seq Position
getOrbits Orbits
b1 Seq Position -> Seq Position -> Bool
forall a. Eq a => a -> a -> Bool
== Orbits -> Seq Position
getOrbits Orbits
b2
                          gs' :: [(Position, [((Position, b), Orbits)])]
gs' = [Position]
-> [[((Position, b), Orbits)]]
-> [(Position, [((Position, b), Orbits)])]
forall a b. [a] -> [b] -> [(a, b)]
zip [(Position
1::Int)..] ((((Position, b), Orbits) -> ((Position, b), Orbits) -> Bool)
-> [((Position, b), Orbits)] -> [[((Position, b), Orbits)]]
forall a. (a -> a -> Bool) -> [a] -> [[a]]
groupBy ((Position, b), Orbits) -> ((Position, b), Orbits) -> Bool
forall {a} {a}. (a, Orbits) -> (a, Orbits) -> Bool
groupPos ([((Position, b), Orbits)] -> [[((Position, b), Orbits)]])
-> ([((Position, b), Orbits)] -> [((Position, b), Orbits)])
-> [((Position, b), Orbits)]
-> [[((Position, b), Orbits)]]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (((Position, b), Orbits) -> ((Position, b), Orbits) -> Ordering)
-> [((Position, b), Orbits)] -> [((Position, b), Orbits)]
forall a. (a -> a -> Ordering) -> [a] -> [a]
sortBy ((Position, b), Orbits) -> ((Position, b), Orbits) -> Ordering
forall {a} {a}. (a, Orbits) -> (a, Orbits) -> Ordering
sortPos ([((Position, b), Orbits)] -> [[((Position, b), Orbits)]])
-> [((Position, b), Orbits)] -> [[((Position, b), Orbits)]]
forall a b. (a -> b) -> a -> b
$ [((Position, b), Orbits)]
gs)
                      [(Position, [((Position, b), Orbits)])]
-> ((Position, [((Position, b), Orbits)]) -> ST s ()) -> ST s ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [(Position, [((Position, b), Orbits)])]
gs' (((Position, [((Position, b), Orbits)]) -> ST s ()) -> ST s ())
-> ((Position, [((Position, b), Orbits)]) -> ST s ()) -> ST s ()
forall a b. (a -> b) -> a -> b
$ \ (!Position
n,[((Position, b), Orbits)]
eqs) -> do
                        [((Position, b), Orbits)]
-> (((Position, b), Orbits) -> ST s ()) -> ST s ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [((Position, b), Orbits)]
eqs ((((Position, b), Orbits) -> ST s ()) -> ST s ())
-> (((Position, b), Orbits) -> ST s ()) -> ST s ()
forall a b. (a -> b) -> a -> b
$ \ ((Position
state,b
_),Orbits
orbit) ->
                          STArray s Position OrbitLog -> Position -> OrbitLog -> ST s ()
forall (a :: * -> * -> *) e s i.
(MArray a e (ST s), Ix i) =>
a i e -> Position -> e -> ST s ()
set (MScratch s -> STArray s Position OrbitLog
forall s. MScratch s -> STArray s Position OrbitLog
m_orbit MScratch s
s1) Position
state
                           (OrbitLog -> ST s ())
-> (OrbitLog -> OrbitLog) -> OrbitLog -> ST s ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Position -> Orbits -> OrbitLog -> OrbitLog
forall a. Position -> a -> IntMap a -> IntMap a
IMap.insert Position
tag (Orbits -> OrbitLog -> OrbitLog) -> Orbits -> OrbitLog -> OrbitLog
forall a b. (a -> b) -> a -> b
$! (Orbits
orbit { ordinal :: Maybe Position
ordinal = Position -> Maybe Position
forall a. a -> Maybe a
Just Position
n, getOrbits :: Seq Position
getOrbits = Seq Position
forall a. Monoid a => a
mempty }))
                            (OrbitLog -> ST s ()) -> ST s OrbitLog -> ST s ()
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< MScratch s -> STArray s Position OrbitLog
forall s. MScratch s -> STArray s Position OrbitLog
m_orbit MScratch s
s1 STArray s Position OrbitLog -> Position -> ST s OrbitLog
forall (a :: * -> * -> *) e s i.
(MArray a e (ST s), Ix i) =>
a i e -> Position -> ST s e
!! Position
state
                let sorter :: ((a, a), Orbits) -> ((a, a), Orbits) -> Ordering
sorter ((a
_,a
a1),Orbits
b1) ((a
_,a
a2),Orbits
b2) = a -> a -> Ordering
forall a. Ord a => a -> a -> Ordering
compare a
a1 a
a2 Ordering -> Ordering -> Ordering
forall a. Monoid a => a -> a -> a
`mappend` Position -> Position -> Ordering
forall a. Ord a => a -> a -> Ordering
compare (Orbits -> Position
basePos Orbits
b1) (Orbits -> Position
basePos Orbits
b2)
                    grouper :: ((a, a), Orbits) -> ((a, a), Orbits) -> Bool
grouper ((a
_,a
a1),Orbits
b1) ((a
_,a
a2),Orbits
b2) = a
a1a -> a -> Bool
forall a. Eq a => a -> a -> Bool
==a
a2 Bool -> Bool -> Bool
&& Orbits -> Position
basePos Orbits
b1 Position -> Position -> Bool
forall a. Eq a => a -> a -> Bool
== Orbits -> Position
basePos Orbits
b2
                    orbitGroups :: [[((Position, Position), Orbits)]]
orbitGroups = (((Position, Position), Orbits)
 -> ((Position, Position), Orbits) -> Bool)
-> [((Position, Position), Orbits)]
-> [[((Position, Position), Orbits)]]
forall a. (a -> a -> Bool) -> [a] -> [[a]]
groupBy ((Position, Position), Orbits)
-> ((Position, Position), Orbits) -> Bool
forall {a} {a} {a}.
Eq a =>
((a, a), Orbits) -> ((a, a), Orbits) -> Bool
grouper ([((Position, Position), Orbits)]
 -> [[((Position, Position), Orbits)]])
-> ([Maybe ((Position, Position), Orbits)]
    -> [((Position, Position), Orbits)])
-> [Maybe ((Position, Position), Orbits)]
-> [[((Position, Position), Orbits)]]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (((Position, Position), Orbits)
 -> ((Position, Position), Orbits) -> Ordering)
-> [((Position, Position), Orbits)]
-> [((Position, Position), Orbits)]
forall a. (a -> a -> Ordering) -> [a] -> [a]
sortBy ((Position, Position), Orbits)
-> ((Position, Position), Orbits) -> Ordering
forall {a} {a} {a}.
Ord a =>
((a, a), Orbits) -> ((a, a), Orbits) -> Ordering
sorter ([((Position, Position), Orbits)]
 -> [((Position, Position), Orbits)])
-> ([Maybe ((Position, Position), Orbits)]
    -> [((Position, Position), Orbits)])
-> [Maybe ((Position, Position), Orbits)]
-> [((Position, Position), Orbits)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Maybe ((Position, Position), Orbits)]
-> [((Position, Position), Orbits)]
forall a. [Maybe a] -> [a]
catMaybes ([Maybe ((Position, Position), Orbits)]
 -> [[((Position, Position), Orbits)]])
-> [Maybe ((Position, Position), Orbits)]
-> [[((Position, Position), Orbits)]]
forall a b. (a -> b) -> a -> b
$ [Maybe ((Position, Position), Orbits)]
mos
                ([((Position, Position), Orbits)] -> ST s ())
-> [[((Position, Position), Orbits)]] -> ST s ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ [((Position, Position), Orbits)] -> ST s ()
forall {s} {b}.
MArray (STArray s) OrbitLog (ST s) =>
[((Position, b), Orbits)] -> ST s ()
compressGroup [[((Position, Position), Orbits)]]
orbitGroups
          (Position -> ST s ()) -> [Position] -> ST s ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ Position -> ST s ()
forall {s}.
MArray (STArray s) OrbitLog (ST s) =>
Position -> ST s ()
compressOrbit [Position]
orbitTags

-- findTrans has to (part 1) decide, for each destination, "which" of
-- zero or more source NFA states will be the chosen source.  Then it
-- has to (part 2) perform the transition or spawn.  It keeps track of
-- the starting index while doing so, and compares the earliest start
-- with the stored winners.  (part 3) If some winners are ready to be
-- released then the future continuation of the search is placed in
-- "storeNext".  If no winners are ready to be released then the
-- computation continues immediately.

        findTrans :: MScratch s
-> MScratch s
-> SetIndex
-> SetIndex
-> DT
-> DTrans
-> Position
-> Char
-> text
-> ST s [MatchArray]
findTrans MScratch s
s1 MScratch s
s2 SetIndex
did SetIndex
did' DT
dt' DTrans
dtrans Position
offset Char
prev' text
input' =  {-# SCC "goNext.findTrans" #-} do
          -- findTrans part 0
          -- MAGIC TUNABLE CONSTANT 100 (and 100-1). TODO: (offset .&. 127 == 127) instead?
          Bool -> ST s () -> ST s ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Bool -> Bool
not ([Position] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Position]
orbitTags) Bool -> Bool -> Bool
&& (Position
offset Position -> Position -> Position
forall a. Integral a => a -> a -> a
`rem` Position
100 Position -> Position -> Bool
forall a. Eq a => a -> a -> Bool
== Position
99)) (MScratch s -> SetIndex -> Position -> ST s ()
forall {s} {s}.
(MArray (STUArray s) Position (ST s),
 MArray (STArray s) (Maybe (STUArray s Position Position)) (ST s),
 MArray (STArray s) OrbitLog (ST s)) =>
MScratch s -> SetIndex -> Position -> ST s ()
compressOrbits MScratch s
s1 SetIndex
did Position
offset)
          -- findTrans part 1
          let findTransTo :: (Position, IntMap (a, Instructions)) -> ST s ()
findTransTo (Position
destIndex,IntMap (a, Instructions)
sources) | IntMap (a, Instructions) -> Bool
forall a. IntMap a -> Bool
IMap.null IntMap (a, Instructions)
sources =
                STArray
  s
  Position
  ((Position, Instructions), STUArray s Position Position, OrbitLog)
-> Position
-> ((Position, Instructions), STUArray s Position Position,
    OrbitLog)
-> ST s ()
forall (a :: * -> * -> *) e s i.
(MArray a e (ST s), Ix i) =>
a i e -> Position -> e -> ST s ()
set STArray
  s
  Position
  ((Position, Instructions), STUArray s Position Position, OrbitLog)
which Position
destIndex ((-Position
1,Instructions { newPos :: [(Position, Action)]
newPos = [(Position
0,Action
SetPost)], newOrbits :: Maybe (Position -> OrbitLog -> OrbitLog)
newOrbits = Maybe (Position -> OrbitLog -> OrbitLog)
forall a. Maybe a
Nothing })
                                    ,BlankScratch s -> STUArray s Position Position
forall s. BlankScratch s -> STUArray s Position Position
blank_pos BlankScratch s
blank,OrbitLog
forall a. Monoid a => a
mempty)
                                              | Bool
otherwise = do
                let prep :: (Position, (a, Instructions))
-> ST
     s
     ((Position, Instructions), STUArray s Position Position, OrbitLog)
prep (Position
sourceIndex,(a
_dopa,Instructions
instructions)) = {-# SCC "goNext.findTrans.prep" #-} do
                      STUArray s Position Position
pos <- ST s (STUArray s Position Position)
-> (STUArray s Position Position
    -> ST s (STUArray s Position Position))
-> Maybe (STUArray s Position Position)
-> ST s (STUArray s Position Position)
forall b a. b -> (a -> b) -> Maybe a -> b
maybe ([Char] -> ST s (STUArray s Position Position)
forall a. [Char] -> a
err ([Char] -> ST s (STUArray s Position Position))
-> [Char] -> ST s (STUArray s Position Position)
forall a b. (a -> b) -> a -> b
$ [Char]
"findTrans,1 : "[Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++(Position, Position, SetIndex) -> [Char]
forall a. Show a => a -> [Char]
show (Position
sourceIndex,Position
destIndex,SetIndex
did')) STUArray s Position Position -> ST s (STUArray s Position Position)
forall (m :: * -> *) a. Monad m => a -> m a
return
                               (Maybe (STUArray s Position Position)
 -> ST s (STUArray s Position Position))
-> ST s (Maybe (STUArray s Position Position))
-> ST s (STUArray s Position Position)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< MScratch s
-> STArray s Position (Maybe (STUArray s Position Position))
forall s.
MScratch s
-> STArray s Position (Maybe (STUArray s Position Position))
m_pos MScratch s
s1 STArray s Position (Maybe (STUArray s Position Position))
-> Position -> ST s (Maybe (STUArray s Position Position))
forall (a :: * -> * -> *) e s i.
(MArray a e (ST s), Ix i) =>
a i e -> Position -> ST s e
!! Position
sourceIndex
                      OrbitLog
orbit <- MScratch s -> STArray s Position OrbitLog
forall s. MScratch s -> STArray s Position OrbitLog
m_orbit MScratch s
s1 STArray s Position OrbitLog -> Position -> ST s OrbitLog
forall (a :: * -> * -> *) e s i.
(MArray a e (ST s), Ix i) =>
a i e -> Position -> ST s e
!! Position
sourceIndex
                      let orbit' :: OrbitLog
orbit' = OrbitLog
-> ((Position -> OrbitLog -> OrbitLog) -> OrbitLog)
-> Maybe (Position -> OrbitLog -> OrbitLog)
-> OrbitLog
forall b a. b -> (a -> b) -> Maybe a -> b
maybe OrbitLog
orbit (\ Position -> OrbitLog -> OrbitLog
f -> Position -> OrbitLog -> OrbitLog
f Position
offset OrbitLog
orbit) (Instructions -> Maybe (Position -> OrbitLog -> OrbitLog)
newOrbits Instructions
instructions)
                      ((Position, Instructions), STUArray s Position Position, OrbitLog)
-> ST
     s
     ((Position, Instructions), STUArray s Position Position, OrbitLog)
forall (m :: * -> *) a. Monad m => a -> m a
return ((Position
sourceIndex,Instructions
instructions),STUArray s Position Position
pos,OrbitLog
orbit')
                    challenge :: ((Position, Instructions), STUArray s Position Position, OrbitLog)
-> ((Position, Instructions), STUArray s Position Position,
    OrbitLog)
-> ST
     s
     ((Position, Instructions), STUArray s Position Position, OrbitLog)
challenge x1 :: ((Position, Instructions), STUArray s Position Position, OrbitLog)
x1@((Position
_si1,Instructions
ins1),STUArray s Position Position
_p1,OrbitLog
_o1) x2 :: ((Position, Instructions), STUArray s Position Position, OrbitLog)
x2@((Position
_si2,Instructions
ins2),STUArray s Position Position
_p2,OrbitLog
_o2) = {-# SCC "goNext.findTrans.challenge" #-} do
                      Ordering
check <- C s
forall s. C s
comp Position
offset ((Position, Instructions), STUArray s Position Position, OrbitLog)
x1 (Instructions -> [(Position, Action)]
newPos Instructions
ins1) ((Position, Instructions), STUArray s Position Position, OrbitLog)
x2 (Instructions -> [(Position, Action)]
newPos Instructions
ins2)
                      if Ordering
checkOrdering -> Ordering -> Bool
forall a. Eq a => a -> a -> Bool
==Ordering
LT then ((Position, Instructions), STUArray s Position Position, OrbitLog)
-> ST
     s
     ((Position, Instructions), STUArray s Position Position, OrbitLog)
forall (m :: * -> *) a. Monad m => a -> m a
return ((Position, Instructions), STUArray s Position Position, OrbitLog)
x2 else ((Position, Instructions), STUArray s Position Position, OrbitLog)
-> ST
     s
     ((Position, Instructions), STUArray s Position Position, OrbitLog)
forall (m :: * -> *) a. Monad m => a -> m a
return ((Position, Instructions), STUArray s Position Position, OrbitLog)
x1
                [((Position, Instructions), STUArray s Position Position,
  OrbitLog)]
first_rest <- ((Position, (a, Instructions))
 -> ST
      s
      ((Position, Instructions), STUArray s Position Position, OrbitLog))
-> [(Position, (a, Instructions))]
-> ST
     s
     [((Position, Instructions), STUArray s Position Position,
       OrbitLog)]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (Position, (a, Instructions))
-> ST
     s
     ((Position, Instructions), STUArray s Position Position, OrbitLog)
forall {s} {a}.
(MArray (STArray s) (Maybe (STUArray s Position Position)) (ST s),
 MArray (STArray s) OrbitLog (ST s)) =>
(Position, (a, Instructions))
-> ST
     s
     ((Position, Instructions), STUArray s Position Position, OrbitLog)
prep (IntMap (a, Instructions) -> [(Position, (a, Instructions))]
forall a. IntMap a -> [(Position, a)]
IMap.toList IntMap (a, Instructions)
sources)
                let ((Position, Instructions), STUArray s Position Position, OrbitLog)
first:[((Position, Instructions), STUArray s Position Position,
  OrbitLog)]
rest = [((Position, Instructions), STUArray s Position Position,
  OrbitLog)]
first_rest
                STArray
  s
  Position
  ((Position, Instructions), STUArray s Position Position, OrbitLog)
-> Position
-> ((Position, Instructions), STUArray s Position Position,
    OrbitLog)
-> ST s ()
forall (a :: * -> * -> *) e s i.
(MArray a e (ST s), Ix i) =>
a i e -> Position -> e -> ST s ()
set STArray
  s
  Position
  ((Position, Instructions), STUArray s Position Position, OrbitLog)
which Position
destIndex (((Position, Instructions), STUArray s Position Position, OrbitLog)
 -> ST s ())
-> ST
     s
     ((Position, Instructions), STUArray s Position Position, OrbitLog)
-> ST s ()
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< (((Position, Instructions), STUArray s Position Position, OrbitLog)
 -> ((Position, Instructions), STUArray s Position Position,
     OrbitLog)
 -> ST
      s
      ((Position, Instructions), STUArray s Position Position, OrbitLog))
-> ((Position, Instructions), STUArray s Position Position,
    OrbitLog)
-> [((Position, Instructions), STUArray s Position Position,
     OrbitLog)]
-> ST
     s
     ((Position, Instructions), STUArray s Position Position, OrbitLog)
forall (t :: * -> *) (m :: * -> *) b a.
(Foldable t, Monad m) =>
(b -> a -> m b) -> b -> t a -> m b
foldM ((Position, Instructions), STUArray s Position Position, OrbitLog)
-> ((Position, Instructions), STUArray s Position Position,
    OrbitLog)
-> ST
     s
     ((Position, Instructions), STUArray s Position Position, OrbitLog)
forall {s}.
((Position, Instructions), STUArray s Position Position, OrbitLog)
-> ((Position, Instructions), STUArray s Position Position,
    OrbitLog)
-> ST
     s
     ((Position, Instructions), STUArray s Position Position, OrbitLog)
challenge ((Position, Instructions), STUArray s Position Position, OrbitLog)
first [((Position, Instructions), STUArray s Position Position,
  OrbitLog)]
rest
          let dl :: [(Position, IntMap (DoPa, Instructions))]
dl = DTrans -> [(Position, IntMap (DoPa, Instructions))]
forall a. IntMap a -> [(Position, a)]
IMap.toList DTrans
dtrans
          ((Position, IntMap (DoPa, Instructions)) -> ST s ())
-> [(Position, IntMap (DoPa, Instructions))] -> ST s ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (Position, IntMap (DoPa, Instructions)) -> ST s ()
forall {a}. (Position, IntMap (a, Instructions)) -> ST s ()
findTransTo [(Position, IntMap (DoPa, Instructions))]
dl
          -- findTrans part 2
          let performTransTo :: (Position, b) -> ST s Position
performTransTo (Position
destIndex,b
_) = {-# SCC "goNext.findTrans.performTransTo" #-} do
                x :: ((Position, Instructions), STUArray s Position Position, OrbitLog)
x@((Position
sourceIndex,Instructions
_instructions),STUArray s Position Position
_pos,OrbitLog
_orbit') <- STArray
  s
  Position
  ((Position, Instructions), STUArray s Position Position, OrbitLog)
which STArray
  s
  Position
  ((Position, Instructions), STUArray s Position Position, OrbitLog)
-> Position
-> ST
     s
     ((Position, Instructions), STUArray s Position Position, OrbitLog)
forall (a :: * -> * -> *) e s i.
(MArray a e (ST s), Ix i) =>
a i e -> Position -> ST s e
!! Position
destIndex
                if Position
sourceIndex Position -> Position -> Bool
forall a. Eq a => a -> a -> Bool
== (-Position
1)
                  then (Position, Position)
-> BlankScratch s
-> Position
-> MScratch s
-> Position
-> ST s Position
forall s.
(Position, Position)
-> BlankScratch s
-> Position
-> MScratch s
-> Position
-> ST s Position
spawnStart (Position, Position)
b_tags BlankScratch s
blank Position
destIndex MScratch s
s2 (Position -> Position
forall a. Enum a => a -> a
succ Position
offset)
                  else ((Position, Instructions), STUArray s Position Position, OrbitLog)
-> Position -> MScratch s -> Position -> ST s Position
forall s.
((Position, Instructions), STUArray s Position Position, OrbitLog)
-> Position -> MScratch s -> Position -> ST s Position
updateCopy ((Position, Instructions), STUArray s Position Position, OrbitLog)
x Position
offset MScratch s
s2 Position
destIndex
          Position
earlyStart <- ([Position] -> Position) -> ST s [Position] -> ST s Position
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap [Position] -> Position
forall (t :: * -> *) a. (Foldable t, Ord a) => t a -> a
minimum (ST s [Position] -> ST s Position)
-> ST s [Position] -> ST s Position
forall a b. (a -> b) -> a -> b
$ ((Position, IntMap (DoPa, Instructions)) -> ST s Position)
-> [(Position, IntMap (DoPa, Instructions))] -> ST s [Position]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (Position, IntMap (DoPa, Instructions)) -> ST s Position
forall {b}. (Position, b) -> ST s Position
performTransTo [(Position, IntMap (DoPa, Instructions))]
dl
          -- findTrans part 3
          Position
earlyWin <- STRef s Position -> ST s Position
forall s a. STRef s a -> ST s a
readSTRef (MQ s -> STRef s Position
forall s. MQ s -> STRef s Position
mq_earliest MQ s
winQ)
          if Position
earlyWin Position -> Position -> Bool
forall a. Ord a => a -> a -> Bool
< Position
earlyStart
            then do
              [WScratch s]
winners <- ([WScratch s] -> [WScratch s])
-> ST s [WScratch s] -> ST s [WScratch s]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (([WScratch s] -> WScratch s -> [WScratch s])
-> [WScratch s] -> [WScratch s] -> [WScratch s]
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' (\ [WScratch s]
rest WScratch s
ws -> WScratch s
ws WScratch s -> [WScratch s] -> [WScratch s]
forall a. a -> [a] -> [a]
: [WScratch s]
rest) []) (ST s [WScratch s] -> ST s [WScratch s])
-> ST s [WScratch s] -> ST s [WScratch s]
forall a b. (a -> b) -> a -> b
$
                           Position -> MQ s -> ST s [WScratch s]
forall s. Position -> MQ s -> ST s [WScratch s]
getMQ Position
earlyStart MQ s
winQ
              STRef s (ST s [MatchArray]) -> ST s [MatchArray] -> ST s ()
forall s a. STRef s a -> a -> ST s ()
writeSTRef STRef s (ST s [MatchArray])
storeNext (MScratch s
-> MScratch s
-> SetIndex
-> DT
-> Position
-> Char
-> text
-> ST s [MatchArray]
next MScratch s
s2 MScratch s
s1 SetIndex
did' DT
dt' (Position -> Position
forall a. Enum a => a -> a
succ Position
offset) Char
prev' text
input')
              (WScratch s -> ST s MatchArray)
-> [WScratch s] -> ST s [MatchArray]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (Array Position [GroupInfo] -> WScratch s -> ST s MatchArray
forall s.
Array Position [GroupInfo] -> WScratch s -> ST s MatchArray
tagsToGroupsST Array Position [GroupInfo]
aGroups) [WScratch s]
winners
            else do
              let offset' :: Position
offset' = Position -> Position
forall a. Enum a => a -> a
succ Position
offset in Position -> ST s [MatchArray] -> ST s [MatchArray]
seq Position
offset' (ST s [MatchArray] -> ST s [MatchArray])
-> ST s [MatchArray] -> ST s [MatchArray]
forall a b. (a -> b) -> a -> b
$ MScratch s
-> MScratch s
-> SetIndex
-> DT
-> Position
-> Char
-> text
-> ST s [MatchArray]
next MScratch s
s2 MScratch s
s1 SetIndex
did' DT
dt' Position
offset' Char
prev' text
input'

-- The "newWinnerThenProceed" can find both a new non-empty winner and
-- a new empty winner.  A new non-empty winner can cause some of the
-- NFA states that comprise the DFA state to be eliminated, and if the
-- startState is eliminated then it must then be respawned.  And
-- imperative flag setting and resetting style is used.
--
-- A non-empty winner from the startState might obscure a potential
-- empty winner (form the startState at the current offset).  This
-- winEmpty possibility is also checked for. (unit test pattern ".*")
-- (futher test "(.+|.+.)*" on "aa\n")

        {-# INLINE processWinner #-}
        processWinner :: MScratch s
-> SetIndex
-> DT
-> IntMap Instructions
-> Position
-> ST s (SetIndex, DT)
processWinner MScratch s
s1 SetIndex
did DT
dt IntMap Instructions
w Position
offset = {-# SCC "goNext.newWinnerThenProceed" #-} do
          let prep :: (Position, Instructions)
-> ST
     s
     (Position,
      ((Position, Instructions), STUArray s Position Position, OrbitLog))
prep x :: (Position, Instructions)
x@(Position
sourceIndex,Instructions
instructions) = {-# SCC "goNext.newWinnerThenProceed.prep" #-} do
                STUArray s Position Position
pos <- ST s (STUArray s Position Position)
-> (STUArray s Position Position
    -> ST s (STUArray s Position Position))
-> Maybe (STUArray s Position Position)
-> ST s (STUArray s Position Position)
forall b a. b -> (a -> b) -> Maybe a -> b
maybe ([Char] -> ST s (STUArray s Position Position)
forall a. [Char] -> a
err [Char]
"newWinnerThenProceed,1") STUArray s Position Position -> ST s (STUArray s Position Position)
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe (STUArray s Position Position)
 -> ST s (STUArray s Position Position))
-> ST s (Maybe (STUArray s Position Position))
-> ST s (STUArray s Position Position)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< MScratch s
-> STArray s Position (Maybe (STUArray s Position Position))
forall s.
MScratch s
-> STArray s Position (Maybe (STUArray s Position Position))
m_pos MScratch s
s1 STArray s Position (Maybe (STUArray s Position Position))
-> Position -> ST s (Maybe (STUArray s Position Position))
forall (a :: * -> * -> *) e s i.
(MArray a e (ST s), Ix i) =>
a i e -> Position -> ST s e
!! Position
sourceIndex
                Position
startPos <- STUArray s Position Position
pos STUArray s Position Position -> Position -> ST s Position
forall (a :: * -> * -> *) e s i.
(MArray a e (ST s), Ix i) =>
a i e -> Position -> ST s e
!! Position
0
                OrbitLog
orbit <- MScratch s -> STArray s Position OrbitLog
forall s. MScratch s -> STArray s Position OrbitLog
m_orbit MScratch s
s1 STArray s Position OrbitLog -> Position -> ST s OrbitLog
forall (a :: * -> * -> *) e s i.
(MArray a e (ST s), Ix i) =>
a i e -> Position -> ST s e
!! Position
sourceIndex
                let orbit' :: OrbitLog
orbit' = OrbitLog
-> ((Position -> OrbitLog -> OrbitLog) -> OrbitLog)
-> Maybe (Position -> OrbitLog -> OrbitLog)
-> OrbitLog
forall b a. b -> (a -> b) -> Maybe a -> b
maybe OrbitLog
orbit (\ Position -> OrbitLog -> OrbitLog
f -> Position -> OrbitLog -> OrbitLog
f Position
offset OrbitLog
orbit) (Instructions -> Maybe (Position -> OrbitLog -> OrbitLog)
newOrbits Instructions
instructions)
                (Position,
 ((Position, Instructions), STUArray s Position Position, OrbitLog))
-> ST
     s
     (Position,
      ((Position, Instructions), STUArray s Position Position, OrbitLog))
forall (m :: * -> *) a. Monad m => a -> m a
return (Position
startPos,((Position, Instructions)
x,STUArray s Position Position
pos,OrbitLog
orbit'))
              challenge :: ((Position, Instructions), STUArray s Position Position, OrbitLog)
-> ((Position, Instructions), STUArray s Position Position,
    OrbitLog)
-> ST
     s
     ((Position, Instructions), STUArray s Position Position, OrbitLog)
challenge x1 :: ((Position, Instructions), STUArray s Position Position, OrbitLog)
x1@((Position
_si1,Instructions
ins1),STUArray s Position Position
_p1,OrbitLog
_o1) x2 :: ((Position, Instructions), STUArray s Position Position, OrbitLog)
x2@((Position
_si2,Instructions
ins2),STUArray s Position Position
_p2,OrbitLog
_o2) = {-# SCC "goNext.newWinnerThenProceed.challenge" #-} do
                Ordering
check <- C s
forall s. C s
comp Position
offset ((Position, Instructions), STUArray s Position Position, OrbitLog)
x1 (Instructions -> [(Position, Action)]
newPos Instructions
ins1) ((Position, Instructions), STUArray s Position Position, OrbitLog)
x2 (Instructions -> [(Position, Action)]
newPos Instructions
ins2)
                if Ordering
checkOrdering -> Ordering -> Bool
forall a. Eq a => a -> a -> Bool
==Ordering
LT then ((Position, Instructions), STUArray s Position Position, OrbitLog)
-> ST
     s
     ((Position, Instructions), STUArray s Position Position, OrbitLog)
forall (m :: * -> *) a. Monad m => a -> m a
return ((Position, Instructions), STUArray s Position Position, OrbitLog)
x2 else ((Position, Instructions), STUArray s Position Position, OrbitLog)
-> ST
     s
     ((Position, Instructions), STUArray s Position Position, OrbitLog)
forall (m :: * -> *) a. Monad m => a -> m a
return ((Position, Instructions), STUArray s Position Position, OrbitLog)
x1
          [(Position,
  ((Position, Instructions), STUArray s Position Position,
   OrbitLog))]
prep'd <- ((Position, Instructions)
 -> ST
      s
      (Position,
       ((Position, Instructions), STUArray s Position Position,
        OrbitLog)))
-> [(Position, Instructions)]
-> ST
     s
     [(Position,
       ((Position, Instructions), STUArray s Position Position,
        OrbitLog))]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (Position, Instructions)
-> ST
     s
     (Position,
      ((Position, Instructions), STUArray s Position Position, OrbitLog))
forall {s}.
(MArray (STUArray s) Position (ST s),
 MArray (STArray s) (Maybe (STUArray s Position Position)) (ST s),
 MArray (STArray s) OrbitLog (ST s)) =>
(Position, Instructions)
-> ST
     s
     (Position,
      ((Position, Instructions), STUArray s Position Position, OrbitLog))
prep (IntMap Instructions -> [(Position, Instructions)]
forall a. IntMap a -> [(Position, a)]
IMap.toList IntMap Instructions
w)
          let ([(Position,
  ((Position, Instructions), STUArray s Position Position,
   OrbitLog))]
emptyFalse,[(Position,
  ((Position, Instructions), STUArray s Position Position,
   OrbitLog))]
emptyTrue) = ((Position,
  ((Position, Instructions), STUArray s Position Position, OrbitLog))
 -> Bool)
-> [(Position,
     ((Position, Instructions), STUArray s Position Position,
      OrbitLog))]
-> ([(Position,
      ((Position, Instructions), STUArray s Position Position,
       OrbitLog))],
    [(Position,
      ((Position, Instructions), STUArray s Position Position,
       OrbitLog))])
forall a. (a -> Bool) -> [a] -> ([a], [a])
partition ((Position
offset Position -> Position -> Bool
forall a. Ord a => a -> a -> Bool
>) (Position -> Bool)
-> ((Position,
     ((Position, Instructions), STUArray s Position Position, OrbitLog))
    -> Position)
-> (Position,
    ((Position, Instructions), STUArray s Position Position, OrbitLog))
-> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Position,
 ((Position, Instructions), STUArray s Position Position, OrbitLog))
-> Position
forall a b. (a, b) -> a
fst) [(Position,
  ((Position, Instructions), STUArray s Position Position,
   OrbitLog))]
prep'd
          Maybe [Position]
mayID <- {-# SCC "goNext.newWinnerThenProceed.mayID" #-}
                   case ((Position,
  ((Position, Instructions), STUArray s Position Position, OrbitLog))
 -> ((Position, Instructions), STUArray s Position Position,
     OrbitLog))
-> [(Position,
     ((Position, Instructions), STUArray s Position Position,
      OrbitLog))]
-> [((Position, Instructions), STUArray s Position Position,
     OrbitLog)]
forall a b. (a -> b) -> [a] -> [b]
map (Position,
 ((Position, Instructions), STUArray s Position Position, OrbitLog))
-> ((Position, Instructions), STUArray s Position Position,
    OrbitLog)
forall a b. (a, b) -> b
snd [(Position,
  ((Position, Instructions), STUArray s Position Position,
   OrbitLog))]
emptyFalse of
                    [] -> Maybe [Position] -> ST s (Maybe [Position])
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe [Position]
forall a. Maybe a
Nothing
                    (((Position, Instructions), STUArray s Position Position, OrbitLog)
first:[((Position, Instructions), STUArray s Position Position,
  OrbitLog)]
rest) -> do
                      best :: ((Position, Instructions), STUArray s Position Position, OrbitLog)
best@((Position
_sourceIndex,Instructions
_instructions),STUArray s Position Position
bp,OrbitLog
_orbit') <- (((Position, Instructions), STUArray s Position Position, OrbitLog)
 -> ((Position, Instructions), STUArray s Position Position,
     OrbitLog)
 -> ST
      s
      ((Position, Instructions), STUArray s Position Position, OrbitLog))
-> ((Position, Instructions), STUArray s Position Position,
    OrbitLog)
-> [((Position, Instructions), STUArray s Position Position,
     OrbitLog)]
-> ST
     s
     ((Position, Instructions), STUArray s Position Position, OrbitLog)
forall (t :: * -> *) (m :: * -> *) b a.
(Foldable t, Monad m) =>
(b -> a -> m b) -> b -> t a -> m b
foldM ((Position, Instructions), STUArray s Position Position, OrbitLog)
-> ((Position, Instructions), STUArray s Position Position,
    OrbitLog)
-> ST
     s
     ((Position, Instructions), STUArray s Position Position, OrbitLog)
forall {s}.
((Position, Instructions), STUArray s Position Position, OrbitLog)
-> ((Position, Instructions), STUArray s Position Position,
    OrbitLog)
-> ST
     s
     ((Position, Instructions), STUArray s Position Position, OrbitLog)
challenge ((Position, Instructions), STUArray s Position Position, OrbitLog)
first [((Position, Instructions), STUArray s Position Position,
  OrbitLog)]
rest
                      Position
-> ((Position, Instructions), STUArray s Position Position,
    OrbitLog)
-> ST s ()
forall {a} {c}.
Position
-> ((a, Instructions), STUArray s Position Position, c) -> ST s ()
newWinner Position
offset ((Position, Instructions), STUArray s Position Position, OrbitLog)
best
                      Position
startWin <- STUArray s Position Position
bp STUArray s Position Position -> Position -> ST s Position
forall (a :: * -> * -> *) e s i.
(MArray a e (ST s), Ix i) =>
a i e -> Position -> ST s e
!! Position
0
                      let states :: [Position]
states = SetIndex -> [Position]
ISet.toAscList SetIndex
did
                          keepState :: Position -> ST s Bool
keepState Position
i1 = do
                            STUArray s Position Position
pos <- ST s (STUArray s Position Position)
-> (STUArray s Position Position
    -> ST s (STUArray s Position Position))
-> Maybe (STUArray s Position Position)
-> ST s (STUArray s Position Position)
forall b a. b -> (a -> b) -> Maybe a -> b
maybe ([Char] -> ST s (STUArray s Position Position)
forall a. [Char] -> a
err [Char]
"newWinnerThenProceed,2") STUArray s Position Position -> ST s (STUArray s Position Position)
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe (STUArray s Position Position)
 -> ST s (STUArray s Position Position))
-> ST s (Maybe (STUArray s Position Position))
-> ST s (STUArray s Position Position)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< MScratch s
-> STArray s Position (Maybe (STUArray s Position Position))
forall s.
MScratch s
-> STArray s Position (Maybe (STUArray s Position Position))
m_pos MScratch s
s1 STArray s Position (Maybe (STUArray s Position Position))
-> Position -> ST s (Maybe (STUArray s Position Position))
forall (a :: * -> * -> *) e s i.
(MArray a e (ST s), Ix i) =>
a i e -> Position -> ST s e
!! Position
i1
                            Position
startsAt <- STUArray s Position Position
pos STUArray s Position Position -> Position -> ST s Position
forall (a :: * -> * -> *) e s i.
(MArray a e (ST s), Ix i) =>
a i e -> Position -> ST s e
!! Position
0
                            let keep :: Bool
keep = (Position
startsAt Position -> Position -> Bool
forall a. Ord a => a -> a -> Bool
<= Position
startWin) Bool -> Bool -> Bool
|| (Position
offset Position -> Position -> Bool
forall a. Ord a => a -> a -> Bool
<= Position
startsAt)
                            Bool -> ST s () -> ST s ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Bool -> Bool
not Bool
keep) (ST s () -> ST s ()) -> ST s () -> ST s ()
forall a b. (a -> b) -> a -> b
$ do
                              STRef s Bool -> Bool -> ST s ()
forall s a. STRef s a -> a -> ST s ()
writeSTRef STRef s Bool
eliminatedStateFlag Bool
True
                              Bool -> ST s () -> ST s ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Position
i1 Position -> Position -> Bool
forall a. Eq a => a -> a -> Bool
== Position
startState) (STRef s Bool -> Bool -> ST s ()
forall s a. STRef s a -> a -> ST s ()
writeSTRef STRef s Bool
eliminatedRespawnFlag Bool
True)
                            Bool -> ST s Bool
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
keep
                      [Position]
states' <- (Position -> ST s Bool) -> [Position] -> ST s [Position]
forall (m :: * -> *) a.
Applicative m =>
(a -> m Bool) -> [a] -> m [a]
filterM Position -> ST s Bool
keepState [Position]
states
                      Bool
changed <- STRef s Bool -> ST s Bool
forall s a. STRef s a -> ST s a
readSTRef STRef s Bool
eliminatedStateFlag
                      if Bool
changed then Maybe [Position] -> ST s (Maybe [Position])
forall (m :: * -> *) a. Monad m => a -> m a
return ([Position] -> Maybe [Position]
forall a. a -> Maybe a
Just [Position]
states') else Maybe [Position] -> ST s (Maybe [Position])
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe [Position]
forall a. Maybe a
Nothing
          case [(Position,
  ((Position, Instructions), STUArray s Position Position,
   OrbitLog))]
emptyTrue of
            [] -> case Position -> IntMap Instructions -> Maybe Instructions
forall a. Position -> IntMap a -> Maybe a
IMap.lookup Position
startState IntMap Instructions
w of
                   Maybe Instructions
Nothing -> () -> ST s ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
                   Just Instructions
ins -> Position -> Instructions -> ST s ()
winEmpty Position
offset Instructions
ins
            [(Position,
 ((Position, Instructions), STUArray s Position Position, OrbitLog))
first] -> Position
-> ((Position, Instructions), STUArray s Position Position,
    OrbitLog)
-> ST s ()
forall {a} {c}.
Position
-> ((a, Instructions), STUArray s Position Position, c) -> ST s ()
newWinner Position
offset ((Position,
 ((Position, Instructions), STUArray s Position Position, OrbitLog))
-> ((Position, Instructions), STUArray s Position Position,
    OrbitLog)
forall a b. (a, b) -> b
snd (Position,
 ((Position, Instructions), STUArray s Position Position, OrbitLog))
first)
            [(Position,
  ((Position, Instructions), STUArray s Position Position,
   OrbitLog))]
_ -> [Char] -> ST s ()
forall a. [Char] -> a
err [Char]
"newWinnerThenProceed,3 : too many emptyTrue values"
          case Maybe [Position]
mayID of
            Maybe [Position]
Nothing -> (SetIndex, DT) -> ST s (SetIndex, DT)
forall (m :: * -> *) a. Monad m => a -> m a
return (SetIndex
did,DT
dt) -- proceedNow s1 s2 did dt offset prev input
            Just [Position]
states' -> do
              STRef s Bool -> Bool -> ST s ()
forall s a. STRef s a -> a -> ST s ()
writeSTRef STRef s Bool
eliminatedStateFlag Bool
False
              Bool
respawn <- STRef s Bool -> ST s Bool
forall s a. STRef s a -> ST s a
readSTRef STRef s Bool
eliminatedRespawnFlag
              DFA {d_id :: DFA -> SetIndex
d_id=SetIndex
did',d_dt :: DFA -> DT
d_dt=DT
dt'} <-
                if Bool
respawn
                  then do
                    STRef s Bool -> Bool -> ST s ()
forall s a. STRef s a -> a -> ST s ()
writeSTRef STRef s Bool
eliminatedRespawnFlag Bool
False
                    Position
_ <- (Position, Position)
-> BlankScratch s
-> Position
-> MScratch s
-> Position
-> ST s Position
forall s.
(Position, Position)
-> BlankScratch s
-> Position
-> MScratch s
-> Position
-> ST s Position
spawnStart (Position, Position)
b_tags BlankScratch s
blank Position
startState MScratch s
s1 (Position -> Position
forall a. Enum a => a -> a
succ Position
offset)
                    DFA -> ST s DFA
forall (m :: * -> *) a. Monad m => a -> m a
return (TrieSet DFA -> [Position] -> DFA
forall v. TrieSet v -> [Position] -> v
Trie.lookupAsc TrieSet DFA
trie ([Position] -> [Position]
forall a. Ord a => [a] -> [a]
sort ([Position]
states'[Position] -> [Position] -> [Position]
forall a. [a] -> [a] -> [a]
++[Position
startState])))
                  else DFA -> ST s DFA
forall (m :: * -> *) a. Monad m => a -> m a
return (TrieSet DFA -> [Position] -> DFA
forall v. TrieSet v -> [Position] -> v
Trie.lookupAsc TrieSet DFA
trie [Position]
states')
              (SetIndex, DT) -> ST s (SetIndex, DT)
forall (m :: * -> *) a. Monad m => a -> m a
return (SetIndex
did',DT
dt')

        winEmpty :: Position -> Instructions -> ST s ()
winEmpty Position
preTag Instructions
winInstructions = {-# SCC "goNext.winEmpty" #-} do
          STUArray s Position Position
newerPos <- (Position, Position) -> ST s (STUArray s Position Position)
forall s e.
MArray (STUArray s) e (ST s) =>
(Position, Position) -> ST s (STUArray s Position e)
newA_ (Position, Position)
b_tags
          STUArray s Position Position
-> STUArray s Position Position -> ST s ()
forall i s e.
(Show i, Ix i, MArray (STUArray s) e (ST s)) =>
STUArray s i e -> STUArray s i e -> ST s ()
copySTU (BlankScratch s -> STUArray s Position Position
forall s. BlankScratch s -> STUArray s Position Position
blank_pos BlankScratch s
blank) STUArray s Position Position
newerPos
          STUArray s Position Position -> Position -> Position -> ST s ()
forall (a :: * -> * -> *) e s i.
(MArray a e (ST s), Ix i) =>
a i e -> Position -> e -> ST s ()
set STUArray s Position Position
newerPos Position
0 Position
preTag
          Position
-> STUArray s Position Position -> [(Position, Action)] -> ST s ()
forall s.
Position
-> STUArray s Position Position -> [(Position, Action)] -> ST s ()
doActions Position
preTag STUArray s Position Position
newerPos (Instructions -> [(Position, Action)]
newPos Instructions
winInstructions)
          WScratch s -> MQ s -> ST s ()
forall s. WScratch s -> MQ s -> ST s ()
putMQ (STUArray s Position Position -> WScratch s
forall s. STUArray s Position Position -> WScratch s
WScratch STUArray s Position Position
newerPos) MQ s
winQ

        newWinner :: Position
-> ((a, Instructions), STUArray s Position Position, c) -> ST s ()
newWinner Position
preTag ((a
_sourceIndex,Instructions
winInstructions),STUArray s Position Position
oldPos,c
_newOrbit) = {-# SCC "goNext.newWinner" #-} do
          STUArray s Position Position
newerPos <- (Position, Position) -> ST s (STUArray s Position Position)
forall s e.
MArray (STUArray s) e (ST s) =>
(Position, Position) -> ST s (STUArray s Position e)
newA_ (Position, Position)
b_tags
          STUArray s Position Position
-> STUArray s Position Position -> ST s ()
forall i s e.
(Show i, Ix i, MArray (STUArray s) e (ST s)) =>
STUArray s i e -> STUArray s i e -> ST s ()
copySTU STUArray s Position Position
oldPos STUArray s Position Position
newerPos
          Position
-> STUArray s Position Position -> [(Position, Action)] -> ST s ()
forall s.
Position
-> STUArray s Position Position -> [(Position, Action)] -> ST s ()
doActions Position
preTag STUArray s Position Position
newerPos (Instructions -> [(Position, Action)]
newPos Instructions
winInstructions)
          WScratch s -> MQ s -> ST s ()
forall s. WScratch s -> MQ s -> ST s ()
putMQ (STUArray s Position Position -> WScratch s
forall s. STUArray s Position Position -> WScratch s
WScratch STUArray s Position Position
newerPos) MQ s
winQ

        finalizeWinners :: ST s [MatchArray]
finalizeWinners = do
          [WScratch s]
winners <- ([MQA s] -> [WScratch s]) -> ST s [MQA s] -> ST s [WScratch s]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (([WScratch s] -> MQA s -> [WScratch s])
-> [WScratch s] -> [MQA s] -> [WScratch s]
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' (\ [WScratch s]
rest MQA s
mqa -> MQA s -> WScratch s
forall s. MQA s -> WScratch s
mqa_ws MQA s
mqa WScratch s -> [WScratch s] -> [WScratch s]
forall a. a -> [a] -> [a]
: [WScratch s]
rest) []) (ST s [MQA s] -> ST s [WScratch s])
-> ST s [MQA s] -> ST s [WScratch s]
forall a b. (a -> b) -> a -> b
$
                       STRef s [MQA s] -> ST s [MQA s]
forall s a. STRef s a -> ST s a
readSTRef (MQ s -> STRef s [MQA s]
forall s. MQ s -> STRef s [MQA s]
mq_list MQ s
winQ) -- reverses the winner list
          MQ s -> ST s ()
forall s. MQ s -> ST s ()
resetMQ MQ s
winQ
          STRef s (ST s [MatchArray]) -> ST s [MatchArray] -> ST s ()
forall s a. STRef s a -> a -> ST s ()
writeSTRef STRef s (ST s [MatchArray])
storeNext ([MatchArray] -> ST s [MatchArray]
forall (m :: * -> *) a. Monad m => a -> m a
return [])
          (WScratch s -> ST s MatchArray)
-> [WScratch s] -> ST s [MatchArray]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (Array Position [GroupInfo] -> WScratch s -> ST s MatchArray
forall s.
Array Position [GroupInfo] -> WScratch s -> ST s MatchArray
tagsToGroupsST Array Position [GroupInfo]
aGroups) [WScratch s]
winners

    -- goNext then ends with the next statement
    MScratch s
-> MScratch s
-> SetIndex
-> DT
-> Position
-> Char
-> text
-> ST s [MatchArray]
next MScratch s
s1In MScratch s
s2In SetIndex
didIn DT
dtIn Position
offsetIn Char
prevIn text
inputIn

{-# INLINE doActions #-}
doActions :: Position -> STUArray s Tag Position -> [(Tag, Action)] -> ST s ()
doActions :: forall s.
Position
-> STUArray s Position Position -> [(Position, Action)] -> ST s ()
doActions Position
preTag STUArray s Position Position
pos [(Position, Action)]
ins = ((Position, Action) -> ST s ()) -> [(Position, Action)] -> ST s ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (Position, Action) -> ST s ()
forall {s}.
MArray (STUArray s) Position (ST s) =>
(Position, Action) -> ST s ()
doAction [(Position, Action)]
ins where
  postTag :: Position
postTag = Position -> Position
forall a. Enum a => a -> a
succ Position
preTag
  doAction :: (Position, Action) -> ST s ()
doAction (Position
tag,Action
SetPre) = STUArray s Position Position -> Position -> Position -> ST s ()
forall (a :: * -> * -> *) e s i.
(MArray a e (ST s), Ix i) =>
a i e -> Position -> e -> ST s ()
set STUArray s Position Position
pos Position
tag Position
preTag
  doAction (Position
tag,Action
SetPost) = STUArray s Position Position -> Position -> Position -> ST s ()
forall (a :: * -> * -> *) e s i.
(MArray a e (ST s), Ix i) =>
a i e -> Position -> e -> ST s ()
set STUArray s Position Position
pos Position
tag Position
postTag
  doAction (Position
tag,SetVal Position
v) = STUArray s Position Position -> Position -> Position -> ST s ()
forall (a :: * -> * -> *) e s i.
(MArray a e (ST s), Ix i) =>
a i e -> Position -> e -> ST s ()
set STUArray s Position Position
pos Position
tag Position
v

----

{-# INLINE mkTest #-}
mkTest :: Uncons text => Bool -> WhichTest -> Index -> Char -> text -> Bool
mkTest :: forall text.
Uncons text =>
Bool -> WhichTest -> Position -> Char -> text -> Bool
mkTest Bool
isMultiline = if Bool
isMultiline then WhichTest -> Position -> Char -> text -> Bool
forall text.
Uncons text =>
WhichTest -> Position -> Char -> text -> Bool
test_multiline else WhichTest -> Position -> Char -> text -> Bool
forall text.
Uncons text =>
WhichTest -> Position -> Char -> text -> Bool
test_singleline

----

{- MUTABLE WINNER QUEUE -}

data MQA s = MQA {forall s. MQA s -> Position
mqa_start :: !Position, forall s. MQA s -> WScratch s
mqa_ws :: !(WScratch s)}

data MQ s = MQ { forall s. MQ s -> STRef s Position
mq_earliest :: !(STRef s Position)
               , forall s. MQ s -> STRef s [MQA s]
mq_list :: !(STRef s [MQA s])
               }

newMQ :: S.ST s (MQ s)
newMQ :: forall s. ST s (MQ s)
newMQ = do
  STRef s Position
earliest <- Position -> ST s (STRef s Position)
forall a s. a -> ST s (STRef s a)
newSTRef Position
forall a. Bounded a => a
maxBound
  STRef s [MQA s]
list <- [MQA s] -> ST s (STRef s [MQA s])
forall a s. a -> ST s (STRef s a)
newSTRef []
  MQ s -> ST s (MQ s)
forall (m :: * -> *) a. Monad m => a -> m a
return (STRef s Position -> STRef s [MQA s] -> MQ s
forall s. STRef s Position -> STRef s [MQA s] -> MQ s
MQ STRef s Position
earliest STRef s [MQA s]
list)

resetMQ :: MQ s -> S.ST s ()
resetMQ :: forall s. MQ s -> ST s ()
resetMQ (MQ {mq_earliest :: forall s. MQ s -> STRef s Position
mq_earliest=STRef s Position
earliest,mq_list :: forall s. MQ s -> STRef s [MQA s]
mq_list=STRef s [MQA s]
list}) = do
  STRef s Position -> Position -> ST s ()
forall s a. STRef s a -> a -> ST s ()
writeSTRef STRef s Position
earliest Position
forall a. Bounded a => a
maxBound
  STRef s [MQA s] -> [MQA s] -> ST s ()
forall s a. STRef s a -> a -> ST s ()
writeSTRef STRef s [MQA s]
list []

putMQ :: WScratch s -> MQ s -> S.ST s ()
putMQ :: forall s. WScratch s -> MQ s -> ST s ()
putMQ WScratch s
ws (MQ {mq_earliest :: forall s. MQ s -> STRef s Position
mq_earliest=STRef s Position
earliest,mq_list :: forall s. MQ s -> STRef s [MQA s]
mq_list=STRef s [MQA s]
list}) = do
  Position
start <- WScratch s -> STUArray s Position Position
forall s. WScratch s -> STUArray s Position Position
w_pos WScratch s
ws STUArray s Position Position -> Position -> ST s Position
forall (a :: * -> * -> *) e s i.
(MArray a e (ST s), Ix i) =>
a i e -> Position -> ST s e
!! Position
0
  let mqa :: MQA s
mqa = Position -> WScratch s -> MQA s
forall s. Position -> WScratch s -> MQA s
MQA Position
start WScratch s
ws
  Position
startE <- STRef s Position -> ST s Position
forall s a. STRef s a -> ST s a
readSTRef STRef s Position
earliest
  if Position
start Position -> Position -> Bool
forall a. Ord a => a -> a -> Bool
<= Position
startE
    then STRef s Position -> Position -> ST s ()
forall s a. STRef s a -> a -> ST s ()
writeSTRef STRef s Position
earliest Position
start ST s () -> ST s () -> ST s ()
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> STRef s [MQA s] -> [MQA s] -> ST s ()
forall s a. STRef s a -> a -> ST s ()
writeSTRef STRef s [MQA s]
list [MQA s
mqa]
    else do
  [MQA s]
old <- STRef s [MQA s] -> ST s [MQA s]
forall s a. STRef s a -> ST s a
readSTRef STRef s [MQA s]
list
  let !rest :: [MQA s]
rest = (MQA s -> Bool) -> [MQA s] -> [MQA s]
forall a. (a -> Bool) -> [a] -> [a]
dropWhile (\ MQA s
m -> Position
start Position -> Position -> Bool
forall a. Ord a => a -> a -> Bool
<= MQA s -> Position
forall s. MQA s -> Position
mqa_start MQA s
m) [MQA s]
old
      !new :: [MQA s]
new = MQA s
mqa MQA s -> [MQA s] -> [MQA s]
forall a. a -> [a] -> [a]
: [MQA s]
rest
  STRef s [MQA s] -> [MQA s] -> ST s ()
forall s a. STRef s a -> a -> ST s ()
writeSTRef STRef s [MQA s]
list [MQA s]
new

getMQ :: Position -> MQ s -> ST s [WScratch s]
getMQ :: forall s. Position -> MQ s -> ST s [WScratch s]
getMQ Position
pos (MQ {mq_earliest :: forall s. MQ s -> STRef s Position
mq_earliest=STRef s Position
earliest,mq_list :: forall s. MQ s -> STRef s [MQA s]
mq_list=STRef s [MQA s]
list}) = do
  [MQA s]
old <- STRef s [MQA s] -> ST s [MQA s]
forall s a. STRef s a -> ST s a
readSTRef STRef s [MQA s]
list
  case (MQA s -> Bool) -> [MQA s] -> ([MQA s], [MQA s])
forall a. (a -> Bool) -> [a] -> ([a], [a])
span (\MQA s
m -> Position
pos Position -> Position -> Bool
forall a. Ord a => a -> a -> Bool
<= MQA s -> Position
forall s. MQA s -> Position
mqa_start MQA s
m) [MQA s]
old of
    ([],[MQA s]
ans) -> do
      STRef s Position -> Position -> ST s ()
forall s a. STRef s a -> a -> ST s ()
writeSTRef STRef s Position
earliest Position
forall a. Bounded a => a
maxBound
      STRef s [MQA s] -> [MQA s] -> ST s ()
forall s a. STRef s a -> a -> ST s ()
writeSTRef STRef s [MQA s]
list []
      [WScratch s] -> ST s [WScratch s]
forall (m :: * -> *) a. Monad m => a -> m a
return ((MQA s -> WScratch s) -> [MQA s] -> [WScratch s]
forall a b. (a -> b) -> [a] -> [b]
map MQA s -> WScratch s
forall s. MQA s -> WScratch s
mqa_ws [MQA s]
ans)
    ([MQA s]
new,[MQA s]
ans) -> do
      STRef s Position -> Position -> ST s ()
forall s a. STRef s a -> a -> ST s ()
writeSTRef STRef s Position
earliest (MQA s -> Position
forall s. MQA s -> Position
mqa_start ([MQA s] -> MQA s
forall a. [a] -> a
last [MQA s]
new))
      STRef s [MQA s] -> [MQA s] -> ST s ()
forall s a. STRef s a -> a -> ST s ()
writeSTRef STRef s [MQA s]
list [MQA s]
new
      [WScratch s] -> ST s [WScratch s]
forall (m :: * -> *) a. Monad m => a -> m a
return ((MQA s -> WScratch s) -> [MQA s] -> [WScratch s]
forall a b. (a -> b) -> [a] -> [b]
map MQA s -> WScratch s
forall s. MQA s -> WScratch s
mqa_ws [MQA s]
ans)

{- MUTABLE SCRATCH DATA STRUCTURES -}

data SScratch s = SScratch { forall s. SScratch s -> MScratch s
_s_1 :: !(MScratch s)
                           , forall s. SScratch s -> MScratch s
_s_2 :: !(MScratch s)
                           , forall s.
SScratch s
-> (MQ s, BlankScratch s,
    STArray
      s
      Position
      ((Position, Instructions), STUArray s Position Position, OrbitLog))
_s_rest :: !( MQ s
                                        , BlankScratch s
                                        , STArray s Index ((Index,Instructions),STUArray s Tag Position,OrbitLog)
                                        )
                           }
data MScratch s = MScratch { forall s.
MScratch s
-> STArray s Position (Maybe (STUArray s Position Position))
m_pos :: !(STArray s Index (Maybe (STUArray s Tag Position)))
                           , forall s. MScratch s -> STArray s Position OrbitLog
m_orbit :: !(STArray s Index OrbitLog)
                           }
newtype BlankScratch s = BlankScratch { forall s. BlankScratch s -> STUArray s Position Position
blank_pos :: (STUArray s Tag Position)
                                      }
newtype WScratch s = WScratch { forall s. WScratch s -> STUArray s Position Position
w_pos :: (STUArray s Tag Position)
                              }

{- DEBUGGING HELPERS -}

{-
indent :: String -> String
indent xs = ' ':' ':xs

showMS :: MScratch s -> Index -> ST s String
showMS s i = do
  ma <- m_pos s !! i
  mc <- m_orbit s !! i
  a <- case ma of
        Nothing -> return "No pos"
        Just pos -> fmap show (getAssocs pos)
  let c = show mc
  return $ unlines [ "MScratch, index = "++show i
                   , indent a
                   , indent c]

showMS2 :: MScratch s -> ST s String
showMS2 s = do
  (lo,hi) <- getBounds (m_pos s)
  strings <- forM [lo..hi] (showMS s)
  return (unlines strings)

showWS :: WScratch s -> ST s String
showWS (WScratch pos) = do
  a <- getAssocs pos
  return $ unlines [ "WScratch"
                   , indent (show a)]
-}
{- CREATING INITIAL MUTABLE SCRATCH DATA STRUCTURES -}

{-# INLINE newA #-}
newA :: (MArray (STUArray s) e (ST s)) => (Tag,Tag) -> e -> S.ST s (STUArray s Tag e)
newA :: forall s e.
MArray (STUArray s) e (ST s) =>
(Position, Position) -> e -> ST s (STUArray s Position e)
newA (Position, Position)
b_tags e
initial = (Position, Position) -> e -> ST s (STUArray s Position e)
forall (a :: * -> * -> *) e (m :: * -> *) i.
(MArray a e m, Ix i) =>
(i, i) -> e -> m (a i e)
newArray (Position, Position)
b_tags e
initial

{-# INLINE newA_ #-}
newA_ :: (MArray (STUArray s) e (ST s)) => (Tag,Tag) -> S.ST s (STUArray s Tag e)
newA_ :: forall s e.
MArray (STUArray s) e (ST s) =>
(Position, Position) -> ST s (STUArray s Position e)
newA_ (Position, Position)
b_tags = (Position, Position) -> ST s (STUArray s Position e)
forall (a :: * -> * -> *) e (m :: * -> *) i.
(MArray a e m, Ix i) =>
(i, i) -> m (a i e)
newArray_ (Position, Position)
b_tags

newScratch :: (Index,Index) -> (Tag,Tag) -> S.ST s (SScratch s)
newScratch :: forall s.
(Position, Position) -> (Position, Position) -> ST s (SScratch s)
newScratch (Position, Position)
b_index (Position, Position)
b_tags = do
  MScratch s
s1 <- (Position, Position) -> ST s (MScratch s)
forall s. (Position, Position) -> ST s (MScratch s)
newMScratch (Position, Position)
b_index
  MScratch s
s2 <- (Position, Position) -> ST s (MScratch s)
forall s. (Position, Position) -> ST s (MScratch s)
newMScratch (Position, Position)
b_index
  MQ s
winQ <- ST s (MQ s)
forall s. ST s (MQ s)
newMQ
  BlankScratch s
blank <- (STUArray s Position Position -> BlankScratch s)
-> ST s (STUArray s Position Position) -> ST s (BlankScratch s)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap STUArray s Position Position -> BlankScratch s
forall s. STUArray s Position Position -> BlankScratch s
BlankScratch ((Position, Position)
-> Position -> ST s (STUArray s Position Position)
forall s e.
MArray (STUArray s) e (ST s) =>
(Position, Position) -> e -> ST s (STUArray s Position e)
newA (Position, Position)
b_tags (-Position
1))
  STArray
  s
  Position
  ((Position, Instructions), STUArray s Position Position, OrbitLog)
which <- ((Position, Position)
-> ((Position, Instructions), STUArray s Position Position,
    OrbitLog)
-> ST
     s
     (STArray
        s
        Position
        ((Position, Instructions), STUArray s Position Position, OrbitLog))
forall (a :: * -> * -> *) e (m :: * -> *) i.
(MArray a e m, Ix i) =>
(i, i) -> e -> m (a i e)
newArray (Position, Position)
b_index ((-Position
1,[Char] -> Instructions
forall a. [Char] -> a
err [Char]
"newScratch which 1"),[Char] -> STUArray s Position Position
forall a. [Char] -> a
err [Char]
"newScratch which 2",[Char] -> OrbitLog
forall a. [Char] -> a
err [Char]
"newScratch which 3"))
  SScratch s -> ST s (SScratch s)
forall (m :: * -> *) a. Monad m => a -> m a
return (MScratch s
-> MScratch s
-> (MQ s, BlankScratch s,
    STArray
      s
      Position
      ((Position, Instructions), STUArray s Position Position, OrbitLog))
-> SScratch s
forall s.
MScratch s
-> MScratch s
-> (MQ s, BlankScratch s,
    STArray
      s
      Position
      ((Position, Instructions), STUArray s Position Position, OrbitLog))
-> SScratch s
SScratch MScratch s
s1 MScratch s
s2 (MQ s
winQ,BlankScratch s
blank,STArray
  s
  Position
  ((Position, Instructions), STUArray s Position Position, OrbitLog)
which))

newMScratch :: (Index,Index) -> S.ST s (MScratch s)
newMScratch :: forall s. (Position, Position) -> ST s (MScratch s)
newMScratch (Position, Position)
b_index = do
  STArray s Position (Maybe (STUArray s Position Position))
pos's <- (Position, Position)
-> Maybe (STUArray s Position Position)
-> ST s (STArray s Position (Maybe (STUArray s Position Position)))
forall (a :: * -> * -> *) e (m :: * -> *) i.
(MArray a e m, Ix i) =>
(i, i) -> e -> m (a i e)
newArray (Position, Position)
b_index Maybe (STUArray s Position Position)
forall a. Maybe a
Nothing
  STArray s Position OrbitLog
orbit's <- (Position, Position)
-> OrbitLog -> ST s (STArray s Position OrbitLog)
forall (a :: * -> * -> *) e (m :: * -> *) i.
(MArray a e m, Ix i) =>
(i, i) -> e -> m (a i e)
newArray (Position, Position)
b_index OrbitLog
forall a. Monoid a => a
Mon.mempty
  MScratch s -> ST s (MScratch s)
forall (m :: * -> *) a. Monad m => a -> m a
return (STArray s Position (Maybe (STUArray s Position Position))
-> STArray s Position OrbitLog -> MScratch s
forall s.
STArray s Position (Maybe (STUArray s Position Position))
-> STArray s Position OrbitLog -> MScratch s
MScratch STArray s Position (Maybe (STUArray s Position Position))
pos's STArray s Position OrbitLog
orbit's)

{- COMPOSE A FUNCTION CLOSURE TO COMPARE TAG VALUES -}

newtype F s = F ([F s] -> C s)
type C s = Position
        -> ((Int, Instructions), STUArray s Tag Position, IntMap Orbits)
        -> [(Int, Action)]
        -> ((Int, Instructions), STUArray s Tag Position, IntMap Orbits)
        -> [(Int, Action)]
        -> ST s Ordering

{-# INLINE orderOf #-}
orderOf :: Action -> Action -> Ordering
orderOf :: Action -> Action -> Ordering
orderOf Action
post1 Action
post2 =
  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)
_ -> [Char] -> Ordering
forall a. [Char] -> a
err ([Char] -> Ordering) -> [Char] -> Ordering
forall a b. (a -> b) -> a -> b
$ [Char]
"bestTrans.compareWith.choose sees incomparable "[Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++(Action, Action) -> [Char]
forall a. Show a => a -> [Char]
show (Action
post1,Action
post2)

ditzyComp'3 :: forall s. Array Tag OP -> C s
ditzyComp'3 :: forall s. Array Position OP -> C s
ditzyComp'3 Array Position OP
aTagOP = C s
comp0 where
  (F [F s] -> C s
comp1:[F s]
compsRest) = Position -> [F s]
allcomps Position
1

  comp0 :: C s
  comp0 :: C s
comp0 Position
preTag x1 :: ((Position, Instructions), STUArray s Position Position, OrbitLog)
x1@((Position, Instructions)
_state1,STUArray s Position Position
pos1,OrbitLog
_orbit1') [(Position, Action)]
np1 x2 :: ((Position, Instructions), STUArray s Position Position, OrbitLog)
x2@((Position, Instructions)
_state2,STUArray s Position Position
pos2,OrbitLog
_orbit2') [(Position, Action)]
np2 = do
    Ordering
c <- (Position -> Position -> Ordering)
-> ST s Position -> ST s Position -> ST s Ordering
forall (m :: * -> *) a1 a2 r.
Monad m =>
(a1 -> a2 -> r) -> m a1 -> m a2 -> m r
liftM2 Position -> Position -> Ordering
forall a. Ord a => a -> a -> Ordering
compare (STUArray s Position Position
pos2STUArray s Position Position -> Position -> ST s Position
forall (a :: * -> * -> *) e s i.
(MArray a e (ST s), Ix i) =>
a i e -> Position -> ST s e
!!Position
0) (STUArray s Position Position
pos1STUArray s Position Position -> Position -> ST s Position
forall (a :: * -> * -> *) e s i.
(MArray a e (ST s), Ix i) =>
a i e -> Position -> ST s e
!!Position
0) -- reversed since Minimize
    case Ordering
c of
      Ordering
EQ -> [F s] -> C s
comp1 [F s]
compsRest Position
preTag ((Position, Instructions), STUArray s Position Position, OrbitLog)
x1 [(Position, Action)]
np1 ((Position, Instructions), STUArray s Position Position, OrbitLog)
x2 [(Position, Action)]
np2
      Ordering
answer -> Ordering -> ST s Ordering
forall (m :: * -> *) a. Monad m => a -> m a
return Ordering
answer

  allcomps :: Tag -> [F s]
  allcomps :: Position -> [F s]
allcomps Position
tag | Position
tag Position -> Position -> Bool
forall a. Ord a => a -> a -> Bool
> Position
top = [([F s] -> C s) -> F s
forall s. ([F s] -> C s) -> F s
F (\ [F s]
_ Position
_ ((Position, Instructions), STUArray s Position Position, OrbitLog)
_ [(Position, Action)]
_ ((Position, Instructions), STUArray s Position Position, OrbitLog)
_ [(Position, Action)]
_ -> Ordering -> ST s Ordering
forall (m :: * -> *) a. Monad m => a -> m a
return Ordering
EQ)]
               | Bool
otherwise =
    case Array Position OP
aTagOP Array Position OP -> Position -> OP
forall (a :: * -> * -> *) e i.
(IArray a e, Ix i) =>
a i e -> i -> e
! Position
tag of
      OP
Orbit -> ([F s] -> C s) -> F s
forall s. ([F s] -> C s) -> F s
F (Position -> [F s] -> C s
forall {s}.
Position
-> [F s]
-> Position
-> ((Position, Instructions), STUArray s Position Position,
    OrbitLog)
-> [(Position, Action)]
-> ((Position, Instructions), STUArray s Position Position,
    OrbitLog)
-> [(Position, Action)]
-> ST s Ordering
challenge_Orb Position
tag) F s -> [F s] -> [F s]
forall a. a -> [a] -> [a]
: Position -> [F s]
allcomps (Position -> Position
forall a. Enum a => a -> a
succ Position
tag)
      OP
Maximize -> ([F s] -> C s) -> F s
forall s. ([F s] -> C s) -> F s
F (Position -> [F s] -> C s
forall {s}.
Position
-> [F s]
-> Position
-> ((Position, Instructions), STUArray s Position Position,
    OrbitLog)
-> [(Position, Action)]
-> ((Position, Instructions), STUArray s Position Position,
    OrbitLog)
-> [(Position, Action)]
-> ST s Ordering
challenge_Max Position
tag) F s -> [F s] -> [F s]
forall a. a -> [a] -> [a]
: Position -> [F s]
allcomps (Position -> Position
forall a. Enum a => a -> a
succ Position
tag)
      OP
Ignore -> ([F s] -> C s) -> F s
forall s. ([F s] -> C s) -> F s
F (Position -> [F s] -> C s
forall {s}.
Position
-> [F s]
-> Position
-> ((Position, Instructions), STUArray s Position Position,
    OrbitLog)
-> [(Position, Action)]
-> ((Position, Instructions), STUArray s Position Position,
    OrbitLog)
-> [(Position, Action)]
-> ST s Ordering
challenge_Ignore Position
tag) F s -> [F s] -> [F s]
forall a. a -> [a] -> [a]
: Position -> [F s]
allcomps (Position -> Position
forall a. Enum a => a -> a
succ Position
tag)
      OP
Minimize -> [Char] -> [F s]
forall a. [Char] -> a
err [Char]
"allcomps Minimize"
   where top :: Position
top = (Position, Position) -> Position
forall a b. (a, b) -> b
snd (Array Position OP -> (Position, Position)
forall (a :: * -> * -> *) e i.
(IArray a e, Ix i) =>
a i e -> (i, i)
bounds Array Position OP
aTagOP)

  challenge_Ignore :: Position
-> [F s]
-> Position
-> ((Position, Instructions), STUArray s Position Position,
    OrbitLog)
-> [(Position, Action)]
-> ((Position, Instructions), STUArray s Position Position,
    OrbitLog)
-> [(Position, Action)]
-> ST s Ordering
challenge_Ignore !Position
tag (F [F s]
-> Position
-> ((Position, Instructions), STUArray s Position Position,
    OrbitLog)
-> [(Position, Action)]
-> ((Position, Instructions), STUArray s Position Position,
    OrbitLog)
-> [(Position, Action)]
-> ST s Ordering
next:[F s]
comps) Position
preTag ((Position, Instructions), STUArray s Position Position, OrbitLog)
x1 [(Position, Action)]
np1 ((Position, Instructions), STUArray s Position Position, OrbitLog)
x2 [(Position, Action)]
np2 =
    case [(Position, Action)]
np1 of
      ((Position
t1,Action
_):[(Position, Action)]
rest1) | Position
t1Position -> Position -> Bool
forall a. Eq a => a -> a -> Bool
==Position
tag ->
        case [(Position, Action)]
np2 of
          ((Position
t2,Action
_):[(Position, Action)]
rest2) | Position
t2Position -> Position -> Bool
forall a. Eq a => a -> a -> Bool
==Position
tag -> [F s]
-> Position
-> ((Position, Instructions), STUArray s Position Position,
    OrbitLog)
-> [(Position, Action)]
-> ((Position, Instructions), STUArray s Position Position,
    OrbitLog)
-> [(Position, Action)]
-> ST s Ordering
next [F s]
comps Position
preTag ((Position, Instructions), STUArray s Position Position, OrbitLog)
x1 [(Position, Action)]
rest1 ((Position, Instructions), STUArray s Position Position, OrbitLog)
x2 [(Position, Action)]
rest2
          [(Position, Action)]
_ -> [F s]
-> Position
-> ((Position, Instructions), STUArray s Position Position,
    OrbitLog)
-> [(Position, Action)]
-> ((Position, Instructions), STUArray s Position Position,
    OrbitLog)
-> [(Position, Action)]
-> ST s Ordering
next [F s]
comps Position
preTag ((Position, Instructions), STUArray s Position Position, OrbitLog)
x1 [(Position, Action)]
rest1 ((Position, Instructions), STUArray s Position Position, OrbitLog)
x2 [(Position, Action)]
np2
      [(Position, Action)]
_ -> do
        case [(Position, Action)]
np2 of
          ((Position
t2,Action
_):[(Position, Action)]
rest2) | Position
t2Position -> Position -> Bool
forall a. Eq a => a -> a -> Bool
==Position
tag -> [F s]
-> Position
-> ((Position, Instructions), STUArray s Position Position,
    OrbitLog)
-> [(Position, Action)]
-> ((Position, Instructions), STUArray s Position Position,
    OrbitLog)
-> [(Position, Action)]
-> ST s Ordering
next [F s]
comps Position
preTag ((Position, Instructions), STUArray s Position Position, OrbitLog)
x1 [(Position, Action)]
np1 ((Position, Instructions), STUArray s Position Position, OrbitLog)
x2 [(Position, Action)]
rest2
          [(Position, Action)]
_ ->  [F s]
-> Position
-> ((Position, Instructions), STUArray s Position Position,
    OrbitLog)
-> [(Position, Action)]
-> ((Position, Instructions), STUArray s Position Position,
    OrbitLog)
-> [(Position, Action)]
-> ST s Ordering
next [F s]
comps Position
preTag ((Position, Instructions), STUArray s Position Position, OrbitLog)
x1 [(Position, Action)]
np1 ((Position, Instructions), STUArray s Position Position, OrbitLog)
x2 [(Position, Action)]
np2
  challenge_Ignore Position
_ [] Position
_ ((Position, Instructions), STUArray s Position Position, OrbitLog)
_ [(Position, Action)]
_ ((Position, Instructions), STUArray s Position Position, OrbitLog)
_ [(Position, Action)]
_ = [Char] -> ST s Ordering
forall a. [Char] -> a
err [Char]
"impossible 2347867"

  challenge_Max :: Position
-> [F s]
-> Position
-> ((Position, Instructions), STUArray s Position Position,
    OrbitLog)
-> [(Position, Action)]
-> ((Position, Instructions), STUArray s Position Position,
    OrbitLog)
-> [(Position, Action)]
-> ST s Ordering
challenge_Max !Position
tag (F [F s]
-> Position
-> ((Position, Instructions), STUArray s Position Position,
    OrbitLog)
-> [(Position, Action)]
-> ((Position, Instructions), STUArray s Position Position,
    OrbitLog)
-> [(Position, Action)]
-> ST s Ordering
next:[F s]
comps) Position
preTag x1 :: ((Position, Instructions), STUArray s Position Position, OrbitLog)
x1@((Position, Instructions)
_state1,STUArray s Position Position
pos1,OrbitLog
_orbit1') [(Position, Action)]
np1 x2 :: ((Position, Instructions), STUArray s Position Position, OrbitLog)
x2@((Position, Instructions)
_state2,STUArray s Position Position
pos2,OrbitLog
_orbit2') [(Position, Action)]
np2 =
    case [(Position, Action)]
np1 of
      ((Position
t1,Action
b1):[(Position, Action)]
rest1) | Position
t1Position -> Position -> Bool
forall a. Eq a => a -> a -> Bool
==Position
tag ->
        case [(Position, Action)]
np2 of
          ((Position
t2,Action
b2):[(Position, Action)]
rest2) | Position
t2Position -> Position -> Bool
forall a. Eq a => a -> a -> Bool
==Position
tag ->
            if Action
b1Action -> Action -> Bool
forall a. Eq a => a -> a -> Bool
==Action
b2 then [F s]
-> Position
-> ((Position, Instructions), STUArray s Position Position,
    OrbitLog)
-> [(Position, Action)]
-> ((Position, Instructions), STUArray s Position Position,
    OrbitLog)
-> [(Position, Action)]
-> ST s Ordering
next [F s]
comps Position
preTag ((Position, Instructions), STUArray s Position Position, OrbitLog)
x1 [(Position, Action)]
rest1 ((Position, Instructions), STUArray s Position Position, OrbitLog)
x2 [(Position, Action)]
rest2
              else Ordering -> ST s Ordering
forall (m :: * -> *) a. Monad m => a -> m a
return (Action -> Action -> Ordering
orderOf Action
b1 Action
b2)
          [(Position, Action)]
_ -> do
            Position
p2 <- STUArray s Position Position
pos2 STUArray s Position Position -> Position -> ST s Position
forall (a :: * -> * -> *) e s i.
(MArray a e (ST s), Ix i) =>
a i e -> Position -> ST s e
!! Position
tag
            let p1 :: Position
p1 = case Action
b1 of Action
SetPre -> Position
preTag
                                Action
SetPost -> Position -> Position
forall a. Enum a => a -> a
succ Position
preTag
                                SetVal Position
v -> Position
v
            if Position
p1Position -> Position -> Bool
forall a. Eq a => a -> a -> Bool
==Position
p2 then [F s]
-> Position
-> ((Position, Instructions), STUArray s Position Position,
    OrbitLog)
-> [(Position, Action)]
-> ((Position, Instructions), STUArray s Position Position,
    OrbitLog)
-> [(Position, Action)]
-> ST s Ordering
next [F s]
comps Position
preTag ((Position, Instructions), STUArray s Position Position, OrbitLog)
x1 [(Position, Action)]
rest1 ((Position, Instructions), STUArray s Position Position, OrbitLog)
x2 [(Position, Action)]
np2
              else Ordering -> ST s Ordering
forall (m :: * -> *) a. Monad m => a -> m a
return (Position -> Position -> Ordering
forall a. Ord a => a -> a -> Ordering
compare Position
p1 Position
p2)
      [(Position, Action)]
_ -> do
        Position
p1 <- STUArray s Position Position
pos1 STUArray s Position Position -> Position -> ST s Position
forall (a :: * -> * -> *) e s i.
(MArray a e (ST s), Ix i) =>
a i e -> Position -> ST s e
!! Position
tag
        case [(Position, Action)]
np2 of
          ((Position
t2,Action
b2):[(Position, Action)]
rest2) | Position
t2Position -> Position -> Bool
forall a. Eq a => a -> a -> Bool
==Position
tag -> do
            let p2 :: Position
p2 = case Action
b2 of Action
SetPre -> Position
preTag
                                Action
SetPost -> Position -> Position
forall a. Enum a => a -> a
succ Position
preTag
                                SetVal Position
v -> Position
v
            if Position
p1Position -> Position -> Bool
forall a. Eq a => a -> a -> Bool
==Position
p2 then [F s]
-> Position
-> ((Position, Instructions), STUArray s Position Position,
    OrbitLog)
-> [(Position, Action)]
-> ((Position, Instructions), STUArray s Position Position,
    OrbitLog)
-> [(Position, Action)]
-> ST s Ordering
next [F s]
comps Position
preTag ((Position, Instructions), STUArray s Position Position, OrbitLog)
x1 [(Position, Action)]
np1 ((Position, Instructions), STUArray s Position Position, OrbitLog)
x2 [(Position, Action)]
rest2
              else Ordering -> ST s Ordering
forall (m :: * -> *) a. Monad m => a -> m a
return (Position -> Position -> Ordering
forall a. Ord a => a -> a -> Ordering
compare Position
p1 Position
p2)
          [(Position, Action)]
_ -> do
            Position
p2 <- STUArray s Position Position
pos2 STUArray s Position Position -> Position -> ST s Position
forall (a :: * -> * -> *) e s i.
(MArray a e (ST s), Ix i) =>
a i e -> Position -> ST s e
!! Position
tag
            if Position
p1Position -> Position -> Bool
forall a. Eq a => a -> a -> Bool
==Position
p2 then [F s]
-> Position
-> ((Position, Instructions), STUArray s Position Position,
    OrbitLog)
-> [(Position, Action)]
-> ((Position, Instructions), STUArray s Position Position,
    OrbitLog)
-> [(Position, Action)]
-> ST s Ordering
next [F s]
comps Position
preTag ((Position, Instructions), STUArray s Position Position, OrbitLog)
x1 [(Position, Action)]
np1 ((Position, Instructions), STUArray s Position Position, OrbitLog)
x2 [(Position, Action)]
np2
              else Ordering -> ST s Ordering
forall (m :: * -> *) a. Monad m => a -> m a
return (Position -> Position -> Ordering
forall a. Ord a => a -> a -> Ordering
compare Position
p1 Position
p2)
  challenge_Max Position
_ [] Position
_ ((Position, Instructions), STUArray s Position Position, OrbitLog)
_ [(Position, Action)]
_ ((Position, Instructions), STUArray s Position Position, OrbitLog)
_ [(Position, Action)]
_ = [Char] -> ST s Ordering
forall a. [Char] -> a
err [Char]
"impossible 9384324"

  challenge_Orb :: Position
-> [F s]
-> Position
-> ((Position, Instructions), STUArray s Position Position,
    OrbitLog)
-> [(Position, Action)]
-> ((Position, Instructions), STUArray s Position Position,
    OrbitLog)
-> [(Position, Action)]
-> ST s Ordering
challenge_Orb !Position
tag (F [F s]
-> Position
-> ((Position, Instructions), STUArray s Position Position,
    OrbitLog)
-> [(Position, Action)]
-> ((Position, Instructions), STUArray s Position Position,
    OrbitLog)
-> [(Position, Action)]
-> ST s Ordering
next:[F s]
comps) Position
preTag x1 :: ((Position, Instructions), STUArray s Position Position, OrbitLog)
x1@((Position, Instructions)
_state1,STUArray s Position Position
_pos1,OrbitLog
orbit1') [(Position, Action)]
np1 x2 :: ((Position, Instructions), STUArray s Position Position, OrbitLog)
x2@((Position, Instructions)
_state2,STUArray s Position Position
_pos2,OrbitLog
orbit2') [(Position, Action)]
np2 =
    let s1 :: Maybe Orbits
s1 = Position -> OrbitLog -> Maybe Orbits
forall a. Position -> IntMap a -> Maybe a
IMap.lookup Position
tag OrbitLog
orbit1'
        s2 :: Maybe Orbits
s2 = Position -> OrbitLog -> Maybe Orbits
forall a. Position -> IntMap a -> Maybe a
IMap.lookup Position
tag OrbitLog
orbit2'
    in case (Maybe Orbits
s1,Maybe Orbits
s2) of
         (Maybe Orbits
Nothing,Maybe Orbits
Nothing) -> [F s]
-> Position
-> ((Position, Instructions), STUArray s Position Position,
    OrbitLog)
-> [(Position, Action)]
-> ((Position, Instructions), STUArray s Position Position,
    OrbitLog)
-> [(Position, Action)]
-> ST s Ordering
next [F s]
comps Position
preTag ((Position, Instructions), STUArray s Position Position, OrbitLog)
x1 [(Position, Action)]
np1 ((Position, Instructions), STUArray s Position Position, OrbitLog)
x2 [(Position, Action)]
np2
         (Just Orbits
o1,Just Orbits
o2) | Orbits -> Bool
inOrbit Orbits
o1 Bool -> Bool -> Bool
forall a. Eq a => a -> a -> Bool
== Orbits -> Bool
inOrbit Orbits
o2 ->
            case Maybe Position -> Maybe Position -> Ordering
forall a. Ord a => a -> a -> Ordering
compare (Orbits -> Maybe Position
ordinal Orbits
o1) (Orbits -> Maybe Position
ordinal Orbits
o2) Ordering -> Ordering -> Ordering
forall a. Monoid a => a -> a -> a
`mappend`
                 ViewL Position -> ViewL Position -> Ordering
comparePos (Seq Position -> ViewL Position
forall a. Seq a -> ViewL a
viewl (Orbits -> Seq Position
getOrbits Orbits
o1)) (Seq Position -> ViewL Position
forall a. Seq a -> ViewL a
viewl (Orbits -> Seq Position
getOrbits Orbits
o2)) of
              Ordering
EQ -> [F s]
-> Position
-> ((Position, Instructions), STUArray s Position Position,
    OrbitLog)
-> [(Position, Action)]
-> ((Position, Instructions), STUArray s Position Position,
    OrbitLog)
-> [(Position, Action)]
-> ST s Ordering
next [F s]
comps Position
preTag ((Position, Instructions), STUArray s Position Position, OrbitLog)
x1 [(Position, Action)]
np1 ((Position, Instructions), STUArray s Position Position, OrbitLog)
x2 [(Position, Action)]
np2
              Ordering
answer -> Ordering -> ST s Ordering
forall (m :: * -> *) a. Monad m => a -> m a
return Ordering
answer
         (Maybe Orbits, Maybe Orbits)
_ -> [Char] -> ST s Ordering
forall a. [Char] -> a
err ([Char] -> ST s Ordering) -> [Char] -> ST s Ordering
forall a b. (a -> b) -> a -> b
$ [[Char]] -> [Char]
unlines [ [Char]
"challenge_Orb is too stupid to handle mismatched orbit data :"
                           , (Position, Position, [(Position, Action)], [(Position, Action)])
-> [Char]
forall a. Show a => a -> [Char]
show(Position
tag,Position
preTag,[(Position, Action)]
np1,[(Position, Action)]
np2)
                           , Maybe Orbits -> [Char]
forall a. Show a => a -> [Char]
show Maybe Orbits
s1
                           , Maybe Orbits -> [Char]
forall a. Show a => a -> [Char]
show Maybe Orbits
s2
                           ]
  challenge_Orb Position
_ [] Position
_ ((Position, Instructions), STUArray s Position Position, OrbitLog)
_ [(Position, Action)]
_ ((Position, Instructions), STUArray s Position Position, OrbitLog)
_ [(Position, Action)]
_ = [Char] -> ST s Ordering
forall a. [Char] -> a
err [Char]
"impossible 0298347"

comparePos :: (ViewL Position) -> (ViewL Position) -> Ordering
comparePos :: ViewL Position -> ViewL Position -> Ordering
comparePos ViewL Position
EmptyL ViewL Position
EmptyL = Ordering
EQ
comparePos ViewL Position
EmptyL ViewL Position
_      = Ordering
GT
comparePos ViewL Position
_      ViewL Position
EmptyL = Ordering
LT
comparePos (Position
p1 :< Seq Position
ps1) (Position
p2 :< Seq Position
ps2) =
  Position -> Position -> Ordering
forall a. Ord a => a -> a -> Ordering
compare Position
p1 Position
p2 Ordering -> Ordering -> Ordering
forall a. Monoid a => a -> a -> a
`mappend` ViewL Position -> ViewL Position -> Ordering
comparePos (Seq Position -> ViewL Position
forall a. Seq a -> ViewL a
viewl Seq Position
ps1) (Seq Position -> ViewL Position
forall a. Seq a -> ViewL a
viewl Seq Position
ps2)

{- CONVERT WINNERS TO MATCHARRAY -}
tagsToGroupsST :: forall s. Array GroupIndex [GroupInfo] -> WScratch s -> S.ST s MatchArray
tagsToGroupsST :: forall s.
Array Position [GroupInfo] -> WScratch s -> ST s MatchArray
tagsToGroupsST Array Position [GroupInfo]
aGroups (WScratch {w_pos :: forall s. WScratch s -> STUArray s Position Position
w_pos=STUArray s Position Position
pos})= do
  let b_max :: Position
b_max = (Position, Position) -> Position
forall a b. (a, b) -> b
snd (Array Position [GroupInfo] -> (Position, Position)
forall (a :: * -> * -> *) e i.
(IArray a e, Ix i) =>
a i e -> (i, i)
bounds (Array Position [GroupInfo]
aGroups))
  STArray s Position (Position, Position)
ma <- (Position, Position)
-> (Position, Position)
-> ST s (STArray s Position (Position, Position))
forall (a :: * -> * -> *) e (m :: * -> *) i.
(MArray a e m, Ix i) =>
(i, i) -> e -> m (a i e)
newArray (Position
0,Position
b_max) (-Position
1,Position
0) :: ST s (STArray s Int (MatchOffset,MatchLength))
  Position
startPos0 <- STUArray s Position Position
pos STUArray s Position Position -> Position -> ST s Position
forall (a :: * -> * -> *) e s i.
(MArray a e (ST s), Ix i) =>
a i e -> Position -> ST s e
!! Position
0
  Position
stopPos0 <- STUArray s Position Position
pos STUArray s Position Position -> Position -> ST s Position
forall (a :: * -> * -> *) e s i.
(MArray a e (ST s), Ix i) =>
a i e -> Position -> ST s e
!! Position
1
  STArray s Position (Position, Position)
-> Position -> (Position, Position) -> ST s ()
forall (a :: * -> * -> *) e s i.
(MArray a e (ST s), Ix i) =>
a i e -> Position -> e -> ST s ()
set STArray s Position (Position, Position)
ma Position
0 (Position
startPos0,Position
stopPos0Position -> Position -> Position
forall a. Num a => a -> a -> a
-Position
startPos0)
  let act :: Position -> [GroupInfo] -> ST s ()
act Position
_this_index [] = () -> ST s ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
      act Position
this_index ((GroupInfo Position
_ Position
parent Position
start Position
stop Position
flagtag):[GroupInfo]
gs) = do
        Position
flagVal <- STUArray s Position Position
pos STUArray s Position Position -> Position -> ST s Position
forall (a :: * -> * -> *) e s i.
(MArray a e (ST s), Ix i) =>
a i e -> Position -> ST s e
!! Position
flagtag
        if (-Position
1) Position -> Position -> Bool
forall a. Eq a => a -> a -> Bool
== Position
flagVal then Position -> [GroupInfo] -> ST s ()
act Position
this_index [GroupInfo]
gs
          else do
        Position
startPos <- STUArray s Position Position
pos STUArray s Position Position -> Position -> ST s Position
forall (a :: * -> * -> *) e s i.
(MArray a e (ST s), Ix i) =>
a i e -> Position -> ST s e
!! Position
start
        Position
stopPos <- STUArray s Position Position
pos STUArray s Position Position -> Position -> ST s Position
forall (a :: * -> * -> *) e s i.
(MArray a e (ST s), Ix i) =>
a i e -> Position -> ST s e
!! Position
stop
        (Position
startParent,Position
lengthParent) <- STArray s Position (Position, Position)
ma STArray s Position (Position, Position)
-> Position -> ST s (Position, Position)
forall (a :: * -> * -> *) e s i.
(MArray a e (ST s), Ix i) =>
a i e -> Position -> ST s e
!! Position
parent
        let ok :: Bool
ok = (Position
0 Position -> Position -> Bool
forall a. Ord a => a -> a -> Bool
<= Position
startParent Bool -> Bool -> Bool
&&
                  Position
0 Position -> Position -> Bool
forall a. Ord a => a -> a -> Bool
<= Position
lengthParent Bool -> Bool -> Bool
&&
                  Position
startParent Position -> Position -> Bool
forall a. Ord a => a -> a -> Bool
<= Position
startPos Bool -> Bool -> Bool
&&
                  Position
stopPos Position -> Position -> Bool
forall a. Ord a => a -> a -> Bool
<= Position
startPos Position -> Position -> Position
forall a. Num a => a -> a -> a
+ Position
lengthParent)
        if Bool -> Bool
not Bool
ok then Position -> [GroupInfo] -> ST s ()
act Position
this_index [GroupInfo]
gs
          else STArray s Position (Position, Position)
-> Position -> (Position, Position) -> ST s ()
forall (a :: * -> * -> *) e s i.
(MArray a e (ST s), Ix i) =>
a i e -> Position -> e -> ST s ()
set STArray s Position (Position, Position)
ma Position
this_index (Position
startPos,Position
stopPosPosition -> Position -> Position
forall a. Num a => a -> a -> a
-Position
startPos)
  [Position] -> (Position -> ST s ()) -> ST s ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ ((Position, Position) -> [Position]
forall a. Ix a => (a, a) -> [a]
range (Position
1,Position
b_max)) ((Position -> ST s ()) -> ST s ())
-> (Position -> ST s ()) -> ST s ()
forall a b. (a -> b) -> a -> b
$ (\Position
i -> Position -> [GroupInfo] -> ST s ()
forall {s}.
(MArray (STUArray s) Position (ST s),
 MArray (STArray s) (Position, Position) (ST s)) =>
Position -> [GroupInfo] -> ST s ()
act Position
i (Array Position [GroupInfo]
aGroupsArray Position [GroupInfo] -> Position -> [GroupInfo]
forall (a :: * -> * -> *) e i.
(IArray a e, Ix i) =>
a i e -> i -> e
!Position
i))
  STArray s Position (Position, Position) -> ST s MatchArray
forall i (a :: * -> * -> *) e (m :: * -> *) (b :: * -> * -> *).
(Ix i, MArray a e m, IArray b e) =>
a i e -> m (b i e)
unsafeFreeze STArray s Position (Position, Position)
ma

{- MUTABLE TAGGED TRANSITION (returning Tag-0 value) -}

{-# INLINE spawnStart #-}
-- Reset the entry at "Index", or allocate such an entry.
-- set tag 0 to the "Position"
spawnStart :: (Tag,Tag) -> BlankScratch s -> Index -> MScratch s -> Position -> S.ST s Position
spawnStart :: forall s.
(Position, Position)
-> BlankScratch s
-> Position
-> MScratch s
-> Position
-> ST s Position
spawnStart (Position, Position)
b_tags (BlankScratch STUArray s Position Position
blankPos) Position
i MScratch s
s1 Position
thisPos = do
  Maybe (STUArray s Position Position)
oldPos <- MScratch s
-> STArray s Position (Maybe (STUArray s Position Position))
forall s.
MScratch s
-> STArray s Position (Maybe (STUArray s Position Position))
m_pos MScratch s
s1 STArray s Position (Maybe (STUArray s Position Position))
-> Position -> ST s (Maybe (STUArray s Position Position))
forall (a :: * -> * -> *) e s i.
(MArray a e (ST s), Ix i) =>
a i e -> Position -> ST s e
!! Position
i
  STUArray s Position Position
pos <- case Maybe (STUArray s Position Position)
oldPos of
           Maybe (STUArray s Position Position)
Nothing -> do
             STUArray s Position Position
pos' <- (Position, Position) -> ST s (STUArray s Position Position)
forall s e.
MArray (STUArray s) e (ST s) =>
(Position, Position) -> ST s (STUArray s Position e)
newA_ (Position, Position)
b_tags
             STArray s Position (Maybe (STUArray s Position Position))
-> Position -> Maybe (STUArray s Position Position) -> ST s ()
forall (a :: * -> * -> *) e s i.
(MArray a e (ST s), Ix i) =>
a i e -> Position -> e -> ST s ()
set (MScratch s
-> STArray s Position (Maybe (STUArray s Position Position))
forall s.
MScratch s
-> STArray s Position (Maybe (STUArray s Position Position))
m_pos MScratch s
s1) Position
i (STUArray s Position Position
-> Maybe (STUArray s Position Position)
forall a. a -> Maybe a
Just STUArray s Position Position
pos')
             STUArray s Position Position -> ST s (STUArray s Position Position)
forall (m :: * -> *) a. Monad m => a -> m a
return STUArray s Position Position
pos'
           Just STUArray s Position Position
pos -> STUArray s Position Position -> ST s (STUArray s Position Position)
forall (m :: * -> *) a. Monad m => a -> m a
return STUArray s Position Position
pos
  STUArray s Position Position
-> STUArray s Position Position -> ST s ()
forall i s e.
(Show i, Ix i, MArray (STUArray s) e (ST s)) =>
STUArray s i e -> STUArray s i e -> ST s ()
copySTU STUArray s Position Position
blankPos STUArray s Position Position
pos
  STArray s Position OrbitLog -> Position -> OrbitLog -> ST s ()
forall (a :: * -> * -> *) e s i.
(MArray a e (ST s), Ix i) =>
a i e -> Position -> e -> ST s ()
set (MScratch s -> STArray s Position OrbitLog
forall s. MScratch s -> STArray s Position OrbitLog
m_orbit MScratch s
s1) Position
i (OrbitLog -> ST s ()) -> OrbitLog -> ST s ()
forall a b. (a -> b) -> a -> b
$! OrbitLog
forall a. Monoid a => a
mempty
  STUArray s Position Position -> Position -> Position -> ST s ()
forall (a :: * -> * -> *) e s i.
(MArray a e (ST s), Ix i) =>
a i e -> Position -> e -> ST s ()
set STUArray s Position Position
pos Position
0 Position
thisPos
  Position -> ST s Position
forall (m :: * -> *) a. Monad m => a -> m a
return Position
thisPos

{-# INLINE updateCopy #-}
updateCopy :: ((Index, Instructions), STUArray s Tag Position, OrbitLog)
           -> Index
           -> MScratch s
           -> Int
           -> ST s Position
updateCopy :: forall s.
((Position, Instructions), STUArray s Position Position, OrbitLog)
-> Position -> MScratch s -> Position -> ST s Position
updateCopy ((Position
_i1,Instructions
instructions),STUArray s Position Position
oldPos,OrbitLog
newOrbit) Position
preTag MScratch s
s2 Position
i2 = do
  (Position, Position)
b_tags <- STUArray s Position Position -> ST s (Position, Position)
forall (a :: * -> * -> *) e (m :: * -> *) i.
(MArray a e m, Ix i) =>
a i e -> m (i, i)
getBounds STUArray s Position Position
oldPos
  STUArray s Position Position
newerPos <- ST s (STUArray s Position Position)
-> (STUArray s Position Position
    -> ST s (STUArray s Position Position))
-> Maybe (STUArray s Position Position)
-> ST s (STUArray s Position Position)
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (do
    STUArray s Position Position
a <- (Position, Position) -> ST s (STUArray s Position Position)
forall s e.
MArray (STUArray s) e (ST s) =>
(Position, Position) -> ST s (STUArray s Position e)
newA_ (Position, Position)
b_tags
    STArray s Position (Maybe (STUArray s Position Position))
-> Position -> Maybe (STUArray s Position Position) -> ST s ()
forall (a :: * -> * -> *) e s i.
(MArray a e (ST s), Ix i) =>
a i e -> Position -> e -> ST s ()
set (MScratch s
-> STArray s Position (Maybe (STUArray s Position Position))
forall s.
MScratch s
-> STArray s Position (Maybe (STUArray s Position Position))
m_pos MScratch s
s2) Position
i2 (STUArray s Position Position
-> Maybe (STUArray s Position Position)
forall a. a -> Maybe a
Just STUArray s Position Position
a)
    STUArray s Position Position -> ST s (STUArray s Position Position)
forall (m :: * -> *) a. Monad m => a -> m a
return STUArray s Position Position
a) STUArray s Position Position -> ST s (STUArray s Position Position)
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe (STUArray s Position Position)
 -> ST s (STUArray s Position Position))
-> ST s (Maybe (STUArray s Position Position))
-> ST s (STUArray s Position Position)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< MScratch s
-> STArray s Position (Maybe (STUArray s Position Position))
forall s.
MScratch s
-> STArray s Position (Maybe (STUArray s Position Position))
m_pos MScratch s
s2 STArray s Position (Maybe (STUArray s Position Position))
-> Position -> ST s (Maybe (STUArray s Position Position))
forall (a :: * -> * -> *) e s i.
(MArray a e (ST s), Ix i) =>
a i e -> Position -> ST s e
!! Position
i2
  STUArray s Position Position
-> STUArray s Position Position -> ST s ()
forall i s e.
(Show i, Ix i, MArray (STUArray s) e (ST s)) =>
STUArray s i e -> STUArray s i e -> ST s ()
copySTU STUArray s Position Position
oldPos STUArray s Position Position
newerPos
  Position
-> STUArray s Position Position -> [(Position, Action)] -> ST s ()
forall s.
Position
-> STUArray s Position Position -> [(Position, Action)] -> ST s ()
doActions Position
preTag STUArray s Position Position
newerPos (Instructions -> [(Position, Action)]
newPos Instructions
instructions)
  STArray s Position OrbitLog -> Position -> OrbitLog -> ST s ()
forall (a :: * -> * -> *) e s i.
(MArray a e (ST s), Ix i) =>
a i e -> Position -> e -> ST s ()
set (MScratch s -> STArray s Position OrbitLog
forall s. MScratch s -> STArray s Position OrbitLog
m_orbit MScratch s
s2) Position
i2 (OrbitLog -> ST s ()) -> OrbitLog -> ST s ()
forall a b. (a -> b) -> a -> b
$! OrbitLog
newOrbit
  STUArray s Position Position
newerPos STUArray s Position Position -> Position -> ST s Position
forall (a :: * -> * -> *) e s i.
(MArray a e (ST s), Ix i) =>
a i e -> Position -> ST s e
!! Position
0

{- USING memcpy TO COPY STUARRAY DATA -}

-- #ifdef __GLASGOW_HASKELL__
foreign import ccall unsafe "memcpy"
    memcpy :: MutableByteArray# RealWorld -> MutableByteArray# RealWorld -> Int# -> IO ()

{-
Prelude Data.Array.Base> :i STUArray
data STUArray s i e
  = STUArray !i !i !Int (GHC.Prim.MutableByteArray# s)
  -- Defined in Data.Array.Base
-}
-- This has been updated for ghc 6.8.3 and still works with ghc 6.10.1
{-# INLINE copySTU #-}
copySTU :: (Show i,Ix i,MArray (STUArray s) e (S.ST s)) => STUArray s i e -> STUArray s i e -> S.ST s () -- (STUArray s i e)
copySTU :: forall i s e.
(Show i, Ix i, MArray (STUArray s) e (ST s)) =>
STUArray s i e -> STUArray s i e -> ST s ()
copySTU _souce :: STUArray s i e
_souce@(STUArray i
_ i
_ Position
_ MutableByteArray# s
msource) _destination :: STUArray s i e
_destination@(STUArray i
_ i
_ Position
_ MutableByteArray# s
mdest) =
-- do b1 <- getBounds s1
--  b2 <- getBounds s2
--  when (b1/=b2) (error ("\n\nWTF copySTU: "++show (b1,b2)))
  STRep s () -> ST s ()
forall s a. STRep s a -> ST s a
ST (STRep s () -> ST s ()) -> STRep s () -> ST s ()
forall a b. (a -> b) -> a -> b
$ \State# s
s1# ->
    case MutableByteArray# s -> Int#
forall d. MutableByteArray# d -> Int#
sizeofMutableByteArray# MutableByteArray# s
msource        of { Int#
n# ->
    case (MutableByteArray# RealWorld
 -> MutableByteArray# RealWorld -> Int# -> IO ())
-> MutableByteArray# s -> MutableByteArray# s -> Int# -> STRep s ()
unsafeCoerce# MutableByteArray# RealWorld
-> MutableByteArray# RealWorld -> Int# -> IO ()
memcpy MutableByteArray# s
mdest MutableByteArray# s
msource Int#
n# State# s
s1# of { (# State# s
s2#, () #) ->
    (# State# s
s2#, () #) }}
{-
-- #else /* !__GLASGOW_HASKELL__ */

copySTU :: (MArray (STUArray s) e (S.ST s))=> STUArray s Tag e -> STUArray s Tag e -> S.ST s (STUArray s i e)
copySTU source destination = do
  b@(start,stop) <- getBounds source
  b' <- getBounds destination
  -- traceCopy ("> copySTArray "++show b) $ do
  when (b/=b') (fail $ "Text.Regex.TDFA.RunMutState copySTUArray bounds mismatch"++show (b,b'))
  forM_ (range b) $ \index ->
    set destination index =<< source !! index
  return destination
-- #endif /* !__GLASGOW_HASKELL__ */
-}