Skip to content
Permalink
Browse files

use-cases: Add a 'GameStateMachine' contract

  • Loading branch information...
j-mueller committed Apr 15, 2019
1 parent e5199ef commit f940011d19ec718dee24f1cb21dc5dfccf65a597
@@ -16,7 +16,7 @@
- error: {lhs: "maybe mempty", rhs: "foldMap", name: "Use foldMap"}
- error: {lhs: "mconcat", rhs: "fold", name: "Generalize mconcat"}

- ignore: {name: Reduce duplication, within: [Language.PlutusCore.Renamer, Language.PlutusCore.Constant.Prelude, Language.PlutusCore.StdLib.Data.Bool, Language.PlutusCore.StdLib.Data.ChurchNat, Language.PlutusCore.StdLib.Data.Function, Language.PlutusCore.StdLib.Data.List, Language.PlutusCore.StdLib.Data.Sum, Language.PlutusCore.StdLib.Data.Nat, Language.PlutusCore.Pretty.Readable, Language.PlutusCore.Examples.Data.InterList, Language.PlutusCore.Examples.Data.TreeForest, Language.PlutusCore.Generators.Interesting, Language.PlutusTx.Compiler.Binders, Language.PlutusTx.Compiler.Type, Evaluation.CkMachine, Spec.Crowdfunding, Spec.Vesting, Spec.Actus, Language.PlutusTx.Lift, OptimizerSpec, TransformSpec, Tutorial.Solutions0Mockchain]}
- ignore: {name: Reduce duplication, within: [Language.PlutusCore.Renamer, Language.PlutusCore.Constant.Prelude, Language.PlutusCore.StdLib.Data.Bool, Language.PlutusCore.StdLib.Data.ChurchNat, Language.PlutusCore.StdLib.Data.Function, Language.PlutusCore.StdLib.Data.List, Language.PlutusCore.StdLib.Data.Sum, Language.PlutusCore.StdLib.Data.Nat, Language.PlutusCore.Pretty.Readable, Language.PlutusCore.Examples.Data.InterList, Language.PlutusCore.Examples.Data.TreeForest, Language.PlutusCore.Generators.Interesting, Language.PlutusTx.Compiler.Binders, Language.PlutusTx.Compiler.Type, Evaluation.CkMachine, Spec.Crowdfunding, Spec.Vesting, Spec.Actus, Language.PlutusTx.Lift, OptimizerSpec, TransformSpec, Tutorial.Solutions0Mockchain, Spec.GameStateMachine]}
- ignore: {name: Redundant $, within: [Evaluation.Constant.Success, Language.PlutusCore.Generators.Internal.TypedBuiltinGen]}
- ignore: {name: Redundant bracket, within: [Language.PlutusTx.TH]}
# this is rarely an improvement, also ignored in cardano
@@ -31,6 +31,7 @@ module Language.PlutusTx.Prelude (
isJust,
isNothing,
maybe,
mapMaybe,
-- * Lists
null,
map,
@@ -5,7 +5,7 @@
-- reusing functions.
module Language.PlutusTx.Prelude.Stage1 where

import Prelude (Bool (..), Int, (>))
import Prelude (Bool (..), Int, Maybe(..), (>))

import Language.PlutusTx.Prelude.Stage0

@@ -50,3 +50,11 @@ append = [|| \l r -> $$(foldr) (\x xs -> x:xs) r l ||]
--
filter :: Q (TExp ((a -> Bool) -> [a] -> [a] ))
filter = [|| \pred -> $$(foldr) (\e xs -> if pred e then e:xs else xs) [] ||]

-- | PlutusTx version of 'Data.Maybe.mapMaybe'.
--
-- >>> $$([|| $$(mapMaybe) (\i -> if i == 2 then Just '2' else Nothing) [1, 2, 3, 4] ||])
-- "2"
--
mapMaybe :: Q (TExp ((a -> Maybe b) -> [a] -> [b]))
mapMaybe = [|| \pred -> $$(foldr) (\e xs -> case pred e of { Just e' -> e':xs; Nothing -> xs}) [] ||]
@@ -25,6 +25,8 @@ library
Language.PlutusTx.Coordination.Contracts.Currency.Stage0
Language.PlutusTx.Coordination.Contracts.Future
Language.PlutusTx.Coordination.Contracts.Game
Language.PlutusTx.Coordination.Contracts.GameStateMachine
Language.PlutusTx.Coordination.Contracts.GameStateMachine.Stage0
Language.PlutusTx.Coordination.Contracts.MultiSig
Language.PlutusTx.Coordination.Contracts.PubKey
Language.PlutusTx.Coordination.Contracts.Vesting
@@ -58,6 +60,7 @@ test-suite plutus-use-cases-test
Spec.Currency
Spec.Future
Spec.Game
Spec.GameStateMachine
Spec.MultiSig
Spec.Size
Spec.Vesting
@@ -0,0 +1,219 @@
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE DataKinds #-}
{-# OPTIONS_GHC -O0 #-}
-- | A guessing game that
--
-- * Uses a state machine to keep track of the current secret word
-- * Uses a token to keep track of who is allowed to make a guess
--
module Language.PlutusTx.Coordination.Contracts.GameStateMachine(
startGame
, guess
, lock
, gameTokenVal
, gameValidator
) where

import qualified Data.Map as Map
import Data.Maybe (maybeToList)
import qualified Data.Set as Set
import qualified Data.Text as Text
import qualified Language.PlutusTx as PlutusTx
import qualified Language.PlutusTx.Prelude as P
import Ledger hiding (to)
import qualified Ledger.Ada as Ada
import Ledger.Value (TokenName)
import qualified Ledger.Value.TH as V
import qualified Ledger.Validation as Validation
import Wallet
import qualified Wallet as WAPI

import qualified Data.ByteString.Lazy.Char8 as C

import Language.PlutusTx.Coordination.Contracts.GameStateMachine.Stage0

data HashedString = HashedString (P.SizedByteString 32)

PlutusTx.makeLift ''HashedString

data ClearString = ClearString (P.SizedByteString 32)

PlutusTx.makeLift ''ClearString

-- | State of the guessing game
data GameState =
Initialised HashedString
-- ^ Initial state. In this state only the 'ForgeTokens' action is allowed.
| Locked TokenName HashedString
-- ^ Funds have been locked. In this state only the 'Guess' action is
-- allowed.

PlutusTx.makeLift ''GameState

-- | Inputs (actions)
data GameInput =
ForgeToken TokenName
-- ^ Forge the "guess" token
| Guess ClearString HashedString
-- ^ Make a guess and lock the remaining funds using a new secret word.

PlutusTx.makeLift ''GameInput

gameValidator :: ValidatorScript
gameValidator = ValidatorScript ($$(Ledger.compileScript [||
\(ds :: (GameState, Maybe GameInput)) (vs :: (GameState, Maybe GameInput)) (p :: PendingTx) ->

let

-- | Check whether a 'ClearString' is the preimage of a
-- 'HashedString'
checkGuess :: HashedString -> ClearString -> Bool
checkGuess (HashedString actual) (ClearString gss) =
$$(P.equalsByteString) actual ($$(P.sha2_256) gss)

-- | Given a 'TokeName', get the value that contains
-- exactly one token of that name
tokenVal :: TokenName -> V.Value
tokenVal tn =
let ownSymbol = $$(Validation.ownCurrencySymbol) p
in $$(V.singleton) ownSymbol tn 1

-- | Check whether the token that was forged at the beginning of the
-- contract is present in the pending transaction
tokenPresent :: TokenName -> Bool
tokenPresent tn =
let vSpent = $$(Validation.valueSpent) p
in $$(V.geq) vSpent (tokenVal tn)

-- | Check whether the value forged by the pending transaction 'p' is
-- equal to the argument.
checkForge :: Value -> Bool
checkForge vl = $$(V.eq) vl ($$(Validation.valueForged) p)

-- | Equality of 'GameState' valzes.
stateEq :: GameState -> GameState -> Bool
stateEq (Initialised (HashedString s)) (Initialised (HashedString s')) =
$$(P.equalsByteString) s s'
stateEq (Locked (V.TokenName n) (HashedString s)) (Locked (V.TokenName n') (HashedString s')) =
$$(P.and) ($$(P.equalsByteString) s s') ($$(P.equalsByteString) n n')
stateEq _ _ = $$(P.traceIfFalseH) "states not equal" False

-- | The transition function of the game's state machine
trans :: GameState -> GameInput -> GameState
trans (Initialised s) (ForgeToken tn) =
if checkForge (tokenVal tn)
then Locked tn s
else $$(P.error) ()
trans (Locked tn currentSecret) (Guess theGuess nextSecret) =
if $$(P.and)
(checkGuess currentSecret theGuess)
($$(P.and) (tokenPresent tn) (checkForge $$(V.zero)))
then Locked tn nextSecret
else $$(P.error) ()
trans _ _ = $$(P.traceH) "Invalid transition" ($$(P.error) ())

sm = StateMachine trans stateEq

in
$$(mkValidator) sm ds vs p

||]))

gameToken :: TokenName
gameToken = "guess"

-- | The 'Value' forged by the 'curValidator' contract
gameTokenVal :: Value
gameTokenVal =
let
-- see note [Obtaining the currency symbol]
cur = plcCurrencySymbol (Ledger.scriptAddress gameValidator)
in
$$(V.singleton) cur gameToken 1

-- | Make a guess, take out some funds, and lock the remaining 'Ada' with a new
-- secret
guess ::
(WalletAPI m, WalletDiagnostics m)
=> String
-- ^ The guess
-> String
-- ^ A new secret
-> Ada
-- ^ How much ada to take out
-> Ada
-- ^ How much to put back into the contract
-> m ()
guess gss newSecret keepAda restAda = do

let clear = ClearString (P.SizedByteString (C.pack gss))
addr = Ledger.scriptAddress gameValidator
scr = HashedString (plcSHA2_256 (P.SizedByteString (C.pack newSecret)))
let step = transition (Locked gameToken scr) (Guess clear scr)
ins <- WAPI.spendScriptOutputs addr gameValidator (RedeemerScript (Ledger.lifted step))
ownOutput <- WAPI.ownPubKeyTxOut (Ada.toValue keepAda <> gameTokenVal)

let scriptOut = scriptTxOut (Ada.toValue restAda) gameValidator (DataScript (Ledger.lifted step))

(i, own) <- createPaymentWithChange gameTokenVal

let tx = Ledger.Tx
{ txInputs = Set.union i (Set.fromList ins)
, txOutputs = [ownOutput, scriptOut] ++ maybeToList own
, txForge = $$(V.zero)
, txFee = Ada.zero
, txValidRange = defaultSlotRange
, txSignatures = Map.empty
}

WAPI.signTxAndSubmit_ tx

-- | Lock some funds in the guessing game. Produces the token that is required
-- when submitting a guess.
lock :: (WalletAPI m, WalletDiagnostics m) => String -> Ada -> m ()
lock initialWord adaVl = do
let secret = HashedString (plcSHA2_256 (P.SizedByteString (C.pack initialWord)))
addr = Ledger.scriptAddress gameValidator
state = initialState @GameState @GameInput (Initialised secret)
ds = DataScript (Ledger.lifted state)

-- 1. Create a transaction output with the value and the secret
payToScript_ defaultSlotRange addr (Ada.toValue adaVl) ds

-- 2. Define a trigger that fires when the first transaction (1.) is
-- placed on the chain.
let oneOrMore = WAPI.intervalFrom $ Ada.adaValueOf 1
trg1 = fundsAtAddressT addr oneOrMore

-- 3. Define a forge_ action that creates the token by and puts the contract
-- into its new state.
let forge :: (WalletAPI m, WalletDiagnostics m) => m ()
forge = do
ownOutput <- WAPI.ownPubKeyTxOut gameTokenVal
let step = transition (Locked gameToken secret) (ForgeToken gameToken)
scriptOut = scriptTxOut (Ada.toValue adaVl) gameValidator (DataScript (Ledger.lifted step))
redeemer = RedeemerScript (Ledger.lifted step)
ins <- WAPI.spendScriptOutputs addr gameValidator redeemer

let tx = Ledger.Tx
{ txInputs = Set.fromList ins
, txOutputs = [ownOutput, scriptOut]
, txForge = gameTokenVal
, txFee = Ada.zero
, txValidRange = defaultSlotRange
, txSignatures = Map.empty
}

WAPI.logMsg $ Text.pack $ "The forging transaction is: " <> show (Ledger.hashTx tx)
WAPI.signTxAndSubmit_ tx


registerOnce trg1 (EventHandler $ const forge)
pure ()

-- | Tell the wallet to start watching the address of the game script
startGame :: WalletAPI m => m ()
startGame = startWatching (Ledger.scriptAddress gameValidator)
@@ -0,0 +1,61 @@
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TemplateHaskell #-}
module Language.PlutusTx.Coordination.Contracts.GameStateMachine.Stage0(
StateMachine(..)
, mkValidator
, initialState
, transition
) where


import qualified Language.PlutusTx as P

import Ledger.Validation (PendingTx)
import qualified Ledger.Validation as V

import Language.Haskell.TH (Q, TExp)

-- | Specification of a state machine
data StateMachine s i = StateMachine {
smTransition :: s -> i -> s
, smStateEq :: s -> s -> Bool
}

initialState :: forall s i. s -> (s, Maybe i)
initialState s = (s, Nothing)

transition :: forall s i. s -> i -> (s, Maybe i)
transition newState input = (newState, Just input)

-- | Turn a transition function 's -> i -> s' into a validator script
mkValidator :: Q (TExp (StateMachine s i -> (s, Maybe i) -> (s, Maybe i) -> PendingTx -> ()))
mkValidator = [||
let
mkValidator' :: forall s i. StateMachine s i -> (s, Maybe i) -> (s, Maybe i) -> PendingTx -> ()
mkValidator' sm (currentState, _) (newState, Just input) p =
let
StateMachine trans sEq = sm
(vh, V.RedeemerHash rh) = $$(V.ownHashes) p
expectedState = trans currentState input

stateOk =
$$(P.traceIfFalseH) "State transition invalid - 'expectedState' not equal to 'newState'"
(sEq expectedState newState)

dataScriptHashOk =
let relevantOutputs =
$$(P.map) (\(ds, _) -> ds)
($$(V.scriptOutputsAt) vh p)
dsHashOk (V.DataScriptHash dh) = $$(P.equalsByteString) dh rh
in
$$(P.traceIfFalseH) "State transition invalid - data script hash not equal to redeemer hash"
($$(P.all) dsHashOk relevantOutputs)
in
if $$(P.and) stateOk dataScriptHashOk
then ()
else ($$(P.error) ($$(P.traceH) "State transition failed" ()))


in mkValidator'
||]
@@ -7,6 +7,7 @@ import qualified Spec.Future
import qualified Spec.Game
import qualified Spec.MultiSig
import qualified Spec.Vesting
import qualified Spec.GameStateMachine
import Test.Tasty
import Test.Tasty.Hedgehog (HedgehogTestLimit (..))

@@ -27,5 +28,6 @@ tests = localOption limit $ testGroup "use cases" [
Spec.Future.tests,
Spec.Game.tests,
Spec.MultiSig.tests,
Spec.Currency.tests
Spec.Currency.tests,
Spec.GameStateMachine.tests
]
Oops, something went wrong.

0 comments on commit f940011

Please sign in to comment.
You can’t perform that action at this time.