module Text.Regex.TDFA.TDFA(patternToRegex,DFA(..),DT(..)
,examineDFA,nfaToDFA,dfaMap) where
import Data.Monoid as Mon(Monoid(..))
import Control.Monad.State(State,MonadState(..),execState)
import Data.Array.IArray(Array,(!),bounds,)
import Data.IntMap(IntMap)
import qualified Data.IntMap as IMap(empty,keys,delete,null,lookup,fromDistinctAscList
,member,unionWith,singleton,union
,toAscList,Key,elems,toList,insert
,insertWith,insertWithKey)
import Data.IntMap.CharMap2(CharMap(..))
import qualified Data.IntMap.CharMap2 as Map(empty)
import qualified Data.IntSet as ISet(empty,singleton,null)
import Data.List(foldl')
import qualified Data.Map (Map,empty,member,insert,elems)
import Data.Sequence as S((|>),)
import Text.Regex.TDFA.Common
import Text.Regex.TDFA.IntArrTrieSet(TrieSet)
import qualified Text.Regex.TDFA.IntArrTrieSet as Trie(lookupAsc,fromSinglesMerge)
import Text.Regex.TDFA.Pattern(Pattern)
import Text.Regex.TDFA.TNFA(patternToNFA)
err :: String -> a
err :: forall a. String -> a
err String
s = String -> String -> a
forall a. String -> String -> a
common_error String
"Text.Regex.TDFA.TDFA" String
s
dlose :: DFA
dlose :: DFA
dlose = DFA { d_id :: SetIndex
d_id = SetIndex
ISet.empty
, d_dt :: DT
d_dt = Simple' { dt_win :: IntMap Instructions
dt_win = IntMap Instructions
forall a. IntMap a
IMap.empty
, dt_trans :: CharMap Transition
dt_trans = CharMap Transition
forall a. CharMap a
Map.empty
, dt_other :: Transition
dt_other = DFA -> DFA -> DTrans -> Transition
Transition DFA
dlose DFA
dlose DTrans
forall a. Monoid a => a
mempty } }
{-# INLINE makeDFA #-}
makeDFA :: SetIndex -> DT -> DFA
makeDFA :: SetIndex -> DT -> DFA
makeDFA SetIndex
i DT
dt = SetIndex -> DT -> DFA
DFA SetIndex
i DT
dt
nfaToDFA :: ((Index,Array Index QNFA),Array Tag OP,Array GroupIndex [GroupInfo])
-> CompOption -> ExecOption
-> Regex
nfaToDFA :: ((Position, Array Position QNFA), Array Position OP,
Array Position [GroupInfo])
-> CompOption -> ExecOption -> Regex
nfaToDFA ((Position
startIndex,Array Position QNFA
aQNFA),Array Position OP
aTagOp,Array Position [GroupInfo]
aGroupInfo) CompOption
co ExecOption
eo = DFA
-> Position
-> (Position, Position)
-> (Position, Position)
-> TrieSet DFA
-> Array Position OP
-> Array Position [GroupInfo]
-> Bool
-> CompOption
-> ExecOption
-> Regex
Regex DFA
dfa Position
startIndex (Position, Position)
indexBounds (Position, Position)
tagBounds TrieSet DFA
trie Array Position OP
aTagOp Array Position [GroupInfo]
aGroupInfo Bool
ifa CompOption
co ExecOption
eo where
dfa :: DFA
dfa = [Position] -> DFA
indexesToDFA [Position
startIndex]
indexBounds :: (Position, Position)
indexBounds = Array Position QNFA -> (Position, Position)
forall i. Ix i => Array i QNFA -> (i, i)
forall (a :: * -> * -> *) e i.
(IArray a e, Ix i) =>
a i e -> (i, i)
bounds Array Position QNFA
aQNFA
tagBounds :: (Position, Position)
tagBounds = Array Position OP -> (Position, Position)
forall i. Ix i => Array i OP -> (i, i)
forall (a :: * -> * -> *) e i.
(IArray a e, Ix i) =>
a i e -> (i, i)
bounds Array Position OP
aTagOp
ifa :: Bool
ifa = (Bool -> Bool
not (CompOption -> Bool
multiline CompOption
co)) Bool -> Bool -> Bool
&& DFA -> Bool
isDFAFrontAnchored DFA
dfa
indexesToDFA :: [Position] -> DFA
indexesToDFA = {-# SCC "nfaToDFA.indexesToDFA" #-} TrieSet DFA -> [Position] -> DFA
forall v. TrieSet v -> [Position] -> v
Trie.lookupAsc TrieSet DFA
trie
trie :: TrieSet DFA
trie :: TrieSet DFA
trie = DFA
-> (DFA -> DFA -> DFA)
-> (Position, Position)
-> (Position -> DFA)
-> TrieSet DFA
forall v.
v
-> (v -> v -> v)
-> (Position, Position)
-> (Position -> v)
-> TrieSet v
Trie.fromSinglesMerge DFA
dlose DFA -> DFA -> DFA
mergeDFA (Array Position QNFA -> (Position, Position)
forall i. Ix i => Array i QNFA -> (i, i)
forall (a :: * -> * -> *) e i.
(IArray a e, Ix i) =>
a i e -> (i, i)
bounds Array Position QNFA
aQNFA) Position -> DFA
indexToDFA
newTransition :: DTrans -> Transition
newTransition :: DTrans -> Transition
newTransition DTrans
dtrans = Transition { trans_many :: DFA
trans_many = [Position] -> DFA
indexesToDFA (DTrans -> [Position]
forall a. IntMap a -> [Position]
IMap.keys DTrans
dtransWithSpawn)
, trans_single :: DFA
trans_single = [Position] -> DFA
indexesToDFA (DTrans -> [Position]
forall a. IntMap a -> [Position]
IMap.keys DTrans
dtrans)
, trans_how :: DTrans
trans_how = DTrans
dtransWithSpawn }
where dtransWithSpawn :: DTrans
dtransWithSpawn = DTrans -> DTrans
addSpawn DTrans
dtrans
makeTransition :: DTrans -> Transition
makeTransition :: DTrans -> Transition
makeTransition DTrans
dtrans | Bool
hasSpawn = Transition { trans_many :: DFA
trans_many = [Position] -> DFA
indexesToDFA (DTrans -> [Position]
forall a. IntMap a -> [Position]
IMap.keys DTrans
dtrans)
, trans_single :: DFA
trans_single = [Position] -> DFA
indexesToDFA (DTrans -> [Position]
forall a. IntMap a -> [Position]
IMap.keys (Position -> DTrans -> DTrans
forall a. Position -> IntMap a -> IntMap a
IMap.delete Position
startIndex DTrans
dtrans))
, trans_how :: DTrans
trans_how = DTrans
dtrans }
| Bool
otherwise = Transition { trans_many :: DFA
trans_many = [Position] -> DFA
indexesToDFA (DTrans -> [Position]
forall a. IntMap a -> [Position]
IMap.keys DTrans
dtrans)
, trans_single :: DFA
trans_single = [Position] -> DFA
indexesToDFA (DTrans -> [Position]
forall a. IntMap a -> [Position]
IMap.keys DTrans
dtrans)
, trans_how :: DTrans
trans_how = DTrans
dtrans }
where hasSpawn :: Bool
hasSpawn = Bool
-> (IntMap (DoPa, Instructions) -> Bool)
-> Maybe (IntMap (DoPa, Instructions))
-> Bool
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Bool
False IntMap (DoPa, Instructions) -> Bool
forall a. IntMap a -> Bool
IMap.null (Position -> DTrans -> Maybe (IntMap (DoPa, Instructions))
forall a. Position -> IntMap a -> Maybe a
IMap.lookup Position
startIndex DTrans
dtrans)
addSpawn :: DTrans -> DTrans
addSpawn :: DTrans -> DTrans
addSpawn DTrans
dtrans | Position -> DTrans -> Bool
forall a. Position -> IntMap a -> Bool
IMap.member Position
startIndex DTrans
dtrans = DTrans
dtrans
| Bool
otherwise = Position -> IntMap (DoPa, Instructions) -> DTrans -> DTrans
forall a. Position -> a -> IntMap a -> IntMap a
IMap.insert Position
startIndex IntMap (DoPa, Instructions)
forall a. Monoid a => a
mempty DTrans
dtrans
indexToDFA :: Index -> DFA
indexToDFA :: Position -> DFA
indexToDFA Position
i = {-# SCC "nfaToDFA.indexToDFA" #-} SetIndex -> DT -> DFA
makeDFA (Position -> SetIndex
ISet.singleton Position
source) (QT -> DT
qtToDT QT
qtIn)
where
(QNFA {q_id :: QNFA -> Position
q_id = Position
source,q_qt :: QNFA -> QT
q_qt = QT
qtIn}) = Array Position QNFA
aQNFAArray Position QNFA -> Position -> QNFA
forall (a :: * -> * -> *) e i.
(IArray a e, Ix i) =>
a i e -> i -> e
!Position
i
qtToDT :: QT -> DT
qtToDT :: QT -> DT
qtToDT (Testing {qt_test :: QT -> WhichTest
qt_test=WhichTest
wt, qt_dopas :: QT -> EnumSet DoPa
qt_dopas=EnumSet DoPa
dopas, qt_a :: QT -> QT
qt_a=QT
a, qt_b :: QT -> QT
qt_b=QT
b}) =
Testing' { dt_test :: WhichTest
dt_test = WhichTest
wt
, dt_dopas :: EnumSet DoPa
dt_dopas = EnumSet DoPa
dopas
, dt_a :: DT
dt_a = QT -> DT
qtToDT QT
a
, dt_b :: DT
dt_b = QT -> DT
qtToDT QT
b }
qtToDT (Simple {qt_win :: QT -> WinTags
qt_win=WinTags
w, qt_trans :: QT -> CharMap QTrans
qt_trans=CharMap QTrans
t, qt_other :: QT -> QTrans
qt_other=QTrans
o}) =
Simple' { dt_win :: IntMap Instructions
dt_win = IntMap Instructions
makeWinner
, dt_trans :: CharMap Transition
dt_trans = (QTrans -> Transition) -> CharMap QTrans -> CharMap Transition
forall a b. (a -> b) -> CharMap a -> CharMap b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap QTrans -> Transition
qtransToDFA CharMap QTrans
t
, dt_other :: Transition
dt_other = QTrans -> Transition
qtransToDFA QTrans
o}
where
makeWinner :: IntMap Instructions
makeWinner :: IntMap Instructions
makeWinner | WinTags -> Bool
noWin WinTags
w = IntMap Instructions
forall a. IntMap a
IMap.empty
| Bool
otherwise = Position -> Instructions -> IntMap Instructions
forall a. Position -> a -> IntMap a
IMap.singleton Position
source (WinTags -> Instructions
cleanWin WinTags
w)
qtransToDFA :: QTrans -> Transition
qtransToDFA :: QTrans -> Transition
qtransToDFA QTrans
qtrans = {-# SCC "nfaToDFA.indexToDFA.qtransToDFA" #-}
DTrans -> Transition
newTransition DTrans
dtrans
where
dtrans :: DTrans
dtrans :: DTrans
dtrans =[(Position, IntMap (DoPa, Instructions))] -> DTrans
forall a. [(Position, a)] -> IntMap a
IMap.fromDistinctAscList ([(Position, IntMap (DoPa, Instructions))] -> DTrans)
-> ([(Position, (DoPa, Instructions))]
-> [(Position, IntMap (DoPa, Instructions))])
-> [(Position, (DoPa, Instructions))]
-> DTrans
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((DoPa, Instructions) -> IntMap (DoPa, Instructions))
-> [(Position, (DoPa, Instructions))]
-> [(Position, IntMap (DoPa, Instructions))]
forall (f :: * -> *) t1 t2 t.
Functor f =>
(t1 -> t2) -> f (t, t1) -> f (t, t2)
mapSnd (Position -> (DoPa, Instructions) -> IntMap (DoPa, Instructions)
forall a. Position -> a -> IntMap a
IMap.singleton Position
source) ([(Position, (DoPa, Instructions))] -> DTrans)
-> [(Position, (DoPa, Instructions))] -> DTrans
forall a b. (a -> b) -> a -> b
$ [(Position, (DoPa, Instructions))]
best
best :: [(Index ,(DoPa,Instructions))]
best :: [(Position, (DoPa, Instructions))]
best = Array Position OP -> QTrans -> [(Position, (DoPa, Instructions))]
pickQTrans Array Position OP
aTagOp (QTrans -> [(Position, (DoPa, Instructions))])
-> QTrans -> [(Position, (DoPa, Instructions))]
forall a b. (a -> b) -> a -> b
$ QTrans
qtrans
mergeDFA :: DFA -> DFA -> DFA
mergeDFA :: DFA -> DFA -> DFA
mergeDFA DFA
d1 DFA
d2 = {-# SCC "nfaToDFA.mergeDFA" #-} SetIndex -> DT -> DFA
makeDFA SetIndex
i DT
dt
where
i :: SetIndex
i = DFA -> SetIndex
d_id DFA
d1 SetIndex -> SetIndex -> SetIndex
forall a. Monoid a => a -> a -> a
`mappend` DFA -> SetIndex
d_id DFA
d2
dt :: DT
dt = DFA -> DT
d_dt DFA
d1 DT -> DT -> DT
`mergeDT` DFA -> DT
d_dt DFA
d2
mergeDT,nestDT :: DT -> DT -> DT
mergeDT :: DT -> DT -> DT
mergeDT (Simple' IntMap Instructions
w1 CharMap Transition
t1 Transition
o1) (Simple' IntMap Instructions
w2 CharMap Transition
t2 Transition
o2) = IntMap Instructions -> CharMap Transition -> Transition -> DT
Simple' IntMap Instructions
w CharMap Transition
t Transition
o
where
w :: IntMap Instructions
w = IntMap Instructions
w1 IntMap Instructions -> IntMap Instructions -> IntMap Instructions
forall a. Monoid a => a -> a -> a
`mappend` IntMap Instructions
w2
t :: CharMap Transition
t = CharMap Transition
fuseDTrans
o :: Transition
o = Transition -> Transition -> Transition
mergeDTrans Transition
o1 Transition
o2
mergeDTrans :: Transition -> Transition -> Transition
mergeDTrans :: Transition -> Transition -> Transition
mergeDTrans (Transition {trans_how :: Transition -> DTrans
trans_how=DTrans
dt1}) (Transition {trans_how :: Transition -> DTrans
trans_how=DTrans
dt2}) = DTrans -> Transition
makeTransition DTrans
dtrans
where dtrans :: DTrans
dtrans = (IntMap (DoPa, Instructions)
-> IntMap (DoPa, Instructions) -> IntMap (DoPa, Instructions))
-> DTrans -> DTrans -> DTrans
forall a. (a -> a -> a) -> IntMap a -> IntMap a -> IntMap a
IMap.unionWith IntMap (DoPa, Instructions)
-> IntMap (DoPa, Instructions) -> IntMap (DoPa, Instructions)
forall a. IntMap a -> IntMap a -> IntMap a
IMap.union DTrans
dt1 DTrans
dt2
fuseDTrans :: CharMap Transition
fuseDTrans :: CharMap Transition
fuseDTrans = IntMap Transition -> CharMap Transition
forall a. IntMap a -> CharMap a
CharMap ([(Position, Transition)] -> IntMap Transition
forall a. [(Position, a)] -> IntMap a
IMap.fromDistinctAscList ([(Position, Transition)]
-> [(Position, Transition)] -> [(Position, Transition)]
fuse [(Position, Transition)]
l1 [(Position, Transition)]
l2))
where
l1 :: [(Position, Transition)]
l1 = IntMap Transition -> [(Position, Transition)]
forall a. IntMap a -> [(Position, a)]
IMap.toAscList (CharMap Transition -> IntMap Transition
forall a. CharMap a -> IntMap a
unCharMap CharMap Transition
t1)
l2 :: [(Position, Transition)]
l2 = IntMap Transition -> [(Position, Transition)]
forall a. IntMap a -> [(Position, a)]
IMap.toAscList (CharMap Transition -> IntMap Transition
forall a. CharMap a -> IntMap a
unCharMap CharMap Transition
t2)
fuse :: [(IMap.Key, Transition)]
-> [(IMap.Key, Transition)]
-> [(IMap.Key, Transition)]
fuse :: [(Position, Transition)]
-> [(Position, Transition)] -> [(Position, Transition)]
fuse [] [(Position, Transition)]
y = ((Position, Transition) -> (Position, Transition))
-> [(Position, Transition)] -> [(Position, Transition)]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((Transition -> Transition)
-> (Position, Transition) -> (Position, Transition)
forall a b. (a -> b) -> (Position, a) -> (Position, b)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Transition -> Transition -> Transition
mergeDTrans Transition
o1)) [(Position, Transition)]
y
fuse [(Position, Transition)]
x [] = ((Position, Transition) -> (Position, Transition))
-> [(Position, Transition)] -> [(Position, Transition)]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((Transition -> Transition)
-> (Position, Transition) -> (Position, Transition)
forall a b. (a -> b) -> (Position, a) -> (Position, b)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Transition -> Transition -> Transition
mergeDTrans Transition
o2)) [(Position, Transition)]
x
fuse x :: [(Position, Transition)]
x@((Position
xc,Transition
xa):[(Position, Transition)]
xs) y :: [(Position, Transition)]
y@((Position
yc,Transition
ya):[(Position, Transition)]
ys) =
case Position -> Position -> Ordering
forall a. Ord a => a -> a -> Ordering
compare Position
xc Position
yc of
Ordering
LT -> (Position
xc,Transition -> Transition -> Transition
mergeDTrans Transition
o2 Transition
xa) (Position, Transition)
-> [(Position, Transition)] -> [(Position, Transition)]
forall a. a -> [a] -> [a]
: [(Position, Transition)]
-> [(Position, Transition)] -> [(Position, Transition)]
fuse [(Position, Transition)]
xs [(Position, Transition)]
y
Ordering
EQ -> (Position
xc,Transition -> Transition -> Transition
mergeDTrans Transition
xa Transition
ya) (Position, Transition)
-> [(Position, Transition)] -> [(Position, Transition)]
forall a. a -> [a] -> [a]
: [(Position, Transition)]
-> [(Position, Transition)] -> [(Position, Transition)]
fuse [(Position, Transition)]
xs [(Position, Transition)]
ys
Ordering
GT -> (Position
yc,Transition -> Transition -> Transition
mergeDTrans Transition
o1 Transition
ya) (Position, Transition)
-> [(Position, Transition)] -> [(Position, Transition)]
forall a. a -> [a] -> [a]
: [(Position, Transition)]
-> [(Position, Transition)] -> [(Position, Transition)]
fuse [(Position, Transition)]
x [(Position, Transition)]
ys
mergeDT dt1 :: DT
dt1@(Testing' WhichTest
wt1 EnumSet DoPa
dopas1 DT
a1 DT
b1) dt2 :: DT
dt2@(Testing' WhichTest
wt2 EnumSet DoPa
dopas2 DT
a2 DT
b2) =
case WhichTest -> WhichTest -> Ordering
forall a. Ord a => a -> a -> Ordering
compare WhichTest
wt1 WhichTest
wt2 of
Ordering
LT -> DT -> DT -> DT
nestDT DT
dt1 DT
dt2
Ordering
EQ -> Testing' { dt_test :: WhichTest
dt_test = WhichTest
wt1
, dt_dopas :: EnumSet DoPa
dt_dopas = EnumSet DoPa
dopas1 EnumSet DoPa -> EnumSet DoPa -> EnumSet DoPa
forall a. Monoid a => a -> a -> a
`mappend` EnumSet DoPa
dopas2
, dt_a :: DT
dt_a = DT -> DT -> DT
mergeDT DT
a1 DT
a2
, dt_b :: DT
dt_b = DT -> DT -> DT
mergeDT DT
b1 DT
b2 }
Ordering
GT -> DT -> DT -> DT
nestDT DT
dt2 DT
dt1
mergeDT dt1 :: DT
dt1@(Testing' {}) DT
dt2 = DT -> DT -> DT
nestDT DT
dt1 DT
dt2
mergeDT DT
dt1 dt2 :: DT
dt2@(Testing' {}) = DT -> DT -> DT
nestDT DT
dt2 DT
dt1
nestDT :: DT -> DT -> DT
nestDT dt1 :: DT
dt1@(Testing' {dt_a :: DT -> DT
dt_a=DT
a,dt_b :: DT -> DT
dt_b=DT
b}) DT
dt2 = DT
dt1 { dt_a = mergeDT a dt2, dt_b = mergeDT b dt2 }
nestDT DT
_ DT
_ = String -> DT
forall a. String -> a
err String
"nestDT called on Simple -- cannot happen"
patternToRegex :: (Pattern,(GroupIndex, DoPa)) -> CompOption -> ExecOption -> Regex
patternToRegex :: (Pattern, (Position, DoPa)) -> CompOption -> ExecOption -> Regex
patternToRegex (Pattern, (Position, DoPa))
pattern CompOption
compOpt ExecOption
execOpt = ((Position, Array Position QNFA), Array Position OP,
Array Position [GroupInfo])
-> CompOption -> ExecOption -> Regex
nfaToDFA (CompOption
-> (Pattern, (Position, DoPa))
-> ((Position, Array Position QNFA), Array Position OP,
Array Position [GroupInfo])
patternToNFA CompOption
compOpt (Pattern, (Position, DoPa))
pattern) CompOption
compOpt ExecOption
execOpt
dfaMap :: DFA -> Data.Map.Map SetIndex DFA
dfaMap :: DFA -> Map SetIndex DFA
dfaMap = Map SetIndex DFA -> DFA -> Map SetIndex DFA
seen (Map SetIndex DFA
forall k a. Map k a
Data.Map.empty) where
seen :: Map SetIndex DFA -> DFA -> Map SetIndex DFA
seen Map SetIndex DFA
old d :: DFA
d@(DFA {d_id :: DFA -> SetIndex
d_id=SetIndex
i,d_dt :: DFA -> DT
d_dt=DT
dt}) =
if SetIndex
i SetIndex -> Map SetIndex DFA -> Bool
forall k a. Ord k => k -> Map k a -> Bool
`Data.Map.member` Map SetIndex DFA
old
then Map SetIndex DFA
old
else let new :: Map SetIndex DFA
new = SetIndex -> DFA -> Map SetIndex DFA -> Map SetIndex DFA
forall k a. Ord k => k -> a -> Map k a -> Map k a
Data.Map.insert SetIndex
i DFA
d Map SetIndex DFA
old
in (Map SetIndex DFA -> DFA -> Map SetIndex DFA)
-> Map SetIndex DFA -> [DFA] -> Map SetIndex DFA
forall b a. (b -> a -> b) -> b -> [a] -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' Map SetIndex DFA -> DFA -> Map SetIndex DFA
seen Map SetIndex DFA
new (DT -> [DFA]
flattenDT DT
dt)
flattenDT :: DT -> [DFA]
flattenDT :: DT -> [DFA]
flattenDT (Simple' {dt_trans :: DT -> CharMap Transition
dt_trans=(CharMap IntMap Transition
mt),dt_other :: DT -> Transition
dt_other=Transition
o}) = (Transition -> [DFA]) -> [Transition] -> [DFA]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (\Transition
d -> [Transition -> DFA
trans_many Transition
d ]) ([Transition] -> [DFA])
-> (IntMap Transition -> [Transition])
-> IntMap Transition
-> [DFA]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (:) Transition
o ([Transition] -> [Transition])
-> (IntMap Transition -> [Transition])
-> IntMap Transition
-> [Transition]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. IntMap Transition -> [Transition]
forall a. IntMap a -> [a]
IMap.elems (IntMap Transition -> [DFA]) -> IntMap Transition -> [DFA]
forall a b. (a -> b) -> a -> b
$ IntMap Transition
mt
flattenDT (Testing' {dt_a :: DT -> DT
dt_a=DT
a,dt_b :: DT -> DT
dt_b=DT
b}) = DT -> [DFA]
flattenDT DT
a [DFA] -> [DFA] -> [DFA]
forall a. [a] -> [a] -> [a]
++ DT -> [DFA]
flattenDT DT
b
examineDFA :: Regex -> String
examineDFA :: Regex -> String
examineDFA (Regex {regex_dfa :: Regex -> DFA
regex_dfa=DFA
dfa}) = [String] -> String
unlines ([String] -> String) -> ([DFA] -> [String]) -> [DFA] -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (:) (String
"Number of reachable DFA states: "String -> String -> String
forall a. [a] -> [a] -> [a]
++Position -> String
forall a. Show a => a -> String
show ([DFA] -> Position
forall a. [a] -> Position
forall (t :: * -> *) a. Foldable t => t a -> Position
length [DFA]
dfas)) ([String] -> [String]) -> ([DFA] -> [String]) -> [DFA] -> [String]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (DFA -> String) -> [DFA] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map DFA -> String
forall a. Show a => a -> String
show ([DFA] -> String) -> [DFA] -> String
forall a b. (a -> b) -> a -> b
$ [DFA]
dfas
where dfas :: [DFA]
dfas = Map SetIndex DFA -> [DFA]
forall k a. Map k a -> [a]
Data.Map.elems (Map SetIndex DFA -> [DFA]) -> Map SetIndex DFA -> [DFA]
forall a b. (a -> b) -> a -> b
$ DFA -> Map SetIndex DFA
dfaMap DFA
dfa
pickQTrans :: Array Tag OP -> QTrans -> [(Index,(DoPa,Instructions))]
pickQTrans :: Array Position OP -> QTrans -> [(Position, (DoPa, Instructions))]
pickQTrans Array Position OP
op QTrans
tr = ([TagCommand] -> (DoPa, Instructions))
-> [(Position, [TagCommand])] -> [(Position, (DoPa, Instructions))]
forall (f :: * -> *) t1 t2 t.
Functor f =>
(t1 -> t2) -> f (t, t1) -> f (t, t2)
mapSnd (Array Position OP -> [TagCommand] -> (DoPa, Instructions)
bestTrans Array Position OP
op) ([(Position, [TagCommand])] -> [(Position, (DoPa, Instructions))])
-> (QTrans -> [(Position, [TagCommand])])
-> QTrans
-> [(Position, (DoPa, Instructions))]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. QTrans -> [(Position, [TagCommand])]
forall a. IntMap a -> [(Position, a)]
IMap.toList (QTrans -> [(Position, (DoPa, Instructions))])
-> QTrans -> [(Position, (DoPa, Instructions))]
forall a b. (a -> b) -> a -> b
$ QTrans
tr
cleanWin :: WinTags -> Instructions
cleanWin :: WinTags -> Instructions
cleanWin = WinTags -> Instructions
toInstructions
bestTrans :: Array Tag OP -> [TagCommand] -> (DoPa,Instructions)
bestTrans :: Array Position OP -> [TagCommand] -> (DoPa, Instructions)
bestTrans Array Position OP
_ [] = String -> (DoPa, Instructions)
forall a. String -> a
err String
"bestTrans : There were no transition choose from!"
bestTrans Array Position OP
aTagOP (TagCommand
f:[TagCommand]
fs) | [TagCommand] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [TagCommand]
fs = TagCommand -> (DoPa, Instructions)
canonical TagCommand
f
| Bool
otherwise = (DoPa, Instructions)
answer
where
answer :: (DoPa, Instructions)
answer = ((DoPa, Instructions) -> TagCommand -> (DoPa, Instructions))
-> (DoPa, Instructions) -> [TagCommand] -> (DoPa, Instructions)
forall b a. (b -> a -> b) -> b -> [a] -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' (DoPa, Instructions) -> TagCommand -> (DoPa, Instructions)
pick (TagCommand -> (DoPa, Instructions)
canonical TagCommand
f) [TagCommand]
fs
canonical :: TagCommand -> (DoPa,Instructions)
canonical :: TagCommand -> (DoPa, Instructions)
canonical (DoPa
dopa,WinTags
spec) = (DoPa
dopa, WinTags -> Instructions
toInstructions WinTags
spec)
pick :: (DoPa,Instructions) -> TagCommand -> (DoPa,Instructions)
pick :: (DoPa, Instructions) -> TagCommand -> (DoPa, Instructions)
pick win :: (DoPa, Instructions)
win@(DoPa
dopa1,Instructions
winI) (DoPa
dopa2,WinTags
spec) =
let nextI :: Instructions
nextI = WinTags -> Instructions
toInstructions WinTags
spec
in case (Maybe (Position, Action) -> Maybe (Position, Action) -> Ordering)
-> [(Position, Action)] -> [(Position, Action)] -> Ordering
forall x a b c.
(Ord x, Monoid a) =>
(Maybe (x, b) -> Maybe (x, c) -> a) -> [(x, b)] -> [(x, c)] -> a
compareWith Maybe (Position, Action) -> Maybe (Position, Action) -> Ordering
choose (Instructions -> [(Position, Action)]
toListing Instructions
winI) (Instructions -> [(Position, Action)]
toListing Instructions
nextI) of
Ordering
GT -> (DoPa, Instructions)
win
Ordering
LT -> (DoPa
dopa2,Instructions
nextI)
Ordering
EQ -> if DoPa
dopa1 DoPa -> DoPa -> Bool
forall a. Ord a => a -> a -> Bool
>= DoPa
dopa2 then (DoPa, Instructions)
win else (DoPa
dopa2,Instructions
nextI)
toListing :: Instructions -> [(Tag,Action)]
toListing :: Instructions -> [(Position, Action)]
toListing (Instructions {newPos :: Instructions -> [(Position, Action)]
newPos = [(Position, Action)]
nextPos}) = ((Position, Action) -> Bool)
-> [(Position, Action)] -> [(Position, Action)]
forall a. (a -> Bool) -> [a] -> [a]
filter (Position, Action) -> Bool
forall {a}. (a, Action) -> Bool
notReset [(Position, Action)]
nextPos
where notReset :: (a, Action) -> Bool
notReset (a
_,SetVal (-1)) = Bool
False
notReset (a, Action)
_ = Bool
True
{-# INLINE choose #-}
choose :: Maybe (Tag,Action) -> Maybe (Tag,Action) -> Ordering
choose :: Maybe (Position, Action) -> Maybe (Position, Action) -> Ordering
choose Maybe (Position, Action)
Nothing Maybe (Position, Action)
Nothing = Ordering
EQ
choose Maybe (Position, Action)
Nothing Maybe (Position, Action)
x = Ordering -> Ordering
flipOrder (Maybe (Position, Action) -> Maybe (Position, Action) -> Ordering
choose Maybe (Position, Action)
x Maybe (Position, Action)
forall a. Maybe a
Nothing)
choose (Just (Position
tag,Action
_post)) Maybe (Position, Action)
Nothing =
case Array Position OP
aTagOPArray Position OP -> Position -> OP
forall (a :: * -> * -> *) e i.
(IArray a e, Ix i) =>
a i e -> i -> e
!Position
tag of
OP
Maximize -> Ordering
GT
OP
Minimize -> Ordering
LT
OP
Ignore -> Ordering
GT
OP
Orbit -> Ordering
LT
choose (Just (Position
tag,Action
post1)) (Just (Position
_,Action
post2)) =
case Array Position OP
aTagOPArray Position OP -> Position -> OP
forall (a :: * -> * -> *) e i.
(IArray a e, Ix i) =>
a i e -> i -> e
!Position
tag of
OP
Maximize -> Ordering
order
OP
Minimize -> Ordering -> Ordering
flipOrder Ordering
order
OP
Ignore -> Ordering
EQ
OP
Orbit -> Ordering
EQ
where order :: Ordering
order = case (Action
post1,Action
post2) of
(Action
SetPre,Action
SetPre) -> Ordering
EQ
(Action
SetPost,Action
SetPost) -> Ordering
EQ
(Action
SetPre,Action
SetPost) -> Ordering
LT
(Action
SetPost,Action
SetPre) -> Ordering
GT
(SetVal Position
v1,SetVal Position
v2) -> Position -> Position -> Ordering
forall a. Ord a => a -> a -> Ordering
compare Position
v1 Position
v2
(Action, Action)
_ -> String -> Ordering
forall a. String -> a
err (String -> Ordering) -> String -> Ordering
forall a b. (a -> b) -> a -> b
$ String
"bestTrans.compareWith.choose sees incomparable "String -> String -> String
forall a. [a] -> [a] -> [a]
++(Position, Action, Action) -> String
forall a. Show a => a -> String
show (Position
tag,Action
post1,Action
post2)
{-# INLINE compareWith #-}
compareWith :: (Ord x,Monoid a) => (Maybe (x,b) -> Maybe (x,c) -> a) -> [(x,b)] -> [(x,c)] -> a
compareWith :: forall x a b c.
(Ord x, Monoid a) =>
(Maybe (x, b) -> Maybe (x, c) -> a) -> [(x, b)] -> [(x, c)] -> a
compareWith Maybe (x, b) -> Maybe (x, c) -> a
comp = [(x, b)] -> [(x, c)] -> a
cw where
cw :: [(x, b)] -> [(x, c)] -> a
cw [] [] = Maybe (x, b) -> Maybe (x, c) -> a
comp Maybe (x, b)
forall a. Maybe a
Nothing Maybe (x, c)
forall a. Maybe a
Nothing
cw xx :: [(x, b)]
xx@((x, b)
x:[(x, b)]
xs) yy :: [(x, c)]
yy@((x, c)
y:[(x, c)]
ys) =
case x -> x -> Ordering
forall a. Ord a => a -> a -> Ordering
compare ((x, b) -> x
forall a b. (a, b) -> a
fst (x, b)
x) ((x, c) -> x
forall a b. (a, b) -> a
fst (x, c)
y) of
Ordering
GT -> Maybe (x, b) -> Maybe (x, c) -> a
comp Maybe (x, b)
forall a. Maybe a
Nothing ((x, c) -> Maybe (x, c)
forall a. a -> Maybe a
Just (x, c)
y) a -> a -> a
forall a. Monoid a => a -> a -> a
`mappend` [(x, b)] -> [(x, c)] -> a
cw [(x, b)]
xx [(x, c)]
ys
Ordering
EQ -> Maybe (x, b) -> Maybe (x, c) -> a
comp ((x, b) -> Maybe (x, b)
forall a. a -> Maybe a
Just (x, b)
x) ((x, c) -> Maybe (x, c)
forall a. a -> Maybe a
Just (x, c)
y) a -> a -> a
forall a. Monoid a => a -> a -> a
`mappend` [(x, b)] -> [(x, c)] -> a
cw [(x, b)]
xs [(x, c)]
ys
Ordering
LT -> Maybe (x, b) -> Maybe (x, c) -> a
comp ((x, b) -> Maybe (x, b)
forall a. a -> Maybe a
Just (x, b)
x) Maybe (x, c)
forall a. Maybe a
Nothing a -> a -> a
forall a. Monoid a => a -> a -> a
`mappend` [(x, b)] -> [(x, c)] -> a
cw [(x, b)]
xs [(x, c)]
yy
cw [(x, b)]
xx [] = ((x, b) -> a -> a) -> a -> [(x, b)] -> a
forall a b. (a -> b -> b) -> b -> [a] -> b
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (\(x, b)
x a
rest -> Maybe (x, b) -> Maybe (x, c) -> a
comp ((x, b) -> Maybe (x, b)
forall a. a -> Maybe a
Just (x, b)
x) Maybe (x, c)
forall a. Maybe a
Nothing a -> a -> a
forall a. Monoid a => a -> a -> a
`mappend` a
rest) a
forall a. Monoid a => a
mempty [(x, b)]
xx
cw [] [(x, c)]
yy = ((x, c) -> a -> a) -> a -> [(x, c)] -> a
forall a b. (a -> b -> b) -> b -> [a] -> b
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (\(x, c)
y a
rest -> Maybe (x, b) -> Maybe (x, c) -> a
comp Maybe (x, b)
forall a. Maybe a
Nothing ((x, c) -> Maybe (x, c)
forall a. a -> Maybe a
Just (x, c)
y) a -> a -> a
forall a. Monoid a => a -> a -> a
`mappend` a
rest) a
forall a. Monoid a => a
mempty [(x, c)]
yy
isDFAFrontAnchored :: DFA -> Bool
isDFAFrontAnchored :: DFA -> Bool
isDFAFrontAnchored = DT -> Bool
isDTFrontAnchored (DT -> Bool) -> (DFA -> DT) -> DFA -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. DFA -> DT
d_dt
where
isDTFrontAnchored :: DT -> Bool
isDTFrontAnchored :: DT -> Bool
isDTFrontAnchored (Simple' {}) = Bool
False
isDTFrontAnchored (Testing' {dt_test :: DT -> WhichTest
dt_test=WhichTest
wt,dt_a :: DT -> DT
dt_a=DT
a,dt_b :: DT -> DT
dt_b=DT
b}) | WhichTest
wt WhichTest -> WhichTest -> Bool
forall a. Eq a => a -> a -> Bool
== WhichTest
Test_BOL = DT -> Bool
isDTLosing DT
b
| Bool
otherwise = DT -> Bool
isDTFrontAnchored DT
a Bool -> Bool -> Bool
&& DT -> Bool
isDTFrontAnchored DT
b
where
isDTLosing :: DT -> Bool
isDTLosing :: DT -> Bool
isDTLosing (Testing' {dt_a :: DT -> DT
dt_a=DT
a',dt_b :: DT -> DT
dt_b=DT
b'}) = DT -> Bool
isDTLosing DT
a' Bool -> Bool -> Bool
&& DT -> Bool
isDTLosing DT
b'
isDTLosing (Simple' {dt_win :: DT -> IntMap Instructions
dt_win=IntMap Instructions
w}) | Bool -> Bool
not (IntMap Instructions -> Bool
forall a. IntMap a -> Bool
IMap.null IntMap Instructions
w) = Bool
False
isDTLosing (Simple' {dt_trans :: DT -> CharMap Transition
dt_trans=CharMap IntMap Transition
mt,dt_other :: DT -> Transition
dt_other=Transition
o}) =
let ts :: [Transition]
ts = Transition
o Transition -> [Transition] -> [Transition]
forall a. a -> [a] -> [a]
: IntMap Transition -> [Transition]
forall a. IntMap a -> [a]
IMap.elems IntMap Transition
mt
in (Transition -> Bool) -> [Transition] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all Transition -> Bool
transLoses [Transition]
ts
where
transLoses :: Transition -> Bool
transLoses :: Transition -> Bool
transLoses (Transition {trans_single :: Transition -> DFA
trans_single=DFA
dfa,trans_how :: Transition -> DTrans
trans_how=DTrans
dtrans}) = DFA -> Bool
isDTLose DFA
dfa Bool -> Bool -> Bool
|| DTrans -> Bool
onlySpawns DTrans
dtrans
where
isDTLose :: DFA -> Bool
isDTLose :: DFA -> Bool
isDTLose DFA
dfa' = SetIndex -> Bool
ISet.null (DFA -> SetIndex
d_id DFA
dfa')
onlySpawns :: DTrans -> Bool
onlySpawns :: DTrans -> Bool
onlySpawns DTrans
t = case DTrans -> [IntMap (DoPa, Instructions)]
forall a. IntMap a -> [a]
IMap.elems DTrans
t of
[IntMap (DoPa, Instructions)
m] -> IntMap (DoPa, Instructions) -> Bool
forall a. IntMap a -> Bool
IMap.null IntMap (DoPa, Instructions)
m
[IntMap (DoPa, Instructions)]
_ -> Bool
False
toInstructions :: TagList -> Instructions
toInstructions :: WinTags -> Instructions
toInstructions WinTags
spec =
let (IntMap Action
p,IntMap AlterOrbit
o) = State (IntMap Action, IntMap AlterOrbit) ()
-> (IntMap Action, IntMap AlterOrbit)
-> (IntMap Action, IntMap AlterOrbit)
forall s a. State s a -> s -> s
execState (WinTags -> State (IntMap Action, IntMap AlterOrbit) ()
assemble WinTags
spec) (IntMap Action
forall a. Monoid a => a
mempty,IntMap AlterOrbit
forall a. Monoid a => a
mempty)
in Instructions { newPos :: [(Position, Action)]
newPos = IntMap Action -> [(Position, Action)]
forall a. IntMap a -> [(Position, a)]
IMap.toList IntMap Action
p
, newOrbits :: Maybe (Position -> OrbitTransformer)
newOrbits = if IntMap AlterOrbit -> Bool
forall a. IntMap a -> Bool
IMap.null IntMap AlterOrbit
o then Maybe (Position -> OrbitTransformer)
forall a. Maybe a
Nothing
else (Position -> OrbitTransformer)
-> Maybe (Position -> OrbitTransformer)
forall a. a -> Maybe a
Just ((Position -> OrbitTransformer)
-> Maybe (Position -> OrbitTransformer))
-> (Position -> OrbitTransformer)
-> Maybe (Position -> OrbitTransformer)
forall a b. (a -> b) -> a -> b
$ [(Position, AlterOrbit)] -> Position -> OrbitTransformer
alterOrbits (IntMap AlterOrbit -> [(Position, AlterOrbit)]
forall a. IntMap a -> [(Position, a)]
IMap.toList IntMap AlterOrbit
o)
}
type CompileInstructions a = State
( IntMap Action
, IntMap AlterOrbit
) a
data AlterOrbit = AlterReset
| AlterLeave
| AlterModify { AlterOrbit -> Bool
newInOrbit :: Bool
, AlterOrbit -> Bool
freshOrbit :: Bool}
deriving (Position -> AlterOrbit -> String -> String
[AlterOrbit] -> String -> String
AlterOrbit -> String
(Position -> AlterOrbit -> String -> String)
-> (AlterOrbit -> String)
-> ([AlterOrbit] -> String -> String)
-> Show AlterOrbit
forall a.
(Position -> a -> String -> String)
-> (a -> String) -> ([a] -> String -> String) -> Show a
$cshowsPrec :: Position -> AlterOrbit -> String -> String
showsPrec :: Position -> AlterOrbit -> String -> String
$cshow :: AlterOrbit -> String
show :: AlterOrbit -> String
$cshowList :: [AlterOrbit] -> String -> String
showList :: [AlterOrbit] -> String -> String
Show)
assemble :: TagList -> CompileInstructions ()
assemble :: WinTags -> State (IntMap Action, IntMap AlterOrbit) ()
assemble = ((Position, TagUpdate)
-> State (IntMap Action, IntMap AlterOrbit) ())
-> WinTags -> State (IntMap Action, IntMap AlterOrbit) ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (Position, TagUpdate)
-> State (IntMap Action, IntMap AlterOrbit) ()
oneInstruction where
oneInstruction :: (Position, TagUpdate)
-> State (IntMap Action, IntMap AlterOrbit) ()
oneInstruction (Position
tag,TagUpdate
command) =
case TagUpdate
command of
PreUpdate TagTask
TagTask -> Position -> State (IntMap Action, IntMap AlterOrbit) ()
setPreTag Position
tag
PreUpdate TagTask
ResetGroupStopTask -> Position -> State (IntMap Action, IntMap AlterOrbit) ()
resetGroupTag Position
tag
PreUpdate TagTask
SetGroupStopTask -> Position -> State (IntMap Action, IntMap AlterOrbit) ()
setGroupTag Position
tag
PreUpdate TagTask
ResetOrbitTask -> Position -> State (IntMap Action, IntMap AlterOrbit) ()
resetOrbit Position
tag
PreUpdate TagTask
EnterOrbitTask -> Position -> State (IntMap Action, IntMap AlterOrbit) ()
enterOrbit Position
tag
PreUpdate TagTask
LeaveOrbitTask -> Position -> State (IntMap Action, IntMap AlterOrbit) ()
leaveOrbit Position
tag
PostUpdate TagTask
TagTask -> Position -> State (IntMap Action, IntMap AlterOrbit) ()
setPostTag Position
tag
PostUpdate TagTask
ResetGroupStopTask -> Position -> State (IntMap Action, IntMap AlterOrbit) ()
resetGroupTag Position
tag
PostUpdate TagTask
SetGroupStopTask -> Position -> State (IntMap Action, IntMap AlterOrbit) ()
setGroupTag Position
tag
TagUpdate
_ -> String -> State (IntMap Action, IntMap AlterOrbit) ()
forall a. String -> a
err (String
"assemble : Weird orbit command: "String -> String -> String
forall a. [a] -> [a] -> [a]
++(Position, TagUpdate) -> String
forall a. Show a => a -> String
show (Position
tag,TagUpdate
command))
setPreTag :: Tag -> CompileInstructions ()
setPreTag :: Position -> State (IntMap Action, IntMap AlterOrbit) ()
setPreTag = Action -> Position -> State (IntMap Action, IntMap AlterOrbit) ()
modifyPos Action
SetPre
setPostTag :: Tag -> CompileInstructions ()
setPostTag :: Position -> State (IntMap Action, IntMap AlterOrbit) ()
setPostTag = Action -> Position -> State (IntMap Action, IntMap AlterOrbit) ()
modifyPos Action
SetPost
resetGroupTag :: Tag -> CompileInstructions ()
resetGroupTag :: Position -> State (IntMap Action, IntMap AlterOrbit) ()
resetGroupTag = Action -> Position -> State (IntMap Action, IntMap AlterOrbit) ()
modifyPos (Position -> Action
SetVal (-Position
1))
setGroupTag :: Tag -> CompileInstructions ()
setGroupTag :: Position -> State (IntMap Action, IntMap AlterOrbit) ()
setGroupTag = Action -> Position -> State (IntMap Action, IntMap AlterOrbit) ()
modifyPos (Position -> Action
SetVal Position
0)
resetOrbit :: Tag -> CompileInstructions ()
resetOrbit :: Position -> State (IntMap Action, IntMap AlterOrbit) ()
resetOrbit Position
tag = Action -> Position -> State (IntMap Action, IntMap AlterOrbit) ()
modifyPos (Position -> Action
SetVal (-Position
1)) Position
tag State (IntMap Action, IntMap AlterOrbit) ()
-> State (IntMap Action, IntMap AlterOrbit) ()
-> State (IntMap Action, IntMap AlterOrbit) ()
forall a b.
StateT (IntMap Action, IntMap AlterOrbit) Identity a
-> StateT (IntMap Action, IntMap AlterOrbit) Identity b
-> StateT (IntMap Action, IntMap AlterOrbit) Identity b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> (IntMap AlterOrbit -> IntMap AlterOrbit)
-> State (IntMap Action, IntMap AlterOrbit) ()
modifyOrbit (Position -> AlterOrbit -> IntMap AlterOrbit -> IntMap AlterOrbit
forall a. Position -> a -> IntMap a -> IntMap a
IMap.insert Position
tag AlterOrbit
AlterReset)
enterOrbit :: Tag -> CompileInstructions ()
enterOrbit :: Position -> State (IntMap Action, IntMap AlterOrbit) ()
enterOrbit Position
tag = Action -> Position -> State (IntMap Action, IntMap AlterOrbit) ()
modifyPos (Position -> Action
SetVal Position
0) Position
tag State (IntMap Action, IntMap AlterOrbit) ()
-> State (IntMap Action, IntMap AlterOrbit) ()
-> State (IntMap Action, IntMap AlterOrbit) ()
forall a b.
StateT (IntMap Action, IntMap AlterOrbit) Identity a
-> StateT (IntMap Action, IntMap AlterOrbit) Identity b
-> StateT (IntMap Action, IntMap AlterOrbit) Identity b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> (IntMap AlterOrbit -> IntMap AlterOrbit)
-> State (IntMap Action, IntMap AlterOrbit) ()
modifyOrbit IntMap AlterOrbit -> IntMap AlterOrbit
changeOrbit where
changeOrbit :: IntMap AlterOrbit -> IntMap AlterOrbit
changeOrbit = (AlterOrbit -> AlterOrbit -> AlterOrbit)
-> Position -> AlterOrbit -> IntMap AlterOrbit -> IntMap AlterOrbit
forall a. (a -> a -> a) -> Position -> a -> IntMap a -> IntMap a
IMap.insertWith AlterOrbit -> AlterOrbit -> AlterOrbit
forall {p}. p -> AlterOrbit -> AlterOrbit
overwriteOrbit Position
tag AlterOrbit
appendNewOrbit
appendNewOrbit :: AlterOrbit
appendNewOrbit = AlterModify {newInOrbit :: Bool
newInOrbit = Bool
True, freshOrbit :: Bool
freshOrbit = Bool
False}
startNewOrbit :: AlterOrbit
startNewOrbit = AlterModify {newInOrbit :: Bool
newInOrbit = Bool
True, freshOrbit :: Bool
freshOrbit = Bool
True}
overwriteOrbit :: p -> AlterOrbit -> AlterOrbit
overwriteOrbit p
_ AlterOrbit
AlterReset = AlterOrbit
startNewOrbit
overwriteOrbit p
_ AlterOrbit
AlterLeave = AlterOrbit
startNewOrbit
overwriteOrbit p
_ (AlterModify {newInOrbit :: AlterOrbit -> Bool
newInOrbit = Bool
False}) = AlterOrbit
startNewOrbit
overwriteOrbit p
_ (AlterModify {newInOrbit :: AlterOrbit -> Bool
newInOrbit = Bool
True}) =
String -> AlterOrbit
forall a. String -> a
err (String -> AlterOrbit) -> String -> AlterOrbit
forall a b. (a -> b) -> a -> b
$ String
"enterOrbit: Cannot enterOrbit twice in a row: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Position -> String
forall a. Show a => a -> String
show Position
tag
leaveOrbit :: Tag -> CompileInstructions ()
leaveOrbit :: Position -> State (IntMap Action, IntMap AlterOrbit) ()
leaveOrbit Position
tag = (IntMap AlterOrbit -> IntMap AlterOrbit)
-> State (IntMap Action, IntMap AlterOrbit) ()
modifyOrbit IntMap AlterOrbit -> IntMap AlterOrbit
escapeOrbit where
escapeOrbit :: IntMap AlterOrbit -> IntMap AlterOrbit
escapeOrbit = (AlterOrbit -> AlterOrbit -> AlterOrbit)
-> Position -> AlterOrbit -> IntMap AlterOrbit -> IntMap AlterOrbit
forall a. (a -> a -> a) -> Position -> a -> IntMap a -> IntMap a
IMap.insertWith AlterOrbit -> AlterOrbit -> AlterOrbit
forall {p}. p -> AlterOrbit -> AlterOrbit
setInOrbitFalse Position
tag AlterOrbit
AlterLeave where
setInOrbitFalse :: p -> AlterOrbit -> AlterOrbit
setInOrbitFalse p
_ x :: AlterOrbit
x@(AlterModify {}) = AlterOrbit
x {newInOrbit = False}
setInOrbitFalse p
_ AlterOrbit
x = AlterOrbit
x
modifyPos :: Action -> Tag -> CompileInstructions ()
modifyPos :: Action -> Position -> State (IntMap Action, IntMap AlterOrbit) ()
modifyPos Action
todo Position
tag = do
(IntMap Action
a,IntMap AlterOrbit
c) <- StateT
(IntMap Action, IntMap AlterOrbit)
Identity
(IntMap Action, IntMap AlterOrbit)
forall s (m :: * -> *). MonadState s m => m s
get
let a' :: IntMap Action
a' = Position -> Action -> IntMap Action -> IntMap Action
forall a. Position -> a -> IntMap a -> IntMap a
IMap.insert Position
tag Action
todo IntMap Action
a
IntMap Action
-> State (IntMap Action, IntMap AlterOrbit) ()
-> State (IntMap Action, IntMap AlterOrbit) ()
forall a b. a -> b -> b
seq IntMap Action
a' (State (IntMap Action, IntMap AlterOrbit) ()
-> State (IntMap Action, IntMap AlterOrbit) ())
-> State (IntMap Action, IntMap AlterOrbit) ()
-> State (IntMap Action, IntMap AlterOrbit) ()
forall a b. (a -> b) -> a -> b
$ (IntMap Action, IntMap AlterOrbit)
-> State (IntMap Action, IntMap AlterOrbit) ()
forall s (m :: * -> *). MonadState s m => s -> m ()
put (IntMap Action
a',IntMap AlterOrbit
c)
modifyOrbit :: (IntMap AlterOrbit -> IntMap AlterOrbit) -> CompileInstructions ()
modifyOrbit :: (IntMap AlterOrbit -> IntMap AlterOrbit)
-> State (IntMap Action, IntMap AlterOrbit) ()
modifyOrbit IntMap AlterOrbit -> IntMap AlterOrbit
f = do
(IntMap Action
a,IntMap AlterOrbit
c) <- StateT
(IntMap Action, IntMap AlterOrbit)
Identity
(IntMap Action, IntMap AlterOrbit)
forall s (m :: * -> *). MonadState s m => m s
get
let c' :: IntMap AlterOrbit
c' = IntMap AlterOrbit -> IntMap AlterOrbit
f IntMap AlterOrbit
c
IntMap AlterOrbit
-> State (IntMap Action, IntMap AlterOrbit) ()
-> State (IntMap Action, IntMap AlterOrbit) ()
forall a b. a -> b -> b
seq IntMap AlterOrbit
c' (State (IntMap Action, IntMap AlterOrbit) ()
-> State (IntMap Action, IntMap AlterOrbit) ())
-> State (IntMap Action, IntMap AlterOrbit) ()
-> State (IntMap Action, IntMap AlterOrbit) ()
forall a b. (a -> b) -> a -> b
$ (IntMap Action, IntMap AlterOrbit)
-> State (IntMap Action, IntMap AlterOrbit) ()
forall s (m :: * -> *). MonadState s m => s -> m ()
put (IntMap Action
a,IntMap AlterOrbit
c')
alterOrbits :: [(Tag,AlterOrbit)] -> (Position -> OrbitTransformer)
alterOrbits :: [(Position, AlterOrbit)] -> Position -> OrbitTransformer
alterOrbits [(Position, AlterOrbit)]
x = let items :: [Position -> OrbitTransformer]
items = ((Position, AlterOrbit) -> Position -> OrbitTransformer)
-> [(Position, AlterOrbit)] -> [Position -> OrbitTransformer]
forall a b. (a -> b) -> [a] -> [b]
map (Position, AlterOrbit) -> Position -> OrbitTransformer
alterOrbit [(Position, AlterOrbit)]
x
in (\ Position
pos OrbitLog
m -> (OrbitLog -> OrbitTransformer -> OrbitLog)
-> OrbitLog -> [OrbitTransformer] -> OrbitLog
forall b a. (b -> a -> b) -> b -> [a] -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl ((OrbitTransformer -> OrbitTransformer)
-> OrbitLog -> OrbitTransformer -> OrbitLog
forall a b c. (a -> b -> c) -> b -> a -> c
flip OrbitTransformer -> OrbitTransformer
forall a b. (a -> b) -> a -> b
($)) OrbitLog
m (((Position -> OrbitTransformer) -> OrbitTransformer)
-> [Position -> OrbitTransformer] -> [OrbitTransformer]
forall a b. (a -> b) -> [a] -> [b]
map ((Position -> OrbitTransformer) -> Position -> OrbitTransformer
forall a b. (a -> b) -> a -> b
$ Position
pos) [Position -> OrbitTransformer]
items))
alterOrbit :: (Tag,AlterOrbit) -> (Position -> OrbitTransformer)
alterOrbit :: (Position, AlterOrbit) -> Position -> OrbitTransformer
alterOrbit (Position
tag,AlterModify {newInOrbit :: AlterOrbit -> Bool
newInOrbit = Bool
inOrbit',freshOrbit :: AlterOrbit -> Bool
freshOrbit = Bool
True}) =
(\ Position
pos OrbitLog
m -> Position -> Orbits -> OrbitTransformer
forall a. Position -> a -> IntMap a -> IntMap a
IMap.insert Position
tag (Orbits { inOrbit :: Bool
inOrbit = Bool
inOrbit'
, basePos :: Position
basePos = Position
pos
, ordinal :: Maybe Position
ordinal = Maybe Position
forall a. Maybe a
Nothing
, getOrbits :: Seq Position
getOrbits = Seq Position
forall a. Monoid a => a
mempty}) OrbitLog
m)
alterOrbit (Position
tag,AlterModify {newInOrbit :: AlterOrbit -> Bool
newInOrbit = Bool
inOrbit',freshOrbit :: AlterOrbit -> Bool
freshOrbit = Bool
False}) =
(\ Position
pos OrbitLog
m -> (Position -> Orbits -> Orbits -> Orbits)
-> Position -> Orbits -> OrbitTransformer
forall a.
(Position -> a -> a -> a) -> Position -> a -> IntMap a -> IntMap a
IMap.insertWithKey (Position -> Position -> Orbits -> Orbits -> Orbits
forall {p}. Position -> p -> Orbits -> Orbits -> Orbits
updateOrbit Position
pos) Position
tag (Position -> Orbits
newOrbit Position
pos) OrbitLog
m) where
newOrbit :: Position -> Orbits
newOrbit Position
pos = Orbits { inOrbit :: Bool
inOrbit = Bool
inOrbit'
, basePos :: Position
basePos = Position
pos
, ordinal :: Maybe Position
ordinal = Maybe Position
forall a. Maybe a
Nothing
, getOrbits :: Seq Position
getOrbits = Seq Position
forall a. Monoid a => a
Mon.mempty}
updateOrbit :: Position -> p -> Orbits -> Orbits -> Orbits
updateOrbit Position
pos p
_tag Orbits
new Orbits
old | Orbits -> Bool
inOrbit Orbits
old = Orbits
old { inOrbit = inOrbit'
, getOrbits = getOrbits old |> pos }
| Bool
otherwise = Orbits
new
alterOrbit (Position
tag,AlterOrbit
AlterReset) = (\ Position
_ OrbitLog
m -> Position -> OrbitTransformer
forall a. Position -> IntMap a -> IntMap a
IMap.delete Position
tag OrbitLog
m)
alterOrbit (Position
tag,AlterOrbit
AlterLeave) = (\ Position
_ OrbitLog
m -> case Position -> OrbitLog -> Maybe Orbits
forall a. Position -> IntMap a -> Maybe a
IMap.lookup Position
tag OrbitLog
m of
Maybe Orbits
Nothing -> OrbitLog
m
Just Orbits
x -> Position -> Orbits -> OrbitTransformer
forall a. Position -> a -> IntMap a -> IntMap a
IMap.insert Position
tag (Orbits
x {inOrbit=False}) OrbitLog
m)