Plutus Playground Smart Contract

Playground.hs

import qualified Data.Text                 as T
import           Language.Plutus.Contract  hiding (when)
-- ScriptLookups semigroup is defined based on the standard prelude <> and doesn't like the plutus one
import           Language.PlutusTx.Prelude hiding  ((<>)) 
import qualified Language.PlutusTx                 as PlutusTx
import           Playground.Contract
import           Control.Monad                     (void, when)
import           Ledger                            (Address (..), Slot (Slot), Validator, pubKeyHash, txOutTxDatum, txOutValue, txOutTxOut, TxOut, ValidatorCtx, Value, scriptAddress, PubKeyHash, Datum(..), TxOutTx, PubKeyHash (..), ValidatorCtx (..), validatorHash, txInInfoValue, outValue, TxInfo (..), txInInfoWitness )
import qualified Ledger.Typed.Scripts              as Scripts
import qualified Data.Map                          as Map
import           Data.List                         (groupBy, maximumBy, partition) 
import qualified Ledger.Ada                        as Ada
import           Data.Maybe                        (fromJust, catMaybes)
import           Ledger.Constraints                (TxConstraints, mustBeSignedBy, mustPayToTheScript, mustValidateIn, mustPayToPubKey, mustPayToOtherScript, scriptInstanceLookups,SomeLookupsAndConstraints (..), mkSomeTx, unspentOutputs, ScriptLookups(..))
import qualified Ledger.Contexts                   as Validation
import           Wallet.Emulator.Types             (Wallet, walletPubKey)
import qualified Prelude

import           Control.Lens

import           Data.Semigroup                   


quorum = 2

-- | Helper functions
lovelaceValue :: Value -> Integer
lovelaceValue value = Ada.getLovelace $ Ada.fromValue value

datumToData :: (PlutusTx.IsData a) => Datum -> Maybe a
datumToData datum = PlutusTx.fromData (getDatum datum)

{-# INLINABLE extractData #-}
extractData :: (PlutusTx.IsData a) => TxOutTx -> Maybe a
extractData txOut = do
                        datum <- txOutTxDatum txOut
                        datumToData datum   


-- Vote script
data VoteDatum = VoteDatum {   
      votedWallet     :: PubKeyHash,
      payout          :: Integer, 
      owner           :: PubKeyHash
    } deriving (Generic, Show)

PlutusTx.makeLift ''VoteDatum
PlutusTx.makeIsData ''VoteDatum

extractVote :: TxOutTx -> VoteDatum
extractVote = fromJust.extractData



data Vote
instance Scripts.ScriptType Vote where
    type instance RedeemerType Vote = ()
    type instance DatumType Vote = VoteDatum

{-# INLINABLE voteScript #-}
voteScript  ::  ValidatorHash -> VoteDatum -> () -> ValidatorCtx -> Bool 
voteScript treasury VoteDatum{owner=voteOwner} _ ctx@ValidatorCtx{valCtxTxInfo=txInfo@TxInfo{txInfoInputs}} =                     
                        Validation.valuePaidTo txInfo voteOwner == Ada.lovelaceValueOf 1
                        || Validation.valuePaidTo txInfo voteOwner == Ada.lovelaceValueOf 1
                        


voteScriptInstance :: ValidatorHash -> Scripts.ScriptInstance Vote
voteScriptInstance treasuryHash = Scripts.validator @Vote
    ($$(PlutusTx.compile [|| voteScript ||]) `PlutusTx.applyCode` PlutusTx.liftCode treasuryHash)
    $$(PlutusTx.compile [|| wrap ||]) where
        wrap = Scripts.wrapValidator @VoteDatum @()

voteScriptAddress :: ValidatorHash -> Address
voteScriptAddress treasuryHash = Ledger.scriptAddress (Scripts.validatorScript ( voteScriptInstance treasuryHash))

-- Treasury script
data Treasury
instance Scripts.ScriptType Treasury where
    type instance RedeemerType Treasury = ()
    type instance DatumType Treasury = ()

{-# INLINABLE treasuryScript #-}
treasuryScript  ::  () -> () -> ValidatorCtx -> Bool 
treasuryScript _ _ _ ctx@ValidatorCtx{valCtxTxInfo=txInfo@TxInfo{txInfoInputs}} =                     
                    let                         
                        fst3 (Just (a,_,_)) = a 
                        -- inputs should be votes or the treasury
                        (votes, [treasury]) = partition (\txInInfo -> fst3 ( txInInfoWitness txInInfo) == Validation.ownHash ctx) txInfoInputs                    
                    in 
                        length votes >= quorum
                        

treasuryScriptInstance :: Scripts.ScriptInstance Treasury
treasuryScriptInstance  = Scripts.validator @Treasury
    $$(PlutusTx.compile [|| treasuryScript ||])
    $$(PlutusTx.compile [|| wrap ||]) where
        wrap = Scripts.wrapValidator @() @()


treasuryScriptHash :: ValidatorHash
treasuryScriptHash = validatorHash $ Scripts.validatorScript treasuryScriptInstance

treasuryScriptAddress :: Address
treasuryScriptAddress = Ledger.scriptAddress (Scripts.validatorScript treasuryScriptInstance)

type VotingSchema =
    BlockchainActions
        .\/ Endpoint "1-setup treasury" Integer
        .\/ Endpoint "2-vote" VoteParams
        .\/ Endpoint "3-collect" ()

initiateVoting :: Contract VotingSchema T.Text ()
initiateVoting = do
                    trasuryAmount <- endpoint @"1-setup treasury" @Integer
                    let            
                        tx = mustPayToTheScript () ( Ada.lovelaceValueOf trasuryAmount) 
                    void (submitTxConstraints treasuryScriptInstance tx)


pubKeyHashOf :: Wallet -> PubKeyHash
pubKeyHashOf = pubKeyHash . walletPubKey

-- | Parameters for the "vote" endpoint
data VoteParams = VoteParams
    { votedFor :: Wallet
    , amount :: Integer
    }
    deriving stock (Prelude.Eq, Prelude.Show, Generic)
    deriving anyclass (FromJSON, ToJSON, IotsType, ToSchema, ToArgument)

vote :: Contract VotingSchema T.Text ()
vote= do
        VoteParams votedFor amount <- endpoint @"2-vote" @VoteParams
        voter <- pubKeyHash <$> ownPubKey
        let
          votedforPKH = pubKeyHashOf votedFor
          txAddVote = mustPayToTheScript VoteDatum{votedWallet=votedforPKH, payout=amount, owner=voter} ( Ada.lovelaceValueOf 1)
        void (submitTxConstraints (voteScriptInstance treasuryScriptHash) txAddVote)

findMostVotedGroup :: (a -> a -> Bool) -> [a] -> ([a], Integer)
findMostVotedGroup grouper elements = 
                let 
                    tally = map (\vs -> (vs, length vs)) $ groupBy grouper elements
                    compareTally (_, count1) (_, count2) = count1 `compare` count2
                in
                    maximumBy compareTally tally


extractWallet :: TxOutTx -> PubKeyHash 
extractWallet tx = votedWallet (extractVote tx)

extractPayout :: TxOutTx -> Integer 
extractPayout tx = payout (extractVote tx)

tally :: Contract VotingSchema T.Text ()
tally = do        
            endpoint @"3-collect" @()
            votesUtxo <- utxoAt (voteScriptAddress treasuryScriptHash)
            treasuryUtxo <- utxoAt treasuryScriptAddress              
            collector <- pubKeyHash <$> ownPubKey
            let
                utxoList = Map.toList votesUtxo
                comparator (_,x) (_,y) = extractWallet x == extractWallet y
                (winningVotes, count) = findMostVotedGroup comparator utxoList
                winningUtxos = Map.fromList winningVotes 
            if count >= quorum then 
                -- recreate winning votes utxos 
                -- add return vote endpoint
                let 
                    ScriptAddress voteScriptHash = voteScriptAddress treasuryScriptHash
                    payoutComparator (_,x) (_,y) = extractPayout x == extractPayout y
                    votedPayout = extractPayout $ snd.head.fst $ findMostVotedGroup payoutComparator winningVotes

                    winningWallet = extractWallet (snd $ head winningVotes) 
                    datum = Datum $ PlutusTx.toData $ VoteDatum{votedWallet=winningWallet, payout=votedPayout,owner=collector}
                                
                    -- pay the voted amount from the treasury            
                    totalTreasury = sum $ map (Ada.getLovelace. Ada.fromValue . txOutValue . txOutTxOut . snd) $  Map.toList treasuryUtxo
                                       

                    txPayWinner = mustPayToPubKey winningWallet ( Ada.lovelaceValueOf votedPayout)
                    txRepayTreasury = mustPayToOtherScript treasuryScriptHash datum ( Ada.lovelaceValueOf ( totalTreasury - votedPayout ))


                    --rebuild spent votes
                    rebuildVote utxo =  mustPayToOtherScript  voteScriptHash (fromJust (txOutTxDatum utxo)) (Ada.lovelaceValueOf 1) 

                    rebuildVoteTxs = map (rebuildVote.snd) utxoList
                    txRebuildVotes = foldl1 (<>) rebuildVoteTxs

                    txVotesUtxos = collectFromScript votesUtxo ()
                    txInputTreasury = collectFromScript treasuryUtxo ()            

                    treasuryUtxosConstraint = txInputTreasury <> txPayWinner  <> txRepayTreasury
                    treasuryLookups = (scriptInstanceLookups treasuryScriptInstance) <> (unspentOutputs treasuryUtxo)

-- 
                    votesUtxosConstraint = txVotesUtxos <> txRebuildVotes
                    votesLookups = (scriptInstanceLookups (voteScriptInstance treasuryScriptHash) ) <> (unspentOutputs votesUtxo)

                    treasurySpend = SomeLookupsAndConstraints treasuryLookups treasuryUtxosConstraint
                    voteSpend = SomeLookupsAndConstraints votesLookups votesUtxosConstraint
                in                     
                  do
                    logInfo @String $ show winningWallet 
                    void $ do
                        tx <- either (throwError . review _ConstraintResolutionError) pure (mkSomeTx [treasurySpend, voteSpend])
                        submitUnbalancedTx tx
            else
                throwError $ T.pack "Not enough votes"

endpoints :: Contract VotingSchema T.Text ()
endpoints = initiateVoting `select` vote `select` tally

mkSchemaDefinitions ''VotingSchema

$(mkKnownCurrencies [])

Simulation.json

[0,[{"simulationWallets":[{"simulatorWalletWallet":{"getWallet":1},"simulatorWalletBalance":{"getValue":[[{"unCurrencySymbol":""},[[{"unTokenName":""},10]]]]}},{"simulatorWalletWallet":{"getWallet":2},"simulatorWalletBalance":{"getValue":[[{"unCurrencySymbol":""},[[{"unTokenName":""},10]]]]}},{"simulatorWalletWallet":{"getWallet":3},"simulatorWalletBalance":{"getValue":[[{"unCurrencySymbol":""},[[{"unTokenName":""},10]]]]}},{"simulatorWalletWallet":{"getWallet":4},"simulatorWalletBalance":{"getValue":[[{"unCurrencySymbol":""},[[{"unTokenName":""},10]]]]}},{"simulatorWalletWallet":{"getWallet":5},"simulatorWalletBalance":{"getValue":[[{"unCurrencySymbol":""},[[{"unTokenName":""},10]]]]}},{"simulatorWalletWallet":{"getWallet":6},"simulatorWalletBalance":{"getValue":[[{"unCurrencySymbol":""},[[{"unTokenName":""},10]]]]}},{"simulatorWalletWallet":{"getWallet":7},"simulatorWalletBalance":{"getValue":[[{"unCurrencySymbol":""},[[{"unTokenName":""},10]]]]}}],"simulationName":"Simulation 1","simulationId":1,"simulationActions":[{"caller":{"getWallet":1},"argumentValues":{"endpointDescription":{"getEndpointDescription":"1-setup treasury"},"argument":{"s":1,"e":0,"c":[9],"tag":"FormIntegerF"}},"tag":"CallEndpoint"},{"caller":{"getWallet":2},"argumentValues":{"endpointDescription":{"getEndpointDescription":"2-vote"},"argument":{"contents":[["votedFor",{"contents":[["getWallet",{"s":1,"e":0,"c":[5],"tag":"FormIntegerF"}]],"tag":"FormObjectF"}],["amount",{"s":1,"e":0,"c":[2],"tag":"FormIntegerF"}]],"tag":"FormObjectF"}},"tag":"CallEndpoint"},{"caller":{"getWallet":3},"argumentValues":{"endpointDescription":{"getEndpointDescription":"2-vote"},"argument":{"contents":[["votedFor",{"contents":[["getWallet",{"s":1,"e":0,"c":[5],"tag":"FormIntegerF"}]],"tag":"FormObjectF"}],["amount",{"s":1,"e":0,"c":[2],"tag":"FormIntegerF"}]],"tag":"FormObjectF"}},"tag":"CallEndpoint"},{"caller":{"getWallet":6},"argumentValues":{"endpointDescription":{"getEndpointDescription":"2-vote"},"argument":{"contents":[["votedFor",{"contents":[["getWallet",{"s":1,"e":0,"c":[7],"tag":"FormIntegerF"}]],"tag":"FormObjectF"}],["amount",{"s":1,"e":0,"c":[4],"tag":"FormIntegerF"}]],"tag":"FormObjectF"}},"tag":"CallEndpoint"},{"blocks":10,"tag":"AddBlocks"},{"caller":{"getWallet":4},"argumentValues":{"endpointDescription":{"getEndpointDescription":"3-collect"},"argument":{"tag":"FormUnitF"}},"tag":"CallEndpoint"},{"blocks":10,"tag":"AddBlocks"}]}]]