theory BeispielSteuern
imports Zahlenwelt Maxime Steuern Aenderung KategorischerImperativ
begin

section\<open>Beispiel: Steuern\<close>
text\<open>In diesem Abschnitt kombinieren wir das vorhergehende Modell der Einkommensteuergesetzgebung
mit dem kategorischen Imperativ um ein Beispiel über moralische Aussagen über Steuern zu schaffen.\<close>

text\<open>Wir nehmen eine einfach Welt an, in der jeder Person ihr Einkommen zugeordnet wird.

Achtung: Im Unterschied zum BeispielZahlenwelt.thy modellieren wir hier nicht den Gesamtbesitz,
sondern das Jahreseinkommen. Besitz wird ignoriert.
\<close>
datatype steuerwelt = Steuerwelt
        (get_einkommen: \<open>person \<Rightarrow> int\<close>) \<comment> \<open>Einkommen jeder Person (im Zweifel 0).\<close>

(*<*)
fun steuerwps :: \<open>person \<Rightarrow> person \<Rightarrow> steuerwelt \<Rightarrow> steuerwelt\<close> where
  \<open>steuerwps p1 p2 (Steuerwelt besitz) = Steuerwelt (swap p1 p2 besitz)\<close>
(*>*)

text\<open>Die Steuerlast sagt, wie viel Steuern gezahlt werden.\<close>
fun steuerlast :: \<open>person \<Rightarrow> steuerwelt handlung \<Rightarrow> int\<close> where
  \<open>steuerlast p (Handlung vor nach) = ((get_einkommen vor) p) - ((get_einkommen nach) p)\<close>

text\<open>Das Einkommen vor Steuer wird brutto genannt.\<close>
fun brutto :: \<open>person \<Rightarrow> steuerwelt handlung \<Rightarrow> int\<close> where
  \<open>brutto p (Handlung vor nach) = (get_einkommen vor) p\<close>
text\<open>Das Einkommen nach Steuer wird netto genannt.\<close>
fun netto :: \<open>person \<Rightarrow> steuerwelt handlung \<Rightarrow> int\<close> where
  \<open>netto p (Handlung vor nach) = (get_einkommen nach) p\<close>

text\<open>Beispiele\<close>
beispiel \<open>steuerlast Alice (Handlung (Steuerwelt (\<euro>(Alice:=8))) (Steuerwelt (\<euro>(Alice:=5)))) = 3\<close>
  by eval
beispiel \<open>steuerlast Alice (Handlung (Steuerwelt (\<euro>(Alice:=8))) (Steuerwelt (\<euro>(Alice:=0)))) = 8\<close>
  by eval
beispiel \<open>steuerlast Bob   (Handlung (Steuerwelt (\<euro>(Alice:=8))) (Steuerwelt (\<euro>(Alice:=5)))) = 0\<close>
  by eval
beispiel \<open>steuerlast Alice (Handlung (Steuerwelt (\<euro>(Alice:=-3))) (Steuerwelt (\<euro>(Alice:=-4)))) = 1\<close>
  by eval
beispiel \<open>steuerlast Alice (Handlung (Steuerwelt (\<euro>(Alice:=1))) (Steuerwelt (\<euro>(Alice:=-1)))) = 2\<close>
  by eval

text\<open>Folgende Menge beinhaltet alle Personen die mehr verdienen als ich.\<close>
fun mehrverdiener :: \<open>person \<Rightarrow> steuerwelt handlung \<Rightarrow> person set\<close> where
  \<open>mehrverdiener ich (Handlung vor nach) = {p. (get_einkommen vor) p \<ge> (get_einkommen vor) ich}\<close>

beispiel \<open>mehrverdiener Alice
        (Handlung (Steuerwelt (\<euro>(Alice:=8, Bob:=12, Eve:=7))) (Steuerwelt (\<euro>(Alice:=5))))
       = {Alice, Bob}\<close> by eval

(*<*)
lemma mehrverdiener_betrachtet_nur_ausgangszustand:
  \<open>mehrverdiener p (handeln p' welt h) = mehrverdiener p (Handlung welt welt)\<close>
  by (metis handlung.collapse mehrverdiener.simps vorher_handeln)
(*>*)

text\<open>Folgende Maxime versucht Steuergerechtigkeit festzuschreiben:\<close>
(*TODO: eine andere test maxime sollte sein,
dass ich mehr steuern zu zahlen hab als geringerverdiener.*)
definition maxime_steuern :: \<open>(person, steuerwelt) maxime\<close> where
  \<open>maxime_steuern \<equiv> Maxime
      (\<lambda>ich handlung.
           (\<forall>p\<in>mehrverdiener ich handlung.
                steuerlast ich handlung \<le> steuerlast p handlung)
          \<and> (\<forall>p\<in>mehrverdiener ich handlung.
                netto ich handlung \<le> netto p handlung)
          )\<close>
  (*do we also need: \<and> steuerlast ich handlung \<le> brutto ich handlung*)

(*okay_MaximeConj sagt ich koennte auch MaximeConj nehmen.
TODO: jeder submaxime eine eigene Definition geben und per MaximeConj kombinieren!*)

(*Ist das uberhaupt eine gute Maxime?
Angenommen ich bin der Spitzenverdiener.
Dann ist die Handlungsabsicht "ich zahle 10 Steuer" gueltig nach der maxime, da "mehrverdiener ich handlung={}".
Diese Handlung kann ich aber nicht auf andere projezieren, da
  * einerseits waere es unmoralisch so viel steuer von geringverdienern zu fordern
  * andererseits erfuelt die handlung die maxime nicht fuer jeden der nicht spitzenverdiener ist.
    Die Handlung die die maxime erfuellen wuerde waere "JEDER zahle 10 Steuer".
*)

(*<*)
fun delta_steuerwelt :: \<open>(steuerwelt, person, int) delta\<close> where
  \<open>delta_steuerwelt (Handlung vor nach) =
      Aenderung.delta_num_fun (Handlung (get_einkommen vor) (get_einkommen nach))\<close>

(*(Maxime
      (\<lambda>ich handlung.
           (\<forall>p\<in>mehrverdiener ich handlung.
                steuerlast ich handlung \<le> steuerlast p handlung)))*)

lemma \<open>wpsm_kommutiert (Maxime
      (\<lambda>ich handlung.
           (\<forall>p\<in>mehrverdiener ich handlung.
                steuerlast ich handlung \<le> steuerlast p handlung))) steuerwps welt\<close>
(*
Nitpick found a counterexample:
  Free variable:
    welt = Steuerwelt ((\<lambda>x. _)(p\<^sub>1 := 1, p\<^sub>2 := 1, p\<^sub>3 := 2, p\<^sub>4 := 2))
  Skolem constants:
    ??.wpsm_kommutiert.h =
      (\<lambda>x. _)
      (p\<^sub>1 := (\<lambda>x. _)
         (Steuerwelt ((\<lambda>x. _)(p\<^sub>1 := - 1, p\<^sub>2 := 2, p\<^sub>3 := 1, p\<^sub>4 := - 1)) :=
            Steuerwelt ((\<lambda>x. _)(p\<^sub>1 := 1, p\<^sub>2 := 1, p\<^sub>3 := 2, p\<^sub>4 := 2)),
          Steuerwelt ((\<lambda>x. _)(p\<^sub>1 := 0, p\<^sub>2 := 2, p\<^sub>3 := 0, p\<^sub>4 := - 1)) :=
            Steuerwelt ((\<lambda>x. _)(p\<^sub>1 := 1, p\<^sub>2 := 1, p\<^sub>3 := 2, p\<^sub>4 := 2)),
          Steuerwelt ((\<lambda>x. _)(p\<^sub>1 := 1, p\<^sub>2 := 1, p\<^sub>3 := 2, p\<^sub>4 := 2)) :=
            Steuerwelt ((\<lambda>x. _)(p\<^sub>1 := 1, p\<^sub>2 := 1, p\<^sub>3 := 2, p\<^sub>4 := 2)),
          Steuerwelt ((\<lambda>x. _)(p\<^sub>1 := 2, p\<^sub>2 := 2, p\<^sub>3 := 1, p\<^sub>4 := 0)) :=
            Steuerwelt ((\<lambda>x. _)(p\<^sub>1 := 1, p\<^sub>2 := 1, p\<^sub>3 := 2, p\<^sub>4 := 2))),
       p\<^sub>2 := (\<lambda>x. _)
         (Steuerwelt ((\<lambda>x. _)(p\<^sub>1 := - 1, p\<^sub>2 := 2, p\<^sub>3 := 1, p\<^sub>4 := - 1)) :=
            Steuerwelt ((\<lambda>x. _)(p\<^sub>1 := 2, p\<^sub>2 := 2, p\<^sub>3 := 1, p\<^sub>4 := 0)),
          Steuerwelt ((\<lambda>x. _)(p\<^sub>1 := 0, p\<^sub>2 := 2, p\<^sub>3 := 0, p\<^sub>4 := - 1)) :=
            Steuerwelt ((\<lambda>x. _)(p\<^sub>1 := - 1, p\<^sub>2 := 2, p\<^sub>3 := 1, p\<^sub>4 := - 1)),
          Steuerwelt ((\<lambda>x. _)(p\<^sub>1 := 1, p\<^sub>2 := 1, p\<^sub>3 := 2, p\<^sub>4 := 2)) :=
            Steuerwelt ((\<lambda>x. _)(p\<^sub>1 := - 1, p\<^sub>2 := 2, p\<^sub>3 := 1, p\<^sub>4 := - 1)),
          Steuerwelt ((\<lambda>x. _)(p\<^sub>1 := 2, p\<^sub>2 := 2, p\<^sub>3 := 1, p\<^sub>4 := 0)) :=
            Steuerwelt ((\<lambda>x. _)(p\<^sub>1 := 0, p\<^sub>2 := 2, p\<^sub>3 := 0, p\<^sub>4 := - 1))),
       p\<^sub>3 := (\<lambda>x. _)
         (Steuerwelt ((\<lambda>x. _)(p\<^sub>1 := - 1, p\<^sub>2 := 2, p\<^sub>3 := 1, p\<^sub>4 := - 1)) :=
            Steuerwelt ((\<lambda>x. _)(p\<^sub>1 := 2, p\<^sub>2 := 2, p\<^sub>3 := 1, p\<^sub>4 := 0)),
          Steuerwelt ((\<lambda>x. _)(p\<^sub>1 := 0, p\<^sub>2 := 2, p\<^sub>3 := 0, p\<^sub>4 := - 1)) :=
            Steuerwelt ((\<lambda>x. _)(p\<^sub>1 := 2, p\<^sub>2 := 2, p\<^sub>3 := 1, p\<^sub>4 := 0)),
          Steuerwelt ((\<lambda>x. _)(p\<^sub>1 := 1, p\<^sub>2 := 1, p\<^sub>3 := 2, p\<^sub>4 := 2)) :=
            Steuerwelt ((\<lambda>x. _)(p\<^sub>1 := 0, p\<^sub>2 := 2, p\<^sub>3 := 0, p\<^sub>4 := - 1)),
          Steuerwelt ((\<lambda>x. _)(p\<^sub>1 := 2, p\<^sub>2 := 2, p\<^sub>3 := 1, p\<^sub>4 := 0)) :=
            Steuerwelt ((\<lambda>x. _)(p\<^sub>1 := 1, p\<^sub>2 := 1, p\<^sub>3 := 2, p\<^sub>4 := 2))),
       p\<^sub>4 := (\<lambda>x. _)
         (Steuerwelt ((\<lambda>x. _)(p\<^sub>1 := - 1, p\<^sub>2 := 2, p\<^sub>3 := 1, p\<^sub>4 := - 1)) :=
            Steuerwelt ((\<lambda>x. _)(p\<^sub>1 := 2, p\<^sub>2 := 2, p\<^sub>3 := 1, p\<^sub>4 := 0)),
          Steuerwelt ((\<lambda>x. _)(p\<^sub>1 := 0, p\<^sub>2 := 2, p\<^sub>3 := 0, p\<^sub>4 := - 1)) :=
            Steuerwelt ((\<lambda>x. _)(p\<^sub>1 := - 1, p\<^sub>2 := 2, p\<^sub>3 := 1, p\<^sub>4 := - 1)),
          Steuerwelt ((\<lambda>x. _)(p\<^sub>1 := 1, p\<^sub>2 := 1, p\<^sub>3 := 2, p\<^sub>4 := 2)) :=
            Steuerwelt ((\<lambda>x. _)(p\<^sub>1 := 1, p\<^sub>2 := 1, p\<^sub>3 := 2, p\<^sub>4 := 2)),
          Steuerwelt ((\<lambda>x. _)(p\<^sub>1 := 2, p\<^sub>2 := 2, p\<^sub>3 := 1, p\<^sub>4 := 0)) :=
            Steuerwelt ((\<lambda>x. _)(p\<^sub>1 := 0, p\<^sub>2 := 2, p\<^sub>3 := 0, p\<^sub>4 := - 1))))
    ??.wpsm_kommutiert.p1 = p\<^sub>4
    ??.wpsm_kommutiert.p2 = p\<^sub>3
*)
  oops

lemma wfh_steuerberechnung_jeder_zahlt_int:
  \<open>ha = Handlungsabsicht (\<lambda>ich w. Some (Steuerwelt ((\<lambda>e. e - steuerberechnung e) \<circ> (get_einkommen w))))
    \<Longrightarrow> wohlgeformte_handlungsabsicht steuerwps welt ha\<close>
  apply(cases \<open>welt\<close>, rename_tac eink, simp)
  apply(simp add: wohlgeformte_handlungsabsicht.simps comp_def fun_eq_iff)
  apply(safe)
  apply(rename_tac eink p1 p2 p)
  by(rule swap_cases, simp_all add: swap_a swap_b swap_nothing)
(*>*)

text\<open>Wenn die Steuerfunktion monoton ist,
dann können wir auch einen sehr eingeschränkten kategorischen Imperativ zeigen.\<close>
lemma katimp_auf_handlungsabsicht_monoton:
  \<open>(\<And>e1 e2. e1 \<le> e2 \<Longrightarrow> steuerberechnung e1 \<le> steuerberechnung e2) \<Longrightarrow>
  ha = Handlungsabsicht
          (\<lambda>ich w. Some (Steuerwelt ((\<lambda>e. e - steuerberechnung e) \<circ> (get_einkommen w)))) \<Longrightarrow>
  kategorischer_imperativ_auf ha welt
    (Maxime
      (\<lambda>ich handlung.
           (\<forall>p\<in>mehrverdiener ich handlung.
                steuerlast ich handlung \<le> steuerlast p handlung)))\<close>
  apply(cases \<open>welt\<close>, rename_tac eink, simp)
  apply(rule kategorischer_imperativ_aufI, rename_tac eink ich p1 p2)
  apply(simp add: handeln_def nachher_handeln.simps)
  done

subsection\<open>Beispiel: Keiner Zahlt Steuern\<close>

text\<open>Die Maxime ist im Beispiel erfüllt, da wir immer nur kleiner-gleich fordern!\<close>
beispiel \<open>moralisch (Steuerwelt (\<euro>(Alice:=8, Bob:=3, Eve:= 5)))
                  maxime_steuern (Handlungsabsicht (\<lambda>ich welt. Some welt))\<close> by eval

subsection\<open>Beispiel: Ich zahle 1 Steuer\<close>
text\<open>Das funktioniert nicht:\<close>
definition \<open>ich_zahle_1_steuer ich welt \<equiv>
  Some (Steuerwelt \<lbrakk>(get_einkommen welt)(ich -= 1)\<rbrakk>)\<close>
beispiel \<open>\<not> moralisch (Steuerwelt (\<euro>(Alice:=8, Bob:=3, Eve:= 5)))
                    maxime_steuern (Handlungsabsicht ich_zahle_1_steuer)\<close> by eval

text\<open>Denn jeder muss Steuer zahlen!
Ich finde es super spannend, dass hier faktisch ein Gleichbehandlungsgrundsatz rausfällt,
ohne dass wir so Etwas jemals explizit gefordert haben.
\<close>

subsection\<open>Beiepiel: Jeder zahle 1 Steuer\<close>
text\<open>Jeder muss steuern zahlen: funktioniert.

Das \<^term>\<open>ich\<close> wird gar nicht verwendet, da jeder Steuern zahlt.\<close>
definition \<open>jeder_zahle_1_steuer ich welt \<equiv>
  Some (Steuerwelt ((\<lambda>e. e - 1) \<circ> (get_einkommen welt)))\<close>
beispiel \<open>moralisch (Steuerwelt (\<euro>(Alice:=8, Bob:=3, Eve:= 5)))
                 maxime_steuern (Handlungsabsicht jeder_zahle_1_steuer)\<close> by eval

subsection\<open>Beispiel: Vereinfachtes Deutsches Steuersystem\<close>
text\<open>Jetzt kommt die Steuern.thy ins Spiel.\<close>

definition jeder_zahlt :: \<open>(nat \<Rightarrow> nat) \<Rightarrow> 'a \<Rightarrow> steuerwelt \<Rightarrow> steuerwelt\<close> where
  \<open>jeder_zahlt steuerberechnung ich welt \<equiv>
    Steuerwelt ((\<lambda>e. e - steuerberechnung e) \<circ> nat \<circ> (get_einkommen welt))\<close>

(*<*)
lemma jeder_zahlt_ignoriert_person:
  \<open>jeder_zahlt steuersystem_impl p w = jeder_zahlt steuersystem_impl p' w\<close>
  by(simp add: jeder_zahlt_def)
(*>*)

definition \<open>jeder_zahlt_einkommenssteuer p w \<equiv> Some (jeder_zahlt einkommenssteuer p w)\<close>

text\<open>Bei dem geringen Einkommen der \<^term>\<open>Steuerwelt (\<euro>(Alice:=8, Bob:=3, Eve:= 5))\<close> zahlt keiner Steuern.\<close>

beispiel \<open>ist_noop
  (handeln Alice(Steuerwelt (\<euro>(Alice:=8, Bob:=3, Eve:= 5)))
             (Handlungsabsicht jeder_zahlt_einkommenssteuer))\<close> by eval

beispiel \<open>moralisch (Steuerwelt (\<euro>(Alice:=8, Bob:=3, Eve:= 5)))
                  maxime_steuern (Handlungsabsicht jeder_zahlt_einkommenssteuer)\<close> by eval

text\<open>Für höhere Einkommen erhalten wir plausible Werte und niemand rutscht ins negative:\<close>
beispiel \<open>delta_steuerwelt
      (handeln
      Alice (Steuerwelt (\<euro>(Alice:=10000, Bob:=14000, Eve:= 20000)))
      (Handlungsabsicht jeder_zahlt_einkommenssteuer))
  = [Verliert Bob 511, Verliert Eve 1857]\<close> by eval
beispiel \<open>moralisch
  (Steuerwelt (\<euro>(Alice:=10000, Bob:=14000, Eve:= 20000)))
  maxime_steuern
  (Handlungsabsicht jeder_zahlt_einkommenssteuer)\<close> by eval

text\<open>Unser Beispiel erfüllt auch den kategorischen Imperativ.\<close>
beispiel \<open>erzeuge_beispiel
    steuerwps (Steuerwelt (\<euro>(Alice:=10000, Bob:=14000, Eve:= 20000)))
    [Handlungsabsicht jeder_zahlt_einkommenssteuer]
    maxime_steuern
  =
  Some
    \<lparr>
     bsp_erfuellte_maxime = True,
     bsp_erlaubte_handlungen = [Handlungsabsicht jeder_zahlt_einkommenssteuer],
     bsp_verbotene_handlungen = [],
     bsp_uneindeutige_handlungen = []
    \<rparr>\<close>
  by beispiel_tac

subsection\<open>Vereinfachtes Deutsches Steuersystem vs. die Steuermaxime\<close>
text\<open>Die Anforderungen für ein \<^locale>\<open>steuersystem\<close> und die \<^const>\<open>maxime_steuern\<close> sind vereinbar.\<close>
lemma steuersystem_imp_maxime:
  \<open>steuersystem steuersystem_impl \<Longrightarrow>
        (\<forall>welt. moralisch welt
                maxime_steuern
                (Handlungsabsicht (\<lambda>p w. Some (jeder_zahlt steuersystem_impl p w))))\<close>
   apply(simp add: maxime_steuern_def moralisch_unfold handeln_def nachher_handeln.simps)
   apply(simp add: jeder_zahlt_def bevoelkerung_def)
   apply(intro allI impI conjI)
   apply(rename_tac welt p1 p2)
   thm steuersystem.wer_hat_der_gibt
   apply(drule_tac
        einkommen_b=\<open>nat (get_einkommen welt p1)\<close> and
        einkommen_a=\<open>nat (get_einkommen welt p2)\<close> in steuersystem.wer_hat_der_gibt)
    apply(simp; fail)
   apply(simp; fail)
  apply(rename_tac welt p1 p2)
  apply(drule_tac
        einkommen_b=\<open>nat (get_einkommen welt p1)\<close> and
        einkommen_a=\<open>nat (get_einkommen welt p2)\<close> in steuersystem.leistung_lohnt_sich)
   apply(simp; fail)
  by (simp add: steuer_defs.netto_def)

(*<*)
text\<open>Danke ihr nats. Macht also keinen Sinn das als Annahme in die Maxime zu packen....\<close>
lemma steuern_kleiner_einkommen_nat:
      \<open>steuerlast ich (Handlung welt (jeder_zahlt steuersystem_impl ich welt))
         \<le> brutto ich (Handlung welt (jeder_zahlt steuersystem_impl ich welt))\<close>
  apply(simp del: steuerlast.simps)
  apply(subst steuerlast.simps)
  apply(simp add: jeder_zahlt_def)
  done
(*>*)

text\<open>Mit genug zusätzlichen Annahmen gilt auch die Rückrichtung:\<close>
lemma maxime_imp_steuersystem:
  \<open>\<forall>einkommen. steuersystem_impl einkommen \<le> einkommen \<Longrightarrow>
   \<forall>einkommen. einkommen \<le> 9888 \<longrightarrow> steuersystem_impl einkommen = 0 \<Longrightarrow>
   \<forall>welt. moralisch welt maxime_steuern
             (Handlungsabsicht (\<lambda>p w. Some (jeder_zahlt steuersystem_impl p w)))
    \<Longrightarrow> steuersystem steuersystem_impl\<close>
proof
  fix einkommen_b einkommen_a :: \<open>nat\<close>
  assume m: \<open>\<forall>welt. moralisch welt maxime_steuern
                      (Handlungsabsicht (\<lambda>p w. Some (jeder_zahlt steuersystem_impl p w)))\<close>
     and a: \<open>einkommen_b \<le> einkommen_a\<close>
     and bezahlbar: \<open>\<forall>einkommen. steuersystem_impl einkommen \<le> einkommen\<close>
  from m have m':
    \<open>get_einkommen welt pA \<le> get_einkommen welt pB \<Longrightarrow>
       get_einkommen welt pA -
             int (nat (get_einkommen welt pA) - steuersystem_impl (nat (get_einkommen welt pA)))
             \<le> get_einkommen welt pB -
                int (nat (get_einkommen welt pB) - steuersystem_impl (nat (get_einkommen welt pB)))\<close>
    for welt :: \<open>steuerwelt\<close> and pA pB :: \<open>person\<close>
    by(simp add: handeln_def nachher_handeln.simps
                 maxime_steuern_def moralisch_unfold jeder_zahlt_def bevoelkerung_def)
  from m'[where welt=\<open>Steuerwelt (\<lambda>p. if p = Bob then einkommen_b else einkommen_a)\<close>
                and pA=\<open>Bob\<close> and pB=\<open>Alice\<close>] a
  have almost:
    \<open>int einkommen_b - int (einkommen_b - steuersystem_impl einkommen_b)
      \<le> int einkommen_a - int (einkommen_a - steuersystem_impl einkommen_a)\<close>
    by simp
  from bezahlbar have \<open>steuersystem_impl einkommen_b \<le> einkommen_b\<close> by simp
  from this almost show \<open>steuersystem_impl einkommen_b \<le> steuersystem_impl einkommen_a\<close>
    by simp
next
  fix einkommen_b einkommen_a :: \<open>nat\<close>
  assume m: \<open>\<forall>welt. moralisch welt maxime_steuern
                        (Handlungsabsicht (\<lambda>p w. Some (jeder_zahlt steuersystem_impl p w)))\<close>
     and a: \<open>einkommen_b \<le> einkommen_a\<close>
  from m have m':
    \<open>get_einkommen welt pA \<le> get_einkommen welt pB \<Longrightarrow>
       nat (get_einkommen welt pA) - steuersystem_impl (nat (get_einkommen welt pA))
       \<le> nat (get_einkommen welt pB) - steuersystem_impl (nat (get_einkommen welt pB))\<close>
    for welt :: \<open>steuerwelt\<close> and pA pB :: \<open>person\<close>
    by(simp add: handeln_def nachher_handeln.simps maxime_steuern_def moralisch_unfold
                 jeder_zahlt_def bevoelkerung_def)
  from m'[where welt=\<open>Steuerwelt (\<lambda>p. if p = Bob then einkommen_b else einkommen_a)\<close>
                and pA=\<open>Bob\<close> and pB=\<open>Alice\<close>] a
  have \<open>einkommen_b - steuersystem_impl einkommen_b \<le> einkommen_a - steuersystem_impl einkommen_a\<close>
    by simp
  from this show
    \<open>steuer_defs.netto steuersystem_impl einkommen_b
      \<le> steuer_defs.netto steuersystem_impl einkommen_a\<close>
    by(simp add: steuer_defs.netto_def)
next
  fix einkommen
  show \<open>\<forall>einkommen\<le>9888. steuersystem_impl einkommen = 0
        \<Longrightarrow> einkommen \<le> 9888 \<Longrightarrow> steuersystem_impl einkommen = 0\<close>
    by simp
qed

text\<open>
Dass die eine Richtung gilt (Maxime impliziert \<^const>\<open>steuersystem\<close>),
die andere Richtung (\<^const>\<open>steuersystem\<close> impliziert Maxime) jedoch nicht ohne weiter Annahmen,
stimmt auch mit Russels Beobachtung überein:
"Kants Maxime [das allgemeine Konzept, nicht meine Implementierung]
scheint tatsächlich ein notwendiges, jedoch nicht \<^emph>\<open>ausreichendes\<close> Kriterium der Tugend zu geben"
@{cite russellphi}.
Insbesondere Russels Folgesatz freut mich, da er mir bestätigt, dass unsere extensionale
Betrachtung von Handlungen vielversprechend ist:
"Um ein ausreichendes Kriterium zu gewinnen, müßten wir Kants rein formalen Standpunkt aufgeben
und die Wirkung der Handlungen in Betracht ziehen" @{cite russellphi}.
\<close>

text\<open>
Für jedes \<^term_type>\<open>steuersystem_impl :: nat \<Rightarrow> nat\<close>,
mit zwei weiteren Annahmen
gilt, dass \<^locale>\<open>steuersystem\<close> und \<^const>\<open>maxime_steuern\<close> in der \<^const>\<open>jeder_zahlt\<close> Implementierung
äquivalent sind.\<close>

theorem
  fixes steuersystem_impl :: \<open>nat \<Rightarrow> nat\<close>
  assumes steuer_kleiner_einkommen: \<open>\<forall>einkommen. steuersystem_impl einkommen \<le> einkommen\<close>
      and existenzminimum: \<open>\<forall>einkommen. einkommen \<le> 9888 \<longrightarrow> steuersystem_impl einkommen = 0\<close>
    shows
     \<open>(\<forall>welt. moralisch welt maxime_steuern
                (Handlungsabsicht (\<lambda>p w. Some (jeder_zahlt steuersystem_impl p w))))
      \<longleftrightarrow>
      steuersystem steuersystem_impl\<close>
  using steuersystem_imp_maxime maxime_imp_steuersystem
  using assms by blast

text\<open>Da jede Steuersystemimplementierung welche \<^locale>\<open>steuersystem\<close> erfüllt auch
moralisch ist (lemma @{thm [source] steuersystem_imp_maxime}),
erfüllt damit auch jedes solche System den kategorischen Imperativ.\<close>
corollary steuersystem_imp_kaptimp:
 \<open>steuersystem steuersystem_impl \<Longrightarrow>
     kategorischer_imperativ_auf
        (Handlungsabsicht (\<lambda>p w. Some (jeder_zahlt steuersystem_impl p w)))
        welt
        maxime_steuern\<close>
  apply(drule steuersystem_imp_maxime)
  by (simp add: kategorischer_imperativ_auf_def)

text\<open>Und daraus folgt, dass auch \<^const>\<open>jeder_zahlt_einkommenssteuer\<close>
den kategorischen Imperativ erfüllt.\<close>
corollary
 \<open>steuersystem steuersystem_impl \<Longrightarrow>
     kategorischer_imperativ_auf
        (Handlungsabsicht jeder_zahlt_einkommenssteuer)
        welt
        maxime_steuern\<close>
  unfolding jeder_zahlt_einkommenssteuer_def
  apply(rule steuersystem_imp_kaptimp)
  by (simp add: steuersystem_axioms)

end


(*  Title:      Containers/RBT_ext.thy
    Author:     Andreas Lochbihler, KIT *)

theory RBT_ext
imports
  "HOL-Library.RBT_Impl"
  Containers_Auxiliary
  List_Fusion
begin

section \<open>More on red-black trees\<close>

subsection \<open>More lemmas\<close>

context linorder begin

lemma is_rbt_fold_rbt_insert_impl:
  "is_rbt t \<Longrightarrow> is_rbt (RBT_Impl.fold rbt_insert t' t)"
by(simp add: rbt_insert_def is_rbt_fold_rbt_insertwk)

lemma rbt_sorted_fold_insert: "rbt_sorted t \<Longrightarrow> rbt_sorted (RBT_Impl.fold rbt_insert t' t)"
by(induct t' arbitrary: t)(simp_all add: rbt_insert_rbt_sorted)

lemma rbt_lookup_rbt_insert': "rbt_sorted t \<Longrightarrow> rbt_lookup (rbt_insert k v t) = rbt_lookup t(k \<mapsto> v)"
by(simp add: rbt_insert_def rbt_lookup_rbt_insertwk fun_eq_iff split: option.split)

lemma rbt_lookup_fold_rbt_insert_impl:
  "rbt_sorted t2 \<Longrightarrow>
  rbt_lookup (RBT_Impl.fold rbt_insert t1 t2) = rbt_lookup t2 ++ map_of (rev (RBT_Impl.entries t1))"
proof(induction t1 arbitrary: t2)
  case Empty thus ?case by simp
next
  case (Branch c l x k r)
  show ?case using Branch.prems
    by(simp add: map_add_def Branch.IH rbt_insert_rbt_sorted rbt_sorted_fold_insert rbt_lookup_rbt_insert' fun_eq_iff split: option.split)
qed

end

subsection \<open>Build the cross product of two RBTs\<close>

context fixes f :: "'a \<Rightarrow> 'b \<Rightarrow> 'c \<Rightarrow> 'd \<Rightarrow> 'e" begin

definition alist_product :: "('a \<times> 'b) list \<Rightarrow> ('c \<times> 'd) list \<Rightarrow> (('a \<times> 'c) \<times> 'e) list"
where "alist_product xs ys = concat (map (\<lambda>(a, b). map (\<lambda>(c, d). ((a, c), f a b c d)) ys) xs)"

lemma alist_product_simps [simp]:
  "alist_product [] ys = []"
  "alist_product xs [] = []"
  "alist_product ((a, b) # xs) ys = map (\<lambda>(c, d). ((a, c), f a b c d)) ys @ alist_product xs ys"
by(simp_all add: alist_product_def)

lemma append_alist_product_conv_fold:
  "zs @ alist_product xs ys = rev (fold (\<lambda>(a, b). fold (\<lambda>(c, d) rest. ((a, c), f a b c d) # rest) ys) xs (rev zs))"
proof(induction xs arbitrary: zs)
  case Nil thus ?case by simp
next
  case (Cons x xs)
  obtain a b where x: "x = (a, b)" by(cases x)
  have "\<And>zs. fold (\<lambda>(c, d). (#) ((a, c), f a b c d)) ys zs =
    rev (map (\<lambda>(c, d). ((a, c), f a b c d)) ys) @ zs"
    by(induct ys) auto
  with Cons.IH[of "zs @ map (\<lambda>(c, d). ((a, c), f a b c d)) ys"] x
  show ?case by simp
qed

lemma set_alist_product:
  "set (alist_product xs ys) =
  (\<lambda>((a, b), (c, d)). ((a, c), f a b c d)) ` (set xs \<times> set ys)"
by(auto 4 3 simp add: alist_product_def intro: rev_image_eqI rev_bexI)

lemma distinct_alist_product:
  "\<lbrakk> distinct (map fst xs); distinct (map fst ys) \<rbrakk>
  \<Longrightarrow> distinct (map fst (alist_product xs ys))"
proof(induct xs)
  case Nil thus ?case by simp
next
  case (Cons x xs)
  obtain a b where x: "x = (a, b)" by(cases x)
  have "distinct (map (fst \<circ> (\<lambda>(c, d). ((a, c), f a b c d))) ys)"
    using \<open>distinct (map fst ys)\<close> by(induct ys)(auto intro: rev_image_eqI)
  thus ?case using Cons x by(auto simp add: set_alist_product intro: rev_image_eqI)
qed

lemma map_of_alist_product:
  "map_of (alist_product xs ys) (a, c) =
  (case map_of xs a of None \<Rightarrow> None
   | Some b \<Rightarrow> map_option (f a b c) (map_of ys c))"
proof(induction xs)
  case Nil thus ?case by simp
next
  case (Cons x xs)
  obtain a b where x: "x = (a, b)" by (cases x)
  let ?map = "map (\<lambda>(c, d). ((a, c), f a b c d)) ys"
  have "map_of ?map (a, c) = map_option (f a b c) (map_of ys c)"
    by(induct ys) auto
  moreover {
    fix a' assume "a' \<noteq> a"
    hence "map_of ?map (a', c) = None"
      by(induct ys) auto }
  ultimately show ?case using x Cons.IH
    by(auto simp add: map_add_def split: option.split)
qed

definition rbt_product :: "('a, 'b) rbt \<Rightarrow> ('c, 'd) rbt \<Rightarrow> ('a \<times> 'c, 'e) rbt"
where
  "rbt_product rbt1 rbt2 = rbtreeify (alist_product (RBT_Impl.entries rbt1) (RBT_Impl.entries rbt2))"

lemma rbt_product_code [code]:
  "rbt_product rbt1 rbt2 =
   rbtreeify (rev (RBT_Impl.fold (\<lambda>a b. RBT_Impl.fold (\<lambda>c d rest. ((a, c), f a b c d) # rest) rbt2) rbt1 []))"
unfolding rbt_product_def alist_product_code RBT_Impl.fold_def ..

end

context
  fixes leq_a :: "'a \<Rightarrow> 'a \<Rightarrow> bool" (infix "\<sqsubseteq>\<^sub>a" 50)
  and less_a :: "'a \<Rightarrow> 'a \<Rightarrow> bool" (infix "\<sqsubset>\<^sub>a" 50)
  and leq_b :: "'b \<Rightarrow> 'b \<Rightarrow> bool" (infix "\<sqsubseteq>\<^sub>b" 50)
  and less_b :: "'b \<Rightarrow> 'b \<Rightarrow> bool" (infix "\<sqsubset>\<^sub>b" 50)
  assumes lin_a: "class.linorder leq_a less_a"
  and lin_b: "class.linorder leq_b less_b"
begin

abbreviation (input) less_eq_prod' :: "('a \<times> 'b) \<Rightarrow> ('a \<times> 'b) \<Rightarrow> bool" (infix "\<sqsubseteq>" 50)
where "less_eq_prod' \<equiv> less_eq_prod leq_a less_a leq_b"

abbreviation (input) less_prod' :: "('a \<times> 'b) \<Rightarrow> ('a \<times> 'b) \<Rightarrow> bool" (infix "\<sqsubset>" 50)
where "less_prod' \<equiv> less_prod leq_a less_a less_b"

lemmas linorder_prod = linorder_prod[OF lin_a lin_b]

lemma sorted_alist_product:
  assumes xs: "linorder.sorted leq_a (map fst xs)" "distinct (map fst xs)"
  and ys: "linorder.sorted (\<sqsubseteq>\<^sub>b) (map fst ys)"
  shows "linorder.sorted (\<sqsubseteq>) (map fst (alist_product f xs ys))"
proof -
  interpret a: linorder "(\<sqsubseteq>\<^sub>a)" "(\<sqsubset>\<^sub>a)" by(fact lin_a)

  note [simp] =
    linorder.sorted.simps(1)[OF linorder_prod] linorder.sorted.simps(2)[OF linorder_prod]
    linorder.sorted_append[OF linorder_prod]
    linorder.sorted.simps(2)[OF lin_b]

  show ?thesis using xs
  proof(induction xs)
    case Nil show ?case by simp
  next
    case (Cons x xs)
    obtain a b where x: "x = (a, b)" by(cases x)
    have "linorder.sorted (\<sqsubseteq>) (map fst (map (\<lambda>(c, d). ((a, c), f a b c d)) ys))"
      using ys by(induct ys) auto
    thus ?case using x Cons
      by(fastforce simp add: set_alist_product a.not_less dest: bspec a.antisym intro: rev_image_eqI)
  qed
qed

lemma is_rbt_rbt_product:
  "\<lbrakk> ord.is_rbt (\<sqsubset>\<^sub>a) rbt1; ord.is_rbt (\<sqsubset>\<^sub>b) rbt2 \<rbrakk>
  \<Longrightarrow> ord.is_rbt (\<sqsubset>) (rbt_product f rbt1 rbt2)"
unfolding rbt_product_def
by(blast intro: linorder.is_rbt_rbtreeify[OF linorder_prod] sorted_alist_product linorder.rbt_sorted_entries[OF lin_a] ord.is_rbt_rbt_sorted linorder.distinct_entries[OF lin_a] linorder.rbt_sorted_entries[OF lin_b] distinct_alist_product linorder.distinct_entries[OF lin_b])

lemma rbt_lookup_rbt_product:
  "\<lbrakk> ord.is_rbt (\<sqsubset>\<^sub>a) rbt1; ord.is_rbt (\<sqsubset>\<^sub>b) rbt2 \<rbrakk>
  \<Longrightarrow> ord.rbt_lookup (\<sqsubset>) (rbt_product f rbt1 rbt2) (a, c) =
     (case ord.rbt_lookup (\<sqsubset>\<^sub>a) rbt1 a of None \<Rightarrow> None
      | Some b \<Rightarrow> map_option (f a b c) (ord.rbt_lookup (\<sqsubset>\<^sub>b) rbt2 c))"
by(simp add: rbt_product_def linorder.rbt_lookup_rbtreeify[OF linorder_prod] linorder.is_rbt_rbtreeify[OF linorder_prod] sorted_alist_product linorder.rbt_sorted_entries[OF lin_a] ord.is_rbt_rbt_sorted linorder.distinct_entries[OF lin_a] linorder.rbt_sorted_entries[OF lin_b] distinct_alist_product linorder.distinct_entries[OF lin_b] map_of_alist_product linorder.map_of_entries[OF lin_a] linorder.map_of_entries[OF lin_b] cong: option.case_cong)

end

hide_const less_eq_prod' less_prod'

subsection \<open>Build an RBT where keys are paired with themselves\<close>

primrec RBT_Impl_diag :: "('a, 'b) rbt \<Rightarrow> ('a \<times> 'a, 'b) rbt"
where
  "RBT_Impl_diag rbt.Empty = rbt.Empty"
| "RBT_Impl_diag (rbt.Branch c l k v r) = rbt.Branch c (RBT_Impl_diag l) (k, k) v (RBT_Impl_diag r)"

lemma entries_RBT_Impl_diag:
  "RBT_Impl.entries (RBT_Impl_diag t) = map (\<lambda>(k, v). ((k, k), v)) (RBT_Impl.entries t)"
by(induct t) simp_all

lemma keys_RBT_Impl_diag:
  "RBT_Impl.keys (RBT_Impl_diag t) = map (\<lambda>k. (k, k)) (RBT_Impl.keys t)"
by(simp add: RBT_Impl.keys_def entries_RBT_Impl_diag split_beta)

lemma rbt_sorted_RBT_Impl_diag:
  "ord.rbt_sorted lt t \<Longrightarrow> ord.rbt_sorted (less_prod leq lt lt) (RBT_Impl_diag t)"
by(induct t)(auto simp add: ord.rbt_sorted.simps ord.rbt_less_prop ord.rbt_greater_prop keys_RBT_Impl_diag)

lemma bheight_RBT_Impl_diag:
  "bheight (RBT_Impl_diag t) = bheight t"
by(induct t) simp_all

lemma inv_RBT_Impl_diag:
  assumes "inv1 t" "inv2 t"
  shows "inv1 (RBT_Impl_diag t)" "inv2 (RBT_Impl_diag t)"
  and "color_of t = color.B \<Longrightarrow> color_of (RBT_Impl_diag t) = color.B"
using assms by(induct t)(auto simp add: bheight_RBT_Impl_diag)

lemma is_rbt_RBT_Impl_diag:
  "ord.is_rbt lt t \<Longrightarrow> ord.is_rbt (less_prod leq lt lt) (RBT_Impl_diag t)"
by(simp add: ord.is_rbt_def rbt_sorted_RBT_Impl_diag inv_RBT_Impl_diag)

lemma (in linorder) rbt_lookup_RBT_Impl_diag:
  "ord.rbt_lookup (less_prod (\<le>) (<) (<)) (RBT_Impl_diag t) =
  (\<lambda>(k, k'). if k = k' then ord.rbt_lookup (<) t k else None)"
by(induct t)(auto simp add: ord.rbt_lookup.simps fun_eq_iff)

subsection \<open>Folding and quantifiers over RBTs\<close>

definition RBT_Impl_fold1 :: "('a \<Rightarrow> 'a \<Rightarrow> 'a) \<Rightarrow> ('a, unit) RBT_Impl.rbt \<Rightarrow> 'a"
where "RBT_Impl_fold1 f rbt = fold f (tl (RBT_Impl.keys rbt)) (hd (RBT_Impl.keys rbt))"

lemma RBT_Impl_fold1_simps [simp, code]:
  "RBT_Impl_fold1 f rbt.Empty = undefined"
  "RBT_Impl_fold1 f (Branch c rbt.Empty k v r) = RBT_Impl.fold (\<lambda>k v. f k) r k"
  "RBT_Impl_fold1 f (Branch c (Branch c' l' k' v' r') k v r) =
   RBT_Impl.fold (\<lambda>k v. f k) r (f k (RBT_Impl_fold1 f (Branch c' l' k' v' r')))"
by(simp_all add: RBT_Impl_fold1_def RBT_Impl.keys_def fold_map RBT_Impl.fold_def split_def o_def tl_append hd_def split: list.split)

definition RBT_Impl_rbt_all :: "('a \<Rightarrow> 'b \<Rightarrow> bool) \<Rightarrow> ('a, 'b) rbt \<Rightarrow> bool"
where [code del]: "RBT_Impl_rbt_all P rbt = (\<forall>(k, v) \<in> set (RBT_Impl.entries rbt). P k v)"

lemma RBT_Impl_rbt_all_simps [simp, code]:
  "RBT_Impl_rbt_all P rbt.Empty \<longleftrightarrow> True"
  "RBT_Impl_rbt_all P (Branch c l k v r) \<longleftrightarrow> P k v \<and> RBT_Impl_rbt_all P l \<and> RBT_Impl_rbt_all P r"
by(auto simp add: RBT_Impl_rbt_all_def)

definition RBT_Impl_rbt_ex :: "('a \<Rightarrow> 'b \<Rightarrow> bool) \<Rightarrow> ('a, 'b) rbt \<Rightarrow> bool"
where [code del]: "RBT_Impl_rbt_ex P rbt = (\<exists>(k, v) \<in> set (RBT_Impl.entries rbt). P k v)"

lemma RBT_Impl_rbt_ex_simps [simp, code]:
  "RBT_Impl_rbt_ex P rbt.Empty \<longleftrightarrow> False"
  "RBT_Impl_rbt_ex P (Branch c l k v r) \<longleftrightarrow> P k v \<or> RBT_Impl_rbt_ex P l \<or> RBT_Impl_rbt_ex P r"
by(auto simp add: RBT_Impl_rbt_ex_def)

subsection \<open>List fusion for RBTs\<close>

type_synonym ('a, 'b, 'c) rbt_generator_state = "('c \<times> ('a, 'b) RBT_Impl.rbt) list \<times> ('a, 'b) RBT_Impl.rbt"

fun rbt_has_next :: "('a, 'b, 'c) rbt_generator_state \<Rightarrow> bool"
where
  "rbt_has_next ([], rbt.Empty) = False"
| "rbt_has_next _ = True"

fun rbt_keys_next :: "('a, 'b, 'a) rbt_generator_state \<Rightarrow> 'a \<times> ('a, 'b, 'a) rbt_generator_state"
where
  "rbt_keys_next ((k, t) # kts, rbt.Empty) = (k, kts, t)"
| "rbt_keys_next (kts, rbt.Branch c l k v r) = rbt_keys_next ((k, r) # kts, l)"

lemma rbt_generator_induct [case_names empty split shuffle]:
  assumes "P ([], rbt.Empty)"
  and "\<And>k t kts. P (kts, t) \<Longrightarrow> P ((k, t) # kts, rbt.Empty)"
  and "\<And>kts c l k v r. P ((f k v, r) # kts, l) \<Longrightarrow> P (kts, Branch c l k v r)"
  shows "P ktst"
using assms
apply(induction_schema)
apply pat_completeness
apply(relation "measure (\<lambda>(kts, t). size_list (\<lambda>(k, t). size_rbt (\<lambda>_. 1) (\<lambda>_. 1) t) kts + size_rbt (\<lambda>_. 1) (\<lambda>_. 1) t)")
apply simp_all
done

lemma terminates_rbt_keys_generator:
  "terminates (rbt_has_next, rbt_keys_next)"
proof
  fix ktst :: "('a \<times> ('a, 'b) rbt) list \<times> ('a, 'b) rbt"
  show "ktst \<in> terminates_on (rbt_has_next, rbt_keys_next)"
    by(induct ktst taking: "\<lambda>k _. k" rule: rbt_generator_induct)(auto 4 3 intro: terminates_on.intros elim: terminates_on.cases)
qed

lift_definition rbt_keys_generator :: "('a, ('a, 'b, 'a) rbt_generator_state) generator"
  is "(rbt_has_next, rbt_keys_next)"
by(rule terminates_rbt_keys_generator)

definition rbt_init :: "('a, 'b) rbt \<Rightarrow> ('a, 'b, 'c) rbt_generator_state"
where "rbt_init = Pair []"

lemma has_next_rbt_keys_generator [simp]:
  "list.has_next rbt_keys_generator = rbt_has_next"
by transfer simp

lemma next_rbt_keys_generator [simp]:
  "list.next rbt_keys_generator = rbt_keys_next"
by transfer simp

lemma unfoldr_rbt_keys_generator_aux:
  "list.unfoldr rbt_keys_generator (kts, t) =
  RBT_Impl.keys t @ concat (map (\<lambda>(k, t). k # RBT_Impl.keys t) kts)"
proof(induct "(kts, t)" arbitrary: kts t taking: "\<lambda>k _. k" rule: rbt_generator_induct)
  case empty thus ?case
    by(simp add: list.unfoldr.simps)
next
  case split thus ?case
    by(subst list.unfoldr.simps) simp
next
  case shuffle thus ?case
    by(subst list.unfoldr.simps)(subst (asm) list.unfoldr.simps, simp)
qed

corollary unfoldr_rbt_keys_generator:
  "list.unfoldr rbt_keys_generator (rbt_init t) = RBT_Impl.keys t"
by(simp add: unfoldr_rbt_keys_generator_aux rbt_init_def)

fun rbt_entries_next ::
  "('a, 'b, 'a \<times> 'b) rbt_generator_state \<Rightarrow> ('a \<times> 'b) \<times> ('a, 'b, 'a \<times> 'b) rbt_generator_state"
where
  "rbt_entries_next ((kv, t) # kts, rbt.Empty) = (kv, kts, t)"
| "rbt_entries_next (kts, rbt.Branch c l k v r) = rbt_entries_next (((k, v), r) # kts, l)"

lemma terminates_rbt_entries_generator:
  "terminates (rbt_has_next, rbt_entries_next)"
proof(rule terminatesI)
  fix ktst :: "('a, 'b, 'a \<times> 'b) rbt_generator_state"
  show "ktst \<in> terminates_on (rbt_has_next, rbt_entries_next)"
    by(induct ktst taking: Pair rule: rbt_generator_induct)(auto 4 3 intro: terminates_on.intros elim: terminates_on.cases)
qed

lift_definition rbt_entries_generator :: "('a \<times> 'b, ('a, 'b, 'a \<times> 'b) rbt_generator_state) generator"
  is "(rbt_has_next, rbt_entries_next)"
by(rule terminates_rbt_entries_generator)

lemma has_next_rbt_entries_generator [simp]:
  "list.has_next rbt_entries_generator = rbt_has_next"
by transfer simp

lemma next_rbt_entries_generator [simp]:
  "list.next rbt_entries_generator = rbt_entries_next"
by transfer simp

lemma unfoldr_rbt_entries_generator_aux:
  "list.unfoldr rbt_entries_generator (kts, t) =
  RBT_Impl.entries t @ concat (map (\<lambda>(k, t). k # RBT_Impl.entries t) kts)"
proof(induct "(kts, t)" arbitrary: kts t taking: Pair rule: rbt_generator_induct)
  case empty thus ?case
    by(simp add: list.unfoldr.simps)
next
  case split thus ?case
    by(subst list.unfoldr.simps) simp
next
  case shuffle thus ?case
    by(subst list.unfoldr.simps)(subst (asm) list.unfoldr.simps, simp)
qed

corollary unfoldr_rbt_entries_generator:
  "list.unfoldr rbt_entries_generator (rbt_init t) = RBT_Impl.entries t"
by(simp add: unfoldr_rbt_entries_generator_aux rbt_init_def)

end


(*  Title:      HOL/HOLCF/IOA/meta_theory/ShortExecutions.thy
    Author:     Olaf Müller
*)

theory ShortExecutions
imports Traces
begin

text {*
  Some properties about @{text "Cut ex"}, defined as follows:

  For every execution ex there is another shorter execution @{text "Cut ex"}
  that has the same trace as ex, but its schedule ends with an external action.
*}

definition
  oraclebuild :: "('a => bool) => 'a Seq -> 'a Seq -> 'a Seq" where
  "oraclebuild P = (fix$(LAM h s t. case t of
       nil => nil
    | x##xs =>
      (case x of
        UU => UU
      | Def y => (Takewhile (%x.~P x)$s)
                  @@ (y>>(h$(TL$(Dropwhile (%x.~ P x)$s))$xs))
      )
    ))"

definition
  Cut :: "('a => bool) => 'a Seq => 'a Seq" where
  "Cut P s = oraclebuild P$s$(Filter P$s)"

definition
  LastActExtsch :: "('a,'s)ioa => 'a Seq => bool" where
  "LastActExtsch A sch = (Cut (%x. x: ext A) sch = sch)"

(* LastActExtex      ::"('a,'s)ioa => ('a,'s) pairs  => bool"*)
(* LastActExtex_def:
  "LastActExtex A ex == LastActExtsch A (filter_act$ex)" *)

axiomatization where
  Cut_prefixcl_Finite: "Finite s ==> (? y. s = Cut P s @@ y)"

axiomatization where
  LastActExtsmall1: "LastActExtsch A sch ==> LastActExtsch A (TL$(Dropwhile P$sch))"

axiomatization where
  LastActExtsmall2: "[| Finite sch1; LastActExtsch A (sch1 @@ sch2) |] ==> LastActExtsch A sch2"

ML {*
fun thin_tac' j =
  rotate_tac (j - 1) THEN'
  etac thin_rl THEN'
  rotate_tac (~ (j - 1))
*}

subsection "oraclebuild rewrite rules"

lemma oraclebuild_unfold:
"oraclebuild P = (LAM s t. case t of
       nil => nil
    | x##xs =>
      (case x of
        UU => UU
      | Def y => (Takewhile (%a.~ P a)$s)
                  @@ (y>>(oraclebuild P$(TL$(Dropwhile (%a.~ P a)$s))$xs))
      )
    )"
apply (rule trans)
apply (rule fix_eq2)
apply (simp only: oraclebuild_def)
apply (rule beta_cfun)
apply simp
done

lemma oraclebuild_UU: "oraclebuild P$sch$UU = UU"
apply (subst oraclebuild_unfold)
apply simp
done

lemma oraclebuild_nil: "oraclebuild P$sch$nil = nil"
apply (subst oraclebuild_unfold)
apply simp
done

lemma oraclebuild_cons: "oraclebuild P$s$(x>>t) =
          (Takewhile (%a.~ P a)$s)
           @@ (x>>(oraclebuild P$(TL$(Dropwhile (%a.~ P a)$s))$t))"
apply (rule trans)
apply (subst oraclebuild_unfold)
apply (simp add: Consq_def)
apply (simp add: Consq_def)
done

subsection "Cut rewrite rules"

lemma Cut_nil:
"[| Forall (%a.~ P a) s; Finite s|]
            ==> Cut P s =nil"
apply (unfold Cut_def)
apply (subgoal_tac "Filter P$s = nil")
apply (simp (no_asm_simp) add: oraclebuild_nil)
apply (rule ForallQFilterPnil)
apply assumption+
done

lemma Cut_UU:
"[| Forall (%a.~ P a) s; ~Finite s|]
            ==> Cut P s =UU"
apply (unfold Cut_def)
apply (subgoal_tac "Filter P$s= UU")
apply (simp (no_asm_simp) add: oraclebuild_UU)
apply (rule ForallQFilterPUU)
apply assumption+
done

lemma Cut_Cons:
"[| P t;  Forall (%x.~ P x) ss; Finite ss|]
            ==> Cut P (ss @@ (t>> rs))
                 = ss @@ (t >> Cut P rs)"
apply (unfold Cut_def)
apply (simp add: ForallQFilterPnil oraclebuild_cons TakewhileConc DropwhileConc)
done

subsection "Cut lemmas for main theorem"

lemma FilterCut: "Filter P$s = Filter P$(Cut P s)"
apply (rule_tac A1 = "%x. True" and Q1 = "%x.~ P x" and x1 = "s" in take_lemma_induct [THEN mp])
prefer 3 apply (fast)
apply (case_tac "Finite s")
apply (simp add: Cut_nil ForallQFilterPnil)
apply (simp add: Cut_UU ForallQFilterPUU)
(* main case *)
apply (simp add: Cut_Cons ForallQFilterPnil)
done

lemma Cut_idemp: "Cut P (Cut P s) = (Cut P s)"
apply (rule_tac A1 = "%x. True" and Q1 = "%x.~ P x" and x1 = "s" in
  take_lemma_less_induct [THEN mp])
prefer 3 apply (fast)
apply (case_tac "Finite s")
apply (simp add: Cut_nil ForallQFilterPnil)
apply (simp add: Cut_UU ForallQFilterPUU)
(* main case *)
apply (simp add: Cut_Cons ForallQFilterPnil)
apply (rule take_reduction)
apply auto
done

lemma MapCut: "Map f$(Cut (P o f) s) = Cut P (Map f$s)"
apply (rule_tac A1 = "%x. True" and Q1 = "%x.~ P (f x) " and x1 = "s" in
  take_lemma_less_induct [THEN mp])
prefer 3 apply (fast)
apply (case_tac "Finite s")
apply (simp add: Cut_nil)
apply (rule Cut_nil [symmetric])
apply (simp add: ForallMap o_def)
apply (simp add: Map2Finite)
(* csae ~ Finite s *)
apply (simp add: Cut_UU)
apply (rule Cut_UU)
apply (simp add: ForallMap o_def)
apply (simp add: Map2Finite)
(* main case *)
apply (simp add: Cut_Cons MapConc ForallMap FiniteMap1 o_def)
apply (rule take_reduction)
apply auto
done

lemma Cut_prefixcl_nFinite [rule_format (no_asm)]: "~Finite s --> Cut P s << s"
apply (intro strip)
apply (rule take_lemma_less [THEN iffD1])
apply (intro strip)
apply (rule mp)
prefer 2 apply (assumption)
apply (tactic "thin_tac' 1 1")
apply (rule_tac x = "s" in spec)
apply (rule nat_less_induct)
apply (intro strip)
apply (rename_tac na n s)
apply (case_tac "Forall (%x. ~ P x) s")
apply (rule take_lemma_less [THEN iffD2, THEN spec])
apply (simp add: Cut_UU)
(* main case *)
apply (drule divide_Seq3)
apply (erule exE)+
apply (erule conjE)+
apply hypsubst
apply (simp add: Cut_Cons)
apply (rule take_reduction_less)
(* auto makes also reasoning about Finiteness of parts of s ! *)
apply auto
done

lemma execThruCut: "!!ex .is_exec_frag A (s,ex) ==> is_exec_frag A (s,Cut P ex)"
apply (case_tac "Finite ex")
apply (cut_tac s = "ex" and P = "P" in Cut_prefixcl_Finite)
apply assumption
apply (erule exE)
apply (rule exec_prefix2closed)
apply (erule_tac s = "ex" and t = "Cut P ex @@ y" in subst)
apply assumption
apply (erule exec_prefixclosed)
apply (erule Cut_prefixcl_nFinite)
done

subsection "Main Cut Theorem"

lemma exists_LastActExtsch:
 "[|sch : schedules A ; tr = Filter (%a. a:ext A)$sch|]
    ==> ? sch. sch : schedules A &
               tr = Filter (%a. a:ext A)$sch &
               LastActExtsch A sch"

apply (unfold schedules_def has_schedule_def)
apply auto
apply (rule_tac x = "filter_act$ (Cut (%a. fst a:ext A) (snd ex))" in exI)
apply (simp add: executions_def)
apply (tactic {* pair_tac @{context} "ex" 1 *})
apply auto
apply (rule_tac x = " (x,Cut (%a. fst a:ext A) y) " in exI)
apply (simp (no_asm_simp))

(* Subgoal 1: Lemma:  propagation of execution through Cut *)

apply (simp add: execThruCut)

(* Subgoal 2:  Lemma:  Filter P s = Filter P (Cut P s) *)

apply (simp (no_asm) add: filter_act_def)
apply (subgoal_tac "Map fst$ (Cut (%a. fst a: ext A) y) = Cut (%a. a:ext A) (Map fst$y) ")

apply (rule_tac [2] MapCut [unfolded o_def])
apply (simp add: FilterCut [symmetric])

(* Subgoal 3: Lemma: Cut idempotent  *)

apply (simp (no_asm) add: LastActExtsch_def filter_act_def)
apply (subgoal_tac "Map fst$ (Cut (%a. fst a: ext A) y) = Cut (%a. a:ext A) (Map fst$y) ")
apply (rule_tac [2] MapCut [unfolded o_def])
apply (simp add: Cut_idemp)
done

subsection "Further Cut lemmas"

lemma LastActExtimplnil:
  "[| LastActExtsch A sch; Filter (%x. x:ext A)$sch = nil |]
    ==> sch=nil"
apply (unfold LastActExtsch_def)
apply (drule FilternPnilForallP)
apply (erule conjE)
apply (drule Cut_nil)
apply assumption
apply simp
done

lemma LastActExtimplUU:
  "[| LastActExtsch A sch; Filter (%x. x:ext A)$sch = UU |]
    ==> sch=UU"
apply (unfold LastActExtsch_def)
apply (drule FilternPUUForallP)
apply (erule conjE)
apply (drule Cut_UU)
apply assumption
apply simp
done

end


section\<open>FLPSystem\<close>

text \<open>
  \file{FLPSystem} extends \file{AsynchronousSystem} with concepts of consensus
  and decisions. It develops a concept of non-uniformity regarding pending
  decision possibilities, where non-uniform configurations can always
  reach other non-uniform ones.
\<close>

theory FLPSystem
imports AsynchronousSystem ListUtilities
begin

subsection\<open>Locale for the FLP consensus setting\<close>

locale flpSystem =
  asynchronousSystem trans sends start
    for trans :: "'p \<Rightarrow> 's \<Rightarrow> 'v messageValue \<Rightarrow>'s"
    and sends :: "'p \<Rightarrow> 's \<Rightarrow> 'v messageValue \<Rightarrow> ('p, 'v) message multiset"
    and start :: "'p \<Rightarrow> 's" +
assumes finiteProcs: "finite Proc"
    and minimalProcs: "card Proc \<ge> 2"
    and finiteSends: "finite {v. v \<in># (sends p s m)}"
    and noInSends: "sends p s m <p2, inM v> = 0"
begin

subsection\<open>Decidedness and uniformity of configurations\<close>

abbreviation vDecided ::
  "bool \<Rightarrow> ('p, 'v, 's) configuration \<Rightarrow> bool"
where
  "vDecided v cfg \<equiv> initReachable cfg \<and> (<\<bottom>, outM v> \<in># msgs cfg)"

abbreviation decided ::
  "('p, 'v, 's) configuration \<Rightarrow> bool"
where
  "decided cfg \<equiv> (\<exists>v . vDecided v cfg)"

definition pSilDecVal ::
  "bool \<Rightarrow> 'p \<Rightarrow> ('p, 'v, 's) configuration \<Rightarrow> bool"
where
  "pSilDecVal v p c \<equiv> initReachable c \<and>
    (\<exists> c'::('p, 'v, 's) configuration . (withoutQReachable c {p} c')
    \<and> vDecided v c')"

abbreviation pSilentDecisionValues ::
  "'p \<Rightarrow> ('p, 'v, 's) configuration \<Rightarrow> bool set" ("val[_,_]")
where
  "val[p, c] \<equiv> {v. pSilDecVal v p c}"

definition vUniform ::
  "bool \<Rightarrow> ('p, 'v, 's) configuration \<Rightarrow> bool"
where
  "vUniform v c \<equiv> initReachable c \<and> (\<forall>p. val[p,c] = {v})"

abbreviation nonUniform ::
  "('p, 'v, 's) configuration \<Rightarrow> bool"
where
  "nonUniform c \<equiv> initReachable c \<and>
    \<not>(vUniform False c) \<and>
    \<not>(vUniform True c)"

subsection\<open>Agreement, validity, termination\<close>

text\<open>
  Völzer defines consensus in terms of the classical notions
  of agreement, validity, and termination. The proof then mostly applies a
  weakened notion of termination, which we refer to as ,,pseudo termination''.
\<close>

definition agreement ::
  "('p, 'v, 's) configuration \<Rightarrow> bool"
where
  "agreement c \<equiv>
    (\<forall>v1. (<\<bottom>, outM v1> \<in># msgs c)
      \<longrightarrow> (\<forall>v2. (<\<bottom>, outM v2> \<in># msgs c)
        \<longleftrightarrow> v2 = v1))"

definition agreementInit ::
  "('p, 'v, 's) configuration \<Rightarrow> ('p, 'v, 's) configuration \<Rightarrow> bool"
where
  "agreementInit i c \<equiv>
    initial i \<and> reachable i c \<longrightarrow>
      (\<forall>v1. (<\<bottom>, outM v1> \<in># msgs c)
        \<longrightarrow> (\<forall>v2. (<\<bottom>, outM v2> \<in># msgs c)
          \<longleftrightarrow> v2 = v1))"

definition validity ::
  "('p, 'v, 's) configuration \<Rightarrow> ('p, 'v, 's) configuration \<Rightarrow> bool"
where
  "validity i c \<equiv>
    initial i \<and> reachable i c \<longrightarrow>
      (\<forall>v. (<\<bottom>, outM v> \<in># msgs c)
        \<longrightarrow> (\<exists>p. (<p, inM v> \<in># msgs i)))"

text\<open>
  The termination concept which is implied by the concept of "pseudo-consensus"
  in the paper.
\<close>
definition terminationPseudo ::
  "nat \<Rightarrow> ('p, 'v, 's) configuration \<Rightarrow> 'p set \<Rightarrow> bool"
where
  "terminationPseudo t c Q \<equiv> ((initReachable c \<and> card Q + t \<ge> card Proc)
    \<longrightarrow> (\<exists>c'. qReachable c Q c' \<and> decided c'))"

subsection \<open>Propositions about decisions\<close>

text\<open>
  For every process \var{p} and every configuration that is reachable from an
  initial configuration (i.e. \isb{initReachable} \var{c}) we have
  $\var{val(p,c)} \neq \emptyset$.

  This follows directly from the definition of \var{val} and the definition of
  \isb{terminationPseudo}, which has to be assumed to ensure that there is a
  reachable configuration that is decided.

  \voelzer{Proposition 2(a)}
\<close>
lemma DecisionValuesExist:
fixes
  c :: "('p, 'v, 's) configuration" and
  p :: "'p"
assumes
  Termination: "\<And>cc Q . terminationPseudo 1 cc Q" and
  Reachable: "initReachable c"
shows
  "val[p,c] \<noteq> {}"
proof -
  from Termination
    have "(initReachable c \<and> card Proc \<le> card (UNIV - {p}) + 1)
      \<longrightarrow> (\<exists>c'. qReachable c (UNIV-{p}) c' \<and> initReachable c'
      \<and> (\<exists>v. 0 < msgs c' <\<bottom>, outM v>))"
    unfolding terminationPseudo_def by simp
  with Reachable minimalProcs finiteProcs
    have "\<exists>c'. qReachable c (UNIV - {p}) c' \<and> initReachable c'
    \<and> (\<exists>v. 0 < msgs c' <\<bottom>, outM v>)"
    unfolding terminationPseudo_def initReachable_def by simp
  thus ?thesis
    unfolding pSilDecVal_def
    using Reachable by auto
qed

text\<open>
  The lemma \isb{DecidedImpliesUniform} proves that every \isb{vDecided}
  configuration \var{c} is also \isb{vUniform}. Völzer claims that this
  follows directly from the definitions of \isb{vDecided} and \isb{vUniform}.
  But this is not quite enough: One must also assume \isb{terminationPseudo}
  and \isb{agreement} for all reachable configurations.

  \voelzer{Proposition 2(b)}
\<close>
lemma DecidedImpliesUniform:
fixes
  c :: "('p, 'v, 's) configuration" and
  v :: "bool"
assumes
  AllAgree: "\<forall> cfg . reachable c cfg \<longrightarrow> agreement cfg" and
  Termination: "\<And>cc Q . terminationPseudo 1 cc Q" and
  VDec: "vDecided v c"
shows
  "vUniform v c"
  using AllAgree VDec unfolding agreement_def vUniform_def pSilDecVal_def
proof simp
  assume
    Agree: "\<forall>cfg. reachable c cfg \<longrightarrow>
      (\<forall>v1. 0 < msgs cfg <\<bottom>, outM v1>
      \<longrightarrow> (\<forall>v2. (0 < msgs cfg <\<bottom>, outM v2>) = (v2 = v1)))" and
    vDec: "initReachable c \<and> 0 < msgs c <\<bottom>, outM v>"
  show
    "(\<forall>p. {v. \<exists>c'. qReachable c (Proc - {p}) c' \<and> initReachable c' \<and>
      0 < msgs c' <\<bottom>, outM v>} = {v})"
  proof clarify
    fix p
    have "val[p,c] \<noteq> {}" using Termination DecisionValuesExist vDec
      by simp
    hence NotEmpty: "{v. \<exists>c'. qReachable c (UNIV - {p}) c'
      \<and> initReachable c' \<and> 0 < msgs c' <\<bottom>, outM v>} \<noteq> {}"
      using pSilDecVal_def by simp
    have U: "\<forall> u . u \<in> {v. \<exists>c'. qReachable c (UNIV - {p}) c'
      \<and> initReachable c' \<and> 0 < msgs c' <\<bottom>, outM v>} \<longrightarrow> (u = v)"
    proof clarify
      fix u c'
      assume "qReachable c (UNIV - {p}) c'" "initReachable c'"
      hence Reach: "reachable c c'" using QReachImplReach by simp
      from VDec have Msg: "0 < msgs c <\<bottom>, outM v>" by simp
      from Reach NoOutMessageLoss have
        "msgs c <\<bottom>, outM v> \<le> msgs c' <\<bottom>, outM v>" by simp
      with Msg have VMsg: "0 < msgs c' <\<bottom>, outM v>"
        using NoOutMessageLoss Reach by (metis less_le_trans)
      assume "0 < msgs c' <\<bottom>, outM u>"
      with Agree VMsg Reach show "u = v" by simp
    qed
    thus " {v. \<exists>c'. qReachable c (UNIV - {p}) c' \<and> initReachable c' \<and>
      0 < msgs c' <\<bottom>, outM v>} = {v}" using NotEmpty U by auto
  qed
qed

corollary NonUniformImpliesNotDecided:
fixes
  c :: "('p, 'v, 's) configuration" and
  v :: "bool"
assumes
  "\<forall> cfg . reachable c cfg \<longrightarrow> agreement cfg"
  "\<And>cc Q . terminationPseudo 1 cc Q"
  "nonUniform c"
  "vDecided v c"
shows
  "False"
using DecidedImpliesUniform[OF assms(1,2,4)] assms(3)
  by (cases v, simp_all)

text\<open>
  All three parts of Völzer's Proposition 3 consider a single step from an
  arbitrary \isb{initReachable} configuration \var{c} with a message
  $\var{msg}$ to a succeeding configuration \var{c'}.
\<close>

text\<open>
  The silent decision values of a process which is not active in a step only
  decrease or stay the same.

  This follows directly from the definitions and the transitivity of the
  reachability properties \isb{reachable} and \isb{qReachable}.

  \voelzer{Proposition 3(a)}
\<close>
lemma InactiveProcessSilentDecisionValuesDecrease:
fixes
  p q :: 'p and
  c c' :: "('p, 'v, 's) configuration" and
  msg :: "('p, 'v) message"
assumes
  "p \<noteq> q" and
  "c \<turnstile> msg \<mapsto> c'" and
  "isReceiverOf p msg" and
  "initReachable c"
shows
  "val[q,c'] \<subseteq> val[q,c]"
proof(auto simp add: pSilDecVal_def assms(4))
  fix x cfg'
  assume
    Msg: "0 < msgs cfg' <\<bottom>, outM x>" and
    Cfg': "qReachable c' (Proc - {q}) cfg'"
  have "initReachable c'"
    using assms initReachable_def reachable.simps
    by blast
  hence Init: "initReachable cfg'"
    using Cfg' initReachable_def QReachImplReach[of c' "(Proc - {q})" cfg']
    ReachableTrans by blast
  have "p \<in> Proc - {q}"
    using assms by blast
  hence "qReachable c (Proc - {q}) c'"
    using assms qReachable.simps by metis
  hence "qReachable c (Proc - {q}) cfg'"
    using Cfg' QReachableTrans
    by blast
  with Msg Init show
    "\<exists>c'a. qReachable c (Proc - {q}) c'a
      \<and> initReachable c'a \<and>
      0 < msgs c'a <\<bottom>, outM x>" by blast
qed

text\<open>
  ...while the silent decision values of the process which is active in
  a step may only increase or stay the same.

  This follows as stated in \cite{Voelzer} from the \emph{diamond property}
  for a reachable configuration and a single step, i.e. \isb{DiamondTwo},
  and in addition from the fact that output messages cannot get lost, i.e.
  \isb{NoOutMessageLoss}.

  \voelzer{Proposition 3(b)}
\<close>
lemma ActiveProcessSilentDecisionValuesIncrease :
fixes
  p q :: 'p and
  c c' :: "('p, 'v, 's) configuration" and
  msg :: "('p, 'v) message"
assumes
  "p = q" and
  "c \<turnstile> msg \<mapsto> c'" and
  "isReceiverOf p msg" and
  "initReachable c"
shows "val[q,c] \<subseteq> val[q,c']"
proof (auto simp add: pSilDecVal_def assms(4))
  from assms initReachable_def reachable.simps show "initReachable c'"
    by meson
  fix x cv
  assume Cv: "qReachable c (Proc - {q}) cv" "initReachable cv"
    "0 < msgs cv <\<bottom>, outM x>"
  have "\<exists>c'a. (cv \<turnstile> msg \<mapsto> c'a) \<and> qReachable c' (Proc - {q}) c'a"
    using DiamondTwo Cv(1) assms
    by blast
  then obtain c'' where C'': "(cv \<turnstile> msg \<mapsto> c'')"
    "qReachable c' (Proc - {q}) c''" by auto
  with Cv(2) initReachable_def reachable.simps
    have Init: "initReachable c''" by blast
  have "reachable cv c''" using C''(1) reachable.intros by blast
  hence "msgs cv <\<bottom>, outM x> \<le> msgs c'' <\<bottom>, outM x>" using NoOutMessageLoss
    by simp
  hence "0 < msgs c'' <\<bottom>, outM x>" using Cv(3) by auto
  thus "\<exists>c'a. qReachable c' (Proc - {q}) c'a
    \<and> initReachable c'a \<and> 0 < msgs c'a <\<bottom>, outM x>"
    using C''(2) Init by blast
qed

text\<open>
  As a result from the previous two propositions, the silent decision values
  of a process cannot go from {0} to {1} or vice versa in a step.

  This is a slightly more generic version of Proposition 3 (c) from
  \cite{Voelzer} since it is proven for both values, while Völzer is only
  interested in the situation starting with $\var{val(q,c) = \{0\}}$.

  \voelzer{Proposition 3(c)}
\<close>

subsection\<open>Towards a proof of FLP\<close>

text\<open>
  There is an \isb{initial} configuration that is \isb{nonUniform} under
  the assumption of \isb{validity}, \isb{agreement} and \isb{terminationPseudo}.

  The lemma is used in the proof of the main theorem to construct the
  \isb{non\-Uni\-form} and \isb{initial} configuration that leads to the
  final contradiction.

  \voelzer{Lemma 1}
\<close>
lemma InitialNonUniformCfg:
assumes
  Termination: "\<And>cc Q . terminationPseudo 1 cc Q" and
  Validity: "\<forall> i c . validity i c" and
  Agreement: "\<forall> i c . agreementInit i c"
shows
  "\<exists> cfg . initial cfg \<and> nonUniform cfg"
proof-
  obtain n::nat where N: "n = card Proc" by blast
  hence "\<exists> procList::('p list). length procList = n \<and> set procList = Proc
    \<and> distinct procList"
    using finiteProcs
    by (metis distinct_card finite_distinct_list)
  then obtain procList where
    ProcList: "length procList = n" "set procList = Proc"
      "distinct procList" by blast
  have AllPInProclist: "\<forall>p. \<exists>i<n. procList ! i = p"
    using ProcList N
  proof auto
    fix p
    assume Asm: "set procList = Proc" "length procList = card Proc"
    have "p \<in> set procList" using ProcList by auto
    with Asm in_set_conv_nth
      show "\<exists>i<card Proc. procList ! i = p" by metis
  qed
  have NGr0: "n > 0"
    using N finiteProcs minimalProcs by auto
  define initMsg :: "nat \<Rightarrow> ('p, 'v) message \<Rightarrow> nat"
    where "initMsg ind m = (if \<exists>p. m = <p, inM (\<exists>i<ind. procList!i = p)> then 1 else 0)" for ind m
  define initCfgList
    where "initCfgList = map (\<lambda>ind. \<lparr>states = start, msgs = initMsg ind\<rparr>) [0..<(n+1)]"
  have InitCfgLength: "length initCfgList = n + 1"
    unfolding initCfgList_def by auto
  have InitCfgNonEmpty: "initCfgList \<noteq> []"
    unfolding initCfgList_def by auto
  hence InitCfgStart: "(\<forall>c \<in> set initCfgList. states c = start)"
    unfolding initCfgList_def by auto
  have InitCfgSet: "set initCfgList =
    {x. \<exists>ind < n+1. x = \<lparr>states = start, msgs = initMsg ind\<rparr>}"
    unfolding initCfgList_def
  proof auto
    fix ind
    assume "ind < n"
    hence "\<exists>inda<Suc n. inda = ind \<and> initMsg ind = initMsg inda" by auto
    thus "\<exists>inda<Suc n. initMsg ind = initMsg inda" by blast
  next
    fix ind
    assume Asm:
      "\<lparr>states = start, msgs = initMsg ind\<rparr> \<notin> (\<lambda>ind::nat. \<lparr>states = start, msgs = initMsg ind\<rparr>) ` {0..<n}"
      "ind < Suc n"
    hence "ind \<ge> n" by auto
    with Asm have "ind = n" by auto
    thus "initMsg ind = initMsg n" by auto
  qed
  have InitInitial: "\<forall>c \<in> set initCfgList . initial c"
    unfolding initial_def initCfgList_def initMsg_def using InitCfgStart
    by auto
  with InitCfgSet have InitInitReachable:
    "\<forall> c \<in> set initCfgList . initReachable c"
    using reachable.simps
    unfolding initReachable_def
    by blast

  define c0 where "c0 = initCfgList ! 0"
  hence "c0 = \<lparr> states = start, msgs = initMsg 0 \<rparr>"
    using InitCfgLength nth_map_upt[of 0 "n+1" 0]
    unfolding initCfgList_def by auto
  hence MsgC0: "msgs c0 = (\<lambda>m. if \<exists>p. m = <p, inM False> then 1 else 0)"
    unfolding initMsg_def by simp

  define cN where "cN = initCfgList ! n"
  hence "cN = \<lparr> states = start, msgs = initMsg n\<rparr>"
    using InitCfgLength nth_map_upt[of n "n+1" 0]
    unfolding initCfgList_def
    by auto
  hence MsgCN: "msgs cN = (\<lambda>m. if \<exists>p. m = <p, inM True> then 1 else 0)"
    unfolding initMsg_def
    using AllPInProclist
    by auto

  have C0NotCN: "c0 \<noteq> cN"
  proof
    assume "c0 = cN"
    hence StrangeEq: "(\<lambda>m::('p, 'v) message.
        if \<exists>p. m = <p, inM False> then 1 else 0 :: nat) =
      (\<lambda>m. if \<exists>p. m = <p, inM True> then 1 else 0)"
      using InitCfgLength N minimalProcs MsgC0 MsgCN
      unfolding c0_def cN_def by auto
    thus "False"
      by (metis message.inject(1) zero_neq_one)
  qed

  have C0NAreUniform: "\<And> cX . (cX = c0) \<or> (cX = cN)
                      \<Longrightarrow> vUniform (cX = cN) cX"
  proof-
    fix cX
    assume xIs0OrN: "(cX = c0) \<or> (cX = cN)"
    have xInit: "initial cX"
      using InitCfgLength InitCfgSet set_conv_nth[of initCfgList] xIs0OrN
      unfolding c0_def cN_def
      by (auto simp add: InitInitial)
    from Validity
      have COnlyReachesOneDecision:
        "\<forall> c . reachable cX c \<and> decided c \<longrightarrow> (vDecided (cX = cN) c)"
      unfolding validity_def initReachable_def
    proof auto
      fix c cfg0 v
      assume
        Validity: "(\<forall>i c. ((initial i) \<and> (reachable i c)) \<longrightarrow>
          (\<forall>v. (0 < msgs c (<\<bottom>, outM v>))
          \<longrightarrow> (\<exists>p. (0 < msgs i (<p, inM v>)))))" and
        OutMsg: "0 < msgs c <\<bottom>, outM v>" and
        InitCXReachable: "reachable cX c"
      thus "0 < msgs c <\<bottom>, outM (cX = cN)>"
        using xIs0OrN
      proof (cases "v = (cX = cN)", simp)
        assume "v \<noteq> (cX = cN)"
        hence vDef: "v = (cX \<noteq> cN)" by auto
        with Validity InitCXReachable OutMsg xInit
          have ExistMsg: "\<exists>p. (0 < msgs cX (<p, inM (cX \<noteq> cN)>))" by auto
        with initMsg_def have False
          using xIs0OrN
          by (auto simp add: MsgC0 MsgCN C0NotCN)
        thus "0 < msgs c <\<bottom>, outM cX = cN>" by simp
      qed
    qed
    have InitRInitC: "initReachable cX" using xInit InitialIsInitReachable
      by auto
    have NoWrongDecs: "\<And> v p cc::('p, 'v, 's) configuration.
      qReachable cX (Proc - {p}) cc \<and> initReachable cc
      \<and> 0 < msgs cc <\<bottom>, outM v>
        \<Longrightarrow> v = (cX = cN)"
    proof clarify
      fix v p cc
      assume Asm: "qReachable cX (Proc - {p}) cc" "initReachable cc"
      "0 < msgs cc <\<bottom>, outM v>"
      hence "reachable cX cc" "decided cc" using QReachImplReach by auto
      hence "\<not>(vDecided (cX \<noteq> cN) cc)"
        using COnlyReachesOneDecision Agreement Asm C0NotCN xInit xIs0OrN
        unfolding agreementInit_def by metis
      with Asm C0NotCN xIs0OrN show "v = (cX = cN)"
      by (auto, metis (full_types) neq0_conv)
    qed
    have ExRightDecs: "\<And>p. \<exists>cc. qReachable (cX) (Proc - {p}) cc
      \<and> initReachable cc \<and> 0 < msgs cc <\<bottom>, outM (cX = cN)>"
    proof-
      fix p
      show "\<exists>cc::('p, 'v, 's) configuration.
           qReachable cX (Proc - {p}) cc \<and> initReachable cc
           \<and> (0::nat) < msgs cc <\<bottom>, outM cX = cN>"
        using Termination[of "cX" "Proc - {p}"] finiteProcs minimalProcs
          InitRInitC
        unfolding terminationPseudo_def
      proof auto
        fix cc v
        assume
          Asm: "initReachable cX" "qReachable (cX) (Proc - {p}) cc"
          "initReachable cc"  "0 < msgs cc <\<bottom>, outM v>"
        with COnlyReachesOneDecision[rule_format, of "cc"] QReachImplReach
          have "0 < msgs cc <\<bottom>, outM cX = cN>" by auto
        with Asm
          show "\<exists>cc::('p, 'v, 's) configuration.
            qReachable cX (Proc - {p}) cc
            \<and> initReachable cc \<and> (0::nat) < msgs cc <\<bottom>, outM cX = cN>"
            by blast
      qed
    qed
    have ZeroinPSilent: "\<forall> p v . v \<in> val[p, cX] \<longleftrightarrow> v = (cX = cN)"
    proof clarify
      fix p v
      show "v \<in> val[p, cX] \<longleftrightarrow> v = (cX = cN)"
        unfolding pSilDecVal_def
        using InitRInitC xIs0OrN C0NotCN NoWrongDecs ExRightDecs by auto
    qed
    thus "vUniform (cX = cN) cX" using InitRInitC
      unfolding vUniform_def by auto
  qed
  hence
    C0Is0Uniform: "vUniform False c0" and
    CNNot0Uniform: "\<not> vUniform False cN"
    using C0NAreUniform unfolding vUniform_def using C0NotCN by auto
  hence "\<exists> j < n. vUniform False (initCfgList ! j)
    \<and> \<not>(vUniform False (initCfgList ! Suc j))"
    unfolding c0_def cN_def
    using NatPredicateTippingPoint
      [of n "\<lambda>x. vUniform False (initCfgList ! x)"] NGr0 by auto
  then obtain j
    where J: "j < n"
      "vUniform False (initCfgList ! j)"
      "\<not>(vUniform False (initCfgList ! Suc j))" by blast
  define pJ where "pJ = procList ! j"
  define cJ where "cJ = initCfgList ! j"
  hence cJDef: "cJ = \<lparr> states = start, msgs = initMsg j\<rparr>"
    using J(1) InitCfgLength nth_map_upt[of 0 "j- 1" 1]
      nth_map_upt[of "j" "n + 1" 0]
    unfolding initCfgList_def
    by auto
  hence MsgCJ: "msgs cJ = (\<lambda>m::('p, 'v) message.
    if \<exists>p::'p. m = <p, inM \<exists>i<j. procList ! i = p> then 1::nat
    else (0::nat))"
    unfolding initMsg_def
    using AllPInProclist
    by auto
  define cJ1 where "cJ1 = initCfgList ! (Suc j)"
  hence cJ1Def: "cJ1 = \<lparr> states = start, msgs = initMsg (Suc j)\<rparr>"
    using J(1) InitCfgLength nth_map_upt[of 0 "j" 1]
    nth_map_upt[of "j + 1" "n + 1" 0]
    unfolding initCfgList_def
    by auto
  hence MsgCJ1: "msgs cJ1 = (\<lambda>m::('p, 'v) message.
    if \<exists>p::'p. m = <p, inM \<exists>i<(Suc j). procList ! i = p> then 1::nat
    else (0::nat))"
    unfolding initMsg_def
    using AllPInProclist
    by auto
  have CJ1Init: "initial cJ1"
    using InitInitial[rule_format, of cJ1]  J(1) InitCfgLength
    unfolding cJ1_def by auto
  hence CJ1InitR: "initReachable cJ1"
    using InitialIsInitReachable by simp
  have ValPj0: "False \<in> val[pJ, cJ]"
    using J(2) unfolding cJ_def vUniform_def by auto
  hence "\<exists>cc. vDecided False cc \<and> withoutQReachable cJ {pJ} cc"
    unfolding pSilDecVal_def by auto
  then obtain cc
    where CC: "vDecided False cc" "withoutQReachable cJ {pJ} cc"
    by blast
    hence "\<exists>Q. qReachable cJ Q cc \<and> Q = Proc - {pJ}" by blast
    then obtain ccQ where CCQ: "qReachable cJ ccQ cc" "ccQ = Proc - {pJ}"
      by blast
  have StatescJcJ1: "states cJ = states cJ1"
    using  cJ_def cJ1_def initCfgList_def
    by (metis InitCfgLength InitCfgStart J(1) Suc_eq_plus1 Suc_mono
      less_SucI nth_mem)
  have Distinct: "\<And> i . distinct procList \<Longrightarrow> i<j
    \<Longrightarrow> procList ! i = procList ! j \<Longrightarrow> False"
    by (metis J(1) ProcList(1) distinct_conv_nth less_trans
       not_less_iff_gr_or_eq)
  have A: "msgs cJ (<pJ ,inM False>) = 1"
    using pJ_def ProcList J(1) MsgCJ using Distinct by auto
  have B: "msgs cJ1 (<pJ ,inM True>) = 1"
    using pJ_def ProcList J(1) MsgCJ1 by auto
  have C: "msgs cJ (<pJ ,inM True>) = 0"
    using pJ_def ProcList J(1) MsgCJ using Distinct by auto
  have D: "msgs cJ1 (<pJ ,inM False>) = 0"
    using pJ_def ProcList J(1) MsgCJ1 by auto
  define msgsCJ' where
    "msgsCJ' m = (if m = (<pJ ,inM False>) \<or> m = (<pJ ,inM True>) then 0 else (msgs cJ) m)" for m
  have MsgsCJ': "msgsCJ' = ((msgs cJ) -# (<pJ ,inM False>))"
    using A C msgsCJ'_def by auto
  have AllOther: "\<forall> m . msgsCJ' m = ((msgs cJ1) -# (<pJ ,inM True>)) m"
    using B D MsgCJ1 MsgCJ  J(1) N ProcList AllPInProclist
    unfolding msgsCJ'_def pJ_def
  proof(clarify)
    fix m
    show "(if m = <procList ! j, inM False> \<or>
        m = <procList ! j, inM True> then 0 else msgs cJ m)
      = (msgs cJ1 -# <procList ! j, inM True>) m"
    proof(cases "m = <procList ! j, inM False> \<or> m
      = <procList ! j, inM True>",auto)
      assume "0 < (msgs cJ1 <procList ! j, inM False>)"
      thus False using D pJ_def by (metis less_nat_zero_code)
    next
      show "msgs cJ1 <procList ! j, inM True> \<le> Suc 0"
        by (metis B One_nat_def order_refl pJ_def)
    next
      assume AssumpMJ: "m \<noteq> <procList ! j, inM False>"
                       "m \<noteq> <procList ! j, inM True>"
      hence "(if \<exists>p. m = <p, inM \<exists>i<j. procList ! i = p> then 1 else 0)
           = (if \<exists>p. m = <p, inM \<exists>i<Suc j. procList ! i = p> then 1 else 0)"
        by (induct m, auto simp add: less_Suc_eq)
      thus "msgs cJ m = msgs cJ1 m"
        using MsgCJ MsgCJ1 by auto
    qed
  qed \<comment> \<open>of AllOther\<close>

  with MsgsCJ' have InitMsgs: "((msgs cJ) -# (<pJ ,inM False>))
    = ((msgs cJ1) -# (<pJ, inM True>))"
    by simp
  hence F: "(((msgs cJ) -# (<pJ ,inM False>)) \<union># ({#<pJ, inM True>})) =
    (((msgs cJ1) -# (<pJ, inM True>))  \<union># ({#<pJ, inM True>}))"
    by (metis (full_types))
  from B have One: "(((msgs cJ1) -# (<pJ, inM True>))
    \<union># ({#<pJ, inM True>})) <pJ, inM True> = 1" by simp
  with B have "\<forall> m :: ('p, 'v) message . (msgs cJ1) m
    = (((msgs cJ1) -# (<pJ, inM True>))  \<union>#
    ({#<pJ, inM True>})) m" by simp
  with B have "(((msgs cJ1) -# (<pJ, inM True>))  \<union># ({#<pJ, inM True>}))
    = (msgs cJ1)" by simp
  with F have InitMsgs: "(((msgs cJ) -# (<pJ ,inM False>))
    \<union># ({#<pJ, inM True>})) = (msgs cJ1)"
    by simp
  define cc' where "cc' = \<lparr>states = (states cc),
    msgs = (((msgs cc) -# (<pJ,inM False>)) \<union># {# (<pJ, inM True>)})\<rparr>"
  have "\<lbrakk>qReachable cJ ccQ cc; ccQ = Proc - {pJ};
    (((msgs cJ) -# (<pJ ,inM False>)) \<union># ({#<pJ, inM True>}))
      = (msgs cJ1); states cJ = states cJ1\<rbrakk>
      \<Longrightarrow> withoutQReachable cJ1 {pJ} \<lparr>states = (states cc),
      msgs = (((msgs cc) -# (<pJ,inM False>)) \<union># {# (<pJ, inM True>)}) \<rparr>"
    proof (induct rule: qReachable.induct)
      fix cfg1::"('p, 'v, 's) configuration"
      fix Q
      assume
        Assm: "(((msgs cfg1) -#(<pJ, inM False>)) \<union># {# <pJ, inM True> })
        = msgs cJ1"
        "states cfg1 = states cJ1"
      hence CJ1: "cJ1 = \<lparr>states = states cfg1,
        msgs = ((msgs cfg1) -# <pJ, inM False>) \<union># {# <pJ, inM True> }\<rparr>" by auto
      have "qReachable cJ1  (Proc - {pJ}) cJ1" using qReachable.simps
        by blast
      with Assm show "qReachable cJ1 (Proc - {pJ})
        \<lparr>states = states cfg1, msgs = ((msgs cfg1) -# <pJ, inM False>)
        \<union># {# <pJ, inM True> }\<rparr>" using CJ1 by blast
      fix cfg1 cfg2 cfg3 :: "('p, 'v, 's) configuration"
      fix msg
      assume Q: "Q = (Proc - {pJ})"
      assume "(((msgs cfg1) -# <pJ, inM False>) \<union># {# <pJ, inM True> })
        = (msgs cJ1)"
        "(states cfg1) = (states cJ1)"
        "Q = (Proc - {pJ}) \<Longrightarrow>
          (((msgs cfg1) -# <pJ, inM False>) \<union># {# <pJ, inM True> })
            = (msgs cJ1)
          \<Longrightarrow> (states cfg1) = (states cJ1)
          \<Longrightarrow> qReachable cJ1 (Proc - {pJ})
          \<lparr>states = (states cfg2),
          msgs = (((msgs cfg2) -# <pJ, inM False>) \<union># {# <pJ, inM True> })\<rparr>"
      with Q have Cfg2:
        "qReachable cJ1 (Proc - {pJ}) \<lparr>states = (states cfg2),
        msgs = (((msgs cfg2) -# <pJ, inM False>) \<union># {# <pJ, inM True> })\<rparr>"
        by simp
      assume "qReachable cfg1 Q cfg2"
        "cfg2 \<turnstile> msg \<mapsto> cfg3"
        "\<exists>(p::'p)\<in>Q. (isReceiverOf p msg)"
      with Q have Step: "qReachable cfg1 (Proc - {pJ}) cfg2"
        "cfg2 \<turnstile> msg \<mapsto> cfg3"
        "\<exists>(p::'p)\<in>(Proc - {pJ}). (isReceiverOf p msg)" by auto
      then obtain p where P: "p\<in>(Proc - {pJ})" "isReceiverOf p msg" by blast
      hence NotEq: "pJ \<noteq> p" by blast
      with UniqueReceiverOf[of "p" "msg" "pJ"] P(2)
        have notRec: "\<not> (isReceiverOf pJ msg)" by blast
      hence MsgNoIn:"msg \<noteq>  <pJ, inM False> \<and> msg \<noteq>  <pJ, inM True>"
        by auto
      from Step(2) have "enabled cfg2 msg" using steps.simps
        by (auto, cases msg, auto)
      hence MsgEnabled: "enabled \<lparr>states = (states cfg2),
        msgs = (((msgs cfg2) -# <pJ, inM False>)
        \<union># {# <pJ, inM True> })\<rparr> msg"
        using MsgNoIn by (simp add: enabled_def)
      have  "\<lparr>states = (states cfg2),
              msgs = (((msgs cfg2) -# <pJ, inM False>)
              \<union># {# <pJ, inM True> })\<rparr>
                \<turnstile> msg \<mapsto> \<lparr>states = (states cfg3),
                msgs = (((msgs cfg3) -# <pJ, inM False>)
                \<union># {# <pJ, inM True> })\<rparr>"
      proof (cases msg)
        fix p' bool
        assume MsgIn :"(msg = <p', inM bool>)"
        with noInSends MsgIn MsgNoIn MsgEnabled
          show "\<lparr>states = (states cfg2),
          msgs = (((msgs cfg2) -# <pJ, inM False>) \<union># {# <pJ, inM True> })\<rparr>
            \<turnstile> msg \<mapsto> \<lparr>states = (states cfg3),
              msgs = (((msgs cfg3) -# <pJ, inM False>)
              \<union># {# <pJ, inM True> })\<rparr>"
          using steps.simps(1) Step(2) select_convs(2) select_convs(1)
          by auto
      next
        fix bool
        assume "(msg = <\<bottom>, outM bool>)"
        thus "\<lparr>states = (states cfg2),
          msgs = (((msgs cfg2) -# <pJ, inM False>) \<union># {# <pJ, inM True> })\<rparr>
            \<turnstile> msg \<mapsto> \<lparr>states = (states cfg3),
              msgs = (((msgs cfg3) -# <pJ, inM False>)
              \<union># {# <pJ, inM True> })\<rparr>"
          using steps_def Step(2) by auto
      next
        fix p v
        assume "(msg = <p, v>)"
        with noInSends MsgNoIn MsgEnabled show "\<lparr>states = (states cfg2),
          msgs = (((msgs cfg2) -# <pJ, inM False>) \<union># {# <pJ, inM True> })\<rparr>
            \<turnstile> msg \<mapsto> \<lparr>states = (states cfg3),
              msgs = (((msgs cfg3) -# <pJ, inM False>)
              \<union># {# <pJ, inM True> })\<rparr>"
        using steps.simps(1) Step(2) select_convs(2) select_convs(1) by auto
      qed
      with Cfg2 Step(3) show "qReachable cJ1 (Proc - {pJ})
        \<lparr>states = (states cfg3),
          msgs = (((msgs cfg3) -# <pJ, inM False>) \<union># {# <pJ, inM True> })\<rparr>"
        using
          qReachable.simps[of "cJ1" "(Proc - {pJ})"
          "\<lparr>states = (states cfg3),
          msgs = (((msgs cfg3) -# <pJ, inM False>)
          \<union># {# <pJ, inM True> })\<rparr>"] by auto
    qed
  with CCQ(1) CCQ(2) InitMsgs StatescJcJ1 have CC':
    "withoutQReachable cJ1 {pJ} \<lparr>states = (states cc),
      msgs = (((msgs cc) -# (<pJ,inM False>))
      \<union># {# (<pJ, inM True>)}) \<rparr>" by auto
  with QReachImplReach CJ1InitR initReachable_def reachable.simps
    ReachableTrans
    have "initReachable \<lparr>states = (states cc),
      msgs = (((msgs cc) -# (<pJ,inM False>))
      \<union># {# (<pJ, inM True>)}) \<rparr>" by meson
  with CC' have "False \<in> val[pJ, cJ1]"
    unfolding pSilDecVal_def
    using CJ1InitR CC(1) select_convs(2) by auto
  hence "\<not>(vUniform True (cJ1))"
    unfolding vUniform_def
    using CJ1InitR by blast
  hence "nonUniform cJ1"
    using J(3) CJ1InitR unfolding cJ1_def by auto
  thus ?thesis
    using CJ1Init by blast
qed

text\<open>
  Völzer's Lemma 2 proves that for every process $p$ in the consensus setting
  \isb{nonUniform} configurations can reach a configuration where the silent
  decision values of $p$ are True and False. This is key to the construction of
  non-deciding executions.

  \voelzer{Lemma 2}
\<close>
lemma NonUniformCanReachSilentBivalence:
fixes
  p:: 'p and
  c:: "('p, 'v, 's) configuration"
assumes
  NonUni: "nonUniform c" and
  PseudoTermination: "\<And>cc Q . terminationPseudo 1 cc Q" and
  Agree: "\<And> cfg . reachable c cfg \<longrightarrow> agreement cfg"
shows
   "\<exists> c' . reachable c c' \<and> val[p,c'] = {True, False}"
proof(cases "val[p,c] = {True, False}")
  case True
  have "reachable c c" using reachable.simps by metis
  thus ?thesis
    using True by blast
next
  case False
  hence notEq: "val[p,c] \<noteq> {True, False}" by simp
  from NonUni PseudoTermination DecisionValuesExist
  have notE: "\<forall>q. val[q,c] \<noteq> {}" by simp
  hence notEP: "val[p,c] \<noteq> {}" by blast
  have valType: "\<forall>q. val[q,c] \<subseteq> {True, False}" using pSilDecVal_def
    by (metis (full_types) insertCI subsetI)
  hence "val[p,c] \<subseteq> {True, False}" by blast
  with notEq notEP  have "\<exists>b:: bool. val[p,c] = {b}" by blast
  then obtain b where B: "val[p,c] = {b}" by auto
  from NonUni vUniform_def have
    NonUni: "(\<exists>q. val[q,c] \<noteq> {True}) \<and> (\<exists>q. val[q,c] \<noteq> {False})" by simp
  have Bool: "b = True \<or> b = False" by simp
  with NonUni have "\<exists>q. val[q,c] \<noteq> {b}" by blast
  then obtain q where Q: "val[q,c] \<noteq> {b}" by auto
  from notE valType
  have "val[q,c] = {True} \<or> val[q,c] = {False} \<or> val[q,c] = {True, False}"
    by auto
  with Bool Q have "val[q,c] = {\<not>b} \<or> val[q,c] = {b, \<not>b}" by blast
  hence "(\<not>b) \<in> val[q,c]" by blast
  with pSilDecVal_def
  have "\<exists> c'::('p, 'v, 's) configuration . (withoutQReachable c {q} c') \<and>
    vDecided (\<not>b) c'" by simp
  then obtain c' where C': "withoutQReachable c {q} c'" "vDecided (\<not>b) c'"
    by auto
  hence Reach: "reachable c c'" using QReachImplReach by simp
  have "\<forall> cfg . reachable c' cfg \<longrightarrow> agreement cfg"
  proof clarify
    fix cfg
    assume "reachable c' cfg"
    with Reach have "reachable c cfg"
      using ReachableTrans[of c c'] by simp
    with Agree show "agreement cfg" by simp
  qed
  with PseudoTermination C'(2) DecidedImpliesUniform have "vUniform (\<not>b) c'"
    by simp
  hence notB: "val[p,c'] = {\<not>b}" using vUniform_def by simp
  with Reach B show "\<exists> cfg. reachable c cfg \<and> val[p,cfg] = {True, False}"
  proof(induct rule: reachable.induct, simp)
    fix cfg1 cfg2 cfg3 msg
    assume
      IV: "val[p,cfg1] = {b} \<Longrightarrow>
        val[p,cfg2] = {\<not> b} \<Longrightarrow>
          \<exists>cfg::('p, 'v, 's) configuration. reachable cfg1 cfg
          \<and> val[p,cfg] = {True, False}" and
      Reach:  "reachable cfg1 cfg2" and
      Step: "cfg2 \<turnstile> msg \<mapsto> cfg3" and
      ValCfg1: "val[p,cfg1] = {b}" and
      ValCfg3: "val[p,cfg3] = {\<not> b}"
    from ValCfg1 have InitCfg1: "initReachable cfg1"
      using pSilDecVal_def by auto
    from Reach InitCfg1 initReachable_def reachable.simps ReachableTrans
      have InitCfg2: "initReachable cfg2" by blast
    with PseudoTermination DecisionValuesExist
    have notE: "\<forall>q. val[q,cfg2] \<noteq> {}" by simp
    have valType: "\<forall>q. val[q,cfg2] \<subseteq> {True, False}" using pSilDecVal_def
      by (metis (full_types) insertCI subsetI)
    from notE valType
      have "val[p,cfg2] = {True} \<or> val[p,cfg2] = {False}
        \<or> val[p,cfg2] = {True, False}"
      by auto
    with Bool have Val: "val[p,cfg2] = {b} \<or> val[p,cfg2] = {\<not>b}
      \<or> val[p,cfg2] = {True, False}"
      by blast
    show "\<exists>cfg::('p, 'v, 's) configuration. reachable cfg1 cfg
      \<and> val[p,cfg] = {True, False}"
    proof(cases "val[p,cfg2] = {b}")
      case True
      hence B: "val[p,cfg2] = {b}" by simp
      from Step have RecOrOut: "\<exists>q. isReceiverOf q msg" by(cases msg, auto)
      then obtain q where Rec: "isReceiverOf q msg" by auto
      with B Step InitCfg2 SilentDecisionValueNotInverting
      have "val[p,cfg3] \<noteq> {\<not>b}" by simp
      with ValCfg3 have "False" by simp
      thus "\<exists>cfg::('p, 'v, 's) configuration. reachable cfg1 cfg \<and>
        val[p,cfg] = {True, False}" by simp
    next
      case False
      with Val have Val: "val[p,cfg2] = {\<not>b} \<or> val[p,cfg2] = {True, False}"
        by simp
      show "\<exists>cfg::('p, 'v, 's) configuration. reachable cfg1 cfg \<and>
            val[p,cfg] = {True, False}"
      proof(cases "val[p,cfg2] = {\<not>b}")
        case True
        hence "val[p,cfg2] = {\<not>b}" by simp
        with ValCfg1 IV show
          "\<exists>cfg::('p, 'v, 's) configuration.
          reachable cfg1 cfg \<and> val[p,cfg] = {True, False}"
          by simp
      next
        case False
        with Val have "val[p,cfg2] = {True, False}" by simp
        with Reach have "reachable cfg1 cfg2 \<and> val[p,cfg2] = {True, False}"
          by blast
        from this show "\<exists>cfg::('p, 'v, 's) configuration.
          reachable cfg1 cfg \<and> val[p,cfg] = {True, False}" by blast
      qed
    qed
  qed
qed

end
end


theory Anomaly
  imports Main DSG Observation
begin

section \<open>Non-Cyclic Anomalies\<close>

text \<open>We are now ready to encode notions of Adya's anomalies. An aborted read, or g1a, implies some
pair of transactions exist such that one wrote v1 and aborted, and another read v1 and committed.\<close>

definition has_g1a :: "history \<Rightarrow> bool" where
"has_g1a h \<equiv> (\<exists>t1 t2 k v1 a v2 r. (t1 \<in> (all_atxns h)) \<and>
                                  (t2 \<in> (all_atxns h)) \<and>
                                  (\<not>(a_is_committed t1)) \<and>
                                  (a_is_committed t2) \<and>
                                  (AWrite k v1 a v2 r) \<in> (all_aops t1) \<and>
                                  (ARead k v2) \<in> (all_aops t2))"

text \<open>An empty history does not have an aborted read.\<close>

lemma "\<not>(has_g1a (History {(register 1)} {} {(KeyVersionOrder 1 [[0]])}))"
  by (simp add:has_g1a_def)

text "But this history does: we write 1 and fail to commit, then read it! We don't actually
have to constrain the version order for this to happen, either."

lemma "has_g1a (History {(register 1)}
                        {(ATxn [(AWrite 1 [0] 1 [1] [])] False),
                         (ATxn [(ARead 1 [1])] True)}
                        kvo)"
  using has_g1a_def by fastforce

(* TODO: intermediate read, dirty update *)

section \<open>Cyclic Anomalies\<close>

text \<open>In an G0 anomaly, a cycle exists in the DSG composed purely of write dependencies.\<close>

definition has_g0 :: "history \<Rightarrow> bool" where
"has_g0 h \<equiv> (\<exists>path. (cycle (dsg h) path) \<and> ((path_dep_types path) = {WW}))"

text \<open>For example...\<close>

lemma ww_depends_ex:
  assumes "(distinct [x,y]) \<and> (distinct [v0,v1,v2])"
  shows "ww_depends (History objs
                         {(ATxn [(AWrite x v0 a1 v1 r1), (AWrite y v1 a2 v2 r2)] True),
                          (ATxn [(AWrite y v0 a1 v1 r1), (AWrite x v1 a2 v2 r2)] True)}
                         {(KeyVersionOrder x [v0,v1,v2]),
                          (KeyVersionOrder y [v0,v1,v2])})
                      (ATxn [(AWrite x v0 a1 v1 r1), (AWrite y v1 a2 v2 r2)] True)
                      (ATxn [(AWrite y v0 a1 v1 r1), (AWrite x v1 a2 v2 r2)] True)"
  apply (simp add:ww_depends_def)
proof-
  obtain t1 t2 where "t1 = (ATxn [(AWrite x v0 a1 v1 r1), (AWrite y v1 a2 v2 r2)] True) \<and>
                      t2 = (ATxn [(AWrite y v0 a1 v1 r1), (AWrite x v1 a2 v2 r2)] True)"
    by blast
  oops

lemma
  assumes "(distinct [x,y]) \<and> (distinct [v0,v1,v2])"
  shows "has_g0 (History objs
                         {(ATxn [(AWrite x v0 a1 v1 r1), (AWrite y v1 a2 v2 r2)] True),
                          (ATxn [(AWrite y v0 a1 v1 r1), (AWrite x v1 a2 v2 r2)] True)}
                         {(KeyVersionOrder x [v0,v1,v2]),
                          (KeyVersionOrder y [v0,v1,v2])})"
  apply (simp add:has_g0_def dsg_def path_def cycle_def)
  oops

text \<open>A G1c anomaly is a cycle comprised of write-write and write-read dependencies. We diverge from
Adya here in classifying G0 and G1c as distinct classes; feels more useful to distinguish them.\<close>

definition has_g1c :: "history \<Rightarrow> bool" where
"has_g1c h \<equiv> (\<exists>path. (cycle (dsg h) path) \<and> ((path_dep_types path) = {WW,WR}))"

text \<open>And a G2 anomaly is a cycle involving read-write dependencies.\<close>

definition has_g2 :: "history \<Rightarrow> bool" where
"has_g2 h \<equiv> (\<exists>path. (cycle (dsg h) path) \<and> (RW \<in> (path_dep_types path)))"

end