{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE TemplateHaskell #-}
module Data.TMS.ATMS.ATMST (
ATMST,
AtmsErr(CannotRemoveNodeWIthConsequences, InternalNoEmptyEnv, FromMonadFail),
runATMST,
setInitialEnvTableAlloc, setEnvTableIncr,
getInitialEnvTableAlloc, getEnvTableIncr,
NodeDatum, contradictionNodeDatum,
ATMS, createATMS, atmsTitle,
getNodes, getJusts, getContradictions, getAssumptions,
getContradictionNode, getEmptyEnvironment, getNodeString, getJustString,
getDatumString, getInformantString, getEnqueueProcedure,
setDatumStringViaString, setDatumStringViaShow,
setInformantStringViaString, setInformantStringViaShow,
Node, nodeDatum, createNode,
nodeATMS, nodeString, defaultNodeString, getNodeLabel, getNodeRules,
getNodeConsequences,
assumeNode, makeContradiction, removeNode,
JustRule(JustRule), justInformant, justConsequence, justAntecedents,
Justification, Explanation, justifyNode,
Env, EnvTable, envIndex, envAssumptions, getEnvNodes,
isTrueNode, isInNode, isInNodeByEnv, isOutNode, isNodeConsistentWith,
getNodeIsAssumption, getNodeIsContradictory,
envIsNogood,
debugAtms, printAtms, debugAtmsEnvs,
printAtmsStatistics,
formatNode, formatNodes, debugNode, printNode,
whyNodes, whyNode,
debugEnv, debugEnvTable, formatNodeLabel,
debugNogoods,
printEnv, printNogoods, printEnvs, printEnvTable, printTable,
debugJust, printJust, formatJustification
) where
import Control.Monad.State
import Control.Monad.ST.Trans
import Control.Monad.Trans.Except
import Control.Monad.Extra
import Data.List
import Data.Symbol
import Data.TMS.Helpers
import Data.TMS.MList
import Data.TMS.Dbg
data AtmsErr = CannotRemoveNodeWIthConsequences String Int
| InternalNoEmptyEnv
| InternalNoContraNode
| UnexpectedNonruleJustification
| FromMonadFail String
deriving Int -> AtmsErr -> ShowS
[AtmsErr] -> ShowS
AtmsErr -> String
(Int -> AtmsErr -> ShowS)
-> (AtmsErr -> String) -> ([AtmsErr] -> ShowS) -> Show AtmsErr
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [AtmsErr] -> ShowS
$cshowList :: [AtmsErr] -> ShowS
show :: AtmsErr -> String
$cshow :: AtmsErr -> String
showsPrec :: Int -> AtmsErr -> ShowS
$cshowsPrec :: Int -> AtmsErr -> ShowS
Show
data AtmstState = AtmstState {
AtmstState -> Int
initialEnvTableAlloc :: Int,
AtmstState -> Int
envTableIncr :: Int
}
initialAtmstState :: AtmstState
initialAtmstState :: AtmstState
initialAtmstState = Int -> Int -> AtmstState
AtmstState Int
50 Int
75
withInitialEnvTableAlloc :: AtmstState -> Int -> AtmstState
withInitialEnvTableAlloc :: AtmstState -> Int -> AtmstState
withInitialEnvTableAlloc (AtmstState Int
_ Int
ei) Int
ia = Int -> Int -> AtmstState
AtmstState Int
ia Int
ei
withEnvTableIncr :: AtmstState -> Int -> AtmstState
withEnvTableIncr :: AtmstState -> Int -> AtmstState
withEnvTableIncr (AtmstState Int
ia Int
_) Int
ei = Int -> Int -> AtmstState
AtmstState Int
ia Int
ei
type ATMSTInner s m a =
Monad m => ExceptT AtmsErr (StateT AtmstState (STT s m)) a
newtype Monad m => ATMST s m a = AtmsT { ATMST s m a
-> Monad m => ExceptT AtmsErr (StateT AtmstState (STT s m)) a
unwrap :: ATMSTInner s m a }
unwrap2 :: Monad m => (forall s . ATMST s m a) -> (forall s . ATMSTInner s m a)
unwrap2 :: (forall s. ATMST s m a) -> forall s. ATMSTInner s m a
unwrap2 (AtmsT m) = ExceptT AtmsErr (StateT AtmstState (STT s m)) a
ATMSTInner s m a
m
instance (Monad m) => Functor (ATMST s m) where
fmap :: (a -> b) -> ATMST s m a -> ATMST s m b
fmap a -> b
f (AtmsT ATMSTInner s m a
m) = ATMSTInner s m b -> ATMST s m b
forall s (m :: * -> *) a. ATMSTInner s m a -> ATMST s m a
AtmsT (ATMSTInner s m b -> ATMST s m b)
-> ATMSTInner s m b -> ATMST s m b
forall a b. (a -> b) -> a -> b
$ do
a
v <- ExceptT AtmsErr (StateT AtmstState (STT s m)) a
ATMSTInner s m a
m
b -> ExceptT AtmsErr (StateT AtmstState (STT s m)) b
forall (m :: * -> *) a. Monad m => a -> m a
return (b -> ExceptT AtmsErr (StateT AtmstState (STT s m)) b)
-> b -> ExceptT AtmsErr (StateT AtmstState (STT s m)) b
forall a b. (a -> b) -> a -> b
$ a -> b
f a
v
instance (Monad m, Functor m) => Applicative (ATMST s m) where
pure :: a -> ATMST s m a
pure a
v = ATMSTInner s m a -> ATMST s m a
forall s (m :: * -> *) a. ATMSTInner s m a -> ATMST s m a
AtmsT (ATMSTInner s m a -> ATMST s m a)
-> ATMSTInner s m a -> ATMST s m a
forall a b. (a -> b) -> a -> b
$ a -> ExceptT AtmsErr (StateT AtmstState (STT s m)) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure a
v
(AtmsT ATMSTInner s m (a -> b)
m1) <*> :: ATMST s m (a -> b) -> ATMST s m a -> ATMST s m b
<*> (AtmsT ATMSTInner s m a
m2) = ATMSTInner s m b -> ATMST s m b
forall s (m :: * -> *) a. ATMSTInner s m a -> ATMST s m a
AtmsT (ATMSTInner s m b -> ATMST s m b)
-> ATMSTInner s m b -> ATMST s m b
forall a b. (a -> b) -> a -> b
$ do
a -> b
f <- ExceptT AtmsErr (StateT AtmstState (STT s m)) (a -> b)
ATMSTInner s m (a -> b)
m1
a
v <- ExceptT AtmsErr (StateT AtmstState (STT s m)) a
ATMSTInner s m a
m2
b -> ExceptT AtmsErr (StateT AtmstState (STT s m)) b
forall (m :: * -> *) a. Monad m => a -> m a
return (a -> b
f a
v)
instance (Monad m, Functor m) => Monad (ATMST s m) where
(AtmsT ATMSTInner s m a
m) >>= :: ATMST s m a -> (a -> ATMST s m b) -> ATMST s m b
>>= a -> ATMST s m b
f = ATMSTInner s m b -> ATMST s m b
forall s (m :: * -> *) a. ATMSTInner s m a -> ATMST s m a
AtmsT (ATMSTInner s m b -> ATMST s m b)
-> ATMSTInner s m b -> ATMST s m b
forall a b. (a -> b) -> a -> b
$ ExceptT AtmsErr (StateT AtmstState (STT s m)) a
ATMSTInner s m a
m ExceptT AtmsErr (StateT AtmstState (STT s m)) a
-> (a -> ExceptT AtmsErr (StateT AtmstState (STT s m)) b)
-> ExceptT AtmsErr (StateT AtmstState (STT s m)) b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= (ATMST s m b -> ExceptT AtmsErr (StateT AtmstState (STT s m)) b
forall s (m :: * -> *) a.
Monad m =>
ATMST s m a -> ATMSTInner s m a
unwrap (ATMST s m b -> ExceptT AtmsErr (StateT AtmstState (STT s m)) b)
-> (a -> ATMST s m b)
-> a
-> ExceptT AtmsErr (StateT AtmstState (STT s m)) b
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> ATMST s m b
f)
(AtmsT ATMSTInner s m a
m1) >> :: ATMST s m a -> ATMST s m b -> ATMST s m b
>> (AtmsT ATMSTInner s m b
m2) = ATMSTInner s m b -> ATMST s m b
forall s (m :: * -> *) a. ATMSTInner s m a -> ATMST s m a
AtmsT (ATMSTInner s m b -> ATMST s m b)
-> ATMSTInner s m b -> ATMST s m b
forall a b. (a -> b) -> a -> b
$ ExceptT AtmsErr (StateT AtmstState (STT s m)) a
ATMSTInner s m a
m1 ExceptT AtmsErr (StateT AtmstState (STT s m)) a
-> ExceptT AtmsErr (StateT AtmstState (STT s m)) b
-> ExceptT AtmsErr (StateT AtmstState (STT s m)) b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> ExceptT AtmsErr (StateT AtmstState (STT s m)) b
ATMSTInner s m b
m2
return :: a -> ATMST s m a
return a
v = ATMSTInner s m a -> ATMST s m a
forall s (m :: * -> *) a. ATMSTInner s m a -> ATMST s m a
AtmsT (ATMSTInner s m a -> ATMST s m a)
-> ATMSTInner s m a -> ATMST s m a
forall a b. (a -> b) -> a -> b
$ a -> ExceptT AtmsErr (StateT AtmstState (STT s m)) a
forall (m :: * -> *) a. Monad m => a -> m a
return a
v
instance MonadTrans (ATMST s) where
lift :: m a -> ATMST s m a
lift m a
m = ATMSTInner s m a -> ATMST s m a
forall s (m :: * -> *) a. ATMSTInner s m a -> ATMST s m a
AtmsT (ATMSTInner s m a -> ATMST s m a)
-> ATMSTInner s m a -> ATMST s m a
forall a b. (a -> b) -> a -> b
$ StateT AtmstState (STT s m) a
-> ExceptT AtmsErr (StateT AtmstState (STT s m)) a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (StateT AtmstState (STT s m) a
-> ExceptT AtmsErr (StateT AtmstState (STT s m)) a)
-> StateT AtmstState (STT s m) a
-> ExceptT AtmsErr (StateT AtmstState (STT s m)) a
forall a b. (a -> b) -> a -> b
$ STT s m a -> StateT AtmstState (STT s m) a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (STT s m a -> StateT AtmstState (STT s m) a)
-> STT s m a -> StateT AtmstState (STT s m) a
forall a b. (a -> b) -> a -> b
$ m a -> STT s m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift m a
m
instance MonadIO m => MonadIO (ATMST s m) where
liftIO :: IO a -> ATMST s m a
liftIO = m a -> ATMST s m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (m a -> ATMST s m a) -> (IO a -> m a) -> IO a -> ATMST s m a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO
sttLayer :: Monad m => STT s m r -> ATMST s m r
sttLayer :: STT s m r -> ATMST s m r
sttLayer STT s m r
md = ATMSTInner s m r -> ATMST s m r
forall s (m :: * -> *) a. ATMSTInner s m a -> ATMST s m a
AtmsT (ATMSTInner s m r -> ATMST s m r)
-> ATMSTInner s m r -> ATMST s m r
forall a b. (a -> b) -> a -> b
$ StateT AtmstState (STT s m) r
-> ExceptT AtmsErr (StateT AtmstState (STT s m)) r
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (StateT AtmstState (STT s m) r
-> ExceptT AtmsErr (StateT AtmstState (STT s m)) r)
-> StateT AtmstState (STT s m) r
-> ExceptT AtmsErr (StateT AtmstState (STT s m)) r
forall a b. (a -> b) -> a -> b
$ STT s m r -> StateT AtmstState (STT s m) r
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (STT s m r -> StateT AtmstState (STT s m) r)
-> STT s m r -> StateT AtmstState (STT s m) r
forall a b. (a -> b) -> a -> b
$ STT s m r
md
exceptLayer ::
Monad m => ExceptT AtmsErr (StateT AtmstState (STT s m)) r -> ATMST s m r
exceptLayer :: ExceptT AtmsErr (StateT AtmstState (STT s m)) r -> ATMST s m r
exceptLayer = ExceptT AtmsErr (StateT AtmstState (STT s m)) r -> ATMST s m r
forall s (m :: * -> *) a. ATMSTInner s m a -> ATMST s m a
AtmsT
stateLayer ::
Monad m => StateT AtmstState (STT s m) r -> ATMST s m r
stateLayer :: StateT AtmstState (STT s m) r -> ATMST s m r
stateLayer = ExceptT AtmsErr (StateT AtmstState (STT s m)) r -> ATMST s m r
forall s (m :: * -> *) a. ATMSTInner s m a -> ATMST s m a
AtmsT (ExceptT AtmsErr (StateT AtmstState (STT s m)) r -> ATMST s m r)
-> (StateT AtmstState (STT s m) r
-> ExceptT AtmsErr (StateT AtmstState (STT s m)) r)
-> StateT AtmstState (STT s m) r
-> ATMST s m r
forall b c a. (b -> c) -> (a -> b) -> a -> c
. StateT AtmstState (STT s m) r
-> ExceptT AtmsErr (StateT AtmstState (STT s m)) r
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift
instance Monad m => MonadFail (ATMST s m) where
fail :: String -> ATMST s m a
fail String
s = ExceptT AtmsErr (StateT AtmstState (STT s m)) a -> ATMST s m a
forall (m :: * -> *) s r.
Monad m =>
ExceptT AtmsErr (StateT AtmstState (STT s m)) r -> ATMST s m r
exceptLayer (ExceptT AtmsErr (StateT AtmstState (STT s m)) a -> ATMST s m a)
-> ExceptT AtmsErr (StateT AtmstState (STT s m)) a -> ATMST s m a
forall a b. (a -> b) -> a -> b
$ AtmsErr -> ExceptT AtmsErr (StateT AtmstState (STT s m)) a
forall (m :: * -> *) e a. Monad m => e -> ExceptT e m a
throwE (AtmsErr -> ExceptT AtmsErr (StateT AtmstState (STT s m)) a)
-> AtmsErr -> ExceptT AtmsErr (StateT AtmstState (STT s m)) a
forall a b. (a -> b) -> a -> b
$ String -> AtmsErr
FromMonadFail String
s
getInitialEnvTableAlloc :: Monad m => ATMST s m Int
getInitialEnvTableAlloc :: ATMST s m Int
getInitialEnvTableAlloc = StateT AtmstState (STT s m) Int -> ATMST s m Int
forall (m :: * -> *) s r.
Monad m =>
StateT AtmstState (STT s m) r -> ATMST s m r
stateLayer (StateT AtmstState (STT s m) Int -> ATMST s m Int)
-> StateT AtmstState (STT s m) Int -> ATMST s m Int
forall a b. (a -> b) -> a -> b
$ (AtmstState -> Int)
-> StateT AtmstState (STT s m) AtmstState
-> StateT AtmstState (STT s m) Int
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap AtmstState -> Int
initialEnvTableAlloc StateT AtmstState (STT s m) AtmstState
forall s (m :: * -> *). MonadState s m => m s
get
setInitialEnvTableAlloc :: Monad m => Int -> ATMST s m ()
setInitialEnvTableAlloc :: Int -> ATMST s m ()
setInitialEnvTableAlloc Int
ia = StateT AtmstState (STT s m) () -> ATMST s m ()
forall (m :: * -> *) s r.
Monad m =>
StateT AtmstState (STT s m) r -> ATMST s m r
stateLayer (StateT AtmstState (STT s m) () -> ATMST s m ())
-> StateT AtmstState (STT s m) () -> ATMST s m ()
forall a b. (a -> b) -> a -> b
$ (AtmstState -> AtmstState) -> StateT AtmstState (STT s m) ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify (AtmstState -> Int -> AtmstState
`withInitialEnvTableAlloc` Int
ia)
getEnvTableIncr :: Monad m => ATMST s m Int
getEnvTableIncr :: ATMST s m Int
getEnvTableIncr = StateT AtmstState (STT s m) Int -> ATMST s m Int
forall (m :: * -> *) s r.
Monad m =>
StateT AtmstState (STT s m) r -> ATMST s m r
stateLayer (StateT AtmstState (STT s m) Int -> ATMST s m Int)
-> StateT AtmstState (STT s m) Int -> ATMST s m Int
forall a b. (a -> b) -> a -> b
$ (AtmstState -> Int)
-> StateT AtmstState (STT s m) AtmstState
-> StateT AtmstState (STT s m) Int
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap AtmstState -> Int
envTableIncr StateT AtmstState (STT s m) AtmstState
forall s (m :: * -> *). MonadState s m => m s
get
setEnvTableIncr :: Monad m => Int -> ATMST s m ()
setEnvTableIncr :: Int -> ATMST s m ()
setEnvTableIncr Int
ia = StateT AtmstState (STT s m) () -> ATMST s m ()
forall (m :: * -> *) s r.
Monad m =>
StateT AtmstState (STT s m) r -> ATMST s m r
stateLayer (StateT AtmstState (STT s m) () -> ATMST s m ())
-> StateT AtmstState (STT s m) () -> ATMST s m ()
forall a b. (a -> b) -> a -> b
$ (AtmstState -> AtmstState) -> StateT AtmstState (STT s m) ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify (AtmstState -> Int -> AtmstState
`withEnvTableIncr` Int
ia)
runATMST :: Monad m => (forall s . ATMST s m r) -> m (Either AtmsErr r)
runATMST :: (forall s. ATMST s m r) -> m (Either AtmsErr r)
runATMST forall s. ATMST s m r
atmst = do
let core :: ExceptT AtmsErr (StateT AtmstState (STT s m)) r
core = (forall s. ATMST s m r) -> forall s. ATMSTInner s m r
forall (m :: * -> *) a.
Monad m =>
(forall s. ATMST s m a) -> forall s. ATMSTInner s m a
unwrap2 forall s. ATMST s m r
atmst
afterExcept :: StateT AtmstState (STT s m) (Either AtmsErr r)
afterExcept = ExceptT AtmsErr (StateT AtmstState (STT s m)) r
-> StateT AtmstState (STT s m) (Either AtmsErr r)
forall e (m :: * -> *) a. ExceptT e m a -> m (Either e a)
runExceptT ExceptT AtmsErr (StateT AtmstState (STT s m)) r
forall s. ExceptT AtmsErr (StateT AtmstState (STT s m)) r
core
afterState :: STT s m (Either AtmsErr r)
afterState = do
(Either AtmsErr r
result, AtmstState
endState) <- StateT AtmstState (STT s m) (Either AtmsErr r)
-> AtmstState -> STT s m (Either AtmsErr r, AtmstState)
forall s (m :: * -> *) a. StateT s m a -> s -> m (a, s)
runStateT StateT AtmstState (STT s m) (Either AtmsErr r)
forall s. StateT AtmstState (STT s m) (Either AtmsErr r)
afterExcept AtmstState
initialAtmstState
Either AtmsErr r -> STT s m (Either AtmsErr r)
forall (m :: * -> *) a. Monad m => a -> m a
return Either AtmsErr r
result
(forall s. STT s m (Either AtmsErr r)) -> m (Either AtmsErr r)
forall (m :: * -> *) a. Monad m => (forall s. STT s m a) -> m a
runSTT forall s. STT s m (Either AtmsErr r)
afterState
class NodeDatum d where
contradictionNodeDatum :: d
instance NodeDatum String where
contradictionNodeDatum :: String
contradictionNodeDatum = String
"The contradiction"
instance NodeDatum Symbol where
contradictionNodeDatum :: Symbol
contradictionNodeDatum = String -> Symbol
intern String
"The contradiction"
data (Monad m, NodeDatum d) => ATMS d i r s m = ATMS {
ATMS d i r s m -> String
atmsTitle :: String,
ATMS d i r s m -> STRef s Int
atmsNodeCounter :: STRef s Int,
ATMS d i r s m -> STRef s Int
atmsJustCounter :: STRef s Int,
ATMS d i r s m -> STRef s Int
atmsEnvCounter :: STRef s Int,
ATMS d i r s m -> STRef s Int
atmsEnvTableAlloc :: STRef s Int,
ATMS d i r s m -> STRef s [Node d i r s m]
atmsNodes :: STRef s [Node d i r s m],
ATMS d i r s m -> STRef s [JustRule d i r s m]
atmsJusts :: STRef s [JustRule d i r s m],
ATMS d i r s m -> STRef s [Node d i r s m]
atmsContradictions :: STRef s [Node d i r s m],
ATMS d i r s m -> STRef s [Node d i r s m]
atmsAssumptions :: STRef s [Node d i r s m],
ATMS d i r s m -> STRef s (EnvTable d i r s m)
atmsEnvTable :: STRef s (EnvTable d i r s m),
ATMS d i r s m -> STRef s (EnvTable d i r s m)
atmsNogoodTable :: STRef s (EnvTable d i r s m),
ATMS d i r s m -> STRef s (Maybe (Env d i r s m))
atmsEmptyEnv :: STRef s (Maybe (Env d i r s m)),
ATMS d i r s m -> STRef s (Maybe (Node d i r s m))
atmsContraNode :: STRef s (Maybe (Node d i r s m)),
ATMS d i r s m -> STRef s (Node d i r s m -> String)
atmsNodeString :: STRef s (Node d i r s m -> String),
ATMS d i r s m -> STRef s (JustRule d i r s m -> String)
atmsJustString :: STRef s (JustRule d i r s m -> String),
ATMS d i r s m -> STRef s (d -> String)
atmsDatumString :: STRef s (d -> String),
ATMS d i r s m -> STRef s (i -> String)
atmsInformantString :: STRef s (i -> String),
ATMS d i r s m -> STRef s (r -> ATMST s m ())
atmsEnqueueProcedure :: STRef s (r -> ATMST s m ()),
ATMS d i r s m -> STRef s Bool
atmsDebugging :: STRef s Bool
}
getATMSMutable ::
(Monad m, NodeDatum d) =>
(ATMS d i r s m -> STRef s a) -> ATMS d i r s m -> ATMST s m a
{-# INLINE getATMSMutable #-}
getATMSMutable :: (ATMS d i r s m -> STRef s a) -> ATMS d i r s m -> ATMST s m a
getATMSMutable ATMS d i r s m -> STRef s a
refGetter ATMS d i r s m
atms = STT s m a -> ATMST s m a
forall (m :: * -> *) s r. Monad m => STT s m r -> ATMST s m r
sttLayer (STT s m a -> ATMST s m a) -> STT s m a -> ATMST s m a
forall a b. (a -> b) -> a -> b
$ STRef s a -> STT s m a
forall (m :: * -> *) s a. Applicative m => STRef s a -> STT s m a
readSTRef (ATMS d i r s m -> STRef s a
refGetter ATMS d i r s m
atms)
setATMSMutable ::
(Monad m, NodeDatum d) =>
(ATMS d i r s m -> STRef s a) -> ATMS d i r s m -> a -> ATMST s m ()
{-# INLINE setATMSMutable #-}
setATMSMutable :: (ATMS d i r s m -> STRef s a)
-> ATMS d i r s m -> a -> ATMST s m ()
setATMSMutable ATMS d i r s m -> STRef s a
refGetter ATMS d i r s m
atms a
envs =
STT s m () -> ATMST s m ()
forall (m :: * -> *) s r. Monad m => STT s m r -> ATMST s m r
sttLayer (STT s m () -> ATMST s m ()) -> STT s m () -> ATMST s m ()
forall a b. (a -> b) -> a -> b
$ STRef s a -> a -> STT s m ()
forall (m :: * -> *) s a.
Applicative m =>
STRef s a -> a -> STT s m ()
writeSTRef (ATMS d i r s m -> STRef s a
refGetter ATMS d i r s m
atms) a
envs
getNodes ::
(Monad m, NodeDatum d) => ATMS d i r s m -> ATMST s m [Node d i r s m]
{-# INLINE getNodes #-}
getNodes :: ATMS d i r s m -> ATMST s m [Node d i r s m]
getNodes = (ATMS d i r s m -> STRef s [Node d i r s m])
-> ATMS d i r s m -> ATMST s m [Node d i r s m]
forall (m :: * -> *) d i r s a.
(Monad m, NodeDatum d) =>
(ATMS d i r s m -> STRef s a) -> ATMS d i r s m -> ATMST s m a
getATMSMutable ATMS d i r s m -> STRef s [Node d i r s m]
forall d i r s (m :: * -> *).
(Monad m, NodeDatum d) =>
ATMS d i r s m -> STRef s [Node d i r s m]
atmsNodes
getEnvTable ::
(Monad m, NodeDatum d) => ATMS d i r s m -> ATMST s m (EnvTable d i r s m)
{-# INLINE getEnvTable #-}
getEnvTable :: ATMS d i r s m -> ATMST s m (EnvTable d i r s m)
getEnvTable = (ATMS d i r s m -> STRef s (EnvTable d i r s m))
-> ATMS d i r s m -> ATMST s m (EnvTable d i r s m)
forall (m :: * -> *) d i r s a.
(Monad m, NodeDatum d) =>
(ATMS d i r s m -> STRef s a) -> ATMS d i r s m -> ATMST s m a
getATMSMutable ATMS d i r s m -> STRef s (EnvTable d i r s m)
forall d i r s (m :: * -> *).
(Monad m, NodeDatum d) =>
ATMS d i r s m -> STRef s (EnvTable d i r s m)
atmsEnvTable
getNogoodTable ::
(Monad m, NodeDatum d) => ATMS d i r s m -> ATMST s m (EnvTable d i r s m)
{-# INLINE getNogoodTable #-}
getNogoodTable :: ATMS d i r s m -> ATMST s m (EnvTable d i r s m)
getNogoodTable = (ATMS d i r s m -> STRef s (EnvTable d i r s m))
-> ATMS d i r s m -> ATMST s m (EnvTable d i r s m)
forall (m :: * -> *) d i r s a.
(Monad m, NodeDatum d) =>
(ATMS d i r s m -> STRef s a) -> ATMS d i r s m -> ATMST s m a
getATMSMutable ATMS d i r s m -> STRef s (EnvTable d i r s m)
forall d i r s (m :: * -> *).
(Monad m, NodeDatum d) =>
ATMS d i r s m -> STRef s (EnvTable d i r s m)
atmsNogoodTable
getJusts ::
(Monad m, NodeDatum d) => ATMS d i r s m -> ATMST s m [JustRule d i r s m]
{-# INLINE getJusts #-}
getJusts :: ATMS d i r s m -> ATMST s m [JustRule d i r s m]
getJusts = (ATMS d i r s m -> STRef s [JustRule d i r s m])
-> ATMS d i r s m -> ATMST s m [JustRule d i r s m]
forall (m :: * -> *) d i r s a.
(Monad m, NodeDatum d) =>
(ATMS d i r s m -> STRef s a) -> ATMS d i r s m -> ATMST s m a
getATMSMutable ATMS d i r s m -> STRef s [JustRule d i r s m]
forall d i r s (m :: * -> *).
(Monad m, NodeDatum d) =>
ATMS d i r s m -> STRef s [JustRule d i r s m]
atmsJusts
getContradictions ::
(Monad m, NodeDatum d) => ATMS d i r s m -> ATMST s m [Node d i r s m]
{-# INLINE getContradictions #-}
getContradictions :: ATMS d i r s m -> ATMST s m [Node d i r s m]
getContradictions = (ATMS d i r s m -> STRef s [Node d i r s m])
-> ATMS d i r s m -> ATMST s m [Node d i r s m]
forall (m :: * -> *) d i r s a.
(Monad m, NodeDatum d) =>
(ATMS d i r s m -> STRef s a) -> ATMS d i r s m -> ATMST s m a
getATMSMutable ATMS d i r s m -> STRef s [Node d i r s m]
forall d i r s (m :: * -> *).
(Monad m, NodeDatum d) =>
ATMS d i r s m -> STRef s [Node d i r s m]
atmsContradictions
getAssumptions ::
(Monad m, NodeDatum d) => ATMS d i r s m -> ATMST s m [Node d i r s m]
{-# INLINE getAssumptions #-}
getAssumptions :: ATMS d i r s m -> ATMST s m [Node d i r s m]
getAssumptions = (ATMS d i r s m -> STRef s [Node d i r s m])
-> ATMS d i r s m -> ATMST s m [Node d i r s m]
forall (m :: * -> *) d i r s a.
(Monad m, NodeDatum d) =>
(ATMS d i r s m -> STRef s a) -> ATMS d i r s m -> ATMST s m a
getATMSMutable ATMS d i r s m -> STRef s [Node d i r s m]
forall d i r s (m :: * -> *).
(Monad m, NodeDatum d) =>
ATMS d i r s m -> STRef s [Node d i r s m]
atmsAssumptions
getEmptyEnvironment ::
(Monad m, NodeDatum d) => ATMS d i r s m -> ATMST s m (Env d i r s m)
{-# INLINE getEmptyEnvironment #-}
getEmptyEnvironment :: ATMS d i r s m -> ATMST s m (Env d i r s m)
getEmptyEnvironment ATMS d i r s m
atms = do
Maybe (Env d i r s m)
maybeEnv <- (ATMS d i r s m -> STRef s (Maybe (Env d i r s m)))
-> ATMS d i r s m -> ATMST s m (Maybe (Env d i r s m))
forall (m :: * -> *) d i r s a.
(Monad m, NodeDatum d) =>
(ATMS d i r s m -> STRef s a) -> ATMS d i r s m -> ATMST s m a
getATMSMutable ATMS d i r s m -> STRef s (Maybe (Env d i r s m))
forall d i r s (m :: * -> *).
(Monad m, NodeDatum d) =>
ATMS d i r s m -> STRef s (Maybe (Env d i r s m))
atmsEmptyEnv ATMS d i r s m
atms
case Maybe (Env d i r s m)
maybeEnv of
Just Env d i r s m
env -> Env d i r s m -> ATMST s m (Env d i r s m)
forall (m :: * -> *) a. Monad m => a -> m a
return Env d i r s m
env
Maybe (Env d i r s m)
Nothing -> ExceptT AtmsErr (StateT AtmstState (STT s m)) (Env d i r s m)
-> ATMST s m (Env d i r s m)
forall (m :: * -> *) s r.
Monad m =>
ExceptT AtmsErr (StateT AtmstState (STT s m)) r -> ATMST s m r
exceptLayer (ExceptT AtmsErr (StateT AtmstState (STT s m)) (Env d i r s m)
-> ATMST s m (Env d i r s m))
-> ExceptT AtmsErr (StateT AtmstState (STT s m)) (Env d i r s m)
-> ATMST s m (Env d i r s m)
forall a b. (a -> b) -> a -> b
$ AtmsErr
-> ExceptT AtmsErr (StateT AtmstState (STT s m)) (Env d i r s m)
forall (m :: * -> *) e a. Monad m => e -> ExceptT e m a
throwE AtmsErr
InternalNoEmptyEnv
getContradictionNode ::
(Monad m, NodeDatum d) => ATMS d i r s m -> ATMST s m (Node d i r s m)
{-# INLINE getContradictionNode #-}
getContradictionNode :: ATMS d i r s m -> ATMST s m (Node d i r s m)
getContradictionNode ATMS d i r s m
atms = do
Maybe (Node d i r s m)
maybeNode <- (ATMS d i r s m -> STRef s (Maybe (Node d i r s m)))
-> ATMS d i r s m -> ATMST s m (Maybe (Node d i r s m))
forall (m :: * -> *) d i r s a.
(Monad m, NodeDatum d) =>
(ATMS d i r s m -> STRef s a) -> ATMS d i r s m -> ATMST s m a
getATMSMutable ATMS d i r s m -> STRef s (Maybe (Node d i r s m))
forall d i r s (m :: * -> *).
(Monad m, NodeDatum d) =>
ATMS d i r s m -> STRef s (Maybe (Node d i r s m))
atmsContraNode ATMS d i r s m
atms
case Maybe (Node d i r s m)
maybeNode of
Just Node d i r s m
node -> Node d i r s m -> ATMST s m (Node d i r s m)
forall (m :: * -> *) a. Monad m => a -> m a
return Node d i r s m
node
Maybe (Node d i r s m)
Nothing -> ExceptT AtmsErr (StateT AtmstState (STT s m)) (Node d i r s m)
-> ATMST s m (Node d i r s m)
forall (m :: * -> *) s r.
Monad m =>
ExceptT AtmsErr (StateT AtmstState (STT s m)) r -> ATMST s m r
exceptLayer (ExceptT AtmsErr (StateT AtmstState (STT s m)) (Node d i r s m)
-> ATMST s m (Node d i r s m))
-> ExceptT AtmsErr (StateT AtmstState (STT s m)) (Node d i r s m)
-> ATMST s m (Node d i r s m)
forall a b. (a -> b) -> a -> b
$ AtmsErr
-> ExceptT AtmsErr (StateT AtmstState (STT s m)) (Node d i r s m)
forall (m :: * -> *) e a. Monad m => e -> ExceptT e m a
throwE AtmsErr
InternalNoContraNode
getNodeString ::
(Monad m, NodeDatum d) =>
ATMS d i r s m -> ATMST s m (Node d i r s m -> String)
{-# INLINE getNodeString #-}
getNodeString :: ATMS d i r s m -> ATMST s m (Node d i r s m -> String)
getNodeString = (ATMS d i r s m -> STRef s (Node d i r s m -> String))
-> ATMS d i r s m -> ATMST s m (Node d i r s m -> String)
forall (m :: * -> *) d i r s a.
(Monad m, NodeDatum d) =>
(ATMS d i r s m -> STRef s a) -> ATMS d i r s m -> ATMST s m a
getATMSMutable ATMS d i r s m -> STRef s (Node d i r s m -> String)
forall d i r s (m :: * -> *).
(Monad m, NodeDatum d) =>
ATMS d i r s m -> STRef s (Node d i r s m -> String)
atmsNodeString
setNodeString ::
(Monad m, NodeDatum d) =>
ATMS d i r s m -> (Node d i r s m -> String) -> ATMST s m ()
{-# INLINE setNodeString #-}
setNodeString :: ATMS d i r s m -> (Node d i r s m -> String) -> ATMST s m ()
setNodeString = (ATMS d i r s m -> STRef s (Node d i r s m -> String))
-> ATMS d i r s m -> (Node d i r s m -> String) -> ATMST s m ()
forall (m :: * -> *) d i r s a.
(Monad m, NodeDatum d) =>
(ATMS d i r s m -> STRef s a)
-> ATMS d i r s m -> a -> ATMST s m ()
setATMSMutable ATMS d i r s m -> STRef s (Node d i r s m -> String)
forall d i r s (m :: * -> *).
(Monad m, NodeDatum d) =>
ATMS d i r s m -> STRef s (Node d i r s m -> String)
atmsNodeString
getJustString ::
(Monad m, NodeDatum d) =>
ATMS d i r s m -> ATMST s m (JustRule d i r s m -> String)
{-# INLINE getJustString #-}
getJustString :: ATMS d i r s m -> ATMST s m (JustRule d i r s m -> String)
getJustString = (ATMS d i r s m -> STRef s (JustRule d i r s m -> String))
-> ATMS d i r s m -> ATMST s m (JustRule d i r s m -> String)
forall (m :: * -> *) d i r s a.
(Monad m, NodeDatum d) =>
(ATMS d i r s m -> STRef s a) -> ATMS d i r s m -> ATMST s m a
getATMSMutable ATMS d i r s m -> STRef s (JustRule d i r s m -> String)
forall d i r s (m :: * -> *).
(Monad m, NodeDatum d) =>
ATMS d i r s m -> STRef s (JustRule d i r s m -> String)
atmsJustString
setJustString ::
(Monad m, NodeDatum d) =>
ATMS d i r s m -> (JustRule d i r s m -> String) -> ATMST s m ()
{-# INLINE setJustString #-}
setJustString :: ATMS d i r s m -> (JustRule d i r s m -> String) -> ATMST s m ()
setJustString = (ATMS d i r s m -> STRef s (JustRule d i r s m -> String))
-> ATMS d i r s m -> (JustRule d i r s m -> String) -> ATMST s m ()
forall (m :: * -> *) d i r s a.
(Monad m, NodeDatum d) =>
(ATMS d i r s m -> STRef s a)
-> ATMS d i r s m -> a -> ATMST s m ()
setATMSMutable ATMS d i r s m -> STRef s (JustRule d i r s m -> String)
forall d i r s (m :: * -> *).
(Monad m, NodeDatum d) =>
ATMS d i r s m -> STRef s (JustRule d i r s m -> String)
atmsJustString
getDatumString ::
(Monad m, NodeDatum d) => ATMS d i r s m -> ATMST s m (d -> String)
{-# INLINE getDatumString #-}
getDatumString :: ATMS d i r s m -> ATMST s m (d -> String)
getDatumString = (ATMS d i r s m -> STRef s (d -> String))
-> ATMS d i r s m -> ATMST s m (d -> String)
forall (m :: * -> *) d i r s a.
(Monad m, NodeDatum d) =>
(ATMS d i r s m -> STRef s a) -> ATMS d i r s m -> ATMST s m a
getATMSMutable ATMS d i r s m -> STRef s (d -> String)
forall d i r s (m :: * -> *).
(Monad m, NodeDatum d) =>
ATMS d i r s m -> STRef s (d -> String)
atmsDatumString
setDatumString ::
(Monad m, NodeDatum d) => ATMS d i r s m -> (d -> String) -> ATMST s m ()
{-# INLINE setDatumString #-}
setDatumString :: ATMS d i r s m -> (d -> String) -> ATMST s m ()
setDatumString = (ATMS d i r s m -> STRef s (d -> String))
-> ATMS d i r s m -> (d -> String) -> ATMST s m ()
forall (m :: * -> *) d i r s a.
(Monad m, NodeDatum d) =>
(ATMS d i r s m -> STRef s a)
-> ATMS d i r s m -> a -> ATMST s m ()
setATMSMutable ATMS d i r s m -> STRef s (d -> String)
forall d i r s (m :: * -> *).
(Monad m, NodeDatum d) =>
ATMS d i r s m -> STRef s (d -> String)
atmsDatumString
setDatumStringViaString :: Monad m => ATMS String i r s m -> ATMST s m ()
setDatumStringViaString :: ATMS String i r s m -> ATMST s m ()
setDatumStringViaString ATMS String i r s m
atms = ATMS String i r s m -> ShowS -> ATMST s m ()
forall (m :: * -> *) d i r s.
(Monad m, NodeDatum d) =>
ATMS d i r s m -> (d -> String) -> ATMST s m ()
setDatumString ATMS String i r s m
atms ShowS
forall a. a -> a
id
setDatumStringViaShow ::
(NodeDatum d, Show d, Monad m) => ATMS d i r s m -> ATMST s m ()
setDatumStringViaShow :: ATMS d i r s m -> ATMST s m ()
setDatumStringViaShow ATMS d i r s m
atms = ATMS d i r s m -> (d -> String) -> ATMST s m ()
forall (m :: * -> *) d i r s.
(Monad m, NodeDatum d) =>
ATMS d i r s m -> (d -> String) -> ATMST s m ()
setDatumString ATMS d i r s m
atms d -> String
forall a. Show a => a -> String
show
getInformantString ::
(Monad m, NodeDatum d) => ATMS d i r s m -> ATMST s m (i -> String)
{-# INLINE getInformantString #-}
getInformantString :: ATMS d i r s m -> ATMST s m (i -> String)
getInformantString = (ATMS d i r s m -> STRef s (i -> String))
-> ATMS d i r s m -> ATMST s m (i -> String)
forall (m :: * -> *) d i r s a.
(Monad m, NodeDatum d) =>
(ATMS d i r s m -> STRef s a) -> ATMS d i r s m -> ATMST s m a
getATMSMutable ATMS d i r s m -> STRef s (i -> String)
forall d i r s (m :: * -> *).
(Monad m, NodeDatum d) =>
ATMS d i r s m -> STRef s (i -> String)
atmsInformantString
setInformantString ::
(Monad m, NodeDatum d) => ATMS d i r s m -> (i -> String) -> ATMST s m ()
{-# INLINE setInformantString #-}
setInformantString :: ATMS d i r s m -> (i -> String) -> ATMST s m ()
setInformantString = (ATMS d i r s m -> STRef s (i -> String))
-> ATMS d i r s m -> (i -> String) -> ATMST s m ()
forall (m :: * -> *) d i r s a.
(Monad m, NodeDatum d) =>
(ATMS d i r s m -> STRef s a)
-> ATMS d i r s m -> a -> ATMST s m ()
setATMSMutable ATMS d i r s m -> STRef s (i -> String)
forall d i r s (m :: * -> *).
(Monad m, NodeDatum d) =>
ATMS d i r s m -> STRef s (i -> String)
atmsInformantString
setInformantStringViaString ::
(Monad m, NodeDatum d) => ATMS d String r s m -> ATMST s m ()
setInformantStringViaString :: ATMS d String r s m -> ATMST s m ()
setInformantStringViaString ATMS d String r s m
atms = ATMS d String r s m -> ShowS -> ATMST s m ()
forall (m :: * -> *) d i r s.
(Monad m, NodeDatum d) =>
ATMS d i r s m -> (i -> String) -> ATMST s m ()
setInformantString ATMS d String r s m
atms ShowS
forall a. a -> a
id
setInformantStringViaShow ::
(Show i, Monad m, NodeDatum d) => ATMS d i r s m -> ATMST s m ()
setInformantStringViaShow :: ATMS d i r s m -> ATMST s m ()
setInformantStringViaShow ATMS d i r s m
atms = ATMS d i r s m -> (i -> String) -> ATMST s m ()
forall (m :: * -> *) d i r s.
(Monad m, NodeDatum d) =>
ATMS d i r s m -> (i -> String) -> ATMST s m ()
setInformantString ATMS d i r s m
atms i -> String
forall a. Show a => a -> String
show
getEnqueueProcedure ::
(Monad m, NodeDatum d) =>
ATMS d i r s m -> ATMST s m (r -> ATMST s m ())
{-# INLINE getEnqueueProcedure #-}
getEnqueueProcedure :: ATMS d i r s m -> ATMST s m (r -> ATMST s m ())
getEnqueueProcedure = (ATMS d i r s m -> STRef s (r -> ATMST s m ()))
-> ATMS d i r s m -> ATMST s m (r -> ATMST s m ())
forall (m :: * -> *) d i r s a.
(Monad m, NodeDatum d) =>
(ATMS d i r s m -> STRef s a) -> ATMS d i r s m -> ATMST s m a
getATMSMutable ATMS d i r s m -> STRef s (r -> ATMST s m ())
forall d i r s (m :: * -> *).
(Monad m, NodeDatum d) =>
ATMS d i r s m -> STRef s (r -> ATMST s m ())
atmsEnqueueProcedure
setEnqueueProcedure ::
(Monad m, NodeDatum d) =>
ATMS d i r s m -> (r -> ATMST s m ()) -> ATMST s m ()
{-# INLINE setEnqueueProcedure #-}
setEnqueueProcedure :: ATMS d i r s m -> (r -> ATMST s m ()) -> ATMST s m ()
setEnqueueProcedure = (ATMS d i r s m -> STRef s (r -> ATMST s m ()))
-> ATMS d i r s m -> (r -> ATMST s m ()) -> ATMST s m ()
forall (m :: * -> *) d i r s a.
(Monad m, NodeDatum d) =>
(ATMS d i r s m -> STRef s a)
-> ATMS d i r s m -> a -> ATMST s m ()
setATMSMutable ATMS d i r s m -> STRef s (r -> ATMST s m ())
forall d i r s (m :: * -> *).
(Monad m, NodeDatum d) =>
ATMS d i r s m -> STRef s (r -> ATMST s m ())
atmsEnqueueProcedure
printAtms :: (MonadIO m, NodeDatum d) => ATMS d i r s m -> ATMST s m ()
printAtms :: ATMS d i r s m -> ATMST s m ()
printAtms ATMS d i r s m
atms = IO () -> ATMST s m ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> ATMST s m ()) -> IO () -> ATMST s m ()
forall a b. (a -> b) -> a -> b
$ String -> IO ()
putStrLn (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String
"#<ATMS: " String -> ShowS
forall a. [a] -> [a] -> [a]
++ ATMS d i r s m -> String
forall d i r s (m :: * -> *).
(Monad m, NodeDatum d) =>
ATMS d i r s m -> String
atmsTitle ATMS d i r s m
atms String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
">"
nextNodeCounter :: (Monad m, NodeDatum d) => ATMS d i r s m -> ATMST s m Int
nextNodeCounter :: ATMS d i r s m -> ATMST s m Int
nextNodeCounter ATMS d i r s m
jtms = STT s m Int -> ATMST s m Int
forall (m :: * -> *) s r. Monad m => STT s m r -> ATMST s m r
sttLayer (STT s m Int -> ATMST s m Int) -> STT s m Int -> ATMST s m Int
forall a b. (a -> b) -> a -> b
$ do
let nodeCounter :: STRef s Int
nodeCounter = ATMS d i r s m -> STRef s Int
forall d i r s (m :: * -> *).
(Monad m, NodeDatum d) =>
ATMS d i r s m -> STRef s Int
atmsNodeCounter ATMS d i r s m
jtms
Int
nodeId <- STRef s Int -> STT s m Int
forall (m :: * -> *) s a. Applicative m => STRef s a -> STT s m a
readSTRef STRef s Int
nodeCounter
STRef s Int -> Int -> STT s m ()
forall (m :: * -> *) s a.
Applicative m =>
STRef s a -> a -> STT s m ()
writeSTRef STRef s Int
nodeCounter (Int -> STT s m ()) -> Int -> STT s m ()
forall a b. (a -> b) -> a -> b
$ Int
1 Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
nodeId
Int -> STT s m Int
forall (m :: * -> *) a. Monad m => a -> m a
return Int
nodeId
nextJustCounter :: (Monad m, NodeDatum d) => ATMS d i r s m -> ATMST s m Int
nextJustCounter :: ATMS d i r s m -> ATMST s m Int
nextJustCounter ATMS d i r s m
atms = STT s m Int -> ATMST s m Int
forall (m :: * -> *) s r. Monad m => STT s m r -> ATMST s m r
sttLayer (STT s m Int -> ATMST s m Int) -> STT s m Int -> ATMST s m Int
forall a b. (a -> b) -> a -> b
$ do
let justCounter :: STRef s Int
justCounter = ATMS d i r s m -> STRef s Int
forall d i r s (m :: * -> *).
(Monad m, NodeDatum d) =>
ATMS d i r s m -> STRef s Int
atmsJustCounter ATMS d i r s m
atms
Int
justId <- STRef s Int -> STT s m Int
forall (m :: * -> *) s a. Applicative m => STRef s a -> STT s m a
readSTRef STRef s Int
justCounter
STRef s Int -> Int -> STT s m ()
forall (m :: * -> *) s a.
Applicative m =>
STRef s a -> a -> STT s m ()
writeSTRef STRef s Int
justCounter (Int -> STT s m ()) -> Int -> STT s m ()
forall a b. (a -> b) -> a -> b
$ Int
1 Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
justId
Int -> STT s m Int
forall (m :: * -> *) a. Monad m => a -> m a
return Int
justId
nextEnvCounter :: (Monad m, NodeDatum d) => ATMS d i r s m -> ATMST s m Int
nextEnvCounter :: ATMS d i r s m -> ATMST s m Int
nextEnvCounter ATMS d i r s m
atms = STT s m Int -> ATMST s m Int
forall (m :: * -> *) s r. Monad m => STT s m r -> ATMST s m r
sttLayer (STT s m Int -> ATMST s m Int) -> STT s m Int -> ATMST s m Int
forall a b. (a -> b) -> a -> b
$ do
let envCounter :: STRef s Int
envCounter = ATMS d i r s m -> STRef s Int
forall d i r s (m :: * -> *).
(Monad m, NodeDatum d) =>
ATMS d i r s m -> STRef s Int
atmsEnvCounter ATMS d i r s m
atms
Int
envId <- STRef s Int -> STT s m Int
forall (m :: * -> *) s a. Applicative m => STRef s a -> STT s m a
readSTRef STRef s Int
envCounter
STRef s Int -> Int -> STT s m ()
forall (m :: * -> *) s a.
Applicative m =>
STRef s a -> a -> STT s m ()
writeSTRef STRef s Int
envCounter (Int -> STT s m ()) -> Int -> STT s m ()
forall a b. (a -> b) -> a -> b
$ Int
1 Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
envId
Int -> STT s m Int
forall (m :: * -> *) a. Monad m => a -> m a
return Int
envId
data (Monad m, NodeDatum d) => Node d i r s m = Node {
Node d i r s m -> Int
nodeIndex :: Int,
Node d i r s m -> d
nodeDatum :: d,
Node d i r s m -> STRef s [Env d i r s m]
nodeLabel :: STRef s [Env d i r s m],
Node d i r s m -> STRef s [Justification d i r s m]
nodeJusts :: STRef s [Justification d i r s m],
Node d i r s m -> STRef s [JustRule d i r s m]
nodeConsequences :: STRef s [JustRule d i r s m],
Node d i r s m -> STRef s Bool
nodeIsContradictory :: STRef s Bool,
Node d i r s m -> STRef s Bool
nodeIsAssumption :: STRef s Bool,
Node d i r s m -> STRef s [r]
nodeRules :: STRef s [r],
Node d i r s m -> ATMS d i r s m
nodeATMS :: ATMS d i r s m
}
instance (Monad m, NodeDatum d) => Eq (Node d i r s m) where
Node d i r s m
n1 == :: Node d i r s m -> Node d i r s m -> Bool
== Node d i r s m
n2 = Node d i r s m -> Int
forall d i r s (m :: * -> *).
(Monad m, NodeDatum d) =>
Node d i r s m -> Int
nodeIndex Node d i r s m
n1 Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Node d i r s m -> Int
forall d i r s (m :: * -> *).
(Monad m, NodeDatum d) =>
Node d i r s m -> Int
nodeIndex Node d i r s m
n2
instance (Monad m, NodeDatum d) => Ord (Node d i r s m) where
Node d i r s m
n1 < :: Node d i r s m -> Node d i r s m -> Bool
< Node d i r s m
n2 = Node d i r s m -> Int
forall d i r s (m :: * -> *).
(Monad m, NodeDatum d) =>
Node d i r s m -> Int
nodeIndex Node d i r s m
n1 Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Node d i r s m -> Int
forall d i r s (m :: * -> *).
(Monad m, NodeDatum d) =>
Node d i r s m -> Int
nodeIndex Node d i r s m
n2
Node d i r s m
n1 compare :: Node d i r s m -> Node d i r s m -> Ordering
`compare` Node d i r s m
n2 = Node d i r s m -> Int
forall d i r s (m :: * -> *).
(Monad m, NodeDatum d) =>
Node d i r s m -> Int
nodeIndex Node d i r s m
n1 Int -> Int -> Ordering
forall a. Ord a => a -> a -> Ordering
`compare` Node d i r s m -> Int
forall d i r s (m :: * -> *).
(Monad m, NodeDatum d) =>
Node d i r s m -> Int
nodeIndex Node d i r s m
n2
instance (Monad m, NodeDatum d) => Show (Node d i r s m) where
show :: Node d i r s m -> String
show Node d i r s m
n = String
"<Node " String -> ShowS
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show (Node d i r s m -> Int
forall d i r s (m :: * -> *).
(Monad m, NodeDatum d) =>
Node d i r s m -> Int
nodeIndex Node d i r s m
n) String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
">"
getNodeMutable ::
(Monad m, NodeDatum d) =>
(Node d i r s m -> STRef s a) -> Node d i r s m -> ATMST s m a
{-# INLINE getNodeMutable #-}
getNodeMutable :: (Node d i r s m -> STRef s a) -> Node d i r s m -> ATMST s m a
getNodeMutable Node d i r s m -> STRef s a
refGetter Node d i r s m
node = STT s m a -> ATMST s m a
forall (m :: * -> *) s r. Monad m => STT s m r -> ATMST s m r
sttLayer (STT s m a -> ATMST s m a) -> STT s m a -> ATMST s m a
forall a b. (a -> b) -> a -> b
$ STRef s a -> STT s m a
forall (m :: * -> *) s a. Applicative m => STRef s a -> STT s m a
readSTRef (Node d i r s m -> STRef s a
refGetter Node d i r s m
node)
setNodeMutable ::
(Monad m, NodeDatum d) =>
(Node d i r s m -> STRef s a) -> Node d i r s m -> a -> ATMST s m ()
{-# INLINE setNodeMutable #-}
setNodeMutable :: (Node d i r s m -> STRef s a)
-> Node d i r s m -> a -> ATMST s m ()
setNodeMutable Node d i r s m -> STRef s a
refGetter Node d i r s m
node a
val = STT s m () -> ATMST s m ()
forall (m :: * -> *) s r. Monad m => STT s m r -> ATMST s m r
sttLayer (STT s m () -> ATMST s m ()) -> STT s m () -> ATMST s m ()
forall a b. (a -> b) -> a -> b
$ STRef s a -> a -> STT s m ()
forall (m :: * -> *) s a.
Applicative m =>
STRef s a -> a -> STT s m ()
writeSTRef (Node d i r s m -> STRef s a
refGetter Node d i r s m
node) a
val
getNodeLabel ::
(Monad m, NodeDatum d) => Node d i r s m -> ATMST s m [Env d i r s m]
{-# INLINE getNodeLabel #-}
getNodeLabel :: Node d i r s m -> ATMST s m [Env d i r s m]
getNodeLabel = (Node d i r s m -> STRef s [Env d i r s m])
-> Node d i r s m -> ATMST s m [Env d i r s m]
forall (m :: * -> *) d i r s a.
(Monad m, NodeDatum d) =>
(Node d i r s m -> STRef s a) -> Node d i r s m -> ATMST s m a
getNodeMutable Node d i r s m -> STRef s [Env d i r s m]
forall d i r s (m :: * -> *).
(Monad m, NodeDatum d) =>
Node d i r s m -> STRef s [Env d i r s m]
nodeLabel
setNodeLabel ::
(Monad m, NodeDatum d) => Node d i r s m -> [Env d i r s m] -> ATMST s m ()
{-# INLINE setNodeLabel #-}
setNodeLabel :: Node d i r s m -> [Env d i r s m] -> ATMST s m ()
setNodeLabel = (Node d i r s m -> STRef s [Env d i r s m])
-> Node d i r s m -> [Env d i r s m] -> ATMST s m ()
forall (m :: * -> *) d i r s a.
(Monad m, NodeDatum d) =>
(Node d i r s m -> STRef s a)
-> Node d i r s m -> a -> ATMST s m ()
setNodeMutable Node d i r s m -> STRef s [Env d i r s m]
forall d i r s (m :: * -> *).
(Monad m, NodeDatum d) =>
Node d i r s m -> STRef s [Env d i r s m]
nodeLabel
getNodeRules :: (Monad m, NodeDatum d) => Node d i r s m -> ATMST s m [r]
{-# INLINE getNodeRules #-}
getNodeRules :: Node d i r s m -> ATMST s m [r]
getNodeRules = (Node d i r s m -> STRef s [r]) -> Node d i r s m -> ATMST s m [r]
forall (m :: * -> *) d i r s a.
(Monad m, NodeDatum d) =>
(Node d i r s m -> STRef s a) -> Node d i r s m -> ATMST s m a
getNodeMutable Node d i r s m -> STRef s [r]
forall d i r s (m :: * -> *).
(Monad m, NodeDatum d) =>
Node d i r s m -> STRef s [r]
nodeRules
setNodeRules :: (Monad m, NodeDatum d) => Node d i r s m -> [r] -> ATMST s m ()
{-# INLINE setNodeRules #-}
setNodeRules :: Node d i r s m -> [r] -> ATMST s m ()
setNodeRules = (Node d i r s m -> STRef s [r])
-> Node d i r s m -> [r] -> ATMST s m ()
forall (m :: * -> *) d i r s a.
(Monad m, NodeDatum d) =>
(Node d i r s m -> STRef s a)
-> Node d i r s m -> a -> ATMST s m ()
setNodeMutable Node d i r s m -> STRef s [r]
forall d i r s (m :: * -> *).
(Monad m, NodeDatum d) =>
Node d i r s m -> STRef s [r]
nodeRules
getNodeJusts ::
(Monad m, NodeDatum d) =>
Node d i r s m -> ATMST s m [Justification d i r s m]
{-# INLINE getNodeJusts #-}
getNodeJusts :: Node d i r s m -> ATMST s m [Justification d i r s m]
getNodeJusts = (Node d i r s m -> STRef s [Justification d i r s m])
-> Node d i r s m -> ATMST s m [Justification d i r s m]
forall (m :: * -> *) d i r s a.
(Monad m, NodeDatum d) =>
(Node d i r s m -> STRef s a) -> Node d i r s m -> ATMST s m a
getNodeMutable Node d i r s m -> STRef s [Justification d i r s m]
forall d i r s (m :: * -> *).
(Monad m, NodeDatum d) =>
Node d i r s m -> STRef s [Justification d i r s m]
nodeJusts
getNodeConsequences ::
(Monad m, NodeDatum d) => Node d i r s m -> ATMST s m [JustRule d i r s m]
{-# INLINE getNodeConsequences #-}
getNodeConsequences :: Node d i r s m -> ATMST s m [JustRule d i r s m]
getNodeConsequences = (Node d i r s m -> STRef s [JustRule d i r s m])
-> Node d i r s m -> ATMST s m [JustRule d i r s m]
forall (m :: * -> *) d i r s a.
(Monad m, NodeDatum d) =>
(Node d i r s m -> STRef s a) -> Node d i r s m -> ATMST s m a
getNodeMutable Node d i r s m -> STRef s [JustRule d i r s m]
forall d i r s (m :: * -> *).
(Monad m, NodeDatum d) =>
Node d i r s m -> STRef s [JustRule d i r s m]
nodeConsequences
setNodeConsequences ::
(Monad m, NodeDatum d) =>
Node d i r s m -> [JustRule d i r s m] -> ATMST s m ()
{-# INLINE setNodeConsequences #-}
setNodeConsequences :: Node d i r s m -> [JustRule d i r s m] -> ATMST s m ()
setNodeConsequences = (Node d i r s m -> STRef s [JustRule d i r s m])
-> Node d i r s m -> [JustRule d i r s m] -> ATMST s m ()
forall (m :: * -> *) d i r s a.
(Monad m, NodeDatum d) =>
(Node d i r s m -> STRef s a)
-> Node d i r s m -> a -> ATMST s m ()
setNodeMutable Node d i r s m -> STRef s [JustRule d i r s m]
forall d i r s (m :: * -> *).
(Monad m, NodeDatum d) =>
Node d i r s m -> STRef s [JustRule d i r s m]
nodeConsequences
getNodeIsContradictory ::
(Monad m, NodeDatum d) => Node d i r s m -> ATMST s m Bool
getNodeIsContradictory :: Node d i r s m -> ATMST s m Bool
getNodeIsContradictory Node d i r s m
node = STT s m Bool -> ATMST s m Bool
forall (m :: * -> *) s r. Monad m => STT s m r -> ATMST s m r
sttLayer (STT s m Bool -> ATMST s m Bool) -> STT s m Bool -> ATMST s m Bool
forall a b. (a -> b) -> a -> b
$ STRef s Bool -> STT s m Bool
forall (m :: * -> *) s a. Applicative m => STRef s a -> STT s m a
readSTRef (Node d i r s m -> STRef s Bool
forall d i r s (m :: * -> *).
(Monad m, NodeDatum d) =>
Node d i r s m -> STRef s Bool
nodeIsContradictory Node d i r s m
node)
setNodeIsContradictory ::
(Monad m, NodeDatum d) => Node d i r s m -> ATMST s m ()
setNodeIsContradictory :: Node d i r s m -> ATMST s m ()
setNodeIsContradictory Node d i r s m
node =
STT s m () -> ATMST s m ()
forall (m :: * -> *) s r. Monad m => STT s m r -> ATMST s m r
sttLayer (STT s m () -> ATMST s m ()) -> STT s m () -> ATMST s m ()
forall a b. (a -> b) -> a -> b
$ STRef s Bool -> Bool -> STT s m ()
forall (m :: * -> *) s a.
Applicative m =>
STRef s a -> a -> STT s m ()
writeSTRef (Node d i r s m -> STRef s Bool
forall d i r s (m :: * -> *).
(Monad m, NodeDatum d) =>
Node d i r s m -> STRef s Bool
nodeIsContradictory Node d i r s m
node) Bool
True
getNodeIsAssumption ::
(Monad m, NodeDatum d) => Node d i r s m -> ATMST s m Bool
getNodeIsAssumption :: Node d i r s m -> ATMST s m Bool
getNodeIsAssumption Node d i r s m
node = STT s m Bool -> ATMST s m Bool
forall (m :: * -> *) s r. Monad m => STT s m r -> ATMST s m r
sttLayer (STT s m Bool -> ATMST s m Bool) -> STT s m Bool -> ATMST s m Bool
forall a b. (a -> b) -> a -> b
$ STRef s Bool -> STT s m Bool
forall (m :: * -> *) s a. Applicative m => STRef s a -> STT s m a
readSTRef (Node d i r s m -> STRef s Bool
forall d i r s (m :: * -> *).
(Monad m, NodeDatum d) =>
Node d i r s m -> STRef s Bool
nodeIsAssumption Node d i r s m
node)
data (Monad m, NodeDatum d) => JustRule d i r s m = JustRule {
JustRule d i r s m -> Int
justIndex :: Int,
JustRule d i r s m -> i
justInformant :: i,
JustRule d i r s m -> Node d i r s m
justConsequence :: Node d i r s m,
JustRule d i r s m -> [Node d i r s m]
justAntecedents :: [Node d i r s m]
}
instance (Monad m, NodeDatum d) => Eq (JustRule d i r s m) where
JustRule d i r s m
e1 == :: JustRule d i r s m -> JustRule d i r s m -> Bool
== JustRule d i r s m
e2 = (JustRule d i r s m -> Int
forall d i r s (m :: * -> *).
(Monad m, NodeDatum d) =>
JustRule d i r s m -> Int
justIndex JustRule d i r s m
e1) Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== (JustRule d i r s m -> Int
forall d i r s (m :: * -> *).
(Monad m, NodeDatum d) =>
JustRule d i r s m -> Int
justIndex JustRule d i r s m
e2)
data Justification d i r s m =
ByRule (JustRule d i r s m) | ByAssumption (Node d i r s m) | ByContradiction
data Explanation d i r s m =
IsRule (JustRule d i r s m) | IsAssumption (Node d i r s m)
data WhyNogood d i r s m =
Good | ByJustification (Justification d i r s m) | ByEnv (Env d i r s m)
isNogood :: WhyNogood d i r s m -> Bool
isNogood :: WhyNogood d i r s m -> Bool
isNogood WhyNogood d i r s m
Good = Bool
False
isNogood WhyNogood d i r s m
_ = Bool
True
data (Monad m, NodeDatum d) => Env d i r s m = Env {
Env d i r s m -> Int
envIndex :: Int,
Env d i r s m -> Int
envCount :: Int,
Env d i r s m -> [Node d i r s m]
envAssumptions :: [Node d i r s m],
Env d i r s m -> STRef s [Node d i r s m]
envNodes :: STRef s [Node d i r s m],
Env d i r s m -> STRef s (WhyNogood d i r s m)
envWhyNogood :: STRef s (WhyNogood d i r s m),
Env d i r s m -> STRef s [r]
envRules :: STRef s [r]
}
instance (Monad m, NodeDatum d) => Eq (Env d i r s m) where
Env d i r s m
e1 == :: Env d i r s m -> Env d i r s m -> Bool
== Env d i r s m
e2 = (Env d i r s m -> Int
forall d i r s (m :: * -> *).
(Monad m, NodeDatum d) =>
Env d i r s m -> Int
envIndex Env d i r s m
e1) Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== (Env d i r s m -> Int
forall d i r s (m :: * -> *).
(Monad m, NodeDatum d) =>
Env d i r s m -> Int
envIndex Env d i r s m
e2)
instance (Monad m, NodeDatum d) => Show (Env d i r s m) where
show :: Env d i r s m -> String
show Env d i r s m
n = String
"<Env " String -> ShowS
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show (Env d i r s m -> Int
forall d i r s (m :: * -> *).
(Monad m, NodeDatum d) =>
Env d i r s m -> Int
envIndex Env d i r s m
n) String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
">"
getEnvMutable ::
(Monad m, NodeDatum d) =>
(Env d i r s m -> STRef s a) -> Env d i r s m -> ATMST s m a
{-# INLINE getEnvMutable #-}
getEnvMutable :: (Env d i r s m -> STRef s a) -> Env d i r s m -> ATMST s m a
getEnvMutable Env d i r s m -> STRef s a
refGetter Env d i r s m
env = STT s m a -> ATMST s m a
forall (m :: * -> *) s r. Monad m => STT s m r -> ATMST s m r
sttLayer (STT s m a -> ATMST s m a) -> STT s m a -> ATMST s m a
forall a b. (a -> b) -> a -> b
$ STRef s a -> STT s m a
forall (m :: * -> *) s a. Applicative m => STRef s a -> STT s m a
readSTRef (Env d i r s m -> STRef s a
refGetter Env d i r s m
env)
setEnvMutable ::
(Monad m, NodeDatum d) =>
(Env d i r s m -> STRef s a) -> Env d i r s m -> a -> ATMST s m ()
{-# INLINE setEnvMutable #-}
setEnvMutable :: (Env d i r s m -> STRef s a) -> Env d i r s m -> a -> ATMST s m ()
setEnvMutable Env d i r s m -> STRef s a
refGetter Env d i r s m
env a
envs = STT s m () -> ATMST s m ()
forall (m :: * -> *) s r. Monad m => STT s m r -> ATMST s m r
sttLayer (STT s m () -> ATMST s m ()) -> STT s m () -> ATMST s m ()
forall a b. (a -> b) -> a -> b
$ STRef s a -> a -> STT s m ()
forall (m :: * -> *) s a.
Applicative m =>
STRef s a -> a -> STT s m ()
writeSTRef (Env d i r s m -> STRef s a
refGetter Env d i r s m
env) a
envs
getEnvNodes ::
(Monad m, NodeDatum d) => Env d i r s m -> ATMST s m [Node d i r s m]
getEnvNodes :: Env d i r s m -> ATMST s m [Node d i r s m]
getEnvNodes = (Env d i r s m -> STRef s [Node d i r s m])
-> Env d i r s m -> ATMST s m [Node d i r s m]
forall (m :: * -> *) d i r s a.
(Monad m, NodeDatum d) =>
(Env d i r s m -> STRef s a) -> Env d i r s m -> ATMST s m a
getEnvMutable Env d i r s m -> STRef s [Node d i r s m]
forall d i r s (m :: * -> *).
(Monad m, NodeDatum d) =>
Env d i r s m -> STRef s [Node d i r s m]
envNodes
setEnvNodes ::
(Monad m, NodeDatum d) => Env d i r s m -> [Node d i r s m] -> ATMST s m ()
setEnvNodes :: Env d i r s m -> [Node d i r s m] -> ATMST s m ()
setEnvNodes = (Env d i r s m -> STRef s [Node d i r s m])
-> Env d i r s m -> [Node d i r s m] -> ATMST s m ()
forall (m :: * -> *) d i r s a.
(Monad m, NodeDatum d) =>
(Env d i r s m -> STRef s a) -> Env d i r s m -> a -> ATMST s m ()
setEnvMutable Env d i r s m -> STRef s [Node d i r s m]
forall d i r s (m :: * -> *).
(Monad m, NodeDatum d) =>
Env d i r s m -> STRef s [Node d i r s m]
envNodes
getEnvRules :: (Monad m, NodeDatum d) => Env d i r s m -> ATMST s m [r]
getEnvRules :: Env d i r s m -> ATMST s m [r]
getEnvRules = (Env d i r s m -> STRef s [r]) -> Env d i r s m -> ATMST s m [r]
forall (m :: * -> *) d i r s a.
(Monad m, NodeDatum d) =>
(Env d i r s m -> STRef s a) -> Env d i r s m -> ATMST s m a
getEnvMutable Env d i r s m -> STRef s [r]
forall d i r s (m :: * -> *).
(Monad m, NodeDatum d) =>
Env d i r s m -> STRef s [r]
envRules
setEnvRules :: (Monad m, NodeDatum d) => Env d i r s m -> [r] -> ATMST s m ()
setEnvRules :: Env d i r s m -> [r] -> ATMST s m ()
setEnvRules = (Env d i r s m -> STRef s [r])
-> Env d i r s m -> [r] -> ATMST s m ()
forall (m :: * -> *) d i r s a.
(Monad m, NodeDatum d) =>
(Env d i r s m -> STRef s a) -> Env d i r s m -> a -> ATMST s m ()
setEnvMutable Env d i r s m -> STRef s [r]
forall d i r s (m :: * -> *).
(Monad m, NodeDatum d) =>
Env d i r s m -> STRef s [r]
envRules
envIsNogood :: (Monad m, NodeDatum d) => Env d i r s m -> ATMST s m Bool
envIsNogood :: Env d i r s m -> ATMST s m Bool
envIsNogood Env d i r s m
env = do
(WhyNogood d i r s m -> Bool)
-> ATMST s m (WhyNogood d i r s m) -> ATMST s m Bool
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap WhyNogood d i r s m -> Bool
forall d i r s (m :: * -> *). WhyNogood d i r s m -> Bool
isNogood (ATMST s m (WhyNogood d i r s m) -> ATMST s m Bool)
-> ATMST s m (WhyNogood d i r s m) -> ATMST s m Bool
forall a b. (a -> b) -> a -> b
$ STT s m (WhyNogood d i r s m) -> ATMST s m (WhyNogood d i r s m)
forall (m :: * -> *) s r. Monad m => STT s m r -> ATMST s m r
sttLayer (STT s m (WhyNogood d i r s m) -> ATMST s m (WhyNogood d i r s m))
-> STT s m (WhyNogood d i r s m) -> ATMST s m (WhyNogood d i r s m)
forall a b. (a -> b) -> a -> b
$ STRef s (WhyNogood d i r s m) -> STT s m (WhyNogood d i r s m)
forall (m :: * -> *) s a. Applicative m => STRef s a -> STT s m a
readSTRef (STRef s (WhyNogood d i r s m) -> STT s m (WhyNogood d i r s m))
-> STRef s (WhyNogood d i r s m) -> STT s m (WhyNogood d i r s m)
forall a b. (a -> b) -> a -> b
$ Env d i r s m -> STRef s (WhyNogood d i r s m)
forall d i r s (m :: * -> *).
(Monad m, NodeDatum d) =>
Env d i r s m -> STRef s (WhyNogood d i r s m)
envWhyNogood Env d i r s m
env
newtype EnvTable d i r s m = EnvTable (STArray s Int [Env d i r s m])
findInEnvTable ::
(Monad m, NodeDatum d) =>
(Env d i r s m -> Bool) -> EnvTable d i r s m ->
ATMST s m (Maybe (Env d i r s m))
findInEnvTable :: (Env d i r s m -> Bool)
-> EnvTable d i r s m -> ATMST s m (Maybe (Env d i r s m))
findInEnvTable Env d i r s m -> Bool
pred (EnvTable STArray s Int [Env d i r s m]
arr) =
let (Int
lo, Int
hi) = STArray s Int [Env d i r s m] -> (Int, Int)
forall s i e. STArray s i e -> (i, i)
boundsSTArray STArray s Int [Env d i r s m]
arr
in (Env d i r s m -> Bool)
-> [Int]
-> STArray s Int [Env d i r s m]
-> ATMST s m (Maybe (Env d i r s m))
forall (m :: * -> *) d i r s.
Monad m =>
(Env d i r s m -> Bool)
-> [Int]
-> STArray s Int [Env d i r s m]
-> ATMST s m (Maybe (Env d i r s m))
findInEnvTableEntries Env d i r s m -> Bool
pred [Int
lo..Int
hi] STArray s Int [Env d i r s m]
arr
where findInEnvTableEntries ::
Monad m =>
(Env d i r s m -> Bool) -> [Int] -> STArray s Int [Env d i r s m] ->
ATMST s m (Maybe (Env d i r s m))
findInEnvTableEntries :: (Env d i r s m -> Bool)
-> [Int]
-> STArray s Int [Env d i r s m]
-> ATMST s m (Maybe (Env d i r s m))
findInEnvTableEntries Env d i r s m -> Bool
pred [] STArray s Int [Env d i r s m]
arr = Maybe (Env d i r s m) -> ATMST s m (Maybe (Env d i r s m))
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe (Env d i r s m)
forall a. Maybe a
Nothing
findInEnvTableEntries Env d i r s m -> Bool
pred (Int
i : [Int]
idxs) STArray s Int [Env d i r s m]
arr = do
[Env d i r s m]
entries <- STT s m [Env d i r s m] -> ATMST s m [Env d i r s m]
forall (m :: * -> *) s r. Monad m => STT s m r -> ATMST s m r
sttLayer (STT s m [Env d i r s m] -> ATMST s m [Env d i r s m])
-> STT s m [Env d i r s m] -> ATMST s m [Env d i r s m]
forall a b. (a -> b) -> a -> b
$ STArray s Int [Env d i r s m] -> Int -> STT s m [Env d i r s m]
forall i (m :: * -> *) s e.
(Ix i, Applicative m) =>
STArray s i e -> i -> STT s m e
readSTArray STArray s Int [Env d i r s m]
arr Int
i
case (Env d i r s m -> Bool) -> [Env d i r s m] -> Maybe (Env d i r s m)
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Maybe a
find Env d i r s m -> Bool
pred [Env d i r s m]
entries of
Maybe (Env d i r s m)
Nothing -> (Env d i r s m -> Bool)
-> [Int]
-> STArray s Int [Env d i r s m]
-> ATMST s m (Maybe (Env d i r s m))
forall (m :: * -> *) d i r s.
Monad m =>
(Env d i r s m -> Bool)
-> [Int]
-> STArray s Int [Env d i r s m]
-> ATMST s m (Maybe (Env d i r s m))
findInEnvTableEntries Env d i r s m -> Bool
pred [Int]
idxs STArray s Int [Env d i r s m]
arr
Maybe (Env d i r s m)
res -> Maybe (Env d i r s m) -> ATMST s m (Maybe (Env d i r s m))
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe (Env d i r s m)
res
findInEnvTableEntry ::
Monad m =>
(Env d i r s m -> Bool) -> [Env d i r s m] -> Maybe (Env d i r s m)
findInEnvTableEntry :: (Env d i r s m -> Bool) -> [Env d i r s m] -> Maybe (Env d i r s m)
findInEnvTableEntry Env d i r s m -> Bool
pred [Env d i r s m]
envs = (Env d i r s m -> Bool) -> [Env d i r s m] -> Maybe (Env d i r s m)
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Maybe a
find Env d i r s m -> Bool
pred [Env d i r s m]
envs
nodeString :: (Monad m, NodeDatum d) => Node d i r s m -> ATMST s m String
nodeString :: Node d i r s m -> ATMST s m String
nodeString Node d i r s m
node = do
Node d i r s m -> String
nodeFmt <- ATMS d i r s m -> ATMST s m (Node d i r s m -> String)
forall (m :: * -> *) d i r s.
(Monad m, NodeDatum d) =>
ATMS d i r s m -> ATMST s m (Node d i r s m -> String)
getNodeString (ATMS d i r s m -> ATMST s m (Node d i r s m -> String))
-> ATMS d i r s m -> ATMST s m (Node d i r s m -> String)
forall a b. (a -> b) -> a -> b
$ Node d i r s m -> ATMS d i r s m
forall d i r s (m :: * -> *).
(Monad m, NodeDatum d) =>
Node d i r s m -> ATMS d i r s m
nodeATMS Node d i r s m
node
String -> ATMST s m String
forall (m :: * -> *) a. Monad m => a -> m a
return (String -> ATMST s m String) -> String -> ATMST s m String
forall a b. (a -> b) -> a -> b
$ Node d i r s m -> String
nodeFmt Node d i r s m
node
defaultNodeString ::
(Monad m, NodeDatum d) => Node d i r s m -> ATMST s m String
defaultNodeString :: Node d i r s m -> ATMST s m String
defaultNodeString Node d i r s m
node = do
d -> String
datumFormatter <- ATMS d i r s m -> ATMST s m (d -> String)
forall (m :: * -> *) d i r s.
(Monad m, NodeDatum d) =>
ATMS d i r s m -> ATMST s m (d -> String)
getDatumString (ATMS d i r s m -> ATMST s m (d -> String))
-> ATMS d i r s m -> ATMST s m (d -> String)
forall a b. (a -> b) -> a -> b
$ Node d i r s m -> ATMS d i r s m
forall d i r s (m :: * -> *).
(Monad m, NodeDatum d) =>
Node d i r s m -> ATMS d i r s m
nodeATMS Node d i r s m
node
String -> ATMST s m String
forall (m :: * -> *) a. Monad m => a -> m a
return (String -> ATMST s m String) -> String -> ATMST s m String
forall a b. (a -> b) -> a -> b
$ d -> String
datumFormatter (d -> String) -> d -> String
forall a b. (a -> b) -> a -> b
$ Node d i r s m -> d
forall d i r s (m :: * -> *).
(Monad m, NodeDatum d) =>
Node d i r s m -> d
nodeDatum Node d i r s m
node
orderedInsert :: Eq a => a -> [a] -> (a -> a -> Bool) -> [a]
orderedInsert :: a -> [a] -> (a -> a -> Bool) -> [a]
orderedInsert a
item [] a -> a -> Bool
_ = [a
item]
orderedInsert a
item list :: [a]
list@(a
i : [a]
_) a -> a -> Bool
test | a -> a -> Bool
test a
item a
i = a
item a -> [a] -> [a]
forall a. a -> [a] -> [a]
: [a]
list
orderedInsert a
item list :: [a]
list@(a
i : [a]
_) a -> a -> Bool
_ | a
item a -> a -> Bool
forall a. Eq a => a -> a -> Bool
== a
i = [a]
list
orderedInsert a
item (a
i : [a]
is) a -> a -> Bool
test = a
i a -> [a] -> [a]
forall a. a -> [a] -> [a]
: a -> [a] -> (a -> a -> Bool) -> [a]
forall a. Eq a => a -> [a] -> (a -> a -> Bool) -> [a]
orderedInsert a
item [a]
is a -> a -> Bool
test
assumptionOrder ::
(Monad m, NodeDatum d) => Node d i r s m -> Node d i r s m -> Bool
assumptionOrder :: Node d i r s m -> Node d i r s m -> Bool
assumptionOrder Node d i r s m
n1 Node d i r s m
n2 = Node d i r s m -> Int
forall d i r s (m :: * -> *).
(Monad m, NodeDatum d) =>
Node d i r s m -> Int
nodeIndex Node d i r s m
n1 Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Node d i r s m -> Int
forall d i r s (m :: * -> *).
(Monad m, NodeDatum d) =>
Node d i r s m -> Int
nodeIndex Node d i r s m
n2
envOrder :: (Monad m, NodeDatum d) => Env d i r s m -> Env d i r s m -> Bool
envOrder :: Env d i r s m -> Env d i r s m -> Bool
envOrder Env d i r s m
e1 Env d i r s m
e2 = Env d i r s m -> Int
forall d i r s (m :: * -> *).
(Monad m, NodeDatum d) =>
Env d i r s m -> Int
envIndex Env d i r s m
e1 Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Env d i r s m -> Int
forall d i r s (m :: * -> *).
(Monad m, NodeDatum d) =>
Env d i r s m -> Int
envIndex Env d i r s m
e2
createATMS ::
(Debuggable m, NodeDatum d) => String -> ATMST s m (ATMS d i r s m)
createATMS :: String -> ATMST s m (ATMS d i r s m)
createATMS String
title = do
Int
ecInitialAlloc <- ATMST s m Int
forall (m :: * -> *) s. Monad m => ATMST s m Int
getInitialEnvTableAlloc
STRef s (Maybe (Env d i r s m))
emptyEnvRef <- STT s m (STRef s (Maybe (Env d i r s m)))
-> ATMST s m (STRef s (Maybe (Env d i r s m)))
forall (m :: * -> *) s r. Monad m => STT s m r -> ATMST s m r
sttLayer (STT s m (STRef s (Maybe (Env d i r s m)))
-> ATMST s m (STRef s (Maybe (Env d i r s m))))
-> STT s m (STRef s (Maybe (Env d i r s m)))
-> ATMST s m (STRef s (Maybe (Env d i r s m)))
forall a b. (a -> b) -> a -> b
$ Maybe (Env d i r s m) -> STT s m (STRef s (Maybe (Env d i r s m)))
forall (m :: * -> *) a s. Applicative m => a -> STT s m (STRef s a)
newSTRef Maybe (Env d i r s m)
forall a. Maybe a
Nothing
STRef s (Maybe (Node d i r s m))
contraNodeRef <- STT s m (STRef s (Maybe (Node d i r s m)))
-> ATMST s m (STRef s (Maybe (Node d i r s m)))
forall (m :: * -> *) s r. Monad m => STT s m r -> ATMST s m r
sttLayer (STT s m (STRef s (Maybe (Node d i r s m)))
-> ATMST s m (STRef s (Maybe (Node d i r s m))))
-> STT s m (STRef s (Maybe (Node d i r s m)))
-> ATMST s m (STRef s (Maybe (Node d i r s m)))
forall a b. (a -> b) -> a -> b
$ Maybe (Node d i r s m)
-> STT s m (STRef s (Maybe (Node d i r s m)))
forall (m :: * -> *) a s. Applicative m => a -> STT s m (STRef s a)
newSTRef Maybe (Node d i r s m)
forall a. Maybe a
Nothing
ATMS d i r s m
result <- STT s m (ATMS d i r s m) -> ATMST s m (ATMS d i r s m)
forall (m :: * -> *) s r. Monad m => STT s m r -> ATMST s m r
sttLayer (STT s m (ATMS d i r s m) -> ATMST s m (ATMS d i r s m))
-> STT s m (ATMS d i r s m) -> ATMST s m (ATMS d i r s m)
forall a b. (a -> b) -> a -> b
$ do
STRef s Int
nc <- Int -> STT s m (STRef s Int)
forall (m :: * -> *) a s. Applicative m => a -> STT s m (STRef s a)
newSTRef Int
0
STRef s Int
jc <- Int -> STT s m (STRef s Int)
forall (m :: * -> *) a s. Applicative m => a -> STT s m (STRef s a)
newSTRef Int
0
STRef s Int
ec <- Int -> STT s m (STRef s Int)
forall (m :: * -> *) a s. Applicative m => a -> STT s m (STRef s a)
newSTRef Int
0
STRef s Int
etAlloc <- Int -> STT s m (STRef s Int)
forall (m :: * -> *) a s. Applicative m => a -> STT s m (STRef s a)
newSTRef Int
ecInitialAlloc
STRef s [Node d i r s m]
nodes <- [Node d i r s m] -> STT s m (STRef s [Node d i r s m])
forall (m :: * -> *) a s. Applicative m => a -> STT s m (STRef s a)
newSTRef ([] :: [Node d i r s m])
STRef s [JustRule d i r s m]
justs <- [JustRule d i r s m] -> STT s m (STRef s [JustRule d i r s m])
forall (m :: * -> *) a s. Applicative m => a -> STT s m (STRef s a)
newSTRef ([] :: [JustRule d i r s m])
STRef s [Node d i r s m]
contradictions <- [Node d i r s m] -> STT s m (STRef s [Node d i r s m])
forall (m :: * -> *) a s. Applicative m => a -> STT s m (STRef s a)
newSTRef ([] :: [Node d i r s m])
STRef s [Node d i r s m]
assumptions <- [Node d i r s m] -> STT s m (STRef s [Node d i r s m])
forall (m :: * -> *) a s. Applicative m => a -> STT s m (STRef s a)
newSTRef ([] :: [Node d i r s m])
STArray s Int [Env d i r s m]
etable <- (Int, Int)
-> [Env d i r s m] -> STT s m (STArray s Int [Env d i r s m])
forall i (m :: * -> *) e s.
(Ix i, Applicative m) =>
(i, i) -> e -> STT s m (STArray s i e)
newSTArray (Int
0, Int
ecInitialAlloc) []
STRef s (EnvTable d i r s m)
etableRef <- EnvTable d i r s m -> STT s m (STRef s (EnvTable d i r s m))
forall (m :: * -> *) a s. Applicative m => a -> STT s m (STRef s a)
newSTRef (STArray s Int [Env d i r s m] -> EnvTable d i r s m
forall d i r s (m :: * -> *).
STArray s Int [Env d i r s m] -> EnvTable d i r s m
EnvTable STArray s Int [Env d i r s m]
etable)
STArray s Int [Env d i r s m]
ngtable <- (Int, Int)
-> [Env d i r s m] -> STT s m (STArray s Int [Env d i r s m])
forall i (m :: * -> *) e s.
(Ix i, Applicative m) =>
(i, i) -> e -> STT s m (STArray s i e)
newSTArray (Int
0, Int
ecInitialAlloc) []
STRef s (EnvTable d i r s m)
ngtableRef <- EnvTable d i r s m -> STT s m (STRef s (EnvTable d i r s m))
forall (m :: * -> *) a s. Applicative m => a -> STT s m (STRef s a)
newSTRef (STArray s Int [Env d i r s m] -> EnvTable d i r s m
forall d i r s (m :: * -> *).
STArray s Int [Env d i r s m] -> EnvTable d i r s m
EnvTable STArray s Int [Env d i r s m]
ngtable)
STRef s (Node d i r s m -> String)
nodeString <- (Node d i r s m -> String)
-> STT s m (STRef s (Node d i r s m -> String))
forall (m :: * -> *) a s. Applicative m => a -> STT s m (STRef s a)
newSTRef (Int -> String
forall a. Show a => a -> String
show (Int -> String)
-> (Node d i r s m -> Int) -> Node d i r s m -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Node d i r s m -> Int
forall d i r s (m :: * -> *).
(Monad m, NodeDatum d) =>
Node d i r s m -> Int
nodeIndex)
STRef s (JustRule d i r s m -> String)
justString <- (JustRule d i r s m -> String)
-> STT s m (STRef s (JustRule d i r s m -> String))
forall (m :: * -> *) a s. Applicative m => a -> STT s m (STRef s a)
newSTRef (Int -> String
forall a. Show a => a -> String
show (Int -> String)
-> (JustRule d i r s m -> Int) -> JustRule d i r s m -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. JustRule d i r s m -> Int
forall d i r s (m :: * -> *).
(Monad m, NodeDatum d) =>
JustRule d i r s m -> Int
justIndex)
STRef s (d -> String)
datumString <- (d -> String) -> STT s m (STRef s (d -> String))
forall (m :: * -> *) a s. Applicative m => a -> STT s m (STRef s a)
newSTRef (\ d
datum -> String
"?")
STRef s (i -> String)
informantString <- (i -> String) -> STT s m (STRef s (i -> String))
forall (m :: * -> *) a s. Applicative m => a -> STT s m (STRef s a)
newSTRef (\ i
inf -> String
"?")
STRef s (r -> ATMST s m ())
enqueueProcedure <- (r -> ATMST s m ()) -> STT s m (STRef s (r -> ATMST s m ()))
forall (m :: * -> *) a s. Applicative m => a -> STT s m (STRef s a)
newSTRef (\ r
_ -> () -> ATMST s m ()
forall (m :: * -> *) a. Monad m => a -> m a
return ())
STRef s Bool
debugging <- Bool -> STT s m (STRef s Bool)
forall (m :: * -> *) a s. Applicative m => a -> STT s m (STRef s a)
newSTRef Bool
False
ATMS d i r s m -> STT s m (ATMS d i r s m)
forall (m :: * -> *) a. Monad m => a -> m a
return (ATMS d i r s m -> STT s m (ATMS d i r s m))
-> ATMS d i r s m -> STT s m (ATMS d i r s m)
forall a b. (a -> b) -> a -> b
$ String
-> STRef s Int
-> STRef s Int
-> STRef s Int
-> STRef s Int
-> STRef s [Node d i r s m]
-> STRef s [JustRule d i r s m]
-> STRef s [Node d i r s m]
-> STRef s [Node d i r s m]
-> STRef s (EnvTable d i r s m)
-> STRef s (EnvTable d i r s m)
-> STRef s (Maybe (Env d i r s m))
-> STRef s (Maybe (Node d i r s m))
-> STRef s (Node d i r s m -> String)
-> STRef s (JustRule d i r s m -> String)
-> STRef s (d -> String)
-> STRef s (i -> String)
-> STRef s (r -> ATMST s m ())
-> STRef s Bool
-> ATMS d i r s m
forall d i r s (m :: * -> *).
String
-> STRef s Int
-> STRef s Int
-> STRef s Int
-> STRef s Int
-> STRef s [Node d i r s m]
-> STRef s [JustRule d i r s m]
-> STRef s [Node d i r s m]
-> STRef s [Node d i r s m]
-> STRef s (EnvTable d i r s m)
-> STRef s (EnvTable d i r s m)
-> STRef s (Maybe (Env d i r s m))
-> STRef s (Maybe (Node d i r s m))
-> STRef s (Node d i r s m -> String)
-> STRef s (JustRule d i r s m -> String)
-> STRef s (d -> String)
-> STRef s (i -> String)
-> STRef s (r -> ATMST s m ())
-> STRef s Bool
-> ATMS d i r s m
ATMS String
title STRef s Int
nc STRef s Int
jc STRef s Int
ec STRef s Int
etAlloc
STRef s [Node d i r s m]
nodes STRef s [JustRule d i r s m]
justs STRef s [Node d i r s m]
contradictions STRef s [Node d i r s m]
assumptions
STRef s (EnvTable d i r s m)
etableRef STRef s (EnvTable d i r s m)
ngtableRef STRef s (Maybe (Env d i r s m))
emptyEnvRef STRef s (Maybe (Node d i r s m))
contraNodeRef
STRef s (Node d i r s m -> String)
nodeString STRef s (JustRule d i r s m -> String)
justString STRef s (d -> String)
datumString STRef s (i -> String)
informantString
STRef s (r -> ATMST s m ())
enqueueProcedure STRef s Bool
debugging
Env d i r s m
emptyEnv <- ATMS d i r s m -> [Node d i r s m] -> ATMST s m (Env d i r s m)
forall (m :: * -> *) d i r s.
(Debuggable m, NodeDatum d) =>
ATMS d i r s m -> [Node d i r s m] -> ATMST s m (Env d i r s m)
createEnv ATMS d i r s m
result []
STT s m () -> ATMST s m ()
forall (m :: * -> *) s r. Monad m => STT s m r -> ATMST s m r
sttLayer (STT s m () -> ATMST s m ()) -> STT s m () -> ATMST s m ()
forall a b. (a -> b) -> a -> b
$ STRef s (Maybe (Env d i r s m))
-> Maybe (Env d i r s m) -> STT s m ()
forall (m :: * -> *) s a.
Applicative m =>
STRef s a -> a -> STT s m ()
writeSTRef STRef s (Maybe (Env d i r s m))
emptyEnvRef (Env d i r s m -> Maybe (Env d i r s m)
forall a. a -> Maybe a
Just Env d i r s m
emptyEnv)
Node d i r s m
contra <- ATMS d i r s m -> d -> Bool -> Bool -> ATMST s m (Node d i r s m)
forall (m :: * -> *) d i r s.
(Debuggable m, NodeDatum d) =>
ATMS d i r s m -> d -> Bool -> Bool -> ATMST s m (Node d i r s m)
createNode ATMS d i r s m
result d
forall d. NodeDatum d => d
contradictionNodeDatum Bool
False Bool
True
STT s m () -> ATMST s m ()
forall (m :: * -> *) s r. Monad m => STT s m r -> ATMST s m r
sttLayer (STT s m () -> ATMST s m ()) -> STT s m () -> ATMST s m ()
forall a b. (a -> b) -> a -> b
$ STRef s (Maybe (Node d i r s m))
-> Maybe (Node d i r s m) -> STT s m ()
forall (m :: * -> *) s a.
Applicative m =>
STRef s a -> a -> STT s m ()
writeSTRef STRef s (Maybe (Node d i r s m))
contraNodeRef (Node d i r s m -> Maybe (Node d i r s m)
forall a. a -> Maybe a
Just Node d i r s m
contra)
ATMS d i r s m -> ATMST s m (ATMS d i r s m)
forall (m :: * -> *) a. Monad m => a -> m a
return ATMS d i r s m
result
isTrueNode :: (Monad m, NodeDatum d) => Node d i r s m -> ATMST s m Bool
isTrueNode :: Node d i r s m -> ATMST s m Bool
isTrueNode Node d i r s m
node = do
[Env d i r s m]
envs <- Node d i r s m -> ATMST s m [Env d i r s m]
forall (m :: * -> *) d i r s.
(Monad m, NodeDatum d) =>
Node d i r s m -> ATMST s m [Env d i r s m]
getNodeLabel Node d i r s m
node
Bool -> ATMST s m Bool
forall (m :: * -> *) a. Monad m => a -> m a
return (Bool -> ATMST s m Bool) -> Bool -> ATMST s m Bool
forall a b. (a -> b) -> a -> b
$ case [Env d i r s m]
envs of
[] -> Bool
False
Env d i r s m
e : [Env d i r s m]
_ -> [Node d i r s m] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null ([Node d i r s m] -> Bool) -> [Node d i r s m] -> Bool
forall a b. (a -> b) -> a -> b
$ Env d i r s m -> [Node d i r s m]
forall d i r s (m :: * -> *).
(Monad m, NodeDatum d) =>
Env d i r s m -> [Node d i r s m]
envAssumptions Env d i r s m
e
isInNode :: (Monad m, NodeDatum d) => Node d i r s m -> ATMST s m Bool
isInNode :: Node d i r s m -> ATMST s m Bool
isInNode Node d i r s m
node = ([Env d i r s m] -> Bool)
-> ATMST s m [Env d i r s m] -> ATMST s m Bool
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Bool -> Bool
not (Bool -> Bool)
-> ([Env d i r s m] -> Bool) -> [Env d i r s m] -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Env d i r s m] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null) (Node d i r s m -> ATMST s m [Env d i r s m]
forall (m :: * -> *) d i r s.
(Monad m, NodeDatum d) =>
Node d i r s m -> ATMST s m [Env d i r s m]
getNodeLabel Node d i r s m
node)
isInNodeByEnv ::
(Monad m, NodeDatum d) => Node d i r s m -> Env d i r s m -> ATMST s m Bool
isInNodeByEnv :: Node d i r s m -> Env d i r s m -> ATMST s m Bool
isInNodeByEnv Node d i r s m
node Env d i r s m
env = do
[Env d i r s m]
labelEnvs <- Node d i r s m -> ATMST s m [Env d i r s m]
forall (m :: * -> *) d i r s.
(Monad m, NodeDatum d) =>
Node d i r s m -> ATMST s m [Env d i r s m]
getNodeLabel Node d i r s m
node
Bool -> ATMST s m Bool
forall (m :: * -> *) a. Monad m => a -> m a
return (Bool -> ATMST s m Bool) -> Bool -> ATMST s m Bool
forall a b. (a -> b) -> a -> b
$ (Env d i r s m -> Bool) -> [Env d i r s m] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (\ Env d i r s m
le -> Env d i r s m -> Env d i r s m -> Bool
forall (m :: * -> *) d i r s.
(Monad m, NodeDatum d) =>
Env d i r s m -> Env d i r s m -> Bool
isSubsetEnv Env d i r s m
le Env d i r s m
env) [Env d i r s m]
labelEnvs
isOutNode ::
(Monad m, NodeDatum d) => Node d i r s m -> Env d i r s m -> ATMST s m Bool
isOutNode :: Node d i r s m -> Env d i r s m -> ATMST s m Bool
isOutNode Node d i r s m
node Env d i r s m
env = (Bool -> Bool) -> ATMST s m Bool -> ATMST s m Bool
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Bool -> Bool
not (ATMST s m Bool -> ATMST s m Bool)
-> ATMST s m Bool -> ATMST s m Bool
forall a b. (a -> b) -> a -> b
$ Node d i r s m -> Env d i r s m -> ATMST s m Bool
forall (m :: * -> *) d i r s.
(Monad m, NodeDatum d) =>
Node d i r s m -> Env d i r s m -> ATMST s m Bool
isInNodeByEnv Node d i r s m
node Env d i r s m
env
isNodeConsistentWith ::
(Monad m, NodeDatum d) => Node d i r s m -> Env d i r s m -> ATMST s m Bool
isNodeConsistentWith :: Node d i r s m -> Env d i r s m -> ATMST s m Bool
isNodeConsistentWith Node d i r s m
node Env d i r s m
env = do
[Env d i r s m]
labelEnvs <- Node d i r s m -> ATMST s m [Env d i r s m]
forall (m :: * -> *) d i r s.
(Monad m, NodeDatum d) =>
Node d i r s m -> ATMST s m [Env d i r s m]
getNodeLabel Node d i r s m
node
(Env d i r s m -> ATMST s m Bool)
-> [Env d i r s m] -> ATMST s m Bool
forall (m :: * -> *) a. Monad m => (a -> m Bool) -> [a] -> m Bool
anyByM (\ Env d i r s m
le -> do
Env d i r s m
union <- Env d i r s m -> Env d i r s m -> ATMST s m (Env d i r s m)
forall (m :: * -> *) d i r s.
(Debuggable m, NodeDatum d) =>
Env d i r s m -> Env d i r s m -> ATMST s m (Env d i r s m)
unionEnv Env d i r s m
le Env d i r s m
env
(Bool -> Bool) -> ATMST s m Bool -> ATMST s m Bool
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Bool -> Bool
not (ATMST s m Bool -> ATMST s m Bool)
-> ATMST s m Bool -> ATMST s m Bool
forall a b. (a -> b) -> a -> b
$ Env d i r s m -> ATMST s m Bool
forall (m :: * -> *) d i r s.
(Monad m, NodeDatum d) =>
Env d i r s m -> ATMST s m Bool
envIsNogood Env d i r s m
union)
[Env d i r s m]
labelEnvs
createNode :: (Debuggable m, NodeDatum d) =>
ATMS d i r s m -> d -> Bool -> Bool -> ATMST s m (Node d i r s m)
createNode :: ATMS d i r s m -> d -> Bool -> Bool -> ATMST s m (Node d i r s m)
createNode ATMS d i r s m
atms d
datum Bool
isAssumption Bool
isContradictory = do
Int
idx <- ATMS d i r s m -> ATMST s m Int
forall (m :: * -> *) d i r s.
(Monad m, NodeDatum d) =>
ATMS d i r s m -> ATMST s m Int
nextNodeCounter ATMS d i r s m
atms
STRef s [Env d i r s m]
label <- STT s m (STRef s [Env d i r s m])
-> ATMST s m (STRef s [Env d i r s m])
forall (m :: * -> *) s r. Monad m => STT s m r -> ATMST s m r
sttLayer (STT s m (STRef s [Env d i r s m])
-> ATMST s m (STRef s [Env d i r s m]))
-> STT s m (STRef s [Env d i r s m])
-> ATMST s m (STRef s [Env d i r s m])
forall a b. (a -> b) -> a -> b
$ [Env d i r s m] -> STT s m (STRef s [Env d i r s m])
forall (m :: * -> *) a s. Applicative m => a -> STT s m (STRef s a)
newSTRef []
STRef s [Justification d i r s m]
justs <- STT s m (STRef s [Justification d i r s m])
-> ATMST s m (STRef s [Justification d i r s m])
forall (m :: * -> *) s r. Monad m => STT s m r -> ATMST s m r
sttLayer (STT s m (STRef s [Justification d i r s m])
-> ATMST s m (STRef s [Justification d i r s m]))
-> STT s m (STRef s [Justification d i r s m])
-> ATMST s m (STRef s [Justification d i r s m])
forall a b. (a -> b) -> a -> b
$ [Justification d i r s m]
-> STT s m (STRef s [Justification d i r s m])
forall (m :: * -> *) a s. Applicative m => a -> STT s m (STRef s a)
newSTRef []
STRef s [JustRule d i r s m]
conseq <- STT s m (STRef s [JustRule d i r s m])
-> ATMST s m (STRef s [JustRule d i r s m])
forall (m :: * -> *) s r. Monad m => STT s m r -> ATMST s m r
sttLayer (STT s m (STRef s [JustRule d i r s m])
-> ATMST s m (STRef s [JustRule d i r s m]))
-> STT s m (STRef s [JustRule d i r s m])
-> ATMST s m (STRef s [JustRule d i r s m])
forall a b. (a -> b) -> a -> b
$ [JustRule d i r s m] -> STT s m (STRef s [JustRule d i r s m])
forall (m :: * -> *) a s. Applicative m => a -> STT s m (STRef s a)
newSTRef []
STRef s Bool
assumptionFlag <- STT s m (STRef s Bool) -> ATMST s m (STRef s Bool)
forall (m :: * -> *) s r. Monad m => STT s m r -> ATMST s m r
sttLayer (STT s m (STRef s Bool) -> ATMST s m (STRef s Bool))
-> STT s m (STRef s Bool) -> ATMST s m (STRef s Bool)
forall a b. (a -> b) -> a -> b
$ Bool -> STT s m (STRef s Bool)
forall (m :: * -> *) a s. Applicative m => a -> STT s m (STRef s a)
newSTRef Bool
isAssumption
STRef s Bool
contraFlag <- STT s m (STRef s Bool) -> ATMST s m (STRef s Bool)
forall (m :: * -> *) s r. Monad m => STT s m r -> ATMST s m r
sttLayer (STT s m (STRef s Bool) -> ATMST s m (STRef s Bool))
-> STT s m (STRef s Bool) -> ATMST s m (STRef s Bool)
forall a b. (a -> b) -> a -> b
$ Bool -> STT s m (STRef s Bool)
forall (m :: * -> *) a s. Applicative m => a -> STT s m (STRef s a)
newSTRef Bool
isContradictory
STRef s [r]
rules <- STT s m (STRef s [r]) -> ATMST s m (STRef s [r])
forall (m :: * -> *) s r. Monad m => STT s m r -> ATMST s m r
sttLayer (STT s m (STRef s [r]) -> ATMST s m (STRef s [r]))
-> STT s m (STRef s [r]) -> ATMST s m (STRef s [r])
forall a b. (a -> b) -> a -> b
$ [r] -> STT s m (STRef s [r])
forall (m :: * -> *) a s. Applicative m => a -> STT s m (STRef s a)
newSTRef []
let node :: Node d i r s m
node = Int
-> d
-> STRef s [Env d i r s m]
-> STRef s [Justification d i r s m]
-> STRef s [JustRule d i r s m]
-> STRef s Bool
-> STRef s Bool
-> STRef s [r]
-> ATMS d i r s m
-> Node d i r s m
forall d i r s (m :: * -> *).
Int
-> d
-> STRef s [Env d i r s m]
-> STRef s [Justification d i r s m]
-> STRef s [JustRule d i r s m]
-> STRef s Bool
-> STRef s Bool
-> STRef s [r]
-> ATMS d i r s m
-> Node d i r s m
Node Int
idx d
datum STRef s [Env d i r s m]
label STRef s [Justification d i r s m]
justs STRef s [JustRule d i r s m]
conseq
STRef s Bool
contraFlag STRef s Bool
assumptionFlag STRef s [r]
rules ATMS d i r s m
atms
STT s m () -> ATMST s m ()
forall (m :: * -> *) s r. Monad m => STT s m r -> ATMST s m r
sttLayer (STT s m () -> ATMST s m ()) -> STT s m () -> ATMST s m ()
forall a b. (a -> b) -> a -> b
$ do
Node d i r s m -> STRef s [Node d i r s m] -> STT s m ()
forall (m :: * -> *) a s. Monad m => a -> STRef s [a] -> STT s m ()
push Node d i r s m
node (STRef s [Node d i r s m] -> STT s m ())
-> STRef s [Node d i r s m] -> STT s m ()
forall a b. (a -> b) -> a -> b
$ ATMS d i r s m -> STRef s [Node d i r s m]
forall d i r s (m :: * -> *).
(Monad m, NodeDatum d) =>
ATMS d i r s m -> STRef s [Node d i r s m]
atmsNodes ATMS d i r s m
atms
Bool -> STT s m () -> STT s m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
isContradictory (STT s m () -> STT s m ()) -> STT s m () -> STT s m ()
forall a b. (a -> b) -> a -> b
$ Node d i r s m -> STRef s [Node d i r s m] -> STT s m ()
forall (m :: * -> *) a s. Monad m => a -> STRef s [a] -> STT s m ()
push Node d i r s m
node (STRef s [Node d i r s m] -> STT s m ())
-> STRef s [Node d i r s m] -> STT s m ()
forall a b. (a -> b) -> a -> b
$ ATMS d i r s m -> STRef s [Node d i r s m]
forall d i r s (m :: * -> *).
(Monad m, NodeDatum d) =>
ATMS d i r s m -> STRef s [Node d i r s m]
atmsContradictions ATMS d i r s m
atms
Bool -> ATMST s m () -> ATMST s m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
isAssumption (ATMST s m () -> ATMST s m ()) -> ATMST s m () -> ATMST s m ()
forall a b. (a -> b) -> a -> b
$ do
Env d i r s m
selfEnv <- ATMS d i r s m -> [Node d i r s m] -> ATMST s m (Env d i r s m)
forall (m :: * -> *) d i r s.
(Debuggable m, NodeDatum d) =>
ATMS d i r s m -> [Node d i r s m] -> ATMST s m (Env d i r s m)
createEnv ATMS d i r s m
atms [Node d i r s m
node]
STT s m () -> ATMST s m ()
forall (m :: * -> *) s r. Monad m => STT s m r -> ATMST s m r
sttLayer (STT s m () -> ATMST s m ()) -> STT s m () -> ATMST s m ()
forall a b. (a -> b) -> a -> b
$ do
Node d i r s m -> STRef s [Node d i r s m] -> STT s m ()
forall (m :: * -> *) a s. Monad m => a -> STRef s [a] -> STT s m ()
push Node d i r s m
node (STRef s [Node d i r s m] -> STT s m ())
-> STRef s [Node d i r s m] -> STT s m ()
forall a b. (a -> b) -> a -> b
$ ATMS d i r s m -> STRef s [Node d i r s m]
forall d i r s (m :: * -> *).
(Monad m, NodeDatum d) =>
ATMS d i r s m -> STRef s [Node d i r s m]
atmsAssumptions ATMS d i r s m
atms
Env d i r s m -> STRef s [Env d i r s m] -> STT s m ()
forall (m :: * -> *) a s. Monad m => a -> STRef s [a] -> STT s m ()
push Env d i r s m
selfEnv (STRef s [Env d i r s m] -> STT s m ())
-> STRef s [Env d i r s m] -> STT s m ()
forall a b. (a -> b) -> a -> b
$ Node d i r s m -> STRef s [Env d i r s m]
forall d i r s (m :: * -> *).
(Monad m, NodeDatum d) =>
Node d i r s m -> STRef s [Env d i r s m]
nodeLabel Node d i r s m
node
Node d i r s m -> ATMST s m (Node d i r s m)
forall (m :: * -> *) a. Monad m => a -> m a
return Node d i r s m
node
assumeNode :: (Debuggable m, NodeDatum d) => Node d i r s m -> ATMST s m ()
assumeNode :: Node d i r s m -> ATMST s m ()
assumeNode Node d i r s m
node =
ATMST s m Bool -> ATMST s m () -> ATMST s m ()
forall (m :: * -> *). Monad m => m Bool -> m () -> m ()
unlessM (Node d i r s m -> ATMST s m Bool
forall (m :: * -> *) d i r s.
(Monad m, NodeDatum d) =>
Node d i r s m -> ATMST s m Bool
getNodeIsAssumption Node d i r s m
node) (ATMST s m () -> ATMST s m ()) -> ATMST s m () -> ATMST s m ()
forall a b. (a -> b) -> a -> b
$ do
let atms :: ATMS d i r s m
atms = Node d i r s m -> ATMS d i r s m
forall d i r s (m :: * -> *).
(Monad m, NodeDatum d) =>
Node d i r s m -> ATMS d i r s m
nodeATMS Node d i r s m
node
STT s m () -> ATMST s m ()
forall (m :: * -> *) s r. Monad m => STT s m r -> ATMST s m r
sttLayer (STT s m () -> ATMST s m ()) -> STT s m () -> ATMST s m ()
forall a b. (a -> b) -> a -> b
$ Node d i r s m -> STRef s [Node d i r s m] -> STT s m ()
forall (m :: * -> *) a s. Monad m => a -> STRef s [a] -> STT s m ()
push Node d i r s m
node (ATMS d i r s m -> STRef s [Node d i r s m]
forall d i r s (m :: * -> *).
(Monad m, NodeDatum d) =>
ATMS d i r s m -> STRef s [Node d i r s m]
atmsAssumptions ATMS d i r s m
atms)
Env d i r s m
selfEnv <- [Node d i r s m] -> ATMS d i r s m -> ATMST s m (Env d i r s m)
forall (m :: * -> *) d i r s.
(Monad m, NodeDatum d) =>
[Node d i r s m] -> ATMS d i r s m -> ATMST s m (Env d i r s m)
findOrMakeEnv [Node d i r s m
node] ATMS d i r s m
atms
MList s (Maybe (Env d i r s m))
nodes <- STT s m (MList s (Maybe (Env d i r s m)))
-> ATMST s m (MList s (Maybe (Env d i r s m)))
forall (m :: * -> *) s r. Monad m => STT s m r -> ATMST s m r
sttLayer (STT s m (MList s (Maybe (Env d i r s m)))
-> ATMST s m (MList s (Maybe (Env d i r s m))))
-> STT s m (MList s (Maybe (Env d i r s m)))
-> ATMST s m (MList s (Maybe (Env d i r s m)))
forall a b. (a -> b) -> a -> b
$ [Maybe (Env d i r s m)]
-> STT s m (MList s (Maybe (Env d i r s m)))
forall (m :: * -> *) a s. Monad m => [a] -> STT s m (MList s a)
toMList [Env d i r s m -> Maybe (Env d i r s m)
forall a. a -> Maybe a
Just Env d i r s m
selfEnv]
MList s (Maybe (Env d i r s m))
-> Node d i r s m -> Justification d i r s m -> ATMST s m ()
forall (m :: * -> *) d s i r.
(Debuggable m, NodeDatum d) =>
MList s (Maybe (Env d i r s m))
-> Node d i r s m -> Justification d i r s m -> ATMST s m ()
update MList s (Maybe (Env d i r s m))
nodes Node d i r s m
node (Node d i r s m -> Justification d i r s m
forall d i r s (m :: * -> *).
Node d i r s m -> Justification d i r s m
ByAssumption Node d i r s m
node)
makeContradiction :: (Monad m, NodeDatum d) => Node d i r s m -> ATMST s m ()
makeContradiction :: Node d i r s m -> ATMST s m ()
makeContradiction Node d i r s m
node = do
let atms :: ATMS d i r s m
atms = Node d i r s m -> ATMS d i r s m
forall d i r s (m :: * -> *).
(Monad m, NodeDatum d) =>
Node d i r s m -> ATMS d i r s m
nodeATMS Node d i r s m
node
ATMST s m Bool -> ATMST s m () -> ATMST s m ()
forall (m :: * -> *). Monad m => m Bool -> m () -> m ()
unlessM (Node d i r s m -> ATMST s m Bool
forall (m :: * -> *) d i r s.
(Monad m, NodeDatum d) =>
Node d i r s m -> ATMST s m Bool
getNodeIsContradictory Node d i r s m
node) (ATMST s m () -> ATMST s m ()) -> ATMST s m () -> ATMST s m ()
forall a b. (a -> b) -> a -> b
$ do
Node d i r s m -> ATMST s m ()
forall (m :: * -> *) d i r s.
(Monad m, NodeDatum d) =>
Node d i r s m -> ATMST s m ()
setNodeIsContradictory Node d i r s m
node
STT s m () -> ATMST s m ()
forall (m :: * -> *) s r. Monad m => STT s m r -> ATMST s m r
sttLayer (STT s m () -> ATMST s m ()) -> STT s m () -> ATMST s m ()
forall a b. (a -> b) -> a -> b
$ Node d i r s m -> STRef s [Node d i r s m] -> STT s m ()
forall (m :: * -> *) a s. Monad m => a -> STRef s [a] -> STT s m ()
push Node d i r s m
node (STRef s [Node d i r s m] -> STT s m ())
-> STRef s [Node d i r s m] -> STT s m ()
forall a b. (a -> b) -> a -> b
$ ATMS d i r s m -> STRef s [Node d i r s m]
forall d i r s (m :: * -> *).
(Monad m, NodeDatum d) =>
ATMS d i r s m -> STRef s [Node d i r s m]
atmsContradictions ATMS d i r s m
atms
ATMST s m [Env d i r s m]
-> ([Env d i r s m] -> Bool)
-> ([Env d i r s m] -> ATMST s m ())
-> ATMST s m ()
forall (m :: * -> *) a.
Monad m =>
m a -> (a -> Bool) -> (a -> m ()) -> m ()
whileDoWith (Node d i r s m -> ATMST s m [Env d i r s m]
forall (m :: * -> *) d i r s.
(Monad m, NodeDatum d) =>
Node d i r s m -> ATMST s m [Env d i r s m]
getNodeLabel Node d i r s m
node) (Bool -> Bool
not (Bool -> Bool)
-> ([Env d i r s m] -> Bool) -> [Env d i r s m] -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Env d i r s m] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null) (([Env d i r s m] -> ATMST s m ()) -> ATMST s m ())
-> ([Env d i r s m] -> ATMST s m ()) -> ATMST s m ()
forall a b. (a -> b) -> a -> b
$ \ (Env d i r s m
env : [Env d i r s m]
_) ->
ATMS d i r s m
-> Env d i r s m -> Justification d i r s m -> ATMST s m ()
forall (m :: * -> *) d i r s.
(Debuggable m, NodeDatum d) =>
ATMS d i r s m
-> Env d i r s m -> Justification d i r s m -> ATMST s m ()
newNogood ATMS d i r s m
atms Env d i r s m
env Justification d i r s m
forall d i r s (m :: * -> *). Justification d i r s m
ByContradiction
justifyNode ::
(Debuggable m, NodeDatum d) =>
i -> Node d i r s m -> [Node d i r s m] -> ATMST s m ()
justifyNode :: i -> Node d i r s m -> [Node d i r s m] -> ATMST s m ()
justifyNode i
informant Node d i r s m
consequence [Node d i r s m]
antecedents = do
let atms :: ATMS d i r s m
atms = Node d i r s m -> ATMS d i r s m
forall d i r s (m :: * -> *).
(Monad m, NodeDatum d) =>
Node d i r s m -> ATMS d i r s m
nodeATMS Node d i r s m
consequence
Int
idx <- ATMS d i r s m -> ATMST s m Int
forall (m :: * -> *) d i r s.
(Monad m, NodeDatum d) =>
ATMS d i r s m -> ATMST s m Int
nextJustCounter ATMS d i r s m
atms
let just :: JustRule d i r s m
just = Int
-> i -> Node d i r s m -> [Node d i r s m] -> JustRule d i r s m
forall d i r s (m :: * -> *).
Int
-> i -> Node d i r s m -> [Node d i r s m] -> JustRule d i r s m
JustRule Int
idx i
informant Node d i r s m
consequence [Node d i r s m]
antecedents
STT s m () -> ATMST s m ()
forall (m :: * -> *) s r. Monad m => STT s m r -> ATMST s m r
sttLayer (STT s m () -> ATMST s m ()) -> STT s m () -> ATMST s m ()
forall a b. (a -> b) -> a -> b
$ Justification d i r s m
-> STRef s [Justification d i r s m] -> STT s m ()
forall (m :: * -> *) a s. Monad m => a -> STRef s [a] -> STT s m ()
push (JustRule d i r s m -> Justification d i r s m
forall d i r s (m :: * -> *).
JustRule d i r s m -> Justification d i r s m
ByRule JustRule d i r s m
just) (Node d i r s m -> STRef s [Justification d i r s m]
forall d i r s (m :: * -> *).
(Monad m, NodeDatum d) =>
Node d i r s m -> STRef s [Justification d i r s m]
nodeJusts Node d i r s m
consequence)
STT s m () -> ATMST s m ()
forall (m :: * -> *) s r. Monad m => STT s m r -> ATMST s m r
sttLayer (STT s m () -> ATMST s m ()) -> STT s m () -> ATMST s m ()
forall a b. (a -> b) -> a -> b
$ [Node d i r s m] -> (Node d i r s m -> STT s m ()) -> STT s m ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [Node d i r s m]
antecedents ((Node d i r s m -> STT s m ()) -> STT s m ())
-> (Node d i r s m -> STT s m ()) -> STT s m ()
forall a b. (a -> b) -> a -> b
$ \Node d i r s m
node -> JustRule d i r s m -> STRef s [JustRule d i r s m] -> STT s m ()
forall (m :: * -> *) a s. Monad m => a -> STRef s [a] -> STT s m ()
push JustRule d i r s m
just (STRef s [JustRule d i r s m] -> STT s m ())
-> STRef s [JustRule d i r s m] -> STT s m ()
forall a b. (a -> b) -> a -> b
$ Node d i r s m -> STRef s [JustRule d i r s m]
forall d i r s (m :: * -> *).
(Monad m, NodeDatum d) =>
Node d i r s m -> STRef s [JustRule d i r s m]
nodeConsequences Node d i r s m
node
STT s m () -> ATMST s m ()
forall (m :: * -> *) s r. Monad m => STT s m r -> ATMST s m r
sttLayer (STT s m () -> ATMST s m ()) -> STT s m () -> ATMST s m ()
forall a b. (a -> b) -> a -> b
$ JustRule d i r s m -> STRef s [JustRule d i r s m] -> STT s m ()
forall (m :: * -> *) a s. Monad m => a -> STRef s [a] -> STT s m ()
push JustRule d i r s m
just (STRef s [JustRule d i r s m] -> STT s m ())
-> STRef s [JustRule d i r s m] -> STT s m ()
forall a b. (a -> b) -> a -> b
$ ATMS d i r s m -> STRef s [JustRule d i r s m]
forall d i r s (m :: * -> *).
(Monad m, NodeDatum d) =>
ATMS d i r s m -> STRef s [JustRule d i r s m]
atmsJusts ATMS d i r s m
atms
Env d i r s m
emptyEnv <- ATMS d i r s m -> ATMST s m (Env d i r s m)
forall (m :: * -> *) d i r s.
(Monad m, NodeDatum d) =>
ATMS d i r s m -> ATMST s m (Env d i r s m)
getEmptyEnvironment ATMS d i r s m
atms
MList s (Maybe (Env d i r s m))
envListRef <- STT s m (MList s (Maybe (Env d i r s m)))
-> ATMST s m (MList s (Maybe (Env d i r s m)))
forall (m :: * -> *) s r. Monad m => STT s m r -> ATMST s m r
sttLayer (STT s m (MList s (Maybe (Env d i r s m)))
-> ATMST s m (MList s (Maybe (Env d i r s m))))
-> STT s m (MList s (Maybe (Env d i r s m)))
-> ATMST s m (MList s (Maybe (Env d i r s m)))
forall a b. (a -> b) -> a -> b
$ (Env d i r s m -> Maybe (Env d i r s m))
-> [Env d i r s m] -> STT s m (MList s (Maybe (Env d i r s m)))
forall (m :: * -> *) a b s.
Monad m =>
(a -> b) -> [a] -> STT s m (MList s b)
fromListMap Env d i r s m -> Maybe (Env d i r s m)
forall a. a -> Maybe a
Just [Env d i r s m
emptyEnv]
JustRule d i r s m
-> Maybe (Node d i r s m)
-> MList s (Maybe (Env d i r s m))
-> ATMST s m ()
forall (m :: * -> *) d i r s.
(Debuggable m, NodeDatum d) =>
JustRule d i r s m
-> Maybe (Node d i r s m)
-> MList s (Maybe (Env d i r s m))
-> ATMST s m ()
propagate JustRule d i r s m
just Maybe (Node d i r s m)
forall a. Maybe a
Nothing MList s (Maybe (Env d i r s m))
envListRef
nogoodNodes :: (Monad m, NodeDatum d) => i -> [Node d i r s m] -> ATMST s m ()
nogoodNodes :: i -> [Node d i r s m] -> ATMST s m ()
nogoodNodes i
informant [Node d i r s m]
nodes = do
Node d i r s m
contra <- ATMS d i r s m -> ATMST s m (Node d i r s m)
forall (m :: * -> *) d i r s.
(Monad m, NodeDatum d) =>
ATMS d i r s m -> ATMST s m (Node d i r s m)
getContradictionNode (Node d i r s m -> ATMS d i r s m
forall d i r s (m :: * -> *).
(Monad m, NodeDatum d) =>
Node d i r s m -> ATMS d i r s m
nodeATMS ([Node d i r s m] -> Node d i r s m
forall a. [a] -> a
head [Node d i r s m]
nodes))
i -> Node d i r s m -> [Node d i r s m] -> ATMST s m ()
forall (m :: * -> *) d i r s.
(Debuggable m, NodeDatum d) =>
i -> Node d i r s m -> [Node d i r s m] -> ATMST s m ()
justifyNode i
informant Node d i r s m
contra [Node d i r s m]
nodes
propagate ::
(Debuggable m, NodeDatum d) =>
JustRule d i r s m ->
Maybe (Node d i r s m) ->
MList s (Maybe (Env d i r s m)) ->
ATMST s m ()
propagate :: JustRule d i r s m
-> Maybe (Node d i r s m)
-> MList s (Maybe (Env d i r s m))
-> ATMST s m ()
propagate JustRule d i r s m
just Maybe (Node d i r s m)
antecedent MList s (Maybe (Env d i r s m))
envs = do
$(dbg [| debugPropagateArgs just antecedent envs |])
MList s (Maybe (Env d i r s m))
newEnvs <- Maybe (Node d i r s m)
-> MList s (Maybe (Env d i r s m))
-> [Node d i r s m]
-> ATMST s m (MList s (Maybe (Env d i r s m)))
forall (m :: * -> *) d i r s.
(Debuggable m, NodeDatum d) =>
Maybe (Node d i r s m)
-> MList s (Maybe (Env d i r s m))
-> [Node d i r s m]
-> ATMST s m (MList s (Maybe (Env d i r s m)))
weave Maybe (Node d i r s m)
antecedent MList s (Maybe (Env d i r s m))
envs (JustRule d i r s m -> [Node d i r s m]
forall d i r s (m :: * -> *).
(Monad m, NodeDatum d) =>
JustRule d i r s m -> [Node d i r s m]
justAntecedents JustRule d i r s m
just)
Bool -> ATMST s m () -> ATMST s m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Bool -> Bool
not (MList s (Maybe (Env d i r s m)) -> Bool
forall s a. MList s a -> Bool
mnull MList s (Maybe (Env d i r s m))
newEnvs)) (ATMST s m () -> ATMST s m ()) -> ATMST s m () -> ATMST s m ()
forall a b. (a -> b) -> a -> b
$ do
MList s (Maybe (Env d i r s m))
-> Node d i r s m -> Justification d i r s m -> ATMST s m ()
forall (m :: * -> *) d s i r.
(Debuggable m, NodeDatum d) =>
MList s (Maybe (Env d i r s m))
-> Node d i r s m -> Justification d i r s m -> ATMST s m ()
update MList s (Maybe (Env d i r s m))
newEnvs (JustRule d i r s m -> Node d i r s m
forall d i r s (m :: * -> *).
(Monad m, NodeDatum d) =>
JustRule d i r s m -> Node d i r s m
justConsequence JustRule d i r s m
just) (JustRule d i r s m -> Justification d i r s m
forall d i r s (m :: * -> *).
JustRule d i r s m -> Justification d i r s m
ByRule JustRule d i r s m
just)
debugPropagateArgs ::
(MonadIO m, NodeDatum d) =>
JustRule d i r s m ->
Maybe (Node d i r s m) ->
MList s (Maybe (Env d i r s m)) ->
ATMST s m ()
debugPropagateArgs :: JustRule d i r s m
-> Maybe (Node d i r s m)
-> MList s (Maybe (Env d i r s m))
-> ATMST s m ()
debugPropagateArgs JustRule d i r s m
justRule Maybe (Node d i r s m)
antecedent MList s (Maybe (Env d i r s m))
envs = do
IO () -> ATMST s m ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> ATMST s m ()) -> IO () -> ATMST s m ()
forall a b. (a -> b) -> a -> b
$ String -> IO ()
putStrLn String
"Calling propagate with"
let atms :: ATMS d i r s m
atms = Node d i r s m -> ATMS d i r s m
forall d i r s (m :: * -> *).
(Monad m, NodeDatum d) =>
Node d i r s m -> ATMS d i r s m
nodeATMS (Node d i r s m -> ATMS d i r s m)
-> Node d i r s m -> ATMS d i r s m
forall a b. (a -> b) -> a -> b
$ JustRule d i r s m -> Node d i r s m
forall d i r s (m :: * -> *).
(Monad m, NodeDatum d) =>
JustRule d i r s m -> Node d i r s m
justConsequence JustRule d i r s m
justRule
IO () -> ATMST s m ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> ATMST s m ()) -> IO () -> ATMST s m ()
forall a b. (a -> b) -> a -> b
$ String -> IO ()
putStr String
". Just: "
JustRule d i r s m -> ATMST s m ()
forall (m :: * -> *) d i r s.
(MonadIO m, NodeDatum d) =>
JustRule d i r s m -> ATMST s m ()
debugJust JustRule d i r s m
justRule
case Maybe (Node d i r s m)
antecedent of
Just Node d i r s m
n -> Node d i r s m -> ATMST s m ()
forall (m :: * -> *) d i r s.
(MonadIO m, NodeDatum d) =>
Node d i r s m -> ATMST s m ()
debugNode Node d i r s m
n
Maybe (Node d i r s m)
Nothing -> IO () -> ATMST s m ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> ATMST s m ()) -> IO () -> ATMST s m ()
forall a b. (a -> b) -> a -> b
$ String -> IO ()
putStrLn String
". No antecedent"
Int
envLen <- STT s m Int -> ATMST s m Int
forall (m :: * -> *) s r. Monad m => STT s m r -> ATMST s m r
sttLayer (STT s m Int -> ATMST s m Int) -> STT s m Int -> ATMST s m Int
forall a b. (a -> b) -> a -> b
$ MList s (Maybe (Env d i r s m)) -> STT s m Int
forall (m :: * -> *) s a. Monad m => MList s a -> STT s m Int
mlength MList s (Maybe (Env d i r s m))
envs
case Int
envLen of
Int
0 -> IO () -> ATMST s m ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> ATMST s m ()) -> IO () -> ATMST s m ()
forall a b. (a -> b) -> a -> b
$ String -> IO ()
putStrLn String
". No envs"
Int
1 -> do
IO () -> ATMST s m ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> ATMST s m ()) -> IO () -> ATMST s m ()
forall a b. (a -> b) -> a -> b
$ String -> IO ()
putStrLn String
". Env: "
Maybe (Env d i r s m)
envm <- STT s m (Maybe (Env d i r s m))
-> ATMST s m (Maybe (Env d i r s m))
forall (m :: * -> *) s r. Monad m => STT s m r -> ATMST s m r
sttLayer (STT s m (Maybe (Env d i r s m))
-> ATMST s m (Maybe (Env d i r s m)))
-> STT s m (Maybe (Env d i r s m))
-> ATMST s m (Maybe (Env d i r s m))
forall a b. (a -> b) -> a -> b
$ MList s (Maybe (Env d i r s m)) -> STT s m (Maybe (Env d i r s m))
forall (m :: * -> *) s a. Applicative m => MList s a -> STT s m a
mcar MList s (Maybe (Env d i r s m))
envs
case Maybe (Env d i r s m)
envm of
Maybe (Env d i r s m)
Nothing -> IO () -> ATMST s m ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> ATMST s m ()) -> IO () -> ATMST s m ()
forall a b. (a -> b) -> a -> b
$ String -> IO ()
putStrLn String
"<nulled out>"
Just Env d i r s m
env -> Env d i r s m -> ATMST s m ()
forall (m :: * -> *) d i r s.
(MonadIO m, NodeDatum d) =>
Env d i r s m -> ATMST s m ()
debugEnv Env d i r s m
env
Int
_ -> do
IO () -> ATMST s m ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> ATMST s m ()) -> IO () -> ATMST s m ()
forall a b. (a -> b) -> a -> b
$ String -> IO ()
putStrLn String
". Envs:"
(forall r. STT s m r -> ATMST s m r)
-> MList s (Maybe (Env d i r s m))
-> (Maybe (Env d i r s m) -> ATMST s m ())
-> ATMST s m ()
forall (m0 :: * -> *) (m :: * -> *) s a.
(Monad m0, Monad m) =>
(forall r. STT s m0 r -> m r) -> MList s a -> (a -> m ()) -> m ()
mlistFor_ forall r. STT s m r -> ATMST s m r
forall (m :: * -> *) s r. Monad m => STT s m r -> ATMST s m r
sttLayer MList s (Maybe (Env d i r s m))
envs ((Maybe (Env d i r s m) -> ATMST s m ()) -> ATMST s m ())
-> (Maybe (Env d i r s m) -> ATMST s m ()) -> ATMST s m ()
forall a b. (a -> b) -> a -> b
$ \Maybe (Env d i r s m)
em -> do
IO () -> ATMST s m ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> ATMST s m ()) -> IO () -> ATMST s m ()
forall a b. (a -> b) -> a -> b
$ String -> IO ()
putStr String
" . "
case Maybe (Env d i r s m)
em of
Just Env d i r s m
e -> Env d i r s m -> ATMST s m ()
forall (m :: * -> *) d i r s.
(MonadIO m, NodeDatum d) =>
Env d i r s m -> ATMST s m ()
debugEnv Env d i r s m
e
Maybe (Env d i r s m)
Nothing -> IO () -> ATMST s m ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> ATMST s m ()) -> IO () -> ATMST s m ()
forall a b. (a -> b) -> a -> b
$ String -> IO ()
putStrLn String
"<nulled out>"
update ::
(Debuggable m, NodeDatum d) =>
MList s (Maybe (Env d i r s m)) ->
Node d i r s m ->
Justification d i r s m ->
ATMST s m ()
update :: MList s (Maybe (Env d i r s m))
-> Node d i r s m -> Justification d i r s m -> ATMST s m ()
update MList s (Maybe (Env d i r s m))
newEnvs Node d i r s m
consequence Justification d i r s m
just = do
$(dbg [| debugUpdateArgs newEnvs consequence just |])
let atms :: ATMS d i r s m
atms = Node d i r s m -> ATMS d i r s m
forall d i r s (m :: * -> *).
(Monad m, NodeDatum d) =>
Node d i r s m -> ATMS d i r s m
nodeATMS Node d i r s m
consequence
ATMST s m Bool -> ATMST s m () -> ATMST s m () -> ATMST s m ()
forall (m :: * -> *) a. Monad m => m Bool -> m a -> m a -> m a
ifM (Node d i r s m -> ATMST s m Bool
forall (m :: * -> *) d i r s.
(Monad m, NodeDatum d) =>
Node d i r s m -> ATMST s m Bool
getNodeIsContradictory Node d i r s m
consequence)
((forall r. STT s m r -> ATMST s m r)
-> MList s (Maybe (Env d i r s m))
-> (Maybe (Env d i r s m) -> ATMST s m ())
-> ATMST s m ()
forall (m0 :: * -> *) (m :: * -> *) s a.
(Monad m0, Monad m) =>
(forall r. STT s m0 r -> m r) -> MList s a -> (a -> m ()) -> m ()
mlistFor_ forall r. STT s m r -> ATMST s m r
forall (m :: * -> *) s r. Monad m => STT s m r -> ATMST s m r
sttLayer MList s (Maybe (Env d i r s m))
newEnvs ((Maybe (Env d i r s m) -> ATMST s m ()) -> ATMST s m ())
-> (Maybe (Env d i r s m) -> ATMST s m ()) -> ATMST s m ()
forall a b. (a -> b) -> a -> b
$ \ Maybe (Env d i r s m)
envmaybe ->
case Maybe (Env d i r s m)
envmaybe of
Maybe (Env d i r s m)
Nothing -> () -> ATMST s m ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
Just Env d i r s m
env -> ATMS d i r s m
-> Env d i r s m -> Justification d i r s m -> ATMST s m ()
forall (m :: * -> *) d i r s.
(Debuggable m, NodeDatum d) =>
ATMS d i r s m
-> Env d i r s m -> Justification d i r s m -> ATMST s m ()
newNogood ATMS d i r s m
atms Env d i r s m
env Justification d i r s m
just) (ATMST s m () -> ATMST s m ()) -> ATMST s m () -> ATMST s m ()
forall a b. (a -> b) -> a -> b
$
do MList s (Maybe (Env d i r s m))
revNewEnvs <- Node d i r s m
-> MList s (Maybe (Env d i r s m))
-> ATMST s m (MList s (Maybe (Env d i r s m)))
forall (m :: * -> *) d i r s.
(Debuggable m, NodeDatum d) =>
Node d i r s m
-> MList s (Maybe (Env d i r s m))
-> ATMST s m (MList s (Maybe (Env d i r s m)))
updateLabel Node d i r s m
consequence MList s (Maybe (Env d i r s m))
newEnvs
STRef s (MList s (Maybe (Env d i r s m)))
newEnvsRef <- STT s m (STRef s (MList s (Maybe (Env d i r s m))))
-> ATMST s m (STRef s (MList s (Maybe (Env d i r s m))))
forall (m :: * -> *) s r. Monad m => STT s m r -> ATMST s m r
sttLayer (STT s m (STRef s (MList s (Maybe (Env d i r s m))))
-> ATMST s m (STRef s (MList s (Maybe (Env d i r s m)))))
-> STT s m (STRef s (MList s (Maybe (Env d i r s m))))
-> ATMST s m (STRef s (MList s (Maybe (Env d i r s m))))
forall a b. (a -> b) -> a -> b
$ MList s (Maybe (Env d i r s m))
-> STT s m (STRef s (MList s (Maybe (Env d i r s m))))
forall (m :: * -> *) a s. Applicative m => a -> STT s m (STRef s a)
newSTRef (MList s (Maybe (Env d i r s m))
-> STT s m (STRef s (MList s (Maybe (Env d i r s m)))))
-> MList s (Maybe (Env d i r s m))
-> STT s m (STRef s (MList s (Maybe (Env d i r s m))))
forall a b. (a -> b) -> a -> b
$ MList s (Maybe (Env d i r s m))
revNewEnvs
ATMST s m Bool -> ATMST s m () -> ATMST s m () -> ATMST s m ()
forall (m :: * -> *) a. Monad m => m Bool -> m a -> m a -> m a
ifM (STT s m Bool -> ATMST s m Bool
forall (m :: * -> *) s r. Monad m => STT s m r -> ATMST s m r
sttLayer (STT s m Bool -> ATMST s m Bool) -> STT s m Bool -> ATMST s m Bool
forall a b. (a -> b) -> a -> b
$ STRef s (MList s (Maybe (Env d i r s m))) -> STT s m Bool
forall (m :: * -> *) s a.
Monad m =>
STRef s (MList s a) -> STT s m Bool
getMnull STRef s (MList s (Maybe (Env d i r s m)))
newEnvsRef) (() -> ATMST s m ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()) (ATMST s m () -> ATMST s m ()) -> ATMST s m () -> ATMST s m ()
forall a b. (a -> b) -> a -> b
$ do
r -> ATMST s m ()
enqueuef <- ATMS d i r s m -> ATMST s m (r -> ATMST s m ())
forall (m :: * -> *) d i r s.
(Monad m, NodeDatum d) =>
ATMS d i r s m -> ATMST s m (r -> ATMST s m ())
getEnqueueProcedure ATMS d i r s m
atms
ATMST s m [r] -> (r -> ATMST s m ()) -> ATMST s m ()
forall (m :: * -> *) (t :: * -> *) a.
(Monad m, Foldable t) =>
m (t a) -> (a -> m ()) -> m ()
forMM_ (Node d i r s m -> ATMST s m [r]
forall (m :: * -> *) d i r s.
(Monad m, NodeDatum d) =>
Node d i r s m -> ATMST s m [r]
getNodeRules Node d i r s m
consequence) ((r -> ATMST s m ()) -> ATMST s m ())
-> (r -> ATMST s m ()) -> ATMST s m ()
forall a b. (a -> b) -> a -> b
$ r -> ATMST s m ()
enqueuef
ATMST s m [JustRule d i r s m]
-> ATMST s m Bool
-> (JustRule d i r s m -> ATMST s m ())
-> ATMST s m ()
forall (m :: * -> *) a.
Monad m =>
m [a] -> m Bool -> (a -> m ()) -> m ()
forMMwhile_ (Node d i r s m -> ATMST s m [JustRule d i r s m]
forall (m :: * -> *) d i r s.
(Monad m, NodeDatum d) =>
Node d i r s m -> ATMST s m [JustRule d i r s m]
getNodeConsequences Node d i r s m
consequence)
(STT s m Bool -> ATMST s m Bool
forall (m :: * -> *) s r. Monad m => STT s m r -> ATMST s m r
sttLayer (STT s m Bool -> ATMST s m Bool) -> STT s m Bool -> ATMST s m Bool
forall a b. (a -> b) -> a -> b
$ STT s m Bool -> STT s m Bool
forall (m :: * -> *). Functor m => m Bool -> m Bool
notM (STT s m Bool -> STT s m Bool) -> STT s m Bool -> STT s m Bool
forall a b. (a -> b) -> a -> b
$ STRef s (MList s (Maybe (Env d i r s m))) -> STT s m Bool
forall (m :: * -> *) s a.
Monad m =>
STRef s (MList s a) -> STT s m Bool
getMnull STRef s (MList s (Maybe (Env d i r s m)))
newEnvsRef) ((JustRule d i r s m -> ATMST s m ()) -> ATMST s m ())
-> (JustRule d i r s m -> ATMST s m ()) -> ATMST s m ()
forall a b. (a -> b) -> a -> b
$ \ JustRule d i r s m
supportedJust -> do
MList s (Maybe (Env d i r s m))
currentNewEnvs <- STT s m (MList s (Maybe (Env d i r s m)))
-> ATMST s m (MList s (Maybe (Env d i r s m)))
forall (m :: * -> *) s r. Monad m => STT s m r -> ATMST s m r
sttLayer (STT s m (MList s (Maybe (Env d i r s m)))
-> ATMST s m (MList s (Maybe (Env d i r s m))))
-> STT s m (MList s (Maybe (Env d i r s m)))
-> ATMST s m (MList s (Maybe (Env d i r s m)))
forall a b. (a -> b) -> a -> b
$ STRef s (MList s (Maybe (Env d i r s m)))
-> STT s m (MList s (Maybe (Env d i r s m)))
forall (m :: * -> *) s a. Applicative m => STRef s a -> STT s m a
readSTRef STRef s (MList s (Maybe (Env d i r s m)))
newEnvsRef
JustRule d i r s m
-> Maybe (Node d i r s m)
-> MList s (Maybe (Env d i r s m))
-> ATMST s m ()
forall (m :: * -> *) d i r s.
(Debuggable m, NodeDatum d) =>
JustRule d i r s m
-> Maybe (Node d i r s m)
-> MList s (Maybe (Env d i r s m))
-> ATMST s m ()
propagate JustRule d i r s m
supportedJust (Node d i r s m -> Maybe (Node d i r s m)
forall a. a -> Maybe a
Just Node d i r s m
consequence) MList s (Maybe (Env d i r s m))
newEnvs
(forall r. STT s m r -> ATMST s m r)
-> MList s (Maybe (Env d i r s m))
-> (MList s (Maybe (Env d i r s m)) -> ATMST s m ())
-> ATMST s m ()
forall (m0 :: * -> *) (m :: * -> *) s a.
(Monad m0, Monad m) =>
(forall r. STT s m0 r -> m r)
-> MList s a -> (MList s a -> m ()) -> m ()
mlistForCons_ forall r. STT s m r -> ATMST s m r
forall (m :: * -> *) s r. Monad m => STT s m r -> ATMST s m r
sttLayer MList s (Maybe (Env d i r s m))
newEnvs ((MList s (Maybe (Env d i r s m)) -> ATMST s m ()) -> ATMST s m ())
-> (MList s (Maybe (Env d i r s m)) -> ATMST s m ())
-> ATMST s m ()
forall a b. (a -> b) -> a -> b
$ \ MList s (Maybe (Env d i r s m))
mcons -> do
Maybe (Env d i r s m)
thisEnvMaybe <- STT s m (Maybe (Env d i r s m))
-> ATMST s m (Maybe (Env d i r s m))
forall (m :: * -> *) s r. Monad m => STT s m r -> ATMST s m r
sttLayer (STT s m (Maybe (Env d i r s m))
-> ATMST s m (Maybe (Env d i r s m)))
-> STT s m (Maybe (Env d i r s m))
-> ATMST s m (Maybe (Env d i r s m))
forall a b. (a -> b) -> a -> b
$ MList s (Maybe (Env d i r s m)) -> STT s m (Maybe (Env d i r s m))
forall (m :: * -> *) s a. Applicative m => MList s a -> STT s m a
mcar MList s (Maybe (Env d i r s m))
mcons
case Maybe (Env d i r s m)
thisEnvMaybe of
Just Env d i r s m
thisEnv -> do
[Env d i r s m]
label <- Node d i r s m -> ATMST s m [Env d i r s m]
forall (m :: * -> *) d i r s.
(Monad m, NodeDatum d) =>
Node d i r s m -> ATMST s m [Env d i r s m]
getNodeLabel Node d i r s m
consequence
Bool -> ATMST s m () -> ATMST s m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (Env d i r s m -> [Env d i r s m] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
elem Env d i r s m
thisEnv [Env d i r s m]
label) (ATMST s m () -> ATMST s m ()) -> ATMST s m () -> ATMST s m ()
forall a b. (a -> b) -> a -> b
$
STT s m () -> ATMST s m ()
forall (m :: * -> *) s r. Monad m => STT s m r -> ATMST s m r
sttLayer (STT s m () -> ATMST s m ()) -> STT s m () -> ATMST s m ()
forall a b. (a -> b) -> a -> b
$ MList s (Maybe (Env d i r s m))
-> Maybe (Env d i r s m) -> STT s m ()
forall (m :: * -> *) s a. Monad m => MList s a -> a -> STT s m ()
rplaca MList s (Maybe (Env d i r s m))
mcons Maybe (Env d i r s m)
forall a. Maybe a
Nothing
Maybe (Env d i r s m)
Nothing -> () -> ATMST s m ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
MList s (Maybe (Env d i r s m))
cleanedNewEnvs <- STT s m (MList s (Maybe (Env d i r s m)))
-> ATMST s m (MList s (Maybe (Env d i r s m)))
forall (m :: * -> *) s r. Monad m => STT s m r -> ATMST s m r
sttLayer (STT s m (MList s (Maybe (Env d i r s m)))
-> ATMST s m (MList s (Maybe (Env d i r s m))))
-> STT s m (MList s (Maybe (Env d i r s m)))
-> ATMST s m (MList s (Maybe (Env d i r s m)))
forall a b. (a -> b) -> a -> b
$ STRef s (MList s (Maybe (Env d i r s m)))
-> STT s m (MList s (Maybe (Env d i r s m)))
forall (m :: * -> *) s a.
Monad m =>
STRef s (MList s (Maybe a)) -> STT s m (MList s (Maybe a))
getMlistStripNothing STRef s (MList s (Maybe (Env d i r s m)))
newEnvsRef
STT s m () -> ATMST s m ()
forall (m :: * -> *) s r. Monad m => STT s m r -> ATMST s m r
sttLayer (STT s m () -> ATMST s m ()) -> STT s m () -> ATMST s m ()
forall a b. (a -> b) -> a -> b
$ STRef s (MList s (Maybe (Env d i r s m)))
-> MList s (Maybe (Env d i r s m)) -> STT s m ()
forall (m :: * -> *) s a.
Applicative m =>
STRef s a -> a -> STT s m ()
writeSTRef STRef s (MList s (Maybe (Env d i r s m)))
newEnvsRef MList s (Maybe (Env d i r s m))
cleanedNewEnvs
debugUpdateArgs ::
(MonadIO m, NodeDatum d) =>
MList s (Maybe (Env d i r s m)) ->
Node d i r s m ->
JustRule d i r s m ->
ATMST s m ()
debugUpdateArgs :: MList s (Maybe (Env d i r s m))
-> Node d i r s m -> JustRule d i r s m -> ATMST s m ()
debugUpdateArgs MList s (Maybe (Env d i r s m))
envs Node d i r s m
consequence JustRule d i r s m
justRule = do
IO () -> ATMST s m ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> ATMST s m ()) -> IO () -> ATMST s m ()
forall a b. (a -> b) -> a -> b
$ String -> IO ()
putStrLn String
"Calling update with"
let atms :: ATMS d i r s m
atms = Node d i r s m -> ATMS d i r s m
forall d i r s (m :: * -> *).
(Monad m, NodeDatum d) =>
Node d i r s m -> ATMS d i r s m
nodeATMS (Node d i r s m -> ATMS d i r s m)
-> Node d i r s m -> ATMS d i r s m
forall a b. (a -> b) -> a -> b
$ JustRule d i r s m -> Node d i r s m
forall d i r s (m :: * -> *).
(Monad m, NodeDatum d) =>
JustRule d i r s m -> Node d i r s m
justConsequence JustRule d i r s m
justRule
Int
envLen <- STT s m Int -> ATMST s m Int
forall (m :: * -> *) s r. Monad m => STT s m r -> ATMST s m r
sttLayer (STT s m Int -> ATMST s m Int) -> STT s m Int -> ATMST s m Int
forall a b. (a -> b) -> a -> b
$ MList s (Maybe (Env d i r s m)) -> STT s m Int
forall (m :: * -> *) s a. Monad m => MList s a -> STT s m Int
mlength MList s (Maybe (Env d i r s m))
envs
case Int
envLen of
Int
0 -> IO () -> ATMST s m ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> ATMST s m ()) -> IO () -> ATMST s m ()
forall a b. (a -> b) -> a -> b
$ String -> IO ()
putStrLn String
". No envs"
Int
1 -> do
IO () -> ATMST s m ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> ATMST s m ()) -> IO () -> ATMST s m ()
forall a b. (a -> b) -> a -> b
$ String -> IO ()
putStr String
". Env: "
Maybe (Env d i r s m)
envm <- STT s m (Maybe (Env d i r s m))
-> ATMST s m (Maybe (Env d i r s m))
forall (m :: * -> *) s r. Monad m => STT s m r -> ATMST s m r
sttLayer (STT s m (Maybe (Env d i r s m))
-> ATMST s m (Maybe (Env d i r s m)))
-> STT s m (Maybe (Env d i r s m))
-> ATMST s m (Maybe (Env d i r s m))
forall a b. (a -> b) -> a -> b
$ MList s (Maybe (Env d i r s m)) -> STT s m (Maybe (Env d i r s m))
forall (m :: * -> *) s a. Applicative m => MList s a -> STT s m a
mcar MList s (Maybe (Env d i r s m))
envs
case Maybe (Env d i r s m)
envm of
Maybe (Env d i r s m)
Nothing -> IO () -> ATMST s m ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> ATMST s m ()) -> IO () -> ATMST s m ()
forall a b. (a -> b) -> a -> b
$ String -> IO ()
putStrLn String
"<nulled out>"
Just Env d i r s m
env -> Env d i r s m -> ATMST s m ()
forall (m :: * -> *) d i r s.
(MonadIO m, NodeDatum d) =>
Env d i r s m -> ATMST s m ()
debugEnv Env d i r s m
env
Int
_ -> do
IO () -> ATMST s m ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> ATMST s m ()) -> IO () -> ATMST s m ()
forall a b. (a -> b) -> a -> b
$ String -> IO ()
putStrLn String
". Envs:"
(forall r. STT s m r -> ATMST s m r)
-> MList s (Maybe (Env d i r s m))
-> (Maybe (Env d i r s m) -> ATMST s m ())
-> ATMST s m ()
forall (m0 :: * -> *) (m :: * -> *) s a.
(Monad m0, Monad m) =>
(forall r. STT s m0 r -> m r) -> MList s a -> (a -> m ()) -> m ()
mlistFor_ forall r. STT s m r -> ATMST s m r
forall (m :: * -> *) s r. Monad m => STT s m r -> ATMST s m r
sttLayer MList s (Maybe (Env d i r s m))
envs ((Maybe (Env d i r s m) -> ATMST s m ()) -> ATMST s m ())
-> (Maybe (Env d i r s m) -> ATMST s m ()) -> ATMST s m ()
forall a b. (a -> b) -> a -> b
$ \Maybe (Env d i r s m)
em -> do
IO () -> ATMST s m ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> ATMST s m ()) -> IO () -> ATMST s m ()
forall a b. (a -> b) -> a -> b
$ String -> IO ()
putStr String
" . "
case Maybe (Env d i r s m)
em of
Just Env d i r s m
e -> Env d i r s m -> ATMST s m ()
forall (m :: * -> *) d i r s.
(MonadIO m, NodeDatum d) =>
Env d i r s m -> ATMST s m ()
debugEnv Env d i r s m
e
Maybe (Env d i r s m)
Nothing -> IO () -> ATMST s m ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> ATMST s m ()) -> IO () -> ATMST s m ()
forall a b. (a -> b) -> a -> b
$ String -> IO ()
putStrLn String
"<nulled out>"
IO () -> ATMST s m ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> ATMST s m ()) -> IO () -> ATMST s m ()
forall a b. (a -> b) -> a -> b
$ String -> IO ()
putStr String
". Consequence: "
Node d i r s m -> ATMST s m ()
forall (m :: * -> *) d i r s.
(MonadIO m, NodeDatum d) =>
Node d i r s m -> ATMST s m ()
blurbNode Node d i r s m
consequence
IO () -> ATMST s m ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> ATMST s m ()) -> IO () -> ATMST s m ()
forall a b. (a -> b) -> a -> b
$ String -> IO ()
putStrLn String
""
IO () -> ATMST s m ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> ATMST s m ()) -> IO () -> ATMST s m ()
forall a b. (a -> b) -> a -> b
$ String -> IO ()
putStr String
". Just: "
JustRule d i r s m -> ATMST s m ()
forall (m :: * -> *) d i r s.
(MonadIO m, NodeDatum d) =>
JustRule d i r s m -> ATMST s m ()
debugJust JustRule d i r s m
justRule
updateLabel ::
(Debuggable m, NodeDatum d) =>
Node d i r s m -> MList s (Maybe (Env d i r s m)) ->
ATMST s m (MList s (Maybe (Env d i r s m)))
updateLabel :: Node d i r s m
-> MList s (Maybe (Env d i r s m))
-> ATMST s m (MList s (Maybe (Env d i r s m)))
updateLabel Node d i r s m
node MList s (Maybe (Env d i r s m))
newEnvs = do
$(dbg [| debugUpdateLabelArgs node newEnvs |])
STRef s (MList s (Maybe (Env d i r s m)))
envsR <- do [Env d i r s m]
labels <- Node d i r s m -> ATMST s m [Env d i r s m]
forall (m :: * -> *) d i r s.
(Monad m, NodeDatum d) =>
Node d i r s m -> ATMST s m [Env d i r s m]
getNodeLabel Node d i r s m
node
MList s (Maybe (Env d i r s m))
envs <- STT s m (MList s (Maybe (Env d i r s m)))
-> ATMST s m (MList s (Maybe (Env d i r s m)))
forall (m :: * -> *) s r. Monad m => STT s m r -> ATMST s m r
sttLayer (STT s m (MList s (Maybe (Env d i r s m)))
-> ATMST s m (MList s (Maybe (Env d i r s m))))
-> STT s m (MList s (Maybe (Env d i r s m)))
-> ATMST s m (MList s (Maybe (Env d i r s m)))
forall a b. (a -> b) -> a -> b
$ (Env d i r s m -> Maybe (Env d i r s m))
-> [Env d i r s m] -> STT s m (MList s (Maybe (Env d i r s m)))
forall (m :: * -> *) a b s.
Monad m =>
(a -> b) -> [a] -> STT s m (MList s b)
fromListMap Env d i r s m -> Maybe (Env d i r s m)
forall a. a -> Maybe a
Just [Env d i r s m]
labels
STT s m (STRef s (MList s (Maybe (Env d i r s m))))
-> ATMST s m (STRef s (MList s (Maybe (Env d i r s m))))
forall (m :: * -> *) s r. Monad m => STT s m r -> ATMST s m r
sttLayer (STT s m (STRef s (MList s (Maybe (Env d i r s m))))
-> ATMST s m (STRef s (MList s (Maybe (Env d i r s m)))))
-> STT s m (STRef s (MList s (Maybe (Env d i r s m))))
-> ATMST s m (STRef s (MList s (Maybe (Env d i r s m))))
forall a b. (a -> b) -> a -> b
$ MList s (Maybe (Env d i r s m))
-> STT s m (STRef s (MList s (Maybe (Env d i r s m))))
forall (m :: * -> *) a s. Applicative m => a -> STT s m (STRef s a)
newSTRef MList s (Maybe (Env d i r s m))
envs
(forall r. STT s m r -> ATMST s m r)
-> MList s (Maybe (Env d i r s m))
-> (MList s (Maybe (Env d i r s m)) -> ATMST s m ())
-> ATMST s m ()
forall (m0 :: * -> *) (m :: * -> *) s a.
(Monad m0, Monad m) =>
(forall r. STT s m0 r -> m r)
-> MList s a -> (MList s a -> m ()) -> m ()
mlistForCons_ forall r. STT s m r -> ATMST s m r
forall (m :: * -> *) s r. Monad m => STT s m r -> ATMST s m r
sttLayer MList s (Maybe (Env d i r s m))
newEnvs ((MList s (Maybe (Env d i r s m)) -> ATMST s m ()) -> ATMST s m ())
-> (MList s (Maybe (Env d i r s m)) -> ATMST s m ())
-> ATMST s m ()
forall a b. (a -> b) -> a -> b
$ \ MList s (Maybe (Env d i r s m))
newEnvCons -> do
Maybe (Env d i r s m)
newEnvCarMaybe <- STT s m (Maybe (Env d i r s m))
-> ATMST s m (Maybe (Env d i r s m))
forall (m :: * -> *) s r. Monad m => STT s m r -> ATMST s m r
sttLayer (STT s m (Maybe (Env d i r s m))
-> ATMST s m (Maybe (Env d i r s m)))
-> STT s m (Maybe (Env d i r s m))
-> ATMST s m (Maybe (Env d i r s m))
forall a b. (a -> b) -> a -> b
$ MList s (Maybe (Env d i r s m)) -> STT s m (Maybe (Env d i r s m))
forall (m :: * -> *) s a. Applicative m => MList s a -> STT s m a
mcar MList s (Maybe (Env d i r s m))
newEnvCons
case Maybe (Env d i r s m)
newEnvCarMaybe of
Maybe (Env d i r s m)
Nothing -> () -> ATMST s m ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
Just Env d i r s m
newEnvCar -> do
MList s (Maybe (Env d i r s m))
thisEnvs <- STT s m (MList s (Maybe (Env d i r s m)))
-> ATMST s m (MList s (Maybe (Env d i r s m)))
forall (m :: * -> *) s r. Monad m => STT s m r -> ATMST s m r
sttLayer (STT s m (MList s (Maybe (Env d i r s m)))
-> ATMST s m (MList s (Maybe (Env d i r s m))))
-> STT s m (MList s (Maybe (Env d i r s m)))
-> ATMST s m (MList s (Maybe (Env d i r s m)))
forall a b. (a -> b) -> a -> b
$ STRef s (MList s (Maybe (Env d i r s m)))
-> STT s m (MList s (Maybe (Env d i r s m)))
forall (m :: * -> *) s a. Applicative m => STRef s a -> STT s m a
readSTRef STRef s (MList s (Maybe (Env d i r s m)))
envsR
(forall r. STT s m r -> ATMST s m r)
-> MList s (Maybe (Env d i r s m))
-> (MList s (Maybe (Env d i r s m)) -> ATMST s m ())
-> ATMST s m ()
forall (m0 :: * -> *) (m :: * -> *) s a.
(Monad m0, Monad m) =>
(forall r. STT s m0 r -> m r)
-> MList s a -> (MList s a -> m ()) -> m ()
mlistForCons_ forall r. STT s m r -> ATMST s m r
forall (m :: * -> *) s r. Monad m => STT s m r -> ATMST s m r
sttLayer MList s (Maybe (Env d i r s m))
thisEnvs ((MList s (Maybe (Env d i r s m)) -> ATMST s m ()) -> ATMST s m ())
-> (MList s (Maybe (Env d i r s m)) -> ATMST s m ())
-> ATMST s m ()
forall a b. (a -> b) -> a -> b
$ \ MList s (Maybe (Env d i r s m))
nenvCons -> do
Maybe (Env d i r s m)
nenvCarMaybe <- STT s m (Maybe (Env d i r s m))
-> ATMST s m (Maybe (Env d i r s m))
forall (m :: * -> *) s r. Monad m => STT s m r -> ATMST s m r
sttLayer (STT s m (Maybe (Env d i r s m))
-> ATMST s m (Maybe (Env d i r s m)))
-> STT s m (Maybe (Env d i r s m))
-> ATMST s m (Maybe (Env d i r s m))
forall a b. (a -> b) -> a -> b
$ MList s (Maybe (Env d i r s m)) -> STT s m (Maybe (Env d i r s m))
forall (m :: * -> *) s a. Applicative m => MList s a -> STT s m a
mcar MList s (Maybe (Env d i r s m))
nenvCons
case Maybe (Env d i r s m)
nenvCarMaybe of
Maybe (Env d i r s m)
Nothing -> () -> ATMST s m ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
Just Env d i r s m
nenvCar -> do
case Env d i r s m -> Env d i r s m -> EnvCompare
forall (m :: * -> *) d i r s.
(Monad m, NodeDatum d) =>
Env d i r s m -> Env d i r s m -> EnvCompare
compareEnv Env d i r s m
newEnvCar Env d i r s m
nenvCar of
EnvCompare
EQenv -> STT s m () -> ATMST s m ()
forall (m :: * -> *) s r. Monad m => STT s m r -> ATMST s m r
sttLayer (STT s m () -> ATMST s m ()) -> STT s m () -> ATMST s m ()
forall a b. (a -> b) -> a -> b
$ MList s (Maybe (Env d i r s m))
-> Maybe (Env d i r s m) -> STT s m ()
forall (m :: * -> *) s a. Monad m => MList s a -> a -> STT s m ()
rplaca MList s (Maybe (Env d i r s m))
newEnvCons Maybe (Env d i r s m)
forall a. Maybe a
Nothing
EnvCompare
S21env -> STT s m () -> ATMST s m ()
forall (m :: * -> *) s r. Monad m => STT s m r -> ATMST s m r
sttLayer (STT s m () -> ATMST s m ()) -> STT s m () -> ATMST s m ()
forall a b. (a -> b) -> a -> b
$ MList s (Maybe (Env d i r s m))
-> Maybe (Env d i r s m) -> STT s m ()
forall (m :: * -> *) s a. Monad m => MList s a -> a -> STT s m ()
rplaca MList s (Maybe (Env d i r s m))
newEnvCons Maybe (Env d i r s m)
forall a. Maybe a
Nothing
EnvCompare
S12env -> do
[Node d i r s m]
nodeList <- Env d i r s m -> ATMST s m [Node d i r s m]
forall (m :: * -> *) d i r s.
(Monad m, NodeDatum d) =>
Env d i r s m -> ATMST s m [Node d i r s m]
getEnvNodes Env d i r s m
nenvCar
Env d i r s m -> [Node d i r s m] -> ATMST s m ()
forall (m :: * -> *) d i r s.
(Monad m, NodeDatum d) =>
Env d i r s m -> [Node d i r s m] -> ATMST s m ()
setEnvNodes Env d i r s m
nenvCar ([Node d i r s m] -> ATMST s m ())
-> [Node d i r s m] -> ATMST s m ()
forall a b. (a -> b) -> a -> b
$ Node d i r s m -> [Node d i r s m] -> [Node d i r s m]
forall a. Eq a => a -> [a] -> [a]
delete Node d i r s m
node [Node d i r s m]
nodeList
STT s m () -> ATMST s m ()
forall (m :: * -> *) s r. Monad m => STT s m r -> ATMST s m r
sttLayer (STT s m () -> ATMST s m ()) -> STT s m () -> ATMST s m ()
forall a b. (a -> b) -> a -> b
$ MList s (Maybe (Env d i r s m))
-> Maybe (Env d i r s m) -> STT s m ()
forall (m :: * -> *) s a. Monad m => MList s a -> a -> STT s m ()
rplaca MList s (Maybe (Env d i r s m))
nenvCons Maybe (Env d i r s m)
forall a. Maybe a
Nothing
EnvCompare
DisjEnv -> () -> ATMST s m ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
$(dbg [| do liftIO $ putStr " >> pushing onto envs: "
blurbMaybeEnv newEnvCarMaybe
liftIO $ putStrLn "" |])
STT s m () -> ATMST s m ()
forall (m :: * -> *) s r. Monad m => STT s m r -> ATMST s m r
sttLayer (STT s m () -> ATMST s m ()) -> STT s m () -> ATMST s m ()
forall a b. (a -> b) -> a -> b
$ Maybe (Env d i r s m)
-> STRef s (MList s (Maybe (Env d i r s m))) -> STT s m ()
forall (m :: * -> *) a s.
Monad m =>
a -> STRef s (MList s a) -> STT s m ()
mlistRefPush Maybe (Env d i r s m)
newEnvCarMaybe STRef s (MList s (Maybe (Env d i r s m)))
envsR
$(dbg [| do liftIO $ putStr " >> envs: "
blurbMaybeEnvMListRef envsR
liftIO $ putStrLn "" |])
() -> ATMST s m ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
MList s (Maybe (Env d i r s m))
finalNewEnvs <- STT s m (MList s (Maybe (Env d i r s m)))
-> ATMST s m (MList s (Maybe (Env d i r s m)))
forall (m :: * -> *) s r. Monad m => STT s m r -> ATMST s m r
sttLayer (STT s m (MList s (Maybe (Env d i r s m)))
-> ATMST s m (MList s (Maybe (Env d i r s m))))
-> STT s m (MList s (Maybe (Env d i r s m)))
-> ATMST s m (MList s (Maybe (Env d i r s m)))
forall a b. (a -> b) -> a -> b
$ MList s (Maybe (Env d i r s m))
-> STT s m (MList s (Maybe (Env d i r s m)))
forall (m :: * -> *) s a.
Monad m =>
MList s (Maybe a) -> STT s m (MList s (Maybe a))
mlistStripNothing MList s (Maybe (Env d i r s m))
newEnvs
(forall r. STT s m r -> ATMST s m r)
-> MList s (Maybe (Env d i r s m))
-> (Maybe (Env d i r s m) -> ATMST s m ())
-> ATMST s m ()
forall (m0 :: * -> *) (m :: * -> *) s a.
(Monad m0, Monad m) =>
(forall r. STT s m0 r -> m r) -> MList s a -> (a -> m ()) -> m ()
mlistFor_ forall r. STT s m r -> ATMST s m r
forall (m :: * -> *) s r. Monad m => STT s m r -> ATMST s m r
sttLayer MList s (Maybe (Env d i r s m))
finalNewEnvs ((Maybe (Env d i r s m) -> ATMST s m ()) -> ATMST s m ())
-> (Maybe (Env d i r s m) -> ATMST s m ()) -> ATMST s m ()
forall a b. (a -> b) -> a -> b
$ \ Maybe (Env d i r s m)
newEnvMaybe ->
case Maybe (Env d i r s m)
newEnvMaybe of
Just Env d i r s m
newEnv -> STT s m () -> ATMST s m ()
forall (m :: * -> *) s r. Monad m => STT s m r -> ATMST s m r
sttLayer (STT s m () -> ATMST s m ()) -> STT s m () -> ATMST s m ()
forall a b. (a -> b) -> a -> b
$ Node d i r s m -> STRef s [Node d i r s m] -> STT s m ()
forall (m :: * -> *) a s. Monad m => a -> STRef s [a] -> STT s m ()
push Node d i r s m
node (STRef s [Node d i r s m] -> STT s m ())
-> STRef s [Node d i r s m] -> STT s m ()
forall a b. (a -> b) -> a -> b
$ Env d i r s m -> STRef s [Node d i r s m]
forall d i r s (m :: * -> *).
(Monad m, NodeDatum d) =>
Env d i r s m -> STRef s [Node d i r s m]
envNodes Env d i r s m
newEnv
Maybe (Env d i r s m)
_ -> () -> ATMST s m ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
$(dbg [| do liftIO $ putStr " >> envs: "
blurbMaybeEnvMListRef envsR
liftIO $ putStrLn "" |])
MList s (Maybe (Env d i r s m))
envs <- STT s m (MList s (Maybe (Env d i r s m)))
-> ATMST s m (MList s (Maybe (Env d i r s m)))
forall (m :: * -> *) s r. Monad m => STT s m r -> ATMST s m r
sttLayer (STT s m (MList s (Maybe (Env d i r s m)))
-> ATMST s m (MList s (Maybe (Env d i r s m))))
-> STT s m (MList s (Maybe (Env d i r s m)))
-> ATMST s m (MList s (Maybe (Env d i r s m)))
forall a b. (a -> b) -> a -> b
$ STRef s (MList s (Maybe (Env d i r s m)))
-> STT s m (MList s (Maybe (Env d i r s m)))
forall (m :: * -> *) s a. Applicative m => STRef s a -> STT s m a
readSTRef STRef s (MList s (Maybe (Env d i r s m)))
envsR
[Env d i r s m]
updatedLabel <- STT s m [Env d i r s m] -> ATMST s m [Env d i r s m]
forall (m :: * -> *) s r. Monad m => STT s m r -> ATMST s m r
sttLayer (STT s m [Env d i r s m] -> ATMST s m [Env d i r s m])
-> STT s m [Env d i r s m] -> ATMST s m [Env d i r s m]
forall a b. (a -> b) -> a -> b
$ MList s (Maybe (Env d i r s m)) -> STT s m [Env d i r s m]
forall (m :: * -> *) s a.
Monad m =>
MList s (Maybe a) -> STT s m [a]
toUnmaybeList MList s (Maybe (Env d i r s m))
envs
$(dbg [| do liftIO $ putStr " >> updatedLabel: "
blurbEnvList 10000 "" updatedLabel
liftIO $ putStrLn "" |])
Node d i r s m -> [Env d i r s m] -> ATMST s m ()
forall (m :: * -> *) d i r s.
(Monad m, NodeDatum d) =>
Node d i r s m -> [Env d i r s m] -> ATMST s m ()
setNodeLabel Node d i r s m
node [Env d i r s m]
updatedLabel
$(dbg [| debugUpdateLabelFinal node updatedLabel finalNewEnvs |])
MList s (Maybe (Env d i r s m))
-> ATMST s m (MList s (Maybe (Env d i r s m)))
forall (m :: * -> *) a. Monad m => a -> m a
return MList s (Maybe (Env d i r s m))
finalNewEnvs
debugUpdateLabelArgs ::
(MonadIO m, NodeDatum d) =>
Node d i r s m -> MList s (Maybe (Env d i r s m)) -> ATMST s m ()
debugUpdateLabelArgs :: Node d i r s m -> MList s (Maybe (Env d i r s m)) -> ATMST s m ()
debugUpdateLabelArgs Node d i r s m
node MList s (Maybe (Env d i r s m))
newEnvs = do
let atms :: ATMS d i r s m
atms = Node d i r s m -> ATMS d i r s m
forall d i r s (m :: * -> *).
(Monad m, NodeDatum d) =>
Node d i r s m -> ATMS d i r s m
nodeATMS Node d i r s m
node
IO () -> ATMST s m ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> ATMST s m ()) -> IO () -> ATMST s m ()
forall a b. (a -> b) -> a -> b
$ String -> IO ()
putStr String
"Calling updateLabel with node "
Node d i r s m -> ATMST s m ()
forall (m :: * -> *) d i r s.
(MonadIO m, NodeDatum d) =>
Node d i r s m -> ATMST s m ()
blurbNode Node d i r s m
node
IO () -> ATMST s m ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> ATMST s m ()) -> IO () -> ATMST s m ()
forall a b. (a -> b) -> a -> b
$ String -> IO ()
putStrLn String
""
Int
envLen <- STT s m Int -> ATMST s m Int
forall (m :: * -> *) s r. Monad m => STT s m r -> ATMST s m r
sttLayer (STT s m Int -> ATMST s m Int) -> STT s m Int -> ATMST s m Int
forall a b. (a -> b) -> a -> b
$ MList s (Maybe (Env d i r s m)) -> STT s m Int
forall (m :: * -> *) s a. Monad m => MList s a -> STT s m Int
mlength MList s (Maybe (Env d i r s m))
newEnvs
case Int
envLen of
Int
0 -> IO () -> ATMST s m ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> ATMST s m ()) -> IO () -> ATMST s m ()
forall a b. (a -> b) -> a -> b
$ String -> IO ()
putStrLn String
". No envs"
Int
1 -> do
IO () -> ATMST s m ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> ATMST s m ()) -> IO () -> ATMST s m ()
forall a b. (a -> b) -> a -> b
$ String -> IO ()
putStr String
". Env: "
Maybe (Env d i r s m)
envm <- STT s m (Maybe (Env d i r s m))
-> ATMST s m (Maybe (Env d i r s m))
forall (m :: * -> *) s r. Monad m => STT s m r -> ATMST s m r
sttLayer (STT s m (Maybe (Env d i r s m))
-> ATMST s m (Maybe (Env d i r s m)))
-> STT s m (Maybe (Env d i r s m))
-> ATMST s m (Maybe (Env d i r s m))
forall a b. (a -> b) -> a -> b
$ MList s (Maybe (Env d i r s m)) -> STT s m (Maybe (Env d i r s m))
forall (m :: * -> *) s a. Applicative m => MList s a -> STT s m a
mcar MList s (Maybe (Env d i r s m))
newEnvs
case Maybe (Env d i r s m)
envm of
Maybe (Env d i r s m)
Nothing -> IO () -> ATMST s m ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> ATMST s m ()) -> IO () -> ATMST s m ()
forall a b. (a -> b) -> a -> b
$ String -> IO ()
putStrLn String
"<nulled out>"
Just Env d i r s m
env -> Env d i r s m -> ATMST s m ()
forall (m :: * -> *) d i r s.
(MonadIO m, NodeDatum d) =>
Env d i r s m -> ATMST s m ()
debugEnv Env d i r s m
env
Int
_ -> do
IO () -> ATMST s m ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> ATMST s m ()) -> IO () -> ATMST s m ()
forall a b. (a -> b) -> a -> b
$ String -> IO ()
putStrLn String
". Envs:"
(forall r. STT s m r -> ATMST s m r)
-> MList s (Maybe (Env d i r s m))
-> (Maybe (Env d i r s m) -> ATMST s m ())
-> ATMST s m ()
forall (m0 :: * -> *) (m :: * -> *) s a.
(Monad m0, Monad m) =>
(forall r. STT s m0 r -> m r) -> MList s a -> (a -> m ()) -> m ()
mlistFor_ forall r. STT s m r -> ATMST s m r
forall (m :: * -> *) s r. Monad m => STT s m r -> ATMST s m r
sttLayer MList s (Maybe (Env d i r s m))
newEnvs ((Maybe (Env d i r s m) -> ATMST s m ()) -> ATMST s m ())
-> (Maybe (Env d i r s m) -> ATMST s m ()) -> ATMST s m ()
forall a b. (a -> b) -> a -> b
$ \Maybe (Env d i r s m)
em -> do
IO () -> ATMST s m ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> ATMST s m ()) -> IO () -> ATMST s m ()
forall a b. (a -> b) -> a -> b
$ String -> IO ()
putStr String
" . "
case Maybe (Env d i r s m)
em of
Just Env d i r s m
e -> Env d i r s m -> ATMST s m ()
forall (m :: * -> *) d i r s.
(MonadIO m, NodeDatum d) =>
Env d i r s m -> ATMST s m ()
debugEnv Env d i r s m
e
Maybe (Env d i r s m)
Nothing -> IO () -> ATMST s m ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> ATMST s m ()) -> IO () -> ATMST s m ()
forall a b. (a -> b) -> a -> b
$ String -> IO ()
putStrLn String
"<nulled out>"
debugUpdateLabelFinal ::
(MonadIO m, NodeDatum d) =>
Node d i r s m -> [Env d i r s m] -> MList s (Maybe (Env d i r s m)) ->
ATMST s m ()
debugUpdateLabelFinal :: Node d i r s m
-> [Env d i r s m]
-> MList s (Maybe (Env d i r s m))
-> ATMST s m ()
debugUpdateLabelFinal Node d i r s m
node [Env d i r s m]
labelEnvs MList s (Maybe (Env d i r s m))
newEnvs = do
case [Env d i r s m]
labelEnvs of
[] -> IO () -> ATMST s m ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> ATMST s m ()) -> IO () -> ATMST s m ()
forall a b. (a -> b) -> a -> b
$ String -> IO ()
putStrLn String
". No label envs"
[Env d i r s m
env] -> do
IO () -> ATMST s m ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> ATMST s m ()) -> IO () -> ATMST s m ()
forall a b. (a -> b) -> a -> b
$ String -> IO ()
putStr String
". Single label env: "
Env d i r s m -> ATMST s m ()
forall (m :: * -> *) d i r s.
(MonadIO m, NodeDatum d) =>
Env d i r s m -> ATMST s m ()
debugEnv Env d i r s m
env
[Env d i r s m]
_ -> do
IO () -> ATMST s m ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> ATMST s m ()) -> IO () -> ATMST s m ()
forall a b. (a -> b) -> a -> b
$ String -> IO ()
putStrLn String
". Final envs:"
[Env d i r s m] -> (Env d i r s m -> ATMST s m ()) -> ATMST s m ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [Env d i r s m]
labelEnvs ((Env d i r s m -> ATMST s m ()) -> ATMST s m ())
-> (Env d i r s m -> ATMST s m ()) -> ATMST s m ()
forall a b. (a -> b) -> a -> b
$ \Env d i r s m
e -> do
IO () -> ATMST s m ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> ATMST s m ()) -> IO () -> ATMST s m ()
forall a b. (a -> b) -> a -> b
$ String -> IO ()
putStr String
" . "
Env d i r s m -> ATMST s m ()
forall (m :: * -> *) d i r s.
(MonadIO m, NodeDatum d) =>
Env d i r s m -> ATMST s m ()
debugEnv Env d i r s m
e
Int
envLen <- STT s m Int -> ATMST s m Int
forall (m :: * -> *) s r. Monad m => STT s m r -> ATMST s m r
sttLayer (STT s m Int -> ATMST s m Int) -> STT s m Int -> ATMST s m Int
forall a b. (a -> b) -> a -> b
$ MList s (Maybe (Env d i r s m)) -> STT s m Int
forall (m :: * -> *) s a. Monad m => MList s a -> STT s m Int
mlength MList s (Maybe (Env d i r s m))
newEnvs
case Int
envLen of
Int
0 -> IO () -> ATMST s m ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> ATMST s m ()) -> IO () -> ATMST s m ()
forall a b. (a -> b) -> a -> b
$ String -> IO ()
putStrLn String
". No final envs"
Int
1 -> do
IO () -> ATMST s m ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> ATMST s m ()) -> IO () -> ATMST s m ()
forall a b. (a -> b) -> a -> b
$ String -> IO ()
putStr String
". Single final env: "
Maybe (Env d i r s m)
envm <- STT s m (Maybe (Env d i r s m))
-> ATMST s m (Maybe (Env d i r s m))
forall (m :: * -> *) s r. Monad m => STT s m r -> ATMST s m r
sttLayer (STT s m (Maybe (Env d i r s m))
-> ATMST s m (Maybe (Env d i r s m)))
-> STT s m (Maybe (Env d i r s m))
-> ATMST s m (Maybe (Env d i r s m))
forall a b. (a -> b) -> a -> b
$ MList s (Maybe (Env d i r s m)) -> STT s m (Maybe (Env d i r s m))
forall (m :: * -> *) s a. Applicative m => MList s a -> STT s m a
mcar MList s (Maybe (Env d i r s m))
newEnvs
case Maybe (Env d i r s m)
envm of
Maybe (Env d i r s m)
Nothing -> IO () -> ATMST s m ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> ATMST s m ()) -> IO () -> ATMST s m ()
forall a b. (a -> b) -> a -> b
$ String -> IO ()
putStrLn String
"<nulled out>"
Just Env d i r s m
env -> Env d i r s m -> ATMST s m ()
forall (m :: * -> *) d i r s.
(MonadIO m, NodeDatum d) =>
Env d i r s m -> ATMST s m ()
debugEnv Env d i r s m
env
Int
_ -> do
IO () -> ATMST s m ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> ATMST s m ()) -> IO () -> ATMST s m ()
forall a b. (a -> b) -> a -> b
$ String -> IO ()
putStrLn String
". Final envs:"
(forall r. STT s m r -> ATMST s m r)
-> MList s (Maybe (Env d i r s m))
-> (Maybe (Env d i r s m) -> ATMST s m ())
-> ATMST s m ()
forall (m0 :: * -> *) (m :: * -> *) s a.
(Monad m0, Monad m) =>
(forall r. STT s m0 r -> m r) -> MList s a -> (a -> m ()) -> m ()
mlistFor_ forall r. STT s m r -> ATMST s m r
forall (m :: * -> *) s r. Monad m => STT s m r -> ATMST s m r
sttLayer MList s (Maybe (Env d i r s m))
newEnvs ((Maybe (Env d i r s m) -> ATMST s m ()) -> ATMST s m ())
-> (Maybe (Env d i r s m) -> ATMST s m ()) -> ATMST s m ()
forall a b. (a -> b) -> a -> b
$ \Maybe (Env d i r s m)
em -> do
IO () -> ATMST s m ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> ATMST s m ()) -> IO () -> ATMST s m ()
forall a b. (a -> b) -> a -> b
$ String -> IO ()
putStr String
" . "
case Maybe (Env d i r s m)
em of
Just Env d i r s m
e -> Env d i r s m -> ATMST s m ()
forall (m :: * -> *) d i r s.
(MonadIO m, NodeDatum d) =>
Env d i r s m -> ATMST s m ()
debugEnv Env d i r s m
e
Maybe (Env d i r s m)
Nothing -> IO () -> ATMST s m ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> ATMST s m ()) -> IO () -> ATMST s m ()
forall a b. (a -> b) -> a -> b
$ String -> IO ()
putStrLn String
"<nulled out>"
Node d i r s m -> ATMST s m ()
forall (m :: * -> *) d i r s.
(MonadIO m, NodeDatum d) =>
Node d i r s m -> ATMST s m ()
debugNode Node d i r s m
node
weave :: (Debuggable m, NodeDatum d) =>
Maybe (Node d i r s m) ->
(MList s (Maybe (Env d i r s m))) ->
[Node d i r s m] ->
ATMST s m (MList s (Maybe (Env d i r s m)))
weave :: Maybe (Node d i r s m)
-> MList s (Maybe (Env d i r s m))
-> [Node d i r s m]
-> ATMST s m (MList s (Maybe (Env d i r s m)))
weave Maybe (Node d i r s m)
antecedent MList s (Maybe (Env d i r s m))
givenEnvs [Node d i r s m]
antecedents = do
$(dbg [| debugWeaveArgs antecedent givenEnvs antecedents |])
STRef s (MList s (Maybe (Env d i r s m)))
envsRef <- STT s m (STRef s (MList s (Maybe (Env d i r s m))))
-> ATMST s m (STRef s (MList s (Maybe (Env d i r s m))))
forall (m :: * -> *) s r. Monad m => STT s m r -> ATMST s m r
sttLayer (STT s m (STRef s (MList s (Maybe (Env d i r s m))))
-> ATMST s m (STRef s (MList s (Maybe (Env d i r s m)))))
-> STT s m (STRef s (MList s (Maybe (Env d i r s m))))
-> ATMST s m (STRef s (MList s (Maybe (Env d i r s m))))
forall a b. (a -> b) -> a -> b
$ MList s (Maybe (Env d i r s m))
-> STT s m (STRef s (MList s (Maybe (Env d i r s m))))
forall (m :: * -> *) a s. Applicative m => a -> STT s m (STRef s a)
newSTRef MList s (Maybe (Env d i r s m))
givenEnvs
[Node d i r s m]
-> (Node d i r s m -> ATMST s m ()) -> ATMST s m ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [Node d i r s m]
antecedents ((Node d i r s m -> ATMST s m ()) -> ATMST s m ())
-> (Node d i r s m -> ATMST s m ()) -> ATMST s m ()
forall a b. (a -> b) -> a -> b
$ \Node d i r s m
node ->
Bool -> ATMST s m () -> ATMST s m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (Bool -> (Node d i r s m -> Bool) -> Maybe (Node d i r s m) -> Bool
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Bool
False (Node d i r s m
node Node d i r s m -> Node d i r s m -> Bool
forall a. Eq a => a -> a -> Bool
==) Maybe (Node d i r s m)
antecedent) (ATMST s m () -> ATMST s m ()) -> ATMST s m () -> ATMST s m ()
forall a b. (a -> b) -> a -> b
$ do
$(dbg [| debugWeaveNodeAntecedent node |])
MList s (Maybe (Env d i r s m))
envs <- STT s m (MList s (Maybe (Env d i r s m)))
-> ATMST s m (MList s (Maybe (Env d i r s m)))
forall (m :: * -> *) s r. Monad m => STT s m r -> ATMST s m r
sttLayer (STT s m (MList s (Maybe (Env d i r s m)))
-> ATMST s m (MList s (Maybe (Env d i r s m))))
-> STT s m (MList s (Maybe (Env d i r s m)))
-> ATMST s m (MList s (Maybe (Env d i r s m)))
forall a b. (a -> b) -> a -> b
$ STRef s (MList s (Maybe (Env d i r s m)))
-> STT s m (MList s (Maybe (Env d i r s m)))
forall (m :: * -> *) s a. Applicative m => STRef s a -> STT s m a
readSTRef STRef s (MList s (Maybe (Env d i r s m)))
envsRef
STRef s (MList s (Maybe (Env d i r s m)))
newEnvs <- STT s m (STRef s (MList s (Maybe (Env d i r s m))))
-> ATMST s m (STRef s (MList s (Maybe (Env d i r s m))))
forall (m :: * -> *) s r. Monad m => STT s m r -> ATMST s m r
sttLayer (STT s m (STRef s (MList s (Maybe (Env d i r s m))))
-> ATMST s m (STRef s (MList s (Maybe (Env d i r s m)))))
-> STT s m (STRef s (MList s (Maybe (Env d i r s m))))
-> ATMST s m (STRef s (MList s (Maybe (Env d i r s m))))
forall a b. (a -> b) -> a -> b
$ MList s (Maybe (Env d i r s m))
-> STT s m (STRef s (MList s (Maybe (Env d i r s m))))
forall (m :: * -> *) a s. Applicative m => a -> STT s m (STRef s a)
newSTRef MList s (Maybe (Env d i r s m))
forall s a. MList s a
MNil
(forall r. STT s m r -> ATMST s m r)
-> MList s (Maybe (Env d i r s m))
-> (Maybe (Env d i r s m) -> ATMST s m ())
-> ATMST s m ()
forall (m0 :: * -> *) (m :: * -> *) s a.
(Monad m0, Monad m) =>
(forall r. STT s m0 r -> m r) -> MList s a -> (a -> m ()) -> m ()
mlistFor_ forall r. STT s m r -> ATMST s m r
forall (m :: * -> *) s r. Monad m => STT s m r -> ATMST s m r
sttLayer MList s (Maybe (Env d i r s m))
envs ((Maybe (Env d i r s m) -> ATMST s m ()) -> ATMST s m ())
-> (Maybe (Env d i r s m) -> ATMST s m ()) -> ATMST s m ()
forall a b. (a -> b) -> a -> b
$ \Maybe (Env d i r s m)
envmaybe ->
case Maybe (Env d i r s m)
envmaybe of
Maybe (Env d i r s m)
Nothing -> () -> ATMST s m ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
Just Env d i r s m
env -> do
ATMST s m [Env d i r s m]
-> (Env d i r s m -> ATMST s m ()) -> ATMST s m ()
forall (m :: * -> *) (t :: * -> *) a.
(Monad m, Foldable t) =>
m (t a) -> (a -> m ()) -> m ()
forMM_ (STT s m [Env d i r s m] -> ATMST s m [Env d i r s m]
forall (m :: * -> *) s r. Monad m => STT s m r -> ATMST s m r
sttLayer (STT s m [Env d i r s m] -> ATMST s m [Env d i r s m])
-> STT s m [Env d i r s m] -> ATMST s m [Env d i r s m]
forall a b. (a -> b) -> a -> b
$ STRef s [Env d i r s m] -> STT s m [Env d i r s m]
forall (m :: * -> *) s a. Applicative m => STRef s a -> STT s m a
readSTRef (STRef s [Env d i r s m] -> STT s m [Env d i r s m])
-> STRef s [Env d i r s m] -> STT s m [Env d i r s m]
forall a b. (a -> b) -> a -> b
$ Node d i r s m -> STRef s [Env d i r s m]
forall d i r s (m :: * -> *).
(Monad m, NodeDatum d) =>
Node d i r s m -> STRef s [Env d i r s m]
nodeLabel Node d i r s m
node) ((Env d i r s m -> ATMST s m ()) -> ATMST s m ())
-> (Env d i r s m -> ATMST s m ()) -> ATMST s m ()
forall a b. (a -> b) -> a -> b
$ \Env d i r s m
nodeEnv -> do
$(dbg [| debugWeavePairIntro env nodeEnv |])
Env d i r s m
newEnv <- Env d i r s m -> Env d i r s m -> ATMST s m (Env d i r s m)
forall (m :: * -> *) d i r s.
(Debuggable m, NodeDatum d) =>
Env d i r s m -> Env d i r s m -> ATMST s m (Env d i r s m)
unionEnv Env d i r s m
env Env d i r s m
nodeEnv
$(dbg [| debugWeavePairUnion newEnv |])
ATMST s m Bool -> ATMST s m () -> ATMST s m ()
forall (m :: * -> *). Monad m => m Bool -> m () -> m ()
unlessM (Env d i r s m -> ATMST s m Bool
forall (m :: * -> *) d i r s.
(Monad m, NodeDatum d) =>
Env d i r s m -> ATMST s m Bool
envIsNogood Env d i r s m
newEnv) (ATMST s m () -> ATMST s m ()) -> ATMST s m () -> ATMST s m ()
forall a b. (a -> b) -> a -> b
$ do
STRef s Bool
addEnv <- STT s m (STRef s Bool) -> ATMST s m (STRef s Bool)
forall (m :: * -> *) s r. Monad m => STT s m r -> ATMST s m r
sttLayer (STT s m (STRef s Bool) -> ATMST s m (STRef s Bool))
-> STT s m (STRef s Bool) -> ATMST s m (STRef s Bool)
forall a b. (a -> b) -> a -> b
$ Bool -> STT s m (STRef s Bool)
forall (m :: * -> *) a s. Applicative m => a -> STT s m (STRef s a)
newSTRef Bool
True
MList s (Maybe (Env d i r s m))
oldMCons <- STT s m (MList s (Maybe (Env d i r s m)))
-> ATMST s m (MList s (Maybe (Env d i r s m)))
forall (m :: * -> *) s r. Monad m => STT s m r -> ATMST s m r
sttLayer (STT s m (MList s (Maybe (Env d i r s m)))
-> ATMST s m (MList s (Maybe (Env d i r s m))))
-> STT s m (MList s (Maybe (Env d i r s m)))
-> ATMST s m (MList s (Maybe (Env d i r s m)))
forall a b. (a -> b) -> a -> b
$ STRef s (MList s (Maybe (Env d i r s m)))
-> STT s m (MList s (Maybe (Env d i r s m)))
forall (m :: * -> *) s a. Applicative m => STRef s a -> STT s m a
readSTRef STRef s (MList s (Maybe (Env d i r s m)))
newEnvs
(forall r. STT s m r -> ATMST s m r)
-> MList s (Maybe (Env d i r s m))
-> ATMST s m Bool
-> (MList s (Maybe (Env d i r s m)) -> ATMST s m ())
-> ATMST s m ()
forall (m0 :: * -> *) (m :: * -> *) s a.
(Monad m0, Monad m) =>
(forall r. STT s m0 r -> m r)
-> MList s a -> m Bool -> (MList s a -> m ()) -> m ()
mlistForConsWhile_ forall r. STT s m r -> ATMST s m r
forall (m :: * -> *) s r. Monad m => STT s m r -> ATMST s m r
sttLayer MList s (Maybe (Env d i r s m))
oldMCons
(STT s m Bool -> ATMST s m Bool
forall (m :: * -> *) s r. Monad m => STT s m r -> ATMST s m r
sttLayer (STT s m Bool -> ATMST s m Bool) -> STT s m Bool -> ATMST s m Bool
forall a b. (a -> b) -> a -> b
$ STRef s Bool -> STT s m Bool
forall (m :: * -> *) s a. Applicative m => STRef s a -> STT s m a
readSTRef STRef s Bool
addEnv) ((MList s (Maybe (Env d i r s m)) -> ATMST s m ()) -> ATMST s m ())
-> (MList s (Maybe (Env d i r s m)) -> ATMST s m ())
-> ATMST s m ()
forall a b. (a -> b) -> a -> b
$ \ MList s (Maybe (Env d i r s m))
cons ->
case MList s (Maybe (Env d i r s m))
cons of
MList s (Maybe (Env d i r s m))
MNil -> () -> ATMST s m ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
mc :: MList s (Maybe (Env d i r s m))
mc@(MCons STRef s (Maybe (Env d i r s m))
carRef STRef s (MList s (Maybe (Env d i r s m)))
cdrRef) -> do
Maybe (Env d i r s m)
maybeCar <- STT s m (Maybe (Env d i r s m))
-> ATMST s m (Maybe (Env d i r s m))
forall (m :: * -> *) s r. Monad m => STT s m r -> ATMST s m r
sttLayer (STT s m (Maybe (Env d i r s m))
-> ATMST s m (Maybe (Env d i r s m)))
-> STT s m (Maybe (Env d i r s m))
-> ATMST s m (Maybe (Env d i r s m))
forall a b. (a -> b) -> a -> b
$ STRef s (Maybe (Env d i r s m)) -> STT s m (Maybe (Env d i r s m))
forall (m :: * -> *) s a. Applicative m => STRef s a -> STT s m a
readSTRef STRef s (Maybe (Env d i r s m))
carRef
case Maybe (Env d i r s m)
maybeCar of
Maybe (Env d i r s m)
Nothing -> () -> ATMST s m ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
Just Env d i r s m
car ->
case Env d i r s m -> Env d i r s m -> EnvCompare
forall (m :: * -> *) d i r s.
(Monad m, NodeDatum d) =>
Env d i r s m -> Env d i r s m -> EnvCompare
compareEnv Env d i r s m
newEnv Env d i r s m
car of
EnvCompare
EQenv -> STT s m () -> ATMST s m ()
forall (m :: * -> *) s r. Monad m => STT s m r -> ATMST s m r
sttLayer (STT s m () -> ATMST s m ()) -> STT s m () -> ATMST s m ()
forall a b. (a -> b) -> a -> b
$ STRef s Bool -> Bool -> STT s m ()
forall (m :: * -> *) s a.
Applicative m =>
STRef s a -> a -> STT s m ()
writeSTRef STRef s Bool
addEnv Bool
False
EnvCompare
S12env -> do
$(dbg [| debugWeaveLoopRemovingEnv car |])
STT s m () -> ATMST s m ()
forall (m :: * -> *) s r. Monad m => STT s m r -> ATMST s m r
sttLayer (STT s m () -> ATMST s m ()) -> STT s m () -> ATMST s m ()
forall a b. (a -> b) -> a -> b
$ MList s (Maybe (Env d i r s m))
-> Maybe (Env d i r s m) -> STT s m ()
forall (m :: * -> *) s a. Monad m => MList s a -> a -> STT s m ()
rplaca MList s (Maybe (Env d i r s m))
cons Maybe (Env d i r s m)
forall a. Maybe a
Nothing
EnvCompare
S21env -> STT s m () -> ATMST s m ()
forall (m :: * -> *) s r. Monad m => STT s m r -> ATMST s m r
sttLayer (STT s m () -> ATMST s m ()) -> STT s m () -> ATMST s m ()
forall a b. (a -> b) -> a -> b
$ STRef s Bool -> Bool -> STT s m ()
forall (m :: * -> *) s a.
Applicative m =>
STRef s a -> a -> STT s m ()
writeSTRef STRef s Bool
addEnv Bool
False
EnvCompare
DisjEnv -> () -> ATMST s m ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
STT s m () -> ATMST s m ()
forall (m :: * -> *) s r. Monad m => STT s m r -> ATMST s m r
sttLayer (STT s m () -> ATMST s m ()) -> STT s m () -> ATMST s m ()
forall a b. (a -> b) -> a -> b
$ STT s m Bool -> STT s m () -> STT s m ()
forall (m :: * -> *). Monad m => m Bool -> m () -> m ()
whenM (STRef s Bool -> STT s m Bool
forall (m :: * -> *) s a. Applicative m => STRef s a -> STT s m a
readSTRef STRef s Bool
addEnv) (STT s m () -> STT s m ()) -> STT s m () -> STT s m ()
forall a b. (a -> b) -> a -> b
$ do
MList s (Maybe (Env d i r s m))
newMCons <- Maybe (Env d i r s m)
-> MList s (Maybe (Env d i r s m))
-> STT s m (MList s (Maybe (Env d i r s m)))
forall (m :: * -> *) a s.
Monad m =>
a -> MList s a -> STT s m (MList s a)
mlistPush (Env d i r s m -> Maybe (Env d i r s m)
forall a. a -> Maybe a
Just Env d i r s m
newEnv) MList s (Maybe (Env d i r s m))
oldMCons
STRef s (MList s (Maybe (Env d i r s m)))
-> MList s (Maybe (Env d i r s m)) -> STT s m ()
forall (m :: * -> *) s a.
Applicative m =>
STRef s a -> a -> STT s m ()
writeSTRef STRef s (MList s (Maybe (Env d i r s m)))
newEnvs MList s (Maybe (Env d i r s m))
newMCons
$(dbg [| debugWeaveLoopPairEnd addEnv newEnvs |])
MList s (Maybe (Env d i r s m))
preFinalNewEnvs <- STT s m (MList s (Maybe (Env d i r s m)))
-> ATMST s m (MList s (Maybe (Env d i r s m)))
forall (m :: * -> *) s r. Monad m => STT s m r -> ATMST s m r
sttLayer (STT s m (MList s (Maybe (Env d i r s m)))
-> ATMST s m (MList s (Maybe (Env d i r s m))))
-> STT s m (MList s (Maybe (Env d i r s m)))
-> ATMST s m (MList s (Maybe (Env d i r s m)))
forall a b. (a -> b) -> a -> b
$ STRef s (MList s (Maybe (Env d i r s m)))
-> STT s m (MList s (Maybe (Env d i r s m)))
forall (m :: * -> *) s a. Applicative m => STRef s a -> STT s m a
readSTRef STRef s (MList s (Maybe (Env d i r s m)))
newEnvs
MList s (Maybe (Env d i r s m))
filteredNewEnvs <- STT s m (MList s (Maybe (Env d i r s m)))
-> ATMST s m (MList s (Maybe (Env d i r s m)))
forall (m :: * -> *) s r. Monad m => STT s m r -> ATMST s m r
sttLayer (STT s m (MList s (Maybe (Env d i r s m)))
-> ATMST s m (MList s (Maybe (Env d i r s m))))
-> STT s m (MList s (Maybe (Env d i r s m)))
-> ATMST s m (MList s (Maybe (Env d i r s m)))
forall a b. (a -> b) -> a -> b
$ MList s (Maybe (Env d i r s m))
-> STT s m (MList s (Maybe (Env d i r s m)))
forall (m :: * -> *) s a.
Monad m =>
MList s (Maybe a) -> STT s m (MList s (Maybe a))
mlistStripNothing MList s (Maybe (Env d i r s m))
preFinalNewEnvs
STT s m () -> ATMST s m ()
forall (m :: * -> *) s r. Monad m => STT s m r -> ATMST s m r
sttLayer (STT s m () -> ATMST s m ()) -> STT s m () -> ATMST s m ()
forall a b. (a -> b) -> a -> b
$ STRef s (MList s (Maybe (Env d i r s m)))
-> MList s (Maybe (Env d i r s m)) -> STT s m ()
forall (m :: * -> *) s a.
Applicative m =>
STRef s a -> a -> STT s m ()
writeSTRef STRef s (MList s (Maybe (Env d i r s m)))
envsRef MList s (Maybe (Env d i r s m))
filteredNewEnvs
MList s (Maybe (Env d i r s m))
result <- STT s m (MList s (Maybe (Env d i r s m)))
-> ATMST s m (MList s (Maybe (Env d i r s m)))
forall (m :: * -> *) s r. Monad m => STT s m r -> ATMST s m r
sttLayer (STT s m (MList s (Maybe (Env d i r s m)))
-> ATMST s m (MList s (Maybe (Env d i r s m))))
-> STT s m (MList s (Maybe (Env d i r s m)))
-> ATMST s m (MList s (Maybe (Env d i r s m)))
forall a b. (a -> b) -> a -> b
$ STRef s (MList s (Maybe (Env d i r s m)))
-> STT s m (MList s (Maybe (Env d i r s m)))
forall (m :: * -> *) s a. Applicative m => STRef s a -> STT s m a
readSTRef STRef s (MList s (Maybe (Env d i r s m)))
envsRef
$(dbg [| debugWeaveResult result |])
MList s (Maybe (Env d i r s m))
-> ATMST s m (MList s (Maybe (Env d i r s m)))
forall (m :: * -> *) a. Monad m => a -> m a
return MList s (Maybe (Env d i r s m))
result
debugWeaveArgs :: (MonadIO m, NodeDatum d) =>
Maybe (Node d i r s m) ->
(MList s (Maybe (Env d i r s m))) ->
[Node d i r s m] ->
ATMST s m ()
debugWeaveArgs :: Maybe (Node d i r s m)
-> MList s (Maybe (Env d i r s m))
-> [Node d i r s m]
-> ATMST s m ()
debugWeaveArgs Maybe (Node d i r s m)
antecedent MList s (Maybe (Env d i r s m))
givenEnvs [Node d i r s m]
antecedents = do
IO () -> ATMST s m ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> ATMST s m ()) -> IO () -> ATMST s m ()
forall a b. (a -> b) -> a -> b
$ String -> IO ()
putStrLn String
"Calling weave with"
case Maybe (Node d i r s m)
antecedent of
Just Node d i r s m
n -> Node d i r s m -> ATMST s m ()
forall (m :: * -> *) d i r s.
(MonadIO m, NodeDatum d) =>
Node d i r s m -> ATMST s m ()
debugNode Node d i r s m
n
Maybe (Node d i r s m)
Nothing -> IO () -> ATMST s m ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> ATMST s m ()) -> IO () -> ATMST s m ()
forall a b. (a -> b) -> a -> b
$ String -> IO ()
putStrLn String
". No antecedent"
let atms :: Maybe (ATMS d i r s m)
atms = case Maybe (Node d i r s m)
antecedent of
Just Node d i r s m
a -> ATMS d i r s m -> Maybe (ATMS d i r s m)
forall a. a -> Maybe a
Just (ATMS d i r s m -> Maybe (ATMS d i r s m))
-> ATMS d i r s m -> Maybe (ATMS d i r s m)
forall a b. (a -> b) -> a -> b
$ Node d i r s m -> ATMS d i r s m
forall d i r s (m :: * -> *).
(Monad m, NodeDatum d) =>
Node d i r s m -> ATMS d i r s m
nodeATMS Node d i r s m
a
Maybe (Node d i r s m)
Nothing -> case [Node d i r s m]
antecedents of
Node d i r s m
a : [Node d i r s m]
_ -> ATMS d i r s m -> Maybe (ATMS d i r s m)
forall a. a -> Maybe a
Just (ATMS d i r s m -> Maybe (ATMS d i r s m))
-> ATMS d i r s m -> Maybe (ATMS d i r s m)
forall a b. (a -> b) -> a -> b
$ Node d i r s m -> ATMS d i r s m
forall d i r s (m :: * -> *).
(Monad m, NodeDatum d) =>
Node d i r s m -> ATMS d i r s m
nodeATMS Node d i r s m
a
[Node d i r s m]
_ -> Maybe (ATMS d i r s m)
forall a. Maybe a
Nothing
case Maybe (ATMS d i r s m)
atms of
Just ATMS d i r s m
a -> do
IO () -> ATMST s m ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> ATMST s m ()) -> IO () -> ATMST s m ()
forall a b. (a -> b) -> a -> b
$ String -> IO ()
putStrLn String
". Envs:"
(forall r. STT s m r -> ATMST s m r)
-> MList s (Maybe (Env d i r s m))
-> (Maybe (Env d i r s m) -> ATMST s m ())
-> ATMST s m ()
forall (m0 :: * -> *) (m :: * -> *) s a.
(Monad m0, Monad m) =>
(forall r. STT s m0 r -> m r) -> MList s a -> (a -> m ()) -> m ()
mlistFor_ forall r. STT s m r -> ATMST s m r
forall (m :: * -> *) s r. Monad m => STT s m r -> ATMST s m r
sttLayer MList s (Maybe (Env d i r s m))
givenEnvs ((Maybe (Env d i r s m) -> ATMST s m ()) -> ATMST s m ())
-> (Maybe (Env d i r s m) -> ATMST s m ()) -> ATMST s m ()
forall a b. (a -> b) -> a -> b
$ \Maybe (Env d i r s m)
em -> do
IO () -> ATMST s m ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> ATMST s m ()) -> IO () -> ATMST s m ()
forall a b. (a -> b) -> a -> b
$ String -> IO ()
putStr String
" . "
case Maybe (Env d i r s m)
em of
Just Env d i r s m
e -> Env d i r s m -> ATMST s m ()
forall (m :: * -> *) d i r s.
(MonadIO m, NodeDatum d) =>
Env d i r s m -> ATMST s m ()
debugEnv Env d i r s m
e
Maybe (Env d i r s m)
Nothing -> IO () -> ATMST s m ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> ATMST s m ()) -> IO () -> ATMST s m ()
forall a b. (a -> b) -> a -> b
$ String -> IO ()
putStrLn String
"<nulled out>"
() -> ATMST s m ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
Maybe (ATMS d i r s m)
_ -> () -> ATMST s m ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
IO () -> ATMST s m ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> ATMST s m ()) -> IO () -> ATMST s m ()
forall a b. (a -> b) -> a -> b
$ String -> IO ()
putStr String
". Antecedents:"
[Node d i r s m]
-> (Node d i r s m -> ATMST s m ()) -> ATMST s m ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [Node d i r s m]
antecedents ((Node d i r s m -> ATMST s m ()) -> ATMST s m ())
-> (Node d i r s m -> ATMST s m ()) -> ATMST s m ()
forall a b. (a -> b) -> a -> b
$ \Node d i r s m
a -> do
let atms :: ATMS d i r s m
atms = Node d i r s m -> ATMS d i r s m
forall d i r s (m :: * -> *).
(Monad m, NodeDatum d) =>
Node d i r s m -> ATMS d i r s m
nodeATMS Node d i r s m
a
d -> String
datumFmt <- ATMS d i r s m -> ATMST s m (d -> String)
forall (m :: * -> *) d i r s.
(Monad m, NodeDatum d) =>
ATMS d i r s m -> ATMST s m (d -> String)
getDatumString ATMS d i r s m
atms
IO () -> ATMST s m ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> ATMST s m ()) -> IO () -> ATMST s m ()
forall a b. (a -> b) -> a -> b
$ String -> IO ()
putStr (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String
" " String -> ShowS
forall a. [a] -> [a] -> [a]
++ d -> String
datumFmt (Node d i r s m -> d
forall d i r s (m :: * -> *).
(Monad m, NodeDatum d) =>
Node d i r s m -> d
nodeDatum Node d i r s m
a)
IO () -> ATMST s m ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> ATMST s m ()) -> IO () -> ATMST s m ()
forall a b. (a -> b) -> a -> b
$ String -> IO ()
putStrLn String
" "
debugWeaveNodeAntecedent :: Node d i r s m -> ATMST s m ()
debugWeaveNodeAntecedent Node d i r s m
antecedent = do
d -> String
datumFmt <- ATMS d i r s m -> ATMST s m (d -> String)
forall (m :: * -> *) d i r s.
(Monad m, NodeDatum d) =>
ATMS d i r s m -> ATMST s m (d -> String)
getDatumString (Node d i r s m -> ATMS d i r s m
forall d i r s (m :: * -> *).
(Monad m, NodeDatum d) =>
Node d i r s m -> ATMS d i r s m
nodeATMS Node d i r s m
antecedent)
IO () -> ATMST s m ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> ATMST s m ()) -> IO () -> ATMST s m ()
forall a b. (a -> b) -> a -> b
$ String -> IO ()
putStrLn (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$
String
" - For node antecedent " String -> ShowS
forall a. [a] -> [a] -> [a]
++ d -> String
datumFmt (Node d i r s m -> d
forall d i r s (m :: * -> *).
(Monad m, NodeDatum d) =>
Node d i r s m -> d
nodeDatum Node d i r s m
antecedent)
debugWeavePairIntro ::
(MonadIO m, NodeDatum d) => Env d i r s m -> Env d i r s m -> ATMST s m ()
debugWeavePairIntro :: Env d i r s m -> Env d i r s m -> ATMST s m ()
debugWeavePairIntro Env d i r s m
srcEnv Env d i r s m
nodeEnv = do
IO () -> ATMST s m ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> ATMST s m ()) -> IO () -> ATMST s m ()
forall a b. (a -> b) -> a -> b
$ String -> IO ()
putStr (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String
" - For "
Env d i r s m -> ATMST s m ()
forall (m :: * -> *) d i r s.
(MonadIO m, NodeDatum d) =>
Env d i r s m -> ATMST s m ()
blurbEnv Env d i r s m
srcEnv
IO () -> ATMST s m ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> ATMST s m ()) -> IO () -> ATMST s m ()
forall a b. (a -> b) -> a -> b
$ String -> IO ()
putStr (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String
" from env, "
Env d i r s m -> ATMST s m ()
forall (m :: * -> *) d i r s.
(MonadIO m, NodeDatum d) =>
Env d i r s m -> ATMST s m ()
blurbEnv Env d i r s m
nodeEnv
IO () -> ATMST s m ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> ATMST s m ()) -> IO () -> ATMST s m ()
forall a b. (a -> b) -> a -> b
$ String -> IO ()
putStrLn (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String
" from node label"
debugWeavePairUnion ::
(MonadIO m, NodeDatum d) => Env d i r s m -> ATMST s m ()
debugWeavePairUnion :: Env d i r s m -> ATMST s m ()
debugWeavePairUnion Env d i r s m
union = do
IO () -> ATMST s m ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> ATMST s m ()) -> IO () -> ATMST s m ()
forall a b. (a -> b) -> a -> b
$ String -> IO ()
putStr String
" Union is "
Env d i r s m -> ATMST s m ()
forall (m :: * -> *) d i r s.
(MonadIO m, NodeDatum d) =>
Env d i r s m -> ATMST s m ()
blurbEnv Env d i r s m
union
IO () -> ATMST s m ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> ATMST s m ()) -> IO () -> ATMST s m ()
forall a b. (a -> b) -> a -> b
$ String -> IO ()
putStrLn String
""
debugWeaveResult ::
(MonadIO m, NodeDatum d) => MList s (Maybe (Env d i r s m)) -> ATMST s m ()
debugWeaveResult :: MList s (Maybe (Env d i r s m)) -> ATMST s m ()
debugWeaveResult MList s (Maybe (Env d i r s m))
result = do
IO () -> ATMST s m ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> ATMST s m ()) -> IO () -> ATMST s m ()
forall a b. (a -> b) -> a -> b
$ String -> IO ()
putStr String
" --> result of weave is "
MList s (Maybe (Env d i r s m)) -> ATMST s m ()
forall (m :: * -> *) d s i r.
(MonadIO m, NodeDatum d) =>
MList s (Maybe (Env d i r s m)) -> ATMST s m ()
blurbMaybeEnvMList MList s (Maybe (Env d i r s m))
result
IO () -> ATMST s m ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> ATMST s m ()) -> IO () -> ATMST s m ()
forall a b. (a -> b) -> a -> b
$ String -> IO ()
putStrLn String
""
debugWeaveLoopRemovingEnv ::
(MonadIO m, NodeDatum d) => Env d i r s m -> ATMST s m ()
debugWeaveLoopRemovingEnv :: Env d i r s m -> ATMST s m ()
debugWeaveLoopRemovingEnv Env d i r s m
env = do
IO () -> ATMST s m ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> ATMST s m ()) -> IO () -> ATMST s m ()
forall a b. (a -> b) -> a -> b
$ String -> IO ()
putStr String
" - Removing from result: env "
Env d i r s m -> ATMST s m ()
forall (m :: * -> *) d i r s.
(MonadIO m, NodeDatum d) =>
Env d i r s m -> ATMST s m ()
blurbEnv Env d i r s m
env
IO () -> ATMST s m ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> ATMST s m ()) -> IO () -> ATMST s m ()
forall a b. (a -> b) -> a -> b
$ String -> IO ()
putStrLn String
""
debugWeaveLoopPairEnd ::
(MonadIO m, NodeDatum d) =>
STRef s Bool -> (STRef s (MList s (Maybe (Env d i r s m)))) -> ATMST s m ()
debugWeaveLoopPairEnd :: STRef s Bool
-> STRef s (MList s (Maybe (Env d i r s m))) -> ATMST s m ()
debugWeaveLoopPairEnd STRef s Bool
addR STRef s (MList s (Maybe (Env d i r s m)))
envmsR = do
Bool
add <- STT s m Bool -> ATMST s m Bool
forall (m :: * -> *) s r. Monad m => STT s m r -> ATMST s m r
sttLayer (STT s m Bool -> ATMST s m Bool) -> STT s m Bool -> ATMST s m Bool
forall a b. (a -> b) -> a -> b
$ STRef s Bool -> STT s m Bool
forall (m :: * -> *) s a. Applicative m => STRef s a -> STT s m a
readSTRef STRef s Bool
addR
IO () -> ATMST s m ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> ATMST s m ()) -> IO () -> ATMST s m ()
forall a b. (a -> b) -> a -> b
$ String -> IO ()
putStrLn (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String
" Adding union: " String -> ShowS
forall a. [a] -> [a] -> [a]
++ (if Bool
add then String
"yes" else String
"no")
MList s (Maybe (Env d i r s m))
mlist <- STT s m (MList s (Maybe (Env d i r s m)))
-> ATMST s m (MList s (Maybe (Env d i r s m)))
forall (m :: * -> *) s r. Monad m => STT s m r -> ATMST s m r
sttLayer (STT s m (MList s (Maybe (Env d i r s m)))
-> ATMST s m (MList s (Maybe (Env d i r s m))))
-> STT s m (MList s (Maybe (Env d i r s m)))
-> ATMST s m (MList s (Maybe (Env d i r s m)))
forall a b. (a -> b) -> a -> b
$ STRef s (MList s (Maybe (Env d i r s m)))
-> STT s m (MList s (Maybe (Env d i r s m)))
forall (m :: * -> *) s a. Applicative m => STRef s a -> STT s m a
readSTRef STRef s (MList s (Maybe (Env d i r s m)))
envmsR
IO () -> ATMST s m ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> ATMST s m ()) -> IO () -> ATMST s m ()
forall a b. (a -> b) -> a -> b
$ String -> IO ()
putStr (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String
" Updated result to: "
MList s (Maybe (Env d i r s m)) -> ATMST s m ()
forall (m :: * -> *) d s i r.
(MonadIO m, NodeDatum d) =>
MList s (Maybe (Env d i r s m)) -> ATMST s m ()
blurbMaybeEnvMList MList s (Maybe (Env d i r s m))
mlist
IO () -> ATMST s m ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> ATMST s m ()) -> IO () -> ATMST s m ()
forall a b. (a -> b) -> a -> b
$ String -> IO ()
putStrLn String
""
isInAntecedent :: (Monad m, NodeDatum d) => [Node d i r s m] -> ATMST s m Bool
isInAntecedent :: [Node d i r s m] -> ATMST s m Bool
isInAntecedent [] = Bool -> ATMST s m Bool
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
True
isInAntecedent [Node d i r s m]
nodes = do
Env d i r s m
empty <- ATMS d i r s m -> ATMST s m (Env d i r s m)
forall (m :: * -> *) d i r s.
(Monad m, NodeDatum d) =>
ATMS d i r s m -> ATMST s m (Env d i r s m)
getEmptyEnvironment (Node d i r s m -> ATMS d i r s m
forall d i r s (m :: * -> *).
(Monad m, NodeDatum d) =>
Node d i r s m -> ATMS d i r s m
nodeATMS ([Node d i r s m] -> Node d i r s m
forall a. [a] -> a
head [Node d i r s m]
nodes))
Env d i r s m -> [Node d i r s m] -> ATMST s m Bool
forall (m :: * -> *) d i r s.
(Monad m, NodeDatum d) =>
Env d i r s m -> [Node d i r s m] -> ATMST s m Bool
isWeave Env d i r s m
empty [Node d i r s m]
nodes
isWeave ::
(Monad m, NodeDatum d) => Env d i r s m -> [Node d i r s m] -> ATMST s m Bool
isWeave :: Env d i r s m -> [Node d i r s m] -> ATMST s m Bool
isWeave Env d i r s m
_ [] = Bool -> ATMST s m Bool
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
True
isWeave Env d i r s m
env (Node d i r s m
n : [Node d i r s m]
ns) =
(Env d i r s m -> ATMST s m Bool)
-> ATMST s m [Env d i r s m] -> ATMST s m Bool
forall (m :: * -> *) a. Monad m => (a -> m Bool) -> m [a] -> m Bool
anyMM (\Env d i r s m
e -> do
Env d i r s m
newEnv <- Env d i r s m -> Env d i r s m -> ATMST s m (Env d i r s m)
forall (m :: * -> *) d i r s.
(Debuggable m, NodeDatum d) =>
Env d i r s m -> Env d i r s m -> ATMST s m (Env d i r s m)
unionEnv Env d i r s m
e Env d i r s m
env
ATMST s m Bool
-> ATMST s m Bool -> ATMST s m Bool -> ATMST s m Bool
forall (m :: * -> *) a. Monad m => m Bool -> m a -> m a -> m a
ifM (Env d i r s m -> ATMST s m Bool
forall (m :: * -> *) d i r s.
(Monad m, NodeDatum d) =>
Env d i r s m -> ATMST s m Bool
envIsNogood Env d i r s m
e) (Bool -> ATMST s m Bool
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False) (Env d i r s m -> [Node d i r s m] -> ATMST s m Bool
forall (m :: * -> *) d i r s.
(Monad m, NodeDatum d) =>
Env d i r s m -> [Node d i r s m] -> ATMST s m Bool
isWeave Env d i r s m
newEnv [Node d i r s m]
ns))
(Node d i r s m -> ATMST s m [Env d i r s m]
forall (m :: * -> *) d i r s.
(Monad m, NodeDatum d) =>
Node d i r s m -> ATMST s m [Env d i r s m]
getNodeLabel Node d i r s m
n)
isSupportingAntecedent ::
(Monad m, NodeDatum d) =>
[Node d i r s m] -> Env d i r s m -> ATMST s m Bool
isSupportingAntecedent :: [Node d i r s m] -> Env d i r s m -> ATMST s m Bool
isSupportingAntecedent [Node d i r s m]
nodes Env d i r s m
env = (Node d i r s m -> ATMST s m Bool)
-> [Node d i r s m] -> ATMST s m Bool
forall (m :: * -> *) a. Monad m => (a -> m Bool) -> [a] -> m Bool
allByM (\Node d i r s m
n -> Node d i r s m -> Env d i r s m -> ATMST s m Bool
forall (m :: * -> *) d i r s.
(Monad m, NodeDatum d) =>
Node d i r s m -> Env d i r s m -> ATMST s m Bool
isInNodeByEnv Node d i r s m
n Env d i r s m
env) [Node d i r s m]
nodes
removeNode :: (Monad m, NodeDatum d) => Node d i r s m -> ATMST s m ()
removeNode :: Node d i r s m -> ATMST s m ()
removeNode Node d i r s m
node = do
let atms :: ATMS d i r s m
atms = Node d i r s m -> ATMS d i r s m
forall d i r s (m :: * -> *).
(Monad m, NodeDatum d) =>
Node d i r s m -> ATMS d i r s m
nodeATMS Node d i r s m
node
ATMST s m Bool -> ATMST s m () -> ATMST s m ()
forall (m :: * -> *). Monad m => m Bool -> m () -> m ()
whenM (([JustRule d i r s m] -> Bool)
-> ATMST s m [JustRule d i r s m] -> ATMST s m Bool
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Bool -> Bool
not (Bool -> Bool)
-> ([JustRule d i r s m] -> Bool) -> [JustRule d i r s m] -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [JustRule d i r s m] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null) (ATMST s m [JustRule d i r s m] -> ATMST s m Bool)
-> ATMST s m [JustRule d i r s m] -> ATMST s m Bool
forall a b. (a -> b) -> a -> b
$ Node d i r s m -> ATMST s m [JustRule d i r s m]
forall (m :: * -> *) d i r s.
(Monad m, NodeDatum d) =>
Node d i r s m -> ATMST s m [JustRule d i r s m]
getNodeConsequences Node d i r s m
node) (ATMST s m () -> ATMST s m ()) -> ATMST s m () -> ATMST s m ()
forall a b. (a -> b) -> a -> b
$ do
Node d i r s m -> String
nodeStr <- ATMS d i r s m -> ATMST s m (Node d i r s m -> String)
forall (m :: * -> *) d i r s.
(Monad m, NodeDatum d) =>
ATMS d i r s m -> ATMST s m (Node d i r s m -> String)
getNodeString ATMS d i r s m
atms
ExceptT AtmsErr (StateT AtmstState (STT s m)) () -> ATMST s m ()
forall (m :: * -> *) s r.
Monad m =>
ExceptT AtmsErr (StateT AtmstState (STT s m)) r -> ATMST s m r
exceptLayer (ExceptT AtmsErr (StateT AtmstState (STT s m)) () -> ATMST s m ())
-> ExceptT AtmsErr (StateT AtmstState (STT s m)) () -> ATMST s m ()
forall a b. (a -> b) -> a -> b
$ AtmsErr -> ExceptT AtmsErr (StateT AtmstState (STT s m)) ()
forall (m :: * -> *) e a. Monad m => e -> ExceptT e m a
throwE (AtmsErr -> ExceptT AtmsErr (StateT AtmstState (STT s m)) ())
-> AtmsErr -> ExceptT AtmsErr (StateT AtmstState (STT s m)) ()
forall a b. (a -> b) -> a -> b
$
String -> Int -> AtmsErr
CannotRemoveNodeWIthConsequences (Node d i r s m -> String
nodeStr Node d i r s m
node) (Node d i r s m -> Int
forall d i r s (m :: * -> *).
(Monad m, NodeDatum d) =>
Node d i r s m -> Int
nodeIndex Node d i r s m
node)
let nodeRef :: STRef s [Node d i r s m]
nodeRef = ATMS d i r s m -> STRef s [Node d i r s m]
forall d i r s (m :: * -> *).
(Monad m, NodeDatum d) =>
ATMS d i r s m -> STRef s [Node d i r s m]
atmsNodes ATMS d i r s m
atms
in STT s m () -> ATMST s m ()
forall (m :: * -> *) s r. Monad m => STT s m r -> ATMST s m r
sttLayer (STT s m () -> ATMST s m ()) -> STT s m () -> ATMST s m ()
forall a b. (a -> b) -> a -> b
$ STRef s [Node d i r s m] -> STT s m [Node d i r s m]
forall (m :: * -> *) s a. Applicative m => STRef s a -> STT s m a
readSTRef STRef s [Node d i r s m]
nodeRef STT s m [Node d i r s m]
-> ([Node d i r s m] -> STT s m ()) -> STT s m ()
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= STRef s [Node d i r s m] -> [Node d i r s m] -> STT s m ()
forall (m :: * -> *) s a.
Applicative m =>
STRef s a -> a -> STT s m ()
writeSTRef STRef s [Node d i r s m]
nodeRef ([Node d i r s m] -> STT s m ())
-> ([Node d i r s m] -> [Node d i r s m])
-> [Node d i r s m]
-> STT s m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Node d i r s m -> [Node d i r s m] -> [Node d i r s m]
forall a. Eq a => a -> [a] -> [a]
delete Node d i r s m
node
(STT s m [Justification d i r s m]
-> ATMST s m [Justification d i r s m])
-> STRef s [Justification d i r s m]
-> (Justification d i r s m -> ATMST s m ())
-> ATMST s m ()
forall (m :: * -> *) (m0 :: * -> *) (t :: * -> *) s a.
(Monad m, Monad m0, Foldable t) =>
(STT s m0 (t a) -> m (t a)) -> STRef s (t a) -> (a -> m ()) -> m ()
forRM_ STT s m [Justification d i r s m]
-> ATMST s m [Justification d i r s m]
forall (m :: * -> *) s r. Monad m => STT s m r -> ATMST s m r
sttLayer (Node d i r s m -> STRef s [Justification d i r s m]
forall d i r s (m :: * -> *).
(Monad m, NodeDatum d) =>
Node d i r s m -> STRef s [Justification d i r s m]
nodeJusts Node d i r s m
node) ((Justification d i r s m -> ATMST s m ()) -> ATMST s m ())
-> (Justification d i r s m -> ATMST s m ()) -> ATMST s m ()
forall a b. (a -> b) -> a -> b
$ \ Justification d i r s m
justification ->
case Justification d i r s m
justification of
ByRule JustRule d i r s m
justRule -> [Node d i r s m]
-> (Node d i r s m -> ATMST s m ()) -> ATMST s m ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ (JustRule d i r s m -> [Node d i r s m]
forall d i r s (m :: * -> *).
(Monad m, NodeDatum d) =>
JustRule d i r s m -> [Node d i r s m]
justAntecedents JustRule d i r s m
justRule) ((Node d i r s m -> ATMST s m ()) -> ATMST s m ())
-> (Node d i r s m -> ATMST s m ()) -> ATMST s m ()
forall a b. (a -> b) -> a -> b
$ \ Node d i r s m
ant -> do
let conseqRef :: STRef s [JustRule d i r s m]
conseqRef = Node d i r s m -> STRef s [JustRule d i r s m]
forall d i r s (m :: * -> *).
(Monad m, NodeDatum d) =>
Node d i r s m -> STRef s [JustRule d i r s m]
nodeConsequences Node d i r s m
ant
in STT s m () -> ATMST s m ()
forall (m :: * -> *) s r. Monad m => STT s m r -> ATMST s m r
sttLayer (STT s m () -> ATMST s m ()) -> STT s m () -> ATMST s m ()
forall a b. (a -> b) -> a -> b
$
STRef s [JustRule d i r s m] -> STT s m [JustRule d i r s m]
forall (m :: * -> *) s a. Applicative m => STRef s a -> STT s m a
readSTRef STRef s [JustRule d i r s m]
conseqRef STT s m [JustRule d i r s m]
-> ([JustRule d i r s m] -> STT s m ()) -> STT s m ()
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= STRef s [JustRule d i r s m] -> [JustRule d i r s m] -> STT s m ()
forall (m :: * -> *) s a.
Applicative m =>
STRef s a -> a -> STT s m ()
writeSTRef STRef s [JustRule d i r s m]
conseqRef ([JustRule d i r s m] -> STT s m ())
-> ([JustRule d i r s m] -> [JustRule d i r s m])
-> [JustRule d i r s m]
-> STT s m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. JustRule d i r s m -> [JustRule d i r s m] -> [JustRule d i r s m]
forall a. Eq a => a -> [a] -> [a]
delete JustRule d i r s m
justRule
Justification d i r s m
_ -> ExceptT AtmsErr (StateT AtmstState (STT s m)) () -> ATMST s m ()
forall (m :: * -> *) s r.
Monad m =>
ExceptT AtmsErr (StateT AtmstState (STT s m)) r -> ATMST s m r
exceptLayer (ExceptT AtmsErr (StateT AtmstState (STT s m)) () -> ATMST s m ())
-> ExceptT AtmsErr (StateT AtmstState (STT s m)) () -> ATMST s m ()
forall a b. (a -> b) -> a -> b
$ AtmsErr -> ExceptT AtmsErr (StateT AtmstState (STT s m)) ()
forall (m :: * -> *) e a. Monad m => e -> ExceptT e m a
throwE (AtmsErr -> ExceptT AtmsErr (StateT AtmstState (STT s m)) ())
-> AtmsErr -> ExceptT AtmsErr (StateT AtmstState (STT s m)) ()
forall a b. (a -> b) -> a -> b
$ AtmsErr
UnexpectedNonruleJustification
(STT s m [Env d i r s m] -> ATMST s m [Env d i r s m])
-> STRef s [Env d i r s m]
-> (Env d i r s m -> ATMST s m ())
-> ATMST s m ()
forall (m :: * -> *) (m0 :: * -> *) (t :: * -> *) s a.
(Monad m, Monad m0, Foldable t) =>
(STT s m0 (t a) -> m (t a)) -> STRef s (t a) -> (a -> m ()) -> m ()
forRM_ STT s m [Env d i r s m] -> ATMST s m [Env d i r s m]
forall (m :: * -> *) s r. Monad m => STT s m r -> ATMST s m r
sttLayer (Node d i r s m -> STRef s [Env d i r s m]
forall d i r s (m :: * -> *).
(Monad m, NodeDatum d) =>
Node d i r s m -> STRef s [Env d i r s m]
nodeLabel Node d i r s m
node) ((Env d i r s m -> ATMST s m ()) -> ATMST s m ())
-> (Env d i r s m -> ATMST s m ()) -> ATMST s m ()
forall a b. (a -> b) -> a -> b
$ \ Env d i r s m
env -> do
let nodesRef :: STRef s [Node d i r s m]
nodesRef = Env d i r s m -> STRef s [Node d i r s m]
forall d i r s (m :: * -> *).
(Monad m, NodeDatum d) =>
Env d i r s m -> STRef s [Node d i r s m]
envNodes Env d i r s m
env
in STT s m () -> ATMST s m ()
forall (m :: * -> *) s r. Monad m => STT s m r -> ATMST s m r
sttLayer (STT s m () -> ATMST s m ()) -> STT s m () -> ATMST s m ()
forall a b. (a -> b) -> a -> b
$ STRef s [Node d i r s m] -> STT s m [Node d i r s m]
forall (m :: * -> *) s a. Applicative m => STRef s a -> STT s m a
readSTRef STRef s [Node d i r s m]
nodesRef STT s m [Node d i r s m]
-> ([Node d i r s m] -> STT s m ()) -> STT s m ()
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= STRef s [Node d i r s m] -> [Node d i r s m] -> STT s m ()
forall (m :: * -> *) s a.
Applicative m =>
STRef s a -> a -> STT s m ()
writeSTRef STRef s [Node d i r s m]
nodesRef ([Node d i r s m] -> STT s m ())
-> ([Node d i r s m] -> [Node d i r s m])
-> [Node d i r s m]
-> STT s m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Node d i r s m -> [Node d i r s m] -> [Node d i r s m]
forall a. Eq a => a -> [a] -> [a]
delete Node d i r s m
node
createEnv ::
(Debuggable m, NodeDatum d) =>
ATMS d i r s m -> [Node d i r s m] -> ATMST s m (Env d i r s m)
createEnv :: ATMS d i r s m -> [Node d i r s m] -> ATMST s m (Env d i r s m)
createEnv ATMS d i r s m
atms [Node d i r s m]
assumptions = do
$(dbg [| debugCreateEnvStart assumptions |])
Int
index <- ATMS d i r s m -> ATMST s m Int
forall (m :: * -> *) d i r s.
(Monad m, NodeDatum d) =>
ATMS d i r s m -> ATMST s m Int
nextEnvCounter ATMS d i r s m
atms
STRef s (WhyNogood d i r s m)
whyNogood <- STT s m (STRef s (WhyNogood d i r s m))
-> ATMST s m (STRef s (WhyNogood d i r s m))
forall (m :: * -> *) s r. Monad m => STT s m r -> ATMST s m r
sttLayer (STT s m (STRef s (WhyNogood d i r s m))
-> ATMST s m (STRef s (WhyNogood d i r s m)))
-> STT s m (STRef s (WhyNogood d i r s m))
-> ATMST s m (STRef s (WhyNogood d i r s m))
forall a b. (a -> b) -> a -> b
$ WhyNogood d i r s m -> STT s m (STRef s (WhyNogood d i r s m))
forall (m :: * -> *) a s. Applicative m => a -> STT s m (STRef s a)
newSTRef WhyNogood d i r s m
forall d i r s (m :: * -> *). WhyNogood d i r s m
Good
STRef s [Node d i r s m]
nodes <- STT s m (STRef s [Node d i r s m])
-> ATMST s m (STRef s [Node d i r s m])
forall (m :: * -> *) s r. Monad m => STT s m r -> ATMST s m r
sttLayer (STT s m (STRef s [Node d i r s m])
-> ATMST s m (STRef s [Node d i r s m]))
-> STT s m (STRef s [Node d i r s m])
-> ATMST s m (STRef s [Node d i r s m])
forall a b. (a -> b) -> a -> b
$ [Node d i r s m] -> STT s m (STRef s [Node d i r s m])
forall (m :: * -> *) a s. Applicative m => a -> STT s m (STRef s a)
newSTRef []
STRef s [r]
rules <- STT s m (STRef s [r]) -> ATMST s m (STRef s [r])
forall (m :: * -> *) s r. Monad m => STT s m r -> ATMST s m r
sttLayer (STT s m (STRef s [r]) -> ATMST s m (STRef s [r]))
-> STT s m (STRef s [r]) -> ATMST s m (STRef s [r])
forall a b. (a -> b) -> a -> b
$ [r] -> STT s m (STRef s [r])
forall (m :: * -> *) a s. Applicative m => a -> STT s m (STRef s a)
newSTRef []
let env :: Env d i r s m
env = Int
-> Int
-> [Node d i r s m]
-> STRef s [Node d i r s m]
-> STRef s (WhyNogood d i r s m)
-> STRef s [r]
-> Env d i r s m
forall d i r s (m :: * -> *).
Int
-> Int
-> [Node d i r s m]
-> STRef s [Node d i r s m]
-> STRef s (WhyNogood d i r s m)
-> STRef s [r]
-> Env d i r s m
Env Int
index ([Node d i r s m] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Node d i r s m]
assumptions) [Node d i r s m]
assumptions STRef s [Node d i r s m]
nodes STRef s (WhyNogood d i r s m)
whyNogood STRef s [r]
rules
$(dbg [| debugCreateEnvEnv env |])
ATMS d i r s m
-> STRef s (EnvTable d i r s m) -> Env d i r s m -> ATMST s m ()
forall (m :: * -> *) d i r s.
(Monad m, NodeDatum d) =>
ATMS d i r s m
-> STRef s (EnvTable d i r s m) -> Env d i r s m -> ATMST s m ()
insertInTable ATMS d i r s m
atms (ATMS d i r s m -> STRef s (EnvTable d i r s m)
forall d i r s (m :: * -> *).
(Monad m, NodeDatum d) =>
ATMS d i r s m -> STRef s (EnvTable d i r s m)
atmsEnvTable ATMS d i r s m
atms) Env d i r s m
env
$(dbg [| debugCreateEnvEnv env |])
ATMS d i r s m -> Env d i r s m -> ATMST s m ()
forall (m :: * -> *) d i r s.
(Debuggable m, NodeDatum d) =>
ATMS d i r s m -> Env d i r s m -> ATMST s m ()
setEnvContradictory ATMS d i r s m
atms Env d i r s m
env
$(dbg [| debugCreateEnvEnv env |])
Env d i r s m -> ATMST s m (Env d i r s m)
forall (m :: * -> *) a. Monad m => a -> m a
return Env d i r s m
env
debugCreateEnvStart ::
(MonadIO m, NodeDatum d) => [Node d i r s m] -> ATMST s m ()
debugCreateEnvStart :: [Node d i r s m] -> ATMST s m ()
debugCreateEnvStart [Node d i r s m]
nodes = do
IO () -> ATMST s m ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> ATMST s m ()) -> IO () -> ATMST s m ()
forall a b. (a -> b) -> a -> b
$ String -> IO ()
putStrLn (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String
" - Running createEnv"
String
astr <- String -> [Node d i r s m] -> ATMST s m String
forall (m :: * -> *) d i r s.
(Monad m, NodeDatum d) =>
String -> [Node d i r s m] -> ATMST s m String
formatNodes String
"," [Node d i r s m]
nodes
IO () -> ATMST s m ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> ATMST s m ()) -> IO () -> ATMST s m ()
forall a b. (a -> b) -> a -> b
$ String -> IO ()
putStrLn (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String
" assumptions " String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
astr
debugCreateEnvEnv ::
(MonadIO m, NodeDatum d) => (Env d i r s m) -> ATMST s m ()
debugCreateEnvEnv :: Env d i r s m -> ATMST s m ()
debugCreateEnvEnv Env d i r s m
env = do
IO () -> ATMST s m ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> ATMST s m ()) -> IO () -> ATMST s m ()
forall a b. (a -> b) -> a -> b
$ String -> IO ()
putStr (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String
" env "
Env d i r s m -> ATMST s m ()
forall (m :: * -> *) d i r s.
(MonadIO m, NodeDatum d) =>
Env d i r s m -> ATMST s m ()
blurbEnv Env d i r s m
env
IO () -> ATMST s m ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> ATMST s m ()) -> IO () -> ATMST s m ()
forall a b. (a -> b) -> a -> b
$ String -> IO ()
putStrLn String
""
unionEnv ::
(Debuggable m, NodeDatum d) =>
Env d i r s m -> Env d i r s m -> ATMST s m (Env d i r s m)
unionEnv :: Env d i r s m -> Env d i r s m -> ATMST s m (Env d i r s m)
unionEnv Env d i r s m
e1 Env d i r s m
e2 =
if Env d i r s m -> Int
forall d i r s (m :: * -> *).
(Monad m, NodeDatum d) =>
Env d i r s m -> Int
envCount Env d i r s m
e1 Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Env d i r s m -> Int
forall d i r s (m :: * -> *).
(Monad m, NodeDatum d) =>
Env d i r s m -> Int
envCount Env d i r s m
e2 then Env d i r s m -> Env d i r s m -> ATMST s m (Env d i r s m)
forall (m :: * -> *) d i r s.
(Monad m, NodeDatum d) =>
Env d i r s m -> Env d i r s m -> ATMST s m (Env d i r s m)
unionEnv' Env d i r s m
e2 Env d i r s m
e1 else Env d i r s m -> Env d i r s m -> ATMST s m (Env d i r s m)
forall (m :: * -> *) d i r s.
(Monad m, NodeDatum d) =>
Env d i r s m -> Env d i r s m -> ATMST s m (Env d i r s m)
unionEnv' Env d i r s m
e1 Env d i r s m
e2
where unionEnv' :: Env d i r s m -> Env d i r s m -> ATMST s m (Env d i r s m)
unionEnv' Env d i r s m
e1 Env d i r s m
e2 = do
$(dbg [| debugUnionEnvStart e1 e2 |])
STRef s (Env d i r s m)
acc <- STT s m (STRef s (Env d i r s m))
-> ATMST s m (STRef s (Env d i r s m))
forall (m :: * -> *) s r. Monad m => STT s m r -> ATMST s m r
sttLayer (STT s m (STRef s (Env d i r s m))
-> ATMST s m (STRef s (Env d i r s m)))
-> STT s m (STRef s (Env d i r s m))
-> ATMST s m (STRef s (Env d i r s m))
forall a b. (a -> b) -> a -> b
$ Env d i r s m -> STT s m (STRef s (Env d i r s m))
forall (m :: * -> *) a s. Applicative m => a -> STT s m (STRef s a)
newSTRef Env d i r s m
e2
[Node d i r s m]
-> ATMST s m Bool
-> (Node d i r s m -> ATMST s m ())
-> ATMST s m ()
forall (m :: * -> *) a.
Monad m =>
[a] -> m Bool -> (a -> m ()) -> m ()
forMwhile_ (Env d i r s m -> [Node d i r s m]
forall d i r s (m :: * -> *).
(Monad m, NodeDatum d) =>
Env d i r s m -> [Node d i r s m]
envAssumptions Env d i r s m
e1)
(do Env d i r s m
thisE2 <- STT s m (Env d i r s m) -> ATMST s m (Env d i r s m)
forall (m :: * -> *) s r. Monad m => STT s m r -> ATMST s m r
sttLayer (STT s m (Env d i r s m) -> ATMST s m (Env d i r s m))
-> STT s m (Env d i r s m) -> ATMST s m (Env d i r s m)
forall a b. (a -> b) -> a -> b
$ STRef s (Env d i r s m) -> STT s m (Env d i r s m)
forall (m :: * -> *) s a. Applicative m => STRef s a -> STT s m a
readSTRef STRef s (Env d i r s m)
acc
ATMST s m Bool -> ATMST s m Bool
forall (m :: * -> *). Functor m => m Bool -> m Bool
notM (ATMST s m Bool -> ATMST s m Bool)
-> ATMST s m Bool -> ATMST s m Bool
forall a b. (a -> b) -> a -> b
$ Env d i r s m -> ATMST s m Bool
forall (m :: * -> *) d i r s.
(Monad m, NodeDatum d) =>
Env d i r s m -> ATMST s m Bool
envIsNogood Env d i r s m
thisE2) ((Node d i r s m -> ATMST s m ()) -> ATMST s m ())
-> (Node d i r s m -> ATMST s m ()) -> ATMST s m ()
forall a b. (a -> b) -> a -> b
$ \Node d i r s m
assume -> do
Env d i r s m
oldE2 <- STT s m (Env d i r s m) -> ATMST s m (Env d i r s m)
forall (m :: * -> *) s r. Monad m => STT s m r -> ATMST s m r
sttLayer (STT s m (Env d i r s m) -> ATMST s m (Env d i r s m))
-> STT s m (Env d i r s m) -> ATMST s m (Env d i r s m)
forall a b. (a -> b) -> a -> b
$ STRef s (Env d i r s m) -> STT s m (Env d i r s m)
forall (m :: * -> *) s a. Applicative m => STRef s a -> STT s m a
readSTRef STRef s (Env d i r s m)
acc
$(dbg [| debugUnionEnvLoopStart assume oldE2 |])
Env d i r s m
newE2 <- Node d i r s m -> Env d i r s m -> ATMST s m (Env d i r s m)
forall (m :: * -> *) d i r s.
(Debuggable m, NodeDatum d) =>
Node d i r s m -> Env d i r s m -> ATMST s m (Env d i r s m)
consEnv Node d i r s m
assume Env d i r s m
oldE2
$(dbg [| debugUnionEnvLoopCons newE2 |])
STT s m () -> ATMST s m ()
forall (m :: * -> *) s r. Monad m => STT s m r -> ATMST s m r
sttLayer (STT s m () -> ATMST s m ()) -> STT s m () -> ATMST s m ()
forall a b. (a -> b) -> a -> b
$ STRef s (Env d i r s m) -> Env d i r s m -> STT s m ()
forall (m :: * -> *) s a.
Applicative m =>
STRef s a -> a -> STT s m ()
writeSTRef STRef s (Env d i r s m)
acc Env d i r s m
newE2
Env d i r s m
result <- STT s m (Env d i r s m) -> ATMST s m (Env d i r s m)
forall (m :: * -> *) s r. Monad m => STT s m r -> ATMST s m r
sttLayer (STT s m (Env d i r s m) -> ATMST s m (Env d i r s m))
-> STT s m (Env d i r s m) -> ATMST s m (Env d i r s m)
forall a b. (a -> b) -> a -> b
$ STRef s (Env d i r s m) -> STT s m (Env d i r s m)
forall (m :: * -> *) s a. Applicative m => STRef s a -> STT s m a
readSTRef STRef s (Env d i r s m)
acc
$(dbg [| debugUnionEnvResult result |])
Env d i r s m -> ATMST s m (Env d i r s m)
forall (m :: * -> *) a. Monad m => a -> m a
return Env d i r s m
result
debugUnionEnvStart ::
(MonadIO m, NodeDatum d) => Env d i r s m -> Env d i r s m -> ATMST s m ()
debugUnionEnvStart :: Env d i r s m -> Env d i r s m -> ATMST s m ()
debugUnionEnvStart Env d i r s m
e1 Env d i r s m
e2 = do
IO () -> ATMST s m ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> ATMST s m ()) -> IO () -> ATMST s m ()
forall a b. (a -> b) -> a -> b
$ String -> IO ()
putStr String
" - Starting unionEnv' with "
Env d i r s m -> ATMST s m ()
forall (m :: * -> *) d i r s.
(MonadIO m, NodeDatum d) =>
Env d i r s m -> ATMST s m ()
blurbEnv Env d i r s m
e1
IO () -> ATMST s m ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> ATMST s m ()) -> IO () -> ATMST s m ()
forall a b. (a -> b) -> a -> b
$ String -> IO ()
putStr String
"; "
Env d i r s m -> ATMST s m ()
forall (m :: * -> *) d i r s.
(MonadIO m, NodeDatum d) =>
Env d i r s m -> ATMST s m ()
blurbEnv Env d i r s m
e2
IO () -> ATMST s m ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> ATMST s m ()) -> IO () -> ATMST s m ()
forall a b. (a -> b) -> a -> b
$ String -> IO ()
putStrLn String
""
debugUnionEnvLoopStart ::
(MonadIO m, NodeDatum d) => Node d i r s m -> Env d i r s m -> ATMST s m ()
debugUnionEnvLoopStart :: Node d i r s m -> Env d i r s m -> ATMST s m ()
debugUnionEnvLoopStart Node d i r s m
node Env d i r s m
e2 = do
d -> String
datumFmt <- ATMS d i r s m -> ATMST s m (d -> String)
forall (m :: * -> *) d i r s.
(Monad m, NodeDatum d) =>
ATMS d i r s m -> ATMST s m (d -> String)
getDatumString (ATMS d i r s m -> ATMST s m (d -> String))
-> ATMS d i r s m -> ATMST s m (d -> String)
forall a b. (a -> b) -> a -> b
$ Node d i r s m -> ATMS d i r s m
forall d i r s (m :: * -> *).
(Monad m, NodeDatum d) =>
Node d i r s m -> ATMS d i r s m
nodeATMS Node d i r s m
node
IO () -> ATMST s m ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> ATMST s m ()) -> IO () -> ATMST s m ()
forall a b. (a -> b) -> a -> b
$ String -> IO ()
putStrLn (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String
" - Running loop with"
IO () -> ATMST s m ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> ATMST s m ()) -> IO () -> ATMST s m ()
forall a b. (a -> b) -> a -> b
$ String -> IO ()
putStrLn (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String
" node " String -> ShowS
forall a. [a] -> [a] -> [a]
++ d -> String
datumFmt (Node d i r s m -> d
forall d i r s (m :: * -> *).
(Monad m, NodeDatum d) =>
Node d i r s m -> d
nodeDatum Node d i r s m
node)
IO () -> ATMST s m ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> ATMST s m ()) -> IO () -> ATMST s m ()
forall a b. (a -> b) -> a -> b
$ String -> IO ()
putStr String
" env "
Env d i r s m -> ATMST s m ()
forall (m :: * -> *) d i r s.
(MonadIO m, NodeDatum d) =>
Env d i r s m -> ATMST s m ()
blurbEnv Env d i r s m
e2
IO () -> ATMST s m ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> ATMST s m ()) -> IO () -> ATMST s m ()
forall a b. (a -> b) -> a -> b
$ String -> IO ()
putStrLn String
""
debugUnionEnvLoopCons ::
(MonadIO m, NodeDatum d) => Env d i r s m -> ATMST s m ()
debugUnionEnvLoopCons :: Env d i r s m -> ATMST s m ()
debugUnionEnvLoopCons Env d i r s m
e = do
IO () -> ATMST s m ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> ATMST s m ()) -> IO () -> ATMST s m ()
forall a b. (a -> b) -> a -> b
$ String -> IO ()
putStr String
" consEnv returns "
Env d i r s m -> ATMST s m ()
forall (m :: * -> *) d i r s.
(MonadIO m, NodeDatum d) =>
Env d i r s m -> ATMST s m ()
blurbEnv Env d i r s m
e
IO () -> ATMST s m ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> ATMST s m ()) -> IO () -> ATMST s m ()
forall a b. (a -> b) -> a -> b
$ String -> IO ()
putStrLn String
""
debugUnionEnvResult ::
(MonadIO m, NodeDatum d) => Env d i r s m -> ATMST s m ()
debugUnionEnvResult :: Env d i r s m -> ATMST s m ()
debugUnionEnvResult Env d i r s m
result = do
IO () -> ATMST s m ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> ATMST s m ()) -> IO () -> ATMST s m ()
forall a b. (a -> b) -> a -> b
$ String -> IO ()
putStr String
" unionEnv returns "
Env d i r s m -> ATMST s m ()
forall (m :: * -> *) d i r s.
(MonadIO m, NodeDatum d) =>
Env d i r s m -> ATMST s m ()
blurbEnv Env d i r s m
result
IO () -> ATMST s m ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> ATMST s m ()) -> IO () -> ATMST s m ()
forall a b. (a -> b) -> a -> b
$ String -> IO ()
putStrLn String
""
consEnv ::
(Debuggable m, NodeDatum d) =>
Node d i r s m -> Env d i r s m -> ATMST s m (Env d i r s m)
consEnv :: Node d i r s m -> Env d i r s m -> ATMST s m (Env d i r s m)
consEnv Node d i r s m
assumption Env d i r s m
env = do
$(dbg [| debugConsEnvStart assumption env |])
let nassumes :: [Node d i r s m]
nassumes = Node d i r s m
-> [Node d i r s m]
-> (Node d i r s m -> Node d i r s m -> Bool)
-> [Node d i r s m]
forall a. Eq a => a -> [a] -> (a -> a -> Bool) -> [a]
orderedInsert Node d i r s m
assumption (Env d i r s m -> [Node d i r s m]
forall d i r s (m :: * -> *).
(Monad m, NodeDatum d) =>
Env d i r s m -> [Node d i r s m]
envAssumptions Env d i r s m
env) Node d i r s m -> Node d i r s m -> Bool
forall (m :: * -> *) d i r s.
(Monad m, NodeDatum d) =>
Node d i r s m -> Node d i r s m -> Bool
assumptionOrder
$(dbg [| debugConsEnvInserted nassumes |])
Maybe (Env d i r s m)
envByLookup <- [Node d i r s m] -> ATMST s m (Maybe (Env d i r s m))
forall (m :: * -> *) d i r s.
(Monad m, NodeDatum d) =>
[Node d i r s m] -> ATMST s m (Maybe (Env d i r s m))
lookupEnv [Node d i r s m]
nassumes
$(dbg [| debugConsEnvLookup envByLookup |])
ATMST s m (Env d i r s m)
-> (Env d i r s m -> ATMST s m (Env d i r s m))
-> Maybe (Env d i r s m)
-> ATMST s m (Env d i r s m)
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (ATMS d i r s m -> [Node d i r s m] -> ATMST s m (Env d i r s m)
forall (m :: * -> *) d i r s.
(Debuggable m, NodeDatum d) =>
ATMS d i r s m -> [Node d i r s m] -> ATMST s m (Env d i r s m)
createEnv (Node d i r s m -> ATMS d i r s m
forall d i r s (m :: * -> *).
(Monad m, NodeDatum d) =>
Node d i r s m -> ATMS d i r s m
nodeATMS Node d i r s m
assumption) [Node d i r s m]
nassumes) (Env d i r s m -> ATMST s m (Env d i r s m)
forall (m :: * -> *) a. Monad m => a -> m a
return (Env d i r s m -> ATMST s m (Env d i r s m))
-> (Env d i r s m -> Env d i r s m)
-> Env d i r s m
-> ATMST s m (Env d i r s m)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Env d i r s m -> Env d i r s m
forall a. a -> a
id) Maybe (Env d i r s m)
envByLookup
debugConsEnvStart ::
(MonadIO m, NodeDatum d) => Node d i r s m -> Env d i r s m -> ATMST s m ()
debugConsEnvStart :: Node d i r s m -> Env d i r s m -> ATMST s m ()
debugConsEnvStart Node d i r s m
node Env d i r s m
e2 = do
d -> String
datumFmt <- ATMS d i r s m -> ATMST s m (d -> String)
forall (m :: * -> *) d i r s.
(Monad m, NodeDatum d) =>
ATMS d i r s m -> ATMST s m (d -> String)
getDatumString (ATMS d i r s m -> ATMST s m (d -> String))
-> ATMS d i r s m -> ATMST s m (d -> String)
forall a b. (a -> b) -> a -> b
$ Node d i r s m -> ATMS d i r s m
forall d i r s (m :: * -> *).
(Monad m, NodeDatum d) =>
Node d i r s m -> ATMS d i r s m
nodeATMS Node d i r s m
node
IO () -> ATMST s m ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> ATMST s m ()) -> IO () -> ATMST s m ()
forall a b. (a -> b) -> a -> b
$ String -> IO ()
putStrLn (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String
" - Running consEnv"
IO () -> ATMST s m ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> ATMST s m ()) -> IO () -> ATMST s m ()
forall a b. (a -> b) -> a -> b
$ String -> IO ()
putStrLn (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String
" inserting node " String -> ShowS
forall a. [a] -> [a] -> [a]
++ d -> String
datumFmt (Node d i r s m -> d
forall d i r s (m :: * -> *).
(Monad m, NodeDatum d) =>
Node d i r s m -> d
nodeDatum Node d i r s m
node)
IO () -> ATMST s m ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> ATMST s m ()) -> IO () -> ATMST s m ()
forall a b. (a -> b) -> a -> b
$ String -> IO ()
putStr String
" into env "
Env d i r s m -> ATMST s m ()
forall (m :: * -> *) d i r s.
(MonadIO m, NodeDatum d) =>
Env d i r s m -> ATMST s m ()
blurbEnv Env d i r s m
e2
IO () -> ATMST s m ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> ATMST s m ()) -> IO () -> ATMST s m ()
forall a b. (a -> b) -> a -> b
$ String -> IO ()
putStrLn String
""
debugConsEnvInserted ::
(MonadIO m, NodeDatum d) => [Node d i r s m] -> ATMST s m ()
debugConsEnvInserted :: [Node d i r s m] -> ATMST s m ()
debugConsEnvInserted [Node d i r s m]
nodes =
case [Node d i r s m]
nodes of
[] -> IO () -> ATMST s m ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> ATMST s m ()) -> IO () -> ATMST s m ()
forall a b. (a -> b) -> a -> b
$ String -> IO ()
putStrLn String
" list after insertion: empty list"
(Node d i r s m
n : [Node d i r s m]
_) -> do
d -> String
datumFmt <- ATMS d i r s m -> ATMST s m (d -> String)
forall (m :: * -> *) d i r s.
(Monad m, NodeDatum d) =>
ATMS d i r s m -> ATMST s m (d -> String)
getDatumString (ATMS d i r s m -> ATMST s m (d -> String))
-> ATMS d i r s m -> ATMST s m (d -> String)
forall a b. (a -> b) -> a -> b
$ Node d i r s m -> ATMS d i r s m
forall d i r s (m :: * -> *).
(Monad m, NodeDatum d) =>
Node d i r s m -> ATMS d i r s m
nodeATMS Node d i r s m
n
IO () -> ATMST s m ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> ATMST s m ()) -> IO () -> ATMST s m ()
forall a b. (a -> b) -> a -> b
$ String -> IO ()
putStrLn (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$
String
" list after insertion: ["
String -> ShowS
forall a. [a] -> [a] -> [a]
++ String -> [String] -> String
forall a. [a] -> [[a]] -> [a]
intercalate String
", " ((Node d i r s m -> String) -> [Node d i r s m] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map (d -> String
datumFmt (d -> String) -> (Node d i r s m -> d) -> Node d i r s m -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Node d i r s m -> d
forall d i r s (m :: * -> *).
(Monad m, NodeDatum d) =>
Node d i r s m -> d
nodeDatum) [Node d i r s m]
nodes)
String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
"]"
debugConsEnvLookup ::
(MonadIO m, NodeDatum d) => Maybe (Env d i r s m) -> ATMST s m ()
debugConsEnvLookup :: Maybe (Env d i r s m) -> ATMST s m ()
debugConsEnvLookup Maybe (Env d i r s m)
Nothing =
IO () -> ATMST s m ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> ATMST s m ()) -> IO () -> ATMST s m ()
forall a b. (a -> b) -> a -> b
$ String -> IO ()
putStrLn (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String
" lookup gives Nothing"
debugConsEnvLookup (Just Env d i r s m
env) = do
IO () -> ATMST s m ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> ATMST s m ()) -> IO () -> ATMST s m ()
forall a b. (a -> b) -> a -> b
$ String -> IO ()
putStr (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String
" lookup gives "
Env d i r s m -> ATMST s m ()
forall (m :: * -> *) d i r s.
(MonadIO m, NodeDatum d) =>
Env d i r s m -> ATMST s m ()
blurbEnv Env d i r s m
env
IO () -> ATMST s m ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> ATMST s m ()) -> IO () -> ATMST s m ()
forall a b. (a -> b) -> a -> b
$ String -> IO ()
putStrLn String
""
findOrMakeEnv ::
(Monad m, NodeDatum d) =>
[Node d i r s m] -> ATMS d i r s m -> ATMST s m (Env d i r s m)
findOrMakeEnv :: [Node d i r s m] -> ATMS d i r s m -> ATMST s m (Env d i r s m)
findOrMakeEnv [] ATMS d i r s m
atms = ATMS d i r s m -> ATMST s m (Env d i r s m)
forall (m :: * -> *) d i r s.
(Monad m, NodeDatum d) =>
ATMS d i r s m -> ATMST s m (Env d i r s m)
getEmptyEnvironment ATMS d i r s m
atms
findOrMakeEnv [Node d i r s m]
assumptions ATMS d i r s m
atms = do
Maybe (Env d i r s m)
check <- [Node d i r s m] -> ATMST s m (Maybe (Env d i r s m))
forall (m :: * -> *) d i r s.
(Monad m, NodeDatum d) =>
[Node d i r s m] -> ATMST s m (Maybe (Env d i r s m))
lookupEnv [Node d i r s m]
assumptions
case Maybe (Env d i r s m)
check of
Maybe (Env d i r s m)
Nothing -> ATMS d i r s m -> [Node d i r s m] -> ATMST s m (Env d i r s m)
forall (m :: * -> *) d i r s.
(Debuggable m, NodeDatum d) =>
ATMS d i r s m -> [Node d i r s m] -> ATMST s m (Env d i r s m)
createEnv ATMS d i r s m
atms [Node d i r s m]
assumptions
Just Env d i r s m
env -> Env d i r s m -> ATMST s m (Env d i r s m)
forall (m :: * -> *) a. Monad m => a -> m a
return Env d i r s m
env
insertInTable ::
(Monad m, NodeDatum d) =>
ATMS d i r s m -> STRef s (EnvTable d i r s m) -> Env d i r s m ->
ATMST s m ()
insertInTable :: ATMS d i r s m
-> STRef s (EnvTable d i r s m) -> Env d i r s m -> ATMST s m ()
insertInTable ATMS d i r s m
atms STRef s (EnvTable d i r s m)
tableRef Env d i r s m
env = do
let count :: Int
count = Env d i r s m -> Int
forall d i r s (m :: * -> *).
(Monad m, NodeDatum d) =>
Env d i r s m -> Int
envCount Env d i r s m
env
EnvTable STArray s Int [Env d i r s m]
currentTable <- STT s m (EnvTable d i r s m) -> ATMST s m (EnvTable d i r s m)
forall (m :: * -> *) s r. Monad m => STT s m r -> ATMST s m r
sttLayer (STT s m (EnvTable d i r s m) -> ATMST s m (EnvTable d i r s m))
-> STT s m (EnvTable d i r s m) -> ATMST s m (EnvTable d i r s m)
forall a b. (a -> b) -> a -> b
$ STRef s (EnvTable d i r s m) -> STT s m (EnvTable d i r s m)
forall (m :: * -> *) s a. Applicative m => STRef s a -> STT s m a
readSTRef STRef s (EnvTable d i r s m)
tableRef
let (Int
_, Int
alloc) = STArray s Int [Env d i r s m] -> (Int, Int)
forall s i e. STArray s i e -> (i, i)
boundsSTArray STArray s Int [Env d i r s m]
currentTable
Bool -> ATMST s m () -> ATMST s m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Int
alloc Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
count) (ATMST s m () -> ATMST s m ()) -> ATMST s m () -> ATMST s m ()
forall a b. (a -> b) -> a -> b
$ do
Int
incr <- ATMST s m Int
forall (m :: * -> *) s. Monad m => ATMST s m Int
getEnvTableIncr
let newAlloc :: Int
newAlloc = Int
count Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
incr
STT s m () -> ATMST s m ()
forall (m :: * -> *) s r. Monad m => STT s m r -> ATMST s m r
sttLayer (STT s m () -> ATMST s m ()) -> STT s m () -> ATMST s m ()
forall a b. (a -> b) -> a -> b
$ do
STArray s Int [Env d i r s m]
newArray <- (Int, Int)
-> [Env d i r s m] -> STT s m (STArray s Int [Env d i r s m])
forall i (m :: * -> *) e s.
(Ix i, Applicative m) =>
(i, i) -> e -> STT s m (STArray s i e)
newSTArray (Int
0, Int
newAlloc) []
[Int] -> (Int -> STT s m ()) -> STT s m ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [Int
1..Int
alloc] ((Int -> STT s m ()) -> STT s m ())
-> (Int -> STT s m ()) -> STT s m ()
forall a b. (a -> b) -> a -> b
$ \Int
i -> do
[Env d i r s m]
envs <- STArray s Int [Env d i r s m] -> Int -> STT s m [Env d i r s m]
forall i (m :: * -> *) s e.
(Ix i, Applicative m) =>
STArray s i e -> i -> STT s m e
readSTArray STArray s Int [Env d i r s m]
currentTable Int
i
STArray s Int [Env d i r s m]
-> Int -> [Env d i r s m] -> STT s m ()
forall i (m :: * -> *) s e.
(Ix i, Applicative m) =>
STArray s i e -> i -> e -> STT s m ()
writeSTArray STArray s Int [Env d i r s m]
newArray Int
i [Env d i r s m]
envs
STRef s (EnvTable d i r s m) -> EnvTable d i r s m -> STT s m ()
forall (m :: * -> *) s a.
Applicative m =>
STRef s a -> a -> STT s m ()
writeSTRef STRef s (EnvTable d i r s m)
tableRef (EnvTable d i r s m -> STT s m ())
-> EnvTable d i r s m -> STT s m ()
forall a b. (a -> b) -> a -> b
$ STArray s Int [Env d i r s m] -> EnvTable d i r s m
forall d i r s (m :: * -> *).
STArray s Int [Env d i r s m] -> EnvTable d i r s m
EnvTable STArray s Int [Env d i r s m]
newArray
STT s m () -> ATMST s m ()
forall (m :: * -> *) s r. Monad m => STT s m r -> ATMST s m r
sttLayer (STT s m () -> ATMST s m ()) -> STT s m () -> ATMST s m ()
forall a b. (a -> b) -> a -> b
$ do
EnvTable STArray s Int [Env d i r s m]
array <- STRef s (EnvTable d i r s m) -> STT s m (EnvTable d i r s m)
forall (m :: * -> *) s a. Applicative m => STRef s a -> STT s m a
readSTRef STRef s (EnvTable d i r s m)
tableRef
[Env d i r s m]
oldEnvs <- STArray s Int [Env d i r s m] -> Int -> STT s m [Env d i r s m]
forall i (m :: * -> *) s e.
(Ix i, Applicative m) =>
STArray s i e -> i -> STT s m e
readSTArray STArray s Int [Env d i r s m]
array Int
count
STArray s Int [Env d i r s m]
-> Int -> [Env d i r s m] -> STT s m ()
forall i (m :: * -> *) s e.
(Ix i, Applicative m) =>
STArray s i e -> i -> e -> STT s m ()
writeSTArray STArray s Int [Env d i r s m]
array Int
count ([Env d i r s m] -> STT s m ()) -> [Env d i r s m] -> STT s m ()
forall a b. (a -> b) -> a -> b
$ Env d i r s m
env Env d i r s m -> [Env d i r s m] -> [Env d i r s m]
forall a. a -> [a] -> [a]
: [Env d i r s m]
oldEnvs
lookupEnv ::
(Monad m, NodeDatum d) =>
[Node d i r s m] -> ATMST s m (Maybe (Env d i r s m))
lookupEnv :: [Node d i r s m] -> ATMST s m (Maybe (Env d i r s m))
lookupEnv [] = Maybe (Env d i r s m) -> ATMST s m (Maybe (Env d i r s m))
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe (Env d i r s m)
forall a. Maybe a
Nothing
lookupEnv assumptions :: [Node d i r s m]
assumptions@(Node d i r s m
a : [Node d i r s m]
_) = do
let atms :: ATMS d i r s m
atms = Node d i r s m -> ATMS d i r s m
forall d i r s (m :: * -> *).
(Monad m, NodeDatum d) =>
Node d i r s m -> ATMS d i r s m
nodeATMS Node d i r s m
a
ns :: [Node d i r s m]
ns = (Node d i r s m -> Int) -> [Node d i r s m] -> [Node d i r s m]
forall b a. Ord b => (a -> b) -> [a] -> [a]
sortOn Node d i r s m -> Int
forall d i r s (m :: * -> *).
(Monad m, NodeDatum d) =>
Node d i r s m -> Int
nodeIndex [Node d i r s m]
assumptions
EnvTable STArray s Int [Env d i r s m]
envTable <- STT s m (EnvTable d i r s m) -> ATMST s m (EnvTable d i r s m)
forall (m :: * -> *) s r. Monad m => STT s m r -> ATMST s m r
sttLayer (STT s m (EnvTable d i r s m) -> ATMST s m (EnvTable d i r s m))
-> STT s m (EnvTable d i r s m) -> ATMST s m (EnvTable d i r s m)
forall a b. (a -> b) -> a -> b
$ STRef s (EnvTable d i r s m) -> STT s m (EnvTable d i r s m)
forall (m :: * -> *) s a. Applicative m => STRef s a -> STT s m a
readSTRef (STRef s (EnvTable d i r s m) -> STT s m (EnvTable d i r s m))
-> STRef s (EnvTable d i r s m) -> STT s m (EnvTable d i r s m)
forall a b. (a -> b) -> a -> b
$ ATMS d i r s m -> STRef s (EnvTable d i r s m)
forall d i r s (m :: * -> *).
(Monad m, NodeDatum d) =>
ATMS d i r s m -> STRef s (EnvTable d i r s m)
atmsEnvTable ATMS d i r s m
atms
[Env d i r s m]
entries <- STT s m [Env d i r s m] -> ATMST s m [Env d i r s m]
forall (m :: * -> *) s r. Monad m => STT s m r -> ATMST s m r
sttLayer (STT s m [Env d i r s m] -> ATMST s m [Env d i r s m])
-> STT s m [Env d i r s m] -> ATMST s m [Env d i r s m]
forall a b. (a -> b) -> a -> b
$ STArray s Int [Env d i r s m] -> Int -> STT s m [Env d i r s m]
forall i (m :: * -> *) s e.
(Ix i, Applicative m) =>
STArray s i e -> i -> STT s m e
readSTArray STArray s Int [Env d i r s m]
envTable (Int -> STT s m [Env d i r s m]) -> Int -> STT s m [Env d i r s m]
forall a b. (a -> b) -> a -> b
$ [Node d i r s m] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Node d i r s m]
ns
case (Env d i r s m -> Bool) -> [Env d i r s m] -> [Env d i r s m]
forall a. (a -> Bool) -> [a] -> [a]
filter (\Env d i r s m
x -> Env d i r s m -> [Node d i r s m]
forall d i r s (m :: * -> *).
(Monad m, NodeDatum d) =>
Env d i r s m -> [Node d i r s m]
envAssumptions Env d i r s m
x [Node d i r s m] -> [Node d i r s m] -> Bool
forall a. Eq a => a -> a -> Bool
== [Node d i r s m]
ns) [Env d i r s m]
entries of
[] -> Maybe (Env d i r s m) -> ATMST s m (Maybe (Env d i r s m))
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe (Env d i r s m)
forall a. Maybe a
Nothing
(Env d i r s m
x : [Env d i r s m]
_) -> Maybe (Env d i r s m) -> ATMST s m (Maybe (Env d i r s m))
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe (Env d i r s m) -> ATMST s m (Maybe (Env d i r s m)))
-> Maybe (Env d i r s m) -> ATMST s m (Maybe (Env d i r s m))
forall a b. (a -> b) -> a -> b
$ Env d i r s m -> Maybe (Env d i r s m)
forall a. a -> Maybe a
Just Env d i r s m
x
isSubsetEnv :: (Monad m, NodeDatum d) => Env d i r s m -> Env d i r s m -> Bool
isSubsetEnv :: Env d i r s m -> Env d i r s m -> Bool
isSubsetEnv Env d i r s m
e1 Env d i r s m
e2 =
if Env d i r s m
e1 Env d i r s m -> Env d i r s m -> Bool
forall a. Eq a => a -> a -> Bool
== Env d i r s m
e2 then Bool
True
else if Env d i r s m -> Int
forall d i r s (m :: * -> *).
(Monad m, NodeDatum d) =>
Env d i r s m -> Int
envCount Env d i r s m
e1 Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Env d i r s m -> Int
forall d i r s (m :: * -> *).
(Monad m, NodeDatum d) =>
Env d i r s m -> Int
envCount Env d i r s m
e2 then Bool
False
else [Node d i r s m] -> [Node d i r s m] -> Bool
forall a. Ord a => [a] -> [a] -> Bool
ordSubsetp (Env d i r s m -> [Node d i r s m]
forall d i r s (m :: * -> *).
(Monad m, NodeDatum d) =>
Env d i r s m -> [Node d i r s m]
envAssumptions Env d i r s m
e1) (Env d i r s m -> [Node d i r s m]
forall d i r s (m :: * -> *).
(Monad m, NodeDatum d) =>
Env d i r s m -> [Node d i r s m]
envAssumptions Env d i r s m
e2)
data EnvCompare =
EQenv
| S12env
| S21env
| DisjEnv
compareEnv ::
(Monad m, NodeDatum d) => Env d i r s m -> Env d i r s m -> EnvCompare
compareEnv :: Env d i r s m -> Env d i r s m -> EnvCompare
compareEnv Env d i r s m
e1 Env d i r s m
e2 =
if Env d i r s m
e1 Env d i r s m -> Env d i r s m -> Bool
forall a. Eq a => a -> a -> Bool
== Env d i r s m
e2
then EnvCompare
EQenv
else if Env d i r s m -> Int
forall d i r s (m :: * -> *).
(Monad m, NodeDatum d) =>
Env d i r s m -> Int
envCount Env d i r s m
e1 Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Env d i r s m -> Int
forall d i r s (m :: * -> *).
(Monad m, NodeDatum d) =>
Env d i r s m -> Int
envCount Env d i r s m
e2
then if [Node d i r s m] -> [Node d i r s m] -> Bool
forall (m :: * -> *) d i r s.
(Monad m, NodeDatum d) =>
[Node d i r s m] -> [Node d i r s m] -> Bool
nodeListIsSubsetEq (Env d i r s m -> [Node d i r s m]
forall d i r s (m :: * -> *).
(Monad m, NodeDatum d) =>
Env d i r s m -> [Node d i r s m]
envAssumptions Env d i r s m
e1) (Env d i r s m -> [Node d i r s m]
forall d i r s (m :: * -> *).
(Monad m, NodeDatum d) =>
Env d i r s m -> [Node d i r s m]
envAssumptions Env d i r s m
e2)
then EnvCompare
S12env
else EnvCompare
DisjEnv
else if [Node d i r s m] -> [Node d i r s m] -> Bool
forall (m :: * -> *) d i r s.
(Monad m, NodeDatum d) =>
[Node d i r s m] -> [Node d i r s m] -> Bool
nodeListIsSubsetEq (Env d i r s m -> [Node d i r s m]
forall d i r s (m :: * -> *).
(Monad m, NodeDatum d) =>
Env d i r s m -> [Node d i r s m]
envAssumptions Env d i r s m
e2) (Env d i r s m -> [Node d i r s m]
forall d i r s (m :: * -> *).
(Monad m, NodeDatum d) =>
Env d i r s m -> [Node d i r s m]
envAssumptions Env d i r s m
e1)
then EnvCompare
S21env
else EnvCompare
DisjEnv
nodeListIsSubsetEq ::
(Monad m, NodeDatum d) => [Node d i r s m] -> [Node d i r s m] -> Bool
nodeListIsSubsetEq :: [Node d i r s m] -> [Node d i r s m] -> Bool
nodeListIsSubsetEq [] [Node d i r s m]
_ = Bool
True
nodeListIsSubsetEq [Node d i r s m]
_ [] = Bool
False
nodeListIsSubsetEq l1 :: [Node d i r s m]
l1@(Node d i r s m
x : [Node d i r s m]
xs) (Node d i r s m
y : [Node d i r s m]
ys) =
case Node d i r s m -> Int
forall d i r s (m :: * -> *).
(Monad m, NodeDatum d) =>
Node d i r s m -> Int
nodeIndex Node d i r s m
x Int -> Int -> Ordering
forall a. Ord a => a -> a -> Ordering
`compare` Node d i r s m -> Int
forall d i r s (m :: * -> *).
(Monad m, NodeDatum d) =>
Node d i r s m -> Int
nodeIndex Node d i r s m
y of
Ordering
LT -> Bool
False
Ordering
EQ -> [Node d i r s m] -> [Node d i r s m] -> Bool
forall (m :: * -> *) d i r s.
(Monad m, NodeDatum d) =>
[Node d i r s m] -> [Node d i r s m] -> Bool
nodeListIsSubsetEq [Node d i r s m]
xs [Node d i r s m]
ys
Ordering
GT -> [Node d i r s m] -> [Node d i r s m] -> Bool
forall (m :: * -> *) d i r s.
(Monad m, NodeDatum d) =>
[Node d i r s m] -> [Node d i r s m] -> Bool
nodeListIsSubsetEq [Node d i r s m]
l1 [Node d i r s m]
ys
newNogood ::
(Debuggable m, NodeDatum d) =>
ATMS d i r s m -> Env d i r s m -> Justification d i r s m -> ATMST s m ()
newNogood :: ATMS d i r s m
-> Env d i r s m -> Justification d i r s m -> ATMST s m ()
newNogood ATMS d i r s m
atms Env d i r s m
cenv Justification d i r s m
why = do
$(dbg [| debugNewNogoodStart cenv why |])
STT s m () -> ATMST s m ()
forall (m :: * -> *) s r. Monad m => STT s m r -> ATMST s m r
sttLayer (STT s m () -> ATMST s m ()) -> STT s m () -> ATMST s m ()
forall a b. (a -> b) -> a -> b
$ STRef s (WhyNogood d i r s m) -> WhyNogood d i r s m -> STT s m ()
forall (m :: * -> *) s a.
Applicative m =>
STRef s a -> a -> STT s m ()
writeSTRef (Env d i r s m -> STRef s (WhyNogood d i r s m)
forall d i r s (m :: * -> *).
(Monad m, NodeDatum d) =>
Env d i r s m -> STRef s (WhyNogood d i r s m)
envWhyNogood Env d i r s m
cenv) (Justification d i r s m -> WhyNogood d i r s m
forall d i r s (m :: * -> *).
Justification d i r s m -> WhyNogood d i r s m
ByJustification Justification d i r s m
why)
Env d i r s m -> ATMS d i r s m -> ATMST s m ()
forall (m :: * -> *) d i r s.
(Monad m, NodeDatum d) =>
Env d i r s m -> ATMS d i r s m -> ATMST s m ()
removeEnvFromLabels Env d i r s m
cenv ATMS d i r s m
atms
ATMS d i r s m
-> STRef s (EnvTable d i r s m) -> Env d i r s m -> ATMST s m ()
forall (m :: * -> *) d i r s.
(Monad m, NodeDatum d) =>
ATMS d i r s m
-> STRef s (EnvTable d i r s m) -> Env d i r s m -> ATMST s m ()
insertInTable ATMS d i r s m
atms (ATMS d i r s m -> STRef s (EnvTable d i r s m)
forall d i r s (m :: * -> *).
(Monad m, NodeDatum d) =>
ATMS d i r s m -> STRef s (EnvTable d i r s m)
atmsNogoodTable ATMS d i r s m
atms) Env d i r s m
cenv
let cenvCount :: Int
cenvCount = Env d i r s m -> Int
forall d i r s (m :: * -> *).
(Monad m, NodeDatum d) =>
Env d i r s m -> Int
envCount Env d i r s m
cenv
EnvTable STArray s Int [Env d i r s m]
nogoodTable <- ATMS d i r s m -> ATMST s m (EnvTable d i r s m)
forall (m :: * -> *) d i r s.
(Monad m, NodeDatum d) =>
ATMS d i r s m -> ATMST s m (EnvTable d i r s m)
getNogoodTable ATMS d i r s m
atms
[Int] -> (Int -> ATMST s m ()) -> ATMST s m ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [Int
1 .. Int
cenvCount Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1] ((Int -> ATMST s m ()) -> ATMST s m ())
-> (Int -> ATMST s m ()) -> ATMST s m ()
forall a b. (a -> b) -> a -> b
$ \ Int
i -> do
[Env d i r s m]
entry <- STT s m [Env d i r s m] -> ATMST s m [Env d i r s m]
forall (m :: * -> *) s r. Monad m => STT s m r -> ATMST s m r
sttLayer (STT s m [Env d i r s m] -> ATMST s m [Env d i r s m])
-> STT s m [Env d i r s m] -> ATMST s m [Env d i r s m]
forall a b. (a -> b) -> a -> b
$ STArray s Int [Env d i r s m] -> Int -> STT s m [Env d i r s m]
forall i (m :: * -> *) s e.
(Ix i, Applicative m) =>
STArray s i e -> i -> STT s m e
readSTArray STArray s Int [Env d i r s m]
nogoodTable Int
i
STT s m () -> ATMST s m ()
forall (m :: * -> *) s r. Monad m => STT s m r -> ATMST s m r
sttLayer (STT s m () -> ATMST s m ()) -> STT s m () -> ATMST s m ()
forall a b. (a -> b) -> a -> b
$ STArray s Int [Env d i r s m]
-> Int -> [Env d i r s m] -> STT s m ()
forall i (m :: * -> *) s e.
(Ix i, Applicative m) =>
STArray s i e -> i -> e -> STT s m ()
writeSTArray STArray s Int [Env d i r s m]
nogoodTable Int
i ([Env d i r s m] -> STT s m ()) -> [Env d i r s m] -> STT s m ()
forall a b. (a -> b) -> a -> b
$
(Env d i r s m -> Bool) -> [Env d i r s m] -> [Env d i r s m]
forall a. (a -> Bool) -> [a] -> [a]
filter (Bool -> Bool
not (Bool -> Bool) -> (Env d i r s m -> Bool) -> Env d i r s m -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Env d i r s m -> Env d i r s m -> Bool
forall (m :: * -> *) d i r s.
(Monad m, NodeDatum d) =>
Env d i r s m -> Env d i r s m -> Bool
isSubsetEnv Env d i r s m
cenv) [Env d i r s m]
entry
EnvTable STArray s Int [Env d i r s m]
envTable <- ATMS d i r s m -> ATMST s m (EnvTable d i r s m)
forall (m :: * -> *) d i r s.
(Monad m, NodeDatum d) =>
ATMS d i r s m -> ATMST s m (EnvTable d i r s m)
getEnvTable ATMS d i r s m
atms
let (Int
_, Int
maxCount) = STArray s Int [Env d i r s m] -> (Int, Int)
forall s i e. STArray s i e -> (i, i)
boundsSTArray STArray s Int [Env d i r s m]
envTable
[Int] -> (Int -> ATMST s m ()) -> ATMST s m ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [Int
cenvCount Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1, Int
maxCount] ((Int -> ATMST s m ()) -> ATMST s m ())
-> (Int -> ATMST s m ()) -> ATMST s m ()
forall a b. (a -> b) -> a -> b
$ \ Int
i -> do
[Env d i r s m]
entry <- STT s m [Env d i r s m] -> ATMST s m [Env d i r s m]
forall (m :: * -> *) s r. Monad m => STT s m r -> ATMST s m r
sttLayer (STT s m [Env d i r s m] -> ATMST s m [Env d i r s m])
-> STT s m [Env d i r s m] -> ATMST s m [Env d i r s m]
forall a b. (a -> b) -> a -> b
$ STArray s Int [Env d i r s m] -> Int -> STT s m [Env d i r s m]
forall i (m :: * -> *) s e.
(Ix i, Applicative m) =>
STArray s i e -> i -> STT s m e
readSTArray STArray s Int [Env d i r s m]
envTable Int
i
[Env d i r s m] -> (Env d i r s m -> ATMST s m ()) -> ATMST s m ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [Env d i r s m]
entry ((Env d i r s m -> ATMST s m ()) -> ATMST s m ())
-> (Env d i r s m -> ATMST s m ()) -> ATMST s m ()
forall a b. (a -> b) -> a -> b
$ \ Env d i r s m
old -> do
Bool
isNogood <- Env d i r s m -> ATMST s m Bool
forall (m :: * -> *) d i r s.
(Monad m, NodeDatum d) =>
Env d i r s m -> ATMST s m Bool
envIsNogood Env d i r s m
old
Bool -> ATMST s m () -> ATMST s m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Bool
isNogood Bool -> Bool -> Bool
&& Env d i r s m -> Env d i r s m -> Bool
forall (m :: * -> *) d i r s.
(Monad m, NodeDatum d) =>
Env d i r s m -> Env d i r s m -> Bool
isSubsetEnv Env d i r s m
cenv Env d i r s m
old) (ATMST s m () -> ATMST s m ()) -> ATMST s m () -> ATMST s m ()
forall a b. (a -> b) -> a -> b
$ do
STT s m () -> ATMST s m ()
forall (m :: * -> *) s r. Monad m => STT s m r -> ATMST s m r
sttLayer (STT s m () -> ATMST s m ()) -> STT s m () -> ATMST s m ()
forall a b. (a -> b) -> a -> b
$ STRef s (WhyNogood d i r s m) -> WhyNogood d i r s m -> STT s m ()
forall (m :: * -> *) s a.
Applicative m =>
STRef s a -> a -> STT s m ()
writeSTRef (Env d i r s m -> STRef s (WhyNogood d i r s m)
forall d i r s (m :: * -> *).
(Monad m, NodeDatum d) =>
Env d i r s m -> STRef s (WhyNogood d i r s m)
envWhyNogood Env d i r s m
old) (Env d i r s m -> WhyNogood d i r s m
forall d i r s (m :: * -> *). Env d i r s m -> WhyNogood d i r s m
ByEnv Env d i r s m
cenv)
Env d i r s m -> ATMS d i r s m -> ATMST s m ()
forall (m :: * -> *) d i r s.
(Monad m, NodeDatum d) =>
Env d i r s m -> ATMS d i r s m -> ATMST s m ()
removeEnvFromLabels Env d i r s m
old ATMS d i r s m
atms
debugNewNogoodStart ::
(MonadIO m, NodeDatum d) =>
Env d i r s m -> Justification d i r s m -> ATMST s m ()
debugNewNogoodStart :: Env d i r s m -> Justification d i r s m -> ATMST s m ()
debugNewNogoodStart Env d i r s m
cenv Justification d i r s m
why = do
IO () -> ATMST s m ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> ATMST s m ()) -> IO () -> ATMST s m ()
forall a b. (a -> b) -> a -> b
$ String -> IO ()
putStr String
"Starting newNogood with "
Env d i r s m -> ATMST s m ()
forall (m :: * -> *) d i r s.
(MonadIO m, NodeDatum d) =>
Env d i r s m -> ATMST s m ()
debugEnv Env d i r s m
cenv
Justification d i r s m -> ATMST s m String
forall (m :: * -> *) d i r s.
(Monad m, NodeDatum d) =>
Justification d i r s m -> ATMST s m String
formatJustification Justification d i r s m
why ATMST s m String -> (String -> ATMST s m ()) -> ATMST s m ()
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= (IO () -> ATMST s m ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> ATMST s m ())
-> (String -> IO ()) -> String -> ATMST s m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> IO ()
putStrLn)
setEnvContradictory ::
(Debuggable m, NodeDatum d) => ATMS d i r s m -> Env d i r s m -> ATMST s m ()
setEnvContradictory :: ATMS d i r s m -> Env d i r s m -> ATMST s m ()
setEnvContradictory ATMS d i r s m
atms Env d i r s m
env = do
$(dbg [| setEnvContradictoryStart env |])
ATMST s m Bool -> ATMST s m () -> ATMST s m () -> ATMST s m ()
forall (m :: * -> *) a. Monad m => m Bool -> m a -> m a -> m a
ifM (Env d i r s m -> ATMST s m Bool
forall (m :: * -> *) d i r s.
(Monad m, NodeDatum d) =>
Env d i r s m -> ATMST s m Bool
envIsNogood Env d i r s m
env)
(do $(dbg [| liftIO $ putStr " Already nogood \n" |])
() -> ATMST s m ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()) (ATMST s m () -> ATMST s m ()) -> ATMST s m () -> ATMST s m ()
forall a b. (a -> b) -> a -> b
$ do
let count :: Int
count = Env d i r s m -> Int
forall d i r s (m :: * -> *).
(Monad m, NodeDatum d) =>
Env d i r s m -> Int
envCount Env d i r s m
env
EnvTable STArray s Int [Env d i r s m]
nogoodTableArray <- STT s m (EnvTable d i r s m) -> ATMST s m (EnvTable d i r s m)
forall (m :: * -> *) s r. Monad m => STT s m r -> ATMST s m r
sttLayer (STT s m (EnvTable d i r s m) -> ATMST s m (EnvTable d i r s m))
-> STT s m (EnvTable d i r s m) -> ATMST s m (EnvTable d i r s m)
forall a b. (a -> b) -> a -> b
$ STRef s (EnvTable d i r s m) -> STT s m (EnvTable d i r s m)
forall (m :: * -> *) s a. Applicative m => STRef s a -> STT s m a
readSTRef (STRef s (EnvTable d i r s m) -> STT s m (EnvTable d i r s m))
-> STRef s (EnvTable d i r s m) -> STT s m (EnvTable d i r s m)
forall a b. (a -> b) -> a -> b
$ ATMS d i r s m -> STRef s (EnvTable d i r s m)
forall d i r s (m :: * -> *).
(Monad m, NodeDatum d) =>
ATMS d i r s m -> STRef s (EnvTable d i r s m)
atmsNogoodTable ATMS d i r s m
atms
[Int] -> (Int -> ATMST s m ()) -> ATMST s m ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [Int
1..Int
count] ((Int -> ATMST s m ()) -> ATMST s m ())
-> (Int -> ATMST s m ()) -> ATMST s m ()
forall a b. (a -> b) -> a -> b
$ \Int
i -> do
STRef s Bool
continueLoop <- STT s m (STRef s Bool) -> ATMST s m (STRef s Bool)
forall (m :: * -> *) s r. Monad m => STT s m r -> ATMST s m r
sttLayer (STT s m (STRef s Bool) -> ATMST s m (STRef s Bool))
-> STT s m (STRef s Bool) -> ATMST s m (STRef s Bool)
forall a b. (a -> b) -> a -> b
$ Bool -> STT s m (STRef s Bool)
forall (m :: * -> *) a s. Applicative m => a -> STT s m (STRef s a)
newSTRef Bool
True
$(dbg [| setEnvContradictoryStartOuter i |])
ATMST s m [Env d i r s m]
-> ATMST s m Bool
-> (Env d i r s m -> ATMST s m ())
-> ATMST s m ()
forall (m :: * -> *) a.
Monad m =>
m [a] -> m Bool -> (a -> m ()) -> m ()
forMMwhile_ (STT s m [Env d i r s m] -> ATMST s m [Env d i r s m]
forall (m :: * -> *) s r. Monad m => STT s m r -> ATMST s m r
sttLayer (STT s m [Env d i r s m] -> ATMST s m [Env d i r s m])
-> STT s m [Env d i r s m] -> ATMST s m [Env d i r s m]
forall a b. (a -> b) -> a -> b
$ STArray s Int [Env d i r s m] -> Int -> STT s m [Env d i r s m]
forall i (m :: * -> *) s e.
(Ix i, Applicative m) =>
STArray s i e -> i -> STT s m e
readSTArray STArray s Int [Env d i r s m]
nogoodTableArray Int
i)
(STT s m Bool -> ATMST s m Bool
forall (m :: * -> *) s r. Monad m => STT s m r -> ATMST s m r
sttLayer (STT s m Bool -> ATMST s m Bool) -> STT s m Bool -> ATMST s m Bool
forall a b. (a -> b) -> a -> b
$ STRef s Bool -> STT s m Bool
forall (m :: * -> *) s a. Applicative m => STRef s a -> STT s m a
readSTRef STRef s Bool
continueLoop) ((Env d i r s m -> ATMST s m ()) -> ATMST s m ())
-> (Env d i r s m -> ATMST s m ()) -> ATMST s m ()
forall a b. (a -> b) -> a -> b
$ \Env d i r s m
cenv -> do
$(dbg [| setEnvContradictoryStartInner cenv |])
Bool -> ATMST s m () -> ATMST s m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Env d i r s m -> Env d i r s m -> Bool
forall (m :: * -> *) d i r s.
(Monad m, NodeDatum d) =>
Env d i r s m -> Env d i r s m -> Bool
isSubsetEnv Env d i r s m
cenv Env d i r s m
env) (ATMST s m () -> ATMST s m ()) -> ATMST s m () -> ATMST s m ()
forall a b. (a -> b) -> a -> b
$ do
$(dbg [| setEnvContradictoryStartInnerWhen cenv env |])
STT s m () -> ATMST s m ()
forall (m :: * -> *) s r. Monad m => STT s m r -> ATMST s m r
sttLayer (STT s m () -> ATMST s m ()) -> STT s m () -> ATMST s m ()
forall a b. (a -> b) -> a -> b
$ do
STRef s (WhyNogood d i r s m) -> WhyNogood d i r s m -> STT s m ()
forall (m :: * -> *) s a.
Applicative m =>
STRef s a -> a -> STT s m ()
writeSTRef (Env d i r s m -> STRef s (WhyNogood d i r s m)
forall d i r s (m :: * -> *).
(Monad m, NodeDatum d) =>
Env d i r s m -> STRef s (WhyNogood d i r s m)
envWhyNogood Env d i r s m
env) (WhyNogood d i r s m -> STT s m ())
-> WhyNogood d i r s m -> STT s m ()
forall a b. (a -> b) -> a -> b
$ Env d i r s m -> WhyNogood d i r s m
forall d i r s (m :: * -> *). Env d i r s m -> WhyNogood d i r s m
ByEnv Env d i r s m
cenv
STRef s Bool -> Bool -> STT s m ()
forall (m :: * -> *) s a.
Applicative m =>
STRef s a -> a -> STT s m ()
writeSTRef STRef s Bool
continueLoop Bool
False
setEnvContradictoryStart ::
(MonadIO m, NodeDatum d) => Env d i r s m -> ATMST s m ()
setEnvContradictoryStart :: Env d i r s m -> ATMST s m ()
setEnvContradictoryStart Env d i r s m
e = do
IO () -> ATMST s m ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> ATMST s m ()) -> IO () -> ATMST s m ()
forall a b. (a -> b) -> a -> b
$ String -> IO ()
putStr String
" - Running setEnvContradictory with "
Env d i r s m -> ATMST s m ()
forall (m :: * -> *) d i r s.
(MonadIO m, NodeDatum d) =>
Env d i r s m -> ATMST s m ()
blurbEnv Env d i r s m
e
IO () -> ATMST s m ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> ATMST s m ()) -> IO () -> ATMST s m ()
forall a b. (a -> b) -> a -> b
$ String -> IO ()
putStrLn String
""
setEnvContradictoryStartOuter ::
(MonadIO m) => Int -> ATMST s m ()
setEnvContradictoryStartOuter :: Int -> ATMST s m ()
setEnvContradictoryStartOuter Int
i = do
IO () -> ATMST s m ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> ATMST s m ()) -> IO () -> ATMST s m ()
forall a b. (a -> b) -> a -> b
$ String -> IO ()
putStrLn (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ (String
" Starting outer loop for "
String -> ShowS
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show Int
i
String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
"-length envs")
setEnvContradictoryStartInner ::
(MonadIO m, NodeDatum d) => Env d i r s m -> ATMST s m ()
setEnvContradictoryStartInner :: Env d i r s m -> ATMST s m ()
setEnvContradictoryStartInner Env d i r s m
cenv = do
IO () -> ATMST s m ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> ATMST s m ()) -> IO () -> ATMST s m ()
forall a b. (a -> b) -> a -> b
$ String -> IO ()
putStr String
" Starting inner loop with nogood env "
Env d i r s m -> ATMST s m ()
forall (m :: * -> *) d i r s.
(MonadIO m, NodeDatum d) =>
Env d i r s m -> ATMST s m ()
blurbEnv Env d i r s m
cenv
IO () -> ATMST s m ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> ATMST s m ()) -> IO () -> ATMST s m ()
forall a b. (a -> b) -> a -> b
$ String -> IO ()
putStrLn String
""
setEnvContradictoryStartInnerWhen ::
(MonadIO m, NodeDatum d) => Env d i r s m -> Env d i r s m -> ATMST s m ()
setEnvContradictoryStartInnerWhen :: Env d i r s m -> Env d i r s m -> ATMST s m ()
setEnvContradictoryStartInnerWhen Env d i r s m
cenv Env d i r s m
env = do
IO () -> ATMST s m ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> ATMST s m ()) -> IO () -> ATMST s m ()
forall a b. (a -> b) -> a -> b
$ String -> IO ()
putStr String
" Nogood "
Env d i r s m -> ATMST s m ()
forall (m :: * -> *) d i r s.
(MonadIO m, NodeDatum d) =>
Env d i r s m -> ATMST s m ()
blurbEnv Env d i r s m
cenv
IO () -> ATMST s m ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> ATMST s m ()) -> IO () -> ATMST s m ()
forall a b. (a -> b) -> a -> b
$ String -> IO ()
putStr String
" is subset of "
Env d i r s m -> ATMST s m ()
forall (m :: * -> *) d i r s.
(MonadIO m, NodeDatum d) =>
Env d i r s m -> ATMST s m ()
blurbEnv Env d i r s m
env
IO () -> ATMST s m ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> ATMST s m ()) -> IO () -> ATMST s m ()
forall a b. (a -> b) -> a -> b
$ String -> IO ()
putStrLn String
", marking latter nogood"
removeEnvFromLabels ::
(Monad m, NodeDatum d) => Env d i r s m -> ATMS d i r s m -> ATMST s m ()
removeEnvFromLabels :: Env d i r s m -> ATMS d i r s m -> ATMST s m ()
removeEnvFromLabels Env d i r s m
env ATMS d i r s m
atms = do
r -> ATMST s m ()
enqueuef <- ATMS d i r s m -> ATMST s m (r -> ATMST s m ())
forall (m :: * -> *) d i r s.
(Monad m, NodeDatum d) =>
ATMS d i r s m -> ATMST s m (r -> ATMST s m ())
getEnqueueProcedure ATMS d i r s m
atms
ATMST s m [r] -> (r -> ATMST s m ()) -> ATMST s m ()
forall (m :: * -> *) (t :: * -> *) a.
(Monad m, Foldable t) =>
m (t a) -> (a -> m ()) -> m ()
forMM_ (Env d i r s m -> ATMST s m [r]
forall (m :: * -> *) d i r s.
(Monad m, NodeDatum d) =>
Env d i r s m -> ATMST s m [r]
getEnvRules Env d i r s m
env) ((r -> ATMST s m ()) -> ATMST s m ())
-> (r -> ATMST s m ()) -> ATMST s m ()
forall a b. (a -> b) -> a -> b
$ \ r
rule -> do
r -> ATMST s m ()
enqueuef r
rule
Env d i r s m -> [r] -> ATMST s m ()
forall (m :: * -> *) d i r s.
(Monad m, NodeDatum d) =>
Env d i r s m -> [r] -> ATMST s m ()
setEnvRules Env d i r s m
env []
ATMST s m [Node d i r s m]
-> (Node d i r s m -> ATMST s m ()) -> ATMST s m ()
forall (m :: * -> *) (t :: * -> *) a.
(Monad m, Foldable t) =>
m (t a) -> (a -> m ()) -> m ()
forMM_ (Env d i r s m -> ATMST s m [Node d i r s m]
forall (m :: * -> *) d i r s.
(Monad m, NodeDatum d) =>
Env d i r s m -> ATMST s m [Node d i r s m]
getEnvNodes Env d i r s m
env) ((Node d i r s m -> ATMST s m ()) -> ATMST s m ())
-> (Node d i r s m -> ATMST s m ()) -> ATMST s m ()
forall a b. (a -> b) -> a -> b
$ \ Node d i r s m
node -> do
[Env d i r s m]
oldLabel <- Node d i r s m -> ATMST s m [Env d i r s m]
forall (m :: * -> *) d i r s.
(Monad m, NodeDatum d) =>
Node d i r s m -> ATMST s m [Env d i r s m]
getNodeLabel Node d i r s m
node
Node d i r s m -> [Env d i r s m] -> ATMST s m ()
forall (m :: * -> *) d i r s.
(Monad m, NodeDatum d) =>
Node d i r s m -> [Env d i r s m] -> ATMST s m ()
setNodeLabel Node d i r s m
node ([Env d i r s m] -> ATMST s m ())
-> [Env d i r s m] -> ATMST s m ()
forall a b. (a -> b) -> a -> b
$ Env d i r s m -> [Env d i r s m] -> [Env d i r s m]
forall a. Eq a => a -> [a] -> [a]
delete Env d i r s m
env [Env d i r s m]
oldLabel
interpretations ::
(Monad m, NodeDatum d) => ATMS d i r s m -> [[Node d i r s m]] -> ATMST s m ()
interpretations :: ATMS d i r s m -> [[Node d i r s m]] -> ATMST s m ()
interpretations = String -> ATMS d i r s m -> [[Node d i r s m]] -> ATMST s m ()
forall a. HasCallStack => String -> a
error String
"< TODO unimplemented interpretations >"
getDepthSolutions1 ::
(Monad m, NodeDatum d) => Env d i r s m -> [[Env d i r s m]] -> ATMST s m ()
getDepthSolutions1 :: Env d i r s m -> [[Env d i r s m]] -> ATMST s m ()
getDepthSolutions1 = String -> Env d i r s m -> [[Env d i r s m]] -> ATMST s m ()
forall a. HasCallStack => String -> a
error String
"< TODO unimplemented getDepthSolutions1 >"
extendViaDefaults ::
(Monad m, NodeDatum d) =>
Env d i r s m -> [Node d i r s m] -> [Node d i r s m] -> ATMST s m ()
extendViaDefaults :: Env d i r s m
-> [Node d i r s m] -> [Node d i r s m] -> ATMST s m ()
extendViaDefaults = String
-> Env d i r s m
-> [Node d i r s m]
-> [Node d i r s m]
-> ATMST s m ()
forall a. HasCallStack => String -> a
error String
"< TODO unimplemented extendViaDefaults >"
explainNode ::
(Monad m, NodeDatum d) =>
Node d i r s m -> Env d i r s m -> ATMST s m [Explanation d i r s m]
explainNode :: Node d i r s m
-> Env d i r s m -> ATMST s m [Explanation d i r s m]
explainNode Node d i r s m
node Env d i r s m
env = Env d i r s m
-> Node d i r s m
-> [Node d i r s m]
-> [Justification d i r s m]
-> ATMST s m [Explanation d i r s m]
forall (m :: * -> *) d i r s.
(Monad m, NodeDatum d) =>
Env d i r s m
-> Node d i r s m
-> [Node d i r s m]
-> [Justification d i r s m]
-> ATMST s m [Explanation d i r s m]
explainNode1 Env d i r s m
env Node d i r s m
node [] []
explainNode1 ::
(Monad m, NodeDatum d) =>
Env d i r s m -> Node d i r s m -> [Node d i r s m] ->
[Justification d i r s m] ->
ATMST s m [Explanation d i r s m]
explainNode1 :: Env d i r s m
-> Node d i r s m
-> [Node d i r s m]
-> [Justification d i r s m]
-> ATMST s m [Explanation d i r s m]
explainNode1 = String
-> Env d i r s m
-> Node d i r s m
-> [Node d i r s m]
-> [Justification d i r s m]
-> ATMST s m [Explanation d i r s m]
forall a. HasCallStack => String -> a
error String
"< TODO unimplemented explainNode1 >"
whyNode :: (MonadIO m, NodeDatum d) => Node d i r s m -> ATMST s m ()
whyNode :: Node d i r s m -> ATMST s m ()
whyNode Node d i r s m
node = do
let atms :: ATMS d i r s m
atms = Node d i r s m -> ATMS d i r s m
forall d i r s (m :: * -> *).
(Monad m, NodeDatum d) =>
Node d i r s m -> ATMS d i r s m
nodeATMS Node d i r s m
node
d -> String
datumStr <- ATMS d i r s m -> ATMST s m (d -> String)
forall (m :: * -> *) d i r s.
(Monad m, NodeDatum d) =>
ATMS d i r s m -> ATMST s m (d -> String)
getDatumString ATMS d i r s m
atms
IO () -> ATMST s m ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> ATMST s m ()) -> IO () -> ATMST s m ()
forall a b. (a -> b) -> a -> b
$ String -> IO ()
putStr (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String
"<" String -> ShowS
forall a. [a] -> [a] -> [a]
++ d -> String
datumStr (Node d i r s m -> d
forall d i r s (m :: * -> *).
(Monad m, NodeDatum d) =>
Node d i r s m -> d
nodeDatum Node d i r s m
node)
ATMST s m [Env d i r s m]
-> (Env d i r s m -> ATMST s m ()) -> ATMST s m ()
forall (m :: * -> *) (t :: * -> *) a.
(Monad m, Foldable t) =>
m (t a) -> (a -> m ()) -> m ()
forMM_ (Node d i r s m -> ATMST s m [Env d i r s m]
forall (m :: * -> *) d i r s.
(Monad m, NodeDatum d) =>
Node d i r s m -> ATMST s m [Env d i r s m]
getNodeLabel Node d i r s m
node) Env d i r s m -> ATMST s m ()
forall (m :: * -> *) d i r s.
(MonadIO m, NodeDatum d) =>
Env d i r s m -> ATMST s m ()
envString
IO () -> ATMST s m ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> ATMST s m ()) -> IO () -> ATMST s m ()
forall a b. (a -> b) -> a -> b
$ String -> IO ()
putStrLn String
">"
whyNodes :: (MonadIO m, NodeDatum d) => ATMS d i r s m -> ATMST s m ()
whyNodes :: ATMS d i r s m -> ATMST s m ()
whyNodes ATMS d i r s m
atms = do
[Node d i r s m]
nodes <- ATMS d i r s m -> ATMST s m [Node d i r s m]
forall (m :: * -> *) d i r s.
(Monad m, NodeDatum d) =>
ATMS d i r s m -> ATMST s m [Node d i r s m]
getNodes ATMS d i r s m
atms
[Node d i r s m]
-> (Node d i r s m -> ATMST s m ()) -> ATMST s m ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [Node d i r s m]
nodes Node d i r s m -> ATMST s m ()
forall (m :: * -> *) d i r s.
(MonadIO m, NodeDatum d) =>
Node d i r s m -> ATMST s m ()
whyNode
nodeJustifications :: (MonadIO m, NodeDatum d) => Node d i r s m -> ATMST s m ()
nodeJustifications :: Node d i r s m -> ATMST s m ()
nodeJustifications Node d i r s m
node = do
String
nodeStr <- Node d i r s m -> ATMST s m String
forall (m :: * -> *) d i r s.
(Monad m, NodeDatum d) =>
Node d i r s m -> ATMST s m String
nodeString Node d i r s m
node
IO () -> ATMST s m ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> ATMST s m ()) -> IO () -> ATMST s m ()
forall a b. (a -> b) -> a -> b
$ String -> IO ()
putStr (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String
" For " String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
nodeStr String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
":"
[Justification d i r s m]
justs <- Node d i r s m -> ATMST s m [Justification d i r s m]
forall (m :: * -> *) d i r s.
(Monad m, NodeDatum d) =>
Node d i r s m -> ATMST s m [Justification d i r s m]
getNodeJusts Node d i r s m
node
[Justification d i r s m]
-> (Justification d i r s m -> ATMST s m ()) -> ATMST s m ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [Justification d i r s m]
justs Justification d i r s m -> ATMST s m ()
forall (m :: * -> *) d i r s.
(MonadIO m, NodeDatum d) =>
Justification d i r s m -> ATMST s m ()
printJustification
e :: (Monad m, NodeDatum d) =>
ATMS d i r s m -> Int -> ATMST s m (Maybe (Env d i r s m))
e :: ATMS d i r s m -> Int -> ATMST s m (Maybe (Env d i r s m))
e ATMS d i r s m
atms Int
i = do
EnvTable d i r s m
table <- ATMS d i r s m -> ATMST s m (EnvTable d i r s m)
forall (m :: * -> *) d i r s.
(Monad m, NodeDatum d) =>
ATMS d i r s m -> ATMST s m (EnvTable d i r s m)
getEnvTable ATMS d i r s m
atms
(Env d i r s m -> Bool)
-> EnvTable d i r s m -> ATMST s m (Maybe (Env d i r s m))
forall (m :: * -> *) d i r s.
(Monad m, NodeDatum d) =>
(Env d i r s m -> Bool)
-> EnvTable d i r s m -> ATMST s m (Maybe (Env d i r s m))
findInEnvTable (\Env d i r s m
env -> Env d i r s m -> Int
forall d i r s (m :: * -> *).
(Monad m, NodeDatum d) =>
Env d i r s m -> Int
envIndex Env d i r s m
env Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
i) EnvTable d i r s m
table
printEnv :: (MonadIO m, NodeDatum d) => Env d i r s m -> ATMST s m ()
printEnv :: Env d i r s m -> ATMST s m ()
printEnv Env d i r s m
env = do
ATMST s m Bool -> ATMST s m () -> ATMST s m ()
forall (m :: * -> *). Monad m => m Bool -> m () -> m ()
whenM (Env d i r s m -> ATMST s m Bool
forall (m :: * -> *) d i r s.
(Monad m, NodeDatum d) =>
Env d i r s m -> ATMST s m Bool
envIsNogood Env d i r s m
env) (ATMST s m () -> ATMST s m ()) -> ATMST s m () -> ATMST s m ()
forall a b. (a -> b) -> a -> b
$ IO () -> ATMST s m ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> ATMST s m ()) -> IO () -> ATMST s m ()
forall a b. (a -> b) -> a -> b
$ String -> IO ()
putStr String
"* "
Env d i r s m -> ATMST s m ()
forall (m :: * -> *) d i r s.
(MonadIO m, NodeDatum d) =>
Env d i r s m -> ATMST s m ()
envString Env d i r s m
env
IO () -> ATMST s m ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> ATMST s m ()) -> IO () -> ATMST s m ()
forall a b. (a -> b) -> a -> b
$ String -> IO ()
putStrLn String
""
envString :: (MonadIO m, NodeDatum d) => Env d i r s m -> ATMST s m ()
envString :: Env d i r s m -> ATMST s m ()
envString Env d i r s m
env = do
let assumptions :: [Node d i r s m]
assumptions = Env d i r s m -> [Node d i r s m]
forall d i r s (m :: * -> *).
(Monad m, NodeDatum d) =>
Env d i r s m -> [Node d i r s m]
envAssumptions Env d i r s m
env
Bool -> ATMST s m () -> ATMST s m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless ([Node d i r s m] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Node d i r s m]
assumptions) (ATMST s m () -> ATMST s m ()) -> ATMST s m () -> ATMST s m ()
forall a b. (a -> b) -> a -> b
$ do
Node d i r s m -> String
printer <- ATMS d i r s m -> ATMST s m (Node d i r s m -> String)
forall (m :: * -> *) d i r s.
(Monad m, NodeDatum d) =>
ATMS d i r s m -> ATMST s m (Node d i r s m -> String)
getNodeString (Node d i r s m -> ATMS d i r s m
forall d i r s (m :: * -> *).
(Monad m, NodeDatum d) =>
Node d i r s m -> ATMS d i r s m
nodeATMS ([Node d i r s m] -> Node d i r s m
forall a. [a] -> a
head [Node d i r s m]
assumptions))
IO () -> ATMST s m ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> ATMST s m ()) -> IO () -> ATMST s m ()
forall a b. (a -> b) -> a -> b
$ String -> IO ()
putStr (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String -> [String] -> String
forall a. [a] -> [[a]] -> [a]
intercalate String
", " ((Node d i r s m -> String) -> [Node d i r s m] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map Node d i r s m -> String
printer [Node d i r s m]
assumptions)
printNogoods :: (MonadIO m, NodeDatum d) => ATMS d i r s m -> ATMST s m ()
printNogoods :: ATMS d i r s m -> ATMST s m ()
printNogoods ATMS d i r s m
atms = ATMS d i r s m -> ATMST s m (EnvTable d i r s m)
forall (m :: * -> *) d i r s.
(Monad m, NodeDatum d) =>
ATMS d i r s m -> ATMST s m (EnvTable d i r s m)
getNogoodTable ATMS d i r s m
atms ATMST s m (EnvTable d i r s m)
-> (EnvTable d i r s m -> ATMST s m ()) -> ATMST s m ()
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \EnvTable d i r s m
table -> EnvTable d i r s m -> ATMST s m ()
forall (m :: * -> *) d i r s.
(MonadIO m, NodeDatum d) =>
EnvTable d i r s m -> ATMST s m ()
printEnvTable EnvTable d i r s m
table
printEnvs :: (MonadIO m, NodeDatum d) => ATMS d i r s m -> ATMST s m ()
printEnvs :: ATMS d i r s m -> ATMST s m ()
printEnvs ATMS d i r s m
atms = ATMS d i r s m -> ATMST s m (EnvTable d i r s m)
forall (m :: * -> *) d i r s.
(Monad m, NodeDatum d) =>
ATMS d i r s m -> ATMST s m (EnvTable d i r s m)
getEnvTable ATMS d i r s m
atms ATMST s m (EnvTable d i r s m)
-> (EnvTable d i r s m -> ATMST s m ()) -> ATMST s m ()
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \EnvTable d i r s m
table -> EnvTable d i r s m -> ATMST s m ()
forall (m :: * -> *) d i r s.
(MonadIO m, NodeDatum d) =>
EnvTable d i r s m -> ATMST s m ()
printEnvTable EnvTable d i r s m
table
printEnvTable :: (MonadIO m, NodeDatum d) => EnvTable d i r s m -> ATMST s m ()
printEnvTable :: EnvTable d i r s m -> ATMST s m ()
printEnvTable (EnvTable STArray s Int [Env d i r s m]
arr) = do
let (Int
lo, Int
hi) = STArray s Int [Env d i r s m] -> (Int, Int)
forall s i e. STArray s i e -> (i, i)
boundsSTArray STArray s Int [Env d i r s m]
arr
[Int] -> (Int -> ATMST s m ()) -> ATMST s m ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [Int
lo..Int
hi] ((Int -> ATMST s m ()) -> ATMST s m ())
-> (Int -> ATMST s m ()) -> ATMST s m ()
forall a b. (a -> b) -> a -> b
$ \Int
i ->
ATMST s m [Env d i r s m]
-> (Env d i r s m -> ATMST s m ()) -> ATMST s m ()
forall (m :: * -> *) (t :: * -> *) a.
(Monad m, Foldable t) =>
m (t a) -> (a -> m ()) -> m ()
forMM_ (STT s m [Env d i r s m] -> ATMST s m [Env d i r s m]
forall (m :: * -> *) s r. Monad m => STT s m r -> ATMST s m r
sttLayer (STT s m [Env d i r s m] -> ATMST s m [Env d i r s m])
-> STT s m [Env d i r s m] -> ATMST s m [Env d i r s m]
forall a b. (a -> b) -> a -> b
$ STArray s Int [Env d i r s m] -> Int -> STT s m [Env d i r s m]
forall i (m :: * -> *) s e.
(Ix i, Applicative m) =>
STArray s i e -> i -> STT s m e
readSTArray STArray s Int [Env d i r s m]
arr Int
i) Env d i r s m -> ATMST s m ()
forall (m :: * -> *) d i r s.
(MonadIO m, NodeDatum d) =>
Env d i r s m -> ATMST s m ()
printEnv
printAtmsStatistics ::
(MonadIO m, NodeDatum d) => ATMS d i r s m -> ATMST s m ()
printAtmsStatistics :: ATMS d i r s m -> ATMST s m ()
printAtmsStatistics ATMS d i r s m
atms = do
IO () -> ATMST s m ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> ATMST s m ()) -> IO () -> ATMST s m ()
forall a b. (a -> b) -> a -> b
$ String -> IO ()
putStrLn (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String
"Env table: "
ATMS d i r s m -> ATMST s m ()
forall (m :: * -> *) d i r s.
(MonadIO m, NodeDatum d) =>
ATMS d i r s m -> ATMST s m ()
printEnvs ATMS d i r s m
atms
IO () -> ATMST s m ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> ATMST s m ()) -> IO () -> ATMST s m ()
forall a b. (a -> b) -> a -> b
$ String -> IO ()
putStrLn (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String
"Nogood table: "
ATMS d i r s m -> ATMST s m ()
forall (m :: * -> *) d i r s.
(MonadIO m, NodeDatum d) =>
ATMS d i r s m -> ATMST s m ()
printNogoods ATMS d i r s m
atms
printTable ::
(MonadIO m, NodeDatum d) => String -> EnvTable d i r s m -> ATMST s m ()
printTable :: String -> EnvTable d i r s m -> ATMST s m ()
printTable String
msg (EnvTable STArray s Int [Env d i r s m]
arr) = do
IO () -> ATMST s m ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> ATMST s m ()) -> IO () -> ATMST s m ()
forall a b. (a -> b) -> a -> b
$ String -> IO ()
putStr String
msg
let (Int
lo, Int
hi) = STArray s Int [Env d i r s m] -> (Int, Int)
forall s i e. STArray s i e -> (i, i)
boundsSTArray STArray s Int [Env d i r s m]
arr
[Int] -> (Int -> ATMST s m ()) -> ATMST s m ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [Int
lo..Int
hi] ((Int -> ATMST s m ()) -> ATMST s m ())
-> (Int -> ATMST s m ()) -> ATMST s m ()
forall a b. (a -> b) -> a -> b
$ \Int
i -> do
[Env d i r s m]
row <- STT s m [Env d i r s m] -> ATMST s m [Env d i r s m]
forall (m :: * -> *) s r. Monad m => STT s m r -> ATMST s m r
sttLayer (STT s m [Env d i r s m] -> ATMST s m [Env d i r s m])
-> STT s m [Env d i r s m] -> ATMST s m [Env d i r s m]
forall a b. (a -> b) -> a -> b
$ STArray s Int [Env d i r s m] -> Int -> STT s m [Env d i r s m]
forall i (m :: * -> *) s e.
(Ix i, Applicative m) =>
STArray s i e -> i -> STT s m e
readSTArray STArray s Int [Env d i r s m]
arr Int
i
let count :: Int
count = [Env d i r s m] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Env d i r s m]
row
Bool -> ATMST s m () -> ATMST s m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Int
count Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
0) (ATMST s m () -> ATMST s m ()) -> ATMST s m () -> ATMST s m ()
forall a b. (a -> b) -> a -> b
$
IO () -> ATMST s m ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> ATMST s m ()) -> IO () -> ATMST s m ()
forall a b. (a -> b) -> a -> b
$ String -> IO ()
putStrLn (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String
" " String -> ShowS
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show Int
count String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
" of length " String -> ShowS
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show Int
i
debugAtms ::
(MonadIO m, NodeDatum d) => String -> ATMS d i r s m -> ATMST s m ()
debugAtms :: String -> ATMS d i r s m -> ATMST s m ()
debugAtms String
blurb ATMS d i r s m
atms = do
IO () -> ATMST s m ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> ATMST s m ()) -> IO () -> ATMST s m ()
forall a b. (a -> b) -> a -> b
$ String -> IO ()
putStrLn (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String
"=============== " String -> ShowS
forall a. [a] -> [a] -> [a]
++ ATMS d i r s m -> String
forall d i r s (m :: * -> *).
(Monad m, NodeDatum d) =>
ATMS d i r s m -> String
atmsTitle ATMS d i r s m
atms String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
": " String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
blurb
ATMS d i r s m -> ATMST s m ()
forall (m :: * -> *) d i r s.
(MonadIO m, NodeDatum d) =>
ATMS d i r s m -> ATMST s m ()
debugNodes ATMS d i r s m
atms
ATMS d i r s m -> ATMST s m ()
forall (m :: * -> *) d i r s.
(MonadIO m, NodeDatum d) =>
ATMS d i r s m -> ATMST s m ()
debugJusts ATMS d i r s m
atms
ATMS d i r s m -> ATMST s m ()
forall (m :: * -> *) d i r s.
(MonadIO m, NodeDatum d) =>
ATMS d i r s m -> ATMST s m ()
debugAtmsEnvs ATMS d i r s m
atms
ATMS d i r s m -> ATMST s m ()
forall (m :: * -> *) d i r s.
(MonadIO m, NodeDatum d) =>
ATMS d i r s m -> ATMST s m ()
debugNogoods ATMS d i r s m
atms
IO () -> ATMST s m ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> ATMST s m ()) -> IO () -> ATMST s m ()
forall a b. (a -> b) -> a -> b
$ String -> IO ()
putStrLn String
"=============== "
debugNodes :: (MonadIO m, NodeDatum d) => ATMS d i r s m -> ATMST s m ()
debugNodes :: ATMS d i r s m -> ATMST s m ()
debugNodes ATMS d i r s m
atms = do
[Node d i r s m]
nodes <- ATMS d i r s m -> ATMST s m [Node d i r s m]
forall (m :: * -> *) d i r s.
(Monad m, NodeDatum d) =>
ATMS d i r s m -> ATMST s m [Node d i r s m]
getNodes ATMS d i r s m
atms
IO () -> ATMST s m ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> ATMST s m ()) -> IO () -> ATMST s m ()
forall a b. (a -> b) -> a -> b
$ String -> IO ()
putStrLn (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ Int -> String
forall a. Show a => a -> String
show ([Node d i r s m] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Node d i r s m]
nodes) String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
" nodes:"
[Node d i r s m]
-> (Node d i r s m -> ATMST s m ()) -> ATMST s m ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ ([Node d i r s m] -> [Node d i r s m]
forall a. [a] -> [a]
reverse [Node d i r s m]
nodes) Node d i r s m -> ATMST s m ()
forall (m :: * -> *) d i r s.
(MonadIO m, NodeDatum d) =>
Node d i r s m -> ATMST s m ()
debugNode
formatNode :: (Monad m, NodeDatum d) => Node d i r s m -> ATMST s m String
formatNode :: Node d i r s m -> ATMST s m String
formatNode Node d i r s m
node = do
d -> String
datumFmt <- ATMS d i r s m -> ATMST s m (d -> String)
forall (m :: * -> *) d i r s.
(Monad m, NodeDatum d) =>
ATMS d i r s m -> ATMST s m (d -> String)
getDatumString (ATMS d i r s m -> ATMST s m (d -> String))
-> ATMS d i r s m -> ATMST s m (d -> String)
forall a b. (a -> b) -> a -> b
$ Node d i r s m -> ATMS d i r s m
forall d i r s (m :: * -> *).
(Monad m, NodeDatum d) =>
Node d i r s m -> ATMS d i r s m
nodeATMS Node d i r s m
node
String -> ATMST s m String
forall (m :: * -> *) a. Monad m => a -> m a
return (String -> ATMST s m String) -> String -> ATMST s m String
forall a b. (a -> b) -> a -> b
$ d -> String
datumFmt (Node d i r s m -> d
forall d i r s (m :: * -> *).
(Monad m, NodeDatum d) =>
Node d i r s m -> d
nodeDatum Node d i r s m
node)
formatNodes ::
(Monad m, NodeDatum d) => String -> [Node d i r s m] -> ATMST s m String
formatNodes :: String -> [Node d i r s m] -> ATMST s m String
formatNodes String
sep = String
-> (Node d i r s m -> ATMST s m String)
-> [Node d i r s m]
-> ATMST s m String
forall (m :: * -> *) a.
Monad m =>
String -> (a -> m String) -> [a] -> m String
formatList String
sep Node d i r s m -> ATMST s m String
forall (m :: * -> *) d i r s.
(Monad m, NodeDatum d) =>
Node d i r s m -> ATMST s m String
formatNode
formatNodeLists ::
(Monad m, NodeDatum d) => String -> [[Node d i r s m]] -> ATMST s m String
formatNodeLists :: String -> [[Node d i r s m]] -> ATMST s m String
formatNodeLists String
sep = String
-> ([Node d i r s m] -> ATMST s m String)
-> [[Node d i r s m]]
-> ATMST s m String
forall (m :: * -> *) a.
Monad m =>
String -> (a -> m String) -> [a] -> m String
formatList String
sep (([Node d i r s m] -> ATMST s m String)
-> [[Node d i r s m]] -> ATMST s m String)
-> ([Node d i r s m] -> ATMST s m String)
-> [[Node d i r s m]]
-> ATMST s m String
forall a b. (a -> b) -> a -> b
$ String -> [Node d i r s m] -> ATMST s m String
forall (m :: * -> *) d i r s.
(Monad m, NodeDatum d) =>
String -> [Node d i r s m] -> ATMST s m String
formatNodes String
","
formatNodeLabel :: (Monad m, NodeDatum d) => Node d i r s m -> ATMST s m String
formatNodeLabel :: Node d i r s m -> ATMST s m String
formatNodeLabel Node d i r s m
node = do
[Env d i r s m]
label <- Node d i r s m -> ATMST s m [Env d i r s m]
forall (m :: * -> *) d i r s.
(Monad m, NodeDatum d) =>
Node d i r s m -> ATMST s m [Env d i r s m]
getNodeLabel Node d i r s m
node
case [Env d i r s m]
label of
[] -> String -> ATMST s m String
forall (m :: * -> *) a. Monad m => a -> m a
return String
"empty"
[Env d i r s m]
_ -> String -> [[Node d i r s m]] -> ATMST s m String
forall (m :: * -> *) d i r s.
(Monad m, NodeDatum d) =>
String -> [[Node d i r s m]] -> ATMST s m String
formatNodeLists String
", " ([[Node d i r s m]] -> ATMST s m String)
-> [[Node d i r s m]] -> ATMST s m String
forall a b. (a -> b) -> a -> b
$ (Env d i r s m -> [Node d i r s m])
-> [Env d i r s m] -> [[Node d i r s m]]
forall a b. (a -> b) -> [a] -> [b]
map Env d i r s m -> [Node d i r s m]
forall d i r s (m :: * -> *).
(Monad m, NodeDatum d) =>
Env d i r s m -> [Node d i r s m]
envAssumptions [Env d i r s m]
label
blurbNode :: (MonadIO m, NodeDatum d) => Node d i r s m -> ATMST s m ()
blurbNode :: Node d i r s m -> ATMST s m ()
blurbNode Node d i r s m
node = Node d i r s m -> ATMST s m String
forall (m :: * -> *) d i r s.
(Monad m, NodeDatum d) =>
Node d i r s m -> ATMST s m String
formatNode Node d i r s m
node ATMST s m String -> (String -> ATMST s m ()) -> ATMST s m ()
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= IO () -> ATMST s m ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> ATMST s m ())
-> (String -> IO ()) -> String -> ATMST s m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> IO ()
putStr
printNode :: (MonadIO m, NodeDatum d) => Node d i r s m -> ATMST s m ()
printNode :: Node d i r s m -> ATMST s m ()
printNode Node d i r s m
node = do
String
str <- Node d i r s m -> ATMST s m String
forall (m :: * -> *) d i r s.
(Monad m, NodeDatum d) =>
Node d i r s m -> ATMST s m String
nodeString Node d i r s m
node
IO () -> ATMST s m ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> ATMST s m ()) -> IO () -> ATMST s m ()
forall a b. (a -> b) -> a -> b
$ String -> IO ()
putStr (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String
"<NODE: " String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
str String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
">"
debugNode :: (MonadIO m, NodeDatum d) => Node d i r s m -> ATMST s m ()
debugNode :: Node d i r s m -> ATMST s m ()
debugNode Node d i r s m
node = do
let atms :: ATMS d i r s m
atms = Node d i r s m -> ATMS d i r s m
forall d i r s (m :: * -> *).
(Monad m, NodeDatum d) =>
Node d i r s m -> ATMS d i r s m
nodeATMS Node d i r s m
node
d -> String
datumFmt <- ATMS d i r s m -> ATMST s m (d -> String)
forall (m :: * -> *) d i r s.
(Monad m, NodeDatum d) =>
ATMS d i r s m -> ATMST s m (d -> String)
getDatumString ATMS d i r s m
atms
i -> String
informantFmt <- ATMS d i r s m -> ATMST s m (i -> String)
forall (m :: * -> *) d i r s.
(Monad m, NodeDatum d) =>
ATMS d i r s m -> ATMST s m (i -> String)
getInformantString ATMS d i r s m
atms
IO () -> ATMST s m ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> ATMST s m ()) -> IO () -> ATMST s m ()
forall a b. (a -> b) -> a -> b
$ String -> IO ()
putStrLn (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String
"- " String -> ShowS
forall a. [a] -> [a] -> [a]
++ d -> String
datumFmt (Node d i r s m -> d
forall d i r s (m :: * -> *).
(Monad m, NodeDatum d) =>
Node d i r s m -> d
nodeDatum Node d i r s m
node)
[Env d i r s m]
label <- Node d i r s m -> ATMST s m [Env d i r s m]
forall (m :: * -> *) d i r s.
(Monad m, NodeDatum d) =>
Node d i r s m -> ATMST s m [Env d i r s m]
getNodeLabel Node d i r s m
node
case [Env d i r s m]
label of
[] -> IO () -> ATMST s m ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> ATMST s m ()) -> IO () -> ATMST s m ()
forall a b. (a -> b) -> a -> b
$ String -> IO ()
putStrLn String
" Empty label"
[Env d i r s m
env] -> do
IO () -> ATMST s m ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> ATMST s m ()) -> IO () -> ATMST s m ()
forall a b. (a -> b) -> a -> b
$ String -> IO ()
putStr String
" Single environment label: "
Env d i r s m -> ATMST s m ()
forall (m :: * -> *) d i r s.
(MonadIO m, NodeDatum d) =>
Env d i r s m -> ATMST s m ()
debugEnv Env d i r s m
env
[Env d i r s m]
_ -> [Env d i r s m] -> (Env d i r s m -> ATMST s m ()) -> ATMST s m ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [Env d i r s m]
label ((Env d i r s m -> ATMST s m ()) -> ATMST s m ())
-> (Env d i r s m -> ATMST s m ()) -> ATMST s m ()
forall a b. (a -> b) -> a -> b
$ \Env d i r s m
env -> do
IO () -> ATMST s m ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> ATMST s m ()) -> IO () -> ATMST s m ()
forall a b. (a -> b) -> a -> b
$ String -> IO ()
putStrLn String
" - "
Env d i r s m -> ATMST s m ()
forall (m :: * -> *) d i r s.
(MonadIO m, NodeDatum d) =>
Env d i r s m -> ATMST s m ()
debugEnv Env d i r s m
env
[JustRule d i r s m]
conseqs <- Node d i r s m -> ATMST s m [JustRule d i r s m]
forall (m :: * -> *) d i r s.
(Monad m, NodeDatum d) =>
Node d i r s m -> ATMST s m [JustRule d i r s m]
getNodeConsequences Node d i r s m
node
case [JustRule d i r s m]
conseqs of
[] -> IO () -> ATMST s m ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> ATMST s m ()) -> IO () -> ATMST s m ()
forall a b. (a -> b) -> a -> b
$ String -> IO ()
putStrLn String
" Antecedent to no justifications"
[JustRule d i r s m]
_ -> do
IO () -> ATMST s m ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> ATMST s m ()) -> IO () -> ATMST s m ()
forall a b. (a -> b) -> a -> b
$ String -> IO ()
putStr String
" Antecedent to:"
[JustRule d i r s m]
-> (JustRule d i r s m -> ATMST s m ()) -> ATMST s m ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [JustRule d i r s m]
conseqs ((JustRule d i r s m -> ATMST s m ()) -> ATMST s m ())
-> (JustRule d i r s m -> ATMST s m ()) -> ATMST s m ()
forall a b. (a -> b) -> a -> b
$ \ JustRule d i r s m
conseq -> do
IO () -> ATMST s m ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> ATMST s m ()) -> IO () -> ATMST s m ()
forall a b. (a -> b) -> a -> b
$ String -> IO ()
putStr (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String
" " String -> ShowS
forall a. [a] -> [a] -> [a]
++ i -> String
informantFmt (JustRule d i r s m -> i
forall d i r s (m :: * -> *).
(Monad m, NodeDatum d) =>
JustRule d i r s m -> i
justInformant JustRule d i r s m
conseq)
IO () -> ATMST s m ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> ATMST s m ()) -> IO () -> ATMST s m ()
forall a b. (a -> b) -> a -> b
$ String -> IO ()
putStrLn String
""
formatJustification ::
(Monad m, NodeDatum d) => Justification d i r s m -> ATMST s m String
formatJustification :: Justification d i r s m -> ATMST s m String
formatJustification (ByRule JustRule d i r s m
j) = String -> ATMST s m String
forall (m :: * -> *) a. Monad m => a -> m a
return (String -> ATMST s m String) -> String -> ATMST s m String
forall a b. (a -> b) -> a -> b
$ String
"By rule " String -> ShowS
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show (JustRule d i r s m -> Int
forall d i r s (m :: * -> *).
(Monad m, NodeDatum d) =>
JustRule d i r s m -> Int
justIndex JustRule d i r s m
j)
formatJustification (ByAssumption Node d i r s m
n) = do
Node d i r s m -> String
nodeFmt <- ATMS d i r s m -> ATMST s m (Node d i r s m -> String)
forall (m :: * -> *) d i r s.
(Monad m, NodeDatum d) =>
ATMS d i r s m -> ATMST s m (Node d i r s m -> String)
getNodeString (Node d i r s m -> ATMS d i r s m
forall d i r s (m :: * -> *).
(Monad m, NodeDatum d) =>
Node d i r s m -> ATMS d i r s m
nodeATMS Node d i r s m
n)
String -> ATMST s m String
forall (m :: * -> *) a. Monad m => a -> m a
return (String -> ATMST s m String) -> String -> ATMST s m String
forall a b. (a -> b) -> a -> b
$ String
"By assumption " String -> ShowS
forall a. [a] -> [a] -> [a]
++ Node d i r s m -> String
nodeFmt Node d i r s m
n
formatJustification Justification d i r s m
ByContradiction = String -> ATMST s m String
forall (m :: * -> *) a. Monad m => a -> m a
return String
"By contradiction"
debugJusts :: (MonadIO m, NodeDatum d) => ATMS d i r s m -> ATMST s m ()
debugJusts :: ATMS d i r s m -> ATMST s m ()
debugJusts ATMS d i r s m
atms = do
[JustRule d i r s m]
justs <- ATMS d i r s m -> ATMST s m [JustRule d i r s m]
forall (m :: * -> *) d i r s.
(Monad m, NodeDatum d) =>
ATMS d i r s m -> ATMST s m [JustRule d i r s m]
getJusts ATMS d i r s m
atms
let len :: Int
len = [JustRule d i r s m] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [JustRule d i r s m]
justs
IO () -> ATMST s m ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> ATMST s m ()) -> IO () -> ATMST s m ()
forall a b. (a -> b) -> a -> b
$ String -> IO ()
putStrLn (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ Int -> String
forall a. Show a => a -> String
show Int
len String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
" justification structure"
String -> ShowS
forall a. [a] -> [a] -> [a]
++ (if Int
len Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
1 then String
"" else String
"s") String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
":"
[JustRule d i r s m]
-> (JustRule d i r s m -> ATMST s m ()) -> ATMST s m ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ ((JustRule d i r s m -> Int)
-> [JustRule d i r s m] -> [JustRule d i r s m]
forall b a. Ord b => (a -> b) -> [a] -> [a]
sortOn JustRule d i r s m -> Int
forall d i r s (m :: * -> *).
(Monad m, NodeDatum d) =>
JustRule d i r s m -> Int
justIndex [JustRule d i r s m]
justs) ((JustRule d i r s m -> ATMST s m ()) -> ATMST s m ())
-> (JustRule d i r s m -> ATMST s m ()) -> ATMST s m ()
forall a b. (a -> b) -> a -> b
$ JustRule d i r s m -> ATMST s m ()
forall (m :: * -> *) d i r s.
(MonadIO m, NodeDatum d) =>
JustRule d i r s m -> ATMST s m ()
debugJust
formatJustInformant ::
(Monad m, NodeDatum d) => JustRule d i r s m -> ATMST s m String
formatJustInformant :: JustRule d i r s m -> ATMST s m String
formatJustInformant JustRule d i r s m
rule = do
i -> String
informantFmt <- ATMS d i r s m -> ATMST s m (i -> String)
forall (m :: * -> *) d i r s.
(Monad m, NodeDatum d) =>
ATMS d i r s m -> ATMST s m (i -> String)
getInformantString (ATMS d i r s m -> ATMST s m (i -> String))
-> ATMS d i r s m -> ATMST s m (i -> String)
forall a b. (a -> b) -> a -> b
$ Node d i r s m -> ATMS d i r s m
forall d i r s (m :: * -> *).
(Monad m, NodeDatum d) =>
Node d i r s m -> ATMS d i r s m
nodeATMS (Node d i r s m -> ATMS d i r s m)
-> Node d i r s m -> ATMS d i r s m
forall a b. (a -> b) -> a -> b
$ JustRule d i r s m -> Node d i r s m
forall d i r s (m :: * -> *).
(Monad m, NodeDatum d) =>
JustRule d i r s m -> Node d i r s m
justConsequence JustRule d i r s m
rule
String -> ATMST s m String
forall (m :: * -> *) a. Monad m => a -> m a
return (String -> ATMST s m String) -> String -> ATMST s m String
forall a b. (a -> b) -> a -> b
$ i -> String
informantFmt (i -> String) -> i -> String
forall a b. (a -> b) -> a -> b
$ JustRule d i r s m -> i
forall d i r s (m :: * -> *).
(Monad m, NodeDatum d) =>
JustRule d i r s m -> i
justInformant JustRule d i r s m
rule
printJust :: (MonadIO m, NodeDatum d) => JustRule d i r s m -> ATMST s m ()
printJust :: JustRule d i r s m -> ATMST s m ()
printJust JustRule d i r s m
rule = do
String
infStr <- JustRule d i r s m -> ATMST s m String
forall (m :: * -> *) d i r s.
(Monad m, NodeDatum d) =>
JustRule d i r s m -> ATMST s m String
formatJustInformant JustRule d i r s m
rule
IO () -> ATMST s m ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> ATMST s m ()) -> IO () -> ATMST s m ()
forall a b. (a -> b) -> a -> b
$ String -> IO ()
putStr (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String
"<" String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
infStr String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
" " String -> ShowS
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show (JustRule d i r s m -> Int
forall d i r s (m :: * -> *).
(Monad m, NodeDatum d) =>
JustRule d i r s m -> Int
justIndex JustRule d i r s m
rule) String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
">"
printJustification ::
(MonadIO m, NodeDatum d) => Justification d i r s m -> ATMST s m ()
printJustification :: Justification d i r s m -> ATMST s m ()
printJustification Justification d i r s m
j = case Justification d i r s m
j of
ByRule JustRule d i r s m
rule -> JustRule d i r s m -> ATMST s m ()
forall (m :: * -> *) d i r s.
(MonadIO m, NodeDatum d) =>
JustRule d i r s m -> ATMST s m ()
printJust JustRule d i r s m
rule
ByAssumption Node d i r s m
node -> do
IO () -> ATMST s m ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> ATMST s m ()) -> IO () -> ATMST s m ()
forall a b. (a -> b) -> a -> b
$ String -> IO ()
putStr (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String
"Assumed node "
Node d i r s m -> ATMST s m ()
forall (m :: * -> *) d i r s.
(MonadIO m, NodeDatum d) =>
Node d i r s m -> ATMST s m ()
printNode Node d i r s m
node
Justification d i r s m
ByContradiction -> IO () -> ATMST s m ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> ATMST s m ()) -> IO () -> ATMST s m ()
forall a b. (a -> b) -> a -> b
$ String -> IO ()
putStrLn (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String
"By contradiction"
debugJust :: (MonadIO m, NodeDatum d) => JustRule d i r s m -> ATMST s m ()
debugJust :: JustRule d i r s m -> ATMST s m ()
debugJust (JustRule Int
idx i
inf Node d i r s m
conseq [Node d i r s m]
ants) = do
let atms :: ATMS d i r s m
atms = Node d i r s m -> ATMS d i r s m
forall d i r s (m :: * -> *).
(Monad m, NodeDatum d) =>
Node d i r s m -> ATMS d i r s m
nodeATMS Node d i r s m
conseq
i -> String
informantFmt <- ATMS d i r s m -> ATMST s m (i -> String)
forall (m :: * -> *) d i r s.
(Monad m, NodeDatum d) =>
ATMS d i r s m -> ATMST s m (i -> String)
getInformantString ATMS d i r s m
atms
d -> String
datumFmt <- ATMS d i r s m -> ATMST s m (d -> String)
forall (m :: * -> *) d i r s.
(Monad m, NodeDatum d) =>
ATMS d i r s m -> ATMST s m (d -> String)
getDatumString ATMS d i r s m
atms
IO () -> ATMST s m ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> ATMST s m ()) -> IO () -> ATMST s m ()
forall a b. (a -> b) -> a -> b
$ String -> IO ()
putStrLn (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String
" "
String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
"[" String -> ShowS
forall a. [a] -> [a] -> [a]
++ i -> String
informantFmt i
inf String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
"." String -> ShowS
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show Int
idx String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
"] "
String -> ShowS
forall a. [a] -> [a] -> [a]
++ d -> String
datumFmt (Node d i r s m -> d
forall d i r s (m :: * -> *).
(Monad m, NodeDatum d) =>
Node d i r s m -> d
nodeDatum Node d i r s m
conseq) String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
" <= "
String -> ShowS
forall a. [a] -> [a] -> [a]
++ String -> [String] -> String
forall a. [a] -> [[a]] -> [a]
intercalate String
", " ((Node d i r s m -> String) -> [Node d i r s m] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map (d -> String
datumFmt (d -> String) -> (Node d i r s m -> d) -> Node d i r s m -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Node d i r s m -> d
forall d i r s (m :: * -> *).
(Monad m, NodeDatum d) =>
Node d i r s m -> d
nodeDatum) [Node d i r s m]
ants)
debugAtmsEnvs :: (MonadIO m, NodeDatum d) => ATMS d i r s m -> ATMST s m ()
debugAtmsEnvs :: ATMS d i r s m -> ATMST s m ()
debugAtmsEnvs ATMS d i r s m
atms = do
IO () -> ATMST s m ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> ATMST s m ()) -> IO () -> ATMST s m ()
forall a b. (a -> b) -> a -> b
$ String -> IO ()
putStrLn String
"Environments:"
EnvTable d i r s m
envTable <- ATMS d i r s m -> ATMST s m (EnvTable d i r s m)
forall (m :: * -> *) d i r s.
(Monad m, NodeDatum d) =>
ATMS d i r s m -> ATMST s m (EnvTable d i r s m)
getEnvTable ATMS d i r s m
atms
ATMS d i r s m -> EnvTable d i r s m -> ATMST s m ()
forall (m :: * -> *) d i r s.
(MonadIO m, NodeDatum d) =>
ATMS d i r s m -> EnvTable d i r s m -> ATMST s m ()
debugEnvTable ATMS d i r s m
atms EnvTable d i r s m
envTable
debugEnv :: (MonadIO m, NodeDatum d) => Env d i r s m -> ATMST s m ()
debugEnv :: Env d i r s m -> ATMST s m ()
debugEnv Env d i r s m
env = do
Bool
isNogood <- Env d i r s m -> ATMST s m Bool
forall (m :: * -> *) d i r s.
(Monad m, NodeDatum d) =>
Env d i r s m -> ATMST s m Bool
envIsNogood Env d i r s m
env
case Env d i r s m -> [Node d i r s m]
forall d i r s (m :: * -> *).
(Monad m, NodeDatum d) =>
Env d i r s m -> [Node d i r s m]
envAssumptions Env d i r s m
env of
[] -> IO () -> ATMST s m ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> ATMST s m ()) -> IO () -> ATMST s m ()
forall a b. (a -> b) -> a -> b
$ String -> IO ()
putStrLn String
"<empty>"
nodes :: [Node d i r s m]
nodes @ (Node d i r s m
n : [Node d i r s m]
_) -> do
let atms :: ATMS d i r s m
atms = Node d i r s m -> ATMS d i r s m
forall d i r s (m :: * -> *).
(Monad m, NodeDatum d) =>
Node d i r s m -> ATMS d i r s m
nodeATMS Node d i r s m
n
d -> String
datumFmt <- ATMS d i r s m -> ATMST s m (d -> String)
forall (m :: * -> *) d i r s.
(Monad m, NodeDatum d) =>
ATMS d i r s m -> ATMST s m (d -> String)
getDatumString ATMS d i r s m
atms
Bool -> ATMST s m () -> ATMST s m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
isNogood (ATMST s m () -> ATMST s m ()) -> ATMST s m () -> ATMST s m ()
forall a b. (a -> b) -> a -> b
$ IO () -> ATMST s m ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> ATMST s m ()) -> IO () -> ATMST s m ()
forall a b. (a -> b) -> a -> b
$ String -> IO ()
putStr String
"[X] "
IO () -> ATMST s m ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> ATMST s m ()) -> IO () -> ATMST s m ()
forall a b. (a -> b) -> a -> b
$ String -> IO ()
putStrLn (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$
(String -> [String] -> String
forall a. [a] -> [[a]] -> [a]
intercalate String
", " ([String] -> String) -> [String] -> String
forall a b. (a -> b) -> a -> b
$ (Node d i r s m -> String) -> [Node d i r s m] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map (d -> String
datumFmt (d -> String) -> (Node d i r s m -> d) -> Node d i r s m -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Node d i r s m -> d
forall d i r s (m :: * -> *).
(Monad m, NodeDatum d) =>
Node d i r s m -> d
nodeDatum) [Node d i r s m]
nodes)
String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
" (count " String -> ShowS
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show ([Node d i r s m] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Node d i r s m]
nodes) String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
")"
blurbMaybeEnvMList ::
(MonadIO m, NodeDatum d) => MList s (Maybe (Env d i r s m)) -> ATMST s m ()
blurbMaybeEnvMList :: MList s (Maybe (Env d i r s m)) -> ATMST s m ()
blurbMaybeEnvMList MList s (Maybe (Env d i r s m))
mlist = do
STRef s String
sep <- STT s m (STRef s String) -> ATMST s m (STRef s String)
forall (m :: * -> *) s r. Monad m => STT s m r -> ATMST s m r
sttLayer (STT s m (STRef s String) -> ATMST s m (STRef s String))
-> STT s m (STRef s String) -> ATMST s m (STRef s String)
forall a b. (a -> b) -> a -> b
$ String -> STT s m (STRef s String)
forall (m :: * -> *) a s. Applicative m => a -> STT s m (STRef s a)
newSTRef String
""
IO () -> ATMST s m ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> ATMST s m ()) -> IO () -> ATMST s m ()
forall a b. (a -> b) -> a -> b
$ String -> IO ()
putStr String
"m["
(forall r. STT s m r -> ATMST s m r)
-> MList s (Maybe (Env d i r s m))
-> (Maybe (Env d i r s m) -> ATMST s m ())
-> ATMST s m ()
forall (m0 :: * -> *) (m :: * -> *) s a.
(Monad m0, Monad m) =>
(forall r. STT s m0 r -> m r) -> MList s a -> (a -> m ()) -> m ()
mlistFor_ forall r. STT s m r -> ATMST s m r
forall (m :: * -> *) s r. Monad m => STT s m r -> ATMST s m r
sttLayer MList s (Maybe (Env d i r s m))
mlist ((Maybe (Env d i r s m) -> ATMST s m ()) -> ATMST s m ())
-> (Maybe (Env d i r s m) -> ATMST s m ()) -> ATMST s m ()
forall a b. (a -> b) -> a -> b
$ \Maybe (Env d i r s m)
envm -> do
String
thisSep <- STT s m String -> ATMST s m String
forall (m :: * -> *) s r. Monad m => STT s m r -> ATMST s m r
sttLayer (STT s m String -> ATMST s m String)
-> STT s m String -> ATMST s m String
forall a b. (a -> b) -> a -> b
$ STRef s String -> STT s m String
forall (m :: * -> *) s a. Applicative m => STRef s a -> STT s m a
readSTRef STRef s String
sep
IO () -> ATMST s m ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> ATMST s m ()) -> IO () -> ATMST s m ()
forall a b. (a -> b) -> a -> b
$ String -> IO ()
putStr String
thisSep
case Maybe (Env d i r s m)
envm of
Just Env d i r s m
env -> Env d i r s m -> ATMST s m ()
forall (m :: * -> *) d i r s.
(MonadIO m, NodeDatum d) =>
Env d i r s m -> ATMST s m ()
blurbEnv Env d i r s m
env
Maybe (Env d i r s m)
Nothing -> IO () -> ATMST s m ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> ATMST s m ()) -> IO () -> ATMST s m ()
forall a b. (a -> b) -> a -> b
$ String -> IO ()
putStr String
"<nothing>"
STT s m () -> ATMST s m ()
forall (m :: * -> *) s r. Monad m => STT s m r -> ATMST s m r
sttLayer (STT s m () -> ATMST s m ()) -> STT s m () -> ATMST s m ()
forall a b. (a -> b) -> a -> b
$ STRef s String -> String -> STT s m ()
forall (m :: * -> *) s a.
Applicative m =>
STRef s a -> a -> STT s m ()
writeSTRef STRef s String
sep String
", "
IO () -> ATMST s m ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> ATMST s m ()) -> IO () -> ATMST s m ()
forall a b. (a -> b) -> a -> b
$ String -> IO ()
putStr String
"]"
blurbMaybeEnvMListRef ::
(MonadIO m, NodeDatum d) =>
STRef s (MList s (Maybe (Env d i r s m))) -> ATMST s m ()
blurbMaybeEnvMListRef :: STRef s (MList s (Maybe (Env d i r s m))) -> ATMST s m ()
blurbMaybeEnvMListRef STRef s (MList s (Maybe (Env d i r s m)))
mlistRef = do
MList s (Maybe (Env d i r s m))
mlist <- STT s m (MList s (Maybe (Env d i r s m)))
-> ATMST s m (MList s (Maybe (Env d i r s m)))
forall (m :: * -> *) s r. Monad m => STT s m r -> ATMST s m r
sttLayer (STT s m (MList s (Maybe (Env d i r s m)))
-> ATMST s m (MList s (Maybe (Env d i r s m))))
-> STT s m (MList s (Maybe (Env d i r s m)))
-> ATMST s m (MList s (Maybe (Env d i r s m)))
forall a b. (a -> b) -> a -> b
$ STRef s (MList s (Maybe (Env d i r s m)))
-> STT s m (MList s (Maybe (Env d i r s m)))
forall (m :: * -> *) s a. Applicative m => STRef s a -> STT s m a
readSTRef STRef s (MList s (Maybe (Env d i r s m)))
mlistRef
MList s (Maybe (Env d i r s m)) -> ATMST s m ()
forall (m :: * -> *) d s i r.
(MonadIO m, NodeDatum d) =>
MList s (Maybe (Env d i r s m)) -> ATMST s m ()
blurbMaybeEnvMList MList s (Maybe (Env d i r s m))
mlist
blurbMaybeEnv ::
(MonadIO m, NodeDatum d) => Maybe (Env d i r s m) -> ATMST s m ()
blurbMaybeEnv :: Maybe (Env d i r s m) -> ATMST s m ()
blurbMaybeEnv Maybe (Env d i r s m)
envm = case Maybe (Env d i r s m)
envm of
Just Env d i r s m
env -> Env d i r s m -> ATMST s m ()
forall (m :: * -> *) d i r s.
(MonadIO m, NodeDatum d) =>
Env d i r s m -> ATMST s m ()
blurbEnv Env d i r s m
env
Maybe (Env d i r s m)
Nothing -> IO () -> ATMST s m ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> ATMST s m ()) -> IO () -> ATMST s m ()
forall a b. (a -> b) -> a -> b
$ String -> IO ()
putStr String
"<nothing>"
blurbEnv :: (MonadIO m, NodeDatum d) => Env d i r s m -> ATMST s m ()
blurbEnv :: Env d i r s m -> ATMST s m ()
blurbEnv Env d i r s m
env = do
WhyNogood d i r s m
wng <- STT s m (WhyNogood d i r s m) -> ATMST s m (WhyNogood d i r s m)
forall (m :: * -> *) s r. Monad m => STT s m r -> ATMST s m r
sttLayer (STT s m (WhyNogood d i r s m) -> ATMST s m (WhyNogood d i r s m))
-> STT s m (WhyNogood d i r s m) -> ATMST s m (WhyNogood d i r s m)
forall a b. (a -> b) -> a -> b
$ STRef s (WhyNogood d i r s m) -> STT s m (WhyNogood d i r s m)
forall (m :: * -> *) s a. Applicative m => STRef s a -> STT s m a
readSTRef (STRef s (WhyNogood d i r s m) -> STT s m (WhyNogood d i r s m))
-> STRef s (WhyNogood d i r s m) -> STT s m (WhyNogood d i r s m)
forall a b. (a -> b) -> a -> b
$ Env d i r s m -> STRef s (WhyNogood d i r s m)
forall d i r s (m :: * -> *).
(Monad m, NodeDatum d) =>
Env d i r s m -> STRef s (WhyNogood d i r s m)
envWhyNogood Env d i r s m
env
Bool
isNogood <- Env d i r s m -> ATMST s m Bool
forall (m :: * -> *) d i r s.
(Monad m, NodeDatum d) =>
Env d i r s m -> ATMST s m Bool
envIsNogood Env d i r s m
env
case Env d i r s m -> [Node d i r s m]
forall d i r s (m :: * -> *).
(Monad m, NodeDatum d) =>
Env d i r s m -> [Node d i r s m]
envAssumptions Env d i r s m
env of
[] -> do
IO () -> ATMST s m ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> ATMST s m ()) -> IO () -> ATMST s m ()
forall a b. (a -> b) -> a -> b
$ String -> IO ()
putStr String
"<empty>"
nodes :: [Node d i r s m]
nodes @ (Node d i r s m
first : [Node d i r s m]
_) -> do
d -> String
datumFmt <- ATMS d i r s m -> ATMST s m (d -> String)
forall (m :: * -> *) d i r s.
(Monad m, NodeDatum d) =>
ATMS d i r s m -> ATMST s m (d -> String)
getDatumString (Node d i r s m -> ATMS d i r s m
forall d i r s (m :: * -> *).
(Monad m, NodeDatum d) =>
Node d i r s m -> ATMS d i r s m
nodeATMS Node d i r s m
first)
Bool -> ATMST s m () -> ATMST s m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
isNogood (ATMST s m () -> ATMST s m ()) -> ATMST s m () -> ATMST s m ()
forall a b. (a -> b) -> a -> b
$ IO () -> ATMST s m ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> ATMST s m ()) -> IO () -> ATMST s m ()
forall a b. (a -> b) -> a -> b
$ String -> IO ()
putStr String
"[X] "
IO () -> ATMST s m ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> ATMST s m ()) -> IO () -> ATMST s m ()
forall a b. (a -> b) -> a -> b
$ String -> IO ()
putStr (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$
String
"{" String -> ShowS
forall a. [a] -> [a] -> [a]
++ (String -> [String] -> String
forall a. [a] -> [[a]] -> [a]
intercalate String
", " ([String] -> String) -> [String] -> String
forall a b. (a -> b) -> a -> b
$ (Node d i r s m -> String) -> [Node d i r s m] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map (d -> String
datumFmt (d -> String) -> (Node d i r s m -> d) -> Node d i r s m -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Node d i r s m -> d
forall d i r s (m :: * -> *).
(Monad m, NodeDatum d) =>
Node d i r s m -> d
nodeDatum) [Node d i r s m]
nodes) String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
"}"
debugNogoods :: (MonadIO m, NodeDatum d) => ATMS d i r s m -> ATMST s m ()
debugNogoods :: ATMS d i r s m -> ATMST s m ()
debugNogoods ATMS d i r s m
atms = do
IO () -> ATMST s m ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> ATMST s m ()) -> IO () -> ATMST s m ()
forall a b. (a -> b) -> a -> b
$ String -> IO ()
putStrLn String
"No-good environments:"
EnvTable d i r s m
nogoodTable <- ATMS d i r s m -> ATMST s m (EnvTable d i r s m)
forall (m :: * -> *) d i r s.
(Monad m, NodeDatum d) =>
ATMS d i r s m -> ATMST s m (EnvTable d i r s m)
getNogoodTable ATMS d i r s m
atms
ATMS d i r s m -> EnvTable d i r s m -> ATMST s m ()
forall (m :: * -> *) d i r s.
(MonadIO m, NodeDatum d) =>
ATMS d i r s m -> EnvTable d i r s m -> ATMST s m ()
debugEnvTable ATMS d i r s m
atms EnvTable d i r s m
nogoodTable
debugEnvTable ::
(MonadIO m, NodeDatum d) =>
ATMS d i r s m -> EnvTable d i r s m -> ATMST s m ()
debugEnvTable :: ATMS d i r s m -> EnvTable d i r s m -> ATMST s m ()
debugEnvTable ATMS d i r s m
atms (EnvTable STArray s Int [Env d i r s m]
array) = do
let (Int
lo, Int
hi) = STArray s Int [Env d i r s m] -> (Int, Int)
forall s i e. STArray s i e -> (i, i)
boundsSTArray STArray s Int [Env d i r s m]
array
[Int] -> (Int -> ATMST s m ()) -> ATMST s m ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [Int
lo..Int
hi] ((Int -> ATMST s m ()) -> ATMST s m ())
-> (Int -> ATMST s m ()) -> ATMST s m ()
forall a b. (a -> b) -> a -> b
$ \ Int
i -> do
[Env d i r s m]
envs <- STT s m [Env d i r s m] -> ATMST s m [Env d i r s m]
forall (m :: * -> *) s r. Monad m => STT s m r -> ATMST s m r
sttLayer (STT s m [Env d i r s m] -> ATMST s m [Env d i r s m])
-> STT s m [Env d i r s m] -> ATMST s m [Env d i r s m]
forall a b. (a -> b) -> a -> b
$ STArray s Int [Env d i r s m] -> Int -> STT s m [Env d i r s m]
forall i (m :: * -> *) s e.
(Ix i, Applicative m) =>
STArray s i e -> i -> STT s m e
readSTArray STArray s Int [Env d i r s m]
array Int
i
[Env d i r s m] -> (Env d i r s m -> ATMST s m ()) -> ATMST s m ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ ([Env d i r s m] -> [Env d i r s m]
forall a. [a] -> [a]
reverse [Env d i r s m]
envs) ((Env d i r s m -> ATMST s m ()) -> ATMST s m ())
-> (Env d i r s m -> ATMST s m ()) -> ATMST s m ()
forall a b. (a -> b) -> a -> b
$ \ Env d i r s m
env -> do
IO () -> ATMST s m ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> ATMST s m ()) -> IO () -> ATMST s m ()
forall a b. (a -> b) -> a -> b
$ String -> IO ()
putStr String
"- "
Env d i r s m -> ATMST s m ()
forall (m :: * -> *) d i r s.
(MonadIO m, NodeDatum d) =>
Env d i r s m -> ATMST s m ()
debugEnv Env d i r s m
env
debugNodeLabel ::
(MonadIO m, NodeDatum d) => Node d i r s m -> ATMST s m ()
debugNodeLabel :: Node d i r s m -> ATMST s m ()
debugNodeLabel Node d i r s m
node = do
[Env d i r s m]
lbl <- STT s m [Env d i r s m] -> ATMST s m [Env d i r s m]
forall (m :: * -> *) s r. Monad m => STT s m r -> ATMST s m r
sttLayer (STT s m [Env d i r s m] -> ATMST s m [Env d i r s m])
-> STT s m [Env d i r s m] -> ATMST s m [Env d i r s m]
forall a b. (a -> b) -> a -> b
$ STRef s [Env d i r s m] -> STT s m [Env d i r s m]
forall (m :: * -> *) s a. Applicative m => STRef s a -> STT s m a
readSTRef (Node d i r s m -> STRef s [Env d i r s m]
forall d i r s (m :: * -> *).
(Monad m, NodeDatum d) =>
Node d i r s m -> STRef s [Env d i r s m]
nodeLabel Node d i r s m
node)
Node d i r s m -> ATMST s m ()
forall (m :: * -> *) d i r s.
(MonadIO m, NodeDatum d) =>
Node d i r s m -> ATMST s m ()
blurbNode Node d i r s m
node
IO () -> ATMST s m ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> ATMST s m ()) -> IO () -> ATMST s m ()
forall a b. (a -> b) -> a -> b
$ String -> IO ()
putStr String
" label: "
Int -> String -> [Env d i r s m] -> ATMST s m ()
forall (m :: * -> *) d i r s.
(MonadIO m, NodeDatum d) =>
Int -> String -> [Env d i r s m] -> ATMST s m ()
blurbEnvList Int
10000 String
"\n" [Env d i r s m]
lbl
IO () -> ATMST s m ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> ATMST s m ()) -> IO () -> ATMST s m ()
forall a b. (a -> b) -> a -> b
$ String -> IO ()
putStrLn String
""
blurbEnvList ::
(MonadIO m, NodeDatum d) => Int -> String -> [Env d i r s m] -> ATMST s m ()
blurbEnvList :: Int -> String -> [Env d i r s m] -> ATMST s m ()
blurbEnvList Int
multiLineIf String
lineLead [Env d i r s m]
envs =
case [Env d i r s m] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Env d i r s m]
envs of
Int
0 -> IO () -> ATMST s m ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> ATMST s m ()) -> IO () -> ATMST s m ()
forall a b. (a -> b) -> a -> b
$ String -> IO ()
putStr String
"empty env list"
Int
n | Int
n Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
multiLineIf -> do
IO () -> ATMST s m ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> ATMST s m ()) -> IO () -> ATMST s m ()
forall a b. (a -> b) -> a -> b
$ String -> IO ()
putStr (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ Int -> String
forall a. Show a => a -> String
show Int
n String -> ShowS
forall a. [a] -> [a] -> [a]
++String
" envs: "
STRef s String
sepR <- STT s m (STRef s String) -> ATMST s m (STRef s String)
forall (m :: * -> *) s r. Monad m => STT s m r -> ATMST s m r
sttLayer (STT s m (STRef s String) -> ATMST s m (STRef s String))
-> STT s m (STRef s String) -> ATMST s m (STRef s String)
forall a b. (a -> b) -> a -> b
$ String -> STT s m (STRef s String)
forall (m :: * -> *) a s. Applicative m => a -> STT s m (STRef s a)
newSTRef String
""
[Env d i r s m] -> (Env d i r s m -> ATMST s m ()) -> ATMST s m ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [Env d i r s m]
envs ((Env d i r s m -> ATMST s m ()) -> ATMST s m ())
-> (Env d i r s m -> ATMST s m ()) -> ATMST s m ()
forall a b. (a -> b) -> a -> b
$ \Env d i r s m
env -> do
String
sep <- STT s m String -> ATMST s m String
forall (m :: * -> *) s r. Monad m => STT s m r -> ATMST s m r
sttLayer (STT s m String -> ATMST s m String)
-> STT s m String -> ATMST s m String
forall a b. (a -> b) -> a -> b
$ STRef s String -> STT s m String
forall (m :: * -> *) s a. Applicative m => STRef s a -> STT s m a
readSTRef STRef s String
sepR
IO () -> ATMST s m ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> ATMST s m ()) -> IO () -> ATMST s m ()
forall a b. (a -> b) -> a -> b
$ String -> IO ()
putStr String
sep
Env d i r s m -> ATMST s m ()
forall (m :: * -> *) d i r s.
(MonadIO m, NodeDatum d) =>
Env d i r s m -> ATMST s m ()
blurbEnv Env d i r s m
env
STT s m () -> ATMST s m ()
forall (m :: * -> *) s r. Monad m => STT s m r -> ATMST s m r
sttLayer (STT s m () -> ATMST s m ()) -> STT s m () -> ATMST s m ()
forall a b. (a -> b) -> a -> b
$ STRef s String -> String -> STT s m ()
forall (m :: * -> *) s a.
Applicative m =>
STRef s a -> a -> STT s m ()
writeSTRef STRef s String
sepR String
", "
Int
n -> do
IO () -> ATMST s m ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> ATMST s m ()) -> IO () -> ATMST s m ()
forall a b. (a -> b) -> a -> b
$ String -> IO ()
putStrLn (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ Int -> String
forall a. Show a => a -> String
show Int
n String -> ShowS
forall a. [a] -> [a] -> [a]
++String
" envs:"
[Env d i r s m] -> (Env d i r s m -> ATMST s m ()) -> ATMST s m ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [Env d i r s m]
envs ((Env d i r s m -> ATMST s m ()) -> ATMST s m ())
-> (Env d i r s m -> ATMST s m ()) -> ATMST s m ()
forall a b. (a -> b) -> a -> b
$ \Env d i r s m
env -> do
IO () -> ATMST s m ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> ATMST s m ()) -> IO () -> ATMST s m ()
forall a b. (a -> b) -> a -> b
$ String -> IO ()
putStr String
lineLead
Env d i r s m -> ATMST s m ()
forall (m :: * -> *) d i r s.
(MonadIO m, NodeDatum d) =>
Env d i r s m -> ATMST s m ()
blurbEnv Env d i r s m
env
IO () -> ATMST s m ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> ATMST s m ()) -> IO () -> ATMST s m ()
forall a b. (a -> b) -> a -> b
$ String -> IO ()
putStrLn String
""
instance MonadIO m => MonadIO (STT s m) where liftIO :: IO a -> STT s m a
liftIO = m a -> STT s m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (m a -> STT s m a) -> (IO a -> m a) -> IO a -> STT s m a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO