added solutions for week 2

README.md

@@ -41,6 +41,13 @@
   - Fix and complete the code in the [Homework1](code/week02/src/Week02/Homework1.hs) module.
   - Fix and complete the code in the [Homework2](code/week02/src/Week02/Homework2.hs) module.
 
+## Solutions
+
+- Week #2
+
+  - [`Homework1`](code/week02/src/Week02/Solution1.hs)
+  - [`Homework2`](code/week02/src/Week02/Solution2.hs)
+
 ## Some Plutus Modules
 
 - [`PlutusTx.Data`](https://github.com/input-output-hk/plutus/blob/master/plutus-tx/src/PlutusTx/Data.hs), contains the definition of the `Data` type.

code/week02/plutus-pioneer-program-week02.cabal

@@ -16,6 +16,8 @@ library
                      , Week02.Homework2
                      , Week02.Gift
                      , Week02.IsData
+                     , Week02.Solution1
+                     , Week02.Solution2
                      , Week02.Typed
   build-depends:       aeson
                      , base ^>=4.14.1.0

code/week02/src/Week02/Solution1.hs

@@ -0,0 +1,90 @@
+{-# LANGUAGE DataKinds           #-}
+{-# LANGUAGE FlexibleContexts    #-}
+{-# LANGUAGE NoImplicitPrelude   #-}
+{-# LANGUAGE OverloadedStrings   #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE TemplateHaskell     #-}
+{-# LANGUAGE TypeApplications    #-}
+{-# LANGUAGE TypeFamilies        #-}
+{-# LANGUAGE TypeOperators       #-}
+
+module Week02.Solution1 where
+
+import           Control.Monad        hiding (fmap)
+import           Data.Map             as Map
+import           Data.Text            (Text)
+import           Data.Void            (Void)
+import           Plutus.Contract      hiding (when)
+import           PlutusTx             (Data (..))
+import qualified PlutusTx
+import           PlutusTx.Prelude     hiding (Semigroup(..), unless)
+import           Ledger               hiding (singleton)
+import           Ledger.Constraints   as Constraints
+import qualified Ledger.Scripts       as Scripts
+import qualified Ledger.Typed.Scripts as Scripts
+import           Ledger.Ada           as Ada
+import           Playground.Contract  (printJson, printSchemas, ensureKnownCurrencies, stage)
+import           Playground.TH        (mkKnownCurrencies, mkSchemaDefinitions)
+import           Playground.Types     (KnownCurrency (..))
+import           Prelude              (Semigroup (..))
+import           Text.Printf          (printf)
+
+{-# INLINABLE mkValidator #-}
+-- This should validate if and only if the two Booleans in the redeemer are equal!
+mkValidator :: () -> (Bool, Bool) -> ValidatorCtx -> Bool
+mkValidator () (b, c) _ = traceIfFalse "wrong redeemer" $ b == c
+
+data Typed
+instance Scripts.ScriptType Typed where
+    type instance DatumType Typed = ()
+    type instance RedeemerType Typed = (Bool, Bool)
+
+inst :: Scripts.ScriptInstance Typed
+inst = Scripts.validator @Typed
+    $$(PlutusTx.compile [|| mkValidator ||])
+    $$(PlutusTx.compile [|| wrap ||])
+  where
+    wrap = Scripts.wrapValidator @() @(Bool, Bool)
+
+validator :: Validator
+validator = Scripts.validatorScript inst
+
+valHash :: Ledger.ValidatorHash
+valHash = Scripts.validatorHash validator
+
+scrAddress :: Ledger.Address
+scrAddress = ScriptAddress valHash
+
+type GiftSchema =
+    BlockchainActions
+        .\/ Endpoint "give" Integer
+        .\/ Endpoint "grab" (Bool, Bool)
+
+give :: (HasBlockchainActions s, AsContractError e) => Integer -> Contract w s e ()
+give amount = do
+    let tx = mustPayToTheScript () $ Ada.lovelaceValueOf amount
+    ledgerTx <- submitTxConstraints inst tx
+    void $ awaitTxConfirmed $ txId ledgerTx
+    logInfo @String $ printf "made a gift of %d lovelace" amount
+
+grab :: forall w s e. (HasBlockchainActions s, AsContractError e) => (Bool, Bool) -> Contract w s e ()
+grab bs = do
+    utxos <- utxoAt scrAddress
+    let orefs   = fst <$> Map.toList utxos
+        lookups = Constraints.unspentOutputs utxos      <>
+                  Constraints.otherScript validator
+        tx :: TxConstraints Void Void
+        tx      = mconcat [mustSpendScriptOutput oref $ Redeemer $ PlutusTx.toData bs | oref <- orefs]
+    ledgerTx <- submitTxConstraintsWith @Void lookups tx
+    void $ awaitTxConfirmed $ txId ledgerTx
+    logInfo @String $ "collected gifts"
+
+endpoints :: Contract () GiftSchema Text ()
+endpoints = (give' `select` grab') >> endpoints
+  where
+    give' = endpoint @"give" >>= give
+    grab' = endpoint @"grab" >>= grab
+
+mkSchemaDefinitions ''GiftSchema
+
+mkKnownCurrencies []

code/week02/src/Week02/Solution2.hs

@@ -0,0 +1,101 @@
+{-# LANGUAGE DataKinds           #-}
+{-# LANGUAGE DeriveAnyClass      #-}
+{-# LANGUAGE DeriveGeneric       #-}
+{-# LANGUAGE FlexibleContexts    #-}
+{-# LANGUAGE NoImplicitPrelude   #-}
+{-# LANGUAGE OverloadedStrings   #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE TemplateHaskell     #-}
+{-# LANGUAGE TypeApplications    #-}
+{-# LANGUAGE TypeFamilies        #-}
+{-# LANGUAGE TypeOperators       #-}
+
+module Week02.Solution2 where
+
+import           Control.Monad        hiding (fmap)
+import           Data.Aeson           (FromJSON, ToJSON)
+import           Data.Map             as Map
+import           Data.Text            (Text)
+import           Data.Void            (Void)
+import           GHC.Generics         (Generic)
+import           Plutus.Contract      hiding (when)
+import           PlutusTx             (Data (..))
+import qualified PlutusTx
+import           PlutusTx.Prelude     hiding (Semigroup(..), unless)
+import           Ledger               hiding (singleton)
+import           Ledger.Constraints   as Constraints
+import qualified Ledger.Scripts       as Scripts
+import qualified Ledger.Typed.Scripts as Scripts
+import           Ledger.Ada           as Ada
+import           Playground.Contract  (printJson, printSchemas, ensureKnownCurrencies, stage, ToSchema)
+import           Playground.TH        (mkKnownCurrencies, mkSchemaDefinitions)
+import           Playground.Types     (KnownCurrency (..))
+import           Prelude              (Semigroup (..))
+import           Text.Printf          (printf)
+
+data MyRedeemer = MyRedeemer
+    { flag1 :: Bool
+    , flag2 :: Bool
+    } deriving (Generic, FromJSON, ToJSON, ToSchema)
+
+PlutusTx.unstableMakeIsData ''MyRedeemer
+
+{-# INLINABLE mkValidator #-}
+-- This should validate if and only if the two Booleans in the redeemer are equal!
+mkValidator :: () -> MyRedeemer -> ValidatorCtx -> Bool
+mkValidator () (MyRedeemer b c) _ = traceIfFalse "wrong redeemer" $ b == c
+
+data Typed
+instance Scripts.ScriptType Typed where
+    type instance DatumType Typed = ()
+    type instance RedeemerType Typed = MyRedeemer
+
+inst :: Scripts.ScriptInstance Typed
+inst = Scripts.validator @Typed
+    $$(PlutusTx.compile [|| mkValidator ||])
+    $$(PlutusTx.compile [|| wrap ||])
+  where
+    wrap = Scripts.wrapValidator @() @MyRedeemer
+
+validator :: Validator
+validator = Scripts.validatorScript inst
+
+valHash :: Ledger.ValidatorHash
+valHash = Scripts.validatorHash validator
+
+scrAddress :: Ledger.Address
+scrAddress = ScriptAddress valHash
+
+type GiftSchema =
+    BlockchainActions
+        .\/ Endpoint "give" Integer
+        .\/ Endpoint "grab" MyRedeemer
+
+give :: (HasBlockchainActions s, AsContractError e) => Integer -> Contract w s e ()
+give amount = do
+    let tx = mustPayToTheScript () $ Ada.lovelaceValueOf amount
+    ledgerTx <- submitTxConstraints inst tx
+    void $ awaitTxConfirmed $ txId ledgerTx
+    logInfo @String $ printf "made a gift of %d lovelace" amount
+
+grab :: forall w s e. (HasBlockchainActions s, AsContractError e) => MyRedeemer -> Contract w s e ()
+grab r = do
+    utxos <- utxoAt scrAddress
+    let orefs   = fst <$> Map.toList utxos
+        lookups = Constraints.unspentOutputs utxos      <>
+                  Constraints.otherScript validator
+        tx :: TxConstraints Void Void
+        tx      = mconcat [mustSpendScriptOutput oref $ Redeemer $ PlutusTx.toData r | oref <- orefs]
+    ledgerTx <- submitTxConstraintsWith @Void lookups tx
+    void $ awaitTxConfirmed $ txId ledgerTx
+    logInfo @String $ "collected gifts"
+
+endpoints :: Contract () GiftSchema Text ()
+endpoints = (give' `select` grab') >> endpoints
+  where
+    give' = endpoint @"give" >>= give
+    grab' = endpoint @"grab" >>= grab
+
+mkSchemaDefinitions ''GiftSchema
+
+mkKnownCurrencies []