From e43c87c2a056c80a2974b80d998f8b16f78e82a8 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Javier=20D=C3=ADaz?= Date: Wed, 4 Dec 2019 12:06:15 -0300 Subject: [PATCH 01/39] Move Byron proofs to its own directory --- Isabelle/ROOTS | 2 +- Isabelle/{ => byron}/Makefile | 0 Isabelle/byron/ROOTS | 2 ++ Isabelle/{ => byron}/UTxO/ROOT | 0 Isabelle/{ => byron}/UTxO/UTxO.thy | 0 Isabelle/{ => byron}/UTxO/document/root.tex | 2 +- 6 files changed, 4 insertions(+), 2 deletions(-) rename Isabelle/{ => byron}/Makefile (100%) create mode 100644 Isabelle/byron/ROOTS rename Isabelle/{ => byron}/UTxO/ROOT (100%) rename Isabelle/{ => byron}/UTxO/UTxO.thy (100%) rename Isabelle/{ => byron}/UTxO/document/root.tex (95%) diff --git a/Isabelle/ROOTS b/Isabelle/ROOTS index e073307..0ebae0d 100644 --- a/Isabelle/ROOTS +++ b/Isabelle/ROOTS @@ -1,2 +1,2 @@ -UTxO +byron diff --git a/Isabelle/Makefile b/Isabelle/byron/Makefile similarity index 100% rename from Isabelle/Makefile rename to Isabelle/byron/Makefile diff --git a/Isabelle/byron/ROOTS b/Isabelle/byron/ROOTS new file mode 100644 index 0000000..e073307 --- /dev/null +++ b/Isabelle/byron/ROOTS @@ -0,0 +1,2 @@ +UTxO + diff --git a/Isabelle/UTxO/ROOT b/Isabelle/byron/UTxO/ROOT similarity index 100% rename from Isabelle/UTxO/ROOT rename to Isabelle/byron/UTxO/ROOT diff --git a/Isabelle/UTxO/UTxO.thy b/Isabelle/byron/UTxO/UTxO.thy similarity index 100% rename from Isabelle/UTxO/UTxO.thy rename to Isabelle/byron/UTxO/UTxO.thy diff --git a/Isabelle/UTxO/document/root.tex b/Isabelle/byron/UTxO/document/root.tex similarity index 95% rename from Isabelle/UTxO/document/root.tex rename to Isabelle/byron/UTxO/document/root.tex index a4140ed..ff00e5e 100644 --- a/Isabelle/UTxO/document/root.tex +++ b/Isabelle/byron/UTxO/document/root.tex @@ -20,7 +20,7 @@ \begin{document} -\title{Formalization of the Cardano Ledger Specification in Isabelle/HOL} +\title{Formalization of the Cardano Ledger Specification in Isabelle/HOL (Byron release)} \author{Javier D\'iaz\\\small\texttt{javier.diaz@iohk.io}\\\small\texttt{github.com/input-output-hk/fm-ouroboros}} \maketitle From 1fd977845fa960697a2f624386c8d312d270df6a Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Javier=20D=C3=ADaz?= Date: Thu, 5 Dec 2019 13:00:37 -0300 Subject: [PATCH 02/39] Improve the project structure --- Isabelle/Byron/ROOT | 10 ++++++++++ Isabelle/{byron/UTxO => Byron}/UTxO.thy | 0 Isabelle/{byron/UTxO => Byron}/document/root.tex | 0 Isabelle/{byron => }/Makefile | 0 Isabelle/ROOTS | 3 +-- Isabelle/byron/ROOTS | 2 -- Isabelle/byron/UTxO/ROOT | 10 ---------- 7 files changed, 11 insertions(+), 14 deletions(-) create mode 100644 Isabelle/Byron/ROOT rename Isabelle/{byron/UTxO => Byron}/UTxO.thy (100%) rename Isabelle/{byron/UTxO => Byron}/document/root.tex (100%) rename Isabelle/{byron => }/Makefile (100%) delete mode 100644 Isabelle/byron/ROOTS delete mode 100644 Isabelle/byron/UTxO/ROOT diff --git a/Isabelle/Byron/ROOT b/Isabelle/Byron/ROOT new file mode 100644 index 0000000..58baa8d --- /dev/null +++ b/Isabelle/Byron/ROOT @@ -0,0 +1,10 @@ +chapter LedgerFormalization + +session Byron (ledgerformalization) = HOL + + description \Byron Release\ + sessions + "HOL-Library" + theories + UTxO + document_files + "root.tex" diff --git a/Isabelle/byron/UTxO/UTxO.thy b/Isabelle/Byron/UTxO.thy similarity index 100% rename from Isabelle/byron/UTxO/UTxO.thy rename to Isabelle/Byron/UTxO.thy diff --git a/Isabelle/byron/UTxO/document/root.tex b/Isabelle/Byron/document/root.tex similarity index 100% rename from Isabelle/byron/UTxO/document/root.tex rename to Isabelle/Byron/document/root.tex diff --git a/Isabelle/byron/Makefile b/Isabelle/Makefile similarity index 100% rename from Isabelle/byron/Makefile rename to Isabelle/Makefile diff --git a/Isabelle/ROOTS b/Isabelle/ROOTS index 0ebae0d..689c69b 100644 --- a/Isabelle/ROOTS +++ b/Isabelle/ROOTS @@ -1,2 +1 @@ -byron - +Byron diff --git a/Isabelle/byron/ROOTS b/Isabelle/byron/ROOTS deleted file mode 100644 index e073307..0000000 --- a/Isabelle/byron/ROOTS +++ /dev/null @@ -1,2 +0,0 @@ -UTxO - diff --git a/Isabelle/byron/UTxO/ROOT b/Isabelle/byron/UTxO/ROOT deleted file mode 100644 index 893ec67..0000000 --- a/Isabelle/byron/UTxO/ROOT +++ /dev/null @@ -1,10 +0,0 @@ -chapter UTxO - -session UTxO(ledgerformalization) = HOL + - description \Formalization of the UTxO transition system\ - sessions - "HOL-Library" - theories - UTxO - document_files - "root.tex" From bf1b0bf1d68fd6cdcb9e630f1b626dcf3fb3b545 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Javier=20D=C3=ADaz?= Date: Thu, 5 Dec 2019 13:15:04 -0300 Subject: [PATCH 03/39] Introduce structure for the Shelley release --- Isabelle/ROOTS | 1 + Isabelle/Shelley/ROOT | 8 +++++++ Isabelle/Shelley/document/root.tex | 34 ++++++++++++++++++++++++++++++ 3 files changed, 43 insertions(+) create mode 100644 Isabelle/Shelley/ROOT create mode 100644 Isabelle/Shelley/document/root.tex diff --git a/Isabelle/ROOTS b/Isabelle/ROOTS index 689c69b..0e3c1e3 100644 --- a/Isabelle/ROOTS +++ b/Isabelle/ROOTS @@ -1 +1,2 @@ Byron +Shelley diff --git a/Isabelle/Shelley/ROOT b/Isabelle/Shelley/ROOT new file mode 100644 index 0000000..79cb9e4 --- /dev/null +++ b/Isabelle/Shelley/ROOT @@ -0,0 +1,8 @@ +chapter LedgerFormalization + +session Shelley (ledgerformalization) = HOL + + description \Shelley Release\ + sessions + "HOL-Library" + document_files + "root.tex" diff --git a/Isabelle/Shelley/document/root.tex b/Isabelle/Shelley/document/root.tex new file mode 100644 index 0000000..0f3d6b3 --- /dev/null +++ b/Isabelle/Shelley/document/root.tex @@ -0,0 +1,34 @@ +\documentclass[a4paper,11pt]{article} + +\usepackage{typearea} + +\usepackage{lmodern} +\usepackage[T1]{fontenc} +\usepackage{textcomp} + +\usepackage{isabelle,isabellesym} + +\usepackage{latexsym} +\usepackage{amssymb} + +\usepackage{pdfsetup} + +\urlstyle{rm} +\isabellestyle{it} + +\newcommand{\isasymntriangleleft}{\isamath{\ntriangleleft}} + +\begin{document} + +\title{Formalization of the Cardano Ledger Specification in Isabelle/HOL (Shelley release)} +\author{Javier D\'iaz\\\small\texttt{javier.diaz@iohk.io}\\\small\texttt{github.com/input-output-hk/fm-ouroboros}} + +\maketitle + +\tableofcontents + +\parindent 0pt\parskip 0.5ex + +\input{session} + +\end{document} From d480162fd4c7655344bb1261054568e995a91153 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Javier=20D=C3=ADaz?= Date: Thu, 12 Dec 2019 12:31:31 -0300 Subject: [PATCH 04/39] Introduce UTxO value preservation lemma --- Isabelle/Shelley/Address.thy | 15 +++ Isabelle/Shelley/Basic_Types.thy | 53 ++++++++++ Isabelle/Shelley/Cryptography.thy | 11 +++ Isabelle/Shelley/Delegation.thy | 19 ++++ Isabelle/Shelley/Finite_Map_Extras.thy | 40 ++++++++ Isabelle/Shelley/Protocol_Parameters.thy | 23 +++++ Isabelle/Shelley/ROOT | 10 ++ Isabelle/Shelley/Transaction.thy | 74 ++++++++++++++ Isabelle/Shelley/UTxO.thy | 120 +++++++++++++++++++++++ Isabelle/Shelley/Update.thy | 11 +++ 10 files changed, 376 insertions(+) create mode 100644 Isabelle/Shelley/Address.thy create mode 100644 Isabelle/Shelley/Basic_Types.thy create mode 100644 Isabelle/Shelley/Cryptography.thy create mode 100644 Isabelle/Shelley/Delegation.thy create mode 100644 Isabelle/Shelley/Finite_Map_Extras.thy create mode 100644 Isabelle/Shelley/Protocol_Parameters.thy create mode 100644 Isabelle/Shelley/Transaction.thy create mode 100644 Isabelle/Shelley/UTxO.thy create mode 100644 Isabelle/Shelley/Update.thy diff --git a/Isabelle/Shelley/Address.thy b/Isabelle/Shelley/Address.thy new file mode 100644 index 0000000..c4beb42 --- /dev/null +++ b/Isabelle/Shelley/Address.thy @@ -0,0 +1,15 @@ +section \ Addresses \ + +theory Address + imports Main +begin + +text \ Output address \ + +typedecl addr \ \NOTE: Abstract for now\ + +text \ Reward account \ + +typedecl addr_rwd \ \NOTE: Abstract for now\ + +end diff --git a/Isabelle/Shelley/Basic_Types.thy b/Isabelle/Shelley/Basic_Types.thy new file mode 100644 index 0000000..38feef8 --- /dev/null +++ b/Isabelle/Shelley/Basic_Types.thy @@ -0,0 +1,53 @@ +section \ Basic Types \ + +theory Basic_Types + imports "HOL-Library.Countable" +begin + +text \ Coin \ + +type_synonym coin = int + +text \ Index \ + +typedecl ix + +axiomatization ix_to_nat :: "ix \ nat" where + ix_to_nat_injectivity: "inj ix_to_nat" + +instantiation ix :: countable +begin +instance by (standard, intro exI) (fact ix_to_nat_injectivity) +end + +instantiation ix :: linorder +begin + +definition less_ix :: "ix \ ix \ bool" where + "less_ix x y = (ix_to_nat x < ix_to_nat y)" + +definition less_eq_ix :: "ix \ ix \ bool" where + "less_eq_ix x y = (ix_to_nat x \ ix_to_nat y)" + +instance +proof + fix x y z :: ix + show "(x < y) = (x \ y \ \ y \ x)" + unfolding less_eq_ix_def and less_ix_def by auto + show "x \ x" + unfolding less_eq_ix_def by simp + show "\x \ y; y \ z\ \ x \ z" + unfolding less_eq_ix_def and less_ix_def by simp + show "\x \ y; y \ x\ \ x = y" + unfolding less_eq_ix_def using ix_to_nat_injectivity by (meson antisym injD) + show "x \ y \ y \ x" + unfolding less_eq_ix_def by auto +qed + +end + +text \ Absolute slot \ + +typedecl slot + +end diff --git a/Isabelle/Shelley/Cryptography.thy b/Isabelle/Shelley/Cryptography.thy new file mode 100644 index 0000000..b2cf16c --- /dev/null +++ b/Isabelle/Shelley/Cryptography.thy @@ -0,0 +1,11 @@ +section \ Cryptographic primitives \ + +theory Cryptography + imports Main +begin + +text \ Hash of a key \ + +typedecl key_hash + +end diff --git a/Isabelle/Shelley/Delegation.thy b/Isabelle/Shelley/Delegation.thy new file mode 100644 index 0000000..c72dc40 --- /dev/null +++ b/Isabelle/Shelley/Delegation.thy @@ -0,0 +1,19 @@ +section \ Delegation \ + +theory Delegation + imports Main +begin + +text \ Delegation certificate \ + +typedecl d_cert \ \NOTE: Abstract for now\ + +text \ Registered stake credential \ + +typedecl stake_creds \ \NOTE: Abstract for now\ + +text \ Registered stake pools \ + +typedecl stake_pools \ \NOTE: Abstract for now\ + +end diff --git a/Isabelle/Shelley/Finite_Map_Extras.thy b/Isabelle/Shelley/Finite_Map_Extras.thy new file mode 100644 index 0000000..e15d865 --- /dev/null +++ b/Isabelle/Shelley/Finite_Map_Extras.thy @@ -0,0 +1,40 @@ +section \ Extra features for \fmap\'s \ + +theory Finite_Map_Extras + imports "HOL-Library.Finite_Map" +begin + +text \ Some extra lemmas and syntactic sugar for \fmap\ \ + +abbreviation fmap_update (\_'(_ $$:= _')\ [1000,0,0] 1000) where + "fmap_update m k v \ fmupd k v m" + +notation fmlookup (infixl \$$\ 999) + +notation fmempty (\{$$}\) + +abbreviation fmap_singleton (\{_ $$:= _}\ [0, 0] 1000) where + "fmap_singleton k v \ {$$}(k $$:= v)" + +abbreviation fmap_lookup_the (infixl \$$!\ 999) where + "fmap_lookup_the m k \ the (m $$ k)" + +lemma fmfilter_fmsubset: "fmfilter p m \\<^sub>f m" +proof - + have "\k \ fmdom' m. \v. (fmfilter p m) $$ k = v \ m $$ k = v" + by blast + then show ?thesis + by (simp add: Ball_def_raw domIff fmsubset.rep_eq map_le_def) +qed + +text \ Domain restriction \ + +abbreviation dom_res :: "'a set \ ('a, 'b) fmap \ ('a, 'b) fmap" (infixl \\\ 150) where + "s \ m \ fmfilter (\x. x \ s) m" + +text \ Domain exclusion \ + +abbreviation dom_exc :: "'a set \ ('a, 'b) fmap \ ('a, 'b) fmap" (infixl \\'/\ 150) where + "s \/ m \ fmfilter (\x. x \ s) m" + +end diff --git a/Isabelle/Shelley/Protocol_Parameters.thy b/Isabelle/Shelley/Protocol_Parameters.thy new file mode 100644 index 0000000..6de8793 --- /dev/null +++ b/Isabelle/Shelley/Protocol_Parameters.thy @@ -0,0 +1,23 @@ +section \ Protocol Parameters \ + +theory Protocol_Parameters + imports Finite_Map_Extras +begin + +text \ Protocol parameter name \ + +typedecl ppm \ \NOTE: Abstract for now\ + +text \ Protocol parameter value \ + +typedecl pvalue \ \NOTE: Abstract for now\ + +text \ Protocol parameter map \ + +type_synonym p_params = "(ppm, pvalue) fmap" + +text \ Reward account \ + +typedecl addr_rwd \ \NOTE: Abstract for now\ + +end diff --git a/Isabelle/Shelley/ROOT b/Isabelle/Shelley/ROOT index 79cb9e4..232dbb0 100644 --- a/Isabelle/Shelley/ROOT +++ b/Isabelle/Shelley/ROOT @@ -4,5 +4,15 @@ session Shelley (ledgerformalization) = HOL + description \Shelley Release\ sessions "HOL-Library" + theories + Address + Basic_Types + Cryptography + Delegation + Finite_Map_Extras + Protocol_Parameters + Transaction + Update + UTxO document_files "root.tex" diff --git a/Isabelle/Shelley/Transaction.thy b/Isabelle/Shelley/Transaction.thy new file mode 100644 index 0000000..fa32e78 --- /dev/null +++ b/Isabelle/Shelley/Transaction.thy @@ -0,0 +1,74 @@ +section \ Transactions \ + +theory Transaction + imports Basic_Types Address Finite_Map_Extras Delegation Update +begin + +text \ Genesis key hash \ + +typedecl key_hash_g + +text \ Transaction ID \ + +typedecl tx_id + +text \ Transaction input \ + +type_synonym tx_in = "tx_id \ ix" + +text \ Transaction output \ + +type_synonym tx_out = "addr \ coin" + +text \ Reward withdrawal \ + +type_synonym wdrl = "(addr_rwd, coin) fmap" + +text \ Update proposal \ + +typedecl update \ \NOTE: Abstract for now\ + +text \ Transaction body \ + +type_synonym tx_body = "tx_in set \ (ix, tx_out) fmap \ d_cert list \ coin \ slot \ wdrl \ update" + +text \ Transaction witness \ + +typedecl tx_witness \ \NOTE: Abstract for now\ + +text \ Transaction \ + +type_synonym tx = "tx_body \ tx_witness" + +text \ Accessor functions \ + +\ \Transaction inputs\ + +fun txins :: "tx \ tx_in set" where + "txins ((txis, _, _, _, _, _, _), _) = txis" + +\ \Transaction outputs\ + +fun txouts :: "tx \ (ix, tx_out) fmap" where + "txouts ((_, txos, _, _, _, _, _), _) = txos" + +\ \Delegation certificates\ + +fun txcerts :: "tx \ d_cert list" where + "txcerts ((_, _, dcs, _, _, _, _), _) = dcs" + +\ \Transaction fee\ + +fun txfee :: "tx \ coin" where + "txfee ((_, _, _, c, _, _, _), _) = c" + +\ \Withdrawals\ + +fun txwdrls :: "tx \ wdrl" where + "txwdrls ((_, _, _, _, _, wds, _), _) = wds" + +text \ Abstract functions \ + +consts txid :: "tx \ tx_id" + +end diff --git a/Isabelle/Shelley/UTxO.thy b/Isabelle/Shelley/UTxO.thy new file mode 100644 index 0000000..afd5ce7 --- /dev/null +++ b/Isabelle/Shelley/UTxO.thy @@ -0,0 +1,120 @@ +section \ UTxO \ + +theory UTxO + imports Transaction Finite_Map_Extras Protocol_Parameters Cryptography +begin + +subsection \ Deposits and Refunds \ + +text \ Total deposits for transaction \ + +abbreviation deposits :: "p_params \ stake_pools \ d_cert list \ coin" where + "deposits \ undefined" \ \NOTE: Abstract for now\ + +text \ Key refunds for a transaction \ + +abbreviation key_refunds :: "p_params \ stake_creds \ tx \ coin" where + "key_refunds \ undefined" \ \NOTE: Abstract for now\ + +text \ Decayed deposit portions \ + +abbreviation decayed_tx :: "p_params \ stake_creds \ tx \ coin" where + "decayed_tx \ undefined" \ \NOTE: Abstract for now\ + +subsection \ UTxO transitions \ + +text \ UTxO \ + +type_synonym utxo = "(tx_in, tx_out) fmap" + +text \ Tx outputs as UTxO \ + +abbreviation outs :: "tx \ utxo" where + "outs tx \ fmap_of_list [((txid tx, ix), txout). (ix, txout) \ sorted_list_of_fmap (txouts tx)]" + +text \ UTxO balance \ + +abbreviation ubalance :: "utxo \ coin" where + "ubalance utxo \ (\txin \ fmdom' utxo. snd (utxo $$! txin))" + +text \ Withdrawal balance \ + +abbreviation wbalance :: "wdrl \ coin" where + "wbalance ws \ (\addr \ fmdom' ws. ws $$! addr)" + +text \ Value consumed \ + +abbreviation consumed :: "p_params \ utxo \ stake_creds \ tx \ coin" where + "consumed pp utxo stk_creds tx \ + ubalance (txins tx \ utxo) + wbalance (txwdrls tx) + key_refunds pp stk_creds tx" + +text \ Value produced \ + +abbreviation produced :: "p_params \ stake_pools \ tx \ coin" where + "produced pp stpools tx \ ubalance (outs tx) + txfee tx + deposits pp stpools (txcerts tx)" + +subsubsection \ UTxO transition-system types \ + +text \ UTxO environment \ + +type_synonym utxo_env = "slot \ p_params \ stake_creds \ stake_pools \ (key_hash_g, key_hash) fmap" + +text \ UTxO states \ + +type_synonym utxo_state = "utxo \ coin \ coin \ update_state" + +text \ UTxO inference rules \ + +(* NOTE: `ups'` is not defined for now since it involves another transition system. *) +inductive utxo_sts :: "utxo_env \ utxo_state \ tx \ utxo_state \ bool" + (\_ \ _ \\<^bsub>UTXO\<^esub>{_} _\ [51, 0, 51] 50) + where + utxo_inductive: " + \ + \ = (slot, pp, stk_creds, stpools, gen_delegs); + s = (utxo, deps, fees, ups); + txins tx \ {}; + txins tx \ fmdom' utxo; + consumed pp utxo stk_creds tx = produced pp stpools tx; + \(_, c) \ fmran' (txouts tx). c \ 0; + refunded = key_refunds pp stk_creds tx; + decayed = decayed_tx pp stk_creds tx; + deposit_change = deposits pp stpools (txcerts tx) - (refunded + decayed); + ups' = ups; \ \FIXME: Complete later\ + finite (fmdom' utxo) + \ + \ + \ \ s \\<^bsub>UTXO\<^esub>{tx} ( + (txins tx \/ utxo) ++\<^sub>f outs tx, deps + deposit_change, fees + txfee tx + decayed, ups')" + +subsection \ Properties \ + +subsubsection \ Preservation of Value \ + +text \ Lovelace Value \ + +abbreviation val_coin :: "coin \ coin" where + "val_coin c \ c" + +abbreviation val_map :: "('a, coin) fmap \ coin" where + "val_map m \ (\k \ fmdom' m. m $$! k)" + +fun val_utxo_state :: "utxo_state \ coin" where + "val_utxo_state (utxo, deps, fees, ups) = ubalance utxo + deps + fees" + +lemma val_map_split: + assumes "s \ fmdom' m" + shows "val_map m = val_map (s \/ m) + val_map (s \ m)" + oops + +lemma val_map_union: + assumes "fmdom' m\<^sub>1 \ fmdom' m\<^sub>2 = {}" + shows "val_map (m\<^sub>1 ++\<^sub>f m\<^sub>2) = val_map m\<^sub>1 + val_map m\<^sub>2" + oops + +lemma utxo_value_preservation: + assumes "\ \ s \\<^bsub>UTXO\<^esub>{t} s'" + shows "val_utxo_state s + wbalance (txwdrls t) = val_utxo_state s'" + oops + +end diff --git a/Isabelle/Shelley/Update.thy b/Isabelle/Shelley/Update.thy new file mode 100644 index 0000000..0d808bb --- /dev/null +++ b/Isabelle/Shelley/Update.thy @@ -0,0 +1,11 @@ +section \ Update Proposal Mechanism \ + +theory Update + imports Main +begin + +text \ Update states \ + +typedecl update_state \ \NOTE: Abstract for now\ + +end From ca5491a76943f781be620f43aec100830551a9e3 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Javier=20D=C3=ADaz?= Date: Mon, 16 Dec 2019 03:37:29 -0300 Subject: [PATCH 05/39] Introduce proof of preservation of value for the UTxO subsystem --- Isabelle/Shelley/Cryptography.thy | 2 +- Isabelle/Shelley/Finite_Map_Extras.thy | 126 +++++++++++++++- Isabelle/Shelley/Properties.thy | 194 +++++++++++++++++++++++++ Isabelle/Shelley/ROOT | 7 +- Isabelle/Shelley/UTxO.thy | 87 ++++++----- 5 files changed, 373 insertions(+), 43 deletions(-) create mode 100644 Isabelle/Shelley/Properties.thy diff --git a/Isabelle/Shelley/Cryptography.thy b/Isabelle/Shelley/Cryptography.thy index b2cf16c..2e02584 100644 --- a/Isabelle/Shelley/Cryptography.thy +++ b/Isabelle/Shelley/Cryptography.thy @@ -1,4 +1,4 @@ -section \ Cryptographic primitives \ +section \ Cryptographic Primitives \ theory Cryptography imports Main diff --git a/Isabelle/Shelley/Finite_Map_Extras.thy b/Isabelle/Shelley/Finite_Map_Extras.thy index e15d865..b853c1e 100644 --- a/Isabelle/Shelley/Finite_Map_Extras.thy +++ b/Isabelle/Shelley/Finite_Map_Extras.thy @@ -1,10 +1,10 @@ -section \ Extra features for \fmap\'s \ +section \ Extra Features for Finite Maps \ theory Finite_Map_Extras imports "HOL-Library.Finite_Map" begin -text \ Some extra lemmas and syntactic sugar for \fmap\ \ +text \ Extra lemmas and syntactic sugar for \fmap\ \ abbreviation fmap_update (\_'(_ $$:= _')\ [1000,0,0] 1000) where "fmap_update m k v \ fmupd k v m" @@ -27,6 +27,81 @@ proof - by (simp add: Ball_def_raw domIff fmsubset.rep_eq map_le_def) qed +lemma fmadd_singletons_comm: + assumes "k\<^sub>1 \ k\<^sub>2" + shows "{k\<^sub>1 $$:= v\<^sub>1} ++\<^sub>f {k\<^sub>2 $$:= v\<^sub>2} = {k\<^sub>2 $$:= v\<^sub>2} ++\<^sub>f {k\<^sub>1 $$:= v\<^sub>1}" +proof (intro fmap_ext) + fix k + consider + (a) "k = k\<^sub>1" | + (b) "k = k\<^sub>2" | + (c) "k \ k\<^sub>1 \ k \ k\<^sub>2" + by auto + with assms show "({k\<^sub>1 $$:= v\<^sub>1} ++\<^sub>f {k\<^sub>2 $$:= v\<^sub>2}) $$ k = ({k\<^sub>2 $$:= v\<^sub>2} ++\<^sub>f {k\<^sub>1 $$:= v\<^sub>1}) $$ k" + by auto +qed + +lemma fmap_singleton_comm: + assumes "m $$ k = None" + shows "m ++\<^sub>f {k $$:= v} = {k $$:= v} ++\<^sub>f m" + using assms +proof (induction m arbitrary: k v rule: fmap_induct) + case fmempty + then show ?case + by simp +next + case (fmupd x y m) + have "m(x $$:= y) ++\<^sub>f {k $$:= v} = m ++\<^sub>f {x $$:= y} ++\<^sub>f {k $$:= v}" + by simp + also from fmupd.hyps and fmupd.IH have "\ = {x $$:= y} ++\<^sub>f m ++\<^sub>f {k $$:= v}" + by simp + also from fmupd.prems and fmupd.hyps and fmupd.IH have "\ = {x $$:= y} ++\<^sub>f {k $$:= v} ++\<^sub>f m" + by (metis fmadd_assoc fmupd_lookup) + also have "\ = {k $$:= v} ++\<^sub>f m(x $$:= y)" + proof (cases "x \ k") + case True + then have "{x $$:= y} ++\<^sub>f {k $$:= v} ++\<^sub>f m = {k $$:= v} ++\<^sub>f {x $$:= y} ++\<^sub>f m" + using fmadd_singletons_comm by metis + also from fmupd.prems and fmupd.hyps and fmupd.IH have "\ = {k $$:= v} ++\<^sub>f m ++\<^sub>f {x $$:= y}" + by (metis fmadd_assoc) + finally show ?thesis + by simp + next + case False + with fmupd.prems show ?thesis + by auto + qed + finally show ?case . +qed + +lemma fmap_disj_comm: + assumes "fmdom' m\<^sub>1 \ fmdom' m\<^sub>2 = {}" + shows "m\<^sub>1 ++\<^sub>f m\<^sub>2 = m\<^sub>2 ++\<^sub>f m\<^sub>1" + using assms +proof (induction m\<^sub>2 arbitrary: m\<^sub>1 rule: fmap_induct) + case fmempty + then show ?case + by simp +next + case (fmupd k v m\<^sub>2) + then show ?case + proof (cases "m\<^sub>1 $$ k = None") + case True + from fmupd.hyps have "m\<^sub>1 ++\<^sub>f m\<^sub>2(k $$:= v) = m\<^sub>1 ++\<^sub>f m\<^sub>2 ++\<^sub>f {k $$:= v}" + by simp + also from fmupd.prems and fmupd.hyps and fmupd.IH have "\ = m\<^sub>2 ++\<^sub>f m\<^sub>1 ++\<^sub>f {k $$:= v}" + by simp + also from True have "\ = m\<^sub>2 ++\<^sub>f {k $$:= v} ++\<^sub>f m\<^sub>1" + using fmap_singleton_comm by (metis fmadd_assoc) + finally show ?thesis + by simp + next + case False + then show ?thesis + using fmupd.prems by auto + qed +qed + text \ Domain restriction \ abbreviation dom_res :: "'a set \ ('a, 'b) fmap \ ('a, 'b) fmap" (infixl \\\ 150) where @@ -37,4 +112,51 @@ text \ Domain exclusion \ abbreviation dom_exc :: "'a set \ ('a, 'b) fmap \ ('a, 'b) fmap" (infixl \\'/\ 150) where "s \/ m \ fmfilter (\x. x \ s) m" +text \ Extra lemmas for \\\ and \\/\ \ + +lemma dom_exc_add_distr: + shows "s \/ (m\<^sub>1 ++\<^sub>f m\<^sub>2) = (s \/ m\<^sub>1) ++\<^sub>f (s \/ m\<^sub>2)" + by (blast intro: fmfilter_add_distrib) + +lemma fmap_partition: + shows "m = s \/ m ++\<^sub>f s \ m" +proof (induction m rule: fmap_induct) + case fmempty + then show ?case + by simp +next + case (fmupd k v m) + from fmupd.hyps have "s \/ m(k $$:= v) ++\<^sub>f s \ m(k $$:= v) = + s \/ (m ++\<^sub>f {k $$:= v}) ++\<^sub>f s \ (m ++\<^sub>f {k $$:= v})" + by simp + also have "\ = s \/ m ++\<^sub>f s \/ {k $$:= v} ++\<^sub>f s \ m ++\<^sub>f s \ {k $$:= v}" + using dom_exc_add_distr by simp + finally show ?case + proof (cases "k \ s") + case True + then have "s \/ m ++\<^sub>f s \/ {k $$:= v} ++\<^sub>f s \ m ++\<^sub>f s \ {k $$:= v} = + s \/ m ++\<^sub>f {$$} ++\<^sub>f s \ m ++\<^sub>f {k $$:= v}" + by simp + also have "\ = s \/ m ++\<^sub>f s \ m ++\<^sub>f {k $$:= v}" + by simp + also from fmupd.IH have "\ = m ++\<^sub>f {k $$:= v}" + by simp + finally show ?thesis using fmupd.hyps + by auto + next + case False + then have "s \/ m ++\<^sub>f s \/ {k $$:= v} ++\<^sub>f s \ m ++\<^sub>f s \ {k $$:= v} = + s \/ m ++\<^sub>f {k $$:= v} ++\<^sub>f s \ m ++\<^sub>f {$$}" + by simp + also have "\ = s \/ m ++\<^sub>f {k $$:= v} ++\<^sub>f s \ m" + by simp + also from fmupd.hyps have "\ = s \/ m ++\<^sub>f s \ m ++\<^sub>f {k $$:= v}" + using fmap_singleton_comm by (metis (full_types) fmadd_assoc fmlookup_filter) + also from fmupd.IH have "\ = m ++\<^sub>f {k $$:= v}" + by simp + finally show ?thesis + by auto + qed +qed + end diff --git a/Isabelle/Shelley/Properties.thy b/Isabelle/Shelley/Properties.thy new file mode 100644 index 0000000..56ceed4 --- /dev/null +++ b/Isabelle/Shelley/Properties.thy @@ -0,0 +1,194 @@ +section \ Properties \ + +theory Properties + imports UTxO +begin + +subsection \ Preservation of Value \ + +text \ Lovelace Value \ + +fun val_coin :: "coin \ coin" where + "val_coin c = c" + +abbreviation val_map :: "('a, coin) fmap \ coin" where + "val_map m \ (\k \ fmdom' m. m $$! k)" + +abbreviation val_utxo :: "utxo \ coin" where + "val_utxo utxo \ ubalance utxo" + +fun val_utxo_state :: "utxo_state \ coin" where + "val_utxo_state (utxo, deps, fees, _) = val_utxo utxo + deps + fees" + +lemma val_map_add: + assumes "k \ fmdom' m" + shows "val_map m(k $$:= c) = val_map m + c" +proof - + let ?m' = "m(k $$:= c)" + have "val_map ?m' = (\k\<^sub>i \ fmdom' m \ {k}. ?m' $$! k\<^sub>i)" + by simp + also from assms have "\ = (\k\<^sub>i \ fmdom' m. ?m' $$! k\<^sub>i) + (?m' $$! k)" + by simp + also have "\ = (\k\<^sub>i \ fmdom' m. ?m' $$! k\<^sub>i) + c" + by simp + also from assms have "\ = (\k\<^sub>i \ fmdom' m. m $$! k\<^sub>i) + c" + by (metis (no_types, lifting) fmupd_lookup sum.cong) + finally show ?thesis + by simp +qed + +lemma val_map_union: + assumes "fmdom' m\<^sub>1 \ fmdom' m\<^sub>2 = {}" + shows "val_map (m\<^sub>1 ++\<^sub>f m\<^sub>2) = val_map m\<^sub>1 + val_map m\<^sub>2" + using assms +proof (induction m\<^sub>2 arbitrary: m\<^sub>1 rule: fmap_induct) + case fmempty + then show ?case + by simp +next + case (fmupd k c m\<^sub>2) + have "val_map (m\<^sub>1 ++\<^sub>f m\<^sub>2(k $$:= c)) = val_map ((m\<^sub>1 ++\<^sub>f m\<^sub>2)(k $$:= c))" + by simp + also have "\ = val_map (m\<^sub>1 ++\<^sub>f m\<^sub>2) + c" + proof - + have "fmdom' (m\<^sub>1 ++\<^sub>f m\<^sub>2) = fmdom' m\<^sub>1 \ fmdom' m\<^sub>2" + by simp + moreover from fmupd.prems have "k \ fmdom' m\<^sub>1" + by auto + moreover from fmupd.hyps have "k \ fmdom' m\<^sub>2" + by (simp add: fmdom'_notI) + ultimately have "k \ fmdom' (m\<^sub>1 ++\<^sub>f m\<^sub>2)" + by simp + then show ?thesis + using val_map_add by (metis sum.cong) + qed + also from fmupd.prems and fmupd.IH have "\ = val_map m\<^sub>1 + val_map m\<^sub>2 + c" + by simp + also have "\ = val_map m\<^sub>1 + val_map (m\<^sub>2(k $$:= c))" + proof - + from fmupd.hyps have "k \ fmdom' m\<^sub>2" + by (simp add: fmdom'_notI) + then show ?thesis + using val_map_add by (metis (full_types) add.assoc) + qed + finally show ?case . +qed + +text \ + NOTE: The precondition \s \ fmdom' m\ stated in the document is not really needed. +\ +lemma val_map_split: + shows "val_map m = val_map (s \/ m) + val_map (s \ m)" +proof - + have *: "fmdom' (s \/ m) \ fmdom' (s \ m) = {}" + by auto + then have "m = s \/ m ++\<^sub>f s \ m" + using fmap_partition by simp + with * show ?thesis + using val_map_union by metis +qed + +lemma val_utxo_val_map: + shows "val_utxo utxo = val_map (fmmap snd utxo)" +proof - + have "fmdom' (fmmap snd utxo) = fmdom' utxo" + by simp + moreover have "\k. k \ fmdom' utxo \ (fmmap snd utxo) $$! k = snd (utxo $$! k)" + using fmlookup_dom'_iff by force + ultimately show ?thesis + by auto +qed + +text \ + NOTE: + \<^item> The proof in the document applies lemmas 15.3 and 15.4 on \utxo\'s, + however this is incorrect since the range of \utxo\ is not \coin\ but + \(addr, coin)\. + \<^item> The proof in the document applies lemma 15.4 without proving its + precondition, which is not trivial to formalize. + \<^item> This formalization does not rely on Theorem 15.10 (the proof in the document does). +\ +lemma utxo_value_preservation: + assumes "\ \ s \\<^bsub>UTXO\<^esub>{tx} s'" + shows "val_utxo_state s + wbalance (txwdrls tx) = val_utxo_state s'" +proof - + from assms show ?thesis + proof cases + case (utxo_inductive utxo pp stk_creds stpools refunded decayed deposit_change ups' ups slot gen_delegs deps fees) + from utxo_inductive(3) have "val_utxo_state s' = + val_utxo_state ( + (txins tx \/ utxo) ++\<^sub>f outs tx, + deps + deposit_change, + fees + txfee tx + decayed, + ups')" + by blast + also have "\ = + ubalance ((txins tx \/ utxo) ++\<^sub>f outs tx) + + (deps + deposit_change) + + (fees + txfee tx + decayed)" + by simp + also have "\ = + ubalance (txins tx \/ utxo) + ubalance (outs tx) + + (deps + deposit_change) + + (fees + txfee tx + decayed)" + proof - + have "ubalance ((txins tx \/ utxo) ++\<^sub>f outs tx) = + val_map (fmmap snd ((txins tx \/ utxo) ++\<^sub>f outs tx))" + by (fact val_utxo_val_map) + also have "\ = val_map (fmmap snd (txins tx \/ utxo) ++\<^sub>f fmmap snd (outs tx))" + by simp + also have "\ = val_map (fmmap snd (txins tx \/ utxo)) + val_map (fmmap snd (outs tx))" + proof - + from utxo_inductive(4) have "fmdom'(txins tx \/ utxo) \ fmdom' (outs tx) = {}" + using txins_outs_exc by blast + then show ?thesis + using val_map_union by (smt fmdom'_map sum.cong) + qed + also have "\ = ubalance (txins tx \/ utxo) + ubalance (outs tx)" + using val_utxo_val_map by presburger + finally show ?thesis + by linarith + qed + also from utxo_inductive(11) have "\ = + ubalance (txins tx \/ utxo) + ubalance (outs tx) + + (deps + deposits pp stpools (txcerts tx) - (refunded + decayed)) + + (fees + txfee tx + decayed)" + by simp + also have "\ = + ubalance (txins tx \/ utxo) + ubalance (outs tx) + + deps + deposits pp stpools (txcerts tx) - refunded + + fees + txfee tx" + by simp + also from utxo_inductive(9) have "\ = + ubalance (txins tx \/ utxo) + ubalance (outs tx) + + deps + deposits pp stpools (txcerts tx) - key_refunds pp stk_creds tx + + fees + txfee tx" + by simp + also from utxo_inductive(7) have "\ = + ubalance (txins tx \/ utxo) + ubalance (txins tx \ utxo) + + wbalance (txwdrls tx) + key_refunds pp stk_creds tx + + deps - key_refunds pp stk_creds tx + fees" + by simp + also have "\ = + ubalance (txins tx \/ utxo) + ubalance (txins tx \ utxo) + + wbalance (txwdrls tx) + deps + fees" + by simp + also have "\ = ubalance utxo + wbalance (txwdrls tx) + deps + fees" + proof - + have "ubalance (txins tx \/ utxo) + ubalance (txins tx \ utxo) = + val_map (fmmap snd (txins tx \/ utxo)) + val_map (fmmap snd (txins tx \ utxo))" + using val_utxo_val_map by presburger + also have "\ = + val_map (txins tx \/ (fmmap snd utxo)) + val_map (txins tx \ (fmmap snd utxo))" + by simp + also from utxo_inductive(6) have "\ = val_map (fmmap snd utxo)" + using val_map_split by (metis fmdom'_map) + finally show ?thesis + using val_utxo_val_map by simp + qed + finally show ?thesis + using utxo_inductive(2) by simp + qed +qed + +end diff --git a/Isabelle/Shelley/ROOT b/Isabelle/Shelley/ROOT index 232dbb0..a35bd35 100644 --- a/Isabelle/Shelley/ROOT +++ b/Isabelle/Shelley/ROOT @@ -5,14 +5,15 @@ session Shelley (ledgerformalization) = HOL + sessions "HOL-Library" theories - Address + Finite_Map_Extras Basic_Types Cryptography - Delegation - Finite_Map_Extras + Address Protocol_Parameters Transaction Update UTxO + Delegation + Properties document_files "root.tex" diff --git a/Isabelle/Shelley/UTxO.thy b/Isabelle/Shelley/UTxO.thy index afd5ce7..b674c20 100644 --- a/Isabelle/Shelley/UTxO.thy +++ b/Isabelle/Shelley/UTxO.thy @@ -32,6 +32,39 @@ text \ Tx outputs as UTxO \ abbreviation outs :: "tx \ utxo" where "outs tx \ fmap_of_list [((txid tx, ix), txout). (ix, txout) \ sorted_list_of_fmap (txouts tx)]" +lemma dom_outs_is_txid: + assumes "(i, ix) \ fmdom' (outs tx)" + shows "i = txid tx" +proof - + from assms have "(i, ix) \ fset (fmdom ( + fmap_of_list [((txid tx, ix), txout). (ix, txout) \ sorted_list_of_fmap (txouts tx)]))" + by (simp add: fmdom'_alt_def) + then have "(i, ix) \ fset (fset_of_list ( + map fst [((txid tx, ix), txout). (ix, txout) \ sorted_list_of_fmap (txouts tx)]))" + by simp + then have "(i, ix) \ fset (fset_of_list + [(txid tx, ix). (ix, txout) \ sorted_list_of_fmap (txouts tx)])" + by auto + then have "(i, ix) \ set [(txid tx, ix). (ix, txout) \ sorted_list_of_fmap (txouts tx)]" + by (simp add: fset_of_list.rep_eq) + then show "i = txid tx" + by auto +qed + +lemma txins_outs_exc: + assumes "txid tx \ {tid | tid ix. (tid, ix) \ fmdom' utxo}" + shows "fmdom' (txins tx \/ utxo) \ fmdom' (outs tx) = {}" +proof - + from assms have "txid tx \ {tid | tid ix. (tid, ix) \ fmdom' (txins tx \/ utxo)}" + by simp + then have "\txin. txin \ fmdom' (txins tx \/ utxo) \ fst txin \ txid tx" + by (smt mem_Collect_eq prod.collapse) + moreover have "\txin. txin \ fmdom' (outs tx) \ fst txin = txid tx" + using dom_outs_is_txid by (metis prod.collapse) + ultimately show ?thesis + by blast +qed + text \ UTxO balance \ abbreviation ubalance :: "utxo \ coin" where @@ -65,14 +98,18 @@ type_synonym utxo_state = "utxo \ coin \ coin \ update_stat text \ UTxO inference rules \ -(* NOTE: `ups'` is not defined for now since it involves another transition system. *) +text \ + NOTE: + \<^item> The assumption that the Tx ID must not appear in utxo needs to be made explicit here (see + first precondition). + \<^item> \ups'\ is not defined for now since it involves another transition system. +\ inductive utxo_sts :: "utxo_env \ utxo_state \ tx \ utxo_state \ bool" (\_ \ _ \\<^bsub>UTXO\<^esub>{_} _\ [51, 0, 51] 50) where utxo_inductive: " \ - \ = (slot, pp, stk_creds, stpools, gen_delegs); - s = (utxo, deps, fees, ups); + txid tx \ {tid | tid ix. (tid, ix) \ fmdom' utxo}; txins tx \ {}; txins tx \ fmdom' utxo; consumed pp utxo stk_creds tx = produced pp stpools tx; @@ -80,41 +117,17 @@ inductive utxo_sts :: "utxo_env \ utxo_state \ tx \ \FIXME: Complete later\ - finite (fmdom' utxo) + ups' = ups \ \TODO: Continue later\ \ \ - \ \ s \\<^bsub>UTXO\<^esub>{tx} ( - (txins tx \/ utxo) ++\<^sub>f outs tx, deps + deposit_change, fees + txfee tx + decayed, ups')" - -subsection \ Properties \ - -subsubsection \ Preservation of Value \ - -text \ Lovelace Value \ - -abbreviation val_coin :: "coin \ coin" where - "val_coin c \ c" - -abbreviation val_map :: "('a, coin) fmap \ coin" where - "val_map m \ (\k \ fmdom' m. m $$! k)" - -fun val_utxo_state :: "utxo_state \ coin" where - "val_utxo_state (utxo, deps, fees, ups) = ubalance utxo + deps + fees" - -lemma val_map_split: - assumes "s \ fmdom' m" - shows "val_map m = val_map (s \/ m) + val_map (s \ m)" - oops - -lemma val_map_union: - assumes "fmdom' m\<^sub>1 \ fmdom' m\<^sub>2 = {}" - shows "val_map (m\<^sub>1 ++\<^sub>f m\<^sub>2) = val_map m\<^sub>1 + val_map m\<^sub>2" - oops - -lemma utxo_value_preservation: - assumes "\ \ s \\<^bsub>UTXO\<^esub>{t} s'" - shows "val_utxo_state s + wbalance (txwdrls t) = val_utxo_state s'" - oops + (slot, pp, stk_creds, stpools, gen_delegs) + \ (utxo, deps, fees, ups) + \\<^bsub>UTXO\<^esub>{tx} + ( + (txins tx \/ utxo) ++\<^sub>f outs tx, + deps + deposit_change, + fees + txfee tx + decayed, + ups' + )" end From 9186ef1ba3d25bdee6646edf1b82fa648a519173 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Javier=20D=C3=ADaz?= Date: Mon, 16 Dec 2019 13:24:45 -0300 Subject: [PATCH 06/39] Use facts literally instead of numbers for better readability --- Isabelle/Shelley/Properties.thy | 21 +++++++++++++-------- 1 file changed, 13 insertions(+), 8 deletions(-) diff --git a/Isabelle/Shelley/Properties.thy b/Isabelle/Shelley/Properties.thy index 56ceed4..d5a2382 100644 --- a/Isabelle/Shelley/Properties.thy +++ b/Isabelle/Shelley/Properties.thy @@ -114,8 +114,11 @@ lemma utxo_value_preservation: proof - from assms show ?thesis proof cases - case (utxo_inductive utxo pp stk_creds stpools refunded decayed deposit_change ups' ups slot gen_delegs deps fees) - from utxo_inductive(3) have "val_utxo_state s' = + case (utxo_inductive utxo pp stk_creds stpools refunded decayed deposit_change ups' ups slot + gen_delegs deps fees) + from \s' = + (txins tx \/ utxo ++\<^sub>f outs tx, deps + deposit_change, fees + txfee tx + decayed, ups')\ + have "val_utxo_state s' = val_utxo_state ( (txins tx \/ utxo) ++\<^sub>f outs tx, deps + deposit_change, @@ -139,7 +142,8 @@ proof - by simp also have "\ = val_map (fmmap snd (txins tx \/ utxo)) + val_map (fmmap snd (outs tx))" proof - - from utxo_inductive(4) have "fmdom'(txins tx \/ utxo) \ fmdom' (outs tx) = {}" + from \txid tx \ {tid | tid ix. (tid, ix) \ fmdom' utxo}\ + have "fmdom'(txins tx \/ utxo) \ fmdom' (outs tx) = {}" using txins_outs_exc by blast then show ?thesis using val_map_union by (smt fmdom'_map sum.cong) @@ -149,7 +153,8 @@ proof - finally show ?thesis by linarith qed - also from utxo_inductive(11) have "\ = + also from \deposit_change = deposits pp stpools (txcerts tx) - (refunded + decayed)\ + have "\ = ubalance (txins tx \/ utxo) + ubalance (outs tx) + (deps + deposits pp stpools (txcerts tx) - (refunded + decayed)) + (fees + txfee tx + decayed)" @@ -159,12 +164,12 @@ proof - + deps + deposits pp stpools (txcerts tx) - refunded + fees + txfee tx" by simp - also from utxo_inductive(9) have "\ = + also from \refunded = decayed_tx pp stk_creds tx\ have "\ = ubalance (txins tx \/ utxo) + ubalance (outs tx) + deps + deposits pp stpools (txcerts tx) - key_refunds pp stk_creds tx + fees + txfee tx" by simp - also from utxo_inductive(7) have "\ = + also from \consumed pp utxo stk_creds tx = produced pp stpools tx\ have "\ = ubalance (txins tx \/ utxo) + ubalance (txins tx \ utxo) + wbalance (txwdrls tx) + key_refunds pp stk_creds tx + deps - key_refunds pp stk_creds tx + fees" @@ -181,13 +186,13 @@ proof - also have "\ = val_map (txins tx \/ (fmmap snd utxo)) + val_map (txins tx \ (fmmap snd utxo))" by simp - also from utxo_inductive(6) have "\ = val_map (fmmap snd utxo)" + also from \txins tx \ fmdom' utxo\ have "\ = val_map (fmmap snd utxo)" using val_map_split by (metis fmdom'_map) finally show ?thesis using val_utxo_val_map by simp qed finally show ?thesis - using utxo_inductive(2) by simp + using \s = (utxo, deps, fees, ups)\ by simp qed qed From 278bdac81c4d276a2e28cf6c4971162ec8cf41f0 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Javier=20D=C3=ADaz?= Date: Tue, 17 Dec 2019 14:40:00 -0300 Subject: [PATCH 07/39] Remove resolved comments --- Isabelle/Shelley/Properties.thy | 4 ---- 1 file changed, 4 deletions(-) diff --git a/Isabelle/Shelley/Properties.thy b/Isabelle/Shelley/Properties.thy index d5a2382..f25e25a 100644 --- a/Isabelle/Shelley/Properties.thy +++ b/Isabelle/Shelley/Properties.thy @@ -74,9 +74,6 @@ next finally show ?case . qed -text \ - NOTE: The precondition \s \ fmdom' m\ stated in the document is not really needed. -\ lemma val_map_split: shows "val_map m = val_map (s \/ m) + val_map (s \ m)" proof - @@ -106,7 +103,6 @@ text \ \(addr, coin)\. \<^item> The proof in the document applies lemma 15.4 without proving its precondition, which is not trivial to formalize. - \<^item> This formalization does not rely on Theorem 15.10 (the proof in the document does). \ lemma utxo_value_preservation: assumes "\ \ s \\<^bsub>UTXO\<^esub>{tx} s'" From eceacb993844a4cd9f671a42842e4532c57c7c6c Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Javier=20D=C3=ADaz?= Date: Tue, 17 Dec 2019 14:51:46 -0300 Subject: [PATCH 08/39] Use Isar syntax for inductive definitions --- Isabelle/Shelley/UTxO.thy | 21 +++++++++------------ 1 file changed, 9 insertions(+), 12 deletions(-) diff --git a/Isabelle/Shelley/UTxO.thy b/Isabelle/Shelley/UTxO.thy index b674c20..6e16a40 100644 --- a/Isabelle/Shelley/UTxO.thy +++ b/Isabelle/Shelley/UTxO.thy @@ -108,18 +108,6 @@ inductive utxo_sts :: "utxo_env \ utxo_state \ tx \_ \ _ \\<^bsub>UTXO\<^esub>{_} _\ [51, 0, 51] 50) where utxo_inductive: " - \ - txid tx \ {tid | tid ix. (tid, ix) \ fmdom' utxo}; - txins tx \ {}; - txins tx \ fmdom' utxo; - consumed pp utxo stk_creds tx = produced pp stpools tx; - \(_, c) \ fmran' (txouts tx). c \ 0; - refunded = key_refunds pp stk_creds tx; - decayed = decayed_tx pp stk_creds tx; - deposit_change = deposits pp stpools (txcerts tx) - (refunded + decayed); - ups' = ups \ \TODO: Continue later\ - \ - \ (slot, pp, stk_creds, stpools, gen_delegs) \ (utxo, deps, fees, ups) \\<^bsub>UTXO\<^esub>{tx} @@ -129,5 +117,14 @@ inductive utxo_sts :: "utxo_env \ utxo_state \ tx \ {tid | tid ix. (tid, ix) \ fmdom' utxo}" + and "txins tx \ {}" + and "txins tx \ fmdom' utxo" + and "consumed pp utxo stk_creds tx = produced pp stpools tx" + and "\(_, c) \ fmran' (txouts tx). c \ 0" + and "refunded = key_refunds pp stk_creds tx" + and "decayed = decayed_tx pp stk_creds tx" + and "deposit_change = deposits pp stpools (txcerts tx) - (refunded + decayed)" + and "ups' = ups" \ \TODO: Continue later\ end From 7c6715bc4e5e9b85ef2beaa13463e3c63657109d Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Javier=20D=C3=ADaz?= Date: Tue, 17 Dec 2019 21:52:04 -0300 Subject: [PATCH 09/39] Introduce update transition system --- Isabelle/Shelley/Basic_Types.thy | 4 ++++ Isabelle/Shelley/Cryptography.thy | 4 ++++ Isabelle/Shelley/Properties.thy | 4 ++-- Isabelle/Shelley/Transaction.thy | 13 +++++-------- Isabelle/Shelley/UTxO.thy | 5 ++--- Isabelle/Shelley/Update.thy | 29 +++++++++++++++++++++++++++-- 6 files changed, 44 insertions(+), 15 deletions(-) diff --git a/Isabelle/Shelley/Basic_Types.thy b/Isabelle/Shelley/Basic_Types.thy index 38feef8..5518577 100644 --- a/Isabelle/Shelley/Basic_Types.thy +++ b/Isabelle/Shelley/Basic_Types.thy @@ -50,4 +50,8 @@ text \ Absolute slot \ typedecl slot +text \ Application versions \ + +typedecl applications \ \NOTE: Abstract for now\ + end diff --git a/Isabelle/Shelley/Cryptography.thy b/Isabelle/Shelley/Cryptography.thy index 2e02584..8b3bfb3 100644 --- a/Isabelle/Shelley/Cryptography.thy +++ b/Isabelle/Shelley/Cryptography.thy @@ -8,4 +8,8 @@ text \ Hash of a key \ typedecl key_hash +text \ Genesis key hash \ + +typedecl key_hash_g + end diff --git a/Isabelle/Shelley/Properties.thy b/Isabelle/Shelley/Properties.thy index f25e25a..37a7a3c 100644 --- a/Isabelle/Shelley/Properties.thy +++ b/Isabelle/Shelley/Properties.thy @@ -110,8 +110,8 @@ lemma utxo_value_preservation: proof - from assms show ?thesis proof cases - case (utxo_inductive utxo pp stk_creds stpools refunded decayed deposit_change ups' ups slot - gen_delegs deps fees) + case (utxo_inductive utxo pp stk_creds stpools refunded decayed deposit_change slot + gen_delegs ups ups' deps fees) from \s' = (txins tx \/ utxo ++\<^sub>f outs tx, deps + deposit_change, fees + txfee tx + decayed, ups')\ have "val_utxo_state s' = diff --git a/Isabelle/Shelley/Transaction.thy b/Isabelle/Shelley/Transaction.thy index fa32e78..343a91c 100644 --- a/Isabelle/Shelley/Transaction.thy +++ b/Isabelle/Shelley/Transaction.thy @@ -4,10 +4,6 @@ theory Transaction imports Basic_Types Address Finite_Map_Extras Delegation Update begin -text \ Genesis key hash \ - -typedecl key_hash_g - text \ Transaction ID \ typedecl tx_id @@ -24,10 +20,6 @@ text \ Reward withdrawal \ type_synonym wdrl = "(addr_rwd, coin) fmap" -text \ Update proposal \ - -typedecl update \ \NOTE: Abstract for now\ - text \ Transaction body \ type_synonym tx_body = "tx_in set \ (ix, tx_out) fmap \ d_cert list \ coin \ slot \ wdrl \ update" @@ -67,6 +59,11 @@ fun txfee :: "tx \ coin" where fun txwdrls :: "tx \ wdrl" where "txwdrls ((_, _, _, _, _, wds, _), _) = wds" +\ \Protocol parameter update\ + +fun txup :: "tx \ update" where + "txup ((_, _, _, _, _, _, upd), _) = upd" + text \ Abstract functions \ consts txid :: "tx \ tx_id" diff --git a/Isabelle/Shelley/UTxO.thy b/Isabelle/Shelley/UTxO.thy index 6e16a40..6f44138 100644 --- a/Isabelle/Shelley/UTxO.thy +++ b/Isabelle/Shelley/UTxO.thy @@ -1,7 +1,7 @@ section \ UTxO \ theory UTxO - imports Transaction Finite_Map_Extras Protocol_Parameters Cryptography + imports Transaction Finite_Map_Extras Protocol_Parameters Cryptography Update begin subsection \ Deposits and Refunds \ @@ -102,7 +102,6 @@ text \ NOTE: \<^item> The assumption that the Tx ID must not appear in utxo needs to be made explicit here (see first precondition). - \<^item> \ups'\ is not defined for now since it involves another transition system. \ inductive utxo_sts :: "utxo_env \ utxo_state \ tx \ utxo_state \ bool" (\_ \ _ \\<^bsub>UTXO\<^esub>{_} _\ [51, 0, 51] 50) @@ -125,6 +124,6 @@ inductive utxo_sts :: "utxo_env \ utxo_state \ tx \ \TODO: Continue later\ + and "(slot, pp, gen_delegs) \ ups \\<^bsub>UP\<^esub>{txup tx} ups'" end diff --git a/Isabelle/Shelley/Update.thy b/Isabelle/Shelley/Update.thy index 0d808bb..a4dd742 100644 --- a/Isabelle/Shelley/Update.thy +++ b/Isabelle/Shelley/Update.thy @@ -1,11 +1,36 @@ section \ Update Proposal Mechanism \ theory Update - imports Main + imports Basic_Types Protocol_Parameters Cryptography Finite_Map_Extras begin +text \ Protocol parameter update \ + +typedecl pp_update \ \NOTE: Abstract for now\ + +text \ Application update \ + +typedecl av_update \ \NOTE: Abstract for now\ + +text \ Update proposal \ + +typedecl update \ \NOTE: Abstract for now\ + +text \ Update environment \ + +type_synonym update_env = "slot \ p_params \ (key_hash_g, key_hash) fmap" + text \ Update states \ -typedecl update_state \ \NOTE: Abstract for now\ +type_synonym update_state = "pp_update \ av_update \ (slot, applications) fmap \ applications" + +text \ Update inference rules \ + +inductive update_sts :: "update_env \ update_state \ update \ update_state \ bool" + (\_ \ _ \\<^bsub>UP\<^esub>{_} _\ [51, 0, 51] 50) + where + update: " + \ \ s \\<^bsub>UP\<^esub>{up} s'" + if "s' = s" \ \TODO: Continue later\ end From 38a3c531c325c3a699e9918f0f0a3dee8b40d477 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Javier=20D=C3=ADaz?= Date: Fri, 20 Dec 2019 13:13:56 -0300 Subject: [PATCH 10/39] Remove duplicate declaration --- Isabelle/Shelley/Protocol_Parameters.thy | 4 ---- 1 file changed, 4 deletions(-) diff --git a/Isabelle/Shelley/Protocol_Parameters.thy b/Isabelle/Shelley/Protocol_Parameters.thy index 6de8793..54f0329 100644 --- a/Isabelle/Shelley/Protocol_Parameters.thy +++ b/Isabelle/Shelley/Protocol_Parameters.thy @@ -16,8 +16,4 @@ text \ Protocol parameter map \ type_synonym p_params = "(ppm, pvalue) fmap" -text \ Reward account \ - -typedecl addr_rwd \ \NOTE: Abstract for now\ - end From 40709f89270e1beec206a4ac4a03bdf9b54ef17d Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Javier=20D=C3=ADaz?= Date: Fri, 20 Dec 2019 13:20:09 -0300 Subject: [PATCH 11/39] Introduce value preservation lemma for the DELEG subsystem --- Isabelle/Shelley/Address.thy | 8 +++ Isabelle/Shelley/Delegation.thy | 48 +++++++++++++++++- Isabelle/Shelley/Finite_Map_Extras.thy | 37 ++++++++++++++ Isabelle/Shelley/Properties.thy | 68 ++++++++++++++++++++++++++ 4 files changed, 159 insertions(+), 2 deletions(-) diff --git a/Isabelle/Shelley/Address.thy b/Isabelle/Shelley/Address.thy index c4beb42..3776787 100644 --- a/Isabelle/Shelley/Address.thy +++ b/Isabelle/Shelley/Address.thy @@ -4,6 +4,10 @@ theory Address imports Main begin +text \ Credential \ + +typedecl credential \ \NOTE: Abstract for now\ + text \ Output address \ typedecl addr \ \NOTE: Abstract for now\ @@ -12,4 +16,8 @@ text \ Reward account \ typedecl addr_rwd \ \NOTE: Abstract for now\ +text \ Construct a reward account \ + +consts addr_rwd :: "credential \ addr_rwd" \ \NOTE: Abstract for now\ + end diff --git a/Isabelle/Shelley/Delegation.thy b/Isabelle/Shelley/Delegation.thy index c72dc40..22f4f3d 100644 --- a/Isabelle/Shelley/Delegation.thy +++ b/Isabelle/Shelley/Delegation.thy @@ -1,12 +1,14 @@ section \ Delegation \ theory Delegation - imports Main + imports Finite_Map_Extras Basic_Types Address begin +subsection \ Delegation Definitions \ + text \ Delegation certificate \ -typedecl d_cert \ \NOTE: Abstract for now\ +datatype d_cert = DCert_RegKey | DCert_DeregKey \ \NOTE: Incomplete for now\ text \ Registered stake credential \ @@ -16,4 +18,46 @@ text \ Registered stake pools \ typedecl stake_pools \ \NOTE: Abstract for now\ +text \ Certificate witness \ + +consts cwitness :: "d_cert \ credential" \ \NOTE: Abstract for now\ + +text \ Registered credential \ + +consts reg_cred :: "d_cert \ credential" \ \NOTE: Abstract for now\ + +subsection \ Delegation Transitions \ + +text \ Delegation States \ + +type_synonym d_state = "(addr_rwd, coin) fmap" \ \NOTE: Only rewards for now\ + +text \ Delegation Environment \ + +type_synonym d_env = slot \ \NOTE: Only slot for now\ + +subsection \ Delegation Rules \ + +text \ Delegation Inference Rules \ + +text \ NOTE: + Although \addr_rwd hk \ dom rewards \ hk \ dom stkCreds\ is a property of the system, + it cannot be proven in \DELEG\ alone (but possibly in \DELEGS\). So I had either to add an extra + precondition \addr_rwd hk \ dom rewards\ or use \\\<^sub>\\ instead of \++\<^sub>f\ in rule \deleg_reg\ since + Lemma 15.6 is a property of \DELEG\. + \ + +inductive deleg_sts :: "d_env \ d_state \ d_cert \ d_state \ bool" + (\_ \ _ \\<^bsub>DELEG\<^esub>{_} _\ [51, 0, 51] 50) + where + deleg_reg: " + \ \ rewards \\<^bsub>DELEG\<^esub>{c} rewards \\<^sub>\ {addr_rwd hk $$:= 0}" + if "c = DCert_RegKey" + and "hk = reg_cred c" + | deleg_dereg: " + \ \ rewards \\<^bsub>DELEG\<^esub>{c} {addr_rwd hk} \/ rewards" + if "c = DCert_DeregKey" + and "hk = cwitness c" + and "rewards $$ (addr_rwd hk) = Some 0" + end diff --git a/Isabelle/Shelley/Finite_Map_Extras.thy b/Isabelle/Shelley/Finite_Map_Extras.thy index b853c1e..c531b4e 100644 --- a/Isabelle/Shelley/Finite_Map_Extras.thy +++ b/Isabelle/Shelley/Finite_Map_Extras.thy @@ -112,8 +112,45 @@ text \ Domain exclusion \ abbreviation dom_exc :: "'a set \ ('a, 'b) fmap \ ('a, 'b) fmap" (infixl \\'/\ 150) where "s \/ m \ fmfilter (\x. x \ s) m" +text \ Union override left \ + +abbreviation union_override_left :: "('a, 'b) fmap \ ('a, 'b) fmap \ ('a, 'b) fmap" (infixl \\\<^sub>\\ 100) where + "m\<^sub>1 \\<^sub>\ m\<^sub>2 \ m\<^sub>1 ++\<^sub>f (fmdom' m\<^sub>1 \/ m\<^sub>2)" + text \ Extra lemmas for \\\ and \\/\ \ +lemma dom_res_singleton: + assumes "m $$ k = Some v" + shows "{k} \ m = {k $$:= v}" + using assms +proof (induction m rule: fmap_induct) + case fmempty + then show ?case + by simp +next + case (fmupd k' v' m) + then show ?case + proof (cases "k = k'") + case True + with \m(k' $$:= v') $$ k = Some v\ have "v = v'" + by simp + with True have "{k} \ m(k' $$:= v') = ({k} \ m)(k $$:= v)" + by simp + also from True and \m $$ k' = None\ have "\ = {$$}(k $$:= v)" + by (simp add: fmap_ext) + finally show ?thesis + by simp + next + case False + with \m(k' $$:= v') $$ k = Some v\ have *: "m $$ k = Some v" + by simp + with False have "{k} \ m(k' $$:= v') = {k} \ m" + by simp + with * and fmupd.IH show ?thesis + by simp + qed +qed + lemma dom_exc_add_distr: shows "s \/ (m\<^sub>1 ++\<^sub>f m\<^sub>2) = (s \/ m\<^sub>1) ++\<^sub>f (s \/ m\<^sub>2)" by (blast intro: fmfilter_add_distrib) diff --git a/Isabelle/Shelley/Properties.thy b/Isabelle/Shelley/Properties.thy index 37a7a3c..2d9da88 100644 --- a/Isabelle/Shelley/Properties.thy +++ b/Isabelle/Shelley/Properties.thy @@ -192,4 +192,72 @@ proof - qed qed +fun val_deleg_state :: "d_state \ coin" where + "val_deleg_state rewards = val_map rewards" + +lemma val_map_dom_exc_singleton: + assumes "m $$ k = Some v" + shows "val_map ({k} \/ m) = val_map m - v" +proof - + from assms have *: "val_map ({k} \ m) = val_map {k $$:= v}" + using dom_res_singleton by metis + have "val_map ({k} \/ m) = val_map ({k} \ m) + val_map ({k} \/ m) - val_map ({k} \ m)" + by simp + also have "\ = val_map ({k} \/ m) + val_map ({k} \ m) - val_map ({k} \ m)" + by simp + also have "\ = val_map m - val_map ({k} \ m)" + using val_map_split by metis + also from * and assms have "\ = val_map m - val_map {k $$:= v}" + by linarith + finally show ?thesis + by simp +qed + +lemma delegation_value_preservation: + assumes "\ \ s \\<^bsub>DELEG\<^esub>{c} s'" + shows "val_deleg_state s = val_deleg_state s'" +proof - + from assms show ?thesis + proof cases + case (deleg_reg hk) + from \s' = s \\<^sub>\ {addr_rwd hk $$:= 0}\ + have *: "val_deleg_state s' = val_deleg_state (s \\<^sub>\ {addr_rwd hk $$:= 0})" + by simp + then show ?thesis + proof (cases "addr_rwd hk \ fmdom' s") + case True + then have "s \\<^sub>\ {addr_rwd hk $$:= 0} = s" + by simp + then have "val_deleg_state (s \\<^sub>\ {addr_rwd hk $$:= 0}) = val_deleg_state s" + by simp + with * show ?thesis + by simp + next + case False + then have **: "s \\<^sub>\ {addr_rwd hk $$:= 0} = s ++\<^sub>f {addr_rwd hk $$:= 0}" + by simp + with False have "fmdom' s \ fmdom' {addr_rwd hk $$:= 0} = {}" + by simp + then have "val_map (s ++\<^sub>f {addr_rwd hk $$:= 0}) = val_map s + val_map {addr_rwd hk $$:= 0}" + using val_map_union by blast + also have "\ = val_map s + 0" + by simp + finally have "val_deleg_state (s ++\<^sub>f {addr_rwd hk $$:= 0}) = val_deleg_state s" + by auto + with * and ** show ?thesis + by presburger + qed + next + case (deleg_dereg hk) + then have "val_deleg_state s' = val_map s'" + by simp + also from \s' = {addr_rwd hk} \/ s\ have "\ = val_map ({addr_rwd hk} \/ s)" + by simp + also from \s $$ (addr_rwd hk) = Some 0\ have "\ = val_map s - 0" + using val_map_dom_exc_singleton by fast + finally show ?thesis + by simp + qed +qed + end From 6f79bef03213656d36f5028771ef921da3a46942 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Javier=20D=C3=ADaz?= Date: Mon, 23 Dec 2019 19:00:06 -0300 Subject: [PATCH 12/39] Introduce value preservation lemma for the DELEGS subsystem --- Isabelle/Shelley/Delegation.thy | 78 ++++++--- Isabelle/Shelley/Delegation_Certificates.thy | 29 ++++ Isabelle/Shelley/Finite_Map_Extras.thy | 60 ++++++- Isabelle/Shelley/Properties.thy | 172 ++++++++++++++++++- Isabelle/Shelley/ROOT | 1 + Isabelle/Shelley/Transaction.thy | 2 +- 6 files changed, 303 insertions(+), 39 deletions(-) create mode 100644 Isabelle/Shelley/Delegation_Certificates.thy diff --git a/Isabelle/Shelley/Delegation.thy b/Isabelle/Shelley/Delegation.thy index 22f4f3d..f332bdb 100644 --- a/Isabelle/Shelley/Delegation.thy +++ b/Isabelle/Shelley/Delegation.thy @@ -1,37 +1,17 @@ section \ Delegation \ theory Delegation - imports Finite_Map_Extras Basic_Types Address + imports Finite_Map_Extras Basic_Types Address Delegation_Certificates Transaction begin -subsection \ Delegation Definitions \ - -text \ Delegation certificate \ - -datatype d_cert = DCert_RegKey | DCert_DeregKey \ \NOTE: Incomplete for now\ - -text \ Registered stake credential \ - -typedecl stake_creds \ \NOTE: Abstract for now\ - -text \ Registered stake pools \ - -typedecl stake_pools \ \NOTE: Abstract for now\ - -text \ Certificate witness \ - -consts cwitness :: "d_cert \ credential" \ \NOTE: Abstract for now\ - -text \ Registered credential \ - -consts reg_cred :: "d_cert \ credential" \ \NOTE: Abstract for now\ - subsection \ Delegation Transitions \ text \ Delegation States \ type_synonym d_state = "(addr_rwd, coin) fmap" \ \NOTE: Only rewards for now\ +typedecl p_state \ \NOTE: Abstract for now\ + text \ Delegation Environment \ type_synonym d_env = slot \ \NOTE: Only slot for now\ @@ -40,8 +20,10 @@ subsection \ Delegation Rules \ text \ Delegation Inference Rules \ -text \ NOTE: - Although \addr_rwd hk \ dom rewards \ hk \ dom stkCreds\ is a property of the system, +text \ + NOTE: + \<^item> Only the \deleg_reg\ and \deleg_dereg\ rules are included for now. + \<^item> Although \addr_rwd hk \ dom rewards \ hk \ dom stkCreds\ is a property of the system, it cannot be proven in \DELEG\ alone (but possibly in \DELEGS\). So I had either to add an extra precondition \addr_rwd hk \ dom rewards\ or use \\\<^sub>\\ instead of \++\<^sub>f\ in rule \deleg_reg\ since Lemma 15.6 is a property of \DELEG\. @@ -60,4 +42,50 @@ inductive deleg_sts :: "d_env \ d_state \ d_cert \ Delegation and Pool Combined Rules \ + +text \ Delegation and Pool Combined Environment \ + +type_synonym d_p_env = slot \ \NOTE: Only slot for now\ + +text \ Delegation and Pool Combined State \ + +type_synonym d_p_state = "d_state \ p_state" + +text \ Delegation and Pool Combined Transition Rules \ + +text \ + NOTE: + \<^item> Only the \delpl_deleg\ rule is included for now. +\ +inductive delpl_sts :: "d_p_env \ d_p_state \ d_cert \ d_p_state \ bool" + (\_ \ _ \\<^bsub>DELPL\<^esub>{_} _\ [51, 0, 51] 50) + where + delpl_deleg: " + slot \ (dstate, pstate) \\<^bsub>DELPL\<^esub>{c} (dstate', pstate)" + if "slot \ dstate \\<^bsub>DELEG\<^esub>{c} dstate'" + +text \ Certificate Sequence Environment \ + +type_synonym d_p_s_env = "slot \ tx" + +text \ Delegation sequence rules \ + +text \ + NOTE: + \<^item> The first and second preconditions in the \seq_delg_ind\ rule are not included for now. +\ +inductive delegs_sts :: "d_p_s_env \ d_p_state \ d_cert list \ d_p_state \ bool" + (\_ \ _ \\<^bsub>DELEGS\<^esub>{_} _\ [51, 0, 51] 50) + where + seq_delg_base: " + (slot, tx) \ (rewards, pstate) \\<^bsub>DELEGS\<^esub>{[]} (rewards', pstate)" + if "wdrls = txwdrls tx" + and "wdrls \\<^sub>f rewards" + and "rewards' = rewards \\<^sub>\ fmmap (\_. 0) wdrls" + | seq_delg_ind: " + (slot, tx) \ dpstate \\<^bsub>DELEGS\<^esub>{\ @ [c]} dpstate''" + if "(slot, tx) \ dpstate \\<^bsub>DELEGS\<^esub>{\} dpstate'" + and "slot \ dpstate' \\<^bsub>DELPL\<^esub>{c} dpstate''" + end diff --git a/Isabelle/Shelley/Delegation_Certificates.thy b/Isabelle/Shelley/Delegation_Certificates.thy new file mode 100644 index 0000000..d5f2f8c --- /dev/null +++ b/Isabelle/Shelley/Delegation_Certificates.thy @@ -0,0 +1,29 @@ +section \ Delegation certificates \ + +theory Delegation_Certificates + imports Address +begin + +subsection \ Delegation Definitions \ + +text \ Delegation certificate \ + +datatype d_cert = DCert_RegKey | DCert_DeregKey \ \NOTE: Incomplete for now\ + +text \ Registered stake credential \ + +typedecl stake_creds \ \NOTE: Abstract for now\ + +text \ Registered stake pools \ + +typedecl stake_pools \ \NOTE: Abstract for now\ + +text \ Certificate witness \ + +consts cwitness :: "d_cert \ credential" \ \NOTE: Abstract for now\ + +text \ Registered credential \ + +consts reg_cred :: "d_cert \ credential" \ \NOTE: Abstract for now\ + +end diff --git a/Isabelle/Shelley/Finite_Map_Extras.thy b/Isabelle/Shelley/Finite_Map_Extras.thy index c531b4e..1d06a47 100644 --- a/Isabelle/Shelley/Finite_Map_Extras.thy +++ b/Isabelle/Shelley/Finite_Map_Extras.thy @@ -45,7 +45,7 @@ lemma fmap_singleton_comm: assumes "m $$ k = None" shows "m ++\<^sub>f {k $$:= v} = {k $$:= v} ++\<^sub>f m" using assms -proof (induction m arbitrary: k v rule: fmap_induct) +proof (induction m arbitrary: k v) case fmempty then show ?case by simp @@ -78,7 +78,7 @@ lemma fmap_disj_comm: assumes "fmdom' m\<^sub>1 \ fmdom' m\<^sub>2 = {}" shows "m\<^sub>1 ++\<^sub>f m\<^sub>2 = m\<^sub>2 ++\<^sub>f m\<^sub>1" using assms -proof (induction m\<^sub>2 arbitrary: m\<^sub>1 rule: fmap_induct) +proof (induction m\<^sub>2 arbitrary: m\<^sub>1) case fmempty then show ?case by simp @@ -97,11 +97,50 @@ next by simp next case False - then show ?thesis - using fmupd.prems by auto + with fmupd.prems show ?thesis + by auto qed qed +(* TODO: Find a nicer proof *) +lemma fmran_singleton: "fmran {k $$:= v} = {|v|}" +proof - + have "\v'. v' |\| fmran {k $$:= v} \ v' = v" + by (metis fmdom_empty fmdom_fmupd fmdom_notD fmranE fmupd_lookup fsingleton_iff + option.distinct(1) option.sel) + moreover have "v |\| fmran {k $$:= v}" + by (simp add: fmranI) + ultimately show ?thesis + by (simp add: fsubsetI fsubset_antisym) +qed + +text \ Map difference \ + +abbreviation + fmdiff :: "('a, 'b) fmap \ ('a, 'b) fmap \ ('a, 'b) fmap" (infixl \--\<^sub>f\ 100) where + "m\<^sub>1 --\<^sub>f m\<^sub>2 \ fmfilter (\x. x \ fmdom' m\<^sub>2) m\<^sub>1" + +(* TODO: Find a nicer proof *) +lemma fmdiff_partition: + assumes "m\<^sub>2 \\<^sub>f m\<^sub>1" + shows "m\<^sub>2 ++\<^sub>f (m\<^sub>1 --\<^sub>f m\<^sub>2) = m\<^sub>1" +proof - + from assms have *: "m\<^sub>2 ++\<^sub>f (m\<^sub>1 --\<^sub>f m\<^sub>2) \\<^sub>f m\<^sub>1" + by (smt fmfilter_subset fmlookup_add fmpred_iff fmsubset_alt_def) + then have "m\<^sub>1 \\<^sub>f m\<^sub>2 ++\<^sub>f (m\<^sub>1 --\<^sub>f m\<^sub>2)" + by (simp add: fmsubset.rep_eq map_le_def) + with * show ?thesis + by (metis (no_types, lifting) domIff fmap_ext fmsubset.rep_eq map_le_def) +qed + +(* TODO: Find a nicer proof *) +lemma fmdiff_fmupd: + assumes "m $$ k = None" + shows "m(k $$:= v) --\<^sub>f {k $$:= v} = m" + using assms + by (smt Diff_iff Diff_insert_absorb fmdom'_empty fmdom'_fmupd fmdom'_notD fmdom'_notI + fmfilter_true fmfilter_upd option.simps(3) singletonI) + text \ Domain restriction \ abbreviation dom_res :: "'a set \ ('a, 'b) fmap \ ('a, 'b) fmap" (infixl \\\ 150) where @@ -112,9 +151,16 @@ text \ Domain exclusion \ abbreviation dom_exc :: "'a set \ ('a, 'b) fmap \ ('a, 'b) fmap" (infixl \\'/\ 150) where "s \/ m \ fmfilter (\x. x \ s) m" +text \ Union override right \ + +abbreviation union_override_right :: "('a, 'b) fmap \ ('a, 'b) fmap \ ('a, 'b) fmap" + (infixl \\\<^sub>\\ 100) where + "m\<^sub>1 \\<^sub>\ m\<^sub>2 \ (fmdom' m\<^sub>2 \/ m\<^sub>1) ++\<^sub>f m\<^sub>2" + text \ Union override left \ -abbreviation union_override_left :: "('a, 'b) fmap \ ('a, 'b) fmap \ ('a, 'b) fmap" (infixl \\\<^sub>\\ 100) where +abbreviation union_override_left :: "('a, 'b) fmap \ ('a, 'b) fmap \ ('a, 'b) fmap" + (infixl \\\<^sub>\\ 100) where "m\<^sub>1 \\<^sub>\ m\<^sub>2 \ m\<^sub>1 ++\<^sub>f (fmdom' m\<^sub>1 \/ m\<^sub>2)" text \ Extra lemmas for \\\ and \\/\ \ @@ -123,7 +169,7 @@ lemma dom_res_singleton: assumes "m $$ k = Some v" shows "{k} \ m = {k $$:= v}" using assms -proof (induction m rule: fmap_induct) +proof (induction m) case fmempty then show ?case by simp @@ -157,7 +203,7 @@ lemma dom_exc_add_distr: lemma fmap_partition: shows "m = s \/ m ++\<^sub>f s \ m" -proof (induction m rule: fmap_induct) +proof (induction m) case fmempty then show ?case by simp diff --git a/Isabelle/Shelley/Properties.thy b/Isabelle/Shelley/Properties.thy index 2d9da88..5515331 100644 --- a/Isabelle/Shelley/Properties.thy +++ b/Isabelle/Shelley/Properties.thy @@ -1,7 +1,7 @@ section \ Properties \ theory Properties - imports UTxO + imports UTxO Delegation begin subsection \ Preservation of Value \ @@ -37,11 +37,12 @@ proof - by simp qed +\ \NOTE: Lemma 15.4 in the spec.\ lemma val_map_union: assumes "fmdom' m\<^sub>1 \ fmdom' m\<^sub>2 = {}" shows "val_map (m\<^sub>1 ++\<^sub>f m\<^sub>2) = val_map m\<^sub>1 + val_map m\<^sub>2" using assms -proof (induction m\<^sub>2 arbitrary: m\<^sub>1 rule: fmap_induct) +proof (induction m\<^sub>2 arbitrary: m\<^sub>1) case fmempty then show ?case by simp @@ -60,7 +61,7 @@ next ultimately have "k \ fmdom' (m\<^sub>1 ++\<^sub>f m\<^sub>2)" by simp then show ?thesis - using val_map_add by (metis sum.cong) + using val_map_add by metis qed also from fmupd.prems and fmupd.IH have "\ = val_map m\<^sub>1 + val_map m\<^sub>2 + c" by simp @@ -74,6 +75,7 @@ next finally show ?case . qed +\ \NOTE: Lemma 15.3 in the spec.\ lemma val_map_split: shows "val_map m = val_map (s \/ m) + val_map (s \ m)" proof - @@ -98,6 +100,7 @@ qed text \ NOTE: + \<^item> Lemma 15.5 in the spec. \<^item> The proof in the document applies lemmas 15.3 and 15.4 on \utxo\'s, however this is incorrect since the range of \utxo\ is not \coin\ but \(addr, coin)\. @@ -105,7 +108,7 @@ text \ precondition, which is not trivial to formalize. \ lemma utxo_value_preservation: - assumes "\ \ s \\<^bsub>UTXO\<^esub>{tx} s'" + assumes "e \ s \\<^bsub>UTXO\<^esub>{tx} s'" shows "val_utxo_state s + wbalance (txwdrls tx) = val_utxo_state s'" proof - from assms show ?thesis @@ -213,8 +216,9 @@ proof - by simp qed -lemma delegation_value_preservation: - assumes "\ \ s \\<^bsub>DELEG\<^esub>{c} s'" +\ \NOTE: Lemma 15.6 in the spec.\ +lemma deleg_value_preservation: + assumes "e \ s \\<^bsub>DELEG\<^esub>{c} s'" shows "val_deleg_state s = val_deleg_state s'" proof - from assms show ?thesis @@ -260,4 +264,160 @@ proof - qed qed +fun val_delegs_state :: "d_p_state \ coin" where + "val_delegs_state (rewards, _) = val_deleg_state rewards" + +lemma val_map_minus: + assumes "m\<^sub>2 \\<^sub>f m\<^sub>1" + shows "val_map (m\<^sub>1 --\<^sub>f m\<^sub>2) = val_map m\<^sub>1 - val_map m\<^sub>2" + using assms +proof (induction m\<^sub>2 arbitrary: m\<^sub>1) + case fmempty + then show ?case + by simp +next + case (fmupd k v m\<^sub>2) + have "val_map (m\<^sub>1 --\<^sub>f m\<^sub>2(k $$:= v)) = val_map ({k} \/ (m\<^sub>1 --\<^sub>f m\<^sub>2))" + by simp + also have "\ = val_map ({k} \/ m\<^sub>1) - val_map m\<^sub>2" + proof - + from fmupd.prems and fmupd.hyps have "m\<^sub>2 \\<^sub>f {k} \/ m\<^sub>1" + using fmdiff_fmupd + by (metis fmdom'_empty fmdom'_fmupd fmdrop_set_single fmfilter_alt_defs(2) fmsubset_drop_mono) + with fmupd.IH have "val_map ({k} \/ m\<^sub>1) - val_map m\<^sub>2 = val_map (fmdom' m\<^sub>2 \/ ({k} \/ m\<^sub>1))" + by presburger + then show ?thesis + by (metis fmfilter_comm) + qed + also have "\ = (val_map m\<^sub>1 - v) - val_map m\<^sub>2" + proof - + from fmupd.prems have "m\<^sub>1 $$ k = Some v" + by (fastforce simp add: fmsubset_alt_def) + with fmupd.prems show ?thesis + using val_map_dom_exc_singleton by fastforce + qed + also have "\ = val_map m\<^sub>1 - val_map (m\<^sub>2(k $$:= v))" + proof - + have "\ = val_map m\<^sub>1 - (val_map m\<^sub>2 + v)" + by simp + with fmupd.hyps show ?thesis + using val_map_add by (metis fmdom'_notI) + qed + finally show ?case . +qed + +lemma fmran_fmmap_const: + assumes "m \ {$$}" + shows "fmran (fmmap (\_. v) m) = {|v|}" + using assms +proof (induction m) + case fmempty + then show ?case by simp +next + case (fmupd k' v' m) + then show ?case + proof (cases "m \ {$$}") + case True + have "fmmap (\_. v) m(k' $$:= v') = fmmap (\_. v) m ++\<^sub>f {k' $$:= v}" + by (smt dom_res_singleton dom_res_singleton fmadd_empty(1) fmadd_empty(1) fmadd_empty(2) fmfilter_fmmap fmlookup_map fmmap_add fmupd_alt_def fmupd_lookup option.simps(9)) + then have "fmran (fmmap (\_. v) m(k' $$:= v')) = fmran (fmmap (\_. v) m ++\<^sub>f {k' $$:= v})" + by simp + also have "\ = fmran (fmmap (\_. v) m) |\| fmran {k' $$:= v}" + proof - + from \m $$ k' = None\ have "fmdom (fmmap (\_. v) m) |\| fmdom {k' $$:= v} = {||}" + by (simp add: fmdom_notI) + with \m $$ k' = None\ show ?thesis + by (smt finter_absorb finter_commute finter_funion_distrib2 fmadd_restrict_right_dom fmap_singleton_comm fmdom_add fmdom_map fmdom_notD fmdom_notI fmimage_dom fmimage_union fmran_restrict_fset) + qed + also from True and fmupd.IH have "\ = {|v|} |\| fmran {k' $$:= v}" + by simp + finally show ?thesis + by (simp add: fmran_singleton) + next + case False + then have "fmmap (\_. v) m(k' $$:= v') = {k' $$:= v}" + by (smt dom_res_singleton dom_res_singleton fmadd_empty(1) fmadd_empty(1) fmadd_empty(2) fmfilter_fmmap fmlookup_map fmmap_add fmupd_alt_def fmupd_lookup option.simps(9)) + then show ?thesis + by (simp add: fmran_singleton) + qed +qed + +lemma val_map_subset_zeroing: + assumes "m\<^sub>2 \\<^sub>f m\<^sub>1" + shows "val_map (m\<^sub>1 \\<^sub>\ fmmap (\_. 0::coin) m\<^sub>2) = val_map (m\<^sub>1 --\<^sub>f m\<^sub>2)" + using assms +proof (cases "m\<^sub>2 = {$$}") + case True + then show ?thesis + by auto +next + case False + let ?m = "fmmap (\_. 0::coin) m\<^sub>2" + have "fmdom' (fmdom' ?m \/ m\<^sub>1) \ fmdom' ?m = {}" + by auto + then have "val_map (m\<^sub>1 \\<^sub>\ ?m) = val_map (fmdom' ?m \/ m\<^sub>1) + val_map ?m" + using val_map_union by blast + also have "\ = val_map (fmdom' ?m \/ m\<^sub>1)" + proof - + from False have "fmran ?m = {|0::coin|}" + using fmran_fmmap_const by simp + then show ?thesis + by (smt fmdom'_map fmlookup_dom'_iff fmlookup_map option.map(2) option.sel + sum.not_neutral_contains_not_neutral) + qed + also have *: "\ = val_map m\<^sub>1 - val_map (fmdom' ?m \ m\<^sub>1)" + using val_map_split by (metis add.commute add_diff_cancel_left') + finally show ?thesis + using \m\<^sub>2 \\<^sub>f m\<^sub>1\ and * and val_map_minus by force +qed + +\ \NOTE: Lemma 15.7 in the spec.\ +lemma delegs_value_preservation: + assumes "(slot, tx) \ (rewards, pstate) \\<^bsub>DELEGS\<^esub>{\} (rewards', pstate)" + shows "val_delegs_state (rewards, pstate) = + val_delegs_state (rewards', pstate) + wbalance (txwdrls tx)" + using assms +proof (induction "(slot, tx)" "(rewards, pstate)" \ "(rewards', pstate)" arbitrary: slot tx rewards + pstate rewards' rule: delegs_sts.induct) + case (seq_delg_base wdrls tx rewards rewards' slot pstate) + have "val_delegs_state (rewards, pstate) = val_map rewards" + by simp + also have "\ = val_map wdrls + val_map (rewards --\<^sub>f wdrls)" + proof - + from \wdrls \\<^sub>f rewards\ have "rewards = wdrls ++\<^sub>f (rewards --\<^sub>f wdrls)" + by (simp add: fmdiff_partition) + moreover have "fmdom' wdrls \ fmdom' (rewards --\<^sub>f wdrls) = {}" + by auto + ultimately show ?thesis + using val_map_union by metis + qed + also from \wdrls = txwdrls tx\ have "\ = val_map (rewards --\<^sub>f wdrls) + wbalance (txwdrls tx)" + by auto + also from \wdrls \\<^sub>f rewards\ have "\ = + val_map (rewards \\<^sub>\ fmmap (\_. 0) wdrls) + wbalance (txwdrls tx)" + using val_map_subset_zeroing by fastforce + also from \rewards' = rewards \\<^sub>\ fmmap (\_. 0) wdrls\ have "\ = + val_map rewards' + wbalance (txwdrls tx)" + by simp + finally show ?case + by simp +next + case (seq_delg_ind slot tx \ dpstate' c) + from \slot \ dpstate' \\<^bsub>DELPL\<^esub>{c} (rewards', pstate)\ have "snd dpstate' = pstate" + using delpl_sts.simps by auto + with seq_delg_ind.hyps(2) have "val_delegs_state (rewards, pstate) = + val_delegs_state (fst dpstate', pstate) + val_map (txwdrls tx)" + by auto + moreover have "val_deleg_state (fst dpstate') = val_deleg_state rewards'" + proof - + from \slot \ dpstate' \\<^bsub>DELPL\<^esub>{c} (rewards', pstate)\ + have "slot \ (fst dpstate') \\<^bsub>DELEG\<^esub>{c} rewards'" + using delpl_sts.simps by auto + then show ?thesis + using deleg_value_preservation by simp + qed + ultimately show ?case + by simp +qed + end diff --git a/Isabelle/Shelley/ROOT b/Isabelle/Shelley/ROOT index a35bd35..0ffaf9e 100644 --- a/Isabelle/Shelley/ROOT +++ b/Isabelle/Shelley/ROOT @@ -13,6 +13,7 @@ session Shelley (ledgerformalization) = HOL + Transaction Update UTxO + Delegation_Certificates Delegation Properties document_files diff --git a/Isabelle/Shelley/Transaction.thy b/Isabelle/Shelley/Transaction.thy index 343a91c..e167e3a 100644 --- a/Isabelle/Shelley/Transaction.thy +++ b/Isabelle/Shelley/Transaction.thy @@ -1,7 +1,7 @@ section \ Transactions \ theory Transaction - imports Basic_Types Address Finite_Map_Extras Delegation Update + imports Basic_Types Address Finite_Map_Extras Delegation_Certificates Update begin text \ Transaction ID \ From 4680d3063ae2ac99b5ef5ea8d6b84a4bdf3b2682 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Javier=20D=C3=ADaz?= Date: Sun, 29 Dec 2019 12:46:37 -0300 Subject: [PATCH 13/39] Introduce value preservation lemma for the POOLREAP subsystem --- Isabelle/Shelley/Basic_Types.thy | 6 +- Isabelle/Shelley/Finite_Map_Extras.thy | 40 ++++++- Isabelle/Shelley/Properties.thy | 154 ++++++++++++++++++++++++- Isabelle/Shelley/Rewards.thy | 48 ++++++++ 4 files changed, 244 insertions(+), 4 deletions(-) create mode 100644 Isabelle/Shelley/Rewards.thy diff --git a/Isabelle/Shelley/Basic_Types.thy b/Isabelle/Shelley/Basic_Types.thy index 5518577..ffc1d39 100644 --- a/Isabelle/Shelley/Basic_Types.thy +++ b/Isabelle/Shelley/Basic_Types.thy @@ -4,7 +4,11 @@ theory Basic_Types imports "HOL-Library.Countable" begin -text \ Coin \ +text \ Epoch \ + +typedecl epoch + +text \ Unit of value \ type_synonym coin = int diff --git a/Isabelle/Shelley/Finite_Map_Extras.thy b/Isabelle/Shelley/Finite_Map_Extras.thy index 1d06a47..46a3c2d 100644 --- a/Isabelle/Shelley/Finite_Map_Extras.thy +++ b/Isabelle/Shelley/Finite_Map_Extras.thy @@ -141,6 +141,11 @@ lemma fmdiff_fmupd: by (smt Diff_iff Diff_insert_absorb fmdom'_empty fmdom'_fmupd fmdom'_notD fmdom'_notI fmfilter_true fmfilter_upd option.simps(3) singletonI) +text \ Map symmetric difference \ + +abbreviation fmsym_diff :: "('a, 'b) fmap \ ('a, 'b) fmap \ ('a, 'b) fmap" (infixl "\\<^sub>f" 100) where + "m\<^sub>1 \\<^sub>f m\<^sub>2 \ (m\<^sub>1 --\<^sub>f m\<^sub>2) ++\<^sub>f (m\<^sub>2 --\<^sub>f m\<^sub>1)" + text \ Domain restriction \ abbreviation dom_res :: "'a set \ ('a, 'b) fmap \ ('a, 'b) fmap" (infixl \\\ 150) where @@ -151,18 +156,34 @@ text \ Domain exclusion \ abbreviation dom_exc :: "'a set \ ('a, 'b) fmap \ ('a, 'b) fmap" (infixl \\'/\ 150) where "s \/ m \ fmfilter (\x. x \ s) m" +text \ Intersection plus \ + +abbreviation intersection_plus :: "('a, 'b::monoid_add) fmap \ ('a, 'b) fmap \ ('a, 'b) fmap" + (infixl "\\<^sub>+" 100) +where + "m\<^sub>1 \\<^sub>+ m\<^sub>2 \ fmmap_keys (\k v. v + m\<^sub>1 $$! k) (fmdom' m\<^sub>1 \ m\<^sub>2)" + text \ Union override right \ abbreviation union_override_right :: "('a, 'b) fmap \ ('a, 'b) fmap \ ('a, 'b) fmap" - (infixl \\\<^sub>\\ 100) where + (infixl \\\<^sub>\\ 100) +where "m\<^sub>1 \\<^sub>\ m\<^sub>2 \ (fmdom' m\<^sub>2 \/ m\<^sub>1) ++\<^sub>f m\<^sub>2" text \ Union override left \ abbreviation union_override_left :: "('a, 'b) fmap \ ('a, 'b) fmap \ ('a, 'b) fmap" - (infixl \\\<^sub>\\ 100) where + (infixl \\\<^sub>\\ 100) +where "m\<^sub>1 \\<^sub>\ m\<^sub>2 \ m\<^sub>1 ++\<^sub>f (fmdom' m\<^sub>1 \/ m\<^sub>2)" +text \ Union override plus \ + +abbreviation union_override_plus :: "('a, 'b::monoid_add) fmap \ ('a, 'b) fmap \ ('a, 'b) fmap" + (infixl \\\<^sub>+\ 100) +where + "m\<^sub>1 \\<^sub>+ m\<^sub>2 \ (m\<^sub>1 \\<^sub>f m\<^sub>2) ++\<^sub>f (m\<^sub>1 \\<^sub>+ m\<^sub>2)" + text \ Extra lemmas for \\\ and \\/\ \ lemma dom_res_singleton: @@ -197,6 +218,21 @@ next qed qed +(* TODO: Find a nicer proof *) +lemma dom_res_union_distr: + shows "(A \ B) \ m = A \ m ++\<^sub>f B \ m" +proof - + have "(A \ B) \ m \\<^sub>f A \ m ++\<^sub>f B \ m" + by (smt Un_iff domIff dom_fmlookup fmdom'_add fmdom'_filter fmfilter_subset fmlookup_add + fmsubset.rep_eq map_le_def member_filter) + moreover have "A \ m ++\<^sub>f B \ m \\<^sub>f (A \ B) \ m" + by (smt Un_iff domIff dom_fmlookup fmdom'_filter fmfilter_subset fmlookup_add fmsubset.rep_eq + map_le_def member_filter) + ultimately show ?thesis + by (smt Un_iff domIff dom_fmlookup fmadd_empty(2) fmdiff_partition fmdom'_add fmfilter_false + option.simps(3)) +qed + lemma dom_exc_add_distr: shows "s \/ (m\<^sub>1 ++\<^sub>f m\<^sub>2) = (s \/ m\<^sub>1) ++\<^sub>f (s \/ m\<^sub>2)" by (blast intro: fmfilter_add_distrib) diff --git a/Isabelle/Shelley/Properties.thy b/Isabelle/Shelley/Properties.thy index 5515331..b5a0627 100644 --- a/Isabelle/Shelley/Properties.thy +++ b/Isabelle/Shelley/Properties.thy @@ -1,7 +1,7 @@ section \ Properties \ theory Properties - imports UTxO Delegation + imports UTxO Delegation Rewards begin subsection \ Preservation of Value \ @@ -420,4 +420,156 @@ next by simp qed +fun val_poolreap_state :: "pl_reap_state \ coin" where + "val_poolreap_state ((_, deps, _, _), (treasury, _), rewards, _) = + val_coin deps + val_coin treasury + val_map rewards" + +lemma val_map_fmmap_keys: + assumes "fmdom' m\<^sub>2 \ fmdom' m\<^sub>1" + shows "val_map (fmmap_keys (\k v. v + m\<^sub>1 $$! k) m\<^sub>2) = val_map (fmdom' m\<^sub>2 \ m\<^sub>1) + val_map m\<^sub>2" + using assms +proof (induction m\<^sub>2) + case fmempty + then show ?case + by auto +next + case (fmupd x y m\<^sub>2) + have "val_map (fmmap_keys (\k v. v + m\<^sub>1 $$! k) m\<^sub>2(x $$:= y)) = + val_map (fmmap_keys (\k v. v + m\<^sub>1 $$! k) m\<^sub>2 ++\<^sub>f {x $$:= y + m\<^sub>1 $$! x})" + proof - + have "fmmap_keys (\k v. v + m\<^sub>1 $$! k) m\<^sub>2(x $$:= y) = + fmmap_keys (\k v. v + m\<^sub>1 $$! k) m\<^sub>2 ++\<^sub>f {x $$:= y + m\<^sub>1 $$! x}" + by transfer' (auto simp add: fmap_ext) + then show ?thesis + by simp + qed + also have "\ = + val_map (fmmap_keys (\k v. v + m\<^sub>1 $$! k) m\<^sub>2) + val_map {x $$:= y + m\<^sub>1 $$! x}" + proof - + from \m\<^sub>2 $$ x = None\ + have "fmdom' (fmmap_keys (\k v. v + m\<^sub>1 $$! k) m\<^sub>2) \ fmdom' {x $$:= y + m\<^sub>1 $$! x} = {}" + by (simp add: fmdom'_notI) + then show ?thesis + using val_map_union by blast + qed + also have "\ = val_map (fmmap_keys (\k v. v + m\<^sub>1 $$! k) m\<^sub>2) + (y + m\<^sub>1 $$! x)" + by simp + also from \fmdom' m\<^sub>2(x $$:= y) \ fmdom' m\<^sub>1\ and fmupd.IH have "\ = + val_map (fmdom' m\<^sub>2 \ m\<^sub>1) + val_map m\<^sub>2 + (y + m\<^sub>1 $$! x)" + by simp + also have "\ = (val_map (fmdom' m\<^sub>2 \ m\<^sub>1) + m\<^sub>1 $$! x) + (val_map m\<^sub>2 + y)" + by simp + also have "\ = val_map (fmdom' m\<^sub>2(x $$:= y) \ m\<^sub>1) + val_map m\<^sub>2(x $$:= y)" + proof - + have "val_map (fmdom' m\<^sub>2 \ m\<^sub>1) + m\<^sub>1 $$! x = val_map (fmdom' m\<^sub>2(x $$:= y) \ m\<^sub>1)" + proof - + from \m\<^sub>2 $$ x = None\ have "val_map (fmdom' m\<^sub>2(x $$:= y) \ m\<^sub>1) = val_map ((fmdom' m\<^sub>2 \ {x}) \ m\<^sub>1)" + by simp + also have "\ = val_map ((fmdom' m\<^sub>2 \ m\<^sub>1) ++\<^sub>f ({x} \ m\<^sub>1))" + using dom_res_union_distr by metis + also have "\ = val_map (fmdom' m\<^sub>2 \ m\<^sub>1) + val_map ({x} \ m\<^sub>1)" + proof - + from \fmdom' m\<^sub>2(x $$:= y) \ fmdom' m\<^sub>1\ have "fmdom' (fmdom' m\<^sub>2 \ m\<^sub>1) = fmdom' m\<^sub>2" + by (auto simp add: fmfilter_alt_defs(4)) + moreover from \fmdom' m\<^sub>2(x $$:= y) \ fmdom' m\<^sub>1\ have "fmdom' ({x} \ m\<^sub>1) = {x}" + by (auto simp add: equalityI) + ultimately have "fmdom' (fmdom' m\<^sub>2 \ m\<^sub>1) \ fmdom' ({x} \ m\<^sub>1) = {}" + using \m\<^sub>2 $$ x = None\ by (simp add: fmdom'_notI) + then show ?thesis + using val_map_union by blast + qed + also have "\ = val_map (fmdom' m\<^sub>2 \ m\<^sub>1) + m\<^sub>1 $$! x" + proof - + from \fmdom' m\<^sub>2(x $$:= y) \ fmdom' m\<^sub>1\ have "x \ fmdom' m\<^sub>1" by simp + then have "fmdom' ({x} \ m\<^sub>1) = {x}" + by (auto simp add: equalityI) + then show ?thesis + by simp + qed + finally show ?thesis + by simp + qed + moreover from \m\<^sub>2 $$ x = None\ have "val_map m\<^sub>2(x $$:= y) = val_map m\<^sub>2 + y" + using val_map_add by (metis fmdom'_notI) + ultimately show ?thesis + by linarith + qed + finally show ?case . +qed + +lemma val_map_inter_plus: + assumes "fmdom' m\<^sub>2 \ fmdom' m\<^sub>1" + shows "val_map (m\<^sub>1 \\<^sub>+ m\<^sub>2) = val_map (fmdom' m\<^sub>2 \ m\<^sub>1) + val_map m\<^sub>2" +proof - + from \fmdom' m\<^sub>2 \ fmdom' m\<^sub>1\ have "m\<^sub>1 \\<^sub>+ m\<^sub>2 = fmmap_keys (\k v. v + m\<^sub>1 $$! k) m\<^sub>2" + by (metis Un_iff fmdom'I fmfilter_true subset_Un_eq) + then have "val_map (m\<^sub>1 \\<^sub>+ m\<^sub>2) = val_map (fmmap_keys (\k v. v + m\<^sub>1 $$! k) m\<^sub>2)" + by simp + also from \fmdom' m\<^sub>2 \ fmdom' m\<^sub>1\ have "\ = val_map (fmdom' m\<^sub>2 \ m\<^sub>1) + val_map m\<^sub>2" + using val_map_fmmap_keys by blast + finally show ?thesis . +qed + +lemma val_map_sym_diff: + assumes "fmdom' m\<^sub>2 \ fmdom' m\<^sub>1" + shows "val_map (m\<^sub>1 \\<^sub>f m\<^sub>2) = val_map m\<^sub>1 - val_map (fmdom' m\<^sub>2 \ m\<^sub>1)" +proof - + from \fmdom' m\<^sub>2 \ fmdom' m\<^sub>1\ have "m\<^sub>1 \\<^sub>f m\<^sub>2 = m\<^sub>1 --\<^sub>f m\<^sub>2" + by (metis Un_iff fmadd_empty(2) fmdom'I fmfilter_false subset_Un_eq) + then have "val_map (m\<^sub>1 \\<^sub>f m\<^sub>2) = val_map (m\<^sub>1 --\<^sub>f m\<^sub>2)" + by simp + also from \fmdom' m\<^sub>2 \ fmdom' m\<^sub>1\ have "\ = val_map m\<^sub>1 - val_map (fmdom' m\<^sub>2 \ m\<^sub>1)" + using val_map_split by (metis add_diff_cancel_right') + finally show ?thesis . +qed + +\ \NOTE: Lemma 15.8 in the spec.\ +lemma poolreap_value_preservation: + assumes "e \ s \\<^bsub>POOLREAP\<^esub>{\} s'" + shows "val_poolreap_state s = val_poolreap_state s'" +proof - + from assms show ?thesis + proof cases + case (pool_reap reward_acnts' refunds rewards m_refunds refunded unclaimed utxo deps fees ups + treasury reserves pstate) + from pool_reap(2) have "val_poolreap_state s' = + deps - (unclaimed + refunded) + treasury + unclaimed + val_map (rewards \\<^sub>+ refunds)" + by simp + also have "\ = deps - refunded + treasury + val_map (rewards \\<^sub>+ refunds)" + by simp + also have "\ = deps - refunded + treasury + val_map rewards + val_map refunds" + proof - + have "val_map (rewards \\<^sub>+ refunds) = val_map rewards + val_map refunds" + proof - + have "val_map (rewards \\<^sub>+ refunds) = + val_map (rewards \\<^sub>f refunds) + val_map (rewards \\<^sub>+ refunds)" + proof - + from \refunds = fmdom' rewards \ reward_acnts'\ + have "fmdom' (rewards \\<^sub>f refunds) \ fmdom' (rewards \\<^sub>+ refunds) = {}" + by (smt Int_emptyI fmadd_empty(2) fmdom'_filter fmdom'_notI fmfilter_false + fmlookup_restrict_set fmrestrict_set_dom fmrestrict_set_fmmap_keys member_filter + option.distinct(1)) (* TODO: Find a nicer proof. *) + then show ?thesis + using val_map_union by blast + qed + also have "\ = val_map rewards - val_map (fmdom' refunds \ rewards) + + val_map (fmdom' refunds \ rewards) + val_map refunds" + proof - + from \refunds = fmdom' rewards \ reward_acnts'\ have "fmdom' refunds \ fmdom' rewards" + by auto + then show ?thesis + using val_map_sym_diff and val_map_inter_plus by fastforce + qed + finally show ?thesis + by simp + qed + then show ?thesis + by linarith + qed + finally show ?thesis + using \s = ((utxo, deps, fees, ups), (treasury, reserves), rewards, pstate)\ and + \refunded = val_map refunds\ by simp + qed +qed + end diff --git a/Isabelle/Shelley/Rewards.thy b/Isabelle/Shelley/Rewards.thy new file mode 100644 index 0000000..cb3e05f --- /dev/null +++ b/Isabelle/Shelley/Rewards.thy @@ -0,0 +1,48 @@ +section \ Rewards and the Epoch Boundary \ +theory Rewards + imports UTxO Delegation Protocol_Parameters +begin + +subsection \ Helper Functions and Accounting Fields \ + +text \ Accounting Fields \ + +type_synonym acnt = "coin \ coin" + +subsection \ Pool Reaping Transition \ + +text \ Pool Reap State \ + +type_synonym pl_reap_state = "utxo_state \ acnt \ d_state \ p_state" + +text \ Pool Reap Inference Rule \ + +text \ + NOTE: + \<^item> \reward_acnts'\ is undefined for now. +\ +inductive poolreap_sts :: "p_params \ pl_reap_state \ epoch \ pl_reap_state \ bool" + (\_ \ _ \\<^bsub>POOLREAP\<^esub>{_} _\ [51, 0, 51] 50) + where + pool_reap: " + pp \ + ( + (utxo, deps, fees, ups), + (treasury, reserves), + rewards, + pstate + ) + \\<^bsub>POOLREAP\<^esub>{e} + ( + (utxo, deps - (unclaimed + refunded), fees, ups), + (treasury + unclaimed, reserves), + rewards \\<^sub>+ refunds, + pstate + )" + if "reward_acnts' = undefined" + and "refunds = fmdom' rewards \ reward_acnts'" + and "m_refunds = fmdom' rewards \/ reward_acnts'" + and "refunded = (\k \ fmdom' refunds. refunds $$! k)" + and "unclaimed = (\k \ fmdom' m_refunds. m_refunds $$! k)" + +end From a08612f542a78ed4f542475409e18f672485269a Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Javier=20D=C3=ADaz?= Date: Sun, 29 Dec 2019 14:01:00 -0300 Subject: [PATCH 14/39] Add `Rewards` theory to `ROOT` --- Isabelle/Shelley/ROOT | 1 + 1 file changed, 1 insertion(+) diff --git a/Isabelle/Shelley/ROOT b/Isabelle/Shelley/ROOT index 0ffaf9e..cc7b583 100644 --- a/Isabelle/Shelley/ROOT +++ b/Isabelle/Shelley/ROOT @@ -15,6 +15,7 @@ session Shelley (ledgerformalization) = HOL + UTxO Delegation_Certificates Delegation + Rewards Properties document_files "root.tex" From 13e858894d51fad0b77c219735e19485bd5ec5e8 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Javier=20D=C3=ADaz?= Date: Thu, 9 Jan 2020 12:31:30 -0300 Subject: [PATCH 15/39] Introduce value preservation lemma 15.9 from the spec --- Isabelle/Shelley/Address.thy | 4 + Isabelle/Shelley/Delegation.thy | 22 +- Isabelle/Shelley/Delegation_Certificates.thy | 8 +- Isabelle/Shelley/Finite_Map_Extras.thy | 318 ++++++++++++- Isabelle/Shelley/Ledger.thy | 11 + Isabelle/Shelley/Properties.thy | 447 +++++++++++++++---- Isabelle/Shelley/Protocol_Parameters.thy | 14 +- Isabelle/Shelley/ROOT | 1 + Isabelle/Shelley/Rewards.thy | 109 ++++- 9 files changed, 825 insertions(+), 109 deletions(-) create mode 100644 Isabelle/Shelley/Ledger.thy diff --git a/Isabelle/Shelley/Address.thy b/Isabelle/Shelley/Address.thy index 3776787..3ff71ef 100644 --- a/Isabelle/Shelley/Address.thy +++ b/Isabelle/Shelley/Address.thy @@ -7,6 +7,8 @@ begin text \ Credential \ typedecl credential \ \NOTE: Abstract for now\ +axiomatization where credential_linorder: "OFCLASS(credential, linorder_class)" +instance credential :: linorder by (rule credential_linorder) text \ Output address \ @@ -15,6 +17,8 @@ typedecl addr \ \NOTE: Abstract for now\ text \ Reward account \ typedecl addr_rwd \ \NOTE: Abstract for now\ +axiomatization where addr_rwd_linorder: "OFCLASS(addr_rwd, linorder_class)" +instance addr_rwd :: linorder by (rule addr_rwd_linorder) text \ Construct a reward account \ diff --git a/Isabelle/Shelley/Delegation.thy b/Isabelle/Shelley/Delegation.thy index f332bdb..7acc0f1 100644 --- a/Isabelle/Shelley/Delegation.thy +++ b/Isabelle/Shelley/Delegation.thy @@ -8,7 +8,11 @@ subsection \ Delegation Transitions \ text \ Delegation States \ -type_synonym d_state = "(addr_rwd, coin) fmap" \ \NOTE: Only rewards for now\ +\ \NOTE: Only \stkCreds\, \rewards\ and \i\<^sub>r\<^sub>w\<^sub>d\ for now\ +type_synonym d_state = " + stake_creds \ \ \registered stake delegators\ + (addr_rwd, coin) fmap \ \ \rewards\ + (credential, coin) fmap \ \instantaneous rewards\" typedecl p_state \ \NOTE: Abstract for now\ @@ -28,19 +32,26 @@ text \ precondition \addr_rwd hk \ dom rewards\ or use \\\<^sub>\\ instead of \++\<^sub>f\ in rule \deleg_reg\ since Lemma 15.6 is a property of \DELEG\. \ - inductive deleg_sts :: "d_env \ d_state \ d_cert \ d_state \ bool" (\_ \ _ \\<^bsub>DELEG\<^esub>{_} _\ [51, 0, 51] 50) where deleg_reg: " - \ \ rewards \\<^bsub>DELEG\<^esub>{c} rewards \\<^sub>\ {addr_rwd hk $$:= 0}" + slot \ + (stk_creds, rewards, i\<^sub>r\<^sub>w\<^sub>d) + \\<^bsub>DELEG\<^esub>{c} + (stk_creds ++\<^sub>f {hk $$:= slot}, rewards \\<^sub>\ {addr_rwd hk $$:= 0}, i\<^sub>r\<^sub>w\<^sub>d)" if "c = DCert_RegKey" and "hk = reg_cred c" + and "hk \ fmdom' stk_creds" | deleg_dereg: " - \ \ rewards \\<^bsub>DELEG\<^esub>{c} {addr_rwd hk} \/ rewards" + slot \ + (stk_creds, rewards, i\<^sub>r\<^sub>w\<^sub>d) + \\<^bsub>DELEG\<^esub>{c} + ({hk} \/ stk_creds, {addr_rwd hk} \/ rewards, i\<^sub>r\<^sub>w\<^sub>d)" if "c = DCert_DeregKey" and "hk = cwitness c" and "rewards $$ (addr_rwd hk) = Some 0" + and "hk \ fmdom' stk_creds" subsection \ Delegation and Pool Combined Rules \ @@ -79,7 +90,8 @@ inductive delegs_sts :: "d_p_s_env \ d_p_state \ d_cert (\_ \ _ \\<^bsub>DELEGS\<^esub>{_} _\ [51, 0, 51] 50) where seq_delg_base: " - (slot, tx) \ (rewards, pstate) \\<^bsub>DELEGS\<^esub>{[]} (rewards', pstate)" + (slot, tx) \ + ((stk_creds, rewards, i\<^sub>r\<^sub>w\<^sub>d), pstate) \\<^bsub>DELEGS\<^esub>{[]} ((stk_creds, rewards', i\<^sub>r\<^sub>w\<^sub>d), pstate)" if "wdrls = txwdrls tx" and "wdrls \\<^sub>f rewards" and "rewards' = rewards \\<^sub>\ fmmap (\_. 0) wdrls" diff --git a/Isabelle/Shelley/Delegation_Certificates.thy b/Isabelle/Shelley/Delegation_Certificates.thy index d5f2f8c..4057ddb 100644 --- a/Isabelle/Shelley/Delegation_Certificates.thy +++ b/Isabelle/Shelley/Delegation_Certificates.thy @@ -1,7 +1,7 @@ section \ Delegation certificates \ theory Delegation_Certificates - imports Address + imports Address Basic_Types Finite_Map_Extras begin subsection \ Delegation Definitions \ @@ -12,12 +12,16 @@ datatype d_cert = DCert_RegKey | DCert_DeregKey \ \NOTE: Incomple text \ Registered stake credential \ -typedecl stake_creds \ \NOTE: Abstract for now\ +type_synonym stake_creds = "(credential, slot) fmap" text \ Registered stake pools \ typedecl stake_pools \ \NOTE: Abstract for now\ +text \ Stake pools parameters \ + +typedecl pool_param \ \NOTE: Abstract for now\ + text \ Certificate witness \ consts cwitness :: "d_cert \ credential" \ \NOTE: Abstract for now\ diff --git a/Isabelle/Shelley/Finite_Map_Extras.thy b/Isabelle/Shelley/Finite_Map_Extras.thy index 46a3c2d..3665927 100644 --- a/Isabelle/Shelley/Finite_Map_Extras.thy +++ b/Isabelle/Shelley/Finite_Map_Extras.thy @@ -102,8 +102,7 @@ next qed qed -(* TODO: Find a nicer proof *) -lemma fmran_singleton: "fmran {k $$:= v} = {|v|}" +lemma fmran_singleton: "fmran {k $$:= v} = {|v|}" (* TODO: Find a nicer proof *) proof - have "\v'. v' |\| fmran {k $$:= v} \ v' = v" by (metis fmdom_empty fmdom_fmupd fmdom_notD fmranE fmupd_lookup fsingleton_iff @@ -114,14 +113,236 @@ proof - by (simp add: fsubsetI fsubset_antisym) qed +lemma fmmap_keys_hom: + assumes "fmdom' m\<^sub>1 \ fmdom' m\<^sub>2 = {}" + shows "fmmap_keys f (m\<^sub>1 ++\<^sub>f m\<^sub>2) = fmmap_keys f m\<^sub>1 ++\<^sub>f fmmap_keys f m\<^sub>2" + using assms + by (simp add: fmap_ext) + +lemma map_insort_is_insort_key: + assumes "m $$ k = None" + shows "map (\k'. (k', m(k $$:= v) $$! k')) (insort k xs) = + insort_key fst (k, v) (map (\k'. (k', m(k $$:= v) $$! k')) xs)" + using assms by (induction xs) auto + +lemma sorted_list_of_fmap_is_insort_key_fst: + assumes "m $$ k = None" + shows "sorted_list_of_fmap m(k $$:= v) = insort_key fst (k, v) (sorted_list_of_fmap m)" +proof - + have "sorted_list_of_fmap m(k $$:= v) = + map (\k'. (k', m(k $$:= v) $$! k')) (sorted_list_of_fset (fmdom (m(k $$:= v))))" + unfolding sorted_list_of_fmap_def .. + also have "\ = map (\k'. (k', m(k $$:= v) $$! k')) (sorted_list_of_fset (finsert k (fmdom m)))" + by simp + also from \m $$ k = None\ have "\ = + map (\k'. (k', m(k $$:= v) $$! k')) (insort k (sorted_list_of_fset (fmdom m - {|k|})))" + by (simp add: sorted_list_of_fset.rep_eq) + also from \m $$ k = None\ have "\ = + map (\k'. (k', m(k $$:= v) $$! k')) (insort k (sorted_list_of_fset (fmdom m)))" + by (simp add: fmdom_notI) + also from \m $$ k = None\ have "\ = + insort_key fst (k, v) (map (\k'. (k', m(k $$:= v) $$! k')) (sorted_list_of_fset (fmdom m)))" + using map_insort_is_insort_key by fastforce + also have "\ = insort_key fst (k, v) (map (\k'. (k', m $$! k')) (sorted_list_of_fset (fmdom m)))" + proof - + from \m $$ k = None\ have "\k'. k' \ fmdom' m \ m(k $$:= v) $$! k' = m $$! k'" + using fmdom'_notI by force + moreover from \m $$ k = None\ have "k \ set (sorted_list_of_fset (fmdom m))" + using fmdom'_alt_def and fmdom'_notI and in_set_member by force + ultimately show ?thesis + by (metis (mono_tags, lifting) fmdom'_alt_def map_eq_conv sorted_list_of_fset_simps(1)) + qed + finally show ?thesis + by (simp add: sorted_list_of_fmap_def) +qed + +lemma distinct_fst_inj: + assumes "distinct (map fst ps)" + and "inj f" + shows "distinct (map fst (map (\(k, v). (f k, v)) ps))" +proof - + have "map fst (map (\(k, v). (f k, v)) ps) = map f (map fst ps)" + by (induction ps) auto + moreover from assms have "distinct (map f (map fst ps))" + by (simp add: distinct_map inj_on_def) + ultimately show ?thesis + by presburger +qed + +lemma distinct_sorted_list_of_fmap: + shows "distinct (map fst (sorted_list_of_fmap m))" + unfolding sorted_list_of_fmap_def and sorted_list_of_fset_def + by (simp add: distinct_map inj_on_def) + +lemma map_inj_pair_non_membership: + assumes "k \ set (map fst ps)" + and "inj f" + shows "f k \ set (map fst (map (\(k, v). (f k, v)) ps))" + using assms by (induction ps) (simp add: member_rec(2), fastforce simp add: injD) + +lemma map_insort_key_fst: + assumes "distinct (map fst ps)" + and "k \ set (map fst ps)" + and "inj f" + and "mono f" + shows "map (\(k, v). (f k, v)) (insort_key fst (k, v) ps) = + insort_key fst (f k, v) (map (\(k, v). (f k, v)) ps)" + using assms +proof (induction ps) + case Nil + then show ?case + by simp +next + let ?g = "(\(k, v). (f k, v))" + case (Cons p ps) + then show ?case + proof (cases "k \ fst p") + case True + let ?f_p = "(f (fst p), snd p)" + have "insort_key fst (f k, v) (map ?g (p # ps)) = insort_key fst (f k, v) (?f_p # map ?g ps)" + by (simp add: prod.case_eq_if) + moreover from Cons.prems(4) and True have "f k \ f (fst p)" + by (auto dest: monoE) + then have "insort_key fst (f k, v) (?f_p # map ?g ps) = (f k, v) # ?f_p # map ?g ps" + by simp + ultimately have "insort_key fst (f k, v) (map ?g (p # ps)) = (f k, v) # ?f_p # map ?g ps" + by simp + moreover from True have "map ?g (insort_key fst (k, v) (p # ps)) = (f k, v) # ?f_p # map ?g ps" + by (simp add: case_prod_beta') + ultimately show ?thesis + by simp + next + case False + let ?f_p = "(f (fst p), snd p)" + have "insort_key fst (f k, v) (map ?g (p # ps)) = insort_key fst (f k, v) (?f_p # map ?g ps)" + by (simp add: prod.case_eq_if) + moreover from \mono f\ and False have "f (fst p) \ f k" + using not_le by (blast dest: mono_invE) + ultimately have "insort_key fst (f k, v) (map ?g (p # ps)) = + ?f_p # insort_key fst (f k, v) (map ?g ps)" + using False and \inj f\ by (fastforce dest: injD) + also from Cons.IH and Cons.prems(1,2) and assms(3,4) have "\ = + ?f_p # (map ?g (insort_key fst (k, v) ps))" + by (fastforce simp add: member_rec(1)) + also have "\ = map ?g (p # insort_key fst (k, v) ps)" + by (simp add: case_prod_beta) + finally show ?thesis + using False by simp + qed +qed + +lemma map_sorted_list_of_fmap: + assumes "inj f" + and "mono f" + and "m $$ k = None" + shows "map (\(k, v). (f k, v)) (sorted_list_of_fmap m(k $$:= v)) = + insort_key fst (f k, v) (map (\(k, v). (f k, v)) (sorted_list_of_fmap m))" +proof - + let ?g = "(\(k, v). (f k, v))" + from \m $$ k = None\ have "map ?g (sorted_list_of_fmap m(k $$:= v)) = + map ?g (insort_key fst (k, v) (sorted_list_of_fmap m))" + using sorted_list_of_fmap_is_insort_key_fst by fastforce + also have "\ = insort_key fst (f k, v) (map ?g (sorted_list_of_fmap m))" + proof - + have "distinct (map fst (sorted_list_of_fmap m))" + by (simp add: distinct_sorted_list_of_fmap) + moreover from \m $$ k = None\ have "k \ set (map fst (sorted_list_of_fmap m))" + by (metis image_set map_of_eq_None_iff map_of_sorted_list) + ultimately show ?thesis + by (simp add: map_insort_key_fst assms(1,2)) + qed + finally show ?thesis . +qed + +lemma fmap_of_list_insort_key_fst: + assumes "distinct (map fst ps)" + and "k \ set (map fst ps)" + shows "fmap_of_list (insort_key fst (k, v) ps) = (fmap_of_list ps)(k $$:= v)" + using assms +proof (induction ps) + case Nil + then show ?case + by simp +next + case (Cons p ps) + then show ?case + proof (cases "k \ fst p") + case True + then show ?thesis + by simp + next + case False + then have "fmap_of_list (insort_key fst (k, v) (p # ps)) = + fmap_of_list (p # insort_key fst (k, v) ps)" + by simp + also have "\ = (fmap_of_list (insort_key fst (k, v) ps))(fst p $$:= snd p)" + by (metis fmap_of_list_simps(2) prod.collapse) + also from Cons.prems(1,2) and Cons.IH have "\ = (fmap_of_list ps)(k $$:= v)(fst p $$:= snd p)" + by (fastforce simp add: member_rec(1)) + finally show ?thesis + proof - + assume *: "fmap_of_list (insort_key fst (k, v) (p # ps)) = + (fmap_of_list ps)(k $$:= v)(fst p $$:= snd p)" + from Cons.prems(2) have "k \ set (fst p # map fst ps)" + by simp + then have **: "{k $$:= v} $$ (fst p) = None" + by (fastforce simp add: member_rec(1)) + have "fmap_of_list (p # ps) = (fmap_of_list ps)(fst p $$:= snd p)" + by (metis fmap_of_list_simps(2) prod.collapse) + with * and ** show ?thesis + using fmap_singleton_comm by (metis fmadd_fmupd fmap_of_list_simps(1,2) fmupd_alt_def) + qed + qed +qed + +lemma fmap_of_list_insort_key_fst_map: + assumes "inj f" + and "m $$ k = None" + shows "fmap_of_list (insort_key fst (f k, v) (map (\(k, v). (f k, v)) (sorted_list_of_fmap m))) = + (fmap_of_list (map (\(k, v). (f k, v)) (sorted_list_of_fmap m)))(f k $$:= v)" +proof - + let ?g = "\(k, v). (f k, v)" + let ?ps = "map ?g (sorted_list_of_fmap m)" + from \inj f\ have "distinct (map fst ?ps)" + using distinct_fst_inj and distinct_sorted_list_of_fmap by fastforce + moreover have "f k \ set (map fst ?ps)" + proof - + from \m $$ k = None\ have "k \ set (map fst (sorted_list_of_fmap m))" + by (metis map_of_eq_None_iff map_of_sorted_list set_map) + with \inj f\ show ?thesis + using map_inj_pair_non_membership by force + qed + ultimately show ?thesis + using fmap_of_list_insort_key_fst by fast +qed + +lemma fmap_of_list_sorted_list_of_fmap: + fixes m :: "('a::linorder, 'b) fmap" + and f :: "'a \ 'c::linorder" + assumes "inj f" + and "mono f" + and "m $$ k = None" + shows "fmap_of_list (map (\(k, v). (f k, v)) (sorted_list_of_fmap m(k $$:= v))) = + (fmap_of_list (map (\(k, v). (f k, v)) (sorted_list_of_fmap m)))(f k $$:= v)" +proof - + let ?g = "\(k, v). (f k, v)" + from assms(3) have "fmap_of_list (map ?g (sorted_list_of_fmap m(k $$:= v))) = + fmap_of_list (map ?g (insort_key fst (k, v) (sorted_list_of_fmap m)))" + by (simp add: sorted_list_of_fmap_is_insort_key_fst) + also from assms have "\ = fmap_of_list (insort_key fst (f k, v) (map ?g (sorted_list_of_fmap m)))" + using calculation and map_sorted_list_of_fmap by fastforce + also from assms(1,3) have "\ = (fmap_of_list (map ?g (sorted_list_of_fmap m)))(f k $$:= v)" + by (simp add: fmap_of_list_insort_key_fst_map) + finally show ?thesis . +qed + text \ Map difference \ abbreviation fmdiff :: "('a, 'b) fmap \ ('a, 'b) fmap \ ('a, 'b) fmap" (infixl \--\<^sub>f\ 100) where "m\<^sub>1 --\<^sub>f m\<^sub>2 \ fmfilter (\x. x \ fmdom' m\<^sub>2) m\<^sub>1" -(* TODO: Find a nicer proof *) -lemma fmdiff_partition: +lemma fmdiff_partition: (* TODO: Find a nicer proof *) assumes "m\<^sub>2 \\<^sub>f m\<^sub>1" shows "m\<^sub>2 ++\<^sub>f (m\<^sub>1 --\<^sub>f m\<^sub>2) = m\<^sub>1" proof - @@ -133,8 +354,7 @@ proof - by (metis (no_types, lifting) domIff fmap_ext fmsubset.rep_eq map_le_def) qed -(* TODO: Find a nicer proof *) -lemma fmdiff_fmupd: +lemma fmdiff_fmupd: (* TODO: Find a nicer proof *) assumes "m $$ k = None" shows "m(k $$:= v) --\<^sub>f {k $$:= v} = m" using assms @@ -143,7 +363,7 @@ lemma fmdiff_fmupd: text \ Map symmetric difference \ -abbreviation fmsym_diff :: "('a, 'b) fmap \ ('a, 'b) fmap \ ('a, 'b) fmap" (infixl "\\<^sub>f" 100) where +abbreviation fmsym_diff :: "('a, 'b) fmap \ ('a, 'b) fmap \ ('a, 'b) fmap" (infixl \\\<^sub>f\ 100) where "m\<^sub>1 \\<^sub>f m\<^sub>2 \ (m\<^sub>1 --\<^sub>f m\<^sub>2) ++\<^sub>f (m\<^sub>2 --\<^sub>f m\<^sub>1)" text \ Domain restriction \ @@ -159,7 +379,7 @@ abbreviation dom_exc :: "'a set \ ('a, 'b) fmap \ ('a, ' text \ Intersection plus \ abbreviation intersection_plus :: "('a, 'b::monoid_add) fmap \ ('a, 'b) fmap \ ('a, 'b) fmap" - (infixl "\\<^sub>+" 100) + (infixl \\\<^sub>+\ 100) where "m\<^sub>1 \\<^sub>+ m\<^sub>2 \ fmmap_keys (\k v. v + m\<^sub>1 $$! k) (fmdom' m\<^sub>1 \ m\<^sub>2)" @@ -184,7 +404,7 @@ abbreviation union_override_plus :: "('a, 'b::monoid_add) fmap \ ('a where "m\<^sub>1 \\<^sub>+ m\<^sub>2 \ (m\<^sub>1 \\<^sub>f m\<^sub>2) ++\<^sub>f (m\<^sub>1 \\<^sub>+ m\<^sub>2)" -text \ Extra lemmas for \\\ and \\/\ \ +text \ Extra lemmas for the non-standard map operators \ lemma dom_res_singleton: assumes "m $$ k = Some v" @@ -218,8 +438,7 @@ next qed qed -(* TODO: Find a nicer proof *) -lemma dom_res_union_distr: +lemma dom_res_union_distr: (* TODO: Find a nicer proof *) shows "(A \ B) \ m = A \ m ++\<^sub>f B \ m" proof - have "(A \ B) \ m \\<^sub>f A \ m ++\<^sub>f B \ m" @@ -278,4 +497,81 @@ next qed qed +lemma dom_res_addition_in: + assumes "m\<^sub>1 $$ k = None" + and "m\<^sub>2 $$ k = Some v'" + shows "fmdom' m\<^sub>1(k $$:= v) \ m\<^sub>2 = fmdom' m\<^sub>1 \ m\<^sub>2 ++\<^sub>f {k $$:= v'}" +proof - + from \m\<^sub>1 $$ k = None\ have "fmdom' m\<^sub>1(k $$:= v) \ m\<^sub>2 = (fmdom' m\<^sub>1 \ {k}) \ m\<^sub>2" + by simp + also have "\ = fmdom' m\<^sub>1 \ m\<^sub>2 ++\<^sub>f {k} \ m\<^sub>2" + using dom_res_union_distr . + finally show ?thesis + using \m\<^sub>2 $$ k = Some v'\ and dom_res_singleton by fastforce +qed + +lemma inter_plus_addition_in: (* TODO: Find nicer proofs for SMT calls. *) + assumes "m\<^sub>1 $$ k = None" + and "m\<^sub>2 $$ k = Some v'" + shows "m\<^sub>1(k $$:= v) \\<^sub>+ m\<^sub>2 = (m\<^sub>1 \\<^sub>+ m\<^sub>2) ++\<^sub>f {k $$:= v' + v}" +proof - + from assms have "m\<^sub>1(k $$:= v) \\<^sub>+ m\<^sub>2 = + fmmap_keys (\k' v'. v' + m\<^sub>1(k $$:= v) $$! k') ((fmdom' m\<^sub>1 \ m\<^sub>2) ++\<^sub>f {k $$:= v'})" + using dom_res_addition_in by fastforce + also have "\ = fmmap_keys (\k' v'. v' + m\<^sub>1(k $$:= v) $$! k') (fmdom' m\<^sub>1 \ m\<^sub>2) + ++\<^sub>f fmmap_keys (\k' v'. v' + m\<^sub>1(k $$:= v) $$! k') {k $$:= v'}" + proof - + from \m\<^sub>1 $$ k = None\ have "fmdom' (fmdom' m\<^sub>1 \ m\<^sub>2) \ fmdom' {k $$:= v'} = {}" + by (simp add: fmdom'_notI) + then show ?thesis + using fmmap_keys_hom by blast + qed + also from assms + have "\ = fmmap_keys (\k' v'. v' + m\<^sub>1(k $$:= v) $$! k') (fmdom' m\<^sub>1 \ m\<^sub>2) ++\<^sub>f {k $$:= v' + v}" + using dom_res_singleton by (smt domIff dom_fmlookup fmfilter_fmmap_keys fmlookup_dom'_iff + fmlookup_fmmap_keys fmupd_lookup map_option_is_None option.map_sel option.sel) + also have "\ = fmmap_keys (\k' v'. v' + m\<^sub>1 $$! k') (fmdom' m\<^sub>1 \ m\<^sub>2) ++\<^sub>f {k $$:= v' + v}" + by (simp add: fmap_ext) + finally show ?thesis . +qed + +lemma inter_plus_addition_notin: (* TODO: Find nicer proofs for SMT calls. *) + assumes "m\<^sub>1 $$ k = None" + and "m\<^sub>2 $$ k = None" + shows "m\<^sub>1(k $$:= v) \\<^sub>+ m\<^sub>2 = (m\<^sub>1 \\<^sub>+ m\<^sub>2)" +proof - + from \m\<^sub>2 $$ k = None\ + have "m\<^sub>1(k $$:= v) \\<^sub>+ m\<^sub>2 = fmmap_keys (\k' v'. v' + m\<^sub>1(k $$:= v) $$! k') (fmdom' m\<^sub>1 \ m\<^sub>2)" + by (smt fmdom'_fmupd fmdom'_notI fmfilter_cong' insert_iff) + also have "\ = fmmap_keys (\k' v'. v' + m\<^sub>1 $$! k') (fmdom' m\<^sub>1 \ m\<^sub>2)" + proof (intro fmap_ext) + fix k' + from \m\<^sub>1 $$ k = None\ + show "fmmap_keys (\k' v'. v' + m\<^sub>1(k $$:= v) $$! k') (fmdom' m\<^sub>1 \ m\<^sub>2) $$ k' = + fmmap_keys (\k' v'. v' + m\<^sub>1 $$! k') (fmdom' m\<^sub>1 \ m\<^sub>2) $$ k'" + by (smt domIff dom_fmlookup fmdiff_fmupd fmlookup_filter fmlookup_fmmap_keys + map_option_is_None option.expand option.map_sel) + qed + finally show ?thesis . +qed + +lemma union_plus_addition_notin: (* TODO: Find nicer proofs for SMT calls. *) + assumes "m\<^sub>1 $$ k = None" + and "m\<^sub>2 $$ k = None" + shows "m\<^sub>1(k $$:= v) \\<^sub>+ m\<^sub>2 = (m\<^sub>1 \\<^sub>+ m\<^sub>2) ++\<^sub>f {k $$:= v}" +proof - + from \m\<^sub>2 $$ k = None\ have "m\<^sub>1(k $$:= v) \\<^sub>+ m\<^sub>2 = + fmdom' m\<^sub>2 \/ m\<^sub>1 ++\<^sub>f {k $$:= v} ++\<^sub>f fmdom' m\<^sub>1(k $$:= v) \/ m\<^sub>2 ++\<^sub>f (m\<^sub>1(k $$:= v) \\<^sub>+ m\<^sub>2)" + by (simp add: fmdom'_notI) + also from assms have "\ = + fmdom' m\<^sub>2 \/ m\<^sub>1 ++\<^sub>f {k $$:= v} ++\<^sub>f fmdom' m\<^sub>1 \/ m\<^sub>2 ++\<^sub>f (m\<^sub>1(k $$:= v) \\<^sub>+ m\<^sub>2)" + by (smt fmdom'_fmupd fmfilter_cong insert_iff option.distinct(1)) + also from assms have "\ = fmdom' m\<^sub>2 \/ m\<^sub>1 ++\<^sub>f {k $$:= v} ++\<^sub>f fmdom' m\<^sub>1 \/ m\<^sub>2 ++\<^sub>f (m\<^sub>1 \\<^sub>+ m\<^sub>2)" + using inter_plus_addition_notin by metis + also from assms have "\ = fmdom' m\<^sub>2 \/ m\<^sub>1 ++\<^sub>f fmdom' m\<^sub>1 \/ m\<^sub>2 ++\<^sub>f (m\<^sub>1 \\<^sub>+ m\<^sub>2) ++\<^sub>f {k $$:= v}" + using fmap_singleton_comm + by (smt fmadd_assoc fmfilter_fmmap_keys fmlookup_filter fmlookup_fmmap_keys) + finally show ?thesis . +qed + end diff --git a/Isabelle/Shelley/Ledger.thy b/Isabelle/Shelley/Ledger.thy new file mode 100644 index 0000000..04a8703 --- /dev/null +++ b/Isabelle/Shelley/Ledger.thy @@ -0,0 +1,11 @@ +section \ Ledger State Transition \ + +theory Ledger + imports UTxO Delegation +begin + +text \ Ledger state \ + +type_synonym l_state = "utxo_state \ d_p_state" + +end diff --git a/Isabelle/Shelley/Properties.thy b/Isabelle/Shelley/Properties.thy index b5a0627..9217246 100644 --- a/Isabelle/Shelley/Properties.thy +++ b/Isabelle/Shelley/Properties.thy @@ -21,18 +21,18 @@ fun val_utxo_state :: "utxo_state \ coin" where "val_utxo_state (utxo, deps, fees, _) = val_utxo utxo + deps + fees" lemma val_map_add: - assumes "k \ fmdom' m" + assumes "m $$ k = None" shows "val_map m(k $$:= c) = val_map m + c" proof - let ?m' = "m(k $$:= c)" have "val_map ?m' = (\k\<^sub>i \ fmdom' m \ {k}. ?m' $$! k\<^sub>i)" by simp also from assms have "\ = (\k\<^sub>i \ fmdom' m. ?m' $$! k\<^sub>i) + (?m' $$! k)" - by simp + by (simp add: fmdom'_notI) also have "\ = (\k\<^sub>i \ fmdom' m. ?m' $$! k\<^sub>i) + c" by simp also from assms have "\ = (\k\<^sub>i \ fmdom' m. m $$! k\<^sub>i) + c" - by (metis (no_types, lifting) fmupd_lookup sum.cong) + by (metis (no_types, lifting) fmdom'_notI fmupd_lookup sum.cong) finally show ?thesis by simp qed @@ -54,24 +54,17 @@ next proof - have "fmdom' (m\<^sub>1 ++\<^sub>f m\<^sub>2) = fmdom' m\<^sub>1 \ fmdom' m\<^sub>2" by simp - moreover from fmupd.prems have "k \ fmdom' m\<^sub>1" + moreover from fmupd.prems have "m\<^sub>1 $$ k = None" by auto - moreover from fmupd.hyps have "k \ fmdom' m\<^sub>2" - by (simp add: fmdom'_notI) - ultimately have "k \ fmdom' (m\<^sub>1 ++\<^sub>f m\<^sub>2)" - by simp + ultimately have "(m\<^sub>1 ++\<^sub>f m\<^sub>2) $$ k = None" + using fmupd.hyps by simp then show ?thesis using val_map_add by metis qed also from fmupd.prems and fmupd.IH have "\ = val_map m\<^sub>1 + val_map m\<^sub>2 + c" by simp - also have "\ = val_map m\<^sub>1 + val_map (m\<^sub>2(k $$:= c))" - proof - - from fmupd.hyps have "k \ fmdom' m\<^sub>2" - by (simp add: fmdom'_notI) - then show ?thesis - using val_map_add by (metis (full_types) add.assoc) - qed + also from fmupd.hyps have "\ = val_map m\<^sub>1 + val_map (m\<^sub>2(k $$:= c))" + using val_map_add by (smt sum.cong) finally show ?case . qed @@ -196,7 +189,7 @@ proof - qed fun val_deleg_state :: "d_state \ coin" where - "val_deleg_state rewards = val_map rewards" + "val_deleg_state (_, rewards, _) = val_map rewards" lemma val_map_dom_exc_singleton: assumes "m $$ k = Some v" @@ -223,49 +216,53 @@ lemma deleg_value_preservation: proof - from assms show ?thesis proof cases - case (deleg_reg hk) - from \s' = s \\<^sub>\ {addr_rwd hk $$:= 0}\ - have *: "val_deleg_state s' = val_deleg_state (s \\<^sub>\ {addr_rwd hk $$:= 0})" + case (deleg_reg hk stk_creds rewards i\<^sub>r\<^sub>w\<^sub>d) + from \s' = (stk_creds ++\<^sub>f {hk $$:= e}, rewards \\<^sub>\ {addr_rwd hk $$:= 0}, i\<^sub>r\<^sub>w\<^sub>d)\ + have *: "val_deleg_state s' = + val_deleg_state (stk_creds ++\<^sub>f {hk $$:= e}, rewards \\<^sub>\ {addr_rwd hk $$:= 0}, i\<^sub>r\<^sub>w\<^sub>d)" by simp then show ?thesis - proof (cases "addr_rwd hk \ fmdom' s") + proof (cases "addr_rwd hk \ fmdom' rewards") case True - then have "s \\<^sub>\ {addr_rwd hk $$:= 0} = s" + then have "rewards \\<^sub>\ {addr_rwd hk $$:= 0} = rewards" by simp - then have "val_deleg_state (s \\<^sub>\ {addr_rwd hk $$:= 0}) = val_deleg_state s" + with \s = (stk_creds, rewards, i\<^sub>r\<^sub>w\<^sub>d)\ + have "val_deleg_state (stk_creds ++\<^sub>f {hk $$:= e}, rewards \\<^sub>\ {addr_rwd hk $$:= 0}, i\<^sub>r\<^sub>w\<^sub>d) = + val_deleg_state s" by simp with * show ?thesis by simp next case False - then have **: "s \\<^sub>\ {addr_rwd hk $$:= 0} = s ++\<^sub>f {addr_rwd hk $$:= 0}" + then have **: "rewards \\<^sub>\ {addr_rwd hk $$:= 0} = rewards ++\<^sub>f {addr_rwd hk $$:= 0}" by simp - with False have "fmdom' s \ fmdom' {addr_rwd hk $$:= 0} = {}" + with False have "fmdom' rewards \ fmdom' {addr_rwd hk $$:= 0} = {}" by simp - then have "val_map (s ++\<^sub>f {addr_rwd hk $$:= 0}) = val_map s + val_map {addr_rwd hk $$:= 0}" + then have "val_map (rewards ++\<^sub>f {addr_rwd hk $$:= 0}) = + val_map rewards + val_map {addr_rwd hk $$:= 0}" using val_map_union by blast - also have "\ = val_map s + 0" + also have "\ = val_map rewards + 0" by simp - finally have "val_deleg_state (s ++\<^sub>f {addr_rwd hk $$:= 0}) = val_deleg_state s" - by auto + finally have " + val_deleg_state (stk_creds ++\<^sub>f {hk $$:= e}, rewards ++\<^sub>f {addr_rwd hk $$:= 0}, i\<^sub>r\<^sub>w\<^sub>d) = + val_deleg_state s" + using \s = (stk_creds, rewards, i\<^sub>r\<^sub>w\<^sub>d)\ by auto with * and ** show ?thesis by presburger qed next - case (deleg_dereg hk) - then have "val_deleg_state s' = val_map s'" - by simp - also from \s' = {addr_rwd hk} \/ s\ have "\ = val_map ({addr_rwd hk} \/ s)" + case (deleg_dereg hk rewards stk_creds i\<^sub>r\<^sub>w\<^sub>d) + then have "val_deleg_state s' = val_map ({addr_rwd hk} \/ rewards)" by simp - also from \s $$ (addr_rwd hk) = Some 0\ have "\ = val_map s - 0" + also from \rewards $$ (addr_rwd hk) = Some 0\ have "\ = val_map rewards - 0" using val_map_dom_exc_singleton by fast finally show ?thesis - by simp + using \s = (stk_creds, rewards, i\<^sub>r\<^sub>w\<^sub>d)\ by simp qed qed fun val_delegs_state :: "d_p_state \ coin" where - "val_delegs_state (rewards, _) = val_deleg_state rewards" + "val_delegs_state (d_state, _) = val_deleg_state d_state" lemma val_map_minus: assumes "m\<^sub>2 \\<^sub>f m\<^sub>1" @@ -301,12 +298,12 @@ next have "\ = val_map m\<^sub>1 - (val_map m\<^sub>2 + v)" by simp with fmupd.hyps show ?thesis - using val_map_add by (metis fmdom'_notI) + using val_map_add by metis qed finally show ?case . qed -lemma fmran_fmmap_const: +lemma fmran_fmmap_const: (* TODO: Find nicer proofs for SMT calls. *) assumes "m \ {$$}" shows "fmran (fmmap (\_. v) m) = {|v|}" using assms @@ -319,7 +316,8 @@ next proof (cases "m \ {$$}") case True have "fmmap (\_. v) m(k' $$:= v') = fmmap (\_. v) m ++\<^sub>f {k' $$:= v}" - by (smt dom_res_singleton dom_res_singleton fmadd_empty(1) fmadd_empty(1) fmadd_empty(2) fmfilter_fmmap fmlookup_map fmmap_add fmupd_alt_def fmupd_lookup option.simps(9)) + by (smt dom_res_singleton dom_res_singleton fmadd_empty(1) fmadd_empty(1,2) fmfilter_fmmap + fmlookup_map fmmap_add fmupd_alt_def fmupd_lookup option.simps(9)) then have "fmran (fmmap (\_. v) m(k' $$:= v')) = fmran (fmmap (\_. v) m ++\<^sub>f {k' $$:= v})" by simp also have "\ = fmran (fmmap (\_. v) m) |\| fmran {k' $$:= v}" @@ -327,7 +325,9 @@ next from \m $$ k' = None\ have "fmdom (fmmap (\_. v) m) |\| fmdom {k' $$:= v} = {||}" by (simp add: fmdom_notI) with \m $$ k' = None\ show ?thesis - by (smt finter_absorb finter_commute finter_funion_distrib2 fmadd_restrict_right_dom fmap_singleton_comm fmdom_add fmdom_map fmdom_notD fmdom_notI fmimage_dom fmimage_union fmran_restrict_fset) + by (smt finter_absorb finter_commute finter_funion_distrib2 fmadd_restrict_right_dom + fmap_singleton_comm fmdom_add fmdom_map fmdom_notD fmdom_notI fmimage_dom fmimage_union + fmran_restrict_fset) qed also from True and fmupd.IH have "\ = {|v|} |\| fmran {k' $$:= v}" by simp @@ -336,7 +336,8 @@ next next case False then have "fmmap (\_. v) m(k' $$:= v') = {k' $$:= v}" - by (smt dom_res_singleton dom_res_singleton fmadd_empty(1) fmadd_empty(1) fmadd_empty(2) fmfilter_fmmap fmlookup_map fmmap_add fmupd_alt_def fmupd_lookup option.simps(9)) + by (smt dom_res_singleton dom_res_singleton fmadd_empty(1,2) fmfilter_fmmap fmlookup_map + fmmap_add fmupd_alt_def fmupd_lookup option.simps(9)) then show ?thesis by (simp add: fmran_singleton) qed @@ -373,14 +374,16 @@ qed \ \NOTE: Lemma 15.7 in the spec.\ lemma delegs_value_preservation: - assumes "(slot, tx) \ (rewards, pstate) \\<^bsub>DELEGS\<^esub>{\} (rewards', pstate)" - shows "val_delegs_state (rewards, pstate) = - val_delegs_state (rewards', pstate) + wbalance (txwdrls tx)" + assumes " + (slot, tx) \ + ((stk_creds, rewards, i\<^sub>r\<^sub>w\<^sub>d), pstate) \\<^bsub>DELEGS\<^esub>{\} ((stk_creds', rewards', i\<^sub>r\<^sub>w\<^sub>d), pstate)" + shows "val_delegs_state ((stk_creds, rewards, i\<^sub>r\<^sub>w\<^sub>d), pstate) = + val_delegs_state ((stk_creds', rewards', i\<^sub>r\<^sub>w\<^sub>d), pstate) + wbalance (txwdrls tx)" using assms -proof (induction "(slot, tx)" "(rewards, pstate)" \ "(rewards', pstate)" arbitrary: slot tx rewards - pstate rewards' rule: delegs_sts.induct) - case (seq_delg_base wdrls tx rewards rewards' slot pstate) - have "val_delegs_state (rewards, pstate) = val_map rewards" +proof (induction "(slot, tx)" "((stk_creds, rewards, i\<^sub>r\<^sub>w\<^sub>d), pstate)" \ "((stk_creds', rewards', i\<^sub>r\<^sub>w\<^sub>d), + pstate)" arbitrary: slot tx stk_creds rewards i\<^sub>r\<^sub>w\<^sub>d stk_creds' rewards' pstate) + case (seq_delg_base wdrls tx rewards rewards' slot stk_creds i\<^sub>r\<^sub>w\<^sub>d pstate) + have "val_delegs_state ((stk_creds, rewards, i\<^sub>r\<^sub>w\<^sub>d), pstate) = val_map rewards" by simp also have "\ = val_map wdrls + val_map (rewards --\<^sub>f wdrls)" proof - @@ -403,25 +406,37 @@ proof (induction "(slot, tx)" "(rewards, pstate)" \ "(rewards', pstate)" by simp next case (seq_delg_ind slot tx \ dpstate' c) - from \slot \ dpstate' \\<^bsub>DELPL\<^esub>{c} (rewards', pstate)\ have "snd dpstate' = pstate" - using delpl_sts.simps by auto - with seq_delg_ind.hyps(2) have "val_delegs_state (rewards, pstate) = - val_delegs_state (fst dpstate', pstate) + val_map (txwdrls tx)" - by auto - moreover have "val_deleg_state (fst dpstate') = val_deleg_state rewards'" + have "snd dpstate' = pstate" and "snd (snd (fst dpstate')) = i\<^sub>r\<^sub>w\<^sub>d" proof - - from \slot \ dpstate' \\<^bsub>DELPL\<^esub>{c} (rewards', pstate)\ - have "slot \ (fst dpstate') \\<^bsub>DELEG\<^esub>{c} rewards'" + from \slot \ dpstate' \\<^bsub>DELPL\<^esub>{c} ((stk_creds', rewards', i\<^sub>r\<^sub>w\<^sub>d), pstate)\ + show "snd dpstate' = pstate" using delpl_sts.simps by auto - then show ?thesis - using deleg_value_preservation by simp + next + from \slot \ dpstate' \\<^bsub>DELPL\<^esub>{c} ((stk_creds', rewards', i\<^sub>r\<^sub>w\<^sub>d), pstate)\ + have "slot \ fst dpstate' \\<^bsub>DELEG\<^esub>{c} (stk_creds', rewards', i\<^sub>r\<^sub>w\<^sub>d)" + using delpl_sts.simps by auto + then show "snd (snd (fst dpstate')) = i\<^sub>r\<^sub>w\<^sub>d" + using deleg_sts.simps by auto + qed + with seq_delg_ind.hyps(2) have "val_delegs_state ((stk_creds, rewards, i\<^sub>r\<^sub>w\<^sub>d), pstate) = + val_delegs_state ((fst (fst dpstate'), fst (snd (fst dpstate')), i\<^sub>r\<^sub>w\<^sub>d), pstate) + + val_map (txwdrls tx)" + by (metis prod.exhaust_sel) + moreover have "val_deleg_state (fst (fst dpstate'), fst (snd (fst dpstate')), i\<^sub>r\<^sub>w\<^sub>d) = + val_deleg_state (stk_creds', rewards', i\<^sub>r\<^sub>w\<^sub>d)" + proof - + from \slot \ dpstate' \\<^bsub>DELPL\<^esub>{c} ((stk_creds', rewards', i\<^sub>r\<^sub>w\<^sub>d), pstate)\ + have "slot \ fst dpstate' \\<^bsub>DELEG\<^esub>{c} (stk_creds', rewards', i\<^sub>r\<^sub>w\<^sub>d)" + using delpl_sts.simps by auto + with \snd (snd (fst dpstate')) = i\<^sub>r\<^sub>w\<^sub>d\ show ?thesis + using deleg_value_preservation by fastforce qed ultimately show ?case by simp qed fun val_poolreap_state :: "pl_reap_state \ coin" where - "val_poolreap_state ((_, deps, _, _), (treasury, _), rewards, _) = + "val_poolreap_state ((_, deps, _, _), (treasury, _), (_, rewards, _), _) = val_coin deps + val_coin treasury + val_map rewards" lemma val_map_fmmap_keys: @@ -433,55 +448,57 @@ proof (induction m\<^sub>2) then show ?case by auto next - case (fmupd x y m\<^sub>2) - have "val_map (fmmap_keys (\k v. v + m\<^sub>1 $$! k) m\<^sub>2(x $$:= y)) = - val_map (fmmap_keys (\k v. v + m\<^sub>1 $$! k) m\<^sub>2 ++\<^sub>f {x $$:= y + m\<^sub>1 $$! x})" + case (fmupd k' v' m\<^sub>2) + have "val_map (fmmap_keys (\k v. v + m\<^sub>1 $$! k) m\<^sub>2(k' $$:= v')) = + val_map (fmmap_keys (\k v. v + m\<^sub>1 $$! k) m\<^sub>2 ++\<^sub>f {k' $$:= v' + m\<^sub>1 $$! k'})" proof - - have "fmmap_keys (\k v. v + m\<^sub>1 $$! k) m\<^sub>2(x $$:= y) = - fmmap_keys (\k v. v + m\<^sub>1 $$! k) m\<^sub>2 ++\<^sub>f {x $$:= y + m\<^sub>1 $$! x}" + have "fmmap_keys (\k v. v + m\<^sub>1 $$! k) m\<^sub>2(k' $$:= v') = + fmmap_keys (\k v. v + m\<^sub>1 $$! k) m\<^sub>2 ++\<^sub>f {k' $$:= v' + m\<^sub>1 $$! k'}" by transfer' (auto simp add: fmap_ext) then show ?thesis by simp qed also have "\ = - val_map (fmmap_keys (\k v. v + m\<^sub>1 $$! k) m\<^sub>2) + val_map {x $$:= y + m\<^sub>1 $$! x}" + val_map (fmmap_keys (\k v. v + m\<^sub>1 $$! k) m\<^sub>2) + val_map {k' $$:= v' + m\<^sub>1 $$! k'}" proof - - from \m\<^sub>2 $$ x = None\ - have "fmdom' (fmmap_keys (\k v. v + m\<^sub>1 $$! k) m\<^sub>2) \ fmdom' {x $$:= y + m\<^sub>1 $$! x} = {}" + from \m\<^sub>2 $$ k' = None\ + have "fmdom' (fmmap_keys (\k v. v + m\<^sub>1 $$! k) m\<^sub>2) \ fmdom' {k' $$:= v' + m\<^sub>1 $$! k'} = {}" by (simp add: fmdom'_notI) then show ?thesis using val_map_union by blast qed - also have "\ = val_map (fmmap_keys (\k v. v + m\<^sub>1 $$! k) m\<^sub>2) + (y + m\<^sub>1 $$! x)" + also have "\ = val_map (fmmap_keys (\k v. v + m\<^sub>1 $$! k) m\<^sub>2) + (v' + m\<^sub>1 $$! k')" by simp - also from \fmdom' m\<^sub>2(x $$:= y) \ fmdom' m\<^sub>1\ and fmupd.IH have "\ = - val_map (fmdom' m\<^sub>2 \ m\<^sub>1) + val_map m\<^sub>2 + (y + m\<^sub>1 $$! x)" + also from \fmdom' m\<^sub>2(k' $$:= v') \ fmdom' m\<^sub>1\ and fmupd.IH have "\ = + val_map (fmdom' m\<^sub>2 \ m\<^sub>1) + val_map m\<^sub>2 + (v' + m\<^sub>1 $$! k')" by simp - also have "\ = (val_map (fmdom' m\<^sub>2 \ m\<^sub>1) + m\<^sub>1 $$! x) + (val_map m\<^sub>2 + y)" + also have "\ = (val_map (fmdom' m\<^sub>2 \ m\<^sub>1) + m\<^sub>1 $$! k') + (val_map m\<^sub>2 + v')" by simp - also have "\ = val_map (fmdom' m\<^sub>2(x $$:= y) \ m\<^sub>1) + val_map m\<^sub>2(x $$:= y)" + also have "\ = val_map (fmdom' m\<^sub>2(k' $$:= v') \ m\<^sub>1) + val_map m\<^sub>2(k' $$:= v')" proof - - have "val_map (fmdom' m\<^sub>2 \ m\<^sub>1) + m\<^sub>1 $$! x = val_map (fmdom' m\<^sub>2(x $$:= y) \ m\<^sub>1)" + have "val_map (fmdom' m\<^sub>2 \ m\<^sub>1) + m\<^sub>1 $$! k' = val_map (fmdom' m\<^sub>2(k' $$:= v') \ m\<^sub>1)" proof - - from \m\<^sub>2 $$ x = None\ have "val_map (fmdom' m\<^sub>2(x $$:= y) \ m\<^sub>1) = val_map ((fmdom' m\<^sub>2 \ {x}) \ m\<^sub>1)" + from \m\<^sub>2 $$ k' = None\ + have "val_map (fmdom' m\<^sub>2(k' $$:= v') \ m\<^sub>1) = val_map ((fmdom' m\<^sub>2 \ {k'}) \ m\<^sub>1)" by simp - also have "\ = val_map ((fmdom' m\<^sub>2 \ m\<^sub>1) ++\<^sub>f ({x} \ m\<^sub>1))" + also have "\ = val_map ((fmdom' m\<^sub>2 \ m\<^sub>1) ++\<^sub>f ({k'} \ m\<^sub>1))" using dom_res_union_distr by metis - also have "\ = val_map (fmdom' m\<^sub>2 \ m\<^sub>1) + val_map ({x} \ m\<^sub>1)" + also have "\ = val_map (fmdom' m\<^sub>2 \ m\<^sub>1) + val_map ({k'} \ m\<^sub>1)" proof - - from \fmdom' m\<^sub>2(x $$:= y) \ fmdom' m\<^sub>1\ have "fmdom' (fmdom' m\<^sub>2 \ m\<^sub>1) = fmdom' m\<^sub>2" + from \fmdom' m\<^sub>2(k' $$:= v') \ fmdom' m\<^sub>1\ have "fmdom' (fmdom' m\<^sub>2 \ m\<^sub>1) = fmdom' m\<^sub>2" by (auto simp add: fmfilter_alt_defs(4)) - moreover from \fmdom' m\<^sub>2(x $$:= y) \ fmdom' m\<^sub>1\ have "fmdom' ({x} \ m\<^sub>1) = {x}" + moreover from \fmdom' m\<^sub>2(k' $$:= v') \ fmdom' m\<^sub>1\ have "fmdom' ({k'} \ m\<^sub>1) = {k'}" by (auto simp add: equalityI) - ultimately have "fmdom' (fmdom' m\<^sub>2 \ m\<^sub>1) \ fmdom' ({x} \ m\<^sub>1) = {}" - using \m\<^sub>2 $$ x = None\ by (simp add: fmdom'_notI) + ultimately have "fmdom' (fmdom' m\<^sub>2 \ m\<^sub>1) \ fmdom' ({k'} \ m\<^sub>1) = {}" + using \m\<^sub>2 $$ k' = None\ by (simp add: fmdom'_notI) then show ?thesis using val_map_union by blast qed - also have "\ = val_map (fmdom' m\<^sub>2 \ m\<^sub>1) + m\<^sub>1 $$! x" + also have "\ = val_map (fmdom' m\<^sub>2 \ m\<^sub>1) + m\<^sub>1 $$! k'" proof - - from \fmdom' m\<^sub>2(x $$:= y) \ fmdom' m\<^sub>1\ have "x \ fmdom' m\<^sub>1" by simp - then have "fmdom' ({x} \ m\<^sub>1) = {x}" + from \fmdom' m\<^sub>2(k' $$:= v') \ fmdom' m\<^sub>1\ have "k' \ fmdom' m\<^sub>1" + by simp + then have "fmdom' ({k'} \ m\<^sub>1) = {k'}" by (auto simp add: equalityI) then show ?thesis by simp @@ -489,8 +506,8 @@ next finally show ?thesis by simp qed - moreover from \m\<^sub>2 $$ x = None\ have "val_map m\<^sub>2(x $$:= y) = val_map m\<^sub>2 + y" - using val_map_add by (metis fmdom'_notI) + moreover from \m\<^sub>2 $$ k' = None\ have "val_map m\<^sub>2(k' $$:= v') = val_map m\<^sub>2 + v'" + using val_map_add by metis ultimately show ?thesis by linarith qed @@ -531,7 +548,7 @@ proof - from assms show ?thesis proof cases case (pool_reap reward_acnts' refunds rewards m_refunds refunded unclaimed utxo deps fees ups - treasury reserves pstate) + treasury reserves stk_creds i\<^sub>r\<^sub>w\<^sub>d pstate) from pool_reap(2) have "val_poolreap_state s' = deps - (unclaimed + refunded) + treasury + unclaimed + val_map (rewards \\<^sub>+ refunds)" by simp @@ -567,9 +584,265 @@ proof - by linarith qed finally show ?thesis - using \s = ((utxo, deps, fees, ups), (treasury, reserves), rewards, pstate)\ and - \refunded = val_map refunds\ by simp + using \s = ((utxo, deps, fees, ups), (treasury, reserves), (stk_creds, rewards, i\<^sub>r\<^sub>w\<^sub>d), pstate)\ + and \refunded = val_map refunds\ by simp + qed +qed + +fun val_epoch_state :: "epoch_state \ coin" where + "val_epoch_state ((treasury, reserves), _, ((_, _, fees, _), ((_, rewards, _), _)), _) = + val_coin treasury + val_coin reserves + val_coin fees + val_map rewards" + +lemma val_map_union_plus: (* TODO: Find nicer proofs for SMT calls. *) + shows "val_map (m\<^sub>1 \\<^sub>+ m\<^sub>2) = val_map m\<^sub>1 + val_map m\<^sub>2" +proof (induction m\<^sub>1) + case fmempty + have "fmdom' m\<^sub>2 \/ {$$} = {$$}" + by simp + moreover have "fmdom' {$$} \/ m\<^sub>2 = m\<^sub>2" + by simp + moreover have "{$$} \\<^sub>+ m\<^sub>2 = {$$}" + by (simp add: fmap_ext) + moreover have "val_map {$$} = 0" + by simp + ultimately show ?case + by simp +next + case (fmupd k v m\<^sub>1) + then show ?case + proof (cases "m\<^sub>2 $$ k = None") + case True + from fmupd.hyps and True have "val_map (m\<^sub>1(k $$:= v) \\<^sub>+ m\<^sub>2) = val_map ((m\<^sub>1 \\<^sub>+ m\<^sub>2) ++\<^sub>f {k $$:= v})" + using union_plus_addition_notin by metis + also have "\ = val_map (m\<^sub>1 \\<^sub>+ m\<^sub>2) + val_map {k $$:= v}" + proof - + from fmupd.hyps and True have "fmdom' (m\<^sub>1 \\<^sub>+ m\<^sub>2) \ fmdom' {k $$:= v} = {}" + by (simp add: fmdom'_notI) + then show ?thesis + using val_map_union by fast + qed + also from fmupd.IH have "\ = val_map m\<^sub>1 + val_map m\<^sub>2 + val_map {k $$:= v}" + by simp + finally show ?thesis + using val_map_add and fmupd.hyps by (smt fmdom'_empty fmempty_lookup sum.cong sum.empty) + next + case False + from False obtain v' where *: "m\<^sub>2 $$ k = Some v'" + by auto + from False have "val_map (m\<^sub>1(k $$:= v) \\<^sub>+ m\<^sub>2) = + val_map (fmdom' m\<^sub>2 \/ m\<^sub>1 ++\<^sub>f fmdom' m\<^sub>1(k $$:= v) \/ m\<^sub>2 ++\<^sub>f (m\<^sub>1(k $$:= v) \\<^sub>+ m\<^sub>2))" + by auto + also from fmupd.hyps and * have "\ = + val_map (fmdom' m\<^sub>2 \/ m\<^sub>1 ++\<^sub>f (fmdom' m\<^sub>1 \/ m\<^sub>2 --\<^sub>f {k $$:= v'}) ++\<^sub>f (m\<^sub>1(k $$:= v) \\<^sub>+ m\<^sub>2))" + by simp + also have "\ = + val_map (fmdom' m\<^sub>2 \/ m\<^sub>1 ++\<^sub>f (fmdom' m\<^sub>1 \/ m\<^sub>2 --\<^sub>f {k $$:= v'}) ++\<^sub>f (m\<^sub>1 \\<^sub>+ m\<^sub>2) + ++\<^sub>f {k $$:= v' + v})" + proof - + from \m\<^sub>1 $$ k = None\ and * have "m\<^sub>1(k $$:= v) \\<^sub>+ m\<^sub>2 = (m\<^sub>1 \\<^sub>+ m\<^sub>2) ++\<^sub>f {k $$:= v' + v}" + using inter_plus_addition_in by simp + then show ?thesis + by auto + qed + also have "\ = val_map ((fmdom' m\<^sub>2 \/ m\<^sub>1 ++\<^sub>f fmdom' m\<^sub>1 \/ m\<^sub>2) --\<^sub>f {k $$:= v'} ++\<^sub>f (m\<^sub>1 \\<^sub>+ m\<^sub>2) + ++\<^sub>f {k $$:= v' + v})" + proof - + from False have "fmdom' m\<^sub>2 \/ m\<^sub>1 ++\<^sub>f (fmdom' m\<^sub>1 \/ m\<^sub>2 --\<^sub>f {k $$:= v'}) = + (fmdom' m\<^sub>2 \/ m\<^sub>1 ++\<^sub>f fmdom' m\<^sub>1 \/ m\<^sub>2) --\<^sub>f {k $$:= v'}" + by (smt fmdom'_empty fmdom'_fmupd fmdom'_notD fmfilter_add_distrib fmfilter_true + fmlookup_filter option.distinct(1) singletonD) + then show ?thesis + by auto + qed + also have "\ = val_map ((fmdom' m\<^sub>2 \/ m\<^sub>1 ++\<^sub>f fmdom' m\<^sub>1 \/ m\<^sub>2 ++\<^sub>f (m\<^sub>1 \\<^sub>+ m\<^sub>2)) --\<^sub>f {k $$:= v'} + ++\<^sub>f {k $$:= v' + v})" + proof - + from fmupd.hyps have "(fmdom' m\<^sub>2 \/ m\<^sub>1 ++\<^sub>f fmdom' m\<^sub>1 \/ m\<^sub>2) --\<^sub>f {k $$:= v'} ++\<^sub>f (m\<^sub>1 \\<^sub>+ m\<^sub>2) = + (fmdom' m\<^sub>2 \/ m\<^sub>1 ++\<^sub>f fmdom' m\<^sub>1 \/ m\<^sub>2) ++\<^sub>f (m\<^sub>1 \\<^sub>+ m\<^sub>2) --\<^sub>f {k $$:= v'}" + by (smt fmdom'_empty fmdom'_fmupd fmdom'_notI fmfilter_add_distrib fmfilter_fmmap_keys + fmfilter_true fmlookup_filter option.distinct(1) singletonD) + then show ?thesis + by auto + qed + also have "\ = val_map ((m\<^sub>1 \\<^sub>+ m\<^sub>2) --\<^sub>f {k $$:= v'}) + val_map {k $$:= v' + v}" + proof - + have "fmdom' ((m\<^sub>1 \\<^sub>+ m\<^sub>2) --\<^sub>f {k $$:= v'}) \ fmdom' {k $$:= v' + v} = {}" + by (simp add: fmdom'_notI) + then show ?thesis + using val_map_union by fast + qed + also have "\ = val_map (m\<^sub>1 \\<^sub>+ m\<^sub>2) - val_map {k $$:= v'} + val_map {k $$:= v' + v}" + proof - + from * and fmupd.hyps have "{k $$:= v'} \\<^sub>f fmdom' m\<^sub>1 \/ m\<^sub>2" + by (simp add: fmdom'_notI fmpred_upd fmsubset_alt_def) + moreover have "(m\<^sub>1 \\<^sub>+ m\<^sub>2) $$ k = None" + by (simp add: fmdom'_notI fmupd.hyps) + ultimately have "{k $$:= v'} \\<^sub>f m\<^sub>1 \\<^sub>+ m\<^sub>2" + using * and fmdiff_partition + by (smt Un_iff domIff dom_fmlookup fmdom'_add fmdom'_empty fmdom'_fmupd fmlookup_add + fmlookup_filter fmpred_empty fmpred_upd fmsubset_alt_def singletonI) + then show ?thesis + using val_map_minus by metis + qed + also have "\ = val_map (m\<^sub>1 \\<^sub>+ m\<^sub>2) - v' + v' + v" + by simp + also from fmupd.IH have "\ = val_map m\<^sub>1 + val_map m\<^sub>2 + v" + by simp + finally show ?thesis + using \m\<^sub>1 $$ k = None\ and val_map_add by (smt sum.cong) qed qed +lemma val_map_fmap_of_list: + fixes m :: "('a::linorder, coin) fmap" and f :: "'a::linorder \ 'b::linorder" + assumes "inj f" + and "mono f" + shows "val_map (fmap_of_list [(f k, v). (k, v) \ sorted_list_of_fmap m]) = val_map m" + using assms +proof (induction m) + case fmempty + then show ?case + unfolding sorted_list_of_fmap_def and sorted_list_of_fset_def by simp +next + case (fmupd k v m) + let ?g = "\(k, v). (f k, v)" + from \m $$ k = None\ and assms(1,2) + have "val_map (fmap_of_list (map ?g (sorted_list_of_fmap m(k $$:= v)))) = + val_map ((fmap_of_list (map ?g (sorted_list_of_fmap m)))(f k $$:= v))" + by (simp add: fmap_of_list_sorted_list_of_fmap) + also have "\ = val_map (fmap_of_list (map ?g (sorted_list_of_fmap m))) + v" + proof - + have "(fmap_of_list (map ?g (sorted_list_of_fmap m))) $$ (f k) = None" + proof - + from \m $$ k = None\ have "k \ set (map fst (sorted_list_of_fmap m))" + by (metis domIff dom_map_of_conv_image_fst map_of_sorted_list set_map) + with assms(1) have "f k \ set (map fst (map ?g (sorted_list_of_fmap m)))" + using map_inj_pair_non_membership by simp + then show ?thesis + by (metis fmlookup_of_list map_of_eq_None_iff set_map) + qed + then show ?thesis + using val_map_add by force + qed + also from assms(1,2) and fmupd.IH have "\ = val_map m + v" + by simp + finally show ?case + by (metis fmupd.hyps val_map_add) +qed + +\ \NOTE: Lemma 15.9 in the spec.\ +\ \NOTE: We require \addr_rwd\ to be monotonic, which is a minor deviation from the spec.\ +lemma reward_update_value_preservation: + assumes "inj addr_rwd" + and "mono addr_rwd" + shows "val_epoch_state s = val_epoch_state (apply_r_upd (create_r_upd b s) s)" +proof - + obtain treasury reserves ss utxo deps fees up stk_creds rewards i\<^sub>r\<^sub>w\<^sub>d pstate ppm + where f1: "s = + ( + (treasury, reserves), + ss, + ((utxo, deps, fees, up), ((stk_creds, rewards, i\<^sub>r\<^sub>w\<^sub>d), pstate)), + ppm + )" + using val_epoch_state.cases by blast + moreover obtain \t \r rs \f rew\<^sub>m\<^sub>i\<^sub>r where f2: "create_r_upd b s = (\t, \r, rs, \f, rew\<^sub>m\<^sub>i\<^sub>r)" + using prod_cases5 by blast + ultimately obtain non_distributed and rew'\<^sub>m\<^sub>i\<^sub>r and update\<^sub>r\<^sub>w\<^sub>d and unregistered + where f3: "apply_r_upd (\t, \r, rs, \f, rew\<^sub>m\<^sub>i\<^sub>r) s = + ( + (treasury + \t, reserves + \r + non_distributed), + ss, + ((utxo, deps, fees + \f, up), ((stk_creds, (rewards \\<^sub>+ rs) \\<^sub>+ update\<^sub>r\<^sub>w\<^sub>d, {$$}), pstate)), + ppm + )" + and f4: "non_distributed = + (\k \ fmdom' (fmdom' stk_creds \/ rew\<^sub>m\<^sub>i\<^sub>r). (fmdom' stk_creds \/ rew\<^sub>m\<^sub>i\<^sub>r) $$! k)" + and f5: "rew'\<^sub>m\<^sub>i\<^sub>r = fmdom' stk_creds \ rew\<^sub>m\<^sub>i\<^sub>r" + and f6: "update\<^sub>r\<^sub>w\<^sub>d = fmap_of_list [(addr_rwd hk, val). (hk, val) \ sorted_list_of_fmap rew'\<^sub>m\<^sub>i\<^sub>r]" + and f7: "unregistered = fmdom' stk_creds \/ rew\<^sub>m\<^sub>i\<^sub>r" + by (metis apply_r_upd.simps) + then have "val_epoch_state (apply_r_upd (create_r_upd b s) s) = + treasury + reserves + fees + val_map rewards + \t + \r + non_distributed + \f + val_map rs + + val_map update\<^sub>r\<^sub>w\<^sub>d" + proof - + from f2 and f3 have "val_epoch_state (apply_r_upd (create_r_upd b s) s) = + (treasury + \t) + (reserves + \r + non_distributed) + (fees + \f) + + val_map ((rewards \\<^sub>+ rs) \\<^sub>+ update\<^sub>r\<^sub>w\<^sub>d)" + using val_coin.simps and val_epoch_state.simps by presburger + moreover have "val_map ((rewards \\<^sub>+ rs) \\<^sub>+ update\<^sub>r\<^sub>w\<^sub>d) = + val_map rewards + val_map rs + val_map update\<^sub>r\<^sub>w\<^sub>d" + using val_map_union_plus by metis + ultimately show ?thesis + by linarith + qed + moreover have "\t + \r + non_distributed + \f + val_map rs + val_map update\<^sub>r\<^sub>w\<^sub>d = 0" + proof (cases ss) + case (fields pstake\<^sub>m\<^sub>a\<^sub>r\<^sub>k pstake\<^sub>s\<^sub>e\<^sub>t pstake\<^sub>g\<^sub>o pools_ss fee_ss) + from f1 and fields have "s = + ( + (treasury, reserves), + (pstake\<^sub>m\<^sub>a\<^sub>r\<^sub>k, pstake\<^sub>s\<^sub>e\<^sub>t, pstake\<^sub>g\<^sub>o, pools_ss, fee_ss), + ((utxo, deps, fees, up), (stk_creds, rewards, i\<^sub>r\<^sub>w\<^sub>d), pstate), + ppm + )" + by simp + then obtain \t\<^sub>1 \t\<^sub>2 \r' \r\<^sub>l rs' rewards\<^sub>m\<^sub>i\<^sub>r registered unregistered' reward_pot R + where "create_r_upd b s = (\t\<^sub>1 + \t\<^sub>2, -\r', rs', -fee_ss, registered)" + and "unregistered' = fmdom' stk_creds \/ i\<^sub>r\<^sub>w\<^sub>d" + and "registered = i\<^sub>r\<^sub>w\<^sub>d --\<^sub>f unregistered'" + and "rewards\<^sub>m\<^sub>i\<^sub>r = (\ k \ fmdom' registered. registered $$! k)" + and "reward_pot = fee_ss + \r\<^sub>l" + and "R = reward_pot - \t\<^sub>1" + and "\t\<^sub>2 = R - (\ k \ fmdom' rs'. rs' $$! k)" + and "\r' = \r\<^sub>l + rewards\<^sub>m\<^sub>i\<^sub>r" + by (metis create_r_upd.simps prod.exhaust_sel that) + with f1 and f2 and fields have "rs' = rs" and "\r' = -\r" and "\t = \t\<^sub>1 + \t\<^sub>2" + and "\f = -fee_ss" and "registered = rew\<^sub>m\<^sub>i\<^sub>r" + by auto + with \R = reward_pot - \t\<^sub>1\ and \\t\<^sub>2 = R - val_map rs'\ and \reward_pot = fee_ss + \r\<^sub>l\ + have "\t\<^sub>1 + \t\<^sub>2 - \r\<^sub>l + val_map rs - fee_ss = 0" + by simp + from \\t = \t\<^sub>1 + \t\<^sub>2\ have "\t + \r + non_distributed + \f + val_map rs + val_map update\<^sub>r\<^sub>w\<^sub>d = + \t\<^sub>1 + \t\<^sub>2 + \r + non_distributed + \f + val_map rs + val_map update\<^sub>r\<^sub>w\<^sub>d" + by simp + also from \\r' = \r\<^sub>l + rewards\<^sub>m\<^sub>i\<^sub>r\ and \\r' = -\r\ and \rewards\<^sub>m\<^sub>i\<^sub>r = val_map registered\ + have "\ = \t\<^sub>1 + \t\<^sub>2 - \r\<^sub>l - val_map registered + non_distributed + \f + val_map rs + + val_map update\<^sub>r\<^sub>w\<^sub>d" + by simp + also from \\f = -fee_ss\ have "\ = \t\<^sub>1 + \t\<^sub>2 - \r\<^sub>l + val_map rs - fee_ss - val_map registered + + non_distributed + val_map update\<^sub>r\<^sub>w\<^sub>d" + by simp + also from \\t\<^sub>1 + \t\<^sub>2 - \r\<^sub>l + val_map rs - fee_ss = 0\ have "\ = + - val_map registered + non_distributed + val_map update\<^sub>r\<^sub>w\<^sub>d" + by simp + also have "\ = 0" + proof - + have "val_map registered = val_map update\<^sub>r\<^sub>w\<^sub>d + non_distributed" + proof - + from f6 and assms(1,2) have "val_map rew'\<^sub>m\<^sub>i\<^sub>r = val_map update\<^sub>r\<^sub>w\<^sub>d" + by (simp add: val_map_fmap_of_list) + moreover from f4 and f7 have "val_map unregistered = non_distributed" + by simp + ultimately have *: "val_map rew'\<^sub>m\<^sub>i\<^sub>r + val_map unregistered = + val_map update\<^sub>r\<^sub>w\<^sub>d + non_distributed" + by simp + from \registered = rew\<^sub>m\<^sub>i\<^sub>r\ have "val_map registered = val_map rew\<^sub>m\<^sub>i\<^sub>r" + by simp + also from f5 and f7 have "\ = val_map rew'\<^sub>m\<^sub>i\<^sub>r + val_map unregistered" + using val_map_split by (metis add.commute) + finally show ?thesis + using * by simp + qed + then show ?thesis + by simp + qed + finally show ?thesis . + qed + moreover have "val_epoch_state s = treasury + reserves + fees + val_map rewards" + using f1 by simp + ultimately show ?thesis + by simp +qed + end diff --git a/Isabelle/Shelley/Protocol_Parameters.thy b/Isabelle/Shelley/Protocol_Parameters.thy index 54f0329..1819a85 100644 --- a/Isabelle/Shelley/Protocol_Parameters.thy +++ b/Isabelle/Shelley/Protocol_Parameters.thy @@ -1,7 +1,7 @@ section \ Protocol Parameters \ theory Protocol_Parameters - imports Finite_Map_Extras + imports "HOL.Complex" Finite_Map_Extras begin text \ Protocol parameter name \ @@ -16,4 +16,16 @@ text \ Protocol parameter map \ type_synonym p_params = "(ppm, pvalue) fmap" +text \ Accessor Functions \ + +consts tau :: "p_params \ real" \ \[0, 1]\ + +consts rho :: "p_params \ real" \ \[0, 1]\ + +consts active_slot_coeff :: "p_params \ real" \ \[0, 1]\ + +text \ Global Constants \ + +consts slots_per_epoch :: nat + end diff --git a/Isabelle/Shelley/ROOT b/Isabelle/Shelley/ROOT index cc7b583..62c43e1 100644 --- a/Isabelle/Shelley/ROOT +++ b/Isabelle/Shelley/ROOT @@ -15,6 +15,7 @@ session Shelley (ledgerformalization) = HOL + UTxO Delegation_Certificates Delegation + Ledger Rewards Properties document_files diff --git a/Isabelle/Shelley/Rewards.thy b/Isabelle/Shelley/Rewards.thy index cb3e05f..fedda5a 100644 --- a/Isabelle/Shelley/Rewards.thy +++ b/Isabelle/Shelley/Rewards.thy @@ -1,6 +1,7 @@ section \ Rewards and the Epoch Boundary \ + theory Rewards - imports UTxO Delegation Protocol_Parameters + imports UTxO Delegation Protocol_Parameters Ledger begin subsection \ Helper Functions and Accounting Fields \ @@ -9,6 +10,27 @@ text \ Accounting Fields \ type_synonym acnt = "coin \ coin" +subsection \ Stake Distribution Calculation \ + +text \ Blocks made by stake pools \ + +type_synonym blocks_made = "(key_hash, nat) fmap" + +text \ Stake \ + +type_synonym stake = "(key_hash, coin) fmap" + +subsection \ Snapshot Transition \ + +text \ Snapshots \ + +type_synonym snapshots = " + (stake \ (key_hash, key_hash) fmap) \ \ \newest stake\ + (stake \ (key_hash, key_hash) fmap) \ \ \middle stake\ + (stake \ (key_hash, key_hash) fmap) \ \ \oldest stake\ + (key_hash, pool_param) fmap \ \ \pool parameters\ + coin \ \fee snapshot\" + subsection \ Pool Reaping Transition \ text \ Pool Reap State \ @@ -29,14 +51,14 @@ inductive poolreap_sts :: "p_params \ pl_reap_state \ ep ( (utxo, deps, fees, ups), (treasury, reserves), - rewards, + (stk_creds, rewards, i\<^sub>r\<^sub>w\<^sub>d), pstate ) \\<^bsub>POOLREAP\<^esub>{e} ( (utxo, deps - (unclaimed + refunded), fees, ups), (treasury + unclaimed, reserves), - rewards \\<^sub>+ refunds, + (stk_creds, rewards \\<^sub>+ refunds, i\<^sub>r\<^sub>w\<^sub>d), pstate )" if "reward_acnts' = undefined" @@ -45,4 +67,85 @@ inductive poolreap_sts :: "p_params \ pl_reap_state \ ep and "refunded = (\k \ fmdom' refunds. refunds $$! k)" and "unclaimed = (\k \ fmdom' m_refunds. m_refunds $$! k)" +subsection \ Complete Epoch Boundary Transition \ + +text \ Epoch States \ + +type_synonym epoch_state = "acnt \ snapshots \ l_state \ p_params" + +subsection \ Reward Distribution Calculation \ + +text \ Calculation to reward all stake pools \ + +fun reward :: "p_params \ blocks_made \ coin \ addr_rwd set \ (key_hash, pool_param) fmap \ + stake \ (key_hash, key_hash) fmap \ (addr_rwd, coin) fmap" where + "reward pp blocks R addrs\<^sub>r\<^sub>e\<^sub>w pool_params stake delegs = undefined" \ \NOTE: Undefined for now\ + +subsection \ Reward Update Calculation \ + +text \ Reward Update \ + +type_synonym reward_update = "coin \ coin \ (addr_rwd, coin) fmap \ coin \ (credential, coin) fmap" + +text \ Calculation to create a reward update \ + +fun create_r_upd :: "blocks_made \ epoch_state \ reward_update" where + "create_r_upd b + ( + (_, reserves), + (_, _, (stake, delegs), pools_ss, fee_ss), + (_, ((stk_creds, rewards, i\<^sub>r\<^sub>w\<^sub>d), _)), + pp + ) = + ( + let + unregistered = fmdom' stk_creds \/ i\<^sub>r\<^sub>w\<^sub>d; + registered = i\<^sub>r\<^sub>w\<^sub>d --\<^sub>f unregistered; + rewards\<^sub>m\<^sub>i\<^sub>r = (\ k \ fmdom' registered. registered $$! k); + reserves' = reserves - rewards\<^sub>m\<^sub>i\<^sub>r; + blocks_made = (\ k \ fmdom' b. b $$! k); + \ = real blocks_made / (real slots_per_epoch * active_slot_coeff pp); + \r\<^sub>l = \min 1 \ * rho pp * reserves'\; + reward_pot = fee_ss + \r\<^sub>l; + \t\<^sub>1 = \tau pp * reward_pot\; + \r = \r\<^sub>l + rewards\<^sub>m\<^sub>i\<^sub>r; + R = reward_pot - \t\<^sub>1; + rs = reward pp b R (fmdom' rewards) pools_ss stake delegs; + \t\<^sub>2 = R - (\ k \ fmdom' rs. rs $$! k) + in + (\t\<^sub>1 + \t\<^sub>2, -\r, rs, -fee_ss, registered) + )" + +text \ Applying a reward update \ + +fun apply_r_upd :: "reward_update \ epoch_state \ epoch_state" where + "apply_r_upd + (\t, \r, rs, \f, rew\<^sub>m\<^sub>i\<^sub>r) + ( + (treasury, reserves), + ss, + ( + (utxo, deps, fees, up), + ((stk_creds, rewards, i\<^sub>r\<^sub>w\<^sub>d), pstate) + ), + ppm + ) = + ( + let + rew'\<^sub>m\<^sub>i\<^sub>r = fmdom' stk_creds \ rew\<^sub>m\<^sub>i\<^sub>r; + unregistered = fmdom' stk_creds \/ rew\<^sub>m\<^sub>i\<^sub>r; + non_distributed = (\k \ fmdom' unregistered. unregistered $$! k); + update\<^sub>r\<^sub>w\<^sub>d = fmap_of_list [(addr_rwd hk, val). (hk, val) \ sorted_list_of_fmap rew'\<^sub>m\<^sub>i\<^sub>r] + in + ( + (treasury + \t, reserves + \r + non_distributed), + ss, + ( + (utxo, deps, fees + \f, up), + ((stk_creds, (rewards \\<^sub>+ rs) \\<^sub>+ update\<^sub>r\<^sub>w\<^sub>d, {$$}), pstate) + ), + ppm + ) + )" + end From 5c1a2dee0c6deb15d77e3c0819aebe8e4d3cb3a6 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Javier=20D=C3=ADaz?= Date: Sat, 11 Jan 2020 02:53:32 -0300 Subject: [PATCH 16/39] Introduce value preservation lemma for UTXOW subsystem --- Isabelle/Shelley/Properties.thy | 20 ++++++++++++++++++++ Isabelle/Shelley/UTxO.thy | 14 ++++++++++++++ 2 files changed, 34 insertions(+) diff --git a/Isabelle/Shelley/Properties.thy b/Isabelle/Shelley/Properties.thy index 9217246..890adc9 100644 --- a/Isabelle/Shelley/Properties.thy +++ b/Isabelle/Shelley/Properties.thy @@ -845,4 +845,24 @@ proof - by simp qed +fun val_utxow_state :: "utxo_state \ coin" where + "val_utxow_state s = val_utxo_state s" + +lemma utxow_value_preservation: + assumes "e \ s \\<^bsub>UTXOW\<^esub>{tx} s'" + shows "val_utxow_state s + wbalance (txwdrls tx) = val_utxow_state s'" +proof - + from assms show ?thesis + proof cases + case utxo_wit + from \e \ s \\<^bsub>UTXO\<^esub>{tx} s'\ have "val_utxo_state s + wbalance (txwdrls tx) = val_utxo_state s'" + using utxo_value_preservation by simp + then have "val_utxow_state s' = val_utxow_state s + wbalance (txwdrls tx)" + using val_utxow_state.simps by simp + then show ?thesis .. + qed +qed + + + end diff --git a/Isabelle/Shelley/UTxO.thy b/Isabelle/Shelley/UTxO.thy index 6f44138..743c7dd 100644 --- a/Isabelle/Shelley/UTxO.thy +++ b/Isabelle/Shelley/UTxO.thy @@ -126,4 +126,18 @@ inductive utxo_sts :: "utxo_env \ utxo_state \ tx \ ups \\<^bsub>UP\<^esub>{txup tx} ups'" +subsection \Witnesses\ + +text \ UTxO with witnesses inference rules \ + +text \ + NOTE: + \<^item> The validation preconditions in the spec are no needed for now. +\ +inductive utxow_sts :: "utxo_env \ utxo_state \ tx \ utxo_state \ bool" + (\_ \ _ \\<^bsub>UTXOW\<^esub>{_} _\ [51, 0, 51] 50) + where + utxo_wit: "\ \ s \\<^bsub>UTXOW\<^esub>{tx} s'" + if "\ \ s \\<^bsub>UTXO\<^esub>{tx} s'" + end From e51e53d86744524217badcfa1abe59f1b879b49c Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Javier=20D=C3=ADaz?= Date: Mon, 13 Jan 2020 21:19:29 -0300 Subject: [PATCH 17/39] Fix typo --- Isabelle/Shelley/UTxO.thy | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/Isabelle/Shelley/UTxO.thy b/Isabelle/Shelley/UTxO.thy index 743c7dd..332f540 100644 --- a/Isabelle/Shelley/UTxO.thy +++ b/Isabelle/Shelley/UTxO.thy @@ -132,7 +132,7 @@ text \ UTxO with witnesses inference rules \ text \ NOTE: - \<^item> The validation preconditions in the spec are no needed for now. + \<^item> The validation preconditions in the spec are not needed for now. \ inductive utxow_sts :: "utxo_env \ utxo_state \ tx \ utxo_state \ bool" (\_ \ _ \\<^bsub>UTXOW\<^esub>{_} _\ [51, 0, 51] 50) From a8026f9ebbb09856f3b55ff763ba03d2c85b1244 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Javier=20D=C3=ADaz?= Date: Mon, 13 Jan 2020 21:23:00 -0300 Subject: [PATCH 18/39] Improve lemma `delegs_value_preservation` --- Isabelle/Shelley/Properties.thy | 67 ++++++++++++++------------------- 1 file changed, 28 insertions(+), 39 deletions(-) diff --git a/Isabelle/Shelley/Properties.thy b/Isabelle/Shelley/Properties.thy index 890adc9..bcc8783 100644 --- a/Isabelle/Shelley/Properties.thy +++ b/Isabelle/Shelley/Properties.thy @@ -374,16 +374,15 @@ qed \ \NOTE: Lemma 15.7 in the spec.\ lemma delegs_value_preservation: - assumes " - (slot, tx) \ - ((stk_creds, rewards, i\<^sub>r\<^sub>w\<^sub>d), pstate) \\<^bsub>DELEGS\<^esub>{\} ((stk_creds', rewards', i\<^sub>r\<^sub>w\<^sub>d), pstate)" - shows "val_delegs_state ((stk_creds, rewards, i\<^sub>r\<^sub>w\<^sub>d), pstate) = - val_delegs_state ((stk_creds', rewards', i\<^sub>r\<^sub>w\<^sub>d), pstate) + wbalance (txwdrls tx)" + assumes "(slot, tx) \ s \\<^bsub>DELEGS\<^esub>{\} s'" + shows "val_delegs_state s = val_delegs_state s' + wbalance (txwdrls tx)" using assms -proof (induction "(slot, tx)" "((stk_creds, rewards, i\<^sub>r\<^sub>w\<^sub>d), pstate)" \ "((stk_creds', rewards', i\<^sub>r\<^sub>w\<^sub>d), - pstate)" arbitrary: slot tx stk_creds rewards i\<^sub>r\<^sub>w\<^sub>d stk_creds' rewards' pstate) - case (seq_delg_base wdrls tx rewards rewards' slot stk_creds i\<^sub>r\<^sub>w\<^sub>d pstate) - have "val_delegs_state ((stk_creds, rewards, i\<^sub>r\<^sub>w\<^sub>d), pstate) = val_map rewards" +proof (induction \ arbitrary: s' rule: rev_induct) + case Nil + from \(slot, tx) \ s \\<^bsub>DELEGS\<^esub>{[]} s'\ show ?case + proof cases + case (seq_delg_base wdrls rewards rewards' stk_creds i\<^sub>r\<^sub>w\<^sub>d pstate) + from \s = ((stk_creds, rewards, i\<^sub>r\<^sub>w\<^sub>d), pstate)\ have "val_delegs_state s = val_map rewards" by simp also have "\ = val_map wdrls + val_map (rewards --\<^sub>f wdrls)" proof - @@ -402,37 +401,29 @@ proof (induction "(slot, tx)" "((stk_creds, rewards, i\<^sub>r\<^sub>w\<^sub>d), also from \rewards' = rewards \\<^sub>\ fmmap (\_. 0) wdrls\ have "\ = val_map rewards' + wbalance (txwdrls tx)" by simp - finally show ?case - by simp -next - case (seq_delg_ind slot tx \ dpstate' c) - have "snd dpstate' = pstate" and "snd (snd (fst dpstate')) = i\<^sub>r\<^sub>w\<^sub>d" - proof - - from \slot \ dpstate' \\<^bsub>DELPL\<^esub>{c} ((stk_creds', rewards', i\<^sub>r\<^sub>w\<^sub>d), pstate)\ - show "snd dpstate' = pstate" - using delpl_sts.simps by auto + finally show ?thesis + using \s' = ((stk_creds, rewards', i\<^sub>r\<^sub>w\<^sub>d), pstate)\ by simp next - from \slot \ dpstate' \\<^bsub>DELPL\<^esub>{c} ((stk_creds', rewards', i\<^sub>r\<^sub>w\<^sub>d), pstate)\ - have "slot \ fst dpstate' \\<^bsub>DELEG\<^esub>{c} (stk_creds', rewards', i\<^sub>r\<^sub>w\<^sub>d)" - using delpl_sts.simps by auto - then show "snd (snd (fst dpstate')) = i\<^sub>r\<^sub>w\<^sub>d" - using deleg_sts.simps by auto - qed - with seq_delg_ind.hyps(2) have "val_delegs_state ((stk_creds, rewards, i\<^sub>r\<^sub>w\<^sub>d), pstate) = - val_delegs_state ((fst (fst dpstate'), fst (snd (fst dpstate')), i\<^sub>r\<^sub>w\<^sub>d), pstate) - + val_map (txwdrls tx)" - by (metis prod.exhaust_sel) - moreover have "val_deleg_state (fst (fst dpstate'), fst (snd (fst dpstate')), i\<^sub>r\<^sub>w\<^sub>d) = - val_deleg_state (stk_creds', rewards', i\<^sub>r\<^sub>w\<^sub>d)" - proof - - from \slot \ dpstate' \\<^bsub>DELPL\<^esub>{c} ((stk_creds', rewards', i\<^sub>r\<^sub>w\<^sub>d), pstate)\ - have "slot \ fst dpstate' \\<^bsub>DELEG\<^esub>{c} (stk_creds', rewards', i\<^sub>r\<^sub>w\<^sub>d)" - using delpl_sts.simps by auto - with \snd (snd (fst dpstate')) = i\<^sub>r\<^sub>w\<^sub>d\ show ?thesis - using deleg_value_preservation by fastforce + case (seq_delg_ind \ dpstate' c) + then show ?thesis + by simp qed - ultimately show ?case +next + case (snoc c \) + from \(slot, tx) \ s \\<^bsub>DELEGS\<^esub>{\ @ [c]} s'\ obtain s'' + where "(slot, tx) \ s \\<^bsub>DELEGS\<^esub>{\} s''" and "slot \ s'' \\<^bsub>DELPL\<^esub>{c} s'" + using delegs_sts.simps by blast + from \(slot, tx) \ s \\<^bsub>DELEGS\<^esub>{\} s''\ and snoc.IH have "val_delegs_state s + = val_delegs_state s'' + val_map (txwdrls tx)" by simp + moreover from \slot \ s'' \\<^bsub>DELPL\<^esub>{c} s'\ have "slot \ fst s'' \\<^bsub>DELEG\<^esub>{c} fst s'" + by (auto simp add: delpl_sts.simps) + then have "val_deleg_state (fst s'') = val_deleg_state (fst s')" + using deleg_value_preservation by simp + moreover have "val_delegs_state s'' = val_deleg_state (fst s'')" + by (metis val_delegs_state.elims eq_fst_iff) + ultimately show ?case + by (metis fst_conv val_delegs_state.elims) qed fun val_poolreap_state :: "pl_reap_state \ coin" where @@ -863,6 +854,4 @@ proof - qed qed - - end From ff34d5ee3db292e2ab6c1fc4869783297056da76 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Javier=20D=C3=ADaz?= Date: Mon, 13 Jan 2020 22:53:04 -0300 Subject: [PATCH 19/39] Introduce value preservation lemma for the LEDGER subsystem --- Isabelle/Shelley/Ledger.thy | 24 ++++++++++++++++++++++++ Isabelle/Shelley/Properties.thy | 23 ++++++++++++++++++++++- 2 files changed, 46 insertions(+), 1 deletion(-) diff --git a/Isabelle/Shelley/Ledger.thy b/Isabelle/Shelley/Ledger.thy index 04a8703..cac8b9c 100644 --- a/Isabelle/Shelley/Ledger.thy +++ b/Isabelle/Shelley/Ledger.thy @@ -4,8 +4,32 @@ theory Ledger imports UTxO Delegation begin +subsubsection \Ledger transition-system types\ + +text \ Ledger environment \ + +type_synonym l_env = " + slot \ \ \current slot\ + ix \ \ \transaction index\ + p_params \ \ \protocol parameters\ + coin \ \total reserves\" + text \ Ledger state \ type_synonym l_state = "utxo_state \ d_p_state" +text \ Ledger inference rule \ + +text \ + NOTE: + \<^item> \stkCreds\, \stpools\ and \genDelegs\ are not included for now. +\ +inductive ledger_sts :: "l_env \ l_state \ tx \ l_state \ bool" + (\_ \ _ \\<^bsub>LEDGER\<^esub>{_} _\ [51, 0, 51] 50) + where + ledger: " + (slot, tx_ix, pp, reserves) \ (utxo_st, dpstate) \\<^bsub>LEDGER\<^esub>{tx} (utxo_st', dpstate')" + if "(slot, tx) \ dpstate \\<^bsub>DELEGS\<^esub>{txcerts tx} dpstate'" + and "(slot, pp, undefined, undefined, undefined) \ utxo_st \\<^bsub>UTXOW\<^esub>{tx} utxo_st'" + end diff --git a/Isabelle/Shelley/Properties.thy b/Isabelle/Shelley/Properties.thy index bcc8783..6270c36 100644 --- a/Isabelle/Shelley/Properties.thy +++ b/Isabelle/Shelley/Properties.thy @@ -1,7 +1,7 @@ section \ Properties \ theory Properties - imports UTxO Delegation Rewards + imports UTxO Delegation Rewards Ledger begin subsection \ Preservation of Value \ @@ -854,4 +854,25 @@ proof - qed qed +fun val_ledger_state :: "l_state \ coin" where + "val_ledger_state (utxo_st, dpstate) = val_utxo_state utxo_st + val_delegs_state dpstate" + +lemma ledger_value_preservation: + assumes "e \ s \\<^bsub>LEDGER\<^esub>{tx} s'" + shows "val_ledger_state s = val_ledger_state s'" +proof - + from assms show ?thesis + proof cases + case (ledger slot dpstate dpstate' pp utxo_st utxo_st' tx_ix reserves) + from \(slot, pp, undefined, undefined, undefined) \ utxo_st \\<^bsub>UTXOW\<^esub>{tx} utxo_st'\ + have "val_utxo_state utxo_st' = val_utxo_state utxo_st + wbalance (txwdrls tx)" + using utxow_value_preservation by simp + moreover from \(slot, tx) \ dpstate \\<^bsub>DELEGS\<^esub>{txcerts tx} dpstate'\ + have "val_delegs_state dpstate = val_delegs_state dpstate' + wbalance (txwdrls tx)" + using delegs_value_preservation by simp + ultimately show ?thesis using val_ledger_state.simps + by (simp add: \s = (utxo_st, dpstate)\ \s' = (utxo_st', dpstate')\) + qed +qed + end From 2d4484e8254134304d374625e24de8159d6d9820 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Javier=20D=C3=ADaz?= Date: Tue, 14 Jan 2020 02:38:00 -0300 Subject: [PATCH 20/39] Introduce value preservation lemma for the LEDGERS subsystem --- Isabelle/Shelley/Basic_Types.thy | 36 +------------------------------ Isabelle/Shelley/Ledger.thy | 21 ++++++++++++++++++ Isabelle/Shelley/Properties.thy | 37 +++++++++++++++++++++++++++++--- 3 files changed, 56 insertions(+), 38 deletions(-) diff --git a/Isabelle/Shelley/Basic_Types.thy b/Isabelle/Shelley/Basic_Types.thy index ffc1d39..97cdc16 100644 --- a/Isabelle/Shelley/Basic_Types.thy +++ b/Isabelle/Shelley/Basic_Types.thy @@ -14,41 +14,7 @@ type_synonym coin = int text \ Index \ -typedecl ix - -axiomatization ix_to_nat :: "ix \ nat" where - ix_to_nat_injectivity: "inj ix_to_nat" - -instantiation ix :: countable -begin -instance by (standard, intro exI) (fact ix_to_nat_injectivity) -end - -instantiation ix :: linorder -begin - -definition less_ix :: "ix \ ix \ bool" where - "less_ix x y = (ix_to_nat x < ix_to_nat y)" - -definition less_eq_ix :: "ix \ ix \ bool" where - "less_eq_ix x y = (ix_to_nat x \ ix_to_nat y)" - -instance -proof - fix x y z :: ix - show "(x < y) = (x \ y \ \ y \ x)" - unfolding less_eq_ix_def and less_ix_def by auto - show "x \ x" - unfolding less_eq_ix_def by simp - show "\x \ y; y \ z\ \ x \ z" - unfolding less_eq_ix_def and less_ix_def by simp - show "\x \ y; y \ x\ \ x = y" - unfolding less_eq_ix_def using ix_to_nat_injectivity by (meson antisym injD) - show "x \ y \ y \ x" - unfolding less_eq_ix_def by auto -qed - -end +type_synonym ix = nat text \ Absolute slot \ diff --git a/Isabelle/Shelley/Ledger.thy b/Isabelle/Shelley/Ledger.thy index cac8b9c..aee3496 100644 --- a/Isabelle/Shelley/Ledger.thy +++ b/Isabelle/Shelley/Ledger.thy @@ -32,4 +32,25 @@ inductive ledger_sts :: "l_env \ l_state \ tx \ dpstate \\<^bsub>DELEGS\<^esub>{txcerts tx} dpstate'" and "(slot, pp, undefined, undefined, undefined) \ utxo_st \\<^bsub>UTXOW\<^esub>{tx} utxo_st'" +text \ Ledger sequence rules \ + +text \ + NOTE: + \<^item> No state updates are performed in \seq_ledger_base\ since all updates in the spec are not + related to the "preservation of value" property. +\ +inductive ledgers_sts :: "(slot \ p_params \ coin) \ l_state \ tx list \ l_state \ bool" + (\_ \ _ \\<^bsub>LEDGERS\<^esub>{_} _\ [51, 0, 51] 50) + where + seq_ledger_base: " + (slot, pp, reserves) \ ls \\<^bsub>LEDGERS\<^esub>{[]} ls'" + if "((utxo, deps, fees, us), (ds, ps)) = ls" + and "us' = us" + and "ds' = ds" + and "ls' = ((utxo, deps, fees, us'), (ds', ps))" + | seq_ledger_ind: " + (slot, pp, reserves) \ ls \\<^bsub>LEDGERS\<^esub>{\ @ [c]} ls''" + if "(slot, pp, reserves) \ ls \\<^bsub>LEDGERS\<^esub>{\} ls'" + and "(slot, length \ - 1, pp, reserves) \ ls' \\<^bsub>LEDGER\<^esub>{c} ls''" + end diff --git a/Isabelle/Shelley/Properties.thy b/Isabelle/Shelley/Properties.thy index 6270c36..bd47574 100644 --- a/Isabelle/Shelley/Properties.thy +++ b/Isabelle/Shelley/Properties.thy @@ -382,9 +382,9 @@ proof (induction \ arbitrary: s' rule: rev_induct) from \(slot, tx) \ s \\<^bsub>DELEGS\<^esub>{[]} s'\ show ?case proof cases case (seq_delg_base wdrls rewards rewards' stk_creds i\<^sub>r\<^sub>w\<^sub>d pstate) - from \s = ((stk_creds, rewards, i\<^sub>r\<^sub>w\<^sub>d), pstate)\ have "val_delegs_state s = val_map rewards" - by simp - also have "\ = val_map wdrls + val_map (rewards --\<^sub>f wdrls)" + from \s = ((stk_creds, rewards, i\<^sub>r\<^sub>w\<^sub>d), pstate)\ have "val_delegs_state s = val_map rewards" + by simp + also have "\ = val_map wdrls + val_map (rewards --\<^sub>f wdrls)" proof - from \wdrls \\<^sub>f rewards\ have "rewards = wdrls ++\<^sub>f (rewards --\<^sub>f wdrls)" by (simp add: fmdiff_partition) @@ -875,4 +875,35 @@ proof - qed qed +fun val_ledgers_state :: "l_state \ coin" where + "val_ledgers_state ls = val_ledger_state ls" + +lemma ledgers_value_preservation: + assumes "e \ s \\<^bsub>LEDGERS\<^esub>{\} s'" + shows "val_ledgers_state s = val_ledgers_state s'" + using assms +proof (induction \ arbitrary: s' rule: rev_induct) + case Nil + from \e \ s \\<^bsub>LEDGERS\<^esub>{[]} s'\ show ?case + by cases simp_all +next + case (snoc c \) + from \e \ s \\<^bsub>LEDGERS\<^esub>{\ @ [c]} s'\ show ?case + proof cases + case seq_ledger_base + then show ?thesis + by simp + next + case (seq_ledger_ind slot pp reserves \' s'' c') + from \(slot, pp, reserves) \ s \\<^bsub>LEDGERS\<^esub>{\'} s''\ and snoc.IH and \e = (slot, pp, reserves)\ + and \\ @ [c] = \' @ [c']\ have "val_ledgers_state s = val_ledgers_state s''" + by simp + moreover from \(slot, length \' - 1, pp, reserves) \ s'' \\<^bsub>LEDGER\<^esub>{c'} s'\ + have "val_ledger_state s'' = val_ledger_state s'" + using ledger_value_preservation by simp + ultimately show ?thesis + by simp + qed +qed + end From a185c118f15c544ffdb6583cd2996910e385cd08 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Javier=20D=C3=ADaz?= Date: Tue, 14 Jan 2020 14:44:42 -0300 Subject: [PATCH 21/39] Introduce value preservation lemma for the SNAP subsystem --- Isabelle/Shelley/Properties.thy | 30 +++++++++++++++++++++++++ Isabelle/Shelley/Rewards.thy | 39 +++++++++++++++++++++++++++++++++ 2 files changed, 69 insertions(+) diff --git a/Isabelle/Shelley/Properties.thy b/Isabelle/Shelley/Properties.thy index bd47574..ef1eff8 100644 --- a/Isabelle/Shelley/Properties.thy +++ b/Isabelle/Shelley/Properties.thy @@ -906,4 +906,34 @@ next qed qed +fun val_snap_state :: "snapshot_state \ coin" where + "val_snap_state (_, utxo_st) = val_utxo_state utxo_st" + +lemma snap_value_preservation: + assumes "e \ s \\<^bsub>SNAP\<^esub>{\} s'" + shows "val_snap_state s = val_snap_state s'" +proof - + from assms show ?thesis + proof cases + case (snapshot stake delegations oblg decayed deps pp dstate pstate pstake\<^sub>m\<^sub>a\<^sub>r\<^sub>k pstake\<^sub>s\<^sub>e\<^sub>t pstake\<^sub>g\<^sub>o + pools_ss fee_ss utxo fees up pools_params) + from \s' = + ( + ((stake, delegations), pstake\<^sub>m\<^sub>a\<^sub>r\<^sub>k, pstake\<^sub>s\<^sub>e\<^sub>t, pools_params, fees + decayed), + (utxo, oblg, fees + decayed, up) + )\ have "val_snap_state s' = val_utxo_state (utxo, oblg, fees + decayed, up)" + by simp + also have "\ = val_utxo utxo + oblg + (fees + decayed)" + by simp + also from \decayed = deps - oblg\ have "\ = val_utxo utxo + deps + fees" + by simp + also have "\ = val_utxo_state (utxo, deps, fees, up)" + by simp + also from \s = ((pstake\<^sub>m\<^sub>a\<^sub>r\<^sub>k, pstake\<^sub>s\<^sub>e\<^sub>t, pstake\<^sub>g\<^sub>o, pools_ss, fee_ss), (utxo, deps, fees, up))\ + have "\ = val_snap_state s" + by simp + finally show ?thesis .. + qed +qed + end diff --git a/Isabelle/Shelley/Rewards.thy b/Isabelle/Shelley/Rewards.thy index fedda5a..5b8bf9f 100644 --- a/Isabelle/Shelley/Rewards.thy +++ b/Isabelle/Shelley/Rewards.thy @@ -22,6 +22,13 @@ type_synonym stake = "(key_hash, coin) fmap" subsection \ Snapshot Transition \ +text \ Snapshots environment \ + +type_synonym snapshot_env = " + p_params \ \ \protocol parameters\ + d_state \ \ \delegation state\ + p_state \ \pool state\" + text \ Snapshots \ type_synonym snapshots = " @@ -31,6 +38,38 @@ type_synonym snapshots = " (key_hash, pool_param) fmap \ \ \pool parameters\ coin \ \fee snapshot\" +text \ Snapshots states \ + +type_synonym snapshot_state = " + snapshots \ \ \snapshots\ + utxo_state \ \utxo state\" + +text \ Snapshot Inference Rule \ + +text \ + NOTE: + \<^item> \stake\, \delegations\ and \oblg\ are not defined since they are not related to the + "preservation of value" property. +\ +inductive snap_sts :: "snapshot_env \ snapshot_state \ epoch \ snapshot_state \ bool" + (\_ \ _ \\<^bsub>SNAP\<^esub>{_} _\ [51, 0, 51] 50) + where + snapshot: " + (pp, dstate, pstate) \ + ( + (pstake\<^sub>m\<^sub>a\<^sub>r\<^sub>k, pstake\<^sub>s\<^sub>e\<^sub>t, pstake\<^sub>g\<^sub>o, pools_ss, fee_ss), + (utxo, deps, fees, up) + ) + \\<^bsub>SNAP\<^esub>{e} + ( + ((stake, delegations), pstake\<^sub>m\<^sub>a\<^sub>r\<^sub>k, pstake\<^sub>s\<^sub>e\<^sub>t, pools_params, fees + decayed), + (utxo, oblg, fees + decayed, up) + )" + if "stake = undefined" + and "delegations = undefined" + and "oblg = undefined" + and "decayed = deps - oblg" + subsection \ Pool Reaping Transition \ text \ Pool Reap State \ From 51847408b5f2b545e070c4f73f665de929f2bc7c Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Javier=20D=C3=ADaz?= Date: Thu, 16 Jan 2020 19:24:40 -0300 Subject: [PATCH 22/39] Introduce preservation lemma for the NEWPP subsystem --- Isabelle/Shelley/Delegation.thy | 5 +- Isabelle/Shelley/Properties.thy | 72 +++++++++++++++- Isabelle/Shelley/Protocol_Parameters.thy | 13 ++- Isabelle/Shelley/Rewards.thy | 100 +++++++++++++++++++++-- Isabelle/Shelley/Update.thy | 2 +- 5 files changed, 180 insertions(+), 12 deletions(-) diff --git a/Isabelle/Shelley/Delegation.thy b/Isabelle/Shelley/Delegation.thy index 7acc0f1..77042b2 100644 --- a/Isabelle/Shelley/Delegation.thy +++ b/Isabelle/Shelley/Delegation.thy @@ -14,7 +14,10 @@ type_synonym d_state = " (addr_rwd, coin) fmap \ \ \rewards\ (credential, coin) fmap \ \instantaneous rewards\" -typedecl p_state \ \NOTE: Abstract for now\ +type_synonym p_state = " + stake_pools \ \ \registered pools to creation time\ + (key_hash, pool_param) fmap \ \ \registered pools to pool parameters\ + (key_hash, epoch) fmap \ \retiring stake pools\" text \ Delegation Environment \ diff --git a/Isabelle/Shelley/Properties.thy b/Isabelle/Shelley/Properties.thy index ef1eff8..7fc683b 100644 --- a/Isabelle/Shelley/Properties.thy +++ b/Isabelle/Shelley/Properties.thy @@ -915,11 +915,11 @@ lemma snap_value_preservation: proof - from assms show ?thesis proof cases - case (snapshot stake delegations oblg decayed deps pp dstate pstate pstake\<^sub>m\<^sub>a\<^sub>r\<^sub>k pstake\<^sub>s\<^sub>e\<^sub>t pstake\<^sub>g\<^sub>o - pools_ss fee_ss utxo fees up pools_params) + case (snapshot stk_creds _ _ dstate stpools pool_params _ pstate stake utxo delegations slot + oblg pp decayed deps pstake\<^sub>m\<^sub>a\<^sub>r\<^sub>k pstake\<^sub>s\<^sub>e\<^sub>t pstake\<^sub>g\<^sub>o pools_ss fee_ss fees up) from \s' = ( - ((stake, delegations), pstake\<^sub>m\<^sub>a\<^sub>r\<^sub>k, pstake\<^sub>s\<^sub>e\<^sub>t, pools_params, fees + decayed), + ((stake, delegations), pstake\<^sub>m\<^sub>a\<^sub>r\<^sub>k, pstake\<^sub>s\<^sub>e\<^sub>t, pool_params, fees + decayed), (utxo, oblg, fees + decayed, up) )\ have "val_snap_state s' = val_utxo_state (utxo, oblg, fees + decayed, up)" by simp @@ -936,4 +936,70 @@ proof - qed qed +fun val_newpp_state :: "new_p_param_state \ coin" where + "val_newpp_state (utxo_st, (treasury, reserves), _) = + val_utxo_state utxo_st + val_coin treasury + val_coin reserves" + +lemma newpp_value_preservation: + assumes "e \ s \\<^bsub>NEWPP\<^esub>{\} s'" + shows "val_newpp_state s = val_newpp_state s'" +proof - + from assms show ?thesis + proof cases + case (new_proto_param_accept _ pp\<^sub>n\<^sub>e\<^sub>w treasury reserves acnt pp _ _ oblg\<^sub>c\<^sub>u\<^sub>r oblg\<^sub>n\<^sub>e\<^sub>w diff utxo deps + fees pup aup favs avs utxo_st utxo_st' acnt') + from \s' = (utxo_st', acnt', pp\<^sub>n\<^sub>e\<^sub>w)\ and \acnt' = (treasury, reserves + diff)\ + have "val_newpp_state s' = + val_utxo_state utxo_st' + val_coin treasury + val_coin (reserves + diff)" + by simp + also from \utxo_st' = (utxo, oblg\<^sub>n\<^sub>e\<^sub>w, fees, {$$}, aup, favs, avs)\ have "\ = + val_utxo utxo + oblg\<^sub>n\<^sub>e\<^sub>w + fees + val_coin treasury + val_coin (reserves + diff)" + by simp + also from \diff = oblg\<^sub>c\<^sub>u\<^sub>r - oblg\<^sub>n\<^sub>e\<^sub>w\ have "\ = + val_utxo utxo + oblg\<^sub>c\<^sub>u\<^sub>r - diff + fees + val_coin treasury + val_coin (reserves + diff)" + by simp + also have "\ = val_utxo utxo + oblg\<^sub>c\<^sub>u\<^sub>r + fees + treasury + reserves" + by simp + also from \deps = oblg\<^sub>c\<^sub>u\<^sub>r\ have "\ = val_utxo utxo + deps + fees + treasury + reserves" + by simp + also from \(utxo, deps, fees, pup, aup, favs, avs) = utxo_st\ have "\ = + val_utxo_state utxo_st + treasury + reserves" + by auto + also from \(treasury, reserves) = acnt\ and \s = (utxo_st, acnt, pp)\ have "\ = + val_newpp_state s" + by auto + finally show ?thesis .. + next + case (new_proto_param_denied_1 _ _ treasury reserves acnt pp _ _ utxo deps fees pup aup favs avs + utxo_st utxo_st') + from \s' = (utxo_st', acnt, pp)\ and \(treasury, reserves) = acnt\ + have "val_newpp_state s' = val_utxo_state utxo_st' + val_coin treasury + val_coin reserves" + by auto + also from \utxo_st' = (utxo, deps, fees, {$$}, aup, favs, avs)\ have "\ = + val_utxo utxo + deps + fees + val_coin treasury + val_coin reserves" + by simp + also from \(utxo, deps, fees, pup, aup, favs, avs) = utxo_st\ have "\ = + val_utxo_state utxo_st + treasury + reserves" + by auto + also from \(treasury, reserves) = acnt\ and \s = (utxo_st, acnt, pp)\ have "\ = + val_newpp_state s" + by auto + finally show ?thesis .. + next + case (new_proto_param_denied_2 _ utxo deps fees pup aup favs avs utxo_st utxo_st' _ _ acnt pp) + from \s' = (utxo_st', acnt, pp)\ + have "val_newpp_state s' = val_utxo_state utxo_st' + val_coin (fst acnt) + val_coin (snd acnt)" + by (metis prod.exhaust_sel val_newpp_state.simps) + also from \utxo_st' = (utxo, deps, fees, {$$}, aup, favs, avs)\ have "\ = + val_utxo utxo + deps + fees + val_coin (fst acnt) + val_coin (snd acnt)" + by simp + also from \(utxo, deps, fees, pup, aup, favs, avs) = utxo_st\ have "\ = + val_utxo_state utxo_st + fst acnt + snd acnt" + by auto + also from \s = (utxo_st, acnt, pp)\ have "\ = val_newpp_state s" + by (metis prod.collapse val_coin.elims val_newpp_state.simps) + finally show ?thesis .. + qed +qed + end diff --git a/Isabelle/Shelley/Protocol_Parameters.thy b/Isabelle/Shelley/Protocol_Parameters.thy index 1819a85..6c96f3b 100644 --- a/Isabelle/Shelley/Protocol_Parameters.thy +++ b/Isabelle/Shelley/Protocol_Parameters.thy @@ -1,7 +1,7 @@ section \ Protocol Parameters \ theory Protocol_Parameters - imports "HOL.Complex" Finite_Map_Extras + imports "HOL.Complex" Finite_Map_Extras Basic_Types begin text \ Protocol parameter name \ @@ -18,6 +18,12 @@ type_synonym p_params = "(ppm, pvalue) fmap" text \ Accessor Functions \ +consts max_block_size :: "p_params \ nat" \ \max block body size\ + +consts max_tx_size :: "p_params \ nat" \ \max transaction size\ + +consts max_header_size :: "p_params \ nat" \ \max block header size\ + consts tau :: "p_params \ real" \ \[0, 1]\ consts rho :: "p_params \ real" \ \[0, 1]\ @@ -28,4 +34,9 @@ text \ Global Constants \ consts slots_per_epoch :: nat +text \ Helper Functions \ + +fun first_slot :: "epoch \ slot" where + "first_slot e = undefined" \ \NOTE: Undefined for now\ + end diff --git a/Isabelle/Shelley/Rewards.thy b/Isabelle/Shelley/Rewards.thy index 5b8bf9f..8b86d13 100644 --- a/Isabelle/Shelley/Rewards.thy +++ b/Isabelle/Shelley/Rewards.thy @@ -6,9 +6,16 @@ begin subsection \ Helper Functions and Accounting Fields \ +text \ Total possible refunds \ + +fun obligation :: "p_params \ stake_creds \ stake_pools \ slot \ coin" where + "obligation pp stk_creds stpools cslot = undefined" \ \NOTE: Undefined for now\ + text \ Accounting Fields \ -type_synonym acnt = "coin \ coin" +type_synonym acnt = " + coin \ \ \treasury pot\ + coin \ \reserve pot\" subsection \ Stake Distribution Calculation \ @@ -20,6 +27,11 @@ text \ Stake \ type_synonym stake = "(key_hash, coin) fmap" +text \ Stake Distribution Function \ + +fun stake_distr :: "utxo \ d_state \ p_state \ stake" where + "stake_distr utxo dstate pstate = undefined" \ \NOTE: Undefined for now\ + subsection \ Snapshot Transition \ text \ Snapshots environment \ @@ -48,8 +60,7 @@ text \ Snapshot Inference Rule \ text \ NOTE: - \<^item> \stake\, \delegations\ and \oblg\ are not defined since they are not related to the - "preservation of value" property. + \<^item> \delegations\ is not defined since it is not related to the "preservation of value" property. \ inductive snap_sts :: "snapshot_env \ snapshot_state \ epoch \ snapshot_state \ bool" (\_ \ _ \\<^bsub>SNAP\<^esub>{_} _\ [51, 0, 51] 50) @@ -62,12 +73,15 @@ inductive snap_sts :: "snapshot_env \ snapshot_state \ e ) \\<^bsub>SNAP\<^esub>{e} ( - ((stake, delegations), pstake\<^sub>m\<^sub>a\<^sub>r\<^sub>k, pstake\<^sub>s\<^sub>e\<^sub>t, pools_params, fees + decayed), + ((stake, delegations), pstake\<^sub>m\<^sub>a\<^sub>r\<^sub>k, pstake\<^sub>s\<^sub>e\<^sub>t, pool_params, fees + decayed), (utxo, oblg, fees + decayed, up) )" - if "stake = undefined" + if "(stk_creds, _, _) = dstate" + and "(stpools, pool_params, _) = pstate" + and "stake = stake_distr utxo dstate pstate" and "delegations = undefined" - and "oblg = undefined" + and "slot = first_slot e" + and "oblg = obligation pp stk_creds stpools slot" and "decayed = deps - oblg" subsection \ Pool Reaping Transition \ @@ -106,6 +120,80 @@ inductive poolreap_sts :: "p_params \ pl_reap_state \ ep and "refunded = (\k \ fmdom' refunds. refunds $$! k)" and "unclaimed = (\k \ fmdom' m_refunds. m_refunds $$! k)" +subsection \ Protocol Parameters Update Transition \ + +text \ New Proto Param environment \ + +type_synonym new_p_param_env = " + p_params option \ \ \new protocol parameters\ + d_state \ \ \delegation state\ + p_state \ \pool state\" + +text \ New Proto Param States \ + +type_synonym new_p_param_state = " + utxo_state \ \ \utxo state\ + acnt \ \ \accounting\ + p_params \ \current protocol parameters\" + +text \ New Proto Param Inference Rules \ + +abbreviation newpp_oblgs where + "newpp_oblgs pp\<^sub>n\<^sub>e\<^sub>w pp dstate pstate e reserves \ + ( + let + stk_creds = fst dstate; + stpools = fst pstate; + slot = first_slot e; + oblg\<^sub>c\<^sub>u\<^sub>r = obligation pp stk_creds stpools slot; + oblg\<^sub>n\<^sub>e\<^sub>w = obligation pp\<^sub>n\<^sub>e\<^sub>w stk_creds stpools slot + in + (oblg\<^sub>c\<^sub>u\<^sub>r, oblg\<^sub>n\<^sub>e\<^sub>w) + )" + +abbreviation newpp_accepted where + "newpp_accepted pp\<^sub>n\<^sub>e\<^sub>w pp dstate pstate e reserves \ + ( + let + (_, _, i\<^sub>r\<^sub>w\<^sub>d) = dstate; + (oblg\<^sub>c\<^sub>u\<^sub>r, oblg\<^sub>n\<^sub>e\<^sub>w) = newpp_oblgs pp\<^sub>n\<^sub>e\<^sub>w pp dstate pstate e reserves; + diff = oblg\<^sub>c\<^sub>u\<^sub>r - oblg\<^sub>n\<^sub>e\<^sub>w + in + reserves + diff \ (\ c \ fmdom' i\<^sub>r\<^sub>w\<^sub>d. i\<^sub>r\<^sub>w\<^sub>d $$! c) \ + max_tx_size pp\<^sub>n\<^sub>e\<^sub>w + max_header_size pp\<^sub>n\<^sub>e\<^sub>w < max_block_size pp\<^sub>n\<^sub>e\<^sub>w + )" + +text \ + NOTE: + \<^item> For the sake of simplicity and readability, an extra rule is added. +\ +inductive newpp_sts :: "new_p_param_env \ new_p_param_state \ epoch \ new_p_param_state \ bool" + (\_ \ _ \\<^bsub>NEWPP\<^esub>{_} _\ [51, 0, 51] 50) + where + new_proto_param_accept: " + (opp\<^sub>n\<^sub>e\<^sub>w, dstate, pstate) \ (utxo_st, acnt, pp) \\<^bsub>NEWPP\<^esub>{e} (utxo_st', acnt', pp\<^sub>n\<^sub>e\<^sub>w)" + if "opp\<^sub>n\<^sub>e\<^sub>w = Some pp\<^sub>n\<^sub>e\<^sub>w" + and "(treasury, reserves) = acnt" + and "newpp_accepted pp\<^sub>n\<^sub>e\<^sub>w pp dstate pstate e reserves" + and "(oblg\<^sub>c\<^sub>u\<^sub>r, oblg\<^sub>n\<^sub>e\<^sub>w) = newpp_oblgs pp\<^sub>n\<^sub>e\<^sub>w pp dstate pstate e reserves" + and "diff = oblg\<^sub>c\<^sub>u\<^sub>r - oblg\<^sub>n\<^sub>e\<^sub>w" + and "(utxo, deps, fees, (pup, aup, favs, avs)) = utxo_st" + and "deps = oblg\<^sub>c\<^sub>u\<^sub>r" + and "utxo_st' = (utxo, oblg\<^sub>n\<^sub>e\<^sub>w, fees, ({$$}, aup, favs, avs))" + and "acnt' = (treasury, reserves + diff)" + | new_proto_param_denied_1: " + (opp\<^sub>n\<^sub>e\<^sub>w, dstate, pstate) \ (utxo_st, acnt, pp) \\<^bsub>NEWPP\<^esub>{e} (utxo_st', acnt, pp)" + if "opp\<^sub>n\<^sub>e\<^sub>w = Some pp\<^sub>n\<^sub>e\<^sub>w" + and "(treasury, reserves) = acnt" + and "\ newpp_accepted pp\<^sub>n\<^sub>e\<^sub>w pp dstate pstate e reserves" + and "(utxo, deps, fees, (pup, aup, favs, avs)) = utxo_st" + and "utxo_st' = (utxo, deps, fees, ({$$}, aup, favs, avs))" + | new_proto_param_denied_2: " + (opp\<^sub>n\<^sub>e\<^sub>w, dstate, pstate) \ (utxo_st, acnt, pp) \\<^bsub>NEWPP\<^esub>{e} (utxo_st', acnt, pp)" + if "opp\<^sub>n\<^sub>e\<^sub>w = None" + and "(utxo, deps, fees, (pup, aup, favs, avs)) = utxo_st" + and "utxo_st' = (utxo, deps, fees, ({$$}, aup, favs, avs))" + subsection \ Complete Epoch Boundary Transition \ text \ Epoch States \ diff --git a/Isabelle/Shelley/Update.thy b/Isabelle/Shelley/Update.thy index a4dd742..8a8ac0c 100644 --- a/Isabelle/Shelley/Update.thy +++ b/Isabelle/Shelley/Update.thy @@ -6,7 +6,7 @@ begin text \ Protocol parameter update \ -typedecl pp_update \ \NOTE: Abstract for now\ +type_synonym pp_update = "(key_hash_g, p_params) fmap" text \ Application update \ From efcb7745abcc0bc34282fbbcba22a9c056075d6e Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Javier=20D=C3=ADaz?= Date: Fri, 17 Jan 2020 16:47:20 -0300 Subject: [PATCH 23/39] Introduce value preservation lemma for the EPOCH subsystem --- Isabelle/Shelley/Properties.thy | 113 +++++++++++++++++++++++++++----- Isabelle/Shelley/Rewards.thy | 14 ++++ Isabelle/Shelley/Update.thy | 9 +++ 3 files changed, 120 insertions(+), 16 deletions(-) diff --git a/Isabelle/Shelley/Properties.thy b/Isabelle/Shelley/Properties.thy index 7fc683b..2bfed6a 100644 --- a/Isabelle/Shelley/Properties.thy +++ b/Isabelle/Shelley/Properties.thy @@ -426,9 +426,12 @@ next by (metis fst_conv val_delegs_state.elims) qed +fun val_acnt :: "acnt \ coin" where + "val_acnt (treasury, reserves) = val_coin treasury + val_coin reserves" + fun val_poolreap_state :: "pl_reap_state \ coin" where - "val_poolreap_state ((_, deps, _, _), (treasury, _), (_, rewards, _), _) = - val_coin deps + val_coin treasury + val_map rewards" + "val_poolreap_state (utxo_st, acnt, dstate, _) = + val_utxo_state utxo_st + val_acnt acnt + val_deleg_state dstate" lemma val_map_fmmap_keys: assumes "fmdom' m\<^sub>2 \ fmdom' m\<^sub>1" @@ -541,11 +544,24 @@ proof - case (pool_reap reward_acnts' refunds rewards m_refunds refunded unclaimed utxo deps fees ups treasury reserves stk_creds i\<^sub>r\<^sub>w\<^sub>d pstate) from pool_reap(2) have "val_poolreap_state s' = - deps - (unclaimed + refunded) + treasury + unclaimed + val_map (rewards \\<^sub>+ refunds)" + val_utxo_state (utxo, deps - (unclaimed + refunded), fees, ups) + + val_acnt (treasury + unclaimed, reserves) + + val_deleg_state (stk_creds, rewards \\<^sub>+ refunds, i\<^sub>r\<^sub>w\<^sub>d)" + by simp + also have "\ = + (val_utxo utxo + deps - (unclaimed + refunded) + fees) + + (treasury + unclaimed + reserves) + + val_map (rewards \\<^sub>+ refunds)" + by simp + also have "\ = + val_utxo utxo + fees + reserves + deps - (unclaimed + refunded) + treasury + unclaimed + + val_map (rewards \\<^sub>+ refunds)" by simp - also have "\ = deps - refunded + treasury + val_map (rewards \\<^sub>+ refunds)" + also have "\ = val_utxo utxo + fees + reserves + deps - refunded + treasury + + val_map (rewards \\<^sub>+ refunds)" by simp - also have "\ = deps - refunded + treasury + val_map rewards + val_map refunds" + also have "\ = val_utxo utxo + fees + reserves + deps - refunded + treasury + + val_map rewards + val_map refunds" proof - have "val_map (rewards \\<^sub>+ refunds) = val_map rewards + val_map refunds" proof - @@ -580,9 +596,11 @@ proof - qed qed +fun val_ledger_state :: "l_state \ coin" where + "val_ledger_state (utxo_st, dpstate) = val_utxo_state utxo_st + val_delegs_state dpstate" + fun val_epoch_state :: "epoch_state \ coin" where - "val_epoch_state ((treasury, reserves), _, ((_, _, fees, _), ((_, rewards, _), _)), _) = - val_coin treasury + val_coin reserves + val_coin fees + val_map rewards" + "val_epoch_state (acnt, _, ls, _) = val_acnt acnt + val_ledger_state ls" lemma val_map_union_plus: (* TODO: Find nicer proofs for SMT calls. *) shows "val_map (m\<^sub>1 \\<^sub>+ m\<^sub>2) = val_map m\<^sub>1 + val_map m\<^sub>2" @@ -736,7 +754,7 @@ proof - ((utxo, deps, fees, up), ((stk_creds, rewards, i\<^sub>r\<^sub>w\<^sub>d), pstate)), ppm )" - using val_epoch_state.cases by blast + by (metis old.prod.exhaust val_deleg_state.cases) moreover obtain \t \r rs \f rew\<^sub>m\<^sub>i\<^sub>r where f2: "create_r_upd b s = (\t, \r, rs, \f, rew\<^sub>m\<^sub>i\<^sub>r)" using prod_cases5 by blast ultimately obtain non_distributed and rew'\<^sub>m\<^sub>i\<^sub>r and update\<^sub>r\<^sub>w\<^sub>d and unregistered @@ -754,13 +772,18 @@ proof - and f7: "unregistered = fmdom' stk_creds \/ rew\<^sub>m\<^sub>i\<^sub>r" by (metis apply_r_upd.simps) then have "val_epoch_state (apply_r_upd (create_r_upd b s) s) = - treasury + reserves + fees + val_map rewards + \t + \r + non_distributed + \f + val_map rs - + val_map update\<^sub>r\<^sub>w\<^sub>d" + treasury + reserves + val_utxo utxo + deps + fees + val_map rewards + \t + \r + non_distributed + + \f + val_map rs + val_map update\<^sub>r\<^sub>w\<^sub>d" proof - from f2 and f3 have "val_epoch_state (apply_r_upd (create_r_upd b s) s) = - (treasury + \t) + (reserves + \r + non_distributed) + (fees + \f) + val_acnt (treasury + \t, reserves + \r + non_distributed) + + val_ledger_state ( + (utxo, deps, fees + \f, up), ((stk_creds, (rewards \\<^sub>+ rs) \\<^sub>+ update\<^sub>r\<^sub>w\<^sub>d, {$$}), pstate))" + by simp + then have "val_epoch_state (apply_r_upd (create_r_upd b s) s) = + (treasury + \t) + (reserves + \r + non_distributed) + val_utxo utxo + deps + (fees + \f) + val_map ((rewards \\<^sub>+ rs) \\<^sub>+ update\<^sub>r\<^sub>w\<^sub>d)" - using val_coin.simps and val_epoch_state.simps by presburger + by auto moreover have "val_map ((rewards \\<^sub>+ rs) \\<^sub>+ update\<^sub>r\<^sub>w\<^sub>d) = val_map rewards + val_map rs + val_map update\<^sub>r\<^sub>w\<^sub>d" using val_map_union_plus by metis @@ -830,7 +853,8 @@ proof - qed finally show ?thesis . qed - moreover have "val_epoch_state s = treasury + reserves + fees + val_map rewards" + moreover have "val_epoch_state s = + treasury + reserves + val_utxo utxo + deps + fees + val_map rewards" using f1 by simp ultimately show ?thesis by simp @@ -854,9 +878,6 @@ proof - qed qed -fun val_ledger_state :: "l_state \ coin" where - "val_ledger_state (utxo_st, dpstate) = val_utxo_state utxo_st + val_delegs_state dpstate" - lemma ledger_value_preservation: assumes "e \ s \\<^bsub>LEDGER\<^esub>{tx} s'" shows "val_ledger_state s = val_ledger_state s'" @@ -1002,4 +1023,64 @@ proof - qed qed + +lemma epoch_value_preservation: + assumes "\ s \\<^bsub>EPOCH\<^esub>{\} s'" + shows "val_epoch_state s = val_epoch_state s'" +proof - + from assms show ?thesis + proof cases + case (epoch utxo_st dstate pstate ls pp acnt utxo_st' acnt' dstate' pstate' ss ss' utxo_st'' + _ _ _ pup _ _ _ pp\<^sub>n\<^sub>e\<^sub>w utxo_st''' acnt'' pp' ls') + from \(pp\<^sub>n\<^sub>e\<^sub>w, dstate', pstate') \ (utxo_st'', acnt', pp) \\<^bsub>NEWPP\<^esub>{\} (utxo_st''', acnt'', pp')\ + have "val_newpp_state (utxo_st'', acnt', pp) = val_newpp_state (utxo_st''', acnt'', pp')" + using newpp_value_preservation by simp + then have f1: "val_utxo_state utxo_st'' + val_acnt acnt' = + val_utxo_state utxo_st''' + val_acnt acnt''" + by (metis add.assoc old.prod.exhaust val_acnt.simps val_newpp_state.simps) + moreover from \(pp, dstate', pstate') \ (ss, utxo_st') \\<^bsub>SNAP\<^esub>{\} (ss', utxo_st'')\ + have "val_snap_state (ss', utxo_st'') = val_snap_state (ss, utxo_st')" + using snap_value_preservation by presburger + then have f2: "val_utxo_state utxo_st'' = val_utxo_state utxo_st'" + by simp + moreover + from \pp \ (utxo_st, acnt, dstate, pstate) \\<^bsub>POOLREAP\<^esub>{\} (utxo_st', acnt', dstate', pstate')\ + have "val_poolreap_state (utxo_st', acnt', dstate', pstate') + = val_poolreap_state (utxo_st, acnt, dstate, pstate)" + using poolreap_value_preservation by presburger + then have f3: "val_utxo_state utxo_st' + val_acnt acnt' + val_deleg_state dstate' = + val_utxo_state utxo_st + val_acnt acnt + val_deleg_state dstate" + by simp + moreover have f4: "val_epoch_state s' = + val_acnt acnt'' + val_utxo_state utxo_st''' + val_deleg_state dstate'" + proof - + from \s' = (acnt'', ss', ls', pp')\ have "val_epoch_state s' = + val_acnt acnt'' + val_ledger_state ls'" + by simp + also from \ls' = (utxo_st''', (dstate', pstate'))\ have "\ = + val_acnt acnt'' + val_utxo_state utxo_st''' + val_delegs_state (dstate', pstate')" + by simp + finally show ?thesis + by simp + qed + ultimately show ?thesis + proof - + from f4 have "val_epoch_state s' = + (val_acnt acnt'' + val_utxo_state utxo_st''') + val_deleg_state dstate'" + by simp + also from f1 have "\ = (val_acnt acnt' + val_utxo_state utxo_st'') + val_deleg_state dstate'" + by simp + also from f2 have "\ = val_acnt acnt' + val_utxo_state utxo_st' + val_deleg_state dstate'" + by simp + also from f3 have "\ = val_utxo_state utxo_st + val_acnt acnt + val_deleg_state dstate" + by simp + also from \(utxo_st, (dstate, pstate)) = ls\ have "\ = val_acnt acnt + val_ledger_state ls" + by auto + finally show ?thesis using \s = (acnt, ss, ls, pp)\ + by simp + qed + qed +qed + + end diff --git a/Isabelle/Shelley/Rewards.thy b/Isabelle/Shelley/Rewards.thy index 8b86d13..5ba2032 100644 --- a/Isabelle/Shelley/Rewards.thy +++ b/Isabelle/Shelley/Rewards.thy @@ -200,6 +200,20 @@ text \ Epoch States \ type_synonym epoch_state = "acnt \ snapshots \ l_state \ p_params" +text \ Epoch Inference Rule \ + +inductive epoch_sts :: "epoch_state \ epoch \ epoch_state \ bool" + (\\ _ \\<^bsub>EPOCH\<^esub>{_} _\ [0, 51] 50) + where + epoch: "\ (acnt, ss, ls, pp) \\<^bsub>EPOCH\<^esub>{e} (acnt'', ss', ls', pp')" + if "(utxo_st, (dstate, pstate)) = ls" + and "pp \ (utxo_st, acnt, dstate, pstate) \\<^bsub>POOLREAP\<^esub>{e} (utxo_st', acnt', dstate', pstate')" + and "(pp, dstate', pstate') \ (ss, utxo_st') \\<^bsub>SNAP\<^esub>{e} (ss', utxo_st'')" + and "(_, _, _, (pup, _, _, _)) = utxo_st''" + and "pp\<^sub>n\<^sub>e\<^sub>w = voted_value\<^sub>P\<^sub>P\<^sub>a\<^sub>r\<^sub>a\<^sub>m\<^sub>s pup" + and "(pp\<^sub>n\<^sub>e\<^sub>w, dstate', pstate') \ (utxo_st'', acnt', pp) \\<^bsub>NEWPP\<^esub>{e} (utxo_st''', acnt'', pp')" + and "ls' = (utxo_st''', (dstate', pstate'))" + subsection \ Reward Distribution Calculation \ text \ Calculation to reward all stake pools \ diff --git a/Isabelle/Shelley/Update.thy b/Isabelle/Shelley/Update.thy index 8a8ac0c..8f3317d 100644 --- a/Isabelle/Shelley/Update.thy +++ b/Isabelle/Shelley/Update.thy @@ -4,10 +4,19 @@ theory Update imports Basic_Types Protocol_Parameters Cryptography Finite_Map_Extras begin +subsection \ Protocol Parameter Update Proposals \ + text \ Protocol parameter update \ type_synonym pp_update = "(key_hash_g, p_params) fmap" +text \ Epoch Helper Functions \ + +fun voted_value\<^sub>P\<^sub>P\<^sub>a\<^sub>r\<^sub>a\<^sub>m\<^sub>s :: "(key_hash_g, p_params) fmap \ p_params option" where + "voted_value\<^sub>P\<^sub>P\<^sub>a\<^sub>r\<^sub>a\<^sub>m\<^sub>s vs = undefined" \ \NOTE: Undefined for now\ + +subsection \ Application Version Update Proposals \ + text \ Application update \ typedecl av_update \ \NOTE: Abstract for now\ From 59d1be0ac1ba482b770203123531dc183036dfdf Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Javier=20D=C3=ADaz?= Date: Fri, 17 Jan 2020 17:17:59 -0300 Subject: [PATCH 24/39] Improve the state value calculation functions --- Isabelle/Shelley/Properties.thy | 25 +++++++++++-------------- 1 file changed, 11 insertions(+), 14 deletions(-) diff --git a/Isabelle/Shelley/Properties.thy b/Isabelle/Shelley/Properties.thy index 2bfed6a..aaf670d 100644 --- a/Isabelle/Shelley/Properties.thy +++ b/Isabelle/Shelley/Properties.thy @@ -18,7 +18,7 @@ abbreviation val_utxo :: "utxo \ coin" where "val_utxo utxo \ ubalance utxo" fun val_utxo_state :: "utxo_state \ coin" where - "val_utxo_state (utxo, deps, fees, _) = val_utxo utxo + deps + fees" + "val_utxo_state (utxo, deps, fees, _) = val_utxo utxo + val_coin deps + val_coin fees" lemma val_map_add: assumes "m $$ k = None" @@ -262,7 +262,7 @@ proof - qed fun val_delegs_state :: "d_p_state \ coin" where - "val_delegs_state (d_state, _) = val_deleg_state d_state" + "val_delegs_state (dstate, _) = val_deleg_state dstate" lemma val_map_minus: assumes "m\<^sub>2 \\<^sub>f m\<^sub>1" @@ -958,8 +958,7 @@ proof - qed fun val_newpp_state :: "new_p_param_state \ coin" where - "val_newpp_state (utxo_st, (treasury, reserves), _) = - val_utxo_state utxo_st + val_coin treasury + val_coin reserves" + "val_newpp_state (utxo_st, acnt, _) = val_utxo_state utxo_st + val_acnt acnt" lemma newpp_value_preservation: assumes "e \ s \\<^bsub>NEWPP\<^esub>{\} s'" @@ -1008,17 +1007,15 @@ proof - finally show ?thesis .. next case (new_proto_param_denied_2 _ utxo deps fees pup aup favs avs utxo_st utxo_st' _ _ acnt pp) - from \s' = (utxo_st', acnt, pp)\ - have "val_newpp_state s' = val_utxo_state utxo_st' + val_coin (fst acnt) + val_coin (snd acnt)" - by (metis prod.exhaust_sel val_newpp_state.simps) + from \s' = (utxo_st', acnt, pp)\ have "val_newpp_state s' = + val_utxo_state utxo_st' + val_acnt acnt" + by simp also from \utxo_st' = (utxo, deps, fees, {$$}, aup, favs, avs)\ have "\ = - val_utxo utxo + deps + fees + val_coin (fst acnt) + val_coin (snd acnt)" + val_utxo utxo + val_coin deps + val_coin fees + val_acnt acnt" by simp - also from \(utxo, deps, fees, pup, aup, favs, avs) = utxo_st\ have "\ = - val_utxo_state utxo_st + fst acnt + snd acnt" + also from \(utxo, deps, fees, pup, aup, favs, avs) = utxo_st\ and \s = (utxo_st, acnt, pp)\ + have "\ = val_newpp_state s" by auto - also from \s = (utxo_st, acnt, pp)\ have "\ = val_newpp_state s" - by (metis prod.collapse val_coin.elims val_newpp_state.simps) finally show ?thesis .. qed qed @@ -1034,10 +1031,10 @@ proof - _ _ _ pup _ _ _ pp\<^sub>n\<^sub>e\<^sub>w utxo_st''' acnt'' pp' ls') from \(pp\<^sub>n\<^sub>e\<^sub>w, dstate', pstate') \ (utxo_st'', acnt', pp) \\<^bsub>NEWPP\<^esub>{\} (utxo_st''', acnt'', pp')\ have "val_newpp_state (utxo_st'', acnt', pp) = val_newpp_state (utxo_st''', acnt'', pp')" - using newpp_value_preservation by simp + using newpp_value_preservation by fast then have f1: "val_utxo_state utxo_st'' + val_acnt acnt' = val_utxo_state utxo_st''' + val_acnt acnt''" - by (metis add.assoc old.prod.exhaust val_acnt.simps val_newpp_state.simps) + by simp moreover from \(pp, dstate', pstate') \ (ss, utxo_st') \\<^bsub>SNAP\<^esub>{\} (ss', utxo_st'')\ have "val_snap_state (ss', utxo_st'') = val_snap_state (ss, utxo_st')" using snap_value_preservation by presburger From d3aec94f186b188f3eb3831e1980d7e1cca1e21a Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Javier=20D=C3=ADaz?= Date: Tue, 21 Jan 2020 12:07:23 -0300 Subject: [PATCH 25/39] Introduce value preservation lemmas for the NEWEPOCH, RUPD, TICK, BBODY and CHAIN subsystems --- Isabelle/Shelley/Basic_Types.thy | 6 +- Isabelle/Shelley/Chain.thy | 235 +++++++++++++++++++++++ Isabelle/Shelley/Cryptography.thy | 8 + Isabelle/Shelley/Properties.thy | 119 +++++++++++- Isabelle/Shelley/Protocol_Parameters.thy | 11 +- Isabelle/Shelley/ROOT | 1 + 6 files changed, 370 insertions(+), 10 deletions(-) create mode 100644 Isabelle/Shelley/Chain.thy diff --git a/Isabelle/Shelley/Basic_Types.thy b/Isabelle/Shelley/Basic_Types.thy index 97cdc16..d076879 100644 --- a/Isabelle/Shelley/Basic_Types.thy +++ b/Isabelle/Shelley/Basic_Types.thy @@ -1,12 +1,12 @@ section \ Basic Types \ theory Basic_Types - imports "HOL-Library.Countable" + imports Main begin text \ Epoch \ -typedecl epoch +type_synonym epoch = nat text \ Unit of value \ @@ -18,7 +18,7 @@ type_synonym ix = nat text \ Absolute slot \ -typedecl slot +type_synonym slot = nat text \ Application versions \ diff --git a/Isabelle/Shelley/Chain.thy b/Isabelle/Shelley/Chain.thy new file mode 100644 index 0000000..970b124 --- /dev/null +++ b/Isabelle/Shelley/Chain.thy @@ -0,0 +1,235 @@ +section \ Blockchain layer \ + +theory Chain + imports Rewards +begin + +subsection \ Verifiable Random Functions (VRF) \ + +text \ Seed for pseudo-random number generator \ + +typedecl seed + +text \ Stake pool distribution \ + +typedecl pool_distr \ \NOTE: Abstract for now\ + +subsection \ Block Definitions \ + +text \ Abstract Types \ + +typedecl hash_header \ \hash of a block header\ + +typedecl hash_b_body \ \hash of a block body\ + +text \ Block Header Body \ + +typedecl b_h_body \ \NOTE: Abstract for now\ + +text \ Block Types \ + +typedecl b_header \ \NOTE: Abstract for now\ + +typedecl block \ \NOTE: Abstract for now\ + +text \ Abstract Functions \ + +consts b_header_size :: "b_header \ nat" \ \size of a block header\ + +consts b_body_size :: "tx list \ nat" \ \size of a block body\ + +text \ Accessor Functions \ + +\ \NOTE: The following function is actually a block header body field in the spec. Abstract for now\ +consts bhash :: "b_h_body \ hash_b_body" \ \block body hash\ + +consts bheader :: "block \ b_header" \ \NOTE: Abstract for now\ + +consts bhbody :: "b_header \ b_h_body" \ \NOTE: Abstract for now\ + +consts bbody :: "block \ tx list" \ \NOTE: Abstract for now\ + +consts bvkcold :: "b_h_body \ v_key" \ \NOTE: Abstract for now\ + +consts bslot :: "b_h_body \ slot" \ \NOTE: Abstract for now\ + +consts h_b_bsize :: "b_h_body \ nat" \ \NOTE: Abstract for now\ + +consts bbodyhash :: "tx list \ hash_b_body" + +subsection \ New Epoch Transition \ + +text \ New Epoch environments \ + +type_synonym new_epoch_env = " + slot \ \ \current slot\ + key_hash_g set \ \genesis key hashes\" + +text \ New Epoch states \ + +type_synonym new_epoch_state = " + epoch \ \ \last epoch\ + blocks_made \ \ \blocks made last epoch\ + blocks_made \ \ \blocks made this epoch\ + epoch_state \ \ \epoch state\ + reward_update option \ \ \reward state\ + pool_distr \ \ \pool stake distribution\ + (slot, key_hash_g option) fmap \ \OBFT overlay schedule\" + +text \ New Epoch rules \ + +text \ + NOTE: + \<^item> The general constraints in the spec are not enforced for now. + \<^item> \pd'\ and \osched'\ are undefined for now. +\ +inductive new_epoch_sts :: "new_epoch_env \ new_epoch_state \ epoch \ new_epoch_state \ bool" + (\_ \ _ \\<^bsub>NEWEPOCH\<^esub>{_} _\ [51, 0, 51] 50) + where + new_epoch: " + \ \ + (e\<^sub>l, b\<^sub>p\<^sub>r\<^sub>e\<^sub>v, b\<^sub>c\<^sub>u\<^sub>r, es, ru, pd, osched) \\<^bsub>NEWEPOCH\<^esub>{e} (e, b\<^sub>c\<^sub>u\<^sub>r, {$$}, es', None, pd', osched')" + if "e = e\<^sub>l + 1" + and "ru = Some ru'" + and "ru' = create_r_upd b\<^sub>p\<^sub>r\<^sub>e\<^sub>v es" + and "\ apply_r_upd ru' es \\<^bsub>EPOCH\<^esub>{e} es'" + and "pd' = undefined" + and "osched' = undefined" + | not_new_epoch: " + \ \ nes \\<^bsub>NEWEPOCH\<^esub>{e} nes" + if "e \ e\<^sub>l + 1" + | no_reward_update: " + \ \ nes \\<^bsub>NEWEPOCH\<^esub>{e} nes" + if "e = e\<^sub>l + 1" + and "(_, _, _, _, ru, _, _) = nes" + and "ru = None" + +subsection \ Reward Update Transition \ + +text \ Reward Update environments \ + +type_synonym r_upd_env = " + blocks_made \ \ \blocks made\ + epoch_state \ \epoch state\" + +text \ Reward Update rules \ + +inductive rupd_sts :: "r_upd_env \ reward_update option \ slot \ reward_update option \ bool" + (\_ \ _ \\<^bsub>RUPD\<^esub>{_} _\ [51, 0, 51] 50) + where + create_reward_update: " + (b, es) \ ru \\<^bsub>RUPD\<^esub>{s} ru'" + if "s > first_slot (epoch s) + start_rewards" + and "ru = None" + and "ru' = Some (create_r_upd b es)" + | reward_update_exists: " + _ \ ru \\<^bsub>RUPD\<^esub>{s} ru" + if "ru \ None" + | reward_too_early: " + _ \ ru \\<^bsub>RUPD\<^esub>{s} ru" + if "ru = None" + and "s \ first_slot (epoch s) + start_rewards" + +subsection \ Chain Tick Transition \ + +inductive tick_sts :: "key_hash_g set \ new_epoch_state \ slot \ new_epoch_state \ bool" + (\_ \ _ \\<^bsub>TICK\<^esub>{_} _\ [51, 0, 51] 50) + where + tick: " + gkeys \ nes \\<^bsub>TICK\<^esub>{s} nes''" + if "(s, gkeys) \ nes \\<^bsub>NEWEPOCH\<^esub>{epoch s} nes'" + and "(_, b\<^sub>p\<^sub>r\<^sub>e\<^sub>v, _, es, _, _, _) = nes" + and "(e\<^sub>l', b\<^sub>p\<^sub>r\<^sub>e\<^sub>v', b\<^sub>c\<^sub>u\<^sub>r', es', ru, pd', osched') = nes'" + and "(b\<^sub>p\<^sub>r\<^sub>e\<^sub>v, es) \ ru \\<^bsub>RUPD\<^esub>{s} ru'" + and "nes'' = (e\<^sub>l', b\<^sub>p\<^sub>r\<^sub>e\<^sub>v', b\<^sub>c\<^sub>u\<^sub>r', es', ru', pd', osched')" + +subsection \ Block Body Transition \ + +text \ BBody environments \ + +type_synonym b_body_env = " + slot set \ \ \overlay slots\ + p_params \ \ \protocol parameters\ + coin \ \total reserves\" + +text \ BBody states \ + +type_synonym b_body_state = " + l_state \ \ \ledger state\ + blocks_made \ \blocks made\" + +text \ BBody helper function \ + +fun incr_blocks :: "bool \ key_hash \ blocks_made \ blocks_made" where + "incr_blocks is_overlay hk b = undefined" \ \NOTE: Undefined for now\ + +text \ BBody rules \ + +inductive bbody_sts :: "b_body_env \ b_body_state \ block \ b_body_state \ bool" + (\_ \ _ \\<^bsub>BBODY\<^esub>{_} _\ [51, 0, 51] 50) + where + block_body: " + (oslots, pp, reserves) \ + (ls, b) \\<^bsub>BBODY\<^esub>{block} (ls', incr_blocks (bslot bhb \ oslots) hk b)" + if "txs = bbody block" + and "bhb = bhbody (bheader block)" + and "hk = hash_key (bvkcold bhb)" + and "b_body_size txs = h_b_bsize bhb" + and "bbodyhash txs = bhash bhb" + and "(bslot bhb, pp, reserves) \ ls \\<^bsub>LEDGERS\<^esub>{txs} ls'" + +subsection \ Chain Transition \ + +text \ Chain states \ + +type_synonym chain_state = " + new_epoch_state \ \ \epoch specific state\ + (key_hash, nat) fmap \ \ \operational certificate issue numbers\ + seed \ \ \epoch nonce\ + seed \ \ \evolving nonce\ + seed \ \ \candidate nonce\ + seed \ \ \seed generated from hash of previous epoch\ + hash_header \ \ \latest header hash\ + slot \ \last slot\" + +text \ Chain Transition Helper Functions \ + +fun get_g_keys :: "new_epoch_state \ key_hash_g set" where + "get_g_keys nes = undefined" \ \NOTE: Undefined for now\ + +fun update_nes :: "new_epoch_state \ blocks_made \ l_state \ new_epoch_state" where + "update_nes (e\<^sub>l, b\<^sub>p\<^sub>r\<^sub>e\<^sub>v, _, (acnt, ss, _, pp), ru, pd, osched) b\<^sub>c\<^sub>u\<^sub>r ls = + (e\<^sub>l, b\<^sub>p\<^sub>r\<^sub>e\<^sub>v, b\<^sub>c\<^sub>u\<^sub>r, (acnt, ss, ls, pp), ru, pd, osched)" + +text \ Chain Rules \ + +text \ + NOTE: + \<^item> The \PRTCL\ rule is not included for now. +\ +inductive chain_sts :: "slot \ chain_state \ block \ chain_state \ bool" + (\_ \ _ \\<^bsub>CHAIN\<^esub>{_} _\ [51, 0, 51] 50) + where + chain: " + s\<^sub>n\<^sub>o\<^sub>w \ (nes, cs, \\<^sub>0, \\<^sub>v, \\<^sub>c, \\<^sub>h, h, s\<^sub>l) \\<^bsub>CHAIN\<^esub>{block} (nes'', cs', \'\<^sub>0, \'\<^sub>v, \'\<^sub>c, \'\<^sub>h, h', s'\<^sub>l)" + if "bh = bheader block" + and "bhb = bhbody bh" + and "gkeys = get_g_keys nes" + and "s = bslot bhb" + and "(_, _, _, (_, _, _, pp), _, _, _) = nes" + and "b_header_size bh \ max_header_size pp" + and "h_b_bsize bhb \ max_block_size pp" + and "gkeys \ nes \\<^bsub>TICK\<^esub>{s} nes'" + and "(_, _, b\<^sub>c\<^sub>u\<^sub>r, es, _, _, osched) = nes'" + and "(acnt, _, ls, pp') = es" + and "(_, reserves) = acnt" + and "(fmdom' osched, pp', reserves) \ (ls, b\<^sub>c\<^sub>u\<^sub>r) \\<^bsub>BBODY\<^esub>{block} (ls', b'\<^sub>c\<^sub>u\<^sub>r)" + and "nes'' = update_nes nes' b'\<^sub>c\<^sub>u\<^sub>r ls'" + and "cs' = undefined" + and "\'\<^sub>0 = undefined" + and "\'\<^sub>v = undefined" + and "\'\<^sub>c = undefined" + and "\'\<^sub>h = undefined" + and "h' = undefined" + and "s'\<^sub>l = undefined" +end diff --git a/Isabelle/Shelley/Cryptography.thy b/Isabelle/Shelley/Cryptography.thy index 8b3bfb3..e78b5e8 100644 --- a/Isabelle/Shelley/Cryptography.thy +++ b/Isabelle/Shelley/Cryptography.thy @@ -4,6 +4,10 @@ theory Cryptography imports Main begin +text \ Public verifying key \ + +typedecl v_key + text \ Hash of a key \ typedecl key_hash @@ -12,4 +16,8 @@ text \ Genesis key hash \ typedecl key_hash_g +text \ hashKey function \ + +consts hash_key :: "v_key \ key_hash" + end diff --git a/Isabelle/Shelley/Properties.thy b/Isabelle/Shelley/Properties.thy index aaf670d..76b8171 100644 --- a/Isabelle/Shelley/Properties.thy +++ b/Isabelle/Shelley/Properties.thy @@ -1,7 +1,7 @@ section \ Properties \ theory Properties - imports UTxO Delegation Rewards Ledger + imports UTxO Delegation Rewards Ledger Chain begin subsection \ Preservation of Value \ @@ -63,8 +63,13 @@ next qed also from fmupd.prems and fmupd.IH have "\ = val_map m\<^sub>1 + val_map m\<^sub>2 + c" by simp - also from fmupd.hyps have "\ = val_map m\<^sub>1 + val_map (m\<^sub>2(k $$:= c))" - using val_map_add by (smt sum.cong) + also have "\ = val_map m\<^sub>1 + val_map (m\<^sub>2(k $$:= c))" + proof - + from fmupd.hyps have "val_map m\<^sub>2(k $$:= c) = val_map m\<^sub>2 + c" + using val_map_add by simp + then show ?thesis + by simp + qed finally show ?case . qed @@ -135,10 +140,12 @@ proof - also have "\ = val_map (fmmap snd (txins tx \/ utxo)) + val_map (fmmap snd (outs tx))" proof - from \txid tx \ {tid | tid ix. (tid, ix) \ fmdom' utxo}\ - have "fmdom'(txins tx \/ utxo) \ fmdom' (outs tx) = {}" + have "fmdom' (txins tx \/ utxo) \ fmdom' (outs tx) = {}" using txins_outs_exc by blast + then have "fmdom' (fmmap snd (txins tx \/ utxo)) \ fmdom' (fmmap snd (outs tx)) = {}" + by simp then show ?thesis - using val_map_union by (smt fmdom'_map sum.cong) + using val_map_union by blast qed also have "\ = ubalance (txins tx \/ utxo) + ubalance (outs tx)" using val_utxo_val_map by presburger @@ -1020,7 +1027,6 @@ proof - qed qed - lemma epoch_value_preservation: assumes "\ s \\<^bsub>EPOCH\<^esub>{\} s'" shows "val_epoch_state s = val_epoch_state s'" @@ -1079,5 +1085,106 @@ proof - qed qed +fun val_new_epoch_state :: "new_epoch_state \ coin" where + "val_new_epoch_state (_, _, _, es, _, _, _) = val_epoch_state es" + +lemma newepoch_value_preservation: + assumes "e \ s \\<^bsub>NEWEPOCH\<^esub>{\} s'" + and "inj addr_rwd" + and "mono addr_rwd" + shows "val_new_epoch_state s = val_new_epoch_state s'" +proof - + from assms show ?thesis + proof cases + case (new_epoch e\<^sub>l ru ru' b\<^sub>p\<^sub>r\<^sub>e\<^sub>v es es' pd' osched' b\<^sub>c\<^sub>u\<^sub>r pd osched) + have "val_epoch_state es' = val_epoch_state es" + proof - + from \inj addr_rwd\ and \mono addr_rwd\ and \ru' = create_r_upd b\<^sub>p\<^sub>r\<^sub>e\<^sub>v es\ have " + val_epoch_state (apply_r_upd ru' es) = val_epoch_state es" + using reward_update_value_preservation by presburger + with \\ apply_r_upd ru' es \\<^bsub>EPOCH\<^esub>{\} es'\ show ?thesis + using epoch_value_preservation by simp + qed + with \s = (e\<^sub>l, b\<^sub>p\<^sub>r\<^sub>e\<^sub>v, b\<^sub>c\<^sub>u\<^sub>r, es, ru, pd, osched)\ and + \s' = (\, b\<^sub>c\<^sub>u\<^sub>r, {$$}, es', None, pd', osched')\ show ?thesis + by simp + next + case not_new_epoch + then show ?thesis by simp + next + case no_reward_update + then show ?thesis by simp + qed +qed + +lemma tick_value_preservation: + assumes "gkeys \ nes \\<^bsub>TICK\<^esub>{s} nes'" + and "inj addr_rwd" + and "mono addr_rwd" + shows "val_new_epoch_state nes = val_new_epoch_state nes'" +proof - + from assms show ?thesis + proof cases + case (tick nes'' _ b\<^sub>p\<^sub>r\<^sub>e\<^sub>v _ es _ _ _ e\<^sub>l'' b\<^sub>p\<^sub>r\<^sub>e\<^sub>v'' b\<^sub>c\<^sub>u\<^sub>r'' es'' ru pd'' osched'' ru'') + from assms and \(s, gkeys) \ nes \\<^bsub>NEWEPOCH\<^esub>{epoch s} nes''\ have " + val_new_epoch_state nes = val_new_epoch_state nes''" + using newepoch_value_preservation by simp + also from \nes' = (e\<^sub>l'', b\<^sub>p\<^sub>r\<^sub>e\<^sub>v'', b\<^sub>c\<^sub>u\<^sub>r'', es'', ru'', pd'', osched'')\ and + \(e\<^sub>l'', b\<^sub>p\<^sub>r\<^sub>e\<^sub>v'', b\<^sub>c\<^sub>u\<^sub>r'', es'', ru, pd'', osched'') = nes''\ have " + \ = val_new_epoch_state nes'" + by auto + finally show ?thesis . + qed +qed + +fun val_b_body_state :: "b_body_state \ coin" where + "val_b_body_state (ls, _) = val_ledgers_state ls" + +lemma bbody_value_preservation: + assumes "e \ s \\<^bsub>BBODY\<^esub>{block} s'" + shows "val_b_body_state s = val_b_body_state s'" +proof - + from assms show ?thesis + proof cases + case (block_body txs bhb hk pp reserves ls ls' oslots b) + from \(bslot bhb, pp, reserves) \ ls \\<^bsub>LEDGERS\<^esub>{txs} ls'\ have " + val_ledgers_state ls = val_ledgers_state ls'" + using ledgers_value_preservation by simp + with \s = (ls, b)\ and \s' = (ls', incr_blocks (bslot bhb \ oslots) hk b)\ have " + val_b_body_state s = val_b_body_state s'" + by simp + then show ?thesis . + qed +qed + +fun val_chain_state :: "chain_state \ coin" where + "val_chain_state s = val_new_epoch_state (fst s)" + +theorem chain_value_preservation: + assumes "e \ s \\<^bsub>CHAIN\<^esub>{block} s'" + and "inj addr_rwd" + and "mono addr_rwd" + shows "val_chain_state s = val_chain_state s'" +proof - + from assms show ?thesis + proof cases + case (chain bh bhb gkeys nes slot _ _ _ _ _ _ pp _ _ _ nes' _ _ b\<^sub>c\<^sub>u\<^sub>r es _ _ osched acnt _ ls pp' + _ reserves ls' b'\<^sub>c\<^sub>u\<^sub>r nes'' cs' \'\<^sub>0 \'\<^sub>v \'\<^sub>c \'\<^sub>h h' s'\<^sub>l cs \\<^sub>0 \\<^sub>v \\<^sub>c \\<^sub>h h s\<^sub>l) + from \gkeys \ nes \\<^bsub>TICK\<^esub>{slot} nes'\ and \inj addr_rwd\ and \mono addr_rwd\ have " + val_new_epoch_state nes = val_new_epoch_state nes'" + using tick_value_preservation by simp + moreover from \(fmdom' osched, pp', reserves) \ (ls, b\<^sub>c\<^sub>u\<^sub>r) \\<^bsub>BBODY\<^esub>{block} (ls', b'\<^sub>c\<^sub>u\<^sub>r)\ have " + val_ledgers_state ls = val_ledgers_state ls'" + using bbody_value_preservation by (blast dest: val_b_body_state.elims) + ultimately show ?thesis + using + \s = (nes, cs, \\<^sub>0, \\<^sub>v, \\<^sub>c, \\<^sub>h, h, s\<^sub>l)\ and + \(_, _, b\<^sub>c\<^sub>u\<^sub>r, es, _, _, osched) = nes'\ and + \(acnt, _, ls, pp') = es\ and + \nes'' = update_nes nes' b'\<^sub>c\<^sub>u\<^sub>r ls'\ and + \s' = (nes'', cs', \'\<^sub>0, \'\<^sub>v, \'\<^sub>c, \'\<^sub>h, h', s'\<^sub>l)\ + by auto + qed +qed end diff --git a/Isabelle/Shelley/Protocol_Parameters.thy b/Isabelle/Shelley/Protocol_Parameters.thy index 6c96f3b..9229af4 100644 --- a/Isabelle/Shelley/Protocol_Parameters.thy +++ b/Isabelle/Shelley/Protocol_Parameters.thy @@ -8,6 +8,10 @@ text \ Protocol parameter name \ typedecl ppm \ \NOTE: Abstract for now\ +text \ Duration difference between slots \ + +type_synonym duration = nat + text \ Protocol parameter value \ typedecl pvalue \ \NOTE: Abstract for now\ @@ -32,10 +36,15 @@ consts active_slot_coeff :: "p_params \ real" \ \[0, text \ Global Constants \ -consts slots_per_epoch :: nat +consts slots_per_epoch :: nat \ \slots per epoch\ + +consts start_rewards :: duration \ \duration to start reward calculations\ text \ Helper Functions \ +fun epoch :: "slot \ epoch" where + "epoch s = undefined" \ \NOTE: Undefined for now\ + fun first_slot :: "epoch \ slot" where "first_slot e = undefined" \ \NOTE: Undefined for now\ diff --git a/Isabelle/Shelley/ROOT b/Isabelle/Shelley/ROOT index 62c43e1..9e07da7 100644 --- a/Isabelle/Shelley/ROOT +++ b/Isabelle/Shelley/ROOT @@ -17,6 +17,7 @@ session Shelley (ledgerformalization) = HOL + Delegation Ledger Rewards + Chain Properties document_files "root.tex" From 283a2a322c2f8894580984ccb3a2bc3b8ca455fb Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Javier=20D=C3=ADaz?= Date: Tue, 21 Jan 2020 12:17:32 -0300 Subject: [PATCH 26/39] Fix README.md --- README.md | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/README.md b/README.md index db2dd50..71065ae 100644 --- a/README.md +++ b/README.md @@ -25,7 +25,7 @@ Building ======== Running `make` builds the PDF documents for the different Isabelle -libraries and places them in `$ISABELLE_BROWSER_INFO/Ouroboros`. You can +libraries and places them in `$ISABELLE_BROWSER_INFO/LedgerFormalization`. You can find out the value of `$ISABELLE_BROWSER_INFO` by running the following command: From 9f1b259da69a142f4966026c04a3101100ba80c7 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Javier=20D=C3=ADaz?= Date: Tue, 21 Jan 2020 20:17:04 -0300 Subject: [PATCH 27/39] Revert to the original order of rules in EPOCH subsystem --- Isabelle/Shelley/Properties.thy | 26 +++++++++++++------------- Isabelle/Shelley/Rewards.thy | 4 ++-- 2 files changed, 15 insertions(+), 15 deletions(-) diff --git a/Isabelle/Shelley/Properties.thy b/Isabelle/Shelley/Properties.thy index 76b8171..783c3e0 100644 --- a/Isabelle/Shelley/Properties.thy +++ b/Isabelle/Shelley/Properties.thy @@ -1033,7 +1033,7 @@ lemma epoch_value_preservation: proof - from assms show ?thesis proof cases - case (epoch utxo_st dstate pstate ls pp acnt utxo_st' acnt' dstate' pstate' ss ss' utxo_st'' + case (epoch utxo_st dstate pstate ls pp ss ss' utxo_st' acnt utxo_st'' acnt' dstate' pstate' _ _ _ pup _ _ _ pp\<^sub>n\<^sub>e\<^sub>w utxo_st''' acnt'' pp' ls') from \(pp\<^sub>n\<^sub>e\<^sub>w, dstate', pstate') \ (utxo_st'', acnt', pp) \\<^bsub>NEWPP\<^esub>{\} (utxo_st''', acnt'', pp')\ have "val_newpp_state (utxo_st'', acnt', pp) = val_newpp_state (utxo_st''', acnt'', pp')" @@ -1041,18 +1041,18 @@ proof - then have f1: "val_utxo_state utxo_st'' + val_acnt acnt' = val_utxo_state utxo_st''' + val_acnt acnt''" by simp - moreover from \(pp, dstate', pstate') \ (ss, utxo_st') \\<^bsub>SNAP\<^esub>{\} (ss', utxo_st'')\ - have "val_snap_state (ss', utxo_st'') = val_snap_state (ss, utxo_st')" - using snap_value_preservation by presburger - then have f2: "val_utxo_state utxo_st'' = val_utxo_state utxo_st'" - by simp moreover - from \pp \ (utxo_st, acnt, dstate, pstate) \\<^bsub>POOLREAP\<^esub>{\} (utxo_st', acnt', dstate', pstate')\ - have "val_poolreap_state (utxo_st', acnt', dstate', pstate') - = val_poolreap_state (utxo_st, acnt, dstate, pstate)" + from \pp \ (utxo_st', acnt, dstate, pstate) \\<^bsub>POOLREAP\<^esub>{\} (utxo_st'', acnt', dstate', pstate')\ + have "val_poolreap_state (utxo_st', acnt, dstate, pstate) + = val_poolreap_state (utxo_st'', acnt', dstate', pstate')" using poolreap_value_preservation by presburger - then have f3: "val_utxo_state utxo_st' + val_acnt acnt' + val_deleg_state dstate' = - val_utxo_state utxo_st + val_acnt acnt + val_deleg_state dstate" + then have f3: "val_utxo_state utxo_st' + val_acnt acnt + val_deleg_state dstate = + val_utxo_state utxo_st'' + val_acnt acnt' + val_deleg_state dstate'" + by simp + moreover from \(pp, dstate, pstate) \ (ss, utxo_st) \\<^bsub>SNAP\<^esub>{\} (ss', utxo_st')\ + have "val_snap_state (ss, utxo_st) = val_snap_state (ss', utxo_st')" + using snap_value_preservation by presburger + then have f2: "val_utxo_state utxo_st = val_utxo_state utxo_st'" by simp moreover have f4: "val_epoch_state s' = val_acnt acnt'' + val_utxo_state utxo_st''' + val_deleg_state dstate'" @@ -1073,9 +1073,9 @@ proof - by simp also from f1 have "\ = (val_acnt acnt' + val_utxo_state utxo_st'') + val_deleg_state dstate'" by simp - also from f2 have "\ = val_acnt acnt' + val_utxo_state utxo_st' + val_deleg_state dstate'" + also from f3 have "\ = val_acnt acnt + val_utxo_state utxo_st' + val_deleg_state dstate" by simp - also from f3 have "\ = val_utxo_state utxo_st + val_acnt acnt + val_deleg_state dstate" + also from f2 have "\ = val_utxo_state utxo_st + val_acnt acnt + val_deleg_state dstate" by simp also from \(utxo_st, (dstate, pstate)) = ls\ have "\ = val_acnt acnt + val_ledger_state ls" by auto diff --git a/Isabelle/Shelley/Rewards.thy b/Isabelle/Shelley/Rewards.thy index 5ba2032..8afdcf2 100644 --- a/Isabelle/Shelley/Rewards.thy +++ b/Isabelle/Shelley/Rewards.thy @@ -207,8 +207,8 @@ inductive epoch_sts :: "epoch_state \ epoch \ epoch_stat where epoch: "\ (acnt, ss, ls, pp) \\<^bsub>EPOCH\<^esub>{e} (acnt'', ss', ls', pp')" if "(utxo_st, (dstate, pstate)) = ls" - and "pp \ (utxo_st, acnt, dstate, pstate) \\<^bsub>POOLREAP\<^esub>{e} (utxo_st', acnt', dstate', pstate')" - and "(pp, dstate', pstate') \ (ss, utxo_st') \\<^bsub>SNAP\<^esub>{e} (ss', utxo_st'')" + and "(pp, dstate, pstate) \ (ss, utxo_st) \\<^bsub>SNAP\<^esub>{e} (ss', utxo_st')" + and "pp \ (utxo_st', acnt, dstate, pstate) \\<^bsub>POOLREAP\<^esub>{e} (utxo_st'', acnt', dstate', pstate')" and "(_, _, _, (pup, _, _, _)) = utxo_st''" and "pp\<^sub>n\<^sub>e\<^sub>w = voted_value\<^sub>P\<^sub>P\<^sub>a\<^sub>r\<^sub>a\<^sub>m\<^sub>s pup" and "(pp\<^sub>n\<^sub>e\<^sub>w, dstate', pstate') \ (utxo_st'', acnt', pp) \\<^bsub>NEWPP\<^esub>{e} (utxo_st''', acnt'', pp')" From e4ce9f0ca65a05e1587222adf3ee91a4bfd1f8e7 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Javier=20D=C3=ADaz?= Date: Tue, 21 Jan 2020 22:54:28 -0300 Subject: [PATCH 28/39] Add minor improvements --- Isabelle/Shelley/Chain.thy | 4 ++-- Isabelle/Shelley/Delegation.thy | 2 +- Isabelle/Shelley/Finite_Map_Extras.thy | 8 ++++---- Isabelle/Shelley/Properties.thy | 3 ++- Isabelle/Shelley/Rewards.thy | 3 ++- 5 files changed, 11 insertions(+), 9 deletions(-) diff --git a/Isabelle/Shelley/Chain.thy b/Isabelle/Shelley/Chain.thy index 970b124..99b035e 100644 --- a/Isabelle/Shelley/Chain.thy +++ b/Isabelle/Shelley/Chain.thy @@ -122,10 +122,10 @@ inductive rupd_sts :: "r_upd_env \ reward_update option \ first_slot (epoch s) + start_rewards" and "ru = None" and "ru' = Some (create_r_upd b es)" - | reward_update_exists: " + | reward_update_exists: " _ \ ru \\<^bsub>RUPD\<^esub>{s} ru" if "ru \ None" - | reward_too_early: " + | reward_too_early: " _ \ ru \\<^bsub>RUPD\<^esub>{s} ru" if "ru = None" and "s \ first_slot (epoch s) + start_rewards" diff --git a/Isabelle/Shelley/Delegation.thy b/Isabelle/Shelley/Delegation.thy index 77042b2..8067507 100644 --- a/Isabelle/Shelley/Delegation.thy +++ b/Isabelle/Shelley/Delegation.thy @@ -98,7 +98,7 @@ inductive delegs_sts :: "d_p_s_env \ d_p_state \ d_cert if "wdrls = txwdrls tx" and "wdrls \\<^sub>f rewards" and "rewards' = rewards \\<^sub>\ fmmap (\_. 0) wdrls" - | seq_delg_ind: " + | seq_delg_ind: " (slot, tx) \ dpstate \\<^bsub>DELEGS\<^esub>{\ @ [c]} dpstate''" if "(slot, tx) \ dpstate \\<^bsub>DELEGS\<^esub>{\} dpstate'" and "slot \ dpstate' \\<^bsub>DELPL\<^esub>{c} dpstate''" diff --git a/Isabelle/Shelley/Finite_Map_Extras.thy b/Isabelle/Shelley/Finite_Map_Extras.thy index 3665927..9efce60 100644 --- a/Isabelle/Shelley/Finite_Map_Extras.thy +++ b/Isabelle/Shelley/Finite_Map_Extras.thy @@ -7,17 +7,17 @@ begin text \ Extra lemmas and syntactic sugar for \fmap\ \ abbreviation fmap_update (\_'(_ $$:= _')\ [1000,0,0] 1000) where - "fmap_update m k v \ fmupd k v m" + "m(k $$:= v) \ fmupd k v m" notation fmlookup (infixl \$$\ 999) notation fmempty (\{$$}\) abbreviation fmap_singleton (\{_ $$:= _}\ [0, 0] 1000) where - "fmap_singleton k v \ {$$}(k $$:= v)" + "{k $$:= v} \ {$$}(k $$:= v)" abbreviation fmap_lookup_the (infixl \$$!\ 999) where - "fmap_lookup_the m k \ the (m $$ k)" + "m $$! k \ the (m $$ k)" lemma fmfilter_fmsubset: "fmfilter p m \\<^sub>f m" proof - @@ -153,7 +153,7 @@ proof - by (metis (mono_tags, lifting) fmdom'_alt_def map_eq_conv sorted_list_of_fset_simps(1)) qed finally show ?thesis - by (simp add: sorted_list_of_fmap_def) + unfolding sorted_list_of_fmap_def by simp qed lemma distinct_fst_inj: diff --git a/Isabelle/Shelley/Properties.thy b/Isabelle/Shelley/Properties.thy index 783c3e0..75d1037 100644 --- a/Isabelle/Shelley/Properties.thy +++ b/Isabelle/Shelley/Properties.thy @@ -747,7 +747,8 @@ next qed \ \NOTE: Lemma 15.9 in the spec.\ -\ \NOTE: We require \addr_rwd\ to be monotonic, which is a minor deviation from the spec.\ +\ \NOTE: We require \addr_rwd\ to be monotonic, which is a minor (though sensible) deviation from +the spec.\ lemma reward_update_value_preservation: assumes "inj addr_rwd" and "mono addr_rwd" diff --git a/Isabelle/Shelley/Rewards.thy b/Isabelle/Shelley/Rewards.thy index 8afdcf2..6a354b0 100644 --- a/Isabelle/Shelley/Rewards.thy +++ b/Isabelle/Shelley/Rewards.thy @@ -205,7 +205,8 @@ text \ Epoch Inference Rule \ inductive epoch_sts :: "epoch_state \ epoch \ epoch_state \ bool" (\\ _ \\<^bsub>EPOCH\<^esub>{_} _\ [0, 51] 50) where - epoch: "\ (acnt, ss, ls, pp) \\<^bsub>EPOCH\<^esub>{e} (acnt'', ss', ls', pp')" + epoch: " + \ (acnt, ss, ls, pp) \\<^bsub>EPOCH\<^esub>{e} (acnt'', ss', ls', pp')" if "(utxo_st, (dstate, pstate)) = ls" and "(pp, dstate, pstate) \ (ss, utxo_st) \\<^bsub>SNAP\<^esub>{e} (ss', utxo_st')" and "pp \ (utxo_st', acnt, dstate, pstate) \\<^bsub>POOLREAP\<^esub>{e} (utxo_st'', acnt', dstate', pstate')" From a9c2a852cda305d05b41cd28ecae59eb5791300f Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Javier=20D=C3=ADaz?= Date: Wed, 22 Jan 2020 12:03:55 -0300 Subject: [PATCH 29/39] Match some minor changes in the formal spec --- Isabelle/Shelley/Chain.thy | 6 +++--- Isabelle/Shelley/Properties.thy | 20 ++++++++++---------- Isabelle/Shelley/Rewards.thy | 8 ++++---- 3 files changed, 17 insertions(+), 17 deletions(-) diff --git a/Isabelle/Shelley/Chain.thy b/Isabelle/Shelley/Chain.thy index 99b035e..b07b9af 100644 --- a/Isabelle/Shelley/Chain.thy +++ b/Isabelle/Shelley/Chain.thy @@ -139,9 +139,9 @@ inductive tick_sts :: "key_hash_g set \ new_epoch_state \ nes \\<^bsub>TICK\<^esub>{s} nes''" if "(s, gkeys) \ nes \\<^bsub>NEWEPOCH\<^esub>{epoch s} nes'" and "(_, b\<^sub>p\<^sub>r\<^sub>e\<^sub>v, _, es, _, _, _) = nes" - and "(e\<^sub>l', b\<^sub>p\<^sub>r\<^sub>e\<^sub>v', b\<^sub>c\<^sub>u\<^sub>r', es', ru, pd', osched') = nes'" - and "(b\<^sub>p\<^sub>r\<^sub>e\<^sub>v, es) \ ru \\<^bsub>RUPD\<^esub>{s} ru'" - and "nes'' = (e\<^sub>l', b\<^sub>p\<^sub>r\<^sub>e\<^sub>v', b\<^sub>c\<^sub>u\<^sub>r', es', ru', pd', osched')" + and "(e\<^sub>l', b\<^sub>p\<^sub>r\<^sub>e\<^sub>v', b\<^sub>c\<^sub>u\<^sub>r', es', ru', pd', osched') = nes'" + and "(b\<^sub>p\<^sub>r\<^sub>e\<^sub>v, es) \ ru' \\<^bsub>RUPD\<^esub>{s} ru''" + and "nes'' = (e\<^sub>l', b\<^sub>p\<^sub>r\<^sub>e\<^sub>v', b\<^sub>c\<^sub>u\<^sub>r', es', ru'', pd', osched')" subsection \ Block Body Transition \ diff --git a/Isabelle/Shelley/Properties.thy b/Isabelle/Shelley/Properties.thy index 75d1037..0314f8a 100644 --- a/Isabelle/Shelley/Properties.thy +++ b/Isabelle/Shelley/Properties.thy @@ -998,15 +998,15 @@ proof - by auto finally show ?thesis .. next - case (new_proto_param_denied_1 _ _ treasury reserves acnt pp _ _ utxo deps fees pup aup favs avs + case (new_proto_param_denied_1 _ _ treasury reserves acnt pp _ _ utxo oblg fees pup aup favs avs utxo_st utxo_st') from \s' = (utxo_st', acnt, pp)\ and \(treasury, reserves) = acnt\ have "val_newpp_state s' = val_utxo_state utxo_st' + val_coin treasury + val_coin reserves" by auto - also from \utxo_st' = (utxo, deps, fees, {$$}, aup, favs, avs)\ have "\ = - val_utxo utxo + deps + fees + val_coin treasury + val_coin reserves" + also from \utxo_st' = (utxo, oblg, fees, {$$}, aup, favs, avs)\ have "\ = + val_utxo utxo + oblg + fees + val_coin treasury + val_coin reserves" by simp - also from \(utxo, deps, fees, pup, aup, favs, avs) = utxo_st\ have "\ = + also from \(utxo, oblg, fees, pup, aup, favs, avs) = utxo_st\ have "\ = val_utxo_state utxo_st + treasury + reserves" by auto also from \(treasury, reserves) = acnt\ and \s = (utxo_st, acnt, pp)\ have "\ = @@ -1014,14 +1014,14 @@ proof - by auto finally show ?thesis .. next - case (new_proto_param_denied_2 _ utxo deps fees pup aup favs avs utxo_st utxo_st' _ _ acnt pp) + case (new_proto_param_denied_2 _ utxo oblg fees pup aup favs avs utxo_st utxo_st' _ _ acnt pp) from \s' = (utxo_st', acnt, pp)\ have "val_newpp_state s' = val_utxo_state utxo_st' + val_acnt acnt" by simp - also from \utxo_st' = (utxo, deps, fees, {$$}, aup, favs, avs)\ have "\ = - val_utxo utxo + val_coin deps + val_coin fees + val_acnt acnt" + also from \utxo_st' = (utxo, oblg, fees, {$$}, aup, favs, avs)\ have "\ = + val_utxo utxo + val_coin oblg + val_coin fees + val_acnt acnt" by simp - also from \(utxo, deps, fees, pup, aup, favs, avs) = utxo_st\ and \s = (utxo_st, acnt, pp)\ + also from \(utxo, oblg, fees, pup, aup, favs, avs) = utxo_st\ and \s = (utxo_st, acnt, pp)\ have "\ = val_newpp_state s" by auto finally show ?thesis .. @@ -1126,12 +1126,12 @@ lemma tick_value_preservation: proof - from assms show ?thesis proof cases - case (tick nes'' _ b\<^sub>p\<^sub>r\<^sub>e\<^sub>v _ es _ _ _ e\<^sub>l'' b\<^sub>p\<^sub>r\<^sub>e\<^sub>v'' b\<^sub>c\<^sub>u\<^sub>r'' es'' ru pd'' osched'' ru'') + case (tick nes'' _ b\<^sub>p\<^sub>r\<^sub>e\<^sub>v _ es _ _ _ e\<^sub>l'' b\<^sub>p\<^sub>r\<^sub>e\<^sub>v'' b\<^sub>c\<^sub>u\<^sub>r'' es'' ru' pd'' osched'' ru'') from assms and \(s, gkeys) \ nes \\<^bsub>NEWEPOCH\<^esub>{epoch s} nes''\ have " val_new_epoch_state nes = val_new_epoch_state nes''" using newepoch_value_preservation by simp also from \nes' = (e\<^sub>l'', b\<^sub>p\<^sub>r\<^sub>e\<^sub>v'', b\<^sub>c\<^sub>u\<^sub>r'', es'', ru'', pd'', osched'')\ and - \(e\<^sub>l'', b\<^sub>p\<^sub>r\<^sub>e\<^sub>v'', b\<^sub>c\<^sub>u\<^sub>r'', es'', ru, pd'', osched'') = nes''\ have " + \(e\<^sub>l'', b\<^sub>p\<^sub>r\<^sub>e\<^sub>v'', b\<^sub>c\<^sub>u\<^sub>r'', es'', ru', pd'', osched'') = nes''\ have " \ = val_new_epoch_state nes'" by auto finally show ?thesis . diff --git a/Isabelle/Shelley/Rewards.thy b/Isabelle/Shelley/Rewards.thy index 6a354b0..80bad4c 100644 --- a/Isabelle/Shelley/Rewards.thy +++ b/Isabelle/Shelley/Rewards.thy @@ -186,13 +186,13 @@ inductive newpp_sts :: "new_p_param_env \ new_p_param_state \n\<^sub>e\<^sub>w = Some pp\<^sub>n\<^sub>e\<^sub>w" and "(treasury, reserves) = acnt" and "\ newpp_accepted pp\<^sub>n\<^sub>e\<^sub>w pp dstate pstate e reserves" - and "(utxo, deps, fees, (pup, aup, favs, avs)) = utxo_st" - and "utxo_st' = (utxo, deps, fees, ({$$}, aup, favs, avs))" + and "(utxo, oblg, fees, (pup, aup, favs, avs)) = utxo_st" + and "utxo_st' = (utxo, oblg, fees, ({$$}, aup, favs, avs))" | new_proto_param_denied_2: " (opp\<^sub>n\<^sub>e\<^sub>w, dstate, pstate) \ (utxo_st, acnt, pp) \\<^bsub>NEWPP\<^esub>{e} (utxo_st', acnt, pp)" if "opp\<^sub>n\<^sub>e\<^sub>w = None" - and "(utxo, deps, fees, (pup, aup, favs, avs)) = utxo_st" - and "utxo_st' = (utxo, deps, fees, ({$$}, aup, favs, avs))" + and "(utxo, oblg, fees, (pup, aup, favs, avs)) = utxo_st" + and "utxo_st' = (utxo, oblg, fees, ({$$}, aup, favs, avs))" subsection \ Complete Epoch Boundary Transition \ From a5b5269d03aaf8ca05ee93d741fe3adc96c34694 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Javier=20D=C3=ADaz?= Date: Wed, 22 Jan 2020 14:56:35 -0300 Subject: [PATCH 30/39] Overhaul proof of `dom_res_union_distr` --- Isabelle/Shelley/Finite_Map_Extras.thy | 25 ++++++++++++++++--------- 1 file changed, 16 insertions(+), 9 deletions(-) diff --git a/Isabelle/Shelley/Finite_Map_Extras.thy b/Isabelle/Shelley/Finite_Map_Extras.thy index 9efce60..68d6d42 100644 --- a/Isabelle/Shelley/Finite_Map_Extras.thy +++ b/Isabelle/Shelley/Finite_Map_Extras.thy @@ -438,18 +438,25 @@ next qed qed -lemma dom_res_union_distr: (* TODO: Find a nicer proof *) +lemma dom_res_union_distr: shows "(A \ B) \ m = A \ m ++\<^sub>f B \ m" proof - - have "(A \ B) \ m \\<^sub>f A \ m ++\<^sub>f B \ m" - by (smt Un_iff domIff dom_fmlookup fmdom'_add fmdom'_filter fmfilter_subset fmlookup_add - fmsubset.rep_eq map_le_def member_filter) - moreover have "A \ m ++\<^sub>f B \ m \\<^sub>f (A \ B) \ m" - by (smt Un_iff domIff dom_fmlookup fmdom'_filter fmfilter_subset fmlookup_add fmsubset.rep_eq - map_le_def member_filter) + have "($$) ((A \ B) \ m) \\<^sub>m ($$) (A \ m ++\<^sub>f B \ m)" + proof (unfold map_le_def, intro ballI) + fix k + assume "k \ dom (($$) ((A \ B) \ m))" + then show "((A \ B) \ m) $$ k = (A \ m ++\<^sub>f B \ m) $$ k" + by auto + qed + moreover have "($$) (A \ m ++\<^sub>f B \ m) \\<^sub>m ($$) ((A \ B) \ m)" + proof (unfold map_le_def, intro ballI) + fix k + assume "k \ dom (($$) (A \ m ++\<^sub>f B \ m))" + then show "(A \ m ++\<^sub>f B \ m) $$ k = ((A \ B) \ m) $$ k" + by auto + qed ultimately show ?thesis - by (smt Un_iff domIff dom_fmlookup fmadd_empty(2) fmdiff_partition fmdom'_add fmfilter_false - option.simps(3)) + using fmlookup_inject and map_le_antisym by blast qed lemma dom_exc_add_distr: From 7315df93fcb24d28961bb815fe2a06a7cb57e1e7 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Javier=20D=C3=ADaz?= Date: Fri, 24 Jan 2020 11:08:42 -0300 Subject: [PATCH 31/39] Match some changes in the spec (issue 1169) --- Isabelle/Shelley/Chain.thy | 7 ++- Isabelle/Shelley/Properties.thy | 103 +++++++++++++++++--------------- Isabelle/Shelley/Rewards.thy | 19 +++--- 3 files changed, 71 insertions(+), 58 deletions(-) diff --git a/Isabelle/Shelley/Chain.thy b/Isabelle/Shelley/Chain.thy index b07b9af..694fb3d 100644 --- a/Isabelle/Shelley/Chain.thy +++ b/Isabelle/Shelley/Chain.thy @@ -88,11 +88,14 @@ inductive new_epoch_sts :: "new_epoch_env \ new_epoch_state \ \ - (e\<^sub>l, b\<^sub>p\<^sub>r\<^sub>e\<^sub>v, b\<^sub>c\<^sub>u\<^sub>r, es, ru, pd, osched) \\<^bsub>NEWEPOCH\<^esub>{e} (e, b\<^sub>c\<^sub>u\<^sub>r, {$$}, es', None, pd', osched')" + (e\<^sub>l, b\<^sub>p\<^sub>r\<^sub>e\<^sub>v, b\<^sub>c\<^sub>u\<^sub>r, es, ru, pd, osched) \\<^bsub>NEWEPOCH\<^esub>{e} (e, b\<^sub>c\<^sub>u\<^sub>r, {$$}, es'', None, pd', osched')" if "e = e\<^sub>l + 1" and "ru = Some ru'" + and "(_, _, _, _, i\<^sub>r\<^sub>w\<^sub>d') = ru'" + and "i\<^sub>r\<^sub>w\<^sub>d' = get_ir es" and "ru' = create_r_upd b\<^sub>p\<^sub>r\<^sub>e\<^sub>v es" - and "\ apply_r_upd ru' es \\<^bsub>EPOCH\<^esub>{e} es'" + and "es' = apply_r_upd ru' es" + and "\ es' \\<^bsub>EPOCH\<^esub>{e} es''" and "pd' = undefined" and "osched' = undefined" | not_new_epoch: " diff --git a/Isabelle/Shelley/Properties.thy b/Isabelle/Shelley/Properties.thy index 0314f8a..8f7c971 100644 --- a/Isabelle/Shelley/Properties.thy +++ b/Isabelle/Shelley/Properties.thy @@ -752,43 +752,51 @@ the spec.\ lemma reward_update_value_preservation: assumes "inj addr_rwd" and "mono addr_rwd" - shows "val_epoch_state s = val_epoch_state (apply_r_upd (create_r_upd b s) s)" + shows "val_epoch_state s\<^sub>2 = val_epoch_state (apply_r_upd (create_r_upd b s\<^sub>1) s\<^sub>2)" proof - - obtain treasury reserves ss utxo deps fees up stk_creds rewards i\<^sub>r\<^sub>w\<^sub>d pstate ppm - where f1: "s = + obtain treasury\<^sub>1 reserves\<^sub>1 ss\<^sub>1 utxo\<^sub>1 deps\<^sub>1 fees\<^sub>1 up\<^sub>1 stk_creds\<^sub>1 rewards\<^sub>1 i\<^sub>r\<^sub>w\<^sub>d pstate\<^sub>1 ppm\<^sub>1 + where f0: "s\<^sub>1 = + ( + (treasury\<^sub>1, reserves\<^sub>1), + ss\<^sub>1, + ((utxo\<^sub>1, deps\<^sub>1, fees\<^sub>1, up\<^sub>1), ((stk_creds\<^sub>1, rewards\<^sub>1, i\<^sub>r\<^sub>w\<^sub>d), pstate\<^sub>1)), + ppm\<^sub>1 + )" + by (metis old.prod.exhaust val_deleg_state.cases) + then obtain \t \r rs \f where f1: "create_r_upd b s\<^sub>1 = (\t, \r, rs, \f, i\<^sub>r\<^sub>w\<^sub>d)" + unfolding Let_def using create_r_upd.elims and get_ir.simps by metis + moreover obtain treasury reserves ss utxo deps fees up stk_creds rewards i'\<^sub>r\<^sub>w\<^sub>d pstate ppm + where f2: "s\<^sub>2 = ( (treasury, reserves), ss, - ((utxo, deps, fees, up), ((stk_creds, rewards, i\<^sub>r\<^sub>w\<^sub>d), pstate)), + ((utxo, deps, fees, up), ((stk_creds, rewards, i'\<^sub>r\<^sub>w\<^sub>d), pstate)), ppm )" by (metis old.prod.exhaust val_deleg_state.cases) - moreover obtain \t \r rs \f rew\<^sub>m\<^sub>i\<^sub>r where f2: "create_r_upd b s = (\t, \r, rs, \f, rew\<^sub>m\<^sub>i\<^sub>r)" - using prod_cases5 by blast ultimately obtain non_distributed and rew'\<^sub>m\<^sub>i\<^sub>r and update\<^sub>r\<^sub>w\<^sub>d and unregistered - where f3: "apply_r_upd (\t, \r, rs, \f, rew\<^sub>m\<^sub>i\<^sub>r) s = + where f3: "apply_r_upd (\t, \r, rs, \f, i\<^sub>r\<^sub>w\<^sub>d) s\<^sub>2 = ( (treasury + \t, reserves + \r + non_distributed), ss, ((utxo, deps, fees + \f, up), ((stk_creds, (rewards \\<^sub>+ rs) \\<^sub>+ update\<^sub>r\<^sub>w\<^sub>d, {$$}), pstate)), ppm )" - and f4: "non_distributed = - (\k \ fmdom' (fmdom' stk_creds \/ rew\<^sub>m\<^sub>i\<^sub>r). (fmdom' stk_creds \/ rew\<^sub>m\<^sub>i\<^sub>r) $$! k)" - and f5: "rew'\<^sub>m\<^sub>i\<^sub>r = fmdom' stk_creds \ rew\<^sub>m\<^sub>i\<^sub>r" + and f7: "unregistered = fmdom' stk_creds \/ i\<^sub>r\<^sub>w\<^sub>d" + and f4: "non_distributed = (\k \ fmdom' unregistered. unregistered $$! k)" + and f5: "rew'\<^sub>m\<^sub>i\<^sub>r = fmdom' stk_creds \ i\<^sub>r\<^sub>w\<^sub>d" and f6: "update\<^sub>r\<^sub>w\<^sub>d = fmap_of_list [(addr_rwd hk, val). (hk, val) \ sorted_list_of_fmap rew'\<^sub>m\<^sub>i\<^sub>r]" - and f7: "unregistered = fmdom' stk_creds \/ rew\<^sub>m\<^sub>i\<^sub>r" by (metis apply_r_upd.simps) - then have "val_epoch_state (apply_r_upd (create_r_upd b s) s) = + then have "val_epoch_state (apply_r_upd (create_r_upd b s\<^sub>1) s\<^sub>2) = treasury + reserves + val_utxo utxo + deps + fees + val_map rewards + \t + \r + non_distributed + \f + val_map rs + val_map update\<^sub>r\<^sub>w\<^sub>d" proof - - from f2 and f3 have "val_epoch_state (apply_r_upd (create_r_upd b s) s) = + from f1 and f3 have "val_epoch_state (apply_r_upd (create_r_upd b s\<^sub>1) s\<^sub>2) = val_acnt (treasury + \t, reserves + \r + non_distributed) + val_ledger_state ( (utxo, deps, fees + \f, up), ((stk_creds, (rewards \\<^sub>+ rs) \\<^sub>+ update\<^sub>r\<^sub>w\<^sub>d, {$$}), pstate))" by simp - then have "val_epoch_state (apply_r_upd (create_r_upd b s) s) = + then have "val_epoch_state (apply_r_upd (create_r_upd b s\<^sub>1) s\<^sub>2) = (treasury + \t) + (reserves + \r + non_distributed) + val_utxo utxo + deps + (fees + \f) + val_map ((rewards \\<^sub>+ rs) \\<^sub>+ update\<^sub>r\<^sub>w\<^sub>d)" by auto @@ -799,28 +807,26 @@ proof - by linarith qed moreover have "\t + \r + non_distributed + \f + val_map rs + val_map update\<^sub>r\<^sub>w\<^sub>d = 0" - proof (cases ss) + proof (cases ss\<^sub>1) case (fields pstake\<^sub>m\<^sub>a\<^sub>r\<^sub>k pstake\<^sub>s\<^sub>e\<^sub>t pstake\<^sub>g\<^sub>o pools_ss fee_ss) - from f1 and fields have "s = + from f0 and fields have "s\<^sub>1 = ( - (treasury, reserves), + (treasury\<^sub>1, reserves\<^sub>1), (pstake\<^sub>m\<^sub>a\<^sub>r\<^sub>k, pstake\<^sub>s\<^sub>e\<^sub>t, pstake\<^sub>g\<^sub>o, pools_ss, fee_ss), - ((utxo, deps, fees, up), (stk_creds, rewards, i\<^sub>r\<^sub>w\<^sub>d), pstate), - ppm + ((utxo\<^sub>1, deps\<^sub>1, fees\<^sub>1, up\<^sub>1), (stk_creds\<^sub>1, rewards\<^sub>1, i\<^sub>r\<^sub>w\<^sub>d), pstate\<^sub>1), + ppm\<^sub>1 )" by simp - then obtain \t\<^sub>1 \t\<^sub>2 \r' \r\<^sub>l rs' rewards\<^sub>m\<^sub>i\<^sub>r registered unregistered' reward_pot R - where "create_r_upd b s = (\t\<^sub>1 + \t\<^sub>2, -\r', rs', -fee_ss, registered)" - and "unregistered' = fmdom' stk_creds \/ i\<^sub>r\<^sub>w\<^sub>d" - and "registered = i\<^sub>r\<^sub>w\<^sub>d --\<^sub>f unregistered'" - and "rewards\<^sub>m\<^sub>i\<^sub>r = (\ k \ fmdom' registered. registered $$! k)" + then obtain \t\<^sub>1 \t\<^sub>2 \r' \r\<^sub>l rs' rewards\<^sub>m\<^sub>i\<^sub>r reward_pot R + where "create_r_upd b s\<^sub>1 = (\t\<^sub>1 + \t\<^sub>2, -\r', rs', -fee_ss, i\<^sub>r\<^sub>w\<^sub>d)" + and "rewards\<^sub>m\<^sub>i\<^sub>r = (\ k \ fmdom' i\<^sub>r\<^sub>w\<^sub>d. i\<^sub>r\<^sub>w\<^sub>d $$! k)" and "reward_pot = fee_ss + \r\<^sub>l" and "R = reward_pot - \t\<^sub>1" and "\t\<^sub>2 = R - (\ k \ fmdom' rs'. rs' $$! k)" and "\r' = \r\<^sub>l + rewards\<^sub>m\<^sub>i\<^sub>r" by (metis create_r_upd.simps prod.exhaust_sel that) with f1 and f2 and fields have "rs' = rs" and "\r' = -\r" and "\t = \t\<^sub>1 + \t\<^sub>2" - and "\f = -fee_ss" and "registered = rew\<^sub>m\<^sub>i\<^sub>r" + and "\f = -fee_ss" by auto with \R = reward_pot - \t\<^sub>1\ and \\t\<^sub>2 = R - val_map rs'\ and \reward_pot = fee_ss + \r\<^sub>l\ have "\t\<^sub>1 + \t\<^sub>2 - \r\<^sub>l + val_map rs - fee_ss = 0" @@ -828,42 +834,42 @@ proof - from \\t = \t\<^sub>1 + \t\<^sub>2\ have "\t + \r + non_distributed + \f + val_map rs + val_map update\<^sub>r\<^sub>w\<^sub>d = \t\<^sub>1 + \t\<^sub>2 + \r + non_distributed + \f + val_map rs + val_map update\<^sub>r\<^sub>w\<^sub>d" by simp - also from \\r' = \r\<^sub>l + rewards\<^sub>m\<^sub>i\<^sub>r\ and \\r' = -\r\ and \rewards\<^sub>m\<^sub>i\<^sub>r = val_map registered\ - have "\ = \t\<^sub>1 + \t\<^sub>2 - \r\<^sub>l - val_map registered + non_distributed + \f + val_map rs + also from \\r' = \r\<^sub>l + rewards\<^sub>m\<^sub>i\<^sub>r\ and \\r' = -\r\ and \rewards\<^sub>m\<^sub>i\<^sub>r = val_map i\<^sub>r\<^sub>w\<^sub>d\ + have "\ = \t\<^sub>1 + \t\<^sub>2 - \r\<^sub>l - val_map i\<^sub>r\<^sub>w\<^sub>d + non_distributed + \f + val_map rs + val_map update\<^sub>r\<^sub>w\<^sub>d" by simp - also from \\f = -fee_ss\ have "\ = \t\<^sub>1 + \t\<^sub>2 - \r\<^sub>l + val_map rs - fee_ss - val_map registered + also from \\f = -fee_ss\ have "\ = \t\<^sub>1 + \t\<^sub>2 - \r\<^sub>l + val_map rs - fee_ss - val_map i\<^sub>r\<^sub>w\<^sub>d + non_distributed + val_map update\<^sub>r\<^sub>w\<^sub>d" by simp also from \\t\<^sub>1 + \t\<^sub>2 - \r\<^sub>l + val_map rs - fee_ss = 0\ have "\ = - - val_map registered + non_distributed + val_map update\<^sub>r\<^sub>w\<^sub>d" + - val_map i\<^sub>r\<^sub>w\<^sub>d + non_distributed + val_map update\<^sub>r\<^sub>w\<^sub>d" by simp also have "\ = 0" proof - - have "val_map registered = val_map update\<^sub>r\<^sub>w\<^sub>d + non_distributed" + have "val_map i\<^sub>r\<^sub>w\<^sub>d = val_map update\<^sub>r\<^sub>w\<^sub>d + non_distributed" proof - - from f6 and assms(1,2) have "val_map rew'\<^sub>m\<^sub>i\<^sub>r = val_map update\<^sub>r\<^sub>w\<^sub>d" - by (simp add: val_map_fmap_of_list) - moreover from f4 and f7 have "val_map unregistered = non_distributed" - by simp - ultimately have *: "val_map rew'\<^sub>m\<^sub>i\<^sub>r + val_map unregistered = - val_map update\<^sub>r\<^sub>w\<^sub>d + non_distributed" - by simp - from \registered = rew\<^sub>m\<^sub>i\<^sub>r\ have "val_map registered = val_map rew\<^sub>m\<^sub>i\<^sub>r" - by simp - also from f5 and f7 have "\ = val_map rew'\<^sub>m\<^sub>i\<^sub>r + val_map unregistered" + have "val_map rew'\<^sub>m\<^sub>i\<^sub>r + val_map unregistered = val_map update\<^sub>r\<^sub>w\<^sub>d + non_distributed" + proof - + from f6 and assms(1,2) have "val_map rew'\<^sub>m\<^sub>i\<^sub>r = val_map update\<^sub>r\<^sub>w\<^sub>d" + by (simp add: val_map_fmap_of_list) + moreover from f4 and f7 have "val_map unregistered = non_distributed" + by simp + ultimately show ?thesis + by simp + qed + moreover from f5 and f7 have "val_map i\<^sub>r\<^sub>w\<^sub>d = val_map rew'\<^sub>m\<^sub>i\<^sub>r + val_map unregistered" using val_map_split by (metis add.commute) - finally show ?thesis - using * by simp + ultimately show ?thesis + by simp qed then show ?thesis by simp qed finally show ?thesis . qed - moreover have "val_epoch_state s = + moreover have "val_epoch_state s\<^sub>2 = treasury + reserves + val_utxo utxo + deps + fees + val_map rewards" - using f1 by simp + using f2 by simp ultimately show ?thesis by simp qed @@ -1097,17 +1103,17 @@ lemma newepoch_value_preservation: proof - from assms show ?thesis proof cases - case (new_epoch e\<^sub>l ru ru' b\<^sub>p\<^sub>r\<^sub>e\<^sub>v es es' pd' osched' b\<^sub>c\<^sub>u\<^sub>r pd osched) - have "val_epoch_state es' = val_epoch_state es" + case (new_epoch e\<^sub>l ru ru' _ _ _ _ i\<^sub>r\<^sub>w\<^sub>d' es b\<^sub>p\<^sub>r\<^sub>e\<^sub>v es' es'' pd' osched' b\<^sub>c\<^sub>u\<^sub>r pd osched) + have "val_epoch_state es'' = val_epoch_state es" proof - from \inj addr_rwd\ and \mono addr_rwd\ and \ru' = create_r_upd b\<^sub>p\<^sub>r\<^sub>e\<^sub>v es\ have " val_epoch_state (apply_r_upd ru' es) = val_epoch_state es" using reward_update_value_preservation by presburger - with \\ apply_r_upd ru' es \\<^bsub>EPOCH\<^esub>{\} es'\ show ?thesis + with \es' = apply_r_upd ru' es\ and \\ es' \\<^bsub>EPOCH\<^esub>{\} es''\ show ?thesis using epoch_value_preservation by simp qed with \s = (e\<^sub>l, b\<^sub>p\<^sub>r\<^sub>e\<^sub>v, b\<^sub>c\<^sub>u\<^sub>r, es, ru, pd, osched)\ and - \s' = (\, b\<^sub>c\<^sub>u\<^sub>r, {$$}, es', None, pd', osched')\ show ?thesis + \s' = (\, b\<^sub>c\<^sub>u\<^sub>r, {$$}, es'', None, pd', osched')\ show ?thesis by simp next case not_new_epoch @@ -1161,6 +1167,7 @@ qed fun val_chain_state :: "chain_state \ coin" where "val_chain_state s = val_new_epoch_state (fst s)" +\ \NOTE: Theorem 15.2 in the spec.\ theorem chain_value_preservation: assumes "e \ s \\<^bsub>CHAIN\<^esub>{block} s'" and "inj addr_rwd" diff --git a/Isabelle/Shelley/Rewards.thy b/Isabelle/Shelley/Rewards.thy index 80bad4c..ba01a63 100644 --- a/Isabelle/Shelley/Rewards.thy +++ b/Isabelle/Shelley/Rewards.thy @@ -200,6 +200,11 @@ text \ Epoch States \ type_synonym epoch_state = "acnt \ snapshots \ l_state \ p_params" +text \ Accessor Functions \ + +fun get_ir :: "epoch_state \ (credential, coin) fmap" where + "get_ir (_, _, (_, ((_, _, i\<^sub>r\<^sub>w\<^sub>d), _)), _) = i\<^sub>r\<^sub>w\<^sub>d" + text \ Epoch Inference Rule \ inductive epoch_sts :: "epoch_state \ epoch \ epoch_state \ bool" @@ -236,14 +241,12 @@ fun create_r_upd :: "blocks_made \ epoch_state \ reward_ ( (_, reserves), (_, _, (stake, delegs), pools_ss, fee_ss), - (_, ((stk_creds, rewards, i\<^sub>r\<^sub>w\<^sub>d), _)), + (_, ((_, rewards, i\<^sub>r\<^sub>w\<^sub>d), _)), pp ) = ( let - unregistered = fmdom' stk_creds \/ i\<^sub>r\<^sub>w\<^sub>d; - registered = i\<^sub>r\<^sub>w\<^sub>d --\<^sub>f unregistered; - rewards\<^sub>m\<^sub>i\<^sub>r = (\ k \ fmdom' registered. registered $$! k); + rewards\<^sub>m\<^sub>i\<^sub>r = (\ k \ fmdom' i\<^sub>r\<^sub>w\<^sub>d. i\<^sub>r\<^sub>w\<^sub>d $$! k); reserves' = reserves - rewards\<^sub>m\<^sub>i\<^sub>r; blocks_made = (\ k \ fmdom' b. b $$! k); \ = real blocks_made / (real slots_per_epoch * active_slot_coeff pp); @@ -255,14 +258,14 @@ fun create_r_upd :: "blocks_made \ epoch_state \ reward_ rs = reward pp b R (fmdom' rewards) pools_ss stake delegs; \t\<^sub>2 = R - (\ k \ fmdom' rs. rs $$! k) in - (\t\<^sub>1 + \t\<^sub>2, -\r, rs, -fee_ss, registered) + (\t\<^sub>1 + \t\<^sub>2, -\r, rs, -fee_ss, i\<^sub>r\<^sub>w\<^sub>d) )" text \ Applying a reward update \ fun apply_r_upd :: "reward_update \ epoch_state \ epoch_state" where "apply_r_upd - (\t, \r, rs, \f, rew\<^sub>m\<^sub>i\<^sub>r) + (\t, \r, rs, \f, i'\<^sub>r\<^sub>w\<^sub>d) ( (treasury, reserves), ss, @@ -274,8 +277,8 @@ fun apply_r_upd :: "reward_update \ epoch_state \ epoch_ ) = ( let - rew'\<^sub>m\<^sub>i\<^sub>r = fmdom' stk_creds \ rew\<^sub>m\<^sub>i\<^sub>r; - unregistered = fmdom' stk_creds \/ rew\<^sub>m\<^sub>i\<^sub>r; + rew'\<^sub>m\<^sub>i\<^sub>r = fmdom' stk_creds \ i'\<^sub>r\<^sub>w\<^sub>d; + unregistered = fmdom' stk_creds \/ i'\<^sub>r\<^sub>w\<^sub>d; non_distributed = (\k \ fmdom' unregistered. unregistered $$! k); update\<^sub>r\<^sub>w\<^sub>d = fmap_of_list [(addr_rwd hk, val). (hk, val) \ sorted_list_of_fmap rew'\<^sub>m\<^sub>i\<^sub>r] in From 470c78e704a7dd20a86e2892d695e277d20e22b8 Mon Sep 17 00:00:00 2001 From: Javier Diaz Date: Mon, 27 Jan 2020 22:19:07 -0300 Subject: [PATCH 32/39] Simplify the redundant check for NEWEPOCH --- Isabelle/Shelley/Chain.thy | 9 ++- Isabelle/Shelley/Properties.thy | 130 +++++++++++++------------------- Isabelle/Shelley/Rewards.thy | 3 + 3 files changed, 63 insertions(+), 79 deletions(-) diff --git a/Isabelle/Shelley/Chain.thy b/Isabelle/Shelley/Chain.thy index 694fb3d..4a79301 100644 --- a/Isabelle/Shelley/Chain.thy +++ b/Isabelle/Shelley/Chain.thy @@ -91,9 +91,12 @@ inductive new_epoch_sts :: "new_epoch_env \ new_epoch_state \l, b\<^sub>p\<^sub>r\<^sub>e\<^sub>v, b\<^sub>c\<^sub>u\<^sub>r, es, ru, pd, osched) \\<^bsub>NEWEPOCH\<^esub>{e} (e, b\<^sub>c\<^sub>u\<^sub>r, {$$}, es'', None, pd', osched')" if "e = e\<^sub>l + 1" and "ru = Some ru'" - and "(_, _, _, _, i\<^sub>r\<^sub>w\<^sub>d') = ru'" - and "i\<^sub>r\<^sub>w\<^sub>d' = get_ir es" - and "ru' = create_r_upd b\<^sub>p\<^sub>r\<^sub>e\<^sub>v es" + and "(\t, \r, rs, \f, i\<^sub>r\<^sub>w\<^sub>d) = ru'" + and "i\<^sub>r\<^sub>w\<^sub>d = get_ir es" + and "\f = - get_fee_ss es" + and "rewards\<^sub>m\<^sub>i\<^sub>r = (\ k \ fmdom' i\<^sub>r\<^sub>w\<^sub>d. i\<^sub>r\<^sub>w\<^sub>d $$! k)" + and "- \r = \r\<^sub>l + rewards\<^sub>m\<^sub>i\<^sub>r" + and "\t - \r\<^sub>l + (\ k \ fmdom' rs. rs $$! k) + \f = 0" and "es' = apply_r_upd ru' es" and "\ es' \\<^bsub>EPOCH\<^esub>{e} es''" and "pd' = undefined" diff --git a/Isabelle/Shelley/Properties.thy b/Isabelle/Shelley/Properties.thy index 8f7c971..648c574 100644 --- a/Isabelle/Shelley/Properties.thy +++ b/Isabelle/Shelley/Properties.thy @@ -749,54 +749,52 @@ qed \ \NOTE: Lemma 15.9 in the spec.\ \ \NOTE: We require \addr_rwd\ to be monotonic, which is a minor (though sensible) deviation from the spec.\ -lemma reward_update_value_preservation: - assumes "inj addr_rwd" +lemma reward_update_application_value_preservation: + assumes "ru = (\t, \r, rs, \f, i\<^sub>r\<^sub>w\<^sub>d)" + and "i\<^sub>r\<^sub>w\<^sub>d = get_ir es" + and "\f = - get_fee_ss es" + and "rewards\<^sub>m\<^sub>i\<^sub>r = (\ k \ fmdom' i\<^sub>r\<^sub>w\<^sub>d. i\<^sub>r\<^sub>w\<^sub>d $$! k)" + and "- \r = \r\<^sub>l + rewards\<^sub>m\<^sub>i\<^sub>r" + and "\t - \r\<^sub>l + (\ k \ fmdom' rs. rs $$! k) + \f = 0" + and "inj addr_rwd" and "mono addr_rwd" - shows "val_epoch_state s\<^sub>2 = val_epoch_state (apply_r_upd (create_r_upd b s\<^sub>1) s\<^sub>2)" + shows "val_epoch_state es = val_epoch_state (apply_r_upd ru es)" proof - - obtain treasury\<^sub>1 reserves\<^sub>1 ss\<^sub>1 utxo\<^sub>1 deps\<^sub>1 fees\<^sub>1 up\<^sub>1 stk_creds\<^sub>1 rewards\<^sub>1 i\<^sub>r\<^sub>w\<^sub>d pstate\<^sub>1 ppm\<^sub>1 - where f0: "s\<^sub>1 = - ( - (treasury\<^sub>1, reserves\<^sub>1), - ss\<^sub>1, - ((utxo\<^sub>1, deps\<^sub>1, fees\<^sub>1, up\<^sub>1), ((stk_creds\<^sub>1, rewards\<^sub>1, i\<^sub>r\<^sub>w\<^sub>d), pstate\<^sub>1)), - ppm\<^sub>1 - )" - by (metis old.prod.exhaust val_deleg_state.cases) - then obtain \t \r rs \f where f1: "create_r_upd b s\<^sub>1 = (\t, \r, rs, \f, i\<^sub>r\<^sub>w\<^sub>d)" - unfolding Let_def using create_r_upd.elims and get_ir.simps by metis - moreover obtain treasury reserves ss utxo deps fees up stk_creds rewards i'\<^sub>r\<^sub>w\<^sub>d pstate ppm - where f2: "s\<^sub>2 = + obtain treasury reserves pstake\<^sub>m\<^sub>a\<^sub>r\<^sub>k pstake\<^sub>s\<^sub>e\<^sub>t pstake\<^sub>g\<^sub>o pools_ss fee_ss utxo deps fees up stk_creds + rewards i'\<^sub>r\<^sub>w\<^sub>d pstate pp + where f0: "es = ( (treasury, reserves), - ss, + (pstake\<^sub>m\<^sub>a\<^sub>r\<^sub>k, pstake\<^sub>s\<^sub>e\<^sub>t, pstake\<^sub>g\<^sub>o, pools_ss, fee_ss), ((utxo, deps, fees, up), ((stk_creds, rewards, i'\<^sub>r\<^sub>w\<^sub>d), pstate)), - ppm + pp )" by (metis old.prod.exhaust val_deleg_state.cases) - ultimately obtain non_distributed and rew'\<^sub>m\<^sub>i\<^sub>r and update\<^sub>r\<^sub>w\<^sub>d and unregistered - where f3: "apply_r_upd (\t, \r, rs, \f, i\<^sub>r\<^sub>w\<^sub>d) s\<^sub>2 = + with assms(2,3) have "i'\<^sub>r\<^sub>w\<^sub>d = i\<^sub>r\<^sub>w\<^sub>d" and "- fee_ss = \f" + by (simp, simp) + from assms(1,2,4) and f0 obtain non_distributed and rew'\<^sub>m\<^sub>i\<^sub>r and update\<^sub>r\<^sub>w\<^sub>d and unregistered + where f1: "apply_r_upd ru es = ( (treasury + \t, reserves + \r + non_distributed), - ss, + (pstake\<^sub>m\<^sub>a\<^sub>r\<^sub>k, pstake\<^sub>s\<^sub>e\<^sub>t, pstake\<^sub>g\<^sub>o, pools_ss, fee_ss), ((utxo, deps, fees + \f, up), ((stk_creds, (rewards \\<^sub>+ rs) \\<^sub>+ update\<^sub>r\<^sub>w\<^sub>d, {$$}), pstate)), - ppm + pp )" - and f7: "unregistered = fmdom' stk_creds \/ i\<^sub>r\<^sub>w\<^sub>d" - and f4: "non_distributed = (\k \ fmdom' unregistered. unregistered $$! k)" - and f5: "rew'\<^sub>m\<^sub>i\<^sub>r = fmdom' stk_creds \ i\<^sub>r\<^sub>w\<^sub>d" - and f6: "update\<^sub>r\<^sub>w\<^sub>d = fmap_of_list [(addr_rwd hk, val). (hk, val) \ sorted_list_of_fmap rew'\<^sub>m\<^sub>i\<^sub>r]" - by (metis apply_r_upd.simps) - then have "val_epoch_state (apply_r_upd (create_r_upd b s\<^sub>1) s\<^sub>2) = + and f2: "unregistered = fmdom' stk_creds \/ i\<^sub>r\<^sub>w\<^sub>d" + and f3: "non_distributed = (\k \ fmdom' unregistered. unregistered $$! k)" + and f4: "rew'\<^sub>m\<^sub>i\<^sub>r = fmdom' stk_creds \ i\<^sub>r\<^sub>w\<^sub>d" + and f5: "update\<^sub>r\<^sub>w\<^sub>d = fmap_of_list [(addr_rwd hk, val). (hk, val) \ sorted_list_of_fmap rew'\<^sub>m\<^sub>i\<^sub>r]" + by (metis apply_r_upd.simps) + then have "val_epoch_state (apply_r_upd ru es) = treasury + reserves + val_utxo utxo + deps + fees + val_map rewards + \t + \r + non_distributed + \f + val_map rs + val_map update\<^sub>r\<^sub>w\<^sub>d" proof - - from f1 and f3 have "val_epoch_state (apply_r_upd (create_r_upd b s\<^sub>1) s\<^sub>2) = + from assms(1) and f1 have "val_epoch_state (apply_r_upd ru es) = val_acnt (treasury + \t, reserves + \r + non_distributed) + val_ledger_state ( (utxo, deps, fees + \f, up), ((stk_creds, (rewards \\<^sub>+ rs) \\<^sub>+ update\<^sub>r\<^sub>w\<^sub>d, {$$}), pstate))" by simp - then have "val_epoch_state (apply_r_upd (create_r_upd b s\<^sub>1) s\<^sub>2) = + then have "val_epoch_state (apply_r_upd ru es) = (treasury + \t) + (reserves + \r + non_distributed) + val_utxo utxo + deps + (fees + \f) + val_map ((rewards \\<^sub>+ rs) \\<^sub>+ update\<^sub>r\<^sub>w\<^sub>d)" by auto @@ -807,42 +805,11 @@ proof - by linarith qed moreover have "\t + \r + non_distributed + \f + val_map rs + val_map update\<^sub>r\<^sub>w\<^sub>d = 0" - proof (cases ss\<^sub>1) - case (fields pstake\<^sub>m\<^sub>a\<^sub>r\<^sub>k pstake\<^sub>s\<^sub>e\<^sub>t pstake\<^sub>g\<^sub>o pools_ss fee_ss) - from f0 and fields have "s\<^sub>1 = - ( - (treasury\<^sub>1, reserves\<^sub>1), - (pstake\<^sub>m\<^sub>a\<^sub>r\<^sub>k, pstake\<^sub>s\<^sub>e\<^sub>t, pstake\<^sub>g\<^sub>o, pools_ss, fee_ss), - ((utxo\<^sub>1, deps\<^sub>1, fees\<^sub>1, up\<^sub>1), (stk_creds\<^sub>1, rewards\<^sub>1, i\<^sub>r\<^sub>w\<^sub>d), pstate\<^sub>1), - ppm\<^sub>1 - )" - by simp - then obtain \t\<^sub>1 \t\<^sub>2 \r' \r\<^sub>l rs' rewards\<^sub>m\<^sub>i\<^sub>r reward_pot R - where "create_r_upd b s\<^sub>1 = (\t\<^sub>1 + \t\<^sub>2, -\r', rs', -fee_ss, i\<^sub>r\<^sub>w\<^sub>d)" - and "rewards\<^sub>m\<^sub>i\<^sub>r = (\ k \ fmdom' i\<^sub>r\<^sub>w\<^sub>d. i\<^sub>r\<^sub>w\<^sub>d $$! k)" - and "reward_pot = fee_ss + \r\<^sub>l" - and "R = reward_pot - \t\<^sub>1" - and "\t\<^sub>2 = R - (\ k \ fmdom' rs'. rs' $$! k)" - and "\r' = \r\<^sub>l + rewards\<^sub>m\<^sub>i\<^sub>r" - by (metis create_r_upd.simps prod.exhaust_sel that) - with f1 and f2 and fields have "rs' = rs" and "\r' = -\r" and "\t = \t\<^sub>1 + \t\<^sub>2" - and "\f = -fee_ss" - by auto - with \R = reward_pot - \t\<^sub>1\ and \\t\<^sub>2 = R - val_map rs'\ and \reward_pot = fee_ss + \r\<^sub>l\ - have "\t\<^sub>1 + \t\<^sub>2 - \r\<^sub>l + val_map rs - fee_ss = 0" - by simp - from \\t = \t\<^sub>1 + \t\<^sub>2\ have "\t + \r + non_distributed + \f + val_map rs + val_map update\<^sub>r\<^sub>w\<^sub>d = - \t\<^sub>1 + \t\<^sub>2 + \r + non_distributed + \f + val_map rs + val_map update\<^sub>r\<^sub>w\<^sub>d" - by simp - also from \\r' = \r\<^sub>l + rewards\<^sub>m\<^sub>i\<^sub>r\ and \\r' = -\r\ and \rewards\<^sub>m\<^sub>i\<^sub>r = val_map i\<^sub>r\<^sub>w\<^sub>d\ - have "\ = \t\<^sub>1 + \t\<^sub>2 - \r\<^sub>l - val_map i\<^sub>r\<^sub>w\<^sub>d + non_distributed + \f + val_map rs - + val_map update\<^sub>r\<^sub>w\<^sub>d" - by simp - also from \\f = -fee_ss\ have "\ = \t\<^sub>1 + \t\<^sub>2 - \r\<^sub>l + val_map rs - fee_ss - val_map i\<^sub>r\<^sub>w\<^sub>d - + non_distributed + val_map update\<^sub>r\<^sub>w\<^sub>d" + proof - + from assms(4-6) have "\t + \r + non_distributed + \f + val_map rs + val_map update\<^sub>r\<^sub>w\<^sub>d = + \t - \r\<^sub>l - val_map i\<^sub>r\<^sub>w\<^sub>d + non_distributed + \f + val_map rs + val_map update\<^sub>r\<^sub>w\<^sub>d" by simp - also from \\t\<^sub>1 + \t\<^sub>2 - \r\<^sub>l + val_map rs - fee_ss = 0\ have "\ = - - val_map i\<^sub>r\<^sub>w\<^sub>d + non_distributed + val_map update\<^sub>r\<^sub>w\<^sub>d" + also from assms(3,6) have "\ = - val_map i\<^sub>r\<^sub>w\<^sub>d + non_distributed + val_map update\<^sub>r\<^sub>w\<^sub>d" by simp also have "\ = 0" proof - @@ -850,26 +817,27 @@ proof - proof - have "val_map rew'\<^sub>m\<^sub>i\<^sub>r + val_map unregistered = val_map update\<^sub>r\<^sub>w\<^sub>d + non_distributed" proof - - from f6 and assms(1,2) have "val_map rew'\<^sub>m\<^sub>i\<^sub>r = val_map update\<^sub>r\<^sub>w\<^sub>d" + from f5 and assms(7,8) have "val_map rew'\<^sub>m\<^sub>i\<^sub>r = val_map update\<^sub>r\<^sub>w\<^sub>d" by (simp add: val_map_fmap_of_list) - moreover from f4 and f7 have "val_map unregistered = non_distributed" + moreover from f2 and f3 have "val_map unregistered = non_distributed" by simp ultimately show ?thesis by simp qed - moreover from f5 and f7 have "val_map i\<^sub>r\<^sub>w\<^sub>d = val_map rew'\<^sub>m\<^sub>i\<^sub>r + val_map unregistered" + moreover from assms(3) and f2 and f4 have "val_map i\<^sub>r\<^sub>w\<^sub>d = + val_map rew'\<^sub>m\<^sub>i\<^sub>r + val_map unregistered" using val_map_split by (metis add.commute) ultimately show ?thesis by simp qed then show ?thesis by simp - qed + qed finally show ?thesis . qed - moreover have "val_epoch_state s\<^sub>2 = + moreover from f0 have "val_epoch_state es = treasury + reserves + val_utxo utxo + deps + fees + val_map rewards" - using f2 by simp + by simp ultimately show ?thesis by simp qed @@ -1103,12 +1071,20 @@ lemma newepoch_value_preservation: proof - from assms show ?thesis proof cases - case (new_epoch e\<^sub>l ru ru' _ _ _ _ i\<^sub>r\<^sub>w\<^sub>d' es b\<^sub>p\<^sub>r\<^sub>e\<^sub>v es' es'' pd' osched' b\<^sub>c\<^sub>u\<^sub>r pd osched) + case (new_epoch e\<^sub>l ru ru' \t \r rs \f i\<^sub>r\<^sub>w\<^sub>d es rewards\<^sub>m\<^sub>i\<^sub>r \r\<^sub>l es' es'' pd' osched' b\<^sub>p\<^sub>r\<^sub>e\<^sub>v b\<^sub>c\<^sub>u\<^sub>r pd osched) have "val_epoch_state es'' = val_epoch_state es" proof - - from \inj addr_rwd\ and \mono addr_rwd\ and \ru' = create_r_upd b\<^sub>p\<^sub>r\<^sub>e\<^sub>v es\ have " + from + \inj addr_rwd\ and + \mono addr_rwd\ and + \(\t, \r, rs, \f, i\<^sub>r\<^sub>w\<^sub>d) = ru'\ and + \i\<^sub>r\<^sub>w\<^sub>d = get_ir es\ and + \\f = - get_fee_ss es\ and + \rewards\<^sub>m\<^sub>i\<^sub>r = (\ k \ fmdom' i\<^sub>r\<^sub>w\<^sub>d. i\<^sub>r\<^sub>w\<^sub>d $$! k)\ and + \- \r = \r\<^sub>l + rewards\<^sub>m\<^sub>i\<^sub>r\ and + \\t - \r\<^sub>l + (\ k \ fmdom' rs. rs $$! k) + \f = 0\ have " val_epoch_state (apply_r_upd ru' es) = val_epoch_state es" - using reward_update_value_preservation by presburger + using reward_update_application_value_preservation by simp with \es' = apply_r_upd ru' es\ and \\ es' \\<^bsub>EPOCH\<^esub>{\} es''\ show ?thesis using epoch_value_preservation by simp qed @@ -1117,10 +1093,12 @@ proof - by simp next case not_new_epoch - then show ?thesis by simp + then show ?thesis + by simp next case no_reward_update - then show ?thesis by simp + then show ?thesis + by simp qed qed diff --git a/Isabelle/Shelley/Rewards.thy b/Isabelle/Shelley/Rewards.thy index ba01a63..1403544 100644 --- a/Isabelle/Shelley/Rewards.thy +++ b/Isabelle/Shelley/Rewards.thy @@ -205,6 +205,9 @@ text \ Accessor Functions \ fun get_ir :: "epoch_state \ (credential, coin) fmap" where "get_ir (_, _, (_, ((_, _, i\<^sub>r\<^sub>w\<^sub>d), _)), _) = i\<^sub>r\<^sub>w\<^sub>d" +fun get_fee_ss :: "epoch_state \ coin" where + "get_fee_ss (_, (_, _, _, _, fee_ss), _, _) = fee_ss" + text \ Epoch Inference Rule \ inductive epoch_sts :: "epoch_state \ epoch \ epoch_state \ bool" From e82140e32743069992e90edc28bc0a94a192309b Mon Sep 17 00:00:00 2001 From: Javier Diaz Date: Tue, 28 Jan 2020 01:16:41 -0300 Subject: [PATCH 33/39] Improve proof of `fmran_singleton` Signed-off-by: Javier Diaz --- Isabelle/Shelley/Finite_Map_Extras.thy | 22 ++++++++++++++++++---- 1 file changed, 18 insertions(+), 4 deletions(-) diff --git a/Isabelle/Shelley/Finite_Map_Extras.thy b/Isabelle/Shelley/Finite_Map_Extras.thy index 68d6d42..7774b26 100644 --- a/Isabelle/Shelley/Finite_Map_Extras.thy +++ b/Isabelle/Shelley/Finite_Map_Extras.thy @@ -102,11 +102,25 @@ next qed qed -lemma fmran_singleton: "fmran {k $$:= v} = {|v|}" (* TODO: Find a nicer proof *) +lemma fmran_singleton: "fmran {k $$:= v} = {|v|}" proof - - have "\v'. v' |\| fmran {k $$:= v} \ v' = v" - by (metis fmdom_empty fmdom_fmupd fmdom_notD fmranE fmupd_lookup fsingleton_iff - option.distinct(1) option.sel) + have "v' |\| fmran {k $$:= v} \ v' = v" for v' + proof - + assume "v' |\| fmran {k $$:= v}" + fix k' + have "fmdom' {k $$:= v} = {k}" + by simp + then show "v' = v" + proof (cases "k' = k") + case True + with \v' |\| fmran {k $$:= v}\ show ?thesis + using fmdom'I by fastforce + next + case False + with \fmdom' {k $$:= v} = {k}\ and \v' |\| fmran {k $$:= v}\ show ?thesis + using fmdom'I by fastforce + qed + qed moreover have "v |\| fmran {k $$:= v}" by (simp add: fmranI) ultimately show ?thesis From 9bb32f43f09d0fac9a2f52e678ba1cf3811b1e9c Mon Sep 17 00:00:00 2001 From: Javier Diaz Date: Tue, 28 Jan 2020 19:31:58 -0300 Subject: [PATCH 34/39] Overhaul proof of `fmdiff_partition` --- Isabelle/Shelley/Finite_Map_Extras.thy | 64 ++++++++++++++++++++++++-- 1 file changed, 60 insertions(+), 4 deletions(-) diff --git a/Isabelle/Shelley/Finite_Map_Extras.thy b/Isabelle/Shelley/Finite_Map_Extras.thy index 7774b26..4388719 100644 --- a/Isabelle/Shelley/Finite_Map_Extras.thy +++ b/Isabelle/Shelley/Finite_Map_Extras.thy @@ -352,20 +352,76 @@ qed text \ Map difference \ +lemma fsubset_antisym: + assumes "m \\<^sub>f n" + and "n \\<^sub>f m" + shows "m = n" +proof - + from \m \\<^sub>f n\ have "\k \ dom (($$) m). (($$) m) k = (($$) n) k" + by (simp add: fmsubset.rep_eq map_le_def) + moreover from \n \\<^sub>f m\ have "\k \ dom (($$) n). (($$) n) k = (($$) m) k" + by (simp add: fmsubset.rep_eq map_le_def) + ultimately show ?thesis + proof (intro fmap_ext) + fix k + consider + (a) "k \ dom (($$) m)" | + (b) "k \ dom (($$) n)" | + (c) "k \ dom (($$) m) \ k \ dom (($$) n)" + by auto + then show "m $$ k = n $$ k" + proof cases + case a + with \\k \ dom (($$) m). m $$ k = n $$ k\ show ?thesis + by simp + next + case b + with \\k \ dom (($$) n). n $$ k = m $$ k\ show ?thesis + by simp + next + case c + then show ?thesis + by (simp add: fmdom'_notD) + qed + qed +qed + abbreviation fmdiff :: "('a, 'b) fmap \ ('a, 'b) fmap \ ('a, 'b) fmap" (infixl \--\<^sub>f\ 100) where "m\<^sub>1 --\<^sub>f m\<^sub>2 \ fmfilter (\x. x \ fmdom' m\<^sub>2) m\<^sub>1" -lemma fmdiff_partition: (* TODO: Find a nicer proof *) +lemma fmdiff_partition: assumes "m\<^sub>2 \\<^sub>f m\<^sub>1" shows "m\<^sub>2 ++\<^sub>f (m\<^sub>1 --\<^sub>f m\<^sub>2) = m\<^sub>1" proof - - from assms have *: "m\<^sub>2 ++\<^sub>f (m\<^sub>1 --\<^sub>f m\<^sub>2) \\<^sub>f m\<^sub>1" - by (smt fmfilter_subset fmlookup_add fmpred_iff fmsubset_alt_def) + have *: "m\<^sub>2 ++\<^sub>f (m\<^sub>1 --\<^sub>f m\<^sub>2) \\<^sub>f m\<^sub>1" + proof - + have "\k v. (m\<^sub>2 ++\<^sub>f (m\<^sub>1 --\<^sub>f m\<^sub>2)) $$ k = Some v \ m\<^sub>1 $$ k = Some v" + proof (intro allI impI) + fix k v + assume "(m\<^sub>2 ++\<^sub>f (m\<^sub>1 --\<^sub>f m\<^sub>2)) $$ k = Some v" + then have **: "(if k |\| fmdom (m\<^sub>1 --\<^sub>f m\<^sub>2) then (m\<^sub>1 --\<^sub>f m\<^sub>2) $$ k else m\<^sub>2 $$ k) = Some v" + by simp + then show "m\<^sub>1 $$ k = Some v" + proof (cases "k |\| fmdom (m\<^sub>1 --\<^sub>f m\<^sub>2)") + case True + with ** show ?thesis + by simp + next + case False + with \m\<^sub>2 \\<^sub>f m\<^sub>1\ show ?thesis + by simp + qed + qed + then have "fmpred (\k v. m\<^sub>1 $$ k = Some v) (m\<^sub>2 ++\<^sub>f (m\<^sub>1 --\<^sub>f m\<^sub>2))" + by (blast intro: fmpred_iff) + then show ?thesis + by (auto simp add: fmsubset_alt_def) + qed then have "m\<^sub>1 \\<^sub>f m\<^sub>2 ++\<^sub>f (m\<^sub>1 --\<^sub>f m\<^sub>2)" by (simp add: fmsubset.rep_eq map_le_def) with * show ?thesis - by (metis (no_types, lifting) domIff fmap_ext fmsubset.rep_eq map_le_def) + by (simp add: fsubset_antisym) qed lemma fmdiff_fmupd: (* TODO: Find a nicer proof *) From b2c3abdb08741d53b9f6c940876524d49a8a4b06 Mon Sep 17 00:00:00 2001 From: Javier Diaz Date: Tue, 11 Feb 2020 20:08:35 -0300 Subject: [PATCH 35/39] Overhaul proof of `fmdiff_fmupd` --- Isabelle/Shelley/Finite_Map_Extras.thy | 22 ++++++++++++++++++---- 1 file changed, 18 insertions(+), 4 deletions(-) diff --git a/Isabelle/Shelley/Finite_Map_Extras.thy b/Isabelle/Shelley/Finite_Map_Extras.thy index 4388719..864f5bd 100644 --- a/Isabelle/Shelley/Finite_Map_Extras.thy +++ b/Isabelle/Shelley/Finite_Map_Extras.thy @@ -424,12 +424,26 @@ proof - by (simp add: fsubset_antisym) qed -lemma fmdiff_fmupd: (* TODO: Find a nicer proof *) +lemma fmdiff_fmupd: assumes "m $$ k = None" shows "m(k $$:= v) --\<^sub>f {k $$:= v} = m" - using assms - by (smt Diff_iff Diff_insert_absorb fmdom'_empty fmdom'_fmupd fmdom'_notD fmdom'_notI - fmfilter_true fmfilter_upd option.simps(3) singletonI) +proof - + let ?P = "(\k'. k' \ {k})" + have "m(k $$:= v) --\<^sub>f {k $$:= v} = fmfilter (\x. x \ fmdom' {k $$:= v}) m(k $$:= v)" .. + also have "\ = fmfilter ?P m(k $$:= v)" + by simp + also have "\ = (if ?P k then (fmfilter ?P m)(k $$:= v) else fmfilter ?P m)" + by simp + also have "\ = fmfilter ?P m" + by simp + finally show ?thesis + proof - + from \m $$ k = None\ have "\k' v'. m $$ k' = Some v' \ ?P k'" + by fastforce + then show ?thesis + by simp + qed +qed text \ Map symmetric difference \ From 74e7f4251715c9e67cb3900230d0486ff863d567 Mon Sep 17 00:00:00 2001 From: Javier Diaz Date: Tue, 11 Feb 2020 23:47:35 -0300 Subject: [PATCH 36/39] Overhaul proof of `inter_plus_addition_in` --- Isabelle/Shelley/Finite_Map_Extras.thy | 28 ++++++++++++++++++-------- 1 file changed, 20 insertions(+), 8 deletions(-) diff --git a/Isabelle/Shelley/Finite_Map_Extras.thy b/Isabelle/Shelley/Finite_Map_Extras.thy index 864f5bd..d513dad 100644 --- a/Isabelle/Shelley/Finite_Map_Extras.thy +++ b/Isabelle/Shelley/Finite_Map_Extras.thy @@ -601,16 +601,15 @@ proof - using \m\<^sub>2 $$ k = Some v'\ and dom_res_singleton by fastforce qed -lemma inter_plus_addition_in: (* TODO: Find nicer proofs for SMT calls. *) +lemma inter_plus_addition_in: assumes "m\<^sub>1 $$ k = None" and "m\<^sub>2 $$ k = Some v'" shows "m\<^sub>1(k $$:= v) \\<^sub>+ m\<^sub>2 = (m\<^sub>1 \\<^sub>+ m\<^sub>2) ++\<^sub>f {k $$:= v' + v}" proof - - from assms have "m\<^sub>1(k $$:= v) \\<^sub>+ m\<^sub>2 = - fmmap_keys (\k' v'. v' + m\<^sub>1(k $$:= v) $$! k') ((fmdom' m\<^sub>1 \ m\<^sub>2) ++\<^sub>f {k $$:= v'})" + let ?f = "\k' v'. v' + m\<^sub>1(k $$:= v) $$! k'" + from assms have "m\<^sub>1(k $$:= v) \\<^sub>+ m\<^sub>2 = fmmap_keys ?f ((fmdom' m\<^sub>1 \ m\<^sub>2) ++\<^sub>f {k $$:= v'})" using dom_res_addition_in by fastforce - also have "\ = fmmap_keys (\k' v'. v' + m\<^sub>1(k $$:= v) $$! k') (fmdom' m\<^sub>1 \ m\<^sub>2) - ++\<^sub>f fmmap_keys (\k' v'. v' + m\<^sub>1(k $$:= v) $$! k') {k $$:= v'}" + also have "\ = fmmap_keys ?f (fmdom' m\<^sub>1 \ m\<^sub>2) ++\<^sub>f fmmap_keys ?f {k $$:= v'}" proof - from \m\<^sub>1 $$ k = None\ have "fmdom' (fmdom' m\<^sub>1 \ m\<^sub>2) \ fmdom' {k $$:= v'} = {}" by (simp add: fmdom'_notI) @@ -618,9 +617,22 @@ proof - using fmmap_keys_hom by blast qed also from assms - have "\ = fmmap_keys (\k' v'. v' + m\<^sub>1(k $$:= v) $$! k') (fmdom' m\<^sub>1 \ m\<^sub>2) ++\<^sub>f {k $$:= v' + v}" - using dom_res_singleton by (smt domIff dom_fmlookup fmfilter_fmmap_keys fmlookup_dom'_iff - fmlookup_fmmap_keys fmupd_lookup map_option_is_None option.map_sel option.sel) + have "\ = fmmap_keys ?f (fmdom' m\<^sub>1 \ m\<^sub>2) ++\<^sub>f {k $$:= v' + v}" + proof - + have "fmmap_keys ?f {k $$:= v'} = {k $$:= v' + v}" + proof (intro fmap_ext) + fix x + have "fmmap_keys ?f {k $$:= v'} $$ x = map_option (?f x) ({k $$:= v'} $$ x)" + using fmlookup_fmmap_keys . + also have "\ = map_option (?f x) (if k = x then Some v' else {$$} $$ x)" + by simp + also have "\ = {k $$:= v' + v} $$ x" + by (cases "x = k") simp_all + finally show "fmmap_keys ?f {k $$:= v'} $$ x = {k $$:= v' + v} $$ x" . + qed + then show ?thesis + by simp + qed also have "\ = fmmap_keys (\k' v'. v' + m\<^sub>1 $$! k') (fmdom' m\<^sub>1 \ m\<^sub>2) ++\<^sub>f {k $$:= v' + v}" by (simp add: fmap_ext) finally show ?thesis . From 308f10093b94cd20091c5c51da629918f27c3629 Mon Sep 17 00:00:00 2001 From: Javier Diaz Date: Wed, 12 Feb 2020 00:55:27 -0300 Subject: [PATCH 37/39] Overhaul proof of `inter_plus_addition_notin` --- Isabelle/Shelley/Finite_Map_Extras.thy | 46 ++++++++++++++++++-------- 1 file changed, 32 insertions(+), 14 deletions(-) diff --git a/Isabelle/Shelley/Finite_Map_Extras.thy b/Isabelle/Shelley/Finite_Map_Extras.thy index d513dad..7ce093d 100644 --- a/Isabelle/Shelley/Finite_Map_Extras.thy +++ b/Isabelle/Shelley/Finite_Map_Extras.thy @@ -601,6 +601,22 @@ proof - using \m\<^sub>2 $$ k = Some v'\ and dom_res_singleton by fastforce qed +lemma dom_res_addition_not_in: + assumes "m\<^sub>2 $$ k = None" + shows "fmdom' m\<^sub>1(k $$:= v) \ m\<^sub>2 = fmdom' m\<^sub>1 \ m\<^sub>2" +proof - + have "fmdom' m\<^sub>1(k $$:= v) \ m\<^sub>2 = fmfilter (\k'. k' = k \ k' \ fmdom' m\<^sub>1) m\<^sub>2" + by simp + also have "\ = fmdom' m\<^sub>1 \ m\<^sub>2" + proof (intro fmfilter_cong') + show "m\<^sub>2 = m\<^sub>2" .. + next + from assms show "k' \ fmdom' m\<^sub>2 \ (k' = k \ k' \ fmdom' m\<^sub>1) = (k' \ fmdom' m\<^sub>1)" for k' + by (cases "k' = k") (simp_all add: fmdom'_notI) + qed + finally show ?thesis . +qed + lemma inter_plus_addition_in: assumes "m\<^sub>1 $$ k = None" and "m\<^sub>2 $$ k = Some v'" @@ -621,14 +637,14 @@ proof - proof - have "fmmap_keys ?f {k $$:= v'} = {k $$:= v' + v}" proof (intro fmap_ext) - fix x - have "fmmap_keys ?f {k $$:= v'} $$ x = map_option (?f x) ({k $$:= v'} $$ x)" + fix k' + have "fmmap_keys ?f {k $$:= v'} $$ k' = map_option (?f k') ({k $$:= v'} $$ k')" using fmlookup_fmmap_keys . - also have "\ = map_option (?f x) (if k = x then Some v' else {$$} $$ x)" + also have "\ = map_option (?f k') (if k = k' then Some v' else {$$} $$ k')" by simp - also have "\ = {k $$:= v' + v} $$ x" - by (cases "x = k") simp_all - finally show "fmmap_keys ?f {k $$:= v'} $$ x = {k $$:= v' + v} $$ x" . + also have "\ = {k $$:= v' + v} $$ k'" + by (cases "k' = k") simp_all + finally show "fmmap_keys ?f {k $$:= v'} $$ k' = {k $$:= v' + v} $$ k'" . qed then show ?thesis by simp @@ -638,22 +654,24 @@ proof - finally show ?thesis . qed -lemma inter_plus_addition_notin: (* TODO: Find nicer proofs for SMT calls. *) +lemma inter_plus_addition_notin: assumes "m\<^sub>1 $$ k = None" and "m\<^sub>2 $$ k = None" shows "m\<^sub>1(k $$:= v) \\<^sub>+ m\<^sub>2 = (m\<^sub>1 \\<^sub>+ m\<^sub>2)" proof - + let ?f = "\k' v'. v' + m\<^sub>1(k $$:= v) $$! k'" from \m\<^sub>2 $$ k = None\ - have "m\<^sub>1(k $$:= v) \\<^sub>+ m\<^sub>2 = fmmap_keys (\k' v'. v' + m\<^sub>1(k $$:= v) $$! k') (fmdom' m\<^sub>1 \ m\<^sub>2)" - by (smt fmdom'_fmupd fmdom'_notI fmfilter_cong' insert_iff) + have "m\<^sub>1(k $$:= v) \\<^sub>+ m\<^sub>2 = fmmap_keys ?f (fmdom' m\<^sub>1 \ m\<^sub>2)" + using dom_res_addition_not_in by metis also have "\ = fmmap_keys (\k' v'. v' + m\<^sub>1 $$! k') (fmdom' m\<^sub>1 \ m\<^sub>2)" proof (intro fmap_ext) fix k' - from \m\<^sub>1 $$ k = None\ - show "fmmap_keys (\k' v'. v' + m\<^sub>1(k $$:= v) $$! k') (fmdom' m\<^sub>1 \ m\<^sub>2) $$ k' = - fmmap_keys (\k' v'. v' + m\<^sub>1 $$! k') (fmdom' m\<^sub>1 \ m\<^sub>2) $$ k'" - by (smt domIff dom_fmlookup fmdiff_fmupd fmlookup_filter fmlookup_fmmap_keys - map_option_is_None option.expand option.map_sel) + have "fmmap_keys ?f (fmdom' m\<^sub>1 \ m\<^sub>2) $$ k' = map_option (?f k') ((fmdom' m\<^sub>1 \ m\<^sub>2) $$ k')" + using fmlookup_fmmap_keys . + also from \m\<^sub>1 $$ k = None\ have "\ = fmmap_keys (\k' v'. v' + m\<^sub>1 $$! k') (fmdom' m\<^sub>1 \ m\<^sub>2) $$ k'" + by (cases "k' = k") (simp_all add: fmdom'_notI) + finally show "fmmap_keys ?f (fmdom' m\<^sub>1 \ m\<^sub>2) $$ k' = + fmmap_keys (\k' v'. v' + m\<^sub>1 $$! k') (fmdom' m\<^sub>1 \ m\<^sub>2) $$ k'" . qed finally show ?thesis . qed From f5bb8bdc01f5054fe22e7c563e6af27e36ede4da Mon Sep 17 00:00:00 2001 From: Javier Diaz Date: Wed, 12 Feb 2020 01:06:17 -0300 Subject: [PATCH 38/39] Fix bug in proof --- Isabelle/Shelley/Finite_Map_Extras.thy | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/Isabelle/Shelley/Finite_Map_Extras.thy b/Isabelle/Shelley/Finite_Map_Extras.thy index 7ce093d..28f025a 100644 --- a/Isabelle/Shelley/Finite_Map_Extras.thy +++ b/Isabelle/Shelley/Finite_Map_Extras.thy @@ -409,8 +409,8 @@ proof - by simp next case False - with \m\<^sub>2 \\<^sub>f m\<^sub>1\ show ?thesis - by simp + with ** and \m\<^sub>2 \\<^sub>f m\<^sub>1\ show ?thesis + by (metis (mono_tags, lifting) fmpredD fmsubset_alt_def) qed qed then have "fmpred (\k v. m\<^sub>1 $$ k = Some v) (m\<^sub>2 ++\<^sub>f (m\<^sub>1 --\<^sub>f m\<^sub>2))" From 8fb5ad3e3759776212e2a5bac35b30e40f198598 Mon Sep 17 00:00:00 2001 From: Javier Diaz Date: Thu, 13 Feb 2020 16:47:39 -0300 Subject: [PATCH 39/39] Adapt formalization to match improvements in spec NOTE: The related PRs in `cardano-ledger-specs` are #1191 and #1203. --- Isabelle/Shelley/Chain.thy | 37 ++++-- Isabelle/Shelley/Properties.thy | 211 ++++++++++++++++++-------------- Isabelle/Shelley/Rewards.thy | 45 ++----- 3 files changed, 160 insertions(+), 133 deletions(-) diff --git a/Isabelle/Shelley/Chain.thy b/Isabelle/Shelley/Chain.thy index 4a79301..88079b0 100644 --- a/Isabelle/Shelley/Chain.thy +++ b/Isabelle/Shelley/Chain.thy @@ -57,6 +57,30 @@ consts h_b_bsize :: "b_h_body \ nat" \ \NOTE: Abstrac consts bbodyhash :: "tx list \ hash_b_body" +subsection \ MIR Transition \ + +inductive mir_sts :: "epoch_state \ epoch_state \ bool" + (\\ _ \\<^bsub>MIR\<^esub> _\ [0, 50]) + where + mir: " + \ (acnt, ss, (us, (ds, ps)), pp) \\<^bsub>MIR\<^esub> (acnt', ss, (us, (ds', ps)), pp)" + if "(stk_creds, rewards, i\<^sub>r\<^sub>w\<^sub>d) = ds" + and "(treasury, reserves) = acnt" + and "i'\<^sub>r\<^sub>w\<^sub>d = fmdom' stk_creds \ i\<^sub>r\<^sub>w\<^sub>d" + and "tot = (\ k \ fmdom' i'\<^sub>r\<^sub>w\<^sub>d. i'\<^sub>r\<^sub>w\<^sub>d $$! k)" + and "update = fmap_of_list [(addr_rwd hk, val). (hk, val) \ sorted_list_of_fmap i'\<^sub>r\<^sub>w\<^sub>d]" + and "tot \ reserves" + and "acnt' = (treasury, reserves - tot)" + and "ds' = (stk_creds, rewards \\<^sub>+ update, {$$})" + | mir_skip: " + \ (acnt, ss, (us, (ds, ps)), pp) \\<^bsub>MIR\<^esub> (acnt, ss, (us, (ds', ps)), pp)" + if "(stk_creds, rewards, i\<^sub>r\<^sub>w\<^sub>d) = ds" + and "(_, reserves) = acnt" + and "i'\<^sub>r\<^sub>w\<^sub>d = fmdom' stk_creds \ i\<^sub>r\<^sub>w\<^sub>d" + and "tot = (\ k \ fmdom' i'\<^sub>r\<^sub>w\<^sub>d. i'\<^sub>r\<^sub>w\<^sub>d $$! k)" + and "tot > reserves" + and "ds' = (stk_creds, rewards, {$$})" + subsection \ New Epoch Transition \ text \ New Epoch environments \ @@ -88,17 +112,14 @@ inductive new_epoch_sts :: "new_epoch_env \ new_epoch_state \ \ - (e\<^sub>l, b\<^sub>p\<^sub>r\<^sub>e\<^sub>v, b\<^sub>c\<^sub>u\<^sub>r, es, ru, pd, osched) \\<^bsub>NEWEPOCH\<^esub>{e} (e, b\<^sub>c\<^sub>u\<^sub>r, {$$}, es'', None, pd', osched')" + (e\<^sub>l, b\<^sub>p\<^sub>r\<^sub>e\<^sub>v, b\<^sub>c\<^sub>u\<^sub>r, es, ru, pd, osched) \\<^bsub>NEWEPOCH\<^esub>{e} (e, b\<^sub>c\<^sub>u\<^sub>r, {$$}, es''', None, pd', osched')" if "e = e\<^sub>l + 1" and "ru = Some ru'" - and "(\t, \r, rs, \f, i\<^sub>r\<^sub>w\<^sub>d) = ru'" - and "i\<^sub>r\<^sub>w\<^sub>d = get_ir es" - and "\f = - get_fee_ss es" - and "rewards\<^sub>m\<^sub>i\<^sub>r = (\ k \ fmdom' i\<^sub>r\<^sub>w\<^sub>d. i\<^sub>r\<^sub>w\<^sub>d $$! k)" - and "- \r = \r\<^sub>l + rewards\<^sub>m\<^sub>i\<^sub>r" - and "\t - \r\<^sub>l + (\ k \ fmdom' rs. rs $$! k) + \f = 0" + and "(\t, \r, rs, \f) = ru'" + and "\t + \r + (\ k \ fmdom' rs. rs $$! k) + \f = 0" and "es' = apply_r_upd ru' es" - and "\ es' \\<^bsub>EPOCH\<^esub>{e} es''" + and "\ es' \\<^bsub>MIR\<^esub> es''" + and "\ es'' \\<^bsub>EPOCH\<^esub>{e} es'''" and "pd' = undefined" and "osched' = undefined" | not_new_epoch: " diff --git a/Isabelle/Shelley/Properties.thy b/Isabelle/Shelley/Properties.thy index 648c574..6f4c768 100644 --- a/Isabelle/Shelley/Properties.thy +++ b/Isabelle/Shelley/Properties.thy @@ -747,96 +747,36 @@ next qed \ \NOTE: Lemma 15.9 in the spec.\ -\ \NOTE: We require \addr_rwd\ to be monotonic, which is a minor (though sensible) deviation from -the spec.\ -lemma reward_update_application_value_preservation: - assumes "ru = (\t, \r, rs, \f, i\<^sub>r\<^sub>w\<^sub>d)" - and "i\<^sub>r\<^sub>w\<^sub>d = get_ir es" - and "\f = - get_fee_ss es" - and "rewards\<^sub>m\<^sub>i\<^sub>r = (\ k \ fmdom' i\<^sub>r\<^sub>w\<^sub>d. i\<^sub>r\<^sub>w\<^sub>d $$! k)" - and "- \r = \r\<^sub>l + rewards\<^sub>m\<^sub>i\<^sub>r" - and "\t - \r\<^sub>l + (\ k \ fmdom' rs. rs $$! k) + \f = 0" - and "inj addr_rwd" - and "mono addr_rwd" - shows "val_epoch_state es = val_epoch_state (apply_r_upd ru es)" +lemma reward_update_cancellation: + assumes "create_r_upd b es = (\t, \r, rs, \f)" + shows "\t + \r + val_map rs + \f = 0" proof - obtain treasury reserves pstake\<^sub>m\<^sub>a\<^sub>r\<^sub>k pstake\<^sub>s\<^sub>e\<^sub>t pstake\<^sub>g\<^sub>o pools_ss fee_ss utxo deps fees up stk_creds - rewards i'\<^sub>r\<^sub>w\<^sub>d pstate pp + rewards i\<^sub>r\<^sub>w\<^sub>d pstate pp where f0: "es = ( (treasury, reserves), (pstake\<^sub>m\<^sub>a\<^sub>r\<^sub>k, pstake\<^sub>s\<^sub>e\<^sub>t, pstake\<^sub>g\<^sub>o, pools_ss, fee_ss), - ((utxo, deps, fees, up), ((stk_creds, rewards, i'\<^sub>r\<^sub>w\<^sub>d), pstate)), + ((utxo, deps, fees, up), ((stk_creds, rewards, i\<^sub>r\<^sub>w\<^sub>d), pstate)), pp )" by (metis old.prod.exhaust val_deleg_state.cases) - with assms(2,3) have "i'\<^sub>r\<^sub>w\<^sub>d = i\<^sub>r\<^sub>w\<^sub>d" and "- fee_ss = \f" - by (simp, simp) - from assms(1,2,4) and f0 obtain non_distributed and rew'\<^sub>m\<^sub>i\<^sub>r and update\<^sub>r\<^sub>w\<^sub>d and unregistered - where f1: "apply_r_upd ru es = + then obtain \t\<^sub>1 \t\<^sub>2 \r' rs' reward_pot R + where f1: "create_r_upd b ( - (treasury + \t, reserves + \r + non_distributed), + (treasury, reserves), (pstake\<^sub>m\<^sub>a\<^sub>r\<^sub>k, pstake\<^sub>s\<^sub>e\<^sub>t, pstake\<^sub>g\<^sub>o, pools_ss, fee_ss), - ((utxo, deps, fees + \f, up), ((stk_creds, (rewards \\<^sub>+ rs) \\<^sub>+ update\<^sub>r\<^sub>w\<^sub>d, {$$}), pstate)), + ((utxo, deps, fees, up), ((stk_creds, rewards, i\<^sub>r\<^sub>w\<^sub>d), pstate)), pp - )" - and f2: "unregistered = fmdom' stk_creds \/ i\<^sub>r\<^sub>w\<^sub>d" - and f3: "non_distributed = (\k \ fmdom' unregistered. unregistered $$! k)" - and f4: "rew'\<^sub>m\<^sub>i\<^sub>r = fmdom' stk_creds \ i\<^sub>r\<^sub>w\<^sub>d" - and f5: "update\<^sub>r\<^sub>w\<^sub>d = fmap_of_list [(addr_rwd hk, val). (hk, val) \ sorted_list_of_fmap rew'\<^sub>m\<^sub>i\<^sub>r]" - by (metis apply_r_upd.simps) - then have "val_epoch_state (apply_r_upd ru es) = - treasury + reserves + val_utxo utxo + deps + fees + val_map rewards + \t + \r + non_distributed - + \f + val_map rs + val_map update\<^sub>r\<^sub>w\<^sub>d" - proof - - from assms(1) and f1 have "val_epoch_state (apply_r_upd ru es) = - val_acnt (treasury + \t, reserves + \r + non_distributed) - + val_ledger_state ( - (utxo, deps, fees + \f, up), ((stk_creds, (rewards \\<^sub>+ rs) \\<^sub>+ update\<^sub>r\<^sub>w\<^sub>d, {$$}), pstate))" - by simp - then have "val_epoch_state (apply_r_upd ru es) = - (treasury + \t) + (reserves + \r + non_distributed) + val_utxo utxo + deps + (fees + \f) - + val_map ((rewards \\<^sub>+ rs) \\<^sub>+ update\<^sub>r\<^sub>w\<^sub>d)" - by auto - moreover have "val_map ((rewards \\<^sub>+ rs) \\<^sub>+ update\<^sub>r\<^sub>w\<^sub>d) = - val_map rewards + val_map rs + val_map update\<^sub>r\<^sub>w\<^sub>d" - using val_map_union_plus by metis - ultimately show ?thesis - by linarith - qed - moreover have "\t + \r + non_distributed + \f + val_map rs + val_map update\<^sub>r\<^sub>w\<^sub>d = 0" - proof - - from assms(4-6) have "\t + \r + non_distributed + \f + val_map rs + val_map update\<^sub>r\<^sub>w\<^sub>d = - \t - \r\<^sub>l - val_map i\<^sub>r\<^sub>w\<^sub>d + non_distributed + \f + val_map rs + val_map update\<^sub>r\<^sub>w\<^sub>d" - by simp - also from assms(3,6) have "\ = - val_map i\<^sub>r\<^sub>w\<^sub>d + non_distributed + val_map update\<^sub>r\<^sub>w\<^sub>d" - by simp - also have "\ = 0" - proof - - have "val_map i\<^sub>r\<^sub>w\<^sub>d = val_map update\<^sub>r\<^sub>w\<^sub>d + non_distributed" - proof - - have "val_map rew'\<^sub>m\<^sub>i\<^sub>r + val_map unregistered = val_map update\<^sub>r\<^sub>w\<^sub>d + non_distributed" - proof - - from f5 and assms(7,8) have "val_map rew'\<^sub>m\<^sub>i\<^sub>r = val_map update\<^sub>r\<^sub>w\<^sub>d" - by (simp add: val_map_fmap_of_list) - moreover from f2 and f3 have "val_map unregistered = non_distributed" - by simp - ultimately show ?thesis - by simp - qed - moreover from assms(3) and f2 and f4 have "val_map i\<^sub>r\<^sub>w\<^sub>d = - val_map rew'\<^sub>m\<^sub>i\<^sub>r + val_map unregistered" - using val_map_split by (metis add.commute) - ultimately show ?thesis - by simp - qed - then show ?thesis - by simp - qed - finally show ?thesis . - qed - moreover from f0 have "val_epoch_state es = - treasury + reserves + val_utxo utxo + deps + fees + val_map rewards" + ) = + (\t\<^sub>1 + \t\<^sub>2, -\r', rs', -fee_ss)" + and f2: "reward_pot = fee_ss + \r'" + and f3: "R = reward_pot - \t\<^sub>1" + and f4: "\t\<^sub>2 = R - (\ k \ fmdom' rs'. rs' $$! k)" + by (metis create_r_upd.simps prod.exhaust_sel) + with assms and f0 and f1 have "rs' = rs" and "\r' = -\r" and "\t = \t\<^sub>1 + \t\<^sub>2" and "\f = -fee_ss" + by auto + moreover with f2 and f3 and f4 have "\t\<^sub>1 + \t\<^sub>2 - \r' + val_map rs' - fee_ss = 0" by simp ultimately show ?thesis by simp @@ -1060,6 +1000,64 @@ proof - qed qed +fun val_mir_state :: "epoch_state \ coin" where + "val_mir_state es = val_epoch_state es" + +\ \NOTE: We require \addr_rwd\ to be monotonic, which is a minor (though sensible) deviation from +the spec.\ +lemma mir_value_preservation: + assumes "\ s \\<^bsub>MIR\<^esub> s'" + and "inj addr_rwd" + and "mono addr_rwd" + shows "val_mir_state s = val_mir_state s'" +proof - + from assms show ?thesis + proof cases + case (mir stk_creds rewards i\<^sub>r\<^sub>w\<^sub>d ds treasury reserves acnt i'\<^sub>r\<^sub>w\<^sub>d tot update acnt' ds' ss us ps pp) + from \s' = (acnt', ss, (us, ds', ps), pp)\ have "val_epoch_state s' = + val_epoch_state (acnt', ss, (us, ds', ps), pp)" + by simp + also have "\ = val_acnt acnt' + val_ledger_state (us, ds', ps)" + by simp + also from \acnt' = (treasury, reserves - tot)\ and \ds' = (stk_creds, rewards \\<^sub>+ update, {$$})\ + have "\ = val_acnt (treasury, reserves - tot) + + val_ledger_state (us, (stk_creds, rewards \\<^sub>+ update, {$$}), ps)" + by simp + also have "\ = treasury + (reserves - tot) + val_utxo_state us + val_map rewards + + val_map update" + using val_map_union_plus by auto + also have "\ = treasury + (reserves - tot) + val_utxo_state us + val_map rewards + tot" + proof - + from \update = fmap_of_list (map (\(hk, val). (addr_rwd hk, val)) (sorted_list_of_fmap i'\<^sub>r\<^sub>w\<^sub>d))\ + and \inj addr_rwd\ and \mono addr_rwd\ have "val_map update = val_map i'\<^sub>r\<^sub>w\<^sub>d" + by (simp add: val_map_fmap_of_list) + also from \tot = val_map i'\<^sub>r\<^sub>w\<^sub>d\ have "\ = tot" + by simp + finally show ?thesis + by simp + qed + also have "\ = treasury + reserves + val_utxo_state us + val_map rewards" + by simp + also from \(treasury, reserves) = acnt\ and \(stk_creds, rewards, i\<^sub>r\<^sub>w\<^sub>d) = ds\ have "\ = + val_acnt acnt + val_ledger_state (us, ds, ps)" + by auto + finally show ?thesis + using \s = (acnt, ss, (us, ds, ps), pp)\ by simp + next + case (mir_skip stk_creds rewards i\<^sub>r\<^sub>w\<^sub>d ds _ reserves acnt _ _ ds' ss us ps pp) + from \s' = (acnt, ss, (us, ds', ps), pp)\ have "val_epoch_state s' = + val_epoch_state (acnt, ss, (us, ds', ps), pp)" + by simp + also have "\ = val_acnt acnt + val_ledger_state (us, ds', ps)" + by simp + also from \(stk_creds, rewards, i\<^sub>r\<^sub>w\<^sub>d) = ds\ and + \ds' = (stk_creds, rewards, {$$})\ have "\ = val_acnt acnt + val_ledger_state (us, ds, ps)" + by auto + finally show ?thesis + using \s = (acnt, ss, (us, ds, ps), pp)\ by simp + qed +qed + fun val_new_epoch_state :: "new_epoch_state \ coin" where "val_new_epoch_state (_, _, _, es, _, _, _) = val_epoch_state es" @@ -1071,25 +1069,52 @@ lemma newepoch_value_preservation: proof - from assms show ?thesis proof cases - case (new_epoch e\<^sub>l ru ru' \t \r rs \f i\<^sub>r\<^sub>w\<^sub>d es rewards\<^sub>m\<^sub>i\<^sub>r \r\<^sub>l es' es'' pd' osched' b\<^sub>p\<^sub>r\<^sub>e\<^sub>v b\<^sub>c\<^sub>u\<^sub>r pd osched) - have "val_epoch_state es'' = val_epoch_state es" + case (new_epoch e\<^sub>l ru ru' \t \r rs \f es' es es'' es''' pd' osched' b\<^sub>p\<^sub>r\<^sub>e\<^sub>v b\<^sub>c\<^sub>u\<^sub>r pd osched) + have "val_epoch_state es''' = val_epoch_state es" proof - - from - \inj addr_rwd\ and - \mono addr_rwd\ and - \(\t, \r, rs, \f, i\<^sub>r\<^sub>w\<^sub>d) = ru'\ and - \i\<^sub>r\<^sub>w\<^sub>d = get_ir es\ and - \\f = - get_fee_ss es\ and - \rewards\<^sub>m\<^sub>i\<^sub>r = (\ k \ fmdom' i\<^sub>r\<^sub>w\<^sub>d. i\<^sub>r\<^sub>w\<^sub>d $$! k)\ and - \- \r = \r\<^sub>l + rewards\<^sub>m\<^sub>i\<^sub>r\ and - \\t - \r\<^sub>l + (\ k \ fmdom' rs. rs $$! k) + \f = 0\ have " - val_epoch_state (apply_r_upd ru' es) = val_epoch_state es" - using reward_update_application_value_preservation by simp - with \es' = apply_r_upd ru' es\ and \\ es' \\<^bsub>EPOCH\<^esub>{\} es''\ show ?thesis + have "val_epoch_state es = val_epoch_state es'" + proof - + have "val_epoch_state es = val_epoch_state (apply_r_upd ru' es)" + proof - + obtain treasury reserves ss utxo deps fees up stk_creds rewards i\<^sub>r\<^sub>w\<^sub>d ps pp + where f0: "es = + ( + (treasury, reserves), + ss, + ((utxo, deps, fees, up), ((stk_creds, rewards, i\<^sub>r\<^sub>w\<^sub>d), ps)), + pp + )" + by (metis old.prod.exhaust val_deleg_state.cases) + with \(\t, \r, rs, \f) = ru'\ have "apply_r_upd ru' es = + ( + (treasury + \t, reserves + \r), + ss, + ((utxo, deps, fees + \f, up), ((stk_creds, rewards \\<^sub>+ rs, i\<^sub>r\<^sub>w\<^sub>d), ps)), + pp + )" + by auto + then have "val_epoch_state (apply_r_upd ru' es) = (treasury + \t) + (reserves + \r) + + val_utxo utxo + deps + (fees + \f) + val_map (rewards \\<^sub>+ rs)" + by simp + also from f0 have "\ = val_epoch_state es + \t + \r + val_map rs + \f" + using val_map_union_plus by simp + also from \\t + \r + (\ k \ fmdom' rs. rs $$! k) + \f = 0\ have "\ = val_epoch_state es" + by simp + finally show ?thesis + by simp + qed + with \es' = apply_r_upd ru' es\ show ?thesis + by simp + qed + also from \\ es' \\<^bsub>MIR\<^esub> es''\ and \inj addr_rwd\ and \mono addr_rwd\ have "\ = + val_epoch_state es''" + using mir_value_preservation by simp + also from \\ es'' \\<^bsub>EPOCH\<^esub>{\} es'''\ have "\ = val_epoch_state es'''" using epoch_value_preservation by simp + finally show ?thesis .. qed with \s = (e\<^sub>l, b\<^sub>p\<^sub>r\<^sub>e\<^sub>v, b\<^sub>c\<^sub>u\<^sub>r, es, ru, pd, osched)\ and - \s' = (\, b\<^sub>c\<^sub>u\<^sub>r, {$$}, es'', None, pd', osched')\ show ?thesis + \s' = (\, b\<^sub>c\<^sub>u\<^sub>r, {$$}, es''', None, pd', osched')\ show ?thesis by simp next case not_new_epoch diff --git a/Isabelle/Shelley/Rewards.thy b/Isabelle/Shelley/Rewards.thy index 1403544..15f83fa 100644 --- a/Isabelle/Shelley/Rewards.thy +++ b/Isabelle/Shelley/Rewards.thy @@ -200,14 +200,6 @@ text \ Epoch States \ type_synonym epoch_state = "acnt \ snapshots \ l_state \ p_params" -text \ Accessor Functions \ - -fun get_ir :: "epoch_state \ (credential, coin) fmap" where - "get_ir (_, _, (_, ((_, _, i\<^sub>r\<^sub>w\<^sub>d), _)), _) = i\<^sub>r\<^sub>w\<^sub>d" - -fun get_fee_ss :: "epoch_state \ coin" where - "get_fee_ss (_, (_, _, _, _, fee_ss), _, _) = fee_ss" - text \ Epoch Inference Rule \ inductive epoch_sts :: "epoch_state \ epoch \ epoch_state \ bool" @@ -235,7 +227,7 @@ subsection \ Reward Update Calculation \ text \ Reward Update \ -type_synonym reward_update = "coin \ coin \ (addr_rwd, coin) fmap \ coin \ (credential, coin) fmap" +type_synonym reward_update = "coin \ coin \ (addr_rwd, coin) fmap \ coin" text \ Calculation to create a reward update \ @@ -244,31 +236,28 @@ fun create_r_upd :: "blocks_made \ epoch_state \ reward_ ( (_, reserves), (_, _, (stake, delegs), pools_ss, fee_ss), - (_, ((_, rewards, i\<^sub>r\<^sub>w\<^sub>d), _)), + (_, ((_, rewards, _), _)), pp ) = ( let - rewards\<^sub>m\<^sub>i\<^sub>r = (\ k \ fmdom' i\<^sub>r\<^sub>w\<^sub>d. i\<^sub>r\<^sub>w\<^sub>d $$! k); - reserves' = reserves - rewards\<^sub>m\<^sub>i\<^sub>r; blocks_made = (\ k \ fmdom' b. b $$! k); \ = real blocks_made / (real slots_per_epoch * active_slot_coeff pp); - \r\<^sub>l = \min 1 \ * rho pp * reserves'\; - reward_pot = fee_ss + \r\<^sub>l; + \r = \min 1 \ * rho pp * reserves\; + reward_pot = fee_ss + \r; \t\<^sub>1 = \tau pp * reward_pot\; - \r = \r\<^sub>l + rewards\<^sub>m\<^sub>i\<^sub>r; R = reward_pot - \t\<^sub>1; rs = reward pp b R (fmdom' rewards) pools_ss stake delegs; \t\<^sub>2 = R - (\ k \ fmdom' rs. rs $$! k) in - (\t\<^sub>1 + \t\<^sub>2, -\r, rs, -fee_ss, i\<^sub>r\<^sub>w\<^sub>d) + (\t\<^sub>1 + \t\<^sub>2, -\r, rs, -fee_ss) )" text \ Applying a reward update \ fun apply_r_upd :: "reward_update \ epoch_state \ epoch_state" where "apply_r_upd - (\t, \r, rs, \f, i'\<^sub>r\<^sub>w\<^sub>d) + (\t, \r, rs, \f) ( (treasury, reserves), ss, @@ -279,21 +268,13 @@ fun apply_r_upd :: "reward_update \ epoch_state \ epoch_ ppm ) = ( - let - rew'\<^sub>m\<^sub>i\<^sub>r = fmdom' stk_creds \ i'\<^sub>r\<^sub>w\<^sub>d; - unregistered = fmdom' stk_creds \/ i'\<^sub>r\<^sub>w\<^sub>d; - non_distributed = (\k \ fmdom' unregistered. unregistered $$! k); - update\<^sub>r\<^sub>w\<^sub>d = fmap_of_list [(addr_rwd hk, val). (hk, val) \ sorted_list_of_fmap rew'\<^sub>m\<^sub>i\<^sub>r] - in - ( - (treasury + \t, reserves + \r + non_distributed), - ss, - ( - (utxo, deps, fees + \f, up), - ((stk_creds, (rewards \\<^sub>+ rs) \\<^sub>+ update\<^sub>r\<^sub>w\<^sub>d, {$$}), pstate) - ), - ppm - ) + (treasury + \t, reserves + \r), + ss, + ( + (utxo, deps, fees + \f, up), + ((stk_creds, rewards \\<^sub>+ rs, i\<^sub>r\<^sub>w\<^sub>d), pstate) + ), + ppm )" end