{-|
Module      : ATMS
Description : Mutable assumption-based truth maintenance systems (ATMSes)
Copyright   : (c) John Maraist, 2022
              Kenneth D. Forbus, Johan de Kleer and Xerox Corporation, 1986-1993
License     : AllRightsReserved
Maintainer  : haskell-tms@maraist.org
Stability   : experimental
Portability : POSIX

Translation of Forbus and de Kleer's assumption-based truth
maintenance systems (ATMSes) from Common Lisp to Haskell.

This is not a very \"Haskelly\" implementation; rather, it is a
translation of the original code with minimal changes.  Most of the
deviations from the original are due to either Haskell's strong
typing, which necessitates some additional tagging, and to the
abomination which is Lisp's @do@ macro.  The translation relies on
mutable data structures using `STT` state thread references.  A more
pure translation, possibly not relying on the [@ST@
monad]("Control.Monad.ST")/[@STT@
transformer]("Control.Monad.ST.Trans"), is a significant piece of
future work.

Note also there are restrictions on the embedded monad @m@ which can
be wrapped in the `STT` transformer; see [the @Control.Monad.ST.Trans@
documentation]("Control.Monad.ST.Trans") for details.

See the @LICENSE.txt@ and @README-forbus-dekleer.txt@ files
distributed with this work for a paragraph stating scope of permission
and disclaimer of warranty, and for additional information regarding
copyright ownership.  The above copyright notice and that paragraph
must be included in any separate copy of this file.

Unless required by applicable law or agreed to in writing, software
distributed under the License is distributed on an "AS IS" BASIS,
WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or
implied, for NON-COMMERCIAL use.  See the License for the specific
language governing permissions and limitations under the License.

-}

{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE TemplateHaskell #-}

module Data.TMS.ATMS.ATMST (
  -- * The ATMST monad
  ATMST,
  AtmsErr(CannotRemoveNodeWIthConsequences, InternalNoEmptyEnv, FromMonadFail),
  runATMST,
  setInitialEnvTableAlloc, setEnvTableIncr,
  getInitialEnvTableAlloc, getEnvTableIncr,

  -- * ATMS data structures

  -- ** Component classes
  NodeDatum, contradictionNodeDatum,

  -- ** Top-level ATMS
  ATMS, createATMS, atmsTitle,

  -- *** ATMS components
  getNodes, getJusts, getContradictions, getAssumptions,
  getContradictionNode, getEmptyEnvironment, getNodeString, getJustString,
  getDatumString, getInformantString, getEnqueueProcedure,

  setDatumStringViaString, setDatumStringViaShow,
  setInformantStringViaString, setInformantStringViaShow,

  -- ** Nodes
  Node, nodeDatum, createNode,
  -- *** Node components
  nodeATMS, nodeString, defaultNodeString, getNodeLabel, getNodeRules,
  getNodeConsequences,
  -- *** Setting node status
  assumeNode, makeContradiction, removeNode,

  -- ** Justifications
  JustRule(JustRule), justInformant, justConsequence, justAntecedents,
  Justification, Explanation, justifyNode,

  -- ** Environments and tables
  Env, EnvTable, envIndex, envAssumptions, getEnvNodes,

  -- * Deduction and search utilities
  {- interpretations, -}

  -- ** Related to a node
  isTrueNode, isInNode, isInNodeByEnv, isOutNode, isNodeConsistentWith,
  getNodeIsAssumption, getNodeIsContradictory, {- explainNode, -}

  -- ** Related to environments
  envIsNogood,

  -- * Printing and debugging

  -- |Functions prefixed @format@ build a computation returning a
  -- `String`.  Functions prefixed @debug@ or @print@ build a unit
  -- computation printing the artifact in question to standard output;
  -- those with prefix @debug@ are generally more verbose.
  debugAtms, printAtms, debugAtmsEnvs,
  printAtmsStatistics,

  -- ** Nodes and node lists
  formatNode, formatNodes, debugNode, printNode,
  whyNodes, whyNode,

  -- ** Environments, labels, and tables
  debugEnv, debugEnvTable, formatNodeLabel,
  debugNogoods,
  printEnv, printNogoods, printEnvs, printEnvTable, printTable,

  -- ** Justifications
  debugJust, printJust, formatJustification

  ) where

import Control.Monad.State
import Control.Monad.ST.Trans
-- import Control.Monad.Except
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


-- * The @ATMST@ monad transformer
--
-- Construction and manipulation of a ATMS happens inside this monad
-- wrapper.

-- |Errors which can arise from ATMS operations.
data AtmsErr = CannotRemoveNodeWIthConsequences String Int
               -- ^ It is not possible to remove a `Node` from an
               -- `ATMS` after a `JustRule` which uses that `Node` is
               -- added to the `ATMS`.
             | InternalNoEmptyEnv
               -- ^ Internal error called when there is no internal
               -- default empty `Env` associated with this `ATMS`.
               -- Should never be signaled for an `ATMS` created with
               -- `createATMS`, since this latter function does set up
               -- the default empty environment before returning the
               -- new `ATMS`.
             | InternalNoContraNode
               -- ^ Internal error called when there is no internal
               -- default contradictory `Node` associated with this
               -- `ATMS`.  Should never be signaled for an `ATMS`
               -- created with `createATMS`, since this latter
               -- function does set up the default contradiction node
               -- before returning the new `ATMS`.
             | UnexpectedNonruleJustification
               -- ^ Indicates that a `Justification` other than
               -- `ByRule` `JustRule` was found, specifically in a
               -- `removeNode` call.
             | FromMonadFail String
               -- ^ Indicates a pattern-matching failure within an
               -- `ATMST` operation.
  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

{- ===== Internal state of an ATMST. =================================== -}

-- |Internal state of an ATMST process
data AtmstState = AtmstState {
  AtmstState -> Int
initialEnvTableAlloc :: Int,
  AtmstState -> Int
envTableIncr :: Int
  }

-- |Initial state of an ATMST process.
initialAtmstState :: AtmstState
initialAtmstState :: AtmstState
initialAtmstState = Int -> Int -> AtmstState
AtmstState Int
50 Int
75

-- |Update the initial table size of an ATMST state.
withInitialEnvTableAlloc :: AtmstState -> Int -> AtmstState
withInitialEnvTableAlloc :: AtmstState -> Int -> AtmstState
withInitialEnvTableAlloc (AtmstState Int
_ Int
ei) Int
ia = Int -> Int -> AtmstState
AtmstState Int
ia Int
ei

-- |Update the table increment size of an ATMST state.
withEnvTableIncr :: AtmstState -> Int -> AtmstState
withEnvTableIncr :: AtmstState -> Int -> AtmstState
withEnvTableIncr (AtmstState Int
ia Int
_) Int
ei = Int -> Int -> AtmstState
AtmstState Int
ia Int
ei

{- ===== ATMST definition. ============================================= -}

-- |The process of building and using a mutable ATMS.
type ATMSTInner s m a =
  Monad m => ExceptT AtmsErr (StateT AtmstState (STT s m)) a

-- |The process of building and using a mutable ATMS.
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 }

-- |Internal unwrapper preserving rank-2 polymorphism of the state
-- thread in the wrapper `STT`.
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 s m a -> (a -> ATMST s m b) -> ATMST s m b
  (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 s m a -> ATMST s m b -> ATMST s m b
  (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 -> 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

-- |Lift `STT` behavior to the `ATMST` level.
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

-- |Lift `ExceptT` behavior to the `ATMST` level.
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

-- |Lift `StateT` behavior to the `ATMST` level.
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

-- |Retrieve the current initial `Env` table size setting.
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

-- |Retrieve the current initial `Env` table size setting.
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)

-- |Retrieve the current initial `Env` table size setting.
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

-- |Retrieve the current initial `Env` table size setting.
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)

-- |Execute a computation in the `ATMST` monad transformer.
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 of type which can be used as the datum underlying `Node`s in
-- an `ATMS`.
class NodeDatum d where
  -- |The datum associated with the contradiction node in a
  -- newly-initialized `ATMS` with `Node` data of this type.
  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"

-- |Top-level representation of an assumption-based truth maintenance
-- system.
data (Monad m, NodeDatum d) => ATMS d i r s m = ATMS {
  -- |Name of this ATMS.
  ATMS d i r s m -> String
atmsTitle :: String,
  -- |Unique namer for nodes.
  ATMS d i r s m -> STRef s Int
atmsNodeCounter :: STRef s Int,
  -- |Unique namer for justifications.
  ATMS d i r s m -> STRef s Int
atmsJustCounter :: STRef s Int,
  -- |Unique namer for environments.
  ATMS d i r s m -> STRef s Int
atmsEnvCounter :: STRef s Int,
  -- |Current size of environment table.
  ATMS d i r s m -> STRef s Int
atmsEnvTableAlloc :: STRef s Int,
  -- |List of all TMS nodes.
  ATMS d i r s m -> STRef s [Node d i r s m]
atmsNodes :: STRef s [Node d i r s m],
  -- |List of all justifications.
  ATMS d i r s m -> STRef s [JustRule d i r s m]
atmsJusts :: STRef s [JustRule d i r s m],
  -- |List of all contradiction nodes.
  ATMS d i r s m -> STRef s [Node d i r s m]
atmsContradictions :: STRef s [Node d i r s m],
  -- |List of all assumption nodes.
  ATMS d i r s m -> STRef s [Node d i r s m]
atmsAssumptions :: STRef s [Node d i r s m],
  -- |The environment table.
  ATMS d i r s m -> STRef s (EnvTable d i r s m)
atmsEnvTable :: STRef s (EnvTable d i r s m),
  -- |The table of nogood environments.
  ATMS d i r s m -> STRef s (EnvTable d i r s m)
atmsNogoodTable :: STRef s (EnvTable d i r s m),
  -- |Canonical empty Env for this ATMS.  This value is not set more
  -- than once, but it created (by `createATMS`) after the ATMS is
  -- allocated, so we use a reference to be able to set it up later.
  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)),
  -- |Canonical contradiction `Node` for this ATMS.  This value is not
  -- set more than once, but it written (by `createATMS`) after the
  -- ATMS is allocated, so we use a reference to be able to set it up
  -- later.
  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)),
  -- |Function for formatting a `Node` of this ATMS.
  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),
  -- |Function for representing a justification rule.
  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),
  -- |Function for representing the data associated with `Node`s.
  ATMS d i r s m -> STRef s (d -> String)
atmsDatumString :: STRef s (d -> String),
  -- |Function for representing the informants of justifications.
  ATMS d i r s m -> STRef s (i -> String)
atmsInformantString :: STRef s (i -> String),
  -- |List of external procedures to be executed for this ATMS.
  ATMS d i r s m -> STRef s (r -> ATMST s m ())
atmsEnqueueProcedure :: STRef s (r -> ATMST s m ()),
  -- |Set to `True` when we wish to debug this ATMS.
  ATMS d i r s m -> STRef s Bool
atmsDebugging :: STRef s Bool
}

-- |Shortcut maker for reading from an `ATMS` reference.
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)
-- |Shortcut to write to an ATMS reference.
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

-- |Return the `ATMS`'s current `Node` list.
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

-- |Return the `ATMS`'s current `EnvTable`.
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

-- |Return the `ATMS`'s current `EnvTable` for nogood `Env`s.
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

-- |Return the `ATMS`'s current `JustRule` list.
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

-- |Return the `ATMS`'s current contradictions list.
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

-- |Return the `ATMS`'s current assumptions list.
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

-- |Return the `ATMS`'s built-in empty environment.
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

-- |Return the `ATMS`'s built-in contradiction node.
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

-- |Return the `ATMS`'s current `Node` formatter.
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
-- |Shortcut to write to the reference to a ATMS's `Node` formatter.
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

-- |Return the `ATMS`'s current `JustRule` formatter.
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
-- |Shortcut to write to the reference to a ATMS's `JustRule` formatter.
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

-- |Return the `ATMS`'s current datum formatter.
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
-- |Shortcut to write to the reference to a ATMS's datum formatter.
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

-- |When the data associated with `Node`s are all `String`s, we can
-- direct the `ATMS` to display each datum as itself.
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

-- |When the data associated with `Node`s are of a type of class
-- `Show`, we can direct the `ATMS` to display each datum using the
-- `show` instance.
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

-- |Return the `ATMS`'s current informant formatter.
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
-- |Shortcut to write to the reference to a ATMS's informant formatter.
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

-- |When the informants associated with `JustRule`s are all
-- `String`s, we can direct the `ATMS` to display each informant as
-- itself.
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

-- |When the informants associated with `JustRule`s are of a type of
-- class `Show`, we can direct the `ATMS` to display each datum using
-- the `show` instance.
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

-- |Return the `ATMS`'s current rule-queueing procedure.
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
-- |Shortcut to write to the reference to a ATMS's rule-queueing procedure.
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

-- |Print the internal title signifying an ATMS.
--
-- Translated from @print-atms@ in @atms.lisp@.
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
">"

-- |Get the next node counter value, incrementing for future accesses.
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

-- |Get the next justification rule counter value, incrementing for
-- future accesses.
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

-- |Get the next environment rule counter value, incrementing for
-- future accesses.
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

{- ----------------------------------------------------------------- -}

-- |Wrapper for the datum associated with a node of the `ATMS`.
--
-- Translated from @(tms-node@ in @atms.lisp@.
data (Monad m, NodeDatum d) => Node d i r s m = Node {
  Node d i r s m -> Int
nodeIndex :: Int,
  -- |Retrieve the datum associated with a `Node`.
  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],
  -- |Retrieve the `ATMS` associated with a `Node`.
  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
">"

-- |Shortcut maker for reading from a `Node` reference.
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)
-- |Shortcut to write to the reference to a node's label.
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

-- |Return the `Node`'s label.
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
-- |Shortcut to write to the reference to a node's label.
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

-- |Return the `Node`'s rules.
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
-- |Shortcut to write to the reference to a node's rules.
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

-- |Return the `JustRule`s concluding a `Node`.
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

-- |Return the `Node`'s consequences.
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
-- |Shortcut to write to the reference to a node's consequences.
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

-- |Return whether the `Node`'s is currently contradictory.
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)

-- |Set whether a `Node`'s is currently contradictory.
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

-- |Return whether the `Node`'s is currently markable as an assumption.
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)

-- |The justification of one `ATMS` `Node` by zero or more others.
data (Monad m, NodeDatum d) => JustRule d i r s m = JustRule {
  JustRule d i r s m -> Int
justIndex :: Int,
  -- |The informant associated with applying this inference rule.
  JustRule d i r s m -> i
justInformant :: i,
  -- |The conclusion of this inference rule.
  JustRule d i r s m -> Node d i r s m
justConsequence :: Node d i r s m,
  -- |The antecedents of this inference rule.
  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)

-- |Description of why a `Node` may be believed by the `ATMS`.
data Justification d i r s m =
  ByRule (JustRule d i r s m) | ByAssumption (Node d i r s m) | ByContradiction

-- |Explanation of why a `Node` may be believed by the `ATMS` for
-- output to a query.
data Explanation d i r s m =
  IsRule (JustRule d i r s m) | IsAssumption (Node d i r s m)

-- |Explanation of why a `Node` may be classified as no-good by the
-- `ATMS`.
data WhyNogood d i r s m =
  Good | ByJustification (Justification d i r s m) | ByEnv (Env d i r s m)

-- |Translation of the explanation of why a `Node` may be classified
-- (or not) as no-good to a boolean value.
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

{- ----------------------------------------------------------------- -}

-- |An environment of `Node`s which may be used as the basis of
-- reasoning in an `ATMS`.
data (Monad m, NodeDatum d) => Env d i r s m = Env {
  -- |The unique nomber of this `Env` within its `ATMS`.
  Env d i r s m -> Int
envIndex :: Int,
  -- |The number of assumptions contained within this `Env`.
  Env d i r s m -> Int
envCount :: Int,
  -- |The assumptions contained within this `Env`.
  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
">"

-- |Shortcut maker for reading from a `Env` reference.
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)
-- |Shortcut to write to the reference to a env's label.
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

-- |Shortcut for reading the `Node`s of an `Env`.
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
-- |Shortcut for writing the `Node`s of an `Env`.
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

-- |Shortcut for reading the rules of an `Env`.
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
-- |Shortcut for writing the rules of an `Env`.
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

-- |Shortcut for testing whether an `Env` is nogood.
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

-- |Type alias for the array storage of a table of `Env`s arranged by
-- length.
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

-- |Shortcut for retrieving the `Node` formatter from an `ATMS`, and
-- applying it to the given `Node`.
--
-- Translated from @node-string@ in @atms.lisp@.
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

-- |Default formatter for the `Node`s of an `ATMS`.
--
-- Translated from @default-node-string@ in @atms.lisp@.
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

-- |Insert an element into a sorted list.
--
-- Translated from @ordered-insert@ in @atms.lisp@.
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

{- Does not seem to be used
-- Translated from @ordered-push@ in @atms.lisp@.
--
-- > ;; In atms.lisp
-- > (defmacro ordered-push (item list test)
-- >   `(setq ,list (ordered-insert ,item ,list ,test)))
orderedPush :: a -> [a] -> (a -> a -> Bool) -> [a]
orderedPush = error "< unimplemented orderedPush >"
-}

-- |We order assumptions in `Env` lists by their index.
--
-- Translated from @assumption-order@ in @atms.lisp@.
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

-- Ordering predicate for two `Env`s; uses their internal index.
--
-- Translated from @env-order@ in @atms.lisp@.
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

{- ----------------------------------------------------------------- -}

-- * Basic inference engine interface.

-- |Create a new, empty ATMS.
--
-- Translated from @create-atms@ in @atms.lisp@.
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

{- ----------------------------------------------------------------- -}

-- |Returns `True` if the given `Node` is axiomatic, following from
-- the assumption of zero other nodes.
--
-- Translated from @true-node?@ in @atms.lisp@.
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

-- |Returns `True` if the given `Node` is justified by some labelling
-- `Env`ironment of `Node`s in the `ATMS`.
--
-- Translated from @in-node?@ in @atms.lisp@.
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)

-- |Returns `True` if the given `Node` is justified by some subset of
-- the given environment in the `ATMS`.
--
-- Translated from @in-node?@ in @atms.lisp@.
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

-- |Returns `True` if the given `Node` is justified by no labelling
-- `Env`ironment of `Node`s in the `ATMS`.
--
-- Translated from @out-node?@ in @atms.lisp@.
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

-- |Returns `True` if some environment justifying the given `Node` is
-- consistent with the given environment, where two environments are
-- consistent when their union is not no-good.
--
-- Translated from @node-consistent-with?@ in @atms.lisp@.
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

-- |Create a new `Node` in an `ATMS`.
--
-- Translated from @create-node@ in @atms.lisp@.
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

-- |Mark the given `Node` as to be believed as an assumption by its
-- `ATMS`.
--
-- Translated from @assume-node@ in @atms.lisp@.
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)

-- |Mark the given `Node` as an additional contradiction node of the
-- `ATMS`.
--
-- Translated from @make-contradiction@ in @atms.lisp@.
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

-- |Direct the `ATMS` to believe a particular `Node` when all of the
-- given list of `Node`s are also believed.  The first argument is the
-- informant associated with this inference.
--
-- Translated from @justify-node@ in @atms.lisp@.
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
  -- Retrieve the ATMS in which we are working
  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

  -- Number and create a new justification record.
  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

  -- Register the new justification with the node it can imply.
  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)

  -- Register the new justification with the nodes that can trigger
  -- it.
  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

  -- Register the new justification with the ATMS itself.
  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

  -- Introduce the new justification
  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

-- |Direct the `ATMS` to find the combination of all of the given
-- `Node`s to be a contradiction associated with the given informant.
--
-- Translated from @nogood-nodes@ in @atms.lisp@.
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

-- * Label updating

--
-- Translated from @propagate@ in @atms.lisp@.
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>"

--
-- Translated from @update@ in @atms.lisp@.
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

  -- If the consequence node is a contradiction, then all we need to
  -- do is mark all of the environments implying it as contradictory
  -- as well.
  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
$

    -- Otherwise we propagate further.  If this step prunes out all
    -- `Env`s from the `newEnvs`, then we have nothing further to do.
    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

         -- Process rules queued in the consequence.
         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

         -- Propagate to the justification rules which might depend on
         -- this node.  If ever the new Env list we are accumulating is
         -- paired down to the empty list, then we can exit these loops.
         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

-- |Internal method to update the label of this node to include the
-- given environments.  The inclusion is not simply list extension;
-- new environments subsumed by an existing label environment will be
-- omitted, and existing label environments subsumed by a new
-- environment will be removed.
--
-- Translated from @update-label@ in @atms.lisp@.
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 |])

  -- We will edit the label of this node, so we extract it as a
  -- mutable list, and replace it at the end of this function.
  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

  -- These two loops traverse respectively the given newEnvs, and the
  -- node label environments, to find pairs of environments where one
  -- of the pair is a subset of the other.
  (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 ()

  -- Strip all `Nothing`s from the `newEnvs`, and add the `node` to
  -- each environment's node list.
  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  -- [B]
      Maybe (Env d i r s m)
_ -> () -> ATMST s m ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()

  -- Un-lift the working version of the node label list, and write the
  -- update back to the node label list.
  $(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 "" |])

  -- debugNodeLabel node
  -- sttLayer $ writeSTRef (nodeLabel node) updatedLabel
  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
  -- debugNodeLabel node

  -- Return the Nothing-stripped version of the newEnvs parameter.
  $(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

-- |Update the label of node @antecedent@ to include the given @envs@
-- environments, pruning environments which are a superset of another
-- included enviroment.
--
-- Implements Algorithm 12.3 of /Building Problem Solvers/.
--
-- Translated from @weave@ in @atms.lisp@.
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 |])

      -- From loop to loop we update what's stored under envsRef, so
      -- we start this outer loop by reading what we start off with
      -- there.
      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

      -- We will update envs with the list built in newEnvs.
      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

      -- We look at all pairs of
      --  - An Env from the passed-in ENVS, plus
      --  - An Env from the NODE's label.
      -- The union of these two is NEW-ENV, and the body of the loop
      -- considers how we should incorporate NEW-ENV into NEW-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)
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 |])

              -- We are not interested in nogood environments, so we
              -- skip filing the union if it is nogood.
              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

                -- If NEW-ENV is a superset of (or is equal to)
                -- anything already in NEW-ENVS, then NEW-ENV is
                -- redundant, and we abort the body of the inner
                -- match-searching loop without adding NEW-ENV to
                -- NEW-ENVS.
                --
                -- Otherwise if anything already in NEW-ENVS is a
                -- superset of NEW-ENV, then (1) NEW-ENV makes that
                -- element redundant, and we strip it out of NEW-ENVS;
                -- and (2) we add NEW-ENV to NEW-ENVS.

                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 () -- Should not be possible
                    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 ()

                -- If we haven't found newEnv to be redundant, then
                -- add it to newEnvs.
                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 |])

      -- So we have nearly produced the refinement of ENVS for this
      -- NODE in the ANTECEDENTS.  It might have spurious NILs, so we
      -- strip those out and update envsRef.
      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

  -- Finally, return the last refinement of ENVS.
  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
""

-- Translated from @in-antecedent?@ in @atms.lisp@.
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

-- |Check whether any union of antecedent environments is consistent.
--
-- Translated from @weave?@ in @atms.lisp@.
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)

-- |Returns `True` if the `Env`ironment argument supports all of the
-- given `Node`s.
--
-- Translated from @supporting-antecedent?@ in @atms.lisp@.
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

-- |Remove a `Node` from the `ATMS`.
--
-- Translated from @remove-node@ in @atms.lisp@.
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

-- * Creating and extending environments.

-- |Create and return a new `Env` for the given assumptions.  Note
-- that this function does not sort or otherwise organize
-- @assumptions@, and it only called with an empty or singleton list.
-- Instead, it is `consEnv` which inserts nodes in order when one
-- environement is defined in terms of another.
--
-- Translated from @create-env@ in @atms.lisp@.
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
""

-- Translated from @union-env@ in @atms.lisp@.
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
""


-- |Derive an environment from the addition of one additional
-- assumption to a previous `Env`'s assumption list.
--
-- Translated from @cons-env@ in @atms.lisp@.
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
""

-- |Return the `Env`ironment containing the given list of `Node`s,
-- creating one if necessary.
--
-- Translated from @find-or-make-env@ in @atms.lisp@.
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

-- * Env tables.

-- Translated from @insert-in-table@ in @atms.lisp@.
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

  -- Re-allocate the array if it needs to grow, and update the
  -- reference.
  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

  -- Add the env to its slot in the table.
  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

-- Translated from @lookup-env@ in @atms.lisp@.
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

-- Translated from @subset-env?@ in @atms.lisp@.
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)

-- |The possible results of comparing two `Env`s.
data EnvCompare =
  EQenv     -- ^ Two `Env`s are the same
  | S12env  -- ^ The first `Env` is a subset of the second.
  | S21env  -- ^ The second `Env` is a subset of the first.
  | DisjEnv -- ^ Two `Env`s are disjoint.

-- Translated from @compare-env@ in @atms.lisp@.
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

-- |Return true if the first sorted (by `Env` index) node list is a
-- subset of the second.
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
-- * Processing nogoods

-- Translated from @new-nogood@ in @atms.lisp@.
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 |])

  -- Record in `cenv` the reason why `cenv` is nogood.
  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)

  -- `cenv` can no longer be used in node labels, so remove it from
  -- any node labels in which it appears, and propagate out any
  -- changes.
  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

  -- Add `cenv` to the ATMS table of nogoods.
  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

  -- Remove any nogood table entries made redundant by `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

  -- Find currently-non-nogood environments which are supersets of the
  -- nogood, and process them as nogoods.
  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)


-- Translated from @set-env-contradictory@ in @atms.lisp@.
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"

-- Translated from @remove-env-from-labels@ in @atms.lisp@.
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
  -- Run all rules associated with `env`, and clear the list of
  -- associated rules.
  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 []

  -- Remove `env` from the label of the nodes currently including it.
  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

-- * Interpretation construction

-- |Return the minimum environments which give the `ATMS` belief in
-- the given choice sets.  The choice sets are essentially
-- conjunctive-normal form expressions; in the list of sublists of
-- nodes, under each environment in the result at least one node of
-- each sublist will be believed.
--
-- TO BE TRANSLATED from @interpretations@ in @atms.lisp@.
--
-- > ;; In atms.lisp
-- > (proclaim '(special *solutions*))
-- > (defun interpretations (atms choice-sets &optional defaults
-- >                    &aux solutions)
-- >   (if (atms-debugging atms)
-- >    (format *trace-output*
-- >       "~%Constructing interpretations depth-first for ~a:" choice-sets))
-- >   (format *trace-output* "~%- Refining choice sets")
-- >   (let ((*solutions* nil)
-- >    (choice-sets
-- >      (mapcar #'(lambda (alt-set)
-- >                  (format *trace-output*
-- >                      "~%  - ~a --> ???" alt-set)
-- >                  (let ((result
-- >                         (mapcan #'(lambda (alt)
-- >                                     (format *trace-output*
-- >                                         "~%    - ~a --> ~a"
-- >                                         alt (tms-node-label alt))
-- >                                     (copy-list (tms-node-label alt)))
-- >                                 alt-set)))
-- >                    (format *trace-output*
-- >                        "~%    ~a --> ~a" alt-set result)
-- >                    result))
-- >              choice-sets)))
-- >     (format *trace-output* "~%  Refined choice sets to ~a" choice-sets)
-- >     (dolist (choice (car choice-sets))
-- >       (format *trace-output*
-- >      "~%- Calling depth-solutions with choice ~a" choice)
-- >       (format *trace-output*
-- >      "~%                               choice sets ~a" (car choice-sets))
-- >       (get-depth-solutions1 choice (cdr choice-sets))
-- >       (format *trace-output*
-- >      "~%      => solutions ~a" *solutions*))
-- >     (setq *solutions* (delete nil *solutions* :TEST #'eq))
-- >     (unless *solutions*
-- >       (if choice-sets (return-from interpretations nil)
-- >                  (setq *solutions* (list (atms-empty-env atms)))))
-- >     (when defaults
-- >       (setq solutions *solutions* *solutions* nil)
-- >       (dolist (solution solutions)
-- >    (extend-via-defaults solution defaults defaults)))
-- >     (delete nil *solutions* :TEST #'eq)))
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 >"

-- |TO BE TRANSLATED from @get-depth-solutions1@ in @atms.lisp@.
--
-- > ;; In atms.lisp
-- > (defun get-depth-solutions1 (solution choice-sets
-- >                                  &aux new-solution)
-- >   (cond ((null choice-sets)
-- >     (unless (do ((old-solutions *solutions* (cdr old-solutions)))
-- >                 ((null old-solutions))
-- >               (when (car old-solutions)
-- >                 (case (compare-env (car old-solutions) solution)
-- >                   ((:EQ :S12) (return t))
-- >                   (:S21 (rplaca old-solutions nil)))))
-- >       (push solution *solutions*)))
-- >    ((env-nogood? solution)) ;something died.
-- >    (t (dolist (choice (car choice-sets))
-- >         (setq new-solution (union-env solution choice))
-- >         (unless (env-nogood? new-solution)
-- >           (get-depth-solutions1 new-solution
-- >                                 (cdr choice-sets)))))))
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 >"

-- |TO BE TRANSLATED from @extend-via-defaults@ in @atms.lisp@.
--
-- > ;; In atms.lisp
-- > (defun extend-via-defaults (solution remaining original)
-- >   (do ((new-solution)
-- >        (defaults remaining (cdr defaults)))
-- >       ((null defaults)
-- >        (or (member solution *solutions* :TEST #'eq)
-- >       (dolist (default original)
-- >         (or (member default (env-assumptions solution)
-- >                     :TEST #'eq)
-- >             (env-nogood? (cons-env default solution))
-- >             (return t)))
-- >       (push solution *solutions*)))
-- >     (setq new-solution (cons-env (car defaults) solution))
-- >     (unless (env-nogood? new-solution)
-- >       (extend-via-defaults new-solution (cdr defaults) original))))
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 >"

-- * Generating explanations

-- |This function returns a list of justifications which form a
-- directed acyclic graph (DAG) for the derivation. This is quite
-- complicated because this is really a simple consequent JTMS.
--
-- Translated from @explain-node@ in @atms.lisp@.
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 [] []

-- Translated from @explain-node-1@ in @atms.lisp@.
--
-- > ;; In atms.lisp
-- > (defun explain-node-1 (env node queued-nodes explanation)
-- >   (cond ((member node queued-nodes) nil)
-- >    ((and (tms-node-assumption? node)
-- >          (member node (env-assumptions env)))
-- >     (cons (cons 'ASSUME node) explanation))
-- >    ((dolist (just explanation)
-- >       (if (if (listp just)
-- >               (eq (cdr just) node) (eq (just-consequence just) node))
-- >           (return explanation))))
-- >    (t (setq queued-nodes (cons node queued-nodes))
-- >       (dolist (just (tms-node-justs node))
-- >         (unless (dolist (a (just-antecedents just))
-- >                   (unless (in-node? a env) (return t)))
-- >          (let ((new-explanation explanation))
-- >            (dolist (a (just-antecedents just)
-- >                       (return-from explain-node-1
-- >                         (cons just new-explanation)))
-- >              (setq new-explanation
-- >                    (explain-node-1 env a queued-nodes new-explanation))
-- >              (unless new-explanation (return nil)))))))))
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 >"

-- |Print the justifying `Env`ironments which label a `Node`.
--
-- Translated from @why-node@ in @atms.lisp@.
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
">"

-- |Print the justifying `Env`ironments which label each `Node` of an
-- `ATMS`.
--
-- Translated from @why-nodes@ in @atms.lisp@.
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

-- |Print a `Node`'s justifications.
--
-- TO BE TRANSLATED from @node-justifications@ in @atms.lisp@.
--
-- > ;; In atms.lisp
-- > (defun node-justifications (node &optional (stream t))
-- >   (format t "~% For ~A:" (node-string node))
-- >   (dolist (j (tms-node-justs node))
-- >     (print-justification j stream)))
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

-- |Retrieve an `ATMS`'s `Env`ironment with the given index number.
--
-- Translated from @e@ in @atms.lisp@.
--
-- > ;; In atms.lisp
-- > (defun e (atms n)
-- >   (dolist (bucket (atms-env-table atms))
-- >     (dolist (env (cdr bucket))
-- >     (if (= (env-index env) n) (return-from e env)))))
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

-- |Print an environment.
--
-- Translated from @print-env@ in @atms.lisp@.
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
""

-- |Convert an `Env`ironment into a string listing the nodes of the
-- environment.
--
-- Translated from @env-string@ in @atms.lisp@.
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)

-- * Printing global data

-- |List the nogood `Env`ironments of an `ATMS`.
--
-- Translated from @print-nogoods@ in @atms.lisp@.
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

-- |Print the `Env`ironments of an `ATMS`.
--
-- Translated from @print-envs@ in @atms.lisp@.
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

-- |Print the `Env`ironments contained in the given `EnvTable`.
--
-- Translated from @print-env-table@ in @atms.lisp@.
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

-- |Print statistics about an `ATMS`.
--
-- Translated from @print-atms-statistics@ in @atms.lisp@.
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

-- |Print the entries of an `EnvTable`.
--
-- Translated from @print-table@ in @atms.lisp@.
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

-- |Give a verbose printout of an `ATMS`.
--
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
"=============== "

-- |Give a verbose printout of the `Node`s of an `ATMS`.
--
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

-- |Computation returning a one-line summary of one `Node` of an `ATMS`.
--
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)

-- |Computation returning a one-line summary of the `Node`s of an
-- `ATMS`.
--
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

-- |Computation returning a one-line summary of a list of lists of
-- `Node`s of an `ATMS`.
--
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
","

-- |Computation returning a one-line summary of the label of a `Node`
-- of an `ATMS`.
--
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

-- |Print a short summary of a `Node` of an `ATMS`.
--
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

-- |Print a verbose summary of a `Node` of an `ATMS`.
--
-- Translated from @print-tms-node@ in @atms.lisp@.
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
">"

-- |Give a verbose printout of a `Node` of an `ATMS`.
--
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
""

-- |Computation returning a one-line summary of the reason an `ATMS`
-- may believe a `Node`.
--
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"


-- |Give a verbose printout of the `Just`ification rules of an
-- `ATMS`.
--
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

-- |Computation returning a one-line summary of the informant of a
-- `Just`ification rule of an `ATMS`.
--
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

-- |Print a more verbose description of a `Just`ification rule of an
-- `ATMS`.
--
-- Translated from @print-just@ in @atms.lisp@.
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
">"

-- |Print a more verbose description of the `Justification`.
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"

-- |Give a verbose printout of one `Just`ification rule of an `ATMS`.
--
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)

-- |Give a verbose printout of the `Env`ironments of an `ATMS`.
--
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

-- |Give a verbose printout of one `Env`ironment of an `ATMS`.
--
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
")"

-- |Print a short summary of a mutable list of nullable (via `Maybe`)
-- `Env`ironments from an `ATMS`.
--
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
"]"

-- |Print a short summary of a reference to a mutable list of
-- nullable (via `Maybe`) `Env`ironments from an `ATMS`.
--
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

-- |Print a short summary of a nullable (via `Maybe`) reference to an
-- `Env`ironment of an `ATMS`.
--
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>"

-- |Print a short summary of one `Env`ironment of an `ATMS`.
--
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
"}"

-- |Give a verbose printout of the no-good `Env`ironments of an
-- `ATMS`.
--
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

-- |Give a verbose printout of the `Env`ironments of an `EnvTable` of
-- an `ATMS`.
--
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

{-
-- |Print a short summary of the label of a `Node` of an `ATMS`.
--
blurbNodeLabel ::
  (MonadIO m, NodeDatum d) => Node d i r s m -> ATMST s m String
blurbNodeLabel node = do
  -- lbl <- getNodeLabel node
  lbl <- sttLayer $ readSTRef (nodeLabel node)
  blurbNode node
  liftIO $ putStr " label: "
  blurbEnvList 10000 "\n" lbl
  liftIO $ putStrLn ""
-}

-- |Give a verbose printout of the label of a `Node` of an `ATMS`.
--
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
  -- lbl <- getNodeLabel node
  [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
""

-- |Print a short summary of a list of `Env`ironments of an `ATMS`.
--
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