{-# LANGUAGE AllowAmbiguousTypes        #-}
{-# LANGUAGE DataKinds                  #-}
{-# LANGUAGE DeriveAnyClass             #-}
{-# LANGUAGE DeriveGeneric              #-}
{-# LANGUAGE DerivingStrategies         #-}
{-# LANGUAGE FlexibleContexts           #-}
{-# LANGUAGE FlexibleInstances          #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE MultiParamTypeClasses      #-}
{-# LANGUAGE NamedFieldPuns             #-}
{-# LANGUAGE NoImplicitPrelude          #-}
{-# LANGUAGE PartialTypeSignatures      #-}
{-# LANGUAGE RecordWildCards            #-}
{-# LANGUAGE ScopedTypeVariables        #-}
{-# LANGUAGE TemplateHaskell            #-}
{-# LANGUAGE TypeApplications           #-}
{-# LANGUAGE TypeFamilies               #-}
{-# LANGUAGE TypeOperators              #-}
{-# LANGUAGE ViewPatterns               #-}

-- | A guessing game. A simplified version of 'Plutus.Contract.GameStateMachine'
-- not using 'Plutus.Contract.StateMachine' and using `yieldUnbalancedTx' for
-- balancing, signing and submitting transactions.
--
-- Currently, remote wallets (anything other than WBE) can only handles
-- `yieldUnbalancedTx` requests, and not `balanceTx`, `signTx` and `submitTx`
-- requests.
--
-- This is the "Alonzo version" of the game, it uses features up to the Alonzo era.
module Plutus.Contracts.Game.Alonzo
    ( contract
    , GameParam(..)
    , GameSchema
    , LockArgs(..)
    , GuessArgs(..)
    -- * Scripts
    , gameInstance
    , mkValidator
    -- * Address
    , gameAddress
    , covIdx
    ) where

import Cardano.Node.Emulator.Internal.Node.Params (testnet)
import Control.Lens (_2, (^?))
import Data.Aeson (FromJSON, ToJSON)
import Data.ByteString.Char8 qualified as C
import Data.Map (Map)
import Data.Map qualified as Map
import Data.Maybe (catMaybes)
import GHC.Generics (Generic)
import Ledger (CardanoAddress, POSIXTime, PaymentPubKeyHash, TxOutRef)
import Ledger.Tx (DecoratedTxOut (..), datumInDatumFromQuery, decoratedTxOutDatum)
import Ledger.Tx.Constraints qualified as Constraints
import Ledger.Typed.Scripts qualified as Scripts
import Ledger.Value.CardanoAPI qualified as C
import Plutus.Contract (AsContractError, Contract, Endpoint, Promise, adjustUnbalancedTx, endpoint, fundsAtAddressGeq,
                        logInfo, mkTxConstraints, selectList, type (.\/), yieldUnbalancedTx)
import Plutus.Script.Utils.Typed (ScriptContextV2)
import Plutus.Script.Utils.V2.Address (mkValidatorCardanoAddress)
import Plutus.Script.Utils.V2.Typed.Scripts qualified as V2
import Plutus.Script.Utils.Value (Value)
import Plutus.V2.Ledger.Api (Datum (Datum), Validator)
import Plutus.V2.Ledger.Contexts qualified as V2
import PlutusTx qualified
import PlutusTx.Code (getCovIdx)
import PlutusTx.Coverage (CoverageIndex)
import PlutusTx.Prelude hiding (pure, (<$>))
import Prelude qualified as Haskell

-- | Datatype for creating a parameterized validator.
data GameParam = GameParam
    { GameParam -> PaymentPubKeyHash
gameParamPayeePkh  :: PaymentPubKeyHash
    -- ^ Payment public key hash of the wallet locking some funds
    , GameParam -> POSIXTime
gameParamStartTime :: POSIXTime
    -- ^ Starting time of the game
    } deriving (Int -> GameParam -> ShowS
[GameParam] -> ShowS
GameParam -> String
(Int -> GameParam -> ShowS)
-> (GameParam -> String)
-> ([GameParam] -> ShowS)
-> Show GameParam
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [GameParam] -> ShowS
$cshowList :: [GameParam] -> ShowS
show :: GameParam -> String
$cshow :: GameParam -> String
showsPrec :: Int -> GameParam -> ShowS
$cshowsPrec :: Int -> GameParam -> ShowS
Haskell.Show, (forall x. GameParam -> Rep GameParam x)
-> (forall x. Rep GameParam x -> GameParam) -> Generic GameParam
forall x. Rep GameParam x -> GameParam
forall x. GameParam -> Rep GameParam x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall x. Rep GameParam x -> GameParam
$cfrom :: forall x. GameParam -> Rep GameParam x
Generic)
      deriving anyclass ([GameParam] -> Encoding
[GameParam] -> Value
GameParam -> Encoding
GameParam -> Value
(GameParam -> Value)
-> (GameParam -> Encoding)
-> ([GameParam] -> Value)
-> ([GameParam] -> Encoding)
-> ToJSON GameParam
forall a.
(a -> Value)
-> (a -> Encoding)
-> ([a] -> Value)
-> ([a] -> Encoding)
-> ToJSON a
toEncodingList :: [GameParam] -> Encoding
$ctoEncodingList :: [GameParam] -> Encoding
toJSONList :: [GameParam] -> Value
$ctoJSONList :: [GameParam] -> Value
toEncoding :: GameParam -> Encoding
$ctoEncoding :: GameParam -> Encoding
toJSON :: GameParam -> Value
$ctoJSON :: GameParam -> Value
ToJSON, Value -> Parser [GameParam]
Value -> Parser GameParam
(Value -> Parser GameParam)
-> (Value -> Parser [GameParam]) -> FromJSON GameParam
forall a.
(Value -> Parser a) -> (Value -> Parser [a]) -> FromJSON a
parseJSONList :: Value -> Parser [GameParam]
$cparseJSONList :: Value -> Parser [GameParam]
parseJSON :: Value -> Parser GameParam
$cparseJSON :: Value -> Parser GameParam
FromJSON)

PlutusTx.makeLift ''GameParam

newtype HashedString = HashedString BuiltinByteString
    deriving newtype (HashedString -> BuiltinData
(HashedString -> BuiltinData) -> ToData HashedString
forall a. (a -> BuiltinData) -> ToData a
toBuiltinData :: HashedString -> BuiltinData
$ctoBuiltinData :: HashedString -> BuiltinData
PlutusTx.ToData, BuiltinData -> Maybe HashedString
(BuiltinData -> Maybe HashedString) -> FromData HashedString
forall a. (BuiltinData -> Maybe a) -> FromData a
fromBuiltinData :: BuiltinData -> Maybe HashedString
$cfromBuiltinData :: BuiltinData -> Maybe HashedString
PlutusTx.FromData, BuiltinData -> HashedString
(BuiltinData -> HashedString) -> UnsafeFromData HashedString
forall a. (BuiltinData -> a) -> UnsafeFromData a
unsafeFromBuiltinData :: BuiltinData -> HashedString
$cunsafeFromBuiltinData :: BuiltinData -> HashedString
PlutusTx.UnsafeFromData)

PlutusTx.makeLift ''HashedString

newtype ClearString = ClearString BuiltinByteString
    deriving newtype (ClearString -> BuiltinData
(ClearString -> BuiltinData) -> ToData ClearString
forall a. (a -> BuiltinData) -> ToData a
toBuiltinData :: ClearString -> BuiltinData
$ctoBuiltinData :: ClearString -> BuiltinData
PlutusTx.ToData, BuiltinData -> Maybe ClearString
(BuiltinData -> Maybe ClearString) -> FromData ClearString
forall a. (BuiltinData -> Maybe a) -> FromData a
fromBuiltinData :: BuiltinData -> Maybe ClearString
$cfromBuiltinData :: BuiltinData -> Maybe ClearString
PlutusTx.FromData, BuiltinData -> ClearString
(BuiltinData -> ClearString) -> UnsafeFromData ClearString
forall a. (BuiltinData -> a) -> UnsafeFromData a
unsafeFromBuiltinData :: BuiltinData -> ClearString
$cunsafeFromBuiltinData :: BuiltinData -> ClearString
PlutusTx.UnsafeFromData)

PlutusTx.makeLift ''ClearString

type GameSchema =
        Endpoint "lock" LockArgs
        .\/ Endpoint "guess" GuessArgs

data Game
instance Scripts.ValidatorTypes Game where
    type instance RedeemerType Game = ClearString
    type instance DatumType Game = HashedString

-- | The address of the game (the hash of its validator script)
gameAddress :: GameParam -> CardanoAddress
gameAddress :: GameParam -> CardanoAddress
gameAddress = NetworkId -> Validator -> CardanoAddress
mkValidatorCardanoAddress NetworkId
testnet (Validator -> CardanoAddress)
-> (GameParam -> Validator) -> GameParam -> CardanoAddress
forall b c a. (b -> c) -> (a -> b) -> a -> c
. GameParam -> Validator
gameValidator

-- | The validator script of the game.
gameValidator :: GameParam -> Validator
gameValidator :: GameParam -> Validator
gameValidator = TypedValidator Game -> Validator
forall a. TypedValidator a -> Validator
Scripts.validatorScript (TypedValidator Game -> Validator)
-> (GameParam -> TypedValidator Game) -> GameParam -> Validator
forall b c a. (b -> c) -> (a -> b) -> a -> c
. GameParam -> TypedValidator Game
gameInstance

gameInstance :: GameParam -> V2.TypedValidator Game
gameInstance :: GameParam -> TypedValidator Game
gameInstance = CompiledCode (GameParam -> ValidatorType Game)
-> CompiledCode (ValidatorType Game -> UntypedValidator)
-> GameParam
-> TypedValidator Game
forall a param.
Lift DefaultUni param =>
CompiledCode (param -> ValidatorType a)
-> CompiledCode (ValidatorType a -> UntypedValidator)
-> param
-> TypedValidator a
V2.mkTypedValidatorParam @Game
    $$(PlutusTx.compile [|| mkValidator ||])
    $$(PlutusTx.compile [|| wrap ||]) where
        wrap :: (HashedString -> ClearString -> ScriptContext -> Bool)
-> UntypedValidator
wrap = (UnsafeFromData HashedString, UnsafeFromData ClearString) =>
(HashedString -> ClearString -> ScriptContext -> Bool)
-> UntypedValidator
forall sc d r.
(IsScriptContext sc, UnsafeFromData d, UnsafeFromData r) =>
(d -> r -> sc -> Bool) -> UntypedValidator
Scripts.mkUntypedValidator @ScriptContextV2 @HashedString @ClearString

-- | The validation function (Datum -> Redeemer -> ScriptContext -> Bool)
--
-- The 'GameParam' parameter is not used in the validation. It is meant to
-- parameterize the script address depending based on the value of 'GaramParam'.
{-# INLINABLE mkValidator #-}
mkValidator :: GameParam -> HashedString -> ClearString -> V2.ScriptContext -> Bool
mkValidator :: GameParam -> HashedString -> ClearString -> ScriptContext -> Bool
mkValidator GameParam
_ HashedString
hs ClearString
cs ScriptContext
_ = HashedString -> ClearString -> Bool
isGoodGuess HashedString
hs ClearString
cs

{-# INLINABLE isGoodGuess #-}
isGoodGuess :: HashedString -> ClearString -> Bool
isGoodGuess :: HashedString -> ClearString -> Bool
isGoodGuess (HashedString BuiltinByteString
actual) (ClearString BuiltinByteString
guess') = BuiltinByteString
actual BuiltinByteString -> BuiltinByteString -> Bool
forall a. Eq a => a -> a -> Bool
== BuiltinByteString -> BuiltinByteString
sha2_256 BuiltinByteString
guess'

-- TODO: Ideas welcome for how to make this interface suck less.
-- Doing it this way actually generates coverage locations that we don't care about(!)
covIdx :: GameParam -> CoverageIndex
covIdx :: GameParam -> CoverageIndex
covIdx GameParam
gameParam =
    CompiledCodeIn
  DefaultUni
  DefaultFun
  (HashedString -> ClearString -> ScriptContext -> Bool)
-> CoverageIndex
forall (uni :: * -> *) fun a.
CompiledCodeIn uni fun a -> CoverageIndex
getCovIdx ($$(PlutusTx.compile [|| mkValidator ||]) CompiledCode
  (GameParam -> HashedString -> ClearString -> ScriptContext -> Bool)
-> CompiledCodeIn DefaultUni DefaultFun GameParam
-> CompiledCodeIn
     DefaultUni
     DefaultFun
     (HashedString -> ClearString -> ScriptContext -> Bool)
forall (uni :: * -> *) fun a b.
(Closed uni, Everywhere uni Flat, Flat fun,
 Everywhere uni PrettyConst, GShow uni, Pretty fun) =>
CompiledCodeIn uni fun (a -> b)
-> CompiledCodeIn uni fun a -> CompiledCodeIn uni fun b
`PlutusTx.applyCode` GameParam -> CompiledCodeIn DefaultUni DefaultFun GameParam
forall (uni :: * -> *) a fun.
(Lift uni a, Throwable uni fun, Typecheckable uni fun) =>
a -> CompiledCodeIn uni fun a
PlutusTx.liftCode GameParam
gameParam)

-- create a data script for the guessing game by hashing the string
-- and lifting the hash to its on-chain representation
hashString :: Haskell.String -> HashedString
hashString :: String -> HashedString
hashString = BuiltinByteString -> HashedString
HashedString (BuiltinByteString -> HashedString)
-> (String -> BuiltinByteString) -> String -> HashedString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. BuiltinByteString -> BuiltinByteString
sha2_256 (BuiltinByteString -> BuiltinByteString)
-> (String -> BuiltinByteString) -> String -> BuiltinByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> BuiltinByteString
forall a arep. ToBuiltin a arep => a -> arep
toBuiltin (ByteString -> BuiltinByteString)
-> (String -> ByteString) -> String -> BuiltinByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> ByteString
C.pack

-- create a redeemer script for the guessing game by lifting the
-- string to its on-chain representation
clearString :: Haskell.String -> ClearString
clearString :: String -> ClearString
clearString = BuiltinByteString -> ClearString
ClearString (BuiltinByteString -> ClearString)
-> (String -> BuiltinByteString) -> String -> ClearString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> BuiltinByteString
forall a arep. ToBuiltin a arep => a -> arep
toBuiltin (ByteString -> BuiltinByteString)
-> (String -> ByteString) -> String -> BuiltinByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> ByteString
C.pack

-- | Arguments for the @"lock"@ endpoint
data LockArgs =
    LockArgs
        { LockArgs -> GameParam
lockArgsGameParam :: GameParam
        -- ^ The parameters for parameterizing the validator.
        , LockArgs -> String
lockArgsSecret    :: Haskell.String -- SecretArgument Haskell.String
        -- ^ The secret
        , LockArgs -> Value
lockArgsValue     :: Value
        -- ^ Value that is locked by the contract initially
        } deriving stock (Int -> LockArgs -> ShowS
[LockArgs] -> ShowS
LockArgs -> String
(Int -> LockArgs -> ShowS)
-> (LockArgs -> String) -> ([LockArgs] -> ShowS) -> Show LockArgs
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [LockArgs] -> ShowS
$cshowList :: [LockArgs] -> ShowS
show :: LockArgs -> String
$cshow :: LockArgs -> String
showsPrec :: Int -> LockArgs -> ShowS
$cshowsPrec :: Int -> LockArgs -> ShowS
Haskell.Show, (forall x. LockArgs -> Rep LockArgs x)
-> (forall x. Rep LockArgs x -> LockArgs) -> Generic LockArgs
forall x. Rep LockArgs x -> LockArgs
forall x. LockArgs -> Rep LockArgs x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall x. Rep LockArgs x -> LockArgs
$cfrom :: forall x. LockArgs -> Rep LockArgs x
Generic)
          deriving anyclass ([LockArgs] -> Encoding
[LockArgs] -> Value
LockArgs -> Encoding
LockArgs -> Value
(LockArgs -> Value)
-> (LockArgs -> Encoding)
-> ([LockArgs] -> Value)
-> ([LockArgs] -> Encoding)
-> ToJSON LockArgs
forall a.
(a -> Value)
-> (a -> Encoding)
-> ([a] -> Value)
-> ([a] -> Encoding)
-> ToJSON a
toEncodingList :: [LockArgs] -> Encoding
$ctoEncodingList :: [LockArgs] -> Encoding
toJSONList :: [LockArgs] -> Value
$ctoJSONList :: [LockArgs] -> Value
toEncoding :: LockArgs -> Encoding
$ctoEncoding :: LockArgs -> Encoding
toJSON :: LockArgs -> Value
$ctoJSON :: LockArgs -> Value
ToJSON, Value -> Parser [LockArgs]
Value -> Parser LockArgs
(Value -> Parser LockArgs)
-> (Value -> Parser [LockArgs]) -> FromJSON LockArgs
forall a.
(Value -> Parser a) -> (Value -> Parser [a]) -> FromJSON a
parseJSONList :: Value -> Parser [LockArgs]
$cparseJSONList :: Value -> Parser [LockArgs]
parseJSON :: Value -> Parser LockArgs
$cparseJSON :: Value -> Parser LockArgs
FromJSON)

-- | Arguments for the @"guess"@ endpoint
data GuessArgs =
    GuessArgs
        { GuessArgs -> GameParam
guessArgsGameParam :: GameParam
        -- ^ The parameters for parameterizing the validator.
        , GuessArgs -> String
guessArgsSecret    :: Haskell.String
        -- ^ The guess
        } deriving stock (Int -> GuessArgs -> ShowS
[GuessArgs] -> ShowS
GuessArgs -> String
(Int -> GuessArgs -> ShowS)
-> (GuessArgs -> String)
-> ([GuessArgs] -> ShowS)
-> Show GuessArgs
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [GuessArgs] -> ShowS
$cshowList :: [GuessArgs] -> ShowS
show :: GuessArgs -> String
$cshow :: GuessArgs -> String
showsPrec :: Int -> GuessArgs -> ShowS
$cshowsPrec :: Int -> GuessArgs -> ShowS
Haskell.Show, (forall x. GuessArgs -> Rep GuessArgs x)
-> (forall x. Rep GuessArgs x -> GuessArgs) -> Generic GuessArgs
forall x. Rep GuessArgs x -> GuessArgs
forall x. GuessArgs -> Rep GuessArgs x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall x. Rep GuessArgs x -> GuessArgs
$cfrom :: forall x. GuessArgs -> Rep GuessArgs x
Generic)
          deriving anyclass ([GuessArgs] -> Encoding
[GuessArgs] -> Value
GuessArgs -> Encoding
GuessArgs -> Value
(GuessArgs -> Value)
-> (GuessArgs -> Encoding)
-> ([GuessArgs] -> Value)
-> ([GuessArgs] -> Encoding)
-> ToJSON GuessArgs
forall a.
(a -> Value)
-> (a -> Encoding)
-> ([a] -> Value)
-> ([a] -> Encoding)
-> ToJSON a
toEncodingList :: [GuessArgs] -> Encoding
$ctoEncodingList :: [GuessArgs] -> Encoding
toJSONList :: [GuessArgs] -> Value
$ctoJSONList :: [GuessArgs] -> Value
toEncoding :: GuessArgs -> Encoding
$ctoEncoding :: GuessArgs -> Encoding
toJSON :: GuessArgs -> Value
$ctoJSON :: GuessArgs -> Value
ToJSON, Value -> Parser [GuessArgs]
Value -> Parser GuessArgs
(Value -> Parser GuessArgs)
-> (Value -> Parser [GuessArgs]) -> FromJSON GuessArgs
forall a.
(Value -> Parser a) -> (Value -> Parser [a]) -> FromJSON a
parseJSONList :: Value -> Parser [GuessArgs]
$cparseJSONList :: Value -> Parser [GuessArgs]
parseJSON :: Value -> Parser GuessArgs
$cparseJSON :: Value -> Parser GuessArgs
FromJSON)

-- | The "lock" contract endpoint. See note [Contract endpoints]
lock :: AsContractError e => Promise () GameSchema e ()
lock :: Promise () GameSchema e ()
lock = forall a w (s :: Row *) e b.
(HasEndpoint "lock" a s, AsContractError e, FromJSON a) =>
(a -> Contract w s e b) -> Promise w s e b
forall (l :: Symbol) a w (s :: Row *) e b.
(HasEndpoint l a s, AsContractError e, FromJSON a) =>
(a -> Contract w s e b) -> Promise w s e b
endpoint @"lock" ((LockArgs
  -> Contract
       ()
       ('R
          '[ "guess" ':-> (EndpointValue GuessArgs, ActiveEndpoint),
             "lock" ':-> (EndpointValue LockArgs, ActiveEndpoint)])
       e
       ())
 -> Promise
      ()
      ('R
         '[ "guess" ':-> (EndpointValue GuessArgs, ActiveEndpoint),
            "lock" ':-> (EndpointValue LockArgs, ActiveEndpoint)])
      e
      ())
-> (LockArgs
    -> Contract
         ()
         ('R
            '[ "guess" ':-> (EndpointValue GuessArgs, ActiveEndpoint),
               "lock" ':-> (EndpointValue LockArgs, ActiveEndpoint)])
         e
         ())
-> Promise
     ()
     ('R
        '[ "guess" ':-> (EndpointValue GuessArgs, ActiveEndpoint),
           "lock" ':-> (EndpointValue LockArgs, ActiveEndpoint)])
     e
     ()
forall a b. (a -> b) -> a -> b
$ \LockArgs { GameParam
lockArgsGameParam :: GameParam
lockArgsGameParam :: LockArgs -> GameParam
lockArgsGameParam, String
lockArgsSecret :: String
lockArgsSecret :: LockArgs -> String
lockArgsSecret, Value
lockArgsValue :: Value
lockArgsValue :: LockArgs -> Value
lockArgsValue } -> do
    forall a w (s :: Row *) e. ToJSON a => a -> Contract w s e ()
forall w (s :: Row *) e.
ToJSON String =>
String -> Contract w s e ()
logInfo @Haskell.String (String
 -> Contract
      ()
      ('R
         '[ "guess" ':-> (EndpointValue GuessArgs, ActiveEndpoint),
            "lock" ':-> (EndpointValue LockArgs, ActiveEndpoint)])
      e
      ())
-> String
-> Contract
     ()
     ('R
        '[ "guess" ':-> (EndpointValue GuessArgs, ActiveEndpoint),
           "lock" ':-> (EndpointValue LockArgs, ActiveEndpoint)])
     e
     ()
forall a b. (a -> b) -> a -> b
$ String
"Pay " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> Value -> String
forall a. Show a => a -> String
Haskell.show Value
lockArgsValue String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
" to the script"
    let lookups :: ScriptLookups Game
lookups = TypedValidator Game -> ScriptLookups Game
forall a. TypedValidator a -> ScriptLookups a
Constraints.typedValidatorLookups (GameParam -> TypedValidator Game
gameInstance GameParam
lockArgsGameParam)
        tx :: TxConstraints ClearString HashedString
tx = HashedString -> Value -> TxConstraints ClearString HashedString
forall o i. o -> Value -> TxConstraints i o
Constraints.mustPayToTheScriptWithDatumInTx (String -> HashedString
hashString String
lockArgsSecret) Value
lockArgsValue
    ScriptLookups Game
-> TxConstraints (RedeemerType Game) (DatumType Game)
-> Contract
     ()
     ('R
        '[ "guess" ':-> (EndpointValue GuessArgs, ActiveEndpoint),
           "lock" ':-> (EndpointValue LockArgs, ActiveEndpoint)])
     e
     UnbalancedTx
forall a w (s :: Row *) e.
(ToData (RedeemerType a), FromData (DatumType a),
 ToData (DatumType a), AsContractError e) =>
ScriptLookups a
-> TxConstraints (RedeemerType a) (DatumType a)
-> Contract w s e UnbalancedTx
mkTxConstraints ScriptLookups Game
lookups TxConstraints (RedeemerType Game) (DatumType Game)
TxConstraints ClearString HashedString
tx Contract
  ()
  ('R
     '[ "guess" ':-> (EndpointValue GuessArgs, ActiveEndpoint),
        "lock" ':-> (EndpointValue LockArgs, ActiveEndpoint)])
  e
  UnbalancedTx
-> (UnbalancedTx
    -> Contract
         ()
         ('R
            '[ "guess" ':-> (EndpointValue GuessArgs, ActiveEndpoint),
               "lock" ':-> (EndpointValue LockArgs, ActiveEndpoint)])
         e
         UnbalancedTx)
-> Contract
     ()
     ('R
        '[ "guess" ':-> (EndpointValue GuessArgs, ActiveEndpoint),
           "lock" ':-> (EndpointValue LockArgs, ActiveEndpoint)])
     e
     UnbalancedTx
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= UnbalancedTx
-> Contract
     ()
     ('R
        '[ "guess" ':-> (EndpointValue GuessArgs, ActiveEndpoint),
           "lock" ':-> (EndpointValue LockArgs, ActiveEndpoint)])
     e
     UnbalancedTx
forall w (s :: Row *) e.
AsContractError e =>
UnbalancedTx -> Contract w s e UnbalancedTx
adjustUnbalancedTx Contract
  ()
  ('R
     '[ "guess" ':-> (EndpointValue GuessArgs, ActiveEndpoint),
        "lock" ':-> (EndpointValue LockArgs, ActiveEndpoint)])
  e
  UnbalancedTx
-> (UnbalancedTx
    -> Contract
         ()
         ('R
            '[ "guess" ':-> (EndpointValue GuessArgs, ActiveEndpoint),
               "lock" ':-> (EndpointValue LockArgs, ActiveEndpoint)])
         e
         ())
-> Contract
     ()
     ('R
        '[ "guess" ':-> (EndpointValue GuessArgs, ActiveEndpoint),
           "lock" ':-> (EndpointValue LockArgs, ActiveEndpoint)])
     e
     ()
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= UnbalancedTx
-> Contract
     ()
     ('R
        '[ "guess" ':-> (EndpointValue GuessArgs, ActiveEndpoint),
           "lock" ':-> (EndpointValue LockArgs, ActiveEndpoint)])
     e
     ()
forall w (s :: Row *) e.
AsContractError e =>
UnbalancedTx -> Contract w s e ()
yieldUnbalancedTx

-- | The "guess" contract endpoint. See note [Contract endpoints]
guess :: AsContractError e => Promise () GameSchema e ()
guess :: Promise () GameSchema e ()
guess = forall a w (s :: Row *) e b.
(HasEndpoint "guess" a s, AsContractError e, FromJSON a) =>
(a -> Contract w s e b) -> Promise w s e b
forall (l :: Symbol) a w (s :: Row *) e b.
(HasEndpoint l a s, AsContractError e, FromJSON a) =>
(a -> Contract w s e b) -> Promise w s e b
endpoint @"guess" ((GuessArgs
  -> Contract
       ()
       ('R
          '[ "guess" ':-> (EndpointValue GuessArgs, ActiveEndpoint),
             "lock" ':-> (EndpointValue LockArgs, ActiveEndpoint)])
       e
       ())
 -> Promise
      ()
      ('R
         '[ "guess" ':-> (EndpointValue GuessArgs, ActiveEndpoint),
            "lock" ':-> (EndpointValue LockArgs, ActiveEndpoint)])
      e
      ())
-> (GuessArgs
    -> Contract
         ()
         ('R
            '[ "guess" ':-> (EndpointValue GuessArgs, ActiveEndpoint),
               "lock" ':-> (EndpointValue LockArgs, ActiveEndpoint)])
         e
         ())
-> Promise
     ()
     ('R
        '[ "guess" ':-> (EndpointValue GuessArgs, ActiveEndpoint),
           "lock" ':-> (EndpointValue LockArgs, ActiveEndpoint)])
     e
     ()
forall a b. (a -> b) -> a -> b
$ \GuessArgs { GameParam
guessArgsGameParam :: GameParam
guessArgsGameParam :: GuessArgs -> GameParam
guessArgsGameParam, String
guessArgsSecret :: String
guessArgsSecret :: GuessArgs -> String
guessArgsSecret } -> do
    -- Wait for script to have a UTxO of a least 1 lovelace
    String
-> Contract
     ()
     ('R
        '[ "guess" ':-> (EndpointValue GuessArgs, ActiveEndpoint),
           "lock" ':-> (EndpointValue LockArgs, ActiveEndpoint)])
     e
     ()
forall a w (s :: Row *) e. ToJSON a => a -> Contract w s e ()
logInfo @Haskell.String String
"Waiting for script to have a UTxO of at least 1 lovelace"
    Map TxOutRef DecoratedTxOut
utxos <- CardanoAddress
-> Value
-> Contract
     ()
     ('R
        '[ "guess" ':-> (EndpointValue GuessArgs, ActiveEndpoint),
           "lock" ':-> (EndpointValue LockArgs, ActiveEndpoint)])
     e
     (Map TxOutRef DecoratedTxOut)
forall w (s :: Row *) e.
AsContractError e =>
CardanoAddress
-> Value -> Contract w s e (Map TxOutRef DecoratedTxOut)
fundsAtAddressGeq (GameParam -> CardanoAddress
gameAddress GameParam
guessArgsGameParam) (Integer -> Value
C.lovelaceValueOf Integer
1)

    let lookups :: ScriptLookups Game
lookups = TypedValidator Game -> ScriptLookups Game
forall a. TypedValidator a -> ScriptLookups a
Constraints.typedValidatorLookups (GameParam -> TypedValidator Game
gameInstance GameParam
guessArgsGameParam)
               ScriptLookups Game -> ScriptLookups Game -> ScriptLookups Game
forall a. Semigroup a => a -> a -> a
Haskell.<> Map TxOutRef DecoratedTxOut -> ScriptLookups Game
forall a. Map TxOutRef DecoratedTxOut -> ScriptLookups a
Constraints.unspentOutputs Map TxOutRef DecoratedTxOut
utxos
        redeemer :: ClearString
redeemer = String -> ClearString
clearString String
guessArgsSecret
        tx :: TxConstraints ClearString HashedString
tx       = Map TxOutRef DecoratedTxOut
-> ClearString -> TxConstraints ClearString HashedString
forall i o. Map TxOutRef DecoratedTxOut -> i -> TxConstraints i o
Constraints.spendUtxosFromTheScript Map TxOutRef DecoratedTxOut
utxos ClearString
redeemer

    UnbalancedTx
unbalancedTx <- ScriptLookups Game
-> TxConstraints (RedeemerType Game) (DatumType Game)
-> Contract
     ()
     ('R
        '[ "guess" ':-> (EndpointValue GuessArgs, ActiveEndpoint),
           "lock" ':-> (EndpointValue LockArgs, ActiveEndpoint)])
     e
     UnbalancedTx
forall a w (s :: Row *) e.
(ToData (RedeemerType a), FromData (DatumType a),
 ToData (DatumType a), AsContractError e) =>
ScriptLookups a
-> TxConstraints (RedeemerType a) (DatumType a)
-> Contract w s e UnbalancedTx
mkTxConstraints ScriptLookups Game
lookups TxConstraints (RedeemerType Game) (DatumType Game)
TxConstraints ClearString HashedString
tx
    UnbalancedTx
-> Contract
     ()
     ('R
        '[ "guess" ':-> (EndpointValue GuessArgs, ActiveEndpoint),
           "lock" ':-> (EndpointValue LockArgs, ActiveEndpoint)])
     e
     ()
forall w (s :: Row *) e.
AsContractError e =>
UnbalancedTx -> Contract w s e ()
yieldUnbalancedTx UnbalancedTx
unbalancedTx

-- | Find the secret word in the Datum of the UTxOs
findSecretWordValue :: Map TxOutRef DecoratedTxOut -> Maybe HashedString
findSecretWordValue :: Map TxOutRef DecoratedTxOut -> Maybe HashedString
findSecretWordValue =
  [HashedString] -> Maybe HashedString
forall a. [a] -> Maybe a
listToMaybe ([HashedString] -> Maybe HashedString)
-> (Map TxOutRef DecoratedTxOut -> [HashedString])
-> Map TxOutRef DecoratedTxOut
-> Maybe HashedString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Maybe HashedString] -> [HashedString]
forall a. [Maybe a] -> [a]
catMaybes ([Maybe HashedString] -> [HashedString])
-> (Map TxOutRef DecoratedTxOut -> [Maybe HashedString])
-> Map TxOutRef DecoratedTxOut
-> [HashedString]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Map TxOutRef (Maybe HashedString) -> [Maybe HashedString]
forall k a. Map k a -> [a]
Map.elems (Map TxOutRef (Maybe HashedString) -> [Maybe HashedString])
-> (Map TxOutRef DecoratedTxOut
    -> Map TxOutRef (Maybe HashedString))
-> Map TxOutRef DecoratedTxOut
-> [Maybe HashedString]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (DecoratedTxOut -> Maybe HashedString)
-> Map TxOutRef DecoratedTxOut -> Map TxOutRef (Maybe HashedString)
forall a b k. (a -> b) -> Map k a -> Map k b
Map.map DecoratedTxOut -> Maybe HashedString
secretWordValue

-- | Extract the secret word in the Datum of a given transaction output is possible
secretWordValue :: DecoratedTxOut -> Maybe HashedString
secretWordValue :: DecoratedTxOut -> Maybe HashedString
secretWordValue DecoratedTxOut
o = do
  Datum BuiltinData
d <- DecoratedTxOut
o DecoratedTxOut
-> Getting (First Datum) DecoratedTxOut Datum -> Maybe Datum
forall s a. s -> Getting (First a) s a -> Maybe a
^? ((DatumHash, DatumFromQuery)
 -> Const (First Datum) (DatumHash, DatumFromQuery))
-> DecoratedTxOut -> Const (First Datum) DecoratedTxOut
Traversal' DecoratedTxOut (DatumHash, DatumFromQuery)
decoratedTxOutDatum (((DatumHash, DatumFromQuery)
  -> Const (First Datum) (DatumHash, DatumFromQuery))
 -> DecoratedTxOut -> Const (First Datum) DecoratedTxOut)
-> ((Datum -> Const (First Datum) Datum)
    -> (DatumHash, DatumFromQuery)
    -> Const (First Datum) (DatumHash, DatumFromQuery))
-> Getting (First Datum) DecoratedTxOut Datum
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (DatumFromQuery -> Const (First Datum) DatumFromQuery)
-> (DatumHash, DatumFromQuery)
-> Const (First Datum) (DatumHash, DatumFromQuery)
forall s t a b. Field2 s t a b => Lens s t a b
_2 ((DatumFromQuery -> Const (First Datum) DatumFromQuery)
 -> (DatumHash, DatumFromQuery)
 -> Const (First Datum) (DatumHash, DatumFromQuery))
-> ((Datum -> Const (First Datum) Datum)
    -> DatumFromQuery -> Const (First Datum) DatumFromQuery)
-> (Datum -> Const (First Datum) Datum)
-> (DatumHash, DatumFromQuery)
-> Const (First Datum) (DatumHash, DatumFromQuery)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Datum -> Const (First Datum) Datum)
-> DatumFromQuery -> Const (First Datum) DatumFromQuery
Traversal' DatumFromQuery Datum
datumInDatumFromQuery
  BuiltinData -> Maybe HashedString
forall a. FromData a => BuiltinData -> Maybe a
PlutusTx.fromBuiltinData BuiltinData
d

contract :: AsContractError e => Contract () GameSchema e ()
contract :: Contract () GameSchema e ()
contract = do
    String
-> Contract
     ()
     ('R
        '[ "guess" ':-> (EndpointValue GuessArgs, ActiveEndpoint),
           "lock" ':-> (EndpointValue LockArgs, ActiveEndpoint)])
     e
     ()
forall a w (s :: Row *) e. ToJSON a => a -> Contract w s e ()
logInfo @Haskell.String String
"Waiting for lock or guess endpoint..."
    [Promise
   ()
   ('R
      '[ "guess" ':-> (EndpointValue GuessArgs, ActiveEndpoint),
         "lock" ':-> (EndpointValue LockArgs, ActiveEndpoint)])
   e
   ()]
-> Contract
     ()
     ('R
        '[ "guess" ':-> (EndpointValue GuessArgs, ActiveEndpoint),
           "lock" ':-> (EndpointValue LockArgs, ActiveEndpoint)])
     e
     ()
forall w (s :: Row *) e a. [Promise w s e a] -> Contract w s e a
selectList [Promise
  ()
  ('R
     '[ "guess" ':-> (EndpointValue GuessArgs, ActiveEndpoint),
        "lock" ':-> (EndpointValue LockArgs, ActiveEndpoint)])
  e
  ()
forall e. AsContractError e => Promise () GameSchema e ()
lock, Promise
  ()
  ('R
     '[ "guess" ':-> (EndpointValue GuessArgs, ActiveEndpoint),
        "lock" ':-> (EndpointValue LockArgs, ActiveEndpoint)])
  e
  ()
forall e. AsContractError e => Promise () GameSchema e ()
guess] Contract
  ()
  ('R
     '[ "guess" ':-> (EndpointValue GuessArgs, ActiveEndpoint),
        "lock" ':-> (EndpointValue LockArgs, ActiveEndpoint)])
  e
  ()
-> Contract
     ()
     ('R
        '[ "guess" ':-> (EndpointValue GuessArgs, ActiveEndpoint),
           "lock" ':-> (EndpointValue LockArgs, ActiveEndpoint)])
     e
     ()
-> Contract
     ()
     ('R
        '[ "guess" ':-> (EndpointValue GuessArgs, ActiveEndpoint),
           "lock" ':-> (EndpointValue LockArgs, ActiveEndpoint)])
     e
     ()
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Contract
  ()
  ('R
     '[ "guess" ':-> (EndpointValue GuessArgs, ActiveEndpoint),
        "lock" ':-> (EndpointValue LockArgs, ActiveEndpoint)])
  e
  ()
forall e. AsContractError e => Contract () GameSchema e ()
contract