{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE OverloadedStrings #-}

module Language.Bitcoin.Miniscript.Witness (
    satisfy,
    SatisfactionContext,
    satisfactionContext,
    signature,
    preimage,
    lookupSignature,
    lookupPreimage,
    ChainState (..),
    emptyChainState,
    Signature (..),
    SatisfactionError (..),
) where

import Control.Exception (Exception)
import Control.Monad.Trans.Reader (
    Reader,
    asks,
    local,
    runReader,
 )
import Data.Bifunctor (first)
import Data.ByteString (ByteString)
import qualified Data.ByteString as BS
import Data.Either (rights)
import Data.Function (on)
import Data.List (foldl')
import Data.Map.Strict (Map)
import qualified Data.Map.Strict as Map
import Data.Maybe (catMaybes, mapMaybe)
import Data.Serialize (encode)
import Data.Text (Text)
import Haskoin.Crypto (Sig)
import Haskoin.Keys (
    PubKeyI (..),
    exportPubKey,
 )
import Haskoin.Script (
    Script (..),
    ScriptOp (..),
    SigHash,
    TxSignature (..),
    encodeTxSig,
    opPushData,
 )

import Language.Bitcoin.Miniscript.Syntax (
    Miniscript (..),
    Value (..),
 )
import Language.Bitcoin.Script.Descriptors.Syntax (
    KeyDescriptor,
    keyDescPubKey,
 )

data Signature = Signature
    { Signature -> Sig
sig :: !Sig
    , Signature -> SigHash
sigHash :: !SigHash
    }
    deriving (Signature -> Signature -> Bool
(Signature -> Signature -> Bool)
-> (Signature -> Signature -> Bool) -> Eq Signature
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Signature -> Signature -> Bool
$c/= :: Signature -> Signature -> Bool
== :: Signature -> Signature -> Bool
$c== :: Signature -> Signature -> Bool
Eq, Int -> Signature -> ShowS
[Signature] -> ShowS
Signature -> String
(Int -> Signature -> ShowS)
-> (Signature -> String)
-> ([Signature] -> ShowS)
-> Show Signature
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Signature] -> ShowS
$cshowList :: [Signature] -> ShowS
show :: Signature -> String
$cshow :: Signature -> String
showsPrec :: Int -> Signature -> ShowS
$cshowsPrec :: Int -> Signature -> ShowS
Show)

newtype OrdPubKeyI = OrdPubKeyI {OrdPubKeyI -> PubKeyI
unOrdPubKeyI :: PubKeyI}
    deriving (OrdPubKeyI -> OrdPubKeyI -> Bool
(OrdPubKeyI -> OrdPubKeyI -> Bool)
-> (OrdPubKeyI -> OrdPubKeyI -> Bool) -> Eq OrdPubKeyI
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: OrdPubKeyI -> OrdPubKeyI -> Bool
$c/= :: OrdPubKeyI -> OrdPubKeyI -> Bool
== :: OrdPubKeyI -> OrdPubKeyI -> Bool
$c== :: OrdPubKeyI -> OrdPubKeyI -> Bool
Eq, Int -> OrdPubKeyI -> ShowS
[OrdPubKeyI] -> ShowS
OrdPubKeyI -> String
(Int -> OrdPubKeyI -> ShowS)
-> (OrdPubKeyI -> String)
-> ([OrdPubKeyI] -> ShowS)
-> Show OrdPubKeyI
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [OrdPubKeyI] -> ShowS
$cshowList :: [OrdPubKeyI] -> ShowS
show :: OrdPubKeyI -> String
$cshow :: OrdPubKeyI -> String
showsPrec :: Int -> OrdPubKeyI -> ShowS
$cshowsPrec :: Int -> OrdPubKeyI -> ShowS
Show)

instance Ord OrdPubKeyI where
    compare :: OrdPubKeyI -> OrdPubKeyI -> Ordering
compare = ByteString -> ByteString -> Ordering
forall a. Ord a => a -> a -> Ordering
compare (ByteString -> ByteString -> Ordering)
-> (OrdPubKeyI -> ByteString)
-> OrdPubKeyI
-> OrdPubKeyI
-> Ordering
forall b c a. (b -> b -> c) -> (a -> b) -> a -> a -> c
`on` PubKeyI -> ByteString
toOrdered (PubKeyI -> ByteString)
-> (OrdPubKeyI -> PubKeyI) -> OrdPubKeyI -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. OrdPubKeyI -> PubKeyI
unOrdPubKeyI
      where
        toOrdered :: PubKeyI -> ByteString
toOrdered (PubKeyI PubKey
pk Bool
c) = Bool -> PubKey -> ByteString
exportPubKey Bool
c PubKey
pk

data SatisfactionContext = SatisfactionContext
    { SatisfactionContext -> Map OrdPubKeyI Signature
signatures :: Map OrdPubKeyI Signature
    , SatisfactionContext -> Map ByteString ByteString
hashPreimages :: Map ByteString ByteString
    }
    deriving (SatisfactionContext -> SatisfactionContext -> Bool
(SatisfactionContext -> SatisfactionContext -> Bool)
-> (SatisfactionContext -> SatisfactionContext -> Bool)
-> Eq SatisfactionContext
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: SatisfactionContext -> SatisfactionContext -> Bool
$c/= :: SatisfactionContext -> SatisfactionContext -> Bool
== :: SatisfactionContext -> SatisfactionContext -> Bool
$c== :: SatisfactionContext -> SatisfactionContext -> Bool
Eq, Int -> SatisfactionContext -> ShowS
[SatisfactionContext] -> ShowS
SatisfactionContext -> String
(Int -> SatisfactionContext -> ShowS)
-> (SatisfactionContext -> String)
-> ([SatisfactionContext] -> ShowS)
-> Show SatisfactionContext
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [SatisfactionContext] -> ShowS
$cshowList :: [SatisfactionContext] -> ShowS
show :: SatisfactionContext -> String
$cshow :: SatisfactionContext -> String
showsPrec :: Int -> SatisfactionContext -> ShowS
$cshowsPrec :: Int -> SatisfactionContext -> ShowS
Show)

instance Semigroup SatisfactionContext where
    SatisfactionContext
icA <> :: SatisfactionContext -> SatisfactionContext -> SatisfactionContext
<> SatisfactionContext
icB =
        SatisfactionContext :: Map OrdPubKeyI Signature
-> Map ByteString ByteString -> SatisfactionContext
SatisfactionContext
            { signatures :: Map OrdPubKeyI Signature
signatures = SatisfactionContext -> Map OrdPubKeyI Signature
signatures SatisfactionContext
icA Map OrdPubKeyI Signature
-> Map OrdPubKeyI Signature -> Map OrdPubKeyI Signature
forall a. Semigroup a => a -> a -> a
<> SatisfactionContext -> Map OrdPubKeyI Signature
signatures SatisfactionContext
icB
            , hashPreimages :: Map ByteString ByteString
hashPreimages = SatisfactionContext -> Map ByteString ByteString
hashPreimages SatisfactionContext
icA Map ByteString ByteString
-> Map ByteString ByteString -> Map ByteString ByteString
forall a. Semigroup a => a -> a -> a
<> SatisfactionContext -> Map ByteString ByteString
hashPreimages SatisfactionContext
icB
            }

instance Monoid SatisfactionContext where
    mempty :: SatisfactionContext
mempty = Map OrdPubKeyI Signature
-> Map ByteString ByteString -> SatisfactionContext
SatisfactionContext Map OrdPubKeyI Signature
forall a. Monoid a => a
mempty Map ByteString ByteString
forall a. Monoid a => a
mempty

-- | Use with the monoid instance to add a signature to the 'SatisfactionContext'
signature :: PubKeyI -> Signature -> SatisfactionContext
signature :: PubKeyI -> Signature -> SatisfactionContext
signature PubKeyI
pk = (Map OrdPubKeyI Signature
-> Map ByteString ByteString -> SatisfactionContext
`SatisfactionContext` Map ByteString ByteString
forall a. Monoid a => a
mempty) (Map OrdPubKeyI Signature -> SatisfactionContext)
-> (Signature -> Map OrdPubKeyI Signature)
-> Signature
-> SatisfactionContext
forall b c a. (b -> c) -> (a -> b) -> a -> c
. OrdPubKeyI -> Signature -> Map OrdPubKeyI Signature
forall k a. k -> a -> Map k a
Map.singleton (PubKeyI -> OrdPubKeyI
OrdPubKeyI PubKeyI
pk)

-- | Use with the monoid instance to add preimage to the 'SatisfactionContext'
preimage ::
    -- | hash
    ByteString ->
    -- | preimage
    ByteString ->
    SatisfactionContext
preimage :: ByteString -> ByteString -> SatisfactionContext
preimage ByteString
h = Map OrdPubKeyI Signature
-> Map ByteString ByteString -> SatisfactionContext
SatisfactionContext Map OrdPubKeyI Signature
forall a. Monoid a => a
mempty (Map ByteString ByteString -> SatisfactionContext)
-> (ByteString -> Map ByteString ByteString)
-> ByteString
-> SatisfactionContext
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> ByteString -> Map ByteString ByteString
forall k a. k -> a -> Map k a
Map.singleton ByteString
h

satisfactionContext :: [(ByteString, ByteString)] -> [(PubKeyI, Signature)] -> SatisfactionContext
satisfactionContext :: [(ByteString, ByteString)]
-> [(PubKeyI, Signature)] -> SatisfactionContext
satisfactionContext [(ByteString, ByteString)]
preimages [(PubKeyI, Signature)]
sigs =
    SatisfactionContext :: Map OrdPubKeyI Signature
-> Map ByteString ByteString -> SatisfactionContext
SatisfactionContext
        { signatures :: Map OrdPubKeyI Signature
signatures = [(OrdPubKeyI, Signature)] -> Map OrdPubKeyI Signature
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList ([(OrdPubKeyI, Signature)] -> Map OrdPubKeyI Signature)
-> [(OrdPubKeyI, Signature)] -> Map OrdPubKeyI Signature
forall a b. (a -> b) -> a -> b
$ (PubKeyI -> OrdPubKeyI)
-> (PubKeyI, Signature) -> (OrdPubKeyI, Signature)
forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first PubKeyI -> OrdPubKeyI
OrdPubKeyI ((PubKeyI, Signature) -> (OrdPubKeyI, Signature))
-> [(PubKeyI, Signature)] -> [(OrdPubKeyI, Signature)]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [(PubKeyI, Signature)]
sigs
        , hashPreimages :: Map ByteString ByteString
hashPreimages = [(ByteString, ByteString)] -> Map ByteString ByteString
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList [(ByteString, ByteString)]
preimages
        }

lookupSignature :: PubKeyI -> SatisfactionContext -> Maybe Signature
lookupSignature :: PubKeyI -> SatisfactionContext -> Maybe Signature
lookupSignature PubKeyI
pk = OrdPubKeyI -> Map OrdPubKeyI Signature -> Maybe Signature
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup (PubKeyI -> OrdPubKeyI
OrdPubKeyI PubKeyI
pk) (Map OrdPubKeyI Signature -> Maybe Signature)
-> (SatisfactionContext -> Map OrdPubKeyI Signature)
-> SatisfactionContext
-> Maybe Signature
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SatisfactionContext -> Map OrdPubKeyI Signature
signatures

lookupPreimage :: ByteString -> SatisfactionContext -> Maybe ByteString
lookupPreimage :: ByteString -> SatisfactionContext -> Maybe ByteString
lookupPreimage ByteString
h = ByteString -> Map ByteString ByteString -> Maybe ByteString
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup ByteString
h (Map ByteString ByteString -> Maybe ByteString)
-> (SatisfactionContext -> Map ByteString ByteString)
-> SatisfactionContext
-> Maybe ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SatisfactionContext -> Map ByteString ByteString
hashPreimages

data ChainState = ChainState
    { ChainState -> Maybe Int
blockHeight :: Maybe Int
    , ChainState -> Maybe Int
utxoAge :: Maybe Int
    }
    deriving (ChainState -> ChainState -> Bool
(ChainState -> ChainState -> Bool)
-> (ChainState -> ChainState -> Bool) -> Eq ChainState
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: ChainState -> ChainState -> Bool
$c/= :: ChainState -> ChainState -> Bool
== :: ChainState -> ChainState -> Bool
$c== :: ChainState -> ChainState -> Bool
Eq, Int -> ChainState -> ShowS
[ChainState] -> ShowS
ChainState -> String
(Int -> ChainState -> ShowS)
-> (ChainState -> String)
-> ([ChainState] -> ShowS)
-> Show ChainState
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [ChainState] -> ShowS
$cshowList :: [ChainState] -> ShowS
show :: ChainState -> String
$cshow :: ChainState -> String
showsPrec :: Int -> ChainState -> ShowS
$cshowsPrec :: Int -> ChainState -> ShowS
Show)

emptyChainState :: ChainState
emptyChainState :: ChainState
emptyChainState = Maybe Int -> Maybe Int -> ChainState
ChainState Maybe Int
forall a. Maybe a
Nothing Maybe Int
forall a. Maybe a
Nothing

data SatisfactionError
    = MissingSignature [KeyDescriptor]
    | MissingPreimage ByteString
    | FreeVariable Text
    | TypeError Text Miniscript
    | Impossible
    | AbstractKey KeyDescriptor
    deriving (SatisfactionError -> SatisfactionError -> Bool
(SatisfactionError -> SatisfactionError -> Bool)
-> (SatisfactionError -> SatisfactionError -> Bool)
-> Eq SatisfactionError
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: SatisfactionError -> SatisfactionError -> Bool
$c/= :: SatisfactionError -> SatisfactionError -> Bool
== :: SatisfactionError -> SatisfactionError -> Bool
$c== :: SatisfactionError -> SatisfactionError -> Bool
Eq, Int -> SatisfactionError -> ShowS
[SatisfactionError] -> ShowS
SatisfactionError -> String
(Int -> SatisfactionError -> ShowS)
-> (SatisfactionError -> String)
-> ([SatisfactionError] -> ShowS)
-> Show SatisfactionError
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [SatisfactionError] -> ShowS
$cshowList :: [SatisfactionError] -> ShowS
show :: SatisfactionError -> String
$cshow :: SatisfactionError -> String
showsPrec :: Int -> SatisfactionError -> ShowS
$cshowsPrec :: Int -> SatisfactionError -> ShowS
Show)

instance Exception SatisfactionError

data SatScript = SatScript
    { SatScript -> Int
satWeight :: Int
    , SatScript -> [ScriptOp]
satScript :: [ScriptOp]
    }
    deriving (SatScript -> SatScript -> Bool
(SatScript -> SatScript -> Bool)
-> (SatScript -> SatScript -> Bool) -> Eq SatScript
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: SatScript -> SatScript -> Bool
$c/= :: SatScript -> SatScript -> Bool
== :: SatScript -> SatScript -> Bool
$c== :: SatScript -> SatScript -> Bool
Eq, Int -> SatScript -> ShowS
[SatScript] -> ShowS
SatScript -> String
(Int -> SatScript -> ShowS)
-> (SatScript -> String)
-> ([SatScript] -> ShowS)
-> Show SatScript
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [SatScript] -> ShowS
$cshowList :: [SatScript] -> ShowS
show :: SatScript -> String
$cshow :: SatScript -> String
showsPrec :: Int -> SatScript -> ShowS
$cshowsPrec :: Int -> SatScript -> ShowS
Show)

instance Semigroup SatScript where
    SatScript Int
n0 [ScriptOp]
s0 <> :: SatScript -> SatScript -> SatScript
<> SatScript Int
n1 [ScriptOp]
s1 = Int -> [ScriptOp] -> SatScript
SatScript (Int
n0 Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
n1) ([ScriptOp]
s0 [ScriptOp] -> [ScriptOp] -> [ScriptOp]
forall a. Semigroup a => a -> a -> a
<> [ScriptOp]
s1)

instance Monoid SatScript where
    mempty :: SatScript
mempty = Int -> [ScriptOp] -> SatScript
SatScript Int
0 [ScriptOp]
forall a. Monoid a => a
mempty

fromScript :: [ScriptOp] -> SatScript
fromScript :: [ScriptOp] -> SatScript
fromScript [ScriptOp]
s = Int -> [ScriptOp] -> SatScript
SatScript (ByteString -> Int
BS.length (ByteString -> Int) -> ByteString -> Int
forall a b. (a -> b) -> a -> b
$ [ScriptOp] -> ByteString
forall a. Serialize a => a -> ByteString
encode [ScriptOp]
s) [ScriptOp]
s

data SatResult = SatResult
    { SatResult -> Either SatisfactionError SatScript
sat :: Either SatisfactionError SatScript
    , SatResult -> Either SatisfactionError SatScript
dsat :: Either SatisfactionError SatScript
    }
    deriving (SatResult -> SatResult -> Bool
(SatResult -> SatResult -> Bool)
-> (SatResult -> SatResult -> Bool) -> Eq SatResult
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: SatResult -> SatResult -> Bool
$c/= :: SatResult -> SatResult -> Bool
== :: SatResult -> SatResult -> Bool
$c== :: SatResult -> SatResult -> Bool
Eq, Int -> SatResult -> ShowS
[SatResult] -> ShowS
SatResult -> String
(Int -> SatResult -> ShowS)
-> (SatResult -> String)
-> ([SatResult] -> ShowS)
-> Show SatResult
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [SatResult] -> ShowS
$cshowList :: [SatResult] -> ShowS
show :: SatResult -> String
$cshow :: SatResult -> String
showsPrec :: Int -> SatResult -> ShowS
$cshowsPrec :: Int -> SatResult -> ShowS
Show)

-- | Compute a scriptinput which satisfies this miniscript
satisfy :: ChainState -> SatisfactionContext -> Miniscript -> Either SatisfactionError Script
satisfy :: ChainState
-> SatisfactionContext
-> Miniscript
-> Either SatisfactionError Script
satisfy ChainState
chainState SatisfactionContext
sc = (SatScript -> Script)
-> Either SatisfactionError SatScript
-> Either SatisfactionError Script
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ([ScriptOp] -> Script
Script ([ScriptOp] -> Script)
-> (SatScript -> [ScriptOp]) -> SatScript -> Script
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SatScript -> [ScriptOp]
satScript) (Either SatisfactionError SatScript
 -> Either SatisfactionError Script)
-> (Miniscript -> Either SatisfactionError SatScript)
-> Miniscript
-> Either SatisfactionError Script
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SatResult -> Either SatisfactionError SatScript
sat (SatResult -> Either SatisfactionError SatScript)
-> (Miniscript -> SatResult)
-> Miniscript
-> Either SatisfactionError SatScript
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Reader (Map Text Miniscript) SatResult
-> Map Text Miniscript -> SatResult
forall r a. Reader r a -> r -> a
`runReader` Map Text Miniscript
forall a. Monoid a => a
mempty) (Reader (Map Text Miniscript) SatResult -> SatResult)
-> (Miniscript -> Reader (Map Text Miniscript) SatResult)
-> Miniscript
-> SatResult
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ChainState
-> SatisfactionContext
-> Miniscript
-> Reader (Map Text Miniscript) SatResult
satisfy' ChainState
chainState SatisfactionContext
sc

satisfy' :: ChainState -> SatisfactionContext -> Miniscript -> Reader (Map Text Miniscript) SatResult
satisfy' :: ChainState
-> SatisfactionContext
-> Miniscript
-> Reader (Map Text Miniscript) SatResult
satisfy' ChainState
chainState SatisfactionContext
sc = \case
    Boolean Bool
False ->
        SatResult -> Reader (Map Text Miniscript) SatResult
forall (m :: * -> *) a. Monad m => a -> m a
return
            SatResult :: Either SatisfactionError SatScript
-> Either SatisfactionError SatScript -> SatResult
SatResult
                { sat :: Either SatisfactionError SatScript
sat = SatisfactionError -> Either SatisfactionError SatScript
forall a b. a -> Either a b
Left SatisfactionError
Impossible
                , dsat :: Either SatisfactionError SatScript
dsat = SatScript -> Either SatisfactionError SatScript
forall a b. b -> Either a b
Right SatScript
forall a. Monoid a => a
mempty
                }
    Boolean Bool
True ->
        SatResult -> Reader (Map Text Miniscript) SatResult
forall (m :: * -> *) a. Monad m => a -> m a
return
            SatResult :: Either SatisfactionError SatScript
-> Either SatisfactionError SatScript -> SatResult
SatResult
                { sat :: Either SatisfactionError SatScript
sat = SatScript -> Either SatisfactionError SatScript
forall a b. b -> Either a b
Right SatScript
forall a. Monoid a => a
mempty
                , dsat :: Either SatisfactionError SatScript
dsat = SatisfactionError -> Either SatisfactionError SatScript
forall a b. a -> Either a b
Left SatisfactionError
Impossible
                }
    Key Value KeyDescriptor
vk -> (Miniscript -> Either SatisfactionError KeyDescriptor)
-> (KeyDescriptor -> Reader (Map Text Miniscript) SatResult)
-> Value KeyDescriptor
-> Reader (Map Text Miniscript) SatResult
forall a.
(Miniscript -> Either SatisfactionError a)
-> (a -> Reader (Map Text Miniscript) SatResult)
-> Value a
-> Reader (Map Text Miniscript) SatResult
withLiteral Miniscript -> Either SatisfactionError KeyDescriptor
guardKey KeyDescriptor -> Reader (Map Text Miniscript) SatResult
forall (m :: * -> *). Monad m => KeyDescriptor -> m SatResult
satisfyKey Value KeyDescriptor
vk
      where
        satisfyKey :: KeyDescriptor -> m SatResult
satisfyKey KeyDescriptor
k
            | Just PubKeyI
pk <- KeyDescriptor -> Maybe PubKeyI
keyDescPubKey KeyDescriptor
k
              , Just Signature
s <- PubKeyI -> SatisfactionContext -> Maybe Signature
lookupSignature PubKeyI
pk SatisfactionContext
sc =
                SatScript -> SatScript -> m SatResult
forall (m :: * -> *).
Monad m =>
SatScript -> SatScript -> m SatResult
satVals ([ScriptOp] -> SatScript
fromScript [Signature -> ScriptOp
pushSig Signature
s]) (Int -> [ScriptOp] -> SatScript
SatScript Int
1 [ScriptOp
OP_0])
            | Bool
otherwise =
                SatResult -> m SatResult
forall (m :: * -> *) a. Monad m => a -> m a
return
                    SatResult :: Either SatisfactionError SatScript
-> Either SatisfactionError SatScript -> SatResult
SatResult
                        { sat :: Either SatisfactionError SatScript
sat = SatisfactionError -> Either SatisfactionError SatScript
forall a b. a -> Either a b
Left (SatisfactionError -> Either SatisfactionError SatScript)
-> SatisfactionError -> Either SatisfactionError SatScript
forall a b. (a -> b) -> a -> b
$ [KeyDescriptor] -> SatisfactionError
MissingSignature [KeyDescriptor
k]
                        , dsat :: Either SatisfactionError SatScript
dsat = SatScript -> Either SatisfactionError SatScript
forall (m :: * -> *) a. Monad m => a -> m a
return (SatScript -> Either SatisfactionError SatScript)
-> SatScript -> Either SatisfactionError SatScript
forall a b. (a -> b) -> a -> b
$ Int -> [ScriptOp] -> SatScript
SatScript Int
1 [ScriptOp
OP_0]
                        }
    KeyH Value KeyDescriptor
vk -> (Miniscript -> Either SatisfactionError KeyDescriptor)
-> (KeyDescriptor -> Reader (Map Text Miniscript) SatResult)
-> Value KeyDescriptor
-> Reader (Map Text Miniscript) SatResult
forall a.
(Miniscript -> Either SatisfactionError a)
-> (a -> Reader (Map Text Miniscript) SatResult)
-> Value a
-> Reader (Map Text Miniscript) SatResult
withLiteral Miniscript -> Either SatisfactionError KeyDescriptor
guardKey KeyDescriptor -> Reader (Map Text Miniscript) SatResult
forall (m :: * -> *). Monad m => KeyDescriptor -> m SatResult
satisfyKeyH Value KeyDescriptor
vk
      where
        satisfyKeyH :: KeyDescriptor -> m SatResult
satisfyKeyH KeyDescriptor
k
            | Just PubKeyI
pk <- KeyDescriptor -> Maybe PubKeyI
keyDescPubKey KeyDescriptor
k
              , Just Signature
s <- PubKeyI -> SatisfactionContext -> Maybe Signature
lookupSignature PubKeyI
pk SatisfactionContext
sc =
                SatScript -> SatScript -> m SatResult
forall (m :: * -> *).
Monad m =>
SatScript -> SatScript -> m SatResult
satVals
                    ([ScriptOp] -> SatScript
fromScript [Signature -> ScriptOp
pushSig Signature
s, PubKeyI -> ScriptOp
pushKey PubKeyI
pk])
                    ([ScriptOp] -> SatScript
fromScript [ScriptOp
OP_0, PubKeyI -> ScriptOp
pushKey PubKeyI
pk])
            | Just PubKeyI
pk <- KeyDescriptor -> Maybe PubKeyI
keyDescPubKey KeyDescriptor
k =
                SatResult -> m SatResult
forall (m :: * -> *) a. Monad m => a -> m a
return
                    SatResult :: Either SatisfactionError SatScript
-> Either SatisfactionError SatScript -> SatResult
SatResult
                        { sat :: Either SatisfactionError SatScript
sat = SatisfactionError -> Either SatisfactionError SatScript
forall a b. a -> Either a b
Left (SatisfactionError -> Either SatisfactionError SatScript)
-> SatisfactionError -> Either SatisfactionError SatScript
forall a b. (a -> b) -> a -> b
$ [KeyDescriptor] -> SatisfactionError
MissingSignature [KeyDescriptor
k]
                        , dsat :: Either SatisfactionError SatScript
dsat = SatScript -> Either SatisfactionError SatScript
forall a b. b -> Either a b
Right (SatScript -> Either SatisfactionError SatScript)
-> SatScript -> Either SatisfactionError SatScript
forall a b. (a -> b) -> a -> b
$ [ScriptOp] -> SatScript
fromScript [ScriptOp
OP_0, PubKeyI -> ScriptOp
pushKey PubKeyI
pk]
                        }
            | Bool
otherwise = SatisfactionError -> m SatResult
forall (m :: * -> *). Monad m => SatisfactionError -> m SatResult
satErr (SatisfactionError -> m SatResult)
-> SatisfactionError -> m SatResult
forall a b. (a -> b) -> a -> b
$ KeyDescriptor -> SatisfactionError
AbstractKey KeyDescriptor
k
    Sha256 Value ByteString
h -> (Miniscript -> Either SatisfactionError ByteString)
-> (ByteString -> Reader (Map Text Miniscript) SatResult)
-> Value ByteString
-> Reader (Map Text Miniscript) SatResult
forall a.
(Miniscript -> Either SatisfactionError a)
-> (a -> Reader (Map Text Miniscript) SatResult)
-> Value a
-> Reader (Map Text Miniscript) SatResult
withLiteral Miniscript -> Either SatisfactionError ByteString
guardBytes ByteString -> Reader (Map Text Miniscript) SatResult
forall (m :: * -> *). Monad m => ByteString -> m SatResult
satisfyHash Value ByteString
h
    Ripemd160 Value ByteString
h -> (Miniscript -> Either SatisfactionError ByteString)
-> (ByteString -> Reader (Map Text Miniscript) SatResult)
-> Value ByteString
-> Reader (Map Text Miniscript) SatResult
forall a.
(Miniscript -> Either SatisfactionError a)
-> (a -> Reader (Map Text Miniscript) SatResult)
-> Value a
-> Reader (Map Text Miniscript) SatResult
withLiteral Miniscript -> Either SatisfactionError ByteString
guardBytes ByteString -> Reader (Map Text Miniscript) SatResult
forall (m :: * -> *). Monad m => ByteString -> m SatResult
satisfyHash Value ByteString
h
    Hash256 Value ByteString
h -> (Miniscript -> Either SatisfactionError ByteString)
-> (ByteString -> Reader (Map Text Miniscript) SatResult)
-> Value ByteString
-> Reader (Map Text Miniscript) SatResult
forall a.
(Miniscript -> Either SatisfactionError a)
-> (a -> Reader (Map Text Miniscript) SatResult)
-> Value a
-> Reader (Map Text Miniscript) SatResult
withLiteral Miniscript -> Either SatisfactionError ByteString
guardBytes ByteString -> Reader (Map Text Miniscript) SatResult
forall (m :: * -> *). Monad m => ByteString -> m SatResult
satisfyHash Value ByteString
h
    Hash160 Value ByteString
h -> (Miniscript -> Either SatisfactionError ByteString)
-> (ByteString -> Reader (Map Text Miniscript) SatResult)
-> Value ByteString
-> Reader (Map Text Miniscript) SatResult
forall a.
(Miniscript -> Either SatisfactionError a)
-> (a -> Reader (Map Text Miniscript) SatResult)
-> Value a
-> Reader (Map Text Miniscript) SatResult
withLiteral Miniscript -> Either SatisfactionError ByteString
guardBytes ByteString -> Reader (Map Text Miniscript) SatResult
forall (m :: * -> *). Monad m => ByteString -> m SatResult
satisfyHash Value ByteString
h
    AndOr Miniscript
x Miniscript
y Miniscript
z -> SatResult -> SatResult -> SatResult -> SatResult
satAndOr (SatResult -> SatResult -> SatResult -> SatResult)
-> Reader (Map Text Miniscript) SatResult
-> ReaderT
     (Map Text Miniscript)
     Identity
     (SatResult -> SatResult -> SatResult)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Miniscript -> Reader (Map Text Miniscript) SatResult
satisfyInContext Miniscript
x ReaderT
  (Map Text Miniscript)
  Identity
  (SatResult -> SatResult -> SatResult)
-> Reader (Map Text Miniscript) SatResult
-> ReaderT (Map Text Miniscript) Identity (SatResult -> SatResult)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Miniscript -> Reader (Map Text Miniscript) SatResult
satisfyInContext Miniscript
y ReaderT (Map Text Miniscript) Identity (SatResult -> SatResult)
-> Reader (Map Text Miniscript) SatResult
-> Reader (Map Text Miniscript) SatResult
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Miniscript -> Reader (Map Text Miniscript) SatResult
satisfyInContext Miniscript
z
      where
        satAndOr :: SatResult -> SatResult -> SatResult -> SatResult
satAndOr SatResult
sx SatResult
sy SatResult
sz =
            SatResult :: Either SatisfactionError SatScript
-> Either SatisfactionError SatScript -> SatResult
SatResult
                { sat :: Either SatisfactionError SatScript
sat = (SatResult -> Either SatisfactionError SatScript)
-> SatResult
-> (SatResult -> Either SatisfactionError SatScript)
-> SatResult
-> Either SatisfactionError SatScript
forall (f :: * -> *) m a b.
(Applicative f, Monoid m) =>
(a -> f m) -> a -> (b -> f m) -> b -> f m
satConcat SatResult -> Either SatisfactionError SatScript
sat SatResult
sy SatResult -> Either SatisfactionError SatScript
sat SatResult
sx Either SatisfactionError SatScript
-> Either SatisfactionError SatScript
-> Either SatisfactionError SatScript
forall e.
Either e SatScript -> Either e SatScript -> Either e SatScript
`satOr` (SatResult -> Either SatisfactionError SatScript)
-> SatResult
-> (SatResult -> Either SatisfactionError SatScript)
-> SatResult
-> Either SatisfactionError SatScript
forall (f :: * -> *) m a b.
(Applicative f, Monoid m) =>
(a -> f m) -> a -> (b -> f m) -> b -> f m
satConcat SatResult -> Either SatisfactionError SatScript
sat SatResult
sz SatResult -> Either SatisfactionError SatScript
dsat SatResult
sx
                , dsat :: Either SatisfactionError SatScript
dsat = (SatResult -> Either SatisfactionError SatScript)
-> SatResult
-> (SatResult -> Either SatisfactionError SatScript)
-> SatResult
-> Either SatisfactionError SatScript
forall (f :: * -> *) m a b.
(Applicative f, Monoid m) =>
(a -> f m) -> a -> (b -> f m) -> b -> f m
satConcat SatResult -> Either SatisfactionError SatScript
dsat SatResult
sz SatResult -> Either SatisfactionError SatScript
dsat SatResult
sx
                }
    AndV Miniscript
x Miniscript
y -> SatResult -> SatResult -> SatResult
satAndV (SatResult -> SatResult -> SatResult)
-> Reader (Map Text Miniscript) SatResult
-> ReaderT (Map Text Miniscript) Identity (SatResult -> SatResult)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Miniscript -> Reader (Map Text Miniscript) SatResult
satisfyInContext Miniscript
x ReaderT (Map Text Miniscript) Identity (SatResult -> SatResult)
-> Reader (Map Text Miniscript) SatResult
-> Reader (Map Text Miniscript) SatResult
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Miniscript -> Reader (Map Text Miniscript) SatResult
satisfyInContext Miniscript
y
      where
        satAndV :: SatResult -> SatResult -> SatResult
satAndV SatResult
sx SatResult
sy =
            SatResult :: Either SatisfactionError SatScript
-> Either SatisfactionError SatScript -> SatResult
SatResult
                { sat :: Either SatisfactionError SatScript
sat = (SatResult -> Either SatisfactionError SatScript)
-> SatResult
-> (SatResult -> Either SatisfactionError SatScript)
-> SatResult
-> Either SatisfactionError SatScript
forall (f :: * -> *) m a b.
(Applicative f, Monoid m) =>
(a -> f m) -> a -> (b -> f m) -> b -> f m
satConcat SatResult -> Either SatisfactionError SatScript
sat SatResult
sy SatResult -> Either SatisfactionError SatScript
sat SatResult
sx
                , dsat :: Either SatisfactionError SatScript
dsat = SatScript -> Either SatisfactionError SatScript
forall (m :: * -> *) a. Monad m => a -> m a
return SatScript
forall a. Monoid a => a
mempty
                }
    AndB Miniscript
x Miniscript
y -> SatResult -> SatResult -> SatResult
satAndB (SatResult -> SatResult -> SatResult)
-> Reader (Map Text Miniscript) SatResult
-> ReaderT (Map Text Miniscript) Identity (SatResult -> SatResult)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Miniscript -> Reader (Map Text Miniscript) SatResult
satisfyInContext Miniscript
x ReaderT (Map Text Miniscript) Identity (SatResult -> SatResult)
-> Reader (Map Text Miniscript) SatResult
-> Reader (Map Text Miniscript) SatResult
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Miniscript -> Reader (Map Text Miniscript) SatResult
satisfyInContext Miniscript
y
      where
        satAndB :: SatResult -> SatResult -> SatResult
satAndB SatResult
sx SatResult
sy =
            SatResult :: Either SatisfactionError SatScript
-> Either SatisfactionError SatScript -> SatResult
SatResult
                { sat :: Either SatisfactionError SatScript
sat = (SatResult -> Either SatisfactionError SatScript)
-> SatResult
-> (SatResult -> Either SatisfactionError SatScript)
-> SatResult
-> Either SatisfactionError SatScript
forall (f :: * -> *) m a b.
(Applicative f, Monoid m) =>
(a -> f m) -> a -> (b -> f m) -> b -> f m
satConcat SatResult -> Either SatisfactionError SatScript
sat SatResult
sy SatResult -> Either SatisfactionError SatScript
sat SatResult
sx
                , dsat :: Either SatisfactionError SatScript
dsat = (SatResult -> Either SatisfactionError SatScript)
-> SatResult
-> (SatResult -> Either SatisfactionError SatScript)
-> SatResult
-> Either SatisfactionError SatScript
forall (f :: * -> *) m a b.
(Applicative f, Monoid m) =>
(a -> f m) -> a -> (b -> f m) -> b -> f m
satConcat SatResult -> Either SatisfactionError SatScript
dsat SatResult
sy SatResult -> Either SatisfactionError SatScript
dsat SatResult
sx
                }
    OrB Miniscript
x Miniscript
z -> SatResult -> SatResult -> SatResult
satOrB (SatResult -> SatResult -> SatResult)
-> Reader (Map Text Miniscript) SatResult
-> ReaderT (Map Text Miniscript) Identity (SatResult -> SatResult)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Miniscript -> Reader (Map Text Miniscript) SatResult
satisfyInContext Miniscript
x ReaderT (Map Text Miniscript) Identity (SatResult -> SatResult)
-> Reader (Map Text Miniscript) SatResult
-> Reader (Map Text Miniscript) SatResult
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Miniscript -> Reader (Map Text Miniscript) SatResult
satisfyInContext Miniscript
z
      where
        satOrB :: SatResult -> SatResult -> SatResult
satOrB SatResult
sx SatResult
sz =
            SatResult :: Either SatisfactionError SatScript
-> Either SatisfactionError SatScript -> SatResult
SatResult
                { sat :: Either SatisfactionError SatScript
sat = (SatResult -> Either SatisfactionError SatScript)
-> SatResult
-> (SatResult -> Either SatisfactionError SatScript)
-> SatResult
-> Either SatisfactionError SatScript
forall (f :: * -> *) m a b.
(Applicative f, Monoid m) =>
(a -> f m) -> a -> (b -> f m) -> b -> f m
satConcat SatResult -> Either SatisfactionError SatScript
dsat SatResult
sz SatResult -> Either SatisfactionError SatScript
sat SatResult
sx Either SatisfactionError SatScript
-> Either SatisfactionError SatScript
-> Either SatisfactionError SatScript
forall e.
Either e SatScript -> Either e SatScript -> Either e SatScript
`satOr` (SatResult -> Either SatisfactionError SatScript)
-> SatResult
-> (SatResult -> Either SatisfactionError SatScript)
-> SatResult
-> Either SatisfactionError SatScript
forall (f :: * -> *) m a b.
(Applicative f, Monoid m) =>
(a -> f m) -> a -> (b -> f m) -> b -> f m
satConcat SatResult -> Either SatisfactionError SatScript
sat SatResult
sz SatResult -> Either SatisfactionError SatScript
dsat SatResult
sx
                , dsat :: Either SatisfactionError SatScript
dsat = (SatResult -> Either SatisfactionError SatScript)
-> SatResult
-> (SatResult -> Either SatisfactionError SatScript)
-> SatResult
-> Either SatisfactionError SatScript
forall (f :: * -> *) m a b.
(Applicative f, Monoid m) =>
(a -> f m) -> a -> (b -> f m) -> b -> f m
satConcat SatResult -> Either SatisfactionError SatScript
dsat SatResult
sz SatResult -> Either SatisfactionError SatScript
dsat SatResult
sx
                }
    OrC Miniscript
x Miniscript
z -> SatResult -> SatResult -> SatResult
satOrC (SatResult -> SatResult -> SatResult)
-> Reader (Map Text Miniscript) SatResult
-> ReaderT (Map Text Miniscript) Identity (SatResult -> SatResult)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Miniscript -> Reader (Map Text Miniscript) SatResult
satisfyInContext Miniscript
x ReaderT (Map Text Miniscript) Identity (SatResult -> SatResult)
-> Reader (Map Text Miniscript) SatResult
-> Reader (Map Text Miniscript) SatResult
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Miniscript -> Reader (Map Text Miniscript) SatResult
satisfyInContext Miniscript
z
      where
        satOrC :: SatResult -> SatResult -> SatResult
satOrC SatResult
sx SatResult
sz =
            SatResult :: Either SatisfactionError SatScript
-> Either SatisfactionError SatScript -> SatResult
SatResult
                { sat :: Either SatisfactionError SatScript
sat = SatResult -> Either SatisfactionError SatScript
sat SatResult
sx Either SatisfactionError SatScript
-> Either SatisfactionError SatScript
-> Either SatisfactionError SatScript
forall e.
Either e SatScript -> Either e SatScript -> Either e SatScript
`satOr` (SatResult -> Either SatisfactionError SatScript)
-> SatResult
-> (SatResult -> Either SatisfactionError SatScript)
-> SatResult
-> Either SatisfactionError SatScript
forall (f :: * -> *) m a b.
(Applicative f, Monoid m) =>
(a -> f m) -> a -> (b -> f m) -> b -> f m
satConcat SatResult -> Either SatisfactionError SatScript
sat SatResult
sz SatResult -> Either SatisfactionError SatScript
dsat SatResult
sx
                , dsat :: Either SatisfactionError SatScript
dsat = SatisfactionError -> Either SatisfactionError SatScript
forall a b. a -> Either a b
Left SatisfactionError
Impossible
                }
    OrD Miniscript
x Miniscript
z -> SatResult -> SatResult -> SatResult
satOrD (SatResult -> SatResult -> SatResult)
-> Reader (Map Text Miniscript) SatResult
-> ReaderT (Map Text Miniscript) Identity (SatResult -> SatResult)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Miniscript -> Reader (Map Text Miniscript) SatResult
satisfyInContext Miniscript
x ReaderT (Map Text Miniscript) Identity (SatResult -> SatResult)
-> Reader (Map Text Miniscript) SatResult
-> Reader (Map Text Miniscript) SatResult
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Miniscript -> Reader (Map Text Miniscript) SatResult
satisfyInContext Miniscript
z
      where
        satOrD :: SatResult -> SatResult -> SatResult
satOrD SatResult
sx SatResult
sz =
            SatResult :: Either SatisfactionError SatScript
-> Either SatisfactionError SatScript -> SatResult
SatResult
                { sat :: Either SatisfactionError SatScript
sat = SatResult -> Either SatisfactionError SatScript
sat SatResult
sx Either SatisfactionError SatScript
-> Either SatisfactionError SatScript
-> Either SatisfactionError SatScript
forall e.
Either e SatScript -> Either e SatScript -> Either e SatScript
`satOr` (SatResult -> Either SatisfactionError SatScript)
-> SatResult
-> (SatResult -> Either SatisfactionError SatScript)
-> SatResult
-> Either SatisfactionError SatScript
forall (f :: * -> *) m a b.
(Applicative f, Monoid m) =>
(a -> f m) -> a -> (b -> f m) -> b -> f m
satConcat SatResult -> Either SatisfactionError SatScript
sat SatResult
sz SatResult -> Either SatisfactionError SatScript
dsat SatResult
sx
                , dsat :: Either SatisfactionError SatScript
dsat = (SatResult -> Either SatisfactionError SatScript)
-> SatResult
-> (SatResult -> Either SatisfactionError SatScript)
-> SatResult
-> Either SatisfactionError SatScript
forall (f :: * -> *) m a b.
(Applicative f, Monoid m) =>
(a -> f m) -> a -> (b -> f m) -> b -> f m
satConcat SatResult -> Either SatisfactionError SatScript
dsat SatResult
sz SatResult -> Either SatisfactionError SatScript
dsat SatResult
sx
                }
    OrI Miniscript
x Miniscript
z -> SatResult -> SatResult -> SatResult
satOrI (SatResult -> SatResult -> SatResult)
-> Reader (Map Text Miniscript) SatResult
-> ReaderT (Map Text Miniscript) Identity (SatResult -> SatResult)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Miniscript -> Reader (Map Text Miniscript) SatResult
satisfyInContext Miniscript
x ReaderT (Map Text Miniscript) Identity (SatResult -> SatResult)
-> Reader (Map Text Miniscript) SatResult
-> Reader (Map Text Miniscript) SatResult
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Miniscript -> Reader (Map Text Miniscript) SatResult
satisfyInContext Miniscript
z
      where
        satOrI :: SatResult -> SatResult -> SatResult
satOrI SatResult
sx SatResult
sz =
            SatResult :: Either SatisfactionError SatScript
-> Either SatisfactionError SatScript -> SatResult
SatResult
                { sat :: Either SatisfactionError SatScript
sat =
                    let satA :: Either SatisfactionError SatScript
satA = (SatScript -> SatScript -> SatScript
forall a. Semigroup a => a -> a -> a
<> Int -> [ScriptOp] -> SatScript
SatScript Int
1 [ScriptOp
OP_1]) (SatScript -> SatScript)
-> Either SatisfactionError SatScript
-> Either SatisfactionError SatScript
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> SatResult -> Either SatisfactionError SatScript
sat SatResult
sx
                        satB :: Either SatisfactionError SatScript
satB = (SatScript -> SatScript -> SatScript
forall a. Semigroup a => a -> a -> a
<> Int -> [ScriptOp] -> SatScript
SatScript Int
1 [ScriptOp
OP_0]) (SatScript -> SatScript)
-> Either SatisfactionError SatScript
-> Either SatisfactionError SatScript
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> SatResult -> Either SatisfactionError SatScript
sat SatResult
sz
                     in Either SatisfactionError SatScript
satA Either SatisfactionError SatScript
-> Either SatisfactionError SatScript
-> Either SatisfactionError SatScript
forall e.
Either e SatScript -> Either e SatScript -> Either e SatScript
`satOr` Either SatisfactionError SatScript
satB
                , dsat :: Either SatisfactionError SatScript
dsat =
                    let dsatA :: Either SatisfactionError SatScript
dsatA = (SatScript -> SatScript -> SatScript
forall a. Semigroup a => a -> a -> a
<> Int -> [ScriptOp] -> SatScript
SatScript Int
1 [ScriptOp
OP_1]) (SatScript -> SatScript)
-> Either SatisfactionError SatScript
-> Either SatisfactionError SatScript
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> SatResult -> Either SatisfactionError SatScript
dsat SatResult
sx
                        dsatB :: Either SatisfactionError SatScript
dsatB = (SatScript -> SatScript -> SatScript
forall a. Semigroup a => a -> a -> a
<> Int -> [ScriptOp] -> SatScript
SatScript Int
1 [ScriptOp
OP_0]) (SatScript -> SatScript)
-> Either SatisfactionError SatScript
-> Either SatisfactionError SatScript
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> SatResult -> Either SatisfactionError SatScript
dsat SatResult
sz
                     in Either SatisfactionError SatScript
dsatA Either SatisfactionError SatScript
-> Either SatisfactionError SatScript
-> Either SatisfactionError SatScript
forall e.
Either e SatScript -> Either e SatScript -> Either e SatScript
`satOr` Either SatisfactionError SatScript
dsatB
                }
    Thresh Value Int
vk Miniscript
x [Miniscript]
xs -> (Miniscript -> Either SatisfactionError Int)
-> (Int -> Reader (Map Text Miniscript) SatResult)
-> Value Int
-> Reader (Map Text Miniscript) SatResult
forall a.
(Miniscript -> Either SatisfactionError a)
-> (a -> Reader (Map Text Miniscript) SatResult)
-> Value a
-> Reader (Map Text Miniscript) SatResult
withLiteral Miniscript -> Either SatisfactionError Int
guardNumber Int -> Reader (Map Text Miniscript) SatResult
satisfyThresh Value Int
vk
      where
        satisfyThresh :: Int -> Reader (Map Text Miniscript) SatResult
satisfyThresh Int
k = do
            [SatResult]
sxs <- (Miniscript -> Reader (Map Text Miniscript) SatResult)
-> [Miniscript]
-> ReaderT (Map Text Miniscript) Identity [SatResult]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse Miniscript -> Reader (Map Text Miniscript) SatResult
satisfyInContext (Miniscript
x Miniscript -> [Miniscript] -> [Miniscript]
forall a. a -> [a] -> [a]
: [Miniscript]
xs)
            SatResult -> Reader (Map Text Miniscript) SatResult
forall (m :: * -> *) a. Monad m => a -> m a
return
                SatResult :: Either SatisfactionError SatScript
-> Either SatisfactionError SatScript -> SatResult
SatResult
                    { sat :: Either SatisfactionError SatScript
sat = [SatScript] -> Either SatisfactionError SatScript
getSat ([SatScript] -> Either SatisfactionError SatScript)
-> [SatScript] -> Either SatisfactionError SatScript
forall a b. (a -> b) -> a -> b
$ Int -> [SatResult] -> [SatScript]
satResults Int
k [SatResult]
sxs
                    , dsat :: Either SatisfactionError SatScript
dsat = [SatScript] -> Either SatisfactionError SatScript
getSat ([SatScript] -> Either SatisfactionError SatScript)
-> [SatScript] -> Either SatisfactionError SatScript
forall a b. (a -> b) -> a -> b
$ Int -> [SatResult] -> [SatScript]
dsatResults Int
k [SatResult]
sxs
                    }

        getSat :: [SatScript] -> Either SatisfactionError SatScript
getSat = (Either SatisfactionError SatScript
 -> SatScript -> Either SatisfactionError SatScript)
-> Either SatisfactionError SatScript
-> [SatScript]
-> Either SatisfactionError SatScript
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' Either SatisfactionError SatScript
-> SatScript -> Either SatisfactionError SatScript
forall a. Either a SatScript -> SatScript -> Either a SatScript
accumResult (SatisfactionError -> Either SatisfactionError SatScript
forall a b. a -> Either a b
Left SatisfactionError
Impossible)
        satResults :: Int -> [SatResult] -> [SatScript]
satResults Int
k [SatResult]
sxs = [Either SatisfactionError SatScript] -> [SatScript]
forall a b. [Either a b] -> [b]
rights ([Either SatisfactionError SatScript] -> [SatScript])
-> [Either SatisfactionError SatScript] -> [SatScript]
forall a b. (a -> b) -> a -> b
$ ([SatScript] -> SatScript)
-> Either SatisfactionError [SatScript]
-> Either SatisfactionError SatScript
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap [SatScript] -> SatScript
forall a. Monoid a => [a] -> a
mconcat (Either SatisfactionError [SatScript]
 -> Either SatisfactionError SatScript)
-> ([Either SatisfactionError SatScript]
    -> Either SatisfactionError [SatScript])
-> [Either SatisfactionError SatScript]
-> Either SatisfactionError SatScript
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Either SatisfactionError SatScript]
-> Either SatisfactionError [SatScript]
forall (t :: * -> *) (m :: * -> *) a.
(Traversable t, Monad m) =>
t (m a) -> m (t a)
sequence ([Either SatisfactionError SatScript]
 -> Either SatisfactionError SatScript)
-> [[Either SatisfactionError SatScript]]
-> [Either SatisfactionError SatScript]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Int
-> (SatResult -> Either SatisfactionError SatScript)
-> (SatResult -> Either SatisfactionError SatScript)
-> [SatResult]
-> [[Either SatisfactionError SatScript]]
forall a b. Int -> (a -> b) -> (a -> b) -> [a] -> [[b]]
choose Int
k SatResult -> Either SatisfactionError SatScript
sat SatResult -> Either SatisfactionError SatScript
dsat ([SatResult] -> [SatResult]
forall a. [a] -> [a]
reverse [SatResult]
sxs)
        dsatResults :: Int -> [SatResult] -> [SatScript]
dsatResults Int
k [SatResult]
sxs = [Either SatisfactionError SatScript] -> [SatScript]
forall a b. [Either a b] -> [b]
rights ([Either SatisfactionError SatScript] -> [SatScript])
-> [Either SatisfactionError SatScript] -> [SatScript]
forall a b. (a -> b) -> a -> b
$ ([SatScript] -> SatScript)
-> Either SatisfactionError [SatScript]
-> Either SatisfactionError SatScript
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap [SatScript] -> SatScript
forall a. Monoid a => [a] -> a
mconcat (Either SatisfactionError [SatScript]
 -> Either SatisfactionError SatScript)
-> ([Either SatisfactionError SatScript]
    -> Either SatisfactionError [SatScript])
-> [Either SatisfactionError SatScript]
-> Either SatisfactionError SatScript
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Either SatisfactionError SatScript]
-> Either SatisfactionError [SatScript]
forall (t :: * -> *) (m :: * -> *) a.
(Traversable t, Monad m) =>
t (m a) -> m (t a)
sequence ([Either SatisfactionError SatScript]
 -> Either SatisfactionError SatScript)
-> [[Either SatisfactionError SatScript]]
-> [Either SatisfactionError SatScript]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Int
-> (SatResult -> Either SatisfactionError SatScript)
-> (SatResult -> Either SatisfactionError SatScript)
-> [SatResult]
-> [[Either SatisfactionError SatScript]]
forall a b. Int -> (a -> b) -> (a -> b) -> [a] -> [[b]]
chooseComplement Int
k SatResult -> Either SatisfactionError SatScript
sat SatResult -> Either SatisfactionError SatScript
dsat ([SatResult] -> [SatResult]
forall a. [a] -> [a]
reverse [SatResult]
sxs)

        chooseComplement :: Int -> (a -> b) -> (a -> b) -> [a] -> [[b]]
chooseComplement Int
k a -> b
f a -> b
g [a]
zs = (Int -> [[b]]) -> [Int] -> [[b]]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (\Int
k' -> Int -> (a -> b) -> (a -> b) -> [a] -> [[b]]
forall a b. Int -> (a -> b) -> (a -> b) -> [a] -> [[b]]
choose Int
k' a -> b
f a -> b
g [a]
zs) ([Int] -> [[b]]) -> [Int] -> [[b]]
forall a b. (a -> b) -> a -> b
$ (Int -> Bool) -> [Int] -> [Int]
forall a. (a -> Bool) -> [a] -> [a]
filter (Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
/= Int
k) [Int
0 .. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [a]
zs]

        accumResult :: Either a SatScript -> SatScript -> Either a SatScript
accumResult z :: Either a SatScript
z@(Right SatScript
s0) SatScript
s1
            | SatScript -> Int
satWeight SatScript
s1 Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< SatScript -> Int
satWeight SatScript
s0 = SatScript -> Either a SatScript
forall a b. b -> Either a b
Right SatScript
s1
            | Bool
otherwise = Either a SatScript
z
        accumResult Left{} SatScript
s = SatScript -> Either a SatScript
forall a b. b -> Either a b
Right SatScript
s
    Multi Value Int
vk [Value KeyDescriptor]
vks -> (Miniscript -> Either SatisfactionError Int)
-> (Int -> Reader (Map Text Miniscript) SatResult)
-> Value Int
-> Reader (Map Text Miniscript) SatResult
forall a.
(Miniscript -> Either SatisfactionError a)
-> (a -> Reader (Map Text Miniscript) SatResult)
-> Value a
-> Reader (Map Text Miniscript) SatResult
withLiteral Miniscript -> Either SatisfactionError Int
guardNumber Int -> Reader (Map Text Miniscript) SatResult
stageSatisfyMulti Value Int
vk
      where
        stageSatisfyMulti :: Int -> Reader (Map Text Miniscript) SatResult
stageSatisfyMulti Int
k = ([KeyDescriptor] -> Reader (Map Text Miniscript) SatResult)
-> [Value KeyDescriptor]
-> [KeyDescriptor]
-> Reader (Map Text Miniscript) SatResult
withKeys (Int -> [KeyDescriptor] -> Reader (Map Text Miniscript) SatResult
forall (m :: * -> *).
Monad m =>
Int -> [KeyDescriptor] -> m SatResult
satisfyMulti Int
k) [Value KeyDescriptor]
vks [KeyDescriptor]
forall a. Monoid a => a
mempty

        satisfyMulti :: Int -> [KeyDescriptor] -> m SatResult
satisfyMulti Int
k [KeyDescriptor]
ks
            | Just [PubKeyI]
pks <- (KeyDescriptor -> Maybe PubKeyI)
-> [KeyDescriptor] -> Maybe [PubKeyI]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse KeyDescriptor -> Maybe PubKeyI
keyDescPubKey [KeyDescriptor]
ks
              , [Signature]
ss <- (PubKeyI -> Maybe Signature) -> [PubKeyI] -> [Signature]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe (PubKeyI -> SatisfactionContext -> Maybe Signature
`lookupSignature` SatisfactionContext
sc) [PubKeyI]
pks
              , Just SatScript
result <- (Maybe SatScript -> SatScript -> Maybe SatScript)
-> Maybe SatScript -> [SatScript] -> Maybe SatScript
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' Maybe SatScript -> SatScript -> Maybe SatScript
accumMS Maybe SatScript
forall a. Maybe a
Nothing ([SatScript] -> Maybe SatScript) -> [SatScript] -> Maybe SatScript
forall a b. (a -> b) -> a -> b
$ Int -> [Signature] -> [SatScript]
bestSigs Int
k [Signature]
ss =
                SatScript -> SatScript -> m SatResult
forall (m :: * -> *).
Monad m =>
SatScript -> SatScript -> m SatResult
satVals SatScript
result (Int -> SatScript
dsatScript Int
k)
            | Bool
otherwise = SatResult -> m SatResult
forall (m :: * -> *) a. Monad m => a -> m a
return SatResult :: Either SatisfactionError SatScript
-> Either SatisfactionError SatScript -> SatResult
SatResult{sat :: Either SatisfactionError SatScript
sat = SatisfactionError -> Either SatisfactionError SatScript
forall a b. a -> Either a b
Left (SatisfactionError -> Either SatisfactionError SatScript)
-> SatisfactionError -> Either SatisfactionError SatScript
forall a b. (a -> b) -> a -> b
$ [KeyDescriptor] -> SatisfactionError
MissingSignature [KeyDescriptor]
ks, dsat :: Either SatisfactionError SatScript
dsat = SatScript -> Either SatisfactionError SatScript
forall (m :: * -> *) a. Monad m => a -> m a
return (SatScript -> Either SatisfactionError SatScript)
-> SatScript -> Either SatisfactionError SatScript
forall a b. (a -> b) -> a -> b
$ Int -> SatScript
dsatScript Int
k}

        bestSigs :: Int -> [Signature] -> [SatScript]
bestSigs Int
k [Signature]
ss = [ScriptOp] -> SatScript
fromScript ([ScriptOp] -> SatScript)
-> ([Maybe ScriptOp] -> [ScriptOp])
-> [Maybe ScriptOp]
-> SatScript
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (ScriptOp
OP_0 ScriptOp -> [ScriptOp] -> [ScriptOp]
forall a. a -> [a] -> [a]
:) ([ScriptOp] -> [ScriptOp])
-> ([Maybe ScriptOp] -> [ScriptOp])
-> [Maybe ScriptOp]
-> [ScriptOp]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Maybe ScriptOp] -> [ScriptOp]
forall a. [Maybe a] -> [a]
catMaybes ([Maybe ScriptOp] -> SatScript)
-> [[Maybe ScriptOp]] -> [SatScript]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Int
-> (Signature -> Maybe ScriptOp)
-> (Signature -> Maybe ScriptOp)
-> [Signature]
-> [[Maybe ScriptOp]]
forall a b. Int -> (a -> b) -> (a -> b) -> [a] -> [[b]]
choose Int
k (ScriptOp -> Maybe ScriptOp
forall a. a -> Maybe a
Just (ScriptOp -> Maybe ScriptOp)
-> (Signature -> ScriptOp) -> Signature -> Maybe ScriptOp
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Signature -> ScriptOp
pushSig) (Maybe ScriptOp -> Signature -> Maybe ScriptOp
forall a b. a -> b -> a
const Maybe ScriptOp
forall a. Maybe a
Nothing) [Signature]
ss

        accumMS :: Maybe SatScript -> SatScript -> Maybe SatScript
accumMS Maybe SatScript
Nothing SatScript
s = SatScript -> Maybe SatScript
forall a. a -> Maybe a
Just SatScript
s
        accumMS x :: Maybe SatScript
x@(Just SatScript
s1) SatScript
s2
            | SatScript -> Int
satWeight SatScript
s2 Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< SatScript -> Int
satWeight SatScript
s1 = SatScript -> Maybe SatScript
forall a. a -> Maybe a
Just SatScript
s2
            | Bool
otherwise = Maybe SatScript
x

        withKeys :: ([KeyDescriptor] -> Reader (Map Text Miniscript) SatResult)
-> [Value KeyDescriptor]
-> [KeyDescriptor]
-> Reader (Map Text Miniscript) SatResult
withKeys [KeyDescriptor] -> Reader (Map Text Miniscript) SatResult
f (Value KeyDescriptor
x : [Value KeyDescriptor]
xs) [KeyDescriptor]
ks = (Miniscript -> Either SatisfactionError KeyDescriptor)
-> (KeyDescriptor -> Reader (Map Text Miniscript) SatResult)
-> Value KeyDescriptor
-> Reader (Map Text Miniscript) SatResult
forall a.
(Miniscript -> Either SatisfactionError a)
-> (a -> Reader (Map Text Miniscript) SatResult)
-> Value a
-> Reader (Map Text Miniscript) SatResult
withLiteral Miniscript -> Either SatisfactionError KeyDescriptor
guardKey (([KeyDescriptor] -> Reader (Map Text Miniscript) SatResult)
-> [Value KeyDescriptor]
-> [KeyDescriptor]
-> Reader (Map Text Miniscript) SatResult
withKeys [KeyDescriptor] -> Reader (Map Text Miniscript) SatResult
f [Value KeyDescriptor]
xs ([KeyDescriptor] -> Reader (Map Text Miniscript) SatResult)
-> (KeyDescriptor -> [KeyDescriptor])
-> KeyDescriptor
-> Reader (Map Text Miniscript) SatResult
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (KeyDescriptor -> [KeyDescriptor] -> [KeyDescriptor]
forall a. a -> [a] -> [a]
: [KeyDescriptor]
ks)) Value KeyDescriptor
x
        withKeys [KeyDescriptor] -> Reader (Map Text Miniscript) SatResult
f [] [KeyDescriptor]
ks = [KeyDescriptor] -> Reader (Map Text Miniscript) SatResult
f [KeyDescriptor]
ks

        dsatScript :: Int -> SatScript
dsatScript Int
k = Int -> [ScriptOp] -> SatScript
SatScript (Int
k Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1) ([ScriptOp] -> SatScript) -> [ScriptOp] -> SatScript
forall a b. (a -> b) -> a -> b
$ Int -> ScriptOp -> [ScriptOp]
forall a. Int -> a -> [a]
replicate (Int
k Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1) ScriptOp
OP_0
    AnnA Miniscript
x -> Miniscript -> Reader (Map Text Miniscript) SatResult
satisfyInContext Miniscript
x
    AnnS Miniscript
x -> Miniscript -> Reader (Map Text Miniscript) SatResult
satisfyInContext Miniscript
x
    AnnC Miniscript
x -> Miniscript -> Reader (Map Text Miniscript) SatResult
satisfyInContext Miniscript
x
    AnnD Miniscript
x -> SatResult -> SatResult
revise (SatResult -> SatResult)
-> Reader (Map Text Miniscript) SatResult
-> Reader (Map Text Miniscript) SatResult
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Miniscript -> Reader (Map Text Miniscript) SatResult
satisfyInContext Miniscript
x
      where
        revise :: SatResult -> SatResult
revise SatResult
s =
            SatResult
s
                { sat :: Either SatisfactionError SatScript
sat = (SatScript -> SatScript -> SatScript
forall a. Semigroup a => a -> a -> a
<> Int -> [ScriptOp] -> SatScript
SatScript Int
1 [ScriptOp
OP_1]) (SatScript -> SatScript)
-> Either SatisfactionError SatScript
-> Either SatisfactionError SatScript
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> SatResult -> Either SatisfactionError SatScript
sat SatResult
s
                , dsat :: Either SatisfactionError SatScript
dsat = SatScript -> Either SatisfactionError SatScript
forall (m :: * -> *) a. Monad m => a -> m a
return (SatScript -> Either SatisfactionError SatScript)
-> SatScript -> Either SatisfactionError SatScript
forall a b. (a -> b) -> a -> b
$ Int -> [ScriptOp] -> SatScript
SatScript Int
1 [ScriptOp
OP_0]
                }
    AnnV Miniscript
x -> SatResult -> SatResult
revise (SatResult -> SatResult)
-> Reader (Map Text Miniscript) SatResult
-> Reader (Map Text Miniscript) SatResult
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Miniscript -> Reader (Map Text Miniscript) SatResult
satisfyInContext Miniscript
x
      where
        revise :: SatResult -> SatResult
revise SatResult
s = SatResult
s{dsat :: Either SatisfactionError SatScript
dsat = SatisfactionError -> Either SatisfactionError SatScript
forall a b. a -> Either a b
Left SatisfactionError
Impossible}
    AnnJ Miniscript
x -> SatResult -> SatResult
revise (SatResult -> SatResult)
-> Reader (Map Text Miniscript) SatResult
-> Reader (Map Text Miniscript) SatResult
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Miniscript -> Reader (Map Text Miniscript) SatResult
satisfyInContext Miniscript
x
      where
        revise :: SatResult -> SatResult
revise SatResult
s = SatResult
s{dsat :: Either SatisfactionError SatScript
dsat = SatScript -> Either SatisfactionError SatScript
forall (m :: * -> *) a. Monad m => a -> m a
return (SatScript -> Either SatisfactionError SatScript)
-> SatScript -> Either SatisfactionError SatScript
forall a b. (a -> b) -> a -> b
$ Int -> [ScriptOp] -> SatScript
SatScript Int
1 [ScriptOp
OP_0]}
    AnnN Miniscript
x -> Miniscript -> Reader (Map Text Miniscript) SatResult
satisfyInContext Miniscript
x
    Number{} -> SatResult -> Reader (Map Text Miniscript) SatResult
forall (m :: * -> *) a. Monad m => a -> m a
return SatResult :: Either SatisfactionError SatScript
-> Either SatisfactionError SatScript -> SatResult
SatResult{sat :: Either SatisfactionError SatScript
sat = SatScript -> Either SatisfactionError SatScript
forall (m :: * -> *) a. Monad m => a -> m a
return SatScript
forall a. Monoid a => a
mempty, dsat :: Either SatisfactionError SatScript
dsat = SatisfactionError -> Either SatisfactionError SatScript
forall a b. a -> Either a b
Left SatisfactionError
Impossible}
    Bytes{} -> SatResult -> Reader (Map Text Miniscript) SatResult
forall (m :: * -> *) a. Monad m => a -> m a
return SatResult :: Either SatisfactionError SatScript
-> Either SatisfactionError SatScript -> SatResult
SatResult{sat :: Either SatisfactionError SatScript
sat = SatScript -> Either SatisfactionError SatScript
forall (m :: * -> *) a. Monad m => a -> m a
return SatScript
forall a. Monoid a => a
mempty, dsat :: Either SatisfactionError SatScript
dsat = SatisfactionError -> Either SatisfactionError SatScript
forall a b. a -> Either a b
Left SatisfactionError
Impossible}
    KeyDesc{} -> SatResult -> Reader (Map Text Miniscript) SatResult
forall (m :: * -> *) a. Monad m => a -> m a
return SatResult :: Either SatisfactionError SatScript
-> Either SatisfactionError SatScript -> SatResult
SatResult{sat :: Either SatisfactionError SatScript
sat = SatScript -> Either SatisfactionError SatScript
forall (m :: * -> *) a. Monad m => a -> m a
return SatScript
forall a. Monoid a => a
mempty, dsat :: Either SatisfactionError SatScript
dsat = SatisfactionError -> Either SatisfactionError SatScript
forall a b. a -> Either a b
Left SatisfactionError
Impossible}
    Older Value Int
va -> (Int -> Reader (Map Text Miniscript) SatResult)
-> Maybe Int
-> ReaderT (Map Text Miniscript) Identity (Maybe SatResult)
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse Int -> Reader (Map Text Miniscript) SatResult
onAge (ChainState -> Maybe Int
utxoAge ChainState
chainState) ReaderT (Map Text Miniscript) Identity (Maybe SatResult)
-> (Maybe SatResult -> Reader (Map Text Miniscript) SatResult)
-> Reader (Map Text Miniscript) SatResult
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Reader (Map Text Miniscript) SatResult
-> (SatResult -> Reader (Map Text Miniscript) SatResult)
-> Maybe SatResult
-> Reader (Map Text Miniscript) SatResult
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (SatisfactionError -> Reader (Map Text Miniscript) SatResult
forall (m :: * -> *). Monad m => SatisfactionError -> m SatResult
satErr SatisfactionError
Impossible) SatResult -> Reader (Map Text Miniscript) SatResult
forall (m :: * -> *) a. Monad m => a -> m a
return
      where
        onAge :: Int -> Reader (Map Text Miniscript) SatResult
onAge Int
age = (Miniscript -> Either SatisfactionError Int)
-> (Int -> Reader (Map Text Miniscript) SatResult)
-> Value Int
-> Reader (Map Text Miniscript) SatResult
forall a.
(Miniscript -> Either SatisfactionError a)
-> (a -> Reader (Map Text Miniscript) SatResult)
-> Value a
-> Reader (Map Text Miniscript) SatResult
withLiteral Miniscript -> Either SatisfactionError Int
guardNumber (SatResult -> Reader (Map Text Miniscript) SatResult
forall (m :: * -> *) a. Monad m => a -> m a
return (SatResult -> Reader (Map Text Miniscript) SatResult)
-> (Int -> SatResult)
-> Int
-> Reader (Map Text Miniscript) SatResult
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> Int -> SatResult
forall a. Ord a => a -> a -> SatResult
satisfyOlder Int
age) Value Int
va
        satisfyOlder :: a -> a -> SatResult
satisfyOlder a
age a
reqAge
            | a
age a -> a -> Bool
forall a. Ord a => a -> a -> Bool
>= a
reqAge = SatResult :: Either SatisfactionError SatScript
-> Either SatisfactionError SatScript -> SatResult
SatResult{sat :: Either SatisfactionError SatScript
sat = SatScript -> Either SatisfactionError SatScript
forall (m :: * -> *) a. Monad m => a -> m a
return SatScript
forall a. Monoid a => a
mempty, dsat :: Either SatisfactionError SatScript
dsat = SatisfactionError -> Either SatisfactionError SatScript
forall a b. a -> Either a b
Left SatisfactionError
Impossible}
            | Bool
otherwise = SatResult :: Either SatisfactionError SatScript
-> Either SatisfactionError SatScript -> SatResult
SatResult{sat :: Either SatisfactionError SatScript
sat = SatisfactionError -> Either SatisfactionError SatScript
forall a b. a -> Either a b
Left SatisfactionError
Impossible, dsat :: Either SatisfactionError SatScript
dsat = SatScript -> Either SatisfactionError SatScript
forall (m :: * -> *) a. Monad m => a -> m a
return SatScript
forall a. Monoid a => a
mempty}
    After Value Int
vh -> (Int -> Reader (Map Text Miniscript) SatResult)
-> Maybe Int
-> ReaderT (Map Text Miniscript) Identity (Maybe SatResult)
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse Int -> Reader (Map Text Miniscript) SatResult
onHeight (ChainState -> Maybe Int
blockHeight ChainState
chainState) ReaderT (Map Text Miniscript) Identity (Maybe SatResult)
-> (Maybe SatResult -> Reader (Map Text Miniscript) SatResult)
-> Reader (Map Text Miniscript) SatResult
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Reader (Map Text Miniscript) SatResult
-> (SatResult -> Reader (Map Text Miniscript) SatResult)
-> Maybe SatResult
-> Reader (Map Text Miniscript) SatResult
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (SatisfactionError -> Reader (Map Text Miniscript) SatResult
forall (m :: * -> *). Monad m => SatisfactionError -> m SatResult
satErr SatisfactionError
Impossible) SatResult -> Reader (Map Text Miniscript) SatResult
forall (m :: * -> *) a. Monad m => a -> m a
return
      where
        onHeight :: Int -> Reader (Map Text Miniscript) SatResult
onHeight Int
h = (Miniscript -> Either SatisfactionError Int)
-> (Int -> Reader (Map Text Miniscript) SatResult)
-> Value Int
-> Reader (Map Text Miniscript) SatResult
forall a.
(Miniscript -> Either SatisfactionError a)
-> (a -> Reader (Map Text Miniscript) SatResult)
-> Value a
-> Reader (Map Text Miniscript) SatResult
withLiteral Miniscript -> Either SatisfactionError Int
guardNumber (SatResult -> Reader (Map Text Miniscript) SatResult
forall (m :: * -> *) a. Monad m => a -> m a
return (SatResult -> Reader (Map Text Miniscript) SatResult)
-> (Int -> SatResult)
-> Int
-> Reader (Map Text Miniscript) SatResult
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> Int -> SatResult
forall a. Ord a => a -> a -> SatResult
satisfyAfter Int
h) Value Int
vh
        satisfyAfter :: a -> a -> SatResult
satisfyAfter a
height a
reqHeight
            | a
height a -> a -> Bool
forall a. Ord a => a -> a -> Bool
>= a
reqHeight = SatResult :: Either SatisfactionError SatScript
-> Either SatisfactionError SatScript -> SatResult
SatResult{sat :: Either SatisfactionError SatScript
sat = SatScript -> Either SatisfactionError SatScript
forall (m :: * -> *) a. Monad m => a -> m a
return SatScript
forall a. Monoid a => a
mempty, dsat :: Either SatisfactionError SatScript
dsat = SatisfactionError -> Either SatisfactionError SatScript
forall a b. a -> Either a b
Left SatisfactionError
Impossible}
            | Bool
otherwise = SatResult :: Either SatisfactionError SatScript
-> Either SatisfactionError SatScript -> SatResult
SatResult{sat :: Either SatisfactionError SatScript
sat = SatisfactionError -> Either SatisfactionError SatScript
forall a b. a -> Either a b
Left SatisfactionError
Impossible, dsat :: Either SatisfactionError SatScript
dsat = SatScript -> Either SatisfactionError SatScript
forall (m :: * -> *) a. Monad m => a -> m a
return SatScript
forall a. Monoid a => a
mempty}
    Var Text
name -> Text
-> (Miniscript -> Reader (Map Text Miniscript) SatResult)
-> Reader (Map Text Miniscript) SatResult
requiredValue Text
name Miniscript -> Reader (Map Text Miniscript) SatResult
satisfyInContext
    Let Text
name Miniscript
x Miniscript
b -> (Map Text Miniscript -> Map Text Miniscript)
-> Reader (Map Text Miniscript) SatResult
-> Reader (Map Text Miniscript) SatResult
forall r (m :: * -> *) a.
(r -> r) -> ReaderT r m a -> ReaderT r m a
local (Text -> Miniscript -> Map Text Miniscript -> Map Text Miniscript
forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert Text
name Miniscript
x) (Reader (Map Text Miniscript) SatResult
 -> Reader (Map Text Miniscript) SatResult)
-> Reader (Map Text Miniscript) SatResult
-> Reader (Map Text Miniscript) SatResult
forall a b. (a -> b) -> a -> b
$ Miniscript -> Reader (Map Text Miniscript) SatResult
satisfyInContext Miniscript
b
  where
    satisfyInContext :: Miniscript -> Reader (Map Text Miniscript) SatResult
satisfyInContext = ChainState
-> SatisfactionContext
-> Miniscript
-> Reader (Map Text Miniscript) SatResult
satisfy' ChainState
chainState SatisfactionContext
sc

    -- it is still possible to dissatisfy when we do not know the preimage since
    -- we can easily detect that some value is _not_ it
    satisfyHash :: ByteString -> m SatResult
satisfyHash ByteString
h
        | Just ByteString
p <- ByteString -> SatisfactionContext -> Maybe ByteString
lookupPreimage ByteString
h SatisfactionContext
sc =
            SatScript -> SatScript -> m SatResult
forall (m :: * -> *).
Monad m =>
SatScript -> SatScript -> m SatResult
satVals ([ScriptOp] -> SatScript
fromScript [ByteString -> ScriptOp
opPushData ByteString
p]) ([ScriptOp] -> SatScript
fromScript [ByteString -> ScriptOp
opPushData (ByteString -> ScriptOp) -> ByteString -> ScriptOp
forall a b. (a -> b) -> a -> b
$ ByteString -> ByteString
otherValue ByteString
p])
        | Bool
otherwise = SatisfactionError -> m SatResult
forall (m :: * -> *). Monad m => SatisfactionError -> m SatResult
satErr (SatisfactionError -> m SatResult)
-> SatisfactionError -> m SatResult
forall a b. (a -> b) -> a -> b
$ ByteString -> SatisfactionError
MissingPreimage ByteString
h

pushSig :: Signature -> ScriptOp
pushSig :: Signature -> ScriptOp
pushSig (Signature Sig
s SigHash
sh) = ByteString -> ScriptOp
opPushData (ByteString -> ScriptOp)
-> (TxSignature -> ByteString) -> TxSignature -> ScriptOp
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TxSignature -> ByteString
encodeTxSig (TxSignature -> ScriptOp) -> TxSignature -> ScriptOp
forall a b. (a -> b) -> a -> b
$ Sig -> SigHash -> TxSignature
TxSignature Sig
s SigHash
sh

pushKey :: PubKeyI -> ScriptOp
pushKey :: PubKeyI -> ScriptOp
pushKey (PubKeyI PubKey
k Bool
c) = ByteString -> ScriptOp
opPushData (ByteString -> ScriptOp) -> ByteString -> ScriptOp
forall a b. (a -> b) -> a -> b
$ Bool -> PubKey -> ByteString
exportPubKey Bool
c PubKey
k

-- TODO fingerprinting implications
otherValue :: ByteString -> ByteString
otherValue :: ByteString -> ByteString
otherValue ByteString
bs
    | ByteString
bs ByteString -> ByteString -> Bool
forall a. Eq a => a -> a -> Bool
== ByteString
zero32 = [Word8] -> ByteString
BS.pack ([Word8] -> ByteString) -> [Word8] -> ByteString
forall a b. (a -> b) -> a -> b
$ Int -> Word8 -> [Word8]
forall a. Int -> a -> [a]
replicate Int
32 Word8
0x1
    | Bool
otherwise = ByteString
zero32

zero32 :: ByteString
zero32 :: ByteString
zero32 = [Word8] -> ByteString
BS.pack ([Word8] -> ByteString) -> [Word8] -> ByteString
forall a b. (a -> b) -> a -> b
$ Int -> Word8 -> [Word8]
forall a. Int -> a -> [a]
replicate Int
32 Word8
0x0

withLiteral ::
    (Miniscript -> Either SatisfactionError a) ->
    (a -> Reader (Map Text Miniscript) SatResult) ->
    Value a ->
    Reader (Map Text Miniscript) SatResult
withLiteral :: (Miniscript -> Either SatisfactionError a)
-> (a -> Reader (Map Text Miniscript) SatResult)
-> Value a
-> Reader (Map Text Miniscript) SatResult
withLiteral Miniscript -> Either SatisfactionError a
g a -> Reader (Map Text Miniscript) SatResult
f = \case
    Lit a
n -> a -> Reader (Map Text Miniscript) SatResult
f a
n
    Variable Text
n -> Text
-> (Miniscript -> Reader (Map Text Miniscript) SatResult)
-> Reader (Map Text Miniscript) SatResult
requiredValue Text
n ((Miniscript -> Reader (Map Text Miniscript) SatResult)
 -> Reader (Map Text Miniscript) SatResult)
-> (Miniscript -> Reader (Map Text Miniscript) SatResult)
-> Reader (Map Text Miniscript) SatResult
forall a b. (a -> b) -> a -> b
$ (SatisfactionError -> Reader (Map Text Miniscript) SatResult)
-> (a -> Reader (Map Text Miniscript) SatResult)
-> Either SatisfactionError a
-> Reader (Map Text Miniscript) SatResult
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either SatisfactionError -> Reader (Map Text Miniscript) SatResult
forall (m :: * -> *). Monad m => SatisfactionError -> m SatResult
satErr a -> Reader (Map Text Miniscript) SatResult
f (Either SatisfactionError a
 -> Reader (Map Text Miniscript) SatResult)
-> (Miniscript -> Either SatisfactionError a)
-> Miniscript
-> Reader (Map Text Miniscript) SatResult
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Miniscript -> Either SatisfactionError a
g

requiredValue ::
    Text ->
    (Miniscript -> Reader (Map Text Miniscript) SatResult) ->
    Reader (Map Text Miniscript) SatResult
requiredValue :: Text
-> (Miniscript -> Reader (Map Text Miniscript) SatResult)
-> Reader (Map Text Miniscript) SatResult
requiredValue Text
name Miniscript -> Reader (Map Text Miniscript) SatResult
f = (Map Text Miniscript -> Maybe Miniscript)
-> ReaderT (Map Text Miniscript) Identity (Maybe Miniscript)
forall (m :: * -> *) r a. Monad m => (r -> a) -> ReaderT r m a
asks (Text -> Map Text Miniscript -> Maybe Miniscript
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup Text
name) ReaderT (Map Text Miniscript) Identity (Maybe Miniscript)
-> (Maybe Miniscript -> Reader (Map Text Miniscript) SatResult)
-> Reader (Map Text Miniscript) SatResult
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Reader (Map Text Miniscript) SatResult
-> (Miniscript -> Reader (Map Text Miniscript) SatResult)
-> Maybe Miniscript
-> Reader (Map Text Miniscript) SatResult
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (SatisfactionError -> Reader (Map Text Miniscript) SatResult
forall (m :: * -> *). Monad m => SatisfactionError -> m SatResult
satErr (SatisfactionError -> Reader (Map Text Miniscript) SatResult)
-> SatisfactionError -> Reader (Map Text Miniscript) SatResult
forall a b. (a -> b) -> a -> b
$ Text -> SatisfactionError
FreeVariable Text
name) Miniscript -> Reader (Map Text Miniscript) SatResult
f

guardNumber :: Miniscript -> Either SatisfactionError Int
guardNumber :: Miniscript -> Either SatisfactionError Int
guardNumber (Number Int
n) = Int -> Either SatisfactionError Int
forall (m :: * -> *) a. Monad m => a -> m a
return Int
n
guardNumber Miniscript
e = SatisfactionError -> Either SatisfactionError Int
forall a b. a -> Either a b
Left (SatisfactionError -> Either SatisfactionError Int)
-> SatisfactionError -> Either SatisfactionError Int
forall a b. (a -> b) -> a -> b
$ Text -> Miniscript -> SatisfactionError
TypeError Text
"number" Miniscript
e

guardKey :: Miniscript -> Either SatisfactionError KeyDescriptor
guardKey :: Miniscript -> Either SatisfactionError KeyDescriptor
guardKey (KeyDesc KeyDescriptor
k) = KeyDescriptor -> Either SatisfactionError KeyDescriptor
forall (m :: * -> *) a. Monad m => a -> m a
return KeyDescriptor
k
guardKey Miniscript
e = SatisfactionError -> Either SatisfactionError KeyDescriptor
forall a b. a -> Either a b
Left (SatisfactionError -> Either SatisfactionError KeyDescriptor)
-> SatisfactionError -> Either SatisfactionError KeyDescriptor
forall a b. (a -> b) -> a -> b
$ Text -> Miniscript -> SatisfactionError
TypeError Text
"key" Miniscript
e

guardBytes :: Miniscript -> Either SatisfactionError ByteString
guardBytes :: Miniscript -> Either SatisfactionError ByteString
guardBytes (Bytes ByteString
b) = ByteString -> Either SatisfactionError ByteString
forall (m :: * -> *) a. Monad m => a -> m a
return ByteString
b
guardBytes Miniscript
e = SatisfactionError -> Either SatisfactionError ByteString
forall a b. a -> Either a b
Left (SatisfactionError -> Either SatisfactionError ByteString)
-> SatisfactionError -> Either SatisfactionError ByteString
forall a b. (a -> b) -> a -> b
$ Text -> Miniscript -> SatisfactionError
TypeError Text
"bytes" Miniscript
e

satVals :: Monad m => SatScript -> SatScript -> m SatResult
satVals :: SatScript -> SatScript -> m SatResult
satVals SatScript
x SatScript
y = SatResult -> m SatResult
forall (m :: * -> *) a. Monad m => a -> m a
return (SatResult -> m SatResult) -> SatResult -> m SatResult
forall a b. (a -> b) -> a -> b
$ Either SatisfactionError SatScript
-> Either SatisfactionError SatScript -> SatResult
SatResult (SatScript -> Either SatisfactionError SatScript
forall a b. b -> Either a b
Right SatScript
x) (SatScript -> Either SatisfactionError SatScript
forall a b. b -> Either a b
Right SatScript
y)

satErr :: Monad m => SatisfactionError -> m SatResult
satErr :: SatisfactionError -> m SatResult
satErr = SatResult -> m SatResult
forall (m :: * -> *) a. Monad m => a -> m a
return (SatResult -> m SatResult)
-> (SatisfactionError -> SatResult)
-> SatisfactionError
-> m SatResult
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Either SatisfactionError SatScript
-> Either SatisfactionError SatScript -> SatResult
SatResult (Either SatisfactionError SatScript
 -> Either SatisfactionError SatScript -> SatResult)
-> (SatisfactionError -> Either SatisfactionError SatScript)
-> SatisfactionError
-> Either SatisfactionError SatScript
-> SatResult
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> SatisfactionError -> Either SatisfactionError SatScript
forall a b. a -> Either a b
Left (SatisfactionError
 -> Either SatisfactionError SatScript -> SatResult)
-> (SatisfactionError -> Either SatisfactionError SatScript)
-> SatisfactionError
-> SatResult
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> SatisfactionError -> Either SatisfactionError SatScript
forall a b. a -> Either a b
Left)

satConcat :: (Applicative f, Monoid m) => (a -> f m) -> a -> (b -> f m) -> b -> f m
satConcat :: (a -> f m) -> a -> (b -> f m) -> b -> f m
satConcat a -> f m
f a
x b -> f m
g b
y = m -> m -> m
forall a. Semigroup a => a -> a -> a
(<>) (m -> m -> m) -> f m -> f (m -> m)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> a -> f m
f a
x f (m -> m) -> f m -> f m
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> b -> f m
g b
y

satOr :: Either e SatScript -> Either e SatScript -> Either e SatScript
satOr :: Either e SatScript -> Either e SatScript -> Either e SatScript
satOr xA :: Either e SatScript
xA@(Right SatScript
sA) xB :: Either e SatScript
xB@(Right SatScript
sB)
    | SatScript -> Int
satWeight SatScript
sA Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= SatScript -> Int
satWeight SatScript
sB = Either e SatScript
xA
    | Bool
otherwise = Either e SatScript
xB
satOr Either e SatScript
sA Either e SatScript
sB = Either e SatScript
sA Either e SatScript -> Either e SatScript -> Either e SatScript
forall a. Semigroup a => a -> a -> a
<> Either e SatScript
sB

choose :: Int -> (a -> b) -> (a -> b) -> [a] -> [[b]]
choose :: Int -> (a -> b) -> (a -> b) -> [a] -> [[b]]
choose Int
0 a -> b
_ a -> b
onExclude [a]
xs = [a -> b
onExclude (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [a]
xs]
choose Int
k a -> b
onInclude a -> b
_ [a]
xs
    | Int
k Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [a]
xs = [a -> b
onInclude (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [a]
xs]
    | Int
k Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [a]
xs = []
choose Int
k a -> b
onInclude a -> b
onExclude (a
x : [a]
xs) =
    ((a -> b) -> [b] -> [b]
forall a. (a -> a) -> [a] -> [a]
handleX a -> b
onInclude ([b] -> [b]) -> [[b]] -> [[b]]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Int -> (a -> b) -> (a -> b) -> [a] -> [[b]]
forall a b. Int -> (a -> b) -> (a -> b) -> [a] -> [[b]]
choose (Int
k Int -> Int -> Int
forall a. Num a => a -> a -> a
-Int
1) a -> b
onInclude a -> b
onExclude [a]
xs)
        [[b]] -> [[b]] -> [[b]]
forall a. Semigroup a => a -> a -> a
<> ((a -> b) -> [b] -> [b]
forall a. (a -> a) -> [a] -> [a]
handleX a -> b
onExclude ([b] -> [b]) -> [[b]] -> [[b]]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Int -> (a -> b) -> (a -> b) -> [a] -> [[b]]
forall a b. Int -> (a -> b) -> (a -> b) -> [a] -> [[b]]
choose Int
k a -> b
onInclude a -> b
onExclude [a]
xs)
  where
    handleX :: (a -> a) -> [a] -> [a]
handleX a -> a
f [a]
zs = a -> a
f a
x a -> [a] -> [a]
forall a. a -> [a] -> [a]
: [a]
zs
choose Int
_ a -> b
_ a -> b
_ [] = []