{-# 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 :: String -> a
err String
s = String -> String -> a
forall a. String -> String -> a
common_error String
"Text.Regex.TDFA.NewDFA.Engine"  String
s

{-# INLINE (!!) #-}
(!!) :: (MArray a e (S.ST s),Ix i) => a i e -> Int -> S.ST s e
!! :: a i e -> Int -> ST s e
(!!) = a i e -> Int -> ST s e
forall (a :: * -> * -> *) e (m :: * -> *) i.
(MArray a e m, Ix i) =>
a i e -> Int -> m e
unsafeRead
{-# INLINE set #-}
set :: (MArray a e (S.ST s),Ix i) => a i e -> Int -> e -> S.ST s ()
set :: a i e -> Int -> e -> ST s ()
set = a i e -> Int -> e -> ST s ()
forall (a :: * -> * -> *) e (m :: * -> *) i.
(MArray a e m, Ix i) =>
a i e -> Int -> 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 :: Regex -> Int -> 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 -> Int
regex_init = Int
startState
                   , regex_b_index :: Regex -> (Int, Int)
regex_b_index = (Int, Int)
b_index
                   , regex_b_tags :: Regex -> (Int, Int)
regex_b_tags = (Int, Int)
b_tags_all
                   , regex_trie :: Regex -> TrieSet DFA
regex_trie = TrieSet DFA
trie
                   , regex_tags :: Regex -> Array Int OP
regex_tags = Array Int OP
aTags
                   , regex_groups :: Regex -> Array Int [GroupInfo]
regex_groups = Array Int [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 }})
          Int
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 -> Int -> Char -> text -> [MatchArray]
forall text.
Uncons text =>
Regex -> Int -> Char -> text -> [MatchArray]
FA.execMatch Regex
r Int
offsetIn Char
prevIn text
inputIn
                                      (Bool
False ,Bool
False) -> Regex -> Int -> Char -> text -> [MatchArray]
forall text.
Uncons text =>
Regex -> Int -> Char -> text -> [MatchArray]
NC.execMatch Regex
r Int
offsetIn Char
prevIn text
inputIn
                                      (Bool
False ,Bool
True)  -> Regex -> Int -> Char -> text -> [MatchArray]
forall text.
Uncons text =>
Regex -> Int -> Char -> text -> [MatchArray]
NC_FA.execMatch Regex
r Int
offsetIn Char
prevIn text
inputIn
 where
  subCapture :: Bool
  subCapture :: Bool
subCapture = Bool
capture Bool -> Bool -> Bool
&& (Int
1Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<=(Int, Int) -> Int
forall a. Ix a => (a, a) -> Int
rangeSize (Array Int [GroupInfo] -> (Int, Int)
forall (a :: * -> * -> *) e i.
(IArray a e, Ix i) =>
a i e -> (i, i)
bounds Array Int [GroupInfo]
aGroups))

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

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

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

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

  runCaptureGroup :: L.ST s [MatchArray]
  runCaptureGroup :: 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 :: 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 :: 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 Int ((Int, Instructions), STUArray s Int Int, OrbitLog)
which)) <- (Int, Int) -> (Int, Int) -> ST s (SScratch s)
forall s. (Int, Int) -> (Int, Int) -> ST s (SScratch s)
newScratch (Int, Int)
b_index (Int, Int)
b_tags
    Int
_ <- (Int, Int)
-> BlankScratch s -> Int -> MScratch s -> Int -> ST s Int
forall s.
(Int, Int)
-> BlankScratch s -> Int -> MScratch s -> Int -> ST s Int
spawnStart (Int, Int)
b_tags BlankScratch s
blank Int
startState MScratch s
s1In Int
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
-> Int
-> Char
-> text
-> ST s [MatchArray]
next MScratch s
s1 MScratch s
s2 SetIndex
did DT
dt Int
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 -> Int -> Char -> text -> Bool
test WhichTest
wt Int
offset Char
prev text
input
                then MScratch s
-> MScratch s
-> SetIndex
-> DT
-> Int
-> Char
-> text
-> ST s [MatchArray]
next MScratch s
s1 MScratch s
s2 SetIndex
did DT
a Int
offset Char
prev text
input
                else MScratch s
-> MScratch s
-> SetIndex
-> DT
-> Int
-> Char
-> text
-> ST s [MatchArray]
next MScratch s
s1 MScratch s
s2 SetIndex
did DT
b Int
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
-> Int
-> Char
-> text
-> ST s [MatchArray]
findTrans MScratch s
s1 MScratch s
s2 SetIndex
did SetIndex
did' DT
dt' DTrans
dtrans Int
offset Char
c text
input'
              | Bool
otherwise -> do
                  (SetIndex
did',DT
dt') <- MScratch s
-> SetIndex
-> DT
-> IntMap Instructions
-> Int
-> ST s (SetIndex, DT)
processWinner MScratch s
s1 SetIndex
did DT
dt IntMap Instructions
w Int
offset
                  MScratch s
-> MScratch s
-> SetIndex
-> DT
-> Int
-> Char
-> text
-> ST s [MatchArray]
next' MScratch s
s1 MScratch s
s2 SetIndex
did' DT
dt' Int
offset Char
prev text
input

        next' :: MScratch s
-> MScratch s
-> SetIndex
-> DT
-> Int
-> Char
-> text
-> ST s [MatchArray]
next' MScratch s
s1 MScratch s
s2 SetIndex
did DT
dt Int
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 -> Int -> Char -> text -> Bool
test WhichTest
wt Int
offset Char
prev text
input
                then MScratch s
-> MScratch s
-> SetIndex
-> DT
-> Int
-> Char
-> text
-> ST s [MatchArray]
next' MScratch s
s1 MScratch s
s2 SetIndex
did DT
a Int
offset Char
prev text
input
                else MScratch s
-> MScratch s
-> SetIndex
-> DT
-> Int
-> Char
-> text
-> ST s [MatchArray]
next' MScratch s
s1 MScratch s
s2 SetIndex
did DT
b Int
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
-> Int
-> Char
-> text
-> ST s [MatchArray]
findTrans MScratch s
s1 MScratch s
s2 SetIndex
did SetIndex
did' DT
dt' DTrans
dtrans Int
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 further 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
-- descendants. 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 comparison 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 comparison 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 only be compared if
-- the other one leaves, an its stop position will be at least offset.
-- The previous sentence is justified by inspection 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 inspection 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 -> Int -> ST s ()
compressOrbits MScratch s
s1 SetIndex
did Int
offset = do
          let getStart :: Int -> ST s (Int, Int)
getStart Int
state = do Int
start <- ST s Int
-> (STUArray s Int Int -> ST s Int)
-> Maybe (STUArray s Int Int)
-> ST s Int
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (String -> ST s Int
forall a. String -> a
err String
"compressOrbit,1") (STUArray s Int Int -> Int -> ST s Int
forall (a :: * -> * -> *) e s i.
(MArray a e (ST s), Ix i) =>
a i e -> Int -> ST s e
!! Int
0) (Maybe (STUArray s Int Int) -> ST s Int)
-> ST s (Maybe (STUArray s Int Int)) -> ST s Int
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< MScratch s -> STArray s Int (Maybe (STUArray s Int Int))
forall s. MScratch s -> STArray s Int (Maybe (STUArray s Int Int))
m_pos MScratch s
s1 STArray s Int (Maybe (STUArray s Int Int))
-> Int -> ST s (Maybe (STUArray s Int Int))
forall (a :: * -> * -> *) e s i.
(MArray a e (ST s), Ix i) =>
a i e -> Int -> ST s e
!! Int
state
                                  (Int, Int) -> ST s (Int, Int)
forall (m :: * -> *) a. Monad m => a -> m a
return (Int
state,Int
start)
              cutoff :: Int
cutoff = Int
offset Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
50 -- Require: cutoff <= offset, MAGIC TUNABLE CONSTANT 50
          [(Int, Int)]
ss <- (Int -> ST s (Int, Int)) -> [Int] -> ST s [(Int, Int)]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM Int -> ST s (Int, Int)
forall s.
(MArray (STUArray s) Int (ST s),
 MArray (STArray s) (Maybe (STUArray s Int Int)) (ST s)) =>
Int -> ST s (Int, Int)
getStart (SetIndex -> [Int]
ISet.toAscList SetIndex
did)
          let compressOrbit :: Int -> ST s ()
compressOrbit Int
tag = do
                [Maybe ((Int, Int), Orbits)]
mos <- [(Int, Int)]
-> ((Int, Int) -> ST s (Maybe ((Int, Int), Orbits)))
-> ST s [Maybe ((Int, Int), Orbits)]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM [(Int, Int)]
ss ( \ p :: (Int, Int)
p@(Int
state,Int
_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 (Int -> OrbitLog -> Maybe Orbits
forall a. Int -> IntMap a -> Maybe a
IMap.lookup Int
tag) (MScratch s -> STArray s Int OrbitLog
forall s. MScratch s -> STArray s Int OrbitLog
m_orbit MScratch s
s1 STArray s Int OrbitLog -> Int -> ST s OrbitLog
forall (a :: * -> * -> *) e s i.
(MArray a e (ST s), Ix i) =>
a i e -> Int -> ST s e
!! Int
state)
                                  case Maybe Orbits
mo of
                                    Just Orbits
orbits | Orbits -> Int
basePos Orbits
orbits Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
cutoff -> Maybe ((Int, Int), Orbits) -> ST s (Maybe ((Int, Int), Orbits))
forall (m :: * -> *) a. Monad m => a -> m a
return (((Int, Int), Orbits) -> Maybe ((Int, Int), Orbits)
forall a. a -> Maybe a
Just ((Int, Int)
p,Orbits
orbits))
                                                | Bool
otherwise -> Maybe ((Int, Int), Orbits) -> ST s (Maybe ((Int, Int), Orbits))
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe ((Int, Int), Orbits)
forall a. Maybe a
Nothing
                                    Maybe Orbits
_ -> Maybe ((Int, Int), Orbits) -> ST s (Maybe ((Int, Int), Orbits))
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe ((Int, Int), Orbits)
forall a. Maybe a
Nothing )
                let compressGroup :: [((Int, b), Orbits)] -> ST s ()
compressGroup [((Int
state,b
_),Orbits
orbit)] | Seq Int -> Bool
forall a. Seq a -> Bool
Seq.null (Orbits -> Seq Int
getOrbits Orbits
orbit) = () -> ST s ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
                                                      | Bool
otherwise =
                      STArray s Int OrbitLog -> Int -> OrbitLog -> ST s ()
forall (a :: * -> * -> *) e s i.
(MArray a e (ST s), Ix i) =>
a i e -> Int -> e -> ST s ()
set (MScratch s -> STArray s Int OrbitLog
forall s. MScratch s -> STArray s Int OrbitLog
m_orbit MScratch s
s1) Int
state
                      (OrbitLog -> ST s ())
-> (OrbitLog -> OrbitLog) -> OrbitLog -> ST s ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Int -> Orbits -> OrbitLog -> OrbitLog
forall a. Int -> a -> IntMap a -> IntMap a
IMap.insert Int
tag (Orbits -> OrbitLog -> OrbitLog) -> Orbits -> OrbitLog -> OrbitLog
forall a b. (a -> b) -> a -> b
$! (Orbits
orbit { ordinal :: Maybe Int
ordinal = Maybe Int
forall a. Maybe a
Nothing, getOrbits :: Seq Int
getOrbits = Seq Int
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 Int OrbitLog
forall s. MScratch s -> STArray s Int OrbitLog
m_orbit MScratch s
s1 STArray s Int OrbitLog -> Int -> ST s OrbitLog
forall (a :: * -> * -> *) e s i.
(MArray a e (ST s), Ix i) =>
a i e -> Int -> ST s e
!! Int
state

                    compressGroup [((Int, b), Orbits)]
gs = do
                      let sortPos :: (a, Orbits) -> (a, Orbits) -> Ordering
sortPos (a
_,Orbits
b1) (a
_,Orbits
b2) = Maybe Int -> Maybe Int -> Ordering
forall a. Ord a => a -> a -> Ordering
compare (Orbits -> Maybe Int
ordinal Orbits
b1) (Orbits -> Maybe Int
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 Int -> ViewL Int -> Ordering
comparePos (Seq Int -> ViewL Int
forall a. Seq a -> ViewL a
viewl (Orbits -> Seq Int
getOrbits Orbits
b1)) (Seq Int -> ViewL Int
forall a. Seq a -> ViewL a
viewl (Orbits -> Seq Int
getOrbits Orbits
b2))
                          groupPos :: (a, Orbits) -> (a, Orbits) -> Bool
groupPos (a
_,Orbits
b1) (a
_,Orbits
b2) = Orbits -> Maybe Int
ordinal Orbits
b1 Maybe Int -> Maybe Int -> Bool
forall a. Eq a => a -> a -> Bool
== Orbits -> Maybe Int
ordinal Orbits
b2 Bool -> Bool -> Bool
&& Orbits -> Seq Int
getOrbits Orbits
b1 Seq Int -> Seq Int -> Bool
forall a. Eq a => a -> a -> Bool
== Orbits -> Seq Int
getOrbits Orbits
b2
                          gs' :: [(Int, [((Int, b), Orbits)])]
gs' = [Int] -> [[((Int, b), Orbits)]] -> [(Int, [((Int, b), Orbits)])]
forall a b. [a] -> [b] -> [(a, b)]
zip [(Int
1::Int)..] ((((Int, b), Orbits) -> ((Int, b), Orbits) -> Bool)
-> [((Int, b), Orbits)] -> [[((Int, b), Orbits)]]
forall a. (a -> a -> Bool) -> [a] -> [[a]]
groupBy ((Int, b), Orbits) -> ((Int, b), Orbits) -> Bool
forall a a. (a, Orbits) -> (a, Orbits) -> Bool
groupPos ([((Int, b), Orbits)] -> [[((Int, b), Orbits)]])
-> ([((Int, b), Orbits)] -> [((Int, b), Orbits)])
-> [((Int, b), Orbits)]
-> [[((Int, b), Orbits)]]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (((Int, b), Orbits) -> ((Int, b), Orbits) -> Ordering)
-> [((Int, b), Orbits)] -> [((Int, b), Orbits)]
forall a. (a -> a -> Ordering) -> [a] -> [a]
sortBy ((Int, b), Orbits) -> ((Int, b), Orbits) -> Ordering
forall a a. (a, Orbits) -> (a, Orbits) -> Ordering
sortPos ([((Int, b), Orbits)] -> [[((Int, b), Orbits)]])
-> [((Int, b), Orbits)] -> [[((Int, b), Orbits)]]
forall a b. (a -> b) -> a -> b
$ [((Int, b), Orbits)]
gs)
                      [(Int, [((Int, b), Orbits)])]
-> ((Int, [((Int, b), Orbits)]) -> ST s ()) -> ST s ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [(Int, [((Int, b), Orbits)])]
gs' (((Int, [((Int, b), Orbits)]) -> ST s ()) -> ST s ())
-> ((Int, [((Int, b), Orbits)]) -> ST s ()) -> ST s ()
forall a b. (a -> b) -> a -> b
$ \ (!Int
n,[((Int, b), Orbits)]
eqs) -> do
                        [((Int, b), Orbits)] -> (((Int, b), Orbits) -> ST s ()) -> ST s ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [((Int, b), Orbits)]
eqs ((((Int, b), Orbits) -> ST s ()) -> ST s ())
-> (((Int, b), Orbits) -> ST s ()) -> ST s ()
forall a b. (a -> b) -> a -> b
$ \ ((Int
state,b
_),Orbits
orbit) ->
                          STArray s Int OrbitLog -> Int -> OrbitLog -> ST s ()
forall (a :: * -> * -> *) e s i.
(MArray a e (ST s), Ix i) =>
a i e -> Int -> e -> ST s ()
set (MScratch s -> STArray s Int OrbitLog
forall s. MScratch s -> STArray s Int OrbitLog
m_orbit MScratch s
s1) Int
state
                           (OrbitLog -> ST s ())
-> (OrbitLog -> OrbitLog) -> OrbitLog -> ST s ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Int -> Orbits -> OrbitLog -> OrbitLog
forall a. Int -> a -> IntMap a -> IntMap a
IMap.insert Int
tag (Orbits -> OrbitLog -> OrbitLog) -> Orbits -> OrbitLog -> OrbitLog
forall a b. (a -> b) -> a -> b
$! (Orbits
orbit { ordinal :: Maybe Int
ordinal = Int -> Maybe Int
forall a. a -> Maybe a
Just Int
n, getOrbits :: Seq Int
getOrbits = Seq Int
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 Int OrbitLog
forall s. MScratch s -> STArray s Int OrbitLog
m_orbit MScratch s
s1 STArray s Int OrbitLog -> Int -> ST s OrbitLog
forall (a :: * -> * -> *) e s i.
(MArray a e (ST s), Ix i) =>
a i e -> Int -> ST s e
!! Int
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` Int -> Int -> Ordering
forall a. Ord a => a -> a -> Ordering
compare (Orbits -> Int
basePos Orbits
b1) (Orbits -> Int
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 -> Int
basePos Orbits
b1 Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Orbits -> Int
basePos Orbits
b2
                    orbitGroups :: [[((Int, Int), Orbits)]]
orbitGroups = (((Int, Int), Orbits) -> ((Int, Int), Orbits) -> Bool)
-> [((Int, Int), Orbits)] -> [[((Int, Int), Orbits)]]
forall a. (a -> a -> Bool) -> [a] -> [[a]]
groupBy ((Int, Int), Orbits) -> ((Int, Int), Orbits) -> Bool
forall a a a. Eq a => ((a, a), Orbits) -> ((a, a), Orbits) -> Bool
grouper ([((Int, Int), Orbits)] -> [[((Int, Int), Orbits)]])
-> ([Maybe ((Int, Int), Orbits)] -> [((Int, Int), Orbits)])
-> [Maybe ((Int, Int), Orbits)]
-> [[((Int, Int), Orbits)]]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (((Int, Int), Orbits) -> ((Int, Int), Orbits) -> Ordering)
-> [((Int, Int), Orbits)] -> [((Int, Int), Orbits)]
forall a. (a -> a -> Ordering) -> [a] -> [a]
sortBy ((Int, Int), Orbits) -> ((Int, Int), Orbits) -> Ordering
forall a a a.
Ord a =>
((a, a), Orbits) -> ((a, a), Orbits) -> Ordering
sorter ([((Int, Int), Orbits)] -> [((Int, Int), Orbits)])
-> ([Maybe ((Int, Int), Orbits)] -> [((Int, Int), Orbits)])
-> [Maybe ((Int, Int), Orbits)]
-> [((Int, Int), Orbits)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Maybe ((Int, Int), Orbits)] -> [((Int, Int), Orbits)]
forall a. [Maybe a] -> [a]
catMaybes ([Maybe ((Int, Int), Orbits)] -> [[((Int, Int), Orbits)]])
-> [Maybe ((Int, Int), Orbits)] -> [[((Int, Int), Orbits)]]
forall a b. (a -> b) -> a -> b
$ [Maybe ((Int, Int), Orbits)]
mos
                ([((Int, Int), Orbits)] -> ST s ())
-> [[((Int, Int), Orbits)]] -> ST s ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ [((Int, Int), Orbits)] -> ST s ()
forall s b.
(MArray (STArray s) OrbitLog (ST s),
 MArray (STArray s) OrbitLog (ST s),
 MArray (STArray s) OrbitLog (ST s),
 MArray (STArray s) OrbitLog (ST s)) =>
[((Int, b), Orbits)] -> ST s ()
compressGroup [[((Int, Int), Orbits)]]
orbitGroups
          (Int -> ST s ()) -> [Int] -> ST s ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ Int -> ST s ()
forall s.
(MArray (STArray s) OrbitLog (ST s),
 MArray (STArray s) OrbitLog (ST s),
 MArray (STArray s) OrbitLog (ST s),
 MArray (STArray s) OrbitLog (ST s),
 MArray (STArray s) OrbitLog (ST s)) =>
Int -> ST s ()
compressOrbit [Int]
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
-> Int
-> Char
-> text
-> ST s [MatchArray]
findTrans MScratch s
s1 MScratch s
s2 SetIndex
did SetIndex
did' DT
dt' DTrans
dtrans Int
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 ([Int] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Int]
orbitTags) Bool -> Bool -> Bool
&& (Int
offset Int -> Int -> Int
forall a. Integral a => a -> a -> a
`rem` Int
100 Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
99)) (MScratch s -> SetIndex -> Int -> ST s ()
forall s s.
(MArray (STUArray s) Int (ST s),
 MArray (STArray s) (Maybe (STUArray s Int Int)) (ST s),
 MArray (STArray s) OrbitLog (ST s)) =>
MScratch s -> SetIndex -> Int -> ST s ()
compressOrbits MScratch s
s1 SetIndex
did Int
offset)
          -- findTrans part 1
          let findTransTo :: (Int, IntMap (a, Instructions)) -> ST s ()
findTransTo (Int
destIndex,IntMap (a, Instructions)
sources) | IntMap (a, Instructions) -> Bool
forall a. IntMap a -> Bool
IMap.null IntMap (a, Instructions)
sources =
                STArray s Int ((Int, Instructions), STUArray s Int Int, OrbitLog)
-> Int
-> ((Int, Instructions), STUArray s Int Int, OrbitLog)
-> ST s ()
forall (a :: * -> * -> *) e s i.
(MArray a e (ST s), Ix i) =>
a i e -> Int -> e -> ST s ()
set STArray s Int ((Int, Instructions), STUArray s Int Int, OrbitLog)
which Int
destIndex ((-Int
1,Instructions :: [(Int, Action)]
-> Maybe (Int -> OrbitLog -> OrbitLog) -> Instructions
Instructions { newPos :: [(Int, Action)]
newPos = [(Int
0,Action
SetPost)], newOrbits :: Maybe (Int -> OrbitLog -> OrbitLog)
newOrbits = Maybe (Int -> OrbitLog -> OrbitLog)
forall a. Maybe a
Nothing })
                                    ,BlankScratch s -> STUArray s Int Int
forall s. BlankScratch s -> STUArray s Int Int
blank_pos BlankScratch s
blank,OrbitLog
forall a. Monoid a => a
mempty)
                                              | Bool
otherwise = do
                let prep :: (Int, (a, Instructions))
-> ST s ((Int, Instructions), STUArray s Int Int, OrbitLog)
prep (Int
sourceIndex,(a
_dopa,Instructions
instructions)) = {-# SCC "goNext.findTrans.prep" #-} do
                      STUArray s Int Int
pos <- ST s (STUArray s Int Int)
-> (STUArray s Int Int -> ST s (STUArray s Int Int))
-> Maybe (STUArray s Int Int)
-> ST s (STUArray s Int Int)
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (String -> ST s (STUArray s Int Int)
forall a. String -> a
err (String -> ST s (STUArray s Int Int))
-> String -> ST s (STUArray s Int Int)
forall a b. (a -> b) -> a -> b
$ String
"findTrans,1 : "String -> String -> String
forall a. [a] -> [a] -> [a]
++(Int, Int, SetIndex) -> String
forall a. Show a => a -> String
show (Int
sourceIndex,Int
destIndex,SetIndex
did')) STUArray s Int Int -> ST s (STUArray s Int Int)
forall (m :: * -> *) a. Monad m => a -> m a
return
                               (Maybe (STUArray s Int Int) -> ST s (STUArray s Int Int))
-> ST s (Maybe (STUArray s Int Int)) -> ST s (STUArray s Int Int)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< MScratch s -> STArray s Int (Maybe (STUArray s Int Int))
forall s. MScratch s -> STArray s Int (Maybe (STUArray s Int Int))
m_pos MScratch s
s1 STArray s Int (Maybe (STUArray s Int Int))
-> Int -> ST s (Maybe (STUArray s Int Int))
forall (a :: * -> * -> *) e s i.
(MArray a e (ST s), Ix i) =>
a i e -> Int -> ST s e
!! Int
sourceIndex
                      OrbitLog
orbit <- MScratch s -> STArray s Int OrbitLog
forall s. MScratch s -> STArray s Int OrbitLog
m_orbit MScratch s
s1 STArray s Int OrbitLog -> Int -> ST s OrbitLog
forall (a :: * -> * -> *) e s i.
(MArray a e (ST s), Ix i) =>
a i e -> Int -> ST s e
!! Int
sourceIndex
                      let orbit' :: OrbitLog
orbit' = OrbitLog
-> ((Int -> OrbitLog -> OrbitLog) -> OrbitLog)
-> Maybe (Int -> OrbitLog -> OrbitLog)
-> OrbitLog
forall b a. b -> (a -> b) -> Maybe a -> b
maybe OrbitLog
orbit (\ Int -> OrbitLog -> OrbitLog
f -> Int -> OrbitLog -> OrbitLog
f Int
offset OrbitLog
orbit) (Instructions -> Maybe (Int -> OrbitLog -> OrbitLog)
newOrbits Instructions
instructions)
                      ((Int, Instructions), STUArray s Int Int, OrbitLog)
-> ST s ((Int, Instructions), STUArray s Int Int, OrbitLog)
forall (m :: * -> *) a. Monad m => a -> m a
return ((Int
sourceIndex,Instructions
instructions),STUArray s Int Int
pos,OrbitLog
orbit')
                    challenge :: ((Int, Instructions), STUArray s Int Int, OrbitLog)
-> ((Int, Instructions), STUArray s Int Int, OrbitLog)
-> ST s ((Int, Instructions), STUArray s Int Int, OrbitLog)
challenge x1 :: ((Int, Instructions), STUArray s Int Int, OrbitLog)
x1@((Int
_si1,Instructions
ins1),STUArray s Int Int
_p1,OrbitLog
_o1) x2 :: ((Int, Instructions), STUArray s Int Int, OrbitLog)
x2@((Int
_si2,Instructions
ins2),STUArray s Int Int
_p2,OrbitLog
_o2) = {-# SCC "goNext.findTrans.challenge" #-} do
                      Ordering
check <- C s
forall s. C s
comp Int
offset ((Int, Instructions), STUArray s Int Int, OrbitLog)
x1 (Instructions -> [(Int, Action)]
newPos Instructions
ins1) ((Int, Instructions), STUArray s Int Int, OrbitLog)
x2 (Instructions -> [(Int, Action)]
newPos Instructions
ins2)
                      if Ordering
checkOrdering -> Ordering -> Bool
forall a. Eq a => a -> a -> Bool
==Ordering
LT then ((Int, Instructions), STUArray s Int Int, OrbitLog)
-> ST s ((Int, Instructions), STUArray s Int Int, OrbitLog)
forall (m :: * -> *) a. Monad m => a -> m a
return ((Int, Instructions), STUArray s Int Int, OrbitLog)
x2 else ((Int, Instructions), STUArray s Int Int, OrbitLog)
-> ST s ((Int, Instructions), STUArray s Int Int, OrbitLog)
forall (m :: * -> *) a. Monad m => a -> m a
return ((Int, Instructions), STUArray s Int Int, OrbitLog)
x1
                [((Int, Instructions), STUArray s Int Int, OrbitLog)]
first_rest <- ((Int, (a, Instructions))
 -> ST s ((Int, Instructions), STUArray s Int Int, OrbitLog))
-> [(Int, (a, Instructions))]
-> ST s [((Int, Instructions), STUArray s Int Int, OrbitLog)]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (Int, (a, Instructions))
-> ST s ((Int, Instructions), STUArray s Int Int, OrbitLog)
forall s a.
(MArray (STArray s) (Maybe (STUArray s Int Int)) (ST s),
 MArray (STArray s) OrbitLog (ST s)) =>
(Int, (a, Instructions))
-> ST s ((Int, Instructions), STUArray s Int Int, OrbitLog)
prep (IntMap (a, Instructions) -> [(Int, (a, Instructions))]
forall a. IntMap a -> [(Int, a)]
IMap.toList IntMap (a, Instructions)
sources)
                let ((Int, Instructions), STUArray s Int Int, OrbitLog)
first:[((Int, Instructions), STUArray s Int Int, OrbitLog)]
rest = [((Int, Instructions), STUArray s Int Int, OrbitLog)]
first_rest
                STArray s Int ((Int, Instructions), STUArray s Int Int, OrbitLog)
-> Int
-> ((Int, Instructions), STUArray s Int Int, OrbitLog)
-> ST s ()
forall (a :: * -> * -> *) e s i.
(MArray a e (ST s), Ix i) =>
a i e -> Int -> e -> ST s ()
set STArray s Int ((Int, Instructions), STUArray s Int Int, OrbitLog)
which Int
destIndex (((Int, Instructions), STUArray s Int Int, OrbitLog) -> ST s ())
-> ST s ((Int, Instructions), STUArray s Int Int, OrbitLog)
-> ST s ()
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< (((Int, Instructions), STUArray s Int Int, OrbitLog)
 -> ((Int, Instructions), STUArray s Int Int, OrbitLog)
 -> ST s ((Int, Instructions), STUArray s Int Int, OrbitLog))
-> ((Int, Instructions), STUArray s Int Int, OrbitLog)
-> [((Int, Instructions), STUArray s Int Int, OrbitLog)]
-> ST s ((Int, Instructions), STUArray s Int Int, OrbitLog)
forall (t :: * -> *) (m :: * -> *) b a.
(Foldable t, Monad m) =>
(b -> a -> m b) -> b -> t a -> m b
foldM ((Int, Instructions), STUArray s Int Int, OrbitLog)
-> ((Int, Instructions), STUArray s Int Int, OrbitLog)
-> ST s ((Int, Instructions), STUArray s Int Int, OrbitLog)
forall s.
((Int, Instructions), STUArray s Int Int, OrbitLog)
-> ((Int, Instructions), STUArray s Int Int, OrbitLog)
-> ST s ((Int, Instructions), STUArray s Int Int, OrbitLog)
challenge ((Int, Instructions), STUArray s Int Int, OrbitLog)
first [((Int, Instructions), STUArray s Int Int, OrbitLog)]
rest
          let dl :: [(Int, IntMap (DoPa, Instructions))]
dl = DTrans -> [(Int, IntMap (DoPa, Instructions))]
forall a. IntMap a -> [(Int, a)]
IMap.toList DTrans
dtrans
          ((Int, IntMap (DoPa, Instructions)) -> ST s ())
-> [(Int, IntMap (DoPa, Instructions))] -> ST s ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (Int, IntMap (DoPa, Instructions)) -> ST s ()
forall a. (Int, IntMap (a, Instructions)) -> ST s ()
findTransTo [(Int, IntMap (DoPa, Instructions))]
dl
          -- findTrans part 2
          let performTransTo :: (Int, b) -> ST s Int
performTransTo (Int
destIndex,b
_) = {-# SCC "goNext.findTrans.performTransTo" #-} do
                x :: ((Int, Instructions), STUArray s Int Int, OrbitLog)
x@((Int
sourceIndex,Instructions
_instructions),STUArray s Int Int
_pos,OrbitLog
_orbit') <- STArray s Int ((Int, Instructions), STUArray s Int Int, OrbitLog)
which STArray s Int ((Int, Instructions), STUArray s Int Int, OrbitLog)
-> Int -> ST s ((Int, Instructions), STUArray s Int Int, OrbitLog)
forall (a :: * -> * -> *) e s i.
(MArray a e (ST s), Ix i) =>
a i e -> Int -> ST s e
!! Int
destIndex
                if Int
sourceIndex Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== (-Int
1)
                  then (Int, Int)
-> BlankScratch s -> Int -> MScratch s -> Int -> ST s Int
forall s.
(Int, Int)
-> BlankScratch s -> Int -> MScratch s -> Int -> ST s Int
spawnStart (Int, Int)
b_tags BlankScratch s
blank Int
destIndex MScratch s
s2 (Int -> Int
forall a. Enum a => a -> a
succ Int
offset)
                  else ((Int, Instructions), STUArray s Int Int, OrbitLog)
-> Int -> MScratch s -> Int -> ST s Int
forall s.
((Int, Instructions), STUArray s Int Int, OrbitLog)
-> Int -> MScratch s -> Int -> ST s Int
updateCopy ((Int, Instructions), STUArray s Int Int, OrbitLog)
x Int
offset MScratch s
s2 Int
destIndex
          Int
earlyStart <- ([Int] -> Int) -> ST s [Int] -> ST s Int
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap [Int] -> Int
forall (t :: * -> *) a. (Foldable t, Ord a) => t a -> a
minimum (ST s [Int] -> ST s Int) -> ST s [Int] -> ST s Int
forall a b. (a -> b) -> a -> b
$ ((Int, IntMap (DoPa, Instructions)) -> ST s Int)
-> [(Int, IntMap (DoPa, Instructions))] -> ST s [Int]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (Int, IntMap (DoPa, Instructions)) -> ST s Int
forall b. (Int, b) -> ST s Int
performTransTo [(Int, IntMap (DoPa, Instructions))]
dl
          -- findTrans part 3
          Int
earlyWin <- STRef s Int -> ST s Int
forall s a. STRef s a -> ST s a
readSTRef (MQ s -> STRef s Int
forall s. MQ s -> STRef s Int
mq_earliest MQ s
winQ)
          if Int
earlyWin Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
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
$
                           Int -> MQ s -> ST s [WScratch s]
forall s. Int -> MQ s -> ST s [WScratch s]
getMQ Int
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
-> Int
-> Char
-> text
-> ST s [MatchArray]
next MScratch s
s2 MScratch s
s1 SetIndex
did' DT
dt' (Int -> Int
forall a. Enum a => a -> a
succ Int
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 Int [GroupInfo] -> WScratch s -> ST s MatchArray
forall s. Array Int [GroupInfo] -> WScratch s -> ST s MatchArray
tagsToGroupsST Array Int [GroupInfo]
aGroups) [WScratch s]
winners
            else do
              let offset' :: Int
offset' = Int -> Int
forall a. Enum a => a -> a
succ Int
offset in Int -> ST s [MatchArray] -> ST s [MatchArray]
seq Int
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
-> Int
-> Char
-> text
-> ST s [MatchArray]
next MScratch s
s2 MScratch s
s1 SetIndex
did' DT
dt' Int
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 ".*")
-- (further test "(.+|.+.)*" on "aa\n")

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

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

        newWinner :: Int -> ((a, Instructions), STUArray s Int Int, c) -> ST s ()
newWinner Int
preTag ((a
_sourceIndex,Instructions
winInstructions),STUArray s Int Int
oldPos,c
_newOrbit) = {-# SCC "goNext.newWinner" #-} do
          STUArray s Int Int
newerPos <- (Int, Int) -> ST s (STUArray s Int Int)
forall s e.
MArray (STUArray s) e (ST s) =>
(Int, Int) -> ST s (STUArray s Int e)
newA_ (Int, Int)
b_tags
          STUArray s Int Int -> STUArray s Int Int -> 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 Int Int
oldPos STUArray s Int Int
newerPos
          Int -> STUArray s Int Int -> [(Int, Action)] -> ST s ()
forall s. Int -> STUArray s Int Int -> [(Int, Action)] -> ST s ()
doActions Int
preTag STUArray s Int Int
newerPos (Instructions -> [(Int, Action)]
newPos Instructions
winInstructions)
          WScratch s -> MQ s -> ST s ()
forall s. WScratch s -> MQ s -> ST s ()
putMQ (STUArray s Int Int -> WScratch s
forall s. STUArray s Int Int -> WScratch s
WScratch STUArray s Int Int
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 Int [GroupInfo] -> WScratch s -> ST s MatchArray
forall s. Array Int [GroupInfo] -> WScratch s -> ST s MatchArray
tagsToGroupsST Array Int [GroupInfo]
aGroups) [WScratch s]
winners

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

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

----

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

----

{- MUTABLE WINNER QUEUE -}

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

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

newMQ :: S.ST s (MQ s)
newMQ :: ST s (MQ s)
newMQ = do
  STRef s Int
earliest <- Int -> ST s (STRef s Int)
forall a s. a -> ST s (STRef s a)
newSTRef Int
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 Int -> STRef s [MQA s] -> MQ s
forall s. STRef s Int -> STRef s [MQA s] -> MQ s
MQ STRef s Int
earliest STRef s [MQA s]
list)

resetMQ :: MQ s -> S.ST s ()
resetMQ :: MQ s -> ST s ()
resetMQ (MQ {mq_earliest :: forall s. MQ s -> STRef s Int
mq_earliest=STRef s Int
earliest,mq_list :: forall s. MQ s -> STRef s [MQA s]
mq_list=STRef s [MQA s]
list}) = do
  STRef s Int -> Int -> ST s ()
forall s a. STRef s a -> a -> ST s ()
writeSTRef STRef s Int
earliest Int
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 :: WScratch s -> MQ s -> ST s ()
putMQ WScratch s
ws (MQ {mq_earliest :: forall s. MQ s -> STRef s Int
mq_earliest=STRef s Int
earliest,mq_list :: forall s. MQ s -> STRef s [MQA s]
mq_list=STRef s [MQA s]
list}) = do
  Int
start <- WScratch s -> STUArray s Int Int
forall s. WScratch s -> STUArray s Int Int
w_pos WScratch s
ws STUArray s Int Int -> Int -> ST s Int
forall (a :: * -> * -> *) e s i.
(MArray a e (ST s), Ix i) =>
a i e -> Int -> ST s e
!! Int
0
  let mqa :: MQA s
mqa = Int -> WScratch s -> MQA s
forall s. Int -> WScratch s -> MQA s
MQA Int
start WScratch s
ws
  Int
startE <- STRef s Int -> ST s Int
forall s a. STRef s a -> ST s a
readSTRef STRef s Int
earliest
  if Int
start Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Int
startE
    then STRef s Int -> Int -> ST s ()
forall s a. STRef s a -> a -> ST s ()
writeSTRef STRef s Int
earliest Int
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 -> Int
start Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= MQA s -> Int
forall s. MQA s -> Int
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 :: Int -> MQ s -> ST s [WScratch s]
getMQ Int
pos (MQ {mq_earliest :: forall s. MQ s -> STRef s Int
mq_earliest=STRef s Int
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 -> Int
pos Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= MQA s -> Int
forall s. MQA s -> Int
mqa_start MQA s
m) [MQA s]
old of
    ([],[MQA s]
ans) -> do
      STRef s Int -> Int -> ST s ()
forall s a. STRef s a -> a -> ST s ()
writeSTRef STRef s Int
earliest Int
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 Int -> Int -> ST s ()
forall s a. STRef s a -> a -> ST s ()
writeSTRef STRef s Int
earliest (MQA s -> Int
forall s. MQA s -> Int
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 { SScratch s -> MScratch s
_s_1 :: !(MScratch s)
                           , SScratch s -> MScratch s
_s_2 :: !(MScratch s)
                           , SScratch s
-> (MQ s, BlankScratch s,
    STArray s Int ((Int, Instructions), STUArray s Int Int, OrbitLog))
_s_rest :: !( MQ s
                                        , BlankScratch s
                                        , STArray s Index ((Index,Instructions),STUArray s Tag Position,OrbitLog)
                                        )
                           }
data MScratch s = MScratch { MScratch s -> STArray s Int (Maybe (STUArray s Int Int))
m_pos :: !(STArray s Index (Maybe (STUArray s Tag Position)))
                           , MScratch s -> STArray s Int OrbitLog
m_orbit :: !(STArray s Index OrbitLog)
                           }
newtype BlankScratch s = BlankScratch { BlankScratch s -> STUArray s Int Int
blank_pos :: (STUArray s Tag Position)
                                      }
newtype WScratch s = WScratch { WScratch s -> STUArray s Int Int
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 :: (Int, Int) -> e -> ST s (STUArray s Int e)
newA (Int, Int)
b_tags e
initial = (Int, Int) -> e -> ST s (STUArray s Int e)
forall (a :: * -> * -> *) e (m :: * -> *) i.
(MArray a e m, Ix i) =>
(i, i) -> e -> m (a i e)
newArray (Int, Int)
b_tags e
initial

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

newScratch :: (Index,Index) -> (Tag,Tag) -> S.ST s (SScratch s)
newScratch :: (Int, Int) -> (Int, Int) -> ST s (SScratch s)
newScratch (Int, Int)
b_index (Int, Int)
b_tags = do
  MScratch s
s1 <- (Int, Int) -> ST s (MScratch s)
forall s. (Int, Int) -> ST s (MScratch s)
newMScratch (Int, Int)
b_index
  MScratch s
s2 <- (Int, Int) -> ST s (MScratch s)
forall s. (Int, Int) -> ST s (MScratch s)
newMScratch (Int, Int)
b_index
  MQ s
winQ <- ST s (MQ s)
forall s. ST s (MQ s)
newMQ
  BlankScratch s
blank <- (STUArray s Int Int -> BlankScratch s)
-> ST s (STUArray s Int Int) -> ST s (BlankScratch s)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap STUArray s Int Int -> BlankScratch s
forall s. STUArray s Int Int -> BlankScratch s
BlankScratch ((Int, Int) -> Int -> ST s (STUArray s Int Int)
forall s e.
MArray (STUArray s) e (ST s) =>
(Int, Int) -> e -> ST s (STUArray s Int e)
newA (Int, Int)
b_tags (-Int
1))
  STArray s Int ((Int, Instructions), STUArray s Int Int, OrbitLog)
which <- ((Int, Int)
-> ((Int, Instructions), STUArray s Int Int, OrbitLog)
-> ST
     s
     (STArray s Int ((Int, Instructions), STUArray s Int Int, OrbitLog))
forall (a :: * -> * -> *) e (m :: * -> *) i.
(MArray a e m, Ix i) =>
(i, i) -> e -> m (a i e)
newArray (Int, Int)
b_index ((-Int
1,String -> Instructions
forall a. String -> a
err String
"newScratch which 1"),String -> STUArray s Int Int
forall a. String -> a
err String
"newScratch which 2",String -> OrbitLog
forall a. String -> a
err String
"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 Int ((Int, Instructions), STUArray s Int Int, OrbitLog))
-> SScratch s
forall s.
MScratch s
-> MScratch s
-> (MQ s, BlankScratch s,
    STArray s Int ((Int, Instructions), STUArray s Int Int, OrbitLog))
-> SScratch s
SScratch MScratch s
s1 MScratch s
s2 (MQ s
winQ,BlankScratch s
blank,STArray s Int ((Int, Instructions), STUArray s Int Int, OrbitLog)
which))

newMScratch :: (Index,Index) -> S.ST s (MScratch s)
newMScratch :: (Int, Int) -> ST s (MScratch s)
newMScratch (Int, Int)
b_index = do
  STArray s Int (Maybe (STUArray s Int Int))
pos's <- (Int, Int)
-> Maybe (STUArray s Int Int)
-> ST s (STArray s Int (Maybe (STUArray s Int Int)))
forall (a :: * -> * -> *) e (m :: * -> *) i.
(MArray a e m, Ix i) =>
(i, i) -> e -> m (a i e)
newArray (Int, Int)
b_index Maybe (STUArray s Int Int)
forall a. Maybe a
Nothing
  STArray s Int OrbitLog
orbit's <- (Int, Int) -> OrbitLog -> ST s (STArray s Int OrbitLog)
forall (a :: * -> * -> *) e (m :: * -> *) i.
(MArray a e m, Ix i) =>
(i, i) -> e -> m (a i e)
newArray (Int, Int)
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 Int (Maybe (STUArray s Int Int))
-> STArray s Int OrbitLog -> MScratch s
forall s.
STArray s Int (Maybe (STUArray s Int Int))
-> STArray s Int OrbitLog -> MScratch s
MScratch STArray s Int (Maybe (STUArray s Int Int))
pos's STArray s Int 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 Int
v1,SetVal Int
v2) -> Int -> Int -> Ordering
forall a. Ord a => a -> a -> Ordering
compare Int
v1 Int
v2
    (Action, Action)
_ -> String -> Ordering
forall a. String -> a
err (String -> Ordering) -> String -> Ordering
forall a b. (a -> b) -> a -> b
$ String
"bestTrans.compareWith.choose sees incomparable "String -> String -> String
forall a. [a] -> [a] -> [a]
++(Action, Action) -> String
forall a. Show a => a -> String
show (Action
post1,Action
post2)

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

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

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

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

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

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

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

{- CONVERT WINNERS TO MATCHARRAY -}
tagsToGroupsST :: forall s. Array GroupIndex [GroupInfo] -> WScratch s -> S.ST s MatchArray
tagsToGroupsST :: Array Int [GroupInfo] -> WScratch s -> ST s MatchArray
tagsToGroupsST Array Int [GroupInfo]
aGroups (WScratch {w_pos :: forall s. WScratch s -> STUArray s Int Int
w_pos=STUArray s Int Int
pos})= do
  let b_max :: Int
b_max = (Int, Int) -> Int
forall a b. (a, b) -> b
snd (Array Int [GroupInfo] -> (Int, Int)
forall (a :: * -> * -> *) e i.
(IArray a e, Ix i) =>
a i e -> (i, i)
bounds (Array Int [GroupInfo]
aGroups))
  STArray s Int (Int, Int)
ma <- (Int, Int) -> (Int, Int) -> ST s (STArray s Int (Int, Int))
forall (a :: * -> * -> *) e (m :: * -> *) i.
(MArray a e m, Ix i) =>
(i, i) -> e -> m (a i e)
newArray (Int
0,Int
b_max) (-Int
1,Int
0) :: ST s (STArray s Int (MatchOffset,MatchLength))
  Int
startPos0 <- STUArray s Int Int
pos STUArray s Int Int -> Int -> ST s Int
forall (a :: * -> * -> *) e s i.
(MArray a e (ST s), Ix i) =>
a i e -> Int -> ST s e
!! Int
0
  Int
stopPos0 <- STUArray s Int Int
pos STUArray s Int Int -> Int -> ST s Int
forall (a :: * -> * -> *) e s i.
(MArray a e (ST s), Ix i) =>
a i e -> Int -> ST s e
!! Int
1
  STArray s Int (Int, Int) -> Int -> (Int, Int) -> ST s ()
forall (a :: * -> * -> *) e s i.
(MArray a e (ST s), Ix i) =>
a i e -> Int -> e -> ST s ()
set STArray s Int (Int, Int)
ma Int
0 (Int
startPos0,Int
stopPos0Int -> Int -> Int
forall a. Num a => a -> a -> a
-Int
startPos0)
  let act :: Int -> [GroupInfo] -> ST s ()
act Int
_this_index [] = () -> ST s ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
      act Int
this_index ((GroupInfo Int
_ Int
parent Int
start Int
stop Int
flagtag):[GroupInfo]
gs) = do
        Int
flagVal <- STUArray s Int Int
pos STUArray s Int Int -> Int -> ST s Int
forall (a :: * -> * -> *) e s i.
(MArray a e (ST s), Ix i) =>
a i e -> Int -> ST s e
!! Int
flagtag
        if (-Int
1) Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
flagVal then Int -> [GroupInfo] -> ST s ()
act Int
this_index [GroupInfo]
gs
          else do
        Int
startPos <- STUArray s Int Int
pos STUArray s Int Int -> Int -> ST s Int
forall (a :: * -> * -> *) e s i.
(MArray a e (ST s), Ix i) =>
a i e -> Int -> ST s e
!! Int
start
        Int
stopPos <- STUArray s Int Int
pos STUArray s Int Int -> Int -> ST s Int
forall (a :: * -> * -> *) e s i.
(MArray a e (ST s), Ix i) =>
a i e -> Int -> ST s e
!! Int
stop
        (Int
startParent,Int
lengthParent) <- STArray s Int (Int, Int)
ma STArray s Int (Int, Int) -> Int -> ST s (Int, Int)
forall (a :: * -> * -> *) e s i.
(MArray a e (ST s), Ix i) =>
a i e -> Int -> ST s e
!! Int
parent
        let ok :: Bool
ok = (Int
0 Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Int
startParent Bool -> Bool -> Bool
&&
                  Int
0 Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Int
lengthParent Bool -> Bool -> Bool
&&
                  Int
startParent Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Int
startPos Bool -> Bool -> Bool
&&
                  Int
stopPos Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Int
startPos Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
lengthParent)
        if Bool -> Bool
not Bool
ok then Int -> [GroupInfo] -> ST s ()
act Int
this_index [GroupInfo]
gs
          else STArray s Int (Int, Int) -> Int -> (Int, Int) -> ST s ()
forall (a :: * -> * -> *) e s i.
(MArray a e (ST s), Ix i) =>
a i e -> Int -> e -> ST s ()
set STArray s Int (Int, Int)
ma Int
this_index (Int
startPos,Int
stopPosInt -> Int -> Int
forall a. Num a => a -> a -> a
-Int
startPos)
  [Int] -> (Int -> ST s ()) -> ST s ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ ((Int, Int) -> [Int]
forall a. Ix a => (a, a) -> [a]
range (Int
1,Int
b_max)) ((Int -> ST s ()) -> ST s ()) -> (Int -> ST s ()) -> ST s ()
forall a b. (a -> b) -> a -> b
$ (\Int
i -> Int -> [GroupInfo] -> ST s ()
forall s.
(MArray (STUArray s) Int (ST s),
 MArray (STArray s) (Int, Int) (ST s)) =>
Int -> [GroupInfo] -> ST s ()
act Int
i (Array Int [GroupInfo]
aGroupsArray Int [GroupInfo] -> Int -> [GroupInfo]
forall (a :: * -> * -> *) e i.
(IArray a e, Ix i) =>
a i e -> i -> e
!Int
i))
  STArray s Int (Int, Int) -> 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 Int (Int, Int)
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 :: (Int, Int)
-> BlankScratch s -> Int -> MScratch s -> Int -> ST s Int
spawnStart (Int, Int)
b_tags (BlankScratch STUArray s Int Int
blankPos) Int
i MScratch s
s1 Int
thisPos = do
  Maybe (STUArray s Int Int)
oldPos <- MScratch s -> STArray s Int (Maybe (STUArray s Int Int))
forall s. MScratch s -> STArray s Int (Maybe (STUArray s Int Int))
m_pos MScratch s
s1 STArray s Int (Maybe (STUArray s Int Int))
-> Int -> ST s (Maybe (STUArray s Int Int))
forall (a :: * -> * -> *) e s i.
(MArray a e (ST s), Ix i) =>
a i e -> Int -> ST s e
!! Int
i
  STUArray s Int Int
pos <- case Maybe (STUArray s Int Int)
oldPos of
           Maybe (STUArray s Int Int)
Nothing -> do
             STUArray s Int Int
pos' <- (Int, Int) -> ST s (STUArray s Int Int)
forall s e.
MArray (STUArray s) e (ST s) =>
(Int, Int) -> ST s (STUArray s Int e)
newA_ (Int, Int)
b_tags
             STArray s Int (Maybe (STUArray s Int Int))
-> Int -> Maybe (STUArray s Int Int) -> ST s ()
forall (a :: * -> * -> *) e s i.
(MArray a e (ST s), Ix i) =>
a i e -> Int -> e -> ST s ()
set (MScratch s -> STArray s Int (Maybe (STUArray s Int Int))
forall s. MScratch s -> STArray s Int (Maybe (STUArray s Int Int))
m_pos MScratch s
s1) Int
i (STUArray s Int Int -> Maybe (STUArray s Int Int)
forall a. a -> Maybe a
Just STUArray s Int Int
pos')
             STUArray s Int Int -> ST s (STUArray s Int Int)
forall (m :: * -> *) a. Monad m => a -> m a
return STUArray s Int Int
pos'
           Just STUArray s Int Int
pos -> STUArray s Int Int -> ST s (STUArray s Int Int)
forall (m :: * -> *) a. Monad m => a -> m a
return STUArray s Int Int
pos
  STUArray s Int Int -> STUArray s Int Int -> 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 Int Int
blankPos STUArray s Int Int
pos
  STArray s Int OrbitLog -> Int -> OrbitLog -> ST s ()
forall (a :: * -> * -> *) e s i.
(MArray a e (ST s), Ix i) =>
a i e -> Int -> e -> ST s ()
set (MScratch s -> STArray s Int OrbitLog
forall s. MScratch s -> STArray s Int OrbitLog
m_orbit MScratch s
s1) Int
i (OrbitLog -> ST s ()) -> OrbitLog -> ST s ()
forall a b. (a -> b) -> a -> b
$! OrbitLog
forall a. Monoid a => a
mempty
  STUArray s Int Int -> Int -> Int -> ST s ()
forall (a :: * -> * -> *) e s i.
(MArray a e (ST s), Ix i) =>
a i e -> Int -> e -> ST s ()
set STUArray s Int Int
pos Int
0 Int
thisPos
  Int -> ST s Int
forall (m :: * -> *) a. Monad m => a -> m a
return Int
thisPos

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