Plutus Playground Smart Contract

Playground.hs

{-# LANGUAGE DataKinds             #-}
{-# LANGUAGE DeriveAnyClass        #-}
{-# LANGUAGE DeriveGeneric         #-}
{-# LANGUAGE DerivingStrategies    #-}
{-# LANGUAGE FlexibleContexts      #-}
{-# LANGUAGE LambdaCase            #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE NamedFieldPuns        #-}
{-# LANGUAGE NoImplicitPrelude     #-}
{-# LANGUAGE OverloadedStrings     #-}
{-# LANGUAGE TemplateHaskell       #-}
{-# LANGUAGE TypeApplications      #-}
{-# LANGUAGE TypeOperators         #-}
{-# LANGUAGE ViewPatterns          #-}
{-# OPTIONS_GHC -fno-ignore-interface-pragmas #-}
{-# OPTIONS_GHC -g -fplugin-opt PlutusTx.Plugin:coverage-all #-}
-- A game with two players. Player 1 thinks of a secret word
-- and uses its hash, and the game validator script, to lock
-- some funds (the prize) in a pay-to-script transaction output.
-- Player 2 guesses the word by attempting to spend the transaction
-- output. If the guess is correct, the validator script releases the funds.
-- If it isn't, the funds stay locked.
import Control.Lens (makeClassyPrisms, prism', review)
import Control.Monad (void)
import qualified Data.ByteString.Char8 as C
import Data.Map             as Map
import Data.Text            (Text)
import Data.Text qualified as T
import Data.Maybe (catMaybes)

import           Plutus.Contract              as Contract hiding (when)
import           Plutus.Contract.StateMachine (State (..), Void)
import           Plutus.Contract.StateMachine qualified as SM
import           Ledger.Scripts
import           Ledger.Typed.Tx
import           Ledger.Value
import           Ledger                       hiding (singleton)
import           Ledger.Ada                   as Ada
import           Ledger.Constraints           as Constraints
import qualified Ledger.Typed.Scripts         as Scripts
import           Plutus.Contract.StateMachine
import qualified PlutusTx
import           PlutusTx.Prelude             hiding (Semigroup (..), check,
                                               unless)
import           Prelude                      (Semigroup (..))
import qualified Prelude as Haskell

import Playground.Contract
------------------------------------------------------------
newtype ClearString = ClearString BuiltinByteString deriving newtype (Haskell.Show, Haskell.Eq, FromJSON, ToJSON, ToSchema)

PlutusTx.unstableMakeIsData ''ClearString
PlutusTx.makeLift ''ClearString


data CardType =
  Two | Three | Four | Five |
  Six | Seven | Eight | Nine |
  Ten | Jack | Queen | King | Ace
  deriving (Haskell.Show, Generic, FromJSON, ToJSON, ToSchema, Haskell.Eq, Haskell.Ord)

PlutusTx.unstableMakeIsData ''CardType
PlutusTx.makeLift ''CardType
  
data CardSuit =
  Hearts | Diamonds | Clubs | Spades
  deriving (Haskell.Show, Generic, FromJSON, ToJSON, ToSchema, Haskell.Eq, Haskell.Ord)

PlutusTx.unstableMakeIsData ''CardSuit
PlutusTx.makeLift ''CardSuit

data GameStatus = Waiting | Playing | Finished deriving (Haskell.Show, Generic, FromJSON, ToJSON, ToSchema, Haskell.Eq, Haskell.Ord)

PlutusTx.unstableMakeIsData ''GameStatus
PlutusTx.makeLift ''GameStatus

data PlayerTurn = Host | Guest deriving (Haskell.Show, Generic, FromJSON, ToJSON, ToSchema, Haskell.Eq, Haskell.Ord)

PlutusTx.unstableMakeIsData ''PlayerTurn
PlutusTx.makeLift ''PlayerTurn

data GameState = GameState {gameName :: ClearString, 
                            hostPlayer :: ClearString, 
                            hostHand :: [(CardType, CardSuit)],
                            hostScore :: Integer,
                            guestPlayer :: Maybe ClearString,
                            guestHand :: [(CardType, CardSuit)],
                            guestScore :: Integer, 
                            turn :: PlayerTurn, 
                            status :: GameStatus} deriving (Haskell.Show, Generic, FromJSON, ToJSON, ToSchema, Haskell.Eq)

PlutusTx.makeIsDataIndexed ''GameState [('GameState, 1)]
PlutusTx.makeLift ''GameState

data GameRedeemer = GameRedeemer 
        { name :: ClearString,
          stake     :: Value
        }
        deriving stock (Haskell.Eq, Haskell.Show, Generic)
        deriving anyclass (ToJSON, FromJSON, ToSchema)

PlutusTx.unstableMakeIsData ''GameRedeemer
PlutusTx.makeLift ''GameRedeemer

type GameSchema =
        Endpoint "new" GameParams
        .\/ Endpoint "join" GameParams

data Game
instance Scripts.ValidatorTypes Game where
    type instance RedeemerType Game = GameRedeemer
    type instance DatumType Game = GameState


-- create a redeemer script for the guessing game by lifting the
-- string to its on-chain representation
clearString :: Haskell.String -> ClearString
clearString = ClearString . toBuiltin . C.pack


{-# INLINABLE transition #-}
transition :: State GameState -> GameRedeemer -> Maybe (TxConstraints Void Void, State GameState)
transition s r = case (stateValue s, stateData s, r) of
    (v, gs, (GameRedeemer{ name=name, stake=stake}))
        | v == stake         -> Just ( Constraints.mustProduceAtLeast (v + stake) 
                                                     , State (initialGameState name (clearString "player2")) $ stake + v
                                                     )
    _                                        -> Nothing


{-# INLINABLE final #-}
final :: GameState -> Bool
final (GameState{status=Finished}) = True
final _        = False

--{-# INLINABLE check #-}
checkValid :: GameState -> GameRedeemer -> ScriptContext -> Bool
checkValid _ _ _ = True

{-# INLINABLE gameStateMachine #-}
gameStateMachine :: GameStateMachine
gameStateMachine = SM.StateMachine
    { smTransition  = transition
    , smFinal       = final
    , smCheck       = checkValid
    , smThreadToken = Nothing
    }

{-# INLINABLE mkGameValidator #-}
mkGameValidator :: Scripts.ValidatorType GameStateMachine
mkGameValidator = SM.mkValidator gameStateMachine

type GameStateMachine = StateMachine GameState GameRedeemer

gameInst :: Scripts.TypedValidator GameStateMachine
gameInst = Scripts.mkTypedValidator @GameStateMachine
    $$(PlutusTx.compile [|| mkGameValidator ||])
    $$(PlutusTx.compile [|| wrap ||])
    where
        wrap = Scripts.wrapValidator

-- TODO: implement custom chooser
gameClient :: ClearString -> SM.StateMachineClient GameState GameRedeemer
gameClient name = mkSMClient (StateMachineInstance gameStateMachine gameInst) (gameSelector name)

mkSMClient :: SM.StateMachineInstance state input -> 
            ([OnChainState state input] -> Either SMContractError (OnChainState state input)) 
            -> StateMachineClient state input
mkSMClient inst c = StateMachineClient { scInstance = inst, scChooser=c}

gameSelector ::
    forall state input
    . ClearString -> [OnChainState state input]
    -> Either SMContractError (OnChainState state input)
gameSelector name states =
    let gameExists OnChainState{ocsTxOut=TypedScriptTxOut{tyTxOutTxOut=TxOut{txOutValue}}} = True in
    case Haskell.filter gameExists states of
        [x] -> Right x
        xs ->
            let msg = Haskell.unwords ["Found", Haskell.show (length xs), " outputs, none with name of ", Haskell.show name]
            in Left (ChooserError (T.pack msg))

--  | Parameters for the "guess" endpoint
---newtype GuessParams = GuessParams
---    { guessWord :: Haskell.String
---    }
---    deriving stock (Haskell.Eq, Haskell.Show, Generic)
---    deriving anyclass (FromJSON, ToJSON, ToSchema, ToArgument)

data GameParams = GameParams 
        { nameParam :: Haskell.String,
          stakeParam     :: Value
        }
        deriving stock (Haskell.Eq, Haskell.Show, Generic)
        deriving anyclass (ToJSON, FromJSON, ToSchema, ToArgument)

initialGameState :: ClearString -> ClearString -> GameState
initialGameState n p = GameState {gameName=n, hostPlayer=p, hostHand=[], hostScore=0, guestPlayer=Nothing, guestHand=[], guestScore=0, turn=Host, status=Waiting}


mapSMError' :: Contract w s SM.SMContractError a -> Contract w s Text a
mapSMError' = mapError $ T.pack . Haskell.show

mapContractError'  :: Contract w s ContractError a -> Contract w s Text a
mapContractError'  = mapError $ T.pack . Haskell.show


-- | The "new" contract endpoint. See note [Contract endpoints]
--new :: AsContractError e => Promise () GameSchema e ()
--new = endpoint @"new" @GameParams $ \(GameParams name amt) -> do
--    logInfo @Haskell.String $ "Pay " <> Haskell.show amt <> " to the script"
--    let tx = Constraints.mustPayToTheScript (initialGameState (clearString name) (clearString "player1")) amt
--    void (submitTxConstraints gameInstance tx)

new :: Promise () GameSchema T.Text ()
new = endpoint @"new" $ \(GameParams name amt) -> do
    logInfo @Haskell.String $ "Pay " <> Haskell.show amt <> " to the script"
    void $ mapSMError' $ SM.runInitialise (gameClient $ clearString name) (initialGameState (clearString name) (clearString "player1")) amt

-- | The "join" contract endpoint. See note [Contract endpoints]
--join :: AsContractError e => Promise () GameSchema e ()
--join = endpoint @"join" @GameParams $ \(GameParams name amt) -> do
    -- Wait for script to have a UTxO of a least 1 lovelace
 --   logInfo @Haskell.String "Waiting for script to have a UTxO of at least 1 lovelace"
 --   utxos <- fundsAtAddressGeq gameAddress (Ada.lovelaceValueOf 1)

  --  logInfo @Haskell.String $ "Pay " <> Haskell.show amt <> " to the script"
  --  let tx         = Constraints.mustPayToTheScript (initialGameState (clearString name) (clearString "player2")) amt
  --  void (submitTxConstraints gameInstance tx)

join :: Promise () GameSchema T.Text ()
join = endpoint @"join" $ \(GameParams name amt) -> do
    logInfo @Haskell.String $ "Pay " <> Haskell.show amt <> " to the script"
    logInfo @Haskell.String $ "Joining game " ++ name
    void $ mapSMError' $ SM.runStep (gameClient $ clearString name) (GameRedeemer{ name=clearString name, stake=amt})

{- Note [Contract endpoints]

A contract endpoint is a function that uses the wallet API to interact with the
blockchain. We can look at contract endpoints from two different points of view.

1. Contract users

Contract endpoints are the visible interface of the contract. They provide a
UI (HTML form) for entering the parameters of the actions we may take as part
of the contract.

2. Contract authors

As contract authors we define endpoints as functions that return a value of
type 'MockWallet ()'. This type indicates that the function uses the wallet API
to produce and spend transaction outputs on the blockchain.

Endpoints can have any number of parameters: 'lock' has two
parameters, 'guess' has one and 'startGame' has none. For each endpoint we
include a call to 'mkFunction' at the end of the contract definition. This
causes the Haskell compiler to generate a schema for the endpoint. The Plutus
Playground then uses this schema to present an HTML form to the user where the
parameters can be entered.

-}

-- | 'MyError' has a constructor for each type of error that our contract
 --   can throw. The 'AContractError' constructor wraps a 'ContractError'.
data GameError = TextError Text
                | GameContractError ContractError
                | GameSMError SM.SMContractError
                deriving Haskell.Show

makeClassyPrisms ''GameError

instance AsContractError GameError where
    _ContractError = _GameContractError . _ContractError

instance SM.AsSMContractError GameError where
    _SMContractError = _GameSMError . SM._SMContractError
    
instance AsGameError Text where
    _GameError = prism' (T.pack . Haskell.show) (const Nothing)

-- | Top-level contract, exposing both endpoints.
game :: Contract () GameSchema T.Text ()
game = selectList [new, join] >> game

endpoints :: Contract () GameSchema T.Text ()
endpoints = game

mkSchemaDefinitions ''GameSchema

$(mkKnownCurrencies [])

Simulation.json

[0,[{"simulationWallets":[{"simulatorWalletWallet":{"getWallet":1},"simulatorWalletBalance":{"getValue":[[{"unCurrencySymbol":""},[[{"unTokenName":""},100000000]]]]}},{"simulatorWalletWallet":{"getWallet":2},"simulatorWalletBalance":{"getValue":[[{"unCurrencySymbol":""},[[{"unTokenName":""},100000000]]]]}}],"simulationName":"Simulation 1","simulationId":1,"simulationActions":[{"tag":"AddBlocks","blocks":10}]}]]