SCP-3196: Added a new Game contract (simplified version of GameStateM…

…achine)

* Parameterized the GameStateMachine contract

* Added Game contract which is compatible with remote wallets by using `yieldUnbalancedTx`.

* Added the contract in the plutus-pab-executables builtin contract

doc/plutus-doc.cabal

@@ -61,6 +61,7 @@ executable doc-doctests
       template-haskell >=2.13.0.0,
       bytestring -any,
       cardano-api -any,
+      data-default -any,
       flat -any,
       plutus-core -any,
       plutus-chain-index-core -any,

doc/plutus/tutorials/GameModel.hs

@@ -57,6 +57,18 @@ import Plutus.Trace.Emulator as Trace
 import Plutus.Contract.Secrets
 -- END import Contract.Security
 
+-- START import TimeSlot
+import Ledger.TimeSlot qualified as TimeSlot
+-- END import TimeSlot
+
+-- START import Data.Default
+import Data.Default (Default (def))
+-- END import Data.Default
+
+-- START gameParam
+gameParam :: G.GameParam
+gameParam = G.GameParam (mockWalletPaymentPubKeyHash w1) (TimeSlot.scSlotZeroTime def)
+-- END gameParam
 
 -- * QuickCheck model
 
@@ -103,18 +115,21 @@ instance ContractModel GameModel where
     perform handle s cmd = case cmd of
         Lock w new val -> do
             callEndpoint @"lock" (handle $ WalletKey w)
-                         LockArgs{ lockArgsSecret = secretArg new
-                                 , lockArgsValue = Ada.lovelaceValueOf val }
+                LockArgs { lockArgsGameParam = gameParam
+                         , lockArgsSecret    = secretArg new
+                         , lockArgsValue     = Ada.lovelaceValueOf val
+                         }
             delay 2
         Guess w old new val -> do
             callEndpoint @"guess" (handle $ WalletKey w)
-                GuessArgs{ guessArgsOldSecret     = old
+                GuessArgs{ guessArgsGameParam     = gameParam
+                         , guessArgsOldSecret     = old
                          , guessArgsNewSecret     = secretArg new
                          , guessArgsValueTakenOut = Ada.lovelaceValueOf val }
             delay 1
         GiveToken w' -> do
             let w = fromJust (s ^. contractState . hasToken)
-            payToWallet w w' gameTokenVal
+            payToWallet w w' guessTokenVal
             delay 1
 -- END perform
 
@@ -125,8 +140,8 @@ instance ContractModel GameModel where
           hasToken      $= Just w
           currentSecret $= secret
           gameValue     $= val
-          mint gameTokenVal
-          deposit  w gameTokenVal
+          mint guessTokenVal
+          deposit  w guessTokenVal
         withdraw w $ Ada.lovelaceValueOf val
         wait 2
 
@@ -144,7 +159,7 @@ instance ContractModel GameModel where
 
     nextState (GiveToken w) = do
         w0 <- fromJust <$> viewContractState hasToken
-        transfer w0 w gameTokenVal
+        transfer w0 w guessTokenVal
         hasToken $= Just w
         wait 1
 
@@ -163,9 +178,9 @@ instance ContractModel GameModel where
 
 -- START precondition
     precondition s cmd = case cmd of
-            Lock _ _ v    -> tok == Nothing
+            Lock _ _ v    -> isNothing tok
             Guess w _ _ v -> tok == Just w && v <= val
-            GiveToken w   -> tok /= Nothing
+            GiveToken w   -> isJust tok
         where
             tok = s ^. contractState . hasToken
             val = s ^. contractState . gameValue
@@ -296,12 +311,12 @@ wallets :: [Wallet]
 wallets = [w1, w2, w3]
 -- END wallets
 
--- START gameTokenVal
-gameTokenVal :: Value
-gameTokenVal =
-    let sym = Scripts.forwardingMintingPolicyHash G.typedValidator
+-- START guessTokenVal
+guessTokenVal :: Value
+guessTokenVal =
+    let sym = Scripts.forwardingMintingPolicyHash $ G.typedValidator gameParam
     in G.token sym "guess"
--- END gameTokenVal
+-- END guessTokenVal
 
 -- START testLock v1
 testLock :: Property
@@ -353,8 +368,8 @@ v1_model = ()
         hasToken      $= Just w
         currentSecret $= secret
         gameValue     $= val
-        mint gameTokenVal
-        deposit  w gameTokenVal
+        mint guessTokenVal
+        deposit  w guessTokenVal
         withdraw w $ Ada.lovelaceValueOf val
 -- END nextState Lock v1
 -- START nextState Guess v1
@@ -370,13 +385,13 @@ v1_model = ()
 -- START nextState GiveToken v1
     nextState (GiveToken w) = do
         w0 <- fromJust <$> viewContractState hasToken
-        transfer w0 w gameTokenVal
+        transfer w0 w guessTokenVal
         hasToken $= Just w
 -- END nextState GiveToken v1
 
     precondition :: ModelState GameModel -> Action GameModel -> Bool
 -- START precondition v1
-    precondition s (GiveToken _) = tok /= Nothing
+    precondition s (GiveToken _) = isJust tok
         where
             tok = s ^. contractState . hasToken
     precondition s _             = True
@@ -387,16 +402,18 @@ v1_model = ()
     perform handle s cmd = case cmd of
         Lock w new val -> do
             callEndpoint @"lock" (handle $ WalletKey w)
-                         LockArgs{ lockArgsSecret = secretArg new
+                         LockArgs{ lockArgsGameParam = gameParam
+                                 , lockArgsSecret = secretArg new
                                  , lockArgsValue = Ada.lovelaceValueOf val}
         Guess w old new val -> do
             callEndpoint @"guess" (handle $ WalletKey w)
-                GuessArgs{ guessArgsOldSecret = old
+                GuessArgs{ guessArgsGameParam = gameParam
+                         , guessArgsOldSecret = old
                          , guessArgsNewSecret = secretArg new
                          , guessArgsValueTakenOut = Ada.lovelaceValueOf val}
         GiveToken w' -> do
             let w = fromJust (s ^. contractState . hasToken)
-            payToWallet w w' gameTokenVal
+            payToWallet w w' guessTokenVal
             return ()
 -- END perform v1
 
@@ -409,8 +426,8 @@ v2_model = ()
         hasToken      $= Just w
         currentSecret $= secret
         gameValue     $= val
-        mint gameTokenVal
-        deposit  w gameTokenVal
+        mint guessTokenVal
+        deposit  w guessTokenVal
         withdraw w $ Ada.lovelaceValueOf val
         wait 2
 -- END nextState Lock v2
@@ -425,9 +442,9 @@ v2_model = ()
     precondition :: ModelState GameModel -> Action GameModel -> Bool
 -- START precondition v2
     precondition s cmd = case cmd of
-            Lock _ _ _    -> tok == Nothing
-            Guess _ _ _ _ -> True
-            GiveToken _   -> tok /= Nothing
+            Lock {}     -> isNothing tok
+            Guess {}    -> True
+            GiveToken _ -> isJust tok
         where
             tok = s ^. contractState . hasToken
 -- END precondition v2
@@ -450,9 +467,9 @@ v3_model = ()
     precondition :: ModelState GameModel -> Action GameModel -> Bool
 -- START precondition v3
     precondition s cmd = case cmd of
-            Lock _ _ _    -> tok == Nothing
+            Lock {}       -> isNothing tok
             Guess w _ _ _ -> tok == Just w
-            GiveToken _   -> tok /= Nothing
+            GiveToken _   -> isJust tok
         where
             tok = s ^. contractState . hasToken
 -- END precondition v3

doc/plutus/tutorials/contract-testing.rst

@@ -92,23 +92,33 @@ we can define it as follows, applying a minting policy defined in the code under
 .. literalinclude:: GameModel.hs
    :start-after: START import Game
    :end-before: END import Game
+.. literalinclude:: GameModel.hs
+   :start-after: START import TimeSlot
+   :end-before: END import TimeSlot
+.. literalinclude:: GameModel.hs
+   :start-after: START import Data.Default
+   :end-before: END import Data.Default
+
+.. literalinclude:: GameModel.hs
+   :start-after: START gameParam
+   :end-before: END gameParam
 
 .. literalinclude:: GameModel.hs
-   :start-after: START gameTokenVal
-   :end-before: END gameTokenVal
+   :start-after: START guessTokenVal
+   :end-before: END guessTokenVal
 
 The value of the :term:`token` is (with long hash values abbreviated):
 
 .. code-block:: text
 
-  > gameTokenVal
+  > guessTokenVal
   Value (Map [(f687...,Map [(guess,1)])])
 
 We can even construct a ``Value`` containing an Ada and a game :term:`token`:
 
 .. code-block:: text
 
-  > Ada.lovelaceValueOf 1 <> gameTokenVal
+  > Ada.lovelaceValueOf 1 <> guessTokenVal
   Value (Map [(,Map [(,1)]),(f687...,Map [(guess,1)])])
 
 If you inspect the output closely, you will see that a ``Value``
@@ -511,6 +521,9 @@ contract end-points, using the API defined in the code under test, and
 transfer the game :term:`token` from one wallet to another as specified by
 ``GiveToken`` actions.
 
+.. literalinclude:: GameModel.hs
+   :start-after: START gameParam
+   :end-before: END gameParam
 .. literalinclude:: GameModel.hs
    :start-after: START perform v1
    :end-before: END perform v1
@@ -680,6 +693,10 @@ We can cause the emulator to delay a number of slots like this:
 
 We add a call to ``delay`` in each branch of :hsobj:`Plutus.Contract.Test.ContractModel.perform`:
 
+.. literalinclude:: GameModel.hs
+   :start-after: START gameParam
+   :end-before: END gameParam
+
 .. literalinclude:: GameModel.hs
    :start-after: START perform
    :end-before: END perform

plutus-pab-executables/examples/ContractExample.hs

@@ -18,6 +18,7 @@ module ContractExample(
 import Control.Monad.Freer
 import Data.Aeson (FromJSON, ToJSON)
 import Data.Default (Default (def))
+import Data.Text (Text)
 import GHC.Generics (Generic)
 import Prettyprinter
 
@@ -32,6 +33,7 @@ import Language.PureScript.Bridge.TypeParameters (A)
 import Ledger (TxId)
 import Playground.Types (FunctionSchema)
 import Plutus.Contracts.Currency qualified as Contracts.Currency
+import Plutus.Contracts.Game qualified as Contracts.Game
 import Plutus.Contracts.GameStateMachine qualified as Contracts.GameStateMachine
 import Plutus.Contracts.PingPong qualified as Contracts.PingPong
 import Plutus.Contracts.Prism.Mirror qualified as Contracts.Prism
@@ -49,6 +51,7 @@ import Schema (FormSchema)
 data ContractExample = UniswapInit
                      | UniswapOwner
                      | UniswapUser Contracts.Uniswap.Uniswap
+                     | Game
                      | GameStateMachine
                      | PayToWallet
                      | AtomicSwap
@@ -78,6 +81,7 @@ instance HasPSTypes ContractExample where
 instance HasDefinitions ContractExample where
     getDefinitions = [ UniswapInit
                      , UniswapOwner
+                     , Game
                      , GameStateMachine
                      , PayToWallet
                      , AtomicSwap
@@ -97,6 +101,7 @@ getContractExampleSchema = \case
     UniswapInit         -> Builtin.endpointsToSchemas @Empty
     UniswapUser _       -> Builtin.endpointsToSchemas @Contracts.Uniswap.UniswapUserSchema
     UniswapOwner        -> Builtin.endpointsToSchemas @Contracts.Uniswap.UniswapOwnerSchema
+    Game                -> Builtin.endpointsToSchemas @Contracts.Game.GameSchema
     GameStateMachine    -> Builtin.endpointsToSchemas @Contracts.GameStateMachine.GameStateMachineSchema
     PayToWallet         -> Builtin.endpointsToSchemas @Contracts.PayToWallet.PayToWalletSchema
     AtomicSwap          -> Builtin.endpointsToSchemas @Contracts.AtomicSwap.AtomicSwapSchema
@@ -114,6 +119,7 @@ getContractExample = \case
     UniswapInit         -> SomeBuiltin Contracts.Uniswap.setupTokens
     UniswapUser us      -> SomeBuiltin $ Contracts.Uniswap.userEndpoints us
     UniswapOwner        -> SomeBuiltin Contracts.Uniswap.ownerEndpoint
+    Game                -> SomeBuiltin (Contracts.Game.contract @Text)
     GameStateMachine    -> SomeBuiltin Contracts.GameStateMachine.contract
     PayToWallet         -> SomeBuiltin Contracts.PayToWallet.payToWallet
     AtomicSwap          -> SomeBuiltin Contracts.AtomicSwap.atomicSwap