(*******************************************************************************

  Project: IsaNet

  Author:  Christoph Sprenger, ETH Zurich <sprenger@inf.ethz.ch>
           Tobias Klenze, ETH Zurich <tobias.klenze@inf.ethz.ch>
  Version: JCSPaper.1.0
  Isabelle Version: Isabelle2021-1

  Copyright (c) 2022 Christoph Sprenger
  Licence: Mozilla Public License 2.0 (MPL) / BSD-3-Clause (dual license)

*******************************************************************************)

chapter\<open>Verification Infrastructure\<close>
text\<open>Here we define event systems, the term algebra, and the Dolev--Yao adversary\<close>
section \<open>Event Systems\<close>

text \<open>This theory contains definitions of event systems, trace, traces, reachability, simulation,
and proves the soundness of simulation for proving trace inclusion. We also derive some related
simulation rules.\<close>

theory Event_Systems
  imports Main
begin

record ('e, 's) ES =
  init :: "'s \<Rightarrow> bool"
  trans :: "'s \<Rightarrow> 'e \<Rightarrow> 's \<Rightarrow> bool"   ("(4_: _\<midarrow>_\<rightarrow> _)" [50, 50, 50] 90)

(********************************************************************************)
subsection \<open>Reachable states and invariants\<close>
(********************************************************************************)

inductive
  reach :: "('e, 's) ES \<Rightarrow> 's \<Rightarrow> bool" for E
  where
    reach_init [simp, intro]:  "init E s \<Longrightarrow> reach E s"
  | reach_trans [intro]: "\<lbrakk> E: s \<midarrow>e\<rightarrow> s'; reach E s \<rbrakk> \<Longrightarrow> reach E s'"

thm reach.induct

text \<open>Abbreviation for stating that a predicate is an invariant of an event system.\<close>

definition Inv :: "('e, 's) ES \<Rightarrow> ('s \<Rightarrow> bool) \<Rightarrow> bool" where
  "Inv E I \<longleftrightarrow> (\<forall>s. reach E s \<longrightarrow> I s)"

lemmas InvI = Inv_def [THEN iffD2, rule_format]
lemmas InvE [elim] = Inv_def [THEN iffD1, elim_format, rule_format]

lemma Invariant_rule [case_names Inv_init Inv_trans]:
  assumes "\<And>s0. init E s0 \<Longrightarrow> I s0"
     and  "\<And>s e s'. \<lbrakk>E: s \<midarrow>e\<rightarrow> s'; reach E s; I s\<rbrakk> \<Longrightarrow> I s'"
  shows "Inv E I"
  unfolding Inv_def
proof (intro allI impI)
  fix s
  assume "reach E s"
  then show "I s" using assms
    by (induction s rule: reach.induct) (auto)
qed

text \<open>Invariant rule that allows strengthening the proof with another invariant.\<close>
lemma Invariant_rule_Inv [case_names Inv_other Inv_init Inv_trans]:
  assumes "Inv E J"
     and  "\<And>s0. init E s0 \<Longrightarrow> I s0"
     and  "\<And>s e s'. \<lbrakk>E: s \<midarrow>e\<rightarrow> s'; reach E s; I s; J s; J s'\<rbrakk> \<Longrightarrow> I s'"
  shows "Inv E I"
  unfolding Inv_def
proof (intro allI impI)
  fix s
  assume "reach E s"
  then show "I s" using assms
    by (induction s rule: reach.induct)(auto 3 4)
qed

(********************************************************************************)
subsection \<open>Traces\<close>
(********************************************************************************)

type_synonym 'e trace = "'e list"

inductive
  trace :: "('e, 's) ES \<Rightarrow> 's \<Rightarrow> 'e trace \<Rightarrow> 's \<Rightarrow> bool"  ("(4_: _ \<midarrow>\<langle>_\<rangle>\<rightarrow> _)" [50, 50, 50] 90)
  for E s
  where
    trace_nil [simp,intro!]:
      "E: s \<midarrow>\<langle>[]\<rangle>\<rightarrow> s"
  | trace_snoc [intro]:
      "\<lbrakk> E: s \<midarrow>\<langle>\<tau>\<rangle>\<rightarrow> s'; E: s' \<midarrow>e\<rightarrow> s'' \<rbrakk> \<Longrightarrow> E: s \<midarrow>\<langle>\<tau> @ [e]\<rangle>\<rightarrow> s''"

thm trace.induct

inductive_cases trace_nil_invert [elim!]: "E: s \<midarrow>\<langle>[]\<rangle>\<rightarrow> t"
inductive_cases trace_snoc_invert [elim]: "E: s \<midarrow>\<langle>\<tau> @ [e]\<rangle>\<rightarrow> t"

lemma trace_init_independence [elim]:
  assumes "E: s \<midarrow>\<langle>\<tau>\<rangle>\<rightarrow> s'" "trans E = trans F"
  shows "F: s \<midarrow>\<langle>\<tau>\<rangle>\<rightarrow> s'"
  using assms
by (induction rule: trace.induct) auto

lemma trace_single [simp, intro!]: "\<lbrakk> E: s \<midarrow>e\<rightarrow> s' \<rbrakk> \<Longrightarrow> E: s \<midarrow>\<langle>[e]\<rangle>\<rightarrow> s'"
  by (auto intro: trace_snoc[where \<tau> = "[]", simplified])

text \<open>Next, we prove an introduction rule for a "cons" trace and a case analysis rule
distinguishing the empty trace and a "cons" trace.\<close>

lemma trace_consI:
  assumes
    "E: s'' \<midarrow>\<langle>\<tau>\<rangle>\<rightarrow> s'" "E: s \<midarrow>e\<rightarrow> s''"
  shows
    "E: s \<midarrow>\<langle>e # \<tau>\<rangle>\<rightarrow> s'"
  using assms
by (induction rule: trace.induct) (auto dest: trace_snoc)

lemma trace_cases_cons:
  assumes
    "E: s \<midarrow>\<langle>\<tau>\<rangle>\<rightarrow> s'"
    "\<lbrakk> \<tau> = []; s' = s \<rbrakk> \<Longrightarrow> P"
    "\<And>e \<tau>' s''. \<lbrakk> \<tau> = e # \<tau>'; E: s \<midarrow>e\<rightarrow> s''; E: s'' \<midarrow>\<langle>\<tau>'\<rangle>\<rightarrow> s' \<rbrakk> \<Longrightarrow> P"
  shows "P"
  using assms
by (induction rule: trace.induct) fastforce+

lemma trace_consD: "(E: s \<midarrow>\<langle>e # \<tau>\<rangle>\<rightarrow> s') \<Longrightarrow> \<exists> s''. (E: s \<midarrow>e\<rightarrow> s'') \<and> (E: s'' \<midarrow>\<langle>\<tau>\<rangle>\<rightarrow> s')"
  by(auto elim: trace_cases_cons)

text \<open>We show how a trace can be appended to another.\<close>

lemma trace_append: "(E: s \<midarrow>\<langle>\<tau>\<^sub>1\<rangle>\<rightarrow> s') \<and> (E: s' \<midarrow>\<langle>\<tau>\<^sub>2\<rangle>\<rightarrow> s'') \<Longrightarrow> E: s \<midarrow>\<langle>\<tau>\<^sub>1@\<tau>\<^sub>2\<rangle>\<rightarrow> s''"
  by(induction \<tau>\<^sub>1 arbitrary: s)
    (auto dest!: trace_consD intro: trace_consI)

lemma trace_append_invert: "(E: s \<midarrow>\<langle>\<tau>\<^sub>1@\<tau>\<^sub>2\<rangle>\<rightarrow> s'') \<Longrightarrow> \<exists>s' . (E: s \<midarrow>\<langle>\<tau>\<^sub>1\<rangle>\<rightarrow> s') \<and> (E: s' \<midarrow>\<langle>\<tau>\<^sub>2\<rangle>\<rightarrow> s'')"
  by (induction \<tau>\<^sub>1 arbitrary: s) (auto intro!: trace_consI dest!: trace_consD)

text\<open>We prove an induction scheme for combining two traces, similar to @{text list_induct2}.\<close>

lemma trace_induct2 [consumes 3, case_names Nil Snoc]:
  "\<lbrakk>E: s \<midarrow>\<langle>\<tau>\<rangle>\<rightarrow> s''; F: t \<midarrow>\<langle>\<sigma>\<rangle>\<rightarrow> t''; length \<tau> = length \<sigma>;
    P [] s [] t;
    \<And>\<tau> s' e s'' \<sigma> t' f t''.
    \<lbrakk>E: s \<midarrow>\<langle>\<tau>\<rangle>\<rightarrow> s'; E: s'\<midarrow>e\<rightarrow> s''; F: t \<midarrow>\<langle>\<sigma>\<rangle>\<rightarrow> t'; F: t'\<midarrow>f\<rightarrow> t''; P \<tau> s' \<sigma> t'\<rbrakk>
      \<Longrightarrow> P (\<tau> @ [e]) s'' (\<sigma> @ [f]) t''\<rbrakk>
  \<Longrightarrow> P \<tau> s'' \<sigma> t''"
proof (induction \<tau> s'' arbitrary: \<sigma> t'' rule: trace.induct)
  case trace_nil
  then show ?case by auto
next
  case (trace_snoc \<tau> s' e s'')
  from \<open>length (\<tau> @ [e]) = length \<sigma>\<close> and \<open>F: t \<midarrow>\<langle>\<sigma>\<rangle>\<rightarrow> t''\<close>
  obtain f \<sigma>' t'
    where "\<sigma> = \<sigma>' @ [f]" "length \<tau> = length \<sigma>'" "F: t \<midarrow>\<langle>\<sigma>'\<rangle>\<rightarrow> t'" "F: t' \<midarrow>f\<rightarrow> t''"
    by (auto elim: trace.cases)
  then show ?case using trace_snoc by blast
qed

subsubsection \<open>Relate traces to reachability and invariants\<close>
(********************************************************************************)

lemma reach_trace_equiv: "reach E s \<longleftrightarrow> (\<exists>s0 \<tau>. init E s0 \<and> E: s0 \<midarrow>\<langle>\<tau>\<rangle>\<rightarrow> s)"  (is "?A \<longleftrightarrow> ?B")
proof
  assume "?A" then show "?B"
    by (induction s rule: reach.induct) auto
next
  assume "?B"
  then obtain s0 \<tau> where "E: s0 \<midarrow>\<langle>\<tau>\<rangle>\<rightarrow> s" "init E s0" by blast
  then show "?A"
    by (induction \<tau> s rule: trace.induct) auto
qed

lemma reach_traceI: "\<lbrakk>init E s0; E: s0 \<midarrow>\<langle>\<tau>\<rangle>\<rightarrow> s\<rbrakk> \<Longrightarrow> reach E s"
  by(auto simp add: reach_trace_equiv)

lemma reach_trace_extend: "\<lbrakk>E: s \<midarrow>\<langle>\<tau>\<rangle>\<rightarrow> s'; reach E s\<rbrakk> \<Longrightarrow> reach E s'"
  by (induction \<tau> s' rule: trace.induct) auto

lemma Inv_trace: "\<lbrakk>Inv E I; init E s0; E: s0 \<midarrow>\<langle>\<tau>\<rangle>\<rightarrow> s'\<rbrakk> \<Longrightarrow> I s'"
  by (auto simp add: Inv_def reach_trace_equiv)

subsubsection \<open>Trace semantics of event systems\<close>
(********************************************************************************)

text \<open>We define the set of traces of an event system.\<close>

definition traces :: "('e, 's) ES \<Rightarrow> 'e trace set" where
  "traces E = {\<tau>. \<exists>s s'. init E s \<and> E: s \<midarrow>\<langle>\<tau>\<rangle>\<rightarrow> s'}"

lemma tracesI [intro]: "\<lbrakk> init E s; E: s \<midarrow>\<langle>\<tau>\<rangle>\<rightarrow> s' \<rbrakk> \<Longrightarrow> \<tau> \<in> traces E"
  by (auto simp add: traces_def)

lemma tracesE [elim]: "\<lbrakk> \<tau> \<in> traces E; \<And>s s'. \<lbrakk> init E s; E: s \<midarrow>\<langle>\<tau>\<rangle>\<rightarrow> s' \<rbrakk> \<Longrightarrow> P \<rbrakk> \<Longrightarrow> P"
  by (auto simp add: traces_def)

lemma traces_nil [simp, intro!]: "init E s \<Longrightarrow> [] \<in> traces E"
  by (auto simp add: traces_def)

text\<open>We now define a trace property satisfaction relation: an event system satisfies a property
@{term "\<phi>"}, if its traces are contained in @{term \<phi>}.\<close>

definition trace_property :: "('e, 's) ES \<Rightarrow> 'e trace set \<Rightarrow> bool" (infix "\<Turnstile>\<^sub>E\<^sub>S" 90) where
  "E \<Turnstile>\<^sub>E\<^sub>S \<phi> \<longleftrightarrow> traces E \<subseteq> \<phi>"

lemmas trace_propertyI = trace_property_def [THEN iffD2, OF subsetI, rule_format]
lemmas trace_propertyE [elim] = trace_property_def [THEN iffD1, THEN subsetD, elim_format]
lemmas trace_propertyD = trace_property_def [THEN iffD1, THEN subsetD, rule_format]

text \<open>Rules for showing trace properties using a stronger trace-state invariant.\<close>

lemma trace_invariant:
  assumes
    "\<tau> \<in> traces E"
    "\<And>s s'. \<lbrakk> init E s; E: s \<midarrow>\<langle>\<tau>\<rangle>\<rightarrow> s' \<rbrakk> \<Longrightarrow> I \<tau> s'"
    "\<And>s. I \<tau> s \<Longrightarrow> \<tau> \<in> \<phi>"
  shows "\<tau> \<in> \<phi>" using assms
  by (auto)

lemma trace_property_rule:
  assumes
    "\<And>s0. init E s0 \<Longrightarrow> I [] s0"
    "\<And>s s' \<tau> e s''.
       \<lbrakk> init E s; E: s \<midarrow>\<langle>\<tau>\<rangle>\<rightarrow> s'; E: s' \<midarrow>e\<rightarrow> s''; I \<tau> s'; reach E s' \<rbrakk> \<Longrightarrow> I (\<tau>@[e]) s''"
    "\<And>\<tau> s. \<lbrakk> I \<tau> s; reach E s \<rbrakk> \<Longrightarrow> \<tau> \<in> \<phi>"
  shows "E \<Turnstile>\<^sub>E\<^sub>S \<phi>"
proof (rule trace_propertyI, erule trace_invariant[where I="\<lambda>\<tau> s. I \<tau> s \<and> reach E s"])
  fix \<tau> s s'
  assume "E: s \<midarrow>\<langle>\<tau>\<rangle>\<rightarrow> s'" and "init E s"
  then show "I \<tau> s' \<and> reach E s'"
    by (induction \<tau> s' rule: trace.induct) (auto simp add: assms)
qed (auto simp add: assms)

text \<open>Similar to @{thm trace_property_rule}, but allows matching pure state invariants directly.\<close>
lemma Inv_trace_property:
  assumes "Inv E I" and "[] \<in> \<phi>"
      and "(\<And>s \<tau> s' e s''.
      \<lbrakk>init E s; E: s \<midarrow>\<langle>\<tau>\<rangle>\<rightarrow> s'; E: s' \<midarrow>e\<rightarrow> s''; I s; I s'; reach E s'; \<tau> \<in> \<phi>\<rbrakk> \<Longrightarrow> \<tau>@[e] \<in> \<phi>)"
    shows "E \<Turnstile>\<^sub>E\<^sub>S \<phi>"
  using assms(1,2)
  by (intro trace_property_rule[where I="\<lambda>\<tau> s. \<tau> \<in> \<phi>"]) (auto intro: assms(3))

subsection \<open>Simulation\<close>
(********************************************************************************)

text \<open>We first define the simulation preorder on pairs of states and derive a series of
useful coinduction principles.\<close>

coinductive
  sim :: "('e, 's ) ES \<Rightarrow> ('f, 't ) ES \<Rightarrow> ('e \<Rightarrow> 'f) \<Rightarrow> 's \<Rightarrow> 't \<Rightarrow> bool"
  for E F \<pi>
  where
    "\<lbrakk> \<And>e s'. (E: s \<midarrow>e\<rightarrow> s') \<Longrightarrow> \<exists>t'. (F: t \<midarrow>\<pi> e\<rightarrow> t') \<and> sim E F \<pi> s' t' \<rbrakk> \<Longrightarrow> sim E F \<pi> s t"

abbreviation
  simS :: "('e, 's ) ES \<Rightarrow> ('f, 't ) ES \<Rightarrow> 's \<Rightarrow> ('e \<Rightarrow> 'f) \<Rightarrow> 't \<Rightarrow> bool"
          ("(5_,_: _ \<sqsubseteq>\<^sub>_ _)" [50, 50, 50, 60, 50] 90)
where
  "simS E F s \<pi> t \<equiv> sim E F \<pi> s t"

lemmas sim_coinduct_id = sim.coinduct[where \<pi>=id, consumes 1, case_names sim]

text \<open>We prove a simplified and slightly weaker coinduction rule for simulation and
register it as the default rule for @{term sim}.\<close>

lemma sim_coinduct_weak [consumes 1, case_names sim, coinduct pred: sim]:
  assumes
    "R s t"
    "\<And>s t a s'. \<lbrakk> R s t;  E: s\<midarrow>a\<rightarrow> s'\<rbrakk> \<Longrightarrow> (\<exists>t'. (F: t\<midarrow>\<pi> a\<rightarrow> t') \<and> R s' t')"
  shows
    "E,F: s \<sqsubseteq>\<^sub>\<pi> t"
  using assms
  by (coinduction arbitrary: s t rule: sim.coinduct) (fastforce)

(*
lemmas sim_coinduct_weak_id [consumes 1, case_names sim, coinduct pred: sim] =
  sim_coinduct_weak [where \<pi>="id"]
*)

(*
  CHECK: declaring sim_refl as [intro] makes proof of simulation_soundness loop! (why?)
*)
lemma sim_refl: "E,E: s \<sqsubseteq>\<^sub>id s"
  by (coinduction arbitrary: s) auto

lemma sim_trans: "\<lbrakk> E,F: s \<sqsubseteq>\<^sub>\<pi>1 t; F,G: t \<sqsubseteq>\<^sub>\<pi>2 u \<rbrakk> \<Longrightarrow> E,G: s \<sqsubseteq>\<^sub>(\<pi>2 \<circ> \<pi>1) u"
proof (coinduction arbitrary: s t u)
  case (sim a s' s t)
  with \<open>E,F: s \<sqsubseteq>\<^sub>\<pi>1 t\<close> obtain t' where "F: t \<midarrow>\<pi>1 a\<rightarrow> t'" "E,F: s' \<sqsubseteq>\<^sub>\<pi>1 t'"
    by (cases rule: sim.cases) auto
  moreover
  from \<open>F,G: t \<sqsubseteq>\<^sub>\<pi>2 u\<close> \<open>F: t \<midarrow>\<pi>1 a\<rightarrow> t'\<close> obtain u' where "G: u \<midarrow>\<pi>2 (\<pi>1 a)\<rightarrow> u'" "F,G: t' \<sqsubseteq>\<^sub>\<pi>2 u'"
    by (cases rule: sim.cases) auto
  ultimately
  have "\<exists>t' u'. (G: u \<midarrow>\<pi>2 (\<pi>1 a)\<rightarrow> u') \<and> (E,F: s' \<sqsubseteq>\<^sub>\<pi>1 t') \<and> (F,G: t' \<sqsubseteq>\<^sub>\<pi>2 u')"
    by auto
  then show ?case by auto
qed

text \<open>Extend transition simulation to traces.\<close>

lemma trace_sim:
  assumes "E: s \<midarrow>\<langle>\<tau>\<rangle>\<rightarrow> s'" "E,F: s \<sqsubseteq>\<^sub>\<pi> t"
  shows "\<exists>t'. (F: t \<midarrow>\<langle>map \<pi> \<tau>\<rangle>\<rightarrow> t') \<and> (E,F: s' \<sqsubseteq>\<^sub>\<pi> t')"
  using assms
proof (induction \<tau> s' rule: trace.induct)
  case trace_nil
  then show ?case by auto
next
  case (trace_snoc \<tau> s' e s'')
  then obtain t' where "F: t \<midarrow>\<langle>map \<pi> \<tau>\<rangle>\<rightarrow> t'" "E,F: s' \<sqsubseteq>\<^sub>\<pi> t'" by auto
  from \<open>E,F: s' \<sqsubseteq>\<^sub>\<pi> t'\<close> \<open>E: s'\<midarrow>e\<rightarrow> s''\<close>
  obtain t'' where "F: t' \<midarrow>\<pi> e\<rightarrow> t''" "E,F: s'' \<sqsubseteq>\<^sub>\<pi> t''"  by (elim sim.cases) fastforce
  then show ?case using \<open>F: t \<midarrow>\<langle>map \<pi> \<tau>\<rangle>\<rightarrow> t'\<close> \<open>E: s \<midarrow>\<langle>\<tau>\<rangle>\<rightarrow> s'\<close> \<open>E: s'\<midarrow>e\<rightarrow> s''\<close> by auto
qed

subsubsection \<open>Simulation for event systems\<close>
(********************************************************************************)

definition
  sim_ES :: "('e, 's ) ES \<Rightarrow> ('e \<Rightarrow> 'f) \<Rightarrow> ('f, 't ) ES \<Rightarrow> bool"  ("(3_ \<sqsubseteq>\<^sub>_ _)" [50, 60, 50] 95)
where
  "E \<sqsubseteq>\<^sub>\<pi> F \<longleftrightarrow> (\<exists>R.
     (\<forall>s0. init E s0 \<longrightarrow> (\<exists>t0. init F t0 \<and> R s0 t0)) \<and>
     (\<forall>s t. R s t \<longrightarrow> E,F: s \<sqsubseteq>\<^sub>\<pi> t))"

lemma sim_ES_I:
  assumes
    "\<And>s0. init E s0 \<Longrightarrow> (\<exists>t0. init F t0 \<and> R s0 t0)" and
    "\<And>s t. R s t \<Longrightarrow> E,F: s \<sqsubseteq>\<^sub>\<pi> t"
  shows "E \<sqsubseteq>\<^sub>\<pi> F"
  using assms
  by (auto simp add: sim_ES_def)

lemma sim_ES_E:
  assumes
    "E \<sqsubseteq>\<^sub>\<pi> F"
    "\<And>R. \<lbrakk> \<And>s0. init E s0 \<Longrightarrow> (\<exists>t0. init F t0 \<and> R s0 t0); \<And>s t. R s t \<Longrightarrow> E,F: s \<sqsubseteq>\<^sub>\<pi> t \<rbrakk> \<Longrightarrow> P"
  shows "P"
  using assms
  by (auto simp add: sim_ES_def)

text \<open>Different rules to set up a simulation proof. Include reachability or weaker invariant(s)
in precondition of ``simulation square''.\<close>

lemma simulate_ES:
  assumes
    init: "\<And>s0. init E s0 \<Longrightarrow> (\<exists>t0. init F t0 \<and> R s0 t0)" and
    step: "\<And>s t a s'. \<lbrakk> R s t; reach E s; reach F t; E: s\<midarrow>a\<rightarrow> s' \<rbrakk>
                    \<Longrightarrow> (\<exists>t'. (F: t\<midarrow>\<pi> a\<rightarrow> t') \<and> R s' t')"
  shows "E \<sqsubseteq>\<^sub>\<pi> F"
  by (auto 4 4 intro!: sim_ES_I[where R="\<lambda>s t. R s t \<and> reach E s \<and> reach F t"] dest: init
               intro: sim_coinduct_weak[where R="\<lambda>s t. R s t \<and> reach E s \<and> reach F t"] dest: step)

lemma simulate_ES_with_invariants:
  assumes
    init: "\<And>s0. init E s0 \<Longrightarrow> (\<exists>t0. init F t0 \<and> R s0 t0)" and
    step: "\<And>s t a s'.
             \<lbrakk> R s t; I s; J t; E: s\<midarrow>a\<rightarrow> s' \<rbrakk> \<Longrightarrow> (\<exists>t'. (F: t\<midarrow>\<pi> a\<rightarrow> t') \<and> R s' t')" and
    invE: "\<And>s. reach E s \<longrightarrow> I s" and
    invE: "\<And>t. reach F t \<longrightarrow> J t"
  shows "E \<sqsubseteq>\<^sub>\<pi> F" using assms
  by (auto intro: simulate_ES[where R=R])

lemmas simulate_ES_with_invariant = simulate_ES_with_invariants[where J="\<lambda>s. True", simplified]

text \<open>Variants with a functional simulation relation, aka refinement mapping.\<close>

lemma simulate_ES_fun:
  assumes
    init: "\<And>s0. init E s0 \<Longrightarrow> init F (h s0)" and
    step: "\<And>s a s'. \<lbrakk> E: s\<midarrow>a\<rightarrow> s'; reach E s; reach F (h s) \<rbrakk> \<Longrightarrow> F: h s\<midarrow>\<pi> a\<rightarrow> h s'"
  shows "E \<sqsubseteq>\<^sub>\<pi> F"
  using assms
  by (auto intro!: simulate_ES[where R="\<lambda>s t. t = h s"])

lemma simulate_ES_fun_with_invariants:
  assumes
    init: "\<And>s0. init E s0 \<Longrightarrow> init F (h s0)" and
    step: "\<And>s a s'. \<lbrakk> E: s\<midarrow>a\<rightarrow> s'; I s; J (h s) \<rbrakk> \<Longrightarrow> F: h s\<midarrow>\<pi> a\<rightarrow> h s'" and
    invE: "\<And>s. reach E s \<longrightarrow> I s" and
    invF: "\<And>t. reach F t \<longrightarrow> J t"
  shows "E \<sqsubseteq>\<^sub>\<pi> F"
  using assms
  by (auto intro!: simulate_ES_fun)

lemmas simulate_ES_fun_with_invariant =
  simulate_ES_fun_with_invariants[where J="\<lambda>t. True", simplified]

text \<open>Reflexivity and transitivity for ES simulation.\<close>

lemma sim_ES_refl: "E \<sqsubseteq>\<^sub>id E"
  by (auto intro: sim_ES_I[where R="(=)"] sim_refl)

lemma sim_ES_trans:
  assumes "E \<sqsubseteq>\<^sub>\<pi>1 F" and "F \<sqsubseteq>\<^sub>\<pi>2 G" shows "E \<sqsubseteq>\<^sub>(\<pi>2 \<circ> \<pi>1) G"
proof -
  from \<open>E \<sqsubseteq>\<^sub>\<pi>1 F\<close> obtain R\<^sub>1 where
    "\<And>s0. init E s0 \<Longrightarrow> (\<exists>t0. init F t0 \<and> R\<^sub>1 s0 t0)"
    "\<And>s t. R\<^sub>1 s t \<Longrightarrow> E,F: s \<sqsubseteq>\<^sub>\<pi>1 t"
    by (auto elim!: sim_ES_E)
  moreover
  from \<open>F \<sqsubseteq>\<^sub>\<pi>2 G\<close> obtain R\<^sub>2 where
    "\<And>t0. init F t0 \<Longrightarrow> (\<exists>u0. init G u0 \<and> R\<^sub>2 t0 u0)"
    "\<And>t u. R\<^sub>2 t u \<Longrightarrow> F,G: t \<sqsubseteq>\<^sub>\<pi>2 u"
    by (auto elim!: sim_ES_E)
  ultimately show ?thesis
    by (auto intro!: sim_ES_I[where R="R\<^sub>1 OO R\<^sub>2"] sim_trans simp add: OO_def) blast
qed

subsubsection \<open>Soundness for trace inclusion and property preservation\<close>
(********************************************************************************)

lemma simulation_soundness: "E \<sqsubseteq>\<^sub>\<pi> F \<Longrightarrow> (map \<pi>)`traces E \<subseteq> traces F"
  by (fastforce simp add: sim_ES_def image_def dest: trace_sim)

lemmas simulation_rule = simulate_ES [THEN simulation_soundness]
lemmas simulation_rule_id = simulation_rule[where \<pi>="id", simplified]

text \<open>This allows us to show that properties are preserved under simulation.\<close>

(*
lemma property_preservation_trivial:
  "\<lbrakk>  map \<pi>`traces E \<subseteq> traces F; F \<Turnstile>\<^sub>E\<^sub>S P; \<And>\<tau>. map \<pi> \<tau> \<in> P \<Longrightarrow> \<tau> \<in> Q \<rbrakk> \<Longrightarrow> E \<Turnstile>\<^sub>E\<^sub>S Q"
  by (auto simp add: trace_property_def)
*)

corollary property_preservation:
  "\<lbrakk>E \<sqsubseteq>\<^sub>\<pi> F; F \<Turnstile>\<^sub>E\<^sub>S P; \<And>\<tau>. map \<pi> \<tau> \<in> P \<Longrightarrow> \<tau> \<in> Q \<rbrakk> \<Longrightarrow> E \<Turnstile>\<^sub>E\<^sub>S Q"
  by (auto simp add: trace_property_def dest: simulation_soundness)

(********************************************************************************)
subsection \<open>Simulation up to simulation preorder\<close>
(********************************************************************************)

lemma sim_coinduct_upto_sim [consumes 1, case_names sim]:
  assumes
    major:  "R s t" and
    S: "\<And>s t a s'. \<lbrakk> R s t; E: s \<midarrow>a\<rightarrow> s'\<rbrakk> \<Longrightarrow>
          \<exists>t'. (F: t \<midarrow>\<pi> a\<rightarrow> t') \<and> ((sim E E id) OO R OO (sim F F id)) s' t'"
  shows
    "E,F: s \<sqsubseteq>\<^sub>\<pi> t"
proof -
  let ?R_upto = "((sim E E id) OO R OO (sim F F id))"
  from major have "?R_upto s t" by (auto intro: sim_refl)
  then show ?thesis
  proof (coinduction arbitrary: s t)
    case (sim a s' s t)
    from \<open>((sim E E id) OO R OO (sim F F id)) s t\<close> obtain s1 t1 where
      "E,E: s \<sqsubseteq>\<^sub>id s1" "R s1 t1" "F,F: t1 \<sqsubseteq>\<^sub>id t" by (elim relcomppE)
    from \<open>E,E: s \<sqsubseteq>\<^sub>id s1\<close> \<open>E: s\<midarrow>a\<rightarrow> s'\<close>
    obtain s1' where "E: s1\<midarrow>a\<rightarrow> s1'" "E,E: s' \<sqsubseteq>\<^sub>id s1'" by (cases rule: sim.cases) auto
    from \<open>R s1 t1\<close> \<open>E: s1\<midarrow>a\<rightarrow> s1'\<close> S
    obtain t1' where "F: t1\<midarrow>\<pi> a\<rightarrow> t1'" "?R_upto s1' t1'" by force
    from \<open>F,F: t1 \<sqsubseteq>\<^sub>id t\<close> \<open>F: t1\<midarrow>\<pi> a\<rightarrow> t1'\<close>
    obtain t' where "F: t\<midarrow>\<pi> a\<rightarrow> t'" "F,F: t1' \<sqsubseteq>\<^sub>id t'" by (cases rule: sim.cases) auto
    from \<open>F: t\<midarrow>\<pi> a\<rightarrow> t'\<close> \<open>E,E: s' \<sqsubseteq>\<^sub>id s1'\<close> \<open>?R_upto s1' t1'\<close> \<open>F,F: t1' \<sqsubseteq>\<^sub>id t'\<close>
    have "((sim E E id) OO R OO (sim F F id)) s' t'"
      apply(auto simp add: OO_def) using comp_id sim_trans by metis
    then have "\<exists>t'. (F: t\<midarrow>\<pi> a\<rightarrow> t') \<and> ?R_upto s' t'"
      using \<open>F: t\<midarrow>\<pi> a\<rightarrow> t'\<close> by (auto intro: sim_trans)
    then show ?case using S by fastforce
  qed
qed

end


theory Tries
imports Main "HOL-Word.Word"
begin

datatype ('v) bintrie =
  TLeaf
  | TNode "'v option" "('v) bintrie" "('v) bintrie"

class rx_key =
  fixes rx_divmod ::
    "'a \<Rightarrow> ('a * bool) option"
  fixes rx_emp :: "'a"
  fixes rx_size :: "'a \<Rightarrow> nat"

  assumes rx_divmod_distinct :
    "\<And> (x :: 'a) (x' :: 'a) .
      rx_divmod x = rx_divmod x' \<Longrightarrow> x = x'"

  assumes rx_size_emp : "rx_size rx_emp = 0"

  assumes rx_size_divmod :
    "rx_divmod x = Some (y, b) \<Longrightarrow> rx_size x > rx_size y"
begin
end

lemma rx_divmod_emp :
  "rx_divmod (rx_emp :: 'a :: rx_key) = None"
proof(cases "rx_divmod (rx_emp :: 'a :: rx_key)")
  case None
  then show ?thesis
    by(auto)
next
  case (Some a)
  obtain y b where A : "a = (y, b)"
    by(cases a; auto)
  then show ?thesis
    using rx_size_divmod[of "rx_emp :: 'a :: rx_key" y b]
    unfolding rx_size_emp using Some A by auto
qed

lemma rx_emp_size :
  fixes a :: "'a :: rx_key"
  assumes H : "rx_size a = 0"
  shows "a = rx_emp"
proof(cases "rx_divmod a")
  case None
  then show ?thesis using rx_divmod_distinct[of a rx_emp]
    unfolding rx_divmod_emp by auto
next
  case (Some a')
  obtain y b where A' : "a' = (y, b)"
    by(cases a'; auto)
  then show ?thesis
    using H rx_size_divmod[of a y b] Some by auto
qed

(*
function (sequential) bt_insert ::
  "'v bintrie \<Rightarrow> ('k :: semiring_bits) \<Rightarrow> 'v \<Rightarrow> 'v bintrie" where
"bt_insert TLeaf k v =
  (if k = 0 then TNode (Some v) TLeaf TLeaf
   else
   (if k mod 2 = 0 then
       TNode None (bt_insert TLeaf (k div 2) v) TLeaf
    else
       TNode None TLeaf (bt_insert TLeaf (k div 2) v)))"
| "bt_insert (TNode x t1 t2) k v =
   (if k = 0 then TNode (Some v) t1 t2
    else
    (if k mod 2 = 0 then
        TNode x (bt_insert t1 (k div 2) v) t2
     else
        TNode x t1 (bt_insert t2 (k div 2) v)))"
  by pat_completeness auto
*)

function (sequential) bt_insert ::
  "'v bintrie \<Rightarrow> ('k :: rx_key) \<Rightarrow> 'v \<Rightarrow> 'v bintrie" where
"bt_insert TLeaf k v =
  (case rx_divmod  k of
    None \<Rightarrow> TNode (Some v) TLeaf TLeaf
    | Some (k', False) \<Rightarrow> TNode None (bt_insert TLeaf (k') v) TLeaf
    | Some (k', True) \<Rightarrow> TNode None TLeaf (bt_insert TLeaf (k') v))"
| "bt_insert (TNode x t1 t2) k v =
  (case rx_divmod  k of
    None \<Rightarrow> TNode (Some v) t1 t2
    | Some (k', False) \<Rightarrow> TNode x (bt_insert t1 (k') v) t2
    | Some (k', True) \<Rightarrow> TNode x t1 (bt_insert t2 (k') v))"
  by pat_completeness auto

termination
  by(relation "measure (\<lambda> (t, k, v) . rx_size k)";
      auto simp add: rx_size_divmod)

function (sequential) bt_get ::
  "'v bintrie \<Rightarrow> ('k :: rx_key) \<Rightarrow> 'v option" where
"bt_get TLeaf k = None"
| "bt_get (TNode x t1 t2) k =
  (case rx_divmod k of
   None \<Rightarrow> x
   | Some (k', False) \<Rightarrow> bt_get t1 k'
   | Some (k', True) \<Rightarrow> bt_get t2 k')"
  by pat_completeness auto

termination
  by(relation "measure (\<lambda> (t, k) . rx_size k)";
      auto simp add: rx_size_divmod)

lemma bt_insert_get_eq :
  fixes t :: "('v) bintrie"
  fixes k :: "'k :: rx_key"
  shows "bt_get (bt_insert t k v) k = Some v"
proof(induction "rx_size k" arbitrary: k t v rule: nat_less_induct)
  case 1
  show ?case
  proof(cases t)
    case TLeaf
    show ?thesis
    proof(cases "rx_divmod k")
      case None
      then show ?thesis using TLeaf by(simp)
    next
      case (Some a)
      obtain b k' where A : "a = (k', b)"
        by(cases a; auto)

      have LessSz : "rx_size k' < rx_size k"
        using rx_size_divmod Some A by auto

      show ?thesis
      proof(cases b)
        case True

        (* TODO: this is _awful_ *)
        then show ?thesis using True Some TLeaf
          spec[OF mp[OF spec[OF HOL.mp[OF spec[OF "1", of "rx_size k'"] LessSz], of k'] refl]
              , of TLeaf] A
          by(auto)
      next
        case False
        then show ?thesis using Some TLeaf
          spec[OF mp[OF spec[OF HOL.mp[OF spec[OF "1", of "rx_size k'"] LessSz], of k'] refl]
              , of TLeaf] A
          by(auto)
      qed
    qed
  next
    case (TNode vx t1 t2)
    show ?thesis
    proof(cases "rx_divmod k")
      case None
      then show ?thesis using TNode by(simp)
    next
      case (Some a)
      obtain b k' where A : "a = (k', b)"
        by(cases a; auto)

      have LessSz : "rx_size k' < rx_size k"
        using rx_size_divmod Some A by auto

      show ?thesis
      proof(cases b)
        case True

        (* TODO: this is _awful_ *)
        then show ?thesis using True Some TNode
          spec[OF mp[OF spec[OF HOL.mp[OF spec[OF "1", of "rx_size k'"] LessSz], of k'] refl]
              , of t2] A
          by(auto)
      next
        case False
        then show ?thesis using Some TNode
          spec[OF mp[OF spec[OF HOL.mp[OF spec[OF "1", of "rx_size k'"] LessSz], of k'] refl]
              , of t1] A
          by(auto)
      qed
    qed
  qed
qed

lemma bt_insert_get_neq :
  fixes t :: "('v) bintrie"
  fixes k k' :: "'k :: rx_key"
  assumes H : "k \<noteq> k'"
  shows "bt_get (bt_insert t k' v) k = bt_get t k" using assms
proof(induction "rx_size k" arbitrary: k k' t v rule: nat_less_induct)
  case 1
  show ?case
  proof(cases t)
    case TLeaf
    show ?thesis
    proof(cases "rx_divmod k")
      case None

      show ?thesis
      proof(cases "rx_divmod k'")
        case None' : None
        then show ?thesis using "1.prems" TLeaf None rx_divmod_distinct[of k k'] by(auto)
      next
        case Some' : (Some a')
        obtain j' b' where A' : "a' = (j', b')" by(cases a'; auto)

        show ?thesis
        proof(cases b')
          case True' : True
          then show ?thesis using A' Some' None TLeaf by(auto)
        next
          case False' : False
          then show ?thesis using A' Some' None TLeaf by(auto)
        qed
      qed
    next
      case (Some a)
      obtain j b where A : "a = (j, b)"
        by(cases a; auto)

      have LessSz : "rx_size j < rx_size k"
        using rx_size_divmod Some A by auto

      show ?thesis
      proof(cases "rx_divmod k'")
        case None' : None
        show ?thesis
        proof(cases b)
          case True
          then show ?thesis using A Some None' TLeaf by(auto)
        next
          case False
          then show ?thesis using A Some None' TLeaf by(auto)
        qed
      next
        case Some' : (Some a')
        obtain j' b' where A' : "a' = (j', b')" by(cases a'; auto)

        have LessSz' : "rx_size j' < rx_size k'"
          using rx_size_divmod Some' A' by auto

        show ?thesis
        proof(cases b)
          case True
          show ?thesis
          proof(cases b')
            case True' : True

            have Neq' : "j \<noteq> j'"
              using rx_divmod_distinct[of k k']
                A A' Some Some' True True' TLeaf "1"(2)
              by(auto)

            then show ?thesis using A A' Some Some' True True' TLeaf
                spec[OF mp[OF spec[OF mp[OF spec[OF mp[OF spec[OF "1"(1), of "rx_size j"] LessSz], of j] refl], of j'] Neq']
                    , of TLeaf]
              by(auto)
          next
            case False' : False
            then show ?thesis using A A' Some Some' True False' TLeaf by(auto)
          qed
        next
          case False
          show ?thesis
          proof(cases b')
            case True' : True
            then show ?thesis using A A' Some Some' False True' TLeaf by(auto)
          next
            case False' : False
            have Neq' : "j \<noteq> j'"
              using rx_divmod_distinct[of k k']
                A A' Some Some' False False' TLeaf "1"(2)
              by(auto)

            then show ?thesis using A A' Some Some' False False' TLeaf
                spec[OF mp[OF spec[OF mp[OF spec[OF mp[OF spec[OF "1"(1), of "rx_size j"] LessSz], of j] refl], of j'] Neq']
                    , of TLeaf]
              by(auto)
          qed
        qed
      qed
    qed
  next
    case (TNode vx t1 t2)
    show ?thesis
    proof(cases "rx_divmod k")
      case None

      show ?thesis
      proof(cases "rx_divmod k'")
        case None' : None
        then show ?thesis using "1.prems" TNode None rx_divmod_distinct[of k k'] by(auto)
      next
        case Some' : (Some a')
        obtain j' b' where A' : "a' = (j', b')" by(cases a'; auto)

        show ?thesis
        proof(cases b')
          case True' : True
          then show ?thesis using A' Some' None TNode by(auto)
        next
          case False' : False
          then show ?thesis using A' Some' None TNode by(auto)
        qed
      qed
    next
      case (Some a)
      obtain j b where A : "a = (j, b)"
        by(cases a; auto)

      have LessSz : "rx_size j < rx_size k"
        using rx_size_divmod Some A by auto

      show ?thesis
      proof(cases "rx_divmod k'")
        case None' : None
        show ?thesis
        proof(cases b)
          case True
          then show ?thesis using A Some None' TNode by(auto)
        next
          case False
          then show ?thesis using A Some None' TNode by(auto)
        qed
      next
        case Some' : (Some a')
        obtain j' b' where A' : "a' = (j', b')" by(cases a'; auto)

        have LessSz' : "rx_size j' < rx_size k'"
          using rx_size_divmod Some' A' by auto

        show ?thesis
        proof(cases b)
          case True
          show ?thesis
          proof(cases b')
            case True' : True

            have Neq' : "j \<noteq> j'"
              using rx_divmod_distinct[of k k']
                A A' Some Some' True True' TNode "1"(2)
              by(auto)

            then show ?thesis using A A' Some Some' True True' TNode
                spec[OF mp[OF spec[OF mp[OF spec[OF mp[OF spec[OF "1"(1), of "rx_size j"] LessSz], of j] refl], of j'] Neq']
                    , of t2]
              by(auto)
          next
            case False' : False
            then show ?thesis using A A' Some Some' True False' TNode by(auto)
          qed
        next
          case False
          show ?thesis
          proof(cases b')
            case True' : True
            then show ?thesis using A A' Some Some' False True' TNode by(auto)
          next
            case False' : False
            have Neq' : "j \<noteq> j'"
              using rx_divmod_distinct[of k k']
                A A' Some Some' False False' TNode "1"(2)
              by(auto)

            then show ?thesis using A A' Some Some' False False' TNode
                spec[OF mp[OF spec[OF mp[OF spec[OF mp[OF spec[OF "1"(1), of "rx_size j"] LessSz], of j] refl], of j'] Neq']
                    , of t1]
              by(auto)
          qed
        qed
      qed
    qed
  qed
qed

(* instances: nat, word, string literal *)

fun rx_divmod_nat ::
  "nat \<Rightarrow> (nat * bool) option" where
"rx_divmod_nat i =
  (if i = (0 :: nat) then None
   else Some (i div 2, (i mod 2 = 1)))"

lemma rx_divmod_nat_distinct :
  assumes H : "rx_divmod_nat n1 = rx_divmod_nat n2"
  shows "n1 = n2" using assms
proof(induction n1  arbitrary: n2 rule: nat_bit_induct)
  case zero
  then show ?case
    by(cases n2; auto)
next
  case (even n)
  show ?case
  proof(cases n2)
    case 0
    then show ?thesis using even
      by(auto)
  next
    case (Suc nat)
    then show ?thesis using even
      by(auto)
  qed
next
  case (odd n)
  show ?case
  proof(cases n)
    case 0
    then show ?thesis
    proof(cases n2)
      case Zero' : 0
      then show ?thesis using 0 odd.prems
        by(auto)
    next
      case (Suc nat)
      then show ?thesis using 0 odd.prems
        by(auto)
    qed
  next
    case (Suc n')
    then show ?thesis
    proof(cases n2)
      case Zero' : 0
      then show ?thesis using Suc odd.prems
        by(auto)
    next
      case Suc' : (Suc nat)
      have Odd: "odd (Suc nat)"
        using Suc odd.prems Suc'
        unfolding odd_iff_mod_2_eq_one
        by(clarsimp)

      then show ?thesis using Suc odd.prems Suc'
          odd_two_times_div_two_nat[OF Odd]
          odd.IH[of "n2 div 2"]
        by(auto)
    qed
  qed
qed

instantiation nat :: rx_key begin

definition nat_rx_divmod :
"rx_divmod = rx_divmod_nat "

definition nat_rx_emp :
"rx_emp = (0 :: nat)"

definition nat_rx_size :
"rx_size n = (n :: nat)"

instance proof
  fix x x' :: nat
  show "rx_divmod x = rx_divmod x' \<Longrightarrow> x = x'"
    using rx_divmod_nat_distinct[of x x']
    unfolding nat_rx_divmod
    by auto
next
  show "rx_size (rx_emp :: nat) = (0 :: nat)"
    unfolding nat_rx_emp nat_rx_size by auto
next
  fix x y :: nat
  fix b :: bool
  assume "rx_divmod x = Some (y, b)"
  then show "rx_size y < rx_size x"
    by(cases x; auto simp add: nat_rx_divmod nat_rx_size)
qed
end

fun rx_divmod_word ::
  "(('a :: len) word) \<Rightarrow> (('a :: len) word * bool) option" where
"rx_divmod_word i =
  (if i = word_of_int 0 then None
   else Some (word_of_int ((uint i) div 2), ((uint i) mod 2 = 1)))"

(* TODO *)
lemma rx_divmod_word_distinct :
  fixes w1 w2 :: "('a :: len) word"
  assumes H : "rx_divmod_word w1 = rx_divmod_word w2"
  shows "w1 = w2" using assms
proof(cases "w1 = 0")
  case True
  show ?thesis
  proof(cases "w2 = 0")
    case True' : True
    then show ?thesis using True by auto
  next
    case False' : False
    then show ?thesis using H True by(auto)
  qed
next
  case False
  show ?thesis
  proof(cases "w2 = 0")
    case True' : True
    then show ?thesis using H False
      by(auto)
  next
    case False' : False
    then show ?thesis
    proof(cases "uint w1 mod 2 = 1")
      case True'' : True

      have Eq : "(word_of_int (uint w1 div 2) :: 'a word) = word_of_int (uint w2 div 2)"
        using False False' H True''
        by(auto)

      have Lt1 : "uint w1 < 2 ^ LENGTH('a)"
        using uint_lt[of w1] by auto

      hence Lt1' : "uint w1 div 2 < 2 ^ LENGTH('a)"
        using uint_0[of w1] by(arith)

      have Lt2 : "uint w2 < 2 ^ LENGTH('a)"
        using uint_lt[of w2] by auto

      hence Lt2' : "uint w2 div 2 < 2 ^ LENGTH('a)"
        using uint_0[of w2] by(arith)

      have Ge1 : "0 \<le> uint w1 div 2" using uint_0[of w1]
        by arith

      have Ge2 : "0 \<le> uint w2 div 2" using uint_0[of w2]
        by arith

      have "uint w1 div 2 = uint w2 div 2"
        using arg_cong[OF Eq, of uint]
           uint_0[of "w2 div 2"] uint_0[of "w1 div 2"]
          int_mod_eq'[OF Ge1 Lt1'] int_mod_eq'[OF Ge2  Lt2']
        by(simp add: uint_word_of_int)

      then show ?thesis using H False False' True''
          Misc_Arithmetic.dme[of "uint w1" 2]
          Misc_Arithmetic.dme[of "uint w2" 2]
        by(auto)
    next
      case False'' : False
      then obtain q qa where
        Q: "uint w1 = 2 * q" "uint w2 = 2 * qa" and
           Qeq : "(word_of_int q :: 'a word) = word_of_int qa"
        using False False' H by(auto)

      have Qgt0 : "0 \<le> q"
        using Word.uint_range'[of w1] Q by auto

      have QLt : "q < 2 ^ LENGTH('a)" using uint_lt[of w1] Q Qgt0
        by(auto)

      have Qagt0 : "0 \<le> qa"
        using Word.uint_range'[of w2] Q by auto

      have QaLt : "qa < 2 ^ LENGTH('a)" using uint_lt[of w2] Q Qagt0
        by(auto)

      have Qeq' : "q = qa"
        using False False' H Q Qeq
        unfolding word.abs_eq_iff no_bintr_alt1
          using int_mod_eq'[OF Qgt0 QLt] int_mod_eq'[OF Qagt0 QaLt]
          by(auto)

      show ?thesis using False False' H Q Qeq word_uint_eqI[of w1 w2]
        unfolding word.abs_eq_iff no_bintr_alt1 Qeq'
        by(auto)
    qed
  qed
qed

instantiation word :: (len) rx_key begin
definition word_rx_divmod :
  "rx_divmod (w :: ('a :: len) word) = rx_divmod_word w"

definition word_rx_emp :
"rx_emp = (word_of_int 0 :: 'a word)"

definition word_rx_size :
"rx_size (n :: ('a :: len) word) =
  unat n"

instance proof
  fix x x' :: "'a word"
  show "rx_divmod x = rx_divmod x' \<Longrightarrow> x = x'"
    using rx_divmod_word_distinct[of x x']
    unfolding word_rx_divmod by auto
next
  show "rx_size (rx_emp :: 'a word) = (0::nat)"
    unfolding word_rx_emp word_rx_size by auto
next
  fix x y :: "'a word"
  fix b :: bool
  assume H: "rx_divmod x = Some (y, b)"
  then show "rx_size y < rx_size x"
  proof(cases "x = 0")
    case True
    then show ?thesis using H by(simp add: word_rx_size word_rx_divmod)
  next
    case False

    then have NZ : "uint x \<noteq> 0"
      using word_uint_eqI[of x 0]
      by(cases "uint x = 0"; auto)

    have GZ : "(0::int) < uint x"
      using NZ uint_ge_0[of x] by(arith)

    have Rew2 : "\<And> q . 0 < q \<Longrightarrow> q mod (2::int) ^ LENGTH('a) < (2::int) * q"
    proof-
      fix q :: int
      assume H : "0 < q"
      have Leq : "q mod (2::int) ^ LENGTH('a) \<le> q" using int_mod_le H
        by auto

      have Lt : "q < (2 :: int) * q" using H by auto

      thus "q mod (2::int) ^ LENGTH('a) < (2::int) * q"
        using Leq Lt by arith
    qed

    show ?thesis
    proof(cases "(uint x mod (2::int) = (1::int))")
      case True' : True

      have Rew1 : "(uint x div (2::int)) mod (2::int) ^ LENGTH('a) < uint x"
      proof-
        have Lt : "uint x div 2 < uint x" using GZ by auto

        have Leq : "(uint x div (2::int)) mod (2::int) ^ LENGTH('a) \<le> uint x div 2"
          using int_mod_le GZ by auto

        show "(uint x div (2::int)) mod (2::int) ^ LENGTH('a) < uint x"
          using Lt Leq by arith
      qed

      show ?thesis using True' False GZ H uint_0[of x]
        by(auto simp add: word_rx_size word_rx_divmod unat_def uint_word_of_int Rew1)
    next
      case False' : False
      then show ?thesis using False GZ H uint_0[of x]
        by(auto simp add: word_rx_size word_rx_divmod unat_def uint_word_of_int Rew2 )
    qed
  qed
qed
end

type_synonym partial_char =
    "(bool *
     (bool *
     (bool *
     (bool *
     (bool *
     (bool *
      bool option) option) option) option) option) option) option"

fun partial_char_sz :: "partial_char \<Rightarrow> nat" where
"partial_char_sz None = 0"
| "partial_char_sz (Some (_, None)) = 1"
| "partial_char_sz (Some (_, Some (_, None))) = 2"
| "partial_char_sz (Some (_, Some (_, Some (_, None)))) = 3"
| "partial_char_sz (Some (_, Some (_, Some (_, Some (_, None))))) = 4"
| "partial_char_sz (Some (_, Some (_, Some (_, Some (_, Some (_, None)))))) = 5"
| "partial_char_sz (Some (_, Some (_, Some (_, Some (_, Some (_, Some (_, None))))))) = 6"
| "partial_char_sz (Some (_, Some (_, Some (_, Some (_, Some (_, Some (_, Some _))))))) = 7"

fun partial_char_split :: "char \<Rightarrow> partial_char * bool" where
"partial_char_split c =
 (Some (digit1 c, Some (digit2 c, Some (digit3 c, Some (digit4 c,
  Some (digit5 c, Some (digit6 c, Some (digit7 c))))))), digit0 c)"

fun partial_char_divmod ::
  "partial_char \<Rightarrow> (partial_char * bool) option" where
"partial_char_divmod None = None"
| "partial_char_divmod (Some (b, None)) = Some (None, b)"
| "partial_char_divmod
  (Some (b0, Some (b1, None))) =
  Some (Some (b1, None), b0)"
| "partial_char_divmod
  (Some (b0, Some (b1, Some (b2, None)))) =
   Some (Some (b1, Some (b2, None)), b0)"
| "partial_char_divmod
  (Some (b0, Some (b1, Some (b2, Some (b3, None))))) =
   Some (Some (b1, Some (b2, Some (b3, None))), b0)"
| "partial_char_divmod
  (Some (b0, Some (b1, Some (b2, Some (b3, Some (b4, None)))))) =
   Some (Some (b1, Some (b2, Some (b3, Some (b4, None)))), b0)"
| "partial_char_divmod
  (Some (b0, Some (b1, Some (b2, Some (b3, Some (b4, Some (b5, None))))))) =
   Some (Some (b1, Some (b2, Some (b3, Some (b4, Some (b5, None))))), b0)"
| "partial_char_divmod
  (Some (b0, Some (b1, Some (b2, Some (b3, Some (b4, Some (b5, Some (b6)))))))) =
  Some (Some (b1, Some (b2, Some (b3, Some (b4, Some (b5, Some (b6, None)))))), b0)"

datatype str' =
  S "char list"
    "partial_char"

definition str'_emp :: "str'" where
"str'_emp = S [] None"

fun str'_size :: "str' \<Rightarrow> nat" where
"str'_size (S l pc) = 8 * length l + partial_char_sz pc"

fun str'_divmod :: "str' \<Rightarrow> (str' * bool) option" where
"str'_divmod (S [] None) = None"
| "str'_divmod (S (ch#ct) None) =
   (case partial_char_split ch of
    (pc, b) \<Rightarrow> Some (S ct pc, b))"
| "str'_divmod (S t (Some (X))) =
  (case partial_char_divmod (Some X) of
   None \<Rightarrow> None \<comment> \<open>bogus\<close>
   | Some (pc', b) \<Rightarrow> Some (S t pc', b))"

fun str'_of_lit :: "String.literal \<Rightarrow> str'" where
"str'_of_lit l =
  (S (String.explode l) None)"

instantiation str' :: rx_key begin
definition str'_rx_divmod :
  "rx_divmod (s :: str') = str'_divmod s"

definition str'_rx_emp :
"rx_emp = S [] None"

definition str'_rx_size :
"rx_size (n :: str') = str'_size n"

instance sorry
end

end


(*
  File: IntervalTree_Impl.thy
  Author: Bohua Zhan
*)

section \<open>Implementation of interval tree\<close>

theory IntervalTree_Impl
  imports SepAuto "../Functional/Interval_Tree"
begin

text \<open>Imperative version of interval tree.\<close>

subsection \<open>Interval and IdxInterval\<close>

fun interval_encode :: "('a::heap) interval \<Rightarrow> nat" where
  "interval_encode (Interval l h) = to_nat (l, h)"

instance interval :: (heap) heap
  apply (rule heap_class.intro)
  apply (rule countable_classI [of "interval_encode"])
  apply (case_tac x, simp_all, case_tac y, simp_all)
  ..

fun idx_interval_encode :: "('a::heap) idx_interval \<Rightarrow> nat" where
  "idx_interval_encode (IdxInterval it i) = to_nat (it, i)"

instance idx_interval :: (heap) heap
  apply (rule heap_class.intro)
  apply (rule countable_classI [of "idx_interval_encode"])
  apply (case_tac x, simp_all, case_tac y, simp_all)
  ..

subsection \<open>Tree nodes\<close>

datatype 'a node =
  Node (lsub: "'a node ref option") (val: "'a idx_interval") (tmax: nat) (rsub: "'a node ref option")
setup \<open>fold add_rewrite_rule @{thms node.sel}\<close>

fun node_encode :: "('a::heap) node \<Rightarrow> nat" where
  "node_encode (Node l v m r) = to_nat (l, v, m, r)"

instance node :: (heap) heap
  apply (rule heap_class.intro)
  apply (rule countable_classI [of "node_encode"])
  apply (case_tac x, simp_all, case_tac y, simp_all)
  ..

fun int_tree :: "interval_tree \<Rightarrow> nat node ref option \<Rightarrow> assn" where
  "int_tree Tip p = \<up>(p = None)"
| "int_tree (interval_tree.Node lt v m rt) (Some p) = (\<exists>\<^sub>Alp rp. p \<mapsto>\<^sub>r Node lp v m rp * int_tree lt lp * int_tree rt rp)"
| "int_tree (interval_tree.Node lt v m rt) None = false"
setup \<open>fold add_rewrite_ent_rule @{thms int_tree.simps}\<close>

lemma int_tree_Tip [forward_ent]: "int_tree Tip p \<Longrightarrow>\<^sub>A \<up>(p = None)" by auto2

lemma int_tree_Node [forward_ent]:
  "int_tree (interval_tree.Node lt v m rt) p \<Longrightarrow>\<^sub>A (\<exists>\<^sub>Alp rp. the p \<mapsto>\<^sub>r Node lp v m rp * int_tree lt lp * int_tree rt rp * \<up>(p \<noteq> None))"
@proof @case "p = None" @qed

lemma int_tree_none: "emp \<Longrightarrow>\<^sub>A int_tree interval_tree.Tip None" by auto2

lemma int_tree_constr_ent:
  "p \<mapsto>\<^sub>r Node lp v m rp * int_tree lt lp * int_tree rt rp \<Longrightarrow>\<^sub>A int_tree (interval_tree.Node lt v m rt) (Some p)" by auto2

setup \<open>fold add_entail_matcher [@{thm int_tree_none}, @{thm int_tree_constr_ent}]\<close>
setup \<open>fold del_prfstep_thm @{thms int_tree.simps}\<close>

type_synonym int_tree = "nat node ref option"

subsection \<open>Operations\<close>

subsubsection \<open>Basic operation\<close>

definition int_tree_empty :: "int_tree Heap" where
  "int_tree_empty = return None"

lemma int_tree_empty_to_fun [hoare_triple]:
  "<emp> int_tree_empty <int_tree Tip>" by auto2

definition int_tree_is_empty :: "int_tree \<Rightarrow> bool Heap" where
  "int_tree_is_empty b = return (b = None)"

lemma int_tree_is_empty_rule [hoare_triple]:
  "<int_tree t b>
   int_tree_is_empty b
   <\<lambda>r. int_tree t b * \<up>(r \<longleftrightarrow> t = Tip)>" by auto2

definition get_tmax :: "int_tree \<Rightarrow> nat Heap" where
  "get_tmax b = (case b of
     None \<Rightarrow> return 0
   | Some p \<Rightarrow> do {
      t \<leftarrow> !p;
      return (tmax t) })"

lemma get_tmax_rule [hoare_triple]:
  "<int_tree t b> get_tmax b <\<lambda>r. int_tree t b * \<up>(r = interval_tree.tmax t)>"
@proof @case "t = Tip" @qed

definition compute_tmax :: "nat idx_interval \<Rightarrow> int_tree \<Rightarrow> int_tree \<Rightarrow> nat Heap" where
  "compute_tmax it l r = do {
    lm \<leftarrow> get_tmax l;
    rm \<leftarrow> get_tmax r;
    return (max3 it lm rm)
  }"

lemma compute_tmax_rule [hoare_triple]:
  "<int_tree t1 b1 * int_tree t2 b2>
   compute_tmax it b1 b2
   <\<lambda>r. int_tree t1 b1 * int_tree t2 b2 * \<up>(r = max3 it (interval_tree.tmax t1) (interval_tree.tmax t2))>"
  by auto2

definition int_tree_constr :: "int_tree \<Rightarrow> nat idx_interval \<Rightarrow> int_tree \<Rightarrow> int_tree Heap" where
  "int_tree_constr lp v rp = do {
    m \<leftarrow> compute_tmax v lp rp;
    p \<leftarrow> ref (Node lp v m rp);
    return (Some p) }"

lemma int_tree_constr_rule [hoare_triple]:
  "<int_tree lt lp * int_tree rt rp>
   int_tree_constr lp v rp
   <int_tree (interval_tree.Node lt v (max3 v (interval_tree.tmax lt) (interval_tree.tmax rt)) rt)>"
  by auto2

subsubsection \<open>Insertion\<close>

partial_function (heap) insert_impl :: "nat idx_interval \<Rightarrow> int_tree \<Rightarrow> int_tree Heap" where
  "insert_impl v b = (case b of
    None \<Rightarrow> int_tree_constr None v None
  | Some p \<Rightarrow> do {
    t \<leftarrow> !p;
    (if v = val t then do {
       return (Some p) }
     else if v < val t then do {
       q \<leftarrow> insert_impl v (lsub t);
       m \<leftarrow> compute_tmax (val t) q (rsub t);
       p := Node q (val t) m (rsub t);
       return (Some p) }
     else do {
       q \<leftarrow> insert_impl v (rsub t);
       m \<leftarrow> compute_tmax (val t) (lsub t) q;
       p := Node (lsub t) (val t) m q;
       return (Some p) })})"

lemma int_tree_insert_to_fun [hoare_triple]:
  "<int_tree t b>
    insert_impl v b
   <int_tree (insert v t)>"
@proof @induct t arbitrary b @qed

subsubsection \<open>Deletion\<close>

partial_function (heap) int_tree_del_min :: "int_tree \<Rightarrow> (nat idx_interval \<times> int_tree) Heap" where
  "int_tree_del_min b = (case b of
     None \<Rightarrow> raise STR ''del_min: empty tree''
   | Some p \<Rightarrow> do {
      t \<leftarrow> !p;
      (if lsub t = None then
         return (val t, rsub t)
       else do {
         r \<leftarrow> int_tree_del_min (lsub t);
         m \<leftarrow> compute_tmax (val t) (snd r) (rsub t);
         p := Node (snd r) (val t) m (rsub t);
         return (fst r, Some p) })})"

lemma int_tree_del_min_to_fun [hoare_triple]:
  "<int_tree t b * \<up>(b \<noteq> None)>
   int_tree_del_min b
   <\<lambda>r. int_tree (snd (del_min t)) (snd r) * \<up>(fst(r) = fst (del_min t))>\<^sub>t"
@proof @induct t arbitrary b @qed

definition int_tree_del_elt :: "int_tree \<Rightarrow> int_tree Heap" where
  "int_tree_del_elt b = (case b of
     None \<Rightarrow> raise STR ''del_elt: empty tree''
   | Some p \<Rightarrow> do {
       t \<leftarrow> !p;
       (if lsub t = None then return (rsub t)
        else if rsub t = None then return (lsub t)
        else do {
          r \<leftarrow> int_tree_del_min (rsub t);
          m \<leftarrow> compute_tmax (fst r) (lsub t) (snd r);
          p := Node (lsub t) (fst r) m (snd r);
          return (Some p) }) })"

lemma int_tree_del_elt_to_fun [hoare_triple]:
  "<int_tree (interval_tree.Node lt v m rt) b>
   int_tree_del_elt b
   <int_tree (delete_elt_tree (interval_tree.Node lt v m rt))>\<^sub>t" by auto2

partial_function (heap) delete_impl :: "nat idx_interval \<Rightarrow> int_tree \<Rightarrow> int_tree Heap" where
  "delete_impl x b = (case b of
     None \<Rightarrow> return None
   | Some p \<Rightarrow> do {
      t \<leftarrow> !p;
      (if x = val t then do {
         r \<leftarrow> int_tree_del_elt b;
         return r }
       else if x < val t then do {
         q \<leftarrow> delete_impl x (lsub t);
         m \<leftarrow> compute_tmax (val t) q (rsub t);
         p := Node q (val t) m (rsub t);
         return (Some p) }
       else do {
         q \<leftarrow> delete_impl x (rsub t);
         m \<leftarrow> compute_tmax (val t) (lsub t) q;
         p := Node (lsub t) (val t) m q;
         return (Some p) })})"

lemma int_tree_delete_to_fun [hoare_triple]:
  "<int_tree t b>
    delete_impl x b
   <int_tree (delete x t)>\<^sub>t"
@proof @induct t arbitrary b @qed

subsubsection \<open>Search\<close>

partial_function (heap) search_impl :: "nat interval \<Rightarrow> int_tree \<Rightarrow> bool Heap" where
  "search_impl x b = (case b of
     None \<Rightarrow> return False
   | Some p \<Rightarrow> do {
      t \<leftarrow> !p;
      (if is_overlap (int (val t)) x then return True
       else case lsub t of
           None \<Rightarrow> do { b \<leftarrow> search_impl x (rsub t); return b }
         | Some lp \<Rightarrow> do {
            lt \<leftarrow> !lp;
            if tmax lt \<ge> low x then
              do { b \<leftarrow> search_impl x (lsub t); return b }
            else
              do { b \<leftarrow> search_impl x (rsub t); return b }})})"

lemma search_impl_correct [hoare_triple]:
  "<int_tree t b>
    search_impl x b
   <\<lambda>r. int_tree t b * \<up>(r \<longleftrightarrow> search t x)>"
@proof @induct t arbitrary b @with
  @subgoal "t = interval_tree.Node l v m r"
    @case "is_overlap (int v) x"
    @case "l \<noteq> Tip \<and> interval_tree.tmax l \<ge> low x"
  @endgoal @end
@qed

subsection \<open>Outer interface\<close>

text \<open>Express Hoare triples for operations on interval tree in terms of
  the set of intervals represented by the tree.\<close>
definition int_tree_set :: "nat idx_interval set \<Rightarrow> int_tree \<Rightarrow> assn" where
  "int_tree_set S p = (\<exists>\<^sub>At. int_tree t p * \<up>(is_interval_tree t) * \<up>(S = tree_set t))"
setup \<open>add_rewrite_ent_rule @{thm int_tree_set_def}\<close>

theorem int_tree_empty_rule [hoare_triple]:
  "<emp> int_tree_empty <int_tree_set {}>" by auto2

theorem int_tree_insert_rule [hoare_triple]:
  "<int_tree_set S b * \<up>(is_interval (int x))>
   insert_impl x b
   <int_tree_set (S \<union> {x})>" by auto2

theorem int_tree_delete_rule [hoare_triple]:
  "<int_tree_set S b * \<up>(is_interval (int x))>
   delete_impl x b
   <int_tree_set (S - {x})>\<^sub>t" by auto2

theorem int_tree_search_rule [hoare_triple]:
  "<int_tree_set S b * \<up>(is_interval x)>
   search_impl x b
   <\<lambda>r. int_tree_set S b * \<up>(r \<longleftrightarrow> has_overlap S x)>" by auto2

setup \<open>del_prfstep_thm @{thm int_tree_set_def}\<close>

end


(*  File:       Plurality_Module.thy
    Copyright   2021  Karlsruhe Institute of Technology (KIT)
*)
\<^marker>\<open>creator "Karsten Diekhoff, Karlsruhe Institute of Technology (KIT)"\<close>
\<^marker>\<open>contributor "Jonas Kraemer, Karlsruhe Institute of Technology (KIT)"\<close>
\<^marker>\<open>contributor "Michael Kirsten, Karlsruhe Institute of Technology (KIT)"\<close>

section \<open>Plurality Module\<close>

theory Plurality_Module
  imports "Component_Types/Electoral_Module"
begin

text
\<open>The plurality module implements the plurality voting rule.
The plurality rule elects all modules with the maximum amount of top
preferences among all alternatives, and rejects all the other alternatives.
It is electing and induces the classical plurality (voting) rule
from social-choice theory.\<close>

subsection \<open>Definition\<close>

fun plurality :: "'a Electoral_Module" where
  "plurality A p vs=
    ({a \<in> A. \<forall>x \<in> A. win_count p x \<le> win_count p a},
     {a \<in> A. \<exists>x \<in> A. win_count p x > win_count p a},
     {})"

subsection \<open>Soundness\<close>

theorem plurality_sound[simp]: "electoral_module plurality"
proof -
  have
    "\<forall>A p.
      let elect = {a \<in> (A::'a set). \<forall>x \<in> A. win_count p x \<le> win_count p a};
      reject = {a \<in> A. \<exists>x \<in> A. win_count p x > win_count p a} in
    elect \<inter> reject = {}"
    by auto
  hence disjoint:
    "\<forall>A p.
      let elect = {a \<in> (A::'a set). \<forall>x \<in> A. win_count p x \<le> win_count p a};
      reject = {a \<in> A. \<exists>x \<in> A. win_count p x > win_count p a} in
    disjoint3 (elect, reject, {})"
    by simp
  have
    "\<forall>A p.
      let elect = {a \<in> (A::'a set). \<forall>x \<in> A. win_count p x \<le> win_count p a};
      reject = {a \<in> A. \<exists>x \<in> A. win_count p x > win_count p a} in
    elect \<union> reject = A"
    using not_le_imp_less
    by auto
  hence unity:
    "\<forall>A p.
      let elect = {a \<in> (A::'a set). \<forall>x \<in> A. win_count p x \<le> win_count p a};
      reject = {a \<in> A. \<exists>x \<in> A. win_count p x > win_count p a} in
    set_equals_partition A (elect, reject, {})"
    by simp
  from disjoint unity show ?thesis
    by (simp add: electoral_modI)
qed

subsection \<open>Electing\<close>

lemma plurality_electing2: "\<forall>A p.
                              (A \<noteq> {} \<and> finite_profile A p) \<longrightarrow>
                                elect plurality A p vs \<noteq> {}"
proof (intro allI impI conjI)
  fix
    A :: "'a set" and
    p :: "'a Profile" and
    vs :: "'a Pair_Vectors"
  assume
    assm0: "A \<noteq> {} \<and> finite_profile A p"
  show
    "elect plurality A p vs \<noteq> {}"
  proof
    obtain max where
      max: "max = Max(win_count p ` A)"
      by simp
    then obtain a where
      a: "win_count p a = max \<and> a \<in> A"
      using Max_in assm0 empty_is_image
            finite_imageI imageE
      by (metis (no_types, lifting))
    hence
      "\<forall>x \<in> A. win_count p x \<le> win_count p a"
      by (simp add: max assm0)
    moreover have
      "a \<in> A"
      using a
      by simp
    ultimately have
      "a \<in> {a \<in> A. \<forall>x \<in> A. win_count p x \<le> win_count p a}"
      by blast
    hence a_elem:
      "a \<in> elect plurality A p vs"
      by simp
    assume
      assm1: "elect plurality A p vs = {}"
    thus "False"
      using a_elem assm1 all_not_in_conv
      by metis
  qed
qed

(*The plurality module is electing.*)
theorem plurality_electing[simp]: "electing plurality"
proof -
  have "electoral_module plurality \<and>
      (\<forall>A p vs. (A \<noteq> {} \<and> finite_profile A p \<and> finite_pair_vectors A vs)
      \<longrightarrow> elect plurality A p vs \<noteq> {})"
  proof
    show "electoral_module plurality"
      by simp
  next
    show "(\<forall>A p vs. (A \<noteq> {} \<and> finite_profile A p \<and> finite_pair_vectors A vs)
      \<longrightarrow> elect plurality A p vs\<noteq> {})"
      using plurality_electing2
      by metis
  qed
  thus ?thesis
      by (simp add: electing_def)
qed

subsection \<open>Property\<close>

lemma plurality_inv_mono2: "\<forall>A p q a.
                              (a \<in> elect plurality A p vs \<and> lifted A p q a) \<longrightarrow>
                                (elect plurality A q vs = elect plurality A p vs \<or>
                                    elect plurality A q vs = {a})"
proof (intro allI impI)
  fix
    A :: "'a set" and
    p :: "'a Profile" and
    q :: "'a Profile" and
    vs :: "'a Pair_Vectors" and
    a :: "'a"
  assume asm1:
    "a \<in> elect plurality A p vs \<and> lifted A p q a"
  have ab1: "\<forall>a b. (a::'a) \<notin> {b} \<or> a = b"
    by force
  have lifted_winner:
    "\<forall>x \<in> A.
      \<forall>i::nat. i < length p \<longrightarrow>
        (above (p!i) x = {x} \<longrightarrow>
          (above (q!i) x = {x} \<or> above (q!i) a = {a}))"
    using asm1 Profile.lifted_def lifted_above_winner
    by (metis (no_types, lifting))
  hence
    "\<forall>i::nat. i < length p \<longrightarrow>
      (above (p!i) a = {a} \<longrightarrow> above (q!i) a = {a})"
    using asm1
    by auto
  hence a_win_subset:
    "{i::nat. i < length p \<and> above (p!i) a = {a}} \<subseteq>
      {i::nat. i < length p \<and> above (q!i) a = {a}}"
    by blast
  moreover have sizes:
    "length p = length q"
    using asm1 Profile.lifted_def
    by metis
  ultimately have win_count_a:
    "win_count p a \<le> win_count q a"
    by (simp add: card_mono)
  have fin_A:
    "finite A"
    using asm1 Profile.lifted_def
    by metis
  hence
    "\<forall>x \<in> A-{a}.
      \<forall>i::nat. i < length p \<longrightarrow>
        (above (q!i) a = {a} \<longrightarrow> above (q!i) x \<noteq> {x})"
    using DiffE Profile.lifted_def above_one2
          asm1 insertCI insert_absorb insert_not_empty
          profile_def sizes
    by metis
  with lifted_winner
  have above_QtoP:
    "\<forall>x \<in> A-{a}.
      \<forall>i::nat. i < length p \<longrightarrow>
        (above (q!i) x = {x} \<longrightarrow> above (p!i) x = {x})"
    using lifted_above_winner3 asm1
          Profile.lifted_def
    by metis
  hence
    "\<forall>x \<in> A-{a}.
      {i::nat. i < length p \<and> above (q!i) x = {x}} \<subseteq>
        {i::nat. i < length p \<and> above (p!i) x = {x}}"
    by (simp add: Collect_mono)
  hence win_count_other:
    "\<forall>x \<in> A-{a}. win_count p x \<ge> win_count q x"
    by (simp add: card_mono sizes)
  show
    "elect plurality A q vs = elect plurality A p vs \<or>
      elect plurality A q vs = {a}"
  proof cases
    assume "win_count p a = win_count q a"
    hence
      "card {i::nat. i < length p \<and> above (p!i) a = {a}} =
        card {i::nat. i < length p \<and> above (q!i) a = {a}}"
      by (simp add: sizes)
    moreover have
      "finite {i::nat. i < length p \<and> above (q!i) a = {a}}"
      by simp
    ultimately have
      "{i::nat. i < length p \<and> above (p!i) a = {a}} =
        {i::nat. i < length p \<and> above (q!i) a = {a}}"
      using a_win_subset
      by (simp add: card_subset_eq)
    hence above_pq:
      "\<forall>i::nat. i < length p \<longrightarrow>
        above (p!i) a = {a} \<longleftrightarrow> above (q!i) a = {a}"
      by blast
    hence above_pq2:
      "\<forall>n. \<not> n < length p \<or>
        (above (p!n) a = {a}) = (above (q!n) a = {a})"
      by presburger
    moreover have
      "\<forall>x \<in> A-{a}.
        \<forall>i::nat. i < length p \<longrightarrow>
          (above (p!i) x = {x} \<longrightarrow>
            (above (q!i) x = {x} \<or> above (q!i) a = {a}))"
      using lifted_winner
      by auto
    moreover have
      "\<forall>x \<in> A-{a}.
        \<forall>i::nat. i < length p \<longrightarrow>
          (above (p!i) x = {x} \<longrightarrow> above (p!i) a \<noteq> {a})"
    proof (rule ccontr, simp, safe, simp)
      fix
        x :: "'a" and
        i :: "nat"
      assume
        x_in_A: "x \<in> A" and
        i_in_range: "i < length p" and
        abv_x: "above (p!i) x = {x}" and
        abv_a: "above (p!i) a = {a}"
      have not_empty:
        "A \<noteq> {}"
        using x_in_A
        by auto
      have
        "linear_order_on A (p!i)"
        using Profile.lifted_def asm1 i_in_range profile_def
        by (metis (no_types))
      thus "x = a"
        using not_empty abv_a abv_x fin_A
        by (simp add: above_one2)
    qed
    ultimately have above_PtoQ:
      "\<forall>x \<in> A-{a}.
        \<forall>i::nat. i < length p \<longrightarrow>
          (above (p!i) x = {x} \<longrightarrow> above (q!i) x = {x})"
      by (simp add: above_pq)
    hence
      "\<forall>x \<in> A.
        card {i::nat. i < length p \<and> above (p!i) x = {x}} =
          card {i::nat. i < length q \<and> above (q!i) x = {x}}"
    proof (safe)
      fix
        x :: "'a"
      assume
        "\<forall>y \<in> A-{a}. \<forall> i<length p.
          above (p!i) y = {y} \<longrightarrow> above (q!i) y = {y}" and
        x_in_A: "x \<in> A"
      show
        "card {i. i < length p \<and> above (p ! i) x = {x}} =
          card {i. i < length q \<and> above (q ! i) x = {x}}"
        using DiffI x_in_A ab1 above_PtoQ above_QtoP above_pq2 sizes
        by (metis (no_types, lifting))
    qed
    hence "\<forall>x \<in> A. win_count p x = win_count q x"
      by simp
    hence
      "{a \<in> A. \<forall>x \<in> A. win_count p x \<le> win_count p a} =
        {a \<in> A. \<forall>x \<in> A. win_count q x \<le> win_count q a}"
      by auto
    thus ?thesis
      by simp
  next
    assume "win_count p a \<noteq> win_count q a"
    hence strict_less:
      "win_count p a < win_count q a"
      using win_count_a
      by auto
    have a_in_win_p:
      "a \<in> {a \<in> A. \<forall>x \<in> A. win_count p x \<le> win_count p a}"
      using asm1
      by auto
    hence "\<forall>x \<in> A. win_count p x \<le> win_count p a"
      by simp
    with strict_less win_count_other
    have less:
      "\<forall>x \<in> A-{a}. win_count q x < win_count q a"
      using DiffD1 antisym dual_order.trans
            not_le_imp_less win_count_a
      by metis
    hence
      "\<forall>x \<in> A-{a}. \<not>(\<forall>y \<in> A. win_count q y \<le> win_count q x)"
      using asm1 Profile.lifted_def not_le
      by metis
    hence
      "\<forall>x \<in> A-{a}.
        x \<notin> {a \<in> A. \<forall>x \<in> A. win_count q x \<le> win_count q a}"
      by blast
    hence
      "\<forall>x \<in> A-{a}. x \<notin> elect plurality A q vs"
      by simp
    moreover have
      "a \<in> elect plurality A q vs"
    proof -
      from less
      have
        "\<forall>x \<in> A-{a}. win_count q x \<le> win_count q a"
        using less_imp_le
        by metis
      moreover have
        "win_count q a \<le> win_count q a"
        by simp
      ultimately have
        "\<forall>x \<in> A. win_count q x \<le> win_count q a"
        by auto
      moreover have
        "a \<in> A"
        using a_in_win_p
        by auto
      ultimately have
        "a \<in> {a \<in> A.
            \<forall>x \<in> A. win_count q x \<le> win_count q a}"
        by auto
      thus ?thesis
        by simp
    qed
    moreover have
      "elect plurality A q vs \<subseteq> A"
      by simp
    ultimately show ?thesis
      by auto
  qed
qed

(*The plurality rule is invariant monotone.*)
theorem plurality_inv_mono[simp]: "invariant_monotonicity plurality"
proof -
  have
    "electoral_module plurality \<and>
      (\<forall>A p q a vs.
        (a \<in> elect plurality A p vs \<and> lifted A p q a) \<longrightarrow>
          (elect plurality A q vs = elect plurality A p vs \<or>
            elect plurality A q vs = {a}))"
  proof
    show "electoral_module plurality"
      by simp
  next
    show
      "\<forall>A p q a vs. (a \<in> elect plurality A p vs \<and> lifted A p q a) \<longrightarrow>
          (elect plurality A q vs = elect plurality A p vs \<or>
            elect plurality A q vs = {a})"
      using plurality_inv_mono2
      by metis
  qed
  thus ?thesis
    by (simp add: invariant_monotonicity_def)
qed

end


theory Type_Soundness
  imports Typing
begin

context sat_general
begin

lemma safe_neg_eq: "safe_formula (Formula.Neg (Formula.Eq x1 x2)) \<Longrightarrow> safe_formula  (Formula.Eq x1 x2) \<or>
(Formula.sat \<sigma> V v i  (Formula.Neg (Formula.Eq x1 x2)) \<longleftrightarrow> sat' \<sigma> V v i  (Formula.Neg (Formula.Eq x1 x2))) "
  by (cases x1; cases x2) auto

lemma foldl_sound:
  assumes  " \<forall>x\<in>set (x22). ty_of x = t" "ty_of x21 = t"
  shows
" foldl undef_min x21 x22 = foldl min x21 x22"
 "foldl undef_max x21 x22 = foldl max x21 x22"
 "t \<in> numeric_ty \<Longrightarrow> foldl undef_plus x21 x22 = foldl (+) x21 x22 \<and> ty_of (foldl (+) x21 x22 ) = t"

proof -

    from  assms(1-2) have minmax:"foldl undef_min x21 x22 = foldl min x21 x22 \<and> foldl undef_max x21 x22 = foldl max x21 x22"
     proof (induction x22 arbitrary: x21 t)
       case (Cons a x22)
       then show  ?case   apply (simp add: min_def undef_min_def max_def undef_max_def)
         using undef_less_eq_sound  by (cases x21; cases a) fastforce+
     qed auto
     from this show "foldl undef_min x21 x22 = foldl min x21 x22" by auto
     from minmax show "foldl undef_max x21 x22 = foldl max x21 x22" by auto
   next
     assume "t \<in> numeric_ty"
     from this assms show "foldl undef_plus x21 x22 = foldl (+) x21 x22 \<and> ty_of (foldl (+) x21 x22 ) = t"
     proof (induction x22 arbitrary: x21 t)
       case (Cons a x22)
       then show ?case using undef_plus_sound   apply (cases x21; cases a) apply (auto simp add: numeric_ty_def)

         using ty_of.simps by presburger+
     qed auto
 qed

lemma eval_agg_op_sound:
  assumes "M={(x, ecard Zs) | x Zs. Zs =
   {zs. length zs = length tys \<and> Formula.sat \<sigma> V (zs @ v) i \<phi> \<and> Formula.eval_trm (zs @ v) f = x} \<and> Zs \<noteq> {}}"
"S, E \<turnstile> formula.Agg y (agg_op,d) tys f \<phi> " "wty_envs S \<sigma> V" "fv_trm f \<subseteq> fv \<phi>" "Formula.nfv \<phi> \<le> length tys + length v"
"safe_formula \<phi>"
shows "eval_agg_op (agg_op,d) M = eval_agg_op' (agg_op,d) M"
proof -
  from assms(2) obtain t where t_def: "agg_env E tys  \<turnstile> f :: t" and t_wty:"t \<in> agg_trm_type agg_op" by cases auto
 have fv_wty: "y\<in>fv_trm f \<Longrightarrow> length zs = length tys \<Longrightarrow> Formula.sat \<sigma> V (zs @ v) i \<phi> \<Longrightarrow> ty_of ((zs @ v) ! y) = agg_env E tys y" for y zs apply (rule ty_of_sat_safe)
        using    assms by (auto elim: wty_formula.cases)
      then  have wty_M: "\<forall>(x,card) \<in>  M . ty_of x = t" using assms(1)  t_def by (auto dest!: ty_of_eval_trm )
      have "finite_multiset M \<Longrightarrow>set (flatten_multiset M) \<subseteq> fst ` M" apply (rule set_of_flatten_multiset)
        using finite_set
       apply (auto simp add:  assms(1)) using finite_fst by (auto simp add: finite_multiset_def assms(1) )
      then have wty_flatten: "finite_multiset M \<Longrightarrow> \<forall>x \<in> set (flatten_multiset M) . ty_of x = t"  using wty_M
        by fastforce
     have avg:"finite_multiset M \<Longrightarrow>  flatten_multiset M = x21 # x22 \<Longrightarrow>agg_op = Formula.Agg_Avg \<Longrightarrow>
          double_of_event_data_agg (foldl (+) x21 x22) = undef_double_of_event_data_agg (foldl undef_plus x21 x22)" for x21 x22
     proof -
       assume as: "finite_multiset M" "flatten_multiset M = x21 # x22"  "agg_op = Formula.Agg_Avg"
       have foldl_plus: "foldl undef_plus x21 x22 = foldl (+) x21 x22"
         apply (rule  conjE[OF foldl_sound(3)])  using wty_flatten t_wty as   by auto
       have foldl_ty: "ty_of (foldl (+) x21 x22) \<in> numeric_ty "  apply (rule conjE[OF  foldl_sound(3)]) using as wty_flatten t_wty by auto
        show ?thesis apply (auto simp: foldl_plus) apply (cases "foldl (+) x21 x22") using  undef_double_of_event_data_agg_sound foldl_ty by (auto simp add: numeric_ty_def)
     qed

      have med:"finite_multiset M \<Longrightarrow> flatten_multiset M = xs \<Longrightarrow> agg_op = Formula.Agg_Med \<Longrightarrow> i< length xs \<Longrightarrow>
double_of_event_data_agg (xs!i) = undef_double_of_event_data_agg (xs!i) " for xs i
        using t_wty wty_flatten undef_double_of_event_data_agg_sound nth_mem[where ?n=i and ?xs=xs] by (cases "xs!i")  (auto simp add: numeric_ty_def split:ty.splits)
      then show ?thesis
      apply (cases agg_op) using wty_flatten t_wty avg apply (auto split: list.splits bool.splits)
      using foldl_sound  apply presburger+
      by (smt (z3) Suc_less_eq diff_Suc_1 div2_less_self even_Suc length_nth_simps(2) less_Suc_eq odd_Suc_div_two)
  qed

 using assms proof (induction arbitrary: v V i S E rule: safe_formula_induct)

  case (Pred e tms)
  from Pred(2)  obtain p  tys where obt: "S p = Some tys \<and> list_all2 (\<lambda>tm ty. E \<turnstile> tm :: ty) tms tys" by cases auto
   from this  Pred  have tms_wty: "x \<in> set tms \<Longrightarrow> \<exists>t \<in> set tys. E \<turnstile> x :: t " for x
     by (metis in_set_conv_nth list_all2_conv_all_nth)
   have eval_tms_eq: "map (Formula.eval_trm v) tms = map (eval_trm' v) tms" using tms_wty Pred(3) by (auto dest!: eval_trm_sound)
  then show ?case using Pred(1)  apply (auto simp add: trm.is_Var_def trm.is_Const_def)
    by (metis eval_tms_eq )+

  next
    case (Let p \<phi> \<psi>)
    obtain E' where  psi_wty: "S(p \<mapsto> tabulate E' 0 (Formula.nfv \<phi>)), E \<turnstile> \<psi>" and phi_wty:"S, E' \<turnstile> \<phi>" using Let.prems(1) by cases auto

    have wtyenv: " x\<in>\<Gamma> \<sigma> i\<Longrightarrow> (case x of (p, xs) \<Rightarrow> p \<notin> dom V \<longrightarrow> (case S p of None \<Rightarrow> False | Some ts \<Rightarrow> wty_tuple ts xs))" for x i
      using Let.prems(3) by  (auto simp add: wty_envs_def wty_event_def wty_tuple_def)
    have ty_of_phi: "x \<in> Formula.fv \<phi> \<Longrightarrow>  Formula.sat \<sigma> V xs i \<phi> \<Longrightarrow> length xs = Formula.nfv \<phi> \<Longrightarrow> ty_of (xs!x) = E' x"
      for x xs apply (rule ty_of_sat_safe) using Let phi_wty by auto
    have "x \<in> Formula.fv \<phi> \<Longrightarrow>  Formula.sat \<sigma> V xs i \<phi> \<Longrightarrow> length xs = Formula.nfv \<phi> \<Longrightarrow> (tabulate E' 0 (Formula.nfv \<phi>)!x) = ty_of (xs!x)"
      for x xs using ty_of_phi[of x xs]  apply (auto simp add: Formula.nfv_def split: nat.splits)
      by (metis Formula.nfv_def add.left_neutral fvi_less_nfv nth_tabulate)
    then  have list_all_tab:"length xs = Formula.nfv \<phi> \<Longrightarrow>
    Formula.sat \<sigma> V xs i \<phi> \<or> sat' \<sigma> V xs i \<phi> \<Longrightarrow> list_all2 (\<lambda>t x. ty_of x = t) (tabulate E' 0 (Formula.nfv \<phi>)) xs " for xs i
    proof -
      assume a1: "Formula.sat \<sigma> V xs i \<phi> \<or> sat' \<sigma> V xs i \<phi>"
      assume a2: "length xs = Formula.nfv \<phi>"
      obtain nn :: "event_data list \<Rightarrow> ty list \<Rightarrow> (ty \<Rightarrow> event_data \<Rightarrow> bool) \<Rightarrow> nat" where
        "\<forall>x0 x1 x2. (\<exists>v3<length x1. \<not> x2 (x1 ! v3) (x0 ! v3)) = (nn x0 x1 x2 < length x1 \<and> \<not> x2 (x1 ! nn x0 x1 x2) (x0 ! nn x0 x1 x2))"
        by moura
      then have "\<forall>p ts es. (\<not> list_all2 p ts es \<or> length ts = length es \<and> (\<forall>n. \<not> n < length ts \<or> p (ts ! n) (es ! n))) \<and> (list_all2 p ts es \<or> length ts \<noteq> length es \<or> nn es ts p < length ts \<and> \<not> p (ts ! nn es ts p) (es ! nn es ts p))"
        by (metis (no_types) list_all2_conv_all_nth)
      then show ?thesis
        using a2 a1
        by (smt (z3) Let.hyps(1) Let.hyps(2) Let.prems(3) add.left_neutral atLeastLessThan_iff dual_order.refl length_tabulate less_nat_zero_code not_less nth_tabulate phi_wty subset_eq ty_of_sat'_safe ty_of_sat_safe)
    qed
    have phi_case: "length v5 = Formula.nfv \<phi> \<Longrightarrow>  sat' \<sigma> V v5 i5 \<phi> = Formula.sat \<sigma> V v5 i5 \<phi> " for v5 i5
    proof -
      assume len_v5: "length v5 = Formula.nfv \<phi>"
      {
        assume sat: " Formula.sat \<sigma> V v5 i5 \<phi>"
        have "y \<in> fv \<phi> \<Longrightarrow> ty_of (v5 ! y) = E' y" for y apply (rule ty_of_sat_safe) using Let sat len_v5 phi_wty by auto
        then have " Formula.sat \<sigma> V v5 i5 \<phi> = sat' \<sigma> V v5 i5 \<phi> "
          using phi_wty Let len_v5 by auto
      }moreover {
          assume sat': "sat' \<sigma> V v5 i5 \<phi>"
        have "y \<in> fv \<phi> \<Longrightarrow> ty_of (v5 ! y) = E' y" for y apply (rule ty_of_sat'_safe) using Let sat' len_v5 phi_wty by auto
        then have " Formula.sat \<sigma> V v5 i5 \<phi> = sat' \<sigma> V v5 i5 \<phi> "
          using phi_wty Let len_v5 by auto
      }
      ultimately show ?thesis by auto
    qed
    have V_eq: "V(p \<mapsto> \<lambda>i. {v. length v = Formula.nfv \<phi> \<and> Formula.sat \<sigma> V v i \<phi>}) = V(p \<mapsto> \<lambda>i. {v. length v = Formula.nfv \<phi> \<and> sat' \<sigma> V v i \<phi>})"
      using phi_case  by fastforce
    have "Formula.sat \<sigma> (V(p \<mapsto> \<lambda>i. {v. length v = Formula.nfv \<phi> \<and> Formula.sat \<sigma> V v i \<phi>})) v i \<psi> = sat' \<sigma> (V(p \<mapsto> \<lambda>i. {v. length v = Formula.nfv \<phi> \<and> Formula.sat \<sigma> V v i \<phi>})) v i \<psi>"
      apply (rule Let.IH(2))
      using  psi_wty    phi_wty Let.prems apply (auto simp add: wty_envs_def wty_event_def wty_tuple_def domIff)
      subgoal for i a b apply (cases "a = p") by auto  subgoal for i xs using list_all_tab[of  xs i] by auto done
  then show ?case by (auto simp add: V_eq)
next
  case (And_assign \<phi> \<psi>)
  obtain t1 t2 where eq: "\<psi> = formula.Eq t1 t2" using And_assign(2) by (auto simp add: safe_assignment_def split: formula.splits)
  obtain t where t_def: "E \<turnstile> t1 :: t \<and> E \<turnstile> t2 :: t" using  And_assign(4) by (auto simp add: eq  elim: wty_formula.cases)
  have " Formula.sat \<sigma> V v i \<psi> = sat' \<sigma> V v i \<psi>" using  t_def And_assign(4,5) by (auto simp add: eq dest: poly_value_of )
  then show ?case using And_assign by (auto elim: wty_formula.cases)

next
  case (And_constraint \<phi> \<psi>)
  have phi_eq: "Formula.sat \<sigma> V v i \<phi> = sat' \<sigma> V v i \<phi>" using And_constraint by (auto elim: wty_formula.cases)
  have psi_wty: "S, E \<turnstile> \<psi>" using And_constraint(7) by (auto elim: wty_formula.cases)
   show ?case using phi_eq And_constraint(5,8)  psi_wty
    by (cases \<psi> rule: is_constraint.cases)
   (auto simp add: undef_less_eq_sound undef_less_def less_event_data_def dest: poly_value_of  elim!: wty_formula.cases)
next
  case (And_Not \<phi> \<psi>)
  have "S, E \<turnstile> \<psi>" using And_Not.prems(1) by (auto elim: wty_formula.cases)
  then show ?case using And_Not by (auto elim: wty_formula.cases)
next
  case (Ands l pos neg)
  have pos_IH: "\<phi> \<in> set pos \<Longrightarrow> S, E \<turnstile> \<phi> \<Longrightarrow> (\<forall>y\<in>fv \<phi>. ty_of (v ! y) = E y) \<Longrightarrow> Formula.nfv \<phi> \<le> length v \<Longrightarrow>  wty_envs S \<sigma> V
\<Longrightarrow>  Formula.sat \<sigma> V v i \<phi> = sat' \<sigma> V v i \<phi>" for \<phi> using Ands.IH(1) Ball_set_list_all   by (smt (verit, best))
    have pos_case: "\<phi> \<in> set pos \<Longrightarrow>  Formula.sat \<sigma> V v i \<phi> = sat' \<sigma> V v i \<phi> " for \<phi> using Ands pos_IH by (auto elim: wty_formula.cases)
  have neg_IH: "\<phi> \<in> set (map remove_neg neg) \<Longrightarrow> S, E \<turnstile> \<phi> \<Longrightarrow> (\<forall>y\<in>fv \<phi>. ty_of (v ! y) = E y) \<Longrightarrow> Formula.nfv \<phi> \<le> length v \<Longrightarrow>  wty_envs S \<sigma> V
\<Longrightarrow>  Formula.sat \<sigma> V v i \<phi> = sat' \<sigma> V v i \<phi>" for \<phi> using Ands.IH(2) Ball_set_list_all
    by (smt (verit, best))
  have "\<phi> \<in> set ( neg) \<Longrightarrow> S, E \<turnstile> \<phi> \<and> (\<forall>y\<in>fv \<phi>. ty_of (v ! y) = E y) \<and> Formula.nfv \<phi> \<le> length v " for \<phi> using Ands by (auto elim: wty_formula.cases)
  then have "\<phi> \<in> set ( map remove_neg neg) \<Longrightarrow> S, E \<turnstile> \<phi> \<and> (\<forall>y\<in>fv \<phi>. ty_of (v ! y) = E y) \<and> Formula.nfv \<phi> \<le> length v" for \<phi>
    apply (auto simp add: Formula.nfv_def )
    subgoal for x by (cases x) (auto elim: wty_formula.cases) done
  then have remove_neg_case: "\<phi> \<in> set (map remove_neg neg) \<Longrightarrow>  Formula.sat \<sigma> V v i \<phi> = sat' \<sigma> V v i \<phi> " for \<phi> using Ands.prems(3) neg_IH by auto
  have remove_neg_sat: " (Formula.sat \<sigma> V v i \<phi> = sat' \<sigma> V v i \<phi> )= ( Formula.sat \<sigma> V v i (remove_neg \<phi>) = sat' \<sigma> V v i (remove_neg \<phi>))  "
    for \<phi>  by (cases \<phi>)  auto
   have neg_case: "\<phi> \<in> set neg\<Longrightarrow>  Formula.sat \<sigma> V v i \<phi> = sat' \<sigma> V v i \<phi>" for \<phi>
    using  remove_neg_case[of "remove_neg \<phi>"]  by ( auto simp add:  remove_neg_sat[of \<phi>] )
  then show ?case using pos_case neg_case Ands(1) by auto

next
  case (Exists \<phi> t)
 {
    fix za
    assume  assm: "Formula.sat \<sigma> V (za # v) i \<phi>"
    from Exists.prems(1) have wty: "S, case_nat t E \<turnstile> \<phi>" by cases
    have nfv: " Formula.nfv \<phi> \<le> Suc (length v)" using Exists(7) nfv_exists[of \<phi> t] by auto
    have "0 \<in> fv \<phi> \<Longrightarrow> ty_of za = t"
      using ty_of_sat_safe[where ?E="case_nat t E" and ?S=S and ?\<phi>=\<phi> and ?v="za#v" and ?V=V and ?i=i and ?\<sigma>=\<sigma> and ?x=0]
      Exists(1,6)  nfv assm wty by auto
    then have "\<forall>y\<in>fv \<phi>. ty_of ((za # v) ! y) = (case y of 0 \<Rightarrow> t | Suc x \<Rightarrow> E x)" using  Exists.prems(2)   by (auto simp add:  fvi_Suc split: nat.splits )

    from this  have "local.sat' \<sigma> V (za # v) i \<phi>" using Exists.IH[of S "case_nat t E" "za#v" V i] Exists(6) wty nfv assm by auto
  }
  moreover {
   fix za
    assume  assm: "sat' \<sigma> V (za # v) i \<phi>"
    from Exists.prems(1) have wty: "S, case_nat t E \<turnstile> \<phi>" by cases
    have nfv: " Formula.nfv \<phi> \<le> Suc (length v)" using Exists(7) nfv_exists[of \<phi> t] by auto
    have "0 \<in> fv \<phi> \<Longrightarrow> ty_of za = t"
      using ty_of_sat'_safe[where ?E="case_nat t E" and ?S=S and ?\<phi>=\<phi> and ?v="za#v" and ?V=V and ?i=i and ?\<sigma>=\<sigma> and ?x=0]
      Exists(1,6)  nfv assm wty by auto
    then have "\<forall>y\<in>fv \<phi>. ty_of ((za # v) ! y) = (case y of 0 \<Rightarrow> t | Suc x \<Rightarrow> E x)" using  Exists.prems(2)   by (auto simp add:  fvi_Suc split: nat.splits )

    from this  have "Formula.sat \<sigma> V (za # v) i \<phi>" using Exists.IH[of S "case_nat t E" "za#v" V i] Exists(6) wty nfv assm by auto
  }
  ultimately show ?case   by auto
next
  case (Agg y \<omega> tys f \<phi>)

    have phi_wty: "S, agg_env E tys \<turnstile> \<phi>" using Agg.prems(1) by (auto elim: wty_formula.cases)
 have " a \<in> fv \<phi> \<Longrightarrow> Suc a \<le> length tys + length v" for a
      using Agg(9)  fvi_plus_bound[of 0 "length tys" \<phi> "length v"] apply (auto simp add: Formula.nfv_def)
      by (metis Un_iff not_less not_less_eq_eq)
    then have nfv:" Formula.nfv \<phi> \<le> length tys + length v" by (auto simp add: Formula.nfv_def)
  have phi_case: "length zs = length tys \<Longrightarrow> Formula.sat \<sigma> V (zs @ v) i \<phi> =  sat' \<sigma> V (zs @ v) i \<phi>" for zs

  proof -
    assume len_zs:"length zs = length tys"
    {
      assume sat: " Formula.sat \<sigma> V (zs @ v) i \<phi>"
      have fv_wty: "y \<in> fv \<phi> \<Longrightarrow> ty_of ((zs @ v) ! y) = agg_env E tys y" for y
        using ty_of_sat_safe Agg(4,8) sat len_zs phi_wty nfv by  (auto simp add: Formula.nfv_def)
       have " Formula.sat \<sigma> V (zs @ v) i \<phi> = sat' \<sigma> V (zs @ v) i \<phi> "
          using phi_wty Agg(4,5,8) len_zs nfv fv_wty by auto
    }
    moreover{
      assume sat':"sat' \<sigma> V (zs @ v) i \<phi>"
      have fv_wty: "y \<in> fv \<phi> \<Longrightarrow> ty_of ((zs @ v) ! y) = agg_env E tys y" for y
        using ty_of_sat'_safe Agg(4,8) sat' len_zs phi_wty nfv by  (auto simp add: Formula.nfv_def)
       have " Formula.sat \<sigma> V (zs @ v) i \<phi> = sat' \<sigma> V (zs @ v) i \<phi> "
          using phi_wty Agg(4,5,8) len_zs nfv fv_wty by auto
      }
      ultimately show ?thesis by auto
    qed
    have "Formula.eval_trm (zs @ v) f = eval_trm' (zs @ v) f"  if a1:"Formula.sat \<sigma> V (zs @ v) i \<phi>" and a2:"length zs = length tys" for zs
    proof -
      have fv_wty: "y\<in>fv_trm f \<Longrightarrow> ty_of ((zs @ v) ! y) = agg_env E tys y" for y
        using ty_of_sat_safe  Agg(3,4,8) a1 a2 phi_wty nfv by auto
       show ?thesis using Agg.prems(1) fv_wty by (auto dest: eval_trm_sound elim: wty_formula.cases)
     qed
    then have
 "{(x, ecard Zs) | x Zs. Zs = {zs. length zs = length tys \<and> Formula.sat \<sigma> V (zs @ v) i \<phi> \<and> Formula.eval_trm (zs @ v) f = x} \<and> Zs \<noteq> {}}
= {(x, ecard Zs) | x Zs. Zs = {zs. length zs = length tys \<and> sat' \<sigma> V (zs @ v) i \<phi> \<and> eval_trm' (zs @ v) f = x} \<and> Zs \<noteq> {}}"
    using phi_case  by (smt (z3) Collect_cong)
  moreover
  obtain agg_op d where omega_def:"\<omega> = (agg_op,d)" using Agg.prems(1) by cases auto
  moreover
  have eval_agg_op_case: "M = {(x, ecard Zs) | x Zs. Zs = {zs. length zs = length tys \<and> Formula.sat \<sigma> V (zs @ v) i \<phi> \<and> Formula.eval_trm (zs @ v) f = x} \<and> Zs \<noteq> {}}
 \<Longrightarrow> eval_agg_op (agg_op,d) M = eval_agg_op' (agg_op,d) M" for M
    apply (rule eval_agg_op_sound) using omega_def nfv Agg(3,4,6,8) by auto
  ultimately show ?case by auto

next
  case (Since \<phi> I \<psi>)
  have phi_eq: "Formula.sat \<sigma> V v i \<phi> = sat' \<sigma> V v i \<phi>" for i using Since by (auto elim: wty_formula.cases)
  have psi_eq: "Formula.sat \<sigma> V v i \<psi> = sat' \<sigma> V v i \<psi>" for i  using Since by (auto elim: wty_formula.cases)
  show ?case by (auto simp add: phi_eq psi_eq)
next
  case (Not_Since \<phi> I \<psi>)
  have phi_eq: "Formula.sat \<sigma> V v i \<phi> = sat' \<sigma> V v i \<phi>" for i apply (rule Not_Since.IH(1)) using Not_Since by (auto elim: wty_formula.cases)
  have psi_eq: "Formula.sat \<sigma> V v i \<psi> = sat' \<sigma> V v i \<psi>" for i  using Not_Since by (auto elim: wty_formula.cases)
  show ?case by (auto simp add: phi_eq psi_eq)
next
  case (Until \<phi> I \<psi>)
  have phi_eq: "Formula.sat \<sigma> V v i \<phi> = sat' \<sigma> V v i \<phi>" for i using Until by (auto elim: wty_formula.cases)
  have psi_eq: "Formula.sat \<sigma> V v i \<psi> = sat' \<sigma> V v i \<psi>" for i  using Until by (auto elim: wty_formula.cases)
  show ?case by (auto simp add: phi_eq psi_eq)
next
  case (Not_Until \<phi> I \<psi>)
  have phi_eq: "Formula.sat \<sigma> V v i \<phi> = sat' \<sigma> V v i \<phi>" for i apply (rule Not_Until.IH(1)) using Not_Until by (auto elim: wty_formula.cases)
  have psi_eq: "Formula.sat \<sigma> V v i \<psi> = sat' \<sigma> V v i \<psi>" for i  using Not_Until by (auto elim: wty_formula.cases)
  show ?case by (auto simp add: phi_eq psi_eq)
next
  case (MatchP I r)
  from  MatchP(1) have "safe_regex Past Strict r \<or>safe_regex Past Lax r " by auto
  from this have atms_safe: " \<phi> \<in> regex.atms r \<Longrightarrow> safe_formula \<phi> \<or> (\<exists> \<psi>. \<phi> = Formula.Neg \<psi> \<and> safe_formula \<psi>)" for \<phi>
    using case_NegE  by (induction r) auto
  have atms_regex_atms: " \<phi> \<in> atms r \<or> ( \<exists> \<psi>. \<phi> = Formula.Neg \<psi> \<and>  \<psi>\<in> atms r)" if assm: " \<phi> \<in> regex.atms r" for \<phi>
    using assm atms_safe apply (induction r) by auto
  from MatchP(4) have  " (\<phi> \<in> atms r \<Longrightarrow>\<forall>y\<in>fv \<phi>. ty_of (v ! y) = E y)" for \<phi> apply auto apply (induction r )
        apply (auto) subgoal for x y apply (cases "safe_formula x") by (auto split: formula.splits  ) done
    from this  MatchP have IH: "\<phi>\<in>atms r \<Longrightarrow>Formula.sat \<sigma> V v i5 \<phi> = sat' \<sigma> V v i5 \<phi>" for \<phi> i5
      using match_safe_wty_nfv[of \<phi> r I S E v  ] by auto
     have other_IH: "\<phi> \<in> regex.atms r \<Longrightarrow> Formula.sat \<sigma> V v i5 \<phi> = sat' \<sigma> V v i5 \<phi>" for \<phi> i5
      using atms_regex_atms[of \<phi>] IH by auto
  then show ?case  using match_cong[OF refl other_IH, where ?r=r] by auto
next
  case (MatchF I r)
   from  MatchF(1) have "safe_regex Futu Strict r \<or>safe_regex Futu Lax r " by auto
  from this have atms_safe: " \<phi> \<in> regex.atms r \<Longrightarrow> safe_formula \<phi> \<or> (\<exists> \<psi>. \<phi> = Formula.Neg \<psi> \<and> safe_formula \<psi>)" for \<phi>
    using case_NegE  by (induction r) auto
  have atms_regex_atms: " \<phi> \<in> atms r \<or> ( \<exists> \<psi>. \<phi> = Formula.Neg \<psi> \<and>  \<psi>\<in> atms r)" if assm: " \<phi> \<in> regex.atms r" for \<phi>
    using assm atms_safe apply (induction r) by auto
  from MatchF(4) have  " (\<phi> \<in> atms r \<Longrightarrow>\<forall>y\<in>fv \<phi>. ty_of (v ! y) = E y)" for \<phi> apply auto apply (induction r )
        apply (auto) subgoal for x y apply (cases "safe_formula x") by (auto split: formula.splits  ) done
    from this  MatchF have IH: "\<phi>\<in>atms r \<Longrightarrow>Formula.sat \<sigma> V v i5 \<phi> = sat' \<sigma> V v i5 \<phi>" for \<phi> i5
      using match_safe_wty_nfv[of \<phi> r I S E v  ] by auto
     have other_IH: "\<phi> \<in> regex.atms r \<Longrightarrow> Formula.sat \<sigma> V v i5 \<phi> = sat' \<sigma> V v i5 \<phi>" for \<phi> i5
      using atms_regex_atms[of \<phi>] IH by auto
  then show ?case  using match_cong[OF refl other_IH, where ?r=r] by auto
qed (auto elim: wty_formula.cases split: nat.splits)

lemma soundness2: (*Theorem 3.12*)
  assumes   "safe_formula \<phi>"  "S,E \<turnstile> \<phi>"  "wty_envs S \<sigma> V"
   "Formula.nfv \<phi> \<le> length v"
 shows "Formula.sat \<sigma> V v i \<phi> \<longleftrightarrow> sat' \<sigma> V v i \<phi>"
  using  soundness[OF assms(1-2) _ assms(3-4)] ty_of_sat_safe[OF assms(1-3) _ _ assms(4)]
    ty_of_sat'_safe[OF assms(1-3) _ _ assms(4)]
  by auto
end
end