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 )
import qualified Ledger.Typed.Scripts              as Scripts
import qualified Data.Map                          as Map
import           Data.List                         (groupBy, maximumBy) 
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           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 _ _ ctx@ValidatorCtx{valCtxTxInfo=txInfo} = 
                    -- check there should be an input to the treasury
                    -- check vote value goes back to owner
                    True


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 =
                    -- check vote count
                    -- check result of vote is 'effected'
                    -- valuePaidTo
                    -- at least 1 lovelace in treasury
                    -- count the votes, make sure they all the same
                    -- legnth votes > quorum

                    -- I have enough votes (filter from utxo inputs) to the same choice
                    True

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" Wallet
        .\/ 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
--, wallet     :: Wallet
vote :: Contract VotingSchema T.Text ()
vote= do
        votedFor <- endpoint @"2-vote" @Wallet
        voter <- pubKeyHash <$> ownPubKey
        let
          votedforPKH = pubKeyHashOf votedFor
          txAddVote = mustPayToTheScript VoteDatum{votedWallet=votedforPKH, 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 
                -- spend from the treasury the amount voted for
                -- send back the lovelaces to the vote script (or something)
                let 
                    ScriptAddress treasuryScriptHash = treasuryScriptAddress
                    winningWallet = extractWallet (snd $ head winningVotes) 
                    datum = Datum $ PlutusTx.toData $ VoteDatum{votedWallet=winningWallet, owner=collector}
                                
                    -- pay the voted amount from the treasury            
                    totalTreasury = sum $ map (Ada.getLovelace. Ada.fromValue . txOutValue . txOutTxOut . snd) $  Map.toList treasuryUtxo
                    
                    payoutComparator (_,x) (_,y) = extractPayout x == extractPayout y
                    votedPayout = extractPayout $ snd.head.fst $ findMostVotedGroup payoutComparator winningVotes

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


                    --votes are repaid
                    makeRepayment utxo =  let 
                                            voter = owner(extractVote utxo) 
                                          in 
                                            mustPayToPubKey voter (Ada.lovelaceValueOf 1) 
                    repayVoteTxs = map (makeRepayment.snd) utxoList
                    txRepayVotes = foldl1 (<>) repayVoteTxs

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

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

-- 
                    votesUtxosConstraint = txVotesUtxos <> txRepayVotes
                    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]]]]}}],"simulationName":"Simulation 1","simulationId":1,"simulationActions":[]}]]